1 /*
2 * Copyright (c) 1995-2018, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /* clang-format off */
19
20 #include "stdioInterf.h"
21 #include "fioMacros.h"
22 #include "type.h"
23 /* transfer intrinsic */
24
I8(next_index)25 static int I8(next_index)(__INT_T *index, F90_Desc *s)
26 {
27 __INT_T i;
28
29 for (i = 0; i < F90_RANK_G(s); i++) {
30 index[i]++;
31 if (index[i] <= DIM_UBOUND_G(s, i))
32 return 1; /* keep going */
33 index[i] = F90_DIM_LBOUND_G(s, i);
34 }
35 return 0; /* finished */
36 }
37
ENTFTN(TRANSFER,transfer)38 void ENTFTN(TRANSFER, transfer)(void *rb, /* result base */
39 void *sb, /* source base */
40 __INT_T *rs, /* size of result element */
41 __INT_T *ms, /* size of mold */
42 F90_Desc *result, /* result descriptor */
43 F90_Desc *source, /* source descriptor */
44 void *rsd, void *msd)
45 {
46 int result_scalar, source_scalar;
47 __INT_T extent, size, rsize, ssize;
48 __INT_T sindex[7];
49 __INT_T k;
50 __INT_T i;
51 /*
52 * when the source is an array, a loop is executed to transfer the
53 * source to the result. Each element is first copied to temp via
54 * __fort_get_scalar(), but the 'scalar' can actually be a character
55 * object. Need to check the length of the scalar to ensure that
56 * it fits in temp; if not, need to malloc a temp.
57 */
58 double temp[16]; /* sufficient for a character*128 source */
59 char *ptemp;
60
61 result_scalar = F90_TAG_G(result) != __DESC;
62 source_scalar = F90_TAG_G(source) != __DESC;
63 if (*rs == 0 && (F90_TAG_G(result) == __POLY)) {
64 OBJECT_DESC *dest = (OBJECT_DESC *)result;
65 TYPE_DESC *dest_td = dest ? dest->type : 0;
66 if (dest_td != NULL) {
67 rsize = ((OBJECT_DESC*)dest_td)->size;
68 } else {
69 rsize = *rs;
70 }
71 } else {
72 rsize = *rs;
73 }
74
75 if (result_scalar && source_scalar) {
76 OBJECT_DESC *src = (OBJECT_DESC *)source;
77 TYPE_DESC *src_td = src ? src->type : 0;
78 if (*ms == 0 && (F90_TAG_G(source) == __POLY) && src_td != NULL) {
79 if (rsize > ((OBJECT_DESC*)src_td)->size) {
80 rsize = ((OBJECT_DESC*)src_td)->size;
81 }
82 } else if (rsize > *ms) {
83 rsize = *ms;
84 }
85 __fort_bcopy(rb, sb, rsize);
86 return;
87 }
88 if (!result_scalar) {
89 extent = F90_DIM_EXTENT_G(result, 0);
90 if (extent < 0)
91 extent = 0;
92 rsize *= extent;
93 }
94
95 /* we assume that result is replicated and contiguous */
96
97 if (source_scalar) {
98
99 /* have to store elements of result */
100
101 ssize = *ms;
102 while (ssize > 0 && rsize > 0) {
103
104 /* we have rsize bytes left to copy. See if there are that
105 * many left in source */
106
107 size = rsize;
108 if (size > ssize)
109 size = ssize;
110 __fort_bcopy(rb, sb, size);
111 rb = (char *)rb + size;
112 sb = (char *)sb + size;
113 ssize -= size;
114 rsize -= size;
115 }
116 return;
117 }
118
119 /* source is an array */
120
121 k = F90_RANK_G(source);
122 ssize = *ms;
123 for (i = 0; i < k; ++i) {
124 sindex[i] = F90_DIM_LBOUND_G(source, i);
125 extent = F90_DIM_EXTENT_G(source, i);
126 if (extent < 0)
127 extent = 0;
128 ssize *= extent;
129 }
130 ptemp = (char *)&temp;
131 if (*ms > sizeof(temp)) {
132 ptemp = __fort_malloc(*ms);
133 }
134 while (ssize > 0 && rsize > 0) {
135 I8(__fort_get_scalar)(ptemp, sb, source, sindex);
136 I8(next_index)(sindex, source);
137 size = rsize;
138 if (size > *ms)
139 size = *ms;
140 __fort_bcopy(rb, ptemp, size);
141 rb = (char *)rb + size;
142 ssize -= size;
143 rsize -= size;
144 }
145 if (ptemp != (char *)&temp) {
146 __fort_free(ptemp);
147 }
148 }
149