1 /* voc 2.1.0 [2019/11/01]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */
2
3 #define SHORTINT INT8
4 #define INTEGER INT16
5 #define LONGINT INT32
6 #define SET UINT32
7
8 #include "SYSTEM.h"
9 #include "OPM.h"
10
11 typedef
12 CHAR OPS_Name[256];
13
14 typedef
15 CHAR OPS_String[256];
16
17
18 export OPS_Name OPS_name;
19 export OPS_String OPS_str;
20 export INT16 OPS_numtyp;
21 export INT64 OPS_intval;
22 export REAL OPS_realval;
23 export LONGREAL OPS_lrlval;
24 static CHAR OPS_ch;
25
26
27 export void OPS_Get (INT8 *sym);
28 static void OPS_Identifier (INT8 *sym);
29 export void OPS_Init (void);
30 static void OPS_Number (void);
31 static void OPS_Str (INT8 *sym);
32 static void OPS_err (INT16 n);
33
34
OPS_err(INT16 n)35 static void OPS_err (INT16 n)
36 {
37 OPM_err(n);
38 }
39
OPS_Str(INT8 * sym)40 static void OPS_Str (INT8 *sym)
41 {
42 INT16 i;
43 CHAR och;
44 i = 0;
45 och = OPS_ch;
46 for (;;) {
47 OPM_Get(&OPS_ch);
48 if (OPS_ch == och) {
49 break;
50 }
51 if (OPS_ch < ' ') {
52 OPS_err(3);
53 break;
54 }
55 if (i == 255) {
56 OPS_err(241);
57 break;
58 }
59 OPS_str[__X(i, 256)] = OPS_ch;
60 i += 1;
61 }
62 OPM_Get(&OPS_ch);
63 OPS_str[__X(i, 256)] = 0x00;
64 OPS_intval = i + 1;
65 if (OPS_intval == 2) {
66 *sym = 35;
67 OPS_numtyp = 1;
68 OPS_intval = (INT16)OPS_str[0];
69 } else {
70 *sym = 37;
71 }
72 }
73
OPS_Identifier(INT8 * sym)74 static void OPS_Identifier (INT8 *sym)
75 {
76 INT16 i;
77 i = 0;
78 do {
79 OPS_name[__X(i, 256)] = OPS_ch;
80 i += 1;
81 OPM_Get(&OPS_ch);
82 } while (!(((OPS_ch < '0' || ('9' < OPS_ch && __CAP(OPS_ch) < 'A')) || 'Z' < __CAP(OPS_ch)) || i == 256));
83 if (i == 256) {
84 OPS_err(240);
85 i -= 1;
86 }
87 OPS_name[__X(i, 256)] = 0x00;
88 *sym = 38;
89 }
90
91 static struct Number__6 {
92 struct Number__6 *lnk;
93 } *Number__6_s;
94
95 static INT16 Ord__7 (CHAR ch, BOOLEAN hex);
96 static LONGREAL Ten__9 (INT16 e);
97
Ten__9(INT16 e)98 static LONGREAL Ten__9 (INT16 e)
99 {
100 LONGREAL x, p;
101 x = (LONGREAL)1;
102 p = (LONGREAL)10;
103 while (e > 0) {
104 if (__ODD(e)) {
105 x = x * p;
106 }
107 e = __ASHR(e, 1);
108 if (e > 0) {
109 p = p * p;
110 }
111 }
112 return x;
113 }
114
Ord__7(CHAR ch,BOOLEAN hex)115 static INT16 Ord__7 (CHAR ch, BOOLEAN hex)
116 {
117 if (ch <= '9') {
118 return (INT16)ch - 48;
119 } else if (hex) {
120 return ((INT16)ch - 65) + 10;
121 } else {
122 OPS_err(2);
123 return 0;
124 }
125 __RETCHK;
126 }
127
OPS_Number(void)128 static void OPS_Number (void)
129 {
130 INT16 i, m, n, d, e;
131 CHAR dig[24];
132 LONGREAL f;
133 CHAR expCh;
134 BOOLEAN neg;
135 struct Number__6 _s;
136 _s.lnk = Number__6_s;
137 Number__6_s = &_s;
138 i = 0;
139 m = 0;
140 n = 0;
141 d = 0;
142 for (;;) {
143 if (('0' <= OPS_ch && OPS_ch <= '9') || (((d == 0 && 'A' <= OPS_ch)) && OPS_ch <= 'F')) {
144 if (m > 0 || OPS_ch != '0') {
145 if (n < 24) {
146 dig[__X(n, 24)] = OPS_ch;
147 n += 1;
148 }
149 m += 1;
150 }
151 OPM_Get(&OPS_ch);
152 i += 1;
153 } else if (OPS_ch == '.') {
154 OPM_Get(&OPS_ch);
155 if (OPS_ch == '.') {
156 OPS_ch = 0x7f;
157 break;
158 } else if (d == 0) {
159 d = i;
160 } else {
161 OPS_err(2);
162 }
163 } else {
164 break;
165 }
166 }
167 if (d == 0) {
168 if (n == m) {
169 OPS_intval = 0;
170 i = 0;
171 if (OPS_ch == 'X') {
172 OPM_Get(&OPS_ch);
173 OPS_numtyp = 1;
174 if (n <= 2) {
175 while (i < n) {
176 OPS_intval = __ASHL(OPS_intval, 4) + (INT64)Ord__7(dig[__X(i, 24)], 1);
177 i += 1;
178 }
179 } else {
180 OPS_err(203);
181 }
182 } else if (OPS_ch == 'H') {
183 OPM_Get(&OPS_ch);
184 OPS_numtyp = 2;
185 if (n <= 16) {
186 if ((n == 16 && dig[0] > '7')) {
187 OPS_intval = -1;
188 }
189 while (i < n) {
190 OPS_intval = __ASHL(OPS_intval, 4) + (INT64)Ord__7(dig[__X(i, 24)], 1);
191 i += 1;
192 }
193 } else {
194 OPS_err(203);
195 }
196 } else {
197 OPS_numtyp = 2;
198 while (i < n) {
199 d = Ord__7(dig[__X(i, 24)], 0);
200 i += 1;
201 if (OPS_intval <= __DIV(9223372036854775807LL - (INT64)d, 10)) {
202 OPS_intval = OPS_intval * 10 + (INT64)d;
203 } else {
204 OPS_err(203);
205 }
206 }
207 }
208 } else {
209 OPS_err(203);
210 }
211 } else {
212 f = (LONGREAL)0;
213 e = 0;
214 expCh = 'E';
215 while (n > 0) {
216 n -= 1;
217 f = (Ord__7(dig[__X(n, 24)], 0) + f) / (LONGREAL)(LONGREAL)10;
218 }
219 if (OPS_ch == 'E' || OPS_ch == 'D') {
220 expCh = OPS_ch;
221 OPM_Get(&OPS_ch);
222 neg = 0;
223 if (OPS_ch == '-') {
224 neg = 1;
225 OPM_Get(&OPS_ch);
226 } else if (OPS_ch == '+') {
227 OPM_Get(&OPS_ch);
228 }
229 if (('0' <= OPS_ch && OPS_ch <= '9')) {
230 do {
231 n = Ord__7(OPS_ch, 0);
232 OPM_Get(&OPS_ch);
233 if (e <= __DIV(32767 - n, 10)) {
234 e = e * 10 + n;
235 } else {
236 OPS_err(203);
237 }
238 } while (!(OPS_ch < '0' || '9' < OPS_ch));
239 if (neg) {
240 e = -e;
241 }
242 } else {
243 OPS_err(2);
244 }
245 }
246 e -= (i - d) - m;
247 if (expCh == 'E') {
248 OPS_numtyp = 3;
249 if ((-37 < e && e <= 38)) {
250 if (e < 0) {
251 OPS_realval = (f / (LONGREAL)Ten__9(-e));
252 } else {
253 OPS_realval = (f * Ten__9(e));
254 }
255 } else {
256 OPS_err(203);
257 }
258 } else {
259 OPS_numtyp = 4;
260 if ((-307 < e && e <= 308)) {
261 if (e < 0) {
262 OPS_lrlval = f / (LONGREAL)Ten__9(-e);
263 } else {
264 OPS_lrlval = f * Ten__9(e);
265 }
266 } else {
267 OPS_err(203);
268 }
269 }
270 }
271 Number__6_s = _s.lnk;
272 }
273
274 static struct Get__1 {
275 struct Get__1 *lnk;
276 } *Get__1_s;
277
278 static void Comment__2 (void);
279
Comment__2(void)280 static void Comment__2 (void)
281 {
282 OPM_Get(&OPS_ch);
283 for (;;) {
284 for (;;) {
285 while (OPS_ch == '(') {
286 OPM_Get(&OPS_ch);
287 if (OPS_ch == '*') {
288 Comment__2();
289 }
290 }
291 if (OPS_ch == '*') {
292 OPM_Get(&OPS_ch);
293 break;
294 }
295 if (OPS_ch == 0x00) {
296 break;
297 }
298 OPM_Get(&OPS_ch);
299 }
300 if (OPS_ch == ')') {
301 OPM_Get(&OPS_ch);
302 break;
303 }
304 if (OPS_ch == 0x00) {
305 OPS_err(5);
306 break;
307 }
308 }
309 }
310
OPS_Get(INT8 * sym)311 void OPS_Get (INT8 *sym)
312 {
313 INT8 s;
314 struct Get__1 _s;
315 _s.lnk = Get__1_s;
316 Get__1_s = &_s;
317 OPM_errpos = OPM_curpos - 1;
318 while (OPS_ch <= ' ') {
319 if (OPS_ch == 0x00) {
320 *sym = 64;
321 Get__1_s = _s.lnk;
322 return;
323 } else {
324 OPM_Get(&OPS_ch);
325 }
326 }
327 switch (OPS_ch) {
328 case '"': case '\'':
329 OPS_Str(&s);
330 break;
331 case '#':
332 s = 10;
333 OPM_Get(&OPS_ch);
334 break;
335 case '&':
336 s = 5;
337 OPM_Get(&OPS_ch);
338 break;
339 case '(':
340 OPM_Get(&OPS_ch);
341 if (OPS_ch == '*') {
342 Comment__2();
343 OPS_Get(&s);
344 } else {
345 s = 30;
346 }
347 break;
348 case ')':
349 s = 22;
350 OPM_Get(&OPS_ch);
351 break;
352 case '*':
353 s = 1;
354 OPM_Get(&OPS_ch);
355 break;
356 case '+':
357 s = 6;
358 OPM_Get(&OPS_ch);
359 break;
360 case ',':
361 s = 19;
362 OPM_Get(&OPS_ch);
363 break;
364 case '-':
365 s = 7;
366 OPM_Get(&OPS_ch);
367 break;
368 case '.':
369 OPM_Get(&OPS_ch);
370 if (OPS_ch == '.') {
371 OPM_Get(&OPS_ch);
372 s = 21;
373 } else {
374 s = 18;
375 }
376 break;
377 case '/':
378 s = 2;
379 OPM_Get(&OPS_ch);
380 break;
381 case '0': case '1': case '2': case '3': case '4':
382 case '5': case '6': case '7': case '8': case '9':
383 OPS_Number();
384 s = 35;
385 break;
386 case ':':
387 OPM_Get(&OPS_ch);
388 if (OPS_ch == '=') {
389 OPM_Get(&OPS_ch);
390 s = 34;
391 } else {
392 s = 20;
393 }
394 break;
395 case ';':
396 s = 39;
397 OPM_Get(&OPS_ch);
398 break;
399 case '<':
400 OPM_Get(&OPS_ch);
401 if (OPS_ch == '=') {
402 OPM_Get(&OPS_ch);
403 s = 12;
404 } else {
405 s = 11;
406 }
407 break;
408 case '=':
409 s = 9;
410 OPM_Get(&OPS_ch);
411 break;
412 case '>':
413 OPM_Get(&OPS_ch);
414 if (OPS_ch == '=') {
415 OPM_Get(&OPS_ch);
416 s = 14;
417 } else {
418 s = 13;
419 }
420 break;
421 case 'A':
422 OPS_Identifier(&s);
423 if (__STRCMP(OPS_name, "ARRAY") == 0) {
424 s = 54;
425 }
426 break;
427 case 'B':
428 OPS_Identifier(&s);
429 if (__STRCMP(OPS_name, "BEGIN") == 0) {
430 s = 57;
431 } else if (__STRCMP(OPS_name, "BY") == 0) {
432 s = 29;
433 }
434 break;
435 case 'C':
436 OPS_Identifier(&s);
437 if (__STRCMP(OPS_name, "CASE") == 0) {
438 s = 46;
439 } else if (__STRCMP(OPS_name, "CONST") == 0) {
440 s = 58;
441 }
442 break;
443 case 'D':
444 OPS_Identifier(&s);
445 if (__STRCMP(OPS_name, "DO") == 0) {
446 s = 27;
447 } else if (__STRCMP(OPS_name, "DIV") == 0) {
448 s = 3;
449 }
450 break;
451 case 'E':
452 OPS_Identifier(&s);
453 if (__STRCMP(OPS_name, "END") == 0) {
454 s = 41;
455 } else if (__STRCMP(OPS_name, "ELSE") == 0) {
456 s = 42;
457 } else if (__STRCMP(OPS_name, "ELSIF") == 0) {
458 s = 43;
459 } else if (__STRCMP(OPS_name, "EXIT") == 0) {
460 s = 52;
461 }
462 break;
463 case 'F':
464 OPS_Identifier(&s);
465 if (__STRCMP(OPS_name, "FOR") == 0) {
466 s = 49;
467 }
468 break;
469 case 'I':
470 OPS_Identifier(&s);
471 if (__STRCMP(OPS_name, "IF") == 0) {
472 s = 45;
473 } else if (__STRCMP(OPS_name, "IN") == 0) {
474 s = 15;
475 } else if (__STRCMP(OPS_name, "IS") == 0) {
476 s = 16;
477 } else if (__STRCMP(OPS_name, "IMPORT") == 0) {
478 s = 62;
479 }
480 break;
481 case 'L':
482 OPS_Identifier(&s);
483 if (__STRCMP(OPS_name, "LOOP") == 0) {
484 s = 50;
485 }
486 break;
487 case 'M':
488 OPS_Identifier(&s);
489 if (__STRCMP(OPS_name, "MOD") == 0) {
490 s = 4;
491 } else if (__STRCMP(OPS_name, "MODULE") == 0) {
492 s = 63;
493 }
494 break;
495 case 'N':
496 OPS_Identifier(&s);
497 if (__STRCMP(OPS_name, "NIL") == 0) {
498 s = 36;
499 }
500 break;
501 case 'O':
502 OPS_Identifier(&s);
503 if (__STRCMP(OPS_name, "OR") == 0) {
504 s = 8;
505 } else if (__STRCMP(OPS_name, "OF") == 0) {
506 s = 25;
507 }
508 break;
509 case 'P':
510 OPS_Identifier(&s);
511 if (__STRCMP(OPS_name, "PROCEDURE") == 0) {
512 s = 61;
513 } else if (__STRCMP(OPS_name, "POINTER") == 0) {
514 s = 56;
515 }
516 break;
517 case 'R':
518 OPS_Identifier(&s);
519 if (__STRCMP(OPS_name, "RECORD") == 0) {
520 s = 55;
521 } else if (__STRCMP(OPS_name, "REPEAT") == 0) {
522 s = 48;
523 } else if (__STRCMP(OPS_name, "RETURN") == 0) {
524 s = 53;
525 }
526 break;
527 case 'T':
528 OPS_Identifier(&s);
529 if (__STRCMP(OPS_name, "THEN") == 0) {
530 s = 26;
531 } else if (__STRCMP(OPS_name, "TO") == 0) {
532 s = 28;
533 } else if (__STRCMP(OPS_name, "TYPE") == 0) {
534 s = 59;
535 }
536 break;
537 case 'U':
538 OPS_Identifier(&s);
539 if (__STRCMP(OPS_name, "UNTIL") == 0) {
540 s = 44;
541 }
542 break;
543 case 'V':
544 OPS_Identifier(&s);
545 if (__STRCMP(OPS_name, "VAR") == 0) {
546 s = 60;
547 }
548 break;
549 case 'W':
550 OPS_Identifier(&s);
551 if (__STRCMP(OPS_name, "WHILE") == 0) {
552 s = 47;
553 } else if (__STRCMP(OPS_name, "WITH") == 0) {
554 s = 51;
555 }
556 break;
557 case 'G': case 'H': case 'J': case 'K': case 'Q':
558 case 'S': case 'X': case 'Y': case 'Z':
559 OPS_Identifier(&s);
560 break;
561 case '[':
562 s = 31;
563 OPM_Get(&OPS_ch);
564 break;
565 case ']':
566 s = 23;
567 OPM_Get(&OPS_ch);
568 break;
569 case '^':
570 s = 17;
571 OPM_Get(&OPS_ch);
572 break;
573 case 'a': case 'b': case 'c': case 'd': case 'e':
574 case 'f': case 'g': case 'h': case 'i': case 'j':
575 case 'k': case 'l': case 'm': case 'n': case 'o':
576 case 'p': case 'q': case 'r': case 's': case 't':
577 case 'u': case 'v': case 'w': case 'x': case 'y':
578 case 'z':
579 OPS_Identifier(&s);
580 break;
581 case '{':
582 s = 32;
583 OPM_Get(&OPS_ch);
584 break;
585 case '|':
586 s = 40;
587 OPM_Get(&OPS_ch);
588 break;
589 case '}':
590 s = 24;
591 OPM_Get(&OPS_ch);
592 break;
593 case '~':
594 s = 33;
595 OPM_Get(&OPS_ch);
596 break;
597 case 0x7f:
598 s = 21;
599 OPM_Get(&OPS_ch);
600 break;
601 default:
602 s = 0;
603 OPM_Get(&OPS_ch);
604 break;
605 }
606 *sym = s;
607 Get__1_s = _s.lnk;
608 }
609
OPS_Init(void)610 void OPS_Init (void)
611 {
612 OPS_ch = ' ';
613 }
614
615
OPS__init(void)616 export void *OPS__init(void)
617 {
618 __DEFMOD;
619 __MODULE_IMPORT(OPM);
620 __REGMOD("OPS", 0);
621 __REGCMD("Init", OPS_Init);
622 /* BEGIN */
623 __ENDMOD;
624 }
625