home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / f2c-93.04.28-src.tgz / tar.out / fsf / f2c / src / io.c < prev    next >
C/C++ Source or Header  |  1996-09-28  |  29KB  |  1,421 lines
  1. /****************************************************************
  2. Copyright 1990, 1991, 1993 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. /* Routines to generate code for I/O statements.
  25.    Some corrections and improvements due to David Wasley, U. C. Berkeley
  26. */
  27.  
  28. /* TEMPORARY */
  29. #define TYIOINT TYLONG
  30. #define SZIOINT SZLONG
  31.  
  32. #include "defs.h"
  33. #include "names.h"
  34. #include "iob.h"
  35.  
  36. extern int inqmask;
  37.  
  38. LOCAL void dofclose(), dofinquire(), dofinquire(), dofmove(), dofopen(),
  39.     doiolist(), ioset(), ioseta(), iosetc(), iosetip(), iosetlc(),
  40.     putio(), putiocall();
  41.  
  42. iob_data *iob_list;
  43. Addrp io_structs[9];
  44.  
  45. LOCAL char ioroutine[12];
  46.  
  47. LOCAL long ioendlab;
  48. LOCAL long ioerrlab;
  49. LOCAL int endbit;
  50. LOCAL int errbit;
  51. LOCAL long jumplab;
  52. LOCAL long skiplab;
  53. LOCAL int ioformatted;
  54. LOCAL int statstruct = NO;
  55. LOCAL struct Labelblock *skiplabel;
  56. Addrp ioblkp;
  57.  
  58. #define UNFORMATTED 0
  59. #define FORMATTED 1
  60. #define LISTDIRECTED 2
  61. #define NAMEDIRECTED 3
  62.  
  63. #define V(z)    ioc[z].iocval
  64.  
  65. #define IOALL 07777
  66.  
  67. LOCAL struct Ioclist
  68. {
  69.     char *iocname;
  70.     int iotype;
  71.     expptr iocval;
  72. }
  73. ioc[ ] =
  74. {
  75.     { "", 0 },
  76.     { "unit", IOALL },
  77.     { "fmt", M(IOREAD) | M(IOWRITE) },
  78.     { "err", IOALL },
  79.     { "end", M(IOREAD) },
  80.     { "iostat", IOALL },
  81.     { "rec", M(IOREAD) | M(IOWRITE) },
  82.     { "recl", M(IOOPEN) | M(IOINQUIRE) },
  83.     { "file", M(IOOPEN) | M(IOINQUIRE) },
  84.     { "status", M(IOOPEN) | M(IOCLOSE) },
  85.     { "access", M(IOOPEN) | M(IOINQUIRE) },
  86.     { "form", M(IOOPEN) | M(IOINQUIRE) },
  87.     { "blank", M(IOOPEN) | M(IOINQUIRE) },
  88.     { "exist", M(IOINQUIRE) },
  89.     { "opened", M(IOINQUIRE) },
  90.     { "number", M(IOINQUIRE) },
  91.     { "named", M(IOINQUIRE) },
  92.     { "name", M(IOINQUIRE) },
  93.     { "sequential", M(IOINQUIRE) },
  94.     { "direct", M(IOINQUIRE) },
  95.     { "formatted", M(IOINQUIRE) },
  96.     { "unformatted", M(IOINQUIRE) },
  97.     { "nextrec", M(IOINQUIRE) },
  98.     { "nml", M(IOREAD) | M(IOWRITE) }
  99. };
  100.  
  101. #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
  102.  
  103. /* #define IOSUNIT 1 */
  104. /* #define IOSFMT 2 */
  105. #define IOSERR 3
  106. #define IOSEND 4
  107. #define IOSIOSTAT 5
  108. #define IOSREC 6
  109. #define IOSRECL 7
  110. #define IOSFILE 8
  111. #define IOSSTATUS 9
  112. #define IOSACCESS 10
  113. #define IOSFORM 11
  114. #define IOSBLANK 12
  115. #define IOSEXISTS 13
  116. #define IOSOPENED 14
  117. #define IOSNUMBER 15
  118. #define IOSNAMED 16
  119. #define IOSNAME 17
  120. #define IOSSEQUENTIAL 18
  121. #define IOSDIRECT 19
  122. #define IOSFORMATTED 20
  123. #define IOSUNFORMATTED 21
  124. #define IOSNEXTREC 22
  125. #define IOSNML 23
  126.  
  127. #define IOSTP V(IOSIOSTAT)
  128.  
  129.  
  130. /* offsets in generated structures */
  131.  
  132. #define SZFLAG SZIOINT
  133.  
  134. /* offsets for external READ and WRITE statements */
  135.  
  136. #define XERR 0
  137. #define XUNIT    SZFLAG
  138. #define XEND    SZFLAG + SZIOINT
  139. #define XFMT    2*SZFLAG + SZIOINT
  140. #define XREC    2*SZFLAG + SZIOINT + SZADDR
  141.  
  142. /* offsets for internal READ and WRITE statements */
  143.  
  144. #define XIUNIT    SZFLAG
  145. #define XIEND    SZFLAG + SZADDR
  146. #define XIFMT    2*SZFLAG + SZADDR
  147. #define XIRLEN    2*SZFLAG + 2*SZADDR
  148. #define XIRNUM    2*SZFLAG + 2*SZADDR + SZIOINT
  149. #define XIREC    2*SZFLAG + 2*SZADDR + 2*SZIOINT
  150.  
  151. /* offsets for OPEN statements */
  152.  
  153. #define XFNAME    SZFLAG + SZIOINT
  154. #define XFNAMELEN    SZFLAG + SZIOINT + SZADDR
  155. #define XSTATUS    SZFLAG + 2*SZIOINT + SZADDR
  156. #define XACCESS    SZFLAG + 2*SZIOINT + 2*SZADDR
  157. #define XFORMATTED    SZFLAG + 2*SZIOINT + 3*SZADDR
  158. #define XRECLEN    SZFLAG + 2*SZIOINT + 4*SZADDR
  159. #define XBLANK    SZFLAG + 3*SZIOINT + 4*SZADDR
  160.  
  161. /* offset for CLOSE statement */
  162.  
  163. #define XCLSTATUS    SZFLAG + SZIOINT
  164.  
  165. /* offsets for INQUIRE statement */
  166.  
  167. #define XFILE    SZFLAG + SZIOINT
  168. #define XFILELEN    SZFLAG + SZIOINT + SZADDR
  169. #define XEXISTS    SZFLAG + 2*SZIOINT + SZADDR
  170. #define XOPEN    SZFLAG + 2*SZIOINT + 2*SZADDR
  171. #define XNUMBER    SZFLAG + 2*SZIOINT + 3*SZADDR
  172. #define XNAMED    SZFLAG + 2*SZIOINT + 4*SZADDR
  173. #define XNAME    SZFLAG + 2*SZIOINT + 5*SZADDR
  174. #define XNAMELEN    SZFLAG + 2*SZIOINT + 6*SZADDR
  175. #define XQACCESS    SZFLAG + 3*SZIOINT + 6*SZADDR
  176. #define XQACCLEN    SZFLAG + 3*SZIOINT + 7*SZADDR
  177. #define XSEQ    SZFLAG + 4*SZIOINT + 7*SZADDR
  178. #define XSEQLEN    SZFLAG + 4*SZIOINT + 8*SZADDR
  179. #define XDIRECT    SZFLAG + 5*SZIOINT + 8*SZADDR
  180. #define XDIRLEN    SZFLAG + 5*SZIOINT + 9*SZADDR
  181. #define XFORM    SZFLAG + 6*SZIOINT + 9*SZADDR
  182. #define XFORMLEN    SZFLAG + 6*SZIOINT + 10*SZADDR
  183. #define XFMTED    SZFLAG + 7*SZIOINT + 10*SZADDR
  184. #define XFMTEDLEN    SZFLAG + 7*SZIOINT + 11*SZADDR
  185. #define XUNFMT    SZFLAG + 8*SZIOINT + 11*SZADDR
  186. #define XUNFMTLEN    SZFLAG + 8*SZIOINT + 12*SZADDR
  187. #define XQRECL    SZFLAG + 9*SZIOINT + 12*SZADDR
  188. #define XNEXTREC    SZFLAG + 9*SZIOINT + 13*SZADDR
  189. #define XQBLANK    SZFLAG + 9*SZIOINT + 14*SZADDR
  190. #define XQBLANKLEN    SZFLAG + 9*SZIOINT + 15*SZADDR
  191.  
  192. LOCAL char *cilist_names[] = {
  193.     "cilist",
  194.     "cierr",
  195.     "ciunit",
  196.     "ciend",
  197.     "cifmt",
  198.     "cirec"
  199.     };
  200. LOCAL char *icilist_names[] = {
  201.     "icilist",
  202.     "icierr",
  203.     "iciunit",
  204.     "iciend",
  205.     "icifmt",
  206.     "icirlen",
  207.     "icirnum"
  208.     };
  209. LOCAL char *olist_names[] = {
  210.     "olist",
  211.     "oerr",
  212.     "ounit",
  213.     "ofnm",
  214.     "ofnmlen",
  215.     "osta",
  216.     "oacc",
  217.     "ofm",
  218.     "orl",
  219.     "oblnk"
  220.     };
  221. LOCAL char *cllist_names[] = {
  222.     "cllist",
  223.     "cerr",
  224.     "cunit",
  225.     "csta"
  226.     };
  227. LOCAL char *alist_names[] = {
  228.     "alist",
  229.     "aerr",
  230.     "aunit"
  231.     };
  232. LOCAL char *inlist_names[] = {
  233.     "inlist",
  234.     "inerr",
  235.     "inunit",
  236.     "infile",
  237.     "infilen",
  238.     "inex",
  239.     "inopen",
  240.     "innum",
  241.     "innamed",
  242.     "inname",
  243.     "innamlen",
  244.     "inacc",
  245.     "inacclen",
  246.     "inseq",
  247.     "inseqlen",
  248.     "indir",
  249.     "indirlen",
  250.     "infmt",
  251.     "infmtlen",
  252.     "inform",
  253.     "informlen",
  254.     "inunf",
  255.     "inunflen",
  256.     "inrecl",
  257.     "innrec",
  258.     "inblank",
  259.     "inblanklen"
  260.     };
  261.  
  262. LOCAL char **io_fields;
  263.  
  264. #define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t
  265.  
  266. LOCAL io_setup io_stuff[] = {
  267.     zork(cilist_names, TYCILIST),    /* external read/write */
  268.     zork(inlist_names, TYINLIST),    /* inquire */
  269.     zork(olist_names,  TYOLIST),    /* open */
  270.     zork(cllist_names, TYCLLIST),    /* close */
  271.     zork(alist_names,  TYALIST),    /* rewind */
  272.     zork(alist_names,  TYALIST),    /* backspace */
  273.     zork(alist_names,  TYALIST),    /* endfile */
  274.     zork(icilist_names,TYICILIST),    /* internal read */
  275.     zork(icilist_names,TYICILIST)    /* internal write */
  276.     };
  277.  
  278. #undef zork
  279.  
  280.  
  281. fmtstmt(lp)
  282. register struct Labelblock *lp;
  283. {
  284.     if(lp == NULL)
  285.     {
  286.         execerr("unlabeled format statement" , CNULL);
  287.         return(-1);
  288.     }
  289.     if(lp->labtype == LABUNKNOWN)
  290.     {
  291.         lp->labtype = LABFORMAT;
  292.         lp->labelno = newlabel();
  293.     }
  294.     else if(lp->labtype != LABFORMAT)
  295.     {
  296.         execerr("bad format number", CNULL);
  297.         return(-1);
  298.     }
  299.     return(lp->labelno);
  300. }
  301.  
  302.  
  303. setfmt(lp)
  304. struct Labelblock *lp;
  305. {
  306.     int n;
  307.     char *s0, *lexline();
  308.     register char *s, *se, *t;
  309.     register k;
  310.  
  311.     s0 = s = lexline(&n);
  312.     se = t = s + n;
  313.  
  314.     /* warn of trivial errors, e.g. "  11 CONTINUE" (one too few spaces) */
  315.     /* following FORMAT... */
  316.  
  317.     if (n <= 0)
  318.         warn("No (...) after FORMAT");
  319.     else if (*s != '(')
  320.         warni("%c rather than ( after FORMAT", *s);
  321.     else if (se[-1] != ')') {
  322.         *se = 0;
  323.         while(--t > s && *t != ')') ;
  324.         if (t <= s)
  325.             warn("No ) at end of FORMAT statement");
  326.         else if (se - t > 30)
  327.             warn1("Extraneous text at end of FORMAT: ...%s", se-12);
  328.         else
  329.             warn1("Extraneous text at end of FORMAT: %s", t+1);
  330.         t = se;
  331.         }
  332.  
  333.     /* fix MYQUOTES (\002's) and \\'s */
  334.  
  335.     while(s < se)
  336.         switch(*s++) {
  337.             case 2:
  338.                 t += 3; break;
  339.             case '"':
  340.             case '\\':
  341.                 t++; break;
  342.             }
  343.     s = s0;
  344.     if (lp) {
  345.         lp->fmtstring = t = mem((int)(t - s + 1), 0);
  346.         while(s < se)
  347.             switch(k = *s++) {
  348.                 case 2:
  349.                     t[0] = '\\';
  350.                     t[1] = '0';
  351.                     t[2] = '0';
  352.                     t[3] = '2';
  353.                     t += 4;
  354.                     break;
  355.                 case '"':
  356.                 case '\\':
  357.                     *t++ = '\\';
  358.                     /* no break */
  359.                 default:
  360.                     *t++ = k;
  361.                 }
  362.         *t = 0;
  363.         }
  364.     flline();
  365. }
  366.  
  367.  
  368.  
  369. startioctl()
  370. {
  371.     register int i;
  372.  
  373.     inioctl = YES;
  374.     nioctl = 0;
  375.     ioformatted = UNFORMATTED;
  376.     for(i = 1 ; i<=NIOS ; ++i)
  377.         V(i) = NULL;
  378. }
  379.  
  380.  static long
  381. newiolabel() {
  382.     long rv;
  383.     rv = ++lastiolabno;
  384.     skiplabel = mklabel(rv);
  385.     skiplabel->labdefined = 1;
  386.     return rv;
  387.     }
  388.  
  389.  
  390. endioctl()
  391. {
  392.     int i;
  393.     expptr p;
  394.     struct io_setup *ios;
  395.  
  396.     inioctl = NO;
  397.  
  398.     /* set up for error recovery */
  399.  
  400.     ioerrlab = ioendlab = skiplab = jumplab = 0;
  401.  
  402.     if(p = V(IOSEND))
  403.         if(ISICON(p))
  404.             execlab(ioendlab = p->constblock.Const.ci);
  405.         else
  406.             err("bad end= clause");
  407.  
  408.     if(p = V(IOSERR))
  409.         if(ISICON(p))
  410.             execlab(ioerrlab = p->constblock.Const.ci);
  411.         else
  412.             err("bad err= clause");
  413.  
  414.     if(IOSTP)
  415.         if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
  416.         {
  417.             err("iostat must be an integer variable");
  418.             frexpr(IOSTP);
  419.             IOSTP = NULL;
  420.         }
  421.  
  422.     if(iostmt == IOREAD)
  423.     {
  424.         if(IOSTP)
  425.         {
  426.             if(ioerrlab && ioendlab && ioerrlab==ioendlab)
  427.                 jumplab = ioerrlab;
  428.             else
  429.                 skiplab = jumplab = newiolabel();
  430.         }
  431.         else    {
  432.             if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
  433.             {
  434.                 IOSTP = (expptr) mktmp(TYINT, ENULL);
  435.                 skiplab = jumplab = newiolabel();
  436.             }
  437.             else
  438.                 jumplab = (ioerrlab ? ioerrlab : ioendlab);
  439.         }
  440.     }
  441.     else if(iostmt == IOWRITE)
  442.     {
  443.         if(IOSTP && !ioerrlab)
  444.             skiplab = jumplab = newiolabel();
  445.         else
  446.             jumplab = ioerrlab;
  447.     }
  448.     else
  449.         jumplab = ioerrlab;
  450.  
  451.     endbit = IOSTP!=NULL || ioendlab!=0;    /* for use in startrw() */
  452.     errbit = IOSTP!=NULL || ioerrlab!=0;
  453.     if (jumplab && !IOSTP)
  454.         IOSTP = (expptr) mktmp(TYINT, ENULL);
  455.  
  456.     if(iostmt!=IOREAD && iostmt!=IOWRITE)
  457.     {
  458.         ios = io_stuff + iostmt;
  459.         io_fields = ios->fields;
  460.         ioblkp = io_structs[iostmt];
  461.         if(ioblkp == NULL)
  462.             io_structs[iostmt] = ioblkp =
  463.                 autovar(1, ios->type, ENULL, "");
  464.         ioset(TYIOINT, XERR, ICON(errbit));
  465.     }
  466.  
  467.     switch(iostmt)
  468.     {
  469.     case IOOPEN:
  470.         dofopen();
  471.         break;
  472.  
  473.     case IOCLOSE:
  474.         dofclose();
  475.         break;
  476.  
  477.     case IOINQUIRE:
  478.         dofinquire();
  479.         break;
  480.  
  481.     case IOBACKSPACE:
  482.         dofmove("f_back");
  483.         break;
  484.  
  485.     case IOREWIND:
  486.         dofmove("f_rew");
  487.         break;
  488.  
  489.     case IOENDFILE:
  490.         dofmove("f_end");
  491.         break;
  492.  
  493.     case IOREAD:
  494.     case IOWRITE:
  495.         startrw();
  496.         break;
  497.  
  498.     default:
  499.         fatali("impossible iostmt %d", iostmt);
  500.     }
  501.     for(i = 1 ; i<=NIOS ; ++i)
  502.         if(i!=IOSIOSTAT && V(i)!=NULL)
  503.             frexpr(V(i));
  504. }
  505.  
  506.  
  507.  
  508. iocname()
  509. {
  510.     register int i;
  511.     int found, mask;
  512.  
  513.     found = 0;
  514.     mask = M(iostmt);
  515.     for(i = 1 ; i <= NIOS ; ++i)
  516.         if(!strcmp(ioc[i].iocname, token))
  517.             if(ioc[i].iotype & mask)
  518.                 return(i);
  519.             else {
  520.                 found = i;
  521.                 break;
  522.                 }
  523.     if(found) {
  524.         if (iostmt == IOOPEN && !strcmp(ioc[i].iocname, "name")) {
  525.             NOEXT("open with \"name=\" treated as \"file=\"");
  526.             for(i = 1; strcmp(ioc[i].iocname, "file"); i++);
  527.             return i;
  528.             }
  529.         errstr("invalid control %s for statement", ioc[found].iocname);
  530.         }
  531.     else
  532.         errstr("unknown iocontrol %s", token);
  533.     return(IOSBAD);
  534. }
  535.  
  536.  
  537. ioclause(n, p)
  538. register int n;
  539. register expptr p;
  540. {
  541.     struct Ioclist *iocp;
  542.  
  543.     ++nioctl;
  544.     if(n == IOSBAD)
  545.         return;
  546.     if(n == IOSPOSITIONAL)
  547.         {
  548.         n = nioctl;
  549.         if (n == IOSFMT) {
  550.             if (iostmt == IOOPEN) {
  551.                 n = IOSFILE;
  552.                 NOEXT("file= specifier omitted from open");
  553.                 }
  554.             else if (iostmt < IOREAD)
  555.                 goto illegal;
  556.             }
  557.         else if(n > IOSFMT)
  558.             {
  559.  illegal:
  560.             err("illegal positional iocontrol");
  561.             return;
  562.             }
  563.         }
  564.     else if (n == IOSNML)
  565.         n = IOSFMT;
  566.  
  567.     if(p == NULL)
  568.     {
  569.         if(n == IOSUNIT)
  570.             p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
  571.         else if(n != IOSFMT)
  572.         {
  573.             err("illegal * iocontrol");
  574.             return;
  575.         }
  576.     }
  577.     if(n == IOSFMT)
  578.         ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
  579.  
  580.     iocp = & ioc[n];
  581.     if(iocp->iocval == NULL)
  582.     {
  583.         if(n!=IOSFMT && ( n!=IOSUNIT || (p && p->headblock.vtype!=TYCHAR) ) )
  584.             p = fixtype(p);
  585.         else if (p && p->tag == TPRIM
  586.                && p->primblock.namep->vclass == CLUNKNOWN) {
  587.             /* kludge made necessary by attempt to infer types
  588.              * for untyped external parameters: given an error
  589.              * in calling sequences, an integer argument might
  590.              * tentatively be assumed TYCHAR; this would otherwise
  591.              * be corrected too late in startrw after startrw
  592.              * had decided this to be an internal file.
  593.              */
  594.             vardcl(p->primblock.namep);
  595.             p->primblock.vtype = p->primblock.namep->vtype;
  596.             }
  597.         iocp->iocval = p;
  598.     }
  599.     else
  600.         errstr("iocontrol %s repeated", iocp->iocname);
  601. }
  602.  
  603. /* io list item */
  604.  
  605. doio(list)
  606. chainp list;
  607. {
  608.     expptr call0();
  609.  
  610.     if(ioformatted == NAMEDIRECTED)
  611.     {
  612.         if(list)
  613.             err("no I/O list allowed in NAMELIST read/write");
  614.     }
  615.     else
  616.     {
  617.         doiolist(list);
  618.         ioroutine[0] = 'e';
  619.         if (skiplab || ioroutine[4] == 'l')
  620.             jumplab = 0;
  621.         putiocall( call0(TYINT, ioroutine) );
  622.     }
  623. }
  624.  
  625.  
  626.  
  627.  
  628.  
  629.  LOCAL void
  630. doiolist(p0)
  631.  chainp p0;
  632. {
  633.     chainp p;
  634.     register tagptr q;
  635.     register expptr qe;
  636.     register Namep qn;
  637.     Addrp tp, mkscalar();
  638.     int range;
  639.     extern char *ohalign;
  640.  
  641.     for (p = p0 ; p ; p = p->nextp)
  642.     {
  643.         q = (tagptr)p->datap;
  644.         if(q->tag == TIMPLDO)
  645.         {
  646.             exdo(range=newlabel(), (Namep)0,
  647.                 q->impldoblock.impdospec);
  648.             doiolist(q->impldoblock.datalist);
  649.             enddo(range);
  650.             free( (charptr) q);
  651.         }
  652.         else    {
  653.             if(q->tag==TPRIM && q->primblock.argsp==NULL
  654.                 && q->primblock.namep->vdim!=NULL)
  655.             {
  656.                 vardcl(qn = q->primblock.namep);
  657.                 if(qn->vdim->nelt) {
  658.                     putio( fixtype(cpexpr(qn->vdim->nelt)),
  659.                         (expptr)mkscalar(qn) );
  660.                     qn->vlastdim = 0;
  661.                     }
  662.                 else
  663.                     err("attempt to i/o array of unknown size");
  664.             }
  665.             else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
  666.                 (qe = (expptr) memversion(q->primblock.namep)) )
  667.                 putio(ICON(1),qe);
  668.             else if (ISCONST(q) && q->constblock.vtype == TYCHAR) {
  669.                 halign = 0;
  670.                 putio(ICON(1), qe = fixtype(cpexpr(q)));
  671.                 halign = ohalign;
  672.                 }
  673.             else if(((qe = fixtype(cpexpr(q)))->tag==TADDR &&
  674.                 (qe->addrblock.uname_tag != UNAM_CONST ||
  675.                 !ISCOMPLEX(qe -> addrblock.vtype))) ||
  676.                 (qe -> tag == TCONST && !ISCOMPLEX(qe ->
  677.                 headblock.vtype))) {
  678.                 if (qe -> tag == TCONST)
  679.                     qe = (expptr) putconst((Constp)qe);
  680.                 putio(ICON(1), qe);
  681.             }
  682.             else if(qe->headblock.vtype != TYERROR)
  683.             {
  684.                 if(iostmt == IOWRITE)
  685.                 {
  686.                     ftnint lencat();
  687.                     expptr qvl;
  688.                     qvl = NULL;
  689.                     if( ISCHAR(qe) )
  690.                     {
  691.                         qvl = (expptr)
  692.                             cpexpr(qe->headblock.vleng);
  693.                         tp = mktmp(qe->headblock.vtype,
  694.                             ICON(lencat(qe)));
  695.                     }
  696.                     else
  697.                         tp = mktmp(qe->headblock.vtype,
  698.                             qe->headblock.vleng);
  699.                     puteq( cpexpr((expptr)tp), qe);
  700.                     if(qvl)    /* put right length on block */
  701.                     {
  702.                         frexpr(tp->vleng);
  703.                         tp->vleng = qvl;
  704.                     }
  705.                     putio(ICON(1), (expptr)tp);
  706.                 }
  707.                 else
  708.                     err("non-left side in READ list");
  709.             }
  710.             frexpr(q);
  711.         }
  712.     }
  713.     frchain( &p0 );
  714. }
  715.  
  716.  int iocalladdr = TYADDR;    /* for fixing TYADDR in saveargtypes */
  717.  int typeconv[TYERROR+1] = {
  718. #ifdef TYQUAD
  719.         0, 1, 11, 2, 3, 14, 4, 5, 6, 7, 12, 13, 8, 9, 10, 15
  720. #else
  721.         0, 1, 11, 2, 3,     4, 5, 6, 7, 12, 13, 8, 9, 10, 14
  722. #endif
  723.         };
  724.  
  725.  LOCAL void
  726. putio(nelt, addr)
  727.  expptr nelt;
  728.  register expptr addr;
  729. {
  730.     int type;
  731.     register expptr q;
  732.     register Addrp c = 0;
  733.  
  734.     type = addr->headblock.vtype;
  735.     if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
  736.     {
  737.         nelt = mkexpr(OPSTAR, ICON(2), nelt);
  738.         type -= (TYCOMPLEX-TYREAL);
  739.     }
  740.  
  741.     /* pass a length with every item.  for noncharacter data, fake one */
  742.     if(type != TYCHAR)
  743.     {
  744.  
  745.         if( ISCONST(addr) )
  746.             addr = (expptr) putconst((Constp)addr);
  747.         c = ALLOC(Addrblock);
  748.         c->tag = TADDR;
  749.         c->vtype = TYLENG;
  750.         c->vstg = STGAUTO;
  751.         c->ntempelt = 1;
  752.         c->isarray = 1;
  753.         c->memoffset = ICON(0);
  754.         c->uname_tag = UNAM_IDENT;
  755.         c->charleng = 1;
  756.         sprintf(c->user.ident, "(ftnlen)sizeof(%s)", typename[type]);
  757.         addr = mkexpr(OPCHARCAST, addr, ENULL);
  758.         }
  759.  
  760.     nelt = fixtype( mkconv(tyioint,nelt) );
  761.     if(ioformatted == LISTDIRECTED) {
  762.         expptr mc = mkconv(tyioint, ICON(typeconv[type]));
  763.         q = c    ? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c)
  764.             : call3(TYINT, "do_lio", mc, nelt, addr);
  765.         }
  766.     else {
  767.         char *s = ioformatted==FORMATTED ? "do_fio" : "do_uio";
  768.         q = c    ? call3(TYINT, s, nelt, addr, (expptr)c)
  769.             : call2(TYINT, s, nelt, addr);
  770.         }
  771.     iocalladdr = TYCHAR;
  772.     putiocall(q);
  773.     iocalladdr = TYADDR;
  774. }
  775.  
  776.  
  777.  
  778.  
  779. endio()
  780. {
  781.     extern void p1_label();
  782.  
  783.     if(skiplab)
  784.     {
  785.         if (ioformatted != NAMEDIRECTED)
  786.             p1_label((long)(skiplabel - labeltab));
  787.         if(ioendlab) {
  788.             exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0)));
  789.             exgoto(execlab(ioendlab));
  790.             exendif();
  791.             }
  792.         if(ioerrlab) {
  793.             exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE
  794.                     ? OPGT : OPNE,
  795.                 cpexpr(IOSTP), ICON(0)));
  796.             exgoto(execlab(ioerrlab));
  797.             exendif();
  798.             }
  799.     }
  800.  
  801.     if(IOSTP)
  802.         frexpr(IOSTP);
  803. }
  804.  
  805.  
  806.  
  807.  LOCAL void
  808. putiocall(q)
  809.  register expptr q;
  810. {
  811.     int tyintsave;
  812.  
  813.     tyintsave = tyint;
  814.     tyint = tyioint;    /* for -I2 and -i2 */
  815.  
  816.     if(IOSTP)
  817.     {
  818.         q->headblock.vtype = TYINT;
  819.         q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q));
  820.     }
  821.     putexpr(q);
  822.     if(jumplab) {
  823.         exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0)));
  824.         exgoto(execlab(jumplab));
  825.         exendif();
  826.         }
  827.     tyint = tyintsave;
  828. }
  829.  
  830.  void
  831. fmtname(np, q)
  832.  Namep np;
  833.  register Addrp q;
  834. {
  835.     register int k;
  836.     register char *s, *t;
  837.     extern chainp assigned_fmts;
  838.  
  839.     if (!np->vfmt_asg) {
  840.         np->vfmt_asg = 1;
  841.         assigned_fmts = mkchain((char *)np, assigned_fmts);
  842.         }
  843.     k = strlen(s = np->fvarname);
  844.     if (k < IDENT_LEN - 4) {
  845.         q->uname_tag = UNAM_IDENT;
  846.         t = q->user.ident;
  847.         }
  848.     else {
  849.         q->uname_tag = UNAM_CHARP;
  850.         q->user.Charp = t = mem(k + 5,0);
  851.         }
  852.     sprintf(t, "%s_fmt", s);
  853.     }
  854.  
  855. LOCAL Addrp asg_addr(p)
  856.  union Expression *p;
  857. {
  858.     register Addrp q;
  859.  
  860.     if (p->tag != TPRIM)
  861.         badtag("asg_addr", p->tag);
  862.     q = ALLOC(Addrblock);
  863.     q->tag = TADDR;
  864.     q->vtype = TYCHAR;
  865.     q->vstg = STGAUTO;
  866.     q->ntempelt = 1;
  867.     q->isarray = 0;
  868.     q->memoffset = ICON(0);
  869.     fmtname(p->primblock.namep, q);
  870.     return q;
  871.     }
  872.  
  873. startrw()
  874. {
  875.     register expptr p;
  876.     register Namep np;
  877.     register Addrp unitp, fmtp, recp;
  878.     register expptr nump;
  879.     Addrp mkscalar();
  880.     expptr mkaddcon();
  881.     int iostmt1;
  882.     flag intfile, sequential, ok, varfmt;
  883.     struct io_setup *ios;
  884.  
  885.     /* First look at all the parameters and determine what is to be done */
  886.  
  887.     ok = YES;
  888.     statstruct = YES;
  889.  
  890.     intfile = NO;
  891.     if(p = V(IOSUNIT))
  892.     {
  893.         if( ISINT(p->headblock.vtype) ) {
  894.  int_unit:
  895.             unitp = (Addrp) cpexpr(p);
  896.             }
  897.         else if(p->headblock.vtype == TYCHAR)
  898.         {
  899.             if (nioctl == 1 && iostmt == IOREAD) {
  900.                 /* kludge to recognize READ(format expr) */
  901.                 V(IOSFMT) = p;
  902.                 V(IOSUNIT) = p = (expptr) IOSTDIN;
  903.                 ioformatted = FORMATTED;
  904.                 goto int_unit;
  905.                 }
  906.             intfile = YES;
  907.             if(p->tag==TPRIM && p->primblock.argsp==NULL &&
  908.                 (np = p->primblock.namep)->vdim!=NULL)
  909.             {
  910.                 vardcl(np);
  911.                 if(nump = np->vdim->nelt)
  912.                 {
  913.                     nump = fixtype(cpexpr(nump));
  914.                     if( ! ISCONST(nump) ) {
  915.                         statstruct = NO;
  916.                         np->vlastdim = 0;
  917.                         }
  918.                 }
  919.                 else
  920.                 {
  921.                     err("attempt to use internal unit array of unknown size");
  922.                     ok = NO;
  923.                     nump = ICON(1);
  924.                 }
  925.                 unitp = mkscalar(np);
  926.             }
  927.             else    {
  928.                 nump = ICON(1);
  929.                 unitp = (Addrp /*pjw */) fixtype(cpexpr(p));
  930.             }
  931.             if(! isstatic((expptr)unitp) )
  932.                 statstruct = NO;
  933.         }
  934.         else {
  935.             err("unit specifier not of type integer or character");
  936.             ok = NO;
  937.             }
  938.     }
  939.     else
  940.     {
  941.         err("bad unit specifier");
  942.         ok = NO;
  943.     }
  944.  
  945.     sequential = YES;
  946.     if(p = V(IOSREC))
  947.         if( ISINT(p->headblock.vtype) )
  948.         {
  949.             recp = (Addrp) cpexpr(p);
  950.             sequential = NO;
  951.         }
  952.         else    {
  953.             err("bad REC= clause");
  954.             ok = NO;
  955.         }
  956.     else
  957.         recp = NULL;
  958.  
  959.  
  960.     varfmt = YES;
  961.     fmtp = NULL;
  962.     if(p = V(IOSFMT))
  963.     {
  964.         if(p->tag==TPRIM && p->primblock.argsp==NULL)
  965.         {
  966.             np = p->primblock.namep;
  967.             if(np->vclass == CLNAMELIST)
  968.             {
  969.                 ioformatted = NAMEDIRECTED;
  970.                 fmtp = (Addrp) fixtype(p);
  971.                 V(IOSFMT) = (expptr)fmtp;
  972.                 if (skiplab)
  973.                     jumplab = 0;
  974.                 goto endfmt;
  975.             }
  976.             vardcl(np);
  977.             if(np->vdim)
  978.             {
  979.                 if( ! ONEOF(np->vstg, MSKSTATIC) )
  980.                     statstruct = NO;
  981.                 fmtp = mkscalar(np);
  982.                 goto endfmt;
  983.             }
  984.             if( ISINT(np->vtype) )    /* ASSIGNed label */
  985.             {
  986.                 statstruct = NO;
  987.                 varfmt = YES;
  988.                 fmtp = asg_addr(p);
  989.                 goto endfmt;
  990.             }
  991.         }
  992.         p = V(IOSFMT) = fixtype(p);
  993.         if(p->headblock.vtype == TYCHAR
  994.             /* Since we allow write(6,n)        */
  995.             /* we may as well allow write(6,n(2))    */
  996.         || p->tag == TADDR && ISINT(p->addrblock.vtype))
  997.         {
  998.             if( ! isstatic(p) )
  999.                 statstruct = NO;
  1000.             fmtp = (Addrp) cpexpr(p);
  1001.         }
  1002.         else if( ISICON(p) )
  1003.         {
  1004.             struct Labelblock *lp;
  1005.             lp = mklabel(p->constblock.Const.ci);
  1006.             if (fmtstmt(lp) > 0)
  1007.             {
  1008.                 fmtp = (Addrp)mkaddcon(lp->stateno);
  1009.                 /* lp->stateno for names fmt_nnn */
  1010.                 lp->fmtlabused = 1;
  1011.                 varfmt = NO;
  1012.             }
  1013.             else
  1014.                 ioformatted = UNFORMATTED;
  1015.         }
  1016.         else    {
  1017.             err("bad format descriptor");
  1018.             ioformatted = UNFORMATTED;
  1019.             ok = NO;
  1020.         }
  1021.     }
  1022.     else
  1023.         fmtp = NULL;
  1024.  
  1025. endfmt:
  1026.     if(intfile) {
  1027.         if (ioformatted==UNFORMATTED) {
  1028.             err("unformatted internal I/O not allowed");
  1029.             ok = NO;
  1030.             }
  1031.         if (recp) {
  1032.             err("direct internal I/O not allowed");
  1033.             ok = NO;
  1034.             }
  1035.         }
  1036.     if(!sequential && ioformatted==LISTDIRECTED)
  1037.     {
  1038.         err("direct list-directed I/O not allowed");
  1039.         ok = NO;
  1040.     }
  1041.     if(!sequential && ioformatted==NAMEDIRECTED)
  1042.     {
  1043.         err("direct namelist I/O not allowed");
  1044.         ok = NO;
  1045.     }
  1046.  
  1047.     if( ! ok ) {
  1048.         statstruct = NO;
  1049.         return;
  1050.         }
  1051.  
  1052.     /*
  1053.    Now put out the I/O structure, statically if all the clauses
  1054.    are constants, dynamically otherwise
  1055. */
  1056.  
  1057.     if (intfile) {
  1058.         ios = io_stuff + iostmt;
  1059.         iostmt1 = IOREAD;
  1060.         }
  1061.     else {
  1062.         ios = io_stuff;
  1063.         iostmt1 = 0;
  1064.         }
  1065.     io_fields = ios->fields;
  1066.     if(statstruct)
  1067.     {
  1068.         ioblkp = ALLOC(Addrblock);
  1069.         ioblkp->tag = TADDR;
  1070.         ioblkp->vtype = ios->type;
  1071.         ioblkp->vclass = CLVAR;
  1072.         ioblkp->vstg = STGINIT;
  1073.         ioblkp->memno = ++lastvarno;
  1074.         ioblkp->memoffset = ICON(0);
  1075.         ioblkp -> uname_tag = UNAM_IDENT;
  1076.         new_iob_data(ios,
  1077.             temp_name("io_", lastvarno, ioblkp->user.ident));            }
  1078.     else if(!(ioblkp = io_structs[iostmt1]))
  1079.         io_structs[iostmt1] = ioblkp =
  1080.             autovar(1, ios->type, ENULL, "");
  1081.  
  1082.     ioset(TYIOINT, XERR, ICON(errbit));
  1083.     if(iostmt == IOREAD)
  1084.         ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );
  1085.  
  1086.     if(intfile)
  1087.     {
  1088.         ioset(TYIOINT, XIRNUM, nump);
  1089.         ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
  1090.         ioseta(XIUNIT, unitp);
  1091.     }
  1092.     else
  1093.         ioset(TYIOINT, XUNIT, (expptr) unitp);
  1094.  
  1095.     if(recp)
  1096.         ioset(TYIOINT, /* intfile ? XIREC : */ XREC, (expptr) recp);
  1097.  
  1098.     if(varfmt)
  1099.         ioseta( intfile ? XIFMT : XFMT , fmtp);
  1100.     else
  1101.         ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);
  1102.  
  1103.     ioroutine[0] = 's';
  1104.     ioroutine[1] = '_';
  1105.     ioroutine[2] = iostmt==IOREAD ? 'r' : 'w';
  1106.     ioroutine[3] = "ds"[sequential];
  1107.     ioroutine[4] = "ufln"[ioformatted];
  1108.     ioroutine[5] = "ei"[intfile];
  1109.     ioroutine[6] = '\0';
  1110.  
  1111.     putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) ));
  1112.  
  1113.     if(statstruct)
  1114.     {
  1115.         frexpr((expptr)ioblkp);
  1116.         statstruct = NO;
  1117.         ioblkp = 0;    /* unnecessary */
  1118.     }
  1119. }
  1120.  
  1121.  
  1122.  
  1123.  LOCAL void
  1124. dofopen()
  1125. {
  1126.     register expptr p;
  1127.  
  1128.     if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
  1129.         ioset(TYIOINT, XUNIT, cpexpr(p) );
  1130.     else
  1131.         err("bad unit in open");
  1132.     if( (p = V(IOSFILE)) )
  1133.         if(p->headblock.vtype == TYCHAR)
  1134.             ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) );
  1135.         else
  1136.             err("bad file in open");
  1137.  
  1138.     iosetc(XFNAME, p);
  1139.  
  1140.     if(p = V(IOSRECL))
  1141.         if( ISINT(p->headblock.vtype) )
  1142.             ioset(TYIOINT, XRECLEN, cpexpr(p) );
  1143.         else
  1144.             err("bad recl");
  1145.     else
  1146.         ioset(TYIOINT, XRECLEN, ICON(0) );
  1147.  
  1148.     iosetc(XSTATUS, V(IOSSTATUS));
  1149.     iosetc(XACCESS, V(IOSACCESS));
  1150.     iosetc(XFORMATTED, V(IOSFORM));
  1151.     iosetc(XBLANK, V(IOSBLANK));
  1152.  
  1153.     putiocall( call1(TYINT, "f_open", cpexpr((expptr)ioblkp) ));
  1154. }
  1155.  
  1156.  
  1157.  LOCAL void
  1158. dofclose()
  1159. {
  1160.     register expptr p;
  1161.  
  1162.     if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
  1163.     {
  1164.         ioset(TYIOINT, XUNIT, cpexpr(p) );
  1165.         iosetc(XCLSTATUS, V(IOSSTATUS));
  1166.         putiocall( call1(TYINT, "f_clos", cpexpr((expptr)ioblkp)) );
  1167.     }
  1168.     else
  1169.         err("bad unit in close statement");
  1170. }
  1171.  
  1172.  
  1173.  LOCAL void
  1174. dofinquire()
  1175. {
  1176.     register expptr p;
  1177.     if(p = V(IOSUNIT))
  1178.     {
  1179.         if( V(IOSFILE) )
  1180.             err("inquire by unit or by file, not both");
  1181.         ioset(TYIOINT, XUNIT, cpexpr(p) );
  1182.     }
  1183.     else if( ! V(IOSFILE) )
  1184.         err("must inquire by unit or by file");
  1185.     iosetlc(IOSFILE, XFILE, XFILELEN);
  1186.     iosetip(IOSEXISTS, XEXISTS);
  1187.     iosetip(IOSOPENED, XOPEN);
  1188.     iosetip(IOSNUMBER, XNUMBER);
  1189.     iosetip(IOSNAMED, XNAMED);
  1190.     iosetlc(IOSNAME, XNAME, XNAMELEN);
  1191.     iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
  1192.     iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
  1193.     iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
  1194.     iosetlc(IOSFORM, XFORM, XFORMLEN);
  1195.     iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
  1196.     iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
  1197.     iosetip(IOSRECL, XQRECL);
  1198.     iosetip(IOSNEXTREC, XNEXTREC);
  1199.     iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
  1200.  
  1201.     putiocall( call1(TYINT,  "f_inqu", cpexpr((expptr)ioblkp) ));
  1202. }
  1203.  
  1204.  
  1205.  
  1206.  LOCAL void
  1207. dofmove(subname)
  1208.  char *subname;
  1209. {
  1210.     register expptr p;
  1211.  
  1212.     if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
  1213.     {
  1214.         ioset(TYIOINT, XUNIT, cpexpr(p) );
  1215.         putiocall( call1(TYINT, subname, cpexpr((expptr)ioblkp) ));
  1216.     }
  1217.     else
  1218.         err("bad unit in I/O motion statement");
  1219. }
  1220.  
  1221. static int ioset_assign = OPASSIGN;
  1222.  
  1223.  LOCAL void
  1224. ioset(type, offset, p)
  1225.  int type, offset;
  1226.  register expptr p;
  1227. {
  1228.     offset /= SZLONG;
  1229.     if(statstruct && ISCONST(p)) {
  1230.         register char *s;
  1231.         switch(type) {
  1232.             case TYADDR:    /* stmt label */
  1233.                 s = "fmt_";
  1234.                 break;
  1235.             case TYIOINT:
  1236.                 s = "";
  1237.                 break;
  1238.             default:
  1239.                 badtype("ioset", type);
  1240.             }
  1241.         iob_list->fields[offset] =
  1242.             string_num(s, p->constblock.Const.ci);
  1243.         frexpr(p);
  1244.         }
  1245.     else {
  1246.         register Addrp q;
  1247.  
  1248.         q = ALLOC(Addrblock);
  1249.         q->tag = TADDR;
  1250.         q->vtype = type;
  1251.         q->vstg = STGAUTO;
  1252.         q->ntempelt = 1;
  1253.         q->isarray = 0;
  1254.         q->memoffset = ICON(0);
  1255.         q->uname_tag = UNAM_IDENT;
  1256.         sprintf(q->user.ident, "%s.%s",
  1257.             statstruct ? iob_list->name : ioblkp->user.ident,
  1258.             io_fields[offset + 1]);
  1259.         if (type == TYADDR && p->tag == TCONST
  1260.                    && p->constblock.vtype == TYADDR) {
  1261.             /* kludge */
  1262.             register Addrp p1;
  1263.             p1 = ALLOC(Addrblock);
  1264.             p1->tag = TADDR;
  1265.             p1->vtype = type;
  1266.             p1->vstg = STGAUTO;    /* wrong, but who cares? */
  1267.             p1->ntempelt = 1;
  1268.             p1->isarray = 0;
  1269.             p1->memoffset = ICON(0);
  1270.             p1->uname_tag = UNAM_IDENT;
  1271.             sprintf(p1->user.ident, "fmt_%ld",
  1272.                 p->constblock.Const.ci);
  1273.             frexpr(p);
  1274.             p = (expptr)p1;
  1275.             }
  1276.         if (type == TYADDR && p->headblock.vtype == TYCHAR)
  1277.             q->vtype = TYCHAR;
  1278.         putexpr(mkexpr(ioset_assign, (expptr)q, p));
  1279.         }
  1280. }
  1281.  
  1282.  
  1283.  
  1284.  
  1285.  LOCAL void
  1286. iosetc(offset, p)
  1287.  int offset;
  1288.  register expptr p;
  1289. {
  1290.     extern Addrp putchop();
  1291.  
  1292.     if(p == NULL)
  1293.         ioset(TYADDR, offset, ICON(0) );
  1294.     else if(p->headblock.vtype == TYCHAR) {
  1295.         p = putx(fixtype((expptr)putchop(cpexpr(p))));
  1296.         ioset(TYADDR, offset, addrof(p));
  1297.         }
  1298.     else
  1299.         err("non-character control clause");
  1300. }
  1301.  
  1302.  
  1303.  
  1304.  LOCAL void
  1305. ioseta(offset, p)
  1306.  int offset;
  1307.  register Addrp p;
  1308. {
  1309.     char *s, *s1;
  1310.     static char who[] = "ioseta";
  1311.     expptr e, mo;
  1312.     Namep np;
  1313.     ftnint ci;
  1314.     int k;
  1315.     char buf[24], buf1[24];
  1316.     Extsym *comm;
  1317.     extern int usedefsforcommon;
  1318.  
  1319.     if(statstruct)
  1320.     {
  1321.         if (!p)
  1322.             return;
  1323.         if (p->tag != TADDR)
  1324.             badtag(who, p->tag);
  1325.         offset /= SZLONG;
  1326.         switch(p->uname_tag) {
  1327.             case UNAM_NAME:
  1328.             mo = p->memoffset;
  1329.             if (mo->tag != TCONST)
  1330.                 badtag("ioseta/memoffset", mo->tag);
  1331.             np = p->user.name;
  1332.             np->visused = 1;
  1333.             ci = mo->constblock.Const.ci - np->voffset;
  1334.             if (np->vstg == STGCOMMON
  1335.             && !np->vcommequiv
  1336.             && !usedefsforcommon) {
  1337.                 comm = &extsymtab[np->vardesc.varno];
  1338.                 sprintf(buf, "%d.", comm->curno);
  1339.                 k = strlen(buf) + strlen(comm->cextname)
  1340.                     + strlen(np->cvarname);
  1341.                 if (ci) {
  1342.                     sprintf(buf1, "+%ld", ci);
  1343.                     k += strlen(buf1);
  1344.                     }
  1345.                 else
  1346.                     buf1[0] = 0;
  1347.                 s = mem(k + 1, 0);
  1348.                 sprintf(s, "%s%s%s%s", comm->cextname, buf,
  1349.                     np->cvarname, buf1);
  1350.                 }
  1351.             else if (ci) {
  1352.                 sprintf(buf,"%ld", ci);
  1353.                 s1 = p->user.name->cvarname;
  1354.                 k = strlen(buf) + strlen(s1);
  1355.                 sprintf(s = mem(k+2,0), "%s+%s", s1, buf);
  1356.                 }
  1357.             else
  1358.                 s = cpstring(np->cvarname);
  1359.             break;
  1360.             case UNAM_CONST:
  1361.             s = tostring(p->user.Const.ccp1.ccp0,
  1362.                 (int)p->vleng->constblock.Const.ci);
  1363.             break;
  1364.             default:
  1365.             badthing("uname_tag", who, p->uname_tag);
  1366.             }
  1367.         /* kludge for Hollerith */
  1368.         if (p->vtype != TYCHAR) {
  1369.             s1 = mem(strlen(s)+10,0);
  1370.             sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s);
  1371.             s = s1;
  1372.             }
  1373.         iob_list->fields[offset] = s;
  1374.     }
  1375.     else {
  1376.         if (!p)
  1377.             e = ICON(0);
  1378.         else if (p->vtype != TYCHAR) {
  1379.             NOEXT("non-character variable as format or internal unit");
  1380.             e = mkexpr(OPCHARCAST, (expptr)p, ENULL);
  1381.             }
  1382.         else
  1383.             e = addrof((expptr)p);
  1384.         ioset(TYADDR, offset, e);
  1385.         }
  1386. }
  1387.  
  1388.  
  1389.  
  1390.  
  1391.  LOCAL void
  1392. iosetip(i, offset)
  1393.  int i, offset;
  1394. {
  1395.     register expptr p;
  1396.  
  1397.     if(p = V(i))
  1398.         if(p->tag==TADDR &&
  1399.             ONEOF(p->addrblock.vtype, inqmask) ) {
  1400.             ioset_assign = OPASSIGNI;
  1401.             ioset(TYADDR, offset, addrof(cpexpr(p)) );
  1402.             ioset_assign = OPASSIGN;
  1403.             }
  1404.         else
  1405.             errstr("impossible inquire parameter %s", ioc[i].iocname);
  1406.     else
  1407.         ioset(TYADDR, offset, ICON(0) );
  1408. }
  1409.  
  1410.  
  1411.  
  1412.  LOCAL void
  1413. iosetlc(i, offp, offl)
  1414.  int i, offp, offl;
  1415. {
  1416.     register expptr p;
  1417.     if( (p = V(i)) && p->headblock.vtype==TYCHAR)
  1418.         ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
  1419.     iosetc(offp, p);
  1420. }
  1421.