Commit | Line | Data |
---|---|---|
0f4556f1 C |
1 | static char Sccsid[] = "ab.c @(#)ab.c 1.1 10/1/82 Berkeley "; |
2 | #include "apl.h" | |
3 | ||
4 | ex_take() | |
5 | { | |
6 | int takezr(); | |
7 | register i, k, o; | |
8 | int fill[MRANK], fflg; | |
9 | ||
10 | /* While TANSTAAFL, in APL there is a close approximation. It | |
11 | * is possible to perform a "take" of more elements than an | |
12 | * array actually contains (to be padded with zeros or blanks). | |
13 | * If "td1()" detects that a dimension exceeds what the array | |
14 | * actually contains it will return 1. Special code is then | |
15 | * required to force the extra elements in the new array to | |
16 | * zero or blank. This code is supposed to work for null items | |
17 | * also, but it doesn't. | |
18 | */ | |
19 | ||
20 | o = 0; | |
21 | fflg = td1(0); | |
22 | for(i=0; i<idx.rank; i++) { | |
23 | fill[i] = 0; | |
24 | k = idx.idx[i]; | |
25 | if(k < 0) { | |
26 | k = -k; | |
27 | if (k > idx.dim[i]) | |
28 | fill[i] = idx.dim[i] - k; | |
29 | o += idx.del[i] * | |
30 | (idx.dim[i] - k); | |
31 | } else | |
32 | if (k > idx.dim[i]) | |
33 | fill[i] = idx.dim[i]; | |
34 | idx.dim[i] = k; | |
35 | } | |
36 | map(o); | |
37 | ||
38 | if (fflg){ | |
39 | bidx(sp[-1]); | |
40 | forloop(takezr, fill); | |
41 | } | |
42 | } | |
43 | ||
44 | ex_drop() | |
45 | { | |
46 | register i, k, o; | |
47 | ||
48 | o = 0; | |
49 | td1(1); | |
50 | for(i=0; i<idx.rank; i++) { | |
51 | k = idx.idx[i]; | |
52 | if(k > 0) | |
53 | o += idx.del[i] * k; | |
54 | else | |
55 | k = -k; | |
56 | idx.dim[i] -= k; | |
57 | } | |
58 | map(o); | |
59 | } | |
60 | ||
61 | td1(tdmode) | |
62 | { | |
63 | register struct item *p; | |
64 | struct item *q, *nq, *s2vect(); | |
65 | register i, k; | |
66 | int r; /* set to 1 if take > array dim */ | |
67 | ||
68 | p = fetch2(); | |
69 | q = sp[-2]; | |
70 | r = !q->size; /* Weird stuff for null items */ | |
71 | if (q->rank == 0){ /* Extend scalars */ | |
72 | nq = newdat(q->type, p->size, 1); | |
73 | *nq->datap = *q->datap; | |
74 | pop(); | |
75 | *sp++ = q = nq; | |
76 | for(i=0; i<p->size; i++) | |
77 | q->dim[i] = 1; | |
78 | } | |
79 | if(p->rank > 1 || q->rank != p->size) | |
80 | error("take/drop C"); | |
81 | bidx(q); | |
82 | for(i=0; i<p->size; i++) { | |
83 | k = fix(getdat(p)); | |
84 | idx.idx[i] = k; | |
85 | if(k < 0) | |
86 | k = -k; | |
87 | ||
88 | /* If an attempt is made to drop more than what | |
89 | * exists, modify the drop to drop exactly what | |
90 | * exists. | |
91 | */ | |
92 | ||
93 | if(k > idx.dim[i]) | |
94 | if (tdmode) | |
95 | idx.idx[i] = idx.dim[i]; | |
96 | else | |
97 | r = 1; | |
98 | } | |
99 | pop(); | |
100 | return(r); | |
101 | } | |
102 | ||
103 | ex_dtrn() | |
104 | { | |
105 | register struct item *p, *q; | |
106 | register i; | |
107 | ||
108 | p = fetch2(); | |
109 | q = sp[-2]; | |
110 | if(p->rank > 1 || p->size != q->rank) | |
111 | error("tranpose C"); | |
112 | for(i=0; i<p->size; i++) | |
113 | idx.idx[i] = fix(getdat(p)) - thread.iorg; | |
114 | pop(); | |
115 | trn0(); | |
116 | } | |
117 | ||
118 | ex_mtrn() | |
119 | { | |
120 | register struct item *p; | |
121 | register i; | |
122 | ||
123 | p = fetch1(); | |
124 | if(p->rank <= 1) | |
125 | return; | |
126 | for(i=0; i<p->rank; i++) | |
127 | idx.idx[i] = p->rank-1-i; | |
128 | trn0(); | |
129 | } | |
130 | ||
131 | trn0() | |
132 | { | |
133 | register i, j; | |
134 | int d[MRANK], r[MRANK]; | |
135 | ||
136 | bidx(sp[-1]); | |
137 | for(i=0; i<idx.rank; i++) | |
138 | d[i] = -1; | |
139 | for(i=0; i<idx.rank; i++) { | |
140 | j = idx.idx[i]; | |
141 | if(j<0 || j>=idx.rank) | |
142 | error("tranpose X"); | |
143 | if(d[j] != -1) { | |
144 | if(idx.dim[i] < d[j]) | |
145 | d[j] = idx.dim[i]; | |
146 | r[j] += idx.del[i]; | |
147 | } else { | |
148 | d[j] = idx.dim[i]; | |
149 | r[j] = idx.del[i]; | |
150 | } | |
151 | } | |
152 | j = idx.rank; | |
153 | for(i=0; i<idx.rank; i++) { | |
154 | if(d[i] != -1) { | |
155 | if(i > j) | |
156 | error("tranpose D"); | |
157 | idx.dim[i] = d[i]; | |
158 | idx.del[i] = r[i]; | |
159 | } else | |
160 | if(i < j) | |
161 | j = i; | |
162 | } | |
163 | idx.rank = j; | |
164 | map(0); | |
165 | } | |
166 | ||
167 | ex_rev0() | |
168 | { | |
169 | ||
170 | fetch1(); | |
171 | revk(0); | |
172 | } | |
173 | ||
174 | ex_revk() | |
175 | { | |
176 | register k; | |
177 | ||
178 | k = topfix() - thread.iorg; | |
179 | fetch1(); | |
180 | revk(k); | |
181 | } | |
182 | ||
183 | ex_rev() | |
184 | { | |
185 | register struct item *p; | |
186 | ||
187 | p = fetch1(); | |
188 | revk(p->rank-1); | |
189 | } | |
190 | ||
191 | revk(k) | |
192 | { | |
193 | register o; | |
194 | ||
195 | bidx(sp[-1]); | |
196 | if(k < 0 || k >= idx.rank) | |
197 | error("reverse X"); | |
198 | o = idx.del[k] * (idx.dim[k]-1); | |
199 | idx.del[k] = -idx.del[k]; | |
200 | map(o); | |
201 | } | |
202 | ||
203 | map(o) | |
204 | { | |
205 | register struct item *p; | |
206 | register n, i; | |
207 | int map1(); | |
208 | ||
209 | n = 1; | |
210 | for(i=0; i<idx.rank; i++) | |
211 | n *= idx.dim[i]; | |
212 | if(n == 0) | |
213 | idx.rank == 0; | |
214 | p = newdat(idx.type, idx.rank, n); | |
215 | copy(IN, idx.dim, p->dim, idx.rank); | |
216 | *sp++ = p; | |
217 | if(n != 0) | |
218 | forloop(map1, o); | |
219 | sp--; | |
220 | pop(); | |
221 | *sp++ = p; | |
222 | } | |
223 | ||
224 | map1(o) | |
225 | { | |
226 | register struct item *p; | |
227 | ||
228 | p = sp[-2]; | |
229 | p->index = access() + o; | |
230 | putdat(sp[-1], getdat(p)); | |
231 | } | |
232 | ||
233 | takezr(fill) | |
234 | int *fill; | |
235 | { | |
236 | register struct item *p; | |
237 | register i; | |
238 | ||
239 | /* Zero appropriate elements of an array created by taking | |
240 | * more than you originally had. I apologize for the "dirty" | |
241 | * argument passing (passing a pointer to an integer array | |
242 | * through "forloop()" which treats it as an integer) and for | |
243 | * the general dumbness of this code. | |
244 | * --John Bruner | |
245 | */ | |
246 | ||
247 | for(i=0; i<idx.rank; i++) | |
248 | if (fill[i] > 0 && idx.idx[i] >= fill[i] | |
249 | || fill[i] < 0 && idx.idx[i] < -fill[i]){ | |
250 | p = sp[-1]; | |
251 | p->index = access(); | |
252 | putdat(p, (p->type==DA) ? zero : (data)' '); | |
253 | return; | |
254 | } | |
255 | } |