1 /*
2  * Copyright (c) 1995-2019, NVIDIA CORPORATION.  All rights reserved.
3  *
4  * Licensed under the Apache License, Version 2.0 (the "License");
5  * you may not use this file except in compliance with the License.
6  * You may obtain a copy of the License at
7  *
8  *     http://www.apache.org/licenses/LICENSE-2.0
9  *
10  * Unless required by applicable law or agreed to in writing, software
11  * distributed under the License is distributed on an "AS IS" BASIS,
12  * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13  * See the License for the specific language governing permissions and
14  * limitations under the License.
15  *
16  */
17 
18 /* clang-format off */
19 
20 /*  encodefmt.c - translate format string into encoded form at runtime. */
21 
22 #include "global.h"
23 #include "feddesc.h"
24 
25 #define STACK_SIZE 20 /* max nesting depth of parens */
26 #define is_digit(c) ((c) >= '0' && (c) <= '9')
27 
28 typedef int ERRCODE;
29 
30 static long numval; /* numeric value computed by ef_getnum */
31 static char *firstchar, *lastchar;
32 static int curpos; /* current avail posn in output buffer */
33 static int paren_stack[STACK_SIZE];
34 static bool enclosing_parens;
35 static INT *buff = NULL;
36 static int buffsize = 0;
37 static char quote;
38 
39 static ERRCODE check_outer_parens(char *, __CLEN_T);
40 static bool ef_getnum(char *, int *);
41 static int ef_nextchar(char *, int *);
42 static void ef_put(INT);
43 static void ef_putnum(INT);
44 static ERRCODE ef_putstring(char *, INT, int);
45 static void ef_alloc(int);
46 static INT ef_error(ERRCODE);
47 static void ef_putvlist(char *, int *);
48 static void ef_putdt();
49 static void ef_putiotype(char *, int *);
50 
51 /* ----------------------------------------------------------------------- */
52 
53 static __INT_T
_f90io_encode_fmt(char * str,__INT_T * nelem,__CLEN_T str_siz)54 _f90io_encode_fmt(char *str,      /* unencoded format string */
55                  __INT_T *nelem, /* number of elements if array */
56                  __CLEN_T str_siz)
57 {
58   char *p;
59   char c, cnext;
60   ERRCODE i;
61   int numlen = 0;
62   int code1, code2, code3, code4;
63   bool j;
64   bool rep_count;        /* TRUE if integer token has just been processed */
65   int reversion_loc = 0; /* position in output buffer */
66   int paren_level = 0;   /* current paren nesting level */
67   int k, n;
68   bool unlimited_repeat_count = FALSE;
69 
70   /* the following call is just to ensure __fortio_init() has been called: */
71   __fortio_errinit03(0, 0, NULL, "encode format string");
72   __fortio_fmtinit();
73 
74   /*  make basic checks for legal input and determine if this format has the
75       outer set of parentheses present or not.  Set global variables
76       enclosing_parens, firstchar and lastchar:  */
77 
78   n = 1;
79   if (*nelem)
80     n = *nelem;
81   i = check_outer_parens(str, str_siz * n);
82   if (i != 0)
83     return ef_error(i);
84 
85   curpos = 0; /* current available output buffer position */
86   rep_count = FALSE;
87   p = firstchar;
88 
89   while (p <= lastchar) {
90     c = *p++;
91     switch (c) {
92     case ',':
93       goto check_no_repeat_count;
94 
95     case ' ': /* ignore blanks */
96     case '\t':
97     case '\r':
98       break;
99 
100     case '(':
101       paren_level++;
102       if (paren_level > STACK_SIZE)
103         return ef_error(FIO_EFSYNTAX /*"stack overflow"*/);
104       ef_put(FED_LPAREN);
105       paren_stack[paren_level - 1] = curpos;
106       if (paren_level == 1) {
107         if (rep_count)
108           reversion_loc = curpos - 3; /* point to repeat count */
109         else
110           reversion_loc = curpos - 1; /* point to left paren */
111       }
112       rep_count = FALSE;
113       break;
114 
115     case ')':
116       if (paren_level < 1) {
117         if (enclosing_parens) {
118           enclosing_parens = 0;
119           goto end_of_format; /* ignore remaining part of input */
120         }
121         return ef_error(FIO_EPAREN /*"unbal parens"*/);
122       }
123       while (p <= lastchar && *p == ' ') /* skip spaces */
124         ++p;
125       if (unlimited_repeat_count &&
126           paren_level == 1 &&
127           p <= lastchar &&
128           *p != ')') {
129         /* F'08 unlimited repeat count must be used on the only or last
130          * constituent of the top-level format list.  Compile-time
131          * FORMAT statement parsing allows unlimited repetition to
132          * precede other parenthesized lists, with a warning or
133          * (with -Mstandard) a severe error.
134          */
135         return ef_error(FIO_EFSYNTAX);
136       }
137       paren_level--;
138 
139       if (paren_stack[paren_level] == curpos)
140         return ef_error(FIO_EFSYNTAX /*"syntax - empty parens"*/);
141       ef_put(FED_RPAREN);
142       ef_put(paren_stack[paren_level]);
143       break;
144 
145     case 'p':
146     case 'P': /*  scale factor;  preceding integer required. */
147       if (!rep_count)
148         return ef_error(FIO_EPT /*"illegal P descriptor"*/);
149       rep_count = FALSE;
150       ef_put(FED_P);
151       ef_putnum(numval);
152       break;
153     case '\'':
154     case '\"':
155       quote = c;
156       n = 0; /* count number of quote characters in string */
157       for (k = 0; p + k <= lastchar; k++) {
158         if (p[k] == quote) {
159           if (p + k < lastchar && p[k + 1] == quote)
160             n++, k++; /* two quotes in a row */
161           else
162             break;
163         }
164       }
165 
166       if (p + k > lastchar)
167         return ef_error(FIO_ESTRING /*"unterminated char string"*/);
168 
169       i = ef_putstring(p, k, n);
170       if (i != 0)
171         return ef_error(i);
172       p += (k + 1);
173       goto check_no_repeat_count;
174 
175     case 'h':
176     case 'H':
177       if (!rep_count)
178         return ef_error(FIO_ESTRING /*"illegal Hollerith constant"*/);
179       rep_count = FALSE;
180       quote = '\'';
181       i = ef_putstring(p, numval, 0);
182       if (i != 0)
183         return ef_error(i);
184       p += numval;
185       break;
186 
187     case 't':
188     case 'T': /*  check for TL, TR or T edit descriptors:  */
189       c = ef_nextchar(p, &numlen);
190       p += numlen;
191       if (c == 'L')
192         ef_put(FED_TL);
193       else if (c == 'R')
194         ef_put(FED_TR);
195       else {
196         ef_put(FED_T);
197         p--;
198       }
199       j = ef_getnum(p, &numlen);
200       if (!j) /* number is required */
201         return ef_error(FIO_EPT /*"T descriptor missing value"*/);
202       p += numlen;
203       ef_putnum(numval);
204       goto check_no_repeat_count;
205 
206     case 'x':
207     case 'X':
208       ef_put(FED_X);
209       if (rep_count) {
210         ef_putnum(numval);
211         rep_count = FALSE;
212       } else
213         ef_putnum(1L); /* default repeat count == 1 */
214       break;
215 
216     case 'r':
217     case 'R': /*  check for RU, RD, RZ, RN, RC, or RP descriptor:  */
218       c = ef_nextchar(p, &numlen);
219       switch (c) {
220       case 'U':
221         ef_put(FED_RU);
222         break;
223       case 'D':
224         ef_put(FED_RD);
225         break;
226       case 'Z':
227         ef_put(FED_RZ);
228         break;
229       case 'N':
230         ef_put(FED_RN);
231         break;
232       case 'C':
233         ef_put(FED_RC);
234         break;
235       case 'P':
236         ef_put(FED_RP);
237         break;
238       default:
239         return ef_error(FIO_ELETTER /*"unrecognized format code"*/);
240       }
241       p += numlen;
242       goto check_no_repeat_count;
243 
244     case 's':
245     case 'S': /*  check for SP, SS, or S descriptor:  */
246       c = ef_nextchar(p, &numlen);
247       p += numlen;
248       if (c == 'P')
249         ef_put(FED_SP);
250       else if (c == 'S')
251         ef_put(FED_SS);
252       else {
253         ef_put(FED_S);
254         p--;
255       }
256       goto check_no_repeat_count;
257 
258     case 'b':
259     case 'B': /*  check for BN or BZ edit descriptor: */
260       c = ef_nextchar(p, &numlen);
261       if (c == 'N') {
262         ef_put(FED_BN);
263         p += numlen;
264       } else if (c == 'Z') {
265         ef_put(FED_BZ);
266         p += numlen;
267       } else { /*  process B edit descriptor:  */
268         code1 = FED_Bw_m;
269         rep_count = FALSE;
270         j = ef_getnum(p, &numlen);
271         if (j == FALSE)
272           return ef_error(FIO_EPT /*"illegal B descriptor"*/);
273         p += numlen;
274         ef_put(code1);
275         ef_putnum(numval);
276         c = ef_nextchar(p, &numlen);
277         if (c != '.')
278           ef_putnum(1L); /* default value for 'm' field */
279         else {
280           p += numlen;
281           j = ef_getnum(p, &numlen);
282           if (!j)
283             return ef_error(FIO_EDOT /*"num expected after '.'"*/);
284           ef_putnum(numval);
285           p += numlen;
286         }
287         break;
288       }
289       goto check_no_repeat_count;
290 
291     case '/':
292       rep_count = FALSE;
293       ef_put(FED_SLASH);
294       break;
295 
296     case ':':
297       ef_put(FED_COLON);
298       goto check_no_repeat_count;
299 
300     case 'q':
301     case 'Q':
302       ef_put(FED_Q);
303       goto check_no_repeat_count;
304 
305     case '$':
306       ef_put(FED_DOLLAR);
307       goto check_no_repeat_count;
308 
309     case 'a':
310     case 'A':
311       code1 = FED_Aw;
312       code2 = FED_A;
313       goto A_shared;
314 
315     case 'l':
316     case 'L':
317       code1 = FED_Lw;
318       code2 = FED_L;
319     A_shared: /* process A or L edit descriptor */
320       rep_count = FALSE;
321       j = ef_getnum(p, &numlen);
322       if (j == FALSE)
323         ef_put(code2);
324       else {
325         p += numlen;
326         ef_put(code1);
327         ef_putnum(numval);
328       }
329       break;
330 
331     case 'F':
332     case 'f':
333       code1 = FED_Fw_d;
334       code2 = FED_F;
335       goto F_shared;
336 
337     case 'E':
338     case 'e':
339       c = ef_nextchar(p, &numlen);
340       if (c == 'N') {
341         code1 = FED_ENw_d;
342         p += numlen;
343         goto EN_shared;
344       }
345       if (c == 'S') {
346         code1 = FED_ESw_d;
347         p += numlen;
348         goto EN_shared;
349       }
350       code1 = FED_Ew_d;
351       code2 = FED_E;
352       goto F_shared;
353 
354     EN_shared: /* process EN or ES edit descriptor */
355       rep_count = FALSE;
356       j = ef_getnum(p, &numlen);
357       if (j == FALSE)
358         return ef_error(FIO_EFGD /*"syntax, width expected"*/);
359       p += numlen;
360       ef_put(code1);
361       ef_putnum(numval);
362       c = ef_nextchar(p, &numlen);
363       if (c != '.')
364         return ef_error(FIO_EFGD /*"syntax, '.' expected"*/);
365       else {
366         p += numlen;
367         j = ef_getnum(p, &numlen);
368         if (!j)
369           return ef_error(FIO_EDOT /*"number expd after '.'"*/);
370         ef_putnum(numval);
371         p += numlen;
372 
373         /*  check for E<numval> which optionally follows
374             ENw.d or ESw.d edit descriptors:  */
375 
376         c = ef_nextchar(p, &numlen);
377         if (c == 'E') {
378           p += numlen;
379           ef_put(FED_Ee);
380           j = ef_getnum(p, &numlen);
381           if (!j)
382             return ef_error(FIO_EFGD);
383           p += numlen;
384           ef_putnum(numval);
385         }
386       }
387       break;
388 
389     case 'G':
390     case 'g':
391       code1 = FED_Gw_d;
392       code2 = FED_G;
393       code3 = FED_G0;
394       code4 = FED_G0_d;
395       goto F_shared;
396 
397     case 'D':
398     case 'd':
399       /*  check for DC or DP edit descriptor and DT too: */
400       c = ef_nextchar(p, &numlen);
401       if (c == 'C') {
402         ef_put(FED_DC);
403         p += numlen;
404         goto check_no_repeat_count;
405       }
406       if (c == 'P') {
407         ef_put(FED_DP);
408         p += numlen;
409         goto check_no_repeat_count;
410       }
411       if (c == 'T') {
412         ef_put(FED_DT);
413         p += numlen;
414         c = *(p);
415         if (c == '(') {
416           ef_putnum(2L);
417           ef_putdt();
418           p++;
419           ef_putvlist(p, &numlen);
420           p += numlen;
421         } else if (c == '\'' || c == '\"') {
422           p++;
423           ef_putiotype(p, &numlen);
424           p += numlen;
425         } else {
426           ef_putnum(1L);
427           ef_putdt();
428         }
429         rep_count = FALSE;
430         goto check_no_repeat_count;
431       }
432       /*  process D edit descriptor:  */
433       code1 = FED_Dw_d;
434       code2 = FED_D;
435     F_shared: /*  process F, E, G or D edit descriptor  */
436       rep_count = FALSE;
437       j = ef_getnum(p, &numlen);
438       p += numlen;
439       cnext = ef_nextchar(p, &numlen);
440       p -= numlen;
441       if (j == FALSE) {
442         ef_put(code2);
443       } else if ((c == 'g' || c == 'G') && numval == 0
444                   && cnext != '.') {
445         p += numlen;
446         j = ef_getnum(p, &numlen);
447         if (j == FALSE) {
448           /* G0 */
449           ef_put(code3);
450         } else {
451           return ef_error(FIO_EFGD);
452         }
453       } else {
454         p += numlen;
455         if ((c == 'g' || c == 'G') && numval == 0) {
456           /* G0.d */
457           ef_put(code4);
458         } else {
459           ef_put(code1);
460         }
461         ef_putnum(numval);
462         c = ef_nextchar(p, &numlen);
463         if (c != '.')
464           return ef_error(FIO_EFGD /*"syntax, '.' expected"*/);
465         else {
466           p += numlen;
467           j = ef_getnum(p, &numlen);
468           if (!j)
469             return ef_error(FIO_EDOT /*"number expd after '.'"*/);
470           ef_putnum(numval);
471           p += numlen;
472 
473           /*  check for E<numval> which optionally follows
474               Ew.d or Gw.d edit descriptors:  */
475 
476           if (code1 == FED_Ew_d || code1 == FED_Gw_d) {
477             c = ef_nextchar(p, &numlen);
478             if (c == 'E') {
479               p += numlen;
480               ef_put(FED_Ee);
481               j = ef_getnum(p, &numlen);
482               if (!j)
483                 return ef_error(FIO_EFGD);
484               p += numlen;
485               ef_putnum(numval);
486             }
487           }
488         }
489       }
490       break;
491 
492     case 'I':
493     case 'i':
494       code1 = FED_Iw_m;
495       code2 = FED_I;
496       goto I_shared;
497 
498     case 'O':
499     case 'o':
500       code1 = FED_Ow_m;
501       code2 = FED_O;
502       goto I_shared;
503 
504     case 'Z':
505     case 'z':
506       code1 = FED_Zw_m;
507       code2 = FED_Z;
508     I_shared: /*  process I, O or Z edit descriptor:  */
509       rep_count = FALSE;
510       j = ef_getnum(p, &numlen);
511       if (j == FALSE)
512         ef_put(code2);
513       else {
514         p += numlen;
515         ef_put(code1);
516         ef_putnum(numval);
517         c = ef_nextchar(p, &numlen);
518         if (c != '.')
519           ef_putnum(1L); /* default value for 'm' field */
520         else {
521           p += numlen;
522           j = ef_getnum(p, &numlen);
523           if (!j)
524             return ef_error(FIO_EDOT /*"num expected after '.'"*/);
525           ef_putnum(numval);
526           p += numlen;
527         }
528       }
529       break;
530 
531     case '+':
532     case '-': /*  number must follow '+' or '-' token:  */
533       j = ef_getnum(p, &numlen);
534       if (j == FALSE || rep_count)
535         return ef_error(FIO_EDOT /*"syntax error (+/-)"*/);
536       p += numlen;
537       if (c == '-')
538         numval = -numval;
539       rep_count = TRUE;
540       break;
541 
542     case '0':
543     case '1':
544     case '2':
545     case '3':
546     case '4':
547     case '5':
548     case '6':
549     case '7':
550     case '8':
551     case '9':
552       p--;
553       (void) ef_getnum(p, &numlen);
554       p += numlen;
555       rep_count = TRUE;
556 
557       /*  except for certain edit descriptors, put out 'repeat count'
558           now:  */
559       c = ef_nextchar(p, &numlen);
560       if (c != 'X' && c != 'P' && c != 'H')
561         ef_putnum(numval);
562       break;
563 
564     case 'c':
565     case 'j':
566     case 'k':
567     case 'm': /* case 'n': */
568     case 'u':
569     case 'v':
570     case 'w':
571     case 'y':
572     case 'C':
573     case 'J':
574     case 'K':
575     case 'M': /* case 'N': */
576     case 'U':
577     case 'V':
578     case 'W':
579     case 'Y':
580     case 'n':
581     case 'N':
582       return ef_error(FIO_ELETTER /*"unrecognized format code"*/);
583 
584     case '*':
585       if (paren_level != 0 ||
586           p > lastchar ||
587           *p != '(') {
588         /* A F'08 unlimited repeat count can appear only before a
589          * parenthesized list.
590          */
591         return ef_error(FIO_EFSYNTAX);
592       }
593       rep_count = TRUE;
594       unlimited_repeat_count = TRUE;
595       ef_putnum(0x7fffffff);
596       break;
597 
598     default:
599       return ef_error(FIO_ECHAR /*"illegal char"*/);
600 
601     check_no_repeat_count:
602       if (rep_count)
603         return ef_error(FIO_EFSYNTAX /*"syntax (repcount)"*/);
604     }
605 
606   } /* while (p <= lastchar); */
607 
608   assert(p == lastchar + 1); /* run off end of format (?)  */
609 
610 end_of_format:
611   if (paren_level != 0)
612     return ef_error(FIO_EPAREN /*"unbal parens"*/);
613   if (rep_count)
614     return ef_error(FIO_EFSYNTAX /*"syntax - number"*/);
615 
616   if (envar_fortranopt != NULL && strstr(envar_fortranopt, "vaxio") != NULL)
617     ;
618   else if (enclosing_parens) {
619     return ef_error(FIO_EENDFMT /*"unexpected end of format"*/);
620   }
621 
622   ef_put(FED_END); /* end of format */
623   ef_put(reversion_loc);
624 
625   return 0; /* no error */
626 }
627 
628 /* ------------------------------------------------------------------- */
629 
630 static ERRCODE
check_outer_parens(char * p,__CLEN_T len)631 check_outer_parens(char *p, /* ptr to format string to be encoded */
632                    __CLEN_T len)
633 {
634   char *q;
635 
636   if (len < 1 || p == 0)
637     return FIO_ELPAREN; /*"no starting '('" */
638 
639   q = p + (len - 1);
640 
641   /*  scan past leading blanks:   */
642 
643   for (; *p == ' ' && p <= q; p++)
644     ;
645 
646   if (q < p)            /*"illegal, empty format"*/
647     return FIO_ELPAREN; /*"no starting '('" */
648 
649   enclosing_parens = FALSE;
650   if (*p == '(') {
651     enclosing_parens = TRUE;
652     p++; /* point to first character following '(':  */
653   }
654   if (envar_fortranopt != NULL && strstr(envar_fortranopt, "vaxio") != NULL)
655     ;
656   else if (!enclosing_parens) {
657     return FIO_ELPAREN; /*"no starting '('" */
658   }
659 
660   firstchar = p;
661   lastchar = q;
662   return 0;
663 }
664 
665 /* ------------------------------------------------------------------- */
666 
ef_getnum(char * p,int * len)667 static bool ef_getnum(
668     /*  if first token, beginning at point p, is a number, assign its
669         value to numval and return TRUE:  */
670     char *p, int *len) /* return number of characters scanned */
671 {
672   char *begin = p;
673   int c;
674   int retlen;
675 
676   while (p <= lastchar && *p == ' ')
677     p++;
678   if (p > lastchar)
679     return FALSE;
680 
681   c = *p++;
682   if (!is_digit(c))
683     return FALSE;
684 
685   numval = 0;
686 
687   do {
688     numval = 10 * numval + (c - '0');
689     c = ef_nextchar(p, &retlen);
690     p += retlen;
691   } while (is_digit(c));
692 
693   *len = p - begin - 1;
694   return TRUE; /* number was present */
695 }
696 
697 /* ---------------------------------------------------------------- */
698 
ef_nextchar(p,len)699 static int ef_nextchar(p, len) char *p;
700 int *len;
701 {
702   char *begin = p, c;
703 
704   while (p <= lastchar && *p == ' ')
705     p++;
706   *len = p - begin + 1;
707   if (p > lastchar)
708     return '\0';
709 
710   c = *p;
711   if (c >= 'a' && c <= 'z') /* convert to u.c. for convenience: */
712     c = c + ('A' - 'a');
713   return c;
714 }
715 
716 /* ---------------------------------------------------------------- */
717 
ef_nextdtchar(p,len)718 static int ef_nextdtchar(p, len)
719     /* call after encounter DT */
720     char *p;
721 int *len;
722 {
723   char *begin = p, c;
724 
725   if (p <= lastchar && (*p == '\'' || *p == '('))
726     p++;
727   *len = p - begin + 1;
728   if (p > lastchar)
729     return '\0';
730 
731   c = *p;
732   if (c >= 'a' && c <= 'z') /* convert to u.c. for convenience: */
733     c = c + ('A' - 'a');
734   return c;
735 }
736 
737 /* -------------------------------------------------------------------- */
738 
739 static void
ef_put(INT val)740 ef_put(INT val)
741 {
742   if (curpos >= buffsize)
743     ef_alloc(0);
744   buff[curpos] = val;
745   curpos++;
746 }
747 
748 /* ------------------------------------------------------------------ */
749 
750 static void
ef_putnum(INT val)751 ef_putnum(INT val)
752 {
753   if (curpos + 1 >= buffsize)
754     ef_alloc(0);
755   buff[curpos++] = 0;
756   buff[curpos++] = val;
757 }
758 
759 /* ----------------------------------------------------------------- */
760 static void
ef_putvlist(char * p,int * len)761 ef_putvlist(char *p, int *len)
762 /* always put vlist as INT8,
763  * ENTF90IO(DTS_FMTR,dts_fmtr)/ENTF90IO(DTS_FMTW,dts_fmtw)
764  * will handle it if it were i4 */
765 {
766   char *begin = p, c;
767   char *op = p;
768   INT i, j, cnt;
769 
770   cnt = 1;
771   while (op <= lastchar && *op != ')') {
772     if (*op == ',') {
773       ++cnt;
774     }
775     ++op;
776   }
777 
778   if (cnt) {
779     ef_putnum(cnt);
780   }
781 
782   i = 0;
783 
784   if (curpos + 1 >= buffsize)
785     ef_alloc(0);
786 
787   /* this value will be change to non-zero in
788    * ENTF90IO(DTS_FMTR,dts_fmtr)/ENTF90IO(DTS_FMTW,dts_fmtw)
789    * when this particular vlist first encounter
790    */
791 
792   ef_putnum(0L);
793 
794   while (p <= lastchar && *p == ' ')
795     ++p;
796 
797   while (p <= lastchar && *p != ')') {
798     int negate = *p == '-';
799     if (*p == '+' || *p == '-')
800       ++p;
801     j = ef_getnum(p, len);
802 
803     if (!j) {
804       break;
805     } else {
806       ++i;
807     }
808     if (curpos + 1 >= buffsize)
809       ef_alloc(0);
810     if (negate)
811       numval = -numval;
812     buff[curpos++] = (__INT8_T)numval;
813     curpos++; /* make sure the size of numval is 8 */
814 
815     if (curpos + 1 >= buffsize)
816       ef_alloc(0);
817     p += *len;
818     while ((*p == ',' || *p == ' ') && p <= lastchar)
819       ++p;
820   }
821 #if DEBUG
822   if (i != cnt) {
823     printf("in cnt:%d is not the same as out cnt:%d\n", cnt, i);
824   }
825 #endif
826 
827   *len = p - begin + 1;
828 }
829 /* ----------------------------------------------------------------- */
830 
ef_putstring(char * p,INT len,int quote_count)831 static ERRCODE ef_putstring(
832     char *p, INT len,
833     int quote_count) /* always 0 for Hollerith; number of '''s in string */
834 {
835   char *q;
836 
837   if (len - quote_count < 0 || p + (len - 1) > lastchar)
838     return FIO_ESTRING /*"illegal Hollerith or character string"*/;
839 
840   len -= quote_count;
841   ef_put((INT)FED_STR);
842   ef_put(len);
843   if (curpos + len > buffsize)
844     ef_alloc(len);
845 
846   q = (char *)&buff[curpos];
847   curpos += (len + 3) >> 2;
848 
849   while (len--) {
850     if (*p == quote && quote_count > 0)
851       quote_count--, p++;
852     *q++ = *p;
853     p++;
854   }
855 
856   return 0;
857 }
858 
859 #define DT_LEN 2
860 static void
ef_putdt()861 ef_putdt()
862 {
863   char *q;
864 
865   ef_putnum(2L);
866   if (curpos + DT_LEN + 16 > buffsize)
867     ef_alloc(DT_LEN + 16);
868 
869   q = (char *)&buff[curpos];
870   *q++ = 'D';
871   *q++ = 'T';
872   curpos += (DT_LEN + 3) >> 2;
873 }
874 
875 static void
ef_putiotype(char * p,int * numlen)876 ef_putiotype(char *p, int *numlen)
877 /* also check if vlist is present */
878 {
879   char *q = p;
880   char *tptr, *fptr;
881   int n = 0;
882   int vlist_ispresent = 0;
883   int len = 0;
884   *numlen = 0;
885   while (q <= lastchar && *q != '\'' && *q != '\"') {
886     ++n;
887     ++len;
888     ++q;
889   }
890   n++; /* ' */
891   ++q;
892   if (*q == '(') {
893     n++;
894     vlist_ispresent = 1;
895   }
896 
897   if (vlist_ispresent)
898     ef_putnum(2L);
899   else
900     ef_putnum(1L);
901 
902   ef_putnum(DT_LEN + len);
903 
904   if (curpos + DT_LEN + len + 16 > buffsize)
905     ef_alloc(DT_LEN + len + 16);
906 
907   tptr = (char *)&buff[curpos];
908   *tptr++ = 'D';
909   *tptr++ = 'T';
910   fptr = p;
911   while (fptr != q) {
912     *tptr++ = *fptr++;
913   }
914   curpos += (DT_LEN + len + 3) >> 2;
915 
916   len = 0;
917   p = p + n;
918   if (vlist_ispresent) {
919     ef_putvlist(p, &len);
920     n += len;
921   }
922   *numlen = n;
923 }
924 
925 /* ------------------------------------------------------------------ */
926 
927 static void
ef_alloc(int len)928 ef_alloc(int len)
929 {
930   buffsize += (300 + len);
931   if (buff == NULL)
932     buff = (INT *)malloc(buffsize * sizeof(INT));
933   else
934     buff = (INT *)realloc(buff, buffsize * sizeof(INT));
935   fioFcbTbls.enctab = buff;
936   assert(buff != NULL);
937 }
938 
939 /* ------------------------------------------------------------------ */
940 
941 static INT
ef_error(ERRCODE code)942 ef_error(ERRCODE code)
943 /*  store error code indication at beginning of fmt output buffer: */
944 {
945   curpos = 0;
946   ef_put((INT)FED_ERROR);
947   ef_put((INT)code);
948   return 1;
949 }
950 
951 /* handle either character or non-character format string */
952 
953 __INT_T
ENTF90IO(ENCODE_FMTA,encode_fmta)954 ENTF90IO(ENCODE_FMTA, encode_fmta)
955 (__INT_T *kind,  /* type of data containing format string */
956  __INT_T *nelem, /* number of elements if array */
957  DCHAR(str)      /* unencoded format string */
958  DCLEN64(str))
959 {
960   __CLEN_T len;
961   int s = 0;
962   len = (*kind == __STR) ? CLEN(str) : GET_DIST_SIZE_OF(*kind);
963   buff = NULL;
964   buffsize = 0;
965 
966   if (LOCAL_MODE) {
967     s = _f90io_encode_fmt(CADR(str), nelem, len);
968     __fortio_errend03();
969     return s;
970   }
971 
972   if (GET_DIST_LCPU == GET_DIST_IOPROC)
973     (void)_f90io_encode_fmt(CADR(str), nelem, len);
974   __fortio_errend03();
975   return 0;
976 }
977 /* 32 bit CLEN version */
978 __INT_T
ENTF90IO(ENCODE_FMT,encode_fmt)979 ENTF90IO(ENCODE_FMT, encode_fmt)
980 (__INT_T *kind,  /* type of data containing format string */
981  __INT_T *nelem, /* number of elements if array */
982  DCHAR(str)      /* unencoded format string */
983  DCLEN(str))
984 {
985   return ENTF90IO(ENCODE_FMTA, encode_fmta) (kind, nelem, CADR(str),
986            (__CLEN_T)CLEN(str));
987 }
988 
989 __INT_T
ENTCRF90IO(ENCODE_FMTA,encode_fmta)990 ENTCRF90IO(ENCODE_FMTA, encode_fmta)
991 (__INT_T *kind,  /* type of data containing format string */
992  __INT_T *nelem, /* number of elements if array */
993  DCHAR(str)      /* unencoded format string */
994  DCLEN64(str))
995 {
996   __CLEN_T len;
997   int s = 0;
998   buff = NULL;
999   buffsize = 0;
1000   len = (*kind == __STR) ? CLEN(str) : GET_DIST_SIZE_OF(*kind);
1001   s = _f90io_encode_fmt(CADR(str), nelem, len);
1002   __fortio_errend03();
1003   return s;
1004 }
1005 /* 32 bit CLEN version */
1006 __INT_T
ENTCRF90IO(ENCODE_FMT,encode_fmt)1007 ENTCRF90IO(ENCODE_FMT, encode_fmt)
1008 (__INT_T *kind,  /* type of data containing format string */
1009  __INT_T *nelem, /* number of elements if array */
1010  DCHAR(str)      /* unencoded format string */
1011  DCLEN(str))
1012 {
1013   return ENTCRF90IO(ENCODE_FMTA, encode_fmta) (kind, nelem, CADR(str),
1014                             (__CLEN_T)CLEN(str));
1015 }
1016 
1017 /* address of character format string is passed in an integer variable */
1018 
1019 __INT_T
ENTF90IO(ENCODE_FMTV,encode_fmtv)1020 ENTF90IO(ENCODE_FMTV, encode_fmtv)
1021 (char **str) /* address of ptr to unencoded format string */
1022 {
1023   int len = 999999; /* no restriction on length */
1024   int s = 0;
1025   __INT_T nelem = 1;
1026   buff = NULL;
1027   buffsize = 0;
1028   if (LOCAL_MODE) {
1029     s = _f90io_encode_fmt(*str, &nelem, len);
1030     __fortio_errend03();
1031     return s;
1032   }
1033 
1034   if (GET_DIST_LCPU == GET_DIST_IOPROC)
1035     (void)_f90io_encode_fmt(*str, &nelem, len);
1036   __fortio_errend03();
1037   return 0;
1038 }
1039 
1040 __INT_T
ENTCRF90IO(ENCODE_FMTV,encode_fmtv)1041 ENTCRF90IO(ENCODE_FMTV, encode_fmtv)
1042 (char **str) /* address of ptr to unencoded format string */
1043 {
1044   int len = 999999; /* no restriction on length */
1045   int s = 0;
1046   __INT_T nelem = 1;
1047   buff = NULL;
1048   buffsize = 0;
1049   s = _f90io_encode_fmt(*str, &nelem, len);
1050   __fortio_errend03();
1051   return s;
1052 }
1053