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