1 /*
2 * $Id: array.c,v 1.2 2005-11-13 21:01:56 dhmunro Exp $
3 */
4 /* Copyright (c) 2005, The Regents of the University of California.
5 * All rights reserved.
6 * This file is part of yorick (http://yorick.sourceforge.net).
7 * Read the accompanying LICENSE file for details.
8 */
9
10 /*
11 Implement Yorick array indexing. This is one half of the Yorick
12 Eval instruction -- the other half of Eval is function invocation,
13 which is handled in fnctn.c. An expression of the form:
14 expr(index_list)
15 where index_list is a comma delimited list of indices, is an indexed
16 array if expr is any array data type (or a function invocation if
17 expr is any function data type). The following index types are
18 handled here:
19
20 (1) nil - the corresponding dimension is copied to the result
21 (2) any integer scalar - reduces the rank of the result
22 (3) any integer array - replaces the corresponding dimension by
23 (index list) a copy of the index list dimensions
24 (4) start:stop:step - replaces the corresponding dimension by
25 (range) a 0-origin dimension 1+(stop-start)/step
26 (5) rf:start:stop:step - as (4), but the specified range function
27 is applied after gathering the result
28 (6) - or -:start:stop:step - "pseudo index" adds a dimension to
29 the result not in the original array
30 (7) + or +:start:stop:step - "marked index" is a special form for
31 matrix multiplication, pushes the
32 result index number onto the stack
33 (8) .. - "rubber index" causes any subsequent indices to be right
34 justified, copying as many dimensions to the result as
35 required in order to do this
36 (9) where(0) - "nuller index" causes result to be nil, a special
37 case of the index list for a zero length list
38
39 Index values may fall into 3 ranges. For a 0-origin dimension of
40 length n, these ranges are:
41 (A) wrap around [-n, -1], which are mapped to [0, n-1] by adding n.
42 (B) ordinary [0, n-1]
43 (C) overreach [n, infinity], which effectively specify offsets in
44 subsequent dimensions. No index may overreach beyond the
45 end of the entire array.
46 All 3 ranges are supported for Range indices and scalar indices, but
47 wrap around indexing is not supported for index lists.
48
49 Note that a Range index or a rank-preserving range function (see
50 range.c) always produces a 0-origin dimension in the result.
51 A nil index or rubber index produces result dimension(s) with the
52 same origin as the input array, and an index list produces result
53 dimensions with origins copied from the index list dimensions.
54 */
55
56 #include "ydata.h"
57
58 extern VMaction Eval2;
59 extern UnaryOp EvalAY, EvalLV;
60
61 extern Operand *FormOperandDB(Symbol *owner, Operand *op);
62
63 #define MAX_INDICES (Y_DIMSIZE-1)
64
65 /*
66 For several types of DataBlock, the Eval operation means to index
67 into an array. This operation proceeds in several steps:
68
69 1. ArrayDims
70 Count the dummy indices, accumulating the corresponding strides.
71 The result of this operation is the static values:
72 nDummy - number of dimensions in dummy dimension list
73 dims[] - Dimension* for each dimension
74
75 2. EvalSetup
76 Scan through the actual indices to set:
77 overreach - 1 if any actual index beyond range of
78 corresponding dummy index
79 overOrigin - maximum origin of current actual index due to
80 overreach from previous actual indices
81 offsets[] - offset from beginning for each actual index
82 for rubber index, number of actual indices after,
83 for index list, -origin (so index values correct)
84 numbers[] - number of elements for each actual index
85 steps[] - index increments for each actual index
86 rangeFlags[] - range->nilFlags for each actual index
87 indexLists[] - index list for each actual index
88 Builder[] - function to build result is one of
89 BuildScalar - long scalar (offsets)
90 BuildList - long array (offsets, indexLists)
91 BuildRange - min:max:inc or rf:min:max:inc
92 (offsets, numbers, steps, rangeFlags)
93 The arrays actually used by each Builder are shown in
94 parentheses. BuildRange also uses strides from step 1.
95
96 rsltIndex - index in result array for current actual index
97 nRF - number of range functions encountered
98 rfs[] - nRF range function pointers
99 rfIndices[] - index in result array for each range function
100 markedIndex - index in result array for marked index, or -1
101
102 tmpDims - Dimension list for result Array or LValue
103
104 After all actual indices have been processed, EvalSetup checks
105 for any overreach errors.
106
107 3. ArrayStrides (called from BuildResult) or LValueStrides
108 Compute the stride associated with each dummy index
109 strides[] - stride (in bytes) for each dimension
110
111 4. loop on BuildScalar, BuildList, BuildRange (from BuildResult or EvalLV)
112 Process the indices from fastest to slowest varying. The resulting
113 LValue is built on the top of the stack by successive calls to the
114 Builder routines set in step 2.
115
116 5. DoRangeFuncs (called from BuildResult)
117 Apply any range functions. If the LValue produced in (3) is
118 disk data, it is gathered before further processing.
119
120 6. (end of BuildResult)
121 Push number of marked index onto stack after result, if any.
122 This is a special form used by the matrix multiply routines.
123 */
124
125 extern void FormEvalOp(int nArgs, Operand *obj);
126 extern DataBlock *ForceToDB(Symbol *s);
127
128 static int EvalSetup(Symbol *stack, int n);
129 static void SetupScalar(long index);
130 static void DotdotScan(Symbol *stack, int singleIndex);
131 static void ArrayDims(Dimension *adims);
132 static void ArrayStrides(long stride);
133 static int LValueStrides(Strider *strider);
134 static void DoRangeFuncs(Array *array);
135 static void BuildResult(char *mem, StructDef *base,
136 Array *array, Symbol *stack, int n);
137
138 /*--------------------------------------------------------------------------*/
139
140 /* current dummy and actual indices */
141 static int iDummy, iActual;
142
143 /* Characteristics of dummy indices (MAX_INDICES==nDummy) */
144 static int nDummy;
145 static Dimension *dims[MAX_INDICES]; /* dummy dimensions, fastest 1st */
146 static long strides[MAX_INDICES]; /* strides for dummy dimensions */
147
148 /* Characteristics of actual indices (MAX_INDICES==nActual) */
149 static int overreach;
150 static long overOrigin; /* maximum origin if overreach */
151 static long offsets[MAX_INDICES]; /* offsets for actual indices
152 used by scalars, ranges -- also
153 index count for rubber index */
154 static long numbers[MAX_INDICES]; /* numbers for actual indices */
155 static long steps[MAX_INDICES]; /* ::steps for actual indices */
156 static int rangeFlags[MAX_INDICES]; /* nilFlags for actual indices */
157 static Array *indexLists[MAX_INDICES]; /* index lists for actual indices */
158 static long (*Builder[MAX_INDICES])(LValue *);
159 /* routine to build result */
160
161 /* Characteristics of result */
162 static int rsltIndex, markedIndex, nRF, iRubber;
163 /* in following arrays (MAX_INDICES==nRF) */
164 static RangeFunc *rfs[MAX_INDICES]; /* range functions */
165 static int rfIndices[MAX_INDICES]; /* index # for rfs */
166
167 /* possible functions for Builder */
168 static long BuildScalar(LValue *result);
169 static long BuildList(LValue *result);
170 static long BuildRange(LValue *result);
171
172 /* set up function tables for initializing Builder and bParam arrays */
173
174 extern UnaryOp SetupC, SetupS, SetupI, SetupL, SetupX, SetupR, SetupVD;
175 extern UnaryOp ToLongC, ToLongS, ToLongI;
176
177 /*--------------------------------------------------------------------------*/
178
EvalSetup(Symbol * stack,int n)179 static int EvalSetup(Symbol *stack, int n)
180 {
181 Operand index;
182 Dimension *tmp= tmpDims;
183 if (n>MAX_INDICES) YError("too many array indices");
184
185 /* Note: There is no point in freeing tmpDims until here, where it
186 is needed again. Until now, tmpDims is simply an extra reference
187 to the Dimension* created in the previous Eval operation. The
188 amount of storage associated with tmpDims is miniscule, so even
189 if this is the last remaining reference, the fact that it wasn't
190 freed as soon as possible is unimportant. */
191 tmpDims= 0;
192 FreeDimension(tmp);
193
194 overreach= rsltIndex= nRF= 0;
195 markedIndex= iRubber= -1;
196 overOrigin= 0;
197
198 /* sort through all of the actual indices, setting up Builder routines */
199 iDummy= 0;
200 for (iActual=0 ; iActual<n ; iActual++) {
201 stack++;
202 if (!stack->ops) YError("array index cannot be keyword");
203 stack->ops->FormOperand(stack, &index);
204 index.ops->Setup(&index);
205 if (iDummy<0) { /* nullifier, e.g.- where(0) */
206 Drop(n+1);
207 PushDataBlock(RefNC(&nilDB));
208 return 1;
209 }
210 }
211 if (iDummy<nDummy && n>0) {
212 if (index.ops==&voidOps) {
213 /* pick up all remaining dummy indices, just as if final index
214 had been .. instead of nil */
215 long number= numbers[--iActual];
216 long na= offsets[iActual];
217 DotdotScan(stack, 0);
218 rangeFlags[iActual]|= R_RUBBER;
219 numbers[iActual]*= number;
220 offsets[iActual++]+= na;
221 } /* else, should check that there wasn't a nil index followed by
222 one or more pseudo index -- however, this error is rather
223 expensive to detect, and I'm omitting the check for now. */
224 }
225
226 /* make sure any references beyond index bounds are kosher */
227 if (overOrigin) {
228 while (overOrigin && iDummy<nDummy) overOrigin/= dims[iDummy++]->number;
229 if (overOrigin) YError("index overreach beyond array bounds");
230 }
231
232 return 0;
233 }
234
235 /*--------------------------------------------------------------------------*/
236 /* Three distinct DataBlock types for Index operation:
237 longType, rangeType, and voidType.
238 char, short, and int also legal, as is LValue.
239 These routines set up the LValue Builder routines. */
240
SetupScalar(long index)241 static void SetupScalar(long index)
242 {
243 long number;
244 if (iDummy<nDummy) {
245 number= dims[iDummy]->number;
246 index-= yForceOrigin? 1L : dims[iDummy]->origin;
247 } else {
248 number= 1;
249 index-= 1L;
250 }
251
252 if (index<0 && (index+=number)<0) { /* notice behavior when index<0 */
253 YError("array index is too small");
254 } else if (index+overOrigin>=number) {
255 overreach= 1;
256 overOrigin+= index;
257 }
258 if (overOrigin) overOrigin/= number; /* origin for next index */
259
260 Builder[iActual]= &BuildScalar;
261 offsets[iActual]= index;
262
263 iDummy++;
264 }
265
SetupL(Operand * op)266 void SetupL(Operand *op)
267 {
268 /* Scalar is simple index, dimensioned array is index list */
269 if (!op->type.dims) {
270 SetupScalar(((long *)op->value)[0]);
271 return;
272
273 } else { /* index list */
274 long i, n= op->type.number;
275 long *il= op->value;
276 long ilMin, ilMax;
277 long number= dims[iDummy]->number;
278 long origin= yForceOrigin? 1L : dims[iDummy]->origin;
279
280 if (iDummy>=nDummy) YError("index list beyond final array index");
281
282 Builder[iActual]= &BuildList;
283 /* Since dims is non-0, we know that the op->owner is a dataBlockSym
284 which points to an Array (any LValue has been fetched). */
285 indexLists[iActual]= (Array *)op->owner->value.db;
286 if (indexLists[iActual]->ops==&lvalueOps) {
287 indexLists[iActual]= FetchLValue(indexLists[iActual], op->owner);
288 il= indexLists[iActual]->value.l;
289 }
290 offsets[iActual]= -origin; /* compensate for non-0 origin */
291 iDummy++;
292
293 /* find minimum and maximum index list values */
294 ilMin= ilMax= il[0];
295 for (i=1 ; i<n ; i++) {
296 if (ilMin > il[i]) ilMin= il[i];
297 else if (ilMax < il[i]) ilMax= il[i];
298 }
299 if (ilMin<origin) {
300 YError("minimum array index in index list is too small");
301 } else if (ilMax-origin+overOrigin>=number) {
302 overreach= 1;
303 overOrigin+= ilMax-origin;
304 }
305 if (overOrigin) overOrigin/= number;
306
307 /* copy dimension list from index list to tmpDims (copy origins) */
308 if (tmpDims) tmpDims= CopyDims(op->type.dims, tmpDims, 1);
309 else tmpDims= Ref(op->type.dims);
310
311 /* increment count of result indices */
312 rsltIndex+= CountDims(op->type.dims);
313 return;
314 }
315 }
316
SetupR(Operand * op)317 void SetupR(Operand *op)
318 {
319 /* Range functions specify several cases:
320 -: this is not an actual index
321 ..: expand to fill remaining indices
322 +: mark this index */
323 Range *range= op->value;
324 int nilFlags= range->nilFlags;
325 long offset, origin, number, step, largest, n;
326
327 /* Return iDummy==-1 to force void result before any Builders called. */
328 if (nilFlags & R_NULLER) { iDummy= -1; return; }
329
330 Builder[iActual]= &BuildRange;
331 rangeFlags[iActual]= nilFlags;
332
333 if (nilFlags & R_RUBBER) {
334 DotdotScan(op->owner, nilFlags&R_PSEUDO);
335 return;
336 }
337
338 /* set origin and n for dummy index corresponding to this actual index */
339 step= range->inc;
340 if (nilFlags & R_PSEUDO) {
341 origin= step>0? range->min : range->max;
342 n= 1;
343 /* iDummy NOT incremented on this branch */
344 } else {
345 if (iDummy>=nDummy) YError("index range beyond final array index");
346 origin= yForceOrigin? 1L : dims[iDummy]->origin;
347 n= dims[iDummy]->number;
348 if (nilFlags & R_MARKED) markedIndex= rsltIndex;
349 iDummy++;
350 }
351
352 /* get min:max:inc and compensate for dummy origin */
353 if (nilFlags&R_MINNIL) offset= step>0? 0 : n-1;
354 else offset= range->min - origin;
355 if (nilFlags&R_MAXNIL) number= step>0? n-1 : 0;
356 else number= range->max - origin;
357
358 /* perform negative index wrap around if necessary */
359 if (offset<0 && (offset+=n)<0) {
360 YError("array index range start is too small");
361 } else if (number<0 && (number+=n)<0) {
362 YError("array index range stop is too small");
363 }
364
365 /* compute the number of footprints (#strides+1) */
366 if (step>=0 && number>=offset) {
367 if (step>1) {
368 largest= (number-offset)/step;
369 number= largest+1;
370 largest= offset + largest*step;
371 } else {
372 largest= number;
373 number= number-offset+1;
374 }
375 } else if (step<0 && offset>=number) {
376 if (step<-1) number= (offset-number)/(-step) + 1;
377 else number= offset-number + 1;
378 largest= offset;
379 } else {
380 YError("array index range step has wrong sign");
381 largest= 0;
382 }
383
384 /* detect and handle overreach */
385 if (largest+overOrigin>=n && (nilFlags&R_PSEUDO)==0) {
386 overreach= 1;
387 overOrigin+= largest;
388 }
389 if (overOrigin) overOrigin/= n;
390
391 offsets[iActual]= offset;
392 numbers[iActual]= number;
393 steps[iActual]= step;
394
395 tmpDims= NewDimension(number, 1L, tmpDims); /* default origin */
396
397 if (range->rf) {
398 rfs[nRF]= range->rf;
399 rfIndices[nRF++]= rsltIndex;
400 }
401 rsltIndex++;
402 }
403
DotdotScan(Symbol * stack,int singleIndex)404 static void DotdotScan(Symbol *stack, int singleIndex)
405 {
406 /* Scan through remaining actual indices to see how many dummy
407 indices to skip. We only need to detect pseudo-indices, since
408 these are the only type which break the one-one correspondence
409 between actual and dummy indices. */
410 int na= 0; /* # remaining non-pseudo actuals */
411 long number, n;
412
413 while (stack<sp) {
414 stack++;
415 if (stack->ops==&referenceSym) ReplaceRef(stack);
416 if (stack->ops!=&dataBlockSym || stack->value.db->ops!=&rangeOps) {
417 na++;
418 } else {
419 int nilFlags= ((Range *)stack->value.db)->nilFlags;
420 if (nilFlags & R_RUBBER)
421 YError("multiple rubber (.. or *) indices in one index list");
422 if ((nilFlags & R_PSEUDO)==0) na++;
423 }
424 }
425
426 if (singleIndex && (iDummy<nDummy-na-1)) iRubber= iActual;
427 offsets[iActual]= na; /* offset is actually 0, intentionally
428 misused here and in BuildRange */
429 number= 1;
430 while (iDummy < nDummy-na) {
431 n= dims[iDummy]->number;
432 if (overOrigin) overOrigin= (overOrigin+n-1)/n;
433 number*= n;
434 /* copy origin here */
435 if (!singleIndex)
436 tmpDims= NewDimension(n, dims[iDummy]->origin, tmpDims);
437 rsltIndex++;
438 iDummy++;
439 }
440 if (singleIndex) tmpDims= NewDimension(number, 1L, tmpDims);
441 numbers[iActual]= number;
442 steps[iActual]= 1;
443 return;
444 }
445
SetupC(Operand * op)446 void SetupC(Operand *op)
447 {
448 if (!op->type.dims) {
449 SetupScalar((long)((char *)op->value)[0]);
450 } else {
451 ToLongC(op);
452 SetupL(FormOperandDB(op->owner, op));
453 }
454 }
455
SetupS(Operand * op)456 void SetupS(Operand *op)
457 {
458 if (!op->type.dims) {
459 SetupScalar((long)((short *)op->value)[0]);
460 } else {
461 ToLongS(op);
462 SetupL(FormOperandDB(op->owner, op));
463 }
464 }
465
SetupI(Operand * op)466 void SetupI(Operand *op)
467 {
468 if (!op->type.dims) {
469 SetupScalar((long)((int *)op->value)[0]);
470 } else {
471 ToLongI(op);
472 SetupL(FormOperandDB(op->owner, op));
473 }
474 }
475
476 /* ARGSUSED */
SetupVD(Operand * op)477 void SetupVD(Operand *op)
478 {
479 long n= iDummy<nDummy? dims[iDummy]->number : 1L;
480 Builder[iActual]= &BuildRange;
481 rangeFlags[iActual]= 0;
482 offsets[iActual]= 0;
483 numbers[iActual]= n;
484 steps[iActual]= 1;
485 if (overOrigin) overOrigin= (overOrigin+n-1)/n;
486 if (iDummy<nDummy) {
487 tmpDims= NewDimension(n, dims[iDummy]->origin, tmpDims);
488 rsltIndex++;
489 }
490 iDummy++;
491 }
492
493 /* ARGSUSED */
SetupX(Operand * op)494 void SetupX(Operand *op)
495 {
496 YError("bad data type for array index");
497 }
498
499 /*--------------------------------------------------------------------------*/
500 /* ArrayDims initializes dims[] and nDummy, ArrayStrides and LValueStrides
501 initialize strides[]. */
502
ArrayDims(Dimension * adims)503 static void ArrayDims(Dimension *adims)
504 { /* ArrayDims(lvalue->type.dims); */
505 if (!adims) { /* halt recursion */
506 nDummy= 0;
507 return;
508 }
509 ArrayDims(adims->next); /* recurse */
510 if (nDummy>=MAX_INDICES) YError("too many array dimensions");
511 dims[nDummy++]= adims;
512 }
513
ArrayStrides(long stride)514 static void ArrayStrides(long stride)
515 { /* ArrayDims(array->type.dims); ArrayStrides(array->type.base->size); */
516 int i;
517 for (i=0 ; i<nDummy ; i++) {
518 strides[i]= stride;
519 stride*= dims[i]->number;
520 }
521 }
522
LValueStrides(Strider * strider)523 static int LValueStrides(Strider *strider)
524 { /* ArrayDims(lvalue->type.dims); LValueStrides(lvalue->strider); */
525 int iDummy;
526 if (!strider) { /* halt recursion */
527 iDummy= 0;
528
529 } else {
530 long n, number= strider->number;
531 long stride= strider->stride;
532
533 iDummy= LValueStrides(strider->next); /* recurse */
534 if (iDummy<0 || strider->indexList) return -1;
535
536 if (iDummy<nDummy) {
537 strides[iDummy]= stride;
538 n= dims[iDummy++]->number;
539 while (n<number) {
540 strides[iDummy]= stride*n;
541 n*= dims[iDummy++]->number;
542 }
543 }
544 }
545 return iDummy;
546 }
547
548 /*--------------------------------------------------------------------------*/
549 /* The Builder routines actually build up the result LValue. */
550
BuildScalar(LValue * result)551 static long BuildScalar(LValue *result)
552 {
553 long offset= offsets[iActual] * strides[iDummy];
554 iDummy++;
555 return offset;
556 }
557
BuildRange(LValue * result)558 static long BuildRange(LValue *result)
559 {
560 int nilFlags= rangeFlags[iActual];
561 long offset, stride, number= numbers[iActual];
562
563 /* Compute appropriate stride, offset, and increment iDummy */
564 if (nilFlags&R_RUBBER) { /* this is .. index (right justify remaining) */
565 int na= offsets[iActual]; /* # remaining non-pseudo actuals */
566 if (iDummy >= nDummy-na) return 0;
567 if (number>1 && (iDummy<nDummy-na-1) && !(nilFlags&R_PSEUDO)) {
568 /* a .. rubber index may need several striders */
569 Strider *strider= result->strider;
570 long n= 1, total= number;
571 for (; iDummy<nDummy-na ; iDummy++) {
572 if (n<total) {
573 stride= strides[iDummy];
574 number= dims[iDummy]->number;
575 if (number>1) { /* (See comments below.) */
576 if (strider) {
577 if (!strider->indexList &&
578 strider->stride*strider->number == stride) {
579 strider->number*= number;
580 } else {
581 result->strider= NewStrider(stride, number);
582 result->strider->next= strider;
583 strider= result->strider;
584 }
585 } else {
586 result->strider= strider= NewStrider(stride, number);
587 }
588 n*= number;
589 }
590 }
591 }
592 return 0;
593
594 } else {
595 stride= strides[iDummy]; /* steps[iActual] always 1 */
596 offset= 0;
597 iDummy= nDummy-na;
598 }
599
600 } else {
601 if (nilFlags&R_PSEUDO) { /* this is - index (insert new dimension) */
602 stride= offset= 0;
603
604 } else { /* this is ordinary rf:min:max:inc */
605 stride= steps[iActual] * strides[iDummy];
606 offset= offsets[iActual] * strides[iDummy];
607 iDummy++;
608 }
609 }
610
611 /* Add or append to result->strider */
612 if (number>1) {
613 if (result->strider) {
614 Strider *strider= result->strider;
615 if (!strider->indexList &&
616 strider->stride*strider->number == stride) {
617 /* If the current strider is not an index list, and its total
618 span (stride*number) is the same as the current stride, then
619 we can simply increment its number to include the current
620 dimension. */
621 strider->number*= number;
622 } else {
623 /* Otherwise, we need a new strider. */
624 result->strider= NewStrider(stride, number);
625 result->strider->next= strider;
626 }
627
628 } else {
629 result->strider= NewStrider(stride, number);
630 }
631 }
632
633 return offset;
634 }
635
BuildList(LValue * result)636 static long BuildList(LValue *result)
637 {
638 Array *array= indexLists[iActual];
639 long offset= offsets[iActual] * strides[iDummy];
640 Strider *newStrider, *strider= result->strider;
641
642 /* Add index list strider to result->strider */
643 newStrider=
644 result->strider= NewStrider(strides[iDummy], array->type.number);
645 newStrider->next= strider;
646 newStrider->indexList= Ref(array);
647
648 iDummy++;
649 return offset;
650 }
651
652 /*--------------------------------------------------------------------------*/
653
DoRangeFuncs(Array * array)654 static void DoRangeFuncs(Array *array)
655 {
656 /* Range functions are performed in left-to-right order, that is,
657 from the fastest varying index to the slowest. */
658 int i, j;
659 for (i=0 ; i<nRF ; i++) {
660 if (rfs[i](array, rfIndices[i])) {
661 /* This was a rank reducing operation, adjust the index numbering
662 for any remaining range functions. */
663 for (j=i+1 ; j<nRF ; j++) rfIndices[j]--;
664 /* Note: parser responsible for ensuring that range->rf==0
665 whenever range->nilFlags&R_MARKED */
666 if (markedIndex>i) markedIndex--;
667 }
668 /* range function left result on top of stack */
669 sp--;
670 sp->value= (sp+1)->value;
671 sp->ops= (sp+1)->ops;
672 Unref(array);
673 array= (Array *)sp->value.db;
674 }
675 }
676
BuildResult(char * mem,StructDef * base,Array * array,Symbol * stack,int n)677 static void BuildResult(char *mem, StructDef *base,
678 Array *array, Symbol *stack, int n)
679 {
680 LValue *result= PushDataBlock(NewLValueM(array, mem, base, tmpDims));
681
682 /* build an appropriate LValue on top of stack */
683 ArrayStrides(base->size);
684 iDummy= 0;
685 for (iActual=0 ; iActual<n ; iActual++) mem+= Builder[iActual](result);
686 result->address.m= mem;
687
688 /* swap result LValue with array on stack */
689 PopTo(stack); /* note that result owns use of array */
690
691 /* discard actual indices */
692 Drop(n);
693
694 /* If range functions were specified, do them now.
695 If the original array is a temporary, or if an index is marked,
696 may as well fetch the result LValue now, and leave an Array on
697 the stack instead. Non-temporaries should be left as they are,
698 since they might be destined for further indexing. */
699 if (nRF)
700 DoRangeFuncs(FetchLValue(result, stack));
701 else if (array->references==0 || markedIndex>=0)
702 FetchLValue(result, stack);
703 }
704
705 /*--------------------------------------------------------------------------*/
706
FormEvalOp(int nArgs,Operand * obj)707 void FormEvalOp(int nArgs, Operand *obj)
708 {
709 Symbol *s= sp-nArgs;
710 DataBlock *db= (s->ops==&dataBlockSym)? s->value.db : ForceToDB(s);
711 obj->owner= s;
712 obj->references= nArgs; /* intentionally misused */
713 obj->ops= db->ops;
714 obj->value= db;
715 }
716
Eval2(void)717 void Eval2(void)
718 {
719 int nArgs= (pc++)->count;
720 Operand obj;
721 FormEvalOp(nArgs, &obj);
722
723 /* guard against x(+)*y(+) where x or y is a function */
724 if (!obj.ops->isArray && obj.ops!=&lvalueOps)
725 YError("matrix multiply index marker (+) not in array index list");
726
727 obj.ops->Eval(&obj);
728 /* One index MUST be marked; Eval2 leaves 2 elements on the top of the
729 stack-- the Array, and an intScalar to tell which index is marked.
730 The parser guarantees that markedIndex>0 here, but only here. */
731 PushIntValue(markedIndex);
732 }
733
EvalAY(Operand * op)734 void EvalAY(Operand *op)
735 {
736 Symbol *stack= op->owner;
737 int nArgs= op->references; /* interpret misuse in FormEvalOp */
738 Array *array= op->value;
739
740 /* initialize nDummy, dims, strides */
741 ArrayDims(array->type.dims);
742
743 /* initialize Builder, offsets, numbers, steps, indexLists, rfs, nRF */
744 if (EvalSetup(stack, nArgs)) return; /* nullifier index */
745
746 BuildResult(array->value.c, array->type.base, array, stack, nArgs);
747 }
748
EvalLV(Operand * op)749 void EvalLV(Operand *op)
750 {
751 Symbol *stack= op->owner;
752 int nArgs= op->references; /* interpret misuse in FormEvalOp */
753 LValue *lvalue= op->value;
754 Strider *strider= lvalue->strider;
755 StructDef *base= lvalue->type.base;
756 int addressType= base->addressType;
757
758 /* initialize nDummy, dims */
759 ArrayDims(lvalue->type.dims);
760
761 /* initialize Builder, offsets, numbers, steps, indexLists, rfs, nRF */
762 if (EvalSetup(stack, nArgs)) return; /* nullifier index */
763
764 if (nRF || markedIndex>=0 || (overreach&&strider) ||
765 LValueStrides(strider)<0 || addressType>1 || iRubber>=0) {
766 /* Must gather the original LValue into a compact Array if any of
767 the following conditions are met:
768 (1) The actual indices include range functions (the range
769 function will need the data immediately).
770 (2) There is a marked index (the matrix multiply operation
771 will need the data)
772 (3) Any actual index overreached its corresponding dummy index,
773 and the LValue has strides (the overreached elements will
774 not be at the expected address)
775 (4) The original LValue includes an index list (some of the
776 actual indices may require extracting a subset of the index
777 list, rather than a subset of the data array)
778 (5) The original LValue references a sequential object in a
779 disk file.
780 (6) A rubber * index contracts two or more dimensions into one
781 As soon as one of these conditions is met, gather the LValue and
782 proceed as for an Array. */
783 Array *dst= FetchLValue(lvalue, stack);
784
785 /* The new Array is guaranteed to have simple strides, but nDummy,
786 dims, Builder, numbers, offsets, steps, etc. have not changed. */
787 BuildResult(dst->value.c, dst->type.base, dst, stack, nArgs);
788
789 } else {
790 /* The input LValue is described by a simple hierarchy of strides.
791 The data itself need never be touched to build the result LValue. */
792 long totalOffset;
793 LValue *result;
794
795 result= PushDataBlock(addressType?
796 NewLValueD(lvalue->address.d, base, tmpDims) :
797 NewLValueM(lvalue->owner, lvalue->address.m,
798 base, tmpDims));
799
800 if (!strider) ArrayStrides(base->size);
801 /* build an appropriate LValue on top of stack */
802 totalOffset= 0;
803 iDummy= 0;
804 for (iActual=0 ; iActual<nArgs ; iActual++)
805 totalOffset+= Builder[iActual](result);
806 if (addressType) result->address.d+= totalOffset;
807 else result->address.m+= totalOffset;
808
809 /* swap result LValue with array on stack */
810 PopTo(stack);
811
812 /* discard actual indices, leaving result on top of stack */
813 Drop(nArgs);
814 }
815 }
816
817 /*--------------------------------------------------------------------------*/
818