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-2024 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 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 NULL;
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 == NULL) {
73 fmtarr[arrptr ++] = NULL;
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 RECORD rstr, wstr;
83 int_4 width, digits, expwid;
84 if (LEQUAL ("a", lex)) {
85 if (sscanf (&lex[1], "%d", &width) != 1) {
86 _srecordf (rstr, "%%s");
87 _srecordf (wstr, "%%s");
88 } else if (width < 1) {
89 jit_error (where, lex);
90 _srecordf (rstr, "%%s");
91 _srecordf (wstr, "%%s");
92 } else {
93 _srecordf (rstr, "%%%ds", width);
94 _srecordf (wstr, "%%-%ds", width);
95 }
96 add_mark (where, FMT_CHAR);
97 (*elems)++;
98 } else if (LEQUAL ("i", lex)) {
99 if (sscanf (&lex[1], "%d", &width) != 1) {
100 jit_error (where, "expected width");
101 _srecordf (rstr, "%%d");
102 _srecordf (wstr, "%%d");
103 } else if (width < 1) {
104 jit_error (where, lex);
105 _srecordf (rstr, "%%d");
106 _srecordf (wstr, "%%d");
107 } else {
108 _srecordf (rstr, "%%%dd", width);
109 _srecordf (wstr, "%%%dd", width);
110 }
111 add_mark (where, FMT_INT);
112 (*elems)++;
113 } else if (LEQUAL ("l", lex)) {
114 if (sscanf (&lex[1], "%d", &width) != 1) {
115 jit_error (where, "expected width");
116 _srecordf (rstr, "%%s");
117 _srecordf (wstr, "%%s");
118 } else if (width < 1) {
119 jit_error (where, lex);
120 _srecordf (rstr, "%%s");
121 _srecordf (wstr, "%%s");
122 } else {
123 _srecordf (rstr, "%%%ds", width);
124 _srecordf (wstr, "%%-%ds", width);
125 }
126 add_mark (where, FMT_INT);
127 (*elems)++;
128 } else if (LEQUAL ("d", lex) || LEQUAL ("e", lex) || LEQUAL ("g", lex) || LEQUAL ("n", lex)) {
129 width = digits = expwid = 0;
130 if (sscanf (&lex[1], "%d.%d.%d", &width, &digits, &expwid) == 3) {
131 ;
132 } else if (sscanf (&lex[1], "%d.%d", &width, &digits) == 2) {
133 ;
134 } else {
135 jit_error (where, "expected width, decimals, [width]");
136 }
137 if (width < 0 || digits < 0) {
138 jit_error (where, lex);
139 }
140 // Reading a REAL - specify width only!
141 _srecordf (rstr, "%%%de", width);
142 // Writing a REAL - specify all.
143 if (tolower (lex[0]) == 'n') {
144 if (islower (lex[0])) {
145 _srecordf (wstr, "%%%d.%d.%dn", width, digits, expwid);
146 } else {
147 _srecordf (wstr, "%%%d.%d.%dN", width, digits, expwid);
148 }
149 } else {
150 if (islower (lex[0])) {
151 _srecordf (wstr, "%%%d.%d.%de", width, digits, expwid);
152 } else {
153 _srecordf (wstr, "%%%d.%d.%dE", width, digits, expwid);
154 }
155 }
156 add_mark (where, FMT_REAL);
157 (*elems)++;
158 } else if (LEQUAL ("f", lex)) {
159 sscanf (&lex[1], "%d.%d", &width, &digits);
160 if (sscanf (&lex[1], "%d.%d", &width, &digits) != 2) {
161 jit_error (where, "expected width, decimals");
162 _srecordf (rstr, "%%f");
163 _srecordf (wstr, "%%f");
164 } else if (width < 1 || digits < 0) {
165 jit_error (where, lex);
166 _srecordf (rstr, "%%f");
167 _srecordf (wstr, "%%f");
168 } else {
169 _srecordf (rstr, "%%%df", width);
170 _srecordf (wstr, "%%%d.%df", width, digits);
171 }
172 add_mark (where, FMT_REAL);
173 (*elems)++;
174 } else {
175 jit_error (where, lex);
176 rstr[0] = wstr[0] = '\0';
177 (*elems)++;
178 }
179 RECORD fstr;
180 _srecordf (fstr, "%s", rstr);
181 add_item (where, fstr);
182 _srecordf (fstr, "%s", wstr);
183 add_item (where, fstr);
184 }
185
186 static void jit_scale (char *where, int_4 N)
187 {
188 add_mark (where, FMT_TEXT);
189 add_item (where, "");
190 if (N == 0) {
191 add_item (where, "0");
192 } else if (N == 1) {
193 add_item (where, "1");
194 } else if (N == 2) {
195 add_item (where, "2");
196 } else if (N == 3) {
197 add_item (where, "3");
198 } else {
199 add_item (where, "1");
200 }
201 }
202
203 static void jit_x (char *where, int_4 N)
204 {
205 RECORD str;
206 str[0] = '\0';
207 for (int_4 k = 0; k < N && k < RECLN; k ++) {
208 bufcat (str, " ", RECLN);
209 }
210 add_mark (where, FMT_TEXT);
211 add_item (where, str);
212 add_item (where, str);
213 }
214
215 static void jit_nl (char *where, int_4 N)
216 {
217 RECORD str;
218 _srecordf (str, "\\n");
219 for (int_4 k = 0; k < N; k ++) {
220 add_mark (where, FMT_TEXT);
221 add_item (where, str);
222 add_item (where, str);
223 }
224 }
225
226 static void jit_text (char *where, int_4 N, char *lex)
227 {
228 for (int_4 k = 0; k < N; k ++) {
229 add_mark (where, FMT_TEXT);
230 add_item (where, lex);
231 add_item (where, lex);
232 }
233 }
234
235 static char *jit_str_list (char *where, char *fmt, int *nest, int *elems)
236 {
237 #define LETTER(ch) (tolower (fmt[0]) == ch)
238 if (fmt[0] == '(') {
239 fmt++;
240 } else {
241 jit_error (where, "expected '('");
242 }
243 while (fmt[0] != ')' && fmt[0] != '\0') {
244 if (fmt[0] == ',') {
245 fmt++;
246 }
247 while (isspace (fmt[0])) {
248 fmt++;
249 }
250 int_4 N;
251 if (!isdigit (fmt[0])) {
252 N = 1;
253 } else {
254 char *end;
255 N = strtol (fmt, &end, 10);
256 fmt = end;
257 }
258 if (LETTER ('p')) {
259 jit_scale (where, N);
260 (*elems)++;
261 fmt++;
262 } else if (LETTER ('x')) {
263 jit_x (where, N);
264 (*elems)++;
265 fmt++;
266 } else if (fmt[0] == '/') {
267 jit_nl (where, N);
268 (*elems)++;
269 fmt++;
270 } else if (LETTER ('h')) {
271 fmt++;
272 RECORD str;
273 RECCLR (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 RECORD str;
283 RECCLR (str);
284 int_4 k = 0;
285 int_4 go_on = TRUE;
286 while (go_on) {
287 if (fmt[0] == '\0') {
288 go_on = FALSE;
289 } else if (fmt[0] == '"') {
290 if ((++fmt)[0] == '"') {
291 str[k++] = '"';
292 fmt++;
293 } else {
294 go_on = FALSE;
295 }
296 } else {
297 str[k++] = (fmt++)[0];
298 }
299 }
300 jit_text (where, N, str);
301 (*elems)++;
302 } else if (fmt[0] == '\'') {
303 fmt++;
304 RECORD str;
305 RECCLR (str);
306 int_4 k = 0;
307 int_4 go_on = TRUE;
308 while (go_on) {
309 if (fmt[0] == '\0') {
310 go_on = FALSE;
311 } else if (fmt[0] == '\'') {
312 if ((++fmt)[0] == '\'') {
313 str[k++] = '\'';
314 fmt++;
315 } else {
316 go_on = FALSE;
317 }
318 } else {
319 str[k++] = (fmt++)[0];
320 }
321 }
322 jit_text (where, N, str);
323 (*elems)++;
324 } else {
325 for (int_4 k = 0; k < N; k++) {
326 char *sav = fmt, *rtn = NULL;
327 if (fmt[0] == '(') {
328 (*nest)++;
329 rtn = jit_str_list (where, fmt, nest, elems);
330 } else if (fmt[0] == ')') {
331 break;
332 } else if (strchr ("adefgiln", tolower (fmt[0])) == NULL) {
333 jit_error (where, fmt);
334 } else {
335 RECORD lex;
336 RECCLR (lex);
337 char *p = lex;
338 do {
339 (p++)[0] = (fmt++)[0];
340 while (isdigit (fmt[0])) {
341 (p++)[0] = (fmt++)[0];
342 }
343 } while (fmt[0] == '.');
344 jit_elem (where, lex, elems);
345 }
346 if (k < N - 1) {
347 fmt = sav;
348 } else if (rtn != NULL) {
349 fmt = rtn;
350 }
351 }
352 }
353 }
354 if (fmt[0] != ')') {
355 jit_error (where, "expected ')'");
356 return fmt;
357 } else if (*nest > 0) {
358 (*nest)--;
359 }
360 return &fmt[1];
361 #undef LETTER
362 }
363
364 char **_vif_jit (char *where, char *arg)
365 {
366 int_4 nest = 0, elems = 0;
367 RECORD cpy;
368 fmtarr[0] = NULL;
369 heaptr = 0;
370 arrptr = 0;
371 strcpy (cpy, arg);
372 char *fmt = (char *) cpy;
373 if (fmt[0] == '"') {
374 fmt++;
375 }
376 if (fmt[strlen (fmt) - 1] == '"') {
377 fmt[strlen (fmt) - 1] = '\0';
378 }
379 (void) jit_str_list (where, fmt, &nest, &elems);
380 if (nest != 0) {
381 jit_error (where, "unbalanced parentheses");
382 }
383 if (elems == 0) {
384 jit_error (where, "empty format");
385 }
386 add_item (where, NULL);
387 add_item (where, NULL);
388 add_item (where, NULL);
389 return fmtarr;
390 }
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
