| 1 | #include "apl.h" |
| 2 | |
| 3 | ex_red0() |
| 4 | { |
| 5 | |
| 6 | fetch1(); |
| 7 | red0(0); |
| 8 | } |
| 9 | |
| 10 | ex_red() |
| 11 | { |
| 12 | register struct item *p; |
| 13 | |
| 14 | p = fetch1(); |
| 15 | red0(p->rank-1); |
| 16 | } |
| 17 | |
| 18 | ex_redk() |
| 19 | { |
| 20 | register i; |
| 21 | |
| 22 | i = topfix() - thread.iorg; |
| 23 | fetch1(); |
| 24 | red0(i); |
| 25 | } |
| 26 | |
| 27 | red0(k) |
| 28 | { |
| 29 | register struct item *p, *q; |
| 30 | int param[3], red1(); |
| 31 | |
| 32 | p = fetch1(); |
| 33 | if(p->type != DA) |
| 34 | error("red T"); |
| 35 | bidx(p); |
| 36 | colapse(k); |
| 37 | if(idx.dimk == 0) { |
| 38 | /* |
| 39 | * reduction identities - ets/jrl 5/76 |
| 40 | */ |
| 41 | q = newdat(DA,0,1); |
| 42 | q->dim[0] = 1; |
| 43 | switch(*pcp++) { |
| 44 | case ADD: |
| 45 | case SUB: |
| 46 | case OR: |
| 47 | q->datap[0] = 0; |
| 48 | break; |
| 49 | case AND: |
| 50 | case MUL: |
| 51 | case DIV: |
| 52 | q->datap[0] = 1; |
| 53 | break; |
| 54 | case MIN: |
| 55 | q->datap[0] = 1.0e38; |
| 56 | break; |
| 57 | case MAX: |
| 58 | q->datap[0] = -1.0e38; |
| 59 | break; |
| 60 | default: |
| 61 | error("reduce identity"); |
| 62 | } |
| 63 | pop(); |
| 64 | push(q); |
| 65 | return; |
| 66 | } |
| 67 | q = newdat(idx.type, idx.rank, idx.size); |
| 68 | copy(IN, idx.dim, q->dim, idx.rank); |
| 69 | param[0] = p->datap; |
| 70 | param[1] = q; |
| 71 | param[2] = exop[*pcp++]; |
| 72 | forloop(red1, param); |
| 73 | pop(); |
| 74 | push(q); |
| 75 | } |
| 76 | |
| 77 | red1(param) |
| 78 | int param[]; |
| 79 | { |
| 80 | register i; |
| 81 | register data *dp; |
| 82 | data d, (*f)(); |
| 83 | |
| 84 | dp = param[0]; |
| 85 | dp =+ access() + (idx.dimk-1) * idx.delk; |
| 86 | f = param[2]; |
| 87 | d = *dp; |
| 88 | for(i=1; i<idx.dimk; i++) { |
| 89 | dp =- idx.delk; |
| 90 | d = (*f)(*dp, d); |
| 91 | } |
| 92 | putdat(param[1], d); |
| 93 | } |