Library for f2c. (part 1 of 2)
Obtained from: netlib.att.com
This commit is contained in:
parent
71e0221b87
commit
876f9d8347
Notes:
svn2git
2020-12-20 02:59:44 +00:00
svn path=/cvs2svn/branches/ATT/; revision=3900
23
lib/libI77/Notice
Normal file
23
lib/libI77/Notice
Normal file
@ -0,0 +1,23 @@
|
||||
/****************************************************************
|
||||
Copyright 1990 - 1994 by AT&T Bell Laboratories and Bellcore.
|
||||
|
||||
Permission to use, copy, modify, and distribute this software
|
||||
and its documentation for any purpose and without fee is hereby
|
||||
granted, provided that the above copyright notice appear in all
|
||||
copies and that both that the copyright notice and this
|
||||
permission notice and warranty disclaimer appear in supporting
|
||||
documentation, and that the names of AT&T Bell Laboratories or
|
||||
Bellcore or any of their entities not be used in advertising or
|
||||
publicity pertaining to distribution of the software without
|
||||
specific, written prior permission.
|
||||
|
||||
AT&T and Bellcore disclaim all warranties with regard to this
|
||||
software, including all implied warranties of merchantability
|
||||
and fitness. In no event shall AT&T or Bellcore be liable for
|
||||
any special, indirect or consequential damages or any damages
|
||||
whatsoever resulting from loss of use, data or profits, whether
|
||||
in an action of contract, negligence or other tortious action,
|
||||
arising out of or in connection with the use or performance of
|
||||
this software.
|
||||
****************************************************************/
|
||||
|
174
lib/libI77/README
Normal file
174
lib/libI77/README
Normal file
@ -0,0 +1,174 @@
|
||||
If your compiler does not recognize ANSI C headers,
|
||||
compile with KR_headers defined: either add -DKR_headers
|
||||
to the definition of CFLAGS in the makefile, or insert
|
||||
|
||||
#define KR_headers
|
||||
|
||||
at the top of f2c.h and fmtlib.c .
|
||||
|
||||
|
||||
If you have a really ancient K&R C compiler that does not understand
|
||||
void, add -Dvoid=int to the definition of CFLAGS in the makefile.
|
||||
|
||||
If you use a C++ compiler, first create a local f2c.h by appending
|
||||
f2ch.add to the usual f2c.h, e.g., by issuing the command
|
||||
make f2c.h
|
||||
which assumes f2c.h is installed in /usr/include .
|
||||
|
||||
If your system lacks /usr/include/fcntl.h , then you
|
||||
should simply create an empty fcntl.h in this directory.
|
||||
If your compiler then complains about creat and open not
|
||||
having a prototype, compile with OPEN_DECL defined.
|
||||
On many systems, open and creat are declared in fcntl.h .
|
||||
|
||||
If your system has /usr/include/fcntl.h, you may need to add
|
||||
-D_POSIX_SOURCE to the makefile's definition of CFLAGS.
|
||||
|
||||
If your system's sprintf does not work the way ANSI C
|
||||
specifies -- specifically, if it does not return the
|
||||
number of characters transmitted -- then insert the line
|
||||
|
||||
#define USE_STRLEN
|
||||
|
||||
at the end of fmt.h . This is necessary with
|
||||
at least some versions of Sun and DEC software.
|
||||
|
||||
If your system's fopen does not like the ANSI binary
|
||||
reading and writing modes "rb" and "wb", then you should
|
||||
compile open.c with NON_ANSI_RW_MODES #defined.
|
||||
|
||||
If you get error messages about references to cf->_ptr
|
||||
and cf->_base when compiling wrtfmt.c and wsfe.c or to
|
||||
stderr->_flag when compiling err.c, then insert the line
|
||||
|
||||
#define NON_UNIX_STDIO
|
||||
|
||||
at the beginning of fio.h, and recompile everything (or
|
||||
at least those modules that contain NON_UNIX_STDIO).
|
||||
|
||||
Unformatted sequential records consist of a length of record
|
||||
contents, the record contents themselves, and the length of
|
||||
record contents again (for backspace). Prior to 17 Oct. 1991,
|
||||
the length was of type int; now it is of type long, but you
|
||||
can change it back to int by inserting
|
||||
|
||||
#define UIOLEN_int
|
||||
|
||||
at the beginning of fio.h. This affects only sue.c and uio.c .
|
||||
|
||||
On VAX, Cray, or Research Tenth-Edition Unix systems, you may
|
||||
need to add -DVAX, -DCRAY, or -DV10 (respectively) to CFLAGS
|
||||
to make fp.h work correctly. Alternatively, you may need to
|
||||
edit fp.h to suit your machine.
|
||||
|
||||
You may need to supply the following non-ANSI routines:
|
||||
|
||||
fstat(int fileds, struct stat *buf) is similar
|
||||
to stat(char *name, struct stat *buf), except that
|
||||
the first argument, fileds, is the file descriptor
|
||||
returned by open rather than the name of the file.
|
||||
fstat is used in the system-dependent routine
|
||||
canseek (in the libI77 source file err.c), which
|
||||
is supposed to return 1 if it's possible to issue
|
||||
seeks on the file in question, 0 if it's not; you may
|
||||
need to suitably modify err.c . On non-UNIX systems,
|
||||
you can avoid references to fstat and stat by compiling
|
||||
with NON_UNIX_STDIO defined; in that case, you may need
|
||||
to supply access(char *Name,0), which is supposed to
|
||||
return 0 if file Name exists, nonzero otherwise.
|
||||
|
||||
char * mktemp(char *buf) is supposed to replace the
|
||||
6 trailing X's in buf with a unique number and then
|
||||
return buf. The idea is to get a unique name for
|
||||
a temporary file.
|
||||
|
||||
On non-UNIX systems, you may need to change a few other,
|
||||
e.g.: the form of name computed by mktemp() in endfile.c and
|
||||
open.c; the use of the open(), close(), and creat() system
|
||||
calls in endfile.c, err.c, open.c; and the modes in calls on
|
||||
fopen() and fdopen() (and perhaps the use of fdopen() itself
|
||||
-- it's supposed to return a FILE* corresponding to a given
|
||||
an integer file descriptor) in err.c and open.c (component ufmt
|
||||
of struct unit is 1 for formatted I/O -- text mode on some systems
|
||||
-- and 0 for unformatted I/O -- binary mode on some systems).
|
||||
Compiling with -DNON_UNIX_STDIO omits all references to creat()
|
||||
and almost all references to open() and close(), the exception
|
||||
being in the function f__isdev() (in open.c).
|
||||
|
||||
For MS-DOS, compile all of libI77 with -DMSDOS (which implies
|
||||
-DNON_UNIX_STDIO). You may need to make other compiler-dependent
|
||||
adjustments; for example, for Turbo C++ you need to adjust the mktemp
|
||||
invocations and to #undef ungetc in lread.c and rsne.c .
|
||||
|
||||
If you want to be able to load against libI77 but not libF77,
|
||||
then you will need to add sig_die.o (from libF77) to libI77.
|
||||
|
||||
If you wish to use translated Fortran that has funny notions
|
||||
of record length for direct unformatted I/O (i.e., that assumes
|
||||
RECL= values in OPEN statements are not bytes but rather counts
|
||||
of some other units -- e.g., 4-character words for VMS), then you
|
||||
should insert an appropriate #define for url_Adjust at the
|
||||
beginning of open.c . For VMS Fortran, for example,
|
||||
#define url_Adjust(x) x *= 4
|
||||
would suffice.
|
||||
|
||||
To check for transmission errors, issue the command
|
||||
make check
|
||||
This assumes you have the xsum program whose source, xsum.c,
|
||||
is distributed as part of "all from f2c/src". If you do not
|
||||
have xsum, you can obtain xsum.c by sending the following E-mail
|
||||
message to netlib@research.att.com
|
||||
send xsum.c from f2c/src
|
||||
|
||||
The makefile assumes you have installed f2c.h in a standard
|
||||
place (and does not cause recompilation when f2c.h is changed);
|
||||
f2c.h comes with "all from f2c" (the source for f2c) and is
|
||||
available separately ("f2c.h from f2c").
|
||||
|
||||
By default, Fortran I/O units 5, 6, and 0 are pre-connected to
|
||||
stdin, stdout, and stderr, respectively. You can change this
|
||||
behavior by changing f_init() in err.c to suit your needs.
|
||||
Note that f2c assumes READ(*... means READ(5... and WRITE(*...
|
||||
means WRITE(6... . Moreover, an OPEN(n,... statement that does
|
||||
not specify a file name (and does not specify STATUS='SCRATCH')
|
||||
assumes FILE='fort.n' . You can change this by editing open.c
|
||||
and endfile.c suitably.
|
||||
|
||||
Lines protected from compilation by #ifdef Allow_TYQUAD
|
||||
are for a possible extension to 64-bit integers in which
|
||||
integer = int = 32 bits and longint = long = 64 bits.
|
||||
|
||||
Extensions (Feb. 1993) to NAMELIST processing:
|
||||
1. Reading a ? instead of &name (the start of a namelist) causes
|
||||
the namelist being sought to be written to stdout (unit 6);
|
||||
to omit this feature, compile rsne.c with -DNo_Namelist_Questions.
|
||||
2. Reading the wrong namelist name now leads to an error message
|
||||
and an attempt to skip input until the right namelist name is found;
|
||||
to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip.
|
||||
3. Namelist writes now insert newlines before each variable; to omit
|
||||
this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines.
|
||||
|
||||
Nonstandard extension (Feb. 1993) to open: for sequential files,
|
||||
ACCESS='APPEND' (or access='anything else starting with "A" or "a"')
|
||||
causes the file to be positioned at end-of-file, so a write will
|
||||
append to the file.
|
||||
|
||||
Some buggy Fortran programs use unformatted direct I/O to write
|
||||
an incomplete record and later read more from that record than
|
||||
they have written. For records other than the last, the unwritten
|
||||
portion of the record reads as binary zeros. The last record is
|
||||
a special case: attempting to read more from it than was written
|
||||
gives end-of-file -- which may help one find a bug. Some other
|
||||
Fortran I/O libraries treat the last record no differently than
|
||||
others and thus give no help in finding the bug of reading more
|
||||
than was written. If you wish to have this behavior, compile
|
||||
uio.c with -DPad_UDread .
|
||||
|
||||
|
||||
Carriage controls are meant to be interpreted by the UNIX col
|
||||
program (or a similar program). Sometimes it's convenient to use
|
||||
only ' ' as the carriage control character (normal single spacing).
|
||||
If you compile lwrite.c and wsfe.c with -DOMIT_BLANK_CC, formatted
|
||||
external output lines will have an initial ' ' quietly omitted,
|
||||
making use of the col program unnecessary with output that only
|
||||
has ' ' for carriage control.
|
200
lib/libI77/Version.c
Normal file
200
lib/libI77/Version.c
Normal file
@ -0,0 +1,200 @@
|
||||
static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 6 Octt. 1994\n";
|
||||
|
||||
/*
|
||||
2.01 $ format added
|
||||
2.02 Coding bug in open.c repaired
|
||||
2.03 fixed bugs in lread.c (read * with negative f-format) and lio.c
|
||||
and lio.h (e-format conforming to spec)
|
||||
2.04 changed open.c and err.c (fopen and freopen respectively) to
|
||||
update to new c-library (append mode)
|
||||
2.05 added namelist capability
|
||||
2.06 allow internal list and namelist I/O
|
||||
*/
|
||||
|
||||
/*
|
||||
close.c:
|
||||
allow upper-case STATUS= values
|
||||
endfile.c
|
||||
create fort.nnn if unit nnn not open;
|
||||
else if (file length == 0) use creat() rather than copy;
|
||||
use local copy() rather than forking /bin/cp;
|
||||
rewind, fseek to clear buffer (for no reading past EOF)
|
||||
err.c
|
||||
use neither setbuf nor setvbuf; make stderr buffered
|
||||
fio.h
|
||||
#define _bufend
|
||||
inquire.c
|
||||
upper case responses;
|
||||
omit byfile test from SEQUENTIAL=
|
||||
answer "YES" to DIRECT= for unopened file (open to debate)
|
||||
lio.c
|
||||
flush stderr, stdout at end of each stmt
|
||||
space before character strings in list output only at line start
|
||||
lio.h
|
||||
adjust LEW, LED consistent with old libI77
|
||||
lread.c
|
||||
use atof()
|
||||
allow "nnn*," when reading complex constants
|
||||
open.c
|
||||
try opening for writing when open for read fails, with
|
||||
special uwrt value (2) delaying creat() to first write;
|
||||
set curunit so error messages don't drop core;
|
||||
no file name ==> fort.nnn except for STATUS='SCRATCH'
|
||||
rdfmt.c
|
||||
use atof(); trust EOF == end-of-file (so don't read past
|
||||
end-of-file after endfile stmt)
|
||||
sfe.c
|
||||
flush stderr, stdout at end of each stmt
|
||||
wrtfmt.c:
|
||||
use upper case
|
||||
put wrt_E and wrt_F into wref.c, use sprintf()
|
||||
rather than ecvt() and fcvt() [more accurate on VAX]
|
||||
*/
|
||||
|
||||
/* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */
|
||||
|
||||
/* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */
|
||||
|
||||
/* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */
|
||||
/* 29 Nov. 1989: change various int return types to long for f2c */
|
||||
/* 30 Nov. 1989: various types from f2c.h */
|
||||
/* 6 Dec. 1989: types corrected various places */
|
||||
/* 19 Dec. 1989: make iostat= work right for internal I/O */
|
||||
/* 8 Jan. 1990: add rsne, wsne -- routines for handling NAMELIST */
|
||||
/* 28 Jan. 1990: have NAMELIST read treat $ as &, general white
|
||||
space as blank */
|
||||
/* 27 Mar. 1990: change an = to == in rd_L(rdfmt.c) so formatted reads
|
||||
of logical values reject letters other than fFtT;
|
||||
have nowwriting reset cf */
|
||||
/* 14 Aug. 1990: adjust lread.c to treat tabs as spaces in list input */
|
||||
/* 17 Aug. 1990: adjust open.c to recognize blank='Z...' as well as
|
||||
blank='z...' when reopening an open file */
|
||||
/* 30 Aug. 1990: prevent embedded blanks in list output of complex values;
|
||||
omit exponent field in list output of values of
|
||||
magnitude between 10 and 1e8; prevent writing stdin
|
||||
and reading stdout or stderr; don't close stdin, stdout,
|
||||
or stderr when reopening units 5, 6, 0. */
|
||||
/* 18 Sep. 1990: add component udev to unit and consider old == new file
|
||||
iff uinode and udev values agree; use stat rather than
|
||||
access to check existence of file (when STATUS='OLD')*/
|
||||
/* 2 Oct. 1990: adjust rewind.c so two successive rewinds after a write
|
||||
don't clobber the file. */
|
||||
/* 9 Oct. 1990: add #include "fcntl.h" to endfile.c, err.c, open.c;
|
||||
adjust g_char in util.c for segmented memories. */
|
||||
/* 17 Oct. 1990: replace abort() and _cleanup() with calls on
|
||||
sig_die(...,1) (defined in main.c). */
|
||||
/* 5 Nov. 1990: changes to open.c: complain if new= is specified and the
|
||||
file already exists; allow file= to be omitted in open stmts
|
||||
and allow status='replace' (Fortran 90 extensions). */
|
||||
/* 11 Dec. 1990: adjustments for POSIX. */
|
||||
/* 15 Jan. 1991: tweak i_ungetc in rsli.c to allow reading from
|
||||
strings in read-only memory. */
|
||||
/* 25 Apr. 1991: adjust namelist stuff to work with f2c -i2 */
|
||||
/* 26 Apr. 1991: fix some bugs with NAMELIST read of multi-dim. arrays */
|
||||
/* 16 May 1991: increase LEFBL in lio.h to bypass NeXT bug */
|
||||
/* 17 Oct. 1991: change type of length field in sequential unformatted
|
||||
records from int to long (for systems where sizeof(int)
|
||||
can vary, depending on the compiler or compiler options). */
|
||||
/* 14 Nov. 1991: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c.
|
||||
/* 25 Nov. 1991: change uint to Uint in lwrite.c; change sizeof(int) to
|
||||
sizeof(uioint) in fseeks in sue.c (missed on 17 Oct.). */
|
||||
/* 1 Dec. 1991: uio.c: add test for read failure (seq. unformatted reads);
|
||||
adjust an error return from EOF to off end of record */
|
||||
/* 12 Dec. 1991: rsli.c: fix bug with internal list input that caused
|
||||
the last character of each record to be ignored.
|
||||
iio.c: adjust error message in internal formatted
|
||||
input from "end-of-file" to "off end of record" if
|
||||
the format specifies more characters than the
|
||||
record contains. */
|
||||
/* 17 Jan. 1992: lread.c, rsne.c: in list and namelist input,
|
||||
treat "r* ," and "r*," alike (where r is a
|
||||
positive integer constant), and fix a bug in
|
||||
handling null values following items with repeat
|
||||
counts (e.g., 2*1,,3); for namelist reading
|
||||
of a numeric array, allow a new name-value subsequence
|
||||
to terminate the current one (as though the current
|
||||
one ended with the right number of null values).
|
||||
lio.h, lwrite.c: omit insignificant zeros in
|
||||
list and namelist output. To get the old
|
||||
behavior, compile with -DOld_list_output . */
|
||||
/* 18 Jan. 1992: make list output consistent with F format by
|
||||
printing .1 rather than 0.1 (introduced yesterday). */
|
||||
/* 3 Feb. 1992: rsne.c: fix namelist read bug that caused the
|
||||
character following a comma to be ignored. */
|
||||
/* 19 May 1992: adjust iio.c, ilnw.c, rdfmt.c and rsli.c to make err=
|
||||
work with internal list and formatted I/O. */
|
||||
/* 18 July 1992: adjust rsne.c to allow namelist input to stop at
|
||||
an & (e.g. &end). */
|
||||
/* 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined ;
|
||||
recognize Z format (assuming 8-bit bytes). */
|
||||
/* 14 Aug. 1992: tweak wrt_E in wref.c to avoid -NaN */
|
||||
/* 23 Oct. 1992: Supply missing l_eof = 0 assignment to s_rsne() in rsne.c
|
||||
(so end-of-file on other files won't confuse namelist
|
||||
reads of external files). Prepend f__ to external
|
||||
names that are only of internal interest to lib[FI]77. */
|
||||
/* 1 Feb. 1993: backspace.c: fix bug that bit when last char of 2nd
|
||||
buffer == '\n'.
|
||||
endfile.c: guard against tiny L_tmpnam; close and reopen
|
||||
files in t_runc().
|
||||
lio.h: lengthen LINTW (buffer size in lwrite.c).
|
||||
err.c, open.c: more prepending of f__ (to [rw]_mode). */
|
||||
/* 5 Feb. 1993: tweaks to NAMELIST: rsne.c: ? prints the namelist being
|
||||
sought; namelists of the wrong name are skipped (after
|
||||
an error message; xwsne.c: namelist writes have a
|
||||
newline before each new variable.
|
||||
open.c: ACCESS='APPEND' positions sequential files
|
||||
at EOF (nonstandard extension -- that doesn't require
|
||||
changing data structures). */
|
||||
/* 9 Feb. 1993: Change some #ifdef MSDOS lines to #ifdef NON_UNIX_STDIO.
|
||||
err.c: under NON_UNIX_STDIO, avoid close(creat(name,0666))
|
||||
when the unit has another file descriptor for name. */
|
||||
/* 4 March 1993: err.c, open.c: take declaration of fdopen from rawio.h;
|
||||
open.c: always give f__w_mode[] 4 elements for use
|
||||
in t_runc (in endfile.c -- for change of 1 Feb. 1993). */
|
||||
/* 6 March 1993: uio.c: adjust off-end-of-record test for sequential
|
||||
unformatted reads to respond to err= rather than end=. */
|
||||
/* 12 March 1993: various tweaks for C++ */
|
||||
/* 6 April 1993: adjust error returns for formatted inputs to flush
|
||||
the current input line when err=label is specified.
|
||||
To restore the old behavior (input left mid-line),
|
||||
either adjust the #definition of errfl in fio.h or
|
||||
omit the invocation of f__doend in err__fl (in err.c). */
|
||||
/* 23 June 1993: iio.c: fix bug in format reversions for internal writes. */
|
||||
/* 5 Aug. 1993: lread.c: fix bug in handling repetition counts for
|
||||
logical data (during list or namelist input).
|
||||
Change struct f__syl to struct syl (for buggy compilers). */
|
||||
/* 7 Aug. 1993: lread.c: fix bug in namelist reading of incomplete
|
||||
logical arrays. */
|
||||
/* 9 Aug. 1993: lread.c: fix bug in namelist reading of an incomplete
|
||||
array of numeric data followed by another namelist
|
||||
item whose name starts with 'd', 'D', 'e', or 'E'. */
|
||||
/* 8 Sept. 1993: open.c: protect #include "sys/..." with
|
||||
#ifndef NON_UNIX_STDIO; Version date not changed. */
|
||||
/* 10 Nov. 1993: backspace.c: add nonsense for #ifdef MSDOS */
|
||||
/* 8 Dec. 1993: iio.c: adjust internal formatted reads to treat
|
||||
short records as though padded with blanks
|
||||
(rather than causing an "off end of record" error). */
|
||||
/* 22 Feb. 1994: lread.c: check that realloc did not return NULL. */
|
||||
/* 6 June 1994: Under NON_UNIX_STDIO, use binary mode for direct
|
||||
formatted files (avoiding any confusion regarding \n). */
|
||||
/* 5 July 1994: Fix bug (introduced 6 June 1994?) in reopening files
|
||||
under NON_UNIX_STDIO. */
|
||||
/* 6 July 1994: wref.c: protect with #ifdef GOOD_SPRINTF_EXPONENT an
|
||||
optimization that requires exponents to have 2 digits
|
||||
when 2 digits suffice.
|
||||
lwrite.c wsfe.c (list and formatted external output):
|
||||
omit ' ' carriage-control when compiled with
|
||||
-DOMIT_BLANK_CC . Off-by-one bug fixed in character
|
||||
count for list output of character strings.
|
||||
Omit '.' in list-directed printing of Nan, Infinity. */
|
||||
/* 12 July 1994: wrtfmt.c: under G11.4, write 0. as " .0000 " rather
|
||||
than " .0000E+00". */
|
||||
/* 3 Aug. 1994: lwrite.c: do not insert a newline when appending an
|
||||
oversize item to an empty line. */
|
||||
/* 12 Aug. 1994: rsli.c rsne.c: fix glitch (reset nml_read) that kept
|
||||
ERR= (in list- or format-directed input) from working
|
||||
after a NAMELIST READ. */
|
||||
/* 7 Sept. 1994: typesize.c: adjust to allow types LOGICAL*1, LOGICAL*2,
|
||||
INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8
|
||||
in NAMELISTs. */
|
||||
/* 6 Oct. 1994: util.c: omit f__mvgbt, as it is never used. */
|
96
lib/libI77/backspace.c
Normal file
96
lib/libI77/backspace.c
Normal file
@ -0,0 +1,96 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#ifdef KR_headers
|
||||
integer f_back(a) alist *a;
|
||||
#else
|
||||
integer f_back(alist *a)
|
||||
#endif
|
||||
{ unit *b;
|
||||
int i, n, ndec;
|
||||
#ifdef MSDOS
|
||||
int j, k;
|
||||
long w, z;
|
||||
#endif
|
||||
long x, y;
|
||||
char buf[32];
|
||||
if(a->aunit >= MXUNIT || a->aunit < 0)
|
||||
err(a->aerr,101,"backspace")
|
||||
b= &f__units[a->aunit];
|
||||
if(b->useek==0) err(a->aerr,106,"backspace")
|
||||
if(b->ufd==NULL) {
|
||||
fk_open(1, 1, a->aunit);
|
||||
return(0);
|
||||
}
|
||||
if(b->uend==1)
|
||||
{ b->uend=0;
|
||||
return(0);
|
||||
}
|
||||
if(b->uwrt) {
|
||||
(void) t_runc(a);
|
||||
if (f__nowreading(b))
|
||||
err(a->aerr,errno,"backspace")
|
||||
}
|
||||
if(b->url>0)
|
||||
{
|
||||
x=ftell(b->ufd);
|
||||
y = x % b->url;
|
||||
if(y == 0) x--;
|
||||
x /= b->url;
|
||||
x *= b->url;
|
||||
(void) fseek(b->ufd,x,SEEK_SET);
|
||||
return(0);
|
||||
}
|
||||
|
||||
if(b->ufmt==0)
|
||||
{ (void) fseek(b->ufd,-(long)sizeof(int),SEEK_CUR);
|
||||
(void) fread((char *)&n,sizeof(int),1,b->ufd);
|
||||
(void) fseek(b->ufd,-(long)n-2*sizeof(int),SEEK_CUR);
|
||||
return(0);
|
||||
}
|
||||
#ifdef MSDOS
|
||||
w = -1;
|
||||
#endif
|
||||
for(ndec = 2;; ndec = 1)
|
||||
{
|
||||
y = x=ftell(b->ufd);
|
||||
if(x<sizeof(buf)) x=0;
|
||||
else x -= sizeof(buf);
|
||||
(void) fseek(b->ufd,x,SEEK_SET);
|
||||
n=fread(buf,1,(int)(y-x), b->ufd);
|
||||
for(i=n-ndec;i>=0;i--)
|
||||
{
|
||||
if(buf[i]!='\n') continue;
|
||||
#ifdef MSDOS
|
||||
for(j = k = 0; j <= i; j++)
|
||||
if (buf[j] == '\n')
|
||||
k++;
|
||||
fseek(b->ufd,x,SEEK_SET);
|
||||
do {
|
||||
if (getc(b->ufd) == '\n') {
|
||||
--k;
|
||||
if ((z = ftell(b->ufd)) >= y) {
|
||||
if (w == -1)
|
||||
goto break2;
|
||||
break;
|
||||
}
|
||||
w = z;
|
||||
}
|
||||
} while(k > 0);
|
||||
fseek(b->ufd, w, SEEK_SET);
|
||||
#else
|
||||
fseek(b->ufd,(long)(i+1-n),SEEK_CUR);
|
||||
#endif
|
||||
return(0);
|
||||
}
|
||||
#ifdef MSDOS
|
||||
break2:
|
||||
#endif
|
||||
if(x==0)
|
||||
{
|
||||
(void) fseek(b->ufd, 0L, SEEK_SET);
|
||||
return(0);
|
||||
}
|
||||
else if(n<=0) err(a->aerr,(EOF),"backspace")
|
||||
(void) fseek(b->ufd, x, SEEK_SET);
|
||||
}
|
||||
}
|
95
lib/libI77/close.c
Normal file
95
lib/libI77/close.c
Normal file
@ -0,0 +1,95 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#ifdef KR_headers
|
||||
integer f_clos(a) cllist *a;
|
||||
#else
|
||||
#undef abs
|
||||
#undef min
|
||||
#undef max
|
||||
#include "stdlib.h"
|
||||
#ifdef NON_UNIX_STDIO
|
||||
#ifndef unlink
|
||||
#define unlink remove
|
||||
#endif
|
||||
#else
|
||||
#ifdef MSDOS
|
||||
#include "io.h"
|
||||
#else
|
||||
#ifdef __cplusplus
|
||||
extern "C" int unlink(const char*);
|
||||
#else
|
||||
extern int unlink(const char*);
|
||||
#endif
|
||||
#endif
|
||||
#endif
|
||||
|
||||
integer f_clos(cllist *a)
|
||||
#endif
|
||||
{ unit *b;
|
||||
|
||||
if(a->cunit >= MXUNIT) return(0);
|
||||
b= &f__units[a->cunit];
|
||||
if(b->ufd==NULL)
|
||||
goto done;
|
||||
if (!a->csta)
|
||||
if (b->uscrtch == 1)
|
||||
goto Delete;
|
||||
else
|
||||
goto Keep;
|
||||
switch(*a->csta) {
|
||||
default:
|
||||
Keep:
|
||||
case 'k':
|
||||
case 'K':
|
||||
if(b->uwrt == 1)
|
||||
t_runc((alist *)a);
|
||||
if(b->ufnm) {
|
||||
fclose(b->ufd);
|
||||
free(b->ufnm);
|
||||
}
|
||||
break;
|
||||
case 'd':
|
||||
case 'D':
|
||||
Delete:
|
||||
if(b->ufnm) {
|
||||
fclose(b->ufd);
|
||||
unlink(b->ufnm); /*SYSDEP*/
|
||||
free(b->ufnm);
|
||||
}
|
||||
}
|
||||
b->ufd=NULL;
|
||||
done:
|
||||
b->uend=0;
|
||||
b->ufnm=NULL;
|
||||
return(0);
|
||||
}
|
||||
void
|
||||
#ifdef KR_headers
|
||||
f_exit()
|
||||
#else
|
||||
f_exit(void)
|
||||
#endif
|
||||
{ int i;
|
||||
static cllist xx;
|
||||
if (!xx.cerr) {
|
||||
xx.cerr=1;
|
||||
xx.csta=NULL;
|
||||
for(i=0;i<MXUNIT;i++)
|
||||
{
|
||||
xx.cunit=i;
|
||||
(void) f_clos(&xx);
|
||||
}
|
||||
}
|
||||
}
|
||||
int
|
||||
#ifdef KR_headers
|
||||
flush_()
|
||||
#else
|
||||
flush_(void)
|
||||
#endif
|
||||
{ int i;
|
||||
for(i=0;i<MXUNIT;i++)
|
||||
if(f__units[i].ufd != NULL && f__units[i].uwrt)
|
||||
fflush(f__units[i].ufd);
|
||||
return 0;
|
||||
}
|
157
lib/libI77/dfe.c
Normal file
157
lib/libI77/dfe.c
Normal file
@ -0,0 +1,157 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
|
||||
y_rsk(Void)
|
||||
{
|
||||
if(f__curunit->uend || f__curunit->url <= f__recpos
|
||||
|| f__curunit->url == 1) return 0;
|
||||
do {
|
||||
getc(f__cf);
|
||||
} while(++f__recpos < f__curunit->url);
|
||||
return 0;
|
||||
}
|
||||
y_getc(Void)
|
||||
{
|
||||
int ch;
|
||||
if(f__curunit->uend) return(-1);
|
||||
if((ch=getc(f__cf))!=EOF)
|
||||
{
|
||||
f__recpos++;
|
||||
if(f__curunit->url>=f__recpos ||
|
||||
f__curunit->url==1)
|
||||
return(ch);
|
||||
else return(' ');
|
||||
}
|
||||
if(feof(f__cf))
|
||||
{
|
||||
f__curunit->uend=1;
|
||||
errno=0;
|
||||
return(-1);
|
||||
}
|
||||
err(f__elist->cierr,errno,"readingd");
|
||||
#ifdef __cplusplus
|
||||
return 0;
|
||||
#endif
|
||||
}
|
||||
#ifdef KR_headers
|
||||
y_putc(c)
|
||||
#else
|
||||
y_putc(int c)
|
||||
#endif
|
||||
{
|
||||
f__recpos++;
|
||||
if(f__recpos <= f__curunit->url || f__curunit->url==1)
|
||||
putc(c,f__cf);
|
||||
else
|
||||
err(f__elist->cierr,110,"dout");
|
||||
return(0);
|
||||
}
|
||||
y_rev(Void)
|
||||
{ /*what about work done?*/
|
||||
if(f__curunit->url==1 || f__recpos==f__curunit->url)
|
||||
return(0);
|
||||
while(f__recpos<f__curunit->url)
|
||||
(*f__putn)(' ');
|
||||
f__recpos=0;
|
||||
return(0);
|
||||
}
|
||||
y_err(Void)
|
||||
{
|
||||
err(f__elist->cierr, 110, "dfe");
|
||||
#ifdef __cplusplus
|
||||
return 0;
|
||||
#endif
|
||||
}
|
||||
|
||||
y_newrec(Void)
|
||||
{
|
||||
if(f__curunit->url == 1 || f__recpos == f__curunit->url) {
|
||||
f__hiwater = f__recpos = f__cursor = 0;
|
||||
return(1);
|
||||
}
|
||||
if(f__hiwater > f__recpos)
|
||||
f__recpos = f__hiwater;
|
||||
y_rev();
|
||||
f__hiwater = f__cursor = 0;
|
||||
return(1);
|
||||
}
|
||||
|
||||
#ifdef KR_headers
|
||||
c_dfe(a) cilist *a;
|
||||
#else
|
||||
c_dfe(cilist *a)
|
||||
#endif
|
||||
{
|
||||
f__sequential=0;
|
||||
f__formatted=f__external=1;
|
||||
f__elist=a;
|
||||
f__cursor=f__scale=f__recpos=0;
|
||||
if(a->ciunit>MXUNIT || a->ciunit<0)
|
||||
err(a->cierr,101,"startchk");
|
||||
f__curunit = &f__units[a->ciunit];
|
||||
if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit))
|
||||
err(a->cierr,104,"dfe");
|
||||
f__cf=f__curunit->ufd;
|
||||
if(!f__curunit->ufmt) err(a->cierr,102,"dfe")
|
||||
if(!f__curunit->useek) err(a->cierr,104,"dfe")
|
||||
f__fmtbuf=a->cifmt;
|
||||
(void) fseek(f__cf,(long)f__curunit->url * (a->cirec-1),SEEK_SET);
|
||||
f__curunit->uend = 0;
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer s_rdfe(a) cilist *a;
|
||||
#else
|
||||
integer s_rdfe(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int n;
|
||||
if(!f__init) f_init();
|
||||
if(n=c_dfe(a))return(n);
|
||||
f__reading=1;
|
||||
if(f__curunit->uwrt && f__nowreading(f__curunit))
|
||||
err(a->cierr,errno,"read start");
|
||||
f__getn = y_getc;
|
||||
f__doed = rd_ed;
|
||||
f__doned = rd_ned;
|
||||
f__dorevert = f__donewrec = y_err;
|
||||
f__doend = y_rsk;
|
||||
if(pars_f(f__fmtbuf)<0)
|
||||
err(a->cierr,100,"read start");
|
||||
fmt_bg();
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer s_wdfe(a) cilist *a;
|
||||
#else
|
||||
integer s_wdfe(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int n;
|
||||
if(!f__init) f_init();
|
||||
if(n=c_dfe(a)) return(n);
|
||||
f__reading=0;
|
||||
if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
|
||||
err(a->cierr,errno,"startwrt");
|
||||
f__putn = y_putc;
|
||||
f__doed = w_ed;
|
||||
f__doned= w_ned;
|
||||
f__dorevert = y_err;
|
||||
f__donewrec = y_newrec;
|
||||
f__doend = y_rev;
|
||||
if(pars_f(f__fmtbuf)<0)
|
||||
err(a->cierr,100,"startwrt");
|
||||
fmt_bg();
|
||||
return(0);
|
||||
}
|
||||
integer e_rdfe(Void)
|
||||
{
|
||||
(void) en_fio();
|
||||
return(0);
|
||||
}
|
||||
integer e_wdfe(Void)
|
||||
{
|
||||
(void) en_fio();
|
||||
return(0);
|
||||
}
|
20
lib/libI77/dolio.c
Normal file
20
lib/libI77/dolio.c
Normal file
@ -0,0 +1,20 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
#ifdef KR_headers
|
||||
extern int (*f__lioproc)();
|
||||
|
||||
integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len;
|
||||
#else
|
||||
extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint);
|
||||
|
||||
integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
return((*f__lioproc)(number,ptr,len,*type));
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
64
lib/libI77/due.c
Normal file
64
lib/libI77/due.c
Normal file
@ -0,0 +1,64 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
c_due(a) cilist *a;
|
||||
#else
|
||||
c_due(cilist *a)
|
||||
#endif
|
||||
{
|
||||
if(!f__init) f_init();
|
||||
if(a->ciunit>=MXUNIT || a->ciunit<0)
|
||||
err(a->cierr,101,"startio");
|
||||
f__sequential=f__formatted=f__recpos=0;
|
||||
f__external=1;
|
||||
f__curunit = &f__units[a->ciunit];
|
||||
f__elist=a;
|
||||
if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due");
|
||||
f__cf=f__curunit->ufd;
|
||||
if(f__curunit->ufmt) err(a->cierr,102,"cdue")
|
||||
if(!f__curunit->useek) err(a->cierr,104,"cdue")
|
||||
if(f__curunit->ufd==NULL) err(a->cierr,114,"cdue")
|
||||
(void) fseek(f__cf,(long)(a->cirec-1)*f__curunit->url,SEEK_SET);
|
||||
f__curunit->uend = 0;
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer s_rdue(a) cilist *a;
|
||||
#else
|
||||
integer s_rdue(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int n;
|
||||
if(n=c_due(a)) return(n);
|
||||
f__reading=1;
|
||||
if(f__curunit->uwrt && f__nowreading(f__curunit))
|
||||
err(a->cierr,errno,"read start");
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer s_wdue(a) cilist *a;
|
||||
#else
|
||||
integer s_wdue(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int n;
|
||||
if(n=c_due(a)) return(n);
|
||||
f__reading=0;
|
||||
if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
|
||||
err(a->cierr,errno,"write start");
|
||||
return(0);
|
||||
}
|
||||
integer e_rdue(Void)
|
||||
{
|
||||
if(f__curunit->url==1 || f__recpos==f__curunit->url)
|
||||
return(0);
|
||||
(void) fseek(f__cf,(long)(f__curunit->url-f__recpos),SEEK_CUR);
|
||||
if(ftell(f__cf)%f__curunit->url)
|
||||
err(f__elist->cierr,200,"syserr");
|
||||
return(0);
|
||||
}
|
||||
integer e_wdue(Void)
|
||||
{
|
||||
return(e_rdue());
|
||||
}
|
195
lib/libI77/endfile.c
Normal file
195
lib/libI77/endfile.c
Normal file
@ -0,0 +1,195 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#ifndef NON_UNIX_STDIO
|
||||
#include "sys/types.h"
|
||||
#endif
|
||||
#include "rawio.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
extern char *strcpy();
|
||||
#else
|
||||
#undef abs
|
||||
#undef min
|
||||
#undef max
|
||||
#include "stdlib.h"
|
||||
#include "string.h"
|
||||
#endif
|
||||
|
||||
#ifdef NON_UNIX_STDIO
|
||||
#ifndef unlink
|
||||
#define unlink remove
|
||||
#endif
|
||||
#else
|
||||
#ifdef MSDOS
|
||||
#include "io.h"
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifdef NON_UNIX_STDIO
|
||||
extern char *f__r_mode[], *f__w_mode[];
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
integer f_end(a) alist *a;
|
||||
#else
|
||||
integer f_end(alist *a)
|
||||
#endif
|
||||
{
|
||||
unit *b;
|
||||
if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile");
|
||||
b = &f__units[a->aunit];
|
||||
if(b->ufd==NULL) {
|
||||
char nbuf[10];
|
||||
(void) sprintf(nbuf,"fort.%ld",a->aunit);
|
||||
#ifdef NON_UNIX_STDIO
|
||||
{ FILE *tf;
|
||||
if (tf = fopen(nbuf, f__w_mode[0]))
|
||||
fclose(tf);
|
||||
}
|
||||
#else
|
||||
close(creat(nbuf, 0666));
|
||||
#endif
|
||||
return(0);
|
||||
}
|
||||
b->uend=1;
|
||||
return(b->useek ? t_runc(a) : 0);
|
||||
}
|
||||
|
||||
static int
|
||||
#ifdef NON_UNIX_STDIO
|
||||
#ifdef KR_headers
|
||||
copy(from, len, to) char *from, *to; register long len;
|
||||
#else
|
||||
copy(FILE *from, register long len, FILE *to)
|
||||
#endif
|
||||
{
|
||||
int k, len1;
|
||||
char buf[BUFSIZ];
|
||||
|
||||
while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) {
|
||||
if (!fwrite(buf, len1, 1, to))
|
||||
return 1;
|
||||
if ((len -= len1) <= 0)
|
||||
break;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
#else
|
||||
#ifdef KR_headers
|
||||
copy(from, len, to) char *from, *to; register long len;
|
||||
#else
|
||||
copy(char *from, register long len, char *to)
|
||||
#endif
|
||||
{
|
||||
register int n;
|
||||
int k, rc = 0, tmp;
|
||||
char buf[BUFSIZ];
|
||||
|
||||
if ((k = open(from, O_RDONLY)) < 0)
|
||||
return 1;
|
||||
if ((tmp = creat(to,0666)) < 0)
|
||||
return 1;
|
||||
while((n = read(k, buf, len > BUFSIZ ? BUFSIZ : (int)len)) > 0) {
|
||||
if (write(tmp, buf, n) != n)
|
||||
{ rc = 1; break; }
|
||||
if ((len -= n) <= 0)
|
||||
break;
|
||||
}
|
||||
close(k);
|
||||
close(tmp);
|
||||
return n < 0 ? 1 : rc;
|
||||
}
|
||||
#endif
|
||||
|
||||
#ifndef L_tmpnam
|
||||
#define L_tmpnam 16
|
||||
#endif
|
||||
|
||||
int
|
||||
#ifdef KR_headers
|
||||
t_runc(a) alist *a;
|
||||
#else
|
||||
t_runc(alist *a)
|
||||
#endif
|
||||
{
|
||||
char nm[L_tmpnam+12]; /* extra space in case L_tmpnam is tiny */
|
||||
long loc, len;
|
||||
unit *b;
|
||||
#ifdef NON_UNIX_STDIO
|
||||
FILE *bf, *tf;
|
||||
#else
|
||||
FILE *bf;
|
||||
#endif
|
||||
int rc = 0;
|
||||
|
||||
b = &f__units[a->aunit];
|
||||
if(b->url)
|
||||
return(0); /*don't truncate direct files*/
|
||||
loc=ftell(bf = b->ufd);
|
||||
fseek(bf,0L,SEEK_END);
|
||||
len=ftell(bf);
|
||||
if (loc >= len || b->useek == 0 || b->ufnm == NULL)
|
||||
return(0);
|
||||
#ifdef NON_UNIX_STDIO
|
||||
fclose(b->ufd);
|
||||
#else
|
||||
rewind(b->ufd); /* empty buffer */
|
||||
#endif
|
||||
if (!loc) {
|
||||
#ifdef NON_UNIX_STDIO
|
||||
if (!(bf = fopen(b->ufnm, f__w_mode[b->ufmt])))
|
||||
#else
|
||||
if (close(creat(b->ufnm,0666)))
|
||||
#endif
|
||||
rc = 1;
|
||||
if (b->uwrt)
|
||||
b->uwrt = 1;
|
||||
goto done;
|
||||
}
|
||||
#ifdef _POSIX_SOURCE
|
||||
tmpnam(nm);
|
||||
#else
|
||||
strcpy(nm,"tmp.FXXXXXX");
|
||||
mktemp(nm);
|
||||
#endif
|
||||
#ifdef NON_UNIX_STDIO
|
||||
if (!(bf = fopen(b->ufnm, f__r_mode[0]))) {
|
||||
bad:
|
||||
rc = 1;
|
||||
goto done;
|
||||
}
|
||||
if (!(tf = fopen(nm, f__w_mode[0])))
|
||||
goto bad;
|
||||
if (copy(bf, loc, tf)) {
|
||||
bad1:
|
||||
rc = 1;
|
||||
goto done1;
|
||||
}
|
||||
if (!(bf = freopen(b->ufnm, f__w_mode[0], bf)))
|
||||
goto bad1;
|
||||
if (!(tf = freopen(nm, f__r_mode[0], tf)))
|
||||
goto bad1;
|
||||
if (copy(tf, loc, bf))
|
||||
goto bad1;
|
||||
if (f__w_mode[0] != f__w_mode[b->ufmt]) {
|
||||
if (!(bf = freopen(b->ufnm, f__w_mode[b->ufmt|2], bf)))
|
||||
goto bad1;
|
||||
fseek(bf, loc, SEEK_SET);
|
||||
}
|
||||
done1:
|
||||
fclose(tf);
|
||||
unlink(nm);
|
||||
done:
|
||||
f__cf = b->ufd = bf;
|
||||
#else
|
||||
if (copy(b->ufnm, loc, nm)
|
||||
|| copy(nm, loc, b->ufnm))
|
||||
rc = 1;
|
||||
unlink(nm);
|
||||
fseek(b->ufd, loc, SEEK_SET);
|
||||
done:
|
||||
#endif
|
||||
if (rc)
|
||||
err(a->aerr,111,"endfile");
|
||||
return 0;
|
||||
}
|
275
lib/libI77/err.c
Normal file
275
lib/libI77/err.c
Normal file
@ -0,0 +1,275 @@
|
||||
#ifndef NON_UNIX_STDIO
|
||||
#include "sys/types.h"
|
||||
#include "sys/stat.h"
|
||||
#endif
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "fmt.h" /* for struct syl */
|
||||
#include "rawio.h" /* for fcntl.h, fdopen */
|
||||
#ifdef NON_UNIX_STDIO
|
||||
#ifdef KR_headers
|
||||
extern char *malloc();
|
||||
#else
|
||||
#undef abs
|
||||
#undef min
|
||||
#undef max
|
||||
#include "stdlib.h"
|
||||
#endif
|
||||
#endif
|
||||
|
||||
/*global definitions*/
|
||||
unit f__units[MXUNIT]; /*unit table*/
|
||||
flag f__init; /*0 on entry, 1 after initializations*/
|
||||
cilist *f__elist; /*active external io list*/
|
||||
flag f__reading; /*1 if reading, 0 if writing*/
|
||||
flag f__cplus,f__cblank;
|
||||
char *f__fmtbuf;
|
||||
flag f__external; /*1 if external io, 0 if internal */
|
||||
#ifdef KR_headers
|
||||
int (*f__doed)(),(*f__doned)();
|
||||
int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)();
|
||||
int (*f__getn)(),(*f__putn)(); /*for formatted io*/
|
||||
#else
|
||||
int (*f__getn)(void),(*f__putn)(int); /*for formatted io*/
|
||||
int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*);
|
||||
int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void);
|
||||
#endif
|
||||
flag f__sequential; /*1 if sequential io, 0 if direct*/
|
||||
flag f__formatted; /*1 if formatted io, 0 if unformatted*/
|
||||
FILE *f__cf; /*current file*/
|
||||
unit *f__curunit; /*current unit*/
|
||||
int f__recpos; /*place in current record*/
|
||||
int f__cursor,f__scale;
|
||||
|
||||
/*error messages*/
|
||||
char *F_err[] =
|
||||
{
|
||||
"error in format", /* 100 */
|
||||
"illegal unit number", /* 101 */
|
||||
"formatted io not allowed", /* 102 */
|
||||
"unformatted io not allowed", /* 103 */
|
||||
"direct io not allowed", /* 104 */
|
||||
"sequential io not allowed", /* 105 */
|
||||
"can't backspace file", /* 106 */
|
||||
"null file name", /* 107 */
|
||||
"can't stat file", /* 108 */
|
||||
"unit not connected", /* 109 */
|
||||
"off end of record", /* 110 */
|
||||
"truncation failed in endfile", /* 111 */
|
||||
"incomprehensible list input", /* 112 */
|
||||
"out of free space", /* 113 */
|
||||
"unit not connected", /* 114 */
|
||||
"read unexpected character", /* 115 */
|
||||
"bad logical input field", /* 116 */
|
||||
"bad variable type", /* 117 */
|
||||
"bad namelist name", /* 118 */
|
||||
"variable not in namelist", /* 119 */
|
||||
"no end record", /* 120 */
|
||||
"variable count incorrect", /* 121 */
|
||||
"subscript for scalar variable", /* 122 */
|
||||
"invalid array section", /* 123 */
|
||||
"substring out of bounds", /* 124 */
|
||||
"subscript out of bounds", /* 125 */
|
||||
"can't read file", /* 126 */
|
||||
"can't write file", /* 127 */
|
||||
"'new' file exists", /* 128 */
|
||||
"can't append to file" /* 129 */
|
||||
};
|
||||
#define MAXERR (sizeof(F_err)/sizeof(char *)+100)
|
||||
|
||||
#ifdef KR_headers
|
||||
f__canseek(f) FILE *f; /*SYSDEP*/
|
||||
#else
|
||||
f__canseek(FILE *f) /*SYSDEP*/
|
||||
#endif
|
||||
{
|
||||
#ifdef NON_UNIX_STDIO
|
||||
return !isatty(fileno(f));
|
||||
#else
|
||||
struct stat x;
|
||||
|
||||
if (fstat(fileno(f),&x) < 0)
|
||||
return(0);
|
||||
#ifdef S_IFMT
|
||||
switch(x.st_mode & S_IFMT) {
|
||||
case S_IFDIR:
|
||||
case S_IFREG:
|
||||
if(x.st_nlink > 0) /* !pipe */
|
||||
return(1);
|
||||
else
|
||||
return(0);
|
||||
case S_IFCHR:
|
||||
if(isatty(fileno(f)))
|
||||
return(0);
|
||||
return(1);
|
||||
#ifdef S_IFBLK
|
||||
case S_IFBLK:
|
||||
return(1);
|
||||
#endif
|
||||
}
|
||||
#else
|
||||
#ifdef S_ISDIR
|
||||
/* POSIX version */
|
||||
if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) {
|
||||
if(x.st_nlink > 0) /* !pipe */
|
||||
return(1);
|
||||
else
|
||||
return(0);
|
||||
}
|
||||
if (S_ISCHR(x.st_mode)) {
|
||||
if(isatty(fileno(f)))
|
||||
return(0);
|
||||
return(1);
|
||||
}
|
||||
if (S_ISBLK(x.st_mode))
|
||||
return(1);
|
||||
#else
|
||||
Help! How does fstat work on this system?
|
||||
#endif
|
||||
#endif
|
||||
return(0); /* who knows what it is? */
|
||||
#endif
|
||||
}
|
||||
|
||||
void
|
||||
#ifdef KR_headers
|
||||
f__fatal(n,s) char *s;
|
||||
#else
|
||||
f__fatal(int n, char *s)
|
||||
#endif
|
||||
{
|
||||
if(n<100 && n>=0) perror(s); /*SYSDEP*/
|
||||
else if(n >= (int)MAXERR || n < -1)
|
||||
{ fprintf(stderr,"%s: illegal error number %d\n",s,n);
|
||||
}
|
||||
else if(n == -1) fprintf(stderr,"%s: end of file\n",s);
|
||||
else
|
||||
fprintf(stderr,"%s: %s\n",s,F_err[n-100]);
|
||||
if (f__curunit) {
|
||||
fprintf(stderr,"apparent state: unit %d ",f__curunit-f__units);
|
||||
fprintf(stderr, f__curunit->ufnm ? "named %s\n" : "(unnamed)\n",
|
||||
f__curunit->ufnm);
|
||||
}
|
||||
else
|
||||
fprintf(stderr,"apparent state: internal I/O\n");
|
||||
if (f__fmtbuf)
|
||||
fprintf(stderr,"last format: %s\n",f__fmtbuf);
|
||||
fprintf(stderr,"lately %s %s %s %s",f__reading?"reading":"writing",
|
||||
f__sequential?"sequential":"direct",f__formatted?"formatted":"unformatted",
|
||||
f__external?"external":"internal");
|
||||
sig_die(" IO", 1);
|
||||
}
|
||||
/*initialization routine*/
|
||||
VOID
|
||||
f_init(Void)
|
||||
{ unit *p;
|
||||
|
||||
f__init=1;
|
||||
p= &f__units[0];
|
||||
p->ufd=stderr;
|
||||
p->useek=f__canseek(stderr);
|
||||
#ifdef NON_UNIX_STDIO
|
||||
setbuf(stderr, (char *)malloc(BUFSIZ));
|
||||
#else
|
||||
stderr->_flag &= ~_IONBF;
|
||||
#endif
|
||||
p->ufmt=1;
|
||||
p->uwrt=1;
|
||||
p = &f__units[5];
|
||||
p->ufd=stdin;
|
||||
p->useek=f__canseek(stdin);
|
||||
p->ufmt=1;
|
||||
p->uwrt=0;
|
||||
p= &f__units[6];
|
||||
p->ufd=stdout;
|
||||
p->useek=f__canseek(stdout);
|
||||
p->ufmt=1;
|
||||
p->uwrt=1;
|
||||
}
|
||||
#ifdef KR_headers
|
||||
f__nowreading(x) unit *x;
|
||||
#else
|
||||
f__nowreading(unit *x)
|
||||
#endif
|
||||
{
|
||||
long loc;
|
||||
int ufmt;
|
||||
extern char *f__r_mode[];
|
||||
|
||||
if (!x->ufnm)
|
||||
goto cantread;
|
||||
ufmt = x->ufmt;
|
||||
loc=ftell(x->ufd);
|
||||
if(freopen(x->ufnm,f__r_mode[ufmt],x->ufd) == NULL) {
|
||||
cantread:
|
||||
errno = 126;
|
||||
return(1);
|
||||
}
|
||||
x->uwrt=0;
|
||||
(void) fseek(x->ufd,loc,SEEK_SET);
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
f__nowwriting(x) unit *x;
|
||||
#else
|
||||
f__nowwriting(unit *x)
|
||||
#endif
|
||||
{
|
||||
long loc;
|
||||
int ufmt;
|
||||
extern char *f__w_mode[];
|
||||
#ifndef NON_UNIX_STDIO
|
||||
int k;
|
||||
#endif
|
||||
|
||||
if (!x->ufnm)
|
||||
goto cantwrite;
|
||||
ufmt = x->ufmt;
|
||||
#ifdef NON_UNIX_STDIO
|
||||
ufmt |= 2;
|
||||
#endif
|
||||
if (x->uwrt == 3) { /* just did write, rewind */
|
||||
#ifdef NON_UNIX_STDIO
|
||||
if (!(f__cf = x->ufd =
|
||||
freopen(x->ufnm,f__w_mode[ufmt],x->ufd)))
|
||||
#else
|
||||
if (close(creat(x->ufnm,0666)))
|
||||
#endif
|
||||
goto cantwrite;
|
||||
}
|
||||
else {
|
||||
loc=ftell(x->ufd);
|
||||
#ifdef NON_UNIX_STDIO
|
||||
if (!(f__cf = x->ufd =
|
||||
freopen(x->ufnm, f__w_mode[ufmt], x->ufd)))
|
||||
#else
|
||||
if (fclose(x->ufd) < 0
|
||||
|| (k = x->uwrt == 2 ? creat(x->ufnm,0666)
|
||||
: open(x->ufnm,O_WRONLY)) < 0
|
||||
|| (f__cf = x->ufd = fdopen(k,f__w_mode[ufmt])) == NULL)
|
||||
#endif
|
||||
{
|
||||
x->ufd = NULL;
|
||||
cantwrite:
|
||||
errno = 127;
|
||||
return(1);
|
||||
}
|
||||
(void) fseek(x->ufd,loc,SEEK_SET);
|
||||
}
|
||||
x->uwrt = 1;
|
||||
return(0);
|
||||
}
|
||||
|
||||
int
|
||||
#ifdef KR_headers
|
||||
err__fl(f, m, s) int f, m; char *s;
|
||||
#else
|
||||
err__fl(int f, int m, char *s)
|
||||
#endif
|
||||
{
|
||||
if (!f)
|
||||
f__fatal(m, s);
|
||||
if (f__doend)
|
||||
(*f__doend)();
|
||||
return errno = m;
|
||||
}
|
162
lib/libI77/f2ch.add
Normal file
162
lib/libI77/f2ch.add
Normal file
@ -0,0 +1,162 @@
|
||||
/* If you are using a C++ compiler, append the following to f2c.h
|
||||
for compiling libF77 and libI77. */
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
extern int abort_(void);
|
||||
extern double c_abs(complex *);
|
||||
extern void c_cos(complex *, complex *);
|
||||
extern void c_div(complex *, complex *, complex *);
|
||||
extern void c_exp(complex *, complex *);
|
||||
extern void c_log(complex *, complex *);
|
||||
extern void c_sin(complex *, complex *);
|
||||
extern void c_sqrt(complex *, complex *);
|
||||
extern double d_abs(double *);
|
||||
extern double d_acos(double *);
|
||||
extern double d_asin(double *);
|
||||
extern double d_atan(double *);
|
||||
extern double d_atn2(double *, double *);
|
||||
extern void d_cnjg(doublecomplex *, doublecomplex *);
|
||||
extern double d_cos(double *);
|
||||
extern double d_cosh(double *);
|
||||
extern double d_dim(double *, double *);
|
||||
extern double d_exp(double *);
|
||||
extern double d_imag(doublecomplex *);
|
||||
extern double d_int(double *);
|
||||
extern double d_lg10(double *);
|
||||
extern double d_log(double *);
|
||||
extern double d_mod(double *, double *);
|
||||
extern double d_nint(double *);
|
||||
extern double d_prod(float *, float *);
|
||||
extern double d_sign(double *, double *);
|
||||
extern double d_sin(double *);
|
||||
extern double d_sinh(double *);
|
||||
extern double d_sqrt(double *);
|
||||
extern double d_tan(double *);
|
||||
extern double d_tanh(double *);
|
||||
extern double derf_(double *);
|
||||
extern double derfc_(double *);
|
||||
extern integer do_fio(ftnint *, char *, ftnlen);
|
||||
extern integer do_lio(ftnint *, ftnint *, char *, ftnlen);
|
||||
extern integer do_uio(ftnint *, char *, ftnlen);
|
||||
extern integer e_rdfe(void);
|
||||
extern integer e_rdue(void);
|
||||
extern integer e_rsfe(void);
|
||||
extern integer e_rsfi(void);
|
||||
extern integer e_rsle(void);
|
||||
extern integer e_rsli(void);
|
||||
extern integer e_rsue(void);
|
||||
extern integer e_wdfe(void);
|
||||
extern integer e_wdue(void);
|
||||
extern integer e_wsfe(void);
|
||||
extern integer e_wsfi(void);
|
||||
extern integer e_wsle(void);
|
||||
extern integer e_wsli(void);
|
||||
extern integer e_wsue(void);
|
||||
extern int ef1asc_(ftnint *, ftnlen *, ftnint *, ftnlen *);
|
||||
extern integer ef1cmc_(ftnint *, ftnlen *, ftnint *, ftnlen *);
|
||||
extern double erf(double);
|
||||
extern double erf_(float *);
|
||||
extern double erfc(double);
|
||||
extern double erfc_(float *);
|
||||
extern integer f_back(alist *);
|
||||
extern integer f_clos(cllist *);
|
||||
extern integer f_end(alist *);
|
||||
extern void f_exit(void);
|
||||
extern integer f_inqu(inlist *);
|
||||
extern integer f_open(olist *);
|
||||
extern integer f_rew(alist *);
|
||||
extern int flush_(void);
|
||||
extern void getarg_(integer *, char *, ftnlen);
|
||||
extern void getenv_(char *, char *, ftnlen, ftnlen);
|
||||
extern short h_abs(short *);
|
||||
extern short h_dim(short *, short *);
|
||||
extern short h_dnnt(double *);
|
||||
extern short h_indx(char *, char *, ftnlen, ftnlen);
|
||||
extern short h_len(char *, ftnlen);
|
||||
extern short h_mod(short *, short *);
|
||||
extern short h_nint(float *);
|
||||
extern short h_sign(short *, short *);
|
||||
extern short hl_ge(char *, char *, ftnlen, ftnlen);
|
||||
extern short hl_gt(char *, char *, ftnlen, ftnlen);
|
||||
extern short hl_le(char *, char *, ftnlen, ftnlen);
|
||||
extern short hl_lt(char *, char *, ftnlen, ftnlen);
|
||||
extern integer i_abs(integer *);
|
||||
extern integer i_dim(integer *, integer *);
|
||||
extern integer i_dnnt(double *);
|
||||
extern integer i_indx(char *, char *, ftnlen, ftnlen);
|
||||
extern integer i_len(char *, ftnlen);
|
||||
extern integer i_mod(integer *, integer *);
|
||||
extern integer i_nint(float *);
|
||||
extern integer i_sign(integer *, integer *);
|
||||
extern integer iargc_(void);
|
||||
extern ftnlen l_ge(char *, char *, ftnlen, ftnlen);
|
||||
extern ftnlen l_gt(char *, char *, ftnlen, ftnlen);
|
||||
extern ftnlen l_le(char *, char *, ftnlen, ftnlen);
|
||||
extern ftnlen l_lt(char *, char *, ftnlen, ftnlen);
|
||||
extern void pow_ci(complex *, complex *, integer *);
|
||||
extern double pow_dd(double *, double *);
|
||||
extern double pow_di(double *, integer *);
|
||||
extern short pow_hh(short *, shortint *);
|
||||
extern integer pow_ii(integer *, integer *);
|
||||
extern double pow_ri(float *, integer *);
|
||||
extern void pow_zi(doublecomplex *, doublecomplex *, integer *);
|
||||
extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *);
|
||||
extern double r_abs(float *);
|
||||
extern double r_acos(float *);
|
||||
extern double r_asin(float *);
|
||||
extern double r_atan(float *);
|
||||
extern double r_atn2(float *, float *);
|
||||
extern void r_cnjg(complex *, complex *);
|
||||
extern double r_cos(float *);
|
||||
extern double r_cosh(float *);
|
||||
extern double r_dim(float *, float *);
|
||||
extern double r_exp(float *);
|
||||
extern double r_imag(complex *);
|
||||
extern double r_int(float *);
|
||||
extern double r_lg10(float *);
|
||||
extern double r_log(float *);
|
||||
extern double r_mod(float *, float *);
|
||||
extern double r_nint(float *);
|
||||
extern double r_sign(float *, float *);
|
||||
extern double r_sin(float *);
|
||||
extern double r_sinh(float *);
|
||||
extern double r_sqrt(float *);
|
||||
extern double r_tan(float *);
|
||||
extern double r_tanh(float *);
|
||||
extern void s_cat(char *, char **, integer *, integer *, ftnlen);
|
||||
extern integer s_cmp(char *, char *, ftnlen, ftnlen);
|
||||
extern void s_copy(char *, char *, ftnlen, ftnlen);
|
||||
extern int s_paus(char *, ftnlen);
|
||||
extern integer s_rdfe(cilist *);
|
||||
extern integer s_rdue(cilist *);
|
||||
extern integer s_rnge(char *, integer, char *, integer);
|
||||
extern integer s_rsfe(cilist *);
|
||||
extern integer s_rsfi(icilist *);
|
||||
extern integer s_rsle(cilist *);
|
||||
extern integer s_rsli(icilist *);
|
||||
extern integer s_rsne(cilist *);
|
||||
extern integer s_rsni(icilist *);
|
||||
extern integer s_rsue(cilist *);
|
||||
extern int s_stop(char *, ftnlen);
|
||||
extern integer s_wdfe(cilist *);
|
||||
extern integer s_wdue(cilist *);
|
||||
extern integer s_wsfe(cilist *);
|
||||
extern integer s_wsfi(icilist *);
|
||||
extern integer s_wsle(cilist *);
|
||||
extern integer s_wsli(icilist *);
|
||||
extern integer s_wsne(cilist *);
|
||||
extern integer s_wsni(icilist *);
|
||||
extern integer s_wsue(cilist *);
|
||||
extern void sig_die(char *, int);
|
||||
extern integer signal_(integer *, void (*)(int));
|
||||
extern int system_(char *, ftnlen);
|
||||
extern double z_abs(doublecomplex *);
|
||||
extern void z_cos(doublecomplex *, doublecomplex *);
|
||||
extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
|
||||
extern void z_exp(doublecomplex *, doublecomplex *);
|
||||
extern void z_log(doublecomplex *, doublecomplex *);
|
||||
extern void z_sin(doublecomplex *, doublecomplex *);
|
||||
extern void z_sqrt(doublecomplex *, doublecomplex *);
|
||||
}
|
||||
#endif
|
102
lib/libI77/fio.h
Normal file
102
lib/libI77/fio.h
Normal file
@ -0,0 +1,102 @@
|
||||
#include "stdio.h"
|
||||
#include "errno.h"
|
||||
#ifndef NULL
|
||||
/* ANSI C */
|
||||
#include "stddef.h"
|
||||
#endif
|
||||
|
||||
#ifndef SEEK_SET
|
||||
#define SEEK_SET 0
|
||||
#define SEEK_CUR 1
|
||||
#define SEEK_END 2
|
||||
#endif
|
||||
|
||||
#ifdef MSDOS
|
||||
#ifndef NON_UNIX_STDIO
|
||||
#define NON_UNIX_STDIO
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifdef UIOLEN_int
|
||||
typedef int uiolen;
|
||||
#else
|
||||
typedef long uiolen;
|
||||
#endif
|
||||
|
||||
/*units*/
|
||||
typedef struct
|
||||
{ FILE *ufd; /*0=unconnected*/
|
||||
char *ufnm;
|
||||
#ifndef MSDOS
|
||||
long uinode;
|
||||
int udev;
|
||||
#endif
|
||||
int url; /*0=sequential*/
|
||||
flag useek; /*true=can backspace, use dir, ...*/
|
||||
flag ufmt;
|
||||
flag uprnt;
|
||||
flag ublnk;
|
||||
flag uend;
|
||||
flag uwrt; /*last io was write*/
|
||||
flag uscrtch;
|
||||
} unit;
|
||||
|
||||
extern flag f__init;
|
||||
extern cilist *f__elist; /*active external io list*/
|
||||
extern flag f__reading,f__external,f__sequential,f__formatted;
|
||||
#undef Void
|
||||
#ifdef KR_headers
|
||||
#define Void /*void*/
|
||||
extern int (*f__getn)(),(*f__putn)(); /*for formatted io*/
|
||||
extern long f__inode();
|
||||
extern VOID sig_die();
|
||||
extern int (*f__donewrec)(), t_putc(), x_wSL();
|
||||
extern int c_sfe(), err__fl(), xrd_SL();
|
||||
#else
|
||||
#define Void void
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
extern int (*f__getn)(void),(*f__putn)(int); /*for formatted io*/
|
||||
extern long f__inode(char*,int*);
|
||||
extern void sig_die(char*,int);
|
||||
extern void f__fatal(int,char*);
|
||||
extern int t_runc(alist*);
|
||||
extern int f__nowreading(unit*), f__nowwriting(unit*);
|
||||
extern int fk_open(int,int,ftnint);
|
||||
extern int en_fio(void);
|
||||
extern void f_init(void);
|
||||
extern int (*f__donewrec)(void), t_putc(int), x_wSL(void);
|
||||
extern void b_char(char*,char*,ftnlen), g_char(char*,ftnlen,char*);
|
||||
extern int c_sfe(cilist*), z_rnew(void);
|
||||
extern int isatty(int);
|
||||
extern int err__fl(int,int,char*);
|
||||
extern int xrd_SL(void);
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
#endif
|
||||
extern int (*f__doend)(Void);
|
||||
extern FILE *f__cf; /*current file*/
|
||||
extern unit *f__curunit; /*current unit*/
|
||||
extern unit f__units[];
|
||||
#define err(f,m,s) {if(f) errno= m; else f__fatal(m,s); return(m);}
|
||||
#define errfl(f,m,s) return err__fl((int)f,m,s)
|
||||
|
||||
/*Table sizes*/
|
||||
#define MXUNIT 100
|
||||
|
||||
extern int f__recpos; /*position in current record*/
|
||||
extern int f__cursor; /* offset to move to */
|
||||
extern int f__hiwater; /* so TL doesn't confuse us */
|
||||
|
||||
#define WRITE 1
|
||||
#define READ 2
|
||||
#define SEQ 3
|
||||
#define DIR 4
|
||||
#define FMT 5
|
||||
#define UNF 6
|
||||
#define EXT 7
|
||||
#define INT 8
|
||||
|
||||
#define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ)
|
488
lib/libI77/fmt.c
Normal file
488
lib/libI77/fmt.c
Normal file
@ -0,0 +1,488 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
#define skip(s) while(*s==' ') s++
|
||||
#ifdef interdata
|
||||
#define SYLMX 300
|
||||
#endif
|
||||
#ifdef pdp11
|
||||
#define SYLMX 300
|
||||
#endif
|
||||
#ifdef vax
|
||||
#define SYLMX 300
|
||||
#endif
|
||||
#ifndef SYLMX
|
||||
#define SYLMX 300
|
||||
#endif
|
||||
#define GLITCH '\2'
|
||||
/* special quote character for stu */
|
||||
extern int f__cursor,f__scale;
|
||||
extern flag f__cblank,f__cplus; /*blanks in I and compulsory plus*/
|
||||
struct syl f__syl[SYLMX];
|
||||
int f__parenlvl,f__pc,f__revloc;
|
||||
|
||||
#ifdef KR_headers
|
||||
char *ap_end(s) char *s;
|
||||
#else
|
||||
char *ap_end(char *s)
|
||||
#endif
|
||||
{ char quote;
|
||||
quote= *s++;
|
||||
for(;*s;s++)
|
||||
{ if(*s!=quote) continue;
|
||||
if(*++s!=quote) return(s);
|
||||
}
|
||||
if(f__elist->cierr) {
|
||||
errno = 100;
|
||||
return(NULL);
|
||||
}
|
||||
f__fatal(100, "bad string");
|
||||
/*NOTREACHED*/ return 0;
|
||||
}
|
||||
#ifdef KR_headers
|
||||
op_gen(a,b,c,d)
|
||||
#else
|
||||
op_gen(int a, int b, int c, int d)
|
||||
#endif
|
||||
{ struct syl *p= &f__syl[f__pc];
|
||||
if(f__pc>=SYLMX)
|
||||
{ fprintf(stderr,"format too complicated:\n");
|
||||
sig_die(f__fmtbuf, 1);
|
||||
}
|
||||
p->op=a;
|
||||
p->p1=b;
|
||||
p->p2=c;
|
||||
p->p3=d;
|
||||
return(f__pc++);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
char *f_list();
|
||||
char *gt_num(s,n) char *s; int *n;
|
||||
#else
|
||||
char *f_list(char*);
|
||||
char *gt_num(char *s, int *n)
|
||||
#endif
|
||||
{ int m=0,f__cnt=0;
|
||||
char c;
|
||||
for(c= *s;;c = *s)
|
||||
{ if(c==' ')
|
||||
{ s++;
|
||||
continue;
|
||||
}
|
||||
if(c>'9' || c<'0') break;
|
||||
m=10*m+c-'0';
|
||||
f__cnt++;
|
||||
s++;
|
||||
}
|
||||
if(f__cnt==0) *n=1;
|
||||
else *n=m;
|
||||
return(s);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
char *f_s(s,curloc) char *s;
|
||||
#else
|
||||
char *f_s(char *s, int curloc)
|
||||
#endif
|
||||
{
|
||||
skip(s);
|
||||
if(*s++!='(')
|
||||
{
|
||||
return(NULL);
|
||||
}
|
||||
if(f__parenlvl++ ==1) f__revloc=curloc;
|
||||
if(op_gen(RET1,curloc,0,0)<0 ||
|
||||
(s=f_list(s))==NULL)
|
||||
{
|
||||
return(NULL);
|
||||
}
|
||||
skip(s);
|
||||
return(s);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
ne_d(s,p) char *s,**p;
|
||||
#else
|
||||
ne_d(char *s, char **p)
|
||||
#endif
|
||||
{ int n,x,sign=0;
|
||||
struct syl *sp;
|
||||
switch(*s)
|
||||
{
|
||||
default:
|
||||
return(0);
|
||||
case ':': (void) op_gen(COLON,0,0,0); break;
|
||||
case '$':
|
||||
(void) op_gen(NONL, 0, 0, 0); break;
|
||||
case 'B':
|
||||
case 'b':
|
||||
if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0);
|
||||
else (void) op_gen(BN,0,0,0);
|
||||
break;
|
||||
case 'S':
|
||||
case 's':
|
||||
if(*(s+1)=='s' || *(s+1) == 'S')
|
||||
{ x=SS;
|
||||
s++;
|
||||
}
|
||||
else if(*(s+1)=='p' || *(s+1) == 'P')
|
||||
{ x=SP;
|
||||
s++;
|
||||
}
|
||||
else x=S;
|
||||
(void) op_gen(x,0,0,0);
|
||||
break;
|
||||
case '/': (void) op_gen(SLASH,0,0,0); break;
|
||||
case '-': sign=1;
|
||||
case '+': s++; /*OUTRAGEOUS CODING TRICK*/
|
||||
case '0': case '1': case '2': case '3': case '4':
|
||||
case '5': case '6': case '7': case '8': case '9':
|
||||
s=gt_num(s,&n);
|
||||
switch(*s)
|
||||
{
|
||||
default:
|
||||
return(0);
|
||||
case 'P':
|
||||
case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break;
|
||||
case 'X':
|
||||
case 'x': (void) op_gen(X,n,0,0); break;
|
||||
case 'H':
|
||||
case 'h':
|
||||
sp = &f__syl[op_gen(H,n,0,0)];
|
||||
*(char **)&sp->p2 = s + 1;
|
||||
s+=n;
|
||||
break;
|
||||
}
|
||||
break;
|
||||
case GLITCH:
|
||||
case '"':
|
||||
case '\'':
|
||||
sp = &f__syl[op_gen(APOS,0,0,0)];
|
||||
*(char **)&sp->p2 = s;
|
||||
if((*p = ap_end(s)) == NULL)
|
||||
return(0);
|
||||
return(1);
|
||||
case 'T':
|
||||
case 't':
|
||||
if(*(s+1)=='l' || *(s+1) == 'L')
|
||||
{ x=TL;
|
||||
s++;
|
||||
}
|
||||
else if(*(s+1)=='r'|| *(s+1) == 'R')
|
||||
{ x=TR;
|
||||
s++;
|
||||
}
|
||||
else x=T;
|
||||
s=gt_num(s+1,&n);
|
||||
s--;
|
||||
(void) op_gen(x,n,0,0);
|
||||
break;
|
||||
case 'X':
|
||||
case 'x': (void) op_gen(X,1,0,0); break;
|
||||
case 'P':
|
||||
case 'p': (void) op_gen(P,1,0,0); break;
|
||||
}
|
||||
s++;
|
||||
*p=s;
|
||||
return(1);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
e_d(s,p) char *s,**p;
|
||||
#else
|
||||
e_d(char *s, char **p)
|
||||
#endif
|
||||
{ int i,im,n,w,d,e,found=0,x=0;
|
||||
char *sv=s;
|
||||
s=gt_num(s,&n);
|
||||
(void) op_gen(STACK,n,0,0);
|
||||
switch(*s++)
|
||||
{
|
||||
default: break;
|
||||
case 'E':
|
||||
case 'e': x=1;
|
||||
case 'G':
|
||||
case 'g':
|
||||
found=1;
|
||||
s=gt_num(s,&w);
|
||||
if(w==0) break;
|
||||
if(*s=='.')
|
||||
{ s++;
|
||||
s=gt_num(s,&d);
|
||||
}
|
||||
else d=0;
|
||||
if(*s!='E' && *s != 'e')
|
||||
(void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */
|
||||
else
|
||||
{ s++;
|
||||
s=gt_num(s,&e);
|
||||
(void) op_gen(x==1?EE:GE,w,d,e);
|
||||
}
|
||||
break;
|
||||
case 'O':
|
||||
case 'o':
|
||||
i = O;
|
||||
im = OM;
|
||||
goto finish_I;
|
||||
case 'Z':
|
||||
case 'z':
|
||||
i = Z;
|
||||
im = ZM;
|
||||
goto finish_I;
|
||||
case 'L':
|
||||
case 'l':
|
||||
found=1;
|
||||
s=gt_num(s,&w);
|
||||
if(w==0) break;
|
||||
(void) op_gen(L,w,0,0);
|
||||
break;
|
||||
case 'A':
|
||||
case 'a':
|
||||
found=1;
|
||||
skip(s);
|
||||
if(*s>='0' && *s<='9')
|
||||
{ s=gt_num(s,&w);
|
||||
if(w==0) break;
|
||||
(void) op_gen(AW,w,0,0);
|
||||
break;
|
||||
}
|
||||
(void) op_gen(A,0,0,0);
|
||||
break;
|
||||
case 'F':
|
||||
case 'f':
|
||||
found=1;
|
||||
s=gt_num(s,&w);
|
||||
if(w==0) break;
|
||||
if(*s=='.')
|
||||
{ s++;
|
||||
s=gt_num(s,&d);
|
||||
}
|
||||
else d=0;
|
||||
(void) op_gen(F,w,d,0);
|
||||
break;
|
||||
case 'D':
|
||||
case 'd':
|
||||
found=1;
|
||||
s=gt_num(s,&w);
|
||||
if(w==0) break;
|
||||
if(*s=='.')
|
||||
{ s++;
|
||||
s=gt_num(s,&d);
|
||||
}
|
||||
else d=0;
|
||||
(void) op_gen(D,w,d,0);
|
||||
break;
|
||||
case 'I':
|
||||
case 'i':
|
||||
i = I;
|
||||
im = IM;
|
||||
finish_I:
|
||||
found=1;
|
||||
s=gt_num(s,&w);
|
||||
if(w==0) break;
|
||||
if(*s!='.')
|
||||
{ (void) op_gen(i,w,0,0);
|
||||
break;
|
||||
}
|
||||
s++;
|
||||
s=gt_num(s,&d);
|
||||
(void) op_gen(im,w,d,0);
|
||||
break;
|
||||
}
|
||||
if(found==0)
|
||||
{ f__pc--; /*unSTACK*/
|
||||
*p=sv;
|
||||
return(0);
|
||||
}
|
||||
*p=s;
|
||||
return(1);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
char *i_tem(s) char *s;
|
||||
#else
|
||||
char *i_tem(char *s)
|
||||
#endif
|
||||
{ char *t;
|
||||
int n,curloc;
|
||||
if(*s==')') return(s);
|
||||
if(ne_d(s,&t)) return(t);
|
||||
if(e_d(s,&t)) return(t);
|
||||
s=gt_num(s,&n);
|
||||
if((curloc=op_gen(STACK,n,0,0))<0) return(NULL);
|
||||
return(f_s(s,curloc));
|
||||
}
|
||||
#ifdef KR_headers
|
||||
char *f_list(s) char *s;
|
||||
#else
|
||||
char *f_list(char *s)
|
||||
#endif
|
||||
{
|
||||
for(;*s!=0;)
|
||||
{ skip(s);
|
||||
if((s=i_tem(s))==NULL) return(NULL);
|
||||
skip(s);
|
||||
if(*s==',') s++;
|
||||
else if(*s==')')
|
||||
{ if(--f__parenlvl==0)
|
||||
{
|
||||
(void) op_gen(REVERT,f__revloc,0,0);
|
||||
return(++s);
|
||||
}
|
||||
(void) op_gen(GOTO,0,0,0);
|
||||
return(++s);
|
||||
}
|
||||
}
|
||||
return(NULL);
|
||||
}
|
||||
|
||||
#ifdef KR_headers
|
||||
pars_f(s) char *s;
|
||||
#else
|
||||
pars_f(char *s)
|
||||
#endif
|
||||
{
|
||||
f__parenlvl=f__revloc=f__pc=0;
|
||||
if(f_s(s,0) == NULL)
|
||||
{
|
||||
return(-1);
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
#define STKSZ 10
|
||||
int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp;
|
||||
flag f__workdone, f__nonl;
|
||||
|
||||
#ifdef KR_headers
|
||||
type_f(n)
|
||||
#else
|
||||
type_f(int n)
|
||||
#endif
|
||||
{
|
||||
switch(n)
|
||||
{
|
||||
default:
|
||||
return(n);
|
||||
case RET1:
|
||||
return(RET1);
|
||||
case REVERT: return(REVERT);
|
||||
case GOTO: return(GOTO);
|
||||
case STACK: return(STACK);
|
||||
case X:
|
||||
case SLASH:
|
||||
case APOS: case H:
|
||||
case T: case TL: case TR:
|
||||
return(NED);
|
||||
case F:
|
||||
case I:
|
||||
case IM:
|
||||
case A: case AW:
|
||||
case O: case OM:
|
||||
case L:
|
||||
case E: case EE: case D:
|
||||
case G: case GE:
|
||||
case Z: case ZM:
|
||||
return(ED);
|
||||
}
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
|
||||
#else
|
||||
integer do_fio(ftnint *number, char *ptr, ftnlen len)
|
||||
#endif
|
||||
{ struct syl *p;
|
||||
int n,i;
|
||||
for(i=0;i<*number;i++,ptr+=len)
|
||||
{
|
||||
loop: switch(type_f((p= &f__syl[f__pc])->op))
|
||||
{
|
||||
default:
|
||||
fprintf(stderr,"unknown code in do_fio: %d\n%s\n",
|
||||
p->op,f__fmtbuf);
|
||||
err(f__elist->cierr,100,"do_fio");
|
||||
case NED:
|
||||
if((*f__doned)(p))
|
||||
{ f__pc++;
|
||||
goto loop;
|
||||
}
|
||||
f__pc++;
|
||||
continue;
|
||||
case ED:
|
||||
if(f__cnt[f__cp]<=0)
|
||||
{ f__cp--;
|
||||
f__pc++;
|
||||
goto loop;
|
||||
}
|
||||
if(ptr==NULL)
|
||||
return((*f__doend)());
|
||||
f__cnt[f__cp]--;
|
||||
f__workdone=1;
|
||||
if((n=(*f__doed)(p,ptr,len))>0)
|
||||
errfl(f__elist->cierr,errno,"fmt");
|
||||
if(n<0)
|
||||
err(f__elist->ciend,(EOF),"fmt");
|
||||
continue;
|
||||
case STACK:
|
||||
f__cnt[++f__cp]=p->p1;
|
||||
f__pc++;
|
||||
goto loop;
|
||||
case RET1:
|
||||
f__ret[++f__rp]=p->p1;
|
||||
f__pc++;
|
||||
goto loop;
|
||||
case GOTO:
|
||||
if(--f__cnt[f__cp]<=0)
|
||||
{ f__cp--;
|
||||
f__rp--;
|
||||
f__pc++;
|
||||
goto loop;
|
||||
}
|
||||
f__pc=1+f__ret[f__rp--];
|
||||
goto loop;
|
||||
case REVERT:
|
||||
f__rp=f__cp=0;
|
||||
f__pc = p->p1;
|
||||
if(ptr==NULL)
|
||||
return((*f__doend)());
|
||||
if(!f__workdone) return(0);
|
||||
if((n=(*f__dorevert)()) != 0) return(n);
|
||||
goto loop;
|
||||
case COLON:
|
||||
if(ptr==NULL)
|
||||
return((*f__doend)());
|
||||
f__pc++;
|
||||
goto loop;
|
||||
case NONL:
|
||||
f__nonl = 1;
|
||||
f__pc++;
|
||||
goto loop;
|
||||
case S:
|
||||
case SS:
|
||||
f__cplus=0;
|
||||
f__pc++;
|
||||
goto loop;
|
||||
case SP:
|
||||
f__cplus = 1;
|
||||
f__pc++;
|
||||
goto loop;
|
||||
case P: f__scale=p->p1;
|
||||
f__pc++;
|
||||
goto loop;
|
||||
case BN:
|
||||
f__cblank=0;
|
||||
f__pc++;
|
||||
goto loop;
|
||||
case BZ:
|
||||
f__cblank=1;
|
||||
f__pc++;
|
||||
goto loop;
|
||||
}
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
en_fio(Void)
|
||||
{ ftnint one=1;
|
||||
return(do_fio(&one,(char *)NULL,(ftnint)0));
|
||||
}
|
||||
VOID
|
||||
fmt_bg(Void)
|
||||
{
|
||||
f__workdone=f__cp=f__rp=f__pc=f__cursor=0;
|
||||
f__cnt[0]=f__ret[0]=0;
|
||||
}
|
82
lib/libI77/fmt.h
Normal file
82
lib/libI77/fmt.h
Normal file
@ -0,0 +1,82 @@
|
||||
struct syl
|
||||
{ int op,p1,p2,p3;
|
||||
};
|
||||
#define RET1 1
|
||||
#define REVERT 2
|
||||
#define GOTO 3
|
||||
#define X 4
|
||||
#define SLASH 5
|
||||
#define STACK 6
|
||||
#define I 7
|
||||
#define ED 8
|
||||
#define NED 9
|
||||
#define IM 10
|
||||
#define APOS 11
|
||||
#define H 12
|
||||
#define TL 13
|
||||
#define TR 14
|
||||
#define T 15
|
||||
#define COLON 16
|
||||
#define S 17
|
||||
#define SP 18
|
||||
#define SS 19
|
||||
#define P 20
|
||||
#define BN 21
|
||||
#define BZ 22
|
||||
#define F 23
|
||||
#define E 24
|
||||
#define EE 25
|
||||
#define D 26
|
||||
#define G 27
|
||||
#define GE 28
|
||||
#define L 29
|
||||
#define A 30
|
||||
#define AW 31
|
||||
#define O 32
|
||||
#define NONL 33
|
||||
#define OM 34
|
||||
#define Z 35
|
||||
#define ZM 36
|
||||
extern struct syl f__syl[];
|
||||
extern int f__pc,f__parenlvl,f__revloc;
|
||||
typedef union
|
||||
{ real pf;
|
||||
doublereal pd;
|
||||
} ufloat;
|
||||
typedef union
|
||||
{ short is;
|
||||
char ic;
|
||||
integer il;
|
||||
#ifdef Allow_TYQUAD
|
||||
longint ili;
|
||||
#endif
|
||||
} Uint;
|
||||
#ifdef KR_headers
|
||||
extern int (*f__doed)(),(*f__doned)();
|
||||
extern int (*f__dorevert)();
|
||||
extern int rd_ed(),rd_ned();
|
||||
extern int w_ed(),w_ned();
|
||||
#else
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
extern int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*);
|
||||
extern int (*f__dorevert)(void);
|
||||
extern void fmt_bg(void);
|
||||
extern int pars_f(char*);
|
||||
extern int rd_ed(struct syl*, char*, ftnlen),rd_ned(struct syl*);
|
||||
extern int w_ed(struct syl*, char*, ftnlen),w_ned(struct syl*);
|
||||
extern int wrt_E(ufloat*, int, int, int, ftnlen);
|
||||
extern int wrt_F(ufloat*, int, int, ftnlen);
|
||||
extern int wrt_L(Uint*, int, ftnlen);
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
#endif
|
||||
extern flag f__cblank,f__cplus,f__workdone, f__nonl;
|
||||
extern char *f__fmtbuf;
|
||||
extern int f__scale;
|
||||
#define GET(x) if((x=(*f__getn)())<0) return(x)
|
||||
#define VAL(x) (x!='\n'?x:' ')
|
||||
#define PUT(x) (*f__putn)(x)
|
||||
extern int f__cursor;
|
28
lib/libI77/fmtlib.c
Normal file
28
lib/libI77/fmtlib.c
Normal file
@ -0,0 +1,28 @@
|
||||
/* @(#)fmtlib.c 1.2 */
|
||||
#define MAXINTLENGTH 23
|
||||
#ifdef KR_headers
|
||||
char *f__icvt(value,ndigit,sign, base) long value; int *ndigit,*sign;
|
||||
register int base;
|
||||
#else
|
||||
char *f__icvt(long value, int *ndigit, int *sign, int base)
|
||||
#endif
|
||||
{ static char buf[MAXINTLENGTH+1];
|
||||
register int i;
|
||||
if(value>0) *sign=0;
|
||||
else if(value<0)
|
||||
{ value = -value;
|
||||
*sign= 1;
|
||||
}
|
||||
else
|
||||
{ *sign=0;
|
||||
*ndigit=1;
|
||||
buf[MAXINTLENGTH]='0';
|
||||
return(&buf[MAXINTLENGTH]);
|
||||
}
|
||||
for(i=MAXINTLENGTH-1;value>0;i--)
|
||||
{ *(buf+i)=(int)(value%base)+'0';
|
||||
value /= base;
|
||||
}
|
||||
*ndigit=MAXINTLENGTH-1-i;
|
||||
return(&buf[i+1]);
|
||||
}
|
28
lib/libI77/fp.h
Normal file
28
lib/libI77/fp.h
Normal file
@ -0,0 +1,28 @@
|
||||
#define FMAX 40
|
||||
#define EXPMAXDIGS 8
|
||||
#define EXPMAX 99999999
|
||||
/* FMAX = max number of nonzero digits passed to atof() */
|
||||
/* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */
|
||||
|
||||
#ifdef V10 /* Research Tenth-Edition Unix */
|
||||
#include "local.h"
|
||||
#endif
|
||||
|
||||
/* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily
|
||||
tight) on the maximum number of digits to the right and left of
|
||||
* the decimal point.
|
||||
*/
|
||||
|
||||
#ifdef VAX
|
||||
#define MAXFRACDIGS 56
|
||||
#define MAXINTDIGS 38
|
||||
#else
|
||||
#ifdef CRAY
|
||||
#define MAXFRACDIGS 9880
|
||||
#define MAXINTDIGS 9864
|
||||
#else
|
||||
/* values that suffice for IEEE double */
|
||||
#define MAXFRACDIGS 344
|
||||
#define MAXINTDIGS 308
|
||||
#endif
|
||||
#endif
|
138
lib/libI77/iio.c
Normal file
138
lib/libI77/iio.c
Normal file
@ -0,0 +1,138 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
extern char *f__icptr;
|
||||
char *f__icend;
|
||||
extern icilist *f__svic;
|
||||
int f__icnum;
|
||||
extern int f__hiwater;
|
||||
z_getc(Void)
|
||||
{
|
||||
if(f__recpos++ < f__svic->icirlen) {
|
||||
if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"endfile");
|
||||
return(*f__icptr++);
|
||||
}
|
||||
return '\n';
|
||||
}
|
||||
#ifdef KR_headers
|
||||
z_putc(c)
|
||||
#else
|
||||
z_putc(int c)
|
||||
#endif
|
||||
{
|
||||
if(f__icptr >= f__icend) err(f__svic->icierr,110,"inwrite");
|
||||
if(f__recpos++ < f__svic->icirlen)
|
||||
*f__icptr++ = c;
|
||||
else err(f__svic->icierr,110,"recend");
|
||||
return 0;
|
||||
}
|
||||
z_rnew(Void)
|
||||
{
|
||||
f__icptr = f__svic->iciunit + (++f__icnum)*f__svic->icirlen;
|
||||
f__recpos = 0;
|
||||
f__cursor = 0;
|
||||
f__hiwater = 0;
|
||||
return 1;
|
||||
}
|
||||
|
||||
static int
|
||||
z_endp(Void)
|
||||
{
|
||||
(*f__donewrec)();
|
||||
return 0;
|
||||
}
|
||||
|
||||
#ifdef KR_headers
|
||||
c_si(a) icilist *a;
|
||||
#else
|
||||
c_si(icilist *a)
|
||||
#endif
|
||||
{
|
||||
f__elist = (cilist *)a;
|
||||
f__fmtbuf=a->icifmt;
|
||||
if(pars_f(f__fmtbuf)<0)
|
||||
err(a->icierr,100,"startint");
|
||||
fmt_bg();
|
||||
f__sequential=f__formatted=1;
|
||||
f__external=0;
|
||||
f__cblank=f__cplus=f__scale=0;
|
||||
f__svic=a;
|
||||
f__icnum=f__recpos=0;
|
||||
f__cursor = 0;
|
||||
f__hiwater = 0;
|
||||
f__icptr = a->iciunit;
|
||||
f__icend = f__icptr + a->icirlen*a->icirnum;
|
||||
f__curunit = 0;
|
||||
f__cf = 0;
|
||||
return(0);
|
||||
}
|
||||
|
||||
int
|
||||
iw_rev(Void)
|
||||
{
|
||||
if(f__workdone)
|
||||
z_endp();
|
||||
f__hiwater = f__recpos = f__cursor = 0;
|
||||
return(f__workdone=0);
|
||||
}
|
||||
|
||||
#ifdef KR_headers
|
||||
integer s_rsfi(a) icilist *a;
|
||||
#else
|
||||
integer s_rsfi(icilist *a)
|
||||
#endif
|
||||
{ int n;
|
||||
if(n=c_si(a)) return(n);
|
||||
f__reading=1;
|
||||
f__doed=rd_ed;
|
||||
f__doned=rd_ned;
|
||||
f__getn=z_getc;
|
||||
f__dorevert = z_endp;
|
||||
f__donewrec = z_rnew;
|
||||
f__doend = z_endp;
|
||||
return(0);
|
||||
}
|
||||
|
||||
z_wnew(Void)
|
||||
{
|
||||
while(f__recpos++ < f__svic->icirlen)
|
||||
*f__icptr++ = ' ';
|
||||
f__recpos = 0;
|
||||
f__cursor = 0;
|
||||
f__hiwater = 0;
|
||||
f__icnum++;
|
||||
return 1;
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer s_wsfi(a) icilist *a;
|
||||
#else
|
||||
integer s_wsfi(icilist *a)
|
||||
#endif
|
||||
{ int n;
|
||||
if(n=c_si(a)) return(n);
|
||||
f__reading=0;
|
||||
f__doed=w_ed;
|
||||
f__doned=w_ned;
|
||||
f__putn=z_putc;
|
||||
f__dorevert = iw_rev;
|
||||
f__donewrec = z_wnew;
|
||||
f__doend = z_endp;
|
||||
return(0);
|
||||
}
|
||||
integer e_rsfi(Void)
|
||||
{ int n;
|
||||
n = en_fio();
|
||||
f__fmtbuf = NULL;
|
||||
return(n);
|
||||
}
|
||||
integer e_wsfi(Void)
|
||||
{
|
||||
int n;
|
||||
n = en_fio();
|
||||
f__fmtbuf = NULL;
|
||||
if(f__icnum >= f__svic->icirnum)
|
||||
return(n);
|
||||
while(f__recpos++ < f__svic->icirlen)
|
||||
*f__icptr++ = ' ';
|
||||
return(n);
|
||||
}
|
77
lib/libI77/ilnw.c
Normal file
77
lib/libI77/ilnw.c
Normal file
@ -0,0 +1,77 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "lio.h"
|
||||
extern char *f__icptr;
|
||||
extern char *f__icend;
|
||||
extern icilist *f__svic;
|
||||
extern int f__icnum;
|
||||
#ifdef KR_headers
|
||||
extern int z_putc();
|
||||
#else
|
||||
extern int z_putc(int);
|
||||
#endif
|
||||
|
||||
static int
|
||||
z_wSL(Void)
|
||||
{
|
||||
while(f__recpos < f__svic->icirlen)
|
||||
z_putc(' ');
|
||||
return z_rnew();
|
||||
}
|
||||
|
||||
VOID
|
||||
#ifdef KR_headers
|
||||
c_liw(a) icilist *a;
|
||||
#else
|
||||
c_liw(icilist *a)
|
||||
#endif
|
||||
{
|
||||
f__reading = 0;
|
||||
f__external = 0;
|
||||
f__formatted = 1;
|
||||
f__putn = z_putc;
|
||||
L_len = a->icirlen;
|
||||
f__donewrec = z_wSL;
|
||||
f__svic = a;
|
||||
f__icnum = f__recpos = 0;
|
||||
f__cursor = 0;
|
||||
f__cf = 0;
|
||||
f__curunit = 0;
|
||||
f__icptr = a->iciunit;
|
||||
f__icend = f__icptr + a->icirlen*a->icirnum;
|
||||
f__elist = (cilist *)a;
|
||||
}
|
||||
|
||||
integer
|
||||
#ifdef KR_headers
|
||||
s_wsni(a) icilist *a;
|
||||
#else
|
||||
s_wsni(icilist *a)
|
||||
#endif
|
||||
{
|
||||
cilist ca;
|
||||
|
||||
c_liw(a);
|
||||
ca.cifmt = a->icifmt;
|
||||
x_wsne(&ca);
|
||||
z_wSL();
|
||||
return 0;
|
||||
}
|
||||
|
||||
integer
|
||||
#ifdef KR_headers
|
||||
s_wsli(a) icilist *a;
|
||||
#else
|
||||
s_wsli(icilist *a)
|
||||
#endif
|
||||
{
|
||||
f__lioproc = l_write;
|
||||
c_liw(a);
|
||||
return(0);
|
||||
}
|
||||
|
||||
integer e_wsli(Void)
|
||||
{
|
||||
z_wSL();
|
||||
return(0);
|
||||
}
|
106
lib/libI77/inquire.c
Normal file
106
lib/libI77/inquire.c
Normal file
@ -0,0 +1,106 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#ifdef KR_headers
|
||||
integer f_inqu(a) inlist *a;
|
||||
#else
|
||||
#ifdef MSDOS
|
||||
#undef abs
|
||||
#undef min
|
||||
#undef max
|
||||
#include "string.h"
|
||||
#include "io.h"
|
||||
#endif
|
||||
integer f_inqu(inlist *a)
|
||||
#endif
|
||||
{ flag byfile;
|
||||
int i, n;
|
||||
unit *p;
|
||||
char buf[256];
|
||||
long x;
|
||||
if(a->infile!=NULL)
|
||||
{ byfile=1;
|
||||
g_char(a->infile,a->infilen,buf);
|
||||
#ifdef NON_UNIX_STDIO
|
||||
x = access(buf,0) ? -1 : 0;
|
||||
for(i=0,p=NULL;i<MXUNIT;i++)
|
||||
if(f__units[i].ufd != NULL
|
||||
&& f__units[i].ufnm != NULL
|
||||
&& !strcmp(f__units[i].ufnm,buf)) {
|
||||
p = &f__units[i];
|
||||
break;
|
||||
}
|
||||
#else
|
||||
x=f__inode(buf, &n);
|
||||
for(i=0,p=NULL;i<MXUNIT;i++)
|
||||
if(f__units[i].uinode==x
|
||||
&& f__units[i].ufd!=NULL
|
||||
&& f__units[i].udev == n) {
|
||||
p = &f__units[i];
|
||||
break;
|
||||
}
|
||||
#endif
|
||||
}
|
||||
else
|
||||
{
|
||||
byfile=0;
|
||||
if(a->inunit<MXUNIT && a->inunit>=0)
|
||||
{
|
||||
p= &f__units[a->inunit];
|
||||
}
|
||||
else
|
||||
{
|
||||
p=NULL;
|
||||
}
|
||||
}
|
||||
if(a->inex!=NULL)
|
||||
if(byfile && x != -1 || !byfile && p!=NULL)
|
||||
*a->inex=1;
|
||||
else *a->inex=0;
|
||||
if(a->inopen!=NULL)
|
||||
if(byfile) *a->inopen=(p!=NULL);
|
||||
else *a->inopen=(p!=NULL && p->ufd!=NULL);
|
||||
if(a->innum!=NULL) *a->innum= p-f__units;
|
||||
if(a->innamed!=NULL)
|
||||
if(byfile || p!=NULL && p->ufnm!=NULL)
|
||||
*a->innamed=1;
|
||||
else *a->innamed=0;
|
||||
if(a->inname!=NULL)
|
||||
if(byfile)
|
||||
b_char(buf,a->inname,a->innamlen);
|
||||
else if(p!=NULL && p->ufnm!=NULL)
|
||||
b_char(p->ufnm,a->inname,a->innamlen);
|
||||
if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL)
|
||||
if(p->url)
|
||||
b_char("DIRECT",a->inacc,a->inacclen);
|
||||
else b_char("SEQUENTIAL",a->inacc,a->inacclen);
|
||||
if(a->inseq!=NULL)
|
||||
if(p!=NULL && p->url)
|
||||
b_char("NO",a->inseq,a->inseqlen);
|
||||
else b_char("YES",a->inseq,a->inseqlen);
|
||||
if(a->indir!=NULL)
|
||||
if(p==NULL || p->url)
|
||||
b_char("YES",a->indir,a->indirlen);
|
||||
else b_char("NO",a->indir,a->indirlen);
|
||||
if(a->infmt!=NULL)
|
||||
if(p!=NULL && p->ufmt==0)
|
||||
b_char("UNFORMATTED",a->infmt,a->infmtlen);
|
||||
else b_char("FORMATTED",a->infmt,a->infmtlen);
|
||||
if(a->inform!=NULL)
|
||||
if(p!=NULL && p->ufmt==0)
|
||||
b_char("NO",a->inform,a->informlen);
|
||||
else b_char("YES",a->inform,a->informlen);
|
||||
if(a->inunf)
|
||||
if(p!=NULL && p->ufmt==0)
|
||||
b_char("YES",a->inunf,a->inunflen);
|
||||
else if (p!=NULL) b_char("NO",a->inunf,a->inunflen);
|
||||
else b_char("UNKNOWN",a->inunf,a->inunflen);
|
||||
if(a->inrecl!=NULL && p!=NULL)
|
||||
*a->inrecl=p->url;
|
||||
if(a->innrec!=NULL && p!=NULL && p->url>0)
|
||||
*a->innrec=ftell(p->ufd)/p->url+1;
|
||||
if(a->inblank && p!=NULL && p->ufmt)
|
||||
if(p->ublnk)
|
||||
b_char("ZERO",a->inblank,a->inblanklen);
|
||||
else b_char("NULL",a->inblank,a->inblanklen);
|
||||
return(0);
|
||||
}
|
41
lib/libI77/libI77.xsum
Normal file
41
lib/libI77/libI77.xsum
Normal file
@ -0,0 +1,41 @@
|
||||
Notice 15a21790 1184
|
||||
README 16b752be 7685
|
||||
Version.c 11b93284 9820
|
||||
backspace.c 198946cc 1759
|
||||
close.c 175acd02 1336
|
||||
dfe.c 3c6b216 2903
|
||||
dolio.c 17595b24 404
|
||||
due.c 1bbe319b 1430
|
||||
endfile.c 12d875dc 3400
|
||||
err.c fccb27de 6084
|
||||
f2ch.add fed3bb7b 6056
|
||||
fio.h e7e8a21c 2315
|
||||
fmt.c e37e7c2a 7857
|
||||
fmt.h 1273f9e8 1628
|
||||
fmtlib.c e010030f 582
|
||||
fp.h 100fb355 665
|
||||
iio.c e04c6615 2258
|
||||
ilnw.c fa459169 1049
|
||||
inquire.c e1059667 2536
|
||||
lio.h ffc2e000 1550
|
||||
lread.c e220dbce 11416
|
||||
lwrite.c 1a82fbe7 4183
|
||||
makefile e8266f12 1972
|
||||
open.c fd6dc333 4485
|
||||
rawio.h b9d538d 688
|
||||
rdfmt.c 1d49cf1d 8344
|
||||
rewind.c 87b080b 408
|
||||
rsfe.c c949b09 1299
|
||||
rsli.c 1259dfec 1748
|
||||
rsne.c ee3a2728 10686
|
||||
sfe.c f8a8b265 638
|
||||
sue.c ff73457b 1740
|
||||
typesize.c e5660590 319
|
||||
uio.c fe44d524 1547
|
||||
util.c f17978be 824
|
||||
wref.c 1d4e4539 4108
|
||||
wrtfmt.c f41b0c38 8075
|
||||
wsfe.c 250d1ef 1658
|
||||
wsle.c 2f94457 611
|
||||
wsne.c fd7a0e2f 438
|
||||
xwsne.c 7ac1479 1080
|
73
lib/libI77/lio.h
Normal file
73
lib/libI77/lio.h
Normal file
@ -0,0 +1,73 @@
|
||||
/* copy of ftypes from the compiler */
|
||||
/* variable types
|
||||
* numeric assumptions:
|
||||
* int < reals < complexes
|
||||
* TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
|
||||
*/
|
||||
|
||||
/* 0-10 retain their old (pre LOGICAL*1, etc.) */
|
||||
/* values to allow mixing old and new objects. */
|
||||
|
||||
#define TYUNKNOWN 0
|
||||
#define TYADDR 1
|
||||
#define TYSHORT 2
|
||||
#define TYLONG 3
|
||||
#define TYREAL 4
|
||||
#define TYDREAL 5
|
||||
#define TYCOMPLEX 6
|
||||
#define TYDCOMPLEX 7
|
||||
#define TYLOGICAL 8
|
||||
#define TYCHAR 9
|
||||
#define TYSUBR 10
|
||||
#define TYINT1 11
|
||||
#define TYLOGICAL1 12
|
||||
#define TYLOGICAL2 13
|
||||
#ifdef Allow_TYQUAD
|
||||
#define TYQUAD 14
|
||||
#endif
|
||||
|
||||
#define LINTW 24
|
||||
#define LINE 80
|
||||
#define LLOGW 2
|
||||
#ifdef Old_list_output
|
||||
#define LLOW 1.0
|
||||
#define LHIGH 1.e9
|
||||
#define LEFMT " %# .8E"
|
||||
#define LFFMT " %# .9g"
|
||||
#else
|
||||
#define LGFMT "%.9G"
|
||||
#endif
|
||||
/* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */
|
||||
#define LEFBL 24
|
||||
|
||||
typedef union
|
||||
{
|
||||
char flchar;
|
||||
short flshort;
|
||||
ftnint flint;
|
||||
#ifdef Allow_TYQUAD
|
||||
longint fllongint;
|
||||
#endif
|
||||
real flreal;
|
||||
doublereal fldouble;
|
||||
} flex;
|
||||
extern int f__scale;
|
||||
#ifdef KR_headers
|
||||
extern int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
|
||||
extern int l_read(), l_write();
|
||||
#else
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint);
|
||||
extern int l_write(ftnint*, char*, ftnlen, ftnint);
|
||||
extern void x_wsne(cilist*);
|
||||
extern int c_le(cilist*), (*l_getc)(void), (*l_ungetc)(int,FILE*);
|
||||
extern int l_read(ftnint*,char*,ftnlen,ftnint);
|
||||
extern integer e_rsle(void), e_wsle(void), s_wsne(cilist*);
|
||||
extern int z_rnew(void);
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
#endif
|
||||
extern ftnint L_len;
|
620
lib/libI77/lread.c
Normal file
620
lib/libI77/lread.c
Normal file
@ -0,0 +1,620 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
#include "lio.h"
|
||||
#include "ctype.h"
|
||||
#include "fp.h"
|
||||
|
||||
extern char *f__fmtbuf;
|
||||
#ifdef KR_headers
|
||||
extern double atof();
|
||||
extern char *malloc(), *realloc();
|
||||
int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
|
||||
#else
|
||||
#undef abs
|
||||
#undef min
|
||||
#undef max
|
||||
#include "stdlib.h"
|
||||
int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
|
||||
(*l_ungetc)(int,FILE*);
|
||||
#endif
|
||||
int l_eof;
|
||||
|
||||
#define isblnk(x) (f__ltab[x+1]&B)
|
||||
#define issep(x) (f__ltab[x+1]&SX)
|
||||
#define isapos(x) (f__ltab[x+1]&AX)
|
||||
#define isexp(x) (f__ltab[x+1]&EX)
|
||||
#define issign(x) (f__ltab[x+1]&SG)
|
||||
#define iswhit(x) (f__ltab[x+1]&WH)
|
||||
#define SX 1
|
||||
#define B 2
|
||||
#define AX 4
|
||||
#define EX 8
|
||||
#define SG 16
|
||||
#define WH 32
|
||||
char f__ltab[128+1] = { /* offset one for EOF */
|
||||
0,
|
||||
0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
||||
SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
||||
0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
||||
AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
|
||||
};
|
||||
|
||||
#ifdef ungetc
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
un_getc(x,f__cf) int x; FILE *f__cf;
|
||||
#else
|
||||
un_getc(int x, FILE *f__cf)
|
||||
#endif
|
||||
{ return ungetc(x,f__cf); }
|
||||
#else
|
||||
#define un_getc ungetc
|
||||
#ifdef KR_headers
|
||||
extern int ungetc();
|
||||
#else
|
||||
extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */
|
||||
#endif
|
||||
#endif
|
||||
|
||||
t_getc(Void)
|
||||
{ int ch;
|
||||
if(f__curunit->uend) return(EOF);
|
||||
if((ch=getc(f__cf))!=EOF) return(ch);
|
||||
if(feof(f__cf))
|
||||
f__curunit->uend = l_eof = 1;
|
||||
return(EOF);
|
||||
}
|
||||
integer e_rsle(Void)
|
||||
{
|
||||
int ch;
|
||||
if(f__curunit->uend) return(0);
|
||||
while((ch=t_getc())!='\n' && ch!=EOF);
|
||||
return(0);
|
||||
}
|
||||
|
||||
flag f__lquit;
|
||||
int f__lcount,f__ltype,nml_read;
|
||||
char *f__lchar;
|
||||
double f__lx,f__ly;
|
||||
#define ERR(x) if(n=(x)) return(n)
|
||||
#define GETC(x) (x=(*l_getc)())
|
||||
#define Ungetc(x,y) (*l_ungetc)(x,y)
|
||||
|
||||
#ifdef KR_headers
|
||||
l_R(poststar) int poststar;
|
||||
#else
|
||||
l_R(int poststar)
|
||||
#endif
|
||||
{
|
||||
char s[FMAX+EXPMAXDIGS+4];
|
||||
register int ch;
|
||||
register char *sp, *spe, *sp1;
|
||||
long e, exp;
|
||||
int havenum, havestar, se;
|
||||
|
||||
if (!poststar) {
|
||||
if (f__lcount > 0)
|
||||
return(0);
|
||||
f__lcount = 1;
|
||||
}
|
||||
f__ltype = 0;
|
||||
exp = 0;
|
||||
havestar = 0;
|
||||
retry:
|
||||
sp1 = sp = s;
|
||||
spe = sp + FMAX;
|
||||
havenum = 0;
|
||||
|
||||
switch(GETC(ch)) {
|
||||
case '-': *sp++ = ch; sp1++; spe++;
|
||||
case '+':
|
||||
GETC(ch);
|
||||
}
|
||||
while(ch == '0') {
|
||||
++havenum;
|
||||
GETC(ch);
|
||||
}
|
||||
while(isdigit(ch)) {
|
||||
if (sp < spe) *sp++ = ch;
|
||||
else ++exp;
|
||||
GETC(ch);
|
||||
}
|
||||
if (ch == '*' && !poststar) {
|
||||
if (sp == sp1 || exp || *s == '-') {
|
||||
errfl(f__elist->cierr,112,"bad repetition count");
|
||||
}
|
||||
poststar = havestar = 1;
|
||||
*sp = 0;
|
||||
f__lcount = atoi(s);
|
||||
goto retry;
|
||||
}
|
||||
if (ch == '.') {
|
||||
GETC(ch);
|
||||
if (sp == sp1)
|
||||
while(ch == '0') {
|
||||
++havenum;
|
||||
--exp;
|
||||
GETC(ch);
|
||||
}
|
||||
while(isdigit(ch)) {
|
||||
if (sp < spe)
|
||||
{ *sp++ = ch; --exp; }
|
||||
GETC(ch);
|
||||
}
|
||||
}
|
||||
havenum += sp - sp1;
|
||||
se = 0;
|
||||
if (issign(ch))
|
||||
goto signonly;
|
||||
if (havenum && isexp(ch)) {
|
||||
GETC(ch);
|
||||
if (issign(ch)) {
|
||||
signonly:
|
||||
if (ch == '-') se = 1;
|
||||
GETC(ch);
|
||||
}
|
||||
if (!isdigit(ch)) {
|
||||
bad:
|
||||
errfl(f__elist->cierr,112,"exponent field");
|
||||
}
|
||||
|
||||
e = ch - '0';
|
||||
while(isdigit(GETC(ch))) {
|
||||
e = 10*e + ch - '0';
|
||||
if (e > EXPMAX)
|
||||
goto bad;
|
||||
}
|
||||
if (se)
|
||||
exp -= e;
|
||||
else
|
||||
exp += e;
|
||||
}
|
||||
(void) Ungetc(ch, f__cf);
|
||||
if (sp > sp1) {
|
||||
++havenum;
|
||||
while(*--sp == '0')
|
||||
++exp;
|
||||
if (exp)
|
||||
sprintf(sp+1, "e%ld", exp);
|
||||
else
|
||||
sp[1] = 0;
|
||||
f__lx = atof(s);
|
||||
}
|
||||
else
|
||||
f__lx = 0.;
|
||||
if (havenum)
|
||||
f__ltype = TYLONG;
|
||||
else
|
||||
switch(ch) {
|
||||
case ',':
|
||||
case '/':
|
||||
break;
|
||||
default:
|
||||
if (havestar && ( ch == ' '
|
||||
||ch == '\t'
|
||||
||ch == '\n'))
|
||||
break;
|
||||
if (nml_read > 1) {
|
||||
f__lquit = 2;
|
||||
return 0;
|
||||
}
|
||||
errfl(f__elist->cierr,112,"invalid number");
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
rd_count(ch) register int ch;
|
||||
#else
|
||||
rd_count(register int ch)
|
||||
#endif
|
||||
{
|
||||
if (ch < '0' || ch > '9')
|
||||
return 1;
|
||||
f__lcount = ch - '0';
|
||||
while(GETC(ch) >= '0' && ch <= '9')
|
||||
f__lcount = 10*f__lcount + ch - '0';
|
||||
Ungetc(ch,f__cf);
|
||||
return f__lcount <= 0;
|
||||
}
|
||||
|
||||
l_C(Void)
|
||||
{ int ch, nml_save;
|
||||
double lz;
|
||||
if(f__lcount>0) return(0);
|
||||
f__ltype=0;
|
||||
GETC(ch);
|
||||
if(ch!='(')
|
||||
{
|
||||
if (nml_read > 1 && (ch < '0' || ch > '9')) {
|
||||
Ungetc(ch,f__cf);
|
||||
f__lquit = 2;
|
||||
return 0;
|
||||
}
|
||||
if (rd_count(ch))
|
||||
if(!f__cf || !feof(f__cf))
|
||||
errfl(f__elist->cierr,112,"complex format");
|
||||
else
|
||||
err(f__elist->cierr,(EOF),"lread");
|
||||
if(GETC(ch)!='*')
|
||||
{
|
||||
if(!f__cf || !feof(f__cf))
|
||||
errfl(f__elist->cierr,112,"no star");
|
||||
else
|
||||
err(f__elist->cierr,(EOF),"lread");
|
||||
}
|
||||
if(GETC(ch)!='(')
|
||||
{ Ungetc(ch,f__cf);
|
||||
return(0);
|
||||
}
|
||||
}
|
||||
else
|
||||
f__lcount = 1;
|
||||
while(iswhit(GETC(ch)));
|
||||
Ungetc(ch,f__cf);
|
||||
nml_save = nml_read;
|
||||
nml_read = 0;
|
||||
if (ch = l_R(1))
|
||||
return ch;
|
||||
if (!f__ltype)
|
||||
errfl(f__elist->cierr,112,"no real part");
|
||||
lz = f__lx;
|
||||
while(iswhit(GETC(ch)));
|
||||
if(ch!=',')
|
||||
{ (void) Ungetc(ch,f__cf);
|
||||
errfl(f__elist->cierr,112,"no comma");
|
||||
}
|
||||
while(iswhit(GETC(ch)));
|
||||
(void) Ungetc(ch,f__cf);
|
||||
if (ch = l_R(1))
|
||||
return ch;
|
||||
if (!f__ltype)
|
||||
errfl(f__elist->cierr,112,"no imaginary part");
|
||||
while(iswhit(GETC(ch)));
|
||||
if(ch!=')') errfl(f__elist->cierr,112,"no )");
|
||||
f__ly = f__lx;
|
||||
f__lx = lz;
|
||||
nml_read = nml_save;
|
||||
return(0);
|
||||
}
|
||||
l_L(Void)
|
||||
{
|
||||
int ch;
|
||||
if(f__lcount>0) return(0);
|
||||
f__lcount = 1;
|
||||
f__ltype=0;
|
||||
GETC(ch);
|
||||
if(isdigit(ch))
|
||||
{
|
||||
rd_count(ch);
|
||||
if(GETC(ch)!='*')
|
||||
if(!f__cf || !feof(f__cf))
|
||||
errfl(f__elist->cierr,112,"no star");
|
||||
else
|
||||
err(f__elist->cierr,(EOF),"lread");
|
||||
GETC(ch);
|
||||
}
|
||||
if(ch == '.') GETC(ch);
|
||||
switch(ch)
|
||||
{
|
||||
case 't':
|
||||
case 'T':
|
||||
f__lx=1;
|
||||
break;
|
||||
case 'f':
|
||||
case 'F':
|
||||
f__lx=0;
|
||||
break;
|
||||
default:
|
||||
if(isblnk(ch) || issep(ch) || ch==EOF)
|
||||
{ (void) Ungetc(ch,f__cf);
|
||||
return(0);
|
||||
}
|
||||
if (nml_read > 1) {
|
||||
Ungetc(ch,f__cf);
|
||||
f__lquit = 2;
|
||||
return 0;
|
||||
}
|
||||
errfl(f__elist->cierr,112,"logical");
|
||||
}
|
||||
f__ltype=TYLONG;
|
||||
while(!issep(GETC(ch)) && ch!=EOF);
|
||||
(void) Ungetc(ch, f__cf);
|
||||
return(0);
|
||||
}
|
||||
#define BUFSIZE 128
|
||||
l_CHAR(Void)
|
||||
{ int ch,size,i;
|
||||
static char rafail[] = "realloc failure";
|
||||
char quote,*p;
|
||||
if(f__lcount>0) return(0);
|
||||
f__ltype=0;
|
||||
if(f__lchar!=NULL) free(f__lchar);
|
||||
size=BUFSIZE;
|
||||
p=f__lchar = (char *)malloc((unsigned int)size);
|
||||
if(f__lchar == NULL)
|
||||
errfl(f__elist->cierr,113,"no space");
|
||||
|
||||
GETC(ch);
|
||||
if(isdigit(ch)) {
|
||||
/* allow Fortran 8x-style unquoted string... */
|
||||
/* either find a repetition count or the string */
|
||||
f__lcount = ch - '0';
|
||||
*p++ = ch;
|
||||
for(i = 1;;) {
|
||||
switch(GETC(ch)) {
|
||||
case '*':
|
||||
if (f__lcount == 0) {
|
||||
f__lcount = 1;
|
||||
goto noquote;
|
||||
}
|
||||
p = f__lchar;
|
||||
goto have_lcount;
|
||||
case ',':
|
||||
case ' ':
|
||||
case '\t':
|
||||
case '\n':
|
||||
case '/':
|
||||
Ungetc(ch,f__cf);
|
||||
/* no break */
|
||||
case EOF:
|
||||
f__lcount = 1;
|
||||
f__ltype = TYCHAR;
|
||||
return *p = 0;
|
||||
}
|
||||
if (!isdigit(ch)) {
|
||||
f__lcount = 1;
|
||||
goto noquote;
|
||||
}
|
||||
*p++ = ch;
|
||||
f__lcount = 10*f__lcount + ch - '0';
|
||||
if (++i == size) {
|
||||
f__lchar = (char *)realloc(f__lchar,
|
||||
(unsigned int)(size += BUFSIZE));
|
||||
if(f__lchar == NULL)
|
||||
errfl(f__elist->cierr,113,rafail);
|
||||
p = f__lchar + i;
|
||||
}
|
||||
}
|
||||
}
|
||||
else (void) Ungetc(ch,f__cf);
|
||||
have_lcount:
|
||||
if(GETC(ch)=='\'' || ch=='"') quote=ch;
|
||||
else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
|
||||
{ (void) Ungetc(ch,f__cf);
|
||||
return(0);
|
||||
}
|
||||
else {
|
||||
/* Fortran 8x-style unquoted string */
|
||||
*p++ = ch;
|
||||
for(i = 1;;) {
|
||||
switch(GETC(ch)) {
|
||||
case ',':
|
||||
case ' ':
|
||||
case '\t':
|
||||
case '\n':
|
||||
case '/':
|
||||
Ungetc(ch,f__cf);
|
||||
/* no break */
|
||||
case EOF:
|
||||
f__ltype = TYCHAR;
|
||||
return *p = 0;
|
||||
}
|
||||
noquote:
|
||||
*p++ = ch;
|
||||
if (++i == size) {
|
||||
f__lchar = (char *)realloc(f__lchar,
|
||||
(unsigned int)(size += BUFSIZE));
|
||||
if(f__lchar == NULL)
|
||||
errfl(f__elist->cierr,113,rafail);
|
||||
p = f__lchar + i;
|
||||
}
|
||||
}
|
||||
}
|
||||
f__ltype=TYCHAR;
|
||||
for(i=0;;)
|
||||
{ while(GETC(ch)!=quote && ch!='\n'
|
||||
&& ch!=EOF && ++i<size) *p++ = ch;
|
||||
if(i==size)
|
||||
{
|
||||
newone:
|
||||
f__lchar= (char *)realloc(f__lchar,
|
||||
(unsigned int)(size += BUFSIZE));
|
||||
if(f__lchar == NULL)
|
||||
errfl(f__elist->cierr,113,rafail);
|
||||
p=f__lchar+i-1;
|
||||
*p++ = ch;
|
||||
}
|
||||
else if(ch==EOF) return(EOF);
|
||||
else if(ch=='\n')
|
||||
{ if(*(p-1) != '\\') continue;
|
||||
i--;
|
||||
p--;
|
||||
if(++i<size) *p++ = ch;
|
||||
else goto newone;
|
||||
}
|
||||
else if(GETC(ch)==quote)
|
||||
{ if(++i<size) *p++ = ch;
|
||||
else goto newone;
|
||||
}
|
||||
else
|
||||
{ (void) Ungetc(ch,f__cf);
|
||||
*p = 0;
|
||||
return(0);
|
||||
}
|
||||
}
|
||||
}
|
||||
#ifdef KR_headers
|
||||
c_le(a) cilist *a;
|
||||
#else
|
||||
c_le(cilist *a)
|
||||
#endif
|
||||
{
|
||||
f__fmtbuf="list io";
|
||||
if(a->ciunit>=MXUNIT || a->ciunit<0)
|
||||
err(a->cierr,101,"stler");
|
||||
f__scale=f__recpos=0;
|
||||
f__elist=a;
|
||||
f__curunit = &f__units[a->ciunit];
|
||||
if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
|
||||
err(a->cierr,102,"lio");
|
||||
f__cf=f__curunit->ufd;
|
||||
if(!f__curunit->ufmt) err(a->cierr,103,"lio")
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
|
||||
#else
|
||||
l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
|
||||
#endif
|
||||
{
|
||||
#define Ptr ((flex *)ptr)
|
||||
int i,n,ch;
|
||||
doublereal *yy;
|
||||
real *xx;
|
||||
for(i=0;i<*number;i++)
|
||||
{
|
||||
if(f__lquit) return(0);
|
||||
if(l_eof)
|
||||
err(f__elist->ciend, EOF, "list in")
|
||||
if(f__lcount == 0) {
|
||||
f__ltype = 0;
|
||||
for(;;) {
|
||||
GETC(ch);
|
||||
switch(ch) {
|
||||
case EOF:
|
||||
goto loopend;
|
||||
case ' ':
|
||||
case '\t':
|
||||
case '\n':
|
||||
continue;
|
||||
case '/':
|
||||
f__lquit = 1;
|
||||
goto loopend;
|
||||
case ',':
|
||||
f__lcount = 1;
|
||||
goto loopend;
|
||||
default:
|
||||
(void) Ungetc(ch, f__cf);
|
||||
goto rddata;
|
||||
}
|
||||
}
|
||||
}
|
||||
rddata:
|
||||
switch((int)type)
|
||||
{
|
||||
case TYINT1:
|
||||
case TYSHORT:
|
||||
case TYLONG:
|
||||
#ifdef TYQUAD
|
||||
case TYQUAD:
|
||||
#endif
|
||||
case TYREAL:
|
||||
case TYDREAL:
|
||||
ERR(l_R(0));
|
||||
break;
|
||||
case TYCOMPLEX:
|
||||
case TYDCOMPLEX:
|
||||
ERR(l_C());
|
||||
break;
|
||||
case TYLOGICAL1:
|
||||
case TYLOGICAL2:
|
||||
case TYLOGICAL:
|
||||
ERR(l_L());
|
||||
break;
|
||||
case TYCHAR:
|
||||
ERR(l_CHAR());
|
||||
break;
|
||||
}
|
||||
while (GETC(ch) == ' ' || ch == '\t');
|
||||
if (ch != ',' || f__lcount > 1)
|
||||
Ungetc(ch,f__cf);
|
||||
loopend:
|
||||
if(f__lquit) return(0);
|
||||
if(f__cf) {
|
||||
if (feof(f__cf))
|
||||
err(f__elist->ciend,(EOF),"list in")
|
||||
else if(ferror(f__cf)) {
|
||||
clearerr(f__cf);
|
||||
errfl(f__elist->cierr,errno,"list in");
|
||||
}
|
||||
}
|
||||
if(f__ltype==0) goto bump;
|
||||
switch((int)type)
|
||||
{
|
||||
case TYINT1:
|
||||
case TYLOGICAL1:
|
||||
Ptr->flchar = (char)f__lx;
|
||||
break;
|
||||
case TYLOGICAL2:
|
||||
case TYSHORT:
|
||||
Ptr->flshort = (short)f__lx;
|
||||
break;
|
||||
case TYLOGICAL:
|
||||
case TYLONG:
|
||||
Ptr->flint=f__lx;
|
||||
break;
|
||||
#ifdef TYQUAD
|
||||
case TYQUAD:
|
||||
Ptr->fllongint = f__lx;
|
||||
break;
|
||||
#endif
|
||||
case TYREAL:
|
||||
Ptr->flreal=f__lx;
|
||||
break;
|
||||
case TYDREAL:
|
||||
Ptr->fldouble=f__lx;
|
||||
break;
|
||||
case TYCOMPLEX:
|
||||
xx=(real *)ptr;
|
||||
*xx++ = f__lx;
|
||||
*xx = f__ly;
|
||||
break;
|
||||
case TYDCOMPLEX:
|
||||
yy=(doublereal *)ptr;
|
||||
*yy++ = f__lx;
|
||||
*yy = f__ly;
|
||||
break;
|
||||
case TYCHAR:
|
||||
b_char(f__lchar,ptr,len);
|
||||
break;
|
||||
}
|
||||
bump:
|
||||
if(f__lcount>0) f__lcount--;
|
||||
ptr += len;
|
||||
if (nml_read)
|
||||
nml_read++;
|
||||
}
|
||||
return(0);
|
||||
#undef Ptr
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer s_rsle(a) cilist *a;
|
||||
#else
|
||||
integer s_rsle(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int n;
|
||||
|
||||
if(!f__init) f_init();
|
||||
if(n=c_le(a)) return(n);
|
||||
f__reading=1;
|
||||
f__external=1;
|
||||
f__formatted=1;
|
||||
f__lioproc = l_read;
|
||||
f__lquit = 0;
|
||||
f__lcount = 0;
|
||||
l_eof = 0;
|
||||
if(f__curunit->uwrt && f__nowreading(f__curunit))
|
||||
err(a->cierr,errno,"read start");
|
||||
l_getc = t_getc;
|
||||
l_ungetc = un_getc;
|
||||
f__doend = xrd_SL;
|
||||
return(0);
|
||||
}
|
276
lib/libI77/lwrite.c
Normal file
276
lib/libI77/lwrite.c
Normal file
@ -0,0 +1,276 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
#include "lio.h"
|
||||
ftnint L_len;
|
||||
|
||||
static VOID
|
||||
donewrec(Void)
|
||||
{
|
||||
if (f__recpos)
|
||||
(*f__donewrec)();
|
||||
}
|
||||
|
||||
#ifdef KR_headers
|
||||
t_putc(c)
|
||||
#else
|
||||
t_putc(int c)
|
||||
#endif
|
||||
{
|
||||
f__recpos++;
|
||||
putc(c,f__cf);
|
||||
return(0);
|
||||
}
|
||||
static VOID
|
||||
#ifdef KR_headers
|
||||
lwrt_I(n) long n;
|
||||
#else
|
||||
lwrt_I(long n)
|
||||
#endif
|
||||
{
|
||||
char buf[LINTW],*p;
|
||||
#ifdef USE_STRLEN
|
||||
(void) sprintf(buf," %ld",n);
|
||||
if(f__recpos+strlen(buf)>=L_len)
|
||||
#else
|
||||
if(f__recpos + sprintf(buf," %ld",n) >= L_len)
|
||||
#endif
|
||||
donewrec();
|
||||
for(p=buf;*p;PUT(*p++));
|
||||
}
|
||||
static VOID
|
||||
#ifdef KR_headers
|
||||
lwrt_L(n, len) ftnint n; ftnlen len;
|
||||
#else
|
||||
lwrt_L(ftnint n, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
if(f__recpos+LLOGW>=L_len)
|
||||
donewrec();
|
||||
wrt_L((Uint *)&n,LLOGW, len);
|
||||
}
|
||||
static VOID
|
||||
#ifdef KR_headers
|
||||
lwrt_A(p,len) char *p; ftnlen len;
|
||||
#else
|
||||
lwrt_A(char *p, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
int i;
|
||||
if(f__recpos+len>=L_len)
|
||||
donewrec();
|
||||
#ifndef OMIT_BLANK_CC
|
||||
if (!f__recpos)
|
||||
PUT(' ');
|
||||
#endif
|
||||
for(i=0;i<len;i++) PUT(*p++);
|
||||
}
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
l_g(buf, n) char *buf; double n;
|
||||
#else
|
||||
l_g(char *buf, double n)
|
||||
#endif
|
||||
{
|
||||
#ifdef Old_list_output
|
||||
doublereal absn;
|
||||
char *fmt;
|
||||
|
||||
absn = n;
|
||||
if (absn < 0)
|
||||
absn = -absn;
|
||||
fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
|
||||
#ifdef USE_STRLEN
|
||||
sprintf(buf, fmt, n);
|
||||
return strlen(buf);
|
||||
#else
|
||||
return sprintf(buf, fmt, n);
|
||||
#endif
|
||||
|
||||
#else
|
||||
register char *b, c, c1;
|
||||
|
||||
b = buf;
|
||||
*b++ = ' ';
|
||||
if (n < 0) {
|
||||
*b++ = '-';
|
||||
n = -n;
|
||||
}
|
||||
else
|
||||
*b++ = ' ';
|
||||
if (n == 0) {
|
||||
*b++ = '0';
|
||||
*b++ = '.';
|
||||
*b = 0;
|
||||
goto f__ret;
|
||||
}
|
||||
sprintf(b, LGFMT, n);
|
||||
switch(*b) {
|
||||
case '0':
|
||||
while(b[0] = b[1])
|
||||
b++;
|
||||
break;
|
||||
case 'i':
|
||||
case 'I':
|
||||
/* Infinity */
|
||||
case 'n':
|
||||
case 'N':
|
||||
/* NaN */
|
||||
while(*++b);
|
||||
break;
|
||||
|
||||
default:
|
||||
/* Fortran 77 insists on having a decimal point... */
|
||||
for(;; b++)
|
||||
switch(*b) {
|
||||
case 0:
|
||||
*b++ = '.';
|
||||
*b = 0;
|
||||
goto f__ret;
|
||||
case '.':
|
||||
while(*++b);
|
||||
goto f__ret;
|
||||
case 'E':
|
||||
for(c1 = '.', c = 'E'; *b = c1;
|
||||
c1 = c, c = *++b);
|
||||
goto f__ret;
|
||||
}
|
||||
}
|
||||
f__ret:
|
||||
return b - buf;
|
||||
#endif
|
||||
}
|
||||
|
||||
static VOID
|
||||
#ifdef KR_headers
|
||||
l_put(s) register char *s;
|
||||
#else
|
||||
l_put(register char *s)
|
||||
#endif
|
||||
{
|
||||
#ifdef KR_headers
|
||||
register int c, (*pn)() = f__putn;
|
||||
#else
|
||||
register int c, (*pn)(int) = f__putn;
|
||||
#endif
|
||||
while(c = *s++)
|
||||
(*pn)(c);
|
||||
}
|
||||
|
||||
static VOID
|
||||
#ifdef KR_headers
|
||||
lwrt_F(n) double n;
|
||||
#else
|
||||
lwrt_F(double n)
|
||||
#endif
|
||||
{
|
||||
char buf[LEFBL];
|
||||
|
||||
if(f__recpos + l_g(buf,n) >= L_len)
|
||||
donewrec();
|
||||
l_put(buf);
|
||||
}
|
||||
static VOID
|
||||
#ifdef KR_headers
|
||||
lwrt_C(a,b) double a,b;
|
||||
#else
|
||||
lwrt_C(double a, double b)
|
||||
#endif
|
||||
{
|
||||
char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
|
||||
int al, bl;
|
||||
|
||||
al = l_g(bufa, a);
|
||||
for(ba = bufa; *ba == ' '; ba++)
|
||||
--al;
|
||||
bl = l_g(bufb, b) + 1; /* intentionally high by 1 */
|
||||
for(bb = bufb; *bb == ' '; bb++)
|
||||
--bl;
|
||||
if(f__recpos + al + bl + 3 >= L_len)
|
||||
donewrec();
|
||||
#ifdef OMIT_BLANK_CC
|
||||
else
|
||||
#endif
|
||||
PUT(' ');
|
||||
PUT('(');
|
||||
l_put(ba);
|
||||
PUT(',');
|
||||
if (f__recpos + bl >= L_len) {
|
||||
(*f__donewrec)();
|
||||
#ifndef OMIT_BLANK_CC
|
||||
PUT(' ');
|
||||
#endif
|
||||
}
|
||||
l_put(bb);
|
||||
PUT(')');
|
||||
}
|
||||
#ifdef KR_headers
|
||||
l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
|
||||
#else
|
||||
l_write(ftnint *number, char *ptr, ftnlen len, ftnint type)
|
||||
#endif
|
||||
{
|
||||
#define Ptr ((flex *)ptr)
|
||||
int i;
|
||||
long x;
|
||||
double y,z;
|
||||
real *xx;
|
||||
doublereal *yy;
|
||||
for(i=0;i< *number; i++)
|
||||
{
|
||||
switch((int)type)
|
||||
{
|
||||
default: f__fatal(204,"unknown type in lio");
|
||||
case TYINT1:
|
||||
x = Ptr->flchar;
|
||||
goto xint;
|
||||
case TYSHORT:
|
||||
x=Ptr->flshort;
|
||||
goto xint;
|
||||
#ifdef TYQUAD
|
||||
case TYQUAD:
|
||||
x = Ptr->fllongint;
|
||||
goto xint;
|
||||
#endif
|
||||
case TYLONG:
|
||||
x=Ptr->flint;
|
||||
xint: lwrt_I(x);
|
||||
break;
|
||||
case TYREAL:
|
||||
y=Ptr->flreal;
|
||||
goto xfloat;
|
||||
case TYDREAL:
|
||||
y=Ptr->fldouble;
|
||||
xfloat: lwrt_F(y);
|
||||
break;
|
||||
case TYCOMPLEX:
|
||||
xx= &Ptr->flreal;
|
||||
y = *xx++;
|
||||
z = *xx;
|
||||
goto xcomplex;
|
||||
case TYDCOMPLEX:
|
||||
yy = &Ptr->fldouble;
|
||||
y= *yy++;
|
||||
z = *yy;
|
||||
xcomplex:
|
||||
lwrt_C(y,z);
|
||||
break;
|
||||
case TYLOGICAL1:
|
||||
x = Ptr->flchar;
|
||||
goto xlog;
|
||||
case TYLOGICAL2:
|
||||
x = Ptr->flshort;
|
||||
goto xlog;
|
||||
case TYLOGICAL:
|
||||
x = Ptr->flint;
|
||||
xlog: lwrt_L(Ptr->flint, len);
|
||||
break;
|
||||
case TYCHAR:
|
||||
lwrt_A(ptr,len);
|
||||
break;
|
||||
}
|
||||
ptr += len;
|
||||
}
|
||||
return(0);
|
||||
}
|
96
lib/libI77/makefile
Normal file
96
lib/libI77/makefile
Normal file
@ -0,0 +1,96 @@
|
||||
.SUFFIXES: .c .o
|
||||
CC = cc
|
||||
CFLAGS = -O
|
||||
SHELL = /bin/sh
|
||||
|
||||
# compile, then strip unnecessary symbols
|
||||
.c.o:
|
||||
$(CC) -c -DSkip_f2c_Undefs $(CFLAGS) $*.c
|
||||
ld -r -x -o $*.xxx $*.o
|
||||
mv $*.xxx $*.o
|
||||
|
||||
OBJ = Version.o backspace.o close.o dfe.o dolio.o due.o endfile.o err.o \
|
||||
fmt.o fmtlib.o iio.o ilnw.o inquire.o lread.o lwrite.o open.o \
|
||||
rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o typesize.o uio.o \
|
||||
util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o
|
||||
libI77.a: $(OBJ)
|
||||
ar r libI77.a $?
|
||||
ranlib libI77.a
|
||||
install: libI77.a
|
||||
cp libI77.a /usr/lib/libI77.a
|
||||
ranlib /usr/lib/libI77.a
|
||||
|
||||
Version.o: Version.c
|
||||
$(CC) -c Version.c
|
||||
|
||||
# To compile with C++, first "make f2c.h"
|
||||
f2c.h: f2ch.add
|
||||
cat /usr/include/f2c.h f2ch.add >f2c.h
|
||||
|
||||
|
||||
clean:
|
||||
rm -f $(OBJ) libI77.a
|
||||
|
||||
clobber: clean
|
||||
rm -f libI77.a
|
||||
|
||||
backspace.o: fio.h
|
||||
close.o: fio.h
|
||||
dfe.o: fio.h
|
||||
dfe.o: fmt.h
|
||||
due.o: fio.h
|
||||
endfile.o: fio.h rawio.h
|
||||
err.o: fio.h rawio.h
|
||||
fmt.o: fio.h
|
||||
fmt.o: fmt.h
|
||||
iio.o: fio.h
|
||||
iio.o: fmt.h
|
||||
ilnw.o: fio.h
|
||||
ilnw.o: lio.h
|
||||
inquire.o: fio.h
|
||||
lread.o: fio.h
|
||||
lread.o: fmt.h
|
||||
lread.o: lio.h
|
||||
lread.o: fp.h
|
||||
lwrite.o: fio.h
|
||||
lwrite.o: fmt.h
|
||||
lwrite.o: lio.h
|
||||
open.o: fio.h rawio.h
|
||||
rdfmt.o: fio.h
|
||||
rdfmt.o: fmt.h
|
||||
rdfmt.o: fp.h
|
||||
rewind.o: fio.h
|
||||
rsfe.o: fio.h
|
||||
rsfe.o: fmt.h
|
||||
rsli.o: fio.h
|
||||
rsli.o: lio.h
|
||||
rsne.o: fio.h
|
||||
rsne.o: lio.h
|
||||
sfe.o: fio.h
|
||||
sue.o: fio.h
|
||||
uio.o: fio.h
|
||||
util.o: fio.h
|
||||
wref.o: fio.h
|
||||
wref.o: fmt.h
|
||||
wref.o: fp.h
|
||||
wrtfmt.o: fio.h
|
||||
wrtfmt.o: fmt.h
|
||||
wsfe.o: fio.h
|
||||
wsfe.o: fmt.h
|
||||
wsle.o: fio.h
|
||||
wsle.o: fmt.h
|
||||
wsle.o: lio.h
|
||||
wsne.o: fio.h
|
||||
wsne.o: lio.h
|
||||
xwsne.o: fio.h
|
||||
xwsne.o: lio.h
|
||||
xwsne.o: fmt.h
|
||||
|
||||
check:
|
||||
xsum Notice README Version.c backspace.c close.c dfe.c dolio.c \
|
||||
due.c endfile.c err.c f2ch.add fio.h fmt.c fmt.h fmtlib.c fp.h \
|
||||
iio.c ilnw.c inquire.c lio.h lread.c lwrite.c makefile open.c \
|
||||
rawio.h rdfmt.c rewind.c rsfe.c rsli.c rsne.c sfe.c sue.c \
|
||||
typesize.c uio.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c \
|
||||
xwsne.c >zap
|
||||
cmp zap libI77.xsum && rm zap || diff libI77.xsum zap
|
237
lib/libI77/open.c
Normal file
237
lib/libI77/open.c
Normal file
@ -0,0 +1,237 @@
|
||||
#ifndef NON_UNIX_STDIO
|
||||
#include "sys/types.h"
|
||||
#include "sys/stat.h"
|
||||
#endif
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "string.h"
|
||||
#include "rawio.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
extern char *malloc(), *mktemp();
|
||||
extern integer f_clos();
|
||||
#else
|
||||
#undef abs
|
||||
#undef min
|
||||
#undef max
|
||||
#include "stdlib.h"
|
||||
extern int f__canseek(FILE*);
|
||||
extern integer f_clos(cllist*);
|
||||
#endif
|
||||
|
||||
#ifdef NON_ANSI_RW_MODES
|
||||
char *f__r_mode[2] = {"r", "r"};
|
||||
char *f__w_mode[4] = {"w", "w", "r+w", "r+w"};
|
||||
#else
|
||||
char *f__r_mode[2] = {"rb", "r"};
|
||||
char *f__w_mode[4] = {"wb", "w", "r+b", "r+"};
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
f__isdev(s) char *s;
|
||||
#else
|
||||
f__isdev(char *s)
|
||||
#endif
|
||||
{
|
||||
#ifdef NON_UNIX_STDIO
|
||||
int i, j;
|
||||
|
||||
i = open(s,O_RDONLY);
|
||||
if (i == -1)
|
||||
return 0;
|
||||
j = isatty(i);
|
||||
close(i);
|
||||
return j;
|
||||
#else
|
||||
struct stat x;
|
||||
|
||||
if(stat(s, &x) == -1) return(0);
|
||||
#ifdef S_IFMT
|
||||
switch(x.st_mode&S_IFMT) {
|
||||
case S_IFREG:
|
||||
case S_IFDIR:
|
||||
return(0);
|
||||
}
|
||||
#else
|
||||
#ifdef S_ISREG
|
||||
/* POSIX version */
|
||||
if(S_ISREG(x.st_mode) || S_ISDIR(x.st_mode))
|
||||
return(0);
|
||||
else
|
||||
#else
|
||||
Help! How does stat work on this system?
|
||||
#endif
|
||||
#endif
|
||||
return(1);
|
||||
#endif
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer f_open(a) olist *a;
|
||||
#else
|
||||
integer f_open(olist *a)
|
||||
#endif
|
||||
{ unit *b;
|
||||
integer rv;
|
||||
char buf[256], *s;
|
||||
cllist x;
|
||||
int ufmt;
|
||||
#ifdef NON_UNIX_STDIO
|
||||
FILE *tf;
|
||||
#else
|
||||
int n;
|
||||
struct stat stb;
|
||||
#endif
|
||||
if(a->ounit>=MXUNIT || a->ounit<0)
|
||||
err(a->oerr,101,"open")
|
||||
f__curunit = b = &f__units[a->ounit];
|
||||
if(b->ufd) {
|
||||
if(a->ofnm==0)
|
||||
{
|
||||
same: if (a->oblnk)
|
||||
b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z';
|
||||
return(0);
|
||||
}
|
||||
#ifdef NON_UNIX_STDIO
|
||||
if (b->ufnm
|
||||
&& strlen(b->ufnm) == a->ofnmlen
|
||||
&& !strncmp(b->ufnm, b->ufnm, (unsigned)a->ofnmlen))
|
||||
goto same;
|
||||
#else
|
||||
g_char(a->ofnm,a->ofnmlen,buf);
|
||||
if (f__inode(buf,&n) == b->uinode && n == b->udev)
|
||||
goto same;
|
||||
#endif
|
||||
x.cunit=a->ounit;
|
||||
x.csta=0;
|
||||
x.cerr=a->oerr;
|
||||
if ((rv = f_clos(&x)) != 0)
|
||||
return rv;
|
||||
}
|
||||
b->url = (int)a->orl;
|
||||
b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z');
|
||||
if(a->ofm==0)
|
||||
{ if(b->url>0) b->ufmt=0;
|
||||
else b->ufmt=1;
|
||||
}
|
||||
else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1;
|
||||
else b->ufmt=0;
|
||||
ufmt = b->ufmt;
|
||||
#ifdef url_Adjust
|
||||
if (b->url && !ufmt)
|
||||
url_Adjust(b->url);
|
||||
#endif
|
||||
if (a->ofnm) {
|
||||
g_char(a->ofnm,a->ofnmlen,buf);
|
||||
if (!buf[0])
|
||||
err(a->oerr,107,"open")
|
||||
}
|
||||
else
|
||||
sprintf(buf, "fort.%ld", a->ounit);
|
||||
b->uscrtch = 0;
|
||||
switch(a->osta ? *a->osta : 'u')
|
||||
{
|
||||
case 'o':
|
||||
case 'O':
|
||||
#ifdef NON_UNIX_STDIO
|
||||
if(access(buf,0))
|
||||
#else
|
||||
if(stat(buf,&stb))
|
||||
#endif
|
||||
err(a->oerr,errno,"open")
|
||||
break;
|
||||
case 's':
|
||||
case 'S':
|
||||
b->uscrtch=1;
|
||||
#ifdef _POSIX_SOURCE
|
||||
tmpnam(buf);
|
||||
#else
|
||||
(void) strcpy(buf,"tmp.FXXXXXX");
|
||||
(void) mktemp(buf);
|
||||
#endif
|
||||
goto replace;
|
||||
case 'n':
|
||||
case 'N':
|
||||
#ifdef NON_UNIX_STDIO
|
||||
if(!access(buf,0))
|
||||
#else
|
||||
if(!stat(buf,&stb))
|
||||
#endif
|
||||
err(a->oerr,128,"open")
|
||||
/* no break */
|
||||
case 'r': /* Fortran 90 replace option */
|
||||
case 'R':
|
||||
replace:
|
||||
#ifdef NON_UNIX_STDIO
|
||||
if (tf = fopen(buf,f__w_mode[0]))
|
||||
fclose(tf);
|
||||
#else
|
||||
(void) close(creat(buf, 0666));
|
||||
#endif
|
||||
}
|
||||
|
||||
b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1));
|
||||
if(b->ufnm==NULL) err(a->oerr,113,"no space");
|
||||
(void) strcpy(b->ufnm,buf);
|
||||
b->uend=0;
|
||||
b->uwrt = 0;
|
||||
#ifdef NON_UNIX_STDIO
|
||||
if ((s = a->oacc) && (*s == 'd' || *s == 'D'))
|
||||
ufmt = 0;
|
||||
#endif
|
||||
if(f__isdev(buf))
|
||||
{ b->ufd = fopen(buf,f__r_mode[ufmt]);
|
||||
if(b->ufd==NULL) err(a->oerr,errno,buf)
|
||||
}
|
||||
else {
|
||||
if(!(b->ufd = fopen(buf, f__r_mode[ufmt]))) {
|
||||
#ifdef NON_UNIX_STDIO
|
||||
if (b->ufd = fopen(buf, f__w_mode[ufmt|2]))
|
||||
b->uwrt = 2;
|
||||
else if (b->ufd = fopen(buf, f__w_mode[ufmt]))
|
||||
b->uwrt = 1;
|
||||
else
|
||||
#else
|
||||
if ((n = open(buf,O_WRONLY)) >= 0)
|
||||
b->uwrt = 2;
|
||||
else {
|
||||
n = creat(buf, 0666);
|
||||
b->uwrt = 1;
|
||||
}
|
||||
if (n < 0
|
||||
|| (b->ufd = fdopen(n, f__w_mode[ufmt])) == NULL)
|
||||
#endif
|
||||
err(a->oerr, errno, "open");
|
||||
}
|
||||
}
|
||||
b->useek=f__canseek(b->ufd);
|
||||
#ifndef NON_UNIX_STDIO
|
||||
if((b->uinode=f__inode(buf,&b->udev))==-1)
|
||||
err(a->oerr,108,"open")
|
||||
#endif
|
||||
if(b->useek)
|
||||
if (a->orl)
|
||||
rewind(b->ufd);
|
||||
else if ((s = a->oacc) && (*s == 'a' || *s == 'A')
|
||||
&& fseek(b->ufd, 0L, SEEK_END))
|
||||
err(a->oerr,129,"open");
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
fk_open(seq,fmt,n) ftnint n;
|
||||
#else
|
||||
fk_open(int seq, int fmt, ftnint n)
|
||||
#endif
|
||||
{ char nbuf[10];
|
||||
olist a;
|
||||
(void) sprintf(nbuf,"fort.%ld",n);
|
||||
a.oerr=1;
|
||||
a.ounit=n;
|
||||
a.ofnm=nbuf;
|
||||
a.ofnmlen=strlen(nbuf);
|
||||
a.osta=NULL;
|
||||
a.oacc= seq==SEQ?"s":"d";
|
||||
a.ofm = fmt==FMT?"f":"u";
|
||||
a.orl = seq==DIR?1:0;
|
||||
a.oblnk=NULL;
|
||||
return(f_open(&a));
|
||||
}
|
41
lib/libI77/rawio.h
Normal file
41
lib/libI77/rawio.h
Normal file
@ -0,0 +1,41 @@
|
||||
#ifdef KR_headers
|
||||
extern FILE *fdopen();
|
||||
#else
|
||||
#ifdef MSDOS
|
||||
#include "io.h"
|
||||
#define close _close
|
||||
#define creat _creat
|
||||
#define open _open
|
||||
#define read _read
|
||||
#define write _write
|
||||
#endif
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
#ifndef MSDOS
|
||||
#ifdef OPEN_DECL
|
||||
extern int creat(const char*,int), open(const char*,int);
|
||||
#endif
|
||||
extern int close(int);
|
||||
extern int read(int,void*,size_t), write(int,void*,size_t);
|
||||
extern int unlink(const char*);
|
||||
#ifndef _POSIX_SOURCE
|
||||
#ifndef NON_UNIX_STDIO
|
||||
extern FILE *fdopen(int, const char*);
|
||||
#endif
|
||||
#endif
|
||||
#endif
|
||||
|
||||
extern char *mktemp(char*);
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#include "fcntl.h"
|
||||
|
||||
#ifndef O_WRONLY
|
||||
#define O_RDONLY 0
|
||||
#define O_WRONLY 1
|
||||
#endif
|
476
lib/libI77/rdfmt.c
Normal file
476
lib/libI77/rdfmt.c
Normal file
@ -0,0 +1,476 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
#include "fp.h"
|
||||
|
||||
extern int f__cursor;
|
||||
#ifdef KR_headers
|
||||
extern double atof();
|
||||
#else
|
||||
#undef abs
|
||||
#undef min
|
||||
#undef max
|
||||
#include "stdlib.h"
|
||||
#endif
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
rd_Z(n,w,len) Uint *n; ftnlen len;
|
||||
#else
|
||||
rd_Z(Uint *n, int w, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
long x[9];
|
||||
char *s, *s0, *s1, *se, *t;
|
||||
int ch, i, w1, w2;
|
||||
static char hex[256];
|
||||
static int one = 1;
|
||||
int bad = 0;
|
||||
|
||||
if (!hex['0']) {
|
||||
s = "0123456789";
|
||||
while(ch = *s++)
|
||||
hex[ch] = ch - '0' + 1;
|
||||
s = "ABCDEF";
|
||||
while(ch = *s++)
|
||||
hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11;
|
||||
}
|
||||
s = s0 = (char *)x;
|
||||
s1 = (char *)&x[4];
|
||||
se = (char *)&x[8];
|
||||
if (len > 4*sizeof(long))
|
||||
return errno = 117;
|
||||
while (w) {
|
||||
GET(ch);
|
||||
if (ch==',' || ch=='\n')
|
||||
break;
|
||||
w--;
|
||||
if (ch > ' ') {
|
||||
if (!hex[ch & 0xff])
|
||||
bad++;
|
||||
*s++ = ch;
|
||||
if (s == se) {
|
||||
/* discard excess characters */
|
||||
for(t = s0, s = s1; t < s1;)
|
||||
*t++ = *s++;
|
||||
s = s1;
|
||||
}
|
||||
}
|
||||
}
|
||||
if (bad)
|
||||
return errno = 115;
|
||||
w = (int)len;
|
||||
w1 = s - s0;
|
||||
w2 = w1+1 >> 1;
|
||||
t = (char *)n;
|
||||
if (*(char *)&one) {
|
||||
/* little endian */
|
||||
t += w - 1;
|
||||
i = -1;
|
||||
}
|
||||
else
|
||||
i = 1;
|
||||
for(; w > w2; t += i, --w)
|
||||
*t = 0;
|
||||
if (!w)
|
||||
return 0;
|
||||
if (w < w2)
|
||||
s0 = s - (w << 1);
|
||||
else if (w1 & 1) {
|
||||
*t = hex[*s0++ & 0xff] - 1;
|
||||
if (!--w)
|
||||
return 0;
|
||||
t += i;
|
||||
}
|
||||
do {
|
||||
*t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1;
|
||||
t += i;
|
||||
s0 += 2;
|
||||
}
|
||||
while(--w);
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base;
|
||||
#else
|
||||
rd_I(Uint *n, int w, ftnlen len, register int base)
|
||||
#endif
|
||||
{ long x;
|
||||
int sign,ch;
|
||||
char s[84], *ps;
|
||||
ps=s; x=0;
|
||||
while (w)
|
||||
{
|
||||
GET(ch);
|
||||
if (ch==',' || ch=='\n') break;
|
||||
*ps=ch; ps++; w--;
|
||||
}
|
||||
*ps='\0';
|
||||
ps=s;
|
||||
while (*ps==' ') ps++;
|
||||
if (*ps=='-') { sign=1; ps++; }
|
||||
else { sign=0; if (*ps=='+') ps++; }
|
||||
loop: while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; }
|
||||
if (*ps==' ') {if (f__cblank) x *= base; ps++; goto loop;}
|
||||
if(sign) x = -x;
|
||||
if(len==sizeof(integer)) n->il=x;
|
||||
else if(len == sizeof(char)) n->ic = (char)x;
|
||||
#ifdef Allow_TYQUAD
|
||||
else if (len == sizeof(longint)) n->ili = x;
|
||||
#endif
|
||||
else n->is = (short)x;
|
||||
if (*ps) return(errno=115); else return(0);
|
||||
}
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
rd_L(n,w,len) ftnint *n; ftnlen len;
|
||||
#else
|
||||
rd_L(ftnint *n, int w, ftnlen len)
|
||||
#endif
|
||||
{ int ch, lv;
|
||||
char s[84], *ps;
|
||||
ps=s;
|
||||
while (w) {
|
||||
GET(ch);
|
||||
if (ch==','||ch=='\n') break;
|
||||
*ps=ch;
|
||||
ps++; w--;
|
||||
}
|
||||
*ps='\0';
|
||||
ps=s; while (*ps==' ') ps++;
|
||||
if (*ps=='.') ps++;
|
||||
if (*ps=='t' || *ps == 'T')
|
||||
lv = 1;
|
||||
else if (*ps == 'f' || *ps == 'F')
|
||||
lv = 0;
|
||||
else return(errno=116);
|
||||
switch(len) {
|
||||
case sizeof(char): *(char *)n = (char)lv; break;
|
||||
case sizeof(short): *(short *)n = (short)lv; break;
|
||||
default: *n = lv;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
#include "ctype.h"
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
rd_F(p, w, d, len) ufloat *p; ftnlen len;
|
||||
#else
|
||||
rd_F(ufloat *p, int w, int d, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
char s[FMAX+EXPMAXDIGS+4];
|
||||
register int ch;
|
||||
register char *sp, *spe, *sp1;
|
||||
double x;
|
||||
int scale1, se;
|
||||
long e, exp;
|
||||
|
||||
sp1 = sp = s;
|
||||
spe = sp + FMAX;
|
||||
exp = -d;
|
||||
x = 0.;
|
||||
|
||||
do {
|
||||
GET(ch);
|
||||
w--;
|
||||
} while (ch == ' ' && w);
|
||||
switch(ch) {
|
||||
case '-': *sp++ = ch; sp1++; spe++;
|
||||
case '+':
|
||||
if (!w) goto zero;
|
||||
--w;
|
||||
GET(ch);
|
||||
}
|
||||
while(ch == ' ') {
|
||||
blankdrop:
|
||||
if (!w--) goto zero; GET(ch); }
|
||||
while(ch == '0')
|
||||
{ if (!w--) goto zero; GET(ch); }
|
||||
if (ch == ' ' && f__cblank)
|
||||
goto blankdrop;
|
||||
scale1 = f__scale;
|
||||
while(isdigit(ch)) {
|
||||
digloop1:
|
||||
if (sp < spe) *sp++ = ch;
|
||||
else ++exp;
|
||||
digloop1e:
|
||||
if (!w--) goto done;
|
||||
GET(ch);
|
||||
}
|
||||
if (ch == ' ') {
|
||||
if (f__cblank)
|
||||
{ ch = '0'; goto digloop1; }
|
||||
goto digloop1e;
|
||||
}
|
||||
if (ch == '.') {
|
||||
exp += d;
|
||||
if (!w--) goto done;
|
||||
GET(ch);
|
||||
if (sp == sp1) { /* no digits yet */
|
||||
while(ch == '0') {
|
||||
skip01:
|
||||
--exp;
|
||||
skip0:
|
||||
if (!w--) goto done;
|
||||
GET(ch);
|
||||
}
|
||||
if (ch == ' ') {
|
||||
if (f__cblank) goto skip01;
|
||||
goto skip0;
|
||||
}
|
||||
}
|
||||
while(isdigit(ch)) {
|
||||
digloop2:
|
||||
if (sp < spe)
|
||||
{ *sp++ = ch; --exp; }
|
||||
digloop2e:
|
||||
if (!w--) goto done;
|
||||
GET(ch);
|
||||
}
|
||||
if (ch == ' ') {
|
||||
if (f__cblank)
|
||||
{ ch = '0'; goto digloop2; }
|
||||
goto digloop2e;
|
||||
}
|
||||
}
|
||||
switch(ch) {
|
||||
default:
|
||||
break;
|
||||
case '-': se = 1; goto signonly;
|
||||
case '+': se = 0; goto signonly;
|
||||
case 'e':
|
||||
case 'E':
|
||||
case 'd':
|
||||
case 'D':
|
||||
if (!w--)
|
||||
goto bad;
|
||||
GET(ch);
|
||||
while(ch == ' ') {
|
||||
if (!w--)
|
||||
goto bad;
|
||||
GET(ch);
|
||||
}
|
||||
se = 0;
|
||||
switch(ch) {
|
||||
case '-': se = 1;
|
||||
case '+':
|
||||
signonly:
|
||||
if (!w--)
|
||||
goto bad;
|
||||
GET(ch);
|
||||
}
|
||||
while(ch == ' ') {
|
||||
if (!w--)
|
||||
goto bad;
|
||||
GET(ch);
|
||||
}
|
||||
if (!isdigit(ch))
|
||||
goto bad;
|
||||
|
||||
e = ch - '0';
|
||||
for(;;) {
|
||||
if (!w--)
|
||||
{ ch = '\n'; break; }
|
||||
GET(ch);
|
||||
if (!isdigit(ch)) {
|
||||
if (ch == ' ') {
|
||||
if (f__cblank)
|
||||
ch = '0';
|
||||
else continue;
|
||||
}
|
||||
else
|
||||
break;
|
||||
}
|
||||
e = 10*e + ch - '0';
|
||||
if (e > EXPMAX && sp > sp1)
|
||||
goto bad;
|
||||
}
|
||||
if (se)
|
||||
exp -= e;
|
||||
else
|
||||
exp += e;
|
||||
scale1 = 0;
|
||||
}
|
||||
switch(ch) {
|
||||
case '\n':
|
||||
case ',':
|
||||
break;
|
||||
default:
|
||||
bad:
|
||||
return (errno = 115);
|
||||
}
|
||||
done:
|
||||
if (sp > sp1) {
|
||||
while(*--sp == '0')
|
||||
++exp;
|
||||
if (exp -= scale1)
|
||||
sprintf(sp+1, "e%ld", exp);
|
||||
else
|
||||
sp[1] = 0;
|
||||
x = atof(s);
|
||||
}
|
||||
zero:
|
||||
if (len == sizeof(real))
|
||||
p->pf = x;
|
||||
else
|
||||
p->pd = x;
|
||||
return(0);
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
rd_A(p,len) char *p; ftnlen len;
|
||||
#else
|
||||
rd_A(char *p, ftnlen len)
|
||||
#endif
|
||||
{ int i,ch;
|
||||
for(i=0;i<len;i++)
|
||||
{ GET(ch);
|
||||
*p++=VAL(ch);
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
rd_AW(p,w,len) char *p; ftnlen len;
|
||||
#else
|
||||
rd_AW(char *p, int w, ftnlen len)
|
||||
#endif
|
||||
{ int i,ch;
|
||||
if(w>=len)
|
||||
{ for(i=0;i<w-len;i++)
|
||||
GET(ch);
|
||||
for(i=0;i<len;i++)
|
||||
{ GET(ch);
|
||||
*p++=VAL(ch);
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
for(i=0;i<w;i++)
|
||||
{ GET(ch);
|
||||
*p++=VAL(ch);
|
||||
}
|
||||
for(i=0;i<len-w;i++) *p++=' ';
|
||||
return(0);
|
||||
}
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
rd_H(n,s) char *s;
|
||||
#else
|
||||
rd_H(int n, char *s)
|
||||
#endif
|
||||
{ int i,ch;
|
||||
for(i=0;i<n;i++)
|
||||
if((ch=(*f__getn)())<0) return(ch);
|
||||
else *s++ = ch=='\n'?' ':ch;
|
||||
return(1);
|
||||
}
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
rd_POS(s) char *s;
|
||||
#else
|
||||
rd_POS(char *s)
|
||||
#endif
|
||||
{ char quote;
|
||||
int ch;
|
||||
quote= *s++;
|
||||
for(;*s;s++)
|
||||
if(*s==quote && *(s+1)!=quote) break;
|
||||
else if((ch=(*f__getn)())<0) return(ch);
|
||||
else *s = ch=='\n'?' ':ch;
|
||||
return(1);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
rd_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
|
||||
#else
|
||||
rd_ed(struct syl *p, char *ptr, ftnlen len)
|
||||
#endif
|
||||
{ int ch;
|
||||
for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch);
|
||||
if(f__cursor<0)
|
||||
{ if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/
|
||||
f__cursor = -f__recpos; /* is this in the standard? */
|
||||
if(f__external == 0) {
|
||||
extern char *f__icptr;
|
||||
f__icptr += f__cursor;
|
||||
}
|
||||
else if(f__curunit && f__curunit->useek)
|
||||
(void) fseek(f__cf,(long) f__cursor,SEEK_CUR);
|
||||
else
|
||||
err(f__elist->cierr,106,"fmt");
|
||||
f__recpos += f__cursor;
|
||||
f__cursor=0;
|
||||
}
|
||||
switch(p->op)
|
||||
{
|
||||
default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op);
|
||||
sig_die(f__fmtbuf, 1);
|
||||
case IM:
|
||||
case I: ch = rd_I((Uint *)ptr,p->p1,len, 10);
|
||||
break;
|
||||
|
||||
/* O and OM don't work right for character, double, complex, */
|
||||
/* or doublecomplex, and they differ from Fortran 90 in */
|
||||
/* showing a minus sign for negative values. */
|
||||
|
||||
case OM:
|
||||
case O: ch = rd_I((Uint *)ptr, p->p1, len, 8);
|
||||
break;
|
||||
case L: ch = rd_L((ftnint *)ptr,p->p1,len);
|
||||
break;
|
||||
case A: ch = rd_A(ptr,len);
|
||||
break;
|
||||
case AW:
|
||||
ch = rd_AW(ptr,p->p1,len);
|
||||
break;
|
||||
case E: case EE:
|
||||
case D:
|
||||
case G:
|
||||
case GE:
|
||||
case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2,len);
|
||||
break;
|
||||
|
||||
/* Z and ZM assume 8-bit bytes. */
|
||||
|
||||
case ZM:
|
||||
case Z:
|
||||
ch = rd_Z((Uint *)ptr, p->p1, len);
|
||||
break;
|
||||
}
|
||||
if(ch == 0) return(ch);
|
||||
else if(ch == EOF) return(EOF);
|
||||
if (f__cf)
|
||||
clearerr(f__cf);
|
||||
return(errno);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
rd_ned(p) struct syl *p;
|
||||
#else
|
||||
rd_ned(struct syl *p)
|
||||
#endif
|
||||
{
|
||||
switch(p->op)
|
||||
{
|
||||
default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
|
||||
sig_die(f__fmtbuf, 1);
|
||||
case APOS:
|
||||
return(rd_POS(*(char **)&p->p2));
|
||||
case H: return(rd_H(p->p1,*(char **)&p->p2));
|
||||
case SLASH: return((*f__donewrec)());
|
||||
case TR:
|
||||
case X: f__cursor += p->p1;
|
||||
return(1);
|
||||
case T: f__cursor=p->p1-f__recpos - 1;
|
||||
return(1);
|
||||
case TL: f__cursor -= p->p1;
|
||||
if(f__cursor < -f__recpos) /* TL1000, 1X */
|
||||
f__cursor = -f__recpos;
|
||||
return(1);
|
||||
}
|
||||
}
|
24
lib/libI77/rewind.c
Normal file
24
lib/libI77/rewind.c
Normal file
@ -0,0 +1,24 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#ifdef KR_headers
|
||||
integer f_rew(a) alist *a;
|
||||
#else
|
||||
integer f_rew(alist *a)
|
||||
#endif
|
||||
{
|
||||
unit *b;
|
||||
if(a->aunit>=MXUNIT || a->aunit<0)
|
||||
err(a->aerr,101,"rewind");
|
||||
b = &f__units[a->aunit];
|
||||
if(b->ufd == NULL || b->uwrt == 3)
|
||||
return(0);
|
||||
if(!b->useek)
|
||||
err(a->aerr,106,"rewind")
|
||||
if(b->uwrt) {
|
||||
(void) t_runc(a);
|
||||
b->uwrt = 3;
|
||||
}
|
||||
rewind(b->ufd);
|
||||
b->uend=0;
|
||||
return(0);
|
||||
}
|
73
lib/libI77/rsfe.c
Normal file
73
lib/libI77/rsfe.c
Normal file
@ -0,0 +1,73 @@
|
||||
/* read sequential formatted external */
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
|
||||
xrd_SL(Void)
|
||||
{ int ch;
|
||||
if(!f__curunit->uend)
|
||||
while((ch=getc(f__cf))!='\n' && ch!=EOF);
|
||||
f__cursor=f__recpos=0;
|
||||
return(1);
|
||||
}
|
||||
x_getc(Void)
|
||||
{ int ch;
|
||||
if(f__curunit->uend) return(EOF);
|
||||
ch = getc(f__cf);
|
||||
if(ch!=EOF && ch!='\n')
|
||||
{ f__recpos++;
|
||||
return(ch);
|
||||
}
|
||||
if(ch=='\n')
|
||||
{ (void) ungetc(ch,f__cf);
|
||||
return(ch);
|
||||
}
|
||||
if(f__curunit->uend || feof(f__cf))
|
||||
{ errno=0;
|
||||
f__curunit->uend=1;
|
||||
return(-1);
|
||||
}
|
||||
return(-1);
|
||||
}
|
||||
x_endp(Void)
|
||||
{
|
||||
(void) xrd_SL();
|
||||
return(0);
|
||||
}
|
||||
x_rev(Void)
|
||||
{
|
||||
(void) xrd_SL();
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer s_rsfe(a) cilist *a; /* start */
|
||||
#else
|
||||
integer s_rsfe(cilist *a) /* start */
|
||||
#endif
|
||||
{ int n;
|
||||
if(!f__init) f_init();
|
||||
if(n=c_sfe(a)) return(n);
|
||||
f__reading=1;
|
||||
f__sequential=1;
|
||||
f__formatted=1;
|
||||
f__external=1;
|
||||
f__elist=a;
|
||||
f__cursor=f__recpos=0;
|
||||
f__scale=0;
|
||||
f__fmtbuf=a->cifmt;
|
||||
f__curunit= &f__units[a->ciunit];
|
||||
f__cf=f__curunit->ufd;
|
||||
if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio");
|
||||
f__getn= x_getc;
|
||||
f__doed= rd_ed;
|
||||
f__doned= rd_ned;
|
||||
fmt_bg();
|
||||
f__doend=x_endp;
|
||||
f__donewrec=xrd_SL;
|
||||
f__dorevert=x_rev;
|
||||
f__cblank=f__curunit->ublnk;
|
||||
f__cplus=0;
|
||||
if(f__curunit->uwrt && f__nowreading(f__curunit))
|
||||
err(a->cierr,errno,"read start");
|
||||
return(0);
|
||||
}
|
102
lib/libI77/rsli.c
Normal file
102
lib/libI77/rsli.c
Normal file
@ -0,0 +1,102 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "lio.h"
|
||||
#include "fmt.h" /* for f__doend */
|
||||
|
||||
extern flag f__lquit;
|
||||
extern int f__lcount;
|
||||
extern char *f__icptr;
|
||||
extern char *f__icend;
|
||||
extern icilist *f__svic;
|
||||
extern int f__icnum, f__recpos;
|
||||
|
||||
static int i_getc(Void)
|
||||
{
|
||||
if(f__recpos >= f__svic->icirlen) {
|
||||
if (f__recpos++ == f__svic->icirlen)
|
||||
return '\n';
|
||||
z_rnew();
|
||||
}
|
||||
f__recpos++;
|
||||
if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"internal read");
|
||||
return(*f__icptr++);
|
||||
}
|
||||
|
||||
static
|
||||
#ifdef KR_headers
|
||||
int i_ungetc(ch, f) int ch; FILE *f;
|
||||
#else
|
||||
int i_ungetc(int ch, FILE *f)
|
||||
#endif
|
||||
{
|
||||
if (--f__recpos == f__svic->icirlen)
|
||||
return '\n';
|
||||
if (f__recpos < -1)
|
||||
err(f__svic->icierr,110,"recend");
|
||||
/* *--icptr == ch, and icptr may point to read-only memory */
|
||||
return *--f__icptr /* = ch */;
|
||||
}
|
||||
|
||||
static void
|
||||
#ifdef KR_headers
|
||||
c_lir(a) icilist *a;
|
||||
#else
|
||||
c_lir(icilist *a)
|
||||
#endif
|
||||
{
|
||||
extern int l_eof;
|
||||
f__reading = 1;
|
||||
f__external = 0;
|
||||
f__formatted = 1;
|
||||
f__svic = a;
|
||||
L_len = a->icirlen;
|
||||
f__recpos = -1;
|
||||
f__icnum = f__recpos = 0;
|
||||
f__cursor = 0;
|
||||
l_getc = i_getc;
|
||||
l_ungetc = i_ungetc;
|
||||
l_eof = 0;
|
||||
f__icptr = a->iciunit;
|
||||
f__icend = f__icptr + a->icirlen*a->icirnum;
|
||||
f__cf = 0;
|
||||
f__curunit = 0;
|
||||
f__elist = (cilist *)a;
|
||||
}
|
||||
|
||||
|
||||
#ifdef KR_headers
|
||||
integer s_rsli(a) icilist *a;
|
||||
#else
|
||||
integer s_rsli(icilist *a)
|
||||
#endif
|
||||
{
|
||||
f__lioproc = l_read;
|
||||
f__lquit = 0;
|
||||
f__lcount = 0;
|
||||
c_lir(a);
|
||||
f__doend = 0;
|
||||
return(0);
|
||||
}
|
||||
|
||||
integer e_rsli(Void)
|
||||
{ return 0; }
|
||||
|
||||
#ifdef KR_headers
|
||||
integer s_rsni(a) icilist *a;
|
||||
#else
|
||||
extern int x_rsne(cilist*);
|
||||
|
||||
integer s_rsni(icilist *a)
|
||||
#endif
|
||||
{
|
||||
extern int nml_read;
|
||||
integer rv;
|
||||
cilist ca;
|
||||
ca.ciend = a->iciend;
|
||||
ca.cierr = a->icierr;
|
||||
ca.cifmt = a->icifmt;
|
||||
c_lir(a);
|
||||
rv = x_rsne(&ca);
|
||||
nml_read = 0;
|
||||
return rv;
|
||||
}
|
568
lib/libI77/rsne.c
Normal file
568
lib/libI77/rsne.c
Normal file
@ -0,0 +1,568 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "lio.h"
|
||||
|
||||
#define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */
|
||||
#define MAXDIM 20 /* maximum number of subscripts */
|
||||
|
||||
struct dimen {
|
||||
ftnlen extent;
|
||||
ftnlen curval;
|
||||
ftnlen delta;
|
||||
ftnlen stride;
|
||||
};
|
||||
typedef struct dimen dimen;
|
||||
|
||||
struct hashentry {
|
||||
struct hashentry *next;
|
||||
char *name;
|
||||
Vardesc *vd;
|
||||
};
|
||||
typedef struct hashentry hashentry;
|
||||
|
||||
struct hashtab {
|
||||
struct hashtab *next;
|
||||
Namelist *nl;
|
||||
int htsize;
|
||||
hashentry *tab[1];
|
||||
};
|
||||
typedef struct hashtab hashtab;
|
||||
|
||||
static hashtab *nl_cache;
|
||||
static n_nlcache;
|
||||
static hashentry **zot;
|
||||
extern ftnlen f__typesize[];
|
||||
|
||||
extern flag f__lquit;
|
||||
extern int f__lcount, nml_read;
|
||||
extern t_getc(Void);
|
||||
|
||||
#ifdef KR_headers
|
||||
extern char *malloc(), *memset();
|
||||
|
||||
#ifdef ungetc
|
||||
static int
|
||||
un_getc(x,f__cf) int x; FILE *f__cf;
|
||||
{ return ungetc(x,f__cf); }
|
||||
#else
|
||||
#define un_getc ungetc
|
||||
extern int ungetc();
|
||||
#endif
|
||||
|
||||
#else
|
||||
#undef abs
|
||||
#undef min
|
||||
#undef max
|
||||
#include "stdlib.h"
|
||||
#include "string.h"
|
||||
|
||||
#ifdef ungetc
|
||||
static int
|
||||
un_getc(int x, FILE *f__cf)
|
||||
{ return ungetc(x,f__cf); }
|
||||
#else
|
||||
#define un_getc ungetc
|
||||
extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */
|
||||
#endif
|
||||
#endif
|
||||
|
||||
static Vardesc *
|
||||
#ifdef KR_headers
|
||||
hash(ht, s) hashtab *ht; register char *s;
|
||||
#else
|
||||
hash(hashtab *ht, register char *s)
|
||||
#endif
|
||||
{
|
||||
register int c, x;
|
||||
register hashentry *h;
|
||||
char *s0 = s;
|
||||
|
||||
for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
|
||||
x += c;
|
||||
for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
|
||||
if (!strcmp(s0, h->name))
|
||||
return h->vd;
|
||||
return 0;
|
||||
}
|
||||
|
||||
hashtab *
|
||||
#ifdef KR_headers
|
||||
mk_hashtab(nl) Namelist *nl;
|
||||
#else
|
||||
mk_hashtab(Namelist *nl)
|
||||
#endif
|
||||
{
|
||||
int nht, nv;
|
||||
hashtab *ht;
|
||||
Vardesc *v, **vd, **vde;
|
||||
hashentry *he;
|
||||
|
||||
hashtab **x, **x0, *y;
|
||||
for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
|
||||
if (nl == y->nl)
|
||||
return y;
|
||||
if (n_nlcache >= MAX_NL_CACHE) {
|
||||
/* discard least recently used namelist hash table */
|
||||
y = *x0;
|
||||
free((char *)y->next);
|
||||
y->next = 0;
|
||||
}
|
||||
else
|
||||
n_nlcache++;
|
||||
nv = nl->nvars;
|
||||
if (nv >= 0x4000)
|
||||
nht = 0x7fff;
|
||||
else {
|
||||
for(nht = 1; nht < nv; nht <<= 1);
|
||||
nht += nht - 1;
|
||||
}
|
||||
ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
|
||||
+ nv*sizeof(hashentry));
|
||||
if (!ht)
|
||||
return 0;
|
||||
he = (hashentry *)&ht->tab[nht];
|
||||
ht->nl = nl;
|
||||
ht->htsize = nht;
|
||||
ht->next = nl_cache;
|
||||
nl_cache = ht;
|
||||
memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
|
||||
vd = nl->vars;
|
||||
vde = vd + nv;
|
||||
while(vd < vde) {
|
||||
v = *vd++;
|
||||
if (!hash(ht, v->name)) {
|
||||
he->next = *zot;
|
||||
*zot = he;
|
||||
he->name = v->name;
|
||||
he->vd = v;
|
||||
he++;
|
||||
}
|
||||
}
|
||||
return ht;
|
||||
}
|
||||
|
||||
static char Alpha[256], Alphanum[256];
|
||||
|
||||
static VOID
|
||||
nl_init(Void) {
|
||||
register char *s;
|
||||
register int c;
|
||||
|
||||
if(!f__init)
|
||||
f_init();
|
||||
for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
|
||||
Alpha[c]
|
||||
= Alphanum[c]
|
||||
= Alpha[c + 'a' - 'A']
|
||||
= Alphanum[c + 'a' - 'A']
|
||||
= c;
|
||||
for(s = "0123456789_"; c = *s++; )
|
||||
Alphanum[c] = c;
|
||||
}
|
||||
|
||||
#define GETC(x) (x=(*l_getc)())
|
||||
#define Ungetc(x,y) (*l_ungetc)(x,y)
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
getname(s, slen) register char *s; int slen;
|
||||
#else
|
||||
getname(register char *s, int slen)
|
||||
#endif
|
||||
{
|
||||
register char *se = s + slen - 1;
|
||||
register int ch;
|
||||
|
||||
GETC(ch);
|
||||
if (!(*s++ = Alpha[ch & 0xff])) {
|
||||
if (ch != EOF)
|
||||
ch = 115;
|
||||
errfl(f__elist->cierr, ch, "namelist read");
|
||||
}
|
||||
while(*s = Alphanum[GETC(ch) & 0xff])
|
||||
if (s < se)
|
||||
s++;
|
||||
if (ch == EOF)
|
||||
err(f__elist->cierr, EOF, "namelist read");
|
||||
if (ch > ' ')
|
||||
Ungetc(ch,f__cf);
|
||||
return *s = 0;
|
||||
}
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
getnum(chp, val) int *chp; ftnlen *val;
|
||||
#else
|
||||
getnum(int *chp, ftnlen *val)
|
||||
#endif
|
||||
{
|
||||
register int ch, sign;
|
||||
register ftnlen x;
|
||||
|
||||
while(GETC(ch) <= ' ' && ch >= 0);
|
||||
if (ch == '-') {
|
||||
sign = 1;
|
||||
GETC(ch);
|
||||
}
|
||||
else {
|
||||
sign = 0;
|
||||
if (ch == '+')
|
||||
GETC(ch);
|
||||
}
|
||||
x = ch - '0';
|
||||
if (x < 0 || x > 9)
|
||||
return 115;
|
||||
while(GETC(ch) >= '0' && ch <= '9')
|
||||
x = 10*x + ch - '0';
|
||||
while(ch <= ' ' && ch >= 0)
|
||||
GETC(ch);
|
||||
if (ch == EOF)
|
||||
return EOF;
|
||||
*val = sign ? -x : x;
|
||||
*chp = ch;
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
getdimen(chp, d, delta, extent, x1)
|
||||
int *chp; dimen *d; ftnlen delta, extent, *x1;
|
||||
#else
|
||||
getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1)
|
||||
#endif
|
||||
{
|
||||
register int k;
|
||||
ftnlen x2, x3;
|
||||
|
||||
if (k = getnum(chp, x1))
|
||||
return k;
|
||||
x3 = 1;
|
||||
if (*chp == ':') {
|
||||
if (k = getnum(chp, &x2))
|
||||
return k;
|
||||
x2 -= *x1;
|
||||
if (*chp == ':') {
|
||||
if (k = getnum(chp, &x3))
|
||||
return k;
|
||||
if (!x3)
|
||||
return 123;
|
||||
x2 /= x3;
|
||||
}
|
||||
if (x2 < 0 || x2 >= extent)
|
||||
return 123;
|
||||
d->extent = x2 + 1;
|
||||
}
|
||||
else
|
||||
d->extent = 1;
|
||||
d->curval = 0;
|
||||
d->delta = delta;
|
||||
d->stride = x3;
|
||||
return 0;
|
||||
}
|
||||
|
||||
#ifndef No_Namelist_Questions
|
||||
static Void
|
||||
#ifdef KR_headers
|
||||
print_ne(a) cilist *a;
|
||||
#else
|
||||
print_ne(cilist *a)
|
||||
#endif
|
||||
{
|
||||
flag intext = f__external;
|
||||
int rpsave = f__recpos;
|
||||
FILE *cfsave = f__cf;
|
||||
unit *usave = f__curunit;
|
||||
cilist t;
|
||||
t = *a;
|
||||
t.ciunit = 6;
|
||||
s_wsne(&t);
|
||||
fflush(f__cf);
|
||||
f__external = intext;
|
||||
f__reading = 1;
|
||||
f__recpos = rpsave;
|
||||
f__cf = cfsave;
|
||||
f__curunit = usave;
|
||||
f__elist = a;
|
||||
}
|
||||
#endif
|
||||
|
||||
static char where0[] = "namelist read start ";
|
||||
|
||||
#ifdef KR_headers
|
||||
x_rsne(a) cilist *a;
|
||||
#else
|
||||
x_rsne(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int ch, got1, k, n, nd, quote;
|
||||
Namelist *nl;
|
||||
static char where[] = "namelist read";
|
||||
char buf[64];
|
||||
hashtab *ht;
|
||||
Vardesc *v;
|
||||
dimen *dn, *dn0, *dn1;
|
||||
ftnlen *dims, *dims1;
|
||||
ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
|
||||
ftnint type;
|
||||
char *vaddr;
|
||||
long iva, ivae;
|
||||
dimen dimens[MAXDIM], substr;
|
||||
|
||||
if (!Alpha['a'])
|
||||
nl_init();
|
||||
f__reading=1;
|
||||
f__formatted=1;
|
||||
got1 = 0;
|
||||
top:
|
||||
for(;;) switch(GETC(ch)) {
|
||||
case EOF:
|
||||
err(a->ciend,(EOF),where0);
|
||||
case '&':
|
||||
case '$':
|
||||
goto have_amp;
|
||||
#ifndef No_Namelist_Questions
|
||||
case '?':
|
||||
print_ne(a);
|
||||
continue;
|
||||
#endif
|
||||
default:
|
||||
if (ch <= ' ' && ch >= 0)
|
||||
continue;
|
||||
errfl(a->cierr, 115, where0);
|
||||
}
|
||||
have_amp:
|
||||
if (ch = getname(buf,sizeof(buf)))
|
||||
return ch;
|
||||
nl = (Namelist *)a->cifmt;
|
||||
if (strcmp(buf, nl->name))
|
||||
#ifdef No_Bad_Namelist_Skip
|
||||
errfl(a->cierr, 118, where0);
|
||||
#else
|
||||
{
|
||||
fprintf(stderr,
|
||||
"Skipping namelist \"%s\": seeking namelist \"%s\".\n",
|
||||
buf, nl->name);
|
||||
fflush(stderr);
|
||||
for(;;) switch(GETC(ch)) {
|
||||
case EOF:
|
||||
err(a->ciend, EOF, where0);
|
||||
case '/':
|
||||
case '&':
|
||||
case '$':
|
||||
if (f__external)
|
||||
e_rsle();
|
||||
else
|
||||
z_rnew();
|
||||
goto top;
|
||||
case '"':
|
||||
case '\'':
|
||||
quote = ch;
|
||||
more_quoted:
|
||||
while(GETC(ch) != quote)
|
||||
if (ch == EOF)
|
||||
err(a->ciend, EOF, where0);
|
||||
if (GETC(ch) == quote)
|
||||
goto more_quoted;
|
||||
Ungetc(ch,f__cf);
|
||||
default:
|
||||
continue;
|
||||
}
|
||||
}
|
||||
#endif
|
||||
ht = mk_hashtab(nl);
|
||||
if (!ht)
|
||||
errfl(f__elist->cierr, 113, where0);
|
||||
for(;;) {
|
||||
for(;;) switch(GETC(ch)) {
|
||||
case EOF:
|
||||
if (got1)
|
||||
return 0;
|
||||
err(a->ciend, EOF, where0);
|
||||
case '/':
|
||||
case '$':
|
||||
case '&':
|
||||
return 0;
|
||||
default:
|
||||
if (ch <= ' ' && ch >= 0 || ch == ',')
|
||||
continue;
|
||||
Ungetc(ch,f__cf);
|
||||
if (ch = getname(buf,sizeof(buf)))
|
||||
return ch;
|
||||
goto havename;
|
||||
}
|
||||
havename:
|
||||
v = hash(ht,buf);
|
||||
if (!v)
|
||||
errfl(a->cierr, 119, where);
|
||||
while(GETC(ch) <= ' ' && ch >= 0);
|
||||
vaddr = v->addr;
|
||||
type = v->type;
|
||||
if (type < 0) {
|
||||
size = -type;
|
||||
type = TYCHAR;
|
||||
}
|
||||
else
|
||||
size = f__typesize[type];
|
||||
ivae = size;
|
||||
iva = 0;
|
||||
if (ch == '(' /*)*/ ) {
|
||||
dn = dimens;
|
||||
if (!(dims = v->dims)) {
|
||||
if (type != TYCHAR)
|
||||
errfl(a->cierr, 122, where);
|
||||
if (k = getdimen(&ch, dn, (ftnlen)size,
|
||||
(ftnlen)size, &b))
|
||||
errfl(a->cierr, k, where);
|
||||
if (ch != ')')
|
||||
errfl(a->cierr, 115, where);
|
||||
b1 = dn->extent;
|
||||
if (--b < 0 || b + b1 > size)
|
||||
return 124;
|
||||
iva += b;
|
||||
size = b1;
|
||||
while(GETC(ch) <= ' ' && ch >= 0);
|
||||
goto scalar;
|
||||
}
|
||||
nd = (int)dims[0];
|
||||
nomax = span = dims[1];
|
||||
ivae = iva + size*nomax;
|
||||
if (k = getdimen(&ch, dn, size, nomax, &b))
|
||||
errfl(a->cierr, k, where);
|
||||
no = dn->extent;
|
||||
b0 = dims[2];
|
||||
dims1 = dims += 3;
|
||||
ex = 1;
|
||||
for(n = 1; n++ < nd; dims++) {
|
||||
if (ch != ',')
|
||||
errfl(a->cierr, 115, where);
|
||||
dn1 = dn + 1;
|
||||
span /= *dims;
|
||||
if (k = getdimen(&ch, dn1, dn->delta**dims,
|
||||
span, &b1))
|
||||
errfl(a->cierr, k, where);
|
||||
ex *= *dims;
|
||||
b += b1*ex;
|
||||
no *= dn1->extent;
|
||||
dn = dn1;
|
||||
}
|
||||
if (ch != ')')
|
||||
errfl(a->cierr, 115, where);
|
||||
b -= b0;
|
||||
if (b < 0 || b >= nomax)
|
||||
errfl(a->cierr, 125, where);
|
||||
iva += size * b;
|
||||
dims = dims1;
|
||||
while(GETC(ch) <= ' ' && ch >= 0);
|
||||
no1 = 1;
|
||||
dn0 = dimens;
|
||||
if (type == TYCHAR && ch == '(' /*)*/) {
|
||||
if (k = getdimen(&ch, &substr, size, size, &b))
|
||||
errfl(a->cierr, k, where);
|
||||
if (ch != ')')
|
||||
errfl(a->cierr, 115, where);
|
||||
b1 = substr.extent;
|
||||
if (--b < 0 || b + b1 > size)
|
||||
return 124;
|
||||
iva += b;
|
||||
b0 = size;
|
||||
size = b1;
|
||||
while(GETC(ch) <= ' ' && ch >= 0);
|
||||
if (b1 < b0)
|
||||
goto delta_adj;
|
||||
}
|
||||
for(; dn0 < dn; dn0++) {
|
||||
if (dn0->extent != *dims++ || dn0->stride != 1)
|
||||
break;
|
||||
no1 *= dn0->extent;
|
||||
}
|
||||
if (dn0 == dimens && dimens[0].stride == 1) {
|
||||
no1 = dimens[0].extent;
|
||||
dn0++;
|
||||
}
|
||||
delta_adj:
|
||||
ex = 0;
|
||||
for(dn1 = dn0; dn1 <= dn; dn1++)
|
||||
ex += (dn1->extent-1)
|
||||
* (dn1->delta *= dn1->stride);
|
||||
for(dn1 = dn; dn1 > dn0; dn1--) {
|
||||
ex -= (dn1->extent - 1) * dn1->delta;
|
||||
dn1->delta -= ex;
|
||||
}
|
||||
}
|
||||
else if (dims = v->dims) {
|
||||
no = no1 = dims[1];
|
||||
ivae = iva + no*size;
|
||||
}
|
||||
else
|
||||
scalar:
|
||||
no = no1 = 1;
|
||||
if (ch != '=')
|
||||
errfl(a->cierr, 115, where);
|
||||
got1 = nml_read = 1;
|
||||
f__lcount = 0;
|
||||
readloop:
|
||||
for(;;) {
|
||||
if (iva >= ivae || iva < 0) {
|
||||
f__lquit = 1;
|
||||
goto mustend;
|
||||
}
|
||||
else if (iva + no1*size > ivae)
|
||||
no1 = (ivae - iva)/size;
|
||||
f__lquit = 0;
|
||||
if (k = l_read(&no1, vaddr + iva, size, type))
|
||||
return k;
|
||||
if (f__lquit == 1)
|
||||
return 0;
|
||||
mustend:
|
||||
if (GETC(ch) == '/' || ch == '$' || ch == '&') {
|
||||
f__lquit = 1;
|
||||
return 0;
|
||||
}
|
||||
else if (f__lquit) {
|
||||
while(ch <= ' ' && ch >= 0)
|
||||
GETC(ch);
|
||||
Ungetc(ch,f__cf);
|
||||
if (!Alpha[ch & 0xff] && ch >= 0)
|
||||
errfl(a->cierr, 125, where);
|
||||
break;
|
||||
}
|
||||
Ungetc(ch,f__cf);
|
||||
if ((no -= no1) <= 0)
|
||||
break;
|
||||
for(dn1 = dn0; dn1 <= dn; dn1++) {
|
||||
if (++dn1->curval < dn1->extent) {
|
||||
iva += dn1->delta;
|
||||
goto readloop;
|
||||
}
|
||||
dn1->curval = 0;
|
||||
}
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
integer
|
||||
#ifdef KR_headers
|
||||
s_rsne(a) cilist *a;
|
||||
#else
|
||||
s_rsne(cilist *a)
|
||||
#endif
|
||||
{
|
||||
extern int l_eof;
|
||||
int n;
|
||||
|
||||
f__external=1;
|
||||
l_eof = 0;
|
||||
if(n = c_le(a))
|
||||
return n;
|
||||
if(f__curunit->uwrt && f__nowreading(f__curunit))
|
||||
err(a->cierr,errno,where0);
|
||||
l_getc = t_getc;
|
||||
l_ungetc = un_getc;
|
||||
f__doend = xrd_SL;
|
||||
n = x_rsne(a);
|
||||
nml_read = 0;
|
||||
if (n)
|
||||
return n;
|
||||
return e_rsle();
|
||||
}
|
32
lib/libI77/sfe.c
Normal file
32
lib/libI77/sfe.c
Normal file
@ -0,0 +1,32 @@
|
||||
/* sequential formatted external common routines*/
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
|
||||
extern char *f__fmtbuf;
|
||||
|
||||
integer e_rsfe(Void)
|
||||
{ int n;
|
||||
n=en_fio();
|
||||
if (f__cf == stdout)
|
||||
fflush(stdout);
|
||||
else if (f__cf == stderr)
|
||||
fflush(stderr);
|
||||
f__fmtbuf=NULL;
|
||||
return(n);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
c_sfe(a) cilist *a; /* check */
|
||||
#else
|
||||
c_sfe(cilist *a) /* check */
|
||||
#endif
|
||||
{ unit *p;
|
||||
if(a->ciunit >= MXUNIT || a->ciunit<0)
|
||||
err(a->cierr,101,"startio");
|
||||
p = &f__units[a->ciunit];
|
||||
if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe")
|
||||
if(!p->ufmt) err(a->cierr,102,"sfe")
|
||||
return(0);
|
||||
}
|
||||
integer e_wsfe(Void)
|
||||
{ return(e_rsfe());
|
||||
}
|
79
lib/libI77/sue.c
Normal file
79
lib/libI77/sue.c
Normal file
@ -0,0 +1,79 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
extern uiolen f__reclen;
|
||||
long f__recloc;
|
||||
|
||||
#ifdef KR_headers
|
||||
c_sue(a) cilist *a;
|
||||
#else
|
||||
c_sue(cilist *a)
|
||||
#endif
|
||||
{
|
||||
if(a->ciunit >= MXUNIT || a->ciunit < 0)
|
||||
err(a->cierr,101,"startio");
|
||||
f__external=f__sequential=1;
|
||||
f__formatted=0;
|
||||
f__curunit = &f__units[a->ciunit];
|
||||
f__elist=a;
|
||||
if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit))
|
||||
err(a->cierr,114,"sue");
|
||||
f__cf=f__curunit->ufd;
|
||||
if(f__curunit->ufmt) err(a->cierr,103,"sue")
|
||||
if(!f__curunit->useek) err(a->cierr,103,"sue")
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer s_rsue(a) cilist *a;
|
||||
#else
|
||||
integer s_rsue(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int n;
|
||||
if(!f__init) f_init();
|
||||
f__reading=1;
|
||||
if(n=c_sue(a)) return(n);
|
||||
f__recpos=0;
|
||||
if(f__curunit->uwrt && f__nowreading(f__curunit))
|
||||
err(a->cierr, errno, "read start");
|
||||
if(fread((char *)&f__reclen,sizeof(uiolen),1,f__cf)
|
||||
!= 1)
|
||||
{ if(feof(f__cf))
|
||||
{ f__curunit->uend = 1;
|
||||
err(a->ciend, EOF, "start");
|
||||
}
|
||||
clearerr(f__cf);
|
||||
err(a->cierr, errno, "start");
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer s_wsue(a) cilist *a;
|
||||
#else
|
||||
integer s_wsue(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int n;
|
||||
if(!f__init) f_init();
|
||||
if(n=c_sue(a)) return(n);
|
||||
f__reading=0;
|
||||
f__reclen=0;
|
||||
if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
|
||||
err(a->cierr, errno, "write start");
|
||||
f__recloc=ftell(f__cf);
|
||||
(void) fseek(f__cf,(long)sizeof(uiolen),SEEK_CUR);
|
||||
return(0);
|
||||
}
|
||||
integer e_wsue(Void)
|
||||
{ long loc;
|
||||
(void) fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf);
|
||||
loc=ftell(f__cf);
|
||||
(void) fseek(f__cf,f__recloc,SEEK_SET);
|
||||
(void) fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf);
|
||||
(void) fseek(f__cf,loc,SEEK_SET);
|
||||
return(0);
|
||||
}
|
||||
integer e_rsue(Void)
|
||||
{
|
||||
(void) fseek(f__cf,(long)(f__reclen-f__recpos+sizeof(uiolen)),SEEK_CUR);
|
||||
return(0);
|
||||
}
|
12
lib/libI77/typesize.c
Normal file
12
lib/libI77/typesize.c
Normal file
@ -0,0 +1,12 @@
|
||||
#include "f2c.h"
|
||||
|
||||
ftnlen f__typesize[] = { 0, 0, sizeof(shortint), sizeof(integer),
|
||||
sizeof(real), sizeof(doublereal),
|
||||
sizeof(complex), sizeof(doublecomplex),
|
||||
sizeof(logical), sizeof(char),
|
||||
0, sizeof(integer1),
|
||||
sizeof(logical1), sizeof(shortlogical),
|
||||
#ifdef Allow_TYQUAD
|
||||
sizeof(longint),
|
||||
#endif
|
||||
0};
|
68
lib/libI77/uio.c
Normal file
68
lib/libI77/uio.c
Normal file
@ -0,0 +1,68 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
uiolen f__reclen;
|
||||
|
||||
#ifdef KR_headers
|
||||
do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
|
||||
#else
|
||||
do_us(ftnint *number, char *ptr, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
if(f__reading)
|
||||
{
|
||||
f__recpos += (int)(*number * len);
|
||||
if(f__recpos>f__reclen)
|
||||
err(f__elist->cierr, 110, "do_us");
|
||||
if (fread(ptr,(int)len,(int)(*number),f__cf) != *number)
|
||||
err(f__elist->ciend, EOF, "do_us");
|
||||
return(0);
|
||||
}
|
||||
else
|
||||
{
|
||||
f__reclen += *number * len;
|
||||
(void) fwrite(ptr,(int)len,(int)(*number),f__cf);
|
||||
return(0);
|
||||
}
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer do_ud(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
|
||||
#else
|
||||
integer do_ud(ftnint *number, char *ptr, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
f__recpos += (int)(*number * len);
|
||||
if(f__recpos > f__curunit->url && f__curunit->url!=1)
|
||||
err(f__elist->cierr,110,"do_ud");
|
||||
if(f__reading)
|
||||
{
|
||||
#ifdef Pad_UDread
|
||||
#ifdef KR_headers
|
||||
int i;
|
||||
#else
|
||||
size_t i;
|
||||
#endif
|
||||
if (!(i = fread(ptr,(int)len,(int)(*number),f__cf))
|
||||
&& !(f__recpos - *number*len))
|
||||
err(f__elist->cierr,EOF,"do_ud")
|
||||
if (i < *number)
|
||||
memset(ptr + i*len, 0, (*number - i)*len);
|
||||
return 0;
|
||||
#else
|
||||
if(fread(ptr,(int)len,(int)(*number),f__cf) != *number)
|
||||
err(f__elist->cierr,EOF,"do_ud")
|
||||
else return(0);
|
||||
#endif
|
||||
}
|
||||
(void) fwrite(ptr,(int)len,(int)(*number),f__cf);
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer do_uio(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
|
||||
#else
|
||||
integer do_uio(ftnint *number, char *ptr, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
if(f__sequential)
|
||||
return(do_us(number,ptr,len));
|
||||
else return(do_ud(number,ptr,len));
|
||||
}
|
51
lib/libI77/util.c
Normal file
51
lib/libI77/util.c
Normal file
@ -0,0 +1,51 @@
|
||||
#ifndef NON_UNIX_STDIO
|
||||
#include "sys/types.h"
|
||||
#include "sys/stat.h"
|
||||
#endif
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
|
||||
VOID
|
||||
#ifdef KR_headers
|
||||
g_char(a,alen,b) char *a,*b; ftnlen alen;
|
||||
#else
|
||||
g_char(char *a, ftnlen alen, char *b)
|
||||
#endif
|
||||
{
|
||||
char *x = a + alen, *y = b + alen;
|
||||
|
||||
for(;; y--) {
|
||||
if (x <= a) {
|
||||
*b = 0;
|
||||
return;
|
||||
}
|
||||
if (*--x != ' ')
|
||||
break;
|
||||
}
|
||||
*y-- = 0;
|
||||
do *y-- = *x;
|
||||
while(x-- > a);
|
||||
}
|
||||
|
||||
VOID
|
||||
#ifdef KR_headers
|
||||
b_char(a,b,blen) char *a,*b; ftnlen blen;
|
||||
#else
|
||||
b_char(char *a, char *b, ftnlen blen)
|
||||
#endif
|
||||
{ int i;
|
||||
for(i=0;i<blen && *a!=0;i++) *b++= *a++;
|
||||
for(;i<blen;i++) *b++=' ';
|
||||
}
|
||||
#ifndef NON_UNIX_STDIO
|
||||
#ifdef KR_headers
|
||||
long f__inode(a, dev) char *a; int *dev;
|
||||
#else
|
||||
long f__inode(char *a, int *dev)
|
||||
#endif
|
||||
{ struct stat x;
|
||||
if(stat(a,&x)<0) return(-1);
|
||||
*dev = x.st_dev;
|
||||
return(x.st_ino);
|
||||
}
|
||||
#endif
|
247
lib/libI77/wref.c
Normal file
247
lib/libI77/wref.c
Normal file
@ -0,0 +1,247 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
#include "fp.h"
|
||||
#ifndef VAX
|
||||
#include "ctype.h"
|
||||
#endif
|
||||
|
||||
#ifndef KR_headers
|
||||
#undef abs
|
||||
#undef min
|
||||
#undef max
|
||||
#include "stdlib.h"
|
||||
#include "string.h"
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
|
||||
#else
|
||||
wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
char buf[FMAX+EXPMAXDIGS+4], *s, *se;
|
||||
int d1, delta, e1, i, sign, signspace;
|
||||
double dd;
|
||||
#ifndef VAX
|
||||
int e0 = e;
|
||||
#endif
|
||||
|
||||
if(e <= 0)
|
||||
e = 2;
|
||||
if(f__scale) {
|
||||
if(f__scale >= d + 2 || f__scale <= -d)
|
||||
goto nogood;
|
||||
}
|
||||
if(f__scale <= 0)
|
||||
--d;
|
||||
if (len == sizeof(real))
|
||||
dd = p->pf;
|
||||
else
|
||||
dd = p->pd;
|
||||
if (dd < 0.) {
|
||||
signspace = sign = 1;
|
||||
dd = -dd;
|
||||
}
|
||||
else {
|
||||
sign = 0;
|
||||
signspace = (int)f__cplus;
|
||||
#ifndef VAX
|
||||
if (!dd)
|
||||
dd = 0.; /* avoid -0 */
|
||||
#endif
|
||||
}
|
||||
delta = w - (2 /* for the . and the d adjustment above */
|
||||
+ 2 /* for the E+ */ + signspace + d + e);
|
||||
if (delta < 0) {
|
||||
nogood:
|
||||
while(--w >= 0)
|
||||
PUT('*');
|
||||
return(0);
|
||||
}
|
||||
if (f__scale < 0)
|
||||
d += f__scale;
|
||||
if (d > FMAX) {
|
||||
d1 = d - FMAX;
|
||||
d = FMAX;
|
||||
}
|
||||
else
|
||||
d1 = 0;
|
||||
sprintf(buf,"%#.*E", d, dd);
|
||||
#ifndef VAX
|
||||
/* check for NaN, Infinity */
|
||||
if (!isdigit(buf[0])) {
|
||||
switch(buf[0]) {
|
||||
case 'n':
|
||||
case 'N':
|
||||
signspace = 0; /* no sign for NaNs */
|
||||
}
|
||||
delta = w - strlen(buf) - signspace;
|
||||
if (delta < 0)
|
||||
goto nogood;
|
||||
while(--delta >= 0)
|
||||
PUT(' ');
|
||||
if (signspace)
|
||||
PUT(sign ? '-' : '+');
|
||||
for(s = buf; *s; s++)
|
||||
PUT(*s);
|
||||
return 0;
|
||||
}
|
||||
#endif
|
||||
se = buf + d + 3;
|
||||
#ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */
|
||||
if (f__scale != 1 && dd)
|
||||
#endif
|
||||
sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
|
||||
s = ++se;
|
||||
if (e < 2) {
|
||||
if (*s != '0')
|
||||
goto nogood;
|
||||
}
|
||||
#ifndef VAX
|
||||
/* accommodate 3 significant digits in exponent */
|
||||
if (s[2]) {
|
||||
#ifdef Pedantic
|
||||
if (!e0 && !s[3])
|
||||
for(s -= 2, e1 = 2; s[0] = s[1]; s++);
|
||||
|
||||
/* Pedantic gives the behavior that Fortran 77 specifies, */
|
||||
/* i.e., requires that E be specified for exponent fields */
|
||||
/* of more than 3 digits. With Pedantic undefined, we get */
|
||||
/* the behavior that Cray displays -- you get a bigger */
|
||||
/* exponent field if it fits. */
|
||||
#else
|
||||
if (!e0) {
|
||||
for(s -= 2, e1 = 2; s[0] = s[1]; s++)
|
||||
#ifdef CRAY
|
||||
delta--;
|
||||
if ((delta += 4) < 0)
|
||||
goto nogood
|
||||
#endif
|
||||
;
|
||||
}
|
||||
#endif
|
||||
else if (e0 >= 0)
|
||||
goto shift;
|
||||
else
|
||||
e1 = e;
|
||||
}
|
||||
else
|
||||
shift:
|
||||
#endif
|
||||
for(s += 2, e1 = 2; *s; ++e1, ++s)
|
||||
if (e1 >= e)
|
||||
goto nogood;
|
||||
while(--delta >= 0)
|
||||
PUT(' ');
|
||||
if (signspace)
|
||||
PUT(sign ? '-' : '+');
|
||||
s = buf;
|
||||
i = f__scale;
|
||||
if (f__scale <= 0) {
|
||||
PUT('.');
|
||||
for(; i < 0; ++i)
|
||||
PUT('0');
|
||||
PUT(*s);
|
||||
s += 2;
|
||||
}
|
||||
else if (f__scale > 1) {
|
||||
PUT(*s);
|
||||
s += 2;
|
||||
while(--i > 0)
|
||||
PUT(*s++);
|
||||
PUT('.');
|
||||
}
|
||||
if (d1) {
|
||||
se -= 2;
|
||||
while(s < se) PUT(*s++);
|
||||
se += 2;
|
||||
do PUT('0'); while(--d1 > 0);
|
||||
}
|
||||
while(s < se)
|
||||
PUT(*s++);
|
||||
if (e < 2)
|
||||
PUT(s[1]);
|
||||
else {
|
||||
while(++e1 <= e)
|
||||
PUT('0');
|
||||
while(*s)
|
||||
PUT(*s++);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
#ifdef KR_headers
|
||||
wrt_F(p,w,d,len) ufloat *p; ftnlen len;
|
||||
#else
|
||||
wrt_F(ufloat *p, int w, int d, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
int d1, sign, n;
|
||||
double x;
|
||||
char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
|
||||
|
||||
x= (len==sizeof(real)?p->pf:p->pd);
|
||||
if (d < MAXFRACDIGS)
|
||||
d1 = 0;
|
||||
else {
|
||||
d1 = d - MAXFRACDIGS;
|
||||
d = MAXFRACDIGS;
|
||||
}
|
||||
if (x < 0.)
|
||||
{ x = -x; sign = 1; }
|
||||
else {
|
||||
sign = 0;
|
||||
#ifndef VAX
|
||||
if (!x)
|
||||
x = 0.;
|
||||
#endif
|
||||
}
|
||||
|
||||
if (n = f__scale)
|
||||
if (n > 0)
|
||||
do x *= 10.; while(--n > 0);
|
||||
else
|
||||
do x *= 0.1; while(++n < 0);
|
||||
|
||||
#ifdef USE_STRLEN
|
||||
sprintf(b = buf, "%#.*f", d, x);
|
||||
n = strlen(b) + d1;
|
||||
#else
|
||||
n = sprintf(b = buf, "%#.*f", d, x) + d1;
|
||||
#endif
|
||||
|
||||
if (buf[0] == '0' && d)
|
||||
{ ++b; --n; }
|
||||
if (sign) {
|
||||
/* check for all zeros */
|
||||
for(s = b;;) {
|
||||
while(*s == '0') s++;
|
||||
switch(*s) {
|
||||
case '.':
|
||||
s++; continue;
|
||||
case 0:
|
||||
sign = 0;
|
||||
}
|
||||
break;
|
||||
}
|
||||
}
|
||||
if (sign || f__cplus)
|
||||
++n;
|
||||
if (n > w) {
|
||||
while(--w >= 0)
|
||||
PUT('*');
|
||||
return 0;
|
||||
}
|
||||
for(w -= n; --w >= 0; )
|
||||
PUT(' ');
|
||||
if (sign)
|
||||
PUT('-');
|
||||
else if (f__cplus)
|
||||
PUT('+');
|
||||
while(n = *b++)
|
||||
PUT(n);
|
||||
while(--d1 >= 0)
|
||||
PUT('0');
|
||||
return 0;
|
||||
}
|
377
lib/libI77/wrtfmt.c
Normal file
377
lib/libI77/wrtfmt.c
Normal file
@ -0,0 +1,377 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
extern int f__cursor;
|
||||
#ifdef KR_headers
|
||||
extern char *f__icvt();
|
||||
#else
|
||||
extern char *f__icvt(long, int*, int*, int);
|
||||
#endif
|
||||
int f__hiwater;
|
||||
icilist *f__svic;
|
||||
char *f__icptr;
|
||||
mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */
|
||||
/* instead we know too much about stdio */
|
||||
{
|
||||
if(f__external == 0) {
|
||||
if(f__cursor < 0) {
|
||||
if(f__hiwater < f__recpos)
|
||||
f__hiwater = f__recpos;
|
||||
f__recpos += f__cursor;
|
||||
f__icptr += f__cursor;
|
||||
f__cursor = 0;
|
||||
if(f__recpos < 0)
|
||||
err(f__elist->cierr, 110, "left off");
|
||||
}
|
||||
else if(f__cursor > 0) {
|
||||
if(f__recpos + f__cursor >= f__svic->icirlen)
|
||||
err(f__elist->cierr, 110, "recend");
|
||||
if(f__hiwater <= f__recpos)
|
||||
for(; f__cursor > 0; f__cursor--)
|
||||
(*f__putn)(' ');
|
||||
else if(f__hiwater <= f__recpos + f__cursor) {
|
||||
f__cursor -= f__hiwater - f__recpos;
|
||||
f__icptr += f__hiwater - f__recpos;
|
||||
f__recpos = f__hiwater;
|
||||
for(; f__cursor > 0; f__cursor--)
|
||||
(*f__putn)(' ');
|
||||
}
|
||||
else {
|
||||
f__icptr += f__cursor;
|
||||
f__recpos += f__cursor;
|
||||
}
|
||||
f__cursor = 0;
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
if(f__cursor > 0) {
|
||||
if(f__hiwater <= f__recpos)
|
||||
for(;f__cursor>0;f__cursor--) (*f__putn)(' ');
|
||||
else if(f__hiwater <= f__recpos + f__cursor) {
|
||||
#ifndef NON_UNIX_STDIO
|
||||
if(f__cf->_ptr + f__hiwater - f__recpos < buf_end(f__cf))
|
||||
f__cf->_ptr += f__hiwater - f__recpos;
|
||||
else
|
||||
#endif
|
||||
(void) fseek(f__cf, (long) (f__hiwater - f__recpos), SEEK_CUR);
|
||||
f__cursor -= f__hiwater - f__recpos;
|
||||
f__recpos = f__hiwater;
|
||||
for(; f__cursor > 0; f__cursor--)
|
||||
(*f__putn)(' ');
|
||||
}
|
||||
else {
|
||||
#ifndef NON_UNIX_STDIO
|
||||
if(f__cf->_ptr + f__cursor < buf_end(f__cf))
|
||||
f__cf->_ptr += f__cursor;
|
||||
else
|
||||
#endif
|
||||
(void) fseek(f__cf, (long)f__cursor, SEEK_CUR);
|
||||
f__recpos += f__cursor;
|
||||
}
|
||||
}
|
||||
if(f__cursor<0)
|
||||
{
|
||||
if(f__cursor+f__recpos<0) err(f__elist->cierr,110,"left off");
|
||||
#ifndef NON_UNIX_STDIO
|
||||
if(f__cf->_ptr + f__cursor >= f__cf->_base)
|
||||
f__cf->_ptr += f__cursor;
|
||||
else
|
||||
#endif
|
||||
if(f__curunit && f__curunit->useek)
|
||||
(void) fseek(f__cf,(long)f__cursor,SEEK_CUR);
|
||||
else
|
||||
err(f__elist->cierr,106,"fmt");
|
||||
if(f__hiwater < f__recpos)
|
||||
f__hiwater = f__recpos;
|
||||
f__recpos += f__cursor;
|
||||
f__cursor=0;
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len;
|
||||
#else
|
||||
wrt_Z(Uint *n, int w, int minlen, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
register char *s, *se;
|
||||
register i, w1;
|
||||
static int one = 1;
|
||||
static char hex[] = "0123456789ABCDEF";
|
||||
s = (char *)n;
|
||||
--len;
|
||||
if (*(char *)&one) {
|
||||
/* little endian */
|
||||
se = s;
|
||||
s += len;
|
||||
i = -1;
|
||||
}
|
||||
else {
|
||||
se = s + len;
|
||||
i = 1;
|
||||
}
|
||||
for(;; s += i)
|
||||
if (s == se || *s)
|
||||
break;
|
||||
w1 = (i*(se-s) << 1) + 1;
|
||||
if (*s & 0xf0)
|
||||
w1++;
|
||||
if (w1 > w)
|
||||
for(i = 0; i < w; i++)
|
||||
(*f__putn)('*');
|
||||
else {
|
||||
if ((minlen -= w1) > 0)
|
||||
w1 += minlen;
|
||||
while(--w >= w1)
|
||||
(*f__putn)(' ');
|
||||
while(--minlen >= 0)
|
||||
(*f__putn)('0');
|
||||
if (!(*s & 0xf0)) {
|
||||
(*f__putn)(hex[*s & 0xf]);
|
||||
if (s == se)
|
||||
return 0;
|
||||
s += i;
|
||||
}
|
||||
for(;; s += i) {
|
||||
(*f__putn)(hex[*s >> 4 & 0xf]);
|
||||
(*f__putn)(hex[*s & 0xf]);
|
||||
if (s == se)
|
||||
break;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base;
|
||||
#else
|
||||
wrt_I(Uint *n, int w, ftnlen len, register int base)
|
||||
#endif
|
||||
{ int ndigit,sign,spare,i;
|
||||
long x;
|
||||
char *ans;
|
||||
if(len==sizeof(integer)) x=n->il;
|
||||
else if(len == sizeof(char)) x = n->ic;
|
||||
#ifdef Allow_TYQUAD
|
||||
else if (len == sizeof(longint)) x = n->ili;
|
||||
#endif
|
||||
else x=n->is;
|
||||
ans=f__icvt(x,&ndigit,&sign, base);
|
||||
spare=w-ndigit;
|
||||
if(sign || f__cplus) spare--;
|
||||
if(spare<0)
|
||||
for(i=0;i<w;i++) (*f__putn)('*');
|
||||
else
|
||||
{ for(i=0;i<spare;i++) (*f__putn)(' ');
|
||||
if(sign) (*f__putn)('-');
|
||||
else if(f__cplus) (*f__putn)('+');
|
||||
for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
wrt_IM(n,w,m,len,base) Uint *n; ftnlen len; int base;
|
||||
#else
|
||||
wrt_IM(Uint *n, int w, int m, ftnlen len, int base)
|
||||
#endif
|
||||
{ int ndigit,sign,spare,i,xsign;
|
||||
long x;
|
||||
char *ans;
|
||||
if(sizeof(integer)==len) x=n->il;
|
||||
else if(len == sizeof(char)) x = n->ic;
|
||||
else x=n->is;
|
||||
ans=f__icvt(x,&ndigit,&sign, base);
|
||||
if(sign || f__cplus) xsign=1;
|
||||
else xsign=0;
|
||||
if(ndigit+xsign>w || m+xsign>w)
|
||||
{ for(i=0;i<w;i++) (*f__putn)('*');
|
||||
return(0);
|
||||
}
|
||||
if(x==0 && m==0)
|
||||
{ for(i=0;i<w;i++) (*f__putn)(' ');
|
||||
return(0);
|
||||
}
|
||||
if(ndigit>=m)
|
||||
spare=w-ndigit-xsign;
|
||||
else
|
||||
spare=w-m-xsign;
|
||||
for(i=0;i<spare;i++) (*f__putn)(' ');
|
||||
if(sign) (*f__putn)('-');
|
||||
else if(f__cplus) (*f__putn)('+');
|
||||
for(i=0;i<m-ndigit;i++) (*f__putn)('0');
|
||||
for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
|
||||
return(0);
|
||||
}
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
wrt_AP(s) char *s;
|
||||
#else
|
||||
wrt_AP(char *s)
|
||||
#endif
|
||||
{ char quote;
|
||||
if(f__cursor && mv_cur()) return(mv_cur());
|
||||
quote = *s++;
|
||||
for(;*s;s++)
|
||||
{ if(*s!=quote) (*f__putn)(*s);
|
||||
else if(*++s==quote) (*f__putn)(*s);
|
||||
else return(1);
|
||||
}
|
||||
return(1);
|
||||
}
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
wrt_H(a,s) char *s;
|
||||
#else
|
||||
wrt_H(int a, char *s)
|
||||
#endif
|
||||
{
|
||||
if(f__cursor && mv_cur()) return(mv_cur());
|
||||
while(a--) (*f__putn)(*s++);
|
||||
return(1);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
wrt_L(n,len, sz) Uint *n; ftnlen sz;
|
||||
#else
|
||||
wrt_L(Uint *n, int len, ftnlen sz)
|
||||
#endif
|
||||
{ int i;
|
||||
long x;
|
||||
if(sizeof(long)==sz) x=n->il;
|
||||
else if(sz == sizeof(char)) x = n->ic;
|
||||
else x=n->is;
|
||||
for(i=0;i<len-1;i++)
|
||||
(*f__putn)(' ');
|
||||
if(x) (*f__putn)('T');
|
||||
else (*f__putn)('F');
|
||||
return(0);
|
||||
}
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
wrt_A(p,len) char *p; ftnlen len;
|
||||
#else
|
||||
wrt_A(char *p, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
while(len-- > 0) (*f__putn)(*p++);
|
||||
return(0);
|
||||
}
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
wrt_AW(p,w,len) char * p; ftnlen len;
|
||||
#else
|
||||
wrt_AW(char * p, int w, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
while(w>len)
|
||||
{ w--;
|
||||
(*f__putn)(' ');
|
||||
}
|
||||
while(w-- > 0)
|
||||
(*f__putn)(*p++);
|
||||
return(0);
|
||||
}
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
|
||||
#else
|
||||
wrt_G(ufloat *p, int w, int d, int e, ftnlen len)
|
||||
#endif
|
||||
{ double up = 1,x;
|
||||
int i=0,oldscale,n,j;
|
||||
x = len==sizeof(real)?p->pf:p->pd;
|
||||
if(x < 0 ) x = -x;
|
||||
if(x<.1) {
|
||||
if (x != 0.)
|
||||
return(wrt_E(p,w,d,e,len));
|
||||
goto have_i;
|
||||
}
|
||||
for(;i<=d;i++,up*=10)
|
||||
{ if(x>=up) continue;
|
||||
have_i:
|
||||
oldscale = f__scale;
|
||||
f__scale = 0;
|
||||
if(e==0) n=4;
|
||||
else n=e+2;
|
||||
i=wrt_F(p,w-n,d-i,len);
|
||||
for(j=0;j<n;j++) (*f__putn)(' ');
|
||||
f__scale=oldscale;
|
||||
return(i);
|
||||
}
|
||||
return(wrt_E(p,w,d,e,len));
|
||||
}
|
||||
#ifdef KR_headers
|
||||
w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
|
||||
#else
|
||||
w_ed(struct syl *p, char *ptr, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
if(f__cursor && mv_cur()) return(mv_cur());
|
||||
switch(p->op)
|
||||
{
|
||||
default:
|
||||
fprintf(stderr,"w_ed, unexpected code: %d\n", p->op);
|
||||
sig_die(f__fmtbuf, 1);
|
||||
case I: return(wrt_I((Uint *)ptr,p->p1,len, 10));
|
||||
case IM:
|
||||
return(wrt_IM((Uint *)ptr,p->p1,p->p2,len,10));
|
||||
|
||||
/* O and OM don't work right for character, double, complex, */
|
||||
/* or doublecomplex, and they differ from Fortran 90 in */
|
||||
/* showing a minus sign for negative values. */
|
||||
|
||||
case O: return(wrt_I((Uint *)ptr, p->p1, len, 8));
|
||||
case OM:
|
||||
return(wrt_IM((Uint *)ptr,p->p1,p->p2,len,8));
|
||||
case L: return(wrt_L((Uint *)ptr,p->p1, len));
|
||||
case A: return(wrt_A(ptr,len));
|
||||
case AW:
|
||||
return(wrt_AW(ptr,p->p1,len));
|
||||
case D:
|
||||
case E:
|
||||
case EE:
|
||||
return(wrt_E((ufloat *)ptr,p->p1,p->p2,p->p3,len));
|
||||
case G:
|
||||
case GE:
|
||||
return(wrt_G((ufloat *)ptr,p->p1,p->p2,p->p3,len));
|
||||
case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2,len));
|
||||
|
||||
/* Z and ZM assume 8-bit bytes. */
|
||||
|
||||
case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len));
|
||||
case ZM:
|
||||
return(wrt_Z((Uint *)ptr,p->p1,p->p2,len));
|
||||
}
|
||||
}
|
||||
#ifdef KR_headers
|
||||
w_ned(p) struct syl *p;
|
||||
#else
|
||||
w_ned(struct syl *p)
|
||||
#endif
|
||||
{
|
||||
switch(p->op)
|
||||
{
|
||||
default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op);
|
||||
sig_die(f__fmtbuf, 1);
|
||||
case SLASH:
|
||||
return((*f__donewrec)());
|
||||
case T: f__cursor = p->p1-f__recpos - 1;
|
||||
return(1);
|
||||
case TL: f__cursor -= p->p1;
|
||||
if(f__cursor < -f__recpos) /* TL1000, 1X */
|
||||
f__cursor = -f__recpos;
|
||||
return(1);
|
||||
case TR:
|
||||
case X:
|
||||
f__cursor += p->p1;
|
||||
return(1);
|
||||
case APOS:
|
||||
return(wrt_AP(*(char **)&p->p2));
|
||||
case H:
|
||||
return(wrt_H(p->p1,*(char **)&p->p2));
|
||||
}
|
||||
}
|
84
lib/libI77/wsfe.c
Normal file
84
lib/libI77/wsfe.c
Normal file
@ -0,0 +1,84 @@
|
||||
/*write sequential formatted external*/
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
extern int f__hiwater;
|
||||
|
||||
#ifdef KR_headers
|
||||
x_putc(c)
|
||||
#else
|
||||
x_putc(int c)
|
||||
#endif
|
||||
{
|
||||
/* this uses \n as an indicator of record-end */
|
||||
if(c == '\n' && f__recpos < f__hiwater) { /* fseek calls fflush, a loss */
|
||||
#ifndef NON_UNIX_STDIO
|
||||
if(f__cf->_ptr + f__hiwater - f__recpos < buf_end(f__cf))
|
||||
f__cf->_ptr += f__hiwater - f__recpos;
|
||||
else
|
||||
#endif
|
||||
(void) fseek(f__cf, (long)(f__hiwater - f__recpos), SEEK_CUR);
|
||||
}
|
||||
#ifdef OMIT_BLANK_CC
|
||||
if (!f__recpos++ && c == ' ')
|
||||
return c;
|
||||
#else
|
||||
f__recpos++;
|
||||
#endif
|
||||
return putc(c,f__cf);
|
||||
}
|
||||
x_wSL(Void)
|
||||
{
|
||||
(*f__putn)('\n');
|
||||
f__recpos=0;
|
||||
f__cursor = 0;
|
||||
f__hiwater = 0;
|
||||
return(1);
|
||||
}
|
||||
xw_end(Void)
|
||||
{
|
||||
if(f__nonl == 0)
|
||||
(*f__putn)('\n');
|
||||
f__hiwater = f__recpos = f__cursor = 0;
|
||||
return(0);
|
||||
}
|
||||
xw_rev(Void)
|
||||
{
|
||||
if(f__workdone) (*f__putn)('\n');
|
||||
f__hiwater = f__recpos = f__cursor = 0;
|
||||
return(f__workdone=0);
|
||||
}
|
||||
|
||||
#ifdef KR_headers
|
||||
integer s_wsfe(a) cilist *a; /*start*/
|
||||
#else
|
||||
integer s_wsfe(cilist *a) /*start*/
|
||||
#endif
|
||||
{ int n;
|
||||
if(!f__init) f_init();
|
||||
if(n=c_sfe(a)) return(n);
|
||||
f__reading=0;
|
||||
f__sequential=1;
|
||||
f__formatted=1;
|
||||
f__external=1;
|
||||
f__elist=a;
|
||||
f__hiwater = f__cursor=f__recpos=0;
|
||||
f__nonl = 0;
|
||||
f__scale=0;
|
||||
f__fmtbuf=a->cifmt;
|
||||
f__curunit = &f__units[a->ciunit];
|
||||
f__cf=f__curunit->ufd;
|
||||
if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio");
|
||||
f__putn= x_putc;
|
||||
f__doed= w_ed;
|
||||
f__doned= w_ned;
|
||||
f__doend=xw_end;
|
||||
f__dorevert=xw_rev;
|
||||
f__donewrec=x_wSL;
|
||||
fmt_bg();
|
||||
f__cplus=0;
|
||||
f__cblank=f__curunit->ublnk;
|
||||
if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
|
||||
err(a->cierr,errno,"write start");
|
||||
return(0);
|
||||
}
|
36
lib/libI77/wsle.c
Normal file
36
lib/libI77/wsle.c
Normal file
@ -0,0 +1,36 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
#include "lio.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
integer s_wsle(a) cilist *a;
|
||||
#else
|
||||
integer s_wsle(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int n;
|
||||
if(!f__init) f_init();
|
||||
if(n=c_le(a)) return(n);
|
||||
f__reading=0;
|
||||
f__external=1;
|
||||
f__formatted=1;
|
||||
f__putn = t_putc;
|
||||
f__lioproc = l_write;
|
||||
L_len = LINE;
|
||||
f__donewrec = x_wSL;
|
||||
if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
|
||||
err(a->cierr, errno, "list output start");
|
||||
return(0);
|
||||
}
|
||||
|
||||
integer e_wsle(Void)
|
||||
{
|
||||
t_putc('\n');
|
||||
f__recpos=0;
|
||||
if (f__cf == stdout)
|
||||
fflush(stdout);
|
||||
else if (f__cf == stderr)
|
||||
fflush(stderr);
|
||||
return(0);
|
||||
}
|
28
lib/libI77/wsne.c
Normal file
28
lib/libI77/wsne.c
Normal file
@ -0,0 +1,28 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "lio.h"
|
||||
|
||||
integer
|
||||
#ifdef KR_headers
|
||||
s_wsne(a) cilist *a;
|
||||
#else
|
||||
s_wsne(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int n;
|
||||
|
||||
if(!f__init)
|
||||
f_init();
|
||||
if(n=c_le(a))
|
||||
return(n);
|
||||
f__reading=0;
|
||||
f__external=1;
|
||||
f__formatted=1;
|
||||
f__putn = t_putc;
|
||||
L_len = LINE;
|
||||
f__donewrec = x_wSL;
|
||||
if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
|
||||
err(a->cierr, errno, "namelist output start");
|
||||
x_wsne(a);
|
||||
return e_wsle();
|
||||
}
|
68
lib/libI77/xwsne.c
Normal file
68
lib/libI77/xwsne.c
Normal file
@ -0,0 +1,68 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "lio.h"
|
||||
#include "fmt.h"
|
||||
|
||||
static VOID
|
||||
nl_donewrec(Void)
|
||||
{
|
||||
(*f__donewrec)();
|
||||
PUT(' ');
|
||||
}
|
||||
|
||||
#ifdef KR_headers
|
||||
x_wsne(a) cilist *a;
|
||||
#else
|
||||
#include "string.h"
|
||||
|
||||
VOID
|
||||
x_wsne(cilist *a)
|
||||
#endif
|
||||
{
|
||||
Namelist *nl;
|
||||
char *s;
|
||||
Vardesc *v, **vd, **vde;
|
||||
ftnint *number, type;
|
||||
ftnlen *dims;
|
||||
ftnlen size;
|
||||
static ftnint one = 1;
|
||||
extern ftnlen f__typesize[];
|
||||
|
||||
nl = (Namelist *)a->cifmt;
|
||||
PUT('&');
|
||||
for(s = nl->name; *s; s++)
|
||||
PUT(*s);
|
||||
PUT(' ');
|
||||
vd = nl->vars;
|
||||
vde = vd + nl->nvars;
|
||||
while(vd < vde) {
|
||||
v = *vd++;
|
||||
s = v->name;
|
||||
#ifdef No_Extra_Namelist_Newlines
|
||||
if (f__recpos+strlen(s)+2 >= L_len)
|
||||
#endif
|
||||
nl_donewrec();
|
||||
while(*s)
|
||||
PUT(*s++);
|
||||
PUT(' ');
|
||||
PUT('=');
|
||||
number = (dims = v->dims) ? dims + 1 : &one;
|
||||
type = v->type;
|
||||
if (type < 0) {
|
||||
size = -type;
|
||||
type = TYCHAR;
|
||||
}
|
||||
else
|
||||
size = f__typesize[type];
|
||||
l_write(number, v->addr, size, type);
|
||||
if (vd < vde) {
|
||||
if (f__recpos+2 >= L_len)
|
||||
nl_donewrec();
|
||||
PUT(',');
|
||||
PUT(' ');
|
||||
}
|
||||
else if (f__recpos+1 >= L_len)
|
||||
nl_donewrec();
|
||||
}
|
||||
PUT('/');
|
||||
}
|
Loading…
Reference in New Issue
Block a user