/* * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. * Notified per clause 4(b) of the license. * * Last modified: Jun 2020 * */ /* * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. * Notified per clause 4(b) of the license. * * Last Modified: May 2020 * * Support to revert to the old value when newunit has errors. * Date of Modification: 15th June 2020 */ /** \file \brief Semantic analyzer routines which process IO statements. */ #include "gbldefs.h" #include "global.h" #include "gramsm.h" #include "gramtk.h" #include "error.h" #include "symtab.h" #include "symutl.h" #include "dtypeutl.h" #include "semant.h" #include "scan.h" #include "dinit.h" #include "semstk.h" #include "ast.h" #include "feddesc.h" #include "rte.h" #include "rtlRtns.h" /* generate asts for calling an io routine; must be performed in the * the following order: * begin_io_call() * add_io_arg() [zero or more calls] * end_io_call() [optional assignment of function] */ static struct { /* record info for begin_io_call - end_io_call */ int ast; int ast_type; int std; } io_call; /*-------- define data structures and macros local to this file: --------*/ /* define macros used to access table the I/O parameter table, "pt". * All of the macros that can be used in the INQUIRE statement are at * the beginning (their values range from 0 .. PT_LAST_INQUIRE_VAL). * These are in the order specified by the fio_inquire routine in the * HPF Execution Environment spec. and only include those which are passed * as arguments. Note that ERR is not passed to fio_inquire. * * N O T E: The static array of struct, pt, is initialized the names of * these parameters. If changes are made to the PT_ macros, * R E M E M B E R to change ptname. */ #define PT_UNIT 0 #define PT_FILE 1 #define PT_IOSTAT 2 #define PT_EXIST 3 #define PT_OPENED 4 #define PT_NUMBER 5 #define PT_NAMED 6 #define PT_NAME 7 #define PT_ACCESS 8 #define PT_SEQUENTIAL 9 #define PT_DIRECT 10 #define PT_FORM 11 #define PT_FORMATTED 12 #define PT_UNFORMATTED 13 #define PT_RECL 14 #define PT_NEXTREC 15 #define PT_BLANK 16 #define PT_POSITION 17 #define PT_ACTION 18 #define PT_READ 19 #define PT_WRITE 20 #define PT_READWRITE 21 #define PT_DELIM 22 #define PT_PAD 23 #define PT_ID 24 #define PT_PENDING 25 #define PT_POS 26 #define PT_SIZE 27 #define PT_ASYNCHRONOUS 28 #define PT_DECIMAL 29 #define PT_ENCODING 30 #define PT_SIGN 31 #define PT_STREAM 32 #define PT_ROUND 33 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * end of INQUIRE parameters: make sure that PT_LAST_INQUIRE_VAL is set * to the last inquire value. * Values <= including PT_LAST_INQUIRE_VALf95 are f95 inquire specifiers * values > PT_LAST_INQUIRE_VALf95 and <= PT_LAST_INQUIRE_VAL are the new * f2003 inquire specifiers. * * PT_IOLENGTH is only present since certain utility functions, such as * chk_var, require a 'pt' argument. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ #define PT_DISPOSE 34 #define PT_END 35 #define PT_ERR 36 #define PT_FMT 37 #define PT_NML 38 #define PT_REC 39 #define PT_STATUS 40 #define PT_ADVANCE 41 #define PT_EOR 42 #define PT_IOLENGTH 43 #define PT_CONVERT 44 #define PT_SHARED 45 #define PT_IOMSG 46 #define PT_NEWUNIT 47 #define PT_LAST_INQUIRE_VALf95 PT_PAD #define PT_LAST_INQUIRE_VAL 33 #define PT_MAXV 47 /* * define bit flag for each I/O statement. Used for checking * illegal cases of I/O keyword specifiers. */ #define BT_ACCEPT 0x00001 #define BT_BKSPACE 0x00002 #define BT_CLOSE 0x00004 #define BT_DECODE 0x00008 #define BT_ENCODE 0x00010 #define BT_ENDFILE 0x00020 #define BT_INQUIRE 0x00040 #define BT_OPEN 0x00080 #define BT_PRINT 0x00100 #define BT_READ 0x00200 #define BT_REWIND 0x00400 #define BT_WRITE 0x00800 #define BT_WAIT 0x01000 #define BT_FLUSH 0x02000 /* define macros for the edit descriptors */ #define PUT(n) (_put((INT)(n), DT_INT)) /* define format type macros: */ typedef enum { FT_UNFORMATTED = 1, FT_LIST_DIRECTED = 2, FT_ENCODED = 3, FT_CHARACTER = 4, FT_NML = 5, FT_FMTSTR = 6, FT_LAST = 7 } FormatType; /* Array indexed by [is_read][] */ static int functype[2][FT_LAST] = { {DT_IO_FWRITE, DT_IO_UWRITE, DT_IO_FWRITE, DT_IO_FWRITE, DT_IO_FWRITE, DT_IO_FWRITE, DT_IO_FWRITE}, {DT_IO_FREAD, DT_IO_UREAD, DT_IO_FREAD, DT_IO_FREAD, DT_IO_FREAD, DT_IO_FREAD, DT_IO_FREAD}}; /* miscellaneous macros: */ #define DEFAULT_UNIT (is_read ? 5 : 6) #define IOERR(n) errsev(n) #define IOERR2(n, s) error(n, 3, gbl.lineno, s, CNULL) #define ERR170(s) error(170, 2, gbl.lineno, s, CNULL) #define ERR204(s1, s2) error(204, 3, gbl.lineno, s1, s2) #define PTV(d) pt[d].val #define PT_CHECK(a, b) \ if (PTV(a) == 0) \ PTV(a) = b #define PTS(a) pt[a].set #define PT_SET(a) PTS(a) = 1 #define PTVARREF(a) pt[a].varref #define PT_VARREF(a, v) PTVARREF(a) = (v) #define PTTMPUSED(a) pt[a].tmp_in_use #define PT_TMPUSED(a, v) (pt[a].tmp_in_use = (v)) #define PTARG(a) \ (PTVARREF(a) && PTVARREF(a) != 1 ? PT_TMPUSED(a, 1), PTV(a) : PTV(a)) #define PTNAME(a) pt[a].name #define PTSTMT(a) pt[a].stmt #define UNIT_CHECK \ if (PTV(PT_UNIT) == 0) \ IOERR(200) /* typedef and macros to access io lists: */ typedef struct iol { struct iol *next; SST *element; DOINFO *doinfo; int id; int l_std; /* list of stds added after the left paren of an * implied-do is parsed */ } IOL; #define IE_EXPR 0 #define IE_DOBEGIN 1 #define IE_DOEND 2 #define IE_OPTDO 3 /* local data */ static struct pt_tag { /* parameter table for I/O statements */ int val; /* pointer to AST of I/O keyword specifier, except * for a keyword specifier for a label, in which * case val is the sptr of the label. */ int set; int varref; /* zero ==> io specifier is not a variable, * non-zero ==> io specifier is a variable reference, * where * the value 1 means that the variable is * being used directly, and any other * non zero value implies that a temp * value is being used in which case * 1) val contains the ast referencing * the temp * 2) and varref (this field) contains * the ast referencing the original * variable. */ int tmp_in_use; /* 1==>a tmp is being used in the current call (see above) */ char *name; int stmt; /* I/O stmts which may use parameter/keyword */ } pt[PT_MAXV + 1] = { {0, 0, 0, 0, "UNIT", BT_BKSPACE | BT_CLOSE | BT_ENDFILE | BT_INQUIRE | BT_OPEN | BT_READ | BT_REWIND | BT_WRITE | BT_WAIT | BT_FLUSH}, {0, 0, 0, 0, "FILE", BT_INQUIRE | BT_OPEN}, {0, 0, 0, 0, "IOSTAT", BT_BKSPACE | BT_CLOSE | BT_DECODE | BT_ENCODE | BT_ENDFILE | BT_INQUIRE | BT_OPEN | BT_READ | BT_REWIND | BT_WRITE | BT_WAIT | BT_FLUSH}, {0, 0, 0, 0, "EXIST", BT_INQUIRE}, {0, 0, 0, 0, "OPENED", BT_INQUIRE}, {0, 0, 0, 0, "NUMBER", BT_INQUIRE}, {0, 0, 0, 0, "NAMED", BT_INQUIRE}, {0, 0, 0, 0, "NAME", BT_INQUIRE | BT_OPEN}, {0, 0, 0, 0, "ACCESS", BT_INQUIRE | BT_OPEN}, {0, 0, 0, 0, "SEQUENTIAL", BT_INQUIRE}, {0, 0, 0, 0, "DIRECT", BT_INQUIRE}, {0, 0, 0, 0, "FORM", BT_INQUIRE | BT_OPEN}, {0, 0, 0, 0, "FORMATTED", BT_INQUIRE}, {0, 0, 0, 0, "UNFORMATTED", BT_INQUIRE}, {0, 0, 0, 0, "RECL", BT_INQUIRE | BT_OPEN}, {0, 0, 0, 0, "NEXTREC", BT_INQUIRE}, {0, 0, 0, 0, "BLANK", BT_INQUIRE | BT_OPEN | BT_READ}, {0, 0, 0, 0, "POSITION", BT_INQUIRE | BT_OPEN}, {0, 0, 0, 0, "ACTION", BT_INQUIRE | BT_OPEN}, {0, 0, 0, 0, "READ", BT_INQUIRE}, {0, 0, 0, 0, "WRITE", BT_INQUIRE}, {0, 0, 0, 0, "READWRITE", BT_INQUIRE}, {0, 0, 0, 0, "DELIM", BT_INQUIRE | BT_OPEN | BT_WRITE}, {0, 0, 0, 0, "PAD", BT_INQUIRE | BT_OPEN | BT_READ}, {0, 0, 0, 0, "ID", BT_INQUIRE | BT_READ | BT_WRITE | BT_WAIT}, {0, 0, 0, 0, "PENDING", BT_INQUIRE}, {0, 0, 0, 0, "POS", BT_INQUIRE | BT_READ | BT_WRITE}, {0, 0, 0, 0, "SIZE", BT_INQUIRE | BT_READ | BT_WRITE}, {0, 0, 0, 0, "ASYNCHRONOUS", BT_INQUIRE | BT_OPEN | BT_READ | BT_WRITE}, {0, 0, 0, 0, "DECIMAL", BT_INQUIRE | BT_OPEN | BT_READ | BT_WRITE}, {0, 0, 0, 0, "ENCODING", BT_INQUIRE | BT_OPEN}, {0, 0, 0, 0, "SIGN", BT_INQUIRE | BT_OPEN | BT_WRITE}, {0, 0, 0, 0, "STREAM", BT_INQUIRE}, {0, 0, 0, 0, "ROUND", BT_INQUIRE | BT_OPEN | BT_READ | BT_WRITE}, {0, 0, 0, 0, "DISPOSE", BT_CLOSE | BT_OPEN}, {0, 0, 0, 0, "END", BT_READ | BT_WAIT}, {0, 0, 0, 0, "ERR", BT_BKSPACE | BT_CLOSE | BT_DECODE | BT_ENCODE | BT_ENDFILE | BT_INQUIRE | BT_OPEN | BT_READ | BT_REWIND | BT_WRITE | BT_WAIT | BT_FLUSH}, {0, 0, 0, 0, "FMT", BT_READ | BT_WRITE}, {0, 0, 0, 0, "NML", BT_READ | BT_WRITE}, {0, 0, 0, 0, "REC", BT_READ | BT_WRITE}, {0, 0, 0, 0, "STATUS", BT_CLOSE | BT_OPEN}, {0, 0, 0, 0, "ADVANCE", BT_READ | BT_WRITE}, {0, 0, 0, 0, "EOR", BT_READ | BT_WAIT}, {0, 0, 0, 0, "IOLENGTH", BT_INQUIRE}, {0, 0, 0, 0, "CONVERT", BT_OPEN}, {0, 0, 0, 0, "SHARED", BT_OPEN}, {0, 0, 0, 0, "IOMSG", BT_BKSPACE | BT_CLOSE | BT_DECODE | BT_ENCODE | BT_ENDFILE | BT_INQUIRE | BT_OPEN | BT_READ | BT_REWIND | BT_WRITE | BT_WAIT | BT_FLUSH}, {0, 0, 0, 0, "NEWUNIT", BT_OPEN}, }; static FormatType fmttyp; /* formatted or unformatted I/O */ static int nml_group; /* sptr to namelist group ident */ static int intern_array; /* AST of array section used as internal unit*/ static int intern_tmp; /* AST of temp replacing 'intern_array' */ static LOGICAL intern; /* internal I/O flag */ static LOGICAL external_io; /* set for any external I/O statement */ static LOGICAL nondevice_io; /* set for any I/O statement not allowed in CUDA device code */ static LOGICAL is_read; /* read flag */ static LOGICAL no_rw; /* statement DOES NOT read or write */ static LOGICAL print_star; /* PRINT * */ static LOGICAL unit_star; /* unit is * */ static int fmt_is_var; /* FMT specifier is a variable */ static int fasize; /* size in units of 32-bit words of the format * list */ static int rescan; /* where formatted I/O begins rescanning if * there are more I/O items than edit * descriptors */ static int lastrpt; /* marks where the last repeat count seen while * processing edit descriptors is in the * format list */ static int edit_state; /* state transition value for edit descriptor * processing -- used for checking "delimiter * conformance" */ static int last_edit; /* last edit descriptor seen */ static int fmt_length; /* ast representing length of an unencoded * format string (FT_CHARACTER). */ static INT num[2]; /* scratch area for making integer constants */ static int filename_type = 0; /* TY_CHAR or TY_NCHAR */ static int iolist; /* ASTLI list for io items in read/write */ static LOGICAL noparens; /* no parens enclosing control list */ static LOGICAL open03; /* any f2003 open specfiers */ static LOGICAL rw03; /* any f2003 read/write specifiers */ static INT bitv; /* bit vector for IOSTAT, END, and ERR: */ #define BITV_IOSTAT 0x01 #define BITV_ERR 0x02 #define BITV_END 0x04 #define BITV_EOR 0x08 #define BITV_IOMSG 0x10 /* * the following values are not seen by the runtime and are just used to * check for illegal combinations of I/O specifers. */ #define BITV_SIZE 0x020 #define BITV_ADVANCE 0x040 #define BYTE_SWAPPED_IO (XBIT(125, 0x2) != 0) #define LARGE_ARRAY (XBIT(68, 1) != 0) /* Selectable unfomatted i/o routines: * Indexed by: * 1) LARGE_ARRAY_IDX * * 2) 0 - normal unformatted i/o (file format matches native byte order) * 1 - byte-swapped unf i/o (file format is reversed from native byte order). * 2 - byte read/write * * '-x 125 2' is used to select one of the first two entries; aggregate * unformatted i/o selects the third entry. */ #define BYTE_SWAPPED_IO_IDX ((BYTE_SWAPPED_IO) ? 1 : 0) #define LARGE_ARRAY_IDX ((LARGE_ARRAY) ? 1 : 0) #define BYTE_RW_IDX 2 typedef struct { FtnRtlEnum init; FtnRtlEnum read; FtnRtlEnum write; FtnRtlEnum end; } UnformattedRtns; UnformattedRtns unf_nm[][3] = {{ {RTE_f90io_unf_init, RTE_f90io_unf_reada, RTE_f90io_unf_writea, RTE_f90io_unf_end}, {RTE_f90io_usw_init, RTE_f90io_usw_reada, RTE_f90io_usw_writea, RTE_f90io_usw_end}, {RTE_f90io_unf_init, RTE_f90io_byte_reada, RTE_f90io_byte_writea, RTE_f90io_unf_end}, }, { {RTE_f90io_unf_init, RTE_f90io_unf_reada, RTE_f90io_unf_writea, RTE_f90io_unf_end}, {RTE_f90io_usw_init, RTE_f90io_usw_reada, RTE_f90io_usw_writea, RTE_f90io_usw_end}, {RTE_f90io_unf_init, RTE_f90io_byte_read64a, RTE_f90io_byte_write64a, RTE_f90io_unf_end}, }}; UnformattedRtns array_unf_nm[][3] = { { {RTE_f90io_unf_init, RTE_f90io_unf_read_aa, RTE_f90io_unf_write_aa, RTE_f90io_unf_end}, {RTE_f90io_usw_init, RTE_f90io_usw_read_aa, RTE_f90io_usw_write_aa, RTE_f90io_usw_end}, {RTE_f90io_unf_init, RTE_f90io_byte_reada, RTE_f90io_byte_writea, RTE_f90io_unf_end}, }, { {RTE_f90io_unf_init, RTE_f90io_unf_read64_aa, RTE_f90io_unf_write64_aa, RTE_f90io_unf_end}, {RTE_f90io_usw_init, RTE_f90io_usw_read64_aa, RTE_f90io_usw_write64_aa, RTE_f90io_usw_end}, {RTE_f90io_unf_init, RTE_f90io_byte_read64a, RTE_f90io_byte_write64a, RTE_f90io_unf_end}, }}; /* Selectable formatted init routines: * 0 - external i/o * 0 - encoded format or not present * 1 - fmt specifier is a variable * 1 - internal i/o * 0 - encoded format or not present * 1 - fmt specifier is a variable */ static struct { FtnRtlEnum read[2]; FtnRtlEnum write[2]; } fmt_init[] = {{ {RTE_f90io_fmtr_init2003a, RTE_f90io_fmtr_initv2003a}, {RTE_f90io_fmtw_inita, RTE_f90io_fmtw_initva}, }, { {RTE_f90io_fmtr_intern_inita, RTE_f90io_fmtr_intern_initva}, {RTE_f90io_fmtw_intern_inita, RTE_f90io_fmtw_intern_initva}, }}; /* Init routines for DECODE/ENCODE */ static struct { FtnRtlEnum read[2]; FtnRtlEnum write[2]; } fmt_inite = { {RTE_f90io_fmtr_intern_inite, RTE_f90io_fmtr_intern_initev}, {RTE_f90io_fmtw_intern_inite, RTE_f90io_fmtw_intern_initev}, }; /* Selectable prefixes for the I/O routines (craft, non-craft) passed * to mkfunc_name(); */ static int io_sc; static int set_io_sc(void); static int copy_replic_sect_to_tmp(int); static void copy_back_to_replic_sect(int, int); static void fix_iostat(void); static int add_cgoto(int); static int end_or_err(int, int, int); static int fio_end_err(int, int); static void chk_expr(SST *, int, int); static void chk_var(SST *, int, int); static void gen_spec_item_tmp(SST *, int, int); static void chk_unitid(SST *); static void chk_fmtid(SST *); static void chk_iospec(void); static void put_edit(int); static void put_ffield(SST *); static void kwd_errchk(int); static int get_fmt_array(int, int); static int ast_ioret(void); static int mk_iofunc(FtnRtlEnum, int, int); static int mk_hpfiofunc(FtnRtlEnum, int, int); static LOGICAL need_descriptor_ast(int); static void rw_array(int, int, int, FtnRtlEnum); static void get_derived_iolptrs(SST *, int, SST *); static void gen_derived_io(int, FtnRtlEnum, int); static void gen_lastval(DOINFO *); static int misc_io_checks(char *); static void iomsg_check(void); static void newunit_check(void); static void put_vlist(SST *); static FtnRtlEnum getBasicScalarRWRtn(LOGICAL, FormatType); static FtnRtlEnum getAggrRWRtn(LOGICAL); static FtnRtlEnum getWriteByDtypeRtn(int, FormatType); static FtnRtlEnum getArrayRWRtn(LOGICAL, FormatType, int, LOGICAL); static ITEM *gen_dtio_args(SST *, int, int, int); static int gen_dtsfmt_args(int *, int *); static int call_dtsfmt(int, int); static int get_defined_io_call(int, int, ITEM *); static int begin_io_call(int, int, int); static void add_io_arg(int); static int end_io_call(void); static void _put(INT, int); /*---------------------------------------------------------------------------*/ /** \brief Semantic analysis of IO statements. \param rednum reduction number \param top top of stack after reduction */ void semantio(int rednum, SST *top) { int sptr, i, iofunc; int len; int dtype, ddtype; int dum; ADSC *ad; SST *stkptr, *e1; IOL *iolptr; IOL *dobegin, *doend; DOINFO *doinfo; FtnRtlEnum rtlRtn; int ast; int argt; int count; int ast1, ast2, ast3; int dim; /* dimension # of the index variable */ int asd; /* array subscript descriptor */ int subs[MAXSUBS]; // AOCC int numdim; int sptr1; int nelems; int last_inquire_val; ITEM *itemp; char *strptr; LOGICAL needDescr; switch (rednum) { /* ------------------------------------------------------------------ */ /* * ::= */ case NULL1: /* * this reduction is made at the beginning of any I/O statement * not involving the transfer of data. It is used to initialize for * the processing of these statements. */ no_rw = TRUE; goto io_shared; /* ------------------------------------------------------------------ */ /* * ::= */ case WRITE1: /* * this reduction is made at the beginning of any I/O statement * performing output. It is used to initialize for the processing * of these statements. */ is_read = FALSE; goto rw_init; /* ------------------------------------------------------------------ */ /* * ::= */ case READ1: /* * this reduction is made at the beginning of any I/O statement * performing input. It is used to initialize for the processing * of these statements. */ is_read = TRUE; rw_init: sem.io_stmt = TRUE; fmttyp = FT_UNFORMATTED; intern = FALSE; no_rw = FALSE; print_star = FALSE; unit_star = FALSE; /* shared entry for all io statements except bufferin/bufferout */ io_shared: set_io_sc(); bitv = 0; for (i = 0; i <= PT_MAXV; i++) { PTV(i) = 0; PTS(i) = 0; PTVARREF(i) = 0; PT_TMPUSED(i, 0); } if (flg.smp || flg.accmp || XBIT(125, 0x1)) { /* begin i/o critical section */ if (flg.smp || flg.accmp) sptr = sym_mkfunc_nodesc("_mp_bcs_nest", DT_NONE); else sptr = mk_iofunc(RTE_f90io_begin, DT_NONE, 0); (void)begin_io_call(A_CALL, sptr, 0); ast = end_io_call(); STD_LINENO(io_call.std) = gbl.lineno; /* * if an I/O statement is labeled, ensure that the first 'statement' * generated is labeled. */ if (scn.currlab && !DEFDG(scn.currlab)) { STD_LABEL(io_call.std) = scn.currlab; DEFDP(scn.currlab, 1); } } /* * Create a character variable which is data initialized with * the name of the source file if character constants can't be * passed to RTE_loc(). Certain systems (hp) may place character * constants on the stack, in which case the run-time or generated * code can't stash away the address of the constant. */ sptr = getstring(gbl.curr_file, strlen(gbl.curr_file)); if (!XBIT(49, 0x100000)) ast1 = mk_cnst(sptr); else { sptr1 = getcctmp_sc('t', sptr, ST_UNKNOWN, DTYPEG(sptr), io_sc); if (STYPEG(sptr1) == ST_UNKNOWN) { STYPEP(sptr1, ST_VAR); DINITP(sptr1, 1); if (SCG(sptr1) != SC_NONE) sym_is_refd(sptr1); dinit_put(DINIT_LOC, sptr1); dinit_put(DINIT_STR, (INT)sptr); dinit_put(DINIT_END, (INT)0); } ast1 = mk_id(sptr1); } sptr = mk_iofunc(RTE_f90io_src_info03a, DT_NONE, 0); (void)begin_io_call(A_CALL, sptr, 2); (void)add_io_arg(mk_cval((INT)gbl.lineno, DT_INT)); (void)add_io_arg(ast1); ast = end_io_call(); STD_LINENO(io_call.std) = gbl.lineno; /* * if an I/O statement is labeled, ensure that the first 'statement' * generated is labeled. */ if (!XBIT(125, 0x1) && !flg.smp && !flg.accmp && scn.currlab && !DEFDG(scn.currlab)) { STD_LABEL(io_call.std) = scn.currlab; DEFDP(scn.currlab, 1); } iolist = 0; noparens = FALSE; external_io = FALSE; nondevice_io = FALSE; open03 = FALSE; rw03 = FALSE; break; /* ------------------------------------------------------------------ */ /* * ::= BACKSPACE | */ case IO_STMT1: (void)misc_io_checks("BACKSPACE"); iomsg_check(); kwd_errchk(BT_BKSPACE); if (BYTE_SWAPPED_IO) rtlRtn = RTE_f90io_swbackspace; /* byte swap backspace */ else rtlRtn = RTE_f90io_backspace; goto rewind_shared; /* * ::= ENDFILE | */ case IO_STMT2: (void)misc_io_checks("ENDFILE"); iomsg_check(); kwd_errchk(BT_ENDFILE); rtlRtn = RTE_f90io_endfile; goto rewind_shared; /* * ::= REWIND | */ case IO_STMT3: (void)misc_io_checks("REWIND"); iomsg_check(); kwd_errchk(BT_REWIND); rtlRtn = RTE_f90io_rewind; rewind_shared: sptr = mk_iofunc(rtlRtn, DT_INT, 0); UNIT_CHECK; fix_iostat(); (void)begin_io_call(A_FUNC, sptr, 3); (void)add_io_arg(PTARG(PT_UNIT)); (void)add_io_arg(mk_cval(bitv, DT_INT)); (void)add_io_arg(PTARG(PT_IOSTAT)); ast = end_io_call(); ast = add_cgoto(ast); external_io = TRUE; nondevice_io = TRUE; goto end_IO_STMT; /* * ::= CLOSE ) | */ case IO_STMT4: (void)misc_io_checks("CLOSE"); iomsg_check(); UNIT_CHECK; kwd_errchk(BT_CLOSE); if (PTV(PT_STATUS)) { if (PTV(PT_DISPOSE)) IOERR2(202, "STATUS and DISPOSE in CLOSE"); } else PTV(PT_STATUS) = PTV(PT_DISPOSE); PT_CHECK(PT_STATUS, astb.ptr0c); sptr = mk_iofunc(RTE_f90io_closea, DT_INT, 0); fix_iostat(); (void)begin_io_call(A_FUNC, sptr, 4); (void)add_io_arg(PTARG(PT_UNIT)); (void)add_io_arg(mk_cval(bitv, DT_INT)); (void)add_io_arg(PTARG(PT_IOSTAT)); (void)add_io_arg(PTARG(PT_STATUS)); ast = end_io_call(); ast = add_cgoto(ast); external_io = TRUE; nondevice_io = TRUE; goto end_IO_STMT; /* * ::= OPEN ) | */ case IO_STMT5: (void)misc_io_checks("OPEN"); iomsg_check(); UNIT_CHECK; newunit_check(); kwd_errchk(BT_OPEN); PT_CHECK(PT_ACCESS, astb.ptr0c); PT_CHECK(PT_ACTION, astb.ptr0c); PT_CHECK(PT_BLANK, astb.ptr0c); PT_CHECK(PT_DELIM, astb.ptr0c); PT_CHECK(PT_FORM, astb.ptr0c); fix_iostat(); PT_CHECK(PT_PAD, astb.ptr0c); PT_CHECK(PT_POSITION, astb.ptr0c); PT_CHECK(PT_RECL, astb.ptr0); PT_CHECK(PT_STATUS, astb.ptr0c); PT_CHECK(PT_FILE, astb.ptr0c); PT_CHECK(PT_DISPOSE, astb.ptr0c); if (PTS(PT_NEWUNIT)) { sptr = sym_mkfunc(mkRteRtnNm(RTE_f90io_get_newunit), DT_INT); INDEPP(sptr, 1); TYPDP(sptr, 1); INTERNALP(sptr, 0); ast = begin_io_call(A_FUNC, sptr, 1); //AOCC (void)add_io_arg(PTARG(PT_UNIT)); //AOCC ast = mk_assn_stmt(PTV(PT_UNIT), ast, A_DTYPEG(PTV(PT_NEWUNIT))); //AOCC add_stmt_after(ast, io_call.std); if (A_DTYPEG(PTV(PT_NEWUNIT)) != DT_INT) { PTV(PT_UNIT) = mk_convert(PTV(PT_UNIT), DT_INT); } } if (PTS(PT_FILE) && PTS(PT_NAME)) IOERR2(202, "FILE and NAME in OPEN"); sptr = mk_iofunc(RTE_f90io_open2003a, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 14); (void)add_io_arg(PTARG(PT_UNIT)); (void)add_io_arg(mk_cval(bitv, DT_INT)); (void)add_io_arg(PTARG(PT_ACCESS)); (void)add_io_arg(PTARG(PT_ACTION)); (void)add_io_arg(PTARG(PT_BLANK)); (void)add_io_arg(PTARG(PT_DELIM)); /* on open statement, FILE and NAME are the same. code previously only set PT_FILE, but this created incorrect error messages */ if (PTV(PT_NAME)) (void)add_io_arg(PTARG(PT_NAME)); else (void)add_io_arg(PTARG(PT_FILE)); (void)add_io_arg(PTARG(PT_FORM)); (void)add_io_arg(PTARG(PT_IOSTAT)); (void)add_io_arg(PTARG(PT_PAD)); (void)add_io_arg(PTARG(PT_POSITION)); (void)add_io_arg(PTARG(PT_RECL)); (void)add_io_arg(PTARG(PT_STATUS)); (void)add_io_arg(PTARG(PT_DISPOSE)); ast = end_io_call(); if (PTV(PT_CONVERT)) { /* ast is an A_ASN of the form * z_io = ...open(...) */ sptr = mk_iofunc(RTE_f90io_open_cvta, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 2); (void)add_io_arg(A_DESTG(ast)); (void)add_io_arg(PTARG(PT_CONVERT)); ast = end_io_call(); } if (PTV(PT_SHARED)) { /* ast is an A_ASN of the form * z_io = ...open(...) */ sptr = mk_iofunc(RTE_f90io_open_sharea, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 2); (void)add_io_arg(A_DESTG(ast)); (void)add_io_arg(PTARG(PT_SHARED)); ast = end_io_call(); } if (PTV(PT_ASYNCHRONOUS)) { /* ast is an A_ASN of the form * z_io = ...open(...) */ sptr = mk_iofunc(RTE_f90io_open_asynca, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 2); (void)add_io_arg(A_DESTG(ast)); (void)add_io_arg(PTARG(PT_ASYNCHRONOUS)); ast = end_io_call(); } if (open03) { /* ast is an A_ASN of the form * z_io = ...open(...) */ PT_CHECK(PT_DECIMAL, astb.ptr0c); PT_CHECK(PT_ROUND, astb.ptr0c); PT_CHECK(PT_SIGN, astb.ptr0c); PT_CHECK(PT_ENCODING, astb.ptr0c); sptr = mk_iofunc(RTE_f90io_open03a, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 5); (void)add_io_arg(A_DESTG(ast)); (void)add_io_arg(PTARG(PT_DECIMAL)); (void)add_io_arg(PTARG(PT_ROUND)); (void)add_io_arg(PTARG(PT_SIGN)); (void)add_io_arg(PTARG(PT_ENCODING)); ast = end_io_call(); } ast = add_cgoto(ast); external_io = TRUE; nondevice_io = TRUE; goto end_IO_STMT; /* * ::= INQUIRE ) | */ case IO_STMT6: (void)misc_io_checks("INQUIRE"); iomsg_check(); if (PTV(PT_UNIT)) { if (PTV(PT_FILE)) IOERR2(201, "UNIT and FILE used in INQUIRE"); PTV(PT_FILE) = astb.ptr0c; } else if (PTV(PT_FILE)) PTV(PT_UNIT) = astb.i0; else IOERR(200); kwd_errchk(BT_INQUIRE); last_inquire_val = PT_LAST_INQUIRE_VALf95; for (i = PT_LAST_INQUIRE_VALf95 + 1; i <= PT_LAST_INQUIRE_VAL; i++) { if (PTV(i)) { last_inquire_val = PT_LAST_INQUIRE_VAL; break; } } for (i = 2; i <= last_inquire_val; i++) { switch (i) { case PT_NEXTREC: case PT_NUMBER: case PT_RECL: case PT_SIZE: case PT_IOSTAT: case PT_EXIST: case PT_NAMED: case PT_OPENED: case PT_ID: case PT_PENDING: case PT_POS: PT_CHECK(i, astb.ptr0); break; default: PT_CHECK(i, astb.ptr0c); } } if (last_inquire_val < PT_LAST_INQUIRE_VAL) { sptr = mk_iofunc(RTE_f90io_inquire2003a, DT_INT, 0); } else { sptr = mk_iofunc(RTE_f90io_inquire03_2a, DT_INT, 0); } filename_type = 0; (void)begin_io_call(A_FUNC, sptr, last_inquire_val + 2); (void)add_io_arg(PTARG(PT_UNIT)); (void)add_io_arg(PTARG(PT_FILE)); (void)add_io_arg(mk_cval(bitv, DT_INT)); for (i = 2; i <= last_inquire_val; i++) (void)add_io_arg(PTARG(i)); ast = end_io_call(); ast = add_cgoto(ast); external_io = TRUE; nondevice_io = TRUE; goto end_IO_STMT; /* * ::= WRITE | */ case IO_STMT7: (void)misc_io_checks("WRITE"); kwd_errchk(BT_WRITE); external_io = !intern; goto io_end; /* * ::= WRITE | */ case IO_STMT8: (void)misc_io_checks("WRITE"); kwd_errchk(BT_WRITE); iolptr = (IOL *)SST_BEGG(RHS(4)); external_io = !intern; goto io_items; /* * ::= PRINT | */ case IO_STMT9: (void)misc_io_checks("PRINT"); kwd_errchk(BT_PRINT); external_io = !intern; goto io_end; /* * ::= PRINT , | */ case IO_STMT10: (void)misc_io_checks("PRINT"); kwd_errchk(BT_PRINT); iolptr = (IOL *)SST_BEGG(RHS(5)); external_io = !intern; goto io_items; /* * ::= READ | */ case IO_STMT11: (void)misc_io_checks("READ"); kwd_errchk(BT_READ); chk_iospec(); iolptr = (IOL *)SST_BEGG(RHS(4)); external_io = !intern; nondevice_io = TRUE; goto io_items; /* * ::= READ | */ case IO_STMT12: (void)misc_io_checks("READ"); kwd_errchk(BT_READ); external_io = !intern; nondevice_io = TRUE; goto io_end; /* * ::= READ , | */ case IO_STMT13: (void)misc_io_checks("READ"); kwd_errchk(BT_READ); iolptr = (IOL *)SST_BEGG(RHS(5)); external_io = !intern; nondevice_io = TRUE; goto io_items; /* * ::= ACCEPT | */ case IO_STMT14: (void)misc_io_checks("ACCEPT"); iomsg_check(); kwd_errchk(BT_ACCEPT); external_io = !intern; nondevice_io = TRUE; goto io_end; /* * ::= ACCEPT , | */ case IO_STMT15: (void)misc_io_checks("ACCEPT"); iomsg_check(); kwd_errchk(BT_ACCEPT); iolptr = (IOL *)SST_BEGG(RHS(5)); external_io = !intern; nondevice_io = TRUE; goto io_items; /* * ::= ENCODE | */ case IO_STMT16: (void)misc_io_checks("ENCODE"); iomsg_check(); kwd_errchk(BT_ENCODE); iolptr = (IOL *)SST_BEGG(RHS(5)); external_io = FALSE; nondevice_io = TRUE; goto io_items; /* * ::= ENCODE | */ case IO_STMT17: (void)misc_io_checks("ENCODE"); iomsg_check(); kwd_errchk(BT_ENCODE); external_io = FALSE; nondevice_io = TRUE; goto io_end; /* * ::= DECODE */ case IO_STMT18: (void)misc_io_checks("DECODE"); iomsg_check(); kwd_errchk(BT_DECODE); iolptr = (IOL *)SST_BEGG(RHS(5)); external_io = FALSE; nondevice_io = TRUE; goto io_items; /* * ::= DECODE | */ case IO_STMT19: (void)misc_io_checks("DECODE"); iomsg_check(); kwd_errchk(BT_DECODE); external_io = FALSE; nondevice_io = TRUE; goto io_end; io_items: if (fmttyp == FT_NML) { IOERR(212); break; } count = 4; rtlRtn = getBasicScalarRWRtn(is_read, fmttyp); iofunc = mk_iofunc(rtlRtn, DT_INT, is_read ? 0 : INTENT_IN); SEQUENTP(iofunc, 1); /* TPR1786 */ for (; iolptr; iolptr = iolptr->next) { switch (iolptr->id) { case IE_OPTDO: stkptr = iolptr->element; dtype = SST_DTYPEG(stkptr); doinfo = iolptr->doinfo; /* TBD: I would rather call a function to compute the lastvalue: index_var = f90_lastval(m1, m2, m3) */ /* * Compute last value of index variable: * index_var = max( (m2 - m1 + m3)/m3, 0) */ gen_lastval(doinfo); goto array_io_item; case IE_EXPR: stkptr = iolptr->element; dtype = SST_DTYPEG(stkptr); if (DTY(dtype) == TY_ARRAY) { ad = AD_DPTR(dtype); if (SST_IDG(stkptr) == S_IDENT && AD_ASSUMSZ(ad)) { /* illegal use of assumed size array */ ast2 = astb.i0; IOERR(215); } goto array_io_item; } /* does this have a shape */ if (SST_SHAPEG(stkptr)) goto array_io_item; /* at this point, io item is a scalar */ if (dtype == DT_HOLL) { /* semantic stack type is hollerith, but want its associated * character constant. */ sptr1 = CONVAL1G(SST_SYMG(stkptr)); dtype = DTYPEG(sptr1); #if DEBUG assert(DTY(dtype) == TY_CHAR, "io_item: HOLL not char", sptr1, 3); #endif SST_DTYPEP(stkptr, dtype); SST_ASTP(stkptr, mk_cnst(sptr1)); } ast2 = astb.i1; ast3 = astb.i0; (void)mkarg(stkptr, &dum); ast = SST_ASTG(stkptr); if (is_read) { if (A_TYPEG(ast) == A_ID) { DOCHK(A_SPTRG(ast)); } if (SST_IDG(stkptr) == S_IDENT || SST_IDG(stkptr) == S_DERIVED) set_assn(sym_of_ast(SST_ASTG(stkptr))); else if (SST_IDG(stkptr) == S_LVALUE) set_assn(sym_of_ast(SST_ASTG(stkptr))); } if (!DT_ISBASIC(dtype) && SST_IDG(stkptr) != S_DERIVED) { int bytfunc; int udt; FtnRtlEnum aggrRWRtn = getAggrRWRtn(is_read); if (SST_IDG(stkptr) == S_IDENT) { sptr = SST_SYMG(stkptr); udt = DTYPEG(sptr); } else if (SST_IDG(stkptr) == S_EXPR) { if (A_TYPEG(ast) == A_ID) { sptr = A_SPTRG(ast); udt = DTYPEG(sptr); } else { sptr = 0; udt = A_DTYPEG(ast); } } else { sptr = SST_LSYMG(stkptr); udt = DTYPEG(sptr); } if (DTYG(udt) == TY_DERIVED) { int iotype_ast, vlist_ast, ast_size; int fsptr, argcnt, has_io, asn, tast; int val[2]; char *iotype; ITEM *arglist, *p; dtype = udt; has_io = dtype_has_defined_io(dtype); #if DEBUG assert(has_io, "unknown status from dtype_has_defined_io()", 0, 3); #endif if (has_io & functype[is_read][fmttyp]) { if (fmttyp == FT_UNFORMATTED) { argcnt = 4; } else { int tast; argcnt = 6; if (fmttyp == FT_NML) { iotype = "NAMELIST"; vlist_ast = astb.i0; iotype_ast = mk_cnst(getstring(iotype, strlen(iotype))); } else if (fmttyp == FT_LIST_DIRECTED) { iotype = "LISTDIRECTED"; vlist_ast = astb.i0; iotype_ast = mk_cnst(getstring(iotype, strlen(iotype))); } else { asn = gen_dtsfmt_args(&iotype_ast, &vlist_ast); asn = call_dtsfmt(iotype_ast, vlist_ast); tast = add_cgoto(asn); } } arglist = gen_dtio_args(stkptr, ast, iotype_ast, vlist_ast); fsptr = resolve_defined_io((is_read ? 0 : 1), stkptr, arglist); if (!fsptr) { /*unable to find io routine*/ error(155, 2, gbl.lineno, "- Unable to resolve user defined io ", CNULL); } else { /* set the upper bound of descriptor here? */ ast = get_defined_io_call(fsptr, argcnt, arglist); (void)add_stmt(ast); /* error handling in parent in case of error */ if (argcnt == 4) { tast = (arglist->next->next)->ast; } else { tast = (arglist->next->next->next->next)->ast; } sptr1 = mk_iofunc(RTE_f90io_dts_stat, DT_NONE, 0); ast1 = begin_io_call(A_CALL, sptr1, 1); (void)add_io_arg(mk_unop(OP_VAL, tast, DT_INT4)); (void)add_stmt(ast1); (void)add_cgoto(tast); } break; } else { gen_derived_io(sptr, aggrRWRtn, is_read); } } else { bytfunc = mk_iofunc(aggrRWRtn, DT_INT, is_read ? 0 : INTENT_IN); if (XBIT(68, 0x1)) { /* just transfer a stream of n bytes */ i = mk_isz_cval(size_of(dtype), DT_INT8); (void)begin_io_call(A_FUNC, bytfunc, 4); (void)add_io_arg(i); /* length, stride */ (void)add_io_arg(astb.i0); (void)add_io_arg(ast); /* item */ (void)add_io_arg(astb.k1); /* explicit item_length */ } else { i = mk_cval(size_of(dtype), DT_INT8); (void)begin_io_call(A_FUNC, bytfunc, 4); (void)add_io_arg(ast2); /* length, stride */ (void)add_io_arg(ast3); (void)add_io_arg(ast); /* item */ (void)add_io_arg(i); /* explicit item_length */ } } } else if (fmttyp != FT_UNFORMATTED && !is_read && (dtype == DT_INT8 || dtype == DT_INT4 || dtype == DT_SINT || dtype == DT_BINT || dtype == DT_LOG8 || dtype == DT_LOG || dtype == DT_SLOG || dtype == DT_BLOG || dtype == DT_REAL4 || dtype == DT_REAL8 || dtype == DT_QUAD || dtype == DT_CMPLX8 || dtype == DT_CMPLX16 || dtype == DT_CMPLX32 || (DTY(dtype) == TY_CHAR && fmttyp == FT_LIST_DIRECTED))) { i = sym_mkfunc_nodesc(mkRteRtnNm(getWriteByDtypeRtn(dtype, fmttyp)), DT_INT); if (DTY(dtype) != TY_CHAR) { ast = mk_unop(OP_VAL, ast, dtype); } ast1 = mk_cval((INT)dtype_to_arg(dtype), DT_INT4); ast1 = mk_unop(OP_VAL, ast1, DT_INT4); (void)begin_io_call(A_FUNC, i, 2); (void)add_io_arg(ast); /* item */ (void)add_io_arg(ast1); /* type */ } else { ast1 = mk_cval((INT)dtype_to_arg(dtype), DT_INT); (void)begin_io_call(A_FUNC, iofunc, 4); (void)add_io_arg(ast1); /* type, length, stride */ (void)add_io_arg(ast2); (void)add_io_arg(ast3); (void)add_io_arg(ast); /* item */ } ast = end_io_call(); ast = add_cgoto(ast); break; case IE_DOBEGIN: doinfo = iolptr->doinfo; ast = do_begin(doinfo); { /* for any stds attached to this DO, add them after * the DO begin; these STDs are simply linked in by * altering the NEXT & PREV fields of the DO's std * and the first and last stds. in the list. */ int s, s1; s1 = add_stmt_after(ast, (int)STD_PREV(0)); s = iolptr->l_std; if (s) { STD_NEXT(s1) = s; STD_PREV(s) = s1; s1 = s; /* find last STD in the list attached to the DO */ while (STD_NEXT(s1)) s1 = STD_NEXT(s1); STD_PREV(0) = s1; } } NEED_DOIF(i, DI_DO); break; case IE_DOEND: do_end(iolptr->doinfo); break; default: interr("io_items, badIE", iolptr->id, 3); } continue; array_io_item: if (DTY(dtype) == TY_ARRAY) dtype = DTY(dtype + 1); if (no_data_components(dtype)) continue; if (!((SST_IDG(stkptr) == S_EXPR && DTYG(dtype) == TY_DERIVED))) (void)mkarg(stkptr, &dum); if (is_read) { if (SST_IDG(stkptr) == S_IDENT) set_assn(sym_of_ast(SST_ASTG(stkptr))); else if (SST_IDG(stkptr) == S_LVALUE) set_assn(sym_of_ast(SST_ASTG(stkptr))); } ast = SST_ASTG(stkptr); needDescr = need_descriptor_ast(ast); rtlRtn = getArrayRWRtn(is_read, fmttyp, dtype, !needDescr); if (DTY(dtype) == TY_CHAR) { if (!needDescr) { /* collapse a read/write of an array into a single call * which doesn't require a descriptor */ if (dtype != DT_ASSCHAR && dtype != DT_DEFERCHAR) { ast3 = SST_CVLENG(stkptr); if (!ast3) ast3 = mk_cval(size_of(dtype), DT_INT); } else { ast3 = string_expr_length(ast); } rw_array(ast, ast3, dtype, rtlRtn); goto end_io_item; } ast1 = mk_cval((INT)ty_to_lib[TY_CHAR], DT_INT); ast2 = astb.i1; /* tpr 1786: this gets elementalized later */ if (dtype != DT_ASSCHAR && dtype != DT_DEFERCHAR) { ast3 = SST_CVLENG(stkptr); if (!ast3) ast3 = mk_cval(size_of(dtype), DT_INT); } else { ast3 = string_expr_length(ast); } (void)begin_io_call(A_FUNC, iofunc, 4); (void)add_io_arg(ast1); /* type, length, stride */ (void)add_io_arg(ast2); (void)add_io_arg(ast3); (void)add_io_arg(ast); /* item */ } else if (DTY(dtype) == TY_NCHAR) { ast1 = mk_cval((INT)ty_to_lib[TY_NCHAR], DT_INT); ast2 = astb.i1; /* tpr 1786: this gets elementalized later */ if (dtype != DT_ASSNCHAR && dtype != DT_DEFERNCHAR) ast3 = mk_cval(size_of(dtype), DT_INT); else { i = sym_mkfunc_nodesc(mkRteRtnNm(RTE_nlena), DT_INT); ast3 = begin_call(A_FUNC, i, 1); add_arg(ast); } (void)begin_io_call(A_FUNC, iofunc, 4); (void)add_io_arg(ast1); /* type, length, stride */ (void)add_io_arg(ast2); (void)add_io_arg(ast3); (void)add_io_arg(ast); /* item */ } else if (!DT_ISBASIC(dtype)) { int bytfunc; if (DTY(dtype) == TY_DERIVED && (dtype_has_defined_io(dtype) & functype[is_read][fmttyp])) { int tast, iotype_ast, vlist_ast, argcnt, asn, fsptr, sptr; char *iotype; int shape, forall, triplet_list, n, lb, ub, st, newast; int index_var, triplet, dovar, list, lc, sym, triple; ITEM *arglist, *p; int subs[MAXSUBS], std; // AOCC int i; if (fmttyp == FT_UNFORMATTED) { argcnt = 4; } else { argcnt = 6; if (fmttyp == FT_LIST_DIRECTED) { iotype = "LISTDIRECTED"; vlist_ast = astb.i0; iotype_ast = mk_cnst(getstring(iotype, strlen(iotype))); } else if (fmttyp != FT_NML) { /* only generates the argument, no call */ asn = gen_dtsfmt_args(&iotype_ast, &vlist_ast); } } /* need to make a loop here */ arglist = gen_dtio_args(stkptr, ast, iotype_ast, vlist_ast); shape = A_SHAPEG(arglist->ast); /* make forall */ start_astli(); numdim = SHD_NDIM(shape); ad = AD_DPTR(dtype); for (i = 0; i < numdim; i++) { subs[i] = ASD_SUBS(A_ASDG(ast1), i); } for (i = numdim - 1; i >= 0; i--) { /* make each forall index */ lb = check_member(ast1, SHD_LWB(shape, i)); ub = check_member(ast1, SHD_UPB(shape, i)); st = check_member(ast1, SHD_STRIDE(shape, i)); if (A_DTYPEG(lb) == DT_INT8 || A_DTYPEG(ub) == DT_INT8 || A_DTYPEG(st) == DT_INT8) dtype = DT_INT8; else dtype = astb.bnd.dtype; if (A_DTYPEG(lb) == DT_INT8 || A_DTYPEG(ub) == DT_INT8 || A_DTYPEG(st) == DT_INT8) sym = sym_get_scalar("i", 0, DT_INT8); else sym = sym_get_scalar("i", 0, DT_INT); list = add_astli(); triple = mk_triple(lb, ub, st); ASTLI_SPTR(list) = sym; ASTLI_TRIPLE(list) = triple; subs[i] = mk_id(sym); } forall = mk_stmt(A_FORALL, 0); A_LISTP(forall, ASTLI_HEAD); A_IFEXPRP(forall, 0); n = 0; triplet_list = A_LISTG(forall); for (; triplet_list; triplet_list = ASTLI_NEXT(triplet_list)) { n++; newast = mk_stmt(A_DO, 0); index_var = ASTLI_SPTR(triplet_list); triplet = ASTLI_TRIPLE(triplet_list); dovar = mk_id(index_var); lb = A_LBDG(triplet); ub = A_UPBDG(triplet); st = A_STRIDEG(triplet); A_M1P(newast, lb); A_M2P(newast, ub); A_M3P(newast, st); A_M4P(newast, 0); A_DOVARP(newast, dovar); std = add_stmt(newast); } if (A_TYPEG(ast) == A_SUBSCR) ast1 = mk_subscr(A_LOPG(ast), subs, numdim, DDTG(A_DTYPEG(ast))); else ast1 = mk_subscr(ast, subs, numdim, DDTG(A_DTYPEG(ast))); /* need to generate a new stkptr */ arglist->t.stkp = (SST *)getitem(0, sizeof(SST)); SST_ASTP(arglist->t.stkp, ast1); SST_DTYPEP(arglist->t.stkp, A_DTYPEG(ast1)); SST_SHAPEP(arglist->t.stkp, 0); arglist->ast = ast1; SST_IDP(arglist->t.stkp, S_EXPR); mkexpr(arglist->t.stkp); fsptr = resolve_defined_io((is_read ? 0 : 1), arglist->t.stkp, arglist); if (!fsptr) { error(155, 2, gbl.lineno, "- Unable to resolve user defined io", CNULL); } else { /* need to make a loop */ if (fmttyp != FT_UNFORMATTED && fmttyp != FT_LIST_DIRECTED && fmttyp != FT_NML) { asn = call_dtsfmt(iotype_ast, vlist_ast); tast = add_cgoto(asn); } tast = get_defined_io_call(fsptr, argcnt, arglist); (void)add_stmt_after(tast, std); if (argcnt == 4) { tast = (arglist->next->next)->ast; } else { tast = (arglist->next->next->next->next)->ast; } asn = mk_assn_stmt(ast_ioret(), tast, DT_INT); (void)add_stmt(asn); tast = add_cgoto(asn); } triplet_list = A_LISTG(forall); for (; triplet_list; triplet_list = ASTLI_NEXT(triplet_list)) { newast = mk_stmt(A_ENDDO, 0); (void)add_stmt(newast); } continue; } else { bytfunc = mk_iofunc(getAggrRWRtn(is_read), DT_INT, is_read ? 0 : INTENT_IN); ast2 = AD_NUMELM(AD_DPTR(SST_DTYPEG(stkptr))); if (XBIT(68, 0x1)) { /* just transfer a stream of n bytes */ ast3 = mk_isz_cval(size_of(dtype), DT_INT8); ast2 = mk_binop(OP_MUL, ast2, ast3, DT_INT8); (void)begin_io_call(A_FUNC, bytfunc, 4); (void)add_io_arg(ast2); /* length, stride */ (void)add_io_arg(astb.i0); (void)add_io_arg(ast); /* item */ (void)add_io_arg(astb.k1); /* explicit item_length */ } else { ast3 = mk_cval(size_of(dtype), DT_INT8); (void)begin_io_call(A_FUNC, bytfunc, 4); (void)add_io_arg(ast2); /* length, stride */ (void)add_io_arg(ast3); (void)add_io_arg(ast); /* item */ (void)add_io_arg(ast3); /* explicit item_length */ } } } else { if (!need_descriptor_ast(ast)) { /* collapse a read/write of an array into a single call * which doesn't require a descriptor */ ast3 = mk_cval(size_of(dtype), DT_INT); rw_array(ast, ast3, dtype, rtlRtn); goto end_io_item; } (void)begin_io_call( A_FUNC, mk_hpfiofunc(rtlRtn, DT_INT, is_read ? 0 : INTENT_IN), 1); (void)add_io_arg(ast); /* item only */ } end_io_item: ast = end_io_call(); ast = add_cgoto(ast); } io_end: if (fmttyp == FT_NML) { if (is_read) rtlRtn = RTE_f90io_nmlr; else rtlRtn = RTE_f90io_nmlw; sptr = mk_iofunc(rtlRtn, DT_INT, is_read ? 0 : INTENT_IN); /* * First, create and "address" of the descriptor for the * namelist group; then, call the appropriate routine */ (void)begin_io_call(A_FUNC, sptr, 1); (void)add_io_arg(PTARG(PT_NML)); ast = end_io_call(); ast = add_cgoto(ast); if (is_read) rtlRtn = RTE_f90io_nmlr_end; else rtlRtn = RTE_f90io_nmlw_end; sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 0); ast = end_io_call(); } else { if (fmttyp == FT_UNFORMATTED) rtlRtn = unf_nm[LARGE_ARRAY_IDX][BYTE_SWAPPED_IO_IDX].end; else if (fmttyp == FT_LIST_DIRECTED) { if (is_read) rtlRtn = RTE_f90io_ldr_end; else rtlRtn = RTE_f90io_ldw_end; } else { if (is_read) rtlRtn = RTE_f90io_fmtr_end; else rtlRtn = RTE_f90io_fmtw_end; } sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 0); ast = end_io_call(); } if (intern_tmp) { copy_back_to_replic_sect(intern_array, intern_tmp); intern_tmp = 0; } ast = add_cgoto(ast); goto end_IO_STMT; /* * ::= INQUIRE IOLENGTH = ) | */ case IO_STMT20: (void)misc_io_checks("INQUIRE"); iomsg_check(); chk_var(RHS(6), PT_IOLENGTH, DT_INT); iolptr = (IOL *)SST_BEGG(RHS(8)); ast = astb.i0; ast = mk_assn_stmt(PTV(PT_IOLENGTH), ast, DT_INT); (void)add_stmt_after(ast, (int)STD_PREV(0)); for (; iolptr; iolptr = iolptr->next) { switch (iolptr->id) { case IE_OPTDO: stkptr = iolptr->element; dtype = SST_DTYPEG(stkptr); doinfo = iolptr->doinfo; /* TBD: I would rather call a function to compute the lastvalue: index_var = f90_lastval(m1, m2, m3) */ /* * Compute last value of index variable: * index_var = max( (m2 - m1 + m3)/m3, 0) */ gen_lastval(doinfo); goto array_iol; case IE_EXPR: stkptr = iolptr->element; dtype = SST_DTYPEG(stkptr); if (DTY(dtype) == TY_ARRAY) { ad = AD_DPTR(dtype); if (SST_IDG(stkptr) == S_IDENT && AD_ASSUMSZ(ad)) { /* illegal use of assumed array */ ast2 = astb.i0; IOERR(215); } goto array_iol; } /* at this point, io item is a scalar */ nelems = astb.i1; goto accum_it; case IE_DOBEGIN: doinfo = iolptr->doinfo; ast = do_begin(doinfo); { /* for any stds attached to this DO, add them after * the DO begin; these STDs are simply linked in by * altering the NEXT & PREV fields of the DO's std * and the first and last stds. in the list. */ int s, s1; s1 = add_stmt_after(ast, (int)STD_PREV(0)); s = iolptr->l_std; if (s) { STD_NEXT(s1) = s; STD_PREV(s) = s1; s1 = s; /* find last STD in the list attached to the DO */ while (STD_NEXT(s1)) s1 = STD_NEXT(s1); STD_PREV(0) = s1; } } NEED_DOIF(i, DI_DO); break; case IE_DOEND: do_end(iolptr->doinfo); break; default: interr("iol_items, badIE", iolptr->id, 3); } continue; array_iol: dtype = DTY(dtype + 1); (void)mkarg(stkptr, &dum); ast = SST_ASTG(stkptr); nelems = size_of_ast(ast); accum_it: if (dtype == DT_HOLL) { /* semantic stack type is hollerith, but want its associated * character constant. */ sptr1 = CONVAL1G(SST_SYMG(stkptr)); dtype = DTYPEG(sptr1); #if DEBUG assert(DTY(dtype) == TY_CHAR, "io_item: HOLL not char", sptr1, 3); #endif ast = mk_cval(size_of(dtype), DT_INT); } else if (!DT_ISBASIC(dtype)) /* treat aggr. as byte stream */ ast = mk_cval(size_of(dtype), DT_INT); else if (DTY(dtype) == TY_CHAR) { (void)mkarg(stkptr, &dum); ast2 = SST_ASTG(stkptr); i = sym_mkfunc_nodesc(mkRteRtnNm(RTE_lena), DT_INT); ast = begin_call(A_FUNC, i, 1); add_arg(ast2); } else if (DTY(dtype) == TY_NCHAR) { (void)mkarg(stkptr, &dum); ast2 = SST_ASTG(stkptr); i = sym_mkfunc_nodesc(mkRteRtnNm(RTE_nlena), DT_INT); ast = begin_call(A_FUNC, i, 1); add_arg(ast2); ast1 = mk_cval(size_of(dtype), DT_INT); ast = mk_binop(OP_MUL, ast, ast1, DT_INT); } else ast = mk_cval(size_of(dtype), DT_INT); ast = mk_binop(OP_MUL, ast, nelems, DT_INT); ast = mk_binop(OP_ADD, PTV(PT_IOLENGTH), ast, DT_INT); ast = mk_assn_stmt(PTV(PT_IOLENGTH), ast, DT_INT); (void)add_stmt_after(ast, (int)STD_PREV(0)); } external_io = TRUE; nondevice_io = TRUE; goto end_IO_STMT; /* * ::= WAIT ) | */ case IO_STMT21: (void)misc_io_checks("WAIT"); iomsg_check(); UNIT_CHECK; kwd_errchk(BT_WAIT); PT_CHECK(PT_ID, astb.ptr0); sptr = mk_iofunc(RTE_f90io_wait, DT_INT, 0); fix_iostat(); (void)begin_io_call(A_FUNC, sptr, 4); (void)add_io_arg(PTARG(PT_UNIT)); (void)add_io_arg(mk_cval(bitv, DT_INT)); (void)add_io_arg(PTARG(PT_IOSTAT)); (void)add_io_arg(PTARG(PT_ID)); ast = end_io_call(); ast = add_cgoto(ast); external_io = TRUE; nondevice_io = TRUE; goto end_IO_STMT; /* * ::= FLUSH */ case IO_STMT22: (void)misc_io_checks("FLUSH"); iomsg_check(); kwd_errchk(BT_FLUSH); rtlRtn = RTE_f90io_flush; goto rewind_shared; /* ------------------------------------------------------------------ */ /* * ::= | */ case UNIT_INFO1: noparens = TRUE; break; /* * ::= ) */ case UNIT_INFO2: break; /* * ::= ) */ case UNIT_INFO3: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case UNIT_DATA_LIST1: break; /* * ::= , | */ case UNIT_DATA_LIST2: break; /* * ::= */ case UNIT_DATA_LIST3: break; /* ------------------------------------------------------------------ */ /* * ::= UNIT = | */ case UNIT_DATA1: PT_SET(PT_UNIT); break; /* * ::= ERR = | */ case UNIT_DATA2: bitv |= BITV_ERR; PT_SET(PT_ERR); PTV(PT_ERR) = SST_SYMG(RHS(3)); /* sptr not ast */ nondevice_io = TRUE; break; /* * ::= IOSTAT = | */ case UNIT_DATA3: bitv |= BITV_IOSTAT; PT_SET(PT_IOSTAT); chk_var(RHS(3), PT_IOSTAT, DT_INT); PTV(PT_IOSTAT) = SST_ASTG(RHS(3)); set_assn(sym_of_ast(SST_ASTG(RHS(3)))); nondevice_io = TRUE; break; /* * ::= IOMSG = */ case UNIT_DATA4: bitv |= BITV_IOMSG; PT_SET(PT_IOMSG); chk_var(RHS(3), PT_IOMSG, DT_CHAR); PTV(PT_IOMSG) = SST_ASTG(RHS(3)); nondevice_io = TRUE; break; /* * ::= NEWUNIT = | */ case UNIT_DATA5: if (PTV(PT_UNIT) && !PTS(PT_NEWUNIT)) { IOERR2(201, "UNIT and NEWUNIT are mutually exclusive"); break; } PT_SET(PT_NEWUNIT); chk_var(RHS(3), PT_NEWUNIT, SST_DTYPEG(RHS(3))); PTV(PT_UNIT) = PTV(PT_NEWUNIT); PT_VARREF(PT_UNIT, PTVARREF(PT_NEWUNIT)); set_assn(sym_of_ast(SST_ASTG(RHS(3)))); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case UNIT_ID1: nondevice_io = TRUE; chk_unitid(RHS(1)); break; /* * ::= * */ case UNIT_ID2: if (scn.stmtyp != TK_READ && scn.stmtyp != TK_WRITE && scn.stmtyp != TK_PRINT) IOERR2(201, "UNIT=*"); chk_unitid((SST *)NULL); unit_star = TRUE; break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case SPEC_LIST1: break; /* * ::= */ case SPEC_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case SPEC_ITEM1: break; /* * ::= STATUS = | */ case SPEC_ITEM2: PT_SET(PT_STATUS); chk_expr(RHS(3), PT_STATUS, DT_CHAR); nondevice_io = TRUE; break; /* * ::= FILE = | */ case SPEC_ITEM3: PT_SET(PT_FILE); filename_type = TY_CHAR; if (DTY(SST_DTYPEG(RHS(3))) == TY_NCHAR) { filename_type = TY_NCHAR; chk_expr(RHS(3), PT_FILE, DT_NCHAR); } else chk_expr(RHS(3), PT_FILE, DT_CHAR); nondevice_io = TRUE; break; /* * ::= NAME = | */ case SPEC_ITEM4: /* string of either CHAR or NCHAR type may be used for file name: */ PT_SET(PT_NAME); filename_type = TY_CHAR; if (DTY(SST_DTYPEG(RHS(3))) == TY_NCHAR) { filename_type = TY_NCHAR; chk_expr(RHS(3), PT_NAME, DT_NCHAR); } else chk_expr(RHS(3), PT_NAME, DT_CHAR); nondevice_io = TRUE; break; /* * ::= ACCESS = | */ case SPEC_ITEM5: PT_SET(PT_ACCESS); chk_expr(RHS(3), PT_ACCESS, DT_CHAR); nondevice_io = TRUE; break; /* * ::= FORM = | */ case SPEC_ITEM6: PT_SET(PT_FORM); chk_expr(RHS(3), PT_FORM, DT_CHAR); nondevice_io = TRUE; break; /* * ::= RECL = | */ case SPEC_ITEM7: i = PT_RECL; dtype = DT_INT8; nondevice_io = TRUE; goto var_or_expr_spec; /* * ::= BLANK = | */ case SPEC_ITEM8: i = PT_BLANK; dtype = DT_CHAR; rw03 = TRUE; nondevice_io = TRUE; goto inq_var_or_expr_spec; /* * ::= DISPOSE = | */ case SPEC_ITEM9: PT_SET(PT_DISPOSE); if (flg.standard) error(171, 2, gbl.lineno, "DISPOSE", CNULL); chk_expr(RHS(3), PT_DISPOSE, DT_CHAR); nondevice_io = TRUE; break; /* * ::= READONLY | */ case SPEC_ITEM10: PT_SET(PT_ACTION); PTV(PT_ACTION) = mk_cnst(getstring("read", strlen("read"))); nondevice_io = TRUE; break; /* * ::= READ = | */ case SPEC_ITEM11: PT_SET(PT_READ); chk_var(RHS(3), PT_READ, DT_CHAR); nondevice_io = TRUE; break; /* * ::= WRITE = | */ case SPEC_ITEM12: PT_SET(PT_WRITE); chk_var(RHS(3), PT_WRITE, DT_CHAR); nondevice_io = TRUE; break; /* * ::= READWRITE = | */ case SPEC_ITEM13: PT_SET(PT_READWRITE); chk_var(RHS(3), PT_READWRITE, DT_CHAR); nondevice_io = TRUE; break; /* * ::= ACTION = | */ case SPEC_ITEM14: i = PT_ACTION; dtype = DT_CHAR; nondevice_io = TRUE; goto var_or_expr_spec; /* * ::= DELIM = | */ case SPEC_ITEM15: i = PT_DELIM; dtype = DT_CHAR; rw03 = TRUE; nondevice_io = TRUE; goto inq_var_or_expr_spec; /* * ::= PAD = | */ case SPEC_ITEM16: i = PT_PAD; dtype = DT_CHAR; rw03 = TRUE; nondevice_io = TRUE; goto inq_var_or_expr_spec; /* * ::= POSITION = | */ case SPEC_ITEM17: i = PT_POSITION; dtype = DT_CHAR; nondevice_io = TRUE; /* goto var_or_expr_spec; */ var_or_expr_spec: PT_SET(i); if (scn.stmtyp == TK_OPEN) chk_expr(RHS(3), i, dtype); else chk_var(RHS(3), i, dtype); break; /* * ::= EXIST = | */ case SPEC_ITEM18: PT_SET(PT_EXIST); chk_var(RHS(3), PT_EXIST, DT_LOG); nondevice_io = TRUE; break; /* * ::= OPENED = | */ case SPEC_ITEM19: PT_SET(PT_OPENED); chk_var(RHS(3), PT_OPENED, DT_LOG); nondevice_io = TRUE; break; /* * ::= NUMBER = | */ case SPEC_ITEM20: PT_SET(PT_NUMBER); chk_var(RHS(3), PT_NUMBER, DT_INT8); nondevice_io = TRUE; break; /* * ::= NAMED = | */ case SPEC_ITEM21: PT_SET(PT_NAMED); chk_var(RHS(3), PT_NAMED, DT_LOG); nondevice_io = TRUE; break; /* * ::= SEQUENTIAL = | */ case SPEC_ITEM22: PT_SET(PT_SEQUENTIAL); chk_var(RHS(3), PT_SEQUENTIAL, DT_CHAR); nondevice_io = TRUE; break; /* * ::= DIRECT = | */ case SPEC_ITEM23: PT_SET(PT_DIRECT); chk_var(RHS(3), PT_DIRECT, DT_CHAR); nondevice_io = TRUE; break; /* * ::= FORMATTED = | */ case SPEC_ITEM24: PT_SET(PT_FORMATTED); chk_var(RHS(3), PT_FORMATTED, DT_CHAR); nondevice_io = TRUE; break; /* * ::= UNFORMATTED = | */ case SPEC_ITEM25: PT_SET(PT_UNFORMATTED); chk_var(RHS(3), PT_UNFORMATTED, DT_CHAR); nondevice_io = TRUE; break; /* * ::= NEXTREC = | */ case SPEC_ITEM26: PT_SET(PT_NEXTREC); chk_var(RHS(3), PT_NEXTREC, DT_INT8); nondevice_io = TRUE; break; /* * ::= FMT = | */ case SPEC_ITEM27: PT_SET(PT_FMT); nondevice_io = TRUE; break; /* * ::= REC = | */ case SPEC_ITEM28: PT_SET(PT_REC); chk_expr(RHS(3), PT_REC, DT_INT); nondevice_io = TRUE; break; /* * ::= End = | */ case SPEC_ITEM29: bitv |= BITV_END; PT_SET(PT_END); PTV(PT_END) = SST_SYMG(RHS(3)); /* sptr not ast */ nondevice_io = TRUE; break; /* * ::= NML = | */ case SPEC_ITEM30: nondevice_io = TRUE; PT_SET(PT_NML); sptr = refsym(SST_SYMG(RHS(3)), OC_OTHER); if (STYPEG(sptr) != ST_NML) { IOERR2(213, SYMNAME(sptr)); break; } nml_io: PTV(PT_NML) = mk_id(get_nml_array(sptr)); if (fmttyp != FT_UNFORMATTED) { if (fmttyp == FT_NML) IOERR2(202, "NML"); else IOERR(212); } fmttyp = FT_NML; nml_group = sptr; REFP(sptr, 1); /* ref ==> must be initialized */ for (i = CMEMFG(sptr); i; i = NML_NEXT(i)) { sptr = NML_SPTR(i); if (SCG(sptr) == SC_NONE) sem_set_storage_class(sptr); } break; /* * ::= | */ case SPEC_ITEM31: nondevice_io = TRUE; if (SST_IDG(RHS(1)) == S_IDENT) { if (STYPEG(SST_SYMG(RHS(1))) == ST_NML) { sptr = refsym(SST_SYMG(RHS(1)), OC_OTHER); goto nml_io; } } if (!PTV(PT_UNIT)) chk_unitid(RHS(1)); else chk_fmtid(RHS(1)); break; /* * ::= * | */ case SPEC_ITEM32: if (scn.stmtyp != TK_READ && scn.stmtyp != TK_WRITE && scn.stmtyp != TK_PRINT) IOERR2(201, "UNIT=*"); if (PTV(PT_UNIT)) chk_fmtid((SST *)NULL); else { chk_unitid((SST *)NULL); unit_star = TRUE; } break; /* * ::= ADVANCE = | */ case SPEC_ITEM33: if (DI_IN_NEST(sem.doif_depth, DI_DOCONCURRENT)) error(1050, ERR_Severe, gbl.lineno, "I/O statement ADVANCE specifier in", CNULL); nondevice_io = TRUE; PT_SET(PT_ADVANCE); bitv |= BITV_ADVANCE; chk_expr(RHS(3), PT_ADVANCE, DT_CHAR); break; /* * ::= EOR = | */ case SPEC_ITEM34: nondevice_io = TRUE; bitv |= BITV_EOR; PT_SET(PT_EOR); PTV(PT_EOR) = SST_SYMG(RHS(3)); /* sptr not ast */ break; /* * ::= CONVERT = | */ case SPEC_ITEM35: nondevice_io = TRUE; PT_SET(PT_CONVERT); chk_expr(RHS(3), PT_CONVERT, DT_CHAR); break; /* * ::= SHARED | */ case SPEC_ITEM36: nondevice_io = TRUE; PT_SET(PT_SHARED); PTV(PT_SHARED) = mk_cnst(getstring("shared", strlen("shared"))); break; /* * ::= ID = | */ case SPEC_ITEM37: nondevice_io = TRUE; PT_SET(PT_ID); chk_var(RHS(3), PT_ID, DT_INT); break; /* * ::= PENDING = | */ case SPEC_ITEM38: nondevice_io = TRUE; PT_SET(PT_PENDING); chk_var(RHS(3), PT_PENDING, DT_LOG); break; /* * ::= POS = | */ case SPEC_ITEM39: nondevice_io = TRUE; i = PT_POS; dtype = DT_INT8; goto inq_var_or_expr_spec; /* * ::= SIZE = | */ case SPEC_ITEM40: nondevice_io = TRUE; PT_SET(PT_SIZE); bitv |= BITV_SIZE; gen_spec_item_tmp(RHS(3), PT_SIZE, DT_INT8); break; /* * ::= ASYNCHRONOUS = | */ case SPEC_ITEM41: nondevice_io = TRUE; i = PT_ASYNCHRONOUS; dtype = DT_CHAR; goto inq_var_or_expr_spec; /* * ::= DECIMAL = | */ case SPEC_ITEM42: nondevice_io = TRUE; i = PT_DECIMAL; dtype = DT_CHAR; rw03 = TRUE; open03 = TRUE; goto inq_var_or_expr_spec; /* * ::= ENCODING = | */ case SPEC_ITEM43: nondevice_io = TRUE; i = PT_ENCODING; dtype = DT_CHAR; rw03 = TRUE; open03 = TRUE; goto inq_var_or_expr_spec; break; /* * ::= SIGN = | */ case SPEC_ITEM44: nondevice_io = TRUE; i = PT_SIGN; dtype = DT_CHAR; open03 = TRUE; rw03 = TRUE; goto inq_var_or_expr_spec; /* * ::= STREAM = | */ case SPEC_ITEM45: nondevice_io = TRUE; PT_SET(PT_STREAM); chk_var(RHS(3), PT_STREAM, DT_CHAR); break; /* * ::= ROUND = */ case SPEC_ITEM46: nondevice_io = TRUE; i = PT_ROUND; dtype = DT_CHAR; open03 = TRUE; rw03 = TRUE; /* fall thru */ inq_var_or_expr_spec: PT_SET(i); if (scn.stmtyp == TK_INQUIRE) chk_var(RHS(3), i, dtype); else chk_expr(RHS(3), i, dtype); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case FORMAT_ID1: nondevice_io = TRUE; chk_fmtid(RHS(1)); break; /* * ::= * */ case FORMAT_ID2: chk_fmtid((SST *)NULL); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case FID_OR_NID1: if (!XBIT(137, 0x010000)) nondevice_io = TRUE; if (SST_IDG(RHS(1)) == S_IDENT) { sptr = refsym(SST_SYMG(RHS(1)), OC_OTHER); if (STYPEG(sptr) == ST_NML) goto nml_io; } chk_fmtid(RHS(1)); break; /* * ::= * */ case FID_OR_NID2: chk_fmtid((SST *)NULL); unit_star = TRUE; break; /* ------------------------------------------------------------------ */ /* * ::= */ case PRINT_SPEC1: chk_unitid((SST *)NULL); noparens = TRUE; if (unit_star) print_star = TRUE; goto io_init; /* ------------------------------------------------------------------ */ /* * ::= ) | */ case IO_SPEC1: goto io_init; /* ------------------------------------------------------------------ */ /* * ::= ) | */ case READ_SPEC21: goto io_init; /* * ::= | */ case READ_SPEC22: /* fall thru */ /* ------------------------------------------------------------------ */ /* * ::= */ case READ_SPEC31: /* fall thru */ /* ------------------------------------------------------------------ */ /* * ::= */ case READ_SPEC41: chk_unitid((SST *)NULL); noparens = TRUE; io_init: if (PTS(PT_POS) && PTS(PT_REC)) { IOERR2(201, "Both POS and REC cannot be specified"); } UNIT_CHECK; PT_CHECK(PT_REC, astb.ptr0); if (PTV(PT_POS)) { ast = PTV(PT_POS); if (A_DTYPEG(ast) != DT_INT8) ast = mk_convert(ast, DT_INT8); ast1 = mk_unop(OP_VAL, astb.i1, DT_INT4); ast2 = mk_unop(OP_VAL, ast, DT_INT8); sptr = mk_iofunc(RTE_f90io_aux_init, DT_INT, 0); (void)begin_io_call(A_CALL, sptr, 2); (void)add_io_arg(ast1); (void)add_io_arg(ast2); (void)add_stmt_after(io_call.ast, (int)STD_PREV(0)); } iomsg_check(); if (fmttyp == FT_UNFORMATTED) { if (intern) IOERR(211); if (PTV(PT_ASYNCHRONOUS) || PTV(PT_ID)) { PT_CHECK(PT_ASYNCHRONOUS, astb.ptr0c); PT_CHECK(PT_ID, astb.ptr0); sptr = mk_iofunc(RTE_f90io_unf_asynca, DT_INT, 0); (void)begin_io_call(A_CALL, sptr, 2); (void)add_io_arg(PTARG(PT_ASYNCHRONOUS)); (void)add_io_arg(PTARG(PT_ID)); (void)add_stmt_after(io_call.ast, (int)STD_PREV(0)); } sptr = mk_iofunc(unf_nm[LARGE_ARRAY_IDX][BYTE_SWAPPED_IO_IDX].init, DT_INT, 0); fix_iostat(); (void)begin_io_call(A_FUNC, sptr, 5); (void)add_io_arg(mk_cval(is_read, DT_INT)); (void)add_io_arg(PTARG(PT_UNIT)); (void)add_io_arg(PTARG(PT_REC)); (void)add_io_arg(mk_cval(bitv, DT_INT)); (void)add_io_arg(PTARG(PT_IOSTAT)); ast = end_io_call(); if (rw03) { if (PTV(PT_BLANK)) IOERR2(201, PTNAME(PT_BLANK)); if (PTV(PT_DECIMAL)) IOERR2(201, PTNAME(PT_DECIMAL)); if (PTV(PT_DELIM)) IOERR2(201, PTNAME(PT_DELIM)); if (PTV(PT_PAD)) IOERR2(201, PTNAME(PT_PAD)); if (PTV(PT_ROUND)) IOERR2(201, PTNAME(PT_ROUND)); if (PTV(PT_SIGN)) IOERR2(201, PTNAME(PT_SIGN)); } } else { /* FORMATTED I/O */ if (fmttyp == FT_LIST_DIRECTED) PTV(PT_FMT) = astb.ptr0; else if (fmttyp == FT_NML) PTV(PT_FMT) = astb.ptr0; else if (fmttyp == FT_FMTSTR) { /* * a character variable be initialized with the character * constant construct from the edit list in the FORMAT * statement. Can't treat this the same as FT_CHARACTER * because we may not know the actual length at the time * of the read/write statement. * Just issue a call to the encode routine which expects a * a character variable and record the fact that it was called. */ if (fmt_is_var) { /* * integer variable containing the address of a character * string. */ fmt_is_var = 0; sptr = mk_iofunc(RTE_f90io_encode_fmtv, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 1); } else { sptr = mk_iofunc(RTE_f90io_encode_fmta, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 3); (void)add_io_arg(mk_cval((INT)ty_to_lib[TY_CHAR], DT_INT)); (void)add_io_arg(astb.i1); } (void)add_io_arg(PTARG(PT_FMT)); ast = end_io_call(); PTV(PT_FMT) = astb.ptr0; fmttyp = FT_CHARACTER; /* FMTSTR is now the same as character*/ } else if (fmttyp != FT_ENCODED) { /* * if an unencoded format string is to be used in this * statement, first issue a call to the encode routine * and record the fact that it was called. */ sptr = mk_iofunc(RTE_f90io_encode_fmta, DT_INT, 0); ast = PTV(PT_FMT); ast1 = mk_cval((INT)ty_to_lib[DTYG(A_DTYPEG(ast))], DT_INT); (void)begin_io_call(A_FUNC, sptr, 3); (void)add_io_arg(ast1); /* kind of format string */ if (fmt_length) (void)add_io_arg(fmt_length); /* number of elements */ else /* * if fmt_length is zero, then the unencoded format * character string is just a scalar, constant, subscripted * reference, or substring reference. Use the calling * convention to pass its length. */ (void)add_io_arg(astb.i1); (void)add_io_arg(ast); /* format string */ ast = end_io_call(); PTV(PT_FMT) = astb.ptr0; } if (intern) { /* INTERNAL I/O */ /* * construct AST's to represent the number of array * elements of the character array or variable specified * as the unit id and the size of each record. */ LOGICAL is_array; LOGICAL noncontig; /* non-contiguous array */ int asd, i, ndim; noncontig = FALSE; ast = ast3 = PTV(PT_UNIT); if (DTY(A_DTYPEG(ast)) != TY_ARRAY) is_array = FALSE; else is_array = TRUE; again: switch (A_TYPEG(ast)) { case A_ID: sptr = A_SPTRG(ast); goto do_intern; case A_MEM: sptr = A_SPTRG(A_MEMG(ast)); if (is_array && DTY(DTYPEG(sptr)) != TY_ARRAY) { noncontig = TRUE; break; } do_intern: /* 'ast' is a scalar or whole array */ if (DTY(DTYPEG(sptr)) != TY_ARRAY) /* a scalar */ ast2 = astb.i1; else if (ASUMSZG(sptr)) ast2 = astb.i0; else if (POINTERG(sptr)) { /* A possible section. Copy it to a contiguous * temporary. */ noncontig = TRUE; } else { ast2 = AD_NUMELM(AD_PTR(sptr)); } break; case A_SUBSCR: /* assume an array element (or an irregular section, * which is an error) */ ast2 = astb.i1; asd = A_ASDG(ast); ndim = ASD_NDIM(asd); for (i = 0; i < ndim; ++i) { int ss = ASD_SUBS(asd, i); if (A_TYPEG(ss) == A_TRIPLE) noncontig = TRUE; else if (A_SHAPEG(ss)) { /* a vector subscript -- illegal! */ error(155, 3, gbl.lineno, "An internal file cannot be a character " "array with a vector subscript", ""); noncontig = FALSE; is_array = FALSE; break; } } if (noncontig) break; noncontig = is_array; break; case A_SUBSTR: ast = A_LOPG(ast); /* the 'parent' char scalar or * array section variable. 'ast3' * stores the A_SUBSTR AST. */ if (is_array) { noncontig = TRUE; break; } goto again; default: interr("semantio-int.io, bad ast", ast, 3); } if (noncontig) { /* A noncontiguous array: * + array section * + array substring * + array%member * + array%member(subscript) * + ... * Copy it to a contiguous temporary. */ intern_array = ast3; intern_tmp = copy_replic_sect_to_tmp(intern_array); PTV(PT_UNIT) = intern_tmp; ast2 = AD_NUMELM(AD_PTR(A_SPTRG(intern_tmp))); } /* * since the UNIT is character, its length is passed as * the last argument. We rely on the passing mechanism * to effect this. IF we have a situation where this * isn't true, we'll need to make this section conditional * on the target. */ fix_iostat(); if (fmttyp == FT_LIST_DIRECTED) { if (is_read) rtlRtn = RTE_f90io_ldr_intern_inita; else rtlRtn = RTE_f90io_ldw_intern_inita; sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 4); (void)add_io_arg(PTARG(PT_UNIT)); (void)add_io_arg(ast2); (void)add_io_arg(mk_cval(bitv, DT_INT)); (void)add_io_arg(PTARG(PT_IOSTAT)); ast = end_io_call(); } else if (fmttyp == FT_NML) { /* Namelist I/O */ if (is_read) rtlRtn = RTE_f90io_nmlr_intern_inita; else rtlRtn = RTE_f90io_nmlw_intern_inita; sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 4); (void)add_io_arg(PTARG(PT_UNIT)); (void)add_io_arg(ast2); (void)add_io_arg(mk_cval(bitv, DT_INT)); (void)add_io_arg(PTARG(PT_IOSTAT)); ast = end_io_call(); } else { if (is_read) rtlRtn = fmt_init[1].read[fmt_is_var]; else rtlRtn = fmt_init[1].write[fmt_is_var]; sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 5); (void)add_io_arg(PTARG(PT_UNIT)); (void)add_io_arg(ast2); (void)add_io_arg(mk_cval(bitv, DT_INT)); (void)add_io_arg(PTARG(PT_IOSTAT)); (void)add_io_arg(PTARG(PT_FMT)); ast = end_io_call(); } } else { /* EXTERNAL I/O */ fix_iostat(); if (fmttyp == FT_LIST_DIRECTED) { if (is_read) rtlRtn = RTE_f90io_ldr_init; else if (!print_star) rtlRtn = RTE_f90io_ldw_init; else rtlRtn = RTE_f90io_print_init; sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 4); (void)add_io_arg(PTARG(PT_UNIT)); (void)add_io_arg(PTARG(PT_REC)); (void)add_io_arg(mk_cval(bitv, DT_INT)); (void)add_io_arg(PTARG(PT_IOSTAT)); ast = end_io_call(); } else if (fmttyp == FT_NML) { if (is_read) rtlRtn = RTE_f90io_nmlr_init; else rtlRtn = RTE_f90io_nmlw_init; sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 4); (void)add_io_arg(PTARG(PT_UNIT)); (void)add_io_arg(PTARG(PT_REC)); (void)add_io_arg(mk_cval(bitv, DT_INT)); if (bitv & BITV_IOSTAT) (void)add_io_arg(PTARG(PT_IOSTAT)); else (void)add_io_arg(mk_fake_iostat()); ast = end_io_call(); } else { if (is_read) { rtlRtn = fmt_init[0].read[fmt_is_var]; sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 7); } else { rtlRtn = fmt_init[0].write[fmt_is_var]; sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 6); } (void)add_io_arg(PTARG(PT_UNIT)); (void)add_io_arg(PTARG(PT_REC)); (void)add_io_arg(mk_cval(bitv, DT_INT)); (void)add_io_arg(PTARG(PT_IOSTAT)); (void)add_io_arg(PTARG(PT_FMT)); if (is_read) { PT_CHECK(PT_SIZE, astb.ptr0); (void)add_io_arg(PTARG(PT_SIZE)); } PT_CHECK(PT_ADVANCE, astb.ptr0c); (void)add_io_arg(PTARG(PT_ADVANCE)); ast = end_io_call(); } } if (rw03) { if (is_read) { if (PTV(PT_DELIM)) IOERR2(201, PTNAME(PT_DELIM)); if (PTV(PT_SIGN)) IOERR2(201, PTNAME(PT_SIGN)); } else { if (PTV(PT_BLANK)) IOERR2(201, PTNAME(PT_BLANK)); if (PTV(PT_PAD)) IOERR2(201, PTNAME(PT_PAD)); } if (fmttyp == FT_LIST_DIRECTED) { if (is_read) { rtlRtn = RTE_f90io_ldr_init03a; PT_CHECK(PT_BLANK, astb.ptr0c); PT_CHECK(PT_DECIMAL, astb.ptr0c); PT_CHECK(PT_PAD, astb.ptr0c); PT_CHECK(PT_ROUND, astb.ptr0c); sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 5); (void)add_io_arg(A_DESTG(ast)); (void)add_io_arg(PTARG(PT_BLANK)); (void)add_io_arg(PTARG(PT_DECIMAL)); (void)add_io_arg(PTARG(PT_PAD)); (void)add_io_arg(PTARG(PT_ROUND)); } else { rtlRtn = RTE_f90io_ldw_init03a; if (PTV(PT_ROUND)) IOERR2(201, PTNAME(PT_ROUND)); PT_CHECK(PT_DECIMAL, astb.ptr0c); PT_CHECK(PT_DELIM, astb.ptr0c); PT_CHECK(PT_SIGN, astb.ptr0c); sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 4); (void)add_io_arg(A_DESTG(ast)); (void)add_io_arg(PTARG(PT_DECIMAL)); (void)add_io_arg(PTARG(PT_DELIM)); (void)add_io_arg(PTARG(PT_SIGN)); } ast = end_io_call(); } else if (fmttyp == FT_NML) { if (is_read) { rtlRtn = RTE_f90io_nmlr_init03a; PT_CHECK(PT_BLANK, astb.ptr0c); PT_CHECK(PT_DECIMAL, astb.ptr0c); PT_CHECK(PT_PAD, astb.ptr0c); PT_CHECK(PT_ROUND, astb.ptr0c); sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 5); (void)add_io_arg(A_DESTG(ast)); (void)add_io_arg(PTARG(PT_BLANK)); (void)add_io_arg(PTARG(PT_DECIMAL)); (void)add_io_arg(PTARG(PT_PAD)); (void)add_io_arg(PTARG(PT_ROUND)); } else { rtlRtn = RTE_f90io_nmlw_init03a; if (PTV(PT_ROUND)) IOERR2(201, PTNAME(PT_ROUND)); PT_CHECK(PT_DECIMAL, astb.ptr0c); PT_CHECK(PT_DELIM, astb.ptr0c); PT_CHECK(PT_SIGN, astb.ptr0c); sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 4); (void)add_io_arg(A_DESTG(ast)); (void)add_io_arg(PTARG(PT_DECIMAL)); (void)add_io_arg(PTARG(PT_DELIM)); (void)add_io_arg(PTARG(PT_SIGN)); } ast = end_io_call(); } else { if (is_read) { rtlRtn = RTE_f90io_fmtr_init03a; PT_CHECK(PT_BLANK, astb.ptr0c); PT_CHECK(PT_DECIMAL, astb.ptr0c); PT_CHECK(PT_PAD, astb.ptr0c); PT_CHECK(PT_ROUND, astb.ptr0c); sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 5); (void)add_io_arg(A_DESTG(ast)); (void)add_io_arg(PTARG(PT_BLANK)); (void)add_io_arg(PTARG(PT_DECIMAL)); (void)add_io_arg(PTARG(PT_PAD)); (void)add_io_arg(PTARG(PT_ROUND)); } else { rtlRtn = RTE_f90io_fmtw_init03a; if (PTV(PT_DELIM)) IOERR2(201, PTNAME(PT_DELIM)); PT_CHECK(PT_DECIMAL, astb.ptr0c); PT_CHECK(PT_SIGN, astb.ptr0c); PT_CHECK(PT_ROUND, astb.ptr0c); sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 4); (void)add_io_arg(A_DESTG(ast)); (void)add_io_arg(PTARG(PT_DECIMAL)); (void)add_io_arg(PTARG(PT_SIGN)); (void)add_io_arg(PTARG(PT_ROUND)); } ast = end_io_call(); } /* * ast is an A_ASN of the form * z_io = ..._init03(...) */ } } ast = add_cgoto(ast); break; /* ------------------------------------------------------------------ */ /* * ::= ) */ case ENCODE_SPEC1: if (flg.standard) error(171, 2, gbl.lineno, "ENCODE/DECODE", CNULL); if (fmttyp == FT_FMTSTR) { /* * a character variable be initialized with the character * constant construct from the edit list in the FORMAT * statement. Can't treat this the same as FT_CHARACTER * because we may not know the actual length at the time * of the read/write statement. * Just issue a call to the encode routine which expects a * a character variable and record the fact that it was called. */ if (fmt_is_var) { /* * integer variable contiaining address of a character * string. */ fmt_is_var = 0; sptr = mk_iofunc(RTE_f90io_encode_fmtv, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 1); } else { sptr = mk_iofunc(RTE_f90io_encode_fmta, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 3); (void)add_io_arg(mk_cval((INT)ty_to_lib[TY_CHAR], DT_INT)); (void)add_io_arg(astb.i1); } (void)add_io_arg(PTARG(PT_FMT)); ast = end_io_call(); PTV(PT_FMT) = astb.ptr0; fmttyp = FT_CHARACTER; /* FMTSTR is now the same as character*/ } else if (fmttyp != FT_ENCODED) { /* * if an unencoded format string is to be used in this * statement, first issue a call to the encode routine * and record the fact that it was called. */ sptr = mk_iofunc(RTE_f90io_encode_fmta, DT_INT, 0); ast = PTV(PT_FMT); ast1 = mk_cval((INT)ty_to_lib[DTYG(A_DTYPEG(ast))], DT_INT); (void)begin_io_call(A_FUNC, sptr, 3); (void)add_io_arg(ast1); /* kind of format string */ if (fmt_length) (void)add_io_arg(fmt_length); /* number of elements */ else (void)add_io_arg(astb.i1); (void)add_io_arg(ast); /* format string */ ast = end_io_call(); PTV(PT_FMT) = astb.ptr0; } ast1 = mk_cval(is_read, DT_INT); /* read flag */ ast2 = astb.i1; /* # of records is always 1 */ fix_iostat(); /* * decode-/encode- specific init routines are called. * Need to pass the 'loc' of the buffer to avoid passing * the length of the buffer if character; this also implies * the corresponding argument of the called function will be * a '**'. The actual length of the buffer is passed as an * explicit argument. */ (void)sym_mkfunc_nodesc(mkRteRtnNm(RTE_loc), DT_ADDR); SST_UNITP(RHS(2), mk_unop(OP_LOC, SST_UNITG(RHS(2)), DT_PTR)); if (fmttyp == FT_LIST_DIRECTED) { if (is_read) rtlRtn = RTE_f90io_ldr_intern_inite; else rtlRtn = RTE_f90io_ldw_intern_inite; sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 5); (void)add_io_arg((int)SST_UNITG(RHS(2))); (void)add_io_arg(ast2); (void)add_io_arg(mk_cval(bitv, DT_INT)); (void)add_io_arg(PTARG(PT_IOSTAT)); (void)add_io_arg((int)SST_LENG(RHS(2))); } else { if (is_read) rtlRtn = fmt_inite.read[fmt_is_var]; else rtlRtn = fmt_inite.write[fmt_is_var]; sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 6); (void)add_io_arg((int)SST_UNITG(RHS(2))); (void)add_io_arg(ast2); (void)add_io_arg(mk_cval(bitv, DT_INT)); (void)add_io_arg(PTARG(PT_IOSTAT)); (void)add_io_arg(PTARG(PT_FMT)); (void)add_io_arg((int)SST_LENG(RHS(2))); } ast = end_io_call(); ast = add_cgoto(ast); break; /* ------------------------------------------------------------------ */ /* * ::= , , */ case ENCODE_UNIT1: if (is_varref(RHS(5))) { (void)mkarg(RHS(5), &dum); ast1 = SST_ASTG(RHS(5)); } else { IOERR(217); ast1 = astb.i0; } (void)chk_scalartyp(RHS(1), DT_INT, FALSE); SST_LENP(LHS, SST_ASTG(RHS(1))); SST_UNITP(LHS, ast1); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ENCODE_CTL1: break; /* * ::= , */ case ENCODE_CTL2: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case OUTPUT_LIST1: ((IOL *)SST_ENDG(RHS(1)))->next = (IOL *)SST_BEGG(RHS(3)); SST_ENDP(RHS(1), SST_ENDG(RHS(3))); break; /* * ::= , ) | */ case OUTPUT_LIST2: ((IOL *)SST_ENDG(RHS(2)))->next = (IOL *)SST_BEGG(RHS(4)); SST_ENDP(RHS(2), SST_ENDG(RHS(4))); *LHS = *RHS(2); break; /* * ::= */ case OUTPUT_LIST3: sem.defined_io_seen = 0; break; /* ------------------------------------------------------------------ */ /* * ::= | */ case OUTPUT_ITEM1: dtype = SST_DTYPEG(RHS(1)); if (DTY(dtype) == TY_ARRAY) dtype = DTY(dtype + 1); if (DTY(dtype) == TY_DERIVED && UNLPOLYG(DTY(dtype + 3))) { error(155, 4, gbl.lineno, "Unlimited polymorphic object not allowed" " in list directed I/O", CNULL); } if (DTYG(SST_DTYPEG(RHS(1))) == TY_DERIVED && (A_TYPEG(SST_ASTG(RHS(1))) == A_FUNC || /* Allocate a temporary ast to store the value of the derived type array * reference whose subscript is a function reference, otherwise the * function would be incorrectly called in each component I/O. */ (A_TYPEG(SST_ASTG(RHS(1))) == A_SUBSCR && A_CALLFGG(SST_ASTG(RHS(1)))))) { ast = sem_tempify(RHS(1)); (void)add_stmt(ast); SST_IDP(RHS(1), S_IDENT); SST_ASTP(RHS(1), 0); SST_SYMP(RHS(1), A_SPTRG(A_DESTG(ast))); } if (DTY(dtype) == TY_DERIVED) { i = dtype_has_defined_io(dtype); if (i & (DT_IO_FWRITE | DT_IO_UWRITE)) { sem.defined_io_seen = 1; } sptr1 = 0; if (SST_IDG(RHS(1)) == S_SCONST) { sptr1 = SST_SYMG(RHS(1)); if (STYPEG(sptr1) == ST_TYPEDEF) { sptr = getcctmp_sc('t', sem.dtemps++, ST_VAR, SST_DTYPEG(RHS(1)), io_sc); sptr = init_derived_w_acl(sptr, SST_ACLG(RHS(1))); SST_IDP(RHS(1), S_IDENT); SST_ASTP(RHS(1), 0); SST_SYMP(RHS(1), sptr); SST_ALIASP(RHS(1), 0); SST_CVLENP(RHS(1), 0); SST_SHAPEP(RHS(1), 0); } } } goto io_item_shared; /* * ::= , ) */ case OUTPUT_ITEM2: goto implied_do_shared; /* ------------------------------------------------------------------ */ /* * ::= , | */ case INPUT_LIST1: ((IOL *)SST_ENDG(RHS(1)))->next = (IOL *)SST_BEGG(RHS(3)); SST_ENDP(RHS(1), SST_ENDG(RHS(3))); break; /* * ::= */ case INPUT_LIST2: sem.defined_io_seen = 0; break; /* ------------------------------------------------------------------ */ /* * ::= | */ case INPUT_ITEM1: if (SST_IDG(RHS(1)) != S_DERIVED && !is_varref(RHS(1))) IOERR(214); dtype = SST_DTYPEG(RHS(1)); if (DTY(dtype) == TY_ARRAY) dtype = DTY(dtype + 1); if (DTY(dtype) == TY_DERIVED) { i = dtype_has_defined_io(dtype); if (i & (DT_IO_FREAD | DT_IO_UREAD)) { sem.defined_io_seen = 1; } } io_item_shared: dtype = SST_DTYPEG(RHS(1)); ast1 = ast3 = SST_ASTG(RHS(1)); if (A_TYPEG(ast1) == A_SUBSTR) ast1 = A_LOPG(ast1); if (SST_IDG(RHS(1)) == S_LVALUE && DTY(dtype) == TY_ARRAY && A_TYPEG(ast1) == A_SUBSCR) { /* * If an input item is an array section containing vector * subscripts, the dimensions containing the vector subscripts * must be scalarized. Ultimately, the io item will be classified * as an 'expression', and the ast for the item will be a subscript * ast bounded by do 'begin-end' pairs, one for each vector * subscript; if more than one vector subscript appears, the * resulting loops will be nested, where the left-most vector * subscript is the innermost loop, etc. The bounds of each do * are derived from the shape of the index vector. */ IOL *iol_var; /* iol item representing the io item if any * vector subscripts are present. */ LOGICAL isvec; /* any subscripts which are triples */ LOGICAL ischar; /* base type is character */ LOGICAL anydiff; /* any difficult subscripts found */ LOGICAL anyvec; /* any vector subscripts found */ isvec = FALSE; ischar = FALSE; anydiff = FALSE; anyvec = FALSE; dtype = DTY(dtype + 1); if (DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) ischar = TRUE; iolptr = NULL; /* previous dobegin which was emitted */ doend = NULL; /* last doend emitted */ asd = A_ASDG(ast1); numdim = ASD_NDIM(asd); /* get number of subscripts */ for (i = 0; i < numdim; i++) { int asd2, ss2; /* look for difficult subscripts */ ast2 = ASD_SUBS(asd, i); switch (A_TYPEG(ast2)) { case A_ID: case A_TRIPLE: break; case A_SUBSCR: /* if only a single dimension with triplet subscript, ok */ asd2 = A_ASDG(ast2); if (ASD_NDIM(asd2) != 1) { anydiff = TRUE; } else if (A_TYPEG(ASD_SUBS(asd2, 0)) != A_TRIPLE) { anydiff = TRUE; } break; default: if (A_SHAPEG(ast2)) anydiff = TRUE; } } for (i = 0; !anydiff && i < numdim; i++) { int shp; ast2 = ASD_SUBS(asd, i); if (A_TYPEG(ast2) == A_TRIPLE && !ischar) isvec = TRUE; else if ((shp = A_SHAPEG(ast2)) || (ischar && A_TYPEG(ast2) == A_TRIPLE)) { IOL *iol_tmp; anyvec = TRUE; /* vector subscript */ if (iolptr == NULL) { /* create the semantic stack and IOL representing the * subscripted form of the input item. */ stkptr = (SST *)getitem(0, sizeof(SST)); *stkptr = *RHS(1); iol_var = (IOL *)getitem(0, sizeof(IOL)); iol_var->id = IE_EXPR; iol_var->next = NULL; iol_var->element = stkptr; iol_var->l_std = 0; iolptr = iol_var; } /* create a DOINFO record for this vector; the index * variable is a compiler-created temporary and the bounds * are extracted from the shape of the index vector. */ doinfo = get_doinfo(0); sptr = get_temp(DT_INT); doinfo->index_var = sptr; if (A_TYPEG(ast2) == A_TRIPLE) { doinfo->init_expr = A_LBDG(ast2); doinfo->limit_expr = A_UPBDG(ast2); doinfo->step_expr = A_STRIDEG(ast2); if (doinfo->step_expr == 0) doinfo->step_expr = astb.i1; } else { doinfo->init_expr = SHD_LWB(shp, 0); doinfo->limit_expr = SHD_UPB(shp, 0); doinfo->step_expr = SHD_STRIDE(shp, 0); } doinfo->count = mk_binop(OP_SUB, doinfo->limit_expr, doinfo->init_expr, DT_INT); doinfo->count = mk_binop(OP_ADD, doinfo->count, doinfo->step_expr, DT_INT); doinfo->count = mk_binop(OP_DIV, doinfo->count, doinfo->step_expr, DT_INT); /* * Create the DOBEGIN IOL for this index. Its 'next' * pointer is just the previous dobegin or the IOL * of the subscripted form. */ dobegin = (IOL *)getitem(0, sizeof(IOL)); dobegin->id = IE_DOBEGIN; dobegin->next = iolptr; dobegin->doinfo = doinfo; dobegin->l_std = 0; /* * Create the DOEND IOL for this index; ensure that * the previous doend, if present, is linked to this doend. * If this is the first do pair, the IOL representing the * item is linked to this doend. */ iol_tmp = (IOL *)getitem(0, sizeof(IOL)); if (doend) doend->next = iol_tmp; else iolptr->next = iol_tmp; doend = iol_tmp; doend->id = IE_DOEND; doend->next = NULL; doend->doinfo = doinfo; doend->l_std = 0; iolptr = dobegin; /* * prepare the subscript for this dimension; it's just * a subscripted reference of the index vector and the * subscript is the DO index variable. */ dum = mk_id(sptr); if (A_TYPEG(ast2) == A_TRIPLE) { ast2 = dum; } else if (A_TYPEG(ast2) == A_SUBSCR) { /* must have been single subscript */ ast2 = mk_subscr(A_LOPG(ast2), &dum, 1, DT_INT); } else { ast2 = mk_subscr(ast2, &dum, 1, DT_INT); } } subs[i] = ast2; } if (iolptr) { /* vector subscripts were found; if any triples were present, * the type of the reference is still array */ dtype = SST_DTYPEG(RHS(1)); if (!isvec) dtype = DTY(dtype + 1); /* * Create the subscripted form of the io item; fill in the * item's semantic stack entry. */ ast1 = mk_subscr((int)A_LOPG(ast1), subs, numdim, dtype); stkptr = iol_var->element; SST_IDP(stkptr, S_LVALUE); SST_DTYPEP(stkptr, dtype); /* if this is a substring, recreate the substring */ if (A_TYPEG(ast3) == A_SUBSTR) ast1 = mk_substr(ast1, A_LEFTG(ast3), A_RIGHTG(ast3), dtype); SST_ASTP(stkptr, ast1); if (!isvec) SST_SHAPEP(stkptr, 0); /* * define the begin and end fields for this item; they are * just the last dobegin and doend IOLs created. */ SST_BEGP(LHS, (ITEM *)dobegin); SST_ENDP(LHS, (ITEM *)doend); break; } } count = 0; sptr1 = 0; if (SST_IDG(RHS(1)) == S_IDENT || SST_IDG(RHS(1)) == S_DERIVED) sptr1 = SST_SYMG(RHS(1)); else if (SST_IDG(RHS(1)) == S_LVALUE) sptr1 = SST_LSYMG(RHS(1)); dtype = SST_DTYPEG(RHS(1)); if (sptr1 && DTYG(dtype) == TY_DERIVED) { /* derived, get_derived_iolptrs() sets up LHS with a list of iolptrs representing the derived object*/ dtype = DDTG(DTYPEG(sptr1)); if (dtype_has_defined_io(dtype) & functype[is_read][fmttyp]) { stkptr = (SST *)getitem(0, sizeof(SST)); *stkptr = *RHS(1); iolptr = (IOL *)getitem(0, sizeof(IOL)); iolptr->id = IE_EXPR; iolptr->next = NULL; iolptr->element = stkptr; iolptr->l_std = 0; SST_BEGP(LHS, (ITEM *)iolptr); SST_ENDP(LHS, (ITEM *)iolptr); break; } (void)mkarg(RHS(1), &dum); sptr1 = refsym(sptr1, OC_OTHER); SST_SYMP(RHS(1), sptr1); get_derived_iolptrs(LHS, sptr1, RHS(1)); } else { /* * guard against the item being c_loc() */ if (DTY(dtype) == TY_DERIVED && A_TYPEG(ast1) == A_INTR && is_iso_cptr(dtype)) { error(155, 3, gbl.lineno, "A derived type containing private " "components cannot be an I/O item", CNULL); } stkptr = (SST *)getitem(0, sizeof(SST)); *stkptr = *RHS(1); iolptr = (IOL *)getitem(0, sizeof(IOL)); iolptr->id = IE_EXPR; iolptr->next = NULL; iolptr->element = stkptr; iolptr->l_std = 0; SST_BEGP(LHS, (ITEM *)iolptr); SST_ENDP(LHS, (ITEM *)iolptr); } break; /* * ::= ) | */ case INPUT_ITEM2: *LHS = *RHS(2); break; /* * ::= , ) */ case INPUT_ITEM3: implied_do_shared: doinfo = (DOINFO *)SST_BEGG(RHS(4)); sptr = doinfo->index_var; if (flg.smp || flg.accmp) is_dovar_sptr(doinfo->index_var); dtype = DTYPEG(sptr); iolptr = (IOL *)SST_BEGG(RHS(2)); if (DT_ISINT(dtype) && iolptr == (IOL *)SST_ENDG(RHS(2)) && iolptr->id == IE_EXPR) { /* * check for an optimizable DO loop; the conditions which must be * satisfied are: * 1. The DO index is integer. * 2. the I/O list consists of a single subscripted array without * a substring specification. Also, the array may not be a * structure member. * 3. one subscript is the DO index variable. * 4. the remaining subscripts are either ICON or ILD of a variable * not the DO index variable. * 5. no subscript checking */ /* * Determine if the I/O list item is a subscripted array -- */ stkptr = iolptr->element; if (SST_IDG(stkptr) == S_IDENT || SST_IDG(stkptr) == S_CONST || SST_IDG(stkptr) == S_ACONST) goto not_optz; ast1 = SST_ASTG(stkptr); if (A_TYPEG(ast1) != A_SUBSCR) goto not_optz; if (DTY(A_DTYPEG(ast1)) == TY_CHAR || !DT_ISBASIC(A_DTYPEG(ast1))) goto not_optz; asd = A_ASDG(ast1); /* scan through the subscripts */ numdim = ASD_NDIM(asd); /* get number of subscripts */ dim = -1; for (i = 0; i < numdim; i++) { ast2 = ASD_SUBS(asd, i); switch (A_TYPEG(ast2)) { case A_CNST: /* constant is okay */ break; case A_ID: /* check load */ if (A_SPTRG(ast2) != sptr) break; if (dim >= 0) /* another use of index */ goto not_optz; dim = i; break; /* subscript is okay */ case A_CONV: ast3 = A_LOPG(ast2); if (A_TYPEG(ast3) != A_ID || A_SPTRG(ast3) != sptr || dim >= 0) { goto not_optz; } dim = i; break; default: /* anything else is not okay */ goto not_optz; } subs[i] = ast2; /* remember subscript just in case */ } if (dim < 0) /* index variable not used as subscript */ goto not_optz; /* * Finally have determined that the implied DO can be optimized * into a single call -- a new subscript ast needs to be created * with a triple replacing the index variable in the corresponding * dimension. The triple will represent the section * ::. * All other dimension will have a triple of :. */ for (i = 0; i < numdim; i++) if (i == dim) { int l, u, s; l = doinfo->init_expr; u = doinfo->limit_expr; s = doinfo->step_expr; if (XBIT(68, 0x1) && A_DTYPEG(subs[dim]) == DT_INT8 && size_of(A_DTYPEG(l)) < 8) { l = mk_convert(l, DT_INT8); u = mk_convert(u, DT_INT8); if (s) s = mk_convert(s, DT_INT8); } subs[dim] = mk_triple(l, u, s); } else subs[i] = ASD_SUBS(asd, i); ast1 = mk_subscr((int)A_LOPG(ast1), subs, numdim, (int)A_DTYPEG(A_LOPG(ast1))); SST_DTYPEP(stkptr, A_DTYPEG(ast1)); SST_ASTP(stkptr, ast1); iolptr->id = IE_OPTDO; iolptr->doinfo = doinfo; *LHS = *RHS(2); break; } not_optz: dobegin = (IOL *)getitem(0, sizeof(IOL)); dobegin->id = IE_DOBEGIN; dobegin->next = iolptr; dobegin->doinfo = doinfo; dobegin->l_std = 0; doend = (IOL *)getitem(0, sizeof(IOL)); doend->id = IE_DOEND; doend->next = NULL; doend->doinfo = doinfo; doend->l_std = 0; SST_BEGP(LHS, (ITEM *)dobegin); ((IOL *)(SST_ENDG(RHS(2))))->next = doend; SST_ENDP(LHS, (ITEM *)doend); /* * STDs could have been added since the beginning left paren. * Since the DO begin is generated later in the parse, these STDs * will appear before the DO. For the STDs added since the beginning * left paren, remove these from the STD list and attach them to the * dobegin; when the DO is generated these STDs will be added after the * DO begin. Examples of when STDs may be added are when referencing * functions/intrinsics which turn into 'calls'. */ { int s, s1, s2, t; s = SST_ASTG(RHS(1)); /* STD generated when left paren seen */ s1 = STD_NEXT(s); /* STD generated after left paren */ s2 = SST_ASTG(RHS(4)); /* STD generated before do expressions*/ if (s != s2) { /* Unlink the list of stds added after the left paren and * before the implied do expressions and add to the dobegin's * iol structure. Stds s1 through s2, inclusive, mark the * list to be moved. * * Before: * s <-> s1 <-> ... <-> s2 <-> t * After: * s s1 <-> ... <-> s2 t * | | * +<------------------------->+ */ dobegin->l_std = s1; t = STD_NEXT(s2); STD_NEXT(s) = t; STD_PREV(t) = s; STD_NEXT(s2) = 0; } else dobegin->l_std = 0; } break; /* ------------------------------------------------------------------ */ /* * ::= ( ) | */ case FORMAT_STMT1: end_format: put_edit(FED_END); /* note that the last rp is not put out */ PUT(rescan); sptr = SST_SYMG(RHS(1)); /* locate format list */ PLLENP(sptr, fasize); /* number of 32-bit elements */ DINITP(sptr, 1); /* sym_is_refd(sptr); REF set when it appears in a read/write stmt */ dinit_put(DINIT_END, 0); SST_ASTP(LHS, 0); break; /* * ::= ( ) | */ case FORMAT_STMT2: rescan = 0; fasize = 2; /* number of 32-bit elements */ goto end_format; /* * ::= FORMAT | */ case FORMAT_STMT3: /* * The format array is actually a data initialized character variable. * The initializing value is the character constant constructed by the * scanner from the format edit list. */ if (scn.currlab == 0) IOERR(203); sptr = get_fmt_array(scn.currlab, ST_VAR); FMTPTP(scn.currlab, sptr); DEFDP(scn.currlab, 1); scn.currlab = 0; sptr1 = SST_SYMG(RHS(2)); DTYPEP(sptr, DTYPEG(sptr1)); DINITP(sptr, 1); DCLDP(sptr, 1); HCCSYMP(sptr, 1); dinit_put(DINIT_LOC, sptr); dinit_put(DINIT_STR, (INT)sptr1); dinit_put(DINIT_END, 0); SST_ASTP(LHS, 0); break; /* * ::= ( ) */ case FORMAT_STMT4: goto end_format; /* ------------------------------------------------------------------ */ /* * ::= FORMAT */ case FORMAT1: if (scn.currlab == 0) IOERR(203); sptr = get_fmt_array(scn.currlab, ST_PLIST); CCSYMP(sptr, 1); SCP(sptr, SC_STATIC); DTYPEP(sptr, DT_INT); FMTPTP(scn.currlab, sptr); DEFDP(scn.currlab, 1); scn.currlab = 0; dinit_put(DINIT_FMT, (INT)sptr); #if DEBUG if (DBGBIT(3, 128)) fprintf(gbl.dbgfil, "Format(%4d) %s:\n", gbl.lineno, getprint(sptr)); #endif fasize = 0; rescan = 0; /* default rescan is to the item after the very * first left paren. NOTE: the outermost left * parenthesis does not occur in the list */ lastrpt = -999; last_edit = FED_LPAREN; edit_state = 0; SST_SYMP(LHS, sptr); /* pass up "array" of encoded format */ break; /* ------------------------------------------------------------------ */ /* * ::= | */ case FORMAT_LIST1: break; /* * ::= */ case FORMAT_LIST2: break; /* * ::= */ case FORMAT_LIST3: error(W_0548_Incorrect_use_of_unlimited_repetition, flg.standard ? ERR_Severe : ERR_Warning, gbl.lineno, CNULL, CNULL); break; /* * ::= */ case FORMAT_LIST4: error(W_0548_Incorrect_use_of_unlimited_repetition, flg.standard ? ERR_Severe : ERR_Warning, gbl.lineno, CNULL, CNULL); break; /* * ::= | */ case FORMAT_LIST_UNL1: break; /* * ::= | */ case FORMAT_LIST_UNL2: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case FORMAT_ITEM1: if (flg.standard) { switch (edit_state) { case 0: /* initial state - process first edit descriptor */ ERR170("comma after left parenthesis in FORMAT"); edit_state = 2; break; case 1: /* an edit descr. was just seen */ if (last_edit == FED_LPAREN) ERR170("comma after left parenthesis in FORMAT"); edit_state = 2; break; case 2: /* a comma was just seen */ ERR170("comma after comma in FORMAT"); edit_state = 1; break; case 3: /* a colon or slash was just seen */ edit_state = 2; break; } } last_edit = -101; /* fake code for ED_COMMA */ break; /* * ::= / | */ case FORMAT_ITEM2: put_edit(FED_SLASH); break; /* * ::= : | */ case FORMAT_ITEM3: put_edit(FED_COLON); break; /* * ::= | */ case FORMAT_ITEM5: put_edit(FED_KANJI_STRING); sptr = SST_SYMG(RHS(1)); goto string_shared; /* * ::= | */ case FORMAT_ITEM4: put_edit(FED_STR); sptr = SST_SYMG(RHS(1)); goto string_shared; /* * ::= | */ case FORMAT_ITEM6: put_edit(FED_STR); sptr = CONVAL1G(SST_SYMG(RHS(1))); string_shared: dtype = DTYPEG(sptr); len = string_length(dtype); PUT(len); dinit_put(DT_CHAR, (INT)sptr); if (DTY(DT_INT) == TY_INT8) { /* pad out data init if len not divisible by 8 */ len = (len + 7) & ~7; fasize += len >> 3; } else { /* pad out data init if len not divisible by 4 */ len = (len + 3) & ~3; fasize += len >> 2; } break; /* * ::= | */ case FORMAT_ITEM7: break; /* * ::= | */ case FORMAT_ITEM8: break; /* * ::= | */ case FORMAT_ITEM9: put_edit(FED_P); put_ffield(RHS(1)); break; /* * ::= */ case FORMAT_ITEM10: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case REPEAT_FACTOR1: break; /* * ::= */ case REPEAT_FACTOR2: lastrpt = fasize; put_ffield(RHS(1)); if (SST_IDG(RHS(1)) == S_CONST && SST_CVALG(RHS(1)) == 0) IOERR(206); break; /* ------------------------------------------------------------------ */ /* * ::= P | */ case SCALE_FACTOR1: break; /* * ::= P */ case SCALE_FACTOR2: if (SST_OPTYPEG(RHS(1)) == OP_ADD) *LHS = *RHS(2); else { /* negate */ #if DEBUG assert(SST_IDG(RHS(2)) == S_CONST, "semantio:exp.-P", 0, 3); #endif SST_IDP(LHS, S_CONST); SST_CVALP(LHS, -SST_CVALG(RHS(2))); SST_ASTP(LHS, mk_cval(SST_CVALG(LHS), DT_INT)); } break; /* ------------------------------------------------------------------ */ /* * ::= ) | */ case F1_ITEM1: rescan = SST_RNG2G(RHS(1)); put_edit(FED_RPAREN); PUT(SST_RNG1G(RHS(1))); break; /* * ::= I | */ case F1_ITEM2: put_edit(FED_Iw_m); put_ffield(RHS(2)); PUT(0); PUT(1); break; /* * ::= I . | */ case F1_ITEM3: put_edit(FED_Iw_m); put_ffield(RHS(2)); put_ffield(RHS(4)); break; /* * ::= A | */ case F1_ITEM4: put_edit(FED_Aw); put_ffield(RHS(2)); break; /* * ::= N | */ case F1_ITEM5: put_edit(FED_Nw); put_ffield(RHS(2)); break; /* * ::= L | */ case F1_ITEM6: put_edit(FED_Lw); put_ffield(RHS(2)); break; /* * ::= O | */ case F1_ITEM7: put_edit(FED_Ow_m); put_ffield(RHS(2)); PUT(0); PUT(1); break; /* * ::= O . | */ case F1_ITEM8: put_edit(FED_Ow_m); put_ffield(RHS(2)); put_ffield(RHS(4)); break; /* * ::= Z | */ case F1_ITEM9: put_edit(FED_Zw_m); put_ffield(RHS(2)); PUT(0); PUT(1); break; /* * ::= Z . | */ case F1_ITEM10: put_edit(FED_Zw_m); put_ffield(RHS(2)); put_ffield(RHS(4)); break; /* * ::= | */ case F1_ITEM11: put_edit(FED_A); break; /* * ::= | */ case F1_ITEM12: put_edit(FED_N); break; /* * ::= | */ case F1_ITEM13: put_edit(FED_L); break; /* * ::= | */ case F1_ITEM14: put_edit(FED_I); break; /* * ::= | */ case F1_ITEM15: put_edit(FED_O); break; /* * ::= | */ case F1_ITEM16: put_edit(FED_Z); break; /* * ::= B | */ case F1_ITEM17: put_edit(FED_Bw_m); put_ffield(RHS(2)); PUT(0); PUT(1); break; /* * ::= B . | */ case F1_ITEM18: put_edit(FED_Bw_m); put_ffield(RHS(2)); put_ffield(RHS(4)); break; /* * ::= ) */ case F1_ITEM19: error(W_0548_Incorrect_use_of_unlimited_repetition, ERR_Warning, gbl.lineno, CNULL, CNULL); rescan = SST_RNG2G(RHS(1)); put_edit(FED_RPAREN); PUT(SST_RNG1G(RHS(1))); break; /* ------------------------------------------------------------------ */ /* * ::= ( */ case FLP1: SST_RNG1P(LHS, fasize + 1); /* point to item which follows the * left paren */ if (lastrpt == fasize - 2) /* * a repeat count immediately preceded the paren. locate the * repeat count for the run-time (marks reversion). */ SST_RNG2P(LHS, fasize - 2); else /* * o.w., just point to the left paren */ SST_RNG2P(LHS, fasize); put_edit(FED_LPAREN); break; /* ------------------------------------------------------------------ */ /* * ::= F . | */ case F2_ITEM1: put_edit(FED_Fw_d); put_ffield(RHS(2)); put_ffield(RHS(4)); break; /* * ::= E . | */ case F2_ITEM2: put_edit(FED_Ew_d); put_ffield(RHS(2)); put_ffield(RHS(4)); break; /* * ::= G . | */ case F2_ITEM3: if (SST_CVALG(RHS(2)) == 0) { put_edit(FED_G0_d); } else { put_edit(FED_Gw_d); } put_ffield(RHS(2)); put_ffield(RHS(4)); break; /* * ::= E | */ case F2_ITEM4: switch (last_edit) { case FED_Ew_d: case FED_Gw_d: case FED_ESw_d: case FED_ENw_d: put_edit(FED_Ee); put_ffield(RHS(2)); break; default: IOERR(210); edit_state = 1; last_edit = FED_Ee; } break; /* * ::= D . | */ case F2_ITEM5: put_edit(FED_Dw_d); put_ffield(RHS(2)); put_ffield(RHS(4)); break; /* * ::= | */ case F2_ITEM6: put_edit(FED_F); break; /* * ::= | */ case F2_ITEM7: put_edit(FED_E); break; /* * ::= | */ case F2_ITEM8: put_edit(FED_G); break; /* * ::= | */ case F2_ITEM9: put_edit(FED_D); break; /* * ::= EN . | */ case F2_ITEM10: put_edit(FED_ENw_d); put_ffield(RHS(2)); put_ffield(RHS(4)); break; /* * ::= ES . */ case F2_ITEM11: put_edit(FED_ESw_d); put_ffield(RHS(2)); put_ffield(RHS(4)); break; /* * ::= */ case F2_ITEM12: put_edit(FED_DT); PUT(0); PUT(1); sptr = getstring("DT", 2); dtype = DTYPEG(sptr); len = string_length(dtype); PUT(0); PUT(len); dinit_put(DT_CHAR, (INT)sptr); if (DTY(DT_INT) == TY_INT8) { len = (len + 7) & ~7; fasize += len >> 3; } else { len = (len + 3) & ~3; fasize += len >> 2; } break; /* * ::= DT */ case F2_ITEM13: put_edit(FED_DT); if (SST_BEGG(RHS(2)) == 0 && SST_ENDG(RHS(2)) == 0) { char *str; /* */ PUT(0); PUT(1); sptr = SST_SYMG(RHS(2)); sptr = A_SPTRG(SST_ASTG(RHS(2))); strptr = malloc(strlen(stb.n_base + CONVAL1G(sptr)) + 3); str = strcpy(strptr, "DT"); str = strcat(strptr, stb.n_base + CONVAL1G(sptr)); sptr = getstring(str, strlen(strptr)); dtype = DTYPEG(sptr); len = string_length(dtype); PUT(0); PUT(len); dinit_put(DT_CHAR, (INT)sptr); /* pad out data init if len not divisible by 8 */ if (DTY(DT_INT) == TY_INT8) { len = (len + 7) & ~7; fasize += len >> 3; } else { len = (len + 3) & ~3; fasize += len >> 2; } } else if (SST_IDG(RHS(2)) == -1) { /* */ PUT(0); PUT(2); sptr = getstring("DT", 2); dtype = DTYPEG(sptr); len = string_length(dtype); PUT(0); PUT(len); dinit_put(DT_CHAR, (INT)sptr); if (DTY(DT_INT) == TY_INT8) { len = (len + 7) & ~7; fasize += len >> 3; } else { len = (len + 3) & ~3; fasize += len >> 2; } put_vlist(RHS(2)); break; } else { /* */ char *str; PUT(0); PUT(2); /*strcpy */ sptr = A_SPTRG(SST_ASTG(RHS(2))); strptr = malloc(strlen(stb.n_base + CONVAL1G(sptr)) + 3); str = strcpy(strptr, "DT"); str = strcat(strptr, stb.n_base + CONVAL1G(sptr)); sptr = getstring(str, strlen(str)); dtype = DTYPEG(sptr); len = string_length(dtype); PUT(0); PUT(len); dinit_put(DT_CHAR, (INT)sptr); /* pad out data init if len not divisible by 8 */ if (DTY(DT_INT) == TY_INT8) { len = (len + 7) & ~7; fasize += len >> 3; } else { len = (len + 3) & ~3; fasize += len >> 2; } put_vlist(RHS(2)); } break; /* * ::= */ case F2_ITEM14: put_edit(FED_G0); break; /* ------------------------------------------------------------------ */ /* * ::= T | */ case F3_ITEM1: put_edit(FED_T); put_ffield(RHS(2)); break; /* * ::= TL | */ case F3_ITEM2: put_edit(FED_TL); put_ffield(RHS(2)); break; /* * ::= TR | */ case F3_ITEM3: put_edit(FED_TR); put_ffield(RHS(2)); break; /* * ::= X | */ case F3_ITEM4: put_edit(FED_X); put_ffield(RHS(1)); break; /* * ::= X | */ case F3_ITEM5: put_edit(FED_X); PUT(0); PUT(1); break; /* * ::= S | */ case F3_ITEM6: put_edit(FED_S); break; /* * ::= SP | */ case F3_ITEM7: put_edit(FED_SP); break; /* * ::= SS | */ case F3_ITEM8: put_edit(FED_SS); break; /* * ::= BN | */ case F3_ITEM9: put_edit(FED_BN); break; /* * ::= BZ | */ case F3_ITEM10: put_edit(FED_BZ); break; /* * ::= DC | */ case F3_ITEM11: put_edit(FED_DC); break; /* * ::= DP | */ case F3_ITEM12: put_edit(FED_DP); break; /* * ::= Q | */ case F3_ITEM13: put_edit(FED_Q); break; /* * ::= '$' | */ case F3_ITEM14: put_edit(FED_DOLLAR); break; /* * ::= RU | */ case F3_ITEM15: put_edit(FED_RU); break; /* * ::= RD | */ case F3_ITEM16: put_edit(FED_RD); break; /* * ::= RZ | */ case F3_ITEM17: put_edit(FED_RZ); break; /* * ::= RN | */ case F3_ITEM18: put_edit(FED_RN); break; /* * ::= RC | */ case F3_ITEM19: put_edit(FED_RC); break; /* * ::= RP */ case F3_ITEM20: put_edit(FED_RP); break; /* ------------------------------------------------------------------ */ /* * ::= */ case DTS1: SST_CVALP(LHS, SST_CVALG(RHS(1))); SST_IDP(LHS, S_CONST); SST_DTYPEP(LHS, SST_DTYPEG(RHS(1))); SST_ASTP(LHS, mk_cval(SST_CVALG(LHS), SST_DTYPEG(RHS(1)))); SST_SYMP(LHS, A_SPTRG(SST_ASTG(LHS))); SST_ENDP(LHS, 0); SST_BEGP(LHS, 0); break; /* * ::=
) */ case DTS2: SST_BEGP(LHS, SST_BEGG(RHS(3))); SST_ENDP(LHS, SST_ENDG(RHS(3))); break; /* * ::=
) */ case DTS3: *LHS = *RHS(2); SST_IDP(LHS, -1); break; /* ------------------------------------------------------------------ */ /* *
::=
, *
::=
, *
::= *
::= */ case DT_VLIST1: case DT_VLIST2: case DT_VLIST3: case DT_VLIST4: count = DT_VLIST4 + 1 - rednum; // RHS symbol count: 4, 3, 2, or 1 if ((count == 2 || count == 4) && SST_OPTYPEG(RHS(count - 1)) == OP_SUB) SST_CVALP(RHS(count), -SST_CVALG(RHS(count))); // negate e1 = (SST *)getitem(0, sizeof(SST)); *e1 = *RHS(count); itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->t.stkp = e1; if (count <= 2) { SST_BEGP(LHS, itemp); } else { (SST_ENDG(RHS(1)))->next = itemp; } SST_ENDP(LHS, itemp); break; /* ------------------------------------------------------------------ */ /* * ::= */ case FFIELD1: SST_IDP(LHS, S_CONST); SST_ASTP(LHS, mk_cval(SST_CVALG(LHS), DT_INT)); SST_DTYPEP(LHS, DT_INT); break; /* * ::= ) */ case UNLIMITED_FORMAT_ITEM1: rescan = SST_RNG2G(RHS(2)); put_edit(FED_RPAREN); PUT(SST_RNG1G(RHS(2))); break; /* * ::= * */ case STAR_REPEAT1: lastrpt = fasize; PUT(0); PUT(0x7fffffff); break; default: interr("semantio: bad rednum ", rednum, 3); break; } return; end_IO_STMT: /* * common termination point for all I/O statments. */ if (gbl.currsub && PUREG(gbl.currsub) && external_io) error(155, 2, gbl.lineno, SYMNAME(gbl.currsub), "- PURE subprograms may not contain external I/O statements"); sem.io_stmt = FALSE; SST_ASTP(LHS, 0); } static int set_io_sc(void) { io_sc = SC_LOCAL; if (sem.task) io_sc = SC_PRIVATE; return io_sc; } /* * 'array_ast' is a character variable used as an internal I/O unit. * Its type is either: * A_SUBSCR: a regular section of a character array, or * A_SUBSTR: a substring whose parent is a regular section of a char array. * This copies 'array_ast' to a contiguous temporary array. The * temporary array is replicated, as is the original array, since * distribution of character arrays isn't supported. */ static int copy_replic_sect_to_tmp(int array_ast) { int asn, std, tmp_ast, tmp_sptr; int dtype; int eldtype; int subscr[MAXSUBS]; // AOCC /* allocate(tmp(...)) * tmp = array */ switch (A_TYPEG(array_ast)) { case A_SUBSCR: /* a regular section */ dtype = DTYPEG(sptr_of_subscript(array_ast)); break; default: /* a substring of a regular section or just some array */ dtype = A_DTYPEG(array_ast); break; } eldtype = DDTG(dtype); tmp_sptr = mk_shape_sptr(A_SHAPEG(array_ast), subscr, eldtype); tmp_ast = mk_id(tmp_sptr); asn = mk_assn_stmt(tmp_ast, array_ast, eldtype); std = add_stmt(asn); mk_mem_allocate(tmp_ast, subscr, std, array_ast); /* ...we call this after 'std = add_stmt( forall )' because * it adds stmts *before* 'std', so 'std' must be defined! */ return tmp_ast; } /* * Copies back the temporary array created by a prior call to * 'copy_replic_sect_to_tmp' to the original regular section. */ static void copy_back_to_replic_sect(int array_ast, int tmp_ast) { int asn, std; int dtype; int eldtype; /* array = tmp * deallocate(tmp) */ switch (A_TYPEG(array_ast)) { case A_SUBSCR: /* a regular section */ dtype = DTYPEG(sptr_of_subscript(array_ast)); break; default: /* a substring of a regular section or just some array */ dtype = A_DTYPEG(array_ast); break; } eldtype = DDTG(dtype); asn = mk_assn_stmt(array_ast, tmp_ast, eldtype); std = add_stmt_after(asn, STD_LAST); mk_mem_deallocate(tmp_ast, std); } /* ensure iostat locates an AST */ static void fix_iostat(void) { if (PTV(PT_IOSTAT) == 0) PTV(PT_IOSTAT) = astb.i0; } static int chk_SIZE_var() { int asn = 0; if (PTS(PT_SIZE) && PTTMPUSED(PT_SIZE) && PTVARREF(PT_SIZE) != 1) { /* if SIZE specified, assign SIZE tmp back to user data item */ asn = mk_assn_stmt(PTVARREF(PT_SIZE), mk_convert(PTV(PT_SIZE), A_DTYPEG(PTVARREF(PT_SIZE))), A_DTYPEG(PTVARREF(PT_SIZE))); } return asn; } /* Add test and branches for ERR=, END=, and EOR=. */ static int add_cgoto(int ast) { int lbsptr; int tmp; int last_ast; int inquire_cnt = 13; if (A_TYPEG(ast) == A_ASN) ast = A_DESTG(ast); last_ast = 0; if (strcmp(SYMNAME(A_SPTRG(A_LOPG(io_call.ast))), mkRteRtnNm(RTE_f90io_fmtr_end)) == 0 || strncmp(SYMNAME(A_SPTRG(A_LOPG(io_call.ast))), mkRteRtnNm(RTE_f90io_inquirea), inquire_cnt) == 0) { int asn = chk_SIZE_var(); if (asn) { add_stmt_after(asn, (int)STD_PREV(0)); PT_TMPUSED(PT_SIZE, 0); } } if ((lbsptr = PTV(PT_ERR)) != 0) /* == 1 => error */ last_ast = end_or_err(ast, lbsptr, astb.i1); if ((lbsptr = PTV(PT_END)) != 0) /* == 2 ==> end of file */ last_ast = end_or_err(ast, lbsptr, mk_cval((INT)2, DT_INT)); if ((lbsptr = PTV(PT_EOR)) != 0) /* == 3 ==> end of record */ last_ast = end_or_err(ast, lbsptr, mk_cval((INT)3, DT_INT)); return last_ast; } /* src - ast of variable assigned the value of the func */ /* elab - label of END=, ERR=, or EOR= */ /* eqval - ast of value which is compared with for equality */ /* * END= or ERR=; generate the ast sequence to test the value of an * i/o function and branch to the END=, ERR=, or EOR= label. We're * always comparing for inequality): * if ( io_call() .neq. eqval ) goto no-error-lab * * goto err_lab * no-error-lab: * NOTE: must end an i/o critical section if end or err is taken. */ static int end_or_err(int src, int elab, int eqval) { int tmp, ast2; int ast; int astlab; int std; int sz_asgn = chk_SIZE_var(); int no_error, ifexpr; tmp = mk_binop(OP_EQ, src, eqval, DT_LOG); /* * if condition is false, branch to no-error case - branch around * critical section code code. */ no_error = getlab(); ast = mk_stmt(A_IF, 0); ifexpr = mk_unop(OP_LNOT, tmp, DT_LOG); A_IFEXPRP(ast, ifexpr); ast2 = mk_stmt(A_GOTO, 0); astlab = mk_label(no_error); A_L1P(ast2, astlab); A_IFSTMTP(ast, ast2); ast = add_stmt_after(ast, (int)STD_PREV(0)); if (sz_asgn) { add_stmt_after(sz_asgn, (int)STD_PREV(0)); } ast = fio_end_err(0, elab); /* fall-thru to critical section end & br code */ RFCNTI(no_error); ast = mk_stmt(A_CONTINUE, 0); std = add_stmt_after(ast, (int)STD_PREV(0)); STD_LABEL(std) = no_error; return ast; } /* * If a ERR= or END= is taken and we need to "end" the i/o critical section, * a special block is written: * new-err/end-label: * fio_end(); * goto err/end-label; * NOTE that the conditional branch has been changed to reflect the new * label. */ /* lab - label of block of code to call fio_end & branch; * may be 0 -- block is not labeled */ /* elab - label of branch target */ static int fio_end_err(int lab, int elab) { int ast; int astlab; if (flg.smp || flg.accmp || XBIT(125, 0x1)) { if (flg.smp || flg.accmp) begin_io_call(A_CALL, sym_mkfunc_nodesc("_mp_ecs_nest", DT_NONE), 0); else (void)begin_io_call(A_CALL, mk_iofunc(RTE_f90io_end, DT_NONE, 0), 0); ast = end_io_call(); } if (lab) STD_LABEL(A_STDG(ast)) = lab; ast = mk_stmt(A_GOTO, 0); astlab = mk_label(elab); A_L1P(ast, astlab); (void)add_stmt_after(ast, (int)STD_PREV(0)); return ast; } static void chk_expr(SST *stk, int p, int dtype) { int dt; if (PTV(p)) IOERR2(202, PTNAME(p)); if (is_varref(stk)) PT_VARREF(p, 1); if (DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) (void)mkarg(stk, &dt); else if (DT_ISINT(dtype)) { (void)chktyp(stk, dtype, FALSE); dt = SST_DTYPEG(stk); } else { /* pass by value: */ (void)mkexpr(stk); dt = SST_DTYPEG(stk); } if (DTY(dt) != DTY(dtype)) IOERR2(201, PTNAME(p)); PTV(p) = SST_ASTG(stk); } static void gen_spec_item_tmp(SST *stk, int p, int dtype) { int dt; int sptr; int i; (void)mkarg(stk, &dt); PT_VARREF(p, SST_ASTG(stk)); sptr = getcctmp_sc('t', sem.dtemps++, ST_VAR, DTY(dtype), io_sc); SST_IDP(stk, S_IDENT); SST_SYMP(stk, sptr); SST_DTYPEP(stk, DTY(dtype)); (void)mkarg(stk, &dt); i = SST_ASTG(stk); PTV(p) = SST_ASTG(stk); if (A_TYPEG(PTVARREF(p)) == A_ID) { DOCHK(A_SPTRG(i)); } } static void chk_var(SST *stk, int p, int dtype) { int dt; int sptr; if (PTV(p)) /* repeated specifier */ IOERR2(202, PTNAME(p)); if (is_varref(stk)) { int i; PT_VARREF(p, 1); if (DTY(SST_DTYPEG(stk)) != DTY(dtype)) { if ((DT_ISINT(dtype) && DT_ISINT(SST_DTYPEG(stk))) || (DT_ISLOG(dtype) && DT_ISLOG(SST_DTYPEG(stk)))) { (void)mkarg(stk, &dt); PT_VARREF(p, SST_ASTG(stk)); sptr = getcctmp_sc('t', sem.dtemps++, ST_VAR, DTY(dtype), io_sc); SST_IDP(stk, S_IDENT); SST_SYMP(stk, sptr); SST_DTYPEP(stk, DTY(dtype)); } else { IOERR2(201, PTNAME(p)); SST_ASTP(stk, astb.i0); } } (void)mkarg(stk, &dt); i = SST_ASTG(stk); PTV(p) = SST_ASTG(stk); if (A_TYPEG(PTVARREF(p)) == A_ID) { DOCHK(A_SPTRG(i)); } } else { IOERR2(201, PTNAME(p)); SST_ASTP(stk, astb.i0); } } static void chk_unitid(SST *stk) { int dtype; INT unit; if (PTS(PT_NEWUNIT)) IOERR2(201, "UNIT and NEWUNIT are mutually exclusive"); else if (PTV(PT_UNIT)) /* error if repeated unit specification */ IOERR2(202, "UNIT"); if (stk == NULL) { /* * Unit id is the default unit ('*') */ if (XBIT(124, 0x4)) /* use -5 (stdin) or -6 (stdout) */ unit = -DEFAULT_UNIT; else /* use 5 or 6 */ unit = DEFAULT_UNIT; PTV(PT_UNIT) = mk_cval(unit, DT_INT); } else { dtype = SST_DTYPEG(stk); if (DT_ISINT(dtype)) /* * Unit id is an integer expression */ (void)chktyp(stk, DT_INT, FALSE); else if (DTYG(dtype) == TY_CHAR && (SST_IDG(stk) == S_IDENT || SST_IDG(stk) == S_LVALUE)) { /* * Unit id specifies an internal file -- a character variable, * a character array, a character array element, or a character * substring. */ (void)mkarg(stk, &dtype); intern = TRUE; if (no_rw) IOERR(211); else if (!is_read && gbl.currsub && PUREG(gbl.currsub)) { int sptr; sptr = sym_of_ast(SST_ASTG(stk)); if (SCG(sptr) == SC_CMBLK) error(155, 2, gbl.lineno, SYMNAME(gbl.currsub), "- PURE subprograms may not contain internal WRITE statements " "where the file unit is a common block variable"); } } else IOERR2(201, "UNIT"); PTV(PT_UNIT) = SST_ASTG(stk); } } static void chk_fmtid(SST *stk) { int dtype; int sptr, lab; char name[8]; ADSC *ad; fmt_is_var = 0; if (fmttyp != FT_UNFORMATTED) IOERR2(202, "FMT"); if (stk == NULL) { fmttyp = FT_LIST_DIRECTED; PTV(PT_FMT) = astb.i0; if (!is_read && unit_star) print_star = TRUE; } else { dtype = SST_DTYPEG(stk); if (legal_labelvar(dtype)) { /* If requested, a string is constructed by the scanner * from the edit list in the FORMAT statement. */ if (XBIT(58, 0x200)) /* similar check exists in scan.c:get_fmtstr() */ fmttyp = FT_FMTSTR; else fmttyp = FT_ENCODED; if (SST_IDG(stk) == S_CONST) { /* * format id is an integer constant representing the statement * label of a FORMAT statement. First, derive the "name" of the * label as in the