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