| 1 | /* |
| 2 | * Copyright (c) 1980 Regents of the University of California. |
| 3 | * All rights reserved. The Berkeley software License Agreement |
| 4 | * specifies the terms and conditions for redistribution. |
| 5 | */ |
| 6 | |
| 7 | #ifndef lint |
| 8 | static char *sccsid = "@(#)io.c 5.1 (Berkeley) 85/06/07"; |
| 9 | #endif |
| 10 | |
| 11 | /* |
| 12 | * io.c |
| 13 | * |
| 14 | * Routines to generate code for I/O statements. |
| 15 | * Some corrections and improvements due to David Wasley, U. C. Berkeley |
| 16 | * |
| 17 | * University of Utah CS Dept modification history: |
| 18 | * |
| 19 | * $Header: io.c,v 2.4 85/02/23 21:09:02 donn Exp $ |
| 20 | * $Log: io.c,v $ |
| 21 | * Revision 2.4 85/02/23 21:09:02 donn |
| 22 | * Jerry Berkman's compiled format fixes move setfmt into a separate file. |
| 23 | * |
| 24 | * Revision 2.3 85/01/10 22:33:41 donn |
| 25 | * Added some strategic cpexpr()s to prevent memory management bugs. |
| 26 | * |
| 27 | * Revision 2.2 84/08/04 21:15:47 donn |
| 28 | * Removed code that creates extra statement labels, per Jerry Berkman's |
| 29 | * fixes to make ASSIGNs work right. |
| 30 | * |
| 31 | * Revision 2.1 84/07/19 12:03:33 donn |
| 32 | * Changed comment headers for UofU. |
| 33 | * |
| 34 | * Revision 1.2 84/02/26 06:35:57 donn |
| 35 | * Added Berkeley changes necessary for shortening offsets to data. |
| 36 | * |
| 37 | */ |
| 38 | |
| 39 | /* TEMPORARY */ |
| 40 | #define TYIOINT TYLONG |
| 41 | #define SZIOINT SZLONG |
| 42 | |
| 43 | #include "defs.h" |
| 44 | #include "io.h" |
| 45 | |
| 46 | |
| 47 | LOCAL char ioroutine[XL+1]; |
| 48 | |
| 49 | LOCAL int ioendlab; |
| 50 | LOCAL int ioerrlab; |
| 51 | LOCAL int endbit; |
| 52 | LOCAL int errbit; |
| 53 | LOCAL int jumplab; |
| 54 | LOCAL int skiplab; |
| 55 | LOCAL int ioformatted; |
| 56 | LOCAL int statstruct = NO; |
| 57 | LOCAL ftnint blklen; |
| 58 | |
| 59 | LOCAL offsetlist *mkiodata(); |
| 60 | |
| 61 | |
| 62 | #define UNFORMATTED 0 |
| 63 | #define FORMATTED 1 |
| 64 | #define LISTDIRECTED 2 |
| 65 | #define NAMEDIRECTED 3 |
| 66 | |
| 67 | #define V(z) ioc[z].iocval |
| 68 | |
| 69 | #define IOALL 07777 |
| 70 | |
| 71 | LOCAL struct Ioclist |
| 72 | { |
| 73 | char *iocname; |
| 74 | int iotype; |
| 75 | expptr iocval; |
| 76 | } ioc[ ] = |
| 77 | { |
| 78 | { "", 0 }, |
| 79 | { "unit", IOALL }, |
| 80 | { "fmt", M(IOREAD) | M(IOWRITE) }, |
| 81 | { "err", IOALL }, |
| 82 | { "end", M(IOREAD) }, |
| 83 | { "iostat", IOALL }, |
| 84 | { "rec", M(IOREAD) | M(IOWRITE) }, |
| 85 | { "recl", M(IOOPEN) | M(IOINQUIRE) }, |
| 86 | { "file", M(IOOPEN) | M(IOINQUIRE) }, |
| 87 | { "status", M(IOOPEN) | M(IOCLOSE) }, |
| 88 | { "access", M(IOOPEN) | M(IOINQUIRE) }, |
| 89 | { "form", M(IOOPEN) | M(IOINQUIRE) }, |
| 90 | { "blank", M(IOOPEN) | M(IOINQUIRE) }, |
| 91 | { "exist", M(IOINQUIRE) }, |
| 92 | { "opened", M(IOINQUIRE) }, |
| 93 | { "number", M(IOINQUIRE) }, |
| 94 | { "named", M(IOINQUIRE) }, |
| 95 | { "name", M(IOINQUIRE) }, |
| 96 | { "sequential", M(IOINQUIRE) }, |
| 97 | { "direct", M(IOINQUIRE) }, |
| 98 | { "formatted", M(IOINQUIRE) }, |
| 99 | { "unformatted", M(IOINQUIRE) }, |
| 100 | { "nextrec", M(IOINQUIRE) } |
| 101 | } ; |
| 102 | |
| 103 | #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1) |
| 104 | #define MAXIO SZFLAG + 10*SZIOINT + 15*SZADDR |
| 105 | |
| 106 | #define IOSUNIT 1 |
| 107 | #define IOSFMT 2 |
| 108 | #define IOSERR 3 |
| 109 | #define IOSEND 4 |
| 110 | #define IOSIOSTAT 5 |
| 111 | #define IOSREC 6 |
| 112 | #define IOSRECL 7 |
| 113 | #define IOSFILE 8 |
| 114 | #define IOSSTATUS 9 |
| 115 | #define IOSACCESS 10 |
| 116 | #define IOSFORM 11 |
| 117 | #define IOSBLANK 12 |
| 118 | #define IOSEXISTS 13 |
| 119 | #define IOSOPENED 14 |
| 120 | #define IOSNUMBER 15 |
| 121 | #define IOSNAMED 16 |
| 122 | #define IOSNAME 17 |
| 123 | #define IOSSEQUENTIAL 18 |
| 124 | #define IOSDIRECT 19 |
| 125 | #define IOSFORMATTED 20 |
| 126 | #define IOSUNFORMATTED 21 |
| 127 | #define IOSNEXTREC 22 |
| 128 | |
| 129 | #define IOSTP V(IOSIOSTAT) |
| 130 | |
| 131 | |
| 132 | /* offsets in generated structures */ |
| 133 | |
| 134 | #define SZFLAG SZIOINT |
| 135 | |
| 136 | /* offsets for external READ and WRITE statements */ |
| 137 | |
| 138 | #define XERR 0 |
| 139 | #define XUNIT SZFLAG |
| 140 | #define XEND SZFLAG + SZIOINT |
| 141 | #define XFMT 2*SZFLAG + SZIOINT |
| 142 | #define XREC 2*SZFLAG + SZIOINT + SZADDR |
| 143 | #define XRLEN 2*SZFLAG + 2*SZADDR |
| 144 | #define XRNUM 2*SZFLAG + 2*SZADDR + SZIOINT |
| 145 | |
| 146 | /* offsets for internal READ and WRITE statements */ |
| 147 | |
| 148 | #define XIERR 0 |
| 149 | #define XIUNIT SZFLAG |
| 150 | #define XIEND SZFLAG + SZADDR |
| 151 | #define XIFMT 2*SZFLAG + SZADDR |
| 152 | #define XIRLEN 2*SZFLAG + 2*SZADDR |
| 153 | #define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT |
| 154 | #define XIREC 2*SZFLAG + 2*SZADDR + 2*SZIOINT |
| 155 | |
| 156 | /* offsets for OPEN statements */ |
| 157 | |
| 158 | #define XFNAME SZFLAG + SZIOINT |
| 159 | #define XFNAMELEN SZFLAG + SZIOINT + SZADDR |
| 160 | #define XSTATUS SZFLAG + 2*SZIOINT + SZADDR |
| 161 | #define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR |
| 162 | #define XFORMATTED SZFLAG + 2*SZIOINT + 3*SZADDR |
| 163 | #define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR |
| 164 | #define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR |
| 165 | |
| 166 | /* offset for CLOSE statement */ |
| 167 | |
| 168 | #define XCLSTATUS SZFLAG + SZIOINT |
| 169 | |
| 170 | /* offsets for INQUIRE statement */ |
| 171 | |
| 172 | #define XFILE SZFLAG + SZIOINT |
| 173 | #define XFILELEN SZFLAG + SZIOINT + SZADDR |
| 174 | #define XEXISTS SZFLAG + 2*SZIOINT + SZADDR |
| 175 | #define XOPEN SZFLAG + 2*SZIOINT + 2*SZADDR |
| 176 | #define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR |
| 177 | #define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR |
| 178 | #define XNAME SZFLAG + 2*SZIOINT + 5*SZADDR |
| 179 | #define XNAMELEN SZFLAG + 2*SZIOINT + 6*SZADDR |
| 180 | #define XQACCESS SZFLAG + 3*SZIOINT + 6*SZADDR |
| 181 | #define XQACCLEN SZFLAG + 3*SZIOINT + 7*SZADDR |
| 182 | #define XSEQ SZFLAG + 4*SZIOINT + 7*SZADDR |
| 183 | #define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR |
| 184 | #define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR |
| 185 | #define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR |
| 186 | #define XFORM SZFLAG + 6*SZIOINT + 9*SZADDR |
| 187 | #define XFORMLEN SZFLAG + 6*SZIOINT + 10*SZADDR |
| 188 | #define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR |
| 189 | #define XFMTEDLEN SZFLAG + 7*SZIOINT + 11*SZADDR |
| 190 | #define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR |
| 191 | #define XUNFMTLEN SZFLAG + 8*SZIOINT + 12*SZADDR |
| 192 | #define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR |
| 193 | #define XNEXTREC SZFLAG + 9*SZIOINT + 13*SZADDR |
| 194 | #define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR |
| 195 | #define XQBLANKLEN SZFLAG + 9*SZIOINT + 15*SZADDR |
| 196 | \f |
| 197 | fmtstmt(lp) |
| 198 | register struct Labelblock *lp; |
| 199 | { |
| 200 | if(lp == NULL) |
| 201 | { |
| 202 | execerr("unlabeled format statement" , CNULL); |
| 203 | return(-1); |
| 204 | } |
| 205 | if(lp->labtype == LABUNKNOWN) |
| 206 | lp->labtype = LABFORMAT; |
| 207 | else if(lp->labtype != LABFORMAT) |
| 208 | { |
| 209 | execerr("bad format number", CNULL); |
| 210 | return(-1); |
| 211 | } |
| 212 | return(lp->labelno); |
| 213 | } |
| 214 | |
| 215 | |
| 216 | |
| 217 | startioctl() |
| 218 | { |
| 219 | register int i; |
| 220 | |
| 221 | inioctl = YES; |
| 222 | nioctl = 0; |
| 223 | ioformatted = UNFORMATTED; |
| 224 | for(i = 1 ; i<=NIOS ; ++i) |
| 225 | V(i) = NULL; |
| 226 | } |
| 227 | |
| 228 | |
| 229 | |
| 230 | endioctl() |
| 231 | { |
| 232 | int i; |
| 233 | expptr p; |
| 234 | |
| 235 | inioctl = NO; |
| 236 | |
| 237 | /* set up for error recovery */ |
| 238 | |
| 239 | ioerrlab = ioendlab = skiplab = jumplab = 0; |
| 240 | |
| 241 | if(p = V(IOSEND)) |
| 242 | if(ISICON(p)) |
| 243 | ioendlab = execlab(p->constblock.const.ci) ->labelno; |
| 244 | else |
| 245 | err("bad end= clause"); |
| 246 | |
| 247 | if(p = V(IOSERR)) |
| 248 | if(ISICON(p)) |
| 249 | ioerrlab = execlab(p->constblock.const.ci) ->labelno; |
| 250 | else |
| 251 | err("bad err= clause"); |
| 252 | |
| 253 | if(IOSTP) |
| 254 | if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) ) |
| 255 | { |
| 256 | err("iostat must be an integer variable"); |
| 257 | frexpr(IOSTP); |
| 258 | IOSTP = NULL; |
| 259 | } |
| 260 | |
| 261 | if(iostmt == IOREAD) |
| 262 | { |
| 263 | if(IOSTP) |
| 264 | { |
| 265 | if(ioerrlab && ioendlab && ioerrlab==ioendlab) |
| 266 | jumplab = ioerrlab; |
| 267 | else |
| 268 | skiplab = jumplab = newlabel(); |
| 269 | } |
| 270 | else { |
| 271 | if(ioerrlab && ioendlab && ioerrlab!=ioendlab) |
| 272 | { |
| 273 | IOSTP = (expptr) mktemp(TYINT, PNULL); |
| 274 | skiplab = jumplab = newlabel(); |
| 275 | } |
| 276 | else |
| 277 | jumplab = (ioerrlab ? ioerrlab : ioendlab); |
| 278 | } |
| 279 | } |
| 280 | else if(iostmt == IOWRITE) |
| 281 | { |
| 282 | if(IOSTP && !ioerrlab) |
| 283 | skiplab = jumplab = newlabel(); |
| 284 | else |
| 285 | jumplab = ioerrlab; |
| 286 | } |
| 287 | else |
| 288 | jumplab = ioerrlab; |
| 289 | |
| 290 | endbit = IOSTP!=NULL || ioendlab!=0; /* for use in startrw() */ |
| 291 | errbit = IOSTP!=NULL || ioerrlab!=0; |
| 292 | if(iostmt!=IOREAD && iostmt!=IOWRITE) |
| 293 | { |
| 294 | if(ioblkp == NULL) |
| 295 | ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, PNULL); |
| 296 | ioset(TYIOINT, XERR, ICON(errbit)); |
| 297 | } |
| 298 | |
| 299 | switch(iostmt) |
| 300 | { |
| 301 | case IOOPEN: |
| 302 | dofopen(); break; |
| 303 | |
| 304 | case IOCLOSE: |
| 305 | dofclose(); break; |
| 306 | |
| 307 | case IOINQUIRE: |
| 308 | dofinquire(); break; |
| 309 | |
| 310 | case IOBACKSPACE: |
| 311 | dofmove("f_back"); break; |
| 312 | |
| 313 | case IOREWIND: |
| 314 | dofmove("f_rew"); break; |
| 315 | |
| 316 | case IOENDFILE: |
| 317 | dofmove("f_end"); break; |
| 318 | |
| 319 | case IOREAD: |
| 320 | case IOWRITE: |
| 321 | startrw(); break; |
| 322 | |
| 323 | default: |
| 324 | fatali("impossible iostmt %d", iostmt); |
| 325 | } |
| 326 | for(i = 1 ; i<=NIOS ; ++i) |
| 327 | if(i!=IOSIOSTAT && V(i)!=NULL) |
| 328 | frexpr(V(i)); |
| 329 | } |
| 330 | |
| 331 | |
| 332 | |
| 333 | iocname() |
| 334 | { |
| 335 | register int i; |
| 336 | int found, mask; |
| 337 | |
| 338 | found = 0; |
| 339 | mask = M(iostmt); |
| 340 | for(i = 1 ; i <= NIOS ; ++i) |
| 341 | if(toklen==strlen(ioc[i].iocname) && eqn(toklen, token, ioc[i].iocname)) |
| 342 | if(ioc[i].iotype & mask) |
| 343 | return(i); |
| 344 | else found = i; |
| 345 | if(found) |
| 346 | errstr("invalid control %s for statement", ioc[found].iocname); |
| 347 | else |
| 348 | errstr("unknown iocontrol %s", varstr(toklen, token) ); |
| 349 | return(IOSBAD); |
| 350 | } |
| 351 | |
| 352 | |
| 353 | ioclause(n, p) |
| 354 | register int n; |
| 355 | register expptr p; |
| 356 | { |
| 357 | struct Ioclist *iocp; |
| 358 | |
| 359 | ++nioctl; |
| 360 | if(n == IOSBAD) |
| 361 | return; |
| 362 | if(n == IOSPOSITIONAL) |
| 363 | { |
| 364 | if(nioctl > IOSFMT) |
| 365 | { |
| 366 | err("illegal positional iocontrol"); |
| 367 | return; |
| 368 | } |
| 369 | n = nioctl; |
| 370 | } |
| 371 | |
| 372 | if(p == NULL) |
| 373 | { |
| 374 | if(n == IOSUNIT) |
| 375 | p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT); |
| 376 | else if(n != IOSFMT) |
| 377 | { |
| 378 | err("illegal * iocontrol"); |
| 379 | return; |
| 380 | } |
| 381 | } |
| 382 | if(n == IOSFMT) |
| 383 | ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED); |
| 384 | |
| 385 | iocp = & ioc[n]; |
| 386 | if(iocp->iocval == NULL) |
| 387 | { |
| 388 | p = (expptr) cpexpr(p); |
| 389 | if(n!=IOSFMT && ( n!=IOSUNIT || (p!=NULL && p->headblock.vtype!=TYCHAR) ) ) |
| 390 | p = fixtype(p); |
| 391 | if(p!=NULL && ISCONST(p) && p->constblock.vtype==TYCHAR) |
| 392 | p = (expptr) putconst(p); |
| 393 | iocp->iocval = p; |
| 394 | } |
| 395 | else |
| 396 | errstr("iocontrol %s repeated", iocp->iocname); |
| 397 | } |
| 398 | |
| 399 | /* io list item */ |
| 400 | |
| 401 | doio(list) |
| 402 | chainp list; |
| 403 | { |
| 404 | expptr call0(); |
| 405 | |
| 406 | if(ioformatted == NAMEDIRECTED) |
| 407 | { |
| 408 | if(list) |
| 409 | err("no I/O list allowed in NAMELIST read/write"); |
| 410 | } |
| 411 | else |
| 412 | { |
| 413 | doiolist(list); |
| 414 | ioroutine[0] = 'e'; |
| 415 | putiocall( call0(TYINT, ioroutine) ); |
| 416 | } |
| 417 | } |
| 418 | |
| 419 | |
| 420 | |
| 421 | |
| 422 | |
| 423 | LOCAL doiolist(p0) |
| 424 | chainp p0; |
| 425 | { |
| 426 | chainp p; |
| 427 | register tagptr q; |
| 428 | register expptr qe; |
| 429 | register Namep qn; |
| 430 | Addrp tp, mkscalar(); |
| 431 | int range; |
| 432 | expptr expr; |
| 433 | |
| 434 | for (p = p0 ; p ; p = p->nextp) |
| 435 | { |
| 436 | q = p->datap; |
| 437 | if(q->tag == TIMPLDO) |
| 438 | { |
| 439 | exdo(range=newlabel(), q->impldoblock.impdospec); |
| 440 | doiolist(q->impldoblock.datalist); |
| 441 | enddo(range); |
| 442 | free( (charptr) q); |
| 443 | } |
| 444 | else { |
| 445 | if(q->tag==TPRIM && q->primblock.argsp==NULL |
| 446 | && q->primblock.namep->vdim!=NULL) |
| 447 | { |
| 448 | vardcl(qn = q->primblock.namep); |
| 449 | if(qn->vdim->nelt) |
| 450 | putio( fixtype(cpexpr(qn->vdim->nelt)), |
| 451 | mkscalar(qn) ); |
| 452 | else |
| 453 | err("attempt to i/o array of unknown size"); |
| 454 | } |
| 455 | else if(q->tag==TPRIM && q->primblock.argsp==NULL && |
| 456 | (qe = (expptr) memversion(q->primblock.namep)) ) |
| 457 | putio(ICON(1),qe); |
| 458 | else if( (qe = fixtype(cpexpr(q)))->tag==TADDR) |
| 459 | putio(ICON(1), qe); |
| 460 | else if(qe->headblock.vtype != TYERROR) |
| 461 | { |
| 462 | if(iostmt == IOWRITE) |
| 463 | { |
| 464 | ftnint lencat(); |
| 465 | expptr qvl; |
| 466 | qvl = NULL; |
| 467 | if( ISCHAR(qe) ) |
| 468 | { |
| 469 | qvl = (expptr) |
| 470 | cpexpr(qe->headblock.vleng); |
| 471 | tp = mkaltemp(qe->headblock.vtype, |
| 472 | ICON(lencat(qe))); |
| 473 | } |
| 474 | else |
| 475 | tp = mkaltemp(qe->headblock.vtype, |
| 476 | qe->headblock.vleng); |
| 477 | if (optimflag) |
| 478 | { |
| 479 | expr = mkexpr(OPASSIGN,cpexpr(tp),qe); |
| 480 | optbuff (SKEQ,expr,0,0); |
| 481 | } |
| 482 | else |
| 483 | puteq (cpexpr(tp),qe); |
| 484 | if(qvl) /* put right length on block */ |
| 485 | { |
| 486 | frexpr(tp->vleng); |
| 487 | tp->vleng = qvl; |
| 488 | } |
| 489 | putio(ICON(1), tp); |
| 490 | } |
| 491 | else |
| 492 | err("non-left side in READ list"); |
| 493 | } |
| 494 | frexpr(q); |
| 495 | } |
| 496 | } |
| 497 | frchain( &p0 ); |
| 498 | } |
| 499 | |
| 500 | |
| 501 | |
| 502 | |
| 503 | |
| 504 | LOCAL putio(nelt, addr) |
| 505 | expptr nelt; |
| 506 | register expptr addr; |
| 507 | { |
| 508 | int type; |
| 509 | register expptr q; |
| 510 | |
| 511 | type = addr->headblock.vtype; |
| 512 | if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) ) |
| 513 | { |
| 514 | nelt = mkexpr(OPSTAR, ICON(2), nelt); |
| 515 | type -= (TYCOMPLEX-TYREAL); |
| 516 | } |
| 517 | |
| 518 | /* pass a length with every item. for noncharacter data, fake one */ |
| 519 | if(type != TYCHAR) |
| 520 | { |
| 521 | addr->headblock.vtype = TYCHAR; |
| 522 | addr->headblock.vleng = ICON( typesize[type] ); |
| 523 | } |
| 524 | |
| 525 | nelt = fixtype( mkconv(TYLENG,nelt) ); |
| 526 | if(ioformatted == LISTDIRECTED) |
| 527 | q = call3(TYINT, "do_lio", mkconv(TYLONG, ICON(type)), nelt, addr); |
| 528 | else |
| 529 | q = call2(TYINT, (ioformatted==FORMATTED ? "do_fio" : "do_uio"), |
| 530 | nelt, addr); |
| 531 | putiocall(q); |
| 532 | } |
| 533 | |
| 534 | |
| 535 | |
| 536 | |
| 537 | endio() |
| 538 | { |
| 539 | if(skiplab) |
| 540 | { |
| 541 | if (optimflag) |
| 542 | optbuff (SKLABEL, 0, skiplab, 0); |
| 543 | else |
| 544 | putlabel (skiplab); |
| 545 | if(ioendlab) |
| 546 | { |
| 547 | expptr test; |
| 548 | test = mkexpr(OPGE, cpexpr(IOSTP), ICON(0)); |
| 549 | if (optimflag) |
| 550 | optbuff (SKIOIFN,test,ioendlab,0); |
| 551 | else |
| 552 | putif (test,ioendlab); |
| 553 | } |
| 554 | if(ioerrlab) |
| 555 | { |
| 556 | expptr test; |
| 557 | test = mkexpr |
| 558 | ( ((iostmt==IOREAD||iostmt==IOWRITE) ? OPLE : OPEQ), |
| 559 | cpexpr(IOSTP), ICON(0)); |
| 560 | if (optimflag) |
| 561 | optbuff (SKIOIFN,test,ioerrlab,0); |
| 562 | else |
| 563 | putif (test,ioerrlab); |
| 564 | } |
| 565 | } |
| 566 | if(IOSTP) |
| 567 | frexpr(IOSTP); |
| 568 | } |
| 569 | |
| 570 | |
| 571 | |
| 572 | LOCAL putiocall(q) |
| 573 | register expptr q; |
| 574 | { |
| 575 | if(IOSTP) |
| 576 | { |
| 577 | q->headblock.vtype = TYINT; |
| 578 | q = fixexpr( mkexpr(OPASSIGN, cpexpr(IOSTP), q)); |
| 579 | } |
| 580 | |
| 581 | if(jumplab) |
| 582 | if (optimflag) |
| 583 | optbuff (SKIOIFN,mkexpr(OPEQ,q,ICON(0)),jumplab,0); |
| 584 | else |
| 585 | putif (mkexpr(OPEQ,q,ICON(0)),jumplab); |
| 586 | else |
| 587 | if (optimflag) |
| 588 | optbuff (SKEQ, q, 0, 0); |
| 589 | else |
| 590 | putexpr(q); |
| 591 | } |
| 592 | \f |
| 593 | startrw() |
| 594 | { |
| 595 | register expptr p; |
| 596 | register Namep np; |
| 597 | register Addrp unitp, fmtp, recp, tioblkp; |
| 598 | register expptr nump; |
| 599 | register ioblock *t; |
| 600 | Addrp mkscalar(); |
| 601 | expptr mkaddcon(); |
| 602 | int k; |
| 603 | flag intfile, sequential, ok, varfmt; |
| 604 | |
| 605 | /* First look at all the parameters and determine what is to be done */ |
| 606 | |
| 607 | ok = YES; |
| 608 | statstruct = YES; |
| 609 | |
| 610 | intfile = NO; |
| 611 | if(p = V(IOSUNIT)) |
| 612 | { |
| 613 | if( ISINT(p->headblock.vtype) ) |
| 614 | unitp = (Addrp) cpexpr(p); |
| 615 | else if(p->headblock.vtype == TYCHAR) |
| 616 | { |
| 617 | intfile = YES; |
| 618 | if(p->tag==TPRIM && p->primblock.argsp==NULL && |
| 619 | (np = p->primblock.namep)->vdim!=NULL) |
| 620 | { |
| 621 | vardcl(np); |
| 622 | if(np->vdim->nelt) |
| 623 | { |
| 624 | nump = (expptr) cpexpr(np->vdim->nelt); |
| 625 | if( ! ISCONST(nump) ) |
| 626 | statstruct = NO; |
| 627 | } |
| 628 | else |
| 629 | { |
| 630 | err("attempt to use internal unit array of unknown size"); |
| 631 | ok = NO; |
| 632 | nump = ICON(1); |
| 633 | } |
| 634 | unitp = mkscalar(np); |
| 635 | } |
| 636 | else { |
| 637 | nump = ICON(1); |
| 638 | unitp = (Addrp) fixtype(cpexpr(p)); |
| 639 | } |
| 640 | if(! isstatic(unitp) ) |
| 641 | statstruct = NO; |
| 642 | } |
| 643 | else |
| 644 | { |
| 645 | err("bad unit specifier type"); |
| 646 | ok = NO; |
| 647 | } |
| 648 | } |
| 649 | else |
| 650 | { |
| 651 | err("bad unit specifier"); |
| 652 | ok = NO; |
| 653 | } |
| 654 | |
| 655 | sequential = YES; |
| 656 | if(p = V(IOSREC)) |
| 657 | if( ISINT(p->headblock.vtype) ) |
| 658 | { |
| 659 | recp = (Addrp) cpexpr(p); |
| 660 | sequential = NO; |
| 661 | } |
| 662 | else { |
| 663 | err("bad REC= clause"); |
| 664 | ok = NO; |
| 665 | } |
| 666 | else |
| 667 | recp = NULL; |
| 668 | |
| 669 | |
| 670 | varfmt = YES; |
| 671 | fmtp = NULL; |
| 672 | if(p = V(IOSFMT)) |
| 673 | { |
| 674 | if(p->tag==TPRIM && p->primblock.argsp==NULL) |
| 675 | { |
| 676 | np = p->primblock.namep; |
| 677 | if(np->vclass == CLNAMELIST) |
| 678 | { |
| 679 | ioformatted = NAMEDIRECTED; |
| 680 | fmtp = (Addrp) fixtype(cpexpr(p)); |
| 681 | goto endfmt; |
| 682 | } |
| 683 | vardcl(np); |
| 684 | if(np->vdim) |
| 685 | { |
| 686 | if( ! ONEOF(np->vstg, MSKSTATIC) ) |
| 687 | statstruct = NO; |
| 688 | fmtp = mkscalar(np); |
| 689 | goto endfmt; |
| 690 | } |
| 691 | if( ISINT(np->vtype) ) /* ASSIGNed label */ |
| 692 | { |
| 693 | statstruct = NO; |
| 694 | varfmt = NO; |
| 695 | fmtp = (Addrp) fixtype(cpexpr(p)); |
| 696 | goto endfmt; |
| 697 | } |
| 698 | } |
| 699 | p = V(IOSFMT) = fixtype(p); |
| 700 | if(p->headblock.vtype == TYCHAR) |
| 701 | { |
| 702 | if (p->tag == TCONST) p = (expptr) putconst(p); |
| 703 | if( ! isstatic(p) ) |
| 704 | statstruct = NO; |
| 705 | fmtp = (Addrp) cpexpr(p); |
| 706 | } |
| 707 | else if( ISICON(p) ) |
| 708 | { |
| 709 | if( (k = fmtstmt( mklabel(p->constblock.const.ci) )) > 0 ) |
| 710 | { |
| 711 | fmtp = (Addrp) mkaddcon(k); |
| 712 | varfmt = NO; |
| 713 | } |
| 714 | else |
| 715 | ioformatted = UNFORMATTED; |
| 716 | } |
| 717 | else { |
| 718 | err("bad format descriptor"); |
| 719 | ioformatted = UNFORMATTED; |
| 720 | ok = NO; |
| 721 | } |
| 722 | } |
| 723 | else |
| 724 | fmtp = NULL; |
| 725 | |
| 726 | endfmt: |
| 727 | if(intfile && ioformatted==UNFORMATTED) |
| 728 | { |
| 729 | err("unformatted internal I/O not allowed"); |
| 730 | ok = NO; |
| 731 | } |
| 732 | if(!sequential && ioformatted==LISTDIRECTED) |
| 733 | { |
| 734 | err("direct list-directed I/O not allowed"); |
| 735 | ok = NO; |
| 736 | } |
| 737 | if(!sequential && ioformatted==NAMEDIRECTED) |
| 738 | { |
| 739 | err("direct namelist I/O not allowed"); |
| 740 | ok = NO; |
| 741 | } |
| 742 | |
| 743 | if( ! ok ) |
| 744 | return; |
| 745 | |
| 746 | if (optimflag && ISCONST (fmtp)) |
| 747 | fmtp = putconst ( (expptr) fmtp); |
| 748 | |
| 749 | /* |
| 750 | Now put out the I/O structure, statically if all the clauses |
| 751 | are constants, dynamically otherwise |
| 752 | */ |
| 753 | |
| 754 | if(statstruct) |
| 755 | { |
| 756 | tioblkp = ioblkp; |
| 757 | ioblkp = ALLOC(Addrblock); |
| 758 | ioblkp->tag = TADDR; |
| 759 | ioblkp->vtype = TYIOINT; |
| 760 | ioblkp->vclass = CLVAR; |
| 761 | ioblkp->vstg = STGINIT; |
| 762 | ioblkp->memno = ++lastvarno; |
| 763 | ioblkp->memoffset = ICON(0); |
| 764 | blklen = (intfile ? XIREC+SZIOINT : |
| 765 | (sequential ? XFMT+SZADDR : XRNUM+SZIOINT) ); |
| 766 | t = ALLOC(IoBlock); |
| 767 | t->blkno = ioblkp->memno; |
| 768 | t->len = blklen; |
| 769 | t->next = iodata; |
| 770 | iodata = t; |
| 771 | } |
| 772 | else if(ioblkp == NULL) |
| 773 | ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, PNULL); |
| 774 | |
| 775 | ioset(TYIOINT, XERR, ICON(errbit)); |
| 776 | if(iostmt == IOREAD) |
| 777 | ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) ); |
| 778 | |
| 779 | if(intfile) |
| 780 | { |
| 781 | ioset(TYIOINT, XIRNUM, nump); |
| 782 | ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) ); |
| 783 | ioseta(XIUNIT, unitp); |
| 784 | } |
| 785 | else |
| 786 | ioset(TYIOINT, XUNIT, (expptr) unitp); |
| 787 | |
| 788 | if(recp) |
| 789 | ioset(TYIOINT, (intfile ? XIREC : XREC) , (expptr) recp); |
| 790 | |
| 791 | if(varfmt) |
| 792 | ioseta( intfile ? XIFMT : XFMT , fmtp); |
| 793 | else |
| 794 | ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp); |
| 795 | |
| 796 | ioroutine[0] = 's'; |
| 797 | ioroutine[1] = '_'; |
| 798 | ioroutine[2] = (iostmt==IOREAD ? 'r' : 'w'); |
| 799 | ioroutine[3] = (sequential ? 's' : 'd'); |
| 800 | ioroutine[4] = "ufln" [ioformatted]; |
| 801 | ioroutine[5] = (intfile ? 'i' : 'e'); |
| 802 | ioroutine[6] = '\0'; |
| 803 | |
| 804 | putiocall( call1(TYINT, ioroutine, cpexpr(ioblkp) )); |
| 805 | |
| 806 | if(statstruct) |
| 807 | { |
| 808 | frexpr(ioblkp); |
| 809 | ioblkp = tioblkp; |
| 810 | statstruct = NO; |
| 811 | } |
| 812 | } |
| 813 | |
| 814 | |
| 815 | |
| 816 | LOCAL dofopen() |
| 817 | { |
| 818 | register expptr p; |
| 819 | |
| 820 | if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) |
| 821 | ioset(TYIOINT, XUNIT, cpexpr(p) ); |
| 822 | else |
| 823 | err("bad unit in open"); |
| 824 | if( (p = V(IOSFILE)) ) |
| 825 | if(p->headblock.vtype == TYCHAR) |
| 826 | ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) ); |
| 827 | else |
| 828 | err("bad file in open"); |
| 829 | |
| 830 | iosetc(XFNAME, p); |
| 831 | |
| 832 | if(p = V(IOSRECL)) |
| 833 | if( ISINT(p->headblock.vtype) ) |
| 834 | ioset(TYIOINT, XRECLEN, cpexpr(p) ); |
| 835 | else |
| 836 | err("bad recl"); |
| 837 | else |
| 838 | ioset(TYIOINT, XRECLEN, ICON(0) ); |
| 839 | |
| 840 | iosetc(XSTATUS, V(IOSSTATUS)); |
| 841 | iosetc(XACCESS, V(IOSACCESS)); |
| 842 | iosetc(XFORMATTED, V(IOSFORM)); |
| 843 | iosetc(XBLANK, V(IOSBLANK)); |
| 844 | |
| 845 | putiocall( call1(TYINT, "f_open", cpexpr(ioblkp) )); |
| 846 | } |
| 847 | |
| 848 | |
| 849 | LOCAL dofclose() |
| 850 | { |
| 851 | register expptr p; |
| 852 | |
| 853 | if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) |
| 854 | { |
| 855 | ioset(TYIOINT, XUNIT, cpexpr(p) ); |
| 856 | iosetc(XCLSTATUS, V(IOSSTATUS)); |
| 857 | putiocall( call1(TYINT, "f_clos", cpexpr(ioblkp)) ); |
| 858 | } |
| 859 | else |
| 860 | err("bad unit in close statement"); |
| 861 | } |
| 862 | |
| 863 | |
| 864 | LOCAL dofinquire() |
| 865 | { |
| 866 | register expptr p; |
| 867 | if(p = V(IOSUNIT)) |
| 868 | { |
| 869 | if( V(IOSFILE) ) |
| 870 | err("inquire by unit or by file, not both"); |
| 871 | ioset(TYIOINT, XUNIT, cpexpr(p) ); |
| 872 | } |
| 873 | else if( ! V(IOSFILE) ) |
| 874 | err("must inquire by unit or by file"); |
| 875 | iosetlc(IOSFILE, XFILE, XFILELEN); |
| 876 | iosetip(IOSEXISTS, XEXISTS); |
| 877 | iosetip(IOSOPENED, XOPEN); |
| 878 | iosetip(IOSNUMBER, XNUMBER); |
| 879 | iosetip(IOSNAMED, XNAMED); |
| 880 | iosetlc(IOSNAME, XNAME, XNAMELEN); |
| 881 | iosetlc(IOSACCESS, XQACCESS, XQACCLEN); |
| 882 | iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN); |
| 883 | iosetlc(IOSDIRECT, XDIRECT, XDIRLEN); |
| 884 | iosetlc(IOSFORM, XFORM, XFORMLEN); |
| 885 | iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN); |
| 886 | iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN); |
| 887 | iosetip(IOSRECL, XQRECL); |
| 888 | iosetip(IOSNEXTREC, XNEXTREC); |
| 889 | iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN); |
| 890 | |
| 891 | putiocall( call1(TYINT, "f_inqu", cpexpr(ioblkp) )); |
| 892 | } |
| 893 | |
| 894 | |
| 895 | |
| 896 | LOCAL dofmove(subname) |
| 897 | char *subname; |
| 898 | { |
| 899 | register expptr p; |
| 900 | |
| 901 | if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) |
| 902 | { |
| 903 | ioset(TYIOINT, XUNIT, cpexpr(p) ); |
| 904 | putiocall( call1(TYINT, subname, cpexpr(ioblkp) )); |
| 905 | } |
| 906 | else |
| 907 | err("bad unit in I/O motion statement"); |
| 908 | } |
| 909 | |
| 910 | |
| 911 | |
| 912 | LOCAL |
| 913 | ioset(type, offset, p) |
| 914 | int type; |
| 915 | int offset; |
| 916 | register expptr p; |
| 917 | { |
| 918 | static char *badoffset = "badoffset in ioset"; |
| 919 | |
| 920 | register Addrp q; |
| 921 | register offsetlist *op; |
| 922 | |
| 923 | q = (Addrp) cpexpr(ioblkp); |
| 924 | q->vtype = type; |
| 925 | q->memoffset = fixtype( mkexpr(OPPLUS, q->memoffset, ICON(offset)) ); |
| 926 | |
| 927 | if (statstruct && ISCONST(p)) |
| 928 | { |
| 929 | if (!ISICON(q->memoffset)) |
| 930 | fatal(badoffset); |
| 931 | |
| 932 | op = mkiodata(q->memno, q->memoffset->constblock.const.ci, blklen); |
| 933 | if (op->tag != 0) |
| 934 | fatal(badoffset); |
| 935 | |
| 936 | if (type == TYADDR) |
| 937 | { |
| 938 | op->tag = NDLABEL; |
| 939 | op->val.label = p->constblock.const.ci; |
| 940 | } |
| 941 | else |
| 942 | { |
| 943 | op->tag = NDDATA; |
| 944 | op->val.cp = (Constp) convconst(type, 0, p); |
| 945 | } |
| 946 | |
| 947 | frexpr((tagptr) p); |
| 948 | frexpr((tagptr) q); |
| 949 | } |
| 950 | else |
| 951 | if (optimflag) |
| 952 | optbuff (SKEQ, mkexpr(OPASSIGN,q,p), 0,0); |
| 953 | else |
| 954 | puteq (q,p); |
| 955 | |
| 956 | return; |
| 957 | } |
| 958 | |
| 959 | |
| 960 | |
| 961 | |
| 962 | LOCAL iosetc(offset, p) |
| 963 | int offset; |
| 964 | register expptr p; |
| 965 | { |
| 966 | if(p == NULL) |
| 967 | ioset(TYADDR, offset, ICON(0) ); |
| 968 | else if(p->headblock.vtype == TYCHAR) |
| 969 | ioset(TYADDR, offset, addrof(cpexpr(p) )); |
| 970 | else |
| 971 | err("non-character control clause"); |
| 972 | } |
| 973 | |
| 974 | |
| 975 | |
| 976 | LOCAL ioseta(offset, p) |
| 977 | int offset; |
| 978 | register Addrp p; |
| 979 | { |
| 980 | static char *badoffset = "bad offset in ioseta"; |
| 981 | |
| 982 | int blkno; |
| 983 | register offsetlist *op; |
| 984 | |
| 985 | if(statstruct) |
| 986 | { |
| 987 | blkno = ioblkp->memno; |
| 988 | op = mkiodata(blkno, offset, blklen); |
| 989 | if (op->tag != 0) |
| 990 | fatal(badoffset); |
| 991 | |
| 992 | if (p == NULL) |
| 993 | op->tag = NDNULL; |
| 994 | else if (p->tag == TADDR) |
| 995 | { |
| 996 | op->tag = NDADDR; |
| 997 | op->val.addr.stg = p->vstg; |
| 998 | op->val.addr.memno = p->memno; |
| 999 | op->val.addr.offset = p->memoffset->constblock.const.ci; |
| 1000 | } |
| 1001 | else |
| 1002 | badtag("ioseta", p->tag); |
| 1003 | } |
| 1004 | else |
| 1005 | ioset(TYADDR, offset, p ? addrof(p) : ICON(0) ); |
| 1006 | |
| 1007 | return; |
| 1008 | } |
| 1009 | |
| 1010 | |
| 1011 | |
| 1012 | |
| 1013 | LOCAL iosetip(i, offset) |
| 1014 | int i, offset; |
| 1015 | { |
| 1016 | register expptr p; |
| 1017 | |
| 1018 | if(p = V(i)) |
| 1019 | if(p->tag==TADDR && |
| 1020 | ONEOF(p->addrblock.vtype, M(TYLONG)|M(TYLOGICAL)) ) |
| 1021 | ioset(TYADDR, offset, addrof(cpexpr(p)) ); |
| 1022 | else |
| 1023 | errstr("impossible inquire parameter %s", ioc[i].iocname); |
| 1024 | else |
| 1025 | ioset(TYADDR, offset, ICON(0) ); |
| 1026 | } |
| 1027 | |
| 1028 | |
| 1029 | |
| 1030 | LOCAL iosetlc(i, offp, offl) |
| 1031 | int i, offp, offl; |
| 1032 | { |
| 1033 | register expptr p; |
| 1034 | if( (p = V(i)) && p->headblock.vtype==TYCHAR) |
| 1035 | ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) ); |
| 1036 | iosetc(offp, p); |
| 1037 | } |
| 1038 | |
| 1039 | |
| 1040 | LOCAL offsetlist * |
| 1041 | mkiodata(blkno, offset, len) |
| 1042 | int blkno; |
| 1043 | ftnint offset; |
| 1044 | ftnint len; |
| 1045 | { |
| 1046 | register offsetlist *p, *q; |
| 1047 | register ioblock *t; |
| 1048 | register int found; |
| 1049 | |
| 1050 | found = NO; |
| 1051 | t = iodata; |
| 1052 | |
| 1053 | while (found == NO && t != NULL) |
| 1054 | { |
| 1055 | if (t->blkno == blkno) |
| 1056 | found = YES; |
| 1057 | else |
| 1058 | t = t->next; |
| 1059 | } |
| 1060 | |
| 1061 | if (found == NO) |
| 1062 | { |
| 1063 | t = ALLOC(IoBlock); |
| 1064 | t->blkno = blkno; |
| 1065 | t->next = iodata; |
| 1066 | iodata = t; |
| 1067 | } |
| 1068 | |
| 1069 | if (len > t->len) |
| 1070 | t->len = len; |
| 1071 | |
| 1072 | p = t->olist; |
| 1073 | |
| 1074 | if (p == NULL) |
| 1075 | { |
| 1076 | p = ALLOC(OffsetList); |
| 1077 | p->next = NULL; |
| 1078 | p->offset = offset; |
| 1079 | t->olist = p; |
| 1080 | return (p); |
| 1081 | } |
| 1082 | |
| 1083 | for (;;) |
| 1084 | { |
| 1085 | if (p->offset == offset) |
| 1086 | return (p); |
| 1087 | else if (p->next != NULL && |
| 1088 | p->next->offset <= offset) |
| 1089 | p = p->next; |
| 1090 | else |
| 1091 | { |
| 1092 | q = ALLOC(OffsetList); |
| 1093 | q->next = p->next; |
| 1094 | p->next = q; |
| 1095 | q->offset = offset; |
| 1096 | return (q); |
| 1097 | } |
| 1098 | } |
| 1099 | } |
| 1100 | |
| 1101 | |
| 1102 | outiodata() |
| 1103 | { |
| 1104 | static char *varfmt = "\t.align\t2\nv.%d:\n"; |
| 1105 | |
| 1106 | register ioblock *p; |
| 1107 | register ioblock *t; |
| 1108 | |
| 1109 | if (iodata == NULL) return; |
| 1110 | |
| 1111 | p = iodata; |
| 1112 | |
| 1113 | while (p != NULL) |
| 1114 | { |
| 1115 | fprintf(initfile, varfmt, p->blkno); |
| 1116 | outolist(p->olist, p->len); |
| 1117 | |
| 1118 | t = p; |
| 1119 | p = t->next; |
| 1120 | free((char *) t); |
| 1121 | } |
| 1122 | |
| 1123 | iodata = NULL; |
| 1124 | return; |
| 1125 | } |
| 1126 | |
| 1127 | |
| 1128 | |
| 1129 | LOCAL |
| 1130 | outolist(op, len) |
| 1131 | register offsetlist *op; |
| 1132 | register int len; |
| 1133 | { |
| 1134 | static char *overlap = "overlapping i/o fields in outolist"; |
| 1135 | static char *toolong = "offset too large in outolist"; |
| 1136 | |
| 1137 | register offsetlist *t; |
| 1138 | register ftnint clen; |
| 1139 | register Constp cp; |
| 1140 | register int type; |
| 1141 | |
| 1142 | clen = 0; |
| 1143 | |
| 1144 | while (op != NULL) |
| 1145 | { |
| 1146 | if (clen > op->offset) |
| 1147 | fatal(overlap); |
| 1148 | |
| 1149 | if (clen < op->offset) |
| 1150 | { |
| 1151 | prspace(op->offset - clen); |
| 1152 | clen = op->offset; |
| 1153 | } |
| 1154 | |
| 1155 | switch (op->tag) |
| 1156 | { |
| 1157 | default: |
| 1158 | badtag("outolist", op->tag); |
| 1159 | |
| 1160 | case NDDATA: |
| 1161 | cp = op->val.cp; |
| 1162 | type = cp->vtype; |
| 1163 | if (type != TYIOINT) |
| 1164 | badtype("outolist", type); |
| 1165 | prconi(initfile, type, cp->const.ci); |
| 1166 | clen += typesize[type]; |
| 1167 | frexpr((tagptr) cp); |
| 1168 | break; |
| 1169 | |
| 1170 | case NDLABEL: |
| 1171 | prcona(initfile, op->val.label); |
| 1172 | clen += typesize[TYADDR]; |
| 1173 | break; |
| 1174 | |
| 1175 | case NDADDR: |
| 1176 | praddr(initfile, op->val.addr.stg, op->val.addr.memno, |
| 1177 | op->val.addr.offset); |
| 1178 | clen += typesize[TYADDR]; |
| 1179 | break; |
| 1180 | |
| 1181 | case NDNULL: |
| 1182 | praddr(initfile, STGNULL, 0, (ftnint) 0); |
| 1183 | clen += typesize[TYADDR]; |
| 1184 | break; |
| 1185 | } |
| 1186 | |
| 1187 | t = op; |
| 1188 | op = t->next; |
| 1189 | free((char *) t); |
| 1190 | } |
| 1191 | |
| 1192 | if (clen > len) |
| 1193 | fatal(toolong); |
| 1194 | |
| 1195 | if (clen < len) |
| 1196 | prspace(len - clen); |
| 1197 | |
| 1198 | return; |
| 1199 | } |