1 /* Test the fix for PR100914 */
2
3 #include <assert.h>
4 #include <complex.h>
5 #include <stdbool.h>
6 #include <stdio.h>
7 #include <math.h>
8
9 #include <ISO_Fortran_binding.h>
10
11 #define _CFI_type_mask 0xFF
12 #define _CFI_type_kind_shift 8
13
14 #define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask)
15 #define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask)
16
17 #define _CFI_encode_type(TYPE, KIND) (int16_t)\
18 ((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\
19 | ((TYPE) & CFI_type_mask))
20
21 #undef CMPLXF
22 #define CMPLXF(x, y) ((float complex)((float)(x) + I * (float)(y)))
23
24 #undef CMPLX
25 #define CMPLX(x, y) ((double complex)((double)(x) + (double complex)I * (double)(y)))
26
27 #undef CMPLXL
28 #define CMPLXL(x, y) ((long double complex)((long double)(x) + (long double complex)I * (long double)(y)))
29
30 #undef CMPLX
31 #define CMPLX(x, y) ((_Float128 _Complex )((double)(x) + (double complex)I * (double)(y)))
32
33 #define N 11
34 #define M 7
35
36 typedef float _Complex c_float_complex;
37 typedef double _Complex c_double_complex;
38 typedef long double _Complex c_long_double_complex;
39 typedef _Float128 _Complex c_float128_complex;
40
41 bool c_vrfy_c_float_complex (const CFI_cdesc_t *restrict);
42
43 bool c_vrfy_c_double_complex (const CFI_cdesc_t *restrict);
44
45 bool c_vrfy_c_long_double_complex (const CFI_cdesc_t *restrict);
46
47 bool c_vrfy_c_float128_complex (const CFI_cdesc_t *restrict);
48
49 bool c_vrfy_complex (const CFI_cdesc_t *restrict);
50
51 bool c_vrfy_desc (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t);
52
53 void check_tk (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t);
54
55
56
57 bool
58 c_vrfy_c_float_complex (const CFI_cdesc_t *restrict auxp)
59 {
60 CFI_index_t i, lb, ub, ex;
61 size_t sz;
62 c_float_complex *ip = NULL;
63
64 assert (auxp);
65 assert (auxp->base_addr);
66 assert (auxp->elem_len>0);
67 lb = auxp->dim[0].lower_bound;
68 ex = auxp->dim[0].extent;
69 assert (ex==11);
70 sz = (size_t)auxp->elem_len / sizeof (c_float_complex);
71 assert (sz==1);
72 ub = ex + lb - 1;
73 ip = (c_float_complex*)auxp->base_addr;
74 for (i=0; i<ex; i++, ip+=sz)
75 if ((cabsf (*ip-(c_float_complex)(CMPLXF((i+1), (2*(i+1)))))>(float)0.0))
76 return false;
77 for (i=lb; i<ub+1; i++)
78 {
79 ip = (c_float_complex*)CFI_address(auxp, &i);
80 if ((cabsf (*ip-(c_float_complex)(CMPLXF((i-lb+1), (2*(i-lb+1)))))>(float)0.0))
81 return false;
82 }
83 return true;
84 }
85
86 bool
87 c_vrfy_c_double_complex (const CFI_cdesc_t *restrict auxp)
88 {
89 CFI_index_t i, lb, ub, ex;
90 size_t sz;
91 c_double_complex *ip = NULL;
92
93 assert (auxp);
94 assert (auxp->base_addr);
95 assert (auxp->elem_len>0);
96 lb = auxp->dim[0].lower_bound;
97 ex = auxp->dim[0].extent;
98 assert (ex==11);
99 sz = (size_t)auxp->elem_len / sizeof (c_double_complex);
100 assert (sz==1);
101 ub = ex + lb - 1;
102 ip = (c_double_complex*)auxp->base_addr;
103 for (i=0; i<ex; i++, ip+=sz)
104 if ((cabs (*ip-(c_double_complex)(CMPLX((i+1), (2*(i+1)))))>(double)0.0))
105 return false;
106 for (i=lb; i<ub+1; i++)
107 {
108 ip = (c_double_complex*)CFI_address(auxp, &i);
109 if ((cabs (*ip-(c_double_complex)(CMPLX((i-lb+1), (2*(i-lb+1)))))>(double)0.0))
110 return false;
111 }
112 return true;
113 }
114
115 bool
116 c_vrfy_c_long_double_complex (const CFI_cdesc_t *restrict auxp)
117 {
118 CFI_index_t i, lb, ub, ex;
119 size_t sz;
120 c_long_double_complex *ip = NULL;
121
122 assert (auxp);
123 assert (auxp->base_addr);
124 assert (auxp->elem_len>0);
125 lb = auxp->dim[0].lower_bound;
126 ex = auxp->dim[0].extent;
127 assert (ex==11);
128 sz = (size_t)auxp->elem_len / sizeof (c_long_double_complex);
129 assert (sz==1);
130 ub = ex + lb - 1;
131 ip = (c_long_double_complex*)auxp->base_addr;
132 for (i=0; i<ex; i++, ip+=sz)
133 if ((cabsl (*ip-(c_long_double_complex)(CMPLXL((i+1), (2*(i+1)))))>(long double)0.0))
134 return false;
135 for (i=lb; i<ub+1; i++)
136 {
137 ip = (c_long_double_complex*)CFI_address(auxp, &i);
138 if ((cabsl (*ip-(c_long_double_complex)(CMPLXL((i-lb+1), (2*(i-lb+1)))))>(long double)0.0))
139 return false;
140 }
141 return true;
142 }
143
144 bool
145 c_vrfy_c_float128_complex (const CFI_cdesc_t *restrict auxp)
146 {
147 CFI_index_t i, lb, ub, ex;
148 size_t sz;
149 c_float128_complex *ip = NULL;
150
151 assert (auxp);
152 assert (auxp->base_addr);
153 assert (auxp->elem_len>0);
154 lb = auxp->dim[0].lower_bound;
155 ex = auxp->dim[0].extent;
156 assert (ex==11);
157 sz = (size_t)auxp->elem_len / sizeof (c_float128_complex);
158 assert (sz==1);
159 ub = ex + lb - 1;
160 ip = (c_float128_complex*)auxp->base_addr;
161 for (i=0; i<ex; i++, ip+=sz)
162 if ((cabs ((double complex)(*ip-(c_float128_complex)(CMPLX((i+1), (2*(i+1))))))>(double)0.0))
163 return false;
164 for (i=lb; i<ub+1; i++)
165 {
166 ip = (c_float128_complex*)CFI_address(auxp, &i);
167 if ((cabs ((double complex)(*ip-(c_float128_complex)(CMPLX((i-lb+1), (2*(i-lb+1))))))>(double)0.0))
168 return false;
169 }
170 return true;
171 }
172
173 bool
174 c_vrfy_complex (const CFI_cdesc_t *restrict auxp)
175 {
176 signed char type, kind;
177
178 assert (auxp);
179 type = _CFI_decode_type(auxp->type);
180 kind = _CFI_decode_kind(auxp->type);
181 assert (type == CFI_type_Complex);
182 switch (kind)
183 {
184 case 4:
185 return c_vrfy_c_float_complex (auxp);
186 break;
187 case 8:
188 return c_vrfy_c_double_complex (auxp);
189 break;
190 case 10:
191 return c_vrfy_c_long_double_complex (auxp);
192 break;
193 case 16:
194 return c_vrfy_c_float128_complex (auxp);
195 break;
196 default:
197 assert (false);
198 }
199 return true;
200 }
201
202 void
203 check_tk (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed char kind, const size_t elem_len, const size_t nelem)
204 {
205 signed char ityp, iknd;
206
207 assert (auxp);
208 assert (auxp->elem_len==elem_len*nelem);
209 assert (auxp->rank==1);
210 assert (auxp->dim[0].sm>0);
211 assert ((size_t)auxp->dim[0].sm==elem_len*nelem);
212 /* */
213 assert (auxp->type==type);
214 ityp = _CFI_decode_type(auxp->type);
215 assert (ityp == CFI_type_Complex);
216 iknd = _CFI_decode_kind(auxp->type);
217 assert (_CFI_decode_type(type)==ityp);
218 assert (kind==iknd);
219 assert (c_vrfy_complex (auxp));
220 return;
221 }
222
223 // Local Variables:
224 // mode: C
225 // End: