Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
00001 /* 00002 00003 Copyright (C) 2000, 2001 Silicon Graphics, Inc. All Rights Reserved. 00004 00005 This program is free software; you can redistribute it and/or modify it 00006 under the terms of version 2.1 of the GNU Lesser General Public License 00007 as published by the Free Software Foundation. 00008 00009 This program is distributed in the hope that it would be useful, but 00010 WITHOUT ANY WARRANTY; without even the implied warranty of 00011 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00012 00013 Further, this software is distributed without any warranty that it is 00014 free of the rightful claim of any third person regarding infringement 00015 or the like. Any license provided herein, whether implied or 00016 otherwise, applies only to this software file. Patent licenses, if 00017 any, provided herein do not apply to combinations of this program with 00018 other software, or any other product whatsoever. 00019 00020 You should have received a copy of the GNU Lesser General Public 00021 License along with this program; if not, write the Free Software 00022 Foundation, Inc., 59 Temple Place - Suite 330, Boston MA 02111-1307, 00023 USA. 00024 00025 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00026 Mountain View, CA 94043, or: 00027 00028 http://www.sgi.com 00029 00030 For further information regarding this notice, see: 00031 00032 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00033 00034 */ 00035 00036 00037 #include <stdio.h> 00038 #include <stdarg.h> 00039 #include <string.h> 00040 #include <stdlib.h> 00041 #include "cmplrs/host.h" 00042 00043 void 00044 __argmnt( int64 *__vcnt, int32 *chararg1, int32 *nargs ) 00045 { 00046 /* 00047 The last 10-bit of __vcnt contains the number of argument passed, not 00048 counting the string lengths. The string lengths 'lcnt' are passed 00049 by: __vcnt = nargs + (lcnt << 10) 00050 */ 00051 *nargs = (int) (*chararg1 ? (*__vcnt&1023) : ((*__vcnt&1023) + (*__vcnt>>10))); 00052 } 00053 00054 void 00055 __getadr( int64 *__vcnt, int32 *n, long *iaddr) 00056 { 00057 int acnt = *__vcnt&1023; 00058 int lcnt = *__vcnt>>10; 00059 /* 00060 The frontend needs to call this with the address of __vaddr as the 00061 first parameter so this routine can find the following argument 00062 addresses passed on the parameter list 00063 */ 00064 if (*n < 1 || *n > acnt + lcnt) { 00065 *iaddr = 0; 00066 return; 00067 } 00068 00069 /* 00070 Note that for 64-bit environment iaddr must always correspond to 00071 an INTEGER*8 argument. However, the actual character length parameters 00072 at the end of the list are passed as INTEGER*4 always so we need to 00073 distinguish the two cases here 00074 */ 00075 /* Gettting the address of the actual arguments */ 00076 if (*n <= acnt) { 00077 /* 00078 For new 32-bit ABI needs the 4-byte adjustment so that 00079 the 4-byte address can be obtained from the 8-byte 00080 argument slot 00081 */ 00082 *iaddr = *(long *) ((char *) __vcnt + ((*n) * 8 + 00083 (_MIPS_SIM == _MIPS_SIM_NABI32 ? 4 : 0))); 00084 return; 00085 } 00086 /* Getting the length of the character arguments. Since these are 00087 ** always 32-bit long regardless of the pointer size we need to 00088 ** force it to be of type int32 */ 00089 *(int32 *) iaddr = *(int32 *) ((char *) __vcnt + ((*n) * 8 + 00090 (_MIPS_SIM == _MIPS_SIM_NABI32 || _MIPS_SZPTR == 64 ? 4 : 0))); 00091 } 00092 00093 00094 void 00095 __getcln( int64 *__vcnt, int32 *n, int32 *iclen) 00096 { 00097 int acnt = *__vcnt&1023; 00098 int lcnt = *__vcnt>>10; 00099 /* 00100 'n' is the Nth character argument is the list and is not the Nth 00101 argument in general. 00102 */ 00103 if (*n < 1 || *n > lcnt) { 00104 *iclen = 0; 00105 return; 00106 } 00107 00108 /* Getting the 4-byte length of the character arguments */ 00109 *iclen = *(int32 *) ((char *) __vcnt 00110 + (4 + (acnt+*n) * 8 00111 + (_MIPS_SIM == _MIPS_SIM_NABI32 || _MIPS_SZPTR == 64 ? 4 : 0))); 00112 } 00113 00114 00115 int32 00116 __nullok( int64 *__vcnt, int32 *n, long *iaddr) 00117 { 00118 int acnt = *__vcnt&1023; 00119 int lcnt = *__vcnt>>10; 00120 /* 00121 The frontend needs to call this with the address of __vaddr as the 00122 first parameter so this routine can find the following argument 00123 addresses passed on the parameter list 00124 */ 00125 if (*n < 1 || *n > acnt) { 00126 return(*iaddr != 0); 00127 } 00128 00129 /* 00130 Note that for 64-bit environment iaddr must always correspond to 00131 an INTEGER*8 argument. However, the actual character length parameters 00132 at the end of the list are passed as INTEGER*4 always so we need to 00133 distinguish the two cases here 00134 */ 00135 /* Gettting the address of the actual arguments */ 00136 if (*n <= acnt) { 00137 /* 00138 For new 32-bit ABI needs the 4-byte adjustment so that 00139 the 4-byte address can be obtained from the 8-byte argument 00140 slot 00141 */ 00142 return(*iaddr != *(long *) ((char *) __vcnt + 00143 (*n * 8 + 00144 (_MIPS_SIM == _MIPS_SIM_NABI32 ? 4 : 0)))); 00145 } 00146 /* Getting the length of the character arguments */ 00147 return(*(int32 *)iaddr != *(int32 *) ((char *) __vcnt + (*n * 8+ 00148 (_MIPS_SIM == _MIPS_SIM_NABI32 || _MIPS_SZPTR == 64 ? 4 : 0)))); 00149 } 00150 00151 00152 void 00153 __xetarg( int64 *__vcnt, int32 *n, int32 *len, void *iarg) 00154 { 00155 long iaddr; 00156 __getadr( __vcnt, n, &iaddr ); 00157 memcpy( iarg, (char *) iaddr, *len ); 00158 } 00159 00160 void 00161 __retour( int64 *__vcnt, int32 *nargs, ... ) 00162 { 00163 va_list ap; 00164 char *cval; 00165 long iaddr; 00166 int32 len, n; 00167 00168 va_start(ap, __vcnt); 00169 nargs = va_arg( ap, int32 * ); 00170 n = 0; 00171 while ((*nargs)--) { 00172 n++; 00173 if ((len = *(va_arg( ap, int32 *))) <= 0) 00174 goto badarg; 00175 __getadr( __vcnt, &n, &iaddr ); 00176 if ((cval = va_arg( ap, char * )) <= 0) 00177 goto badarg; 00178 memcpy( (char *) iaddr, cval, len ); 00179 } 00180 goto endsub; 00181 badarg: 00182 fprintf( stderr, "Warning: Wrong arguments in RETOUR\n" ); 00183 endsub: 00184 va_end(ap); 00185 } 00186 00187 00188 /* Everything after this point is used to support the objects produced 00189 ** by fcom for the old 32-bit support. 00190 */ 00191 00192 #include "comargs.h" 00193 int32 comargs__ [COMARGSZ]; 00194 00195 00196 static int32 nlev = -1; 00197 static int32 **comptr = NULL; 00198 static int32 comptr_size = 0; 00199 00200 extern void check_vararg_error(void); 00201 extern void s_abort(void); 00202 #ifdef FTN90_IO 00203 #include "fio.h" 00204 #else 00205 extern void f77fatal (int32, char *); 00206 #endif 00207 00208 int32 nullok_( argno, adr ) 00209 int32 *argno; 00210 int32 *adr; 00211 { 00212 check_vararg_error(); 00213 return( *adr != *( comptr[nlev] + *argno ) ); 00214 } 00215 00216 00217 00218 void getadr_(int32 *argno, int32 *argadr ) 00219 { 00220 check_vararg_error(); 00221 *argadr = *( comptr[nlev] + *argno ); 00222 } 00223 00224 00225 00226 void argmnt_(int32 *narg ) 00227 { 00228 check_vararg_error(); 00229 *narg = *comptr[nlev]; 00230 } 00231 00232 00233 void xetarg_(int32 *argno, int32 *len, char *buff ) 00234 { 00235 check_vararg_error(); 00236 memcpy( buff, (void *) *(comptr[nlev] + *argno), *len ); 00237 } 00238 00239 00240 void set_varg_() 00241 { 00242 int n; 00243 if (++nlev >= comptr_size) 00244 { 00245 comptr_size += 20; 00246 if (comptr_size == 20) 00247 comptr = (int32 **) calloc( comptr_size, sizeof(int32) ); 00248 else 00249 comptr = (int32 **) realloc( comptr, comptr_size * sizeof(int32) ); 00250 } 00251 n = comargs__[0]*8 + 4; /* make sure that char lengths are copied */ 00252 if (!(comptr[nlev] = (int32 *) malloc( n ))) 00253 #ifdef FTN90_IO 00254 _ferr( NULL, FENOMEMY ); 00255 #else 00256 f77fatal( 113, "vararg" ); 00257 #endif 00258 memcpy( comptr[nlev], comargs__, n ); 00259 } 00260 00261 00262 void free_varg_() 00263 { 00264 check_vararg_error(); 00265 free(comptr[nlev--]); 00266 } 00267 00268 00269 void check_vararg_error(void) 00270 { 00271 if (nlev < 0) 00272 { 00273 fprintf( stderr, "Compiler error in vararg\n" ); 00274 s_abort(); 00275 } 00276 } 00277 00278 00279 void retour_(int32 *arg1, ... ) 00280 { 00281 va_list ap; 00282 char *cval; 00283 int32 *ip, *ival; 00284 int32 nargs, len, n; 00285 double_t *dp, *dval; 00286 00287 va_start(ap, arg1); 00288 nargs = *arg1; 00289 n = 0; 00290 while (nargs--) 00291 { 00292 n++; 00293 if ((len = *(va_arg( ap, int32 *))) <= 0) 00294 goto badarg; 00295 if (len == 4) 00296 { 00297 ip = (int32 *) *(comptr[nlev] + n); 00298 if (!(ival = va_arg( ap, int32 * ))) 00299 goto badarg; 00300 *ip = *ival; 00301 } 00302 else if (len == 8) 00303 { 00304 dp = (double *) *(comptr[nlev] + n); 00305 if (!(dval = va_arg( ap, double * ))) 00306 goto badarg; 00307 *dp = *dval; 00308 } 00309 else 00310 { 00311 ip = (int32 *) *(comptr[nlev] + n); 00312 if (!(cval = va_arg( ap, char * ))) 00313 goto badarg; 00314 memcpy( ip, cval, len ); 00315 } 00316 } 00317 goto endsub; 00318 badarg: 00319 fprintf( stderr, "Warning: Wrong arguments in RETOUR\n" ); 00320 endsub: 00321 va_end(ap); 00322 } 00323 00324 00325 void reset_comargs__() 00326 { 00327 comargs__[0] = 0; 00328 }