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