Commit | Line | Data |
---|---|---|
2febe727 CH |
1 | # |
2 | /* | |
3 | * pi - Pascal interpreter code translator | |
4 | * | |
5 | * Charles Haley, Bill Joy UCB | |
6 | * Version 1.0 August 1977 | |
7 | */ | |
8 | ||
9 | #include "whoami" | |
10 | #include "0.h" | |
11 | #include "tree.h" | |
12 | #include "opcode.h" | |
13 | ||
14 | /* | |
15 | * Constant set constructor. | |
16 | * settype is the type of the | |
17 | * set if we think that we know it | |
18 | * if not we try our damndest to figure | |
19 | * out what the type should be. | |
20 | */ | |
21 | cset(r, settype, x) | |
22 | int *r; | |
23 | struct nl *settype; | |
24 | int x; | |
25 | { | |
26 | register *e; | |
27 | register struct nl *t, *exptype; | |
28 | int n, *el; | |
29 | ||
30 | if (settype == NIL) { | |
31 | /* | |
32 | * So far we have no indication | |
33 | * of what the set type should be. | |
34 | * We "look ahead" and try to infer | |
35 | * The type of the constant set | |
36 | * by evaluating one of its members. | |
37 | */ | |
38 | e = r[2]; | |
39 | if (e == NIL) | |
40 | return (nl+TSET); /* tenative for [] */ | |
41 | e = e[1]; | |
42 | if (e == NIL) | |
43 | return (NIL); | |
44 | if (e[0] == T_RANG) | |
45 | e = e[1]; | |
46 | codeoff(); | |
47 | t = rvalue(e, NIL); | |
48 | codeon(); | |
49 | if (t == NIL) | |
50 | return (NIL); | |
51 | /* | |
52 | * The type of the set, settype, is | |
53 | * deemed to be a set of the base type | |
54 | * of t, which we call exptype. If, | |
55 | * however, this would involve a | |
56 | * "set of integer", we cop out | |
57 | * and use "intset"'s current scoped | |
58 | * type instead. | |
59 | */ | |
60 | if (isa(t, "r")) { | |
61 | error("Sets may not have 'real' elements"); | |
62 | return (NIL); | |
63 | } | |
64 | if (isnta(t, "bcsi")) { | |
65 | error("Set elements must be scalars, not %ss", nameof(t)); | |
66 | return (NIL); | |
67 | } | |
68 | if (isa(t, "i")) { | |
69 | settype = lookup(intset); | |
70 | if (settype == NIL) | |
71 | panic("intset"); | |
72 | settype = settype->type; | |
73 | if (settype == NIL) | |
74 | return (NIL); | |
75 | if (isnta(settype, "t")) { | |
76 | error("Set default type \"intset\" is not a set"); | |
77 | return (NIL); | |
78 | } | |
79 | exptype = settype->type; | |
80 | } else { | |
81 | exptype = t->type; | |
82 | if (exptype == NIL) | |
83 | return (NIL); | |
84 | if (exptype->class != RANGE) | |
85 | exptype = exptype->type; | |
86 | settype = defnl(0, SET, exptype, 0); | |
87 | } | |
88 | } else { | |
89 | if (settype->class != SET) { | |
90 | /* | |
91 | * e.g string context [1,2] = 'abc' | |
92 | */ | |
93 | error("Constant set involved in non set context"); | |
94 | return (NIL); | |
95 | } | |
96 | exptype = settype->type; | |
97 | } | |
98 | if (x == NIL) | |
99 | put2(O_PUSH, -width(settype)); | |
100 | n = 0; | |
101 | for (el=r[2]; el; el=el[2]) { | |
102 | n++; | |
103 | e = el[1]; | |
104 | if (e == NIL) | |
105 | return (NIL); | |
106 | if (e[0] == T_RANG) { | |
107 | t = rvalue(e[2], NIL); | |
108 | if (t == NIL) { | |
109 | rvalue(e[1], NIL); | |
110 | continue; | |
111 | } | |
112 | if (incompat(t, exptype, e[2])) | |
113 | cerror("Upper bound of element type clashed with set type in constant set"); | |
114 | else | |
115 | convert(t, nl+T2INT); | |
116 | t = rvalue(e[1], NIL); | |
117 | if (t == NIL) | |
118 | continue; | |
119 | if (incompat(t, exptype, e[1])) | |
120 | cerror("Lower bound of element type clashed with set type in constant set"); | |
121 | else | |
122 | convert(t, nl+T2INT); | |
123 | } else { | |
124 | t = rvalue(e, NIL); | |
125 | if (t == NIL) | |
126 | continue; | |
127 | if (incompat(t, exptype, e)) | |
128 | cerror("Element type clashed with set type in constant set"); | |
129 | else | |
130 | convert(t, nl+T2INT); | |
131 | put1(O_SDUP); | |
132 | } | |
133 | } | |
134 | if (x == NIL) { | |
135 | setran(exptype); | |
136 | put(4, O_CTTOT, n, set.lwrb, set.uprbp); | |
137 | } else | |
138 | put1(O_CON2, n); | |
139 | return (settype); | |
140 | } |