libf2c/libI77/xwsne.c

   1 #include "config.h"
   2 #include "f2c.h"
   3 #include "fio.h"
   4 #include "lio.h"
   5 #include "fmt.h"
   6
   7 extern int f__Aquote;
   8
   9 static void
  10 nl_donewrec (void)
  11 {
  12   (*f__donewrec) ();
  13   PUT (' ');
  14 }
  15
  16 #include <string.h>
  17
  18 void
  19 x_wsne (cilist * a)
  20 {
  21   Namelist *nl;
  22   char *s;
  23   Vardesc *v, **vd, **vde;
  24   ftnint number, type;
  25   ftnlen *dims;
  26   ftnlen size;
  27   extern ftnlen f__typesize[];
  28
  29   nl = (Namelist *) a->cifmt;
  30   PUT ('&');
  31   for (s = nl->name; *s; s++)
  32     PUT (*s);
  33   PUT (' ');
  34   f__Aquote = 1;
  35   vd = nl->vars;
  36   vde = vd + nl->nvars;
  37   while (vd < vde)
  38     {
  39       v = *vd++;
  40       s = v->name;
  41 #ifdef No_Extra_Namelist_Newlines
  42       if (f__recpos + strlen (s) + 2 >= L_len)
  43 #endif
  44         nl_donewrec ();
  45       while (*s)
  46         PUT (*s++);
  47       PUT (' ');
  48       PUT ('=');
  49       number = (dims = v->dims) ? dims[1] : 1;
  50       type = v->type;
  51       if (type < 0)
  52         {
  53           size = -type;
  54           type = TYCHAR;
  55         }
  56       else
  57         size = f__typesize[type];
  58       l_write (&number, v->addr, size, type);
  59       if (vd < vde)
  60         {
  61           if (f__recpos + 2 >= L_len)
  62             nl_donewrec ();
  63           PUT (',');
  64           PUT (' ');
  65         }
  66       else if (f__recpos + 1 >= L_len)
  67         nl_donewrec ();
  68     }
  69   f__Aquote = 0;
  70   PUT ('/');
  71 }