|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
00001 /* 00002 00003 Copyright (C) 2000, 2001, Silicon Graphics, Inc. All Rights Reserved. 00004 00005 This program is free software; you can redistribute it and/or modify it 00006 under the terms of version 2.1 of the GNU Lesser General Public License 00007 as published by the Free Software Foundation. 00008 00009 This program is distributed in the hope that it would be useful, but 00010 WITHOUT ANY WARRANTY; without even the implied warranty of 00011 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00012 00013 Further, this software is distributed without any warranty that it is 00014 free of the rightful claim of any third person regarding infringement 00015 or the like. Any license provided herein, whether implied or 00016 otherwise, applies only to this software file. Patent licenses, if 00017 any, provided herein do not apply to combinations of this program with 00018 other software, or any other product whatsoever. 00019 00020 You should have received a copy of the GNU Lesser General Public 00021 License along with this program; if not, write the Free Software 00022 Foundation, Inc., 59 Temple Place - Suite 330, Boston MA 02111-1307, 00023 USA. 00024 00025 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00026 Mountain View, CA 94043, or: 00027 00028 http://www.sgi.com 00029 00030 For further information regarding this notice, see: 00031 00032 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00033 00034 */ 00035 00036 00037 00038 #pragma ident "@(#) libf/fio/wnl90.c 92.3 10/12/99 13:16:22" 00039 00040 #include <stdio.h> 00041 #include <errno.h> 00042 #include <cray/nassert.h> 00043 #include <liberrno.h> 00044 #include "fio.h" 00045 #include "namelist.h" 00046 #include "wnl90def.h" 00047 00048 int _nlstrent(FIOSPTR css, unit *cup, nmlist_goli_t *nalist, 00049 int count, int errf, int bytofset); 00050 00051 int _wnl90to77(FIOSPTR css, unit *cup, nmlist_group *namlist, 00052 void *stck, int errf); 00053 00054 /* 00055 * _FWN - called by compiled Fortran programs to process a namelist 00056 * WRITE statement. 00057 * 00058 * Synopsis 00059 * 00060 * int _FWN( ControlListType *cilist, 00061 * nmlist_group *namlist, 00062 * void *stck); 00063 * 00064 * Where 00065 * 00066 * cilist - pointer to the control information list 00067 * information. This describes the specifiers 00068 * for the current I/O statement. 00069 * iolist - pointer to the namelist table. 00070 * stck - pointer to stack space which is passed 00071 * to each call to _FRU for a particular 00072 * statement. This is used by the library. 00073 * 00074 * Return value 00075 * 00076 * IO_OKAY, IO_END, or IO_ERR 00077 */ 00078 00079 int 00080 _FWN(ControlListType *cilist, nmlist_group *namlist, void *stck) 00081 { 00082 int errf; /* Error processing flag */ 00083 int errn; /* Error number */ 00084 unum_t unum; /* Actual unit number */ 00085 unit *cup; /* Pointer to unit table entry */ 00086 char *wptr; /* pointer to group name */ 00087 unsigned long wlen; /* group name length */ 00088 unsigned wcount; /* count of namelist items */ 00089 int icnt; 00090 char *varptr; /* ptr to group_obj_list_item */ 00091 unsigned long varlen; /* len to group_obj_list_item */ 00092 nmlist_goli_t *nlvar; /* ptr to next variable entry */ 00093 long eqlchr; /* hold nl equal character */ 00094 long sepchr; /* hold nl delimiter character */ 00095 long nlchr; /* hold nl group character */ 00096 long trmchr; /* hold nl terminator character */ 00097 int trmsize; /* size of terminator character */ 00098 FIOSPTR css; 00099 00100 /* 00101 * Assertions 00102 */ 00103 /* Validate that the size of *stck is large enough */ 00104 00105 assert (cilist->stksize >= sizeof(struct fiostate)/sizeof(long)); 00106 00107 /* The compiler flags namelist with fmt flag */ 00108 00109 assert ((cilist->fmt == CI_NAMELIST)); 00110 00111 /* The compiler disallows namelist with internal files */ 00112 00113 assert(!(cilist->internal && cilist->fmt == CI_NAMELIST)); 00114 00115 /* The compiler disallows namelist with direct files */ 00116 00117 assert(!(cilist->dflag && cilist->fmt == CI_NAMELIST)); 00118 00119 css = stck; 00120 errn = 0; 00121 00122 /**************************************************************************** 00123 * 00124 * Statement Initialization Section 00125 * 00126 ***************************************************************************/ 00127 00128 /* Establish error processing options */ 00129 00130 errf = (cilist->errflag || cilist->iostatflg); 00131 00132 if (cilist->uflag == CI_UNITASTERK) 00133 unum = STDOUT_U; 00134 else 00135 unum = *cilist->unit.wa; 00136 00137 STMT_BEGIN(unum, 0, T_WNL, NULL, css, cup); 00138 00139 if (cup == NULL) { /* If not connected */ 00140 00141 cup = _imp_open(css, SEQ, FMT, unum, errf, &errn); 00142 00143 /* 00144 * If the open failed, cup is NULL and errn contains 00145 * the error number. 00146 */ 00147 if (cup == NULL) 00148 goto finalization; 00149 } 00150 00151 /* All paths which lead here have set cup to a non-null value */ 00152 00153 assert ((cup != NULL)); /* cup assumed non-NULL */ 00154 00155 /* 00156 * Copy the user's error processing options into the unit table 00157 */ 00158 cup->uflag = (cilist->errflag ? _UERRF : 0) | 00159 (cilist->iostat_spec != NULL ? _UIOSTF : 0); 00160 00161 css->u.fmt.nonadv = 0; 00162 00163 /* If trying to write a file without write permission */ 00164 00165 if ((cup->uaction & OS_WRITE) == 0) { 00166 errn = FENOWRIT; /* No write permission */ 00167 ERROR0(errf, css, errn); 00168 } 00169 00170 /* If attempting formatted I/O on an unformatted file */ 00171 00172 if (!cup->ufmt) { 00173 errn = FEFMTTIV; /* Formatted not allowed */ 00174 ERROR0(errf, css, errn); 00175 } 00176 00177 /* Initialize fields in the Fortran statement state structure */ 00178 00179 css->u.fmt.icp = NULL; 00180 css->u.fmt.nonl = 0; 00181 00182 if (cup->useq == 0) { /* seq-io attempted on direct file */ 00183 errn = FESEQTIV; /* Sequential not allowed */ 00184 ERROR0(errf, css, errn); 00185 } 00186 00187 /* external sequential formatted I/O */ 00188 00189 if (cup->uend != BEFORE_ENDFILE) { 00190 /* 00191 * If positioned after an endfile, and the file does not 00192 * support multiple endfiles, a write is invalid. 00193 */ 00194 if (!cup->umultfil) { 00195 errn = FEWRAFEN; 00196 ERROR0(errf, css, errn); 00197 } 00198 /* 00199 * If a logical endfile record had just been read, replace 00200 * it with a physical endfile record before starting the 00201 * current data record. 00202 */ 00203 if (cup->uend == LOGICAL_ENDFILE) { 00204 if (XRCALL(cup->ufp.fdc, weofrtn)cup->ufp.fdc, 00205 &cup->uffsw) < 0) { 00206 errn = cup->uffsw.sw_error; 00207 ERROR0(errf, css, errn); 00208 } 00209 } 00210 cup->uend = BEFORE_ENDFILE; 00211 } 00212 00213 /* 00214 * Set up record size. The hierarchy for determining Namelist 00215 * output record size is as follows: 00216 * 1) RECL, if specified 00217 * 2) WNLLONG(), if set and does not exceed cup->urecsize 00218 * 3) list-directed output record size (cup->uldwsize) 00219 * 00220 * Note that while (1) and (3) are established at OPEN time, (2) 00221 * can be changed ``on the fly''; therefore, this check has to 00222 * be performed here. 00223 */ 00224 00225 cup->unmlsize = cup->uldwsize; 00226 00227 if (cup->urecl == 0 && _wnlrecsiz > 0) { 00228 /* RECL is not present but WNLLONG() set */ 00229 if (cup->uft90) 00230 cup->unmlsize = cup->urecsize; 00231 else { 00232 cup->unmlsize = MIN(cup->urecsize, _wnlrecsiz); 00233 } 00234 } 00235 00236 if (cup->pnonadv && cup->uwrt == 0) { 00237 /* 00238 * A formatted or list-directed write statement 00239 * follows a nonadvancing read. Switch the 00240 * current line (record) from read to write 00241 * mode. Then backspace the file so the 00242 * current record gets written back in place. 00243 */ 00244 00245 int cur_offset; 00246 cur_offset = cup->ulineptr - cup->ulinebuf; 00247 00248 cup->ulinemax = cur_offset + cup->ulinecnt; 00249 cup->ulinecnt = cur_offset; 00250 cup->uflshptr = cup->ulinebuf; 00251 00252 errn = _unit_bksp(cup); 00253 00254 if (errn != 0) { 00255 ERROR0(errf, css, errn); 00256 } 00257 } 00258 else if (cup->pnonadv == 0) { 00259 /* 00260 * There is no current record (due to a prior 00261 * nonadvancing read or write). Initialize 00262 * the empty line buffer. 00263 */ 00264 cup->ulinemax = 0; /* Highwater mark */ 00265 cup->ulineptr = cup->ulinebuf; 00266 cup->uflshptr = cup->ulinebuf; 00267 } 00268 00269 /* 00270 * If there is a current record then truncate the current record at 00271 * the current position and flush it if the current record 00272 * is already beyond unmlsize. 00273 */ 00274 if (cup->pnonadv) { 00275 errn = _lw_after_nonadv(css, cup, cup->unmlsize, 1); 00276 if (errn != 0) 00277 ERROR0(errf, css, errn); 00278 } 00279 00280 if (errn != 0) { 00281 ERROR0(errf, css, errn); 00282 } 00283 00284 css->u.fmt.endrec = _sw_endrec; 00285 cup->pnonadv = 0; 00286 cup->uwrt = 1; /* set write mode */ 00287 00288 /**************************************************************************** 00289 * 00290 * Data Transfer Section 00291 * 00292 ***************************************************************************/ 00293 00294 assert ((cup != NULL)); /* cup assumed non-NULL */ 00295 wcount = namlist->icount; /* count of list items */ 00296 00297 /* set up one set of variables to use where f90 or f77 mode */ 00298 00299 if (!(cup->uft90)) { 00300 errn = _wnl90to77(css,cup,namlist,stck,errf); 00301 goto finalization; 00302 } 00303 eqlchr = (long) '='; 00304 sepchr = (long) ','; 00305 nlchr = (long) '&'; 00306 trmchr = (long) '/'; 00307 trmsize = 3; 00308 /* 00309 * WNLFLAG for echo not accepted for Fortran 90, 00310 * use blank as first char 00311 */ 00312 NLCHAR(' '); /* write blank */ 00313 NLCHAR(nlchr); /* write ampersand */ 00314 00315 wptr = _fcdtocp(namlist->group_name); /* ptr to groupname */ 00316 wlen = _fcdlen(namlist->group_name); /* len of groupname */ 00317 00318 /* If length of groupname exceeds recl, put out an error */ 00319 00320 if ((wlen + 4) > cup->unmlsize) { 00321 errn = FENLNMSZ; 00322 ERROR0(errf, css, errn); 00323 } 00324 00325 /* Move namelist group name to output buffer */ 00326 00327 for (icnt = 0; icnt < wlen; icnt++) { 00328 *cup->ulineptr++ = *wptr++; 00329 cup->ulinemax++; 00330 } 00331 00332 NLCHAR(' '); /* write blank */ 00333 NLCHAR(' '); /* write blank */ 00334 00335 nlvar = namlist->goli; /* group object pointer */ 00336 00337 while (wcount--) { 00338 varptr = _fcdtocp(nlvar->goli_name); 00339 varlen = _fcdlen(nlvar->goli_name); 00340 00341 /* If length of variable name exceeds recl, put out an error */ 00342 00343 if (varlen > cup->unmlsize) { 00344 /* error: group object name too big for rec size */ 00345 errn = FENLNMSZ; 00346 ERROR0(errf, css, errn); 00347 } 00348 else 00349 if (varlen > (cup->unmlsize - cup->ulinemax)) { 00350 NLWFLUSH(); 00351 NLCHAR(' '); /* write blank */ 00352 NLCHAR(' '); /* write blank */ 00353 } 00354 00355 /* Write namelist group object name to output buffer */ 00356 00357 for (icnt = 0; icnt < varlen; icnt++) { 00358 *cup->ulineptr++ = varptr[icnt]; 00359 cup->ulinemax++; 00360 } 00361 00362 /* Flush output buffer if blank=blank will not fit */ 00363 00364 if ((cup->unmlsize - cup->ulinemax) < 3) { 00365 NLWFLUSH(); 00366 NLCHAR(' '); /* write blank */ 00367 } 00368 00369 /* Write equal size or replacement character after name */ 00370 00371 NLCHAR(' '); /* write blank */ 00372 NLCHAR(eqlchr); /* write equal sign */ 00373 NLCHAR(' '); /* write blank */ 00374 00375 /* Flag needed for first call to _ld_write per variable */ 00376 00377 css->u.fmt.u.le.ldwinit = 1; 00378 00379 /* Write the value of the namelist group object */ 00380 00381 switch (nlvar->valtype) { 00382 00383 case IO_SCALAR: 00384 { 00385 nmlist_scalar_t *nlscalar; /* nmlist scalar entry */ 00386 void *vaddr; 00387 type_packet tip; 00388 00389 nlscalar = nlvar->goli_addr.ptr; /* ptr to scalar */ 00390 tip.type90 = nlscalar->tinfo.type; 00391 tip.type77 = -1; 00392 tip.intlen = nlscalar->tinfo.int_len; 00393 tip.extlen = tip.intlen; 00394 tip.elsize = tip.intlen >> 3; 00395 tip.cnvindx = 0; 00396 tip.count = 1; 00397 tip.stride = 1; 00398 00399 /* Assertions */ 00400 00401 assert (tip.type90 >= DVTYPE_TYPELESS && 00402 tip.type90 <= DVTYPE_ASCII); 00403 assert (tip.intlen > 0); 00404 00405 if (tip.type90 == DVTYPE_ASCII) { 00406 vaddr = _fcdtocp(nlscalar->scal_addr.charptr); 00407 tip.elsize = tip.elsize * 00408 _fcdlen(nlscalar->scal_addr.charptr); 00409 } 00410 else 00411 vaddr = nlscalar->scal_addr.ptr; 00412 00413 /* Use list-directed write */ 00414 00415 errn = _ld_write(css, cup, vaddr, &tip, 0); 00416 00417 if (errn != 0) { 00418 ERROR0(errf, css, errn); 00419 } 00420 00421 /* Flush the list-directed output to the line buffer */ 00422 00423 errn = _ld_write(css, cup, (void *) NULL, 00424 &__tip_null, 0); 00425 00426 if (errn != 0) { 00427 ERROR0(errf, css, errn); 00428 } 00429 00430 break; 00431 } 00432 00433 case IO_DOPEVEC: 00434 { 00435 register short nc; 00436 register long extent; 00437 DopeVectorType *nldv; 00438 void *vaddr; 00439 type_packet tip; 00440 00441 nldv = nlvar->goli_addr.dv; /* ptr to dope vector */ 00442 00443 /* Assertions */ 00444 00445 assert (nldv != NULL); 00446 assert (nldv->type_lens.int_len > 0); 00447 00448 tip.type90 = nldv->type_lens.type; 00449 tip.type77 = -1; 00450 tip.intlen = nldv->type_lens.int_len; 00451 tip.extlen = tip.intlen; 00452 tip.elsize = tip.intlen >> 3; 00453 tip.cnvindx = 0; 00454 tip.stride = 1; 00455 00456 if (tip.type90 == DVTYPE_ASCII) { 00457 vaddr = _fcdtocp(nldv->base_addr.charptr); 00458 tip.elsize = tip.elsize * 00459 _fcdlen(nldv->base_addr.charptr); 00460 } 00461 else 00462 vaddr = nldv->base_addr.a.ptr; 00463 00464 extent = 1; 00465 00466 for (nc = 0; nc < nldv->n_dim; nc++) 00467 extent = extent * nldv->dimension[nc].extent; 00468 00469 /* Assertions */ 00470 00471 assert (tip.elsize > 0 && extent >= 0); 00472 00473 /* Use list-directed write */ 00474 00475 tip.count = extent; 00476 00477 errn = _ld_write(css, cup, vaddr, &tip, 0); 00478 00479 if (errn != 0) { 00480 ERROR0(errf, css, errn); 00481 } 00482 00483 /* Flush the list-directed output to the line buffer */ 00484 00485 errn = _ld_write(css, cup, (void *) NULL, 00486 &__tip_null, 0); 00487 00488 if (errn != 0) { 00489 ERROR0(errf, css, errn); 00490 } 00491 00492 break; 00493 } 00494 00495 case IO_STRUC_A: 00496 { 00497 register int bytofset; 00498 register long scount; 00499 nmlist_goli_t *vaddr; 00500 nmlist_struclist_t *nlstruc; /* nmlist struc entry */ 00501 00502 nlstruc = nlvar->goli_addr.sptr; /* ptr to struc */ 00503 vaddr = nlstruc->goli; /* ptr to list */ 00504 scount = nlstruc->structlen; /* number entries */ 00505 00506 /* Bytofset is zero for a scalar structure */ 00507 00508 bytofset = 0; 00509 00510 errn = _nlstrent(css, cup, vaddr, scount, errf, 00511 bytofset); 00512 00513 if (errn != 0) { 00514 ERROR0(errf, css, errn); 00515 } 00516 00517 break; 00518 } 00519 00520 case IO_STRUC_S: 00521 { 00522 register short nc; 00523 register int scount; 00524 register long elsize; 00525 register long extent; 00526 register long ic; 00527 nmlist_goli_t *vaddr; 00528 DopeVectorType *nlsdv; 00529 nmlist_struclist_t *nlstruc; /* nmlist struc entry */ 00530 00531 nlstruc = nlvar->goli_addr.sptr; /* ptr to struc */ 00532 scount = nlstruc->structlen; /* number entries */ 00533 vaddr = nlstruc->goli; /* ptr to list */ 00534 nlsdv = nlstruc->struc_addr.dv; /* ptr to dopevec */ 00535 elsize = nlsdv->base_addr.a.el_len; 00536 extent = 1; 00537 00538 for (nc = 0; nc < nlsdv->n_dim; nc++) 00539 extent = extent * nlsdv->dimension[nc].extent; 00540 00541 for (ic = 0; ic < extent; ic++) { 00542 register int bytofset; 00543 /* 00544 * bytofset is used when a structure is an 00545 * array of structures. Each component must 00546 * add an offset to its base address after 00547 * the first array element. Must change 00548 * bits to bytes 00549 */ 00550 bytofset = (elsize >> 3) * ic; 00551 errn = _nlstrent(css, cup, vaddr, 00552 scount, errf, bytofset); 00553 00554 if (errn != 0) { 00555 ERROR0(errf, css, errn); 00556 } 00557 } 00558 break; 00559 } 00560 00561 default: 00562 errn = FEINTUNK; 00563 ERROR0(errf, css, errn); 00564 } 00565 00566 /* Flush the list-directed output to the line buffer */ 00567 00568 errn = _ld_write(css, cup, (void *) NULL, &__tip_null, 0); 00569 00570 if (errn != 0) { 00571 ERROR0(errf, css, errn); 00572 } 00573 00574 if (OUT_LINE) { 00575 NLINE(); 00576 css->u.fmt.u.le.ldwinit = 1; /* suppress comma*/ 00577 } 00578 else 00579 if (wcount > 0) { 00580 if ((cup->unmlsize - cup->ulinemax) < 2) { 00581 NLWFLUSH(); 00582 NLCHAR(' '); /* write delimiter */ 00583 NLCHAR(' '); /* write delimiter */ 00584 css->u.fmt.u.le.ldwinit = 1; /* suppress comma*/ 00585 } 00586 else { 00587 if (cup->ufcomsep == 0) { 00588 NLCHAR(sepchr); /* write comma */ 00589 } 00590 NLCHAR(' '); /* write delimiter */ 00591 css->u.fmt.u.le.ldwinit = 1; /* suppress comma*/ 00592 } 00593 } 00594 #if (defined(__mips) && (_MIPS_SZLONG == 32)) || (defined(_LITTLE_ENDIAN) && !defined(_LP64)) 00595 nlvar = (nmlist_goli_t*)((long *)nlvar + 3 + 00596 (sizeof(_fcd))/(sizeof(long))); 00597 #else 00598 nlvar = (nmlist_goli_t*)((long *)nlvar + 2 + 00599 (sizeof(_fcd))/(sizeof(long))); 00600 #endif 00601 } 00602 00603 if ((cup->unmlsize - cup->ulinemax) < trmsize) { 00604 NLWFLUSH(); 00605 NLCHAR(' '); /* write blank */ 00606 } 00607 00608 /* 00609 * Fortran 90 ends namelist with slash or compat character 00610 */ 00611 00612 NLCHAR(' '); /* write blank */ 00613 NLCHAR(trmchr); /* write ending slash */ 00614 00615 NLWFLUSH(); 00616 00617 if (errn != 0) 00618 cup->uflag = cup->uflag | _UERRC; /* Set error status */ 00619 00620 /**************************************************************************** 00621 * 00622 * Statement Finalization Section 00623 * 00624 ***************************************************************************/ 00625 finalization: 00626 00627 /* Set IOSTAT variable to 0 if no error, >0 error code otherwise */ 00628 00629 if (cilist->iostat_spec != NULL) 00630 *cilist->iostat_spec = errn; 00631 00632 /* End the Beguine */ 00633 00634 STMT_END(cup, TF_WRITE, NULL, css); /* Unlock unit */ 00635 00636 /* Return proper status */ 00637 00638 if (errn == 0) 00639 return(IO_OKAY); 00640 else 00641 return(IO_ERR); 00642 } 00643 00644 /* 00645 * _nlstrent - namelist output of structure entries 00646 * Recursive call to handle structure table entries for 00647 * namelist. This code is not used for a file that has 00648 * cf77 compatibility mode turned on. 00649 * Return value: 00650 * 0 on success. 00651 * >0 error code if error encountered 00652 */ 00653 int 00654 _nlstrent( 00655 FIOSPTR css, 00656 unit *cup, 00657 nmlist_goli_t *nalist, 00658 int count, 00659 int errf, 00660 int bytofset) 00661 { 00662 register int errn; /* error number */ 00663 register int scnt; /* count of namelist struc items */ 00664 nmlist_goli_t *nlvar; /* ptr to next var entry */ 00665 00666 scnt = count; 00667 errn = 0; 00668 nlvar = nalist; /* group object pointer */ 00669 00670 while (scnt-- && (errn == 0)) { 00671 00672 switch (nlvar->valtype) { 00673 00674 case IO_SCALAR: 00675 { 00676 nmlist_scalar_t *nlscalar; /* nmlist scalar entry */ 00677 void *vaddr; 00678 type_packet tip; 00679 00680 nlscalar = nlvar->goli_addr.ptr; /* ptr to scalar */ 00681 tip.type90 = nlscalar->tinfo.type; 00682 tip.type77 = -1; 00683 tip.intlen = nlscalar->tinfo.int_len; 00684 tip.extlen = tip.intlen; 00685 tip.elsize = tip.intlen >> 3; 00686 tip.cnvindx = 0; 00687 tip.count = 1; 00688 tip.stride = 1; 00689 00690 /* Assertions */ 00691 00692 assert (tip.type90 >= DVTYPE_TYPELESS && 00693 tip.type90 <= DVTYPE_ASCII); 00694 assert (tip.intlen > 0); 00695 00696 if (tip.type90 == DVTYPE_ASCII) { 00697 vaddr = _fcdtocp(nlscalar->scal_addr.charptr) + 00698 bytofset; 00699 tip.elsize = tip.elsize * 00700 _fcdlen(nlscalar->scal_addr.charptr); 00701 } 00702 else { 00703 register int adj; 00704 00705 if (bytofset > 0) 00706 adj = bytofset / (sizeof(_f_int)); 00707 else 00708 adj = 0; 00709 00710 vaddr = (_f_int *) nlscalar->scal_addr.ptr + 00711 adj; 00712 } 00713 00714 /* Use list-directed write */ 00715 00716 errn = _ld_write(css, cup, vaddr, &tip, 0); 00717 00718 break; 00719 } 00720 00721 case IO_DOPEVEC: 00722 { 00723 register short nc; 00724 register long extent; 00725 void *vaddr; 00726 type_packet tip; 00727 DopeVectorType *nldv; 00728 00729 nldv = nlvar->goli_addr.dv; /* ptr to dope vector */ 00730 00731 /* Assertions */ 00732 00733 assert (nldv != NULL); 00734 assert (nldv->type_lens.int_len > 0); 00735 00736 tip.type90 = nldv->type_lens.type; 00737 tip.type77 = -1; 00738 tip.intlen = nldv->type_lens.int_len; 00739 tip.extlen = tip.intlen; 00740 tip.elsize = tip.intlen >> 3; 00741 tip.cnvindx = 0; 00742 tip.stride = 1; 00743 00744 if (tip.type90 == DVTYPE_ASCII) { 00745 vaddr = _fcdtocp(nldv->base_addr.charptr) + 00746 bytofset; 00747 tip.elsize = tip.elsize * 00748 _fcdlen(nldv->base_addr.charptr); 00749 } 00750 else { 00751 register int adj; 00752 00753 if (bytofset > 0) 00754 adj = bytofset/(sizeof(_f_int)); 00755 else 00756 adj = 0; 00757 00758 vaddr = (_f_int *) nldv->base_addr.a.ptr + 00759 adj; 00760 } 00761 00762 extent = 1; 00763 00764 for (nc = 0; nc < nldv->n_dim; nc++) 00765 extent = extent * nldv->dimension[nc].extent; 00766 00767 /* Assertions */ 00768 00769 assert (tip.elsize > 0 && extent > 0); 00770 00771 /* Use list-directed write */ 00772 00773 tip.count = extent; 00774 00775 errn = _ld_write(css, cup, vaddr, &tip, 0); 00776 00777 break; 00778 } 00779 00780 case IO_STRUC_A: 00781 { 00782 register int scount; 00783 nmlist_struclist_t *nlstruc; /* nmlist struc entry */ 00784 nmlist_goli_t *vaddr; 00785 00786 nlstruc = nlvar->goli_addr.sptr; /* ptr to struc */ 00787 scount = nlstruc->structlen; /* number entries */ 00788 vaddr = nlstruc->goli; /* ptr to list */ 00789 00790 /* 00791 * No additional offset needed, pass current offset 00792 * on to next version. 00793 */ 00794 00795 errn = _nlstrent(css, cup, vaddr, scount, errf, 00796 bytofset); 00797 break; 00798 } 00799 00800 case IO_STRUC_S: 00801 { 00802 register short nc; 00803 register int scount; 00804 register long elsize; 00805 register long extent; 00806 register long ic; 00807 nmlist_struclist_t *nlstruc; /* nmlist struc entry */ 00808 nmlist_goli_t *vaddr; 00809 DopeVectorType *nlsdv; 00810 00811 nlstruc = nlvar->goli_addr.sptr; /* ptr to struc */ 00812 scount = nlstruc->structlen; /* number entries */ 00813 vaddr = nlstruc->goli; /* ptr to list */ 00814 nlsdv = nlstruc->struc_addr.dv; /* ptr to dopevec */ 00815 00816 /* 00817 * bytofset is used when the structure is an array 00818 * of structures. Each element must add an offset 00819 * to its address after the first array element. 00820 */ 00821 00822 elsize = nlsdv->base_addr.a.el_len; 00823 extent = 1; 00824 00825 for (nc = 0; nc < nlsdv->n_dim; nc++) 00826 extent = extent * nlsdv->dimension[nc].extent; 00827 00828 for (ic = 0; ic < extent; ic++) { 00829 register int bytoff; 00830 /* 00831 * create another byte offset for this 00832 * nesting of a structure of arrays. Must 00833 * change elsize from bits to bytes. 00834 */ 00835 bytoff = bytofset + ((elsize >> 3) * ic); 00836 00837 errn = _nlstrent(css, cup, vaddr, scount, 00838 errf, bytoff); 00839 } 00840 break; 00841 } 00842 00843 default: 00844 errn = FEINTUNK; 00845 } /* switch */ 00846 00847 if (errn !=0) 00848 return(errn); 00849 00850 /* Flush the list-directed output to line buffer */ 00851 00852 errn = _ld_write(css, cup, (void *) NULL, &__tip_null, 0); 00853 00854 if (errn != 0) 00855 return(errn); 00856 00857 if (scnt > 0) { 00858 if ((cup->unmlsize - cup->ulinemax) < 2) { 00859 NLWFLUSH(); 00860 NLCHAR(' '); /* write delimiter */ 00861 NLCHAR(' '); /* write delimiter */ 00862 css->u.fmt.u.le.ldwinit = 1; /* suppress comma*/ 00863 } 00864 else { 00865 NLCHAR(','); /* write delimiter */ 00866 NLCHAR(' '); /* write delimiter */ 00867 css->u.fmt.u.le.ldwinit = 1; /* suppress comma*/ 00868 } 00869 } 00870 #if (defined(__mips) && (_MIPS_SZLONG == 32)) || (defined(_LITTLE_ENDIAN) && !defined(_LP64)) 00871 nlvar = (nmlist_goli_t *)((long *)nlvar + 3 + 00872 (sizeof(_fcd))/(sizeof(long))); 00873 #else 00874 nlvar = (nmlist_goli_t *)((long *)nlvar + 2 + 00875 (sizeof(_fcd))/(sizeof(long))); 00876 #endif 00877 } 00878 00879 finalization: 00880 return(errn); 00881 }
1.7.6.1 
