1 /*
2 This file is part of GNU APL, a free implementation of the
3 ISO/IEC Standard 13751, "Programming Language APL, Extended"
4
5 Copyright (C) 2008-2016 Dr. Jürgen Sauermann
6
7 This program is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
11
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>.
19 */
20
21 #include "Bif_F12_TAKE_DROP.hh"
22 #include "Bif_OPER2_RANK.hh"
23 #include "IntCell.hh"
24 #include "Macro.hh"
25 #include "PointerCell.hh"
26 #include "Workspace.hh"
27
28 Bif_OPER2_RANK Bif_OPER2_RANK::_fun;
29 Bif_OPER2_RANK * Bif_OPER2_RANK::fun = &Bif_OPER2_RANK::_fun;
30
31 /* general comment: we use the term 'chunk' instead of 'p-rank' to avoid
32 * confusion with the rank of a value
33 */
34
35 //-----------------------------------------------------------------------------
36 Token
eval_LRB(Token & LO,Token & y,Value_P B)37 Bif_OPER2_RANK::eval_LRB(Token & LO, Token & y, Value_P B)
38 {
39 if (B->element_count() == 1 && B->get_ravel(0).is_pointer_cell())
40 B = B->get_ravel(0).get_pointer_value();
41
42 Rank rank_chunk_B = B->get_rank();
43 y123_to_B(y.get_apl_val(), rank_chunk_B);
44
45 return do_LyXB(LO, Value_P(), B, rank_chunk_B);
46 }
47 //-----------------------------------------------------------------------------
48 Token
eval_LRXB(Token & LO,Token & y,Value_P X,Value_P B)49 Bif_OPER2_RANK::eval_LRXB(Token & LO, Token & y, Value_P X, Value_P B)
50 {
51 if (B->element_count() == 1 && B->get_ravel(0).is_pointer_cell())
52 B = B->get_ravel(0).get_pointer_value();
53
54 Rank rank_chunk_B = B->get_rank();
55
56 y123_to_B(y.get_apl_val(), rank_chunk_B);
57
58 return do_LyXB(LO, X, B, rank_chunk_B);
59 }
60 //-----------------------------------------------------------------------------
61 Token
do_LyXB(Token & _LO,Value_P X,Value_P B,Rank rank_chunk_B)62 Bif_OPER2_RANK::do_LyXB(Token & _LO, Value_P X, Value_P B, Rank rank_chunk_B)
63 {
64 Function * LO = _LO.get_function();
65 Assert(LO);
66 if (!LO->has_result()) DOMAIN_ERROR;
67
68 // split shape of B into high (=frame) and low (= chunk) shapes.
69 //
70 const Shape shape_Z = B->get_shape().high_shape(B->get_rank() - rank_chunk_B);
71 if (shape_Z.is_empty())
72 {
73 Value_P Fill_B = Bif_F12_TAKE::first(B);
74 Token tZ = LO->eval_fill_B(Fill_B);
75 Value_P Z = tZ.get_apl_val();
76 Z->set_shape(B->get_shape());
77 Z->check_value(LOC);
78 return Token(TOK_APL_VALUE1, Z);
79 }
80
81 const Shape shape_B = B->get_shape().low_shape(rank_chunk_B);
82
83 Value_P vsh_B(shape_B.get_rank(), LOC);
84 new (&vsh_B->get_ravel(0)) IntCell(0); // prototype
85 loop(sh, shape_B.get_rank())
86 new (vsh_B->next_ravel()) IntCell(shape_B.get_shape_item(sh));
87 vsh_B->check_value(LOC);
88
89 Value_P vsh_Z(shape_Z.get_rank(), LOC);
90 loop(sh, shape_Z.get_rank())
91 new (vsh_Z->next_ravel()) IntCell(shape_Z.get_shape_item(sh));
92 vsh_Z->check_value(LOC);
93
94 Value_P X5(5, LOC);
95 if (!X) new (X5->next_ravel()) IntCell(-1); // no X
96 else new (X5->next_ravel()) PointerCell(X.get(), X5.getref()); // X
97
98 new (X5->next_ravel()) IntCell(shape_B.get_volume()); // LB
99 new (X5->next_ravel()) PointerCell(vsh_B.get(), X5.getref()); // rho_B
100 new (X5->next_ravel()) IntCell(shape_Z.get_volume()); // N_max
101 new (X5->next_ravel()) PointerCell(vsh_Z.get(), X5.getref()); // rho_Z
102 X5->check_value(LOC);
103 return Macro::get_macro(Macro::MAC_Z__LO_RANK_X5_B)->eval_LXB(_LO, X5, B);
104 }
105 //-----------------------------------------------------------------------------
106 Token
eval_ALRB(Value_P A,Token & LO,Token & y,Value_P B)107 Bif_OPER2_RANK::eval_ALRB(Value_P A, Token & LO, Token & y, Value_P B)
108 {
109 if (B->element_count() == 1 && B->get_ravel(0).is_pointer_cell())
110 B = B->get_ravel(0).get_pointer_value();
111
112 Rank rank_chunk_A = A->get_rank();
113 Rank rank_chunk_B = B->get_rank();
114 y123_to_AB(y.get_apl_val(), rank_chunk_A, rank_chunk_B);
115
116 return do_ALyXB(A, rank_chunk_A, LO, Value_P(), B, rank_chunk_B);
117 }
118 //-----------------------------------------------------------------------------
119 Token
eval_ALRXB(Value_P A,Token & LO,Token & y,Value_P X,Value_P B)120 Bif_OPER2_RANK::eval_ALRXB(Value_P A, Token & LO, Token & y,
121 Value_P X, Value_P B)
122 {
123 if (B->element_count() == 1 && B->get_ravel(0).is_pointer_cell())
124 B = B->get_ravel(0).get_pointer_value();
125
126 Rank rank_chunk_A = A->get_rank();
127 Rank rank_chunk_B = B->get_rank();
128
129 y123_to_AB(y.get_apl_val(), rank_chunk_A, rank_chunk_B);
130
131 return do_ALyXB(A, rank_chunk_A, LO, X, B, rank_chunk_B);
132 }
133 //-----------------------------------------------------------------------------
134 Token
do_ALyXB(Value_P A,Rank rank_chunk_A,Token & _LO,Value_P X,Value_P B,Rank rank_chunk_B)135 Bif_OPER2_RANK::do_ALyXB(Value_P A, Rank rank_chunk_A, Token & _LO,
136 Value_P X, Value_P B, Rank rank_chunk_B)
137 {
138 Function * LO = _LO.get_function();
139 Assert(LO);
140 if (!LO->has_result()) DOMAIN_ERROR;
141
142 Rank rk_A_frame = A->get_rank() - rank_chunk_A; // rk_A_frame is y8
143 Rank rk_B_frame = B->get_rank() - rank_chunk_B; // rk_B_frame is y9
144
145 // if both high-ranks are 0, then return A LO B.
146 //
147 if (rk_A_frame == 0 && rk_B_frame == 0) return LO->eval_AB(A, B);
148
149 // split shapes of A1 and B1 into high (frame) and low (chunk) shapes.
150 // Even though A and B have the same shape, rk_A_frame and rk_B_frame
151 // could be different, leading to different split shapes for A and B
152 //
153 const Shape shape_Z = rk_B_frame ? B->get_shape().high_shape(rk_B_frame)
154 : A->get_shape().high_shape(rk_A_frame);
155
156 if (rk_A_frame && rk_B_frame) // A and B frames non-scalar
157 {
158 if (rk_A_frame != rk_B_frame) RANK_ERROR;
159 if (shape_Z != A->get_shape().high_shape(rk_A_frame)) LENGTH_ERROR;
160 }
161
162 if (shape_Z.is_empty())
163 {
164 Value_P Fill_A = Bif_F12_TAKE::first(A);
165 Value_P Fill_B = Bif_F12_TAKE::first(B);
166 Shape shape_Z;
167
168 if (A->is_empty()) shape_Z = A->get_shape();
169 else if (!A->is_scalar()) DOMAIN_ERROR;
170
171 if (B->is_empty()) shape_Z = B->get_shape();
172 else if (!B->is_scalar()) DOMAIN_ERROR;
173
174 Value_P Z1 = LO->eval_fill_AB(Fill_A, Fill_B).get_apl_val();
175
176 Value_P Z(shape_Z, LOC);
177 Z->get_ravel(0).init_from_value(Z1.get(), Z.getref(), LOC);
178 Z->check_value(LOC);
179 return Token(TOK_APL_VALUE1, Z);
180 }
181
182 const Shape low_A = A->get_shape().low_shape(rank_chunk_A);
183 const Shape low_B = B->get_shape().low_shape(rank_chunk_B);
184
185 Value_P vsh_A(LOC, &low_A);
186 Value_P vsh_B(LOC, &low_B);
187 Value_P vsh_Z(LOC, &shape_Z);
188
189 Value_P X7(7, LOC);
190 if (!X) new (X7->next_ravel()) IntCell(-1); // no X
191 else X7->next_ravel()->init_from_value(X.get(), X7.getref(), LOC);
192
193 new (X7->next_ravel()) IntCell(low_A.get_volume()); // LA
194
195 X7->next_ravel()->init_from_value(vsh_A.get(), X7.getref(), LOC);
196
197 new (X7->next_ravel()) IntCell(low_B.get_volume()); // LB
198
199 X7->next_ravel()->init_from_value(vsh_B.get(), X7.getref(), LOC);
200
201 new (X7->next_ravel()) IntCell(shape_Z.get_volume()); // N_max
202
203 X7->next_ravel()->init_from_value(vsh_Z.get(), X7.getref(), LOC);
204
205 X7->check_value(LOC);
206 return Macro::get_macro(Macro::MAC_Z__A_LO_RANK_X7_B)
207 ->eval_ALXB(A, _LO, X7, B);
208 }
209 //-----------------------------------------------------------------------------
210 void
y123_to_B(Value_P y123,Rank & rank_B)211 Bif_OPER2_RANK::y123_to_B(Value_P y123, Rank & rank_B)
212 {
213 // y123_to_AB() splits the ranks of A and B into a (higher-dimensions)
214 // "frame" and a (lower-dimensions) "chunk" as specified by y123.
215
216 // 1. on entry rank_B is the rank of B.
217 //
218 // Remember the rank of B to limit rank_B
219 // if values in y123 should exceed them.
220 //
221 const Rank rk_B = rank_B;
222
223 if (!y123) VALUE_ERROR;
224 if ( y123->get_rank() > 1) DOMAIN_ERROR;
225
226 // 2. the number of elements in y determine how rank_B shall be computed:
227 //
228 // -- monadic f⍤ -- -- dyadic f⍤ --
229 // rank_A rank_B rank_A rank_B
230 // ---------------------------------------------------------
231 // y : N/A y y y
232 // yA yB : N/A yB yA yB
233 // yM yA yB : N/A yM yA yB
234 // ---------------------------------------------------------
235
236 switch(y123->element_count())
237 {
238 case 1: rank_B = y123->get_ravel(0).get_near_int(); break;
239
240 case 2: y123->get_ravel(0).get_near_int();
241 rank_B = y123->get_ravel(1).get_near_int(); break;
242
243 case 3: rank_B = y123->get_ravel(0).get_near_int();
244 y123->get_ravel(1).get_near_int();
245 y123->get_ravel(2).get_near_int(); break;
246
247 default: LENGTH_ERROR;
248 }
249
250 // 3. adjust rank_B if they exceed its initial value or
251 // if it is negative
252 //
253 if (rank_B > rk_B) rank_B = rk_B;
254 if (rank_B < 0) rank_B += rk_B;
255 if (rank_B < 0) rank_B = 0;
256 }
257 //-----------------------------------------------------------------------------
258 void
y123_to_AB(Value_P y123,Rank & rank_A,Rank & rank_B)259 Bif_OPER2_RANK::y123_to_AB(Value_P y123, Rank & rank_A, Rank & rank_B)
260 {
261 // y123_to_AB() splits the ranks of A and B into a (higher-dimensions)
262 // "frame" and a (lower-dimensions) "chunk" as specified by y123.
263
264 // 1. on entry rank_A and rank_B are the ranks of A and B.
265 //
266 // Remember the ranks of A and B to limit rank_A and rank_B
267 // if values in y123 should exceed them.
268 //
269 const Rank rk_A = rank_A;
270 const Rank rk_B = rank_B;
271
272 if (!y123) VALUE_ERROR;
273 if ( y123->get_rank() > 1) DOMAIN_ERROR;
274
275 // 2. the number of elements in y determine how rank_A and rank_B
276 // shall be computed:
277 //
278 // -- monadic f⍤ -- -- dyadic f⍤ --
279 // rank_A rank_B rank_A rank_B
280 // ---------------------------------------------------------
281 // y : N/A y y y
282 // yA yB : N/A yB yA yB
283 // yM yA yB : N/A yM yA yB
284 // ---------------------------------------------------------
285
286 switch(y123->element_count())
287 {
288 case 1: rank_A = y123->get_ravel(0).get_near_int();
289 rank_B = rank_A; break;
290
291 case 2: rank_A = y123->get_ravel(0).get_near_int();
292 rank_B = y123->get_ravel(1).get_near_int(); break;
293
294 case 3: y123->get_ravel(0).get_near_int();
295 rank_A = y123->get_ravel(1).get_near_int();
296 rank_B = y123->get_ravel(2).get_near_int(); break;
297
298 default: LENGTH_ERROR;
299 }
300
301 // 3. adjust rank_A and rank_B if they exceed their initial value or
302 // if they are negative
303 //
304 if (rank_A > rk_A) rank_A = rk_A;
305 if (rank_A < 0) rank_A += rk_A;
306 if (rank_A < 0) rank_A = 0;
307
308 if (rank_B > rk_B) rank_B = rk_B;
309 if (rank_B < 0) rank_B += rk_B;
310 if (rank_B < 0) rank_B = 0;
311 }
312 //-----------------------------------------------------------------------------
313 void
split_y123_B(Value_P y123_B,Value_P & y123,Value_P & B)314 Bif_OPER2_RANK::split_y123_B(Value_P y123_B, Value_P & y123, Value_P & B)
315 {
316 // The ISO standard and NARS define the reduction pattern for the RANK
317 // operator ⍤ as:
318 //
319 // Z ← A f ⍤ y B (ISO)
320 // Z ← f ⍤ y B (ISO)
321 // Z ← A f ⍤ [X] y B (NARS)
322 // Z ← f ⍤ [X] y B (NARS)
323 //
324 // GNU APL may bind y to B at tokenization time if y and B are constants
325 // This function tries to "unbind" its argument y123_B into the original
326 // components y123 (= y in the standard) and B. The tokenization time
327 // binding is shown as y123:B
328 //
329 // Usage y123 : B Result: j123 B
330 //-------------------------------------------------------------------------
331 // 1. f ⍤ (y123):B... nested any y123 B
332 // 2. (f ⍤ y123:⍬) simple empty y123 -
333 // 3. f ⍤ y123:(B) simple nested skalar y123 B
334 // 4a. f ⍤ y123:B... simple any y123 B...
335 //
336
337 // y123_B shall be a scalar or vector
338 //
339 if (y123_B->get_rank() > 1) RANK_ERROR;
340
341 const ShapeItem length = y123_B->element_count();
342 if (length == 0) LENGTH_ERROR;
343
344 // check for case 1 (the only one with nested first element)
345 //
346 if (y123_B->get_ravel(0).is_pointer_cell()) // (y123)
347 {
348 y123 = y123_B->get_ravel(0).get_pointer_value();
349 if (length == 1) // empty B
350 {
351 }
352 else if (length == 2) // skalar B
353 {
354 const Cell & B0 = y123_B->get_ravel(1);
355 if (B0.is_pointer_cell()) // (B)
356 {
357 B = B0.get_pointer_value();
358 }
359 else
360 {
361 B = Value_P(LOC);
362 B->next_ravel()->init(B0, B.getref(), LOC);
363 }
364 }
365 else // vector B
366 {
367 B = Value_P(length - 1, LOC);
368 loop(l, length - 1)
369 B->next_ravel()->init(y123_B->get_ravel(l + 1),
370 B.getref(), LOC);
371 }
372 y123->check_value(LOC);
373 B->check_value(LOC);
374 return;
375 }
376
377 // case 1. ruled out, so the first 1, 2, or 3 cells are j123.
378 // see how many (at most)
379 //
380 int y123_len = 0;
381 loop(yy, 3)
382 {
383 if (yy >= length) break;
384 const Cell & cy = y123_B->get_ravel(yy);
385 if (cy.is_near_int()) ++y123_len;
386 else break;
387 }
388 if (y123_len == 0) LENGTH_ERROR; // at least y1 is needed
389
390 // cases 2.-4. start with integers of length 1, 2, or 3
391 //
392 if (length == y123_len) // case 2: y123:⍬
393 {
394 y123 = y123_B;
395 //
396 // NOTE: B is NOT assigned so that Prefix::reduce_F_D_B_() can detect
397 // that y123_ was only y123 !
398 //
399 return;
400 }
401
402 if (length == (y123_len + 1) &&
403 y123_B->get_ravel(y123_len).is_pointer_cell()) // case 3. y123:⊂B
404 {
405 y123 = Value_P(y123_len, LOC);
406 loop(yy, y123_len)
407 y123->next_ravel()->init(y123_B->get_ravel(yy), y123.getref(), LOC);
408 B = y123_B->get_ravel(y123_len).get_pointer_value();
409 y123->check_value(LOC);
410 B->check_value(LOC);
411 return;
412 }
413
414 // case 4: y123:B...
415 //
416 y123 = Value_P(y123_len, LOC);
417 loop(yy, y123_len)
418 y123->next_ravel()->init(y123_B->get_ravel(yy), y123.getref(), LOC);
419
420 const ShapeItem B_len = length - y123_len;
421 B = Value_P(B_len, LOC);
422 loop(bb, B_len)
423 B->next_ravel()->init(y123_B->get_ravel(bb + y123_len), B.getref(), LOC);
424 B->check_value(LOC);
425 }
426 //-----------------------------------------------------------------------------
427