projects / unix-history / blame
| Commit | Line | Data |
|---|---|---|
| 957bb13d BJ |
1 | #include "apl.h" |
| 2 | ||
| 3 | ex_iprod() | |
| 4 | { | |
| 5 | register i, j; | |
| 6 | struct item *p, *q, *r; | |
| 7 | int param[10], ipr1(); | |
| 8 | ||
| 9 | param[0] = exop[*pcp++]; | |
| 10 | param[1] = exop[*pcp++]; | |
| 11 | p = fetch2(); | |
| 12 | q = sp[-2]; | |
| 13 | if(p->type != DA || q->type != DA) | |
| 14 | error("iprod T"); | |
| 15 | bidx(p); | |
| 16 | idx.rank--; | |
| 17 | param[2] = idx.dim[idx.rank]; | |
| 18 | if(param[2] != q->dim[0]) | |
| 19 | error("inner prod C"); | |
| 20 | param[3] = q->size/param[2]; | |
| 21 | for(i=1; i<q->rank; i++) | |
| 22 | idx.dim[idx.rank++] = q->dim[i]; | |
| 23 | r = newdat(DA, idx.rank, size()); | |
| 24 | copy(IN, idx.dim, r->dim, idx.rank); | |
| 25 | param[4] = 0; | |
| 26 | param[5] = 0; | |
| 27 | param[6] = p->datap; | |
| 28 | param[7] = q->datap; | |
| 29 | param[8] = r->datap; | |
| 30 | param[9] = p->size; | |
| 31 | forloop(ipr1, param); | |
| 32 | pop(); | |
| 33 | pop(); | |
| 34 | push(r); | |
| 35 | } | |
| 36 | ||
| 37 | ipr1(param) | |
| 38 | int param[]; | |
| 39 | { | |
| 40 | register i, dk; | |
| 41 | int lk, a, b; | |
| 42 | data *dp1, *dp2, *dp3; | |
| 43 | data (*f1)(), (*f2)(), d; | |
| 44 | ||
| 45 | f1 = param[0]; | |
| 46 | f2 = param[1]; | |
| 47 | dk = param[2]; | |
| 48 | lk = param[3]; | |
| 49 | a = param[4]; | |
| 50 | b = param[5]; | |
| 51 | dp1 = param[6]; | |
| 52 | dp2 = param[7]; | |
| 53 | dp3 = param[8]; | |
| 54 | a =+ dk; | |
| 55 | b =+ (dk * lk); | |
| 56 | for(i=0; i<dk; i++) { | |
| 57 | a--; | |
| 58 | b =- lk; | |
| 59 | d = (*f2)(dp1[a], dp2[b]); | |
| 60 | if(i == 0) | |
| 61 | datum = d; else | |
| 62 | datum = (*f1)(d, datum); | |
| 63 | } | |
| 64 | *dp3++ = datum; | |
| 65 | param[8] = dp3; | |
| 66 | param[5]++; | |
| 67 | if(param[5] >= lk) { | |
| 68 | param[5] = 0; | |
| 69 | param[4] =+ dk; | |
| 70 | if(param[4] >= param[9]) | |
| 71 | param[4] = 0; | |
| 72 | } | |
| 73 | } | |
| 74 | ||
| 75 | ex_oprod() | |
| 76 | { | |
| 77 | register i, j; | |
| 78 | register data *dp; | |
| 79 | struct item *p, *q, *r; | |
| 80 | data *dp1, *dp2; | |
| 81 | data (*f)(); | |
| 82 | ||
| 83 | f = exop[*pcp++]; | |
| 84 | p = fetch2(); | |
| 85 | q = sp[-2]; | |
| 86 | if(p->type != DA || q->type != DA) | |
| 87 | error("oprod T"); | |
| 88 | bidx(p); | |
| 89 | for(i=0; i<q->rank; i++) | |
| 90 | idx.dim[idx.rank++] = q->dim[i]; | |
| 91 | r = newdat(DA, idx.rank, size()); | |
| 92 | copy(IN, idx.dim, r->dim, idx.rank); | |
| 93 | dp = r->datap; | |
| 94 | dp1 = p->datap; | |
| 95 | for(i=0; i<p->size; i++) { | |
| 96 | datum = *dp1++; | |
| 97 | dp2 = q->datap; | |
| 98 | for(j=0; j<q->size; j++) | |
| 99 | *dp++ = (*f)(datum, *dp2++); | |
| 100 | } | |
| 101 | pop(); | |
| 102 | pop(); | |
| 103 | push(r); | |
| 104 | } |