1 #define UNSIGNED_BYTE
2
3 #include "cfortran.h"
4
5 /************************************************************************
6 Some platforms creates longs as 8-byte integers. On other machines, ints
7 and longs are both 4-bytes, so both are compatible with Fortrans
8 default integer which is 4-bytes. To support 8-byte longs, we must redefine
9 LONGs and convert them to 8-bytes when going to C, and restore them
10 to 4-bytes when returning to Fortran. Ugh!!!
11 *************************************************************************/
12
13 #if defined(DECFortran) || (defined(__alpha) && defined(g77Fortran)) \
14 || (defined(mipsFortran) && _MIPS_SZLONG==64) \
15 || (defined(IBMR2Fortran) && defined(__64BIT__)) \
16 || defined(__ia64__) \
17 || defined (__sparcv9) || (defined(__sparc__) && defined(__arch64__)) \
18 || defined (__x86_64__) \
19 || defined (_SX) \
20 || defined (__powerpc64__)\
21 || defined (__s390x__)
22
23 #define LONG8BYTES_INT4BYTES
24
25 #undef LONGV_cfSTR
26 #undef PLONG_cfSTR
27 #undef LONGVVVVVVV_cfTYPE
28 #undef PLONG_cfTYPE
29 #undef LONGV_cfT
30 #undef PLONG_cfT
31
32 #define LONGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,LONGV,A,B,C,D,E)
33 #define PLONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PLONG,A,B,C,D,E)
34 #define LONGVVVVVVV_cfTYPE int
35 #define PLONG_cfTYPE int
36 #define LONGV_cfQ(B) long *B, _(B,N);
37 #define PLONG_cfQ(B) long B;
38 #define LONGV_cfT(M,I,A,B,D) ( (_(B,N) = * _3(M,_LONGV_A,I)), \
39 B = F2Clongv(_(B,N),A) )
40 #define PLONG_cfT(M,I,A,B,D) ((B=*A),&B)
41 #define LONGV_cfR(A,B,D) C2Flongv(_(B,N),A,B);
42 #define PLONG_cfR(A,B,D) *A=B;
43 #define LONGV_cfH(S,U,B)
44 #define PLONG_cfH(S,U,B)
45
F2Clongv(long size,int * A)46 static long *F2Clongv(long size, int *A)
47 {
48 long i;
49 long *B;
50
51 B=(long *)malloc( size*sizeof(long) );
52 for(i=0;i<size;i++) B[i]=A[i];
53 return(B);
54 }
55
C2Flongv(long size,int * A,long * B)56 static void C2Flongv(long size, int *A, long *B)
57 {
58 long i;
59
60 for(i=0;i<size;i++) A[i]=B[i];
61 free(B);
62 }
63
64 #endif
65
66 /************************************************************************
67 Modify cfortran.h's handling of strings. C interprets a "char **"
68 parameter as an array of pointers to the strings (or as a handle),
69 not as a pointer to a block of contiguous strings. Also set a
70 a minimum length for string allocations, to minimize risk of
71 overflow.
72 *************************************************************************/
73
74 extern unsigned long gMinStrLen;
75
76 #undef STRINGV_cfQ
77 #undef STRINGV_cfR
78 #undef TTSTR
79 #undef TTTTSTRV
80 #undef RRRRPSTRV
81
82 #undef PPSTRING_cfT
83
84 #ifdef vmsFortran
85 #define PPSTRING_cfT(M,I,A,B,D) (unsigned char*)A->dsc$a_pointer
86
87 /* We want single strings to be equivalent to string vectors with */
88 /* a single element, so ignore the number of elements info in the */
89 /* vector structure, and rely on the NUM_ELEM definitions. */
90
91 #undef STRINGV_cfT
92 #define STRINGV_cfT(M,I,A,B,D) TTTTSTRV(A->dsc$a_pointer, B, \
93 A->dsc$w_length, \
94 num_elem(A->dsc$a_pointer, \
95 A->dsc$w_length, \
96 _3(M,_STRV_A,I) ) )
97 #else
98 #ifdef CRAYFortran
99 #define PPSTRING_cfT(M,I,A,B,D) (unsigned char*)_fcdtocp(A)
100 #else
101 #define PPSTRING_cfT(M,I,A,B,D) (unsigned char*)A
102 #endif
103 #endif
104
105 #define _cfMAX(A,B) ( (A>B) ? A : B )
106 #define STRINGV_cfQ(B) char **B; unsigned int _(B,N), _(B,M);
107 #define STRINGV_cfR(A,B,D) free(B[0]); free(B);
108 #define TTSTR( A,B,D) \
109 ((B=(char*)malloc(_cfMAX(D,gMinStrLen)+1))[D]='\0',memcpy(B,A,D), \
110 kill_trailing(B,' '))
111 #define TTTTSTRV( A,B,D,E) ( \
112 _(B,N)=_cfMAX(E,1), \
113 _(B,M)=_cfMAX(D,gMinStrLen)+1, \
114 B=(char**)malloc(_(B,N)*sizeof(char*)), \
115 B[0]=(char*)malloc(_(B,N)*_(B,M)), \
116 vindex(B,_(B,M),_(B,N),f2cstrv2(A,B[0],D,_(B,M),_(B,N))) \
117 )
118 #define RRRRPSTRV(A,B,D) \
119 c2fstrv2(B[0],A,_(B,M),D,_(B,N)), \
120 free(B[0]), \
121 free(B);
122
vindex(char ** B,int elem_len,int nelem,char * B0)123 static char **vindex(char **B, int elem_len, int nelem, char *B0)
124 {
125 int i;
126 if( nelem )
127 for( i=0;i<nelem;i++ ) B[i] = B0+i*elem_len;
128 return B;
129 }
130
c2fstrv2(char * cstr,char * fstr,int celem_len,int felem_len,int nelem)131 static char *c2fstrv2(char* cstr, char *fstr, int celem_len, int felem_len,
132 int nelem)
133 {
134 int i,j;
135
136 if( nelem )
137 for (i=0; i<nelem; i++) {
138 for (j=0; j<felem_len && *cstr; j++) *fstr++ = *cstr++;
139 cstr += celem_len-j;
140 for (; j<felem_len; j++) *fstr++ = ' ';
141 }
142 return( fstr-felem_len*nelem );
143 }
144
f2cstrv2(char * fstr,char * cstr,int felem_len,int celem_len,int nelem)145 static char *f2cstrv2(char *fstr, char* cstr, int felem_len, int celem_len,
146 int nelem)
147 {
148 int i,j;
149
150 if( nelem )
151 for (i=0; i<nelem; i++, cstr+=(celem_len-felem_len)) {
152 for (j=0; j<felem_len; j++) *cstr++ = *fstr++;
153 *cstr='\0';
154 kill_trailingn( cstr-felem_len, ' ', cstr );
155 }
156 return( cstr-celem_len*nelem );
157 }
158
159 /************************************************************************
160 The following definitions redefine the BYTE data type to be
161 interpretted as a character*1 string instead of an integer*1 which
162 is not supported by all compilers.
163 *************************************************************************/
164
165 #undef BYTE_cfT
166 #undef BYTEV_cfT
167 #undef BYTE_cfINT
168 #undef BYTEV_cfINT
169 #undef BYTE_cfSTR
170 #undef BYTEV_cfSTR
171
172 #define BYTE_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,BYTE,B,X,Y,Z,0)
173 #define BYTEV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,BYTEV,B,X,Y,Z,0)
174 #define BYTE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,BYTE,A,B,C,D,E)
175 #define BYTEV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,BYTEV,A,B,C,D,E)
176 #define BYTE_cfSEP(T,B) INT_cfSEP(T,B)
177 #define BYTEV_cfSEP(T,B) INT_cfSEP(T,B)
178 #define BYTE_cfH(S,U,B) STRING_cfH(S,U,B)
179 #define BYTEV_cfH(S,U,B) STRING_cfH(S,U,B)
180 #define BYTE_cfQ(B)
181 #define BYTEV_cfQ(B)
182 #define BYTE_cfR(A,B,D)
183 #define BYTEV_cfR(A,B,D)
184
185 #ifdef vmsFortran
186 #define BYTE_cfN(T,A) fstring * A
187 #define BYTEV_cfN(T,A) fstringvector * A
188 #define BYTE_cfT(M,I,A,B,D) (INTEGER_BYTE)((A->dsc$a_pointer)[0])
189 #define BYTEV_cfT(M,I,A,B,D) (INTEGER_BYTE*)A->dsc$a_pointer
190 #else
191 #ifdef CRAYFortran
192 #define BYTE_cfN(T,A) _fcd A
193 #define BYTEV_cfN(T,A) _fcd A
194 #define BYTE_cfT(M,I,A,B,D) (INTEGER_BYTE)((_fcdtocp(A))[0])
195 #define BYTEV_cfT(M,I,A,B,D) (INTEGER_BYTE*)_fcdtocp(A)
196 #else
197 #define BYTE_cfN(T,A) INTEGER_BYTE * A
198 #define BYTEV_cfN(T,A) INTEGER_BYTE * A
199 #define BYTE_cfT(M,I,A,B,D) A[0]
200 #define BYTEV_cfT(M,I,A,B,D) A
201 #endif
202 #endif
203
204 /************************************************************************
205 The following definitions and functions handle conversions between
206 C and Fortran arrays of LOGICALS. Individually, LOGICALS are
207 treated as int's but as char's when in an array. cfortran defines
208 (F2C/C2F)LOGICALV but never uses them, so these routines also
209 handle TRUE/FALSE conversions.
210 *************************************************************************/
211
212 #undef LOGICALV_cfSTR
213 #undef LOGICALV_cfT
214 #define LOGICALV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,LOGICALV,A,B,C,D,E)
215 #define LOGICALV_cfQ(B) char *B; unsigned int _(B,N);
216 #define LOGICALV_cfT(M,I,A,B,D) (_(B,N)= * _3(M,_LOGV_A,I), \
217 B=F2CcopyLogVect(_(B,N),A))
218 #define LOGICALV_cfR(A,B,D) C2FcopyLogVect(_(B,N),A,B);
219 #define LOGICALV_cfH(S,U,B)
220
F2CcopyLogVect(long size,int * A)221 static char *F2CcopyLogVect(long size, int *A)
222 {
223 long i;
224 char *B;
225
226 B=(char *)malloc(size*sizeof(char));
227 for( i=0; i<size; i++ ) B[i]=F2CLOGICAL(A[i]);
228 return(B);
229 }
230
C2FcopyLogVect(long size,int * A,char * B)231 static void C2FcopyLogVect(long size, int *A, char *B)
232 {
233 long i;
234
235 for( i=0; i<size; i++ ) A[i]=C2FLOGICAL(B[i]);
236 free(B);
237 }
238
239 /*------------------ Fortran File Handling ----------------------*/
240 /* Fortran uses unit numbers, whereas C uses file pointers, so */
241 /* a global array of file pointers is setup in which Fortran's */
242 /* unit number serves as the index. Two FITSIO routines are */
243 /* the integer unit number and the fitsfile file pointer. */
244 /*-----------------------------------------------------------------*/
245
246 extern fitsfile *gFitsFiles[]; /* by Fortran unit numbers */
247
248 #define FITSUNIT_cfINT(N,A,B,X,Y,Z) INT_cfINT(N,A,B,X,Y,Z)
249 #define FITSUNIT_cfSTR(N,T,A,B,C,D,E) INT_cfSTR(N,T,A,B,C,D,E)
250 #define FITSUNIT_cfT(M,I,A,B,D) gFitsFiles[*A]
251 #define FITSUNITVVVVVVV_cfTYPE int
252 #define PFITSUNIT_cfINT(N,A,B,X,Y,Z) PINT_cfINT(N,A,B,X,Y,Z)
253 #define PFITSUNIT_cfSTR(N,T,A,B,C,D,E) PINT_cfSTR(N,T,A,B,C,D,E)
254 #define PFITSUNIT_cfT(M,I,A,B,D) (gFitsFiles + *A)
255 #define PFITSUNIT_cfTYPE int
256
257
258 /*---------------------- Make C++ Happy -----------------------------*/
259 /* Redefine FCALLSCFUNn so that they create prototypes of themselves */
260 /* and change TTTTSTR to use (char *)0 instead of NULL */
261 /*-------------------------------------------------------------------*/
262
263 #undef FCALLSCFUN0
264 #undef FCALLSCFUN14
265 #undef TTTTSTR
266
267 #define TTTTSTR(A,B,D) ( !(D<4||A[0]||A[1]||A[2]||A[3]) ) ? ((char*)0) : \
268 memchr(A,'\0',D) ? A : TTSTR(A,B,D)
269
270 #define FCALLSCFUN0(T0,CN,UN,LN) \
271 CFextern _(T0,_cfFZ)(UN,LN) void ABSOFT_cf2(T0)); \
272 CFextern _(T0,_cfFZ)(UN,LN) void ABSOFT_cf2(T0)) \
273 {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)}
274
275 #define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
276 CFextern _(T0,_cfF)(UN,LN) \
277 CFARGT14(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \
278 CFextern _(T0,_cfF)(UN,LN) \
279 CFARGT14(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)) \
280 { CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
281 _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \
282 TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \
283 TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
284 TCF(LN,TD,13,1) TCF(LN,TE,14,1) ); _Icf(0,K,T0,0,0) \
285 CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfI) \
286 }
287
288