mirrors/cosmopolitan
1
0
Fork 0
mirror of https://github.com/jart/cosmopolitan.git synced 2025-06-26 22:38:30 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

Initial import

Browse source
This commit is contained in:
Justine Tunney 2020-06-15 07:18:57 -07:00
commit c91b3c5006
14915 changed files with 590219 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

2
third_party/f2c/README.cosmo vendored Normal file
View file

@ -0,0 +1,2 @@
https://www.netlib.org/f2c/
2020-02-14

58
third_party/f2c/close.c vendored Normal file
View file

@ -0,0 +1,58 @@
#include "libc/calls/calls.h"
#include "libc/mem/mem.h"
#include "third_party/f2c/f2c.h"
#include "third_party/f2c/fio.h"
integer f_clos(cllist *a) {
unit *b;
if (a->cunit >= MXUNIT) return (0);
b = &f__units[a->cunit];
if (b->ufd == NULL) goto done;
if (b->uscrtch == 1) goto Delete;
if (!a->csta) 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:
fclose(b->ufd);
if (b->ufnm) {
unlink(b->ufnm); /*SYSDEP*/
free(b->ufnm);
}
}
b->ufd = NULL;
done:
b->uend = 0;
b->ufnm = NULL;
return (0);
}
void f_exit(void) {
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 flush_(void) {
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;
}

41
third_party/f2c/endfile.c vendored Normal file
View file

@ -0,0 +1,41 @@
#include "libc/calls/calls.h"
#include "libc/fmt/fmt.h"
#include "libc/stdio/stdio.h"
#include "third_party/f2c/fio.h"
extern char *f__r_mode[], *f__w_mode[];
integer f_end(alist *a) {
unit *b;
FILE *tf;
if (a->aunit >= MXUNIT || a->aunit < 0) err(a->aerr, 101, "endfile");
b = &f__units[a->aunit];
if (b->ufd == NULL) {
char nbuf[10];
sprintf(nbuf, "fort.%ld", (long)a->aunit);
if (tf = fopen(nbuf, f__w_mode[0])) fclose(tf);
return (0);
}
b->uend = 1;
return (b->useek ? t_runc(a) : 0);
}
int t_runc(alist *a) {
OFF_T loc, len;
unit *b;
int rc;
FILE *bf;
b = &f__units[a->aunit];
if (b->url) return (0); /*don't truncate direct files*/
loc = ftell(bf = b->ufd);
fseek(bf, (OFF_T)0, SEEK_END);
len = ftell(bf);
if (loc >= len || b->useek == 0) return (0);
if (b->urw & 2) fflush(b->ufd); /* necessary on some Linux systems */
rc = ftruncate(fileno(b->ufd), loc);
/* The following FSEEK is unnecessary on some systems, */
/* but should be harmless. */
fseek(b->ufd, (OFF_T)0, SEEK_END);
if (rc) err(a->aerr, 111, "endfile");
return 0;
}

221
third_party/f2c/err.c vendored Normal file
View file

@ -0,0 +1,221 @@
#include "libc/calls/calls.h"
#include "libc/calls/struct/stat.h"
#include "libc/log/log.h"
#include "libc/stdio/stdio.h"
#include "third_party/f2c/f2c.h"
#include "third_party/f2c/fio.h"
#include "third_party/f2c/fmt.h"
extern char *f__r_mode[], *f__w_mode[];
/*global definitions*/
unit f__units[MXUNIT]; /*unit table*/
flag f__init; /*0 on entry, 1 after initializations*/
cilist *f__elist; /*active external io list*/
icilist *f__svic; /*active internal io list*/
flag f__reading; /*1 if reading, 0 if writing*/
flag f__cplus, f__cblank;
const char *f__fmtbuf;
flag f__external; /*1 if external io, 0 if internal */
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*/
OFF_T f__cursor, f__hiwater;
int f__scale;
char *f__icptr;
int (*f__getn)(void); /* for formatted input */
void (*f__putn)(int); /* for formatted output */
int (*f__doed)(struct syl *, char *, ftnlen), (*f__doned)(struct syl *);
int (*f__dorevert)(void), (*f__donewrec)(void), (*f__doend)(void);
/*error messages*/
const 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 */
"non-positive record number", /* 130 */
"nmLbuf overflow" /* 131 */
};
#define MAXERR (sizeof(F_err) / sizeof(char *) + 100)
int f__canseek(FILE *f) /*SYSDEP*/
{
#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 f__fatal(int n, const char *s) {
if (n < 100 && n >= 0)
fprintf(stderr, "error: %s: %m\n", 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 ", (int)(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);
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;
}
int f__nowreading(unit *x) {
OFF_T loc;
int ufmt, urw;
if (x->urw & 1) goto done;
if (!x->ufnm) goto cantread;
ufmt = x->url ? 0 : x->ufmt;
loc = ftell(x->ufd);
urw = 3;
if (!freopen(x->ufnm, f__w_mode[ufmt | 2], x->ufd)) {
urw = 1;
if (!freopen(x->ufnm, f__r_mode[ufmt], x->ufd)) {
cantread:
errno = 126;
return 1;
}
}
fseek(x->ufd, loc, SEEK_SET);
x->urw = urw;
done:
x->uwrt = 0;
return 0;
}
int f__nowwriting(unit *x) {
OFF_T loc;
int ufmt;
if (x->urw & 2) {
if (x->urw & 1) fseek(x->ufd, (OFF_T)0, SEEK_CUR);
goto done;
}
if (!x->ufnm) goto cantwrite;
ufmt = x->url ? 0 : x->ufmt;
if (x->uwrt == 3) { /* just did write, rewind */
if (!(f__cf = x->ufd = freopen(x->ufnm, f__w_mode[ufmt], x->ufd)))
goto cantwrite;
x->urw = 2;
} else {
loc = ftell(x->ufd);
if (!(f__cf = x->ufd = freopen(x->ufnm, f__w_mode[ufmt | 2], x->ufd))) {
x->ufd = NULL;
cantwrite:
errno = 127;
return (1);
}
x->urw = 3;
fseek(x->ufd, loc, SEEK_SET);
}
done:
x->uwrt = 1;
return 0;
}
int err__fl(int f, int m, const char *s) {
if (!f) f__fatal(m, s);
if (f__doend) (*f__doend)();
return errno = m;
}

18
third_party/f2c/exit_.c vendored Normal file
View file

@ -0,0 +1,18 @@
#include "libc/runtime/runtime.h"
#include "third_party/f2c/f2c.h"
#include "third_party/f2c/internal.h"
/**
* This gives the effect of
*
* subroutine exit(rc)
* integer*4 rc
* stop
* end
*
* with the added side effect of supplying rc as the program's exit code.
*/
void exit_(integer *rc) {
f_exit();
exit(*rc);
}

198
third_party/f2c/f2c.h vendored Normal file
View file

@ -0,0 +1,198 @@
#ifndef COSMOPOLITAN_THIRD_PARTY_F2C_F2C_H_
#define COSMOPOLITAN_THIRD_PARTY_F2C_F2C_H_
#if !(__ASSEMBLER__ + __LINKER__ + 0)
COSMOPOLITAN_C_START_
/* f2c.h -- Standard Fortran to C header file */
/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
typedef long int integer;
typedef unsigned long int uinteger;
typedef char *address;
typedef short int shortint;
typedef float real;
typedef double doublereal;
typedef struct {
real r, i;
} complex;
typedef struct {
doublereal r, i;
} doublecomplex;
typedef long int logical;
typedef short int shortlogical;
typedef char logical1;
typedef char integer1;
#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */
typedef long long longint; /* system-dependent */
typedef unsigned long long ulongint; /* system-dependent */
#define qbit_clear(a, b) ((a) & ~((ulongint)1 << (b)))
#define qbit_set(a, b) ((a) | ((ulongint)1 << (b)))
#endif
#define TRUE_ (1)
#define FALSE_ (0)
#ifndef Void
#define Void void
#endif
/* Extern is for use with -E */
#ifndef Extern
#define Extern extern
#endif
/* I/O stuff */
#ifdef f2c_i2
/* for -i2 */
typedef short flag;
typedef short ftnlen;
typedef short ftnint;
#else
typedef long int flag;
typedef long int ftnlen;
typedef long int ftnint;
#endif
/*external read, write*/
typedef struct {
flag cierr;
ftnint ciunit;
flag ciend;
char *cifmt;
ftnint cirec;
} cilist;
/*internal read, write*/
typedef struct {
flag icierr;
char *iciunit;
flag iciend;
char *icifmt;
ftnint icirlen;
ftnint icirnum;
} icilist;
/*open*/
typedef struct {
flag oerr;
ftnint ounit;
char *ofnm;
ftnlen ofnmlen;
char *osta;
char *oacc;
char *ofm;
ftnint orl;
char *oblnk;
} olist;
/*close*/
typedef struct {
flag cerr;
ftnint cunit;
char *csta;
} cllist;
/*rewind, backspace, endfile*/
typedef struct {
flag aerr;
ftnint aunit;
} alist;
/* inquire */
typedef struct {
flag inerr;
ftnint inunit;
char *infile;
ftnlen infilen;
ftnint *inex; /*parameters in standard's order*/
ftnint *inopen;
ftnint *innum;
ftnint *innamed;
char *inname;
ftnlen innamlen;
char *inacc;
ftnlen inacclen;
char *inseq;
ftnlen inseqlen;
char *indir;
ftnlen indirlen;
char *infmt;
ftnlen infmtlen;
char *inform;
ftnint informlen;
char *inunf;
ftnlen inunflen;
ftnint *inrecl;
ftnint *innrec;
char *inblank;
ftnlen inblanklen;
} inlist;
#define VOID void
union Multitype { /* for multiple entry points */
integer1 g;
shortint h;
integer i;
/* longint j; */
real r;
doublereal d;
complex c;
doublecomplex z;
};
typedef union Multitype Multitype;
/*typedef long int Long;*/ /* No longer used; formerly in Namelist */
struct Vardesc { /* for Namelist */
char *name;
char *addr;
ftnlen *dims;
int type;
};
typedef struct Vardesc Vardesc;
struct Namelist {
char *name;
Vardesc **vars;
int nvars;
};
typedef struct Namelist Namelist;
#define abs(x) ((x) >= 0 ? (x) : -(x))
#define dabs(x) (doublereal) abs(x)
#define min(a, b) ((a) <= (b) ? (a) : (b))
#define max(a, b) ((a) >= (b) ? (a) : (b))
#define dmin(a, b) (doublereal) min(a, b)
#define dmax(a, b) (doublereal) max(a, b)
#define bit_test(a, b) ((a) >> (b)&1)
#define bit_clear(a, b) ((a) & ~((uinteger)1 << (b)))
#define bit_set(a, b) ((a) | ((uinteger)1 << (b)))
/* procedure parameter types for -A and -C++ */
#define F2C_proc_par_types 1
typedef int /* Unknown procedure type */ (*U_fp)();
typedef shortint (*J_fp)();
typedef integer (*I_fp)();
typedef real (*R_fp)();
typedef doublereal (*D_fp)(), (*E_fp)();
typedef /* Complex */ VOID (*C_fp)();
typedef /* Double Complex */ VOID (*Z_fp)();
typedef logical (*L_fp)();
typedef shortlogical (*K_fp)();
typedef /* Character */ VOID (*H_fp)();
typedef /* Subroutine */ int (*S_fp)();
/* E_fp is for real functions when -R is not specified */
typedef VOID C_f; /* complex function */
typedef VOID H_f; /* character function */
typedef VOID Z_f; /* double complex function */
typedef doublereal E_f; /* real function with -R not specified */
COSMOPOLITAN_C_END_
#endif /* !(__ASSEMBLER__ + __LINKER__ + 0) */
#endif /* COSMOPOLITAN_THIRD_PARTY_F2C_F2C_H_ */

57
third_party/f2c/f2c.mk vendored Normal file
View file

@ -0,0 +1,57 @@
#-*-mode:makefile-gmake;indent-tabs-mode:t;tab-width:8;coding:utf-8-*-┐
#───vi: set et ft=make ts=8 tw=8 fenc=utf-8 :vi───────────────────────┘
PKGS += THIRD_PARTY_F2C
THIRD_PARTY_F2C_ARTIFACTS += THIRD_PARTY_F2C_A
THIRD_PARTY_F2C = $(THIRD_PARTY_F2C_A_DEPS) $(THIRD_PARTY_F2C_A)
THIRD_PARTY_F2C_A = o/$(MODE)/third_party/f2c/f2c.a
THIRD_PARTY_F2C_A_FILES := $(wildcard third_party/f2c/*)
THIRD_PARTY_F2C_A_HDRS = $(filter %.h,$(THIRD_PARTY_F2C_A_FILES))
THIRD_PARTY_F2C_A_SRCS_C = $(filter %.c,$(THIRD_PARTY_F2C_A_FILES))
THIRD_PARTY_F2C_A_SRCS = \
$(THIRD_PARTY_F2C_A_SRCS_C)
THIRD_PARTY_F2C_A_OBJS = \
$(THIRD_PARTY_F2C_A_SRCS:%=o/$(MODE)/%.zip.o) \
$(THIRD_PARTY_F2C_A_SRCS_C:%.c=o/$(MODE)/%.o)
THIRD_PARTY_F2C_A_CHECKS = \
$(THIRD_PARTY_F2C_A).pkg \
$(THIRD_PARTY_F2C_A_HDRS:%=o/$(MODE)/%.ok)
THIRD_PARTY_F2C_A_DIRECTDEPS = \
LIBC_CONV \
LIBC_CALLS \
LIBC_CALLS_HEFTY \
LIBC_RUNTIME \
LIBC_MEM \
LIBC_FMT \
LIBC_STR \
LIBC_STUBS \
LIBC_STDIO \
LIBC_NEXGEN32E \
LIBC_UNICODE
THIRD_PARTY_F2C_A_DEPS := \
$(call uniq,$(foreach x,$(THIRD_PARTY_F2C_A_DIRECTDEPS),$($(x))))
$(THIRD_PARTY_F2C_A): \
third_party/f2c/ \
$(THIRD_PARTY_F2C_A).pkg \
$(THIRD_PARTY_F2C_A_OBJS)
$(THIRD_PARTY_F2C_A).pkg: \
$(THIRD_PARTY_F2C_A_OBJS) \
$(foreach x,$(THIRD_PARTY_F2C_A_DIRECTDEPS),$($(x)_A).pkg)
THIRD_PARTY_F2C_LIBS = $(foreach x,$(THIRD_PARTY_F2C_ARTIFACTS),$($(x)))
THIRD_PARTY_F2C_SRCS = $(foreach x,$(THIRD_PARTY_F2C_ARTIFACTS),$($(x)_SRCS))
THIRD_PARTY_F2C_HDRS = $(foreach x,$(THIRD_PARTY_F2C_ARTIFACTS),$($(x)_HDRS))
THIRD_PARTY_F2C_CHECKS = $(foreach x,$(THIRD_PARTY_F2C_ARTIFACTS),$($(x)_CHECKS))
THIRD_PARTY_F2C_OBJS = $(foreach x,$(THIRD_PARTY_F2C_ARTIFACTS),$($(x)_OBJS))
$(THIRD_PARTY_F2C_OBJS): $(BUILD_FILES) third_party/f2c/f2c.mk
.PHONY: o/$(MODE)/third_party/f2c
o/$(MODE)/third_party/f2c: $(THIRD_PARTY_F2C_CHECKS)

97
third_party/f2c/fio.h vendored Normal file
View file

@ -0,0 +1,97 @@
#ifndef COSMOPOLITAN_THIRD_PARTY_F2C_LIB_FIO_H_
#define COSMOPOLITAN_THIRD_PARTY_F2C_LIB_FIO_H_
#include "libc/errno.h"
#include "libc/stdio/stdio.h"
#include "third_party/f2c/f2c.h"
#if !(__ASSEMBLER__ + __LINKER__ + 0)
COSMOPOLITAN_C_START_
#ifndef OFF_T
#define OFF_T long
#endif
#ifdef UIOLEN_int
typedef int uiolen;
#else
typedef long uiolen;
#endif
/*units*/
typedef struct {
FILE *ufd; /*0=unconnected*/
char *ufnm;
long uinode;
int udev;
int url; /*0=sequential*/
flag useek; /*true=can backspace, use dir, ...*/
flag ufmt;
flag urw; /* (1 for can read) | (2 for can write) */
flag ublnk;
flag uend;
flag uwrt; /*last io was write*/
flag uscrtch;
} unit;
void x_putc(int);
long f__inode(char *, int *);
void sig_die(const char *, int);
void f__fatal(int, const char *);
int t_runc(alist *);
int f__nowreading(unit *);
int f__nowwriting(unit *);
int fk_open(int, int, ftnint);
int en_fio(void);
void f_init(void);
int t_putc(int);
int x_wSL(void);
void b_char(const char *, char *, ftnlen);
void g_char(const char *, ftnlen, char *);
int c_sfe(cilist *);
int z_rnew(void);
int err__fl(int, int, const char *);
int xrd_SL(void);
int f__putbuf(int);
extern cilist *f__elist; /*active external io list*/
extern flag f__reading, f__external, f__sequential, f__formatted;
extern flag f__init;
extern FILE *f__cf; /*current file*/
extern unit *f__curunit; /*current unit*/
extern unit f__units[];
extern int (*f__doend)(void);
extern int (*f__getn)(void); /* for formatted input */
extern void (*f__putn)(int); /* for formatted output */
extern int (*f__donewrec)(void);
#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 OFF_T f__cursor; /* offset to move to */
extern OFF_T 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)
COSMOPOLITAN_C_END_
#endif /* !(__ASSEMBLER__ + __LINKER__ + 0) */
#endif /* COSMOPOLITAN_THIRD_PARTY_F2C_LIB_FIO_H_ */

477
third_party/f2c/fmt.c vendored Normal file
View file

@ -0,0 +1,477 @@
#include "libc/calls/calls.h"
#include "libc/errno.h"
#include "third_party/f2c/f2c.h"
#include "third_party/f2c/fio.h"
#include "third_party/f2c/fmt.h"
#define SYLMX 300
#define GLITCH '\2'
#define Const const
#define STKSZ 10
#define skip(s) \
while (*s == ' ') s++
/* special quote character for stu */
static struct syl f__syl[SYLMX];
int f__parenlvl, f__pc, f__revloc;
int f__cnt[STKSZ], f__ret[STKSZ], f__cp, f__rp;
flag f__workdone, f__nonl;
static const char *ap_end(const char *s) {
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;
}
static int op_gen(int a, int b, int c, int d) {
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.i[0] = c;
p->p2.i[1] = d;
return (f__pc++);
}
static const char *f_list(const char *);
static const char *gt_num(const char *s, int *n, int n1) {
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) {
if (!n1) s = 0;
*n = n1;
} else
*n = m;
return (s);
}
static const char *f_s(const char *s, int curloc) {
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);
}
static int ne_d(const char *s, const char **p) {
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':
if (!(s = gt_num(s, &n, 0))) {
bad:
*p = 0;
return 1;
}
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)];
sp->p2.s = (char *)s + 1;
s += n;
break;
}
break;
case GLITCH:
case '"':
case '\'':
sp = &f__syl[op_gen(APOS, 0, 0, 0)];
sp->p2.s = (char *)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;
if (!(s = gt_num(s + 1, &n, 0))) goto bad;
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);
}
static int e_d(const char *s, const char **p) {
int i, im, n, w, d, e, found = 0, x = 0;
Const char *sv = s;
s = gt_num(s, &n, 1);
(void)op_gen(STACK, n, 0, 0);
switch (*s++) {
default:
break;
case 'E':
case 'e':
x = 1;
case 'G':
case 'g':
found = 1;
if (!(s = gt_num(s, &w, 0))) {
bad:
*p = 0;
return 1;
}
if (w == 0) break;
if (*s == '.') {
if (!(s = gt_num(s + 1, &d, 0))) goto bad;
} else
d = 0;
if (*s != 'E' && *s != 'e')
(void)op_gen(x == 1 ? E : G, w, d, 0); /* default is Ew.dE2 */
else {
if (!(s = gt_num(s + 1, &e, 0))) goto bad;
(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;
if (!(s = gt_num(s, &w, 0))) goto bad;
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, 1);
if (w == 0) break;
(void)op_gen(AW, w, 0, 0);
break;
}
(void)op_gen(A, 0, 0, 0);
break;
case 'F':
case 'f':
if (!(s = gt_num(s, &w, 0))) goto bad;
found = 1;
if (w == 0) break;
if (*s == '.') {
if (!(s = gt_num(s + 1, &d, 0))) goto bad;
} else
d = 0;
(void)op_gen(F, w, d, 0);
break;
case 'D':
case 'd':
found = 1;
if (!(s = gt_num(s, &w, 0))) goto bad;
if (w == 0) break;
if (*s == '.') {
if (!(s = gt_num(s + 1, &d, 0))) goto bad;
} else
d = 0;
(void)op_gen(D, w, d, 0);
break;
case 'I':
case 'i':
i = I;
im = IM;
finish_I:
if (!(s = gt_num(s, &w, 0))) goto bad;
found = 1;
if (w == 0) break;
if (*s != '.') {
(void)op_gen(i, w, 0, 0);
break;
}
if (!(s = gt_num(s + 1, &d, 0))) goto bad;
(void)op_gen(im, w, d, 0);
break;
}
if (found == 0) {
f__pc--; /*unSTACK*/
*p = sv;
return (0);
}
*p = s;
return (1);
}
static const char *i_tem(const char *s) {
const 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, 1);
if ((curloc = op_gen(STACK, n, 0, 0)) < 0) return (NULL);
return (f_s(s, curloc));
}
static const char *f_list(const char *s) {
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);
}
int pars_f(const char *s) {
f__parenlvl = f__revloc = f__pc = 0;
if (f_s(s, 0) == NULL) {
return (-1);
}
return (0);
}
static int type_f(int n) {
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);
}
int 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;
}

103
third_party/f2c/fmt.h vendored Normal file
View file

@ -0,0 +1,103 @@
#ifndef COSMOPOLITAN_THIRD_PARTY_F2C_FMT_H_
#define COSMOPOLITAN_THIRD_PARTY_F2C_FMT_H_
#include "third_party/f2c/f2c.h"
#include "third_party/f2c/fio.h"
#if !(__ASSEMBLER__ + __LINKER__ + 0)
COSMOPOLITAN_C_START_
#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
struct syl {
int op;
int p1;
union {
int i[2];
char *s;
} p2;
};
typedef union {
real pf;
doublereal pd;
} ufloat;
typedef union {
short is;
signed char ic;
integer il;
#ifdef Allow_TYQUAD
longint ili;
#endif
} Uint;
void fmt_bg(void);
int pars_f(const char *);
int rd_ed(struct syl *, char *, ftnlen);
int rd_ned(struct syl *);
int signbit_f2c(double *);
int w_ed(struct syl *, char *, ftnlen);
int w_ned(struct syl *);
int wrt_E(ufloat *, int, int, int, ftnlen);
int wrt_F(ufloat *, int, int, ftnlen);
int wrt_L(Uint *, int, ftnlen);
extern const char *f__fmtbuf;
extern int (*f__doed)(struct syl *, char *, ftnlen), (*f__doned)(struct syl *);
extern int (*f__dorevert)(void);
extern int f__pc, f__parenlvl, f__revloc;
extern flag f__cblank, f__cplus, f__workdone, f__nonl;
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)
#undef TYQUAD
#ifndef Allow_TYQUAD
#undef longint
#define longint long
#else
#define TYQUAD 14
#endif
char *f__icvt(longint, int *, int *, int);
COSMOPOLITAN_C_END_
#endif /* !(__ASSEMBLER__ + __LINKER__ + 0) */
#endif /* COSMOPOLITAN_THIRD_PARTY_F2C_FMT_H_ */

33
third_party/f2c/fmtlib.c vendored Normal file
View file

@ -0,0 +1,33 @@
#define MAXINTLENGTH 23
#ifndef Allow_TYQUAD
#undef longint
#define longint long
#undef ulongint
#define ulongint unsigned long
#endif
char *f__icvt(longint value, int *ndigit, int *sign, int base) {
static char buf[MAXINTLENGTH + 1];
register int i;
ulongint uvalue;
if (value > 0) {
uvalue = value;
*sign = 0;
} else if (value < 0) {
uvalue = -value;
*sign = 1;
} else {
*sign = 0;
*ndigit = 1;
buf[MAXINTLENGTH - 1] = '0';
return &buf[MAXINTLENGTH - 1];
}
i = MAXINTLENGTH;
do {
buf[--i] = (uvalue % base) + '0';
uvalue /= base;
} while (uvalue > 0);
*ndigit = MAXINTLENGTH - i;
return &buf[i];
}

25
third_party/f2c/fp.h vendored Normal file
View file

@ -0,0 +1,25 @@
#ifndef COSMOPOLITAN_THIRD_PARTY_F2C_FP_H_
#define COSMOPOLITAN_THIRD_PARTY_F2C_FP_H_
#if !(__ASSEMBLER__ + __LINKER__ + 0)
COSMOPOLITAN_C_START_
#include "libc/math.h"
#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 */
/* 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.
*/
/* values that suffice for IEEE double */
#define MAXFRACDIGS 344
#define MAXINTDIGS DBL_MAX_10_EXP
COSMOPOLITAN_C_END_
#endif /* !(__ASSEMBLER__ + __LINKER__ + 0) */
#endif /* COSMOPOLITAN_THIRD_PARTY_F2C_FP_H_ */

24
third_party/f2c/i_len.c vendored Normal file
View file

@ -0,0 +1,24 @@
/*-*- mode:c;indent-tabs-mode:nil;c-basic-offset:2;tab-width:8;coding:utf-8 -*-│
│vi: set net ft=c ts=2 sts=2 sw=2 fenc=utf-8 :vi│
╞══════════════════════════════════════════════════════════════════════════════╡
│ Copyright 2020 Justine Alexandra Roberts Tunney │
│ │
│ This program is free software; you can redistribute it and/or modify │
│ it under the terms of the GNU General Public License as published by │
│ the Free Software Foundation; version 2 of the License. │
│ │
│ This program is distributed in the hope that it will be useful, but │
│ WITHOUT ANY WARRANTY; without even the implied warranty of │
│ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU │
│ General Public License for more details. │
│ │
│ You should have received a copy of the GNU General Public License │
│ along with this program; if not, write to the Free Software │
│ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA │
│ 02110-1301 USA │
╚─────────────────────────────────────────────────────────────────────────────*/
#include "third_party/f2c/f2c.h"
integer i_len(char *s, ftnlen n) {
return n;
}

10
third_party/f2c/internal.h vendored Normal file
View file

@ -0,0 +1,10 @@
#ifndef COSMOPOLITAN_THIRD_PARTY_F2C_INTERNAL_H_
#define COSMOPOLITAN_THIRD_PARTY_F2C_INTERNAL_H_
#if !(__ASSEMBLER__ + __LINKER__ + 0)
COSMOPOLITAN_C_START_
void f_exit(void);
COSMOPOLITAN_C_END_
#endif /* !(__ASSEMBLER__ + __LINKER__ + 0) */
#endif /* COSMOPOLITAN_THIRD_PARTY_F2C_INTERNAL_H_ */

284
third_party/f2c/open.c vendored Normal file
View file

@ -0,0 +1,284 @@
#include "libc/calls/calls.h"
#include "libc/fmt/fmt.h"
#include "libc/mem/mem.h"
#include "libc/stdio/stdio.h"
#include "libc/stdio/temp.h"
#include "libc/str/str.h"
#include "third_party/f2c/f2c.h"
#include "third_party/f2c/fio.h"
#ifdef KR_headers
extern char *malloc();
#ifdef NON_ANSI_STDIO
extern char *mktemp();
#endif
extern integer f_clos();
#define Const /*nothing*/
#else
#define Const const
#undef abs
#undef min
#undef max
#ifdef __cplusplus
extern "C" {
#endif
extern int f__canseek(FILE *);
extern integer f_clos(cllist *);
#endif
#ifdef NON_ANSI_RW_MODES
Const char *f__r_mode[2] = {"r", "r"};
Const char *f__w_mode[4] = {"w", "w", "r+w", "r+w"};
#else
Const char *f__r_mode[2] = {"rb", "r"};
Const char *f__w_mode[4] = {"wb", "w", "r+b", "r+"};
#endif
static char f__buf0[400], *f__buf = f__buf0;
int f__buflen = (int)sizeof(f__buf0);
static void
#ifdef KR_headers
f__bufadj(n, c) int n,
c;
#else
f__bufadj(int n, int c)
#endif
{
unsigned int len;
char *nbuf, *s, *t, *te;
if (f__buf == f__buf0) f__buflen = 1024;
while (f__buflen <= n) f__buflen <<= 1;
len = (unsigned int)f__buflen;
if (len != f__buflen || !(nbuf = (char *)malloc(len)))
f__fatal(113, "malloc failure");
s = nbuf;
t = f__buf;
te = t + c;
while (t < te) *s++ = *t++;
if (f__buf != f__buf0) free(f__buf);
f__buf = nbuf;
}
int
#ifdef KR_headers
f__putbuf(c) int c;
#else
f__putbuf(int c)
#endif
{
char *s, *se;
int n;
if (f__hiwater > f__recpos) f__recpos = f__hiwater;
n = f__recpos + 1;
if (n >= f__buflen) f__bufadj(n, f__recpos);
s = f__buf;
se = s + f__recpos;
if (c) *se++ = c;
*se = 0;
for (;;) {
fputs(s, f__cf);
s += strlen(s);
if (s >= se) break; /* normally happens the first time */
putc(*s++, f__cf);
}
return 0;
}
void
#ifdef KR_headers
x_putc(c)
#else
x_putc(int c)
#endif
{
if (f__recpos >= f__buflen) f__bufadj(f__recpos, f__buflen);
f__buf[f__recpos++] = c;
}
#define opnerr(f, m, s) \
{ \
if (f) \
errno = m; \
else \
opn_err(m, s, a); \
return (m); \
}
static void
#ifdef KR_headers
opn_err(m, s, a) int m;
char *s;
olist *a;
#else
opn_err(int m, const char *s, olist *a)
#endif
{
if (a->ofnm) {
/* supply file name to error message */
if (a->ofnmlen >= f__buflen) f__bufadj((int)a->ofnmlen, 0);
g_char(a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf);
}
f__fatal(m, s);
}
#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;
FILE *tf;
#ifndef NON_UNIX_STDIO
int n;
#endif
f__external = 1;
if (a->ounit >= MXUNIT || a->ounit < 0)
err(a->oerr, 101, "open") if (!f__init) f_init();
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, a->ofnm, (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]) opnerr(a->oerr, 107, "open")
} else
sprintf(buf, "fort.%ld", (long)a->ounit);
b->uscrtch = 0;
b->uend = 0;
b->uwrt = 0;
b->ufd = 0;
b->urw = 3;
switch (a->osta ? *a->osta : 'u') {
case 'o':
case 'O':
#ifdef NON_POSIX_STDIO
if (!(tf = FOPEN(buf, "r"))) opnerr(a->oerr, errno, "open") fclose(tf);
#else
if (access(buf, 0))
opnerr(a->oerr, errno, "open")
#endif
break;
case 's':
case 'S':
b->uscrtch = 1;
#ifdef NON_ANSI_STDIO
(void)strcpy(buf, "tmp.FXXXXXX");
(void)mktemp(buf);
goto replace;
#else
if (!(b->ufd = tmpfile())) opnerr(a->oerr, errno, "open") b->ufnm = 0;
#ifndef NON_UNIX_STDIO
b->uinode = b->udev = -1;
#endif
b->useek = 1;
return 0;
#endif
case 'n':
case 'N':
#ifdef NON_POSIX_STDIO
if ((tf = FOPEN(buf, "r")) || (tf = FOPEN(buf, "a"))) {
fclose(tf);
opnerr(a->oerr, 128, "open")
}
#else
if (!access(buf, 0))
opnerr(a->oerr, 128, "open")
#endif
/* no break */
case 'r': /* Fortran 90 replace option */
case 'R':
#ifdef NON_ANSI_STDIO
replace:
#endif
if (tf = fopen(buf, f__w_mode[0])) fclose(tf);
}
b->ufnm = (char *)malloc((unsigned int)(strlen(buf) + 1));
if (b->ufnm == NULL) opnerr(a->oerr, 113, "no space");
(void)strcpy(b->ufnm, buf);
if ((s = a->oacc) && b->url) ufmt = 0;
if (!(tf = fopen(buf, f__w_mode[ufmt | 2]))) {
if (tf = fopen(buf, f__r_mode[ufmt]))
b->urw = 1;
else if (tf = fopen(buf, f__w_mode[ufmt])) {
b->uwrt = 1;
b->urw = 2;
} else
err(a->oerr, errno, "open");
}
b->useek = f__canseek(b->ufd = tf);
#ifndef NON_UNIX_STDIO
if ((b->uinode = f__inode(buf, &b->udev)) == -1)
opnerr(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))
opnerr(a->oerr, 129, "open");
return (0);
}
int
#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", (long)n);
a.oerr = 1;
a.ounit = n;
a.ofnm = nbuf;
a.ofnmlen = strlen(nbuf);
a.osta = NULL;
a.oacc = (char *)(seq == SEQ ? "s" : "d");
a.ofm = (char *)(fmt == FMT ? "f" : "u");
a.orl = seq == DIR ? 1 : 0;
a.oblnk = NULL;
return (f_open(&a));
}
#ifdef __cplusplus
}
#endif

21
third_party/f2c/s_stop.c vendored Normal file
View file

@ -0,0 +1,21 @@
#include "libc/runtime/runtime.h"
#include "libc/stdio/stdio.h"
#include "third_party/f2c/f2c.h"
#include "third_party/f2c/internal.h"
int s_stop(char *s, ftnlen n) {
int i;
if (n > 0) {
fprintf(stderr, "STOP ");
for (i = 0; i < n; ++i) putc(*s++, stderr);
fprintf(stderr, " statement executed\n");
}
#ifdef NO_ONEXIT
f_exit();
#endif
exit(0);
/* We cannot avoid (useless) compiler diagnostics here: */
/* some compilers complain if there is no return statement, */
/* and others complain that this one cannot be reached. */
return 0; /* NOT REACHED */
}

29
third_party/f2c/sfe.c vendored Normal file
View file

@ -0,0 +1,29 @@
/* sequential formatted external common routines*/
#include "third_party/f2c/fio.h"
#include "third_party/f2c/fmt.h"
integer e_rsfe(Void) {
int n;
n = en_fio();
f__fmtbuf = NULL;
return (n);
}
int c_sfe(cilist *a) /* check */
{
unit *p;
f__curunit = p = &f__units[a->ciunit];
if (a->ciunit >= MXUNIT || a->ciunit < 0) err(a->cierr, 101, "startio");
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) {
int n = en_fio();
f__fmtbuf = NULL;
#ifdef ALWAYS_FLUSH
if (!n && fflush(f__cf)) err(f__elist->cierr, errno, "write end");
#endif
return n;
}

21
third_party/f2c/sig_die.c vendored Normal file
View file

@ -0,0 +1,21 @@
#include "libc/calls/calls.h"
#include "libc/runtime/runtime.h"
#include "libc/stdio/stdio.h"
#include "libc/sysv/consts/sig.h"
#include "third_party/f2c/internal.h"
void sig_die(const char *s, int kill) {
/* print error message, then clear buffers */
fprintf(stderr, "%s\n", s);
if (kill) {
fflush(stderr);
f_exit();
fflush(stderr);
/* now get a core */
signal(SIGIOT, SIG_DFL);
abort();
} else {
f_exit();
exit(1);
}
}

36
third_party/f2c/trmlen.c vendored Normal file
View file

@ -0,0 +1,36 @@
/* trmlen.f -- translated by f2c (version 20191129).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#include "third_party/f2c/f2c.h"
extern void _uninit_f2c(void *, int, long);
extern double _0;
/* Length of character string, excluding trailing blanks */
/* Same thing as LEN_TRIM() */
integer trmlen_(char *t, ftnlen t_len) {
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Parameter: */
for (ret_val = i_len(t, t_len); ret_val >= 1; --ret_val) {
/* L1: */
if (*(unsigned char *)&t[ret_val - 1] != ' ') {
return ret_val;
}
}
ret_val = 1;
return ret_val;
} /* trmlen_ */

14
third_party/f2c/trmlen.f vendored Normal file
View file

@ -0,0 +1,14 @@
c Length of character string, excluding trailing blanks
c Same thing as LEN_TRIM()
integer function trmlen(t)
implicit none
c Parameter:
character t*(*)
do 1 trmlen=LEN(t),1,-1
1 if(t(trmlen:trmlen).ne.' ')RETURN
trmlen=1
end ! of integer function trmlen

58
third_party/f2c/util.c vendored Normal file
View file

@ -0,0 +1,58 @@
#include "libc/calls/calls.h"
#include "libc/calls/struct/stat.h"
#include "third_party/f2c/f2c.h"
VOID
#ifdef KR_headers
#define Const /*nothing*/
g_char(a, alen, b) char *a,
*b;
ftnlen alen;
#else
#define Const const
g_char(const char *a, ftnlen alen, char *b)
#endif
{
Const char *x = a + alen;
char *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(const 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

246
third_party/f2c/wref.c vendored Normal file
View file

@ -0,0 +1,246 @@
#include "libc/conv/conv.h"
#include "libc/fmt/fmt.h"
#include "libc/str/str.h"
#include "third_party/f2c/fmt.h"
#include "third_party/f2c/fp.h"
int wrt_E(ufloat *p, int w, int d, int e, ftnlen len) {
char buf[FMAX + EXPMAXDIGS + 4], *s, *se;
int d1, delta, e1, i, sign, signspace;
double dd;
#ifdef WANT_LEAD_0
int insert0 = 0;
#endif
#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) {
#ifdef SIGNED_ZEROS
if (signbit_f2c(&dd)) signspace = sign = 1;
#endif
dd = 0.; /* avoid -0 */
}
#endif
}
delta = w - (2 /* for the . and the d adjustment above */
+ 2 /* for the E+ */ + signspace + d + e);
#ifdef WANT_LEAD_0
if (f__scale <= 0 && delta > 0) {
delta--;
insert0 = 1;
} else
#endif
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) sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
#else
if (dd)
sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
else
strcpy(se, "+00");
#endif
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) {
#ifdef WANT_LEAD_0
if (insert0) PUT('0');
#endif
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;
}
int wrt_F(ufloat *p, int w, int d, ftnlen len) {
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) {
#ifdef SIGNED_ZEROS
if (signbit_f2c(&x)) sign = 2;
#endif
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
#ifndef WANT_LEAD_0
if (buf[0] == '0' && d) {
++b;
--n;
}
#endif
if (sign == 1) {
/* 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) {
#ifdef WANT_LEAD_0
if (buf[0] == '0' && --n == w)
++b;
else
#endif
{
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;
}
#ifdef __cplusplus
}
#endif

318
third_party/f2c/wrtfmt.c vendored Normal file
View file

@ -0,0 +1,318 @@
#include "third_party/f2c/f2c.h"
#include "third_party/f2c/fio.h"
#include "third_party/f2c/fmt.h"
extern icilist *f__svic;
extern char *f__icptr;
/* shouldn't use fseek because it insists on calling fflush */
/* instead we know too much about stdio */
static int mv_cur(void) {
int cursor = f__cursor;
f__cursor = 0;
if (f__external == 0) {
if (cursor < 0) {
if (f__hiwater < f__recpos) f__hiwater = f__recpos;
f__recpos += cursor;
f__icptr += cursor;
if (f__recpos < 0) err(f__elist->cierr, 110, "left off");
} else if (cursor > 0) {
if (f__recpos + cursor >= f__svic->icirlen)
err(f__elist->cierr, 110, "recend");
if (f__hiwater <= f__recpos)
for (; cursor > 0; cursor--) (*f__putn)(' ');
else if (f__hiwater <= f__recpos + cursor) {
cursor -= f__hiwater - f__recpos;
f__icptr += f__hiwater - f__recpos;
f__recpos = f__hiwater;
for (; cursor > 0; cursor--) (*f__putn)(' ');
} else {
f__icptr += cursor;
f__recpos += cursor;
}
}
return (0);
}
if (cursor > 0) {
if (f__hiwater <= f__recpos)
for (; cursor > 0; cursor--) (*f__putn)(' ');
else if (f__hiwater <= f__recpos + cursor) {
cursor -= f__hiwater - f__recpos;
f__recpos = f__hiwater;
for (; cursor > 0; cursor--) (*f__putn)(' ');
} else {
f__recpos += cursor;
}
} else if (cursor < 0) {
if (cursor + f__recpos < 0) err(f__elist->cierr, 110, "left off");
if (f__hiwater < f__recpos) f__hiwater = f__recpos;
f__recpos += cursor;
}
return (0);
}
static int wrt_Z(Uint *n, int w, int minlen, ftnlen len) {
register char *s, *se;
register int 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 wrt_I(Uint *n, int w, ftnlen len, register int base) {
int ndigit, sign, spare, i;
longint 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 wrt_IM(Uint *n, int w, int m, ftnlen len, int base) {
int ndigit, sign, spare, i, xsign;
longint x;
char *ans;
if (sizeof(integer) == len)
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);
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 wrt_AP(char *s) {
char quote;
int i;
if (f__cursor && (i = mv_cur())) return i;
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 wrt_H(int a, char *s) {
int i;
if (f__cursor && (i = mv_cur())) return i;
while (a--) (*f__putn)(*s++);
return (1);
}
int wrt_L(Uint *n, int len, ftnlen sz) {
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 wrt_A(char *p, ftnlen len) {
while (len-- > 0) (*f__putn)(*p++);
return (0);
}
static int wrt_AW(char *p, int w, ftnlen len) {
while (w > len) {
w--;
(*f__putn)(' ');
}
while (w-- > 0) (*f__putn)(*p++);
return (0);
}
static int wrt_G(ufloat *p, int w, int d, int e, ftnlen len) {
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));
i = 1;
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));
}
int w_ed(struct syl *p, char *ptr, ftnlen len) {
int i;
if (f__cursor && (i = mv_cur())) return i;
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.i[0], 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.i[0], 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.i[0], p->p2.i[1], len));
case G:
case GE:
return (wrt_G((ufloat *)ptr, p->p1, p->p2.i[0], p->p2.i[1], len));
case F:
return (wrt_F((ufloat *)ptr, p->p1, p->p2.i[0], 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.i[0], len));
}
}
int w_ned(struct syl *p) {
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(p->p2.s));
case H:
return (wrt_H(p->p1, p->p2.s));
}
}

61
third_party/f2c/wsfe.c vendored Normal file
View file

@ -0,0 +1,61 @@
#include "third_party/f2c/f2c.h"
#include "third_party/f2c/fio.h"
#include "third_party/f2c/fmt.h"
/*write sequential formatted external*/
int x_wSL(Void) {
int n = f__putbuf('\n');
f__hiwater = f__recpos = f__cursor = 0;
return (n == 0);
}
static int xw_end(Void) {
int n;
if (f__nonl) {
f__putbuf(n = 0);
fflush(f__cf);
} else
n = f__putbuf('\n');
f__hiwater = f__recpos = f__cursor = 0;
return n;
}
static int xw_rev(Void) {
int n = 0;
if (f__workdone) {
n = f__putbuf('\n');
f__workdone = 0;
}
f__hiwater = f__recpos = f__cursor = 0;
return n;
}
/*start*/
integer s_wsfe(cilist *a) {
int n;
if (!f__init) f_init();
f__reading = 0;
f__sequential = 1;
f__formatted = 1;
f__external = 1;
if (n = c_sfe(a)) return (n);
f__elist = a;
f__hiwater = f__cursor = f__recpos = 0;
f__nonl = 0;
f__scale = 0;
f__fmtbuf = a->cifmt;
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);
}