Commit | Line | Data |
---|---|---|
a629ae97 SL |
1 | #ifndef lint |
2 | static char sccsid[] = "@(#)modula-2.c 1.1 (Berkeley) %G%"; /* from 1.4 84/03/27 10:22:04 linton Exp */ | |
3 | #endif | |
4 | ||
5 | /* | |
6 | * Modula-2 specific symbol routines. | |
7 | */ | |
8 | ||
9 | #include "defs.h" | |
10 | #include "symbols.h" | |
11 | #include "modula-2.h" | |
12 | #include "languages.h" | |
13 | #include "tree.h" | |
14 | #include "eval.h" | |
15 | #include "mappings.h" | |
16 | #include "process.h" | |
17 | #include "runtime.h" | |
18 | #include "machine.h" | |
19 | ||
20 | #ifndef public | |
21 | #endif | |
22 | ||
23 | private Language mod2; | |
24 | private boolean initialized; | |
25 | ||
26 | /* | |
27 | * Initialize Modula-2 information. | |
28 | */ | |
29 | ||
30 | public modula2_init () | |
31 | { | |
32 | mod2 = language_define("modula-2", ".mod"); | |
33 | language_setop(mod2, L_PRINTDECL, modula2_printdecl); | |
34 | language_setop(mod2, L_PRINTVAL, modula2_printval); | |
35 | language_setop(mod2, L_TYPEMATCH, modula2_typematch); | |
36 | language_setop(mod2, L_BUILDAREF, modula2_buildaref); | |
37 | language_setop(mod2, L_EVALAREF, modula2_evalaref); | |
38 | language_setop(mod2, L_MODINIT, modula2_modinit); | |
39 | language_setop(mod2, L_HASMODULES, modula2_hasmodules); | |
40 | language_setop(mod2, L_PASSADDR, modula2_passaddr); | |
41 | initialized = false; | |
42 | } | |
43 | ||
44 | /* | |
45 | * Typematch tests if two types are compatible. The issue | |
46 | * is a bit complicated, so several subfunctions are used for | |
47 | * various kinds of compatibility. | |
48 | */ | |
49 | ||
50 | private boolean nilMatch (t1, t2) | |
51 | register Symbol t1, t2; | |
52 | { | |
53 | boolean b; | |
54 | ||
55 | b = (boolean) ( | |
56 | (t1 == t_nil and t2->class == PTR) or | |
57 | (t1->class == PTR and t2 == t_nil) | |
58 | ); | |
59 | return b; | |
60 | } | |
61 | ||
62 | private boolean enumMatch (t1, t2) | |
63 | register Symbol t1, t2; | |
64 | { | |
65 | boolean b; | |
66 | ||
67 | b = (boolean) ( | |
68 | t1->type == t2->type and ( | |
69 | (t1->class == t2->class) or | |
70 | (t1->class == SCAL and t2->class == CONST) or | |
71 | (t1->class == CONST and t2->class == SCAL) | |
72 | ) | |
73 | ); | |
74 | return b; | |
75 | } | |
76 | ||
77 | private boolean openArrayMatch (t1, t2) | |
78 | register Symbol t1, t2; | |
79 | { | |
80 | boolean b; | |
81 | ||
82 | b = (boolean) ( | |
83 | ( | |
84 | t1->class == ARRAY and t1->chain == t_open and | |
85 | t2->class == ARRAY and | |
86 | compatible(rtype(t2->chain)->type, t_int) and | |
87 | compatible(t1->type, t2->type) | |
88 | ) or ( | |
89 | t2->class == ARRAY and t2->chain == t_open and | |
90 | t1->class == ARRAY and | |
91 | compatible(rtype(t1->chain)->type, t_int) and | |
92 | compatible(t1->type, t2->type) | |
93 | ) | |
94 | ); | |
95 | return b; | |
96 | } | |
97 | ||
98 | private boolean isConstString (t) | |
99 | register Symbol t; | |
100 | { | |
101 | boolean b; | |
102 | ||
103 | b = (boolean) ( | |
104 | t->language == primlang and t->class == ARRAY and t->type == t_char | |
105 | ); | |
106 | return b; | |
107 | } | |
108 | ||
109 | private boolean stringArrayMatch (t1, t2) | |
110 | register Symbol t1, t2; | |
111 | { | |
112 | boolean b; | |
113 | ||
114 | b = (boolean) ( | |
115 | ( | |
116 | isConstString(t1) and | |
117 | t2->class == ARRAY and compatible(t2->type, t_char->type) | |
118 | ) or ( | |
119 | isConstString(t2) and | |
120 | t1->class == ARRAY and compatible(t1->type, t_char->type) | |
121 | ) | |
122 | ); | |
123 | return b; | |
124 | } | |
125 | ||
126 | public boolean modula2_typematch (type1, type2) | |
127 | Symbol type1, type2; | |
128 | { | |
129 | Boolean b; | |
130 | Symbol t1, t2, tmp; | |
131 | ||
132 | t1 = rtype(type1); | |
133 | t2 = rtype(type2); | |
134 | if (t1 == t2) { | |
135 | b = true; | |
136 | } else { | |
137 | if (t1 == t_char->type or t1 == t_int->type or t1 == t_real->type) { | |
138 | tmp = t1; | |
139 | t1 = t2; | |
140 | t2 = tmp; | |
141 | } | |
142 | b = (Boolean) ( | |
143 | ( | |
144 | t2 == t_int->type and | |
145 | t1->class == RANGE and ( | |
146 | istypename(t1->type, "integer") or | |
147 | istypename(t1->type, "cardinal") | |
148 | ) | |
149 | ) or ( | |
150 | t2 == t_char->type and | |
151 | t1->class == RANGE and istypename(t1->type, "char") | |
152 | ) or ( | |
153 | t2 == t_real->type and | |
154 | t1->class == RANGE and ( | |
155 | istypename(t1->type, "real") or | |
156 | istypename(t1->type, "longreal") | |
157 | ) | |
158 | ) or ( | |
159 | nilMatch(t1, t2) | |
160 | ) or ( | |
161 | enumMatch(t1, t2) | |
162 | ) or ( | |
163 | openArrayMatch(t1, t2) | |
164 | ) or ( | |
165 | stringArrayMatch(t1, t2) | |
166 | ) | |
167 | ); | |
168 | } | |
169 | return b; | |
170 | } | |
171 | ||
172 | /* | |
173 | * Indent n spaces. | |
174 | */ | |
175 | ||
176 | private indent (n) | |
177 | int n; | |
178 | { | |
179 | if (n > 0) { | |
180 | printf("%*c", n, ' '); | |
181 | } | |
182 | } | |
183 | ||
184 | public modula2_printdecl (s) | |
185 | Symbol s; | |
186 | { | |
187 | register Symbol t; | |
188 | Boolean semicolon; | |
189 | ||
190 | semicolon = true; | |
191 | if (s->class == TYPEREF) { | |
192 | resolveRef(t); | |
193 | } | |
194 | switch (s->class) { | |
195 | case CONST: | |
196 | if (s->type->class == SCAL) { | |
197 | printf("(enumeration constant, ord %ld)", | |
198 | s->symvalue.iconval); | |
199 | } else { | |
200 | printf("const %s = ", symname(s)); | |
201 | modula2_printval(s); | |
202 | } | |
203 | break; | |
204 | ||
205 | case TYPE: | |
206 | printf("type %s = ", symname(s)); | |
207 | printtype(s, s->type, 0); | |
208 | break; | |
209 | ||
210 | case TYPEREF: | |
211 | printf("type %s", symname(s)); | |
212 | break; | |
213 | ||
214 | case VAR: | |
215 | if (isparam(s)) { | |
216 | printf("(parameter) %s : ", symname(s)); | |
217 | } else { | |
218 | printf("var %s : ", symname(s)); | |
219 | } | |
220 | printtype(s, s->type, 0); | |
221 | break; | |
222 | ||
223 | case REF: | |
224 | printf("(var parameter) %s : ", symname(s)); | |
225 | printtype(s, s->type, 0); | |
226 | break; | |
227 | ||
228 | case RANGE: | |
229 | case ARRAY: | |
230 | case RECORD: | |
231 | case VARNT: | |
232 | case PTR: | |
233 | printtype(s, s, 0); | |
234 | semicolon = false; | |
235 | break; | |
236 | ||
237 | case FVAR: | |
238 | printf("(function variable) %s : ", symname(s)); | |
239 | printtype(s, s->type, 0); | |
240 | break; | |
241 | ||
242 | case FIELD: | |
243 | printf("(field) %s : ", symname(s)); | |
244 | printtype(s, s->type, 0); | |
245 | break; | |
246 | ||
247 | case PROC: | |
248 | printf("procedure %s", symname(s)); | |
249 | listparams(s); | |
250 | break; | |
251 | ||
252 | case PROG: | |
253 | printf("program %s", symname(s)); | |
254 | listparams(s); | |
255 | break; | |
256 | ||
257 | case FUNC: | |
258 | printf("function %s", symname(s)); | |
259 | listparams(s); | |
260 | printf(" : "); | |
261 | printtype(s, s->type, 0); | |
262 | break; | |
263 | ||
264 | case MODULE: | |
265 | printf("module %s", symname(s)); | |
266 | break; | |
267 | ||
268 | default: | |
269 | printf("%s : (class %s)", symname(s), classname(s)); | |
270 | break; | |
271 | } | |
272 | if (semicolon) { | |
273 | putchar(';'); | |
274 | } | |
275 | putchar('\n'); | |
276 | } | |
277 | ||
278 | /* | |
279 | * Recursive whiz-bang procedure to print the type portion | |
280 | * of a declaration. | |
281 | * | |
282 | * The symbol associated with the type is passed to allow | |
283 | * searching for type names without getting "type blah = blah". | |
284 | */ | |
285 | ||
286 | private printtype (s, t, n) | |
287 | Symbol s; | |
288 | Symbol t; | |
289 | int n; | |
290 | { | |
291 | register Symbol tmp; | |
292 | ||
293 | if (t->class == TYPEREF) { | |
294 | resolveRef(t); | |
295 | } | |
296 | switch (t->class) { | |
297 | case VAR: | |
298 | case CONST: | |
299 | case FUNC: | |
300 | case PROC: | |
301 | panic("printtype: class %s", classname(t)); | |
302 | break; | |
303 | ||
304 | case ARRAY: | |
305 | printf("array["); | |
306 | tmp = t->chain; | |
307 | if (tmp != nil) { | |
308 | for (;;) { | |
309 | printtype(tmp, tmp, n); | |
310 | tmp = tmp->chain; | |
311 | if (tmp == nil) { | |
312 | break; | |
313 | } | |
314 | printf(", "); | |
315 | } | |
316 | } | |
317 | printf("] of "); | |
318 | printtype(t, t->type, n); | |
319 | break; | |
320 | ||
321 | case RECORD: | |
322 | printRecordDecl(t, n); | |
323 | break; | |
324 | ||
325 | case FIELD: | |
326 | if (t->chain != nil) { | |
327 | printtype(t->chain, t->chain, n); | |
328 | } | |
329 | printf("\t%s : ", symname(t)); | |
330 | printtype(t, t->type, n); | |
331 | printf(";\n"); | |
332 | break; | |
333 | ||
334 | case RANGE: | |
335 | printRangeDecl(t); | |
336 | break; | |
337 | ||
338 | case PTR: | |
339 | printf("pointer to "); | |
340 | printtype(t, t->type, n); | |
341 | break; | |
342 | ||
343 | case TYPE: | |
344 | if (t->name != nil and ident(t->name)[0] != '\0') { | |
345 | printname(stdout, t); | |
346 | } else { | |
347 | printtype(t, t->type, n); | |
348 | } | |
349 | break; | |
350 | ||
351 | case SCAL: | |
352 | printEnumDecl(t, n); | |
353 | break; | |
354 | ||
355 | case SET: | |
356 | printf("set of "); | |
357 | printtype(t, t->type, n); | |
358 | break; | |
359 | ||
360 | case TYPEREF: | |
361 | break; | |
362 | ||
363 | default: | |
364 | printf("(class %d)", t->class); | |
365 | break; | |
366 | } | |
367 | } | |
368 | ||
369 | /* | |
370 | * Print out a record declaration. | |
371 | */ | |
372 | ||
373 | private printRecordDecl (t, n) | |
374 | Symbol t; | |
375 | int n; | |
376 | { | |
377 | register Symbol f; | |
378 | ||
379 | if (t->chain == nil) { | |
380 | printf("record end"); | |
381 | } else { | |
382 | printf("record\n"); | |
383 | for (f = t->chain; f != nil; f = f->chain) { | |
384 | indent(n+4); | |
385 | printf("%s : ", symname(f)); | |
386 | printtype(f->type, f->type, n+4); | |
387 | printf(";\n"); | |
388 | } | |
389 | indent(n); | |
390 | printf("end"); | |
391 | } | |
392 | } | |
393 | ||
394 | /* | |
395 | * Print out the declaration of a range type. | |
396 | */ | |
397 | ||
398 | private printRangeDecl (t) | |
399 | Symbol t; | |
400 | { | |
401 | long r0, r1; | |
402 | ||
403 | r0 = t->symvalue.rangev.lower; | |
404 | r1 = t->symvalue.rangev.upper; | |
405 | if (t == t_char or istypename(t, "char")) { | |
406 | if (r0 < 0x20 or r0 > 0x7e) { | |
407 | printf("%ld..", r0); | |
408 | } else { | |
409 | printf("'%c'..", (char) r0); | |
410 | } | |
411 | if (r1 < 0x20 or r1 > 0x7e) { | |
412 | printf("\\%lo", r1); | |
413 | } else { | |
414 | printf("'%c'", (char) r1); | |
415 | } | |
416 | } else if (r0 > 0 and r1 == 0) { | |
417 | printf("%ld byte real", r0); | |
418 | } else if (r0 >= 0) { | |
419 | printf("%lu..%lu", r0, r1); | |
420 | } else { | |
421 | printf("%ld..%ld", r0, r1); | |
422 | } | |
423 | } | |
424 | ||
425 | /* | |
426 | * Print out an enumeration declaration. | |
427 | */ | |
428 | ||
429 | private printEnumDecl (e, n) | |
430 | Symbol e; | |
431 | int n; | |
432 | { | |
433 | Symbol t; | |
434 | ||
435 | printf("("); | |
436 | t = e->chain; | |
437 | if (t != nil) { | |
438 | printf("%s", symname(t)); | |
439 | t = t->chain; | |
440 | while (t != nil) { | |
441 | printf(", %s", symname(t)); | |
442 | t = t->chain; | |
443 | } | |
444 | } | |
445 | printf(")"); | |
446 | } | |
447 | ||
448 | /* | |
449 | * List the parameters of a procedure or function. | |
450 | * No attempt is made to combine like types. | |
451 | */ | |
452 | ||
453 | private listparams (s) | |
454 | Symbol s; | |
455 | { | |
456 | Symbol t; | |
457 | ||
458 | if (s->chain != nil) { | |
459 | putchar('('); | |
460 | for (t = s->chain; t != nil; t = t->chain) { | |
461 | switch (t->class) { | |
462 | case REF: | |
463 | printf("var "); | |
464 | break; | |
465 | ||
466 | case FPROC: | |
467 | case FFUNC: | |
468 | printf("procedure "); | |
469 | break; | |
470 | ||
471 | case VAR: | |
472 | break; | |
473 | ||
474 | default: | |
475 | panic("unexpected class %d for parameter", t->class); | |
476 | } | |
477 | printf("%s", symname(t)); | |
478 | if (s->class == PROG) { | |
479 | printf(", "); | |
480 | } else { | |
481 | printf(" : "); | |
482 | printtype(t, t->type, 0); | |
483 | if (t->chain != nil) { | |
484 | printf("; "); | |
485 | } | |
486 | } | |
487 | } | |
488 | putchar(')'); | |
489 | } | |
490 | } | |
491 | ||
492 | /* | |
493 | * Modula 2 interface to printval. | |
494 | */ | |
495 | ||
496 | public modula2_printval (s) | |
497 | Symbol s; | |
498 | { | |
499 | prval(s, size(s)); | |
500 | } | |
501 | ||
502 | /* | |
503 | * Print out the value on the top of the expression stack | |
504 | * in the format for the type of the given symbol, assuming | |
505 | * the size of the object is n bytes. | |
506 | */ | |
507 | ||
508 | private prval (s, n) | |
509 | Symbol s; | |
510 | integer n; | |
511 | { | |
512 | Symbol t; | |
513 | Address a; | |
514 | integer len; | |
515 | double r; | |
516 | integer scalar; | |
517 | boolean found; | |
518 | ||
519 | if (s->class == TYPEREF) { | |
520 | resolveRef(s); | |
521 | } | |
522 | switch (s->class) { | |
523 | case CONST: | |
524 | case TYPE: | |
525 | case VAR: | |
526 | case REF: | |
527 | case FVAR: | |
528 | case TAG: | |
529 | case FIELD: | |
530 | prval(s->type, n); | |
531 | break; | |
532 | ||
533 | case ARRAY: | |
534 | t = rtype(s->type); | |
535 | if (t->class == RANGE and istypename(t->type, "char")) { | |
536 | len = size(s); | |
537 | sp -= len; | |
538 | printf("'%.*s'", len, sp); | |
539 | break; | |
540 | } else { | |
541 | printarray(s); | |
542 | } | |
543 | break; | |
544 | ||
545 | case RECORD: | |
546 | printrecord(s); | |
547 | break; | |
548 | ||
549 | case VARNT: | |
550 | printf("can't print out variant records"); | |
551 | break; | |
552 | ||
553 | case RANGE: | |
554 | printrange(s, n); | |
555 | break; | |
556 | ||
557 | case FILET: | |
558 | case PTR: | |
559 | a = pop(Address); | |
560 | if (a == 0) { | |
561 | printf("nil"); | |
562 | } else { | |
563 | printf("0x%x", a); | |
564 | } | |
565 | break; | |
566 | ||
567 | case SCAL: | |
568 | popn(n, &scalar); | |
569 | found = false; | |
570 | for (t = s->chain; t != nil; t = t->chain) { | |
571 | if (t->symvalue.iconval == scalar) { | |
572 | printf("%s", symname(t)); | |
573 | found = true; | |
574 | break; | |
575 | } | |
576 | } | |
577 | if (not found) { | |
578 | printf("(scalar = %d)", scalar); | |
579 | } | |
580 | break; | |
581 | ||
582 | case FPROC: | |
583 | case FFUNC: | |
584 | a = pop(long); | |
585 | t = whatblock(a); | |
586 | if (t == nil) { | |
587 | printf("(proc 0x%x)", a); | |
588 | } else { | |
589 | printf("%s", symname(t)); | |
590 | } | |
591 | break; | |
592 | ||
593 | case SET: | |
594 | printSet(s); | |
595 | break; | |
596 | ||
597 | default: | |
598 | if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) { | |
599 | panic("printval: bad class %d", ord(s->class)); | |
600 | } | |
601 | printf("[%s]", classname(s)); | |
602 | break; | |
603 | } | |
604 | } | |
605 | ||
606 | /* | |
607 | * Print out the value of a scalar (non-enumeration) type. | |
608 | */ | |
609 | ||
610 | private printrange (s, n) | |
611 | Symbol s; | |
612 | integer n; | |
613 | { | |
614 | double d; | |
615 | float f; | |
616 | integer i; | |
617 | ||
618 | if (s->symvalue.rangev.upper == 0 and s->symvalue.rangev.lower > 0) { | |
619 | if (n == sizeof(float)) { | |
620 | popn(n, &f); | |
621 | d = f; | |
622 | } else { | |
623 | popn(n, &d); | |
624 | } | |
625 | prtreal(d); | |
626 | } else { | |
627 | i = 0; | |
628 | popn(n, &i); | |
629 | if (s == t_boolean) { | |
630 | printf(((Boolean) i) == true ? "true" : "false"); | |
631 | } else if (s == t_char or istypename(s->type, "char")) { | |
632 | printf("'%c'", i); | |
633 | } else if (s->symvalue.rangev.lower >= 0) { | |
634 | printf("%lu", i); | |
635 | } else { | |
636 | printf("%ld", i); | |
637 | } | |
638 | } | |
639 | } | |
640 | ||
641 | /* | |
642 | * Print out a set. | |
643 | */ | |
644 | ||
645 | private printSet (s) | |
646 | Symbol s; | |
647 | { | |
648 | Symbol t; | |
649 | integer nbytes; | |
650 | ||
651 | nbytes = size(s); | |
652 | t = rtype(s->type); | |
653 | printf("{"); | |
654 | sp -= nbytes; | |
655 | if (t->class == SCAL) { | |
656 | printSetOfEnum(t); | |
657 | } else if (t->class == RANGE) { | |
658 | printSetOfRange(t); | |
659 | } else { | |
660 | panic("expected range or enumerated base type for set"); | |
661 | } | |
662 | printf("}"); | |
663 | } | |
664 | ||
665 | /* | |
666 | * Print out a set of an enumeration. | |
667 | */ | |
668 | ||
669 | private printSetOfEnum (t) | |
670 | Symbol t; | |
671 | { | |
672 | register Symbol e; | |
673 | register integer i, j, *p; | |
674 | boolean first; | |
675 | ||
676 | p = (int *) sp; | |
677 | i = *p; | |
678 | j = 0; | |
679 | e = t->chain; | |
680 | first = true; | |
681 | while (e != nil) { | |
682 | if ((i&1) == 1) { | |
683 | if (first) { | |
684 | first = false; | |
685 | printf("%s", symname(e)); | |
686 | } else { | |
687 | printf(", %s", symname(e)); | |
688 | } | |
689 | } | |
690 | i >>= 1; | |
691 | ++j; | |
692 | if (j >= sizeof(integer)*BITSPERBYTE) { | |
693 | j = 0; | |
694 | ++p; | |
695 | i = *p; | |
696 | } | |
697 | e = e->chain; | |
698 | } | |
699 | } | |
700 | ||
701 | /* | |
702 | * Print out a set of a subrange type. | |
703 | */ | |
704 | ||
705 | private printSetOfRange (t) | |
706 | Symbol t; | |
707 | { | |
708 | register integer i, j, *p; | |
709 | long v; | |
710 | boolean first; | |
711 | ||
712 | p = (int *) sp; | |
713 | i = *p; | |
714 | j = 0; | |
715 | v = t->symvalue.rangev.lower; | |
716 | first = true; | |
717 | while (v <= t->symvalue.rangev.upper) { | |
718 | if ((i&1) == 1) { | |
719 | if (first) { | |
720 | first = false; | |
721 | printf("%ld", v); | |
722 | } else { | |
723 | printf(", %ld", v); | |
724 | } | |
725 | } | |
726 | i >>= 1; | |
727 | ++j; | |
728 | if (j >= sizeof(integer)*BITSPERBYTE) { | |
729 | j = 0; | |
730 | ++p; | |
731 | i = *p; | |
732 | } | |
733 | ++v; | |
734 | } | |
735 | } | |
736 | ||
737 | /* | |
738 | * Construct a node for subscripting. | |
739 | */ | |
740 | ||
741 | public Node modula2_buildaref (a, slist) | |
742 | Node a, slist; | |
743 | { | |
744 | register Symbol t; | |
745 | register Node p; | |
746 | Symbol etype, atype, eltype; | |
747 | Node esub, r; | |
748 | ||
749 | r = a; | |
750 | t = rtype(a->nodetype); | |
751 | eltype = t->type; | |
752 | if (t->class != ARRAY) { | |
753 | beginerrmsg(); | |
754 | prtree(stderr, a); | |
755 | fprintf(stderr, " is not an array"); | |
756 | enderrmsg(); | |
757 | } else { | |
758 | p = slist; | |
759 | t = t->chain; | |
760 | for (; p != nil and t != nil; p = p->value.arg[1], t = t->chain) { | |
761 | esub = p->value.arg[0]; | |
762 | etype = rtype(esub->nodetype); | |
763 | atype = rtype(t); | |
764 | if (not compatible(atype, etype)) { | |
765 | beginerrmsg(); | |
766 | fprintf(stderr, "subscript "); | |
767 | prtree(stderr, esub); | |
768 | fprintf(stderr, " is the wrong type"); | |
769 | enderrmsg(); | |
770 | } | |
771 | r = build(O_INDEX, r, esub); | |
772 | r->nodetype = eltype; | |
773 | } | |
774 | if (p != nil or t != nil) { | |
775 | beginerrmsg(); | |
776 | if (p != nil) { | |
777 | fprintf(stderr, "too many subscripts for "); | |
778 | } else { | |
779 | fprintf(stderr, "not enough subscripts for "); | |
780 | } | |
781 | prtree(stderr, a); | |
782 | enderrmsg(); | |
783 | } | |
784 | } | |
785 | return r; | |
786 | } | |
787 | ||
788 | /* | |
789 | * Evaluate a subscript index. | |
790 | */ | |
791 | ||
792 | public int modula2_evalaref (s, i) | |
793 | Symbol s; | |
794 | long i; | |
795 | { | |
796 | long lb, ub; | |
797 | ||
798 | chkOpenArray(s); | |
799 | s = rtype(rtype(s)->chain); | |
800 | findbounds(s, &lb, &ub); | |
801 | if (i < lb or i > ub) { | |
802 | error("subscript %d out of range [%d..%d]", i, lb, ub); | |
803 | } | |
804 | return (i - lb); | |
805 | } | |
806 | ||
807 | /* | |
808 | * Initial Modula-2 type information. | |
809 | */ | |
810 | ||
811 | #define NTYPES 12 | |
812 | ||
813 | private Symbol inittype[NTYPES + 1]; | |
814 | ||
815 | private addType (n, s, lower, upper) | |
816 | integer n; | |
817 | String s; | |
818 | long lower, upper; | |
819 | { | |
820 | register Symbol t; | |
821 | ||
822 | if (n > NTYPES) { | |
823 | panic("initial Modula-2 type number too large for '%s'", s); | |
824 | } | |
825 | t = insert(identname(s, true)); | |
826 | t->language = mod2; | |
827 | t->class = TYPE; | |
828 | t->type = newSymbol(nil, 0, RANGE, t, nil); | |
829 | t->type->symvalue.rangev.lower = lower; | |
830 | t->type->symvalue.rangev.upper = upper; | |
831 | t->type->language = mod2; | |
832 | inittype[n] = t; | |
833 | } | |
834 | ||
835 | private initModTypes () | |
836 | { | |
837 | addType(1, "integer", 0x80000000L, 0x7fffffffL); | |
838 | addType(2, "char", 0L, 255L); | |
839 | addType(3, "boolean", 0L, 1L); | |
840 | addType(4, "unsigned", 0L, 0xffffffffL); | |
841 | addType(5, "real", 4L, 0L); | |
842 | addType(6, "longreal", 8L, 0L); | |
843 | addType(7, "word", 0L, 0xffffffffL); | |
844 | addType(8, "byte", 0L, 255L); | |
845 | addType(9, "address", 0L, 0xffffffffL); | |
846 | addType(10, "file", 0L, 0xffffffffL); | |
847 | addType(11, "process", 0L, 0xffffffffL); | |
848 | addType(12, "cardinal", 0L, 0x7fffffffL); | |
849 | } | |
850 | ||
851 | /* | |
852 | * Initialize typetable. | |
853 | */ | |
854 | ||
855 | public modula2_modinit (typetable) | |
856 | Symbol typetable[]; | |
857 | { | |
858 | register integer i; | |
859 | ||
860 | if (not initialized) { | |
861 | initModTypes(); | |
862 | } | |
863 | for (i = 1; i <= NTYPES; i++) { | |
864 | typetable[i] = inittype[i]; | |
865 | } | |
866 | } | |
867 | ||
868 | public boolean modula2_hasmodules () | |
869 | { | |
870 | return true; | |
871 | } | |
872 | ||
873 | public boolean modula2_passaddr (param, exprtype) | |
874 | Symbol param, exprtype; | |
875 | { | |
876 | return false; | |
877 | } |