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 00038 #pragma ident "@(#) libf/fio/lu2s.c 92.1 06/21/99 10:37:21" 00039 #include <fortran.h> 00040 #include <cray/fmtconv.h> 00041 00042 extern ic_func _LU2S; /* Interface must match ic_func prototype */ 00043 00044 /* 00045 * _LU2S() Convert Fortran logical input to internal format. 00046 * 00047 * Valid Fortran logical input consists of the following: 00048 * 00049 * Zero or more blanks, optionally followed by: 00050 * Zero or one period, optionally followed by: 00051 * Zero or more blanks, immediately followed by: 00052 * 'T' or 'F' or 't' or 'f', optionally followed by: 00053 * Zero or more characters 00054 * 00055 * A field of all blanks is interpreted as .FALSE. 00056 * 00057 * Entry: 00058 * fca Address of first unpacked character 00059 * width Field width 00060 * lcap1 Pointer to pointer to last character address plus one 00061 * mode Unused 00062 * result Address to store result 00063 * status Pointer to status word 00064 * digits Unused 00065 * scale Unused 00066 * 00067 * Exit: 00068 * lcap1 Pointer updated to last character read (plus one) 00069 * result Updated to .TRUE. or .FALSE., if valid input 00070 * status Updated status: 00071 * 0 Valid Fortran logical input 00072 * EX_INVLOGI (-10) Invalid Fortran logical input 00073 * 00074 * The function result is the same as the status. 00075 * 00076 * Note: This routine has the same parameters as IU2S, etc. in 00077 * libc. 00078 */ 00079 00080 int 00081 _LU2S( 00082 const long *fca, 00083 const long *width, 00084 long **lcap1, 00085 const long *mode, 00086 void *result, 00087 long *status, 00088 const long *digits, 00089 const long *scale 00090 ) 00091 { 00092 char ch; 00093 int fw; 00094 int stat; 00095 int value; 00096 00097 stat = 0; 00098 value = 0; /* Assume .FALSE. */ 00099 fw = *lcap1 - fca; /* Maximum possible field width */ 00100 00101 if (*width < fw) 00102 fw = *width; /* Set actual width */ 00103 00104 if (fw > 0) { /* If there is a field */ 00105 00106 *lcap1 = (long *)fca + fw; 00107 ch = (char) *fca++; 00108 00109 /* Skip optional blanks */ 00110 00111 while (ch == ' ' && fw > 0) { 00112 ch = (char) *fca++; 00113 fw--; 00114 } 00115 00116 /* Process nonblank character */ 00117 00118 if (fw > 0) { /* If not at end of field */ 00119 00120 /* Skip optional period */ 00121 00122 if (ch == '.') { 00123 ch = (char) *fca++; 00124 value = -1; /* TRUE or FALSE now required */ 00125 fw--; 00126 } 00127 00128 /* Skip optional blanks */ 00129 00130 while (ch == ' ' && fw > 0) { 00131 ch = (char) *fca++; 00132 fw--; 00133 } 00134 00135 /* Process required character */ 00136 00137 if (fw > 0) { /* If not at end of field */ 00138 00139 if (ch == 'T' || ch == 't') 00140 value = 1; 00141 else 00142 if (ch == 'F' || ch == 'f') 00143 value = 0; 00144 else 00145 value = -1; 00146 } 00147 } 00148 00149 } 00150 00151 if (value >= 0) { /* If we found something */ 00152 #ifdef _F_LOG4 00153 if (*mode & MODEHP) 00154 *(_f_log4 *)result = _btol(value); 00155 else 00156 #if defined(_F_LOG2) && (defined(__mips) || defined(_LITTLE_ENDIAN)) 00157 if (*mode & MODEWP) 00158 *(_f_log2 *)result = (_f_log2) _btol(value); 00159 else if (*mode & MODEBP) 00160 *(_f_log1 *)result = (_f_log1) _btol(value); 00161 else 00162 #endif /* _F_LOG2 and (mips or little endian) */ 00163 #endif /* _F_LOG4 */ 00164 *(_f_log8 *)result = _btol(value); 00165 } 00166 else 00167 stat = EX_INVLOGI; 00168 00169 *status = stat; 00170 00171 return (stat); 00172 }