rts-jit.c
1 //! @file jit.c
2 //! @author J. Marcel van der Veer
3 //
4 //! @section Copyright
5 //
6 // This file is part of VIF - vintage FORTRAN compiler.
7 // Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
8 //
9 //! @section License
10 //
11 // This program is free software; you can redistribute it and/or modify it
12 // under the terms of the GNU General Public License as published by the
13 // Free Software Foundation; either version 3 of the License, or
14 // (at your option) any later version.
15 //
16 // This program is distributed in the hope that it will be useful, but
17 // WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 // or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 // more details. You should have received a copy of the GNU General Public
20 // License along with this program. If not, see <http://www.gnu.org/licenses/>.
21
22 //! @section Synopsis
23 //!
24 //! Just-in-time compilation of FORMAT strings.
25
26 #include <vif.h>
27
28 #define HEAP_SIZE 8192
29 #define MAX_ITEMS 256
30
31 static char heap[HEAP_SIZE];
32 static char *fmtarr[MAX_ITEMS];
33 static size_t heaptr, arrptr;
34
35 static char *jit_str_list (char *, char *, int *, int *);
36
37 static void jit_error (char *where, char *msg)
38 {
39 NEW_RECORD (diag);
40 _srecordf (diag, "format compiler: %s", msg);
41 RTE (where, diag);
42 }
43
44 static char *alloc (char *where, char *elem)
45 {
46 size_t N = strlen (elem) + 1;
47 if ((heaptr + N) >= (HEAP_SIZE - 1)) {
48 jit_error (where, "heap overflow");
49 return NO_TEXT;
50 } else {
51 char *q = &heap[heaptr];
52 strcpy (q, elem);
53 heaptr += N;
54 return q;
55 }
56 }
57
58 static void add_mark (char *where, char *elem)
59 {
60 if (arrptr == (MAX_ITEMS - 1)) {
61 jit_error (where, "too many items");
62 } else {
63 fmtarr[arrptr ++] = elem;
64 }
65 }
66
67 static void add_item (char *where, char *elem)
68 {
69 if (arrptr == (MAX_ITEMS - 1)) {
70 jit_error (where, "too many items");
71 } else {
72 if (elem == NO_TEXT) {
73 fmtarr[arrptr ++] = NO_TEXT;
74 } else {
75 fmtarr[arrptr ++] = alloc (where, elem);
76 }
77 }
78 }
79
80 static void jit_elem (char *where, char *lex, int_4 *elems)
81 {
82 NEW_RECORD (rstr);
83 NEW_RECORD (wstr);
84 int_4 width, digits, expwid;
85 if (LEQUAL ("a", lex)) {
86 if (sscanf (&lex[1], "%d", &width) != 1) {
87 _srecordf (rstr, "%%s");
88 _srecordf (wstr, "%%s");
89 } else if (width < 1) {
90 jit_error (where, lex);
91 _srecordf (rstr, "%%s");
92 _srecordf (wstr, "%%s");
93 } else {
94 _srecordf (rstr, "%%%ds", width);
95 _srecordf (wstr, "%%-%ds", width);
96 }
97 add_mark (where, FMT_CHAR);
98 (*elems)++;
99 } else if (LEQUAL ("i", lex)) {
100 if (sscanf (&lex[1], "%d", &width) != 1) {
101 jit_error (where, "expected width");
102 _srecordf (rstr, "%%d");
103 _srecordf (wstr, "%%d");
104 } else if (width < 1) {
105 jit_error (where, lex);
106 _srecordf (rstr, "%%d");
107 _srecordf (wstr, "%%d");
108 } else {
109 _srecordf (rstr, "%%%dd", width);
110 _srecordf (wstr, "%%%dd", width);
111 }
112 add_mark (where, FMT_INT);
113 (*elems)++;
114 } else if (LEQUAL ("l", lex)) {
115 if (sscanf (&lex[1], "%d", &width) != 1) {
116 jit_error (where, "expected width");
117 _srecordf (rstr, "%%s");
118 _srecordf (wstr, "%%s");
119 } else if (width < 1) {
120 jit_error (where, lex);
121 _srecordf (rstr, "%%s");
122 _srecordf (wstr, "%%s");
123 } else {
124 _srecordf (rstr, "%%%ds", width);
125 _srecordf (wstr, "%%-%ds", width);
126 }
127 add_mark (where, FMT_INT);
128 (*elems)++;
129 } else if (LEQUAL ("d", lex) || LEQUAL ("e", lex) || LEQUAL ("g", lex) || LEQUAL ("n", lex)) {
130 width = digits = expwid = 0;
131 if (sscanf (&lex[1], "%d.%d.%d", &width, &digits, &expwid) == 3) {
132 ;
133 } else if (sscanf (&lex[1], "%d.%d", &width, &digits) == 2) {
134 ;
135 } else {
136 jit_error (where, "expected width, decimals, [width]");
137 }
138 if (width < 0 || digits < 0) {
139 jit_error (where, lex);
140 }
141 // Reading a REAL - specify width only!
142 _srecordf (rstr, "%%%de", width);
143 // Writing a REAL - specify all.
144 if (tolower (lex[0]) == 'n') {
145 if (islower (lex[0])) {
146 _srecordf (wstr, "%%%d.%d.%dn", width, digits, expwid);
147 } else {
148 _srecordf (wstr, "%%%d.%d.%dN", width, digits, expwid);
149 }
150 } else {
151 if (islower (lex[0])) {
152 _srecordf (wstr, "%%%d.%d.%de", width, digits, expwid);
153 } else {
154 _srecordf (wstr, "%%%d.%d.%dE", width, digits, expwid);
155 }
156 }
157 add_mark (where, FMT_REAL);
158 (*elems)++;
159 } else if (LEQUAL ("f", lex)) {
160 sscanf (&lex[1], "%d.%d", &width, &digits);
161 if (sscanf (&lex[1], "%d.%d", &width, &digits) != 2) {
162 jit_error (where, "expected width, decimals");
163 _srecordf (rstr, "%%f");
164 _srecordf (wstr, "%%f");
165 } else if (width < 1 || digits < 0) {
166 jit_error (where, lex);
167 _srecordf (rstr, "%%f");
168 _srecordf (wstr, "%%f");
169 } else {
170 _srecordf (rstr, "%%%df", width);
171 _srecordf (wstr, "%%%d.%df", width, digits);
172 }
173 add_mark (where, FMT_REAL);
174 (*elems)++;
175 } else {
176 jit_error (where, lex);
177 rstr[0] = wstr[0] = '\0';
178 (*elems)++;
179 }
180 NEW_RECORD (fstr);
181 _srecordf (fstr, "%s", rstr);
182 add_item (where, fstr);
183 _srecordf (fstr, "%s", wstr);
184 add_item (where, fstr);
185 }
186
187 static void jit_scale (char *where, int_4 N)
188 {
189 add_mark (where, FMT_TEXT);
190 add_item (where, "");
191 if (N == 0) {
192 add_item (where, "0");
193 } else if (N == 1) {
194 add_item (where, "1");
195 } else if (N == 2) {
196 add_item (where, "2");
197 } else if (N == 3) {
198 add_item (where, "3");
199 } else {
200 add_item (where, "1");
201 }
202 }
203
204 static void jit_x (char *where, int_4 N)
205 {
206 NEW_RECORD (str);
207 str[0] = '\0';
208 for (int_4 k = 0; k < N && k < RECLN; k ++) {
209 bufcat (str, " ", RECLN);
210 }
211 add_mark (where, FMT_TEXT);
212 add_item (where, str);
213 add_item (where, str);
214 }
215
216 static void jit_nl (char *where, int_4 N)
217 {
218 NEW_RECORD (str);
219 _srecordf (str, "\\n");
220 for (int_4 k = 0; k < N; k ++) {
221 add_mark (where, FMT_TEXT);
222 add_item (where, str);
223 add_item (where, str);
224 }
225 }
226
227 static void jit_text (char *where, int_4 N, char *lex)
228 {
229 for (int_4 k = 0; k < N; k ++) {
230 add_mark (where, FMT_TEXT);
231 add_item (where, lex);
232 add_item (where, lex);
233 }
234 }
235
236 static char *jit_str_list (char *where, char *fmt, int *nest, int *elems)
237 {
238 #define LETTER(ch) (tolower (fmt[0]) == ch)
239 if (fmt[0] == '(') {
240 fmt++;
241 } else {
242 jit_error (where, "expected '('");
243 }
244 while (fmt[0] != ')' && fmt[0] != '\0') {
245 if (fmt[0] == ',') {
246 fmt++;
247 }
248 while (isspace (fmt[0])) {
249 fmt++;
250 }
251 int_4 N;
252 if (!isdigit (fmt[0])) {
253 N = 1;
254 } else {
255 char *end;
256 N = strtol (fmt, &end, 10);
257 fmt = end;
258 }
259 if (LETTER ('p')) {
260 jit_scale (where, N);
261 (*elems)++;
262 fmt++;
263 } else if (LETTER ('x')) {
264 jit_x (where, N);
265 (*elems)++;
266 fmt++;
267 } else if (fmt[0] == '/') {
268 jit_nl (where, N);
269 (*elems)++;
270 fmt++;
271 } else if (LETTER ('h')) {
272 fmt++;
273 NEW_RECORD (str);
274 int_4 k = 0;
275 for (int_4 M = 0; M < N && fmt[0] != '\0'; M++) {
276 str[k++] = (fmt++)[0];
277 }
278 jit_text (where, 1, str);
279 (*elems)++;
280 } else if (fmt[0] == '\"') {
281 fmt++;
282 NEW_RECORD (str);
283 int_4 k = 0;
284 int_4 go_on = TRUE;
285 while (go_on) {
286 if (fmt[0] == '\0') {
287 go_on = FALSE;
288 } else if (fmt[0] == '"') {
289 if ((++fmt)[0] == '"') {
290 str[k++] = '"';
291 fmt++;
292 } else {
293 go_on = FALSE;
294 }
295 } else {
296 str[k++] = (fmt++)[0];
297 }
298 }
299 jit_text (where, N, str);
300 (*elems)++;
301 } else if (fmt[0] == '\'') {
302 fmt++;
303 NEW_RECORD (str);
304 int_4 k = 0;
305 int_4 go_on = TRUE;
306 while (go_on) {
307 if (fmt[0] == '\0') {
308 go_on = FALSE;
309 } else if (fmt[0] == '\'') {
310 if ((++fmt)[0] == '\'') {
311 str[k++] = '\'';
312 fmt++;
313 } else {
314 go_on = FALSE;
315 }
316 } else {
317 str[k++] = (fmt++)[0];
318 }
319 }
320 jit_text (where, N, str);
321 (*elems)++;
322 } else {
323 for (int_4 k = 0; k < N; k++) {
324 char *sav = fmt, *rtn = NO_TEXT;
325 if (fmt[0] == '(') {
326 (*nest)++;
327 rtn = jit_str_list (where, fmt, nest, elems);
328 } else if (fmt[0] == ')') {
329 break;
330 } else if (strchr ("adefgiln", tolower (fmt[0])) == NO_TEXT) {
331 jit_error (where, fmt);
332 } else {
333 NEW_RECORD (lex);
334 char *p = lex;
335 do {
336 (p++)[0] = (fmt++)[0];
337 while (isdigit (fmt[0])) {
338 (p++)[0] = (fmt++)[0];
339 }
340 } while (fmt[0] == '.');
341 jit_elem (where, lex, elems);
342 }
343 if (k < N - 1) {
344 fmt = sav;
345 } else if (rtn != NO_TEXT) {
346 fmt = rtn;
347 }
348 }
349 }
350 }
351 if (fmt[0] != ')') {
352 jit_error (where, "expected ')'");
353 return fmt;
354 } else if (*nest > 0) {
355 (*nest)--;
356 }
357 return &fmt[1];
358 #undef LETTER
359 }
360
361 char **_vif_jit (char *where, char *arg)
362 {
363 int_4 nest = 0, elems = 0;
364 NEW_RECORD (cpy);
365 fmtarr[0] = NO_TEXT;
366 heaptr = 0;
367 arrptr = 0;
368 strcpy (cpy, arg);
369 char *fmt = (char *) cpy;
370 if (fmt[0] == '"') {
371 fmt++;
372 }
373 if (fmt[strlen (fmt) - 1] == '"') {
374 fmt[strlen (fmt) - 1] = '\0';
375 }
376 (void) jit_str_list (where, fmt, &nest, &elems);
377 if (nest != 0) {
378 jit_error (where, "unbalanced parentheses");
379 }
380 if (elems == 0) {
381 jit_error (where, "empty format");
382 }
383 add_item (where, NO_TEXT);
384 add_item (where, NO_TEXT);
385 add_item (where, NO_TEXT);
386 return fmtarr;
387 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
