Changeset 1391 for branches/GNU/src/gcc/libf2c/libI77
- Timestamp:
- Apr 27, 2004, 8:39:34 PM (21 years ago)
- Location:
- branches/GNU/src/gcc
- Files:
-
- 42 edited
-
. (modified) (1 prop)
-
libf2c/libI77/Makefile.in (modified) (1 diff, 1 prop)
-
libf2c/libI77/Version.c (modified) (2 diffs, 1 prop)
-
libf2c/libI77/backspace.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/close.c (modified) (2 diffs, 1 prop)
-
libf2c/libI77/configure (modified) (53 diffs, 1 prop)
-
libf2c/libI77/configure.in (modified) (3 diffs, 1 prop)
-
libf2c/libI77/dfe.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/dolio.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/due.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/endfile.c (modified) (2 diffs, 1 prop)
-
libf2c/libI77/err.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/f2ch.add (modified) (1 diff, 1 prop)
-
libf2c/libI77/fio.h (modified) (2 diffs, 1 prop)
-
libf2c/libI77/fmt.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/fmt.h (modified) (3 diffs, 1 prop)
-
libf2c/libI77/fmtlib.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/fp.h (modified) (1 diff, 1 prop)
-
libf2c/libI77/ftell_.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/iio.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/ilnw.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/inquire.c (modified) (2 diffs, 1 prop)
-
libf2c/libI77/lio.h (modified) (1 diff, 1 prop)
-
libf2c/libI77/lread.c (modified) (3 diffs, 1 prop)
-
libf2c/libI77/lwrite.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/open.c (modified) (2 diffs, 1 prop)
-
libf2c/libI77/rdfmt.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/rewind.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/rsfe.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/rsli.c (modified) (2 diffs, 1 prop)
-
libf2c/libI77/rsne.c (modified) (2 diffs, 1 prop)
-
libf2c/libI77/sfe.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/sue.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/typesize.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/uio.c (modified) (2 diffs, 1 prop)
-
libf2c/libI77/util.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/wref.c (modified) (2 diffs, 1 prop)
-
libf2c/libI77/wrtfmt.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/wsfe.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/wsle.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/wsne.c (modified) (1 diff, 1 prop)
-
libf2c/libI77/xwsne.c (modified) (1 diff, 1 prop)
Legend:
- Unmodified
- Added
- Removed
-
branches/GNU/src/gcc
- Property svn:ignore
-
old new 26 26 configure.vr 27 27 configure.vrs 28 dir.info 28 29 Makefile 29 dir.info30 30 lost+found 31 31 update.out
-
- Property svn:ignore
-
branches/GNU/src/gcc/libf2c/libI77/Makefile.in
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 39 39 @SET_MAKE@ 40 40 41 SHELL = /bin/sh41 SHELL = @SHELL@ 42 42 43 43 #### End of system configuration section. #### 44 44 45 45 ALL_CFLAGS = -I. -I$(srcdir) -I$(G2C_H_DIR) -I$(F2C_H_DIR) $(CPPFLAGS) \ 46 $(DEFS) $( CFLAGS)46 $(DEFS) $(WARN_CFLAGS) $(CFLAGS) 47 47 48 48 .SUFFIXES: -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/Version.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 1 static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 20001205\n"; 2 3 /* 4 */ 5 6 char __G77_LIBI77_VERSION__[] = "3.2.2 20030205 (release)"; 1 const char __LIBI77_VERSION__[] = "@(#) LIBI77 VERSION pjw,dmg-mods 20001205\n"; 7 2 8 3 /* … … 325 320 /* logical constants. */ 326 321 327 328 329 322 /* Changes for GNU Fortran (g77) version of libf2c: */ 330 323 331 324 /* 17 June 1997: detect recursive I/O and call f__fatal explaining it. */ 332 333 #include <stdio.h>334 335 void336 g77__ivers__ ()337 {338 fprintf (stderr, "__G77_LIBI77_VERSION__: %s", __G77_LIBI77_VERSION__);339 fputs (junk, stderr);340 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/backspace.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 3 3 #include "f2c.h" 4 4 #include "fio.h" 5 #ifdef KR_headers 6 integer f_back(a) alist *a; 7 #else 8 integer f_back(alist *a) 9 #endif 10 { unit *b; 11 off_t v, w, x, y, z; 12 uiolen n; 13 FILE *f; 5 integer 6 f_back (alist * a) 7 { 8 unit *b; 9 off_t v, w, x, y, z; 10 uiolen n; 11 FILE *f; 14 12 15 f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */ 16 if (f__init & 2) 17 f__fatal (131, "I/O recursion"); 18 if(a->aunit >= MXUNIT || a->aunit < 0) 19 err(a->aerr,101,"backspace"); 20 if(b->useek==0) err(a->aerr,106,"backspace"); 21 if(b->ufd == NULL) { 22 fk_open(1, 1, a->aunit); 23 return(0); 24 } 25 if(b->uend==1) 26 { b->uend=0; 27 return(0); 13 f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */ 14 if (f__init & 2) 15 f__fatal (131, "I/O recursion"); 16 if (a->aunit >= MXUNIT || a->aunit < 0) 17 err (a->aerr, 101, "backspace"); 18 if (b->useek == 0) 19 err (a->aerr, 106, "backspace"); 20 if (b->ufd == NULL) 21 { 22 fk_open (1, 1, a->aunit); 23 return (0); 24 } 25 if (b->uend == 1) 26 { 27 b->uend = 0; 28 return (0); 29 } 30 if (b->uwrt) 31 { 32 t_runc (a); 33 if (f__nowreading (b)) 34 err (a->aerr, errno, "backspace"); 35 } 36 f = b->ufd; /* may have changed in t_runc() */ 37 if (b->url > 0) 38 { 39 x = FTELL (f); 40 y = x % b->url; 41 if (y == 0) 42 x--; 43 x /= b->url; 44 x *= b->url; 45 FSEEK (f, x, SEEK_SET); 46 return (0); 47 } 48 49 if (b->ufmt == 0) 50 { 51 FSEEK (f, -(off_t) sizeof (uiolen), SEEK_CUR); 52 fread ((char *) &n, sizeof (uiolen), 1, f); 53 FSEEK (f, -(off_t) n - 2 * sizeof (uiolen), SEEK_CUR); 54 return (0); 55 } 56 w = x = FTELL (f); 57 z = 0; 58 loop: 59 while (x) 60 { 61 x -= x < 64 ? x : 64; 62 FSEEK (f, x, SEEK_SET); 63 for (y = x; y < w; y++) 64 { 65 if (getc (f) != '\n') 66 continue; 67 v = FTELL (f); 68 if (v == w) 69 { 70 if (z) 71 goto break2; 72 goto loop; 73 } 74 z = v; 28 75 } 29 if(b->uwrt) { 30 t_runc(a); 31 if (f__nowreading(b)) 32 err(a->aerr,errno,"backspace"); 33 } 34 f = b->ufd; /* may have changed in t_runc() */ 35 if(b->url>0) 36 { 37 x=FTELL(f); 38 y = x % b->url; 39 if(y == 0) x--; 40 x /= b->url; 41 x *= b->url; 42 FSEEK(f,x,SEEK_SET); 43 return(0); 44 } 45 46 if(b->ufmt==0) 47 { FSEEK(f,-(off_t)sizeof(uiolen),SEEK_CUR); 48 fread((char *)&n,sizeof(uiolen),1,f); 49 FSEEK(f,-(off_t)n-2*sizeof(uiolen),SEEK_CUR); 50 return(0); 51 } 52 w = x = FTELL(f); 53 z = 0; 54 loop: 55 while(x) { 56 x -= x < 64 ? x : 64; 57 FSEEK(f,x,SEEK_SET); 58 for(y = x; y < w; y++) { 59 if (getc(f) != '\n') 60 continue; 61 v = FTELL(f); 62 if (v == w) { 63 if (z) 64 goto break2; 65 goto loop; 66 } 67 z = v; 68 } 69 err(a->aerr,(EOF),"backspace"); 70 } 71 break2: 72 FSEEK(f, z, SEEK_SET); 73 return 0; 76 err (a->aerr, (EOF), "backspace"); 77 } 78 break2: 79 FSEEK (f, z, SEEK_SET); 80 return 0; 74 81 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/close.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 2 2 #include "f2c.h" 3 3 #include "fio.h" 4 #ifdef KR_headers 5 integer f_clos(a) cllist *a; 6 #else 4 7 5 #undef abs 8 6 #undef min … … 17 15 #include "io.h" 18 16 #else 19 #ifdef __cplusplus 20 extern "C" int unlink(const char*); 21 #else 22 extern int unlink(const char*); 23 #endif 17 extern int unlink (const char *); 24 18 #endif 25 19 #endif 26 20 27 integer f_clos(cllist *a) 28 #endif 29 { unit *b; 21 integer 22 f_clos (cllist * a) 23 { 24 unit *b; 30 25 31 if (f__init & 2) 32 f__fatal (131, "I/O recursion"); 33 if(a->cunit >= MXUNIT) return(0); 34 b= &f__units[a->cunit]; 35 if(b->ufd==NULL) 36 goto done; 37 if (b->uscrtch == 1) 38 goto Delete; 39 if (!a->csta) 40 goto Keep; 41 switch(*a->csta) { 42 default: 43 Keep: 44 case 'k': 45 case 'K': 46 if(b->uwrt == 1) 47 t_runc((alist *)a); 48 if(b->ufnm) { 49 fclose(b->ufd); 50 free(b->ufnm); 51 } 52 break; 53 case 'd': 54 case 'D': 55 Delete: 56 fclose(b->ufd); 57 if(b->ufnm) { 58 unlink(b->ufnm); /*SYSDEP*/ 59 free(b->ufnm); 60 } 61 } 62 b->ufd=NULL; 63 done: 64 b->uend=0; 65 b->ufnm=NULL; 66 return(0); 26 if (f__init & 2) 27 f__fatal (131, "I/O recursion"); 28 if (a->cunit >= MXUNIT) 29 return (0); 30 b = &f__units[a->cunit]; 31 if (b->ufd == NULL) 32 goto done; 33 if (b->uscrtch == 1) 34 goto Delete; 35 if (!a->csta) 36 goto Keep; 37 switch (*a->csta) 38 { 39 default: 40 Keep: 41 case 'k': 42 case 'K': 43 if (b->uwrt == 1) 44 t_runc ((alist *) a); 45 if (b->ufnm) 46 { 47 fclose (b->ufd); 48 free (b->ufnm); 67 49 } 68 void 69 #ifdef KR_headers 70 f_exit() 71 #else 72 f_exit(void) 73 #endif 74 { int i; 75 static cllist xx; 76 if (! (f__init & 1)) 77 return; /* Not initialized, so no open units. */ 78 /* I/O no longer in progress. If, during an I/O operation (such 79 as waiting for the user to enter a line), there is an 80 interrupt (such as ^C to stop the program on a UNIX system), 81 f_exit() is called, but there is no longer any I/O in 82 progress. Without turning off this flag, f_clos() would 83 think that there is an I/O recursion in this circumstance. */ 84 f__init &= ~2; 85 if (!xx.cerr) { 86 xx.cerr=1; 87 xx.csta=NULL; 88 for(i=0;i<MXUNIT;i++) 89 { 90 xx.cunit=i; 91 (void) f_clos(&xx); 92 } 50 break; 51 case 'd': 52 case 'D': 53 Delete: 54 fclose (b->ufd); 55 if (b->ufnm) 56 { 57 unlink (b->ufnm); 58 /*SYSDEP*/ free (b->ufnm); 93 59 } 60 } 61 b->ufd = NULL; 62 done: 63 b->uend = 0; 64 b->ufnm = NULL; 65 return (0); 94 66 } 95 int 96 #ifdef KR_headers 97 G77_flush_0 () 98 #else 67 68 void 69 f_exit (void) 70 { 71 int i; 72 static cllist xx; 73 if (!(f__init & 1)) 74 return; /* Not initialized, so no open units. */ 75 /* I/O no longer in progress. If, during an I/O operation (such 76 as waiting for the user to enter a line), there is an 77 interrupt (such as ^C to stop the program on a UNIX system), 78 f_exit() is called, but there is no longer any I/O in 79 progress. Without turning off this flag, f_clos() would 80 think that there is an I/O recursion in this circumstance. */ 81 f__init &= ~2; 82 if (!xx.cerr) 83 { 84 xx.cerr = 1; 85 xx.csta = NULL; 86 for (i = 0; i < MXUNIT; i++) 87 { 88 xx.cunit = i; 89 (void) f_clos (&xx); 90 } 91 } 92 } 93 int 99 94 G77_flush_0 (void) 100 #endif 101 {int i;102 for(i=0;i<MXUNIT;i++)103 if(f__units[i].ufd != NULL && f__units[i].uwrt)104 fflush(f__units[i].ufd);105 return 0;95 { 96 int i; 97 for (i = 0; i < MXUNIT; i++) 98 if (f__units[i].ufd != NULL && f__units[i].uwrt) 99 fflush (f__units[i].ufd); 100 return 0; 106 101 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/configure
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 29 29 silent= 30 30 site= 31 sitefile= 31 32 srcdir= 32 33 target=NONE … … 143 144 --no-create do not create output files 144 145 --quiet, --silent do not print \`checking...' messages 146 --site-file=FILE use FILE as the site file 145 147 --version print the version of autoconf that created configure 146 148 Directory and file names: … … 313 315 site="$ac_optarg" ;; 314 316 317 -site-file | --site-file | --site-fil | --site-fi | --site-f) 318 ac_prev=sitefile ;; 319 -site-file=* | --site-file=* | --site-fil=* | --site-fi=* | --site-f=*) 320 sitefile="$ac_optarg" ;; 321 315 322 -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) 316 323 ac_prev=srcdir ;; … … 478 485 479 486 # Prefer explicitly selected file to automatically selected ones. 480 if test -z "$CONFIG_SITE"; then 481 if test "x$prefix" != xNONE; then 482 CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" 483 else 484 CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" 487 if test -z "$sitefile"; then 488 if test -z "$CONFIG_SITE"; then 489 if test "x$prefix" != xNONE; then 490 CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" 491 else 492 CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" 493 fi 485 494 fi 495 else 496 CONFIG_SITE="$sitefile" 486 497 fi 487 498 for ac_site_file in $CONFIG_SITE; do … … 524 535 525 536 526 # These defines are necessary to get 64-bit file size support.527 528 cat >> confdefs.h <<\EOF529 #define _XOPEN_SOURCE 500L530 EOF531 532 # The following is needed by irix6.2 so that struct timeval is declared.533 cat >> confdefs.h <<\EOF534 #define _XOPEN_SOURCE_EXTENDED 1535 EOF536 537 # The following is needed by Solaris2.5.1 so that struct timeval is declared.538 cat >> confdefs.h <<\EOF539 #define __EXTENSIONS__ 1540 EOF541 542 cat >> confdefs.h <<\EOF543 #define _FILE_OFFSET_BITS 64544 EOF545 546 cat >> confdefs.h <<\EOF547 #define _LARGEFILE_SOURCE 1548 EOF549 550 551 552 537 553 538 … … 557 542 set dummy gcc; ac_word=$2 558 543 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 559 echo "configure:5 60: checking for $ac_word" >&5544 echo "configure:545: checking for $ac_word" >&5 560 545 if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then 561 546 echo $ac_n "(cached) $ac_c" 1>&6 … … 587 572 set dummy cc; ac_word=$2 588 573 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 589 echo "configure:5 90: checking for $ac_word" >&5574 echo "configure:575: checking for $ac_word" >&5 590 575 if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then 591 576 echo $ac_n "(cached) $ac_c" 1>&6 … … 638 623 set dummy cl; ac_word=$2 639 624 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 640 echo "configure:6 41: checking for $ac_word" >&5625 echo "configure:626: checking for $ac_word" >&5 641 626 if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then 642 627 echo $ac_n "(cached) $ac_c" 1>&6 … … 671 656 672 657 echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 673 echo "configure:6 74: checking whether we are using GNU C" >&5658 echo "configure:659: checking whether we are using GNU C" >&5 674 659 if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then 675 660 echo $ac_n "(cached) $ac_c" 1>&6 … … 680 665 #endif 681 666 EOF 682 if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:6 83: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then667 if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:668: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then 683 668 ac_cv_prog_gcc=yes 684 669 else … … 699 684 CFLAGS= 700 685 echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 701 echo "configure: 702: checking whether ${CC-cc} accepts -g" >&5686 echo "configure:687: checking whether ${CC-cc} accepts -g" >&5 702 687 if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then 703 688 echo $ac_n "(cached) $ac_c" 1>&6 … … 731 716 732 717 718 # These defines are necessary to get 64-bit file size support. 719 # NetBSD 1.4 header files does not support XOPEN_SOURCE == 600, but it 720 # handles 64-bit file sizes without needing these defines. 721 echo $ac_n "checking whether _XOPEN_SOURCE may be defined""... $ac_c" 1>&6 722 echo "configure:723: checking whether _XOPEN_SOURCE may be defined" >&5 723 cat > conftest.$ac_ext <<EOF 724 #line 725 "configure" 725 #include "confdefs.h" 726 #define _XOPEN_SOURCE 600L 727 #include <unistd.h> 728 int main() { 729 730 ; return 0; } 731 EOF 732 if { (eval echo configure:733: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then 733 rm -rf conftest* 734 may_use_xopen_source=yes 735 else 736 echo "configure: failed program was:" >&5 737 cat conftest.$ac_ext >&5 738 rm -rf conftest* 739 may_use_xopen_source=no 740 fi 741 rm -f conftest* 742 echo "$ac_t""$may_use_xopen_source" 1>&6 743 if test $may_use_xopen_source = yes; then 744 cat >> confdefs.h <<\EOF 745 #define _XOPEN_SOURCE 600L 746 EOF 747 748 # The following is needed by irix6.2 so that struct timeval is declared. 749 cat >> confdefs.h <<\EOF 750 #define _XOPEN_SOURCE_EXTENDED 1 751 EOF 752 753 # The following is needed by Solaris2.5.1 so that struct timeval is declared. 754 cat >> confdefs.h <<\EOF 755 #define __EXTENSIONS__ 1 756 EOF 757 758 cat >> confdefs.h <<\EOF 759 #define _FILE_OFFSET_BITS 64 760 EOF 761 762 cat >> confdefs.h <<\EOF 763 #define _LARGEFILE_SOURCE 1 764 EOF 765 766 fi 767 768 733 769 LIBTOOL='$(SHELL) ../libtool' 734 770 … … 737 773 738 774 echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 739 echo "configure:7 40: checking whether ${MAKE-make} sets \${MAKE}" >&5775 echo "configure:776: checking whether ${MAKE-make} sets \${MAKE}" >&5 740 776 set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` 741 777 if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then … … 767 803 # Sanity check for the cross-compilation case: 768 804 echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 769 echo "configure: 770: checking how to run the C preprocessor" >&5805 echo "configure:806: checking how to run the C preprocessor" >&5 770 806 # On Suns, sometimes $CPP names a directory. 771 807 if test -n "$CPP" && test -d "$CPP"; then … … 782 818 # not just through cpp. 783 819 cat > conftest.$ac_ext <<EOF 784 #line 785"configure"820 #line 821 "configure" 785 821 #include "confdefs.h" 786 822 #include <assert.h> … … 788 824 EOF 789 825 ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" 790 { (eval echo configure: 791: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }826 { (eval echo configure:827: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } 791 827 ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` 792 828 if test -z "$ac_err"; then … … 799 835 CPP="${CC-cc} -E -traditional-cpp" 800 836 cat > conftest.$ac_ext <<EOF 801 #line 8 02"configure"837 #line 838 "configure" 802 838 #include "confdefs.h" 803 839 #include <assert.h> … … 805 841 EOF 806 842 ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" 807 { (eval echo configure:8 08: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }843 { (eval echo configure:844: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } 808 844 ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` 809 845 if test -z "$ac_err"; then … … 816 852 CPP="${CC-cc} -nologo -E" 817 853 cat > conftest.$ac_ext <<EOF 818 #line 8 19"configure"854 #line 855 "configure" 819 855 #include "confdefs.h" 820 856 #include <assert.h> … … 822 858 EOF 823 859 ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" 824 { (eval echo configure:8 25: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }860 { (eval echo configure:861: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } 825 861 ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` 826 862 if test -z "$ac_err"; then … … 848 884 ac_safe=`echo "stdio.h" | sed 'y%./+-%__p_%'` 849 885 echo $ac_n "checking for stdio.h""... $ac_c" 1>&6 850 echo "configure:8 51: checking for stdio.h" >&5886 echo "configure:887: checking for stdio.h" >&5 851 887 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then 852 888 echo $ac_n "(cached) $ac_c" 1>&6 853 889 else 854 890 cat > conftest.$ac_ext <<EOF 855 #line 8 56"configure"891 #line 892 "configure" 856 892 #include "confdefs.h" 857 893 #include <stdio.h> 858 894 EOF 859 895 ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" 860 { (eval echo configure:8 61: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }896 { (eval echo configure:897: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } 861 897 ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` 862 898 if test -z "$ac_err"; then … … 886 922 887 923 echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 888 echo "configure: 889: checking for ANSI C header files" >&5924 echo "configure:925: checking for ANSI C header files" >&5 889 925 if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then 890 926 echo $ac_n "(cached) $ac_c" 1>&6 891 927 else 892 928 cat > conftest.$ac_ext <<EOF 893 #line 894"configure"929 #line 930 "configure" 894 930 #include "confdefs.h" 895 931 #include <stdlib.h> … … 899 935 EOF 900 936 ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" 901 { (eval echo configure:9 02: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }937 { (eval echo configure:938: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } 902 938 ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` 903 939 if test -z "$ac_err"; then … … 916 952 # SunOS 4.x string.h does not declare mem*, contrary to ANSI. 917 953 cat > conftest.$ac_ext <<EOF 918 #line 9 19"configure"954 #line 955 "configure" 919 955 #include "confdefs.h" 920 956 #include <string.h> … … 934 970 # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. 935 971 cat > conftest.$ac_ext <<EOF 936 #line 9 37"configure"972 #line 973 "configure" 937 973 #include "confdefs.h" 938 974 #include <stdlib.h> … … 955 991 else 956 992 cat > conftest.$ac_ext <<EOF 957 #line 9 58"configure"993 #line 994 "configure" 958 994 #include "confdefs.h" 959 995 #include <ctype.h> … … 966 1002 967 1003 EOF 968 if { (eval echo configure: 969: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null1004 if { (eval echo configure:1005: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null 969 1005 then 970 1006 : … … 989 1025 fi 990 1026 991 992 1027 echo $ac_n "checking for posix""... $ac_c" 1>&6 993 echo "configure: 994: checking for posix" >&51028 echo "configure:1029: checking for posix" >&5 994 1029 if eval "test \"`echo '$''{'g77_cv_header_posix'+set}'`\" = set"; then 995 1030 echo $ac_n "(cached) $ac_c" 1>&6 996 1031 else 997 1032 cat > conftest.$ac_ext <<EOF 998 #line 999"configure"1033 #line 1034 "configure" 999 1034 #include "confdefs.h" 1000 1035 #include <sys/types.h> … … 1022 1057 # header isn't actually like checking the functions, though... 1023 1058 echo $ac_n "checking for GNU library""... $ac_c" 1>&6 1024 echo "configure:10 25: checking for GNU library" >&51059 echo "configure:1060: checking for GNU library" >&5 1025 1060 if eval "test \"`echo '$''{'g77_cv_lib_gnu'+set}'`\" = set"; then 1026 1061 echo $ac_n "(cached) $ac_c" 1>&6 1027 1062 else 1028 1063 cat > conftest.$ac_ext <<EOF 1029 #line 10 30"configure"1064 #line 1065 "configure" 1030 1065 #include "confdefs.h" 1031 1066 #include <stdio.h> … … 1051 1086 # Apparently cygwin needs to be special-cased. 1052 1087 echo $ac_n "checking for cyg\`win'32""... $ac_c" 1>&6 1053 echo "configure:10 54: checking for cyg\`win'32" >&51088 echo "configure:1089: checking for cyg\`win'32" >&5 1054 1089 if eval "test \"`echo '$''{'g77_cv_sys_cygwin32'+set}'`\" = set"; then 1055 1090 echo $ac_n "(cached) $ac_c" 1>&6 1056 1091 else 1057 1092 cat > conftest.$ac_ext <<EOF 1058 #line 10 59"configure"1093 #line 1094 "configure" 1059 1094 #include "confdefs.h" 1060 1095 #ifdef __CYGWIN32__ … … 1079 1114 # ditto for mingw32. 1080 1115 echo $ac_n "checking for mingw32""... $ac_c" 1>&6 1081 echo "configure:1 082: checking for mingw32" >&51116 echo "configure:1117: checking for mingw32" >&5 1082 1117 if eval "test \"`echo '$''{'g77_cv_sys_mingw32'+set}'`\" = set"; then 1083 1118 echo $ac_n "(cached) $ac_c" 1>&6 1084 1119 else 1085 1120 cat > conftest.$ac_ext <<EOF 1086 #line 1 087"configure"1121 #line 1122 "configure" 1087 1122 #include "confdefs.h" 1088 1123 #ifdef __MINGW32__ … … 1107 1142 1108 1143 echo $ac_n "checking for working const""... $ac_c" 1>&6 1109 echo "configure:11 10: checking for working const" >&51144 echo "configure:1145: checking for working const" >&5 1110 1145 if eval "test \"`echo '$''{'ac_cv_c_const'+set}'`\" = set"; then 1111 1146 echo $ac_n "(cached) $ac_c" 1>&6 1112 1147 else 1113 1148 cat > conftest.$ac_ext <<EOF 1114 #line 11 15"configure"1149 #line 1150 "configure" 1115 1150 #include "confdefs.h" 1116 1151 … … 1161 1196 ; return 0; } 1162 1197 EOF 1163 if { (eval echo configure:11 64: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then1198 if { (eval echo configure:1199: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then 1164 1199 rm -rf conftest* 1165 1200 ac_cv_c_const=yes … … 1182 1217 1183 1218 echo $ac_n "checking for size_t""... $ac_c" 1>&6 1184 echo "configure:1 185: checking for size_t" >&51219 echo "configure:1220: checking for size_t" >&5 1185 1220 if eval "test \"`echo '$''{'ac_cv_type_size_t'+set}'`\" = set"; then 1186 1221 echo $ac_n "(cached) $ac_c" 1>&6 1187 1222 else 1188 1223 cat > conftest.$ac_ext <<EOF 1189 #line 1 190"configure"1224 #line 1225 "configure" 1190 1225 #include "confdefs.h" 1191 1226 #include <sys/types.h> … … 1220 1255 # (as of cygwin b18). Likewise on mingw. 1221 1256 echo $ac_n "checking for fstat""... $ac_c" 1>&6 1222 echo "configure:12 23: checking for fstat" >&51257 echo "configure:1258: checking for fstat" >&5 1223 1258 if eval "test \"`echo '$''{'ac_cv_func_fstat'+set}'`\" = set"; then 1224 1259 echo $ac_n "(cached) $ac_c" 1>&6 1225 1260 else 1226 1261 cat > conftest.$ac_ext <<EOF 1227 #line 12 28"configure"1262 #line 1263 "configure" 1228 1263 #include "confdefs.h" 1229 1264 /* System header to define __stub macros and hopefully few prototypes, … … 1248 1283 ; return 0; } 1249 1284 EOF 1250 if { (eval echo configure:12 51: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then1285 if { (eval echo configure:1286: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then 1251 1286 rm -rf conftest* 1252 1287 eval "ac_cv_func_fstat=yes" … … 1268 1303 1269 1304 echo $ac_n "checking need for NON_UNIX_STDIO""... $ac_c" 1>&6 1270 echo "configure:1 271: checking need for NON_UNIX_STDIO" >&51305 echo "configure:1306: checking need for NON_UNIX_STDIO" >&5 1271 1306 if test $g77_cv_sys_cygwin32 = yes \ 1272 1307 || test $g77_cv_sys_mingw32 = yes \ … … 1284 1319 do 1285 1320 echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 1286 echo "configure:1 287: checking for $ac_func" >&51321 echo "configure:1322: checking for $ac_func" >&5 1287 1322 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then 1288 1323 echo $ac_n "(cached) $ac_c" 1>&6 1289 1324 else 1290 1325 cat > conftest.$ac_ext <<EOF 1291 #line 1 292"configure"1326 #line 1327 "configure" 1292 1327 #include "confdefs.h" 1293 1328 /* System header to define __stub macros and hopefully few prototypes, … … 1312 1347 ; return 0; } 1313 1348 EOF 1314 if { (eval echo configure:13 15: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then1349 if { (eval echo configure:1350: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then 1315 1350 rm -rf conftest* 1316 1351 eval "ac_cv_func_$ac_func=yes" … … 1339 1374 do 1340 1375 echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 1341 echo "configure:13 42: checking for $ac_func" >&51376 echo "configure:1377: checking for $ac_func" >&5 1342 1377 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then 1343 1378 echo $ac_n "(cached) $ac_c" 1>&6 1344 1379 else 1345 1380 cat > conftest.$ac_ext <<EOF 1346 #line 13 47"configure"1381 #line 1382 "configure" 1347 1382 #include "confdefs.h" 1348 1383 /* System header to define __stub macros and hopefully few prototypes, … … 1367 1402 ; return 0; } 1368 1403 EOF 1369 if { (eval echo configure:1 370: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then1404 if { (eval echo configure:1405: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then 1370 1405 rm -rf conftest* 1371 1406 eval "ac_cv_func_$ac_func=yes" … … 1394 1429 do 1395 1430 echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 1396 echo "configure:1 397: checking for $ac_func" >&51431 echo "configure:1432: checking for $ac_func" >&5 1397 1432 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then 1398 1433 echo $ac_n "(cached) $ac_c" 1>&6 1399 1434 else 1400 1435 cat > conftest.$ac_ext <<EOF 1401 #line 14 02"configure"1436 #line 1437 "configure" 1402 1437 #include "confdefs.h" 1403 1438 /* System header to define __stub macros and hopefully few prototypes, … … 1422 1457 ; return 0; } 1423 1458 EOF 1424 if { (eval echo configure:14 25: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then1459 if { (eval echo configure:1460: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then 1425 1460 rm -rf conftest* 1426 1461 eval "ac_cv_func_$ac_func=yes" … … 1449 1484 do 1450 1485 echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 1451 echo "configure:14 52: checking for $ac_func" >&51486 echo "configure:1487: checking for $ac_func" >&5 1452 1487 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then 1453 1488 echo $ac_n "(cached) $ac_c" 1>&6 1454 1489 else 1455 1490 cat > conftest.$ac_ext <<EOF 1456 #line 14 57"configure"1491 #line 1492 "configure" 1457 1492 #include "confdefs.h" 1458 1493 /* System header to define __stub macros and hopefully few prototypes, … … 1477 1512 ; return 0; } 1478 1513 EOF 1479 if { (eval echo configure:1 480: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then1514 if { (eval echo configure:1515: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then 1480 1515 rm -rf conftest* 1481 1516 eval "ac_cv_func_$ac_func=yes" … … 1504 1539 do 1505 1540 echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 1506 echo "configure:15 07: checking for $ac_func" >&51541 echo "configure:1542: checking for $ac_func" >&5 1507 1542 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then 1508 1543 echo $ac_n "(cached) $ac_c" 1>&6 1509 1544 else 1510 1545 cat > conftest.$ac_ext <<EOF 1511 #line 15 12"configure"1546 #line 1547 "configure" 1512 1547 #include "confdefs.h" 1513 1548 /* System header to define __stub macros and hopefully few prototypes, … … 1532 1567 ; return 0; } 1533 1568 EOF 1534 if { (eval echo configure:15 35: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then1569 if { (eval echo configure:1570: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then 1535 1570 rm -rf conftest* 1536 1571 eval "ac_cv_func_$ac_func=yes" … … 1559 1594 do 1560 1595 echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 1561 echo "configure:15 62: checking for $ac_func" >&51596 echo "configure:1597: checking for $ac_func" >&5 1562 1597 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then 1563 1598 echo $ac_n "(cached) $ac_c" 1>&6 1564 1599 else 1565 1600 cat > conftest.$ac_ext <<EOF 1566 #line 1 567"configure"1601 #line 1602 "configure" 1567 1602 #include "confdefs.h" 1568 1603 /* System header to define __stub macros and hopefully few prototypes, … … 1587 1622 ; return 0; } 1588 1623 EOF 1589 if { (eval echo configure:1 590: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then1624 if { (eval echo configure:1625: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then 1590 1625 rm -rf conftest* 1591 1626 eval "ac_cv_func_$ac_func=yes" … … 1617 1652 # we're posix-conformant, so always do the test. 1618 1653 echo $ac_n "checking for ansi/posix sprintf result""... $ac_c" 1>&6 1619 echo "configure:16 20: checking for ansi/posix sprintf result" >&51654 echo "configure:1655: checking for ansi/posix sprintf result" >&5 1620 1655 if test "$cross_compiling" = yes; then 1621 1656 g77_cv_sys_sprintf_ansi=no 1622 1657 else 1623 1658 cat > conftest.$ac_ext <<EOF 1624 #line 16 25"configure"1659 #line 1660 "configure" 1625 1660 #include "confdefs.h" 1626 1661 #include <stdio.h> … … 1629 1664 1630 1665 EOF 1631 if { (eval echo configure:16 32: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null1666 if { (eval echo configure:1667: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null 1632 1667 then 1633 1668 g77_cv_sys_sprintf_ansi=yes … … 1660 1695 # define NON_ANSI_RW_MODES on unix (can't hurt) 1661 1696 echo $ac_n "checking NON_ANSI_RW_MODES""... $ac_c" 1>&6 1662 echo "configure:16 63: checking NON_ANSI_RW_MODES" >&51697 echo "configure:1698: checking NON_ANSI_RW_MODES" >&5 1663 1698 cat > conftest.$ac_ext <<EOF 1664 #line 1 665"configure"1699 #line 1700 "configure" 1665 1700 #include "confdefs.h" 1666 1701 #ifdef unix … … 1707 1742 1708 1743 echo $ac_n "checking for off_t""... $ac_c" 1>&6 1709 echo "configure:17 10: checking for off_t" >&51744 echo "configure:1745: checking for off_t" >&5 1710 1745 if eval "test \"`echo '$''{'ac_cv_type_off_t'+set}'`\" = set"; then 1711 1746 echo $ac_n "(cached) $ac_c" 1>&6 1712 1747 else 1713 1748 cat > conftest.$ac_ext <<EOF 1714 #line 17 15"configure"1749 #line 1750 "configure" 1715 1750 #include "confdefs.h" 1716 1751 #include <sys/types.h> -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/configure.in
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 24 24 AC_CONFIG_HEADER(config.h) 25 25 26 # These defines are necessary to get 64-bit file size support.27 28 AC_DEFINE(_XOPEN_SOURCE, 500L, [Get Single Unix Specification semantics])29 # The following is needed by irix6.2 so that struct timeval is declared.30 AC_DEFINE(_XOPEN_SOURCE_EXTENDED, 1, [Get Single Unix Specification semantics])31 # The following is needed by Solaris2.5.1 so that struct timeval is declared.32 AC_DEFINE(__EXTENSIONS__, 1, [Solaris extensions])33 AC_DEFINE(_FILE_OFFSET_BITS, 64, [Get 64-bit file size support])34 AC_DEFINE(_LARGEFILE_SOURCE, 1, [Define for HP-UX ftello and fseeko extension.])35 36 dnl Checks for programs.37 38 26 dnl FIXME AC_PROG_CC wants CC to be able to link things, but it may 39 27 dnl not be able to. … … 43 31 # the makefiles 44 32 AC_PROG_CC 33 34 # These defines are necessary to get 64-bit file size support. 35 # NetBSD 1.4 header files does not support XOPEN_SOURCE == 600, but it 36 # handles 64-bit file sizes without needing these defines. 37 AC_MSG_CHECKING(whether _XOPEN_SOURCE may be defined) 38 AC_TRY_COMPILE([#define _XOPEN_SOURCE 600L 39 #include <unistd.h>],, 40 may_use_xopen_source=yes, 41 may_use_xopen_source=no) 42 AC_MSG_RESULT($may_use_xopen_source) 43 if test $may_use_xopen_source = yes; then 44 AC_DEFINE(_XOPEN_SOURCE, 600L, [Get Single Unix Specification semantics]) 45 # The following is needed by irix6.2 so that struct timeval is declared. 46 AC_DEFINE(_XOPEN_SOURCE_EXTENDED, 1, [Get Single Unix Specification semantics]) 47 # The following is needed by Solaris2.5.1 so that struct timeval is declared. 48 AC_DEFINE(__EXTENSIONS__, 1, [Solaris extensions]) 49 AC_DEFINE(_FILE_OFFSET_BITS, 64, [Get 64-bit file size support]) 50 AC_DEFINE(_LARGEFILE_SOURCE, 1, [Define for HP-UX ftello and fseeko extension.]) 51 fi 52 53 dnl Checks for programs. 45 54 46 55 LIBTOOL='$(SHELL) ../libtool' … … 63 72 64 73 AC_HEADER_STDC 65 dnl We could do this if we didn't know we were using gcc66 dnl AC_MSG_CHECKING(for prototype-savvy compiler)67 dnl AC_CACHE_VAL(g77_cv_sys_proto,68 dnl [AC_TRY_LINK(,69 dnl dnl looks screwy because TRY_LINK expects a function body70 dnl [return 0;} int foo (int * bar) {],71 dnl g77_cv_sys_proto=yes,72 dnl [g77_cv_sys_proto=no73 dnl AC_DEFINE(KR_headers)])])74 dnl AC_MSG_RESULT($g77_cv_sys_proto)75 76 74 AC_MSG_CHECKING(for posix) 77 75 AC_CACHE_VAL(g77_cv_header_posix, -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/dfe.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 4 4 #include "fmt.h" 5 5 6 y_rsk(Void) 6 int 7 y_rsk (void) 7 8 { 8 if(f__curunit->uend || f__curunit->url <= f__recpos 9 || f__curunit->url == 1) return 0; 10 do { 11 getc(f__cf); 12 } while(++f__recpos < f__curunit->url); 13 return 0; 14 } 15 y_getc(Void) 16 { 17 int ch; 18 if(f__curunit->uend) return(-1); 19 if((ch=getc(f__cf))!=EOF) 20 { 21 f__recpos++; 22 if(f__curunit->url>=f__recpos || 23 f__curunit->url==1) 24 return(ch); 25 else return(' '); 26 } 27 if(feof(f__cf)) 28 { 29 f__curunit->uend=1; 30 errno=0; 31 return(-1); 32 } 33 err(f__elist->cierr,errno,"readingd"); 9 if (f__curunit->uend || f__curunit->url <= f__recpos 10 || f__curunit->url == 1) 11 return 0; 12 do 13 { 14 getc (f__cf); 15 } 16 while (++f__recpos < f__curunit->url); 17 return 0; 34 18 } 35 19 36 staticint37 y_ rev(Void)20 int 21 y_getc (void) 38 22 { 39 if (f__recpos < f__hiwater) 40 f__recpos = f__hiwater; 41 if (f__curunit->url > 1) 42 while(f__recpos < f__curunit->url) 43 (*f__putn)(' '); 44 if (f__recpos) 45 f__putbuf(0); 46 f__recpos = 0; 47 return(0); 23 int ch; 24 if (f__curunit->uend) 25 return (-1); 26 if ((ch = getc (f__cf)) != EOF) 27 { 28 f__recpos++; 29 if (f__curunit->url >= f__recpos || f__curunit->url == 1) 30 return (ch); 31 else 32 return (' '); 33 } 34 if (feof (f__cf)) 35 { 36 f__curunit->uend = 1; 37 errno = 0; 38 return (-1); 39 } 40 err (f__elist->cierr, errno, "readingd"); 48 41 } 49 42 50 51 y_ err(Void)43 static int 44 y_rev (void) 52 45 { 53 err(f__elist->cierr, 110, "dfe"); 46 if (f__recpos < f__hiwater) 47 f__recpos = f__hiwater; 48 if (f__curunit->url > 1) 49 while (f__recpos < f__curunit->url) 50 (*f__putn) (' '); 51 if (f__recpos) 52 f__putbuf (0); 53 f__recpos = 0; 54 return (0); 54 55 } 55 56 56 57 y_ newrec(Void)57 static int 58 y_err (void) 58 59 { 59 y_rev(); 60 f__hiwater = f__cursor = 0; 61 return(1); 60 err (f__elist->cierr, 110, "dfe"); 62 61 } 63 62 64 #ifdef KR_headers 65 c_dfe(a) cilist *a; 66 #else 67 c_dfe(cilist *a) 68 #endif 63 static int 64 y_newrec (void) 69 65 { 70 f__sequential=0; 71 f__formatted=f__external=1; 72 f__elist=a; 73 f__cursor=f__scale=f__recpos=0; 74 f__curunit = &f__units[a->ciunit]; 75 if(a->ciunit>MXUNIT || a->ciunit<0) 76 err(a->cierr,101,"startchk"); 77 if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit)) 78 err(a->cierr,104,"dfe"); 79 f__cf=f__curunit->ufd; 80 if(!f__curunit->ufmt) err(a->cierr,102,"dfe"); 81 if(!f__curunit->useek) err(a->cierr,104,"dfe"); 82 f__fmtbuf=a->cifmt; 83 if(a->cirec <= 0) 84 err(a->cierr,130,"dfe"); 85 FSEEK(f__cf,(off_t)f__curunit->url * (a->cirec-1),SEEK_SET); 86 f__curunit->uend = 0; 87 return(0); 88 } 89 #ifdef KR_headers 90 integer s_rdfe(a) cilist *a; 91 #else 92 integer s_rdfe(cilist *a) 93 #endif 94 { 95 int n; 96 if(f__init != 1) f_init(); 97 f__init = 3; 98 f__reading=1; 99 if(n=c_dfe(a))return(n); 100 if(f__curunit->uwrt && f__nowreading(f__curunit)) 101 err(a->cierr,errno,"read start"); 102 f__getn = y_getc; 103 f__doed = rd_ed; 104 f__doned = rd_ned; 105 f__dorevert = f__donewrec = y_err; 106 f__doend = y_rsk; 107 if(pars_f(f__fmtbuf)<0) 108 err(a->cierr,100,"read start"); 109 fmt_bg(); 110 return(0); 111 } 112 #ifdef KR_headers 113 integer s_wdfe(a) cilist *a; 114 #else 115 integer s_wdfe(cilist *a) 116 #endif 117 { 118 int n; 119 if(f__init != 1) f_init(); 120 f__init = 3; 121 f__reading=0; 122 if(n=c_dfe(a)) return(n); 123 if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) 124 err(a->cierr,errno,"startwrt"); 125 f__putn = x_putc; 126 f__doed = w_ed; 127 f__doned= w_ned; 128 f__dorevert = y_err; 129 f__donewrec = y_newrec; 130 f__doend = y_rev; 131 if(pars_f(f__fmtbuf)<0) 132 err(a->cierr,100,"startwrt"); 133 fmt_bg(); 134 return(0); 135 } 136 integer e_rdfe(Void) 137 { 138 f__init = 1; 139 en_fio(); 140 return(0); 66 y_rev (); 67 f__hiwater = f__cursor = 0; 68 return (1); 141 69 } 142 70 143 integer e_wdfe(Void) 71 int 72 c_dfe (cilist * a) 144 73 { 145 f__init = 1; 146 return en_fio(); 74 f__sequential = 0; 75 f__formatted = f__external = 1; 76 f__elist = a; 77 f__cursor = f__scale = f__recpos = 0; 78 f__curunit = &f__units[a->ciunit]; 79 if (a->ciunit > MXUNIT || a->ciunit < 0) 80 err (a->cierr, 101, "startchk"); 81 if (f__curunit->ufd == NULL && fk_open (DIR, FMT, a->ciunit)) 82 err (a->cierr, 104, "dfe"); 83 f__cf = f__curunit->ufd; 84 if (!f__curunit->ufmt) 85 err (a->cierr, 102, "dfe"); 86 if (!f__curunit->useek) 87 err (a->cierr, 104, "dfe"); 88 f__fmtbuf = a->cifmt; 89 if (a->cirec <= 0) 90 err (a->cierr, 130, "dfe"); 91 FSEEK (f__cf, (off_t) f__curunit->url * (a->cirec - 1), SEEK_SET); 92 f__curunit->uend = 0; 93 return (0); 147 94 } 95 96 integer 97 s_rdfe (cilist * a) 98 { 99 int n; 100 if (f__init != 1) 101 f_init (); 102 f__init = 3; 103 f__reading = 1; 104 if ((n = c_dfe (a))) 105 return (n); 106 if (f__curunit->uwrt && f__nowreading (f__curunit)) 107 err (a->cierr, errno, "read start"); 108 f__getn = y_getc; 109 f__doed = rd_ed; 110 f__doned = rd_ned; 111 f__dorevert = f__donewrec = y_err; 112 f__doend = y_rsk; 113 if (pars_f (f__fmtbuf) < 0) 114 err (a->cierr, 100, "read start"); 115 fmt_bg (); 116 return (0); 117 } 118 119 integer 120 s_wdfe (cilist * a) 121 { 122 int n; 123 if (f__init != 1) 124 f_init (); 125 f__init = 3; 126 f__reading = 0; 127 if ((n = c_dfe (a))) 128 return (n); 129 if (f__curunit->uwrt != 1 && f__nowwriting (f__curunit)) 130 err (a->cierr, errno, "startwrt"); 131 f__putn = x_putc; 132 f__doed = w_ed; 133 f__doned = w_ned; 134 f__dorevert = y_err; 135 f__donewrec = y_newrec; 136 f__doend = y_rev; 137 if (pars_f (f__fmtbuf) < 0) 138 err (a->cierr, 100, "startwrt"); 139 fmt_bg (); 140 return (0); 141 } 142 143 integer 144 e_rdfe (void) 145 { 146 f__init = 1; 147 en_fio (); 148 return (0); 149 } 150 151 integer 152 e_wdfe (void) 153 { 154 f__init = 1; 155 return en_fio (); 156 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/dolio.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 2 2 #include "f2c.h" 3 3 4 #ifdef __cplusplus 5 extern "C" { 6 #endif 7 #ifdef KR_headers 8 extern int (*f__lioproc)(); 4 extern int (*f__lioproc) (ftnint *, char *, ftnlen, ftnint); 9 5 10 integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len; 11 #else 12 extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); 13 14 integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len) 15 #endif 6 integer 7 do_lio (ftnint * type, ftnint * number, char *ptr, ftnlen len) 16 8 { 17 return((*f__lioproc)(number,ptr,len,*type));9 return ((*f__lioproc) (number, ptr, len, *type)); 18 10 } 19 #ifdef __cplusplus20 }21 #endif -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/due.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 3 3 #include "fio.h" 4 4 5 #ifdef KR_headers 6 c_due(a) cilist *a; 7 #else 8 c_due(cilist *a) 5 int 6 c_due (cilist * a) 7 { 8 if (f__init != 1) 9 f_init (); 10 f__init = 3; 11 if (a->ciunit >= MXUNIT || a->ciunit < 0) 12 err (a->cierr, 101, "startio"); 13 f__sequential = f__formatted = f__recpos = 0; 14 f__external = 1; 15 f__curunit = &f__units[a->ciunit]; 16 if (a->ciunit >= MXUNIT || a->ciunit < 0) 17 err (a->cierr, 101, "startio"); 18 f__elist = a; 19 if (f__curunit->ufd == NULL && fk_open (DIR, UNF, a->ciunit)) 20 err (a->cierr, 104, "due"); 21 f__cf = f__curunit->ufd; 22 if (f__curunit->ufmt) 23 err (a->cierr, 102, "cdue"); 24 if (!f__curunit->useek) 25 err (a->cierr, 104, "cdue"); 26 if (f__curunit->ufd == NULL) 27 err (a->cierr, 114, "cdue"); 28 if (a->cirec <= 0) 29 err (a->cierr, 130, "due"); 30 FSEEK (f__cf, (off_t) (a->cirec - 1) * f__curunit->url, SEEK_SET); 31 f__curunit->uend = 0; 32 return (0); 33 } 34 35 integer 36 s_rdue (cilist * a) 37 { 38 int n; 39 f__reading = 1; 40 if ((n = c_due (a))) 41 return (n); 42 if (f__curunit->uwrt && f__nowreading (f__curunit)) 43 err (a->cierr, errno, "read start"); 44 return (0); 45 } 46 47 integer 48 s_wdue (cilist * a) 49 { 50 int n; 51 f__reading = 0; 52 if ((n = c_due (a))) 53 return (n); 54 if (f__curunit->uwrt != 1 && f__nowwriting (f__curunit)) 55 err (a->cierr, errno, "write start"); 56 return (0); 57 } 58 59 integer 60 e_rdue (void) 61 { 62 f__init = 1; 63 if (f__curunit->url == 1 || f__recpos == f__curunit->url) 64 return (0); 65 FSEEK (f__cf, (off_t) (f__curunit->url - f__recpos), SEEK_CUR); 66 if (FTELL (f__cf) % f__curunit->url) 67 err (f__elist->cierr, 200, "syserr"); 68 return (0); 69 } 70 71 integer 72 e_wdue (void) 73 { 74 f__init = 1; 75 #ifdef ALWAYS_FLUSH 76 if (fflush (f__cf)) 77 err (f__elist->cierr, errno, "write end"); 9 78 #endif 10 { 11 if(f__init != 1) f_init(); 12 f__init = 3; 13 if(a->ciunit>=MXUNIT || a->ciunit<0) 14 err(a->cierr,101,"startio"); 15 f__sequential=f__formatted=f__recpos=0; 16 f__external=1; 17 f__curunit = &f__units[a->ciunit]; 18 if(a->ciunit>=MXUNIT || a->ciunit<0) 19 err(a->cierr,101,"startio"); 20 f__elist=a; 21 if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due"); 22 f__cf=f__curunit->ufd; 23 if(f__curunit->ufmt) err(a->cierr,102,"cdue"); 24 if(!f__curunit->useek) err(a->cierr,104,"cdue"); 25 if(f__curunit->ufd==NULL) err(a->cierr,114,"cdue"); 26 if(a->cirec <= 0) 27 err(a->cierr,130,"due"); 28 FSEEK(f__cf,(off_t)(a->cirec-1)*f__curunit->url,SEEK_SET); 29 f__curunit->uend = 0; 30 return(0); 79 return (e_rdue ()); 31 80 } 32 #ifdef KR_headers33 integer s_rdue(a) cilist *a;34 #else35 integer s_rdue(cilist *a)36 #endif37 {38 int n;39 f__reading=1;40 if(n=c_due(a)) return(n);41 if(f__curunit->uwrt && f__nowreading(f__curunit))42 err(a->cierr,errno,"read start");43 return(0);44 }45 #ifdef KR_headers46 integer s_wdue(a) cilist *a;47 #else48 integer s_wdue(cilist *a)49 #endif50 {51 int n;52 f__reading=0;53 if(n=c_due(a)) return(n);54 if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))55 err(a->cierr,errno,"write start");56 return(0);57 }58 integer e_rdue(Void)59 {60 f__init = 1;61 if(f__curunit->url==1 || f__recpos==f__curunit->url)62 return(0);63 FSEEK(f__cf,(off_t)(f__curunit->url-f__recpos),SEEK_CUR);64 if(FTELL(f__cf)%f__curunit->url)65 err(f__elist->cierr,200,"syserr");66 return(0);67 }68 integer e_wdue(Void)69 {70 f__init = 1;71 #ifdef ALWAYS_FLUSH72 if (fflush(f__cf))73 err(f__elist->cierr,errno,"write end");74 #endif75 return(e_rdue());76 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/endfile.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 6 6 #include <unistd.h> 7 7 8 #ifdef KR_headers9 extern char *strcpy();10 extern FILE *tmpfile();11 #else12 8 #undef abs 13 9 #undef min … … 15 11 #include <stdlib.h> 16 12 #include <string.h> 17 #endif18 13 19 14 extern char *f__r_mode[], *f__w_mode[]; 20 15 21 #ifdef KR_headers 22 integer f_end(a) alist *a; 23 #else 24 integer f_end(alist *a) 25 #endif 16 integer 17 f_end (alist * a) 26 18 { 27 28 19 unit *b; 20 FILE *tf; 29 21 30 if (f__init & 2) 31 f__fatal (131, "I/O recursion"); 32 if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile"); 33 b = &f__units[a->aunit]; 34 if(b->ufd==NULL) { 35 char nbuf[10]; 36 sprintf(nbuf,"fort.%ld",(long)a->aunit); 37 if (tf = fopen(nbuf, f__w_mode[0])) 38 fclose(tf); 39 return(0); 40 } 41 b->uend=1; 42 return(b->useek ? t_runc(a) : 0); 22 if (f__init & 2) 23 f__fatal (131, "I/O recursion"); 24 if (a->aunit >= MXUNIT || a->aunit < 0) 25 err (a->aerr, 101, "endfile"); 26 b = &f__units[a->aunit]; 27 if (b->ufd == NULL) 28 { 29 char nbuf[10]; 30 sprintf (nbuf, "fort.%ld", (long) a->aunit); 31 if ((tf = fopen (nbuf, f__w_mode[0]))) 32 fclose (tf); 33 return (0); 34 } 35 b->uend = 1; 36 return (b->useek ? t_runc (a) : 0); 43 37 } 44 38 45 39 #ifndef HAVE_FTRUNCATE 46 static int 47 #ifdef KR_headers 48 copy(from, len, to) FILE *from, *to; register long len; 49 #else 50 copy(FILE *from, register long len, FILE *to) 51 #endif 40 static int 41 copy (FILE * from, register long len, FILE * to) 52 42 { 53 54 43 int len1; 44 char buf[BUFSIZ]; 55 45 56 while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) { 57 if (!fwrite(buf, len1, 1, to)) 58 return 1; 59 if ((len -= len1) <= 0) 60 break; 61 } 62 return 0; 63 } 46 while (fread (buf, len1 = len > BUFSIZ ? BUFSIZ : (int) len, 1, from)) 47 { 48 if (!fwrite (buf, len1, 1, to)) 49 return 1; 50 if ((len -= len1) <= 0) 51 break; 52 } 53 return 0; 54 } 64 55 #endif /* !defined(HAVE_FTRUNCATE) */ 65 56 66 int 67 #ifdef KR_headers 68 t_runc(a) alist *a; 69 #else 70 t_runc(alist *a) 71 #endif 57 int 58 t_runc (alist * a) 72 59 { 73 74 75 76 60 off_t loc, len; 61 unit *b; 62 int rc; 63 FILE *bf; 77 64 #ifndef HAVE_FTRUNCATE 78 65 FILE *tf; 79 66 #endif /* !defined(HAVE_FTRUNCATE) */ 80 67 81 82 if(b->url)83 return(0); /*don't truncate direct files*/84 loc=FTELL(bf = b->ufd);85 FSEEK(bf,0,SEEK_END);86 len=FTELL(bf);87 88 return(0);68 b = &f__units[a->aunit]; 69 if (b->url) 70 return (0); /*don't truncate direct files */ 71 loc = FTELL (bf = b->ufd); 72 FSEEK (bf, 0, SEEK_END); 73 len = FTELL (bf); 74 if (loc >= len || b->useek == 0 || b->ufnm == NULL) 75 return (0); 89 76 #ifndef HAVE_FTRUNCATE 90 rc = 0; 91 fclose(b->ufd); 92 if (!loc) { 93 if (!(bf = fopen(b->ufnm, f__w_mode[b->ufmt]))) 94 rc = 1; 95 if (b->uwrt) 96 b->uwrt = 1; 97 goto done; 98 } 99 if (!(bf = fopen(b->ufnm, f__r_mode[0])) 100 || !(tf = tmpfile())) { 77 rc = 0; 78 fclose (b->ufd); 79 if (!loc) 80 { 81 if (!(bf = fopen (b->ufnm, f__w_mode[b->ufmt]))) 82 rc = 1; 83 if (b->uwrt) 84 b->uwrt = 1; 85 goto done; 86 } 87 if (!(bf = fopen (b->ufnm, f__r_mode[0])) || !(tf = tmpfile ())) 88 { 101 89 #ifdef NON_UNIX_STDIO 102 bad:90 bad: 103 91 #endif 104 rc = 1; 105 goto done; 106 } 107 if (copy(bf, loc, tf)) { 108 bad1: 109 rc = 1; 110 goto done1; 111 } 112 if (!(bf = freopen(b->ufnm, f__w_mode[0], bf))) 113 goto bad1; 114 FSEEK(tf, 0, SEEK_SET); 115 if (copy(tf, loc, bf)) 116 goto bad1; 117 b->uwrt = 1; 118 b->urw = 2; 92 rc = 1; 93 goto done; 94 } 95 if (copy (bf, loc, tf)) 96 { 97 bad1: 98 rc = 1; 99 goto done1; 100 } 101 if (!(bf = freopen (b->ufnm, f__w_mode[0], bf))) 102 goto bad1; 103 FSEEK (tf, 0, SEEK_SET); 104 if (copy (tf, loc, bf)) 105 goto bad1; 106 b->uwrt = 1; 107 b->urw = 2; 119 108 #ifdef NON_UNIX_STDIO 120 if (b->ufmt) { 121 fclose(bf); 122 if (!(bf = fopen(b->ufnm, f__w_mode[3]))) 123 goto bad; 124 FSEEK(bf,0,SEEK_END); 125 b->urw = 3; 126 } 109 if (b->ufmt) 110 { 111 fclose (bf); 112 if (!(bf = fopen (b->ufnm, f__w_mode[3]))) 113 goto bad; 114 FSEEK (bf, 0, SEEK_END); 115 b->urw = 3; 116 } 127 117 #endif 128 118 done1: 129 fclose(tf);119 fclose (tf); 130 120 done: 131 132 #else 133 fflush(b->ufd);134 rc = ftruncate(fileno(b->ufd), loc);135 FSEEK(bf,loc,SEEK_SET);121 f__cf = b->ufd = bf; 122 #else /* !defined(HAVE_FTRUNCATE) */ 123 fflush (b->ufd); 124 rc = ftruncate (fileno (b->ufd), loc); 125 FSEEK (bf, loc, SEEK_SET); 136 126 #endif /* !defined(HAVE_FTRUNCATE) */ 137 138 err(a->aerr,111,"endfile");139 140 127 if (rc) 128 err (a->aerr, 111, "endfile"); 129 return 0; 130 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/err.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 7 7 #endif 8 8 #include "f2c.h" 9 #ifdef KR_headers10 extern char *malloc();11 #else12 9 #undef abs 13 10 #undef min 14 11 #undef max 15 12 #include <stdlib.h> 16 #endif17 13 #include "fio.h" 18 #include "fmt.h" /* for struct syl */14 #include "fmt.h" /* for struct syl */ 19 15 20 16 /*global definitions*/ 21 unit f__units[MXUNIT]; /*unit table*/22 int f__init; /*bit 0: set after initializations;23 bit 1: set during I/O involving returns to24 caller of library (or calls to user code)*/25 cilist *f__elist; /*active external io list*/26 icilist *f__svic; /*active internal io list*/27 flag f__reading; /*1 if reading, 0 if writing*/28 flag f__cplus, f__cblank;17 unit f__units[MXUNIT]; /*unit table */ 18 int f__init; /*bit 0: set after initializations; 19 bit 1: set during I/O involving returns to 20 caller of library (or calls to user code) */ 21 cilist *f__elist; /*active external io list */ 22 icilist *f__svic; /*active internal io list */ 23 flag f__reading; /*1 if reading, 0 if writing */ 24 flag f__cplus, f__cblank; 29 25 char *f__fmtbuf; 30 26 int f__fmtlen; 31 flag f__external; /*1 if external io, 0 if internal */ 32 #ifdef KR_headers 33 int (*f__doed)(),(*f__doned)(); 34 int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)(); 35 int (*f__getn)(); /* for formatted input */ 36 void (*f__putn)(); /* for formatted output */ 37 #else 38 int (*f__getn)(void); /* for formatted input */ 39 void (*f__putn)(int); /* for formatted output */ 40 int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); 41 int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void); 42 #endif 43 flag f__sequential; /*1 if sequential io, 0 if direct*/ 44 flag f__formatted; /*1 if formatted io, 0 if unformatted*/ 45 FILE *f__cf; /*current file*/ 46 unit *f__curunit; /*current unit*/ 47 int f__recpos; /*place in current record*/ 27 flag f__external; /*1 if external io, 0 if internal */ 28 int (*f__getn) (void); /* for formatted input */ 29 void (*f__putn) (int); /* for formatted output */ 30 int (*f__doed) (struct syl *, char *, ftnlen), (*f__doned) (struct syl *); 31 int (*f__dorevert) (void), (*f__donewrec) (void), (*f__doend) (void); 32 flag f__sequential; /*1 if sequential io, 0 if direct */ 33 flag f__formatted; /*1 if formatted io, 0 if unformatted */ 34 FILE *f__cf; /*current file */ 35 unit *f__curunit; /*current unit */ 36 int f__recpos; /*place in current record */ 48 37 int f__cursor, f__hiwater, f__scale; 49 38 char *f__icptr; 50 39 51 40 /*error messages*/ 52 char *F_err[] = 53 { 54 "error in format", /* 100 */ 55 "illegal unit number", /* 101 */ 56 "formatted io not allowed", /* 102 */ 57 "unformatted io not allowed", /* 103 */ 58 "direct io not allowed", /* 104 */ 59 "sequential io not allowed", /* 105 */ 60 "can't backspace file", /* 106 */ 61 "null file name", /* 107 */ 62 "can't stat file", /* 108 */ 63 "unit not connected", /* 109 */ 64 "off end of record", /* 110 */ 65 "truncation failed in endfile", /* 111 */ 66 "incomprehensible list input", /* 112 */ 67 "out of free space", /* 113 */ 68 "unit not connected", /* 114 */ 69 "read unexpected character", /* 115 */ 70 "bad logical input field", /* 116 */ 71 "bad variable type", /* 117 */ 72 "bad namelist name", /* 118 */ 73 "variable not in namelist", /* 119 */ 74 "no end record", /* 120 */ 75 "variable count incorrect", /* 121 */ 76 "subscript for scalar variable", /* 122 */ 77 "invalid array section", /* 123 */ 78 "substring out of bounds", /* 124 */ 79 "subscript out of bounds", /* 125 */ 80 "can't read file", /* 126 */ 81 "can't write file", /* 127 */ 82 "'new' file exists", /* 128 */ 83 "can't append to file", /* 129 */ 84 "non-positive record number", /* 130 */ 85 "I/O started while already doing I/O", /* 131 */ 86 "Temporary file name (TMPDIR?) too long" /* 132 */ 41 char *F_err[] = { 42 "error in format", /* 100 */ 43 "illegal unit number", /* 101 */ 44 "formatted io not allowed", /* 102 */ 45 "unformatted io not allowed", /* 103 */ 46 "direct io not allowed", /* 104 */ 47 "sequential io not allowed", /* 105 */ 48 "can't backspace file", /* 106 */ 49 "null file name", /* 107 */ 50 "can't stat file", /* 108 */ 51 "unit not connected", /* 109 */ 52 "off end of record", /* 110 */ 53 "truncation failed in endfile", /* 111 */ 54 "incomprehensible list input", /* 112 */ 55 "out of free space", /* 113 */ 56 "unit not connected", /* 114 */ 57 "read unexpected character", /* 115 */ 58 "bad logical input field", /* 116 */ 59 "bad variable type", /* 117 */ 60 "bad namelist name", /* 118 */ 61 "variable not in namelist", /* 119 */ 62 "no end record", /* 120 */ 63 "variable count incorrect", /* 121 */ 64 "subscript for scalar variable", /* 122 */ 65 "invalid array section", /* 123 */ 66 "substring out of bounds", /* 124 */ 67 "subscript out of bounds", /* 125 */ 68 "can't read file", /* 126 */ 69 "can't write file", /* 127 */ 70 "'new' file exists", /* 128 */ 71 "can't append to file", /* 129 */ 72 "non-positive record number", /* 130 */ 73 "I/O started while already doing I/O", /* 131 */ 74 "Temporary file name (TMPDIR?) too long" /* 132 */ 87 75 }; 88 76 #define MAXERR (sizeof(F_err)/sizeof(char *)+100) 89 77 90 #ifdef KR_headers 91 f__canseek(f) FILE *f; /*SYSDEP*/ 78 int 79 f__canseek (FILE * f) /*SYSDEP*/ 80 { 81 #ifdef NON_UNIX_STDIO 82 return !isatty (fileno (f)); 92 83 #else 93 f__canseek(FILE *f) /*SYSDEP*/ 94 #endif 95 { 96 #ifdef NON_UNIX_STDIO 97 return !isatty(fileno(f)); 98 #else 99 struct stat x; 100 101 if (fstat(fileno(f),&x) < 0) 102 return(0); 84 struct stat x; 85 86 if (fstat (fileno (f), &x) < 0) 87 return (0); 103 88 #ifdef S_IFMT 104 switch(x.st_mode & S_IFMT) { 105 case S_IFDIR: 106 case S_IFREG: 107 if(x.st_nlink > 0) /* !pipe */ 108 return(1); 109 else 110 return(0); 111 case S_IFCHR: 112 if(isatty(fileno(f))) 113 return(0); 114 return(1); 89 switch (x.st_mode & S_IFMT) 90 { 91 case S_IFDIR: 92 case S_IFREG: 93 if (x.st_nlink > 0) /* !pipe */ 94 return (1); 95 else 96 return (0); 97 case S_IFCHR: 98 if (isatty (fileno (f))) 99 return (0); 100 return (1); 115 101 #ifdef S_IFBLK 116 117 return(1);118 #endif 119 102 case S_IFBLK: 103 return (1); 104 #endif 105 } 120 106 #else 121 107 #ifdef S_ISDIR 122 /* POSIX version */ 123 if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) { 124 if(x.st_nlink > 0) /* !pipe */ 125 return(1); 126 else 127 return(0); 128 } 129 if (S_ISCHR(x.st_mode)) { 130 if(isatty(fileno(f))) 131 return(0); 132 return(1); 133 } 134 if (S_ISBLK(x.st_mode)) 135 return(1); 108 /* POSIX version */ 109 if (S_ISREG (x.st_mode) || S_ISDIR (x.st_mode)) 110 { 111 if (x.st_nlink > 0) /* !pipe */ 112 return (1); 113 else 114 return (0); 115 } 116 if (S_ISCHR (x.st_mode)) 117 { 118 if (isatty (fileno (f))) 119 return (0); 120 return (1); 121 } 122 if (S_ISBLK (x.st_mode)) 123 return (1); 136 124 #else 137 Help! How does fstat work on this system? 138 #endif 139 #endif 140 return(0); /* who knows what it is? */ 141 #endif 142 } 143 144 void 145 #ifdef KR_headers 146 f__fatal(n,s) char *s; 147 #else 148 f__fatal(int n, char *s) 149 #endif 150 { 151 static int dead = 0; 152 153 if(n<100 && n>=0) perror(s); /*SYSDEP*/ 154 else if(n >= (int)MAXERR || n < -1) 155 { fprintf(stderr,"%s: illegal error number %d\n",s,n); 125 Help ! How does fstat work on this system ? 126 #endif 127 #endif 128 return (0); /* who knows what it is? */ 129 #endif 130 } 131 132 void 133 f__fatal (int n, char *s) 134 { 135 static int dead = 0; 136 137 if (n < 100 && n >= 0) 138 perror (s); 139 /*SYSDEP*/ 140 else if (n >= (int) MAXERR || n < -1) 141 { 142 fprintf (stderr, "%s: illegal error number %d\n", s, n); 143 } 144 else if (n == -1) 145 fprintf (stderr, "%s: end of file\n", s); 146 else 147 fprintf (stderr, "%s: %s\n", s, F_err[n - 100]); 148 if (dead) 149 { 150 fprintf (stderr, "(libf2c f__fatal already called, aborting.)"); 151 abort (); 152 } 153 dead = 1; 154 if (f__init & 1) 155 { 156 if (f__curunit) 157 { 158 fprintf (stderr, "apparent state: unit %d ", 159 (int) (f__curunit - f__units)); 160 fprintf (stderr, f__curunit->ufnm ? "named %s\n" : "(unnamed)\n", 161 f__curunit->ufnm); 156 162 } 157 else if(n == -1) fprintf(stderr,"%s: end of file\n",s); 158 else 159 fprintf(stderr,"%s: %s\n",s,F_err[n-100]); 160 if (dead) { 161 fprintf (stderr, "(libf2c f__fatal already called, aborting.)"); 162 abort(); 163 else 164 fprintf (stderr, "apparent state: internal I/O\n"); 165 if (f__fmtbuf) 166 fprintf (stderr, "last format: %.*s\n", f__fmtlen, f__fmtbuf); 167 fprintf (stderr, "lately %s %s %s %s", 168 f__reading ? "reading" : "writing", 169 f__sequential ? "sequential" : "direct", 170 f__formatted ? "formatted" : "unformatted", 171 f__external ? "external" : "internal"); 172 } 173 f__init &= ~2; /* No longer doing I/O (no more user code to be called). */ 174 sig_die (" IO", 1); 175 } 176 177 /*initialization routine*/ 178 void 179 f_init (void) 180 { 181 unit *p; 182 183 if (f__init & 2) 184 f__fatal (131, "I/O recursion"); 185 f__init = 1; 186 p = &f__units[0]; 187 p->ufd = stderr; 188 p->useek = f__canseek (stderr); 189 p->ufmt = 1; 190 p->uwrt = 1; 191 p = &f__units[5]; 192 p->ufd = stdin; 193 p->useek = f__canseek (stdin); 194 p->ufmt = 1; 195 p->uwrt = 0; 196 p = &f__units[6]; 197 p->ufd = stdout; 198 p->useek = f__canseek (stdout); 199 p->ufmt = 1; 200 p->uwrt = 1; 201 } 202 203 int 204 f__nowreading (unit * x) 205 { 206 off_t loc; 207 int ufmt, urw; 208 extern char *f__r_mode[], *f__w_mode[]; 209 210 if (x->urw & 1) 211 goto done; 212 if (!x->ufnm) 213 goto cantread; 214 ufmt = x->url ? 0 : x->ufmt; 215 loc = FTELL (x->ufd); 216 urw = 3; 217 if (!freopen (x->ufnm, f__w_mode[ufmt | 2], x->ufd)) 218 { 219 urw = 1; 220 if (!freopen (x->ufnm, f__r_mode[ufmt], x->ufd)) 221 { 222 cantread: 223 errno = 126; 224 return 1; 163 225 } 164 dead = 1; 165 if (f__init & 1) { 166 if (f__curunit) { 167 fprintf(stderr,"apparent state: unit %d ", 168 (int)(f__curunit-f__units)); 169 fprintf(stderr, f__curunit->ufnm ? "named %s\n" : "(unnamed)\n", 170 f__curunit->ufnm); 171 } 172 else 173 fprintf(stderr,"apparent state: internal I/O\n"); 174 if (f__fmtbuf) 175 fprintf(stderr,"last format: %.*s\n",f__fmtlen,f__fmtbuf); 176 fprintf(stderr,"lately %s %s %s %s",f__reading?"reading":"writing", 177 f__sequential?"sequential":"direct",f__formatted?"formatted":"unformatted", 178 f__external?"external":"internal"); 226 } 227 FSEEK (x->ufd, loc, SEEK_SET); 228 x->urw = urw; 229 done: 230 x->uwrt = 0; 231 return 0; 232 } 233 234 int 235 f__nowwriting (unit * x) 236 { 237 off_t loc; 238 int ufmt; 239 extern char *f__w_mode[]; 240 241 if (x->urw & 2) 242 goto done; 243 if (!x->ufnm) 244 goto cantwrite; 245 ufmt = x->url ? 0 : x->ufmt; 246 if (x->uwrt == 3) 247 { /* just did write, rewind */ 248 if (!(f__cf = x->ufd = freopen (x->ufnm, f__w_mode[ufmt], x->ufd))) 249 goto cantwrite; 250 x->urw = 2; 251 } 252 else 253 { 254 loc = FTELL (x->ufd); 255 if (!(f__cf = x->ufd = freopen (x->ufnm, f__w_mode[ufmt |= 2], x->ufd))) 256 { 257 x->ufd = NULL; 258 cantwrite: 259 errno = 127; 260 return (1); 179 261 } 180 f__init &= ~2; /* No longer doing I/O (no more user code to be called). */ 181 sig_die(" IO", 1); 182 } 183 /*initialization routine*/ 184 VOID 185 f_init(Void) 186 { unit *p; 187 188 if (f__init & 2) 189 f__fatal (131, "I/O recursion"); 190 f__init = 1; 191 p= &f__units[0]; 192 p->ufd=stderr; 193 p->useek=f__canseek(stderr); 194 p->ufmt=1; 195 p->uwrt=1; 196 p = &f__units[5]; 197 p->ufd=stdin; 198 p->useek=f__canseek(stdin); 199 p->ufmt=1; 200 p->uwrt=0; 201 p= &f__units[6]; 202 p->ufd=stdout; 203 p->useek=f__canseek(stdout); 204 p->ufmt=1; 205 p->uwrt=1; 206 } 207 #ifdef KR_headers 208 f__nowreading(x) unit *x; 209 #else 210 f__nowreading(unit *x) 211 #endif 212 { 213 off_t loc; 214 int ufmt, urw; 215 extern char *f__r_mode[], *f__w_mode[]; 216 217 if (x->urw & 1) 218 goto done; 219 if (!x->ufnm) 220 goto cantread; 221 ufmt = x->url ? 0 : x->ufmt; 222 loc = FTELL(x->ufd); 223 urw = 3; 224 if (!freopen(x->ufnm, f__w_mode[ufmt|2], x->ufd)) { 225 urw = 1; 226 if(!freopen(x->ufnm, f__r_mode[ufmt], x->ufd)) { 227 cantread: 228 errno = 126; 229 return 1; 230 } 231 } 232 FSEEK(x->ufd,loc,SEEK_SET); 233 x->urw = urw; 234 done: 235 x->uwrt = 0; 236 return 0; 237 } 238 #ifdef KR_headers 239 f__nowwriting(x) unit *x; 240 #else 241 f__nowwriting(unit *x) 242 #endif 243 { 244 off_t loc; 245 int ufmt; 246 extern char *f__w_mode[]; 247 248 if (x->urw & 2) 249 goto done; 250 if (!x->ufnm) 251 goto cantwrite; 252 ufmt = x->url ? 0 : x->ufmt; 253 if (x->uwrt == 3) { /* just did write, rewind */ 254 if (!(f__cf = x->ufd = 255 freopen(x->ufnm,f__w_mode[ufmt],x->ufd))) 256 goto cantwrite; 257 x->urw = 2; 258 } 259 else { 260 loc=FTELL(x->ufd); 261 if (!(f__cf = x->ufd = 262 freopen(x->ufnm, f__w_mode[ufmt |= 2], x->ufd))) 263 { 264 x->ufd = NULL; 265 cantwrite: 266 errno = 127; 267 return(1); 268 } 269 x->urw = 3; 270 FSEEK(x->ufd,loc,SEEK_SET); 271 } 272 done: 273 x->uwrt = 1; 274 return 0; 275 } 276 277 int 278 #ifdef KR_headers 279 err__fl(f, m, s) int f, m; char *s; 280 #else 281 err__fl(int f, int m, char *s) 282 #endif 283 { 284 if (!f) 285 f__fatal(m, s); 286 if (f__doend) 287 (*f__doend)(); 288 f__init &= ~2; 289 return errno = m; 290 } 262 x->urw = 3; 263 FSEEK (x->ufd, loc, SEEK_SET); 264 } 265 done: 266 x->uwrt = 1; 267 return 0; 268 } 269 270 int 271 err__fl (int f, int m, char *s) 272 { 273 if (!f) 274 f__fatal (m, s); 275 if (f__doend) 276 (*f__doend) (); 277 f__init &= ~2; 278 return errno = m; 279 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/f2ch.add
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 3 3 4 4 #ifdef __cplusplus 5 extern "C" { 6 extern int abort_(void); 7 extern double c_abs(complex *); 8 extern void c_cos(complex *, complex *); 9 extern void c_div(complex *, complex *, complex *); 10 extern void c_exp(complex *, complex *); 11 extern void c_log(complex *, complex *); 12 extern void c_sin(complex *, complex *); 13 extern void c_sqrt(complex *, complex *); 14 extern double d_abs(double *); 15 extern double d_acos(double *); 16 extern double d_asin(double *); 17 extern double d_atan(double *); 18 extern double d_atn2(double *, double *); 19 extern void d_cnjg(doublecomplex *, doublecomplex *); 20 extern double d_cos(double *); 21 extern double d_cosh(double *); 22 extern double d_dim(double *, double *); 23 extern double d_exp(double *); 24 extern double d_imag(doublecomplex *); 25 extern double d_int(double *); 26 extern double d_lg10(double *); 27 extern double d_log(double *); 28 extern double d_mod(double *, double *); 29 extern double d_nint(double *); 30 extern double d_prod(float *, float *); 31 extern double d_sign(double *, double *); 32 extern double d_sin(double *); 33 extern double d_sinh(double *); 34 extern double d_sqrt(double *); 35 extern double d_tan(double *); 36 extern double d_tanh(double *); 37 extern double derf_(double *); 38 extern double derfc_(double *); 39 extern integer do_fio(ftnint *, char *, ftnlen); 40 extern integer do_lio(ftnint *, ftnint *, char *, ftnlen); 41 extern integer do_uio(ftnint *, char *, ftnlen); 42 extern integer e_rdfe(void); 43 extern integer e_rdue(void); 44 extern integer e_rsfe(void); 45 extern integer e_rsfi(void); 46 extern integer e_rsle(void); 47 extern integer e_rsli(void); 48 extern integer e_rsue(void); 49 extern integer e_wdfe(void); 50 extern integer e_wdue(void); 51 extern integer e_wsfe(void); 52 extern integer e_wsfi(void); 53 extern integer e_wsle(void); 54 extern integer e_wsli(void); 55 extern integer e_wsue(void); 56 extern int ef1asc_(ftnint *, ftnlen *, ftnint *, ftnlen *); 57 extern integer ef1cmc_(ftnint *, ftnlen *, ftnint *, ftnlen *); 58 extern double erf(double); 59 extern double erf_(float *); 60 extern double erfc(double); 61 extern double erfc_(float *); 62 extern integer f_back(alist *); 63 extern integer f_clos(cllist *); 64 extern integer f_end(alist *); 65 extern void f_exit(void); 66 extern integer f_inqu(inlist *); 67 extern integer f_open(olist *); 68 extern integer f_rew(alist *); 69 extern int flush_(void); 70 extern void getarg_(integer *, char *, ftnlen); 71 extern void getenv_(char *, char *, ftnlen, ftnlen); 72 extern short h_abs(short *); 73 extern short h_dim(short *, short *); 74 extern short h_dnnt(double *); 75 extern short h_indx(char *, char *, ftnlen, ftnlen); 76 extern short h_len(char *, ftnlen); 77 extern short h_mod(short *, short *); 78 extern short h_nint(float *); 79 extern short h_sign(short *, short *); 80 extern short hl_ge(char *, char *, ftnlen, ftnlen); 81 extern short hl_gt(char *, char *, ftnlen, ftnlen); 82 extern short hl_le(char *, char *, ftnlen, ftnlen); 83 extern short hl_lt(char *, char *, ftnlen, ftnlen); 84 extern integer i_abs(integer *); 85 extern integer i_dim(integer *, integer *); 86 extern integer i_dnnt(double *); 87 extern integer i_indx(char *, char *, ftnlen, ftnlen); 88 extern integer i_len(char *, ftnlen); 89 extern integer i_mod(integer *, integer *); 90 extern integer i_nint(float *); 91 extern integer i_sign(integer *, integer *); 92 extern integer iargc_(void); 93 extern ftnlen l_ge(char *, char *, ftnlen, ftnlen); 94 extern ftnlen l_gt(char *, char *, ftnlen, ftnlen); 95 extern ftnlen l_le(char *, char *, ftnlen, ftnlen); 96 extern ftnlen l_lt(char *, char *, ftnlen, ftnlen); 97 extern void pow_ci(complex *, complex *, integer *); 98 extern double pow_dd(double *, double *); 99 extern double pow_di(double *, integer *); 100 extern short pow_hh(short *, shortint *); 101 extern integer pow_ii(integer *, integer *); 102 extern double pow_ri(float *, integer *); 103 extern void pow_zi(doublecomplex *, doublecomplex *, integer *); 104 extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *); 105 extern double r_abs(float *); 106 extern double r_acos(float *); 107 extern double r_asin(float *); 108 extern double r_atan(float *); 109 extern double r_atn2(float *, float *); 110 extern void r_cnjg(complex *, complex *); 111 extern double r_cos(float *); 112 extern double r_cosh(float *); 113 extern double r_dim(float *, float *); 114 extern double r_exp(float *); 115 extern double r_imag(complex *); 116 extern double r_int(float *); 117 extern double r_lg10(float *); 118 extern double r_log(float *); 119 extern double r_mod(float *, float *); 120 extern double r_nint(float *); 121 extern double r_sign(float *, float *); 122 extern double r_sin(float *); 123 extern double r_sinh(float *); 124 extern double r_sqrt(float *); 125 extern double r_tan(float *); 126 extern double r_tanh(float *); 127 extern void s_cat(char *, char **, integer *, integer *, ftnlen); 128 extern integer s_cmp(char *, char *, ftnlen, ftnlen); 129 extern void s_copy(char *, char *, ftnlen, ftnlen); 130 extern int s_paus(char *, ftnlen); 131 extern integer s_rdfe(cilist *); 132 extern integer s_rdue(cilist *); 133 extern integer s_rnge(char *, integer, char *, integer); 134 extern integer s_rsfe(cilist *); 135 extern integer s_rsfi(icilist *); 136 extern integer s_rsle(cilist *); 137 extern integer s_rsli(icilist *); 138 extern integer s_rsne(cilist *); 139 extern integer s_rsni(icilist *); 140 extern integer s_rsue(cilist *); 141 extern int s_stop(char *, ftnlen); 142 extern integer s_wdfe(cilist *); 143 extern integer s_wdue(cilist *); 144 extern integer s_wsfe(cilist *); 145 extern integer s_wsfi(icilist *); 146 extern integer s_wsle(cilist *); 147 extern integer s_wsli(icilist *); 148 extern integer s_wsne(cilist *); 149 extern integer s_wsni(icilist *); 150 extern integer s_wsue(cilist *); 151 extern void sig_die(char *, int); 152 extern integer signal_(integer *, void (*)(int)); 153 extern integer system_(char *, ftnlen); 154 extern double z_abs(doublecomplex *); 155 extern void z_cos(doublecomplex *, doublecomplex *); 156 extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *); 157 extern void z_exp(doublecomplex *, doublecomplex *); 158 extern void z_log(doublecomplex *, doublecomplex *); 159 extern void z_sin(doublecomplex *, doublecomplex *); 160 extern void z_sqrt(doublecomplex *, doublecomplex *); 161 } 5 extern "C" 6 { 7 extern int abort_ (void); 8 extern double c_abs (complex *); 9 extern void c_cos (complex *, complex *); 10 extern void c_div (complex *, complex *, complex *); 11 extern void c_exp (complex *, complex *); 12 extern void c_log (complex *, complex *); 13 extern void c_sin (complex *, complex *); 14 extern void c_sqrt (complex *, complex *); 15 extern double d_abs (double *); 16 extern double d_acos (double *); 17 extern double d_asin (double *); 18 extern double d_atan (double *); 19 extern double d_atn2 (double *, double *); 20 extern void d_cnjg (doublecomplex *, doublecomplex *); 21 extern double d_cos (double *); 22 extern double d_cosh (double *); 23 extern double d_dim (double *, double *); 24 extern double d_exp (double *); 25 extern double d_imag (doublecomplex *); 26 extern double d_int (double *); 27 extern double d_lg10 (double *); 28 extern double d_log (double *); 29 extern double d_mod (double *, double *); 30 extern double d_nint (double *); 31 extern double d_prod (float *, float *); 32 extern double d_sign (double *, double *); 33 extern double d_sin (double *); 34 extern double d_sinh (double *); 35 extern double d_sqrt (double *); 36 extern double d_tan (double *); 37 extern double d_tanh (double *); 38 extern double derf_ (double *); 39 extern double derfc_ (double *); 40 extern integer do_fio (ftnint *, char *, ftnlen); 41 extern integer do_lio (ftnint *, ftnint *, char *, ftnlen); 42 extern integer do_uio (ftnint *, char *, ftnlen); 43 extern integer e_rdfe (void); 44 extern integer e_rdue (void); 45 extern integer e_rsfe (void); 46 extern integer e_rsfi (void); 47 extern integer e_rsle (void); 48 extern integer e_rsli (void); 49 extern integer e_rsue (void); 50 extern integer e_wdfe (void); 51 extern integer e_wdue (void); 52 extern integer e_wsfe (void); 53 extern integer e_wsfi (void); 54 extern integer e_wsle (void); 55 extern integer e_wsli (void); 56 extern integer e_wsue (void); 57 extern int ef1asc_ (ftnint *, ftnlen *, ftnint *, ftnlen *); 58 extern integer ef1cmc_ (ftnint *, ftnlen *, ftnint *, ftnlen *); 59 extern double erf (double); 60 extern double erf_ (float *); 61 extern double erfc (double); 62 extern double erfc_ (float *); 63 extern integer f_back (alist *); 64 extern integer f_clos (cllist *); 65 extern integer f_end (alist *); 66 extern void f_exit (void); 67 extern integer f_inqu (inlist *); 68 extern integer f_open (olist *); 69 extern integer f_rew (alist *); 70 extern int flush_ (void); 71 extern void getarg_ (integer *, char *, ftnlen); 72 extern void getenv_ (char *, char *, ftnlen, ftnlen); 73 extern short h_abs (short *); 74 extern short h_dim (short *, short *); 75 extern short h_dnnt (double *); 76 extern short h_indx (char *, char *, ftnlen, ftnlen); 77 extern short h_len (char *, ftnlen); 78 extern short h_mod (short *, short *); 79 extern short h_nint (float *); 80 extern short h_sign (short *, short *); 81 extern short hl_ge (char *, char *, ftnlen, ftnlen); 82 extern short hl_gt (char *, char *, ftnlen, ftnlen); 83 extern short hl_le (char *, char *, ftnlen, ftnlen); 84 extern short hl_lt (char *, char *, ftnlen, ftnlen); 85 extern integer i_abs (integer *); 86 extern integer i_dim (integer *, integer *); 87 extern integer i_dnnt (double *); 88 extern integer i_indx (char *, char *, ftnlen, ftnlen); 89 extern integer i_len (char *, ftnlen); 90 extern integer i_mod (integer *, integer *); 91 extern integer i_nint (float *); 92 extern integer i_sign (integer *, integer *); 93 extern integer iargc_ (void); 94 extern ftnlen l_ge (char *, char *, ftnlen, ftnlen); 95 extern ftnlen l_gt (char *, char *, ftnlen, ftnlen); 96 extern ftnlen l_le (char *, char *, ftnlen, ftnlen); 97 extern ftnlen l_lt (char *, char *, ftnlen, ftnlen); 98 extern void pow_ci (complex *, complex *, integer *); 99 extern double pow_dd (double *, double *); 100 extern double pow_di (double *, integer *); 101 extern short pow_hh (short *, shortint *); 102 extern integer pow_ii (integer *, integer *); 103 extern double pow_ri (float *, integer *); 104 extern void pow_zi (doublecomplex *, doublecomplex *, integer *); 105 extern void pow_zz (doublecomplex *, doublecomplex *, doublecomplex *); 106 extern double r_abs (float *); 107 extern double r_acos (float *); 108 extern double r_asin (float *); 109 extern double r_atan (float *); 110 extern double r_atn2 (float *, float *); 111 extern void r_cnjg (complex *, complex *); 112 extern double r_cos (float *); 113 extern double r_cosh (float *); 114 extern double r_dim (float *, float *); 115 extern double r_exp (float *); 116 extern double r_imag (complex *); 117 extern double r_int (float *); 118 extern double r_lg10 (float *); 119 extern double r_log (float *); 120 extern double r_mod (float *, float *); 121 extern double r_nint (float *); 122 extern double r_sign (float *, float *); 123 extern double r_sin (float *); 124 extern double r_sinh (float *); 125 extern double r_sqrt (float *); 126 extern double r_tan (float *); 127 extern double r_tanh (float *); 128 extern void s_cat (char *, char **, integer *, integer *, ftnlen); 129 extern integer s_cmp (char *, char *, ftnlen, ftnlen); 130 extern void s_copy (char *, char *, ftnlen, ftnlen); 131 extern int s_paus (char *, ftnlen); 132 extern integer s_rdfe (cilist *); 133 extern integer s_rdue (cilist *); 134 extern integer s_rnge (char *, integer, char *, integer); 135 extern integer s_rsfe (cilist *); 136 extern integer s_rsfi (icilist *); 137 extern integer s_rsle (cilist *); 138 extern integer s_rsli (icilist *); 139 extern integer s_rsne (cilist *); 140 extern integer s_rsni (icilist *); 141 extern integer s_rsue (cilist *); 142 extern int s_stop (char *, ftnlen); 143 extern integer s_wdfe (cilist *); 144 extern integer s_wdue (cilist *); 145 extern integer s_wsfe (cilist *); 146 extern integer s_wsfi (icilist *); 147 extern integer s_wsle (cilist *); 148 extern integer s_wsli (icilist *); 149 extern integer s_wsne (cilist *); 150 extern integer s_wsni (icilist *); 151 extern integer s_wsue (cilist *); 152 extern void sig_die (char *, int); 153 extern integer signal_ (integer *, void (*)(int)); 154 extern integer system_ (char *, ftnlen); 155 extern double z_abs (doublecomplex *); 156 extern void z_cos (doublecomplex *, doublecomplex *); 157 extern void z_div (doublecomplex *, doublecomplex *, doublecomplex *); 158 extern void z_exp (doublecomplex *, doublecomplex *); 159 extern void z_log (doublecomplex *, doublecomplex *); 160 extern void z_sin (doublecomplex *, doublecomplex *); 161 extern void z_sqrt (doublecomplex *, doublecomplex *); 162 } 162 163 #endif -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/fio.h
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 40 40 /*units*/ 41 41 typedef struct 42 { FILE *ufd; /*0=unconnected*/ 43 char *ufnm; 42 { 43 FILE *ufd; /*0=unconnected */ 44 char *ufnm; 44 45 #if !(defined (MSDOS) && !defined (GO32)) 45 46 46 long uinode; 47 int udev; 47 48 #endif 48 int url; /*0=sequential*/ 49 flag useek; /*true=can backspace, use dir, ...*/ 50 flag ufmt; 51 flag urw; /* (1 for can read) | (2 for can write) */ 52 flag ublnk; 53 flag uend; 54 flag uwrt; /*last io was write*/ 55 flag uscrtch; 56 } unit; 49 int url; /*0=sequential */ 50 flag useek; /*true=can backspace, use dir, ... */ 51 flag ufmt; 52 flag urw; /* (1 for can read) | (2 for can write) */ 53 flag ublnk; 54 flag uend; 55 flag uwrt; /*last io was write */ 56 flag uscrtch; 57 } 58 unit; 57 59 58 60 extern int f__init; 59 extern cilist *f__elist; /*active external io list*/ 60 extern flag f__reading,f__external,f__sequential,f__formatted; 61 #undef Void 62 #ifdef KR_headers 63 #define Void /*void*/ 64 extern int (*f__getn)(); /* for formatted input */ 65 extern void (*f__putn)(); /* for formatted output */ 66 extern void x_putc(); 67 extern long f__inode(); 68 extern VOID sig_die(); 69 extern int (*f__donewrec)(), t_putc(), x_wSL(); 70 extern int c_sfe(), err__fl(), xrd_SL(), f__putbuf(); 71 #else 72 #define Void void 73 #ifdef __cplusplus 74 extern "C" { 75 #endif 76 extern int (*f__getn)(void); /* for formatted input */ 77 extern void (*f__putn)(int); /* for formatted output */ 78 extern void x_putc(int); 79 extern long f__inode(char*,int*); 80 extern void sig_die(char*,int); 81 extern void f__fatal(int,char*); 82 extern int t_runc(alist*); 83 extern int f__nowreading(unit*), f__nowwriting(unit*); 84 extern int fk_open(int,int,ftnint); 85 extern int en_fio(void); 86 extern void f_init(void); 87 extern int (*f__donewrec)(void), t_putc(int), x_wSL(void); 88 extern void b_char(char*,char*,ftnlen), g_char(char*,ftnlen,char*); 89 extern int c_sfe(cilist*), z_rnew(void); 90 extern int isatty(int); 91 extern int err__fl(int,int,char*); 92 extern int xrd_SL(void); 93 extern int f__putbuf(int); 94 #ifdef __cplusplus 95 } 96 #endif 97 #endif 98 extern int (*f__doend)(Void); 99 extern FILE *f__cf; /*current file*/ 100 extern unit *f__curunit; /*current unit*/ 61 extern cilist *f__elist; /*active external io list */ 62 extern flag f__reading, f__external, f__sequential, f__formatted; 63 extern int (*f__getn) (void); /* for formatted input */ 64 extern void (*f__putn) (int); /* for formatted output */ 65 extern void x_putc (int); 66 extern long f__inode (char *, int *); 67 extern void sig_die (char *, int); 68 extern void f__fatal (int, char *); 69 extern int t_runc (alist *); 70 extern int f__nowreading (unit *), f__nowwriting (unit *); 71 extern int fk_open (int, int, ftnint); 72 extern int en_fio (void); 73 extern void f_init (void); 74 extern int (*f__donewrec) (void), t_putc (int), x_wSL (void); 75 extern void b_char (char *, char *, ftnlen), g_char (char *, ftnlen, char *); 76 extern int c_sfe (cilist *), z_rnew (void); 77 extern int isatty (int); 78 extern int err__fl (int, int, char *); 79 extern int xrd_SL (void); 80 extern int f__putbuf (int); 81 extern int (*f__doend) (void); 82 extern FILE *f__cf; /*current file */ 83 extern unit *f__curunit; /*current unit */ 101 84 extern unit f__units[]; 102 85 #define err(f,m,s) do {if(f) {f__init &= ~2; errno= m;} else f__fatal(m,s); return(m);} while(0) … … 106 89 #define MXUNIT 100 107 90 108 extern int f__recpos; /*position in current record*/109 extern int f__cursor; /* offset to move to */110 extern int f__hiwater; /* so TL doesn't confuse us */91 extern int f__recpos; /*position in current record */ 92 extern int f__cursor; /* offset to move to */ 93 extern int f__hiwater; /* so TL doesn't confuse us */ 111 94 112 95 #define WRITE 1 -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/fmt.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 18 18 #define GLITCH '\2' 19 19 /* special quote character for stu */ 20 extern int f__cursor, f__scale;21 extern flag f__cblank, f__cplus; /*blanks in I and compulsory plus*/20 extern int f__cursor, f__scale; 21 extern flag f__cblank, f__cplus; /*blanks in I and compulsory plus */ 22 22 static struct syl f__syl[SYLMX]; 23 int f__parenlvl,f__pc,f__revloc; 24 25 static 26 #ifdef KR_headers 27 char *ap_end(s) char *s; 28 #else 29 char *ap_end(char *s) 30 #endif 31 { char quote; 32 quote= *s++; 33 for(;*s;s++) 34 { if(*s!=quote) continue; 35 if(*++s!=quote) return(s); 36 } 37 if(f__elist->cierr) { 38 errno = 100; 39 return(NULL); 40 } 41 f__fatal(100, "bad string"); 42 /*NOTREACHED*/ return 0; 43 } 44 static 45 #ifdef KR_headers 46 op_gen(a,b,c,d) 47 #else 48 op_gen(int a, int b, int c, int d) 49 #endif 50 { struct syl *p= &f__syl[f__pc]; 51 if(f__pc>=SYLMX) 52 { fprintf(stderr,"format too complicated:\n"); 53 sig_die(f__fmtbuf, 1); 54 } 55 p->op=a; 56 p->p1=b; 57 p->p2.i[0]=c; 58 p->p2.i[1]=d; 59 return(f__pc++); 60 } 61 #ifdef KR_headers 62 static char *f_list(); 63 static char *gt_num(s,n,n1) char *s; int *n, n1; 64 #else 65 static char *f_list(char*); 66 static char *gt_num(char *s, int *n, int n1) 67 #endif 68 { int m=0,f__cnt=0; 69 char c; 70 for(c= *s;;c = *s) 71 { if(c==' ') 72 { s++; 73 continue; 74 } 75 if(c>'9' || c<'0') break; 76 m=10*m+c-'0'; 77 f__cnt++; 78 s++; 79 } 80 if(f__cnt==0) { 81 if (!n1) 82 s = 0; 83 *n=n1; 84 } 85 else *n=m; 86 return(s); 87 } 88 89 static 90 #ifdef KR_headers 91 char *f_s(s,curloc) char *s; 92 #else 93 char *f_s(char *s, int curloc) 94 #endif 95 { 96 skip(s); 97 if(*s++!='(') 98 { 99 return(NULL); 100 } 101 if(f__parenlvl++ ==1) f__revloc=curloc; 102 if(op_gen(RET1,curloc,0,0)<0 || 103 (s=f_list(s))==NULL) 104 { 105 return(NULL); 106 } 107 return(s); 108 } 109 110 static 111 #ifdef KR_headers 112 ne_d(s,p) char *s,**p; 113 #else 114 ne_d(char *s, char **p) 115 #endif 116 { int n,x,sign=0; 117 struct syl *sp; 118 switch(*s) 23 int f__parenlvl, f__pc, f__revloc; 24 25 static char * 26 ap_end (char *s) 27 { 28 char quote; 29 quote = *s++; 30 for (; *s; s++) 31 { 32 if (*s != quote) 33 continue; 34 if (*++s != quote) 35 return (s); 36 } 37 if (f__elist->cierr) 38 { 39 errno = 100; 40 return (NULL); 41 } 42 f__fatal (100, "bad string"); 43 /*NOTREACHED*/ return 0; 44 } 45 46 static int 47 op_gen (int a, int b, int c, int d) 48 { 49 struct syl *p = &f__syl[f__pc]; 50 if (f__pc >= SYLMX) 51 { 52 fprintf (stderr, "format too complicated:\n"); 53 sig_die (f__fmtbuf, 1); 54 } 55 p->op = a; 56 p->p1 = b; 57 p->p2.i[0] = c; 58 p->p2.i[1] = d; 59 return (f__pc++); 60 } 61 static char *f_list (char *); 62 static char * 63 gt_num (char *s, int *n, int n1) 64 { 65 int m = 0, f__cnt = 0; 66 char c; 67 for (c = *s;; c = *s) 68 { 69 if (c == ' ') 70 { 71 s++; 72 continue; 73 } 74 if (c > '9' || c < '0') 75 break; 76 m = 10 * m + c - '0'; 77 f__cnt++; 78 s++; 79 } 80 if (f__cnt == 0) 81 { 82 if (!n1) 83 s = 0; 84 *n = n1; 85 } 86 else 87 *n = m; 88 return (s); 89 } 90 91 static char * 92 f_s (char *s, int curloc) 93 { 94 skip (s); 95 if (*s++ != '(') 96 { 97 return (NULL); 98 } 99 if (f__parenlvl++ == 1) 100 f__revloc = curloc; 101 if (op_gen (RET1, curloc, 0, 0) < 0 || (s = f_list (s)) == NULL) 102 { 103 return (NULL); 104 } 105 return (s); 106 } 107 108 static int 109 ne_d (char *s, char **p) 110 { 111 int n, x, sign = 0; 112 struct syl *sp; 113 switch (*s) 114 { 115 default: 116 return (0); 117 case ':': 118 (void) op_gen (COLON, 0, 0, 0); 119 break; 120 case '$': 121 (void) op_gen (NONL, 0, 0, 0); 122 break; 123 case 'B': 124 case 'b': 125 if (*++s == 'z' || *s == 'Z') 126 (void) op_gen (BZ, 0, 0, 0); 127 else 128 (void) op_gen (BN, 0, 0, 0); 129 break; 130 case 'S': 131 case 's': 132 if (*(s + 1) == 's' || *(s + 1) == 'S') 133 { 134 x = SS; 135 s++; 136 } 137 else if (*(s + 1) == 'p' || *(s + 1) == 'P') 138 { 139 x = SP; 140 s++; 141 } 142 else 143 x = S; 144 (void) op_gen (x, 0, 0, 0); 145 break; 146 case '/': 147 (void) op_gen (SLASH, 0, 0, 0); 148 break; 149 case '-': 150 sign = 1; 151 case '+': 152 s++; /*OUTRAGEOUS CODING TRICK */ 153 case '0': 154 case '1': 155 case '2': 156 case '3': 157 case '4': 158 case '5': 159 case '6': 160 case '7': 161 case '8': 162 case '9': 163 if (!(s = gt_num (s, &n, 0))) 164 { 165 bad:*p = 0; 166 return 1; 167 } 168 switch (*s) 119 169 { 120 170 default: 121 return(0); 122 case ':': (void) op_gen(COLON,0,0,0); break; 123 case '$': 124 (void) op_gen(NONL, 0, 0, 0); break; 125 case 'B': 126 case 'b': 127 if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0); 128 else (void) op_gen(BN,0,0,0); 129 break; 130 case 'S': 131 case 's': 132 if(*(s+1)=='s' || *(s+1) == 'S') 133 { x=SS; 134 s++; 135 } 136 else if(*(s+1)=='p' || *(s+1) == 'P') 137 { x=SP; 138 s++; 139 } 140 else x=S; 141 (void) op_gen(x,0,0,0); 142 break; 143 case '/': (void) op_gen(SLASH,0,0,0); break; 144 case '-': sign=1; 145 case '+': s++; /*OUTRAGEOUS CODING TRICK*/ 146 case '0': case '1': case '2': case '3': case '4': 147 case '5': case '6': case '7': case '8': case '9': 148 if (!(s=gt_num(s,&n,0))) { 149 bad: *p = 0; 150 return 1; 151 } 152 switch(*s) 153 { 154 default: 155 return(0); 156 case 'P': 157 case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break; 158 case 'X': 159 case 'x': (void) op_gen(X,n,0,0); break; 160 case 'H': 161 case 'h': 162 sp = &f__syl[op_gen(H,n,0,0)]; 163 sp->p2.s = s + 1; 164 s+=n; 165 break; 166 } 167 break; 168 case GLITCH: 169 case '"': 170 case '\'': 171 sp = &f__syl[op_gen(APOS,0,0,0)]; 172 sp->p2.s = s; 173 if((*p = ap_end(s)) == NULL) 174 return(0); 175 return(1); 176 case 'T': 177 case 't': 178 if(*(s+1)=='l' || *(s+1) == 'L') 179 { x=TL; 180 s++; 181 } 182 else if(*(s+1)=='r'|| *(s+1) == 'R') 183 { x=TR; 184 s++; 185 } 186 else x=T; 187 if (!(s=gt_num(s+1,&n,0))) 188 goto bad; 189 s--; 190 (void) op_gen(x,n,0,0); 191 break; 171 return (0); 172 case 'P': 173 case 'p': 174 if (sign) 175 n = -n; 176 (void) op_gen (P, n, 0, 0); 177 break; 192 178 case 'X': 193 case 'x': (void) op_gen(X,1,0,0); break; 194 case 'P': 195 case 'p': (void) op_gen(P,1,0,0); break; 196 } 179 case 'x': 180 (void) op_gen (X, n, 0, 0); 181 break; 182 case 'H': 183 case 'h': 184 sp = &f__syl[op_gen (H, n, 0, 0)]; 185 sp->p2.s = s + 1; 186 s += n; 187 break; 188 } 189 break; 190 case GLITCH: 191 case '"': 192 case '\'': 193 sp = &f__syl[op_gen (APOS, 0, 0, 0)]; 194 sp->p2.s = s; 195 if ((*p = ap_end (s)) == NULL) 196 return (0); 197 return (1); 198 case 'T': 199 case 't': 200 if (*(s + 1) == 'l' || *(s + 1) == 'L') 201 { 202 x = TL; 203 s++; 204 } 205 else if (*(s + 1) == 'r' || *(s + 1) == 'R') 206 { 207 x = TR; 208 s++; 209 } 210 else 211 x = T; 212 if (!(s = gt_num (s + 1, &n, 0))) 213 goto bad; 214 s--; 215 (void) op_gen (x, n, 0, 0); 216 break; 217 case 'X': 218 case 'x': 219 (void) op_gen (X, 1, 0, 0); 220 break; 221 case 'P': 222 case 'p': 223 (void) op_gen (P, 1, 0, 0); 224 break; 225 } 226 s++; 227 *p = s; 228 return (1); 229 } 230 231 static int 232 e_d (char *s, char **p) 233 { 234 int i, im, n, w, d, e, found = 0, x = 0; 235 char *sv = s; 236 s = gt_num (s, &n, 1); 237 (void) op_gen (STACK, n, 0, 0); 238 switch (*s++) 239 { 240 default: 241 break; 242 case 'E': 243 case 'e': 244 x = 1; 245 case 'G': 246 case 'g': 247 found = 1; 248 if (!(s = gt_num (s, &w, 0))) 249 { 250 bad: 251 *p = 0; 252 return 1; 253 } 254 if (w == 0) 255 break; 256 if (*s == '.') 257 { 258 if (!(s = gt_num (s + 1, &d, 0))) 259 goto bad; 260 } 261 else 262 d = 0; 263 if (*s != 'E' && *s != 'e') 264 (void) op_gen (x == 1 ? E : G, w, d, 0); /* default is Ew.dE2 */ 265 else 266 { 267 if (!(s = gt_num (s + 1, &e, 0))) 268 goto bad; 269 (void) op_gen (x == 1 ? EE : GE, w, d, e); 270 } 271 break; 272 case 'O': 273 case 'o': 274 i = O; 275 im = OM; 276 goto finish_I; 277 case 'Z': 278 case 'z': 279 i = Z; 280 im = ZM; 281 goto finish_I; 282 case 'L': 283 case 'l': 284 found = 1; 285 if (!(s = gt_num (s, &w, 0))) 286 goto bad; 287 if (w == 0) 288 break; 289 (void) op_gen (L, w, 0, 0); 290 break; 291 case 'A': 292 case 'a': 293 found = 1; 294 skip (s); 295 if (*s >= '0' && *s <= '9') 296 { 297 s = gt_num (s, &w, 1); 298 if (w == 0) 299 break; 300 (void) op_gen (AW, w, 0, 0); 301 break; 302 } 303 (void) op_gen (A, 0, 0, 0); 304 break; 305 case 'F': 306 case 'f': 307 if (!(s = gt_num (s, &w, 0))) 308 goto bad; 309 found = 1; 310 if (w == 0) 311 break; 312 if (*s == '.') 313 { 314 if (!(s = gt_num (s + 1, &d, 0))) 315 goto bad; 316 } 317 else 318 d = 0; 319 (void) op_gen (F, w, d, 0); 320 break; 321 case 'D': 322 case 'd': 323 found = 1; 324 if (!(s = gt_num (s, &w, 0))) 325 goto bad; 326 if (w == 0) 327 break; 328 if (*s == '.') 329 { 330 if (!(s = gt_num (s + 1, &d, 0))) 331 goto bad; 332 } 333 else 334 d = 0; 335 (void) op_gen (D, w, d, 0); 336 break; 337 case 'I': 338 case 'i': 339 i = I; 340 im = IM; 341 finish_I: 342 if (!(s = gt_num (s, &w, 0))) 343 goto bad; 344 found = 1; 345 if (w == 0) 346 break; 347 if (*s != '.') 348 { 349 (void) op_gen (i, w, 0, 0); 350 break; 351 } 352 if (!(s = gt_num (s + 1, &d, 0))) 353 goto bad; 354 (void) op_gen (im, w, d, 0); 355 break; 356 } 357 if (found == 0) 358 { 359 f__pc--; /*unSTACK */ 360 *p = sv; 361 return (0); 362 } 363 *p = s; 364 return (1); 365 } 366 static char * 367 i_tem (char *s) 368 { 369 char *t; 370 int n, curloc; 371 if (*s == ')') 372 return (s); 373 if (ne_d (s, &t)) 374 return (t); 375 if (e_d (s, &t)) 376 return (t); 377 s = gt_num (s, &n, 1); 378 if ((curloc = op_gen (STACK, n, 0, 0)) < 0) 379 return (NULL); 380 return (f_s (s, curloc)); 381 } 382 383 static char * 384 f_list (char *s) 385 { 386 for (; *s != 0;) 387 { 388 skip (s); 389 if ((s = i_tem (s)) == NULL) 390 return (NULL); 391 skip (s); 392 if (*s == ',') 197 393 s++; 198 *p=s; 199 return(1); 200 } 201 202 static 203 #ifdef KR_headers 204 e_d(s,p) char *s,**p; 205 #else 206 e_d(char *s, char **p) 207 #endif 208 { int i,im,n,w,d,e,found=0,x=0; 209 char *sv=s; 210 s=gt_num(s,&n,1); 211 (void) op_gen(STACK,n,0,0); 212 switch(*s++) 213 { 214 default: break; 215 case 'E': 216 case 'e': x=1; 217 case 'G': 218 case 'g': 219 found=1; 220 if (!(s=gt_num(s,&w,0))) { 221 bad: 222 *p = 0; 223 return 1; 224 } 225 if(w==0) break; 226 if(*s=='.') { 227 if (!(s=gt_num(s+1,&d,0))) 228 goto bad; 229 } 230 else d=0; 231 if(*s!='E' && *s != 'e') 232 (void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */ 233 else { 234 if (!(s=gt_num(s+1,&e,0))) 235 goto bad; 236 (void) op_gen(x==1?EE:GE,w,d,e); 237 } 238 break; 239 case 'O': 240 case 'o': 241 i = O; 242 im = OM; 243 goto finish_I; 244 case 'Z': 245 case 'z': 246 i = Z; 247 im = ZM; 248 goto finish_I; 249 case 'L': 250 case 'l': 251 found=1; 252 if (!(s=gt_num(s,&w,0))) 253 goto bad; 254 if(w==0) break; 255 (void) op_gen(L,w,0,0); 256 break; 257 case 'A': 258 case 'a': 259 found=1; 260 skip(s); 261 if(*s>='0' && *s<='9') 262 { s=gt_num(s,&w,1); 263 if(w==0) break; 264 (void) op_gen(AW,w,0,0); 265 break; 266 } 267 (void) op_gen(A,0,0,0); 268 break; 269 case 'F': 270 case 'f': 271 if (!(s=gt_num(s,&w,0))) 272 goto bad; 273 found=1; 274 if(w==0) break; 275 if(*s=='.') { 276 if (!(s=gt_num(s+1,&d,0))) 277 goto bad; 278 } 279 else d=0; 280 (void) op_gen(F,w,d,0); 281 break; 282 case 'D': 283 case 'd': 284 found=1; 285 if (!(s=gt_num(s,&w,0))) 286 goto bad; 287 if(w==0) break; 288 if(*s=='.') { 289 if (!(s=gt_num(s+1,&d,0))) 290 goto bad; 291 } 292 else d=0; 293 (void) op_gen(D,w,d,0); 294 break; 295 case 'I': 296 case 'i': 297 i = I; 298 im = IM; 299 finish_I: 300 if (!(s=gt_num(s,&w,0))) 301 goto bad; 302 found=1; 303 if(w==0) break; 304 if(*s!='.') 305 { (void) op_gen(i,w,0,0); 306 break; 307 } 308 if (!(s=gt_num(s+1,&d,0))) 309 goto bad; 310 (void) op_gen(im,w,d,0); 311 break; 312 } 313 if(found==0) 314 { f__pc--; /*unSTACK*/ 315 *p=sv; 316 return(0); 317 } 318 *p=s; 319 return(1); 320 } 321 static 322 #ifdef KR_headers 323 char *i_tem(s) char *s; 324 #else 325 char *i_tem(char *s) 326 #endif 327 { char *t; 328 int n,curloc; 329 if(*s==')') return(s); 330 if(ne_d(s,&t)) return(t); 331 if(e_d(s,&t)) return(t); 332 s=gt_num(s,&n,1); 333 if((curloc=op_gen(STACK,n,0,0))<0) return(NULL); 334 return(f_s(s,curloc)); 335 } 336 337 static 338 #ifdef KR_headers 339 char *f_list(s) char *s; 340 #else 341 char *f_list(char *s) 342 #endif 343 { 344 for(;*s!=0;) 345 { skip(s); 346 if((s=i_tem(s))==NULL) return(NULL); 347 skip(s); 348 if(*s==',') s++; 349 else if(*s==')') 350 { if(--f__parenlvl==0) 351 { 352 (void) op_gen(REVERT,f__revloc,0,0); 353 return(++s); 354 } 355 (void) op_gen(GOTO,0,0,0); 356 return(++s); 357 } 358 } 359 return(NULL); 360 } 361 362 #ifdef KR_headers 363 pars_f(s) char *s; 364 #else 365 pars_f(char *s) 366 #endif 367 { 368 char *e; 369 370 f__parenlvl=f__revloc=f__pc=0; 371 if((e=f_s(s,0)) == NULL) 372 { 373 /* Try and delimit the format string. Parens within 374 hollerith and quoted strings have to match for this 375 to work, but it's probably adequate for most needs. 376 Note that this is needed because a valid CHARACTER 377 variable passed for FMT= can contain '(I)garbage', 378 where `garbage' is billions and billions of junk 379 characters, and it's up to the run-time library to 380 know where the format string ends by counting parens. 381 Meanwhile, still treat NUL byte as "hard stop", since 382 f2c still appends that at end of FORMAT-statement 383 strings. */ 384 385 int level=0; 386 387 for (f__fmtlen=0; 388 ((*s!=')') || (--level > 0)) 389 && (*s!='\0') 390 && (f__fmtlen<80); 391 ++s, ++f__fmtlen) 392 { 393 if (*s=='(') 394 ++level; 395 } 396 if (*s==')') 397 ++f__fmtlen; 398 return(-1); 399 } 400 f__fmtlen = e - s; 401 return(0); 402 } 394 else if (*s == ')') 395 { 396 if (--f__parenlvl == 0) 397 { 398 (void) op_gen (REVERT, f__revloc, 0, 0); 399 return (++s); 400 } 401 (void) op_gen (GOTO, 0, 0, 0); 402 return (++s); 403 } 404 } 405 return (NULL); 406 } 407 408 int 409 pars_f (char *s) 410 { 411 char *e; 412 413 f__parenlvl = f__revloc = f__pc = 0; 414 if ((e = f_s (s, 0)) == NULL) 415 { 416 /* Try and delimit the format string. Parens within 417 hollerith and quoted strings have to match for this 418 to work, but it's probably adequate for most needs. 419 Note that this is needed because a valid CHARACTER 420 variable passed for FMT= can contain '(I)garbage', 421 where `garbage' is billions and billions of junk 422 characters, and it's up to the run-time library to 423 know where the format string ends by counting parens. 424 Meanwhile, still treat NUL byte as "hard stop", since 425 f2c still appends that at end of FORMAT-statement 426 strings. */ 427 428 int level = 0; 429 430 for (f__fmtlen = 0; 431 ((*s != ')') || (--level > 0)) 432 && (*s != '\0') && (f__fmtlen < 80); ++s, ++f__fmtlen) 433 { 434 if (*s == '(') 435 ++level; 436 } 437 if (*s == ')') 438 ++f__fmtlen; 439 return (-1); 440 } 441 f__fmtlen = e - s; 442 return (0); 443 } 444 403 445 #define STKSZ 10 404 int f__cnt[STKSZ], f__ret[STKSZ],f__cp,f__rp;446 int f__cnt[STKSZ], f__ret[STKSZ], f__cp, f__rp; 405 447 flag f__workdone, f__nonl; 406 448 407 static 408 #ifdef KR_headers 409 type_f(n) 410 #else 411 type_f(int n) 412 #endif 413 { 414 switch(n) 449 static int 450 type_f (int n) 451 { 452 switch (n) 453 { 454 default: 455 return (n); 456 case RET1: 457 return (RET1); 458 case REVERT: 459 return (REVERT); 460 case GOTO: 461 return (GOTO); 462 case STACK: 463 return (STACK); 464 case X: 465 case SLASH: 466 case APOS: 467 case H: 468 case T: 469 case TL: 470 case TR: 471 return (NED); 472 case F: 473 case I: 474 case IM: 475 case A: 476 case AW: 477 case O: 478 case OM: 479 case L: 480 case E: 481 case EE: 482 case D: 483 case G: 484 case GE: 485 case Z: 486 case ZM: 487 return (ED); 488 } 489 } 490 integer 491 do_fio (ftnint * number, char *ptr, ftnlen len) 492 { 493 struct syl *p; 494 int n, i; 495 for (i = 0; i < *number; i++, ptr += len) 496 { 497 loop:switch (type_f ((p = &f__syl[f__pc])->op)) 415 498 { 416 499 default: 417 return(n); 500 fprintf (stderr, "unknown code in do_fio: %d\n%.*s\n", 501 p->op, f__fmtlen, f__fmtbuf); 502 err (f__elist->cierr, 100, "do_fio"); 503 case NED: 504 if ((*f__doned) (p)) 505 { 506 f__pc++; 507 goto loop; 508 } 509 f__pc++; 510 continue; 511 case ED: 512 if (f__cnt[f__cp] <= 0) 513 { 514 f__cp--; 515 f__pc++; 516 goto loop; 517 } 518 if (ptr == NULL) 519 return ((*f__doend) ()); 520 f__cnt[f__cp]--; 521 f__workdone = 1; 522 if ((n = (*f__doed) (p, ptr, len)) > 0) 523 errfl (f__elist->cierr, errno, "fmt"); 524 if (n < 0) 525 err (f__elist->ciend, (EOF), "fmt"); 526 continue; 527 case STACK: 528 f__cnt[++f__cp] = p->p1; 529 f__pc++; 530 goto loop; 418 531 case RET1: 419 return(RET1); 420 case REVERT: return(REVERT); 421 case GOTO: return(GOTO); 422 case STACK: return(STACK); 423 case X: 424 case SLASH: 425 case APOS: case H: 426 case T: case TL: case TR: 427 return(NED); 428 case F: 429 case I: 430 case IM: 431 case A: case AW: 432 case O: case OM: 433 case L: 434 case E: case EE: case D: 435 case G: case GE: 436 case Z: case ZM: 437 return(ED); 438 } 439 } 440 #ifdef KR_headers 441 integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr; 442 #else 443 integer do_fio(ftnint *number, char *ptr, ftnlen len) 444 #endif 445 { struct syl *p; 446 int n,i; 447 for(i=0;i<*number;i++,ptr+=len) 448 { 449 loop: switch(type_f((p= &f__syl[f__pc])->op)) 450 { 451 default: 452 fprintf(stderr,"unknown code in do_fio: %d\n%.*s\n", 453 p->op,f__fmtlen,f__fmtbuf); 454 err(f__elist->cierr,100,"do_fio"); 455 case NED: 456 if((*f__doned)(p)) 457 { f__pc++; 458 goto loop; 459 } 460 f__pc++; 461 continue; 462 case ED: 463 if(f__cnt[f__cp]<=0) 464 { f__cp--; 465 f__pc++; 466 goto loop; 467 } 468 if(ptr==NULL) 469 return((*f__doend)()); 470 f__cnt[f__cp]--; 471 f__workdone=1; 472 if((n=(*f__doed)(p,ptr,len))>0) 473 errfl(f__elist->cierr,errno,"fmt"); 474 if(n<0) 475 err(f__elist->ciend,(EOF),"fmt"); 476 continue; 477 case STACK: 478 f__cnt[++f__cp]=p->p1; 479 f__pc++; 480 goto loop; 481 case RET1: 482 f__ret[++f__rp]=p->p1; 483 f__pc++; 484 goto loop; 532 f__ret[++f__rp] = p->p1; 533 f__pc++; 534 goto loop; 485 535 case GOTO: 486 if(--f__cnt[f__cp]<=0) 487 { f__cp--; 488 f__rp--; 489 f__pc++; 490 goto loop; 491 } 492 f__pc=1+f__ret[f__rp--]; 493 goto loop; 536 if (--f__cnt[f__cp] <= 0) 537 { 538 f__cp--; 539 f__rp--; 540 f__pc++; 541 goto loop; 542 } 543 f__pc = 1 + f__ret[f__rp--]; 544 goto loop; 494 545 case REVERT: 495 f__rp=f__cp=0; 496 f__pc = p->p1; 497 if(ptr==NULL) 498 return((*f__doend)()); 499 if(!f__workdone) return(0); 500 if((n=(*f__dorevert)()) != 0) return(n); 501 goto loop; 546 f__rp = f__cp = 0; 547 f__pc = p->p1; 548 if (ptr == NULL) 549 return ((*f__doend) ()); 550 if (!f__workdone) 551 return (0); 552 if ((n = (*f__dorevert) ()) != 0) 553 return (n); 554 goto loop; 502 555 case COLON: 503 if(ptr==NULL)504 return((*f__doend)());505 506 556 if (ptr == NULL) 557 return ((*f__doend) ()); 558 f__pc++; 559 goto loop; 507 560 case NONL: 508 509 510 561 f__nonl = 1; 562 f__pc++; 563 goto loop; 511 564 case S: 512 565 case SS: 513 f__cplus=0;514 515 566 f__cplus = 0; 567 f__pc++; 568 goto loop; 516 569 case SP: 517 f__cplus = 1; 518 f__pc++; 519 goto loop; 520 case P: f__scale=p->p1; 521 f__pc++; 522 goto loop; 570 f__cplus = 1; 571 f__pc++; 572 goto loop; 573 case P: 574 f__scale = p->p1; 575 f__pc++; 576 goto loop; 523 577 case BN: 524 f__cblank=0;525 526 578 f__cblank = 0; 579 f__pc++; 580 goto loop; 527 581 case BZ: 528 f__cblank=1; 529 f__pc++; 530 goto loop; 531 } 532 } 533 return(0); 534 } 535 en_fio(Void) 536 { ftnint one=1; 537 return(do_fio(&one,(char *)NULL,(ftnint)0)); 538 } 539 VOID 540 fmt_bg(Void) 541 { 542 f__workdone=f__cp=f__rp=f__pc=f__cursor=0; 543 f__cnt[0]=f__ret[0]=0; 544 } 582 f__cblank = 1; 583 f__pc++; 584 goto loop; 585 } 586 } 587 return (0); 588 } 589 590 int 591 en_fio (void) 592 { 593 ftnint one = 1; 594 return (do_fio (&one, (char *) NULL, (ftnint) 0)); 595 } 596 597 void 598 fmt_bg (void) 599 { 600 f__workdone = f__cp = f__rp = f__pc = f__cursor = 0; 601 f__cnt[0] = f__ret[0] = 0; 602 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/fmt.h
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 1 1 struct syl 2 { int op; 3 int p1; 4 union { int i[2]; char *s;} p2; 5 }; 2 { 3 int op; 4 int p1; 5 union 6 { 7 int i[2]; 8 char *s; 9 } 10 p2; 11 }; 6 12 #define RET1 1 7 13 #define REVERT 2 … … 40 46 #define Z 35 41 47 #define ZM 36 42 extern int f__pc, f__parenlvl,f__revloc;48 extern int f__pc, f__parenlvl, f__revloc; 43 49 typedef union 44 { real pf; 45 doublereal pd; 46 } ufloat; 50 { 51 real pf; 52 doublereal pd; 53 } 54 ufloat; 47 55 typedef union 48 { short is; 49 #ifndef KR_headers 50 signed 56 { 57 short is; 58 signed char ic; 59 integer il; 60 #ifdef Allow_TYQUAD 61 longint ili; 51 62 #endif 52 char ic; 53 integer il; 54 #ifdef Allow_TYQUAD 55 longint ili; 56 #endif 57 } Uint; 58 #ifdef KR_headers 59 extern int (*f__doed)(),(*f__doned)(); 60 extern int (*f__dorevert)(); 61 extern int rd_ed(),rd_ned(); 62 extern int w_ed(),w_ned(); 63 #else 64 #ifdef __cplusplus 65 extern "C" { 66 #endif 67 extern int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); 68 extern int (*f__dorevert)(void); 69 extern void fmt_bg(void); 70 extern int pars_f(char*); 71 extern int rd_ed(struct syl*, char*, ftnlen),rd_ned(struct syl*); 72 extern int w_ed(struct syl*, char*, ftnlen),w_ned(struct syl*); 73 extern int wrt_E(ufloat*, int, int, int, ftnlen); 74 extern int wrt_F(ufloat*, int, int, ftnlen); 75 extern int wrt_L(Uint*, int, ftnlen); 76 #ifdef __cplusplus 77 } 78 #endif 79 #endif 80 extern flag f__cblank,f__cplus,f__workdone, f__nonl; 63 } 64 Uint; 65 extern int (*f__doed) (struct syl *, char *, ftnlen), 66 (*f__doned) (struct syl *); 67 extern int (*f__dorevert) (void); 68 extern void fmt_bg (void); 69 extern int pars_f (char *); 70 extern int rd_ed (struct syl *, char *, ftnlen), rd_ned (struct syl *); 71 extern int w_ed (struct syl *, char *, ftnlen), w_ned (struct syl *); 72 extern int wrt_E (ufloat *, int, int, int, ftnlen); 73 extern int wrt_F (ufloat *, int, int, ftnlen); 74 extern int wrt_L (Uint *, int, ftnlen); 75 extern flag f__cblank, f__cplus, f__workdone, f__nonl; 81 76 extern char *f__fmtbuf; 82 77 extern int f__fmtlen; … … 95 90 #endif 96 91 97 #ifdef KR_headers 98 extern char *f__icvt(); 99 #else 100 extern char *f__icvt(longint, int*, int*, int); 101 #endif 92 extern char *f__icvt (longint, int *, int *, int); -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/fmtlib.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 11 11 #endif 12 12 13 #ifdef KR_headers 14 char *f__icvt(value,ndigit,sign, base) longint value; int *ndigit,*sign; 15 register int base; 16 #else 17 char *f__icvt(longint value, int *ndigit, int *sign, int base) 18 #endif 13 char * 14 f__icvt (longint value, int *ndigit, int *sign, int base) 19 15 { 20 static char buf[MAXINTLENGTH+1];21 22 16 static char buf[MAXINTLENGTH + 1]; 17 register int i; 18 ulongint uvalue; 23 19 24 if(value > 0) { 25 uvalue = value; 26 *sign = 0; 27 } 28 else if (value < 0) { 29 uvalue = -value; 30 *sign = 1; 31 } 32 else { 33 *sign = 0; 34 *ndigit = 1; 35 buf[MAXINTLENGTH-1] = '0'; 36 return &buf[MAXINTLENGTH-1]; 37 } 38 i = MAXINTLENGTH; 39 do { 40 buf[--i] = (uvalue%base) + '0'; 41 uvalue /= base; 42 } 43 while(uvalue > 0); 44 *ndigit = MAXINTLENGTH - i; 45 return &buf[i]; 46 } 20 if (value > 0) 21 { 22 uvalue = value; 23 *sign = 0; 24 } 25 else if (value < 0) 26 { 27 uvalue = -value; 28 *sign = 1; 29 } 30 else 31 { 32 *sign = 0; 33 *ndigit = 1; 34 buf[MAXINTLENGTH - 1] = '0'; 35 return &buf[MAXINTLENGTH - 1]; 36 } 37 i = MAXINTLENGTH; 38 do 39 { 40 buf[--i] = (uvalue % base) + '0'; 41 uvalue /= base; 42 } 43 while (uvalue > 0); 44 *ndigit = MAXINTLENGTH - i; 45 return &buf[i]; 46 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/fp.h
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 5 5 /* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */ 6 6 7 #ifdef V10 7 #ifdef V10 /* Research Tenth-Edition Unix */ 8 8 #include "local.h" 9 9 #endif -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/ftell_.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 3 3 #include "fio.h" 4 4 5 static FILE * 6 #ifdef KR_headers 7 unit_chk(Unit, who) integer Unit; char *who; 8 #else 9 unit_chk(integer Unit, char *who) 5 static FILE * 6 unit_chk (integer Unit, char *who) 7 { 8 if (Unit >= MXUNIT || Unit < 0) 9 f__fatal (101, who); 10 return f__units[Unit].ufd; 11 } 12 13 integer 14 G77_ftell_0 (integer * Unit) 15 { 16 FILE *f; 17 return (f = unit_chk (*Unit, "ftell")) ? (integer) FTELL (f) : -1L; 18 } 19 20 integer 21 G77_fseek_0 (integer * Unit, integer * offset, integer * xwhence) 22 { 23 FILE *f; 24 int w = (int) *xwhence; 25 #ifdef SEEK_SET 26 static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; 10 27 #endif 11 { 12 if (Unit >= MXUNIT || Unit < 0) 13 f__fatal(101, who); 14 return f__units[Unit].ufd; 15 } 16 17 integer 18 #ifdef KR_headers 19 G77_ftell_0 (Unit) integer *Unit; 20 #else 21 G77_ftell_0 (integer *Unit) 28 if (w < 0 || w > 2) 29 w = 0; 30 #ifdef SEEK_SET 31 w = wohin[w]; 22 32 #endif 23 { 24 FILE *f; 25 return (f = unit_chk(*Unit, "ftell")) ? (integer) FTELL(f) : -1L; 26 } 27 28 integer 29 #ifdef KR_headers 30 G77_fseek_0 (Unit, offset, xwhence) integer *Unit, *offset, *xwhence; 31 #else 32 G77_fseek_0 (integer *Unit, integer *offset, integer *xwhence) 33 #endif 34 { 35 FILE *f; 36 int w = (int)*xwhence; 37 #ifdef SEEK_SET 38 static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; 39 #endif 40 if (w < 0 || w > 2) 41 w = 0; 42 #ifdef SEEK_SET 43 w = wohin[w]; 44 #endif 45 return !(f = unit_chk(*Unit, "fseek")) 46 || FSEEK(f, (off_t) *offset, w) ? 1 : 0; 47 } 33 return !(f = unit_chk (*Unit, "fseek")) 34 || FSEEK (f, (off_t) * offset, w) ? 1 : 0; 35 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/iio.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 7 7 int f__icnum; 8 8 extern int f__hiwater; 9 z_getc(Void) 9 int 10 z_getc (void) 10 11 { 11 if(f__recpos++ < f__svic->icirlen) { 12 if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"endfile"); 13 return(*(unsigned char *)f__icptr++); 14 } 15 return '\n'; 12 if (f__recpos++ < f__svic->icirlen) 13 { 14 if (f__icptr >= f__icend) 15 err (f__svic->iciend, (EOF), "endfile"); 16 return (*(unsigned char *) f__icptr++); 17 } 18 return '\n'; 16 19 } 17 20 18 void 19 #ifdef KR_headers 20 z_putc(c) 21 #else 22 z_putc(int c) 23 #endif 21 void 22 z_putc (int c) 24 23 { 25 if (f__icptr < f__icend && f__recpos++ < f__svic->icirlen)26 24 if (f__recpos++ < f__svic->icirlen && f__icptr < f__icend) 25 *f__icptr++ = c; 27 26 } 28 z_rnew(Void) 27 int 28 z_rnew (void) 29 29 { 30 f__icptr = f__svic->iciunit + (++f__icnum)*f__svic->icirlen;31 32 33 34 30 f__icptr = f__svic->iciunit + (++f__icnum) * f__svic->icirlen; 31 f__recpos = 0; 32 f__cursor = 0; 33 f__hiwater = 0; 34 return 1; 35 35 } 36 36 37 38 z_endp (Void)37 static int 38 z_endp (void) 39 39 { 40 (*f__donewrec)(); 41 return 0; 42 } 43 44 #ifdef KR_headers 45 c_si(a) icilist *a; 46 #else 47 c_si(icilist *a) 48 #endif 49 { 50 if (f__init & 2) 51 f__fatal (131, "I/O recursion"); 52 f__init |= 2; 53 f__elist = (cilist *)a; 54 f__fmtbuf=a->icifmt; 55 f__curunit = 0; 56 f__sequential=f__formatted=1; 57 f__external=0; 58 if(pars_f(f__fmtbuf)<0) 59 err(a->icierr,100,"startint"); 60 fmt_bg(); 61 f__cblank=f__cplus=f__scale=0; 62 f__svic=a; 63 f__icnum=f__recpos=0; 64 f__cursor = 0; 65 f__hiwater = 0; 66 f__icptr = a->iciunit; 67 f__icend = f__icptr + a->icirlen*a->icirnum; 68 f__cf = 0; 69 return(0); 40 (*f__donewrec) (); 41 return 0; 70 42 } 71 43 72 73 iw_rev(Void)44 int 45 c_si (icilist * a) 74 46 { 75 if(f__workdone) 76 z_endp(); 77 f__hiwater = f__recpos = f__cursor = 0; 78 return(f__workdone=0); 79 } 80 81 #ifdef KR_headers 82 integer s_rsfi(a) icilist *a; 83 #else 84 integer s_rsfi(icilist *a) 85 #endif 86 { int n; 87 if(n=c_si(a)) return(n); 88 f__reading=1; 89 f__doed=rd_ed; 90 f__doned=rd_ned; 91 f__getn=z_getc; 92 f__dorevert = z_endp; 93 f__donewrec = z_rnew; 94 f__doend = z_endp; 95 return(0); 47 if (f__init & 2) 48 f__fatal (131, "I/O recursion"); 49 f__init |= 2; 50 f__elist = (cilist *) a; 51 f__fmtbuf = a->icifmt; 52 f__curunit = 0; 53 f__sequential = f__formatted = 1; 54 f__external = 0; 55 if (pars_f (f__fmtbuf) < 0) 56 err (a->icierr, 100, "startint"); 57 fmt_bg (); 58 f__cblank = f__cplus = f__scale = 0; 59 f__svic = a; 60 f__icnum = f__recpos = 0; 61 f__cursor = 0; 62 f__hiwater = 0; 63 f__icptr = a->iciunit; 64 f__icend = f__icptr + a->icirlen * a->icirnum; 65 f__cf = 0; 66 return (0); 96 67 } 97 68 98 z_wnew(Void) 69 int 70 iw_rev (void) 99 71 { 100 if (f__recpos < f__hiwater) { 101 f__icptr += f__hiwater - f__recpos; 102 f__recpos = f__hiwater; 103 } 104 while(f__recpos++ < f__svic->icirlen) 105 *f__icptr++ = ' '; 106 f__recpos = 0; 107 f__cursor = 0; 108 f__hiwater = 0; 109 f__icnum++; 110 return 1; 72 if (f__workdone) 73 z_endp (); 74 f__hiwater = f__recpos = f__cursor = 0; 75 return (f__workdone = 0); 111 76 } 112 #ifdef KR_headers 113 integer s_wsfi(a) icilist *a;114 #else 115 integer s_wsfi(icilist *a) 116 #endif 117 { int n; 118 if(n=c_si(a)) return(n);119 f__reading=0;120 f__doed=w_ed;121 f__doned=w_ned;122 f__putn=z_putc;123 f__dorevert = iw_rev;124 f__donewrec = z_wnew;125 126 return(0);77 78 integer 79 s_rsfi (icilist * a) 80 { 81 int n; 82 if ((n = c_si (a))) 83 return (n); 84 f__reading = 1; 85 f__doed = rd_ed; 86 f__doned = rd_ned; 87 f__getn = z_getc; 88 f__dorevert = z_endp; 89 f__donewrec = z_rnew; 90 f__doend = z_endp; 91 return (0); 127 92 } 128 integer e_rsfi(Void) 129 { int n; 130 f__init &= ~2; 131 n = en_fio(); 132 f__fmtbuf = NULL; 133 return(n); 93 94 int 95 z_wnew (void) 96 { 97 if (f__recpos < f__hiwater) 98 { 99 f__icptr += f__hiwater - f__recpos; 100 f__recpos = f__hiwater; 101 } 102 while (f__recpos++ < f__svic->icirlen) 103 *f__icptr++ = ' '; 104 f__recpos = 0; 105 f__cursor = 0; 106 f__hiwater = 0; 107 f__icnum++; 108 return 1; 134 109 } 135 integer e_wsfi(Void) 110 111 integer 112 s_wsfi (icilist * a) 136 113 { 137 int n; 138 f__init &= ~2; 139 n = en_fio(); 140 f__fmtbuf = NULL; 141 if(f__svic->icirnum != 1 142 && (f__icnum > f__svic->icirnum 143 || (f__icnum == f__svic->icirnum && (f__recpos | f__hiwater)))) 144 err(f__svic->icierr,110,"inwrite"); 145 if (f__recpos < f__hiwater) 146 f__recpos = f__hiwater; 147 if (f__recpos >= f__svic->icirlen) 148 err(f__svic->icierr,110,"recend"); 149 if (!f__recpos && f__icnum) 150 return n; 151 while(f__recpos++ < f__svic->icirlen) 152 *f__icptr++ = ' '; 153 return n; 114 int n; 115 if ((n = c_si (a))) 116 return (n); 117 f__reading = 0; 118 f__doed = w_ed; 119 f__doned = w_ned; 120 f__putn = z_putc; 121 f__dorevert = iw_rev; 122 f__donewrec = z_wnew; 123 f__doend = z_endp; 124 return (0); 154 125 } 126 127 integer 128 e_rsfi (void) 129 { 130 int n; 131 f__init &= ~2; 132 n = en_fio (); 133 f__fmtbuf = NULL; 134 return (n); 135 } 136 137 integer 138 e_wsfi (void) 139 { 140 int n; 141 f__init &= ~2; 142 n = en_fio (); 143 f__fmtbuf = NULL; 144 if (f__svic->icirnum != 1 145 && (f__icnum > f__svic->icirnum 146 || (f__icnum == f__svic->icirnum && (f__recpos | f__hiwater)))) 147 err (f__svic->icierr, 110, "inwrite"); 148 if (f__recpos < f__hiwater) 149 f__recpos = f__hiwater; 150 if (f__recpos >= f__svic->icirlen) 151 err (f__svic->icierr, 110, "recend"); 152 if (!f__recpos && f__icnum) 153 return n; 154 while (f__recpos++ < f__svic->icirlen) 155 *f__icptr++ = ' '; 156 return n; 157 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/ilnw.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 7 7 extern icilist *f__svic; 8 8 extern int f__icnum; 9 #ifdef KR_headers 10 extern void z_putc(); 11 #else 12 extern void z_putc(int); 13 #endif 9 extern void z_putc (int); 14 10 15 16 z_wSL (Void)11 static int 12 z_wSL (void) 17 13 { 18 while(f__recpos < f__svic->icirlen)19 z_putc(' ');20 return z_rnew();21 14 while (f__recpos < f__svic->icirlen) 15 z_putc (' '); 16 return z_rnew (); 17 } 22 18 23 static void 24 #ifdef KR_headers 25 c_liw(a) icilist *a; 26 #else 27 c_liw(icilist *a) 28 #endif 19 static void 20 c_liw (icilist * a) 29 21 { 30 31 32 33 34 35 36 37 38 39 40 41 42 f__icend = f__icptr + a->icirlen*a->icirnum;43 f__elist = (cilist *)a;44 22 f__reading = 0; 23 f__external = 0; 24 f__formatted = 1; 25 f__putn = z_putc; 26 L_len = a->icirlen; 27 f__donewrec = z_wSL; 28 f__svic = a; 29 f__icnum = f__recpos = 0; 30 f__cursor = 0; 31 f__cf = 0; 32 f__curunit = 0; 33 f__icptr = a->iciunit; 34 f__icend = f__icptr + a->icirlen * a->icirnum; 35 f__elist = (cilist *) a; 36 } 45 37 46 integer 47 #ifdef KR_headers 48 s_wsni(a) icilist *a; 49 #else 50 s_wsni(icilist *a) 51 #endif 38 integer 39 s_wsni (icilist * a) 52 40 { 53 41 cilist ca; 54 42 55 if(f__init != 1) f_init(); 56 f__init = 3; 57 c_liw(a); 58 ca.cifmt = a->icifmt; 59 x_wsne(&ca); 60 z_wSL(); 61 return 0; 62 } 43 if (f__init != 1) 44 f_init (); 45 f__init = 3; 46 c_liw (a); 47 ca.cifmt = a->icifmt; 48 x_wsne (&ca); 49 z_wSL (); 50 return 0; 51 } 63 52 64 integer 65 #ifdef KR_headers 66 s_wsli(a) icilist *a; 67 #else 68 s_wsli(icilist *a) 69 #endif 53 integer 54 s_wsli (icilist * a) 70 55 { 71 if(f__init != 1) f_init(); 72 f__init = 3; 73 f__lioproc = l_write; 74 c_liw(a); 75 return(0); 76 } 56 if (f__init != 1) 57 f_init (); 58 f__init = 3; 59 f__lioproc = l_write; 60 c_liw (a); 61 return (0); 62 } 77 63 78 integer e_wsli(Void) 64 integer 65 e_wsli (void) 79 66 { 80 81 z_wSL();82 return(0);83 67 f__init = 1; 68 z_wSL (); 69 return (0); 70 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/inquire.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 3 3 #include "fio.h" 4 4 #include <string.h> 5 #ifdef KR_headers6 integer f_inqu(a) inlist *a;7 #else8 5 #if defined (MSDOS) && !defined (GO32) 9 6 #undef abs … … 12 9 #include "io.h" 13 10 #endif 14 integer f_inqu(inlist *a) 11 integer 12 f_inqu (inlist * a) 13 { 14 flag byfile; 15 int i, n; 16 unit *p; 17 char buf[256]; 18 long x; 19 if (f__init & 2) 20 f__fatal (131, "I/O recursion"); 21 if (a->infile != NULL) 22 { 23 byfile = 1; 24 g_char (a->infile, a->infilen, buf); 25 #ifdef NON_UNIX_STDIO 26 x = access (buf, 0) ? -1 : 0; 27 for (i = 0, p = NULL; i < MXUNIT; i++) 28 if (f__units[i].ufd != NULL 29 && f__units[i].ufnm != NULL && !strcmp (f__units[i].ufnm, buf)) 30 { 31 p = &f__units[i]; 32 break; 33 } 34 #else 35 x = f__inode (buf, &n); 36 for (i = 0, p = NULL; i < MXUNIT; i++) 37 if (f__units[i].uinode == x 38 && f__units[i].ufd != NULL && f__units[i].udev == n) 39 { 40 p = &f__units[i]; 41 break; 42 } 15 43 #endif 16 { flag byfile; 17 int i, n; 18 unit *p; 19 char buf[256]; 20 long x; 21 if (f__init & 2) 22 f__fatal (131, "I/O recursion"); 23 if(a->infile!=NULL) 24 { byfile=1; 25 g_char(a->infile,a->infilen,buf); 26 #ifdef NON_UNIX_STDIO 27 x = access(buf,0) ? -1 : 0; 28 for(i=0,p=NULL;i<MXUNIT;i++) 29 if(f__units[i].ufd != NULL 30 && f__units[i].ufnm != NULL 31 && !strcmp(f__units[i].ufnm,buf)) { 32 p = &f__units[i]; 33 break; 34 } 35 #else 36 x=f__inode(buf, &n); 37 for(i=0,p=NULL;i<MXUNIT;i++) 38 if(f__units[i].uinode==x 39 && f__units[i].ufd!=NULL 40 && f__units[i].udev == n) { 41 p = &f__units[i]; 42 break; 43 } 44 #endif 44 } 45 else 46 { 47 byfile = 0; 48 if (a->inunit < MXUNIT && a->inunit >= 0) 49 { 50 p = &f__units[a->inunit]; 45 51 } 46 52 else 47 53 { 48 byfile=0; 49 if(a->inunit<MXUNIT && a->inunit>=0) 50 { 51 p= &f__units[a->inunit]; 52 } 53 else 54 { 55 p=NULL; 56 } 54 p = NULL; 57 55 } 58 if(a->inex!=NULL) 59 if(byfile && x != -1 || !byfile && p!=NULL) 60 *a->inex=1; 61 else *a->inex=0; 62 if(a->inopen!=NULL) 63 if(byfile) *a->inopen=(p!=NULL); 64 else *a->inopen=(p!=NULL && p->ufd!=NULL); 65 if(a->innum!=NULL) *a->innum= p-f__units; 66 if(a->innamed!=NULL) 67 if(byfile || p!=NULL && p->ufnm!=NULL) 68 *a->innamed=1; 69 else *a->innamed=0; 70 if(a->inname!=NULL) 71 if(byfile) 72 b_char(buf,a->inname,a->innamlen); 73 else if(p!=NULL && p->ufnm!=NULL) 74 b_char(p->ufnm,a->inname,a->innamlen); 75 if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL) 76 if(p->url) 77 b_char("DIRECT",a->inacc,a->inacclen); 78 else b_char("SEQUENTIAL",a->inacc,a->inacclen); 79 if(a->inseq!=NULL) 80 if(p!=NULL && p->url) 81 b_char("NO",a->inseq,a->inseqlen); 82 else b_char("YES",a->inseq,a->inseqlen); 83 if(a->indir!=NULL) 84 if(p==NULL || p->url) 85 b_char("YES",a->indir,a->indirlen); 86 else b_char("NO",a->indir,a->indirlen); 87 if(a->infmt!=NULL) 88 if(p!=NULL && p->ufmt==0) 89 b_char("UNFORMATTED",a->infmt,a->infmtlen); 90 else b_char("FORMATTED",a->infmt,a->infmtlen); 91 if(a->inform!=NULL) 92 if(p!=NULL && p->ufmt==0) 93 b_char("NO",a->inform,a->informlen); 94 else b_char("YES",a->inform,a->informlen); 95 if(a->inunf) 96 if(p!=NULL && p->ufmt==0) 97 b_char("YES",a->inunf,a->inunflen); 98 else if (p!=NULL) b_char("NO",a->inunf,a->inunflen); 99 else b_char("UNKNOWN",a->inunf,a->inunflen); 100 if(a->inrecl!=NULL && p!=NULL) 101 *a->inrecl=p->url; 102 if(a->innrec!=NULL && p!=NULL && p->url>0) 103 *a->innrec=FTELL(p->ufd)/p->url+1; 104 if(a->inblank && p!=NULL && p->ufmt) 105 if(p->ublnk) 106 b_char("ZERO",a->inblank,a->inblanklen); 107 else b_char("NULL",a->inblank,a->inblanklen); 108 return(0); 56 } 57 if (a->inex != NULL) 58 { 59 if ((byfile && x != -1) || (!byfile && p != NULL)) 60 *a->inex = 1; 61 else 62 *a->inex = 0; 63 } 64 if (a->inopen != NULL) 65 { 66 if (byfile) 67 *a->inopen = (p != NULL); 68 else 69 *a->inopen = (p != NULL && p->ufd != NULL); 70 } 71 if (a->innum != NULL) 72 *a->innum = p - f__units; 73 if (a->innamed != NULL) 74 { 75 if (byfile || (p != NULL && p->ufnm != NULL)) 76 *a->innamed = 1; 77 else 78 *a->innamed = 0; 79 } 80 if (a->inname != NULL) 81 { 82 if (byfile) 83 b_char (buf, a->inname, a->innamlen); 84 else if (p != NULL && p->ufnm != NULL) 85 b_char (p->ufnm, a->inname, a->innamlen); 86 } 87 if (a->inacc != NULL && p != NULL && p->ufd != NULL) 88 { 89 if (p->url) 90 b_char ("DIRECT", a->inacc, a->inacclen); 91 else 92 b_char ("SEQUENTIAL", a->inacc, a->inacclen); 93 } 94 if (a->inseq != NULL) 95 { 96 if (p != NULL && p->url) 97 b_char ("NO", a->inseq, a->inseqlen); 98 else 99 b_char ("YES", a->inseq, a->inseqlen); 100 } 101 if (a->indir != NULL) 102 { 103 if (p == NULL || p->url) 104 b_char ("YES", a->indir, a->indirlen); 105 else 106 b_char ("NO", a->indir, a->indirlen); 107 } 108 if (a->infmt != NULL) 109 { 110 if (p != NULL && p->ufmt == 0) 111 b_char ("UNFORMATTED", a->infmt, a->infmtlen); 112 else 113 b_char ("FORMATTED", a->infmt, a->infmtlen); 114 } 115 if (a->inform != NULL) 116 { 117 if (p != NULL && p->ufmt == 0) 118 b_char ("NO", a->inform, a->informlen); 119 else 120 b_char ("YES", a->inform, a->informlen); 121 } 122 if (a->inunf) 123 { 124 if (p != NULL && p->ufmt == 0) 125 b_char ("YES", a->inunf, a->inunflen); 126 else if (p != NULL) 127 b_char ("NO", a->inunf, a->inunflen); 128 else 129 b_char ("UNKNOWN", a->inunf, a->inunflen); 130 } 131 if (a->inrecl != NULL && p != NULL) 132 *a->inrecl = p->url; 133 if (a->innrec != NULL && p != NULL && p->url > 0) 134 *a->innrec = FTELL (p->ufd) / p->url + 1; 135 if (a->inblank && p != NULL && p->ufmt) 136 { 137 if (p->ublnk) 138 b_char ("ZERO", a->inblank, a->inblanklen); 139 else 140 b_char ("NULL", a->inblank, a->inblanklen); 141 } 142 return (0); 109 143 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/lio.h
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 44 44 typedef union 45 45 { 46 charflchar;47 shortflshort;48 ftnintflint;46 signed char flchar; 47 short flshort; 48 ftnint flint; 49 49 #ifdef Allow_TYQUAD 50 50 longint fllongint; 51 51 #endif 52 real flreal; 53 doublereal fldouble; 54 } flex; 52 real flreal; 53 doublereal fldouble; 54 } 55 flex; 55 56 extern int f__scale; 56 #ifdef KR_headers 57 extern int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); 58 extern int l_read(), l_write(); 59 #else 60 #ifdef __cplusplus 61 extern "C" { 62 #endif 63 extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); 64 extern int l_write(ftnint*, char*, ftnlen, ftnint); 65 extern void x_wsne(cilist*); 66 extern int c_le(cilist*), (*l_getc)(void), (*l_ungetc)(int,FILE*); 67 extern int l_read(ftnint*,char*,ftnlen,ftnint); 68 extern integer e_rsle(void), e_wsle(void), s_wsne(cilist*); 69 extern int z_rnew(void); 70 #ifdef __cplusplus 71 } 72 #endif 73 #endif 57 extern int (*f__lioproc) (ftnint *, char *, ftnlen, ftnint); 58 extern int l_write (ftnint *, char *, ftnlen, ftnint); 59 extern void x_wsne (cilist *); 60 extern int c_le (cilist *), (*l_getc) (void), (*l_ungetc) (int, FILE *); 61 extern int l_read (ftnint *, char *, ftnlen, ftnint); 62 extern integer e_rsle (void), e_wsle (void), s_wsne (cilist *); 63 extern int z_rnew (void); 74 64 extern ftnint L_len; -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/lread.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 14 14 #ifdef Allow_TYQUAD 15 15 static longint f__llx; 16 static int quad_read; 17 #endif 18 19 #ifdef KR_headers 20 extern double atof(); 21 extern char *malloc(), *realloc(); 22 int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); 23 #else 16 #endif 17 24 18 #undef abs 25 19 #undef min 26 20 #undef max 27 21 #include <stdlib.h> 28 #endif29 22 30 23 #include "fmt.h" … … 32 25 #include "fp.h" 33 26 34 #ifndef KR_headers 35 int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void), 36 (*l_ungetc)(int,FILE*); 37 #endif 27 int (*f__lioproc) (ftnint *, char *, ftnlen, ftnint), (*l_getc) (void), 28 (*l_ungetc) (int, FILE *); 38 29 39 30 int l_eof; … … 51 42 #define SG 16 52 43 #define WH 32 53 char f__ltab[128 +1] = { /* offset one for EOF */54 55 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,56 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,57 SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,58 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,59 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,60 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,61 AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,62 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,044 char f__ltab[128 + 1] = { /* offset one for EOF */ 45 0, 46 0, 0, AX, 0, 0, 0, 0, 0, 0, WH | B, SX | WH, 0, 0, 0, 0, 0, 47 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 48 SX | B | WH, 0, AX, 0, 0, 0, 0, AX, 0, 0, 0, SG, SX, SG, 0, SX, 49 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 50 0, 0, 0, 0, EX, EX, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 51 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 52 AX, 0, 0, 0, EX, EX, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 53 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 63 54 }; 64 55 65 56 #ifdef ungetc 66 static int 67 #ifdef KR_headers 68 un_getc(x,f__cf) int x; FILE *f__cf; 69 #else 70 un_getc(int x, FILE *f__cf) 71 #endif 72 { return ungetc(x,f__cf); } 57 static int 58 un_getc (int x, FILE * f__cf) 59 { 60 return ungetc (x, f__cf); 61 } 73 62 #else 74 63 #define un_getc ungetc 75 #ifdef KR_headers 76 extern int ungetc(); 77 #else 78 extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ 79 #endif 80 #endif 81 82 t_getc(Void) 83 { int ch; 84 if(f__curunit->uend) return(EOF); 85 if((ch=getc(f__cf))!=EOF) return(ch); 86 if(feof(f__cf)) 87 f__curunit->uend = l_eof = 1; 88 return(EOF); 89 } 90 integer e_rsle(Void) 91 { 92 int ch; 93 f__init = 1; 94 if(f__curunit->uend) return(0); 95 while((ch=t_getc())!='\n') 96 if (ch == EOF) { 97 if(feof(f__cf)) 98 f__curunit->uend = l_eof = 1; 99 return EOF; 100 } 101 return(0); 64 extern int ungetc (int, FILE *); /* for systems with a buggy stdio.h */ 65 #endif 66 67 int 68 t_getc (void) 69 { 70 int ch; 71 if (f__curunit->uend) 72 return (EOF); 73 if ((ch = getc (f__cf)) != EOF) 74 return (ch); 75 if (feof (f__cf)) 76 f__curunit->uend = l_eof = 1; 77 return (EOF); 78 } 79 80 integer 81 e_rsle (void) 82 { 83 int ch; 84 f__init = 1; 85 if (f__curunit->uend) 86 return (0); 87 while ((ch = t_getc ()) != '\n') 88 if (ch == EOF) 89 { 90 if (feof (f__cf)) 91 f__curunit->uend = l_eof = 1; 92 return EOF; 93 } 94 return (0); 102 95 } 103 96 104 97 flag f__lquit; 105 int f__lcount, f__ltype,nml_read;98 int f__lcount, f__ltype, nml_read; 106 99 char *f__lchar; 107 double f__lx, f__ly;108 #define ERR(x) if( n=(x)) {f__init &= ~2; return(n);}100 double f__lx, f__ly; 101 #define ERR(x) if((n=(x))) {f__init &= ~2; return(n);} 109 102 #define GETC(x) (x=(*l_getc)()) 110 103 #define Ungetc(x,y) (*l_ungetc)(x,y) 111 104 112 static int 113 #ifdef KR_headers 114 l_R(poststar, reqint) int poststar, reqint; 115 #else 116 l_R(int poststar, int reqint) 117 #endif 118 { 119 char s[FMAX+EXPMAXDIGS+4]; 120 register int ch; 121 register char *sp, *spe, *sp1; 122 long e, exp; 123 int havenum, havestar, se; 124 125 if (!poststar) { 126 if (f__lcount > 0) 127 return(0); 128 f__lcount = 1; 105 static int 106 l_R (int poststar, int reqint) 107 { 108 char s[FMAX + EXPMAXDIGS + 4]; 109 register int ch; 110 register char *sp, *spe, *sp1; 111 long e, exp; 112 int havenum, havestar, se; 113 114 if (!poststar) 115 { 116 if (f__lcount > 0) 117 return (0); 118 f__lcount = 1; 119 } 120 #ifdef Allow_TYQUAD 121 f__llx = 0; 122 #endif 123 f__ltype = 0; 124 exp = 0; 125 havestar = 0; 126 retry: 127 sp1 = sp = s; 128 spe = sp + FMAX; 129 havenum = 0; 130 131 switch (GETC (ch)) 132 { 133 case '-': 134 *sp++ = ch; 135 sp1++; 136 spe++; 137 case '+': 138 GETC (ch); 139 } 140 while (ch == '0') 141 { 142 ++havenum; 143 GETC (ch); 144 } 145 while (isdigit (ch)) 146 { 147 if (sp < spe) 148 *sp++ = ch; 149 else 150 ++exp; 151 GETC (ch); 152 } 153 if (ch == '*' && !poststar) 154 { 155 if (sp == sp1 || exp || *s == '-') 156 { 157 errfl (f__elist->cierr, 112, "bad repetition count"); 158 } 159 poststar = havestar = 1; 160 *sp = 0; 161 f__lcount = atoi (s); 162 goto retry; 163 } 164 if (ch == '.') 165 { 166 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT 167 if (reqint) 168 errfl (f__elist->cierr, 115, "invalid integer"); 169 #endif 170 GETC (ch); 171 if (sp == sp1) 172 while (ch == '0') 173 { 174 ++havenum; 175 --exp; 176 GETC (ch); 177 } 178 while (isdigit (ch)) 179 { 180 if (sp < spe) 181 { 182 *sp++ = ch; 183 --exp; 184 } 185 GETC (ch); 186 } 187 } 188 havenum += sp - sp1; 189 se = 0; 190 if (issign (ch)) 191 goto signonly; 192 if (havenum && isexp (ch)) 193 { 194 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT 195 if (reqint) 196 errfl (f__elist->cierr, 115, "invalid integer"); 197 #endif 198 GETC (ch); 199 if (issign (ch)) 200 { 201 signonly: 202 if (ch == '-') 203 se = 1; 204 GETC (ch); 205 } 206 if (!isdigit (ch)) 207 { 208 bad: 209 errfl (f__elist->cierr, 112, "exponent field"); 210 } 211 212 e = ch - '0'; 213 while (isdigit (GETC (ch))) 214 { 215 e = 10 * e + ch - '0'; 216 if (e > EXPMAX) 217 goto bad; 218 } 219 if (se) 220 exp -= e; 221 else 222 exp += e; 223 } 224 (void) Ungetc (ch, f__cf); 225 if (sp > sp1) 226 { 227 ++havenum; 228 while (*--sp == '0') 229 ++exp; 230 if (exp) 231 sprintf (sp + 1, "e%ld", exp); 232 else 233 sp[1] = 0; 234 f__lx = atof (s); 235 #ifdef Allow_TYQUAD 236 if (reqint & 2 && (se = sp - sp1 + exp) > 14 && se < 20) 237 { 238 /* Assuming 64-bit longint and 32-bit long. */ 239 if (exp < 0) 240 sp += exp; 241 if (sp1 <= sp) 242 { 243 f__llx = *sp1 - '0'; 244 while (++sp1 <= sp) 245 f__llx = 10 * f__llx + (*sp1 - '0'); 246 } 247 while (--exp >= 0) 248 f__llx *= 10; 249 if (*s == '-') 250 f__llx = -f__llx; 251 } 252 #endif 253 } 254 else 255 f__lx = 0.; 256 if (havenum) 257 f__ltype = TYLONG; 258 else 259 switch (ch) 260 { 261 case ',': 262 case '/': 263 break; 264 default: 265 if (havestar && (ch == ' ' || ch == '\t' || ch == '\n')) 266 break; 267 if (nml_read > 1) 268 { 269 f__lquit = 2; 270 return 0; 271 } 272 errfl (f__elist->cierr, 112, "invalid number"); 273 } 274 return 0; 275 } 276 277 static int 278 rd_count (register int ch) 279 { 280 if (ch < '0' || ch > '9') 281 return 1; 282 f__lcount = ch - '0'; 283 while (GETC (ch) >= '0' && ch <= '9') 284 f__lcount = 10 * f__lcount + ch - '0'; 285 Ungetc (ch, f__cf); 286 return f__lcount <= 0; 287 } 288 289 static int 290 l_C (void) 291 { 292 int ch, nml_save; 293 double lz; 294 if (f__lcount > 0) 295 return (0); 296 f__ltype = 0; 297 GETC (ch); 298 if (ch != '(') 299 { 300 if (nml_read > 1 && (ch < '0' || ch > '9')) 301 { 302 Ungetc (ch, f__cf); 303 f__lquit = 2; 304 return 0; 305 } 306 if (rd_count (ch)) 307 { 308 if (!f__cf || !feof (f__cf)) 309 errfl (f__elist->cierr, 112, "complex format"); 310 else 311 err (f__elist->cierr, (EOF), "lread"); 312 } 313 if (GETC (ch) != '*') 314 { 315 if (!f__cf || !feof (f__cf)) 316 errfl (f__elist->cierr, 112, "no star"); 317 else 318 err (f__elist->cierr, (EOF), "lread"); 319 } 320 if (GETC (ch) != '(') 321 { 322 Ungetc (ch, f__cf); 323 return (0); 324 } 325 } 326 else 327 f__lcount = 1; 328 while (iswhit (GETC (ch))); 329 Ungetc (ch, f__cf); 330 nml_save = nml_read; 331 nml_read = 0; 332 if ((ch = l_R (1, 0))) 333 return ch; 334 if (!f__ltype) 335 errfl (f__elist->cierr, 112, "no real part"); 336 lz = f__lx; 337 while (iswhit (GETC (ch))); 338 if (ch != ',') 339 { 340 (void) Ungetc (ch, f__cf); 341 errfl (f__elist->cierr, 112, "no comma"); 342 } 343 while (iswhit (GETC (ch))); 344 (void) Ungetc (ch, f__cf); 345 if ((ch = l_R (1, 0))) 346 return ch; 347 if (!f__ltype) 348 errfl (f__elist->cierr, 112, "no imaginary part"); 349 while (iswhit (GETC (ch))); 350 if (ch != ')') 351 errfl (f__elist->cierr, 112, "no )"); 352 f__ly = f__lx; 353 f__lx = lz; 354 #ifdef Allow_TYQUAD 355 f__llx = 0; 356 #endif 357 nml_read = nml_save; 358 return (0); 359 } 360 361 static char nmLbuf[256], *nmL_next; 362 static int (*nmL_getc_save) (void); 363 static int (*nmL_ungetc_save) (int, FILE *); 364 365 static int 366 nmL_getc (void) 367 { 368 int rv; 369 if ((rv = *nmL_next++)) 370 return rv; 371 l_getc = nmL_getc_save; 372 l_ungetc = nmL_ungetc_save; 373 return (*l_getc) (); 374 } 375 376 static int 377 nmL_ungetc (int x, FILE * f) 378 { 379 f = f; /* banish non-use warning */ 380 return *--nmL_next = x; 381 } 382 383 static int 384 Lfinish (int ch, int dot, int *rvp) 385 { 386 char *s, *se; 387 static char what[] = "namelist input"; 388 389 s = nmLbuf + 2; 390 se = nmLbuf + sizeof (nmLbuf) - 1; 391 *s++ = ch; 392 while (!issep (GETC (ch)) && ch != EOF) 393 { 394 if (s >= se) 395 { 396 nmLbuf_ovfl: 397 return *rvp = err__fl (f__elist->cierr, 131, what); 398 } 399 *s++ = ch; 400 if (ch != '=') 401 continue; 402 if (dot) 403 return *rvp = err__fl (f__elist->cierr, 112, what); 404 got_eq: 405 *s = 0; 406 nmL_getc_save = l_getc; 407 l_getc = nmL_getc; 408 nmL_ungetc_save = l_ungetc; 409 l_ungetc = nmL_ungetc; 410 nmLbuf[1] = *(nmL_next = nmLbuf) = ','; 411 *rvp = f__lcount = 0; 412 return 1; 413 } 414 if (dot) 415 goto done; 416 for (;;) 417 { 418 if (s >= se) 419 goto nmLbuf_ovfl; 420 *s++ = ch; 421 if (!isblnk (ch)) 422 break; 423 if (GETC (ch) == EOF) 424 goto done; 425 } 426 if (ch == '=') 427 goto got_eq; 428 done: 429 Ungetc (ch, f__cf); 430 return 0; 431 } 432 433 static int 434 l_L (void) 435 { 436 int ch, rv, sawdot; 437 if (f__lcount > 0) 438 return (0); 439 f__lcount = 1; 440 f__ltype = 0; 441 GETC (ch); 442 if (isdigit (ch)) 443 { 444 rd_count (ch); 445 if (GETC (ch) != '*') 446 { 447 if (!f__cf || !feof (f__cf)) 448 errfl (f__elist->cierr, 112, "no star"); 449 else 450 err (f__elist->cierr, (EOF), "lread"); 451 } 452 GETC (ch); 453 } 454 sawdot = 0; 455 if (ch == '.') 456 { 457 sawdot = 1; 458 GETC (ch); 459 } 460 switch (ch) 461 { 462 case 't': 463 case 'T': 464 if (nml_read && Lfinish (ch, sawdot, &rv)) 465 return rv; 466 f__lx = 1; 467 break; 468 case 'f': 469 case 'F': 470 if (nml_read && Lfinish (ch, sawdot, &rv)) 471 return rv; 472 f__lx = 0; 473 break; 474 default: 475 if (isblnk (ch) || issep (ch) || ch == EOF) 476 { 477 (void) Ungetc (ch, f__cf); 478 return (0); 479 } 480 if (nml_read > 1) 481 { 482 Ungetc (ch, f__cf); 483 f__lquit = 2; 484 return 0; 485 } 486 errfl (f__elist->cierr, 112, "logical"); 487 } 488 f__ltype = TYLONG; 489 while (!issep (GETC (ch)) && ch != EOF); 490 (void) Ungetc (ch, f__cf); 491 return (0); 492 } 493 494 #define BUFSIZE 128 495 496 static int 497 l_CHAR (void) 498 { 499 int ch, size, i; 500 static char rafail[] = "realloc failure"; 501 char quote, *p; 502 if (f__lcount > 0) 503 return (0); 504 f__ltype = 0; 505 if (f__lchar != NULL) 506 free (f__lchar); 507 size = BUFSIZE; 508 p = f__lchar = (char *) malloc ((unsigned int) size); 509 if (f__lchar == NULL) 510 errfl (f__elist->cierr, 113, "no space"); 511 512 GETC (ch); 513 if (isdigit (ch)) 514 { 515 /* allow Fortran 8x-style unquoted string... */ 516 /* either find a repetition count or the string */ 517 f__lcount = ch - '0'; 518 *p++ = ch; 519 for (i = 1;;) 520 { 521 switch (GETC (ch)) 522 { 523 case '*': 524 if (f__lcount == 0) 525 { 526 f__lcount = 1; 527 #ifndef F8X_NML_ELIDE_QUOTES 528 if (nml_read) 529 goto no_quote; 530 #endif 531 goto noquote; 129 532 } 533 p = f__lchar; 534 goto have_lcount; 535 case ',': 536 case ' ': 537 case '\t': 538 case '\n': 539 case '/': 540 Ungetc (ch, f__cf); 541 /* no break */ 542 case EOF: 543 f__lcount = 1; 544 f__ltype = TYCHAR; 545 return *p = 0; 546 } 547 if (!isdigit (ch)) 548 { 549 f__lcount = 1; 550 #ifndef F8X_NML_ELIDE_QUOTES 551 if (nml_read) 552 { 553 no_quote: 554 errfl (f__elist->cierr, 112, 555 "undelimited character string"); 556 } 557 #endif 558 goto noquote; 559 } 560 *p++ = ch; 561 f__lcount = 10 * f__lcount + ch - '0'; 562 if (++i == size) 563 { 564 f__lchar = (char *) realloc (f__lchar, 565 (unsigned int) (size += BUFSIZE)); 566 if (f__lchar == NULL) 567 errfl (f__elist->cierr, 113, rafail); 568 p = f__lchar + i; 569 } 570 } 571 } 572 else 573 (void) Ungetc (ch, f__cf); 574 have_lcount: 575 if (GETC (ch) == '\'' || ch == '"') 576 quote = ch; 577 else if (isblnk (ch) || (issep (ch) && ch != '\n') || ch == EOF) 578 { 579 Ungetc (ch, f__cf); 580 return 0; 581 } 582 #ifndef F8X_NML_ELIDE_QUOTES 583 else if (nml_read > 1) 584 { 585 Ungetc (ch, f__cf); 586 f__lquit = 2; 587 return 0; 588 } 589 #endif 590 else 591 { 592 /* Fortran 8x-style unquoted string */ 593 *p++ = ch; 594 for (i = 1;;) 595 { 596 switch (GETC (ch)) 597 { 598 case ',': 599 case ' ': 600 case '\t': 601 case '\n': 602 case '/': 603 Ungetc (ch, f__cf); 604 /* no break */ 605 case EOF: 606 f__ltype = TYCHAR; 607 return *p = 0; 608 } 609 noquote: 610 *p++ = ch; 611 if (++i == size) 612 { 613 f__lchar = (char *) realloc (f__lchar, 614 (unsigned int) (size += BUFSIZE)); 615 if (f__lchar == NULL) 616 errfl (f__elist->cierr, 113, rafail); 617 p = f__lchar + i; 618 } 619 } 620 } 621 f__ltype = TYCHAR; 622 for (i = 0;;) 623 { 624 while (GETC (ch) != quote && ch != '\n' && ch != EOF && ++i < size) 625 *p++ = ch; 626 if (i == size) 627 { 628 newone: 629 f__lchar = (char *) realloc (f__lchar, 630 (unsigned int) (size += BUFSIZE)); 631 if (f__lchar == NULL) 632 errfl (f__elist->cierr, 113, rafail); 633 p = f__lchar + i - 1; 634 *p++ = ch; 635 } 636 else if (ch == EOF) 637 return (EOF); 638 else if (ch == '\n') 639 { 640 if (*(p - 1) != '\\') 641 continue; 642 i--; 643 p--; 644 if (++i < size) 645 *p++ = ch; 646 else 647 goto newone; 648 } 649 else if (GETC (ch) == quote) 650 { 651 if (++i < size) 652 *p++ = ch; 653 else 654 goto newone; 655 } 656 else 657 { 658 (void) Ungetc (ch, f__cf); 659 *p = 0; 660 return (0); 661 } 662 } 663 } 664 665 int 666 c_le (cilist * a) 667 { 668 if (f__init != 1) 669 f_init (); 670 f__init = 3; 671 f__fmtbuf = "list io"; 672 f__curunit = &f__units[a->ciunit]; 673 f__fmtlen = 7; 674 if (a->ciunit >= MXUNIT || a->ciunit < 0) 675 err (a->cierr, 101, "stler"); 676 f__scale = f__recpos = 0; 677 f__elist = a; 678 if (f__curunit->ufd == NULL && fk_open (SEQ, FMT, a->ciunit)) 679 err (a->cierr, 102, "lio"); 680 f__cf = f__curunit->ufd; 681 if (!f__curunit->ufmt) 682 err (a->cierr, 103, "lio"); 683 return (0); 684 } 685 686 int 687 l_read (ftnint * number, char *ptr, ftnlen len, ftnint type) 688 { 689 #define Ptr ((flex *)ptr) 690 int i, n, ch; 691 doublereal *yy; 692 real *xx; 693 for (i = 0; i < *number; i++) 694 { 695 if (f__lquit) 696 return (0); 697 if (l_eof) 698 err (f__elist->ciend, EOF, "list in"); 699 if (f__lcount == 0) 700 { 701 f__ltype = 0; 702 for (;;) 703 { 704 GETC (ch); 705 switch (ch) 706 { 707 case EOF: 708 err (f__elist->ciend, (EOF), "list in"); 709 case ' ': 710 case '\t': 711 case '\n': 712 continue; 713 case '/': 714 f__lquit = 1; 715 goto loopend; 716 case ',': 717 f__lcount = 1; 718 goto loopend; 719 default: 720 (void) Ungetc (ch, f__cf); 721 goto rddata; 722 } 723 } 724 } 725 rddata: 726 switch ((int) type) 727 { 728 case TYINT1: 729 case TYSHORT: 730 case TYLONG: 731 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT 732 ERR (l_R (0, 1)); 733 break; 734 #endif 735 case TYREAL: 736 case TYDREAL: 737 ERR (l_R (0, 0)); 738 break; 739 #ifdef TYQUAD 740 case TYQUAD: 741 n = l_R (0, 2); 742 if (n) 743 return n; 744 break; 745 #endif 746 case TYCOMPLEX: 747 case TYDCOMPLEX: 748 ERR (l_C ()); 749 break; 750 case TYLOGICAL1: 751 case TYLOGICAL2: 752 case TYLOGICAL: 753 ERR (l_L ()); 754 break; 755 case TYCHAR: 756 ERR (l_CHAR ()); 757 break; 758 } 759 while (GETC (ch) == ' ' || ch == '\t'); 760 if (ch != ',' || f__lcount > 1) 761 Ungetc (ch, f__cf); 762 loopend: 763 if (f__lquit) 764 return (0); 765 if (f__cf && ferror (f__cf)) 766 { 767 clearerr (f__cf); 768 errfl (f__elist->cierr, errno, "list in"); 769 } 770 if (f__ltype == 0) 771 goto bump; 772 switch ((int) type) 773 { 774 case TYINT1: 775 case TYLOGICAL1: 776 Ptr->flchar = (char) f__lx; 777 break; 778 case TYLOGICAL2: 779 case TYSHORT: 780 Ptr->flshort = (short) f__lx; 781 break; 782 case TYLOGICAL: 783 case TYLONG: 784 Ptr->flint = (ftnint) f__lx; 785 break; 130 786 #ifdef Allow_TYQUAD 131 f__llx = 0; 132 #endif 133 f__ltype = 0; 134 exp = 0; 135 havestar = 0; 136 retry: 137 sp1 = sp = s; 138 spe = sp + FMAX; 139 havenum = 0; 140 141 switch(GETC(ch)) { 142 case '-': *sp++ = ch; sp1++; spe++; 143 case '+': 144 GETC(ch); 145 } 146 while(ch == '0') { 147 ++havenum; 148 GETC(ch); 149 } 150 while(isdigit(ch)) { 151 if (sp < spe) *sp++ = ch; 152 else ++exp; 153 GETC(ch); 154 } 155 if (ch == '*' && !poststar) { 156 if (sp == sp1 || exp || *s == '-') { 157 errfl(f__elist->cierr,112,"bad repetition count"); 158 } 159 poststar = havestar = 1; 160 *sp = 0; 161 f__lcount = atoi(s); 162 goto retry; 163 } 164 if (ch == '.') { 165 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT 166 if (reqint) 167 errfl(f__elist->cierr,115,"invalid integer"); 168 #endif 169 GETC(ch); 170 if (sp == sp1) 171 while(ch == '0') { 172 ++havenum; 173 --exp; 174 GETC(ch); 175 } 176 while(isdigit(ch)) { 177 if (sp < spe) 178 { *sp++ = ch; --exp; } 179 GETC(ch); 180 } 181 } 182 havenum += sp - sp1; 183 se = 0; 184 if (issign(ch)) 185 goto signonly; 186 if (havenum && isexp(ch)) { 187 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT 188 if (reqint) 189 errfl(f__elist->cierr,115,"invalid integer"); 190 #endif 191 GETC(ch); 192 if (issign(ch)) { 193 signonly: 194 if (ch == '-') se = 1; 195 GETC(ch); 196 } 197 if (!isdigit(ch)) { 198 bad: 199 errfl(f__elist->cierr,112,"exponent field"); 200 } 201 202 e = ch - '0'; 203 while(isdigit(GETC(ch))) { 204 e = 10*e + ch - '0'; 205 if (e > EXPMAX) 206 goto bad; 207 } 208 if (se) 209 exp -= e; 210 else 211 exp += e; 212 } 213 (void) Ungetc(ch, f__cf); 214 if (sp > sp1) { 215 ++havenum; 216 while(*--sp == '0') 217 ++exp; 218 if (exp) 219 sprintf(sp+1, "e%ld", exp); 220 else 221 sp[1] = 0; 222 f__lx = atof(s); 223 #ifdef Allow_TYQUAD 224 if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) { 225 /* Assuming 64-bit longint and 32-bit long. */ 226 if (exp < 0) 227 sp += exp; 228 if (sp1 <= sp) { 229 f__llx = *sp1 - '0'; 230 while(++sp1 <= sp) 231 f__llx = 10*f__llx + (*sp1 - '0'); 232 } 233 while(--exp >= 0) 234 f__llx *= 10; 235 if (*s == '-') 236 f__llx = -f__llx; 237 } 238 #endif 239 } 240 else 241 f__lx = 0.; 242 if (havenum) 243 f__ltype = TYLONG; 244 else 245 switch(ch) { 246 case ',': 247 case '/': 248 break; 249 default: 250 if (havestar && ( ch == ' ' 251 ||ch == '\t' 252 ||ch == '\n')) 253 break; 254 if (nml_read > 1) { 255 f__lquit = 2; 256 return 0; 257 } 258 errfl(f__elist->cierr,112,"invalid number"); 259 } 260 return 0; 261 } 262 263 static int 264 #ifdef KR_headers 265 rd_count(ch) register int ch; 266 #else 267 rd_count(register int ch) 268 #endif 269 { 270 if (ch < '0' || ch > '9') 271 return 1; 272 f__lcount = ch - '0'; 273 while(GETC(ch) >= '0' && ch <= '9') 274 f__lcount = 10*f__lcount + ch - '0'; 275 Ungetc(ch,f__cf); 276 return f__lcount <= 0; 277 } 278 279 static int 280 l_C(Void) 281 { int ch, nml_save; 282 double lz; 283 if(f__lcount>0) return(0); 284 f__ltype=0; 285 GETC(ch); 286 if(ch!='(') 287 { 288 if (nml_read > 1 && (ch < '0' || ch > '9')) { 289 Ungetc(ch,f__cf); 290 f__lquit = 2; 291 return 0; 292 } 293 if (rd_count(ch)) 294 if(!f__cf || !feof(f__cf)) 295 errfl(f__elist->cierr,112,"complex format"); 296 else 297 err(f__elist->cierr,(EOF),"lread"); 298 if(GETC(ch)!='*') 299 { 300 if(!f__cf || !feof(f__cf)) 301 errfl(f__elist->cierr,112,"no star"); 302 else 303 err(f__elist->cierr,(EOF),"lread"); 304 } 305 if(GETC(ch)!='(') 306 { Ungetc(ch,f__cf); 307 return(0); 308 } 309 } 310 else 311 f__lcount = 1; 312 while(iswhit(GETC(ch))); 313 Ungetc(ch,f__cf); 314 nml_save = nml_read; 315 nml_read = 0; 316 if (ch = l_R(1,0)) 317 return ch; 318 if (!f__ltype) 319 errfl(f__elist->cierr,112,"no real part"); 320 lz = f__lx; 321 while(iswhit(GETC(ch))); 322 if(ch!=',') 323 { (void) Ungetc(ch,f__cf); 324 errfl(f__elist->cierr,112,"no comma"); 325 } 326 while(iswhit(GETC(ch))); 327 (void) Ungetc(ch,f__cf); 328 if (ch = l_R(1,0)) 329 return ch; 330 if (!f__ltype) 331 errfl(f__elist->cierr,112,"no imaginary part"); 332 while(iswhit(GETC(ch))); 333 if(ch!=')') errfl(f__elist->cierr,112,"no )"); 334 f__ly = f__lx; 335 f__lx = lz; 336 #ifdef Allow_TYQUAD 337 f__llx = 0; 338 #endif 339 nml_read = nml_save; 340 return(0); 341 } 342 343 static char nmLbuf[256], *nmL_next; 344 static int (*nmL_getc_save)(Void); 345 #ifdef KR_headers 346 static int (*nmL_ungetc_save)(/* int, FILE* */); 347 #else 348 static int (*nmL_ungetc_save)(int, FILE*); 349 #endif 350 351 static int 352 nmL_getc(Void) 353 { 354 int rv; 355 if (rv = *nmL_next++) 356 return rv; 357 l_getc = nmL_getc_save; 358 l_ungetc = nmL_ungetc_save; 359 return (*l_getc)(); 360 } 361 362 static int 363 #ifdef KR_headers 364 nmL_ungetc(x, f) int x; FILE *f; 365 #else 366 nmL_ungetc(int x, FILE *f) 367 #endif 368 { 369 f = f; /* banish non-use warning */ 370 return *--nmL_next = x; 371 } 372 373 static int 374 #ifdef KR_headers 375 Lfinish(ch, dot, rvp) int ch, dot, *rvp; 376 #else 377 Lfinish(int ch, int dot, int *rvp) 378 #endif 379 { 380 char *s, *se; 381 static char what[] = "namelist input"; 382 383 s = nmLbuf + 2; 384 se = nmLbuf + sizeof(nmLbuf) - 1; 385 *s++ = ch; 386 while(!issep(GETC(ch)) && ch!=EOF) { 387 if (s >= se) { 388 nmLbuf_ovfl: 389 return *rvp = err__fl(f__elist->cierr,131,what); 390 } 391 *s++ = ch; 392 if (ch != '=') 393 continue; 394 if (dot) 395 return *rvp = err__fl(f__elist->cierr,112,what); 396 got_eq: 397 *s = 0; 398 nmL_getc_save = l_getc; 399 l_getc = nmL_getc; 400 nmL_ungetc_save = l_ungetc; 401 l_ungetc = nmL_ungetc; 402 nmLbuf[1] = *(nmL_next = nmLbuf) = ','; 403 *rvp = f__lcount = 0; 404 return 1; 405 } 406 if (dot) 407 goto done; 408 for(;;) { 409 if (s >= se) 410 goto nmLbuf_ovfl; 411 *s++ = ch; 412 if (!isblnk(ch)) 413 break; 414 if (GETC(ch) == EOF) 415 goto done; 416 } 417 if (ch == '=') 418 goto got_eq; 419 done: 420 Ungetc(ch, f__cf); 421 return 0; 422 } 423 424 static int 425 l_L(Void) 426 { 427 int ch, rv, sawdot; 428 if(f__lcount>0) 429 return(0); 430 f__lcount = 1; 431 f__ltype=0; 432 GETC(ch); 433 if(isdigit(ch)) 434 { 435 rd_count(ch); 436 if(GETC(ch)!='*') 437 if(!f__cf || !feof(f__cf)) 438 errfl(f__elist->cierr,112,"no star"); 439 else 440 err(f__elist->cierr,(EOF),"lread"); 441 GETC(ch); 442 } 443 sawdot = 0; 444 if(ch == '.') { 445 sawdot = 1; 446 GETC(ch); 447 } 448 switch(ch) 449 { 450 case 't': 451 case 'T': 452 if (nml_read && Lfinish(ch, sawdot, &rv)) 453 return rv; 454 f__lx=1; 455 break; 456 case 'f': 457 case 'F': 458 if (nml_read && Lfinish(ch, sawdot, &rv)) 459 return rv; 460 f__lx=0; 461 break; 462 default: 463 if(isblnk(ch) || issep(ch) || ch==EOF) 464 { (void) Ungetc(ch,f__cf); 465 return(0); 466 } 467 if (nml_read > 1) { 468 Ungetc(ch,f__cf); 469 f__lquit = 2; 470 return 0; 471 } 472 errfl(f__elist->cierr,112,"logical"); 473 } 474 f__ltype=TYLONG; 475 while(!issep(GETC(ch)) && ch!=EOF); 476 (void) Ungetc(ch, f__cf); 477 return(0); 478 } 479 480 #define BUFSIZE 128 481 482 static int 483 l_CHAR(Void) 484 { int ch,size,i; 485 static char rafail[] = "realloc failure"; 486 char quote,*p; 487 if(f__lcount>0) return(0); 488 f__ltype=0; 489 if(f__lchar!=NULL) free(f__lchar); 490 size=BUFSIZE; 491 p=f__lchar = (char *)malloc((unsigned int)size); 492 if(f__lchar == NULL) 493 errfl(f__elist->cierr,113,"no space"); 494 495 GETC(ch); 496 if(isdigit(ch)) { 497 /* allow Fortran 8x-style unquoted string... */ 498 /* either find a repetition count or the string */ 499 f__lcount = ch - '0'; 500 *p++ = ch; 501 for(i = 1;;) { 502 switch(GETC(ch)) { 503 case '*': 504 if (f__lcount == 0) { 505 f__lcount = 1; 506 #ifndef F8X_NML_ELIDE_QUOTES 507 if (nml_read) 508 goto no_quote; 509 #endif 510 goto noquote; 511 } 512 p = f__lchar; 513 goto have_lcount; 514 case ',': 515 case ' ': 516 case '\t': 517 case '\n': 518 case '/': 519 Ungetc(ch,f__cf); 520 /* no break */ 521 case EOF: 522 f__lcount = 1; 523 f__ltype = TYCHAR; 524 return *p = 0; 525 } 526 if (!isdigit(ch)) { 527 f__lcount = 1; 528 #ifndef F8X_NML_ELIDE_QUOTES 529 if (nml_read) { 530 no_quote: 531 errfl(f__elist->cierr,112, 532 "undelimited character string"); 533 } 534 #endif 535 goto noquote; 536 } 537 *p++ = ch; 538 f__lcount = 10*f__lcount + ch - '0'; 539 if (++i == size) { 540 f__lchar = (char *)realloc(f__lchar, 541 (unsigned int)(size += BUFSIZE)); 542 if(f__lchar == NULL) 543 errfl(f__elist->cierr,113,rafail); 544 p = f__lchar + i; 545 } 546 } 547 } 548 else (void) Ungetc(ch,f__cf); 549 have_lcount: 550 if(GETC(ch)=='\'' || ch=='"') quote=ch; 551 else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) { 552 Ungetc(ch,f__cf); 553 return 0; 554 } 555 #ifndef F8X_NML_ELIDE_QUOTES 556 else if (nml_read > 1) { 557 Ungetc(ch,f__cf); 558 f__lquit = 2; 559 return 0; 560 } 561 #endif 562 else { 563 /* Fortran 8x-style unquoted string */ 564 *p++ = ch; 565 for(i = 1;;) { 566 switch(GETC(ch)) { 567 case ',': 568 case ' ': 569 case '\t': 570 case '\n': 571 case '/': 572 Ungetc(ch,f__cf); 573 /* no break */ 574 case EOF: 575 f__ltype = TYCHAR; 576 return *p = 0; 577 } 578 noquote: 579 *p++ = ch; 580 if (++i == size) { 581 f__lchar = (char *)realloc(f__lchar, 582 (unsigned int)(size += BUFSIZE)); 583 if(f__lchar == NULL) 584 errfl(f__elist->cierr,113,rafail); 585 p = f__lchar + i; 586 } 587 } 588 } 589 f__ltype=TYCHAR; 590 for(i=0;;) 591 { while(GETC(ch)!=quote && ch!='\n' 592 && ch!=EOF && ++i<size) *p++ = ch; 593 if(i==size) 594 { 595 newone: 596 f__lchar= (char *)realloc(f__lchar, 597 (unsigned int)(size += BUFSIZE)); 598 if(f__lchar == NULL) 599 errfl(f__elist->cierr,113,rafail); 600 p=f__lchar+i-1; 601 *p++ = ch; 602 } 603 else if(ch==EOF) return(EOF); 604 else if(ch=='\n') 605 { if(*(p-1) != '\\') continue; 606 i--; 607 p--; 608 if(++i<size) *p++ = ch; 609 else goto newone; 610 } 611 else if(GETC(ch)==quote) 612 { if(++i<size) *p++ = ch; 613 else goto newone; 614 } 615 else 616 { (void) Ungetc(ch,f__cf); 617 *p = 0; 618 return(0); 619 } 620 } 621 } 622 #ifdef KR_headers 623 c_le(a) cilist *a; 624 #else 625 c_le(cilist *a) 626 #endif 627 { 628 if(f__init != 1) f_init(); 629 f__init = 3; 630 f__fmtbuf="list io"; 631 f__curunit = &f__units[a->ciunit]; 632 f__fmtlen=7; 633 if(a->ciunit>=MXUNIT || a->ciunit<0) 634 err(a->cierr,101,"stler"); 635 f__scale=f__recpos=0; 636 f__elist=a; 637 if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) 638 err(a->cierr,102,"lio"); 639 f__cf=f__curunit->ufd; 640 if(!f__curunit->ufmt) err(a->cierr,103,"lio"); 641 return(0); 642 } 643 #ifdef KR_headers 644 l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; 645 #else 646 l_read(ftnint *number, char *ptr, ftnlen len, ftnint type) 647 #endif 648 { 649 #define Ptr ((flex *)ptr) 650 int i,n,ch; 651 doublereal *yy; 652 real *xx; 653 for(i=0;i<*number;i++) 654 { 655 if(f__lquit) return(0); 656 if(l_eof) 657 err(f__elist->ciend, EOF, "list in"); 658 if(f__lcount == 0) { 659 f__ltype = 0; 660 for(;;) { 661 GETC(ch); 662 switch(ch) { 663 case EOF: 664 err(f__elist->ciend,(EOF),"list in"); 665 case ' ': 666 case '\t': 667 case '\n': 668 continue; 669 case '/': 670 f__lquit = 1; 671 goto loopend; 672 case ',': 673 f__lcount = 1; 674 goto loopend; 675 default: 676 (void) Ungetc(ch, f__cf); 677 goto rddata; 678 } 679 } 680 } 681 rddata: 682 switch((int)type) 683 { 684 case TYINT1: 685 case TYSHORT: 686 case TYLONG: 687 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT 688 ERR(l_R(0,1)); 689 break; 690 #endif 691 case TYREAL: 692 case TYDREAL: 693 ERR(l_R(0,0)); 694 break; 695 #ifdef TYQUAD 696 case TYQUAD: 697 n = l_R(0,2); 698 if (n) 699 return n; 700 break; 701 #endif 702 case TYCOMPLEX: 703 case TYDCOMPLEX: 704 ERR(l_C()); 705 break; 706 case TYLOGICAL1: 707 case TYLOGICAL2: 708 case TYLOGICAL: 709 ERR(l_L()); 710 break; 711 case TYCHAR: 712 ERR(l_CHAR()); 713 break; 714 } 715 while (GETC(ch) == ' ' || ch == '\t'); 716 if (ch != ',' || f__lcount > 1) 717 Ungetc(ch,f__cf); 718 loopend: 719 if(f__lquit) return(0); 720 if(f__cf && ferror(f__cf)) { 721 clearerr(f__cf); 722 errfl(f__elist->cierr,errno,"list in"); 723 } 724 if(f__ltype==0) goto bump; 725 switch((int)type) 726 { 727 case TYINT1: 728 case TYLOGICAL1: 729 Ptr->flchar = (char)f__lx; 730 break; 731 case TYLOGICAL2: 732 case TYSHORT: 733 Ptr->flshort = (short)f__lx; 734 break; 735 case TYLOGICAL: 736 case TYLONG: 737 Ptr->flint = (ftnint)f__lx; 738 break; 739 #ifdef Allow_TYQUAD 740 case TYQUAD: 741 if (!(Ptr->fllongint = f__llx)) 742 Ptr->fllongint = f__lx; 743 break; 744 #endif 745 case TYREAL: 746 Ptr->flreal=f__lx; 747 break; 748 case TYDREAL: 749 Ptr->fldouble=f__lx; 750 break; 751 case TYCOMPLEX: 752 xx=(real *)ptr; 753 *xx++ = f__lx; 754 *xx = f__ly; 755 break; 756 case TYDCOMPLEX: 757 yy=(doublereal *)ptr; 758 *yy++ = f__lx; 759 *yy = f__ly; 760 break; 761 case TYCHAR: 762 b_char(f__lchar,ptr,len); 763 break; 764 } 765 bump: 766 if(f__lcount>0) f__lcount--; 767 ptr += len; 768 if (nml_read) 769 nml_read++; 770 } 771 return(0); 787 case TYQUAD: 788 if (!(Ptr->fllongint = f__llx)) 789 Ptr->fllongint = f__lx; 790 break; 791 #endif 792 case TYREAL: 793 Ptr->flreal = f__lx; 794 break; 795 case TYDREAL: 796 Ptr->fldouble = f__lx; 797 break; 798 case TYCOMPLEX: 799 xx = (real *) ptr; 800 *xx++ = f__lx; 801 *xx = f__ly; 802 break; 803 case TYDCOMPLEX: 804 yy = (doublereal *) ptr; 805 *yy++ = f__lx; 806 *yy = f__ly; 807 break; 808 case TYCHAR: 809 b_char (f__lchar, ptr, len); 810 break; 811 } 812 bump: 813 if (f__lcount > 0) 814 f__lcount--; 815 ptr += len; 816 if (nml_read) 817 nml_read++; 818 } 819 return (0); 772 820 #undef Ptr 773 821 } 774 #ifdef KR_headers 775 integer s_rsle(a) cilist *a; 776 #else 777 integer s_rsle(cilist *a) 778 #endif 779 { 780 int n; 781 782 f__reading=1; 783 f__external=1; 784 f__formatted=1; 785 if(n=c_le(a)) return(n); 786 f__lioproc = l_read; 787 f__lquit = 0; 788 f__lcount = 0; 789 l_eof = 0; 790 if(f__curunit->uwrt && f__nowreading(f__curunit)) 791 err(a->cierr,errno,"read start"); 792 if(f__curunit->uend) 793 err(f__elist->ciend,(EOF),"read start"); 794 l_getc = t_getc; 795 l_ungetc = un_getc; 796 f__doend = xrd_SL; 797 return(0); 798 } 822 823 integer 824 s_rsle (cilist * a) 825 { 826 int n; 827 828 f__reading = 1; 829 f__external = 1; 830 f__formatted = 1; 831 if ((n = c_le (a))) 832 return (n); 833 f__lioproc = l_read; 834 f__lquit = 0; 835 f__lcount = 0; 836 l_eof = 0; 837 if (f__curunit->uwrt && f__nowreading (f__curunit)) 838 err (a->cierr, errno, "read start"); 839 if (f__curunit->uend) 840 err (f__elist->ciend, (EOF), "read start"); 841 l_getc = t_getc; 842 l_ungetc = un_getc; 843 f__doend = xrd_SL; 844 return (0); 845 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/lwrite.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 7 7 int f__Aquote; 8 8 9 static VOID 10 donewrec(Void) 11 { 12 if (f__recpos) 13 (*f__donewrec)(); 9 static void 10 donewrec (void) 11 { 12 if (f__recpos) 13 (*f__donewrec) (); 14 } 15 16 static void 17 lwrt_I (longint n) 18 { 19 char *p; 20 int ndigit, sign; 21 22 p = f__icvt (n, &ndigit, &sign, 10); 23 if (f__recpos + ndigit >= L_len) 24 donewrec (); 25 PUT (' '); 26 if (sign) 27 PUT ('-'); 28 while (*p) 29 PUT (*p++); 30 } 31 static void 32 lwrt_L (ftnint n, ftnlen len) 33 { 34 if (f__recpos + LLOGW >= L_len) 35 donewrec (); 36 wrt_L ((Uint *) & n, LLOGW, len); 37 } 38 static void 39 lwrt_A (char *p, ftnlen len) 40 { 41 int a; 42 char *p1, *pe; 43 44 a = 0; 45 pe = p + len; 46 if (f__Aquote) 47 { 48 a = 3; 49 if (len > 1 && p[len - 1] == ' ') 50 { 51 while (--len > 1 && p[len - 1] == ' '); 52 pe = p + len; 14 53 } 15 16 static VOID 17 #ifdef KR_headers 18 lwrt_I(n) longint n; 54 p1 = p; 55 while (p1 < pe) 56 if (*p1++ == '\'') 57 a++; 58 } 59 if (f__recpos + len + a >= L_len) 60 donewrec (); 61 if (a 62 #ifndef OMIT_BLANK_CC 63 || !f__recpos 64 #endif 65 ) 66 PUT (' '); 67 if (a) 68 { 69 PUT ('\''); 70 while (p < pe) 71 { 72 if (*p == '\'') 73 PUT ('\''); 74 PUT (*p++); 75 } 76 PUT ('\''); 77 } 78 else 79 while (p < pe) 80 PUT (*p++); 81 } 82 83 static int 84 l_g (char *buf, double n) 85 { 86 #ifdef Old_list_output 87 doublereal absn; 88 char *fmt; 89 90 absn = n; 91 if (absn < 0) 92 absn = -absn; 93 fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT; 94 #ifdef USE_STRLEN 95 sprintf (buf, fmt, n); 96 return strlen (buf); 19 97 #else 20 lwrt_I(longint n) 21 #endif 22 { 23 char *p; 24 int ndigit, sign; 25 26 p = f__icvt(n, &ndigit, &sign, 10); 27 if(f__recpos + ndigit >= L_len) 28 donewrec(); 29 PUT(' '); 30 if (sign) 31 PUT('-'); 32 while(*p) 33 PUT(*p++); 34 } 35 static VOID 36 #ifdef KR_headers 37 lwrt_L(n, len) ftnint n; ftnlen len; 98 return sprintf (buf, fmt, n); 99 #endif 100 38 101 #else 39 lwrt_L(ftnint n, ftnlen len) 40 #endif 41 { 42 if(f__recpos+LLOGW>=L_len) 43 donewrec(); 44 wrt_L((Uint *)&n,LLOGW, len); 45 } 46 static VOID 47 #ifdef KR_headers 48 lwrt_A(p,len) char *p; ftnlen len; 49 #else 50 lwrt_A(char *p, ftnlen len) 51 #endif 52 { 53 int a; 54 char *p1, *pe; 55 56 a = 0; 57 pe = p + len; 58 if (f__Aquote) { 59 a = 3; 60 if (len > 1 && p[len-1] == ' ') { 61 while(--len > 1 && p[len-1] == ' '); 62 pe = p + len; 63 } 64 p1 = p; 65 while(p1 < pe) 66 if (*p1++ == '\'') 67 a++; 68 } 69 if(f__recpos+len+a >= L_len) 70 donewrec(); 71 if (a 102 register char *b, c, c1; 103 104 b = buf; 105 *b++ = ' '; 106 if (n < 0) 107 { 108 *b++ = '-'; 109 n = -n; 110 } 111 else 112 *b++ = ' '; 113 if (n == 0) 114 { 115 *b++ = '0'; 116 *b++ = '.'; 117 *b = 0; 118 goto f__ret; 119 } 120 sprintf (b, LGFMT, n); 121 switch (*b) 122 { 123 #ifndef WANT_LEAD_0 124 case '0': 125 while (b[0] = b[1]) 126 b++; 127 break; 128 #endif 129 case 'i': 130 case 'I': 131 /* Infinity */ 132 case 'n': 133 case 'N': 134 /* NaN */ 135 while (*++b); 136 break; 137 138 default: 139 /* Fortran 77 insists on having a decimal point... */ 140 for (;; b++) 141 switch (*b) 142 { 143 case 0: 144 *b++ = '.'; 145 *b = 0; 146 goto f__ret; 147 case '.': 148 while (*++b); 149 goto f__ret; 150 case 'E': 151 for (c1 = '.', c = 'E'; (*b = c1); c1 = c, c = *++b); 152 goto f__ret; 153 } 154 } 155 f__ret: 156 return b - buf; 157 #endif 158 } 159 160 static void 161 l_put (register char *s) 162 { 163 register void (*pn) (int) = f__putn; 164 register int c; 165 166 while ((c = *s++)) 167 (*pn) (c); 168 } 169 170 static void 171 lwrt_F (double n) 172 { 173 char buf[LEFBL]; 174 175 if (f__recpos + l_g (buf, n) >= L_len) 176 donewrec (); 177 l_put (buf); 178 } 179 static void 180 lwrt_C (double a, double b) 181 { 182 char *ba, *bb, bufa[LEFBL], bufb[LEFBL]; 183 int al, bl; 184 185 al = l_g (bufa, a); 186 for (ba = bufa; *ba == ' '; ba++) 187 --al; 188 bl = l_g (bufb, b) + 1; /* intentionally high by 1 */ 189 for (bb = bufb; *bb == ' '; bb++) 190 --bl; 191 if (f__recpos + al + bl + 3 >= L_len) 192 donewrec (); 193 #ifdef OMIT_BLANK_CC 194 else 195 #endif 196 PUT (' '); 197 PUT ('('); 198 l_put (ba); 199 PUT (','); 200 if (f__recpos + bl >= L_len) 201 { 202 (*f__donewrec) (); 72 203 #ifndef OMIT_BLANK_CC 73 || !f__recpos 74 #endif 75 ) 76 PUT(' '); 77 if (a) { 78 PUT('\''); 79 while(p < pe) { 80 if (*p == '\'') 81 PUT('\''); 82 PUT(*p++); 83 } 84 PUT('\''); 85 } 86 else 87 while(p < pe) 88 PUT(*p++); 89 } 90 91 static int 92 #ifdef KR_headers 93 l_g(buf, n) char *buf; double n; 94 #else 95 l_g(char *buf, double n) 96 #endif 97 { 98 #ifdef Old_list_output 99 doublereal absn; 100 char *fmt; 101 102 absn = n; 103 if (absn < 0) 104 absn = -absn; 105 fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT; 106 #ifdef USE_STRLEN 107 sprintf(buf, fmt, n); 108 return strlen(buf); 109 #else 110 return sprintf(buf, fmt, n); 111 #endif 112 113 #else 114 register char *b, c, c1; 115 116 b = buf; 117 *b++ = ' '; 118 if (n < 0) { 119 *b++ = '-'; 120 n = -n; 121 } 122 else 123 *b++ = ' '; 124 if (n == 0) { 125 *b++ = '0'; 126 *b++ = '.'; 127 *b = 0; 128 goto f__ret; 129 } 130 sprintf(b, LGFMT, n); 131 switch(*b) { 132 #ifndef WANT_LEAD_0 133 case '0': 134 while(b[0] = b[1]) 135 b++; 136 break; 137 #endif 138 case 'i': 139 case 'I': 140 /* Infinity */ 141 case 'n': 142 case 'N': 143 /* NaN */ 144 while(*++b); 145 break; 146 147 default: 148 /* Fortran 77 insists on having a decimal point... */ 149 for(;; b++) 150 switch(*b) { 151 case 0: 152 *b++ = '.'; 153 *b = 0; 154 goto f__ret; 155 case '.': 156 while(*++b); 157 goto f__ret; 158 case 'E': 159 for(c1 = '.', c = 'E'; *b = c1; 160 c1 = c, c = *++b); 161 goto f__ret; 162 } 163 } 164 f__ret: 165 return b - buf; 166 #endif 204 PUT (' '); 205 #endif 206 } 207 l_put (bb); 208 PUT (')'); 209 } 210 211 int 212 l_write (ftnint * number, char *ptr, ftnlen len, ftnint type) 213 { 214 #define Ptr ((flex *)ptr) 215 int i; 216 longint x; 217 double y, z; 218 real *xx; 219 doublereal *yy; 220 for (i = 0; i < *number; i++) 221 { 222 switch ((int) type) 223 { 224 default: 225 f__fatal (204, "unknown type in lio"); 226 case TYINT1: 227 x = Ptr->flchar; 228 goto xint; 229 case TYSHORT: 230 x = Ptr->flshort; 231 goto xint; 232 #ifdef Allow_TYQUAD 233 case TYQUAD: 234 x = Ptr->fllongint; 235 goto xint; 236 #endif 237 case TYLONG: 238 x = Ptr->flint; 239 xint:lwrt_I (x); 240 break; 241 case TYREAL: 242 y = Ptr->flreal; 243 goto xfloat; 244 case TYDREAL: 245 y = Ptr->fldouble; 246 xfloat:lwrt_F (y); 247 break; 248 case TYCOMPLEX: 249 xx = &Ptr->flreal; 250 y = *xx++; 251 z = *xx; 252 goto xcomplex; 253 case TYDCOMPLEX: 254 yy = &Ptr->fldouble; 255 y = *yy++; 256 z = *yy; 257 xcomplex: 258 lwrt_C (y, z); 259 break; 260 case TYLOGICAL1: 261 x = Ptr->flchar; 262 goto xlog; 263 case TYLOGICAL2: 264 x = Ptr->flshort; 265 goto xlog; 266 case TYLOGICAL: 267 x = Ptr->flint; 268 xlog:lwrt_L (Ptr->flint, len); 269 break; 270 case TYCHAR: 271 lwrt_A (ptr, len); 272 break; 167 273 } 168 169 static VOID 170 #ifdef KR_headers 171 l_put(s) register char *s; 172 #else 173 l_put(register char *s) 174 #endif 175 { 176 #ifdef KR_headers 177 register void (*pn)() = f__putn; 178 #else 179 register void (*pn)(int) = f__putn; 180 #endif 181 register int c; 182 183 while(c = *s++) 184 (*pn)(c); 185 } 186 187 static VOID 188 #ifdef KR_headers 189 lwrt_F(n) double n; 190 #else 191 lwrt_F(double n) 192 #endif 193 { 194 char buf[LEFBL]; 195 196 if(f__recpos + l_g(buf,n) >= L_len) 197 donewrec(); 198 l_put(buf); 199 } 200 static VOID 201 #ifdef KR_headers 202 lwrt_C(a,b) double a,b; 203 #else 204 lwrt_C(double a, double b) 205 #endif 206 { 207 char *ba, *bb, bufa[LEFBL], bufb[LEFBL]; 208 int al, bl; 209 210 al = l_g(bufa, a); 211 for(ba = bufa; *ba == ' '; ba++) 212 --al; 213 bl = l_g(bufb, b) + 1; /* intentionally high by 1 */ 214 for(bb = bufb; *bb == ' '; bb++) 215 --bl; 216 if(f__recpos + al + bl + 3 >= L_len) 217 donewrec(); 218 #ifdef OMIT_BLANK_CC 219 else 220 #endif 221 PUT(' '); 222 PUT('('); 223 l_put(ba); 224 PUT(','); 225 if (f__recpos + bl >= L_len) { 226 (*f__donewrec)(); 227 #ifndef OMIT_BLANK_CC 228 PUT(' '); 229 #endif 230 } 231 l_put(bb); 232 PUT(')'); 233 } 234 #ifdef KR_headers 235 l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; 236 #else 237 l_write(ftnint *number, char *ptr, ftnlen len, ftnint type) 238 #endif 239 { 240 #define Ptr ((flex *)ptr) 241 int i; 242 longint x; 243 double y,z; 244 real *xx; 245 doublereal *yy; 246 for(i=0;i< *number; i++) 247 { 248 switch((int)type) 249 { 250 default: f__fatal(204,"unknown type in lio"); 251 case TYINT1: 252 x = Ptr->flchar; 253 goto xint; 254 case TYSHORT: 255 x=Ptr->flshort; 256 goto xint; 257 #ifdef Allow_TYQUAD 258 case TYQUAD: 259 x = Ptr->fllongint; 260 goto xint; 261 #endif 262 case TYLONG: 263 x=Ptr->flint; 264 xint: lwrt_I(x); 265 break; 266 case TYREAL: 267 y=Ptr->flreal; 268 goto xfloat; 269 case TYDREAL: 270 y=Ptr->fldouble; 271 xfloat: lwrt_F(y); 272 break; 273 case TYCOMPLEX: 274 xx= &Ptr->flreal; 275 y = *xx++; 276 z = *xx; 277 goto xcomplex; 278 case TYDCOMPLEX: 279 yy = &Ptr->fldouble; 280 y= *yy++; 281 z = *yy; 282 xcomplex: 283 lwrt_C(y,z); 284 break; 285 case TYLOGICAL1: 286 x = Ptr->flchar; 287 goto xlog; 288 case TYLOGICAL2: 289 x = Ptr->flshort; 290 goto xlog; 291 case TYLOGICAL: 292 x = Ptr->flint; 293 xlog: lwrt_L(Ptr->flint, len); 294 break; 295 case TYCHAR: 296 lwrt_A(ptr,len); 297 break; 298 } 299 ptr += len; 300 } 301 return(0); 302 } 274 ptr += len; 275 } 276 return (0); 277 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/open.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 1 /* Define _XOPEN_SOURCE to get tempnam prototype with glibc et al --2 more general than _INCLUDE_XOPEN_SOURCE used elsewhere `for HP-UX'. */3 #define _XOPEN_SOURCE 14 1 #include "config.h" 5 2 #include "f2c.h" … … 10 7 #include "io.h" 11 8 #else 12 #include "unistd.h" /* for access */ 13 #endif 14 #endif 15 16 #ifdef KR_headers 17 extern char *malloc(); 18 #ifdef NON_ANSI_STDIO 19 extern char *mktemp(); 20 #endif 21 extern integer f_clos(); 22 #else 9 #include "unistd.h" /* for access */ 10 #endif 11 #endif 12 23 13 #undef abs 24 14 #undef min 25 15 #undef max 26 16 #include <stdlib.h> 27 extern int f__canseek(FILE*); 28 extern integer f_clos(cllist*); 29 #endif 17 extern int f__canseek (FILE *); 18 extern integer f_clos (cllist *); 30 19 31 20 #ifdef NON_ANSI_RW_MODES 32 char *f__r_mode[2] = {"r", "r"}; 33 char *f__w_mode[4] = {"w", "w", "r+w", "r+w"}; 34 #else 35 char *f__r_mode[2] = {"rb", "r"}; 36 char *f__w_mode[4] = {"wb", "w", "r+b", "r+"}; 37 #endif 38 39 static char f__buf0[400], *f__buf = f__buf0; 40 int f__buflen = (int)sizeof(f__buf0); 41 42 static void 43 #ifdef KR_headers 44 f__bufadj(n, c) int n, c; 45 #else 46 f__bufadj(int n, int c) 47 #endif 48 { 49 unsigned int len; 50 char *nbuf, *s, *t, *te; 51 52 if (f__buf == f__buf0) 53 f__buflen = 1024; 54 while(f__buflen <= n) 55 f__buflen <<= 1; 56 len = (unsigned int)f__buflen; 57 if (len != f__buflen || !(nbuf = (char*)malloc(len))) 58 f__fatal(113, "malloc failure"); 59 s = nbuf; 60 t = f__buf; 61 te = t + c; 62 while(t < te) 63 *s++ = *t++; 64 if (f__buf != f__buf0) 65 free(f__buf); 66 f__buf = nbuf; 67 } 68 69 int 70 #ifdef KR_headers 71 f__putbuf(c) int c; 72 #else 73 f__putbuf(int c) 74 #endif 75 { 76 char *s, *se; 77 int n; 78 79 if (f__hiwater > f__recpos) 80 f__recpos = f__hiwater; 81 n = f__recpos + 1; 82 if (n >= f__buflen) 83 f__bufadj(n, f__recpos); 84 s = f__buf; 85 se = s + f__recpos; 86 if (c) 87 *se++ = c; 88 *se = 0; 89 for(;;) { 90 fputs(s, f__cf); 91 s += strlen(s); 92 if (s >= se) 93 break; /* normally happens the first time */ 94 putc(*s++, f__cf); 95 } 96 return 0; 97 } 98 99 void 100 #ifdef KR_headers 101 x_putc(c) 102 #else 103 x_putc(int c) 104 #endif 105 { 106 if (f__recpos >= f__buflen) 107 f__bufadj(f__recpos, f__buflen); 108 f__buf[f__recpos++] = c; 109 } 21 char *f__r_mode[2] = { "r", "r" }; 22 char *f__w_mode[4] = { "w", "w", "r+w", "r+w" }; 23 #else 24 char *f__r_mode[2] = { "rb", "r" }; 25 char *f__w_mode[4] = { "wb", "w", "r+b", "r+" }; 26 #endif 27 28 static char f__buf0[400], *f__buf = f__buf0; 29 int f__buflen = (int) sizeof (f__buf0); 30 31 static void 32 f__bufadj (int n, int c) 33 { 34 unsigned int len; 35 char *nbuf, *s, *t, *te; 36 37 if (f__buf == f__buf0) 38 f__buflen = 1024; 39 while (f__buflen <= n) 40 f__buflen <<= 1; 41 len = (unsigned int) f__buflen; 42 if (len != f__buflen || !(nbuf = (char *) malloc (len))) 43 f__fatal (113, "malloc failure"); 44 s = nbuf; 45 t = f__buf; 46 te = t + c; 47 while (t < te) 48 *s++ = *t++; 49 if (f__buf != f__buf0) 50 free (f__buf); 51 f__buf = nbuf; 52 } 53 54 int 55 f__putbuf (int c) 56 { 57 char *s, *se; 58 int n; 59 60 if (f__hiwater > f__recpos) 61 f__recpos = f__hiwater; 62 n = f__recpos + 1; 63 if (n >= f__buflen) 64 f__bufadj (n, f__recpos); 65 s = f__buf; 66 se = s + f__recpos; 67 if (c) 68 *se++ = c; 69 *se = 0; 70 for (;;) 71 { 72 fputs (s, f__cf); 73 s += strlen (s); 74 if (s >= se) 75 break; /* normally happens the first time */ 76 putc (*s++, f__cf); 77 } 78 return 0; 79 } 80 81 void 82 x_putc (int c) 83 { 84 if (f__recpos >= f__buflen) 85 f__bufadj (f__recpos, f__buflen); 86 f__buf[f__recpos++] = c; 87 } 110 88 111 89 #define opnerr(f,m,s) \ 112 90 do {if(f) {f__init &= ~2; errno= m;} else opn_err(m,s,a); return(m);} while(0) 113 91 114 static void 115 #ifdef KR_headers 116 opn_err(m, s, a) int m; char *s; olist *a; 117 #else 118 opn_err(int m, char *s, olist *a) 119 #endif 120 { 121 if (a->ofnm) { 122 /* supply file name to error message */ 123 if (a->ofnmlen >= f__buflen) 124 f__bufadj((int)a->ofnmlen, 0); 125 g_char(a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf); 126 } 127 f__fatal(m, s); 92 static void 93 opn_err (int m, char *s, olist * a) 94 { 95 if (a->ofnm) 96 { 97 /* supply file name to error message */ 98 if (a->ofnmlen >= f__buflen) 99 f__bufadj ((int) a->ofnmlen, 0); 100 g_char (a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf); 101 } 102 f__fatal (m, s); 103 } 104 105 integer 106 f_open (olist * a) 107 { 108 unit *b; 109 integer rv; 110 char buf[256], *s, *env; 111 cllist x; 112 int ufmt; 113 FILE *tf; 114 int fd, len; 115 #ifndef NON_UNIX_STDIO 116 int n; 117 #endif 118 if (f__init != 1) 119 f_init (); 120 f__external = 1; 121 if (a->ounit >= MXUNIT || a->ounit < 0) 122 err (a->oerr, 101, "open"); 123 f__curunit = b = &f__units[a->ounit]; 124 if (b->ufd) 125 { 126 if (a->ofnm == 0) 127 { 128 same:if (a->oblnk) 129 b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z'; 130 return (0); 128 131 } 129 130 #ifdef KR_headers131 integer f_open(a) olist *a;132 #else133 integer f_open(olist *a)134 #endif135 { unit *b;136 integer rv;137 char buf[256], *s, *env;138 cllist x;139 int ufmt;140 FILE *tf;141 int fd, len;142 #ifndef NON_UNIX_STDIO143 int n;144 #endif145 if(f__init != 1) f_init();146 f__external = 1;147 if(a->ounit>=MXUNIT || a->ounit<0)148 err(a->oerr,101,"open");149 f__curunit = b = &f__units[a->ounit];150 if(b->ufd) {151 if(a->ofnm==0)152 {153 same: if (a->oblnk)154 b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z';155 return(0);156 }157 132 #ifdef NON_UNIX_STDIO 158 if (b->ufnm 159 && strlen(b->ufnm) == a->ofnmlen 160 && !strncmp(b->ufnm, a->ofnm, (unsigned)a->ofnmlen)) 161 goto same; 162 #else 163 g_char(a->ofnm,a->ofnmlen,buf); 164 if (f__inode(buf,&n) == b->uinode && n == b->udev) 165 goto same; 166 #endif 167 x.cunit=a->ounit; 168 x.csta=0; 169 x.cerr=a->oerr; 170 if ((rv = f_clos(&x)) != 0) 171 return rv; 172 } 173 b->url = (int)a->orl; 174 b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z'); 175 if(a->ofm==0) 176 { if(b->url>0) b->ufmt=0; 177 else b->ufmt=1; 178 } 179 else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1; 180 else b->ufmt=0; 181 ufmt = b->ufmt; 133 if (b->ufnm 134 && strlen (b->ufnm) == a->ofnmlen 135 && !strncmp (b->ufnm, a->ofnm, (unsigned) a->ofnmlen)) 136 goto same; 137 #else 138 g_char (a->ofnm, a->ofnmlen, buf); 139 if (f__inode (buf, &n) == b->uinode && n == b->udev) 140 goto same; 141 #endif 142 x.cunit = a->ounit; 143 x.csta = 0; 144 x.cerr = a->oerr; 145 if ((rv = f_clos (&x)) != 0) 146 return rv; 147 } 148 b->url = (int) a->orl; 149 b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z'); 150 if (a->ofm == 0) 151 if ((a->oacc) && (*a->oacc == 'D' || *a->oacc == 'd')) 152 b->ufmt = 0; 153 else 154 b->ufmt = 1; 155 else if (*a->ofm == 'f' || *a->ofm == 'F') 156 b->ufmt = 1; 157 else 158 b->ufmt = 0; 159 ufmt = b->ufmt; 182 160 #ifdef url_Adjust 183 if (b->url && !ufmt) 184 url_Adjust(b->url); 185 #endif 186 if (a->ofnm) { 187 g_char(a->ofnm,a->ofnmlen,buf); 188 if (!buf[0]) 189 opnerr(a->oerr,107,"open"); 190 } 191 else 192 sprintf(buf, "fort.%ld", (long)a->ounit); 193 b->uscrtch = 0; 194 b->uend=0; 195 b->uwrt = 0; 196 b->ufd = 0; 197 b->urw = 3; 198 switch(a->osta ? *a->osta : 'u') 199 { 200 case 'o': 201 case 'O': 161 if (b->url && !ufmt) 162 url_Adjust (b->url); 163 #endif 164 if (a->ofnm) 165 { 166 g_char (a->ofnm, a->ofnmlen, buf); 167 if (!buf[0]) 168 opnerr (a->oerr, 107, "open"); 169 } 170 else 171 sprintf (buf, "fort.%ld", (long) a->ounit); 172 b->uscrtch = 0; 173 b->uend = 0; 174 b->uwrt = 0; 175 b->ufd = 0; 176 b->urw = 3; 177 switch (a->osta ? *a->osta : 'u') 178 { 179 case 'o': 180 case 'O': 202 181 #ifdef NON_POSIX_STDIO 203 if (!(tf = fopen(buf,"r"))) 204 opnerr(a->oerr,errno,"open"); 205 fclose(tf); 206 #else 207 if (access(buf,0)) 208 opnerr(a->oerr,errno,"open"); 209 #endif 210 break; 211 case 's': 212 case 'S': 213 b->uscrtch=1; 214 #ifdef HAVE_MKSTEMP /* Allow use of TMPDIR preferentially. */ 215 env = getenv("TMPDIR"); 216 if (!env) env = getenv("TEMP"); 217 if (!env) env = "/tmp"; 218 len = strlen(env); 219 if (len > 256 - sizeof "/tmp.FXXXXXX") 220 err (a->oerr, 132, "open"); 221 strcpy(buf, env); 222 strcat(buf, "/tmp.FXXXXXX"); 223 fd = mkstemp(buf); 224 if (fd == -1 || close(fd)) 225 err (a->oerr, 132, "open"); 182 if (!(tf = fopen (buf, "r"))) 183 opnerr (a->oerr, errno, "open"); 184 fclose (tf); 185 #else 186 if (access (buf, 0)) 187 opnerr (a->oerr, errno, "open"); 188 #endif 189 break; 190 case 's': 191 case 'S': 192 b->uscrtch = 1; 193 #ifdef HAVE_MKSTEMP /* Allow use of TMPDIR preferentially. */ 194 env = getenv ("TMPDIR"); 195 if (!env) 196 env = getenv ("TEMP"); 197 if (!env) 198 env = "/tmp"; 199 len = strlen (env); 200 if (len > 256 - (int) sizeof ("/tmp.FXXXXXX")) 201 err (a->oerr, 132, "open"); 202 strcpy (buf, env); 203 strcat (buf, "/tmp.FXXXXXX"); 204 fd = mkstemp (buf); 205 if (fd == -1 || close (fd)) 206 err (a->oerr, 132, "open"); 226 207 #else /* ! defined (HAVE_MKSTEMP) */ 227 208 #ifdef HAVE_TEMPNAM /* Allow use of TMPDIR preferentially. */ 228 229 230 231 232 209 s = tempnam (0, buf); 210 if (strlen (s) >= sizeof (buf)) 211 err (a->oerr, 132, "open"); 212 (void) strcpy (buf, s); 213 free (s); 233 214 #else /* ! defined (HAVE_TEMPNAM) */ 234 215 #ifdef HAVE_TMPNAM 235 tmpnam(buf);236 #else 237 (void) strcpy(buf,"tmp.FXXXXXX");238 (void) mktemp(buf);216 tmpnam (buf); 217 #else 218 (void) strcpy (buf, "tmp.FXXXXXX"); 219 (void) mktemp (buf); 239 220 #endif 240 221 #endif /* ! defined (HAVE_TEMPNAM) */ 241 222 #endif /* ! defined (HAVE_MKSTEMP) */ 242 243 244 223 goto replace; 224 case 'n': 225 case 'N': 245 226 #ifdef NON_POSIX_STDIO 246 if ((tf = fopen(buf,"r")) || (tf = fopen(buf,"a"))) { 247 fclose(tf); 248 opnerr(a->oerr,128,"open"); 249 } 250 #else 251 if (!access(buf,0)) 252 opnerr(a->oerr,128,"open"); 253 #endif 254 /* no break */ 255 case 'r': /* Fortran 90 replace option */ 256 case 'R': 257 replace: 258 if (tf = fopen(buf,f__w_mode[0])) 259 fclose(tf); 227 if ((tf = fopen (buf, "r")) || (tf = fopen (buf, "a"))) 228 { 229 fclose (tf); 230 opnerr (a->oerr, 128, "open"); 260 231 } 261 262 b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1)); 263 if(b->ufnm==NULL) opnerr(a->oerr,113,"no space"); 264 (void) strcpy(b->ufnm,buf); 265 if ((s = a->oacc) && b->url) 266 ufmt = 0; 267 if(!(tf = fopen(buf, f__w_mode[ufmt|2]))) { 268 if (tf = fopen(buf, f__r_mode[ufmt])) 269 b->urw = 1; 270 else if (tf = fopen(buf, f__w_mode[ufmt])) { 271 b->uwrt = 1; 272 b->urw = 2; 273 } 274 else 275 err(a->oerr, errno, "open"); 276 } 277 b->useek = f__canseek(b->ufd = tf); 232 #else 233 if (!access (buf, 0)) 234 opnerr (a->oerr, 128, "open"); 235 #endif 236 /* no break */ 237 case 'r': /* Fortran 90 replace option */ 238 case 'R': 239 replace: 240 if ((tf = fopen (buf, f__w_mode[0]))) 241 fclose (tf); 242 } 243 244 b->ufnm = (char *) malloc ((unsigned int) (strlen (buf) + 1)); 245 if (b->ufnm == NULL) 246 opnerr (a->oerr, 113, "no space"); 247 (void) strcpy (b->ufnm, buf); 248 if ((s = a->oacc) && b->url) 249 ufmt = 0; 250 if (!(tf = fopen (buf, f__w_mode[ufmt | 2]))) 251 { 252 if ((tf = fopen (buf, f__r_mode[ufmt]))) 253 b->urw = 1; 254 else if ((tf = fopen (buf, f__w_mode[ufmt]))) 255 { 256 b->uwrt = 1; 257 b->urw = 2; 258 } 259 else 260 err (a->oerr, errno, "open"); 261 } 262 b->useek = f__canseek (b->ufd = tf); 278 263 #ifndef NON_UNIX_STDIO 279 if((b->uinode = f__inode(buf,&b->udev)) == -1) 280 opnerr(a->oerr,108,"open"); 281 #endif 282 if(b->useek) 283 if (a->orl) 284 FSEEK(b->ufd, 0, SEEK_SET); 285 else if ((s = a->oacc) && (*s == 'a' || *s == 'A') 286 && FSEEK(b->ufd, 0, SEEK_END)) 287 opnerr(a->oerr,129,"open"); 288 return(0); 289 } 290 #ifdef KR_headers 291 fk_open(seq,fmt,n) ftnint n; 292 #else 293 fk_open(int seq, int fmt, ftnint n) 294 #endif 295 { char nbuf[10]; 296 olist a; 297 int rtn; 298 int save_init; 299 300 (void) sprintf(nbuf,"fort.%ld",(long)n); 301 a.oerr=1; 302 a.ounit=n; 303 a.ofnm=nbuf; 304 a.ofnmlen=strlen(nbuf); 305 a.osta=NULL; 306 a.oacc= seq==SEQ?"s":"d"; 307 a.ofm = fmt==FMT?"f":"u"; 308 a.orl = seq==DIR?1:0; 309 a.oblnk=NULL; 310 save_init = f__init; 311 f__init &= ~2; 312 rtn = f_open(&a); 313 f__init = save_init | 1; 314 return rtn; 315 } 264 if ((b->uinode = f__inode (buf, &b->udev)) == -1) 265 opnerr (a->oerr, 108, "open"); 266 #endif 267 if (b->useek) 268 { 269 if (a->orl) 270 FSEEK (b->ufd, 0, SEEK_SET); 271 else if ((s = a->oacc) && (*s == 'a' || *s == 'A') 272 && FSEEK (b->ufd, 0, SEEK_END)) 273 opnerr (a->oerr, 129, "open"); 274 } 275 return (0); 276 } 277 278 int 279 fk_open (int seq, int fmt, ftnint n) 280 { 281 char nbuf[10]; 282 olist a; 283 int rtn; 284 int save_init; 285 286 (void) sprintf (nbuf, "fort.%ld", (long) n); 287 a.oerr = 1; 288 a.ounit = n; 289 a.ofnm = nbuf; 290 a.ofnmlen = strlen (nbuf); 291 a.osta = NULL; 292 a.oacc = seq == SEQ ? "s" : "d"; 293 a.ofm = fmt == FMT ? "f" : "u"; 294 a.orl = seq == DIR ? 1 : 0; 295 a.oblnk = NULL; 296 save_init = f__init; 297 f__init &= ~2; 298 rtn = f_open (&a); 299 f__init = save_init | 1; 300 return rtn; 301 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/rdfmt.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 5 5 6 6 extern int f__cursor; 7 #ifdef KR_headers8 extern double atof();9 #else10 7 #undef abs 11 8 #undef min 12 9 #undef max 13 10 #include <stdlib.h> 14 #endif15 11 16 12 #include "fmt.h" 17 13 #include "fp.h" 18 14 19 static int 20 #ifdef KR_headers 21 rd_Z(n,w,len) Uint *n; ftnlen len; 22 #else 23 rd_Z(Uint *n, int w, ftnlen len) 15 static int 16 rd_Z (Uint * n, int w, ftnlen len) 17 { 18 long x[9]; 19 char *s, *s0, *s1, *se, *t; 20 int ch, i, w1, w2; 21 static char hex[256]; 22 static int one = 1; 23 int bad = 0; 24 25 if (!hex['0']) 26 { 27 s = "0123456789"; 28 while ((ch = *s++)) 29 hex[ch] = ch - '0' + 1; 30 s = "ABCDEF"; 31 while ((ch = *s++)) 32 hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11; 33 } 34 s = s0 = (char *) x; 35 s1 = (char *) &x[4]; 36 se = (char *) &x[8]; 37 if (len > 4 * (ftnlen) sizeof (long)) 38 return errno = 117; 39 while (w) 40 { 41 GET (ch); 42 if (ch == ',' || ch == '\n') 43 break; 44 w--; 45 if (ch > ' ') 46 { 47 if (!hex[ch & 0xff]) 48 bad++; 49 *s++ = ch; 50 if (s == se) 51 { 52 /* discard excess characters */ 53 for (t = s0, s = s1; t < s1;) 54 *t++ = *s++; 55 s = s1; 56 } 57 } 58 } 59 if (bad) 60 return errno = 115; 61 w = (int) len; 62 w1 = s - s0; 63 w2 = (w1 + 1) >> 1; 64 t = (char *) n; 65 if (*(char *) &one) 66 { 67 /* little endian */ 68 t += w - 1; 69 i = -1; 70 } 71 else 72 i = 1; 73 for (; w > w2; t += i, --w) 74 *t = 0; 75 if (!w) 76 return 0; 77 if (w < w2) 78 s0 = s - (w << 1); 79 else if (w1 & 1) 80 { 81 *t = hex[*s0++ & 0xff] - 1; 82 if (!--w) 83 return 0; 84 t += i; 85 } 86 do 87 { 88 *t = (hex[*s0 & 0xff] - 1) << 4 | (hex[s0[1] & 0xff] - 1); 89 t += i; 90 s0 += 2; 91 } 92 while (--w); 93 return 0; 94 } 95 96 static int 97 rd_I (Uint * n, int w, ftnlen len, register int base) 98 { 99 int ch, sign; 100 longint x = 0; 101 102 if (w <= 0) 103 goto have_x; 104 for (;;) 105 { 106 GET (ch); 107 if (ch != ' ') 108 break; 109 if (!--w) 110 goto have_x; 111 } 112 sign = 0; 113 switch (ch) 114 { 115 case ',': 116 case '\n': 117 w = 0; 118 goto have_x; 119 case '-': 120 sign = 1; 121 case '+': 122 break; 123 default: 124 if (ch >= '0' && ch <= '9') 125 { 126 x = ch - '0'; 127 break; 128 } 129 goto have_x; 130 } 131 while (--w) 132 { 133 GET (ch); 134 if (ch >= '0' && ch <= '9') 135 { 136 x = x * base + ch - '0'; 137 continue; 138 } 139 if (ch != ' ') 140 { 141 if (ch == '\n' || ch == ',') 142 w = 0; 143 break; 144 } 145 if (f__cblank) 146 x *= base; 147 } 148 if (sign) 149 x = -x; 150 have_x: 151 if (len == sizeof (integer)) 152 n->il = x; 153 else if (len == sizeof (char)) 154 n->ic = (char) x; 155 #ifdef Allow_TYQUAD 156 else if (len == sizeof (longint)) 157 n->ili = x; 24 158 #endif 25 { 26 long x[9]; 27 char *s, *s0, *s1, *se, *t; 28 int ch, i, w1, w2; 29 static char hex[256]; 30 static int one = 1; 31 int bad = 0; 32 33 if (!hex['0']) { 34 s = "0123456789"; 35 while(ch = *s++) 36 hex[ch] = ch - '0' + 1; 37 s = "ABCDEF"; 38 while(ch = *s++) 39 hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11; 159 else 160 n->is = (short) x; 161 if (w) 162 { 163 while (--w) 164 GET (ch); 165 return errno = 115; 166 } 167 return 0; 168 } 169 170 static int 171 rd_L (ftnint * n, int w, ftnlen len) 172 { 173 int ch, dot, lv; 174 175 if (w <= 0) 176 goto bad; 177 for (;;) 178 { 179 GET (ch); 180 --w; 181 if (ch != ' ') 182 break; 183 if (!w) 184 goto bad; 185 } 186 dot = 0; 187 retry: 188 switch (ch) 189 { 190 case '.': 191 if (dot++ || !w) 192 goto bad; 193 GET (ch); 194 --w; 195 goto retry; 196 case 't': 197 case 'T': 198 lv = 1; 199 break; 200 case 'f': 201 case 'F': 202 lv = 0; 203 break; 204 default: 205 bad: 206 for (; w > 0; --w) 207 GET (ch); 208 /* no break */ 209 case ',': 210 case '\n': 211 return errno = 116; 212 } 213 /* The switch statement that was here 214 didn't cut it: It broke down for targets 215 where sizeof(char) == sizeof(short). */ 216 if (len == sizeof (char)) 217 *(char *) n = (char) lv; 218 else if (len == sizeof (short)) 219 *(short *) n = (short) lv; 220 else 221 *n = lv; 222 while (w-- > 0) 223 { 224 GET (ch); 225 if (ch == ',' || ch == '\n') 226 break; 227 } 228 return 0; 229 } 230 231 static int 232 rd_F (ufloat * p, int w, int d, ftnlen len) 233 { 234 char s[FMAX + EXPMAXDIGS + 4]; 235 register int ch; 236 register char *sp, *spe, *sp1; 237 double x; 238 int scale1, se; 239 long e, exp; 240 241 sp1 = sp = s; 242 spe = sp + FMAX; 243 exp = -d; 244 x = 0.; 245 246 do 247 { 248 GET (ch); 249 w--; 250 } 251 while (ch == ' ' && w); 252 switch (ch) 253 { 254 case '-': 255 *sp++ = ch; 256 sp1++; 257 spe++; 258 case '+': 259 if (!w) 260 goto zero; 261 --w; 262 GET (ch); 263 } 264 while (ch == ' ') 265 { 266 blankdrop: 267 if (!w--) 268 goto zero; 269 GET (ch); 270 } 271 while (ch == '0') 272 { 273 if (!w--) 274 goto zero; 275 GET (ch); 276 } 277 if (ch == ' ' && f__cblank) 278 goto blankdrop; 279 scale1 = f__scale; 280 while (isdigit (ch)) 281 { 282 digloop1: 283 if (sp < spe) 284 *sp++ = ch; 285 else 286 ++exp; 287 digloop1e: 288 if (!w--) 289 goto done; 290 GET (ch); 291 } 292 if (ch == ' ') 293 { 294 if (f__cblank) 295 { 296 ch = '0'; 297 goto digloop1; 298 } 299 goto digloop1e; 300 } 301 if (ch == '.') 302 { 303 exp += d; 304 if (!w--) 305 goto done; 306 GET (ch); 307 if (sp == sp1) 308 { /* no digits yet */ 309 while (ch == '0') 310 { 311 skip01: 312 --exp; 313 skip0: 314 if (!w--) 315 goto done; 316 GET (ch); 317 } 318 if (ch == ' ') 319 { 320 if (f__cblank) 321 goto skip01; 322 goto skip0; 323 } 324 } 325 while (isdigit (ch)) 326 { 327 digloop2: 328 if (sp < spe) 329 { 330 *sp++ = ch; 331 --exp; 332 } 333 digloop2e: 334 if (!w--) 335 goto done; 336 GET (ch); 337 } 338 if (ch == ' ') 339 { 340 if (f__cblank) 341 { 342 ch = '0'; 343 goto digloop2; 344 } 345 goto digloop2e; 346 } 347 } 348 switch (ch) 349 { 350 default: 351 break; 352 case '-': 353 se = 1; 354 goto signonly; 355 case '+': 356 se = 0; 357 goto signonly; 358 case 'e': 359 case 'E': 360 case 'd': 361 case 'D': 362 if (!w--) 363 goto bad; 364 GET (ch); 365 while (ch == ' ') 366 { 367 if (!w--) 368 goto bad; 369 GET (ch); 370 } 371 se = 0; 372 switch (ch) 373 { 374 case '-': 375 se = 1; 376 case '+': 377 signonly: 378 if (!w--) 379 goto bad; 380 GET (ch); 381 } 382 while (ch == ' ') 383 { 384 if (!w--) 385 goto bad; 386 GET (ch); 387 } 388 if (!isdigit (ch)) 389 goto bad; 390 391 e = ch - '0'; 392 for (;;) 393 { 394 if (!w--) 395 { 396 ch = '\n'; 397 break; 398 } 399 GET (ch); 400 if (!isdigit (ch)) 401 { 402 if (ch == ' ') 403 { 404 if (f__cblank) 405 ch = '0'; 406 else 407 continue; 40 408 } 41 s = s0 = (char *)x; 42 s1 = (char *)&x[4]; 43 se = (char *)&x[8]; 44 if (len > 4*sizeof(long)) 45 return errno = 117; 46 while (w) { 47 GET(ch); 48 if (ch==',' || ch=='\n') 49 break; 50 w--; 51 if (ch > ' ') { 52 if (!hex[ch & 0xff]) 53 bad++; 54 *s++ = ch; 55 if (s == se) { 56 /* discard excess characters */ 57 for(t = s0, s = s1; t < s1;) 58 *t++ = *s++; 59 s = s1; 60 } 61 } 62 } 63 if (bad) 64 return errno = 115; 65 w = (int)len; 66 w1 = s - s0; 67 w2 = w1+1 >> 1; 68 t = (char *)n; 69 if (*(char *)&one) { 70 /* little endian */ 71 t += w - 1; 72 i = -1; 73 } 74 else 75 i = 1; 76 for(; w > w2; t += i, --w) 77 *t = 0; 78 if (!w) 79 return 0; 80 if (w < w2) 81 s0 = s - (w << 1); 82 else if (w1 & 1) { 83 *t = hex[*s0++ & 0xff] - 1; 84 if (!--w) 85 return 0; 86 t += i; 87 } 88 do { 89 *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1; 90 t += i; 91 s0 += 2; 92 } 93 while(--w); 94 return 0; 95 } 96 97 static int 98 #ifdef KR_headers 99 rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base; 100 #else 101 rd_I(Uint *n, int w, ftnlen len, register int base) 102 #endif 103 { 104 int bad, ch, sign; 105 longint x = 0; 106 107 if (w <= 0) 108 goto have_x; 109 for(;;) { 110 GET(ch); 111 if (ch != ' ') 112 break; 113 if (!--w) 114 goto have_x; 115 } 116 sign = 0; 117 switch(ch) { 118 case ',': 119 case '\n': 120 w = 0; 121 goto have_x; 122 case '-': 123 sign = 1; 124 case '+': 409 else 125 410 break; 126 default: 127 if (ch >= '0' && ch <= '9') { 128 x = ch - '0'; 129 break; 130 } 131 goto have_x; 132 } 133 while(--w) { 134 GET(ch); 135 if (ch >= '0' && ch <= '9') { 136 x = x*base + ch - '0'; 137 continue; 138 } 139 if (ch != ' ') { 140 if (ch == '\n' || ch == ',') 141 w = 0; 142 break; 143 } 144 if (f__cblank) 145 x *= base; 146 } 147 if (sign) 148 x = -x; 149 have_x: 150 if(len == sizeof(integer)) 151 n->il=x; 152 else if(len == sizeof(char)) 153 n->ic = (char)x; 154 #ifdef Allow_TYQUAD 155 else if (len == sizeof(longint)) 156 n->ili = x; 157 #endif 158 else 159 n->is = (short)x; 160 if (w) { 161 while(--w) 162 GET(ch); 163 return errno = 115; 164 } 165 return 0; 166 } 167 168 static int 169 #ifdef KR_headers 170 rd_L(n,w,len) ftnint *n; ftnlen len; 171 #else 172 rd_L(ftnint *n, int w, ftnlen len) 173 #endif 174 { int ch, dot, lv; 175 176 if (w <= 0) 177 goto bad; 178 for(;;) { 179 GET(ch); 180 --w; 181 if (ch != ' ') 182 break; 183 if (!w) 184 goto bad; 185 } 186 dot = 0; 187 retry: 188 switch(ch) { 189 case '.': 190 if (dot++ || !w) 191 goto bad; 192 GET(ch); 193 --w; 194 goto retry; 195 case 't': 196 case 'T': 197 lv = 1; 198 break; 199 case 'f': 200 case 'F': 201 lv = 0; 202 break; 203 default: 204 bad: 205 for(; w > 0; --w) 206 GET(ch); 207 /* no break */ 208 case ',': 209 case '\n': 210 return errno = 116; 211 } 212 /* The switch statement that was here 213 didn't cut it: It broke down for targets 214 where sizeof(char) == sizeof(short). */ 215 if (len == sizeof(char)) 216 *(char *)n = (char)lv; 217 else if (len == sizeof(short)) 218 *(short *)n = (short)lv; 219 else 220 *n = lv; 221 while(w-- > 0) { 222 GET(ch); 223 if (ch == ',' || ch == '\n') 224 break; 225 } 226 return 0; 227 } 228 229 static int 230 #ifdef KR_headers 231 rd_F(p, w, d, len) ufloat *p; ftnlen len; 232 #else 233 rd_F(ufloat *p, int w, int d, ftnlen len) 234 #endif 235 { 236 char s[FMAX+EXPMAXDIGS+4]; 237 register int ch; 238 register char *sp, *spe, *sp1; 239 double x; 240 int scale1, se; 241 long e, exp; 242 243 sp1 = sp = s; 244 spe = sp + FMAX; 245 exp = -d; 246 x = 0.; 247 248 do { 249 GET(ch); 250 w--; 251 } while (ch == ' ' && w); 252 switch(ch) { 253 case '-': *sp++ = ch; sp1++; spe++; 254 case '+': 255 if (!w) goto zero; 256 --w; 257 GET(ch); 258 } 259 while(ch == ' ') { 260 blankdrop: 261 if (!w--) goto zero; GET(ch); } 262 while(ch == '0') 263 { if (!w--) goto zero; GET(ch); } 264 if (ch == ' ' && f__cblank) 265 goto blankdrop; 266 scale1 = f__scale; 267 while(isdigit(ch)) { 268 digloop1: 269 if (sp < spe) *sp++ = ch; 270 else ++exp; 271 digloop1e: 272 if (!w--) goto done; 273 GET(ch); 274 } 275 if (ch == ' ') { 276 if (f__cblank) 277 { ch = '0'; goto digloop1; } 278 goto digloop1e; 279 } 280 if (ch == '.') { 281 exp += d; 282 if (!w--) goto done; 283 GET(ch); 284 if (sp == sp1) { /* no digits yet */ 285 while(ch == '0') { 286 skip01: 287 --exp; 288 skip0: 289 if (!w--) goto done; 290 GET(ch); 291 } 292 if (ch == ' ') { 293 if (f__cblank) goto skip01; 294 goto skip0; 295 } 296 } 297 while(isdigit(ch)) { 298 digloop2: 299 if (sp < spe) 300 { *sp++ = ch; --exp; } 301 digloop2e: 302 if (!w--) goto done; 303 GET(ch); 304 } 305 if (ch == ' ') { 306 if (f__cblank) 307 { ch = '0'; goto digloop2; } 308 goto digloop2e; 309 } 310 } 311 switch(ch) { 312 default: 313 break; 314 case '-': se = 1; goto signonly; 315 case '+': se = 0; goto signonly; 316 case 'e': 317 case 'E': 318 case 'd': 319 case 'D': 320 if (!w--) 321 goto bad; 322 GET(ch); 323 while(ch == ' ') { 324 if (!w--) 325 goto bad; 326 GET(ch); 327 } 328 se = 0; 329 switch(ch) { 330 case '-': se = 1; 331 case '+': 332 signonly: 333 if (!w--) 334 goto bad; 335 GET(ch); 336 } 337 while(ch == ' ') { 338 if (!w--) 339 goto bad; 340 GET(ch); 341 } 342 if (!isdigit(ch)) 343 goto bad; 344 345 e = ch - '0'; 346 for(;;) { 347 if (!w--) 348 { ch = '\n'; break; } 349 GET(ch); 350 if (!isdigit(ch)) { 351 if (ch == ' ') { 352 if (f__cblank) 353 ch = '0'; 354 else continue; 355 } 356 else 357 break; 358 } 359 e = 10*e + ch - '0'; 360 if (e > EXPMAX && sp > sp1) 361 goto bad; 362 } 363 if (se) 364 exp -= e; 365 else 366 exp += e; 367 scale1 = 0; 368 } 369 switch(ch) { 370 case '\n': 371 case ',': 372 break; 373 default: 374 bad: 375 return (errno = 115); 376 } 411 } 412 e = 10 * e + ch - '0'; 413 if (e > EXPMAX && sp > sp1) 414 goto bad; 415 } 416 if (se) 417 exp -= e; 418 else 419 exp += e; 420 scale1 = 0; 421 } 422 switch (ch) 423 { 424 case '\n': 425 case ',': 426 break; 427 default: 428 bad: 429 return (errno = 115); 430 } 377 431 done: 378 if (sp > sp1) { 379 while(*--sp == '0') 380 ++exp; 381 if (exp -= scale1) 382 sprintf(sp+1, "e%ld", exp); 383 else 384 sp[1] = 0; 385 x = atof(s); 386 } 432 if (sp > sp1) 433 { 434 while (*--sp == '0') 435 ++exp; 436 if (exp -= scale1) 437 sprintf (sp + 1, "e%ld", exp); 438 else 439 sp[1] = 0; 440 x = atof (s); 441 } 387 442 zero: 388 if (len == sizeof(real)) 389 p->pf = x; 390 else 391 p->pd = x; 392 return(0); 393 } 394 395 396 static int 397 #ifdef KR_headers 398 rd_A(p,len) char *p; ftnlen len; 399 #else 400 rd_A(char *p, ftnlen len) 401 #endif 402 { int i,ch; 403 for(i=0;i<len;i++) 404 { GET(ch); 405 *p++=VAL(ch); 406 } 407 return(0); 408 } 409 static int 410 #ifdef KR_headers 411 rd_AW(p,w,len) char *p; ftnlen len; 412 #else 413 rd_AW(char *p, int w, ftnlen len) 414 #endif 415 { int i,ch; 416 if(w>=len) 417 { for(i=0;i<w-len;i++) 418 GET(ch); 419 for(i=0;i<len;i++) 420 { GET(ch); 421 *p++=VAL(ch); 422 } 423 return(0); 424 } 425 for(i=0;i<w;i++) 426 { GET(ch); 427 *p++=VAL(ch); 428 } 429 for(i=0;i<len-w;i++) *p++=' '; 430 return(0); 431 } 432 static int 433 #ifdef KR_headers 434 rd_H(n,s) char *s; 435 #else 436 rd_H(int n, char *s) 437 #endif 438 { int i,ch; 439 for(i=0;i<n;i++) 440 if((ch=(*f__getn)())<0) return(ch); 441 else *s++ = ch=='\n'?' ':ch; 442 return(1); 443 } 444 static int 445 #ifdef KR_headers 446 rd_POS(s) char *s; 447 #else 448 rd_POS(char *s) 449 #endif 450 { char quote; 451 int ch; 452 quote= *s++; 453 for(;*s;s++) 454 if(*s==quote && *(s+1)!=quote) break; 455 else if((ch=(*f__getn)())<0) return(ch); 456 else *s = ch=='\n'?' ':ch; 457 return(1); 458 } 459 #ifdef KR_headers 460 rd_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len; 461 #else 462 rd_ed(struct syl *p, char *ptr, ftnlen len) 463 #endif 464 { int ch; 465 for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch); 466 if(f__cursor<0) 467 { if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/ 468 f__cursor = -f__recpos; /* is this in the standard? */ 469 if(f__external == 0) { 470 extern char *f__icptr; 471 f__icptr += f__cursor; 472 } 473 else if(f__curunit && f__curunit->useek) 474 FSEEK(f__cf,(off_t)f__cursor,SEEK_CUR); 475 else 476 err(f__elist->cierr,106,"fmt"); 477 f__recpos += f__cursor; 478 f__cursor=0; 479 } 480 switch(p->op) 481 { 482 default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op); 483 sig_die(f__fmtbuf, 1); 484 case IM: 485 case I: ch = rd_I((Uint *)ptr,p->p1,len, 10); 486 break; 487 488 /* O and OM don't work right for character, double, complex, */ 489 /* or doublecomplex, and they differ from Fortran 90 in */ 490 /* showing a minus sign for negative values. */ 491 492 case OM: 493 case O: ch = rd_I((Uint *)ptr, p->p1, len, 8); 494 break; 495 case L: ch = rd_L((ftnint *)ptr,p->p1,len); 496 break; 497 case A: ch = rd_A(ptr,len); 498 break; 499 case AW: 500 ch = rd_AW(ptr,p->p1,len); 501 break; 502 case E: case EE: 503 case D: 504 case G: 505 case GE: 506 case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2.i[0],len); 507 break; 508 509 /* Z and ZM assume 8-bit bytes. */ 510 511 case ZM: 512 case Z: 513 ch = rd_Z((Uint *)ptr, p->p1, len); 514 break; 515 } 516 if(ch == 0) return(ch); 517 else if(ch == EOF) return(EOF); 518 if (f__cf) 519 clearerr(f__cf); 520 return(errno); 521 } 522 #ifdef KR_headers 523 rd_ned(p) struct syl *p; 524 #else 525 rd_ned(struct syl *p) 526 #endif 527 { 528 switch(p->op) 529 { 530 default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op); 531 sig_die(f__fmtbuf, 1); 532 case APOS: 533 return(rd_POS(p->p2.s)); 534 case H: return(rd_H(p->p1,p->p2.s)); 535 case SLASH: return((*f__donewrec)()); 536 case TR: 537 case X: f__cursor += p->p1; 538 return(1); 539 case T: f__cursor=p->p1-f__recpos - 1; 540 return(1); 541 case TL: f__cursor -= p->p1; 542 if(f__cursor < -f__recpos) /* TL1000, 1X */ 543 f__cursor = -f__recpos; 544 return(1); 545 } 546 } 443 if (len == sizeof (real)) 444 p->pf = x; 445 else 446 p->pd = x; 447 return (0); 448 } 449 450 451 static int 452 rd_A (char *p, ftnlen len) 453 { 454 int i, ch; 455 for (i = 0; i < len; i++) 456 { 457 GET (ch); 458 *p++ = VAL (ch); 459 } 460 return (0); 461 } 462 static int 463 rd_AW (char *p, int w, ftnlen len) 464 { 465 int i, ch; 466 if (w >= len) 467 { 468 for (i = 0; i < w - len; i++) 469 GET (ch); 470 for (i = 0; i < len; i++) 471 { 472 GET (ch); 473 *p++ = VAL (ch); 474 } 475 return (0); 476 } 477 for (i = 0; i < w; i++) 478 { 479 GET (ch); 480 *p++ = VAL (ch); 481 } 482 for (i = 0; i < len - w; i++) 483 *p++ = ' '; 484 return (0); 485 } 486 static int 487 rd_H (int n, char *s) 488 { 489 int i, ch; 490 for (i = 0; i < n; i++) 491 if ((ch = (*f__getn) ()) < 0) 492 return (ch); 493 else 494 *s++ = ch == '\n' ? ' ' : ch; 495 return (1); 496 } 497 static int 498 rd_POS (char *s) 499 { 500 char quote; 501 int ch; 502 quote = *s++; 503 for (; *s; s++) 504 if (*s == quote && *(s + 1) != quote) 505 break; 506 else if ((ch = (*f__getn) ()) < 0) 507 return (ch); 508 else 509 *s = ch == '\n' ? ' ' : ch; 510 return (1); 511 } 512 513 int 514 rd_ed (struct syl * p, char *ptr, ftnlen len) 515 { 516 int ch; 517 for (; f__cursor > 0; f__cursor--) 518 if ((ch = (*f__getn) ()) < 0) 519 return (ch); 520 if (f__cursor < 0) 521 { 522 if (f__recpos + f__cursor < 0) /*err(elist->cierr,110,"fmt") */ 523 f__cursor = -f__recpos; /* is this in the standard? */ 524 if (f__external == 0) 525 { 526 extern char *f__icptr; 527 f__icptr += f__cursor; 528 } 529 else if (f__curunit && f__curunit->useek) 530 FSEEK (f__cf, (off_t) f__cursor, SEEK_CUR); 531 else 532 err (f__elist->cierr, 106, "fmt"); 533 f__recpos += f__cursor; 534 f__cursor = 0; 535 } 536 switch (p->op) 537 { 538 default: 539 fprintf (stderr, "rd_ed, unexpected code: %d\n", p->op); 540 sig_die (f__fmtbuf, 1); 541 case IM: 542 case I: 543 ch = rd_I ((Uint *) ptr, p->p1, len, 10); 544 break; 545 546 /* O and OM don't work right for character, double, complex, */ 547 /* or doublecomplex, and they differ from Fortran 90 in */ 548 /* showing a minus sign for negative values. */ 549 550 case OM: 551 case O: 552 ch = rd_I ((Uint *) ptr, p->p1, len, 8); 553 break; 554 case L: 555 ch = rd_L ((ftnint *) ptr, p->p1, len); 556 break; 557 case A: 558 ch = rd_A (ptr, len); 559 break; 560 case AW: 561 ch = rd_AW (ptr, p->p1, len); 562 break; 563 case E: 564 case EE: 565 case D: 566 case G: 567 case GE: 568 case F: 569 ch = rd_F ((ufloat *) ptr, p->p1, p->p2.i[0], len); 570 break; 571 572 /* Z and ZM assume 8-bit bytes. */ 573 574 case ZM: 575 case Z: 576 ch = rd_Z ((Uint *) ptr, p->p1, len); 577 break; 578 } 579 if (ch == 0) 580 return (ch); 581 else if (ch == EOF) 582 return (EOF); 583 if (f__cf) 584 clearerr (f__cf); 585 return (errno); 586 } 587 588 int 589 rd_ned (struct syl * p) 590 { 591 switch (p->op) 592 { 593 default: 594 fprintf (stderr, "rd_ned, unexpected code: %d\n", p->op); 595 sig_die (f__fmtbuf, 1); 596 case APOS: 597 return (rd_POS (p->p2.s)); 598 case H: 599 return (rd_H (p->p1, p->p2.s)); 600 case SLASH: 601 return ((*f__donewrec) ()); 602 case TR: 603 case X: 604 f__cursor += p->p1; 605 return (1); 606 case T: 607 f__cursor = p->p1 - f__recpos - 1; 608 return (1); 609 case TL: 610 f__cursor -= p->p1; 611 if (f__cursor < -f__recpos) /* TL1000, 1X */ 612 f__cursor = -f__recpos; 613 return (1); 614 } 615 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/rewind.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 2 2 #include "f2c.h" 3 3 #include "fio.h" 4 #ifdef KR_headers 5 integer f_rew(a) alist *a; 6 #else 7 integer f_rew(alist *a) 8 #endif 4 integer 5 f_rew (alist * a) 9 6 { 10 unit *b; 11 if (f__init & 2) 12 f__fatal (131, "I/O recursion"); 13 if(a->aunit>=MXUNIT || a->aunit<0) 14 err(a->aerr,101,"rewind"); 15 b = &f__units[a->aunit]; 16 if(b->ufd == NULL || b->uwrt == 3) 17 return(0); 18 if(!b->useek) 19 err(a->aerr,106,"rewind"); 20 if(b->uwrt) { 21 (void) t_runc(a); 22 b->uwrt = 3; 23 } 24 FSEEK(b->ufd, 0, SEEK_SET); 25 b->uend=0; 26 return(0); 7 unit *b; 8 if (f__init & 2) 9 f__fatal (131, "I/O recursion"); 10 if (a->aunit >= MXUNIT || a->aunit < 0) 11 err (a->aerr, 101, "rewind"); 12 b = &f__units[a->aunit]; 13 if (b->ufd == NULL || b->uwrt == 3) 14 return (0); 15 if (!b->useek) 16 err (a->aerr, 106, "rewind"); 17 if (b->uwrt) 18 { 19 (void) t_runc (a); 20 b->uwrt = 3; 21 } 22 FSEEK (b->ufd, 0, SEEK_SET); 23 b->uend = 0; 24 return (0); 27 25 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/rsfe.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 5 5 #include "fmt.h" 6 6 7 xrd_SL(Void) 8 { int ch; 9 if(!f__curunit->uend) 10 while((ch=getc(f__cf))!='\n') 11 if (ch == EOF) { 12 f__curunit->uend = 1; 13 break; 14 } 15 f__cursor=f__recpos=0; 16 return(1); 7 int 8 xrd_SL (void) 9 { 10 int ch; 11 if (!f__curunit->uend) 12 while ((ch = getc (f__cf)) != '\n') 13 if (ch == EOF) 14 { 15 f__curunit->uend = 1; 16 break; 17 } 18 f__cursor = f__recpos = 0; 19 return (1); 17 20 } 18 x_getc(Void) 19 { int ch; 20 if(f__curunit->uend) return(EOF); 21 ch = getc(f__cf); 22 if(ch!=EOF && ch!='\n') 23 { f__recpos++; 24 return(ch); 25 } 26 if(ch=='\n') 27 { (void) ungetc(ch,f__cf); 28 return(ch); 29 } 30 if(f__curunit->uend || feof(f__cf)) 31 { errno=0; 32 f__curunit->uend=1; 33 return(-1); 34 } 35 return(-1); 21 22 int 23 x_getc (void) 24 { 25 int ch; 26 if (f__curunit->uend) 27 return (EOF); 28 ch = getc (f__cf); 29 if (ch != EOF && ch != '\n') 30 { 31 f__recpos++; 32 return (ch); 33 } 34 if (ch == '\n') 35 { 36 (void) ungetc (ch, f__cf); 37 return (ch); 38 } 39 if (f__curunit->uend || feof (f__cf)) 40 { 41 errno = 0; 42 f__curunit->uend = 1; 43 return (-1); 44 } 45 return (-1); 36 46 } 37 x_endp(Void) 47 48 int 49 x_endp (void) 38 50 { 39 xrd_SL();40 51 xrd_SL (); 52 return f__curunit->uend == 1 ? EOF : 0; 41 53 } 42 x_rev(Void) 54 55 int 56 x_rev (void) 43 57 { 44 (void) xrd_SL();45 return(0);58 (void) xrd_SL (); 59 return (0); 46 60 } 47 #ifdef KR_headers 48 integer s_rsfe(a) cilist *a; /* start */ 49 #else 50 integer s_rsfe(cilist *a) /* start */ 51 #endif 52 { int n; 53 if(f__init != 1) f_init(); 54 f__init = 3; 55 f__reading=1; 56 f__sequential=1; 57 f__formatted=1; 58 f__external=1; 59 if(n=c_sfe(a)) return(n); 60 f__elist=a; 61 f__cursor=f__recpos=0; 62 f__scale=0; 63 f__fmtbuf=a->cifmt; 64 f__curunit= &f__units[a->ciunit]; 65 f__cf=f__curunit->ufd; 66 if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); 67 f__getn= x_getc; 68 f__doed= rd_ed; 69 f__doned= rd_ned; 70 fmt_bg(); 71 f__doend=x_endp; 72 f__donewrec=xrd_SL; 73 f__dorevert=x_rev; 74 f__cblank=f__curunit->ublnk; 75 f__cplus=0; 76 if(f__curunit->uwrt && f__nowreading(f__curunit)) 77 err(a->cierr,errno,"read start"); 78 if(f__curunit->uend) 79 err(f__elist->ciend,(EOF),"read start"); 80 return(0); 61 62 integer 63 s_rsfe (cilist * a) /* start */ 64 { 65 int n; 66 if (f__init != 1) 67 f_init (); 68 f__init = 3; 69 f__reading = 1; 70 f__sequential = 1; 71 f__formatted = 1; 72 f__external = 1; 73 if ((n = c_sfe (a))) 74 return (n); 75 f__elist = a; 76 f__cursor = f__recpos = 0; 77 f__scale = 0; 78 f__fmtbuf = a->cifmt; 79 f__curunit = &f__units[a->ciunit]; 80 f__cf = f__curunit->ufd; 81 if (pars_f (f__fmtbuf) < 0) 82 err (a->cierr, 100, "startio"); 83 f__getn = x_getc; 84 f__doed = rd_ed; 85 f__doned = rd_ned; 86 fmt_bg (); 87 f__doend = x_endp; 88 f__donewrec = xrd_SL; 89 f__dorevert = x_rev; 90 f__cblank = f__curunit->ublnk; 91 f__cplus = 0; 92 if (f__curunit->uwrt && f__nowreading (f__curunit)) 93 err (a->cierr, errno, "read start"); 94 if (f__curunit->uend) 95 err (f__elist->ciend, (EOF), "read start"); 96 return (0); 81 97 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/rsli.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 2 2 #include "fio.h" 3 3 #include "lio.h" 4 #include "fmt.h" 4 #include "fmt.h" /* for f__doend */ 5 5 6 6 extern flag f__lquit; … … 11 11 extern int f__icnum, f__recpos; 12 12 13 static int i_getc(Void) 13 static int 14 i_getc (void) 14 15 { 15 if(f__recpos >= f__svic->icirlen) { 16 if (f__recpos++ == f__svic->icirlen) 17 return '\n'; 18 z_rnew(); 19 } 20 f__recpos++; 21 if(f__icptr >= f__icend) 22 return EOF; 23 return(*f__icptr++); 24 } 16 if (f__recpos >= f__svic->icirlen) 17 { 18 if (f__recpos++ == f__svic->icirlen) 19 return '\n'; 20 z_rnew (); 21 } 22 f__recpos++; 23 if (f__icptr >= f__icend) 24 return EOF; 25 return (*f__icptr++); 26 } 25 27 26 static 27 #ifdef KR_headers 28 int i_ungetc(ch, f) int ch; FILE *f; 29 #else 30 int i_ungetc(int ch, FILE *f) 31 #endif 28 static int 29 i_ungetc (int ch __attribute__ ((__unused__)), 30 FILE * f __attribute__ ((__unused__))) 32 31 { 33 34 35 36 err(f__svic->icierr,110,"recend");37 38 return *--f__icptr /* = ch */;39 32 if (--f__recpos == f__svic->icirlen) 33 return '\n'; 34 if (f__recpos < -1) 35 err (f__svic->icierr, 110, "recend"); 36 /* *--icptr == ch, and icptr may point to read-only memory */ 37 return *--f__icptr /* = ch */ ; 38 } 40 39 41 static void 42 #ifdef KR_headers 43 c_lir(a) icilist *a; 44 #else 45 c_lir(icilist *a) 46 #endif 40 static void 41 c_lir (icilist * a) 47 42 { 48 extern int l_eof; 49 if(f__init != 1) f_init(); 50 f__init = 3; 51 f__reading = 1; 52 f__external = 0; 53 f__formatted = 1; 54 f__svic = a; 55 L_len = a->icirlen; 56 f__recpos = -1; 57 f__icnum = f__recpos = 0; 58 f__cursor = 0; 59 l_getc = i_getc; 60 l_ungetc = i_ungetc; 61 l_eof = 0; 62 f__icptr = a->iciunit; 63 f__icend = f__icptr + a->icirlen*a->icirnum; 64 f__cf = 0; 65 f__curunit = 0; 66 f__elist = (cilist *)a; 67 } 43 extern int l_eof; 44 if (f__init != 1) 45 f_init (); 46 f__init = 3; 47 f__reading = 1; 48 f__external = 0; 49 f__formatted = 1; 50 f__svic = a; 51 L_len = a->icirlen; 52 f__recpos = -1; 53 f__icnum = f__recpos = 0; 54 f__cursor = 0; 55 l_getc = i_getc; 56 l_ungetc = i_ungetc; 57 l_eof = 0; 58 f__icptr = a->iciunit; 59 f__icend = f__icptr + a->icirlen * a->icirnum; 60 f__cf = 0; 61 f__curunit = 0; 62 f__elist = (cilist *) a; 63 } 68 64 69 65 70 #ifdef KR_headers 71 integer s_rsli(a) icilist *a; 72 #else 73 integer s_rsli(icilist *a) 74 #endif 66 integer 67 s_rsli (icilist * a) 75 68 { 76 77 78 79 c_lir(a);80 81 return(0);82 69 f__lioproc = l_read; 70 f__lquit = 0; 71 f__lcount = 0; 72 c_lir (a); 73 f__doend = 0; 74 return (0); 75 } 83 76 84 integer e_rsli(Void) 85 { f__init = 1; return 0; } 77 integer 78 e_rsli (void) 79 { 80 f__init = 1; 81 return 0; 82 } 86 83 87 #ifdef KR_headers 88 integer s_rsni(a) icilist *a; 89 #else 90 extern int x_rsne(cilist*); 84 extern int x_rsne (cilist *); 91 85 92 integer s_rsni(icilist *a)93 #endif 86 integer 87 s_rsni (icilist * a) 94 88 { 95 96 97 98 99 100 101 c_lir(a);102 rv = x_rsne(&ca);103 104 105 89 extern int nml_read; 90 integer rv; 91 cilist ca; 92 ca.ciend = a->iciend; 93 ca.cierr = a->icierr; 94 ca.cifmt = a->icifmt; 95 c_lir (a); 96 rv = x_rsne (&ca); 97 nml_read = 0; 98 return rv; 99 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/rsne.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 4 4 #include "lio.h" 5 5 6 #define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */ 7 #define MAXDIM 20 /* maximum number of subscripts */ 8 9 struct dimen { 10 ftnlen extent; 11 ftnlen curval; 12 ftnlen delta; 13 ftnlen stride; 14 }; 15 typedef struct dimen dimen; 16 17 struct hashentry { 18 struct hashentry *next; 19 char *name; 20 Vardesc *vd; 21 }; 22 typedef struct hashentry hashentry; 23 24 struct hashtab { 25 struct hashtab *next; 26 Namelist *nl; 27 int htsize; 28 hashentry *tab[1]; 29 }; 30 typedef struct hashtab hashtab; 31 32 static hashtab *nl_cache; 33 static int n_nlcache; 34 static hashentry **zot; 35 static int colonseen; 36 extern ftnlen f__typesize[]; 37 38 extern flag f__lquit; 39 extern int f__lcount, nml_read; 40 extern t_getc(Void); 41 42 #ifdef KR_headers 43 extern char *malloc(), *memset(); 44 45 #ifdef ungetc 46 static int 47 un_getc(x,f__cf) int x; FILE *f__cf; 48 { return ungetc(x,f__cf); } 49 #else 50 #define un_getc ungetc 51 extern int ungetc(); 52 #endif 53 54 #else 6 #define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */ 7 #define MAXDIM 20 /* maximum number of subscripts */ 8 9 struct dimen 10 { 11 ftnlen extent; 12 ftnlen curval; 13 ftnlen delta; 14 ftnlen stride; 15 }; 16 typedef struct dimen dimen; 17 18 struct hashentry 19 { 20 struct hashentry *next; 21 char *name; 22 Vardesc *vd; 23 }; 24 typedef struct hashentry hashentry; 25 26 struct hashtab 27 { 28 struct hashtab *next; 29 Namelist *nl; 30 int htsize; 31 hashentry *tab[1]; 32 }; 33 typedef struct hashtab hashtab; 34 35 static hashtab *nl_cache; 36 static int n_nlcache; 37 static hashentry **zot; 38 static int colonseen; 39 extern ftnlen f__typesize[]; 40 41 extern flag f__lquit; 42 extern int f__lcount, nml_read; 43 extern int t_getc (void); 44 55 45 #undef abs 56 46 #undef min … … 60 50 61 51 #ifdef ungetc 62 static int 63 un_getc(int x, FILE *f__cf) 64 { return ungetc(x,f__cf); } 52 static int 53 un_getc (int x, FILE * f__cf) 54 { 55 return ungetc (x, f__cf); 56 } 65 57 #else 66 58 #define un_getc ungetc 67 extern int ungetc (int, FILE*); /* for systems with a buggy stdio.h */59 extern int ungetc (int, FILE *); /* for systems with a buggy stdio.h */ 68 60 #endif 69 #endif 70 71 static Vardesc * 72 #ifdef KR_headers 73 hash(ht, s) hashtab *ht; register char *s; 74 #else 75 hash(hashtab *ht, register char *s) 76 #endif 77 { 78 register int c, x; 79 register hashentry *h; 80 char *s0 = s; 81 82 for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1) 83 x += c; 84 for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next) 85 if (!strcmp(s0, h->name)) 86 return h->vd; 87 return 0; 61 62 static Vardesc * 63 hash (hashtab * ht, register char *s) 64 { 65 register int c, x; 66 register hashentry *h; 67 char *s0 = s; 68 69 for (x = 0; (c = *s++); x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1) 70 x += c; 71 for (h = *(zot = ht->tab + x % ht->htsize); h; h = h->next) 72 if (!strcmp (s0, h->name)) 73 return h->vd; 74 return 0; 75 } 76 77 hashtab * 78 mk_hashtab (Namelist * nl) 79 { 80 int nht, nv; 81 hashtab *ht; 82 Vardesc *v, **vd, **vde; 83 hashentry *he; 84 85 hashtab **x, **x0, *y; 86 for (x = &nl_cache; (y = *x); x0 = x, x = &y->next) 87 if (nl == y->nl) 88 return y; 89 if (n_nlcache >= MAX_NL_CACHE) 90 { 91 /* discard least recently used namelist hash table */ 92 y = *x0; 93 free ((char *) y->next); 94 y->next = 0; 95 } 96 else 97 n_nlcache++; 98 nv = nl->nvars; 99 if (nv >= 0x4000) 100 nht = 0x7fff; 101 else 102 { 103 for (nht = 1; nht < nv; nht <<= 1); 104 nht += nht - 1; 105 } 106 ht = (hashtab *) malloc (sizeof (hashtab) + (nht - 1) * sizeof (hashentry *) 107 + nv * sizeof (hashentry)); 108 if (!ht) 109 return 0; 110 he = (hashentry *) & ht->tab[nht]; 111 ht->nl = nl; 112 ht->htsize = nht; 113 ht->next = nl_cache; 114 nl_cache = ht; 115 memset ((char *) ht->tab, 0, nht * sizeof (hashentry *)); 116 vd = nl->vars; 117 vde = vd + nv; 118 while (vd < vde) 119 { 120 v = *vd++; 121 if (!hash (ht, v->name)) 122 { 123 he->next = *zot; 124 *zot = he; 125 he->name = v->name; 126 he->vd = v; 127 he++; 88 128 } 89 90 hashtab * 91 #ifdef KR_headers 92 mk_hashtab(nl) Namelist *nl; 93 #else 94 mk_hashtab(Namelist *nl) 95 #endif 96 { 97 int nht, nv; 98 hashtab *ht; 99 Vardesc *v, **vd, **vde; 100 hashentry *he; 101 102 hashtab **x, **x0, *y; 103 for(x = &nl_cache; y = *x; x0 = x, x = &y->next) 104 if (nl == y->nl) 105 return y; 106 if (n_nlcache >= MAX_NL_CACHE) { 107 /* discard least recently used namelist hash table */ 108 y = *x0; 109 free((char *)y->next); 110 y->next = 0; 111 } 112 else 113 n_nlcache++; 114 nv = nl->nvars; 115 if (nv >= 0x4000) 116 nht = 0x7fff; 117 else { 118 for(nht = 1; nht < nv; nht <<= 1); 119 nht += nht - 1; 120 } 121 ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *) 122 + nv*sizeof(hashentry)); 123 if (!ht) 124 return 0; 125 he = (hashentry *)&ht->tab[nht]; 126 ht->nl = nl; 127 ht->htsize = nht; 128 ht->next = nl_cache; 129 nl_cache = ht; 130 memset((char *)ht->tab, 0, nht*sizeof(hashentry *)); 131 vd = nl->vars; 132 vde = vd + nv; 133 while(vd < vde) { 134 v = *vd++; 135 if (!hash(ht, v->name)) { 136 he->next = *zot; 137 *zot = he; 138 he->name = v->name; 139 he->vd = v; 140 he++; 141 } 142 } 143 return ht; 144 } 129 } 130 return ht; 131 } 145 132 146 133 static char Alpha[256], Alphanum[256]; 147 134 148 static VOID 149 nl_init(Void) { 150 register char *s; 151 register int c; 152 153 for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; ) 154 Alpha[c] 155 = Alphanum[c] 156 = Alpha[c + 'a' - 'A'] 157 = Alphanum[c + 'a' - 'A'] 158 = c; 159 for(s = "0123456789_"; c = *s++; ) 160 Alphanum[c] = c; 161 } 135 static void 136 nl_init (void) 137 { 138 register char *s; 139 register int c; 140 141 for (s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; (c = *s++);) 142 Alpha[c] 143 = Alphanum[c] = Alpha[c + 'a' - 'A'] = Alphanum[c + 'a' - 'A'] = c; 144 for (s = "0123456789_"; (c = *s++);) 145 Alphanum[c] = c; 146 } 162 147 163 148 #define GETC(x) (x=(*l_getc)()) 164 149 #define Ungetc(x,y) (*l_ungetc)(x,y) 165 150 166 static int 167 #ifdef KR_headers 168 getname(s, slen) register char *s; int slen; 151 static int 152 getname (register char *s, int slen) 153 { 154 register char *se = s + slen - 1; 155 register int ch; 156 157 GETC (ch); 158 if (!(*s++ = Alpha[ch & 0xff])) 159 { 160 if (ch != EOF) 161 ch = 115; 162 errfl (f__elist->cierr, ch, "namelist read"); 163 } 164 while ((*s = Alphanum[GETC (ch) & 0xff])) 165 if (s < se) 166 s++; 167 if (ch == EOF) 168 err (f__elist->cierr, EOF, "namelist read"); 169 if (ch > ' ') 170 Ungetc (ch, f__cf); 171 return *s = 0; 172 } 173 174 static int 175 getnum (int *chp, ftnlen * val) 176 { 177 register int ch, sign; 178 register ftnlen x; 179 180 while (GETC (ch) <= ' ' && ch >= 0); 181 if (ch == '-') 182 { 183 sign = 1; 184 GETC (ch); 185 } 186 else 187 { 188 sign = 0; 189 if (ch == '+') 190 GETC (ch); 191 } 192 x = ch - '0'; 193 if (x < 0 || x > 9) 194 return 115; 195 while (GETC (ch) >= '0' && ch <= '9') 196 x = 10 * x + ch - '0'; 197 while (ch <= ' ' && ch >= 0) 198 GETC (ch); 199 if (ch == EOF) 200 return EOF; 201 *val = sign ? -x : x; 202 *chp = ch; 203 return 0; 204 } 205 206 static int 207 getdimen (int *chp, dimen * d, ftnlen delta, ftnlen extent, ftnlen * x1) 208 { 209 register int k; 210 ftnlen x2, x3; 211 212 if ((k = getnum (chp, x1))) 213 return k; 214 x3 = 1; 215 if (*chp == ':') 216 { 217 if ((k = getnum (chp, &x2))) 218 return k; 219 x2 -= *x1; 220 if (*chp == ':') 221 { 222 if ((k = getnum (chp, &x3))) 223 return k; 224 if (!x3) 225 return 123; 226 x2 /= x3; 227 colonseen = 1; 228 } 229 if (x2 < 0 || x2 >= extent) 230 return 123; 231 d->extent = x2 + 1; 232 } 233 else 234 d->extent = 1; 235 d->curval = 0; 236 d->delta = delta; 237 d->stride = x3; 238 return 0; 239 } 240 241 #ifndef No_Namelist_Questions 242 static void 243 print_ne (cilist * a) 244 { 245 flag intext = f__external; 246 int rpsave = f__recpos; 247 FILE *cfsave = f__cf; 248 unit *usave = f__curunit; 249 cilist t; 250 t = *a; 251 t.ciunit = 6; 252 s_wsne (&t); 253 fflush (f__cf); 254 f__external = intext; 255 f__reading = 1; 256 f__recpos = rpsave; 257 f__cf = cfsave; 258 f__curunit = usave; 259 f__elist = a; 260 } 261 #endif 262 263 static char where0[] = "namelist read start "; 264 265 int 266 x_rsne (cilist * a) 267 { 268 int ch, got1, k, n, nd, quote, readall; 269 Namelist *nl; 270 static char where[] = "namelist read"; 271 char buf[64]; 272 hashtab *ht; 273 Vardesc *v; 274 dimen *dn, *dn0, *dn1; 275 ftnlen *dims, *dims1; 276 ftnlen b, b0, b1, ex, no, nomax, size, span; 277 ftnint no1, type; 278 char *vaddr; 279 long iva, ivae; 280 dimen dimens[MAXDIM], substr; 281 282 if (!Alpha['a']) 283 nl_init (); 284 f__reading = 1; 285 f__formatted = 1; 286 got1 = 0; 287 top: 288 for (;;) 289 switch (GETC (ch)) 290 { 291 case EOF: 292 eof: 293 err (a->ciend, (EOF), where0); 294 case '&': 295 case '$': 296 goto have_amp; 297 #ifndef No_Namelist_Questions 298 case '?': 299 print_ne (a); 300 continue; 301 #endif 302 default: 303 if (ch <= ' ' && ch >= 0) 304 continue; 305 #ifndef No_Namelist_Comments 306 while (GETC (ch) != '\n') 307 if (ch == EOF) 308 goto eof; 169 309 #else 170 getname(register char *s, int slen) 310 errfl (a->cierr, 115, where0); 171 311 #endif 172 { 173 register char *se = s + slen - 1; 174 register int ch; 175 176 GETC(ch); 177 if (!(*s++ = Alpha[ch & 0xff])) { 178 if (ch != EOF) 179 ch = 115; 180 errfl(f__elist->cierr, ch, "namelist read"); 312 } 313 have_amp: 314 if ((ch = getname (buf, sizeof (buf)))) 315 return ch; 316 nl = (Namelist *) a->cifmt; 317 if (strcmp (buf, nl->name)) 318 #ifdef No_Bad_Namelist_Skip 319 errfl (a->cierr, 118, where0); 320 #else 321 { 322 fprintf (stderr, 323 "Skipping namelist \"%s\": seeking namelist \"%s\".\n", 324 buf, nl->name); 325 fflush (stderr); 326 for (;;) 327 switch (GETC (ch)) 328 { 329 case EOF: 330 err (a->ciend, EOF, where0); 331 case '/': 332 case '&': 333 case '$': 334 if (f__external) 335 e_rsle (); 336 else 337 z_rnew (); 338 goto top; 339 case '"': 340 case '\'': 341 quote = ch; 342 more_quoted: 343 while (GETC (ch) != quote) 344 if (ch == EOF) 345 err (a->ciend, EOF, where0); 346 if (GETC (ch) == quote) 347 goto more_quoted; 348 Ungetc (ch, f__cf); 349 default: 350 continue; 351 } 352 } 353 #endif 354 ht = mk_hashtab (nl); 355 if (!ht) 356 errfl (f__elist->cierr, 113, where0); 357 for (;;) 358 { 359 for (;;) 360 switch (GETC (ch)) 361 { 362 case EOF: 363 if (got1) 364 return 0; 365 err (a->ciend, EOF, where0); 366 case '/': 367 case '$': 368 case '&': 369 return 0; 370 default: 371 if ((ch <= ' ' && ch >= 0) || ch == ',') 372 continue; 373 Ungetc (ch, f__cf); 374 if ((ch = getname (buf, sizeof (buf)))) 375 return ch; 376 goto havename; 377 } 378 havename: 379 v = hash (ht, buf); 380 if (!v) 381 errfl (a->cierr, 119, where); 382 while (GETC (ch) <= ' ' && ch >= 0); 383 vaddr = v->addr; 384 type = v->type; 385 if (type < 0) 386 { 387 size = -type; 388 type = TYCHAR; 389 } 390 else 391 size = f__typesize[type]; 392 ivae = size; 393 iva = readall = 0; 394 if (ch == '(' /*) */ ) 395 { 396 dn = dimens; 397 if (!(dims = v->dims)) 398 { 399 if (type != TYCHAR) 400 errfl (a->cierr, 122, where); 401 if ((k = getdimen (&ch, dn, (ftnlen) size, (ftnlen) size, &b))) 402 errfl (a->cierr, k, where); 403 if (ch != ')') 404 errfl (a->cierr, 115, where); 405 b1 = dn->extent; 406 if (--b < 0 || b + b1 > size) 407 return 124; 408 iva += b; 409 size = b1; 410 while (GETC (ch) <= ' ' && ch >= 0); 411 goto scalar; 412 } 413 nd = (int) dims[0]; 414 nomax = span = dims[1]; 415 ivae = iva + size * nomax; 416 colonseen = 0; 417 if ((k = getdimen (&ch, dn, size, nomax, &b))) 418 errfl (a->cierr, k, where); 419 no = dn->extent; 420 b0 = dims[2]; 421 dims1 = dims += 3; 422 ex = 1; 423 for (n = 1; n++ < nd; dims++) 424 { 425 if (ch != ',') 426 errfl (a->cierr, 115, where); 427 dn1 = dn + 1; 428 span /= *dims; 429 if ((k = getdimen (&ch, dn1, dn->delta ** dims, span, &b1))) 430 errfl (a->cierr, k, where); 431 ex *= *dims; 432 b += b1 * ex; 433 no *= dn1->extent; 434 dn = dn1; 435 } 436 if (ch != ')') 437 errfl (a->cierr, 115, where); 438 readall = 1 - colonseen; 439 b -= b0; 440 if (b < 0 || b >= nomax) 441 errfl (a->cierr, 125, where); 442 iva += size * b; 443 dims = dims1; 444 while (GETC (ch) <= ' ' && ch >= 0); 445 no1 = 1; 446 dn0 = dimens; 447 if (type == TYCHAR && ch == '(' /*) */ ) 448 { 449 if ((k = getdimen (&ch, &substr, size, size, &b))) 450 errfl (a->cierr, k, where); 451 if (ch != ')') 452 errfl (a->cierr, 115, where); 453 b1 = substr.extent; 454 if (--b < 0 || b + b1 > size) 455 return 124; 456 iva += b; 457 b0 = size; 458 size = b1; 459 while (GETC (ch) <= ' ' && ch >= 0); 460 if (b1 < b0) 461 goto delta_adj; 462 } 463 if (readall) 464 goto delta_adj; 465 for (; dn0 < dn; dn0++) 466 { 467 if (dn0->extent != *dims++ || dn0->stride != 1) 468 break; 469 no1 *= dn0->extent; 470 } 471 if (dn0 == dimens && dimens[0].stride == 1) 472 { 473 no1 = dimens[0].extent; 474 dn0++; 475 } 476 delta_adj: 477 ex = 0; 478 for (dn1 = dn0; dn1 <= dn; dn1++) 479 ex += (dn1->extent - 1) * (dn1->delta *= dn1->stride); 480 for (dn1 = dn; dn1 > dn0; dn1--) 481 { 482 ex -= (dn1->extent - 1) * dn1->delta; 483 dn1->delta -= ex; 484 } 485 } 486 else if ((dims = v->dims)) 487 { 488 no = no1 = dims[1]; 489 ivae = iva + no * size; 490 } 491 else 492 scalar: 493 no = no1 = 1; 494 if (ch != '=') 495 errfl (a->cierr, 115, where); 496 got1 = nml_read = 1; 497 f__lcount = 0; 498 readloop: 499 for (;;) 500 { 501 if (iva >= ivae || iva < 0) 502 { 503 f__lquit = 1; 504 goto mustend; 505 } 506 else if (iva + no1 * size > ivae) 507 no1 = (ivae - iva) / size; 508 f__lquit = 0; 509 if ((k = l_read (&no1, vaddr + iva, size, type))) 510 return k; 511 if (f__lquit == 1) 512 return 0; 513 if (readall) 514 { 515 iva += dn0->delta; 516 if (f__lcount > 0) 517 { 518 ftnint no2 = (ivae - iva) / size; 519 if (no2 > f__lcount) 520 no2 = f__lcount; 521 if ((k = l_read (&no2, vaddr + iva, size, type))) 522 return k; 523 iva += no2 * dn0->delta; 181 524 } 182 while(*s = Alphanum[GETC(ch) & 0xff]) 183 if (s < se) 184 s++; 185 if (ch == EOF) 186 err(f__elist->cierr, EOF, "namelist read"); 187 if (ch > ' ') 188 Ungetc(ch,f__cf); 189 return *s = 0; 525 } 526 mustend: 527 GETC (ch); 528 if (readall) 529 { 530 if (iva >= ivae) 531 readall = 0; 532 else 533 for (;;) 534 { 535 switch (ch) 536 { 537 case ' ': 538 case '\t': 539 case '\n': 540 GETC (ch); 541 continue; 542 } 543 break; 544 } 545 } 546 if (ch == '/' || ch == '$' || ch == '&') 547 { 548 f__lquit = 1; 549 return 0; 550 } 551 else if (f__lquit) 552 { 553 while (ch <= ' ' && ch >= 0) 554 GETC (ch); 555 Ungetc (ch, f__cf); 556 if (!Alpha[ch & 0xff] && ch >= 0) 557 errfl (a->cierr, 125, where); 558 break; 559 } 560 Ungetc (ch, f__cf); 561 if (readall && !Alpha[ch & 0xff]) 562 goto readloop; 563 if ((no -= no1) <= 0) 564 break; 565 for (dn1 = dn0; dn1 <= dn; dn1++) 566 { 567 if (++dn1->curval < dn1->extent) 568 { 569 iva += dn1->delta; 570 goto readloop; 571 } 572 dn1->curval = 0; 573 } 574 break; 190 575 } 191 192 static int 193 #ifdef KR_headers 194 getnum(chp, val) int *chp; ftnlen *val; 195 #else 196 getnum(int *chp, ftnlen *val) 197 #endif 198 { 199 register int ch, sign; 200 register ftnlen x; 201 202 while(GETC(ch) <= ' ' && ch >= 0); 203 if (ch == '-') { 204 sign = 1; 205 GETC(ch); 206 } 207 else { 208 sign = 0; 209 if (ch == '+') 210 GETC(ch); 211 } 212 x = ch - '0'; 213 if (x < 0 || x > 9) 214 return 115; 215 while(GETC(ch) >= '0' && ch <= '9') 216 x = 10*x + ch - '0'; 217 while(ch <= ' ' && ch >= 0) 218 GETC(ch); 219 if (ch == EOF) 220 return EOF; 221 *val = sign ? -x : x; 222 *chp = ch; 223 return 0; 224 } 225 226 static int 227 #ifdef KR_headers 228 getdimen(chp, d, delta, extent, x1) 229 int *chp; dimen *d; ftnlen delta, extent, *x1; 230 #else 231 getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1) 232 #endif 233 { 234 register int k; 235 ftnlen x2, x3; 236 237 if (k = getnum(chp, x1)) 238 return k; 239 x3 = 1; 240 if (*chp == ':') { 241 if (k = getnum(chp, &x2)) 242 return k; 243 x2 -= *x1; 244 if (*chp == ':') { 245 if (k = getnum(chp, &x3)) 246 return k; 247 if (!x3) 248 return 123; 249 x2 /= x3; 250 colonseen = 1; 251 } 252 if (x2 < 0 || x2 >= extent) 253 return 123; 254 d->extent = x2 + 1; 255 } 256 else 257 d->extent = 1; 258 d->curval = 0; 259 d->delta = delta; 260 d->stride = x3; 261 return 0; 262 } 263 264 #ifndef No_Namelist_Questions 265 static Void 266 #ifdef KR_headers 267 print_ne(a) cilist *a; 268 #else 269 print_ne(cilist *a) 270 #endif 271 { 272 flag intext = f__external; 273 int rpsave = f__recpos; 274 FILE *cfsave = f__cf; 275 unit *usave = f__curunit; 276 cilist t; 277 t = *a; 278 t.ciunit = 6; 279 s_wsne(&t); 280 fflush(f__cf); 281 f__external = intext; 282 f__reading = 1; 283 f__recpos = rpsave; 284 f__cf = cfsave; 285 f__curunit = usave; 286 f__elist = a; 287 } 288 #endif 289 290 static char where0[] = "namelist read start "; 291 292 #ifdef KR_headers 293 x_rsne(a) cilist *a; 294 #else 295 x_rsne(cilist *a) 296 #endif 297 { 298 int ch, got1, k, n, nd, quote, readall; 299 Namelist *nl; 300 static char where[] = "namelist read"; 301 char buf[64]; 302 hashtab *ht; 303 Vardesc *v; 304 dimen *dn, *dn0, *dn1; 305 ftnlen *dims, *dims1; 306 ftnlen b, b0, b1, ex, no, nomax, size, span; 307 ftnint no1, type; 308 char *vaddr; 309 long iva, ivae; 310 dimen dimens[MAXDIM], substr; 311 312 if (!Alpha['a']) 313 nl_init(); 314 f__reading=1; 315 f__formatted=1; 316 got1 = 0; 317 top: 318 for(;;) switch(GETC(ch)) { 319 case EOF: 320 eof: 321 err(a->ciend,(EOF),where0); 322 case '&': 323 case '$': 324 goto have_amp; 325 #ifndef No_Namelist_Questions 326 case '?': 327 print_ne(a); 328 continue; 329 #endif 330 default: 331 if (ch <= ' ' && ch >= 0) 332 continue; 333 #ifndef No_Namelist_Comments 334 while(GETC(ch) != '\n') 335 if (ch == EOF) 336 goto eof; 337 #else 338 errfl(a->cierr, 115, where0); 339 #endif 340 } 341 have_amp: 342 if (ch = getname(buf,sizeof(buf))) 343 return ch; 344 nl = (Namelist *)a->cifmt; 345 if (strcmp(buf, nl->name)) 346 #ifdef No_Bad_Namelist_Skip 347 errfl(a->cierr, 118, where0); 348 #else 349 { 350 fprintf(stderr, 351 "Skipping namelist \"%s\": seeking namelist \"%s\".\n", 352 buf, nl->name); 353 fflush(stderr); 354 for(;;) switch(GETC(ch)) { 355 case EOF: 356 err(a->ciend, EOF, where0); 357 case '/': 358 case '&': 359 case '$': 360 if (f__external) 361 e_rsle(); 362 else 363 z_rnew(); 364 goto top; 365 case '"': 366 case '\'': 367 quote = ch; 368 more_quoted: 369 while(GETC(ch) != quote) 370 if (ch == EOF) 371 err(a->ciend, EOF, where0); 372 if (GETC(ch) == quote) 373 goto more_quoted; 374 Ungetc(ch,f__cf); 375 default: 376 continue; 377 } 378 } 379 #endif 380 ht = mk_hashtab(nl); 381 if (!ht) 382 errfl(f__elist->cierr, 113, where0); 383 for(;;) { 384 for(;;) switch(GETC(ch)) { 385 case EOF: 386 if (got1) 387 return 0; 388 err(a->ciend, EOF, where0); 389 case '/': 390 case '$': 391 case '&': 392 return 0; 393 default: 394 if (ch <= ' ' && ch >= 0 || ch == ',') 395 continue; 396 Ungetc(ch,f__cf); 397 if (ch = getname(buf,sizeof(buf))) 398 return ch; 399 goto havename; 400 } 401 havename: 402 v = hash(ht,buf); 403 if (!v) 404 errfl(a->cierr, 119, where); 405 while(GETC(ch) <= ' ' && ch >= 0); 406 vaddr = v->addr; 407 type = v->type; 408 if (type < 0) { 409 size = -type; 410 type = TYCHAR; 411 } 412 else 413 size = f__typesize[type]; 414 ivae = size; 415 iva = readall = 0; 416 if (ch == '(' /*)*/ ) { 417 dn = dimens; 418 if (!(dims = v->dims)) { 419 if (type != TYCHAR) 420 errfl(a->cierr, 122, where); 421 if (k = getdimen(&ch, dn, (ftnlen)size, 422 (ftnlen)size, &b)) 423 errfl(a->cierr, k, where); 424 if (ch != ')') 425 errfl(a->cierr, 115, where); 426 b1 = dn->extent; 427 if (--b < 0 || b + b1 > size) 428 return 124; 429 iva += b; 430 size = b1; 431 while(GETC(ch) <= ' ' && ch >= 0); 432 goto scalar; 433 } 434 nd = (int)dims[0]; 435 nomax = span = dims[1]; 436 ivae = iva + size*nomax; 437 colonseen = 0; 438 if (k = getdimen(&ch, dn, size, nomax, &b)) 439 errfl(a->cierr, k, where); 440 no = dn->extent; 441 b0 = dims[2]; 442 dims1 = dims += 3; 443 ex = 1; 444 for(n = 1; n++ < nd; dims++) { 445 if (ch != ',') 446 errfl(a->cierr, 115, where); 447 dn1 = dn + 1; 448 span /= *dims; 449 if (k = getdimen(&ch, dn1, dn->delta**dims, 450 span, &b1)) 451 errfl(a->cierr, k, where); 452 ex *= *dims; 453 b += b1*ex; 454 no *= dn1->extent; 455 dn = dn1; 456 } 457 if (ch != ')') 458 errfl(a->cierr, 115, where); 459 readall = 1 - colonseen; 460 b -= b0; 461 if (b < 0 || b >= nomax) 462 errfl(a->cierr, 125, where); 463 iva += size * b; 464 dims = dims1; 465 while(GETC(ch) <= ' ' && ch >= 0); 466 no1 = 1; 467 dn0 = dimens; 468 if (type == TYCHAR && ch == '(' /*)*/) { 469 if (k = getdimen(&ch, &substr, size, size, &b)) 470 errfl(a->cierr, k, where); 471 if (ch != ')') 472 errfl(a->cierr, 115, where); 473 b1 = substr.extent; 474 if (--b < 0 || b + b1 > size) 475 return 124; 476 iva += b; 477 b0 = size; 478 size = b1; 479 while(GETC(ch) <= ' ' && ch >= 0); 480 if (b1 < b0) 481 goto delta_adj; 482 } 483 if (readall) 484 goto delta_adj; 485 for(; dn0 < dn; dn0++) { 486 if (dn0->extent != *dims++ || dn0->stride != 1) 487 break; 488 no1 *= dn0->extent; 489 } 490 if (dn0 == dimens && dimens[0].stride == 1) { 491 no1 = dimens[0].extent; 492 dn0++; 493 } 494 delta_adj: 495 ex = 0; 496 for(dn1 = dn0; dn1 <= dn; dn1++) 497 ex += (dn1->extent-1) 498 * (dn1->delta *= dn1->stride); 499 for(dn1 = dn; dn1 > dn0; dn1--) { 500 ex -= (dn1->extent - 1) * dn1->delta; 501 dn1->delta -= ex; 502 } 503 } 504 else if (dims = v->dims) { 505 no = no1 = dims[1]; 506 ivae = iva + no*size; 507 } 508 else 509 scalar: 510 no = no1 = 1; 511 if (ch != '=') 512 errfl(a->cierr, 115, where); 513 got1 = nml_read = 1; 514 f__lcount = 0; 515 readloop: 516 for(;;) { 517 if (iva >= ivae || iva < 0) { 518 f__lquit = 1; 519 goto mustend; 520 } 521 else if (iva + no1*size > ivae) 522 no1 = (ivae - iva)/size; 523 f__lquit = 0; 524 if (k = l_read(&no1, vaddr + iva, size, type)) 525 return k; 526 if (f__lquit == 1) 527 return 0; 528 if (readall) { 529 iva += dn0->delta; 530 if (f__lcount > 0) { 531 no1 = (ivae - iva)/size; 532 if (no1 > f__lcount) 533 no1 = f__lcount; 534 if (k = l_read(&no1, vaddr + iva, 535 size, type)) 536 return k; 537 iva += no1 * dn0->delta; 538 } 539 } 540 mustend: 541 GETC(ch); 542 if (readall) 543 if (iva >= ivae) 544 readall = 0; 545 else for(;;) { 546 switch(ch) { 547 case ' ': 548 case '\t': 549 case '\n': 550 GETC(ch); 551 continue; 552 } 553 break; 554 } 555 if (ch == '/' || ch == '$' || ch == '&') { 556 f__lquit = 1; 557 return 0; 558 } 559 else if (f__lquit) { 560 while(ch <= ' ' && ch >= 0) 561 GETC(ch); 562 Ungetc(ch,f__cf); 563 if (!Alpha[ch & 0xff] && ch >= 0) 564 errfl(a->cierr, 125, where); 565 break; 566 } 567 Ungetc(ch,f__cf); 568 if (readall && !Alpha[ch & 0xff]) 569 goto readloop; 570 if ((no -= no1) <= 0) 571 break; 572 for(dn1 = dn0; dn1 <= dn; dn1++) { 573 if (++dn1->curval < dn1->extent) { 574 iva += dn1->delta; 575 goto readloop; 576 } 577 dn1->curval = 0; 578 } 579 break; 580 } 581 } 582 } 583 584 integer 585 #ifdef KR_headers 586 s_rsne(a) cilist *a; 587 #else 588 s_rsne(cilist *a) 589 #endif 590 { 591 extern int l_eof; 592 int n; 593 594 f__external=1; 595 l_eof = 0; 596 if(n = c_le(a)) 597 return n; 598 if(f__curunit->uwrt && f__nowreading(f__curunit)) 599 err(a->cierr,errno,where0); 600 l_getc = t_getc; 601 l_ungetc = un_getc; 602 f__doend = xrd_SL; 603 n = x_rsne(a); 604 nml_read = 0; 605 if (n) 606 return n; 607 return e_rsle(); 608 } 576 } 577 } 578 579 integer 580 s_rsne (cilist * a) 581 { 582 extern int l_eof; 583 int n; 584 585 f__external = 1; 586 l_eof = 0; 587 if ((n = c_le (a))) 588 return n; 589 if (f__curunit->uwrt && f__nowreading (f__curunit)) 590 err (a->cierr, errno, where0); 591 l_getc = t_getc; 592 l_ungetc = un_getc; 593 f__doend = xrd_SL; 594 n = x_rsne (a); 595 nml_read = 0; 596 if (n) 597 return n; 598 return e_rsle (); 599 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/sfe.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 6 6 extern char *f__fmtbuf; 7 7 8 integer e_rsfe(Void) 9 { int n; 10 f__init = 1; 11 n=en_fio(); 12 f__fmtbuf=NULL; 13 return(n); 8 integer 9 e_rsfe (void) 10 { 11 int n; 12 f__init = 1; 13 n = en_fio (); 14 f__fmtbuf = NULL; 15 return (n); 14 16 } 15 #ifdef KR_headers 16 c_sfe(a) cilist *a; /* check */ 17 #else 18 c_sfe(cilist *a) /* check */ 17 18 int 19 c_sfe (cilist * a) /* check */ 20 { 21 unit *p; 22 if (a->ciunit >= MXUNIT || a->ciunit < 0) 23 err (a->cierr, 101, "startio"); 24 p = &f__units[a->ciunit]; 25 if (p->ufd == NULL && fk_open (SEQ, FMT, a->ciunit)) 26 err (a->cierr, 114, "sfe"); 27 if (!p->ufmt) 28 err (a->cierr, 102, "sfe"); 29 return (0); 30 } 31 32 integer 33 e_wsfe (void) 34 { 35 int n; 36 f__init = 1; 37 n = en_fio (); 38 f__fmtbuf = NULL; 39 #ifdef ALWAYS_FLUSH 40 if (!n && fflush (f__cf)) 41 err (f__elist->cierr, errno, "write end"); 19 42 #endif 20 { unit *p; 21 if(a->ciunit >= MXUNIT || a->ciunit<0) 22 err(a->cierr,101,"startio"); 23 p = &f__units[a->ciunit]; 24 if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe"); 25 if(!p->ufmt) err(a->cierr,102,"sfe"); 26 return(0); 43 return n; 27 44 } 28 integer e_wsfe(Void)29 {30 int n;31 f__init = 1;32 n = en_fio();33 f__fmtbuf=NULL;34 #ifdef ALWAYS_FLUSH35 if (!n && fflush(f__cf))36 err(f__elist->cierr, errno, "write end");37 #endif38 return n;39 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/sue.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 5 5 off_t f__recloc; 6 6 7 #ifdef KR_headers 8 c_sue(a) cilist *a; 9 #else 10 c_sue(cilist *a) 7 int 8 c_sue (cilist * a) 9 { 10 f__external = f__sequential = 1; 11 f__formatted = 0; 12 f__curunit = &f__units[a->ciunit]; 13 if (a->ciunit >= MXUNIT || a->ciunit < 0) 14 err (a->cierr, 101, "startio"); 15 f__elist = a; 16 if (f__curunit->ufd == NULL && fk_open (SEQ, UNF, a->ciunit)) 17 err (a->cierr, 114, "sue"); 18 f__cf = f__curunit->ufd; 19 if (f__curunit->ufmt) 20 err (a->cierr, 103, "sue"); 21 if (!f__curunit->useek) 22 err (a->cierr, 103, "sue"); 23 return (0); 24 } 25 26 integer 27 s_rsue (cilist * a) 28 { 29 int n; 30 if (f__init != 1) 31 f_init (); 32 f__init = 3; 33 f__reading = 1; 34 if ((n = c_sue (a))) 35 return (n); 36 f__recpos = 0; 37 if (f__curunit->uwrt && f__nowreading (f__curunit)) 38 err (a->cierr, errno, "read start"); 39 if (fread ((char *) &f__reclen, sizeof (uiolen), 1, f__cf) != 1) 40 { 41 if (feof (f__cf)) 42 { 43 f__curunit->uend = 1; 44 err (a->ciend, EOF, "start"); 45 } 46 clearerr (f__cf); 47 err (a->cierr, errno, "start"); 48 } 49 return (0); 50 } 51 52 integer 53 s_wsue (cilist * a) 54 { 55 int n; 56 if (f__init != 1) 57 f_init (); 58 f__init = 3; 59 if ((n = c_sue (a))) 60 return (n); 61 f__reading = 0; 62 f__reclen = 0; 63 if (f__curunit->uwrt != 1 && f__nowwriting (f__curunit)) 64 err (a->cierr, errno, "write start"); 65 f__recloc = FTELL (f__cf); 66 FSEEK (f__cf, (off_t) sizeof (uiolen), SEEK_CUR); 67 return (0); 68 } 69 70 integer 71 e_wsue (void) 72 { 73 off_t loc; 74 f__init = 1; 75 fwrite ((char *) &f__reclen, sizeof (uiolen), 1, f__cf); 76 #ifdef ALWAYS_FLUSH 77 if (fflush (f__cf)) 78 err (f__elist->cierr, errno, "write end"); 11 79 #endif 80 loc = FTELL (f__cf); 81 FSEEK (f__cf, f__recloc, SEEK_SET); 82 fwrite ((char *) &f__reclen, sizeof (uiolen), 1, f__cf); 83 FSEEK (f__cf, loc, SEEK_SET); 84 return (0); 85 } 86 87 integer 88 e_rsue (void) 12 89 { 13 f__external=f__sequential=1; 14 f__formatted=0; 15 f__curunit = &f__units[a->ciunit]; 16 if(a->ciunit >= MXUNIT || a->ciunit < 0) 17 err(a->cierr,101,"startio"); 18 f__elist=a; 19 if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit)) 20 err(a->cierr,114,"sue"); 21 f__cf=f__curunit->ufd; 22 if(f__curunit->ufmt) err(a->cierr,103,"sue"); 23 if(!f__curunit->useek) err(a->cierr,103,"sue"); 24 return(0); 90 f__init = 1; 91 FSEEK (f__cf, (off_t) (f__reclen - f__recpos + sizeof (uiolen)), SEEK_CUR); 92 return (0); 25 93 } 26 #ifdef KR_headers27 integer s_rsue(a) cilist *a;28 #else29 integer s_rsue(cilist *a)30 #endif31 {32 int n;33 if(f__init != 1) f_init();34 f__init = 3;35 f__reading=1;36 if(n=c_sue(a)) return(n);37 f__recpos=0;38 if(f__curunit->uwrt && f__nowreading(f__curunit))39 err(a->cierr, errno, "read start");40 if(fread((char *)&f__reclen,sizeof(uiolen),1,f__cf)41 != 1)42 { if(feof(f__cf))43 { f__curunit->uend = 1;44 err(a->ciend, EOF, "start");45 }46 clearerr(f__cf);47 err(a->cierr, errno, "start");48 }49 return(0);50 }51 #ifdef KR_headers52 integer s_wsue(a) cilist *a;53 #else54 integer s_wsue(cilist *a)55 #endif56 {57 int n;58 if(f__init != 1) f_init();59 f__init = 3;60 if(n=c_sue(a)) return(n);61 f__reading=0;62 f__reclen=0;63 if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))64 err(a->cierr, errno, "write start");65 f__recloc=FTELL(f__cf);66 FSEEK(f__cf,(off_t)sizeof(uiolen),SEEK_CUR);67 return(0);68 }69 integer e_wsue(Void)70 { off_t loc;71 f__init = 1;72 fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf);73 #ifdef ALWAYS_FLUSH74 if (fflush(f__cf))75 err(f__elist->cierr, errno, "write end");76 #endif77 loc=FTELL(f__cf);78 FSEEK(f__cf,f__recloc,SEEK_SET);79 fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf);80 FSEEK(f__cf,loc,SEEK_SET);81 return(0);82 }83 integer e_rsue(Void)84 {85 f__init = 1;86 FSEEK(f__cf,(off_t)(f__reclen-f__recpos+sizeof(uiolen)),SEEK_CUR);87 return(0);88 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/typesize.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 2 2 #include "f2c.h" 3 3 4 ftnlen f__typesize[] = { 0, 0, sizeof (shortint), sizeof(integer),5 sizeof(real), sizeof(doublereal),6 sizeof(complex), sizeof(doublecomplex),7 sizeof(logical), sizeof(char),8 0, sizeof(integer1),9 sizeof(logical1), sizeof(shortlogical),4 ftnlen f__typesize[] = { 0, 0, sizeof (shortint), sizeof (integer), 5 sizeof (real), sizeof (doublereal), 6 sizeof (complex), sizeof (doublecomplex), 7 sizeof (logical), sizeof (char), 8 0, sizeof (integer1), 9 sizeof (logical1), sizeof (shortlogical), 10 10 #ifdef Allow_TYQUAD 11 sizeof(longint),11 sizeof (longint), 12 12 #endif 13 0}; 13 0 14 }; -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/uio.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 1 #include "config.h" 1 2 #include "f2c.h" 2 3 #include "fio.h" … … 4 5 uiolen f__reclen; 5 6 6 #ifdef KR_headers 7 do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len; 7 int 8 do_us (ftnint * number, char *ptr, ftnlen len) 9 { 10 if (f__reading) 11 { 12 f__recpos += (int) (*number * len); 13 if (f__recpos > f__reclen) 14 err (f__elist->cierr, 110, "do_us"); 15 if (fread (ptr, (size_t) len, (size_t) (*number), f__cf) != (size_t) *number) 16 err (f__elist->ciend, EOF, "do_us"); 17 return (0); 18 } 19 else 20 { 21 f__reclen += *number * len; 22 (void) fwrite (ptr, (size_t) len, (size_t) (*number), f__cf); 23 return (0); 24 } 25 } 26 integer 27 do_ud (ftnint * number, char *ptr, ftnlen len) 28 { 29 f__recpos += (int) (*number * len); 30 if (f__recpos > f__curunit->url && f__curunit->url != 1) 31 err (f__elist->cierr, 110, "do_ud"); 32 if (f__reading) 33 { 34 #ifdef Pad_UDread 35 size_t i; 36 if (!(i = fread (ptr, (size_t) len, (size_t) (*number), f__cf)) 37 && !(f__recpos - *number * len)) 38 err (f__elist->cierr, EOF, "do_ud"); 39 if (i < (size_t) *number) 40 memset (ptr + i * len, 0, (*number - i) * len); 41 return 0; 8 42 #else 9 do_us(ftnint *number, char *ptr, ftnlen len) 43 if (fread (ptr, (size_t) len, (size_t) (*number), f__cf) != *number) 44 err (f__elist->cierr, EOF, "do_ud"); 45 else 46 return (0); 10 47 #endif 48 } 49 (void) fwrite (ptr, (size_t) len, (size_t) (*number), f__cf); 50 return (0); 51 } 52 53 integer 54 do_uio (ftnint * number, char *ptr, ftnlen len) 11 55 { 12 if(f__reading) 13 { 14 f__recpos += (int)(*number * len); 15 if(f__recpos>f__reclen) 16 err(f__elist->cierr, 110, "do_us"); 17 if (fread(ptr,(size_t)len,(size_t)(*number),f__cf) != *number) 18 err(f__elist->ciend, EOF, "do_us"); 19 return(0); 20 } 21 else 22 { 23 f__reclen += *number * len; 24 (void) fwrite(ptr,(size_t)len,(size_t)(*number),f__cf); 25 return(0); 26 } 56 if (f__sequential) 57 return (do_us (number, ptr, len)); 58 else 59 return (do_ud (number, ptr, len)); 27 60 } 28 #ifdef KR_headers29 integer do_ud(number,ptr,len) ftnint *number; char *ptr; ftnlen len;30 #else31 integer do_ud(ftnint *number, char *ptr, ftnlen len)32 #endif33 {34 f__recpos += (int)(*number * len);35 if(f__recpos > f__curunit->url && f__curunit->url!=1)36 err(f__elist->cierr,110,"do_ud");37 if(f__reading)38 {39 #ifdef Pad_UDread40 #ifdef KR_headers41 int i;42 #else43 size_t i;44 #endif45 if (!(i = fread(ptr,(size_t)len,(size_t)(*number),f__cf))46 && !(f__recpos - *number*len))47 err(f__elist->cierr,EOF,"do_ud");48 if (i < *number)49 memset(ptr + i*len, 0, (*number - i)*len);50 return 0;51 #else52 if(fread(ptr,(size_t)len,(size_t)(*number),f__cf) != *number)53 err(f__elist->cierr,EOF,"do_ud");54 else return(0);55 #endif56 }57 (void) fwrite(ptr,(size_t)len,(size_t)(*number),f__cf);58 return(0);59 }60 #ifdef KR_headers61 integer do_uio(number,ptr,len) ftnint *number; char *ptr; ftnlen len;62 #else63 integer do_uio(ftnint *number, char *ptr, ftnlen len)64 #endif65 {66 if(f__sequential)67 return(do_us(number,ptr,len));68 else return(do_ud(number,ptr,len));69 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/util.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 9 9 #include "fio.h" 10 10 11 VOID 12 #ifdef KR_headers 13 g_char(a,alen,b) char *a,*b; ftnlen alen; 14 #else 15 g_char(char *a, ftnlen alen, char *b) 16 #endif 11 void 12 g_char (char *a, ftnlen alen, char *b) 17 13 { 18 14 char *x = a + alen, *y = b + alen; 19 15 20 for(;; y--) { 21 if (x <= a) { 22 *b = 0; 23 return; 24 } 25 if (*--x != ' ') 26 break; 27 } 28 *y-- = 0; 29 do *y-- = *x; 30 while(x-- > a); 16 for (;; y--) 17 { 18 if (x <= a) 19 { 20 *b = 0; 21 return; 31 22 } 23 if (*--x != ' ') 24 break; 25 } 26 *y-- = 0; 27 do 28 *y-- = *x; 29 while (x-- > a); 30 } 32 31 33 VOID 34 #ifdef KR_headers 35 b_char(a,b,blen) char *a,*b; ftnlen blen; 36 #else 37 b_char(char *a, char *b, ftnlen blen) 38 #endif 39 { int i; 40 for(i=0;i<blen && *a!=0;i++) *b++= *a++; 41 for(;i<blen;i++) *b++=' '; 32 void 33 b_char (char *a, char *b, ftnlen blen) 34 { 35 int i; 36 for (i = 0; i < blen && *a != 0; i++) 37 *b++ = *a++; 38 for (; i < blen; i++) 39 *b++ = ' '; 42 40 } 41 43 42 #ifndef NON_UNIX_STDIO 44 #ifdef KR_headers 45 long f__inode(a, dev) char *a; int *dev; 46 #else 47 long f__inode(char *a, int *dev) 48 #endif 49 { struct stat x; 50 if(stat(a,&x)<0) return(-1); 51 *dev = x.st_dev; 52 return(x.st_ino); 43 long 44 f__inode (char *a, int *dev) 45 { 46 struct stat x; 47 if (stat (a, &x) < 0) 48 return (-1); 49 *dev = x.st_dev; 50 return (x.st_ino); 53 51 } 54 52 #endif -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/wref.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 5 5 #endif 6 6 7 #ifndef KR_headers8 7 #undef abs 9 8 #undef min … … 11 10 #include <stdlib.h> 12 11 #include <string.h> 13 #endif14 12 15 13 #include "fmt.h" 16 14 #include "fp.h" 17 15 18 #ifdef KR_headers 19 wrt_E(p,w,d,e,len) ufloat *p; ftnlen len; 16 int 17 wrt_E (ufloat * p, int w, int d, int e, ftnlen len) 18 { 19 char buf[FMAX + EXPMAXDIGS + 4], *s, *se; 20 int d1, delta, e1, i, sign, signspace; 21 double dd; 22 #ifdef WANT_LEAD_0 23 int insert0 = 0; 24 #endif 25 #ifndef VAX 26 int e0 = e; 27 #endif 28 29 if (e <= 0) 30 e = 2; 31 if (f__scale) 32 { 33 if (f__scale >= d + 2 || f__scale <= -d) 34 goto nogood; 35 } 36 if (f__scale <= 0) 37 --d; 38 if (len == sizeof (real)) 39 dd = p->pf; 40 else 41 dd = p->pd; 42 if (dd < 0.) 43 { 44 signspace = sign = 1; 45 dd = -dd; 46 } 47 else 48 { 49 sign = 0; 50 signspace = (int) f__cplus; 51 #ifndef VAX 52 if (!dd) 53 dd = 0.; /* avoid -0 */ 54 #endif 55 } 56 delta = w - (2 /* for the . and the d adjustment above */ 57 + 2 /* for the E+ */ + signspace + d + e); 58 #ifdef WANT_LEAD_0 59 if (f__scale <= 0 && delta > 0) 60 { 61 delta--; 62 insert0 = 1; 63 } 64 else 65 #endif 66 if (delta < 0) 67 { 68 nogood: 69 while (--w >= 0) 70 PUT ('*'); 71 return (0); 72 } 73 if (f__scale < 0) 74 d += f__scale; 75 if (d > FMAX) 76 { 77 d1 = d - FMAX; 78 d = FMAX; 79 } 80 else 81 d1 = 0; 82 sprintf (buf, "%#.*E", d, dd); 83 #ifndef VAX 84 /* check for NaN, Infinity */ 85 if (!isdigit ((unsigned char) buf[0])) 86 { 87 switch (buf[0]) 88 { 89 case 'n': 90 case 'N': 91 signspace = 0; /* no sign for NaNs */ 92 } 93 delta = w - strlen (buf) - signspace; 94 if (delta < 0) 95 goto nogood; 96 while (--delta >= 0) 97 PUT (' '); 98 if (signspace) 99 PUT (sign ? '-' : '+'); 100 for (s = buf; *s; s++) 101 PUT (*s); 102 return 0; 103 } 104 #endif 105 se = buf + d + 3; 106 #ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */ 107 if (f__scale != 1 && dd) 108 sprintf (se, "%+.2d", atoi (se) + 1 - f__scale); 20 109 #else 21 wrt_E(ufloat *p, int w, int d, int e, ftnlen len) 22 #endif 110 if (dd) 111 sprintf (se, "%+.2d", atoi (se) + 1 - f__scale); 112 else 113 strcpy (se, "+00"); 114 #endif 115 s = ++se; 116 if (e < 2) 117 { 118 if (*s != '0') 119 goto nogood; 120 } 121 #ifndef VAX 122 /* accommodate 3 significant digits in exponent */ 123 if (s[2]) 124 { 125 #ifdef Pedantic 126 if (!e0 && !s[3]) 127 for (s -= 2, e1 = 2; s[0] = s[1]; s++); 128 129 /* Pedantic gives the behavior that Fortran 77 specifies, */ 130 /* i.e., requires that E be specified for exponent fields */ 131 /* of more than 3 digits. With Pedantic undefined, we get */ 132 /* the behavior that Cray displays -- you get a bigger */ 133 /* exponent field if it fits. */ 134 #else 135 if (!e0) 136 { 137 for (s -= 2, e1 = 2; (s[0] = s[1]); s++) 138 #ifdef CRAY 139 delta--; 140 if ((delta += 4) < 0) 141 goto nogood 142 #endif 143 ; 144 } 145 #endif 146 else if (e0 >= 0) 147 goto shift; 148 else 149 e1 = e; 150 } 151 else 152 shift: 153 #endif 154 for (s += 2, e1 = 2; *s; ++e1, ++s) 155 if (e1 >= e) 156 goto nogood; 157 while (--delta >= 0) 158 PUT (' '); 159 if (signspace) 160 PUT (sign ? '-' : '+'); 161 s = buf; 162 i = f__scale; 163 if (f__scale <= 0) 164 { 165 #ifdef WANT_LEAD_0 166 if (insert0) 167 PUT ('0'); 168 #endif 169 PUT ('.'); 170 for (; i < 0; ++i) 171 PUT ('0'); 172 PUT (*s); 173 s += 2; 174 } 175 else if (f__scale > 1) 176 { 177 PUT (*s); 178 s += 2; 179 while (--i > 0) 180 PUT (*s++); 181 PUT ('.'); 182 } 183 if (d1) 184 { 185 se -= 2; 186 while (s < se) 187 PUT (*s++); 188 se += 2; 189 do 190 PUT ('0'); 191 while (--d1 > 0); 192 } 193 while (s < se) 194 PUT (*s++); 195 if (e < 2) 196 PUT (s[1]); 197 else 198 { 199 while (++e1 <= e) 200 PUT ('0'); 201 while (*s) 202 PUT (*s++); 203 } 204 return 0; 205 } 206 207 int 208 wrt_F (ufloat * p, int w, int d, ftnlen len) 23 209 { 24 char buf[FMAX+EXPMAXDIGS+4], *s, *se; 25 int d1, delta, e1, i, sign, signspace; 26 double dd; 210 int d1, sign, n; 211 double x; 212 char *b, buf[MAXINTDIGS + MAXFRACDIGS + 4], *s; 213 214 x = (len == sizeof (real) ? p->pf : p->pd); 215 if (d < MAXFRACDIGS) 216 d1 = 0; 217 else 218 { 219 d1 = d - MAXFRACDIGS; 220 d = MAXFRACDIGS; 221 } 222 if (x < 0.) 223 { 224 x = -x; 225 sign = 1; 226 } 227 else 228 { 229 sign = 0; 230 #ifndef VAX 231 if (!x) 232 x = 0.; 233 #endif 234 } 235 236 if ((n = f__scale)) 237 { 238 if (n > 0) 239 do 240 x *= 10.; 241 while (--n > 0); 242 else 243 do 244 x *= 0.1; 245 while (++n < 0); 246 } 247 248 #ifdef USE_STRLEN 249 sprintf (b = buf, "%#.*f", d, x); 250 n = strlen (b) + d1; 251 #else 252 n = sprintf (b = buf, "%#.*f", d, x) + d1; 253 #endif 254 255 #ifndef WANT_LEAD_0 256 if (buf[0] == '0' && d) 257 { 258 ++b; 259 --n; 260 } 261 #endif 262 if (sign) 263 { 264 /* check for all zeros */ 265 for (s = b;;) 266 { 267 while (*s == '0') 268 s++; 269 switch (*s) 270 { 271 case '.': 272 s++; 273 continue; 274 case 0: 275 sign = 0; 276 } 277 break; 278 } 279 } 280 if (sign || f__cplus) 281 ++n; 282 if (n > w) 283 { 27 284 #ifdef WANT_LEAD_0 28 int insert0 = 0; 29 #endif 30 #ifndef VAX 31 int e0 = e; 32 #endif 33 34 if(e <= 0) 35 e = 2; 36 if(f__scale) { 37 if(f__scale >= d + 2 || f__scale <= -d) 38 goto nogood; 39 } 40 if(f__scale <= 0) 41 --d; 42 if (len == sizeof(real)) 43 dd = p->pf; 44 else 45 dd = p->pd; 46 if (dd < 0.) { 47 signspace = sign = 1; 48 dd = -dd; 49 } 50 else { 51 sign = 0; 52 signspace = (int)f__cplus; 53 #ifndef VAX 54 if (!dd) 55 dd = 0.; /* avoid -0 */ 56 #endif 57 } 58 delta = w - (2 /* for the . and the d adjustment above */ 59 + 2 /* for the E+ */ + signspace + d + e); 60 #ifdef WANT_LEAD_0 61 if (f__scale <= 0 && delta > 0) { 62 delta--; 63 insert0 = 1; 64 } 65 else 66 #endif 67 if (delta < 0) { 68 nogood: 69 while(--w >= 0) 70 PUT('*'); 71 return(0); 72 } 73 if (f__scale < 0) 74 d += f__scale; 75 if (d > FMAX) { 76 d1 = d - FMAX; 77 d = FMAX; 78 } 79 else 80 d1 = 0; 81 sprintf(buf,"%#.*E", d, dd); 82 #ifndef VAX 83 /* check for NaN, Infinity */ 84 if (!isdigit(buf[0])) { 85 switch(buf[0]) { 86 case 'n': 87 case 'N': 88 signspace = 0; /* no sign for NaNs */ 89 } 90 delta = w - strlen(buf) - signspace; 91 if (delta < 0) 92 goto nogood; 93 while(--delta >= 0) 94 PUT(' '); 95 if (signspace) 96 PUT(sign ? '-' : '+'); 97 for(s = buf; *s; s++) 98 PUT(*s); 99 return 0; 100 } 101 #endif 102 se = buf + d + 3; 103 #ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */ 104 if (f__scale != 1 && dd) 105 sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); 106 #else 107 if (dd) 108 sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); 109 else 110 strcpy(se, "+00"); 111 #endif 112 s = ++se; 113 if (e < 2) { 114 if (*s != '0') 115 goto nogood; 116 } 117 #ifndef VAX 118 /* accommodate 3 significant digits in exponent */ 119 if (s[2]) { 120 #ifdef Pedantic 121 if (!e0 && !s[3]) 122 for(s -= 2, e1 = 2; s[0] = s[1]; s++); 123 124 /* Pedantic gives the behavior that Fortran 77 specifies, */ 125 /* i.e., requires that E be specified for exponent fields */ 126 /* of more than 3 digits. With Pedantic undefined, we get */ 127 /* the behavior that Cray displays -- you get a bigger */ 128 /* exponent field if it fits. */ 129 #else 130 if (!e0) { 131 for(s -= 2, e1 = 2; s[0] = s[1]; s++) 132 #ifdef CRAY 133 delta--; 134 if ((delta += 4) < 0) 135 goto nogood 136 #endif 137 ; 138 } 139 #endif 140 else if (e0 >= 0) 141 goto shift; 142 else 143 e1 = e; 144 } 145 else 146 shift: 147 #endif 148 for(s += 2, e1 = 2; *s; ++e1, ++s) 149 if (e1 >= e) 150 goto nogood; 151 while(--delta >= 0) 152 PUT(' '); 153 if (signspace) 154 PUT(sign ? '-' : '+'); 155 s = buf; 156 i = f__scale; 157 if (f__scale <= 0) { 158 #ifdef WANT_LEAD_0 159 if (insert0) 160 PUT('0'); 161 #endif 162 PUT('.'); 163 for(; i < 0; ++i) 164 PUT('0'); 165 PUT(*s); 166 s += 2; 167 } 168 else if (f__scale > 1) { 169 PUT(*s); 170 s += 2; 171 while(--i > 0) 172 PUT(*s++); 173 PUT('.'); 174 } 175 if (d1) { 176 se -= 2; 177 while(s < se) PUT(*s++); 178 se += 2; 179 do PUT('0'); while(--d1 > 0); 180 } 181 while(s < se) 182 PUT(*s++); 183 if (e < 2) 184 PUT(s[1]); 185 else { 186 while(++e1 <= e) 187 PUT('0'); 188 while(*s) 189 PUT(*s++); 190 } 191 return 0; 285 if (buf[0] == '0' && --n == w) 286 ++b; 287 else 288 #endif 289 { 290 while (--w >= 0) 291 PUT ('*'); 292 return 0; 192 293 } 193 194 #ifdef KR_headers 195 wrt_F(p,w,d,len) ufloat *p; ftnlen len; 196 #else 197 wrt_F(ufloat *p, int w, int d, ftnlen len) 198 #endif 199 { 200 int d1, sign, n; 201 double x; 202 char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s; 203 204 x= (len==sizeof(real)?p->pf:p->pd); 205 if (d < MAXFRACDIGS) 206 d1 = 0; 207 else { 208 d1 = d - MAXFRACDIGS; 209 d = MAXFRACDIGS; 210 } 211 if (x < 0.) 212 { x = -x; sign = 1; } 213 else { 214 sign = 0; 215 #ifndef VAX 216 if (!x) 217 x = 0.; 218 #endif 219 } 220 221 if (n = f__scale) 222 if (n > 0) 223 do x *= 10.; while(--n > 0); 224 else 225 do x *= 0.1; while(++n < 0); 226 227 #ifdef USE_STRLEN 228 sprintf(b = buf, "%#.*f", d, x); 229 n = strlen(b) + d1; 230 #else 231 n = sprintf(b = buf, "%#.*f", d, x) + d1; 232 #endif 233 234 #ifndef WANT_LEAD_0 235 if (buf[0] == '0' && d) 236 { ++b; --n; } 237 #endif 238 if (sign) { 239 /* check for all zeros */ 240 for(s = b;;) { 241 while(*s == '0') s++; 242 switch(*s) { 243 case '.': 244 s++; continue; 245 case 0: 246 sign = 0; 247 } 248 break; 249 } 250 } 251 if (sign || f__cplus) 252 ++n; 253 if (n > w) { 254 #ifdef WANT_LEAD_0 255 if (buf[0] == '0' && --n == w) 256 ++b; 257 else 258 #endif 259 { 260 while(--w >= 0) 261 PUT('*'); 262 return 0; 263 } 264 } 265 for(w -= n; --w >= 0; ) 266 PUT(' '); 267 if (sign) 268 PUT('-'); 269 else if (f__cplus) 270 PUT('+'); 271 while(n = *b++) 272 PUT(n); 273 while(--d1 >= 0) 274 PUT('0'); 275 return 0; 276 } 294 } 295 for (w -= n; --w >= 0;) 296 PUT (' '); 297 if (sign) 298 PUT ('-'); 299 else if (f__cplus) 300 PUT ('+'); 301 while ((n = *b++)) 302 PUT (n); 303 while (--d1 >= 0) 304 PUT ('0'); 305 return 0; 306 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/wrtfmt.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 7 7 extern char *f__icptr; 8 8 9 10 mv_cur (Void)/* shouldn't use fseek because it insists on calling fflush */9 static int 10 mv_cur (void) /* shouldn't use fseek because it insists on calling fflush */ 11 11 /* instead we know too much about stdio */ 12 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 68 static int 69 #ifdef KR_headers 70 wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len; 71 #else 72 wrt_Z(Uint *n, int w, int minlen, ftnlen len) 13 int cursor = f__cursor; 14 f__cursor = 0; 15 if (f__external == 0) 16 { 17 if (cursor < 0) 18 { 19 if (f__hiwater < f__recpos) 20 f__hiwater = f__recpos; 21 f__recpos += cursor; 22 f__icptr += cursor; 23 if (f__recpos < 0) 24 err (f__elist->cierr, 110, "left off"); 25 } 26 else if (cursor > 0) 27 { 28 if (f__recpos + cursor >= f__svic->icirlen) 29 err (f__elist->cierr, 110, "recend"); 30 if (f__hiwater <= f__recpos) 31 for (; cursor > 0; cursor--) 32 (*f__putn) (' '); 33 else if (f__hiwater <= f__recpos + cursor) 34 { 35 cursor -= f__hiwater - f__recpos; 36 f__icptr += f__hiwater - f__recpos; 37 f__recpos = f__hiwater; 38 for (; cursor > 0; cursor--) 39 (*f__putn) (' '); 40 } 41 else 42 { 43 f__icptr += cursor; 44 f__recpos += cursor; 45 } 46 } 47 return (0); 48 } 49 if (cursor > 0) 50 { 51 if (f__hiwater <= f__recpos) 52 for (; cursor > 0; cursor--) 53 (*f__putn) (' '); 54 else if (f__hiwater <= f__recpos + cursor) 55 { 56 cursor -= f__hiwater - f__recpos; 57 f__recpos = f__hiwater; 58 for (; cursor > 0; cursor--) 59 (*f__putn) (' '); 60 } 61 else 62 { 63 f__recpos += cursor; 64 } 65 } 66 else if (cursor < 0) 67 { 68 if (cursor + f__recpos < 0) 69 err (f__elist->cierr, 110, "left off"); 70 if (f__hiwater < f__recpos) 71 f__hiwater = f__recpos; 72 f__recpos += cursor; 73 } 74 return (0); 75 } 76 77 static int 78 wrt_Z (Uint * n, int w, int minlen, ftnlen len) 79 { 80 register char *s, *se; 81 register int i, w1; 82 static int one = 1; 83 static char hex[] = "0123456789ABCDEF"; 84 s = (char *) n; 85 --len; 86 if (*(char *) &one) 87 { 88 /* little endian */ 89 se = s; 90 s += len; 91 i = -1; 92 } 93 else 94 { 95 se = s + len; 96 i = 1; 97 } 98 for (;; s += i) 99 if (s == se || *s) 100 break; 101 w1 = (i * (se - s) << 1) + 1; 102 if (*s & 0xf0) 103 w1++; 104 if (w1 > w) 105 for (i = 0; i < w; i++) 106 (*f__putn) ('*'); 107 else 108 { 109 if ((minlen -= w1) > 0) 110 w1 += minlen; 111 while (--w >= w1) 112 (*f__putn) (' '); 113 while (--minlen >= 0) 114 (*f__putn) ('0'); 115 if (!(*s & 0xf0)) 116 { 117 (*f__putn) (hex[*s & 0xf]); 118 if (s == se) 119 return 0; 120 s += i; 121 } 122 for (;; s += i) 123 { 124 (*f__putn) (hex[*s >> 4 & 0xf]); 125 (*f__putn) (hex[*s & 0xf]); 126 if (s == se) 127 break; 128 } 129 } 130 return 0; 131 } 132 133 static int 134 wrt_I (Uint * n, int w, ftnlen len, register int base) 135 { 136 int ndigit, sign, spare, i; 137 longint x; 138 char *ans; 139 if (len == sizeof (integer)) 140 x = n->il; 141 else if (len == sizeof (char)) 142 x = n->ic; 143 #ifdef Allow_TYQUAD 144 else if (len == sizeof (longint)) 145 x = n->ili; 73 146 #endif 74 { 75 register char *s, *se; 76 register int i, w1; 77 static int one = 1; 78 static char hex[] = "0123456789ABCDEF"; 79 s = (char *)n; 80 --len; 81 if (*(char *)&one) { 82 /* little endian */ 83 se = s; 84 s += len; 85 i = -1; 86 } 87 else { 88 se = s + len; 89 i = 1; 90 } 91 for(;; s += i) 92 if (s == se || *s) 93 break; 94 w1 = (i*(se-s) << 1) + 1; 95 if (*s & 0xf0) 96 w1++; 97 if (w1 > w) 98 for(i = 0; i < w; i++) 99 (*f__putn)('*'); 100 else { 101 if ((minlen -= w1) > 0) 102 w1 += minlen; 103 while(--w >= w1) 104 (*f__putn)(' '); 105 while(--minlen >= 0) 106 (*f__putn)('0'); 107 if (!(*s & 0xf0)) { 108 (*f__putn)(hex[*s & 0xf]); 109 if (s == se) 110 return 0; 111 s += i; 112 } 113 for(;; s += i) { 114 (*f__putn)(hex[*s >> 4 & 0xf]); 115 (*f__putn)(hex[*s & 0xf]); 116 if (s == se) 117 break; 118 } 119 } 120 return 0; 121 } 122 123 static int 124 #ifdef KR_headers 125 wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base; 126 #else 127 wrt_I(Uint *n, int w, ftnlen len, register int base) 147 else 148 x = n->is; 149 ans = f__icvt (x, &ndigit, &sign, base); 150 spare = w - ndigit; 151 if (sign || f__cplus) 152 spare--; 153 if (spare < 0) 154 for (i = 0; i < w; i++) 155 (*f__putn) ('*'); 156 else 157 { 158 for (i = 0; i < spare; i++) 159 (*f__putn) (' '); 160 if (sign) 161 (*f__putn) ('-'); 162 else if (f__cplus) 163 (*f__putn) ('+'); 164 for (i = 0; i < ndigit; i++) 165 (*f__putn) (*ans++); 166 } 167 return (0); 168 } 169 static int 170 wrt_IM (Uint * n, int w, int m, ftnlen len, int base) 171 { 172 int ndigit, sign, spare, i, xsign; 173 longint x; 174 char *ans; 175 if (sizeof (integer) == len) 176 x = n->il; 177 else if (len == sizeof (char)) 178 x = n->ic; 179 #ifdef Allow_TYQUAD 180 else if (len == sizeof (longint)) 181 x = n->ili; 128 182 #endif 129 { int ndigit,sign,spare,i; 130 longint x; 131 char *ans; 132 if(len==sizeof(integer)) x=n->il; 133 else if(len == sizeof(char)) x = n->ic; 134 #ifdef Allow_TYQUAD 135 else if (len == sizeof(longint)) x = n->ili; 136 #endif 137 else x=n->is; 138 ans=f__icvt(x,&ndigit,&sign, base); 139 spare=w-ndigit; 140 if(sign || f__cplus) spare--; 141 if(spare<0) 142 for(i=0;i<w;i++) (*f__putn)('*'); 143 else 144 { for(i=0;i<spare;i++) (*f__putn)(' '); 145 if(sign) (*f__putn)('-'); 146 else if(f__cplus) (*f__putn)('+'); 147 for(i=0;i<ndigit;i++) (*f__putn)(*ans++); 148 } 149 return(0); 150 } 151 static int 152 #ifdef KR_headers 153 wrt_IM(n,w,m,len,base) Uint *n; ftnlen len; int base; 154 #else 155 wrt_IM(Uint *n, int w, int m, ftnlen len, int base) 156 #endif 157 { int ndigit,sign,spare,i,xsign; 158 longint x; 159 char *ans; 160 if(sizeof(integer)==len) x=n->il; 161 else if(len == sizeof(char)) x = n->ic; 162 #ifdef Allow_TYQUAD 163 else if (len == sizeof(longint)) x = n->ili; 164 #endif 165 else x=n->is; 166 ans=f__icvt(x,&ndigit,&sign, base); 167 if(sign || f__cplus) xsign=1; 168 else xsign=0; 169 if(ndigit+xsign>w || m+xsign>w) 170 { for(i=0;i<w;i++) (*f__putn)('*'); 171 return(0); 172 } 173 if(x==0 && m==0) 174 { for(i=0;i<w;i++) (*f__putn)(' '); 175 return(0); 176 } 177 if(ndigit>=m) 178 spare=w-ndigit-xsign; 179 else 180 spare=w-m-xsign; 181 for(i=0;i<spare;i++) (*f__putn)(' '); 182 if(sign) (*f__putn)('-'); 183 else if(f__cplus) (*f__putn)('+'); 184 for(i=0;i<m-ndigit;i++) (*f__putn)('0'); 185 for(i=0;i<ndigit;i++) (*f__putn)(*ans++); 186 return(0); 187 } 188 static int 189 #ifdef KR_headers 190 wrt_AP(s) char *s; 191 #else 192 wrt_AP(char *s) 193 #endif 194 { char quote; 195 int i; 196 197 if(f__cursor && (i = mv_cur())) 198 return i; 199 quote = *s++; 200 for(;*s;s++) 201 { if(*s!=quote) (*f__putn)(*s); 202 else if(*++s==quote) (*f__putn)(*s); 203 else return(1); 204 } 205 return(1); 206 } 207 static int 208 #ifdef KR_headers 209 wrt_H(a,s) char *s; 210 #else 211 wrt_H(int a, char *s) 212 #endif 213 { 214 int i; 215 216 if(f__cursor && (i = mv_cur())) 217 return i; 218 while(a--) (*f__putn)(*s++); 219 return(1); 220 } 221 #ifdef KR_headers 222 wrt_L(n,len, sz) Uint *n; ftnlen sz; 223 #else 224 wrt_L(Uint *n, int len, ftnlen sz) 225 #endif 226 { int i; 227 long x; 228 if(sizeof(long)==sz) x=n->il; 229 else if(sz == sizeof(char)) x = n->ic; 230 else x=n->is; 231 for(i=0;i<len-1;i++) 232 (*f__putn)(' '); 233 if(x) (*f__putn)('T'); 234 else (*f__putn)('F'); 235 return(0); 236 } 237 static int 238 #ifdef KR_headers 239 wrt_A(p,len) char *p; ftnlen len; 240 #else 241 wrt_A(char *p, ftnlen len) 242 #endif 243 { 244 while(len-- > 0) (*f__putn)(*p++); 245 return(0); 246 } 247 static int 248 #ifdef KR_headers 249 wrt_AW(p,w,len) char * p; ftnlen len; 250 #else 251 wrt_AW(char * p, int w, ftnlen len) 252 #endif 253 { 254 while(w>len) 255 { w--; 256 (*f__putn)(' '); 257 } 258 while(w-- > 0) 259 (*f__putn)(*p++); 260 return(0); 261 } 262 263 static int 264 #ifdef KR_headers 265 wrt_G(p,w,d,e,len) ufloat *p; ftnlen len; 266 #else 267 wrt_G(ufloat *p, int w, int d, int e, ftnlen len) 268 #endif 269 { double up = 1,x; 270 int i=0,oldscale,n,j; 271 x = len==sizeof(real)?p->pf:p->pd; 272 if(x < 0 ) x = -x; 273 if(x<.1) { 274 if (x != 0.) 275 return(wrt_E(p,w,d,e,len)); 276 i = 1; 277 goto have_i; 278 } 279 for(;i<=d;i++,up*=10) 280 { if(x>=up) continue; 281 have_i: 282 oldscale = f__scale; 283 f__scale = 0; 284 if(e==0) n=4; 285 else n=e+2; 286 i=wrt_F(p,w-n,d-i,len); 287 for(j=0;j<n;j++) (*f__putn)(' '); 288 f__scale=oldscale; 289 return(i); 290 } 291 return(wrt_E(p,w,d,e,len)); 292 } 293 #ifdef KR_headers 294 w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len; 295 #else 296 w_ed(struct syl *p, char *ptr, ftnlen len) 297 #endif 298 { 299 int i; 300 301 if(f__cursor && (i = mv_cur())) 302 return i; 303 switch(p->op) 304 { 305 default: 306 fprintf(stderr,"w_ed, unexpected code: %d\n", p->op); 307 sig_die(f__fmtbuf, 1); 308 case I: return(wrt_I((Uint *)ptr,p->p1,len, 10)); 309 case IM: 310 return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,10)); 311 312 /* O and OM don't work right for character, double, complex, */ 313 /* or doublecomplex, and they differ from Fortran 90 in */ 314 /* showing a minus sign for negative values. */ 315 316 case O: return(wrt_I((Uint *)ptr, p->p1, len, 8)); 317 case OM: 318 return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,8)); 319 case L: return(wrt_L((Uint *)ptr,p->p1, len)); 320 case A: return(wrt_A(ptr,len)); 321 case AW: 322 return(wrt_AW(ptr,p->p1,len)); 323 case D: 324 case E: 325 case EE: 326 return(wrt_E((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); 327 case G: 328 case GE: 329 return(wrt_G((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); 330 case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2.i[0],len)); 331 332 /* Z and ZM assume 8-bit bytes. */ 333 334 case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len)); 335 case ZM: 336 return(wrt_Z((Uint *)ptr,p->p1,p->p2.i[0],len)); 337 } 338 } 339 #ifdef KR_headers 340 w_ned(p) struct syl *p; 341 #else 342 w_ned(struct syl *p) 343 #endif 344 { 345 switch(p->op) 346 { 347 default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op); 348 sig_die(f__fmtbuf, 1); 349 case SLASH: 350 return((*f__donewrec)()); 351 case T: f__cursor = p->p1-f__recpos - 1; 352 return(1); 353 case TL: f__cursor -= p->p1; 354 if(f__cursor < -f__recpos) /* TL1000, 1X */ 355 f__cursor = -f__recpos; 356 return(1); 357 case TR: 358 case X: 359 f__cursor += p->p1; 360 return(1); 361 case APOS: 362 return(wrt_AP(p->p2.s)); 363 case H: 364 return(wrt_H(p->p1,p->p2.s)); 365 } 366 } 183 else 184 x = n->is; 185 ans = f__icvt (x, &ndigit, &sign, base); 186 if (sign || f__cplus) 187 xsign = 1; 188 else 189 xsign = 0; 190 if (ndigit + xsign > w || m + xsign > w) 191 { 192 for (i = 0; i < w; i++) 193 (*f__putn) ('*'); 194 return (0); 195 } 196 if (x == 0 && m == 0) 197 { 198 for (i = 0; i < w; i++) 199 (*f__putn) (' '); 200 return (0); 201 } 202 if (ndigit >= m) 203 spare = w - ndigit - xsign; 204 else 205 spare = w - m - xsign; 206 for (i = 0; i < spare; i++) 207 (*f__putn) (' '); 208 if (sign) 209 (*f__putn) ('-'); 210 else if (f__cplus) 211 (*f__putn) ('+'); 212 for (i = 0; i < m - ndigit; i++) 213 (*f__putn) ('0'); 214 for (i = 0; i < ndigit; i++) 215 (*f__putn) (*ans++); 216 return (0); 217 } 218 static int 219 wrt_AP (char *s) 220 { 221 char quote; 222 int i; 223 224 if (f__cursor && (i = mv_cur ())) 225 return i; 226 quote = *s++; 227 for (; *s; s++) 228 { 229 if (*s != quote) 230 (*f__putn) (*s); 231 else if (*++s == quote) 232 (*f__putn) (*s); 233 else 234 return (1); 235 } 236 return (1); 237 } 238 static int 239 wrt_H (int a, char *s) 240 { 241 int i; 242 243 if (f__cursor && (i = mv_cur ())) 244 return i; 245 while (a--) 246 (*f__putn) (*s++); 247 return (1); 248 } 249 250 int 251 wrt_L (Uint * n, int len, ftnlen sz) 252 { 253 int i; 254 long x; 255 if (sizeof (long) == sz) 256 x = n->il; 257 else if (sz == sizeof (char)) 258 x = n->ic; 259 else 260 x = n->is; 261 for (i = 0; i < len - 1; i++) 262 (*f__putn) (' '); 263 if (x) 264 (*f__putn) ('T'); 265 else 266 (*f__putn) ('F'); 267 return (0); 268 } 269 static int 270 wrt_A (char *p, ftnlen len) 271 { 272 while (len-- > 0) 273 (*f__putn) (*p++); 274 return (0); 275 } 276 static int 277 wrt_AW (char *p, int w, ftnlen len) 278 { 279 while (w > len) 280 { 281 w--; 282 (*f__putn) (' '); 283 } 284 while (w-- > 0) 285 (*f__putn) (*p++); 286 return (0); 287 } 288 289 static int 290 wrt_G (ufloat * p, int w, int d, int e, ftnlen len) 291 { 292 double up = 1, x; 293 int i = 0, oldscale, n, j; 294 x = len == sizeof (real) ? p->pf : p->pd; 295 if (x < 0) 296 x = -x; 297 if (x < .1) 298 { 299 if (x != 0.) 300 return (wrt_E (p, w, d, e, len)); 301 i = 1; 302 goto have_i; 303 } 304 for (; i <= d; i++, up *= 10) 305 { 306 if (x >= up) 307 continue; 308 have_i: 309 oldscale = f__scale; 310 f__scale = 0; 311 if (e == 0) 312 n = 4; 313 else 314 n = e + 2; 315 i = wrt_F (p, w - n, d - i, len); 316 for (j = 0; j < n; j++) 317 (*f__putn) (' '); 318 f__scale = oldscale; 319 return (i); 320 } 321 return (wrt_E (p, w, d, e, len)); 322 } 323 324 int 325 w_ed (struct syl * p, char *ptr, ftnlen len) 326 { 327 int i; 328 329 if (f__cursor && (i = mv_cur ())) 330 return i; 331 switch (p->op) 332 { 333 default: 334 fprintf (stderr, "w_ed, unexpected code: %d\n", p->op); 335 sig_die (f__fmtbuf, 1); 336 case I: 337 return (wrt_I ((Uint *) ptr, p->p1, len, 10)); 338 case IM: 339 return (wrt_IM ((Uint *) ptr, p->p1, p->p2.i[0], len, 10)); 340 341 /* O and OM don't work right for character, double, complex, */ 342 /* or doublecomplex, and they differ from Fortran 90 in */ 343 /* showing a minus sign for negative values. */ 344 345 case O: 346 return (wrt_I ((Uint *) ptr, p->p1, len, 8)); 347 case OM: 348 return (wrt_IM ((Uint *) ptr, p->p1, p->p2.i[0], len, 8)); 349 case L: 350 return (wrt_L ((Uint *) ptr, p->p1, len)); 351 case A: 352 return (wrt_A (ptr, len)); 353 case AW: 354 return (wrt_AW (ptr, p->p1, len)); 355 case D: 356 case E: 357 case EE: 358 return (wrt_E ((ufloat *) ptr, p->p1, p->p2.i[0], p->p2.i[1], len)); 359 case G: 360 case GE: 361 return (wrt_G ((ufloat *) ptr, p->p1, p->p2.i[0], p->p2.i[1], len)); 362 case F: 363 return (wrt_F ((ufloat *) ptr, p->p1, p->p2.i[0], len)); 364 365 /* Z and ZM assume 8-bit bytes. */ 366 367 case Z: 368 return (wrt_Z ((Uint *) ptr, p->p1, 0, len)); 369 case ZM: 370 return (wrt_Z ((Uint *) ptr, p->p1, p->p2.i[0], len)); 371 } 372 } 373 374 int 375 w_ned (struct syl * p) 376 { 377 switch (p->op) 378 { 379 default: 380 fprintf (stderr, "w_ned, unexpected code: %d\n", p->op); 381 sig_die (f__fmtbuf, 1); 382 case SLASH: 383 return ((*f__donewrec) ()); 384 case T: 385 f__cursor = p->p1 - f__recpos - 1; 386 return (1); 387 case TL: 388 f__cursor -= p->p1; 389 if (f__cursor < -f__recpos) /* TL1000, 1X */ 390 f__cursor = -f__recpos; 391 return (1); 392 case TR: 393 case X: 394 f__cursor += p->p1; 395 return (1); 396 case APOS: 397 return (wrt_AP (p->p2.s)); 398 case H: 399 return (wrt_H (p->p1, p->p2.s)); 400 } 401 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/wsfe.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 6 6 extern int f__hiwater; 7 7 8 9 x_wSL (Void)8 int 9 x_wSL (void) 10 10 { 11 int n = f__putbuf('\n');12 13 return(n == 0);11 int n = f__putbuf ('\n'); 12 f__hiwater = f__recpos = f__cursor = 0; 13 return (n == 0); 14 14 } 15 15 16 17 xw_end (Void)16 static int 17 xw_end (void) 18 18 { 19 19 int n; 20 20 21 if(f__nonl) { 22 f__putbuf(n = 0); 23 fflush(f__cf); 24 } 25 else 26 n = f__putbuf('\n'); 27 f__hiwater = f__recpos = f__cursor = 0; 28 return n; 21 if (f__nonl) 22 { 23 f__putbuf (n = 0); 24 fflush (f__cf); 25 } 26 else 27 n = f__putbuf ('\n'); 28 f__hiwater = f__recpos = f__cursor = 0; 29 return n; 29 30 } 30 31 31 32 xw_rev (Void)32 static int 33 xw_rev (void) 33 34 { 34 int n = 0; 35 if(f__workdone) { 36 n = f__putbuf('\n'); 37 f__workdone = 0; 38 } 39 f__hiwater = f__recpos = f__cursor = 0; 40 return n; 35 int n = 0; 36 if (f__workdone) 37 { 38 n = f__putbuf ('\n'); 39 f__workdone = 0; 40 } 41 f__hiwater = f__recpos = f__cursor = 0; 42 return n; 41 43 } 42 44 43 #ifdef KR_headers 44 integer s_wsfe(a) cilist *a; /*start*/ 45 #else 46 integer s_wsfe(cilist *a) /*start*/ 47 #endif 48 { int n; 49 if(f__init != 1) f_init(); 50 f__init = 3; 51 f__reading=0; 52 f__sequential=1; 53 f__formatted=1; 54 f__external=1; 55 if(n=c_sfe(a)) return(n); 56 f__elist=a; 57 f__hiwater = f__cursor=f__recpos=0; 58 f__nonl = 0; 59 f__scale=0; 60 f__fmtbuf=a->cifmt; 61 f__curunit = &f__units[a->ciunit]; 62 f__cf=f__curunit->ufd; 63 if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); 64 f__putn= x_putc; 65 f__doed= w_ed; 66 f__doned= w_ned; 67 f__doend=xw_end; 68 f__dorevert=xw_rev; 69 f__donewrec=x_wSL; 70 fmt_bg(); 71 f__cplus=0; 72 f__cblank=f__curunit->ublnk; 73 if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) 74 err(a->cierr,errno,"write start"); 75 return(0); 45 integer 46 s_wsfe (cilist * a) /*start */ 47 { 48 int n; 49 if (f__init != 1) 50 f_init (); 51 f__init = 3; 52 f__reading = 0; 53 f__sequential = 1; 54 f__formatted = 1; 55 f__external = 1; 56 if ((n = c_sfe (a))) 57 return (n); 58 f__elist = a; 59 f__hiwater = f__cursor = f__recpos = 0; 60 f__nonl = 0; 61 f__scale = 0; 62 f__fmtbuf = a->cifmt; 63 f__curunit = &f__units[a->ciunit]; 64 f__cf = f__curunit->ufd; 65 if (pars_f (f__fmtbuf) < 0) 66 err (a->cierr, 100, "startio"); 67 f__putn = x_putc; 68 f__doed = w_ed; 69 f__doned = w_ned; 70 f__doend = xw_end; 71 f__dorevert = xw_rev; 72 f__donewrec = x_wSL; 73 fmt_bg (); 74 f__cplus = 0; 75 f__cblank = f__curunit->ublnk; 76 if (f__curunit->uwrt != 1 && f__nowwriting (f__curunit)) 77 err (a->cierr, errno, "write start"); 78 return (0); 76 79 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/wsle.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 6 6 #include "string.h" 7 7 8 #ifdef KR_headers 9 integer s_wsle(a) cilist *a; 10 #else 11 integer s_wsle(cilist *a) 8 integer 9 s_wsle (cilist * a) 10 { 11 int n; 12 if ((n = c_le (a))) 13 return (n); 14 f__reading = 0; 15 f__external = 1; 16 f__formatted = 1; 17 f__putn = x_putc; 18 f__lioproc = l_write; 19 L_len = LINE; 20 f__donewrec = x_wSL; 21 if (f__curunit->uwrt != 1 && f__nowwriting (f__curunit)) 22 err (a->cierr, errno, "list output start"); 23 return (0); 24 } 25 26 integer 27 e_wsle (void) 28 { 29 int n; 30 f__init = 1; 31 n = f__putbuf ('\n'); 32 f__recpos = 0; 33 #ifdef ALWAYS_FLUSH 34 if (!n && fflush (f__cf)) 35 err (f__elist->cierr, errno, "write end"); 12 36 #endif 13 { 14 int n; 15 if(n=c_le(a)) return(n); 16 f__reading=0; 17 f__external=1; 18 f__formatted=1; 19 f__putn = x_putc; 20 f__lioproc = l_write; 21 L_len = LINE; 22 f__donewrec = x_wSL; 23 if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) 24 err(a->cierr, errno, "list output start"); 25 return(0); 26 } 27 28 integer e_wsle(Void) 29 { 30 int n; 31 f__init = 1; 32 n = f__putbuf('\n'); 33 f__recpos=0; 34 #ifdef ALWAYS_FLUSH 35 if (!n && fflush(f__cf)) 36 err(f__elist->cierr, errno, "write end"); 37 #endif 38 return(n); 39 } 37 return (n); 38 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/wsne.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 3 3 #include "lio.h" 4 4 5 integer 6 #ifdef KR_headers 7 s_wsne(a) cilist *a; 8 #else 9 s_wsne(cilist *a) 10 #endif 5 integer 6 s_wsne (cilist * a) 11 7 { 12 8 int n; 13 9 14 if(n=c_le(a))15 return(n);16 f__reading=0;17 f__external=1;18 f__formatted=1;19 20 21 22 if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))23 err(a->cierr, errno, "namelist output start");24 x_wsne(a);25 return e_wsle();26 10 if ((n = c_le (a))) 11 return (n); 12 f__reading = 0; 13 f__external = 1; 14 f__formatted = 1; 15 f__putn = x_putc; 16 L_len = LINE; 17 f__donewrec = x_wSL; 18 if (f__curunit->uwrt != 1 && f__nowwriting (f__curunit)) 19 err (a->cierr, errno, "namelist output start"); 20 x_wsne (a); 21 return e_wsle (); 22 } -
Property cvs2svn:cvs-rev
changed from
-
branches/GNU/src/gcc/libf2c/libI77/xwsne.c
-
Property cvs2svn:cvs-rev
changed from
1.1to1.1.1.2
r1390 r1391 7 7 extern int f__Aquote; 8 8 9 static VOID 10 nl_donewrec (Void)9 static void 10 nl_donewrec (void) 11 11 { 12 (*f__donewrec)();13 PUT(' ');14 12 (*f__donewrec) (); 13 PUT (' '); 14 } 15 15 16 #ifdef KR_headers17 x_wsne(a) cilist *a;18 #else19 16 #include <string.h> 20 17 21 VOID 22 x_wsne(cilist *a) 18 void 19 x_wsne (cilist * a) 20 { 21 Namelist *nl; 22 char *s; 23 Vardesc *v, **vd, **vde; 24 ftnint number, type; 25 ftnlen *dims; 26 ftnlen size; 27 extern ftnlen f__typesize[]; 28 29 nl = (Namelist *) a->cifmt; 30 PUT ('&'); 31 for (s = nl->name; *s; s++) 32 PUT (*s); 33 PUT (' '); 34 f__Aquote = 1; 35 vd = nl->vars; 36 vde = vd + nl->nvars; 37 while (vd < vde) 38 { 39 v = *vd++; 40 s = v->name; 41 #ifdef No_Extra_Namelist_Newlines 42 if (f__recpos + strlen (s) + 2 >= L_len) 23 43 #endif 24 { 25 Namelist *nl; 26 char *s; 27 Vardesc *v, **vd, **vde; 28 ftnint number, type; 29 ftnlen *dims; 30 ftnlen size; 31 extern ftnlen f__typesize[]; 32 33 nl = (Namelist *)a->cifmt; 34 PUT('&'); 35 for(s = nl->name; *s; s++) 36 PUT(*s); 37 PUT(' '); 38 f__Aquote = 1; 39 vd = nl->vars; 40 vde = vd + nl->nvars; 41 while(vd < vde) { 42 v = *vd++; 43 s = v->name; 44 #ifdef No_Extra_Namelist_Newlines 45 if (f__recpos+strlen(s)+2 >= L_len) 46 #endif 47 nl_donewrec(); 48 while(*s) 49 PUT(*s++); 50 PUT(' '); 51 PUT('='); 52 number = (dims = v->dims) ? dims[1] : 1; 53 type = v->type; 54 if (type < 0) { 55 size = -type; 56 type = TYCHAR; 57 } 58 else 59 size = f__typesize[type]; 60 l_write(&number, v->addr, size, type); 61 if (vd < vde) { 62 if (f__recpos+2 >= L_len) 63 nl_donewrec(); 64 PUT(','); 65 PUT(' '); 66 } 67 else if (f__recpos+1 >= L_len) 68 nl_donewrec(); 69 } 70 f__Aquote = 0; 71 PUT('/'); 44 nl_donewrec (); 45 while (*s) 46 PUT (*s++); 47 PUT (' '); 48 PUT ('='); 49 number = (dims = v->dims) ? dims[1] : 1; 50 type = v->type; 51 if (type < 0) 52 { 53 size = -type; 54 type = TYCHAR; 72 55 } 56 else 57 size = f__typesize[type]; 58 l_write (&number, v->addr, size, type); 59 if (vd < vde) 60 { 61 if (f__recpos + 2 >= L_len) 62 nl_donewrec (); 63 PUT (','); 64 PUT (' '); 65 } 66 else if (f__recpos + 1 >= L_len) 67 nl_donewrec (); 68 } 69 f__Aquote = 0; 70 PUT ('/'); 71 } -
Property cvs2svn:cvs-rev
changed from
Note:
See TracChangeset
for help on using the changeset viewer.
