PageRenderTime 334ms CodeModel.GetById 24ms RepoModel.GetById 0ms app.codeStats 0ms

/min-dgels/base/F2CLIBS/libf2c/wrtfmt.c

https://bitbucket.org/jeromerobert/starpu
C | 377 lines | 356 code | 15 blank | 6 comment | 111 complexity | 7dafc626080c7256c9be4a7515c560a5 MD5 | raw file
  1. #include "f2c.h"
  2. #include "fio.h"
  3. #include "fmt.h"
  4. #ifdef __cplusplus
  5. extern "C" {
  6. #endif
  7. extern icilist *f__svic;
  8. extern char *f__icptr;
  9. static int
  10. mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */
  11. /* instead we know too much about stdio */
  12. {
  13. int cursor = f__cursor;
  14. f__cursor = 0;
  15. if(f__external == 0) {
  16. if(cursor < 0) {
  17. if(f__hiwater < f__recpos)
  18. f__hiwater = f__recpos;
  19. f__recpos += cursor;
  20. f__icptr += cursor;
  21. if(f__recpos < 0)
  22. err(f__elist->cierr, 110, "left off");
  23. }
  24. else if(cursor > 0) {
  25. if(f__recpos + cursor >= f__svic->icirlen)
  26. err(f__elist->cierr, 110, "recend");
  27. if(f__hiwater <= f__recpos)
  28. for(; cursor > 0; cursor--)
  29. (*f__putn)(' ');
  30. else if(f__hiwater <= f__recpos + cursor) {
  31. cursor -= f__hiwater - f__recpos;
  32. f__icptr += f__hiwater - f__recpos;
  33. f__recpos = f__hiwater;
  34. for(; cursor > 0; cursor--)
  35. (*f__putn)(' ');
  36. }
  37. else {
  38. f__icptr += cursor;
  39. f__recpos += cursor;
  40. }
  41. }
  42. return(0);
  43. }
  44. if (cursor > 0) {
  45. if(f__hiwater <= f__recpos)
  46. for(;cursor>0;cursor--) (*f__putn)(' ');
  47. else if(f__hiwater <= f__recpos + cursor) {
  48. cursor -= f__hiwater - f__recpos;
  49. f__recpos = f__hiwater;
  50. for(; cursor > 0; cursor--)
  51. (*f__putn)(' ');
  52. }
  53. else {
  54. f__recpos += cursor;
  55. }
  56. }
  57. else if (cursor < 0)
  58. {
  59. if(cursor + f__recpos < 0)
  60. err(f__elist->cierr,110,"left off");
  61. if(f__hiwater < f__recpos)
  62. f__hiwater = f__recpos;
  63. f__recpos += cursor;
  64. }
  65. return(0);
  66. }
  67. static int
  68. #ifdef KR_headers
  69. wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len;
  70. #else
  71. wrt_Z(Uint *n, int w, int minlen, ftnlen len)
  72. #endif
  73. {
  74. register char *s, *se;
  75. register int i, w1;
  76. static int one = 1;
  77. static char hex[] = "0123456789ABCDEF";
  78. s = (char *)n;
  79. --len;
  80. if (*(char *)&one) {
  81. /* little endian */
  82. se = s;
  83. s += len;
  84. i = -1;
  85. }
  86. else {
  87. se = s + len;
  88. i = 1;
  89. }
  90. for(;; s += i)
  91. if (s == se || *s)
  92. break;
  93. w1 = (i*(se-s) << 1) + 1;
  94. if (*s & 0xf0)
  95. w1++;
  96. if (w1 > w)
  97. for(i = 0; i < w; i++)
  98. (*f__putn)('*');
  99. else {
  100. if ((minlen -= w1) > 0)
  101. w1 += minlen;
  102. while(--w >= w1)
  103. (*f__putn)(' ');
  104. while(--minlen >= 0)
  105. (*f__putn)('0');
  106. if (!(*s & 0xf0)) {
  107. (*f__putn)(hex[*s & 0xf]);
  108. if (s == se)
  109. return 0;
  110. s += i;
  111. }
  112. for(;; s += i) {
  113. (*f__putn)(hex[*s >> 4 & 0xf]);
  114. (*f__putn)(hex[*s & 0xf]);
  115. if (s == se)
  116. break;
  117. }
  118. }
  119. return 0;
  120. }
  121. static int
  122. #ifdef KR_headers
  123. wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base;
  124. #else
  125. wrt_I(Uint *n, int w, ftnlen len, register int base)
  126. #endif
  127. { int ndigit,sign,spare,i;
  128. longint x;
  129. char *ans;
  130. if(len==sizeof(integer)) x=n->il;
  131. else if(len == sizeof(char)) x = n->ic;
  132. #ifdef Allow_TYQUAD
  133. else if (len == sizeof(longint)) x = n->ili;
  134. #endif
  135. else x=n->is;
  136. ans=f__icvt(x,&ndigit,&sign, base);
  137. spare=w-ndigit;
  138. if(sign || f__cplus) spare--;
  139. if(spare<0)
  140. for(i=0;i<w;i++) (*f__putn)('*');
  141. else
  142. { for(i=0;i<spare;i++) (*f__putn)(' ');
  143. if(sign) (*f__putn)('-');
  144. else if(f__cplus) (*f__putn)('+');
  145. for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
  146. }
  147. return(0);
  148. }
  149. static int
  150. #ifdef KR_headers
  151. wrt_IM(n,w,m,len,base) Uint *n; ftnlen len; int base;
  152. #else
  153. wrt_IM(Uint *n, int w, int m, ftnlen len, int base)
  154. #endif
  155. { int ndigit,sign,spare,i,xsign;
  156. longint x;
  157. char *ans;
  158. if(sizeof(integer)==len) x=n->il;
  159. else if(len == sizeof(char)) x = n->ic;
  160. #ifdef Allow_TYQUAD
  161. else if (len == sizeof(longint)) x = n->ili;
  162. #endif
  163. else x=n->is;
  164. ans=f__icvt(x,&ndigit,&sign, base);
  165. if(sign || f__cplus) xsign=1;
  166. else xsign=0;
  167. if(ndigit+xsign>w || m+xsign>w)
  168. { for(i=0;i<w;i++) (*f__putn)('*');
  169. return(0);
  170. }
  171. if(x==0 && m==0)
  172. { for(i=0;i<w;i++) (*f__putn)(' ');
  173. return(0);
  174. }
  175. if(ndigit>=m)
  176. spare=w-ndigit-xsign;
  177. else
  178. spare=w-m-xsign;
  179. for(i=0;i<spare;i++) (*f__putn)(' ');
  180. if(sign) (*f__putn)('-');
  181. else if(f__cplus) (*f__putn)('+');
  182. for(i=0;i<m-ndigit;i++) (*f__putn)('0');
  183. for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
  184. return(0);
  185. }
  186. static int
  187. #ifdef KR_headers
  188. wrt_AP(s) char *s;
  189. #else
  190. wrt_AP(char *s)
  191. #endif
  192. { char quote;
  193. int i;
  194. if(f__cursor && (i = mv_cur()))
  195. return i;
  196. quote = *s++;
  197. for(;*s;s++)
  198. { if(*s!=quote) (*f__putn)(*s);
  199. else if(*++s==quote) (*f__putn)(*s);
  200. else return(1);
  201. }
  202. return(1);
  203. }
  204. static int
  205. #ifdef KR_headers
  206. wrt_H(a,s) char *s;
  207. #else
  208. wrt_H(int a, char *s)
  209. #endif
  210. {
  211. int i;
  212. if(f__cursor && (i = mv_cur()))
  213. return i;
  214. while(a--) (*f__putn)(*s++);
  215. return(1);
  216. }
  217. int
  218. #ifdef KR_headers
  219. wrt_L(n,len, sz) Uint *n; ftnlen sz;
  220. #else
  221. wrt_L(Uint *n, int len, ftnlen sz)
  222. #endif
  223. { int i;
  224. long x;
  225. if(sizeof(long)==sz) x=n->il;
  226. else if(sz == sizeof(char)) x = n->ic;
  227. else x=n->is;
  228. for(i=0;i<len-1;i++)
  229. (*f__putn)(' ');
  230. if(x) (*f__putn)('T');
  231. else (*f__putn)('F');
  232. return(0);
  233. }
  234. static int
  235. #ifdef KR_headers
  236. wrt_A(p,len) char *p; ftnlen len;
  237. #else
  238. wrt_A(char *p, ftnlen len)
  239. #endif
  240. {
  241. while(len-- > 0) (*f__putn)(*p++);
  242. return(0);
  243. }
  244. static int
  245. #ifdef KR_headers
  246. wrt_AW(p,w,len) char * p; ftnlen len;
  247. #else
  248. wrt_AW(char * p, int w, ftnlen len)
  249. #endif
  250. {
  251. while(w>len)
  252. { w--;
  253. (*f__putn)(' ');
  254. }
  255. while(w-- > 0)
  256. (*f__putn)(*p++);
  257. return(0);
  258. }
  259. static int
  260. #ifdef KR_headers
  261. wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
  262. #else
  263. wrt_G(ufloat *p, int w, int d, int e, ftnlen len)
  264. #endif
  265. { double up = 1,x;
  266. int i=0,oldscale,n,j;
  267. x = len==sizeof(real)?p->pf:p->pd;
  268. if(x < 0 ) x = -x;
  269. if(x<.1) {
  270. if (x != 0.)
  271. return(wrt_E(p,w,d,e,len));
  272. i = 1;
  273. goto have_i;
  274. }
  275. for(;i<=d;i++,up*=10)
  276. { if(x>=up) continue;
  277. have_i:
  278. oldscale = f__scale;
  279. f__scale = 0;
  280. if(e==0) n=4;
  281. else n=e+2;
  282. i=wrt_F(p,w-n,d-i,len);
  283. for(j=0;j<n;j++) (*f__putn)(' ');
  284. f__scale=oldscale;
  285. return(i);
  286. }
  287. return(wrt_E(p,w,d,e,len));
  288. }
  289. int
  290. #ifdef KR_headers
  291. w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
  292. #else
  293. w_ed(struct syl *p, char *ptr, ftnlen len)
  294. #endif
  295. {
  296. int i;
  297. if(f__cursor && (i = mv_cur()))
  298. return i;
  299. switch(p->op)
  300. {
  301. default:
  302. fprintf(stderr,"w_ed, unexpected code: %d\n", p->op);
  303. sig_die(f__fmtbuf, 1);
  304. case I: return(wrt_I((Uint *)ptr,p->p1,len, 10));
  305. case IM:
  306. return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,10));
  307. /* O and OM don't work right for character, double, complex, */
  308. /* or doublecomplex, and they differ from Fortran 90 in */
  309. /* showing a minus sign for negative values. */
  310. case O: return(wrt_I((Uint *)ptr, p->p1, len, 8));
  311. case OM:
  312. return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,8));
  313. case L: return(wrt_L((Uint *)ptr,p->p1, len));
  314. case A: return(wrt_A(ptr,len));
  315. case AW:
  316. return(wrt_AW(ptr,p->p1,len));
  317. case D:
  318. case E:
  319. case EE:
  320. return(wrt_E((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len));
  321. case G:
  322. case GE:
  323. return(wrt_G((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len));
  324. case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2.i[0],len));
  325. /* Z and ZM assume 8-bit bytes. */
  326. case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len));
  327. case ZM:
  328. return(wrt_Z((Uint *)ptr,p->p1,p->p2.i[0],len));
  329. }
  330. }
  331. int
  332. #ifdef KR_headers
  333. w_ned(p) struct syl *p;
  334. #else
  335. w_ned(struct syl *p)
  336. #endif
  337. {
  338. switch(p->op)
  339. {
  340. default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op);
  341. sig_die(f__fmtbuf, 1);
  342. case SLASH:
  343. return((*f__donewrec)());
  344. case T: f__cursor = p->p1-f__recpos - 1;
  345. return(1);
  346. case TL: f__cursor -= p->p1;
  347. if(f__cursor < -f__recpos) /* TL1000, 1X */
  348. f__cursor = -f__recpos;
  349. return(1);
  350. case TR:
  351. case X:
  352. f__cursor += p->p1;
  353. return(1);
  354. case APOS:
  355. return(wrt_AP(p->p2.s));
  356. case H:
  357. return(wrt_H(p->p1,p->p2.s));
  358. }
  359. }
  360. #ifdef __cplusplus
  361. }
  362. #endif