mirrors/cosmopolitan
1
0
Fork 0
mirror of https://github.com/jart/cosmopolitan.git synced 2025-09-10 02:33:49 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

Get codebase completely working with LLVM

Browse source 
You can now build Cosmopolitan with Clang:

    make -j8 MODE=llvm
    o/llvm/examples/hello.com

The assembler and linker code is now friendly to LLVM too.
So it's not needed to configure Clang to use binutils under
the hood. If you love LLVM then you can now use pure LLVM.
This commit is contained in:
Justine Tunney 2021-02-08 09:19:00 -08:00
parent 0e36cb3ac4
commit e75ffde09e
4528 changed files with 7776 additions and 11640 deletions
Download patch file Download diff file Expand all files Collapse all files

13
third_party/blas/blas.h vendored
View file

@ -1,13 +0,0 @@
#ifndef COSMOPOLITAN_THIRD_PARTY_BLAS_BLAS_H_
#define COSMOPOLITAN_THIRD_PARTY_BLAS_BLAS_H_
#if !(__ASSEMBLER__ + __LINKER__ + 0)
COSMOPOLITAN_C_START_
int dgemm_(char *transa, char *transb, long *m, long *n, long *k, double *alpha,
double *A /*['N'?k:m][1≤m≤lda]*/, long *lda,
double *B /*['N'?k:n][1≤n≤ldb]*/, long *ldb, double *beta,
double *C /*[n][1≤m≤ldc]*/, long *ldc);
COSMOPOLITAN_C_END_
#endif /* !(__ASSEMBLER__ + __LINKER__ + 0) */
#endif /* COSMOPOLITAN_THIRD_PARTY_BLAS_BLAS_H_ */

56
third_party/blas/blas.mk vendored
View file

@ -1,56 +0,0 @@
#-*-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_BLAS
THIRD_PARTY_BLAS_ARTIFACTS += THIRD_PARTY_BLAS_A
THIRD_PARTY_BLAS = $(THIRD_PARTY_BLAS_A_DEPS) $(THIRD_PARTY_BLAS_A)
THIRD_PARTY_BLAS_A = o/$(MODE)/third_party/blas/blas.a
THIRD_PARTY_BLAS_A_FILES := $(wildcard third_party/blas/*)
THIRD_PARTY_BLAS_A_HDRS = $(filter %.h,$(THIRD_PARTY_BLAS_A_FILES))
THIRD_PARTY_BLAS_A_SRCS_S = $(filter %.S,$(THIRD_PARTY_BLAS_A_FILES))
THIRD_PARTY_BLAS_A_SRCS_C = $(filter %.c,$(THIRD_PARTY_BLAS_A_FILES))
THIRD_PARTY_BLAS_A_SRCS = \
$(THIRD_PARTY_BLAS_A_SRCS_S) \
$(THIRD_PARTY_BLAS_A_SRCS_C)
THIRD_PARTY_BLAS_A_OBJS = \
$(THIRD_PARTY_BLAS_A_SRCS_S:%.S=o/$(MODE)/%.o) \
$(THIRD_PARTY_BLAS_A_SRCS_C:%.c=o/$(MODE)/%.o)
THIRD_PARTY_BLAS_A_CHECKS = \
$(THIRD_PARTY_BLAS_A).pkg \
$(THIRD_PARTY_BLAS_A_HDRS:%=o/$(MODE)/%.ok)
THIRD_PARTY_BLAS_A_DIRECTDEPS = \
LIBC_INTRIN \
LIBC_NEXGEN32E \
LIBC_STUBS \
THIRD_PARTY_F2C
THIRD_PARTY_BLAS_A_DEPS := \
$(call uniq,$(foreach x,$(THIRD_PARTY_BLAS_A_DIRECTDEPS),$($(x))))
$(THIRD_PARTY_BLAS_A_OBJS): \
OVERRIDE_CFLAGS += \
$(MATHEMATICAL)
$(THIRD_PARTY_BLAS_A): \
third_party/blas/ \
$(THIRD_PARTY_BLAS_A).pkg \
$(THIRD_PARTY_BLAS_A_OBJS)
$(THIRD_PARTY_BLAS_A).pkg: \
$(THIRD_PARTY_BLAS_A_OBJS) \
$(foreach x,$(THIRD_PARTY_BLAS_A_DIRECTDEPS),$($(x)_A).pkg)
THIRD_PARTY_BLAS_LIBS = $(foreach x,$(THIRD_PARTY_BLAS_ARTIFACTS),$($(x)))
THIRD_PARTY_BLAS_SRCS = $(foreach x,$(THIRD_PARTY_BLAS_ARTIFACTS),$($(x)_SRCS))
THIRD_PARTY_BLAS_HDRS = $(foreach x,$(THIRD_PARTY_BLAS_ARTIFACTS),$($(x)_HDRS))
THIRD_PARTY_BLAS_CHECKS = $(foreach x,$(THIRD_PARTY_BLAS_ARTIFACTS),$($(x)_CHECKS))
THIRD_PARTY_BLAS_OBJS = $(foreach x,$(THIRD_PARTY_BLAS_ARTIFACTS),$($(x)_OBJS))
$(THIRD_PARTY_BLAS_OBJS): $(BUILD_FILES) third_party/blas/blas.mk
.PHONY: o/$(MODE)/third_party/blas
o/$(MODE)/third_party/blas: $(THIRD_PARTY_BLAS_CHECKS)

384
third_party/blas/dgemm.f vendored
View file

@ -1,384 +0,0 @@
*> \brief \b DGEMM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA,BETA
* INTEGER K,LDA,LDB,LDC,M,N
* CHARACTER TRANSA,TRANSB
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGEMM performs one of the matrix-matrix operations
*>
*> C := alpha*op( A )*op( B ) + beta*C,
*>
*> where op( X ) is one of
*>
*> op( X ) = X or op( X ) = X**T,
*>
*> alpha and beta are scalars, and A, B and C are matrices, with op( A )
*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANSA
*> \verbatim
*> TRANSA is CHARACTER*1
*> On entry, TRANSA specifies the form of op( A ) to be used in
*> the matrix multiplication as follows:
*>
*> TRANSA = 'N' or 'n', op( A ) = A.
*>
*> TRANSA = 'T' or 't', op( A ) = A**T.
*>
*> TRANSA = 'C' or 'c', op( A ) = A**T.
*> \endverbatim
*>
*> \param[in] TRANSB
*> \verbatim
*> TRANSB is CHARACTER*1
*> On entry, TRANSB specifies the form of op( B ) to be used in
*> the matrix multiplication as follows:
*>
*> TRANSB = 'N' or 'n', op( B ) = B.
*>
*> TRANSB = 'T' or 't', op( B ) = B**T.
*>
*> TRANSB = 'C' or 'c', op( B ) = B**T.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of the matrix
*> op( A ) and of the matrix C. M must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of the matrix
*> op( B ) and the number of columns of the matrix C. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> On entry, K specifies the number of columns of the matrix
*> op( A ) and the number of rows of the matrix op( B ). K must
*> be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is
*> k when TRANSA = 'N' or 'n', and is m otherwise.
*> Before entry with TRANSA = 'N' or 'n', the leading m by k
*> part of the array A must contain the matrix A, otherwise
*> the leading k by m part of the array A must contain the
*> matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. When TRANSA = 'N' or 'n' then
*> LDA must be at least max( 1, m ), otherwise LDA must be at
*> least max( 1, k ).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is
*> n when TRANSB = 'N' or 'n', and is k otherwise.
*> Before entry with TRANSB = 'N' or 'n', the leading k by n
*> part of the array B must contain the matrix B, otherwise
*> the leading n by k part of the array B must contain the
*> matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB specifies the first dimension of B as declared
*> in the calling (sub) program. When TRANSB = 'N' or 'n' then
*> LDB must be at least max( 1, k ), otherwise LDB must be at
*> least max( 1, n ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is DOUBLE PRECISION.
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then C need not be set on input.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension ( LDC, N )
*> Before entry, the leading m by n part of the array C must
*> contain the matrix C, except when beta is zero, in which
*> case C need not be set on entry.
*> On exit, the array C is overwritten by the m by n matrix
*> ( alpha*op( A )*op( B ) + beta*C ).
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> On entry, LDC specifies the first dimension of C as declared
*> in the calling (sub) program. LDC must be at least
*> max( 1, m ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup double_blas_level3
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* -- Reference BLAS level3 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER K,LDA,LDB,LDC,M,N
CHARACTER TRANSA,TRANSB
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
LOGICAL NOTA,NOTB
* ..
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
*
* Set NOTA and NOTB as true if A and B respectively are not
* transposed and set NROWA, NCOLA and NROWB as the number of rows
* and columns of A and the number of rows of B respectively.
*
NOTA = LSAME(TRANSA,'N')
NOTB = LSAME(TRANSB,'N')
IF (NOTA) THEN
NROWA = M
NCOLA = K
ELSE
NROWA = K
NCOLA = M
END IF
IF (NOTB) THEN
NROWB = K
ELSE
NROWB = N
END IF
*
* Test the input parameters.
*
INFO = 0
IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND.
+ (.NOT.LSAME(TRANSA,'T'))) THEN
INFO = 1
ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND.
+ (.NOT.LSAME(TRANSB,'T'))) THEN
INFO = 2
ELSE IF (M.LT.0) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (K.LT.0) THEN
INFO = 5
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 8
ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
INFO = 10
ELSE IF (LDC.LT.MAX(1,M)) THEN
INFO = 13
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DGEMM ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
* And if alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (BETA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,M
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,M
C(I,J) = BETA*C(I,J)
30 CONTINUE
40 CONTINUE
END IF
RETURN
END IF
*
* Start the operations.
*
IF (NOTB) THEN
IF (NOTA) THEN
*
* Form C := alpha*A*B + beta*C.
*
DO 90 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 50 I = 1,M
C(I,J) = ZERO
50 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 60 I = 1,M
C(I,J) = BETA*C(I,J)
60 CONTINUE
END IF
DO 80 L = 1,K
TEMP = ALPHA*B(L,J)
DO 70 I = 1,M
C(I,J) = C(I,J) + TEMP*A(I,L)
70 CONTINUE
80 CONTINUE
90 CONTINUE
ELSE
*
* Form C := alpha*A**T*B + beta*C
*
DO 120 J = 1,N
DO 110 I = 1,M
TEMP = ZERO
DO 100 L = 1,K
TEMP = TEMP + A(L,I)*B(L,J)
100 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
110 CONTINUE
120 CONTINUE
END IF
ELSE
IF (NOTA) THEN
*
* Form C := alpha*A*B**T + beta*C
*
DO 170 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 130 I = 1,M
C(I,J) = ZERO
130 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 140 I = 1,M
C(I,J) = BETA*C(I,J)
140 CONTINUE
END IF
DO 160 L = 1,K
TEMP = ALPHA*B(J,L)
DO 150 I = 1,M
C(I,J) = C(I,J) + TEMP*A(I,L)
150 CONTINUE
160 CONTINUE
170 CONTINUE
ELSE
*
* Form C := alpha*A**T*B**T + beta*C
*
DO 200 J = 1,N
DO 190 I = 1,M
TEMP = ZERO
DO 180 L = 1,K
TEMP = TEMP + A(L,I)*B(J,L)
180 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
190 CONTINUE
200 CONTINUE
END IF
END IF
*
RETURN
*
* End of DGEMM .
*
END

155
third_party/blas/lsame.c vendored
View file

@ -1,155 +0,0 @@
/* lsame.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"
/* > \brief \b LSAME */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* Definition: */
/* =========== */
/* LOGICAL FUNCTION LSAME(CA,CB) */
/* .. Scalar Arguments .. */
/* CHARACTER CA,CB */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > LSAME returns .TRUE. if CA is the same letter as CB regardless of */
/* > case. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] CA */
/* > \verbatim */
/* > CA is CHARACTER*1 */
/* > \endverbatim */
/* > */
/* > \param[in] CB */
/* > \verbatim */
/* > CB is CHARACTER*1 */
/* > CA and CB specify the single characters to be compared. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \date December 2016 */
/* > \ingroup aux_blas */
/* ===================================================================== */
logical lsame_(char *ca, char *cb) {
/* System generated locals */
logical ret_val;
/* Local variables */
static integer inta, intb, zcode;
/* -- Reference BLAS level1 routine (version 3.1) -- */
/* -- Reference BLAS is a software package provided by Univ. of Tennessee,
* -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*/
/* December 2016 */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* Test if the characters are equal */
ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
if (ret_val) {
return ret_val;
}
/* Now test for equivalence if both characters are alphabetic. */
zcode = 'Z';
/* Use 'Z' rather than 'A' so that ASCII can be detected on Prime */
/* machines, on which ICHAR returns a value with bit 8 set. */
/* ICHAR('A') on Prime machines returns 193 which is the same as */
/* ICHAR('A') on an EBCDIC machine. */
inta = *(unsigned char *)ca;
intb = *(unsigned char *)cb;
if (zcode == 90 || zcode == 122) {
/* ASCII is assumed - ZCODE is the ASCII code of either lower or */
/* upper case 'Z'. */
if (inta >= 97 && inta <= 122) {
inta += -32;
}
if (intb >= 97 && intb <= 122) {
intb += -32;
}
} else if (zcode == 233 || zcode == 169) {
/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or */
/* upper case 'Z'. */
if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 ||
inta >= 162 && inta <= 169) {
inta += 64;
}
if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 ||
intb >= 162 && intb <= 169) {
intb += 64;
}
} else if (zcode == 218 || zcode == 250) {
/* ASCII is assumed, on Prime machines - ZCODE is the ASCII code */
/* plus 128 of either lower or upper case 'Z'. */
if (inta >= 225 && inta <= 250) {
inta += -32;
}
if (intb >= 225 && intb <= 250) {
intb += -32;
}
}
ret_val = inta == intb;
/* RETURN */
/* End of LSAME */
return ret_val;
} /* lsame_ */

125
third_party/blas/lsame.f vendored
View file

@ -1,125 +0,0 @@
*> \brief \b LSAME
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* LOGICAL FUNCTION LSAME(CA,CB)
*
* .. Scalar Arguments ..
* CHARACTER CA,CB
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> LSAME returns .TRUE. if CA is the same letter as CB regardless of
*> case.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] CA
*> \verbatim
*> CA is CHARACTER*1
*> \endverbatim
*>
*> \param[in] CB
*> \verbatim
*> CB is CHARACTER*1
*> CA and CB specify the single characters to be compared.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup aux_blas
*
* =====================================================================
LOGICAL FUNCTION LSAME(CA,CB)
*
* -- Reference BLAS level1 routine (version 3.1) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER CA,CB
* ..
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC ICHAR
* ..
* .. Local Scalars ..
INTEGER INTA,INTB,ZCODE
* ..
*
* Test if the characters are equal
*
LSAME = CA .EQ. CB
IF (LSAME) RETURN
*
* Now test for equivalence if both characters are alphabetic.
*
ZCODE = ICHAR('Z')
*
* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
* machines, on which ICHAR returns a value with bit 8 set.
* ICHAR('A') on Prime machines returns 193 which is the same as
* ICHAR('A') on an EBCDIC machine.
*
INTA = ICHAR(CA)
INTB = ICHAR(CB)
*
IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN
*
* ASCII is assumed - ZCODE is the ASCII code of either lower or
* upper case 'Z'.
*
IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32
IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32
*
ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN
*
* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
* upper case 'Z'.
*
IF (INTA.GE.129 .AND. INTA.LE.137 .OR.
+ INTA.GE.145 .AND. INTA.LE.153 .OR.
+ INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64
IF (INTB.GE.129 .AND. INTB.LE.137 .OR.
+ INTB.GE.145 .AND. INTB.LE.153 .OR.
+ INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64
*
ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN
*
* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
* plus 128 of either lower or upper case 'Z'.
*
IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32
IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32
END IF
LSAME = INTA .EQ. INTB
*
* RETURN
*
* End of LSAME
*
END

121
third_party/blas/xerbla.c vendored
View file

@ -1,121 +0,0 @@
/* xerbla.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"
/* Table of constant values */
static integer c__1 = 1;
/* > \brief \b XERBLA */
/* =========== DOCUMENTATION =========== */
/* Online html documentation available at */
/* http://www.netlib.org/lapack/explore-html/ */
/* Definition: */
/* =========== */
/* SUBROUTINE XERBLA( SRNAME, INFO ) */
/* .. Scalar Arguments .. */
/* CHARACTER*(*) SRNAME */
/* INTEGER INFO */
/* .. */
/* > \par Purpose: */
/* ============= */
/* > */
/* > \verbatim */
/* > */
/* > XERBLA is an error handler for the LAPACK routines. */
/* > It is called by an LAPACK routine if an input parameter has an */
/* > invalid value. A message is printed and execution stops. */
/* > */
/* > Installers may consider modifying the STOP statement in order to */
/* > call system-specific exception-handling facilities. */
/* > \endverbatim */
/* Arguments: */
/* ========== */
/* > \param[in] SRNAME */
/* > \verbatim */
/* > SRNAME is CHARACTER*(*) */
/* > The name of the routine which called XERBLA. */
/* > \endverbatim */
/* > */
/* > \param[in] INFO */
/* > \verbatim */
/* > INFO is INTEGER */
/* > The position of the invalid parameter in the parameter list */
/* > of the calling routine. */
/* > \endverbatim */
/* Authors: */
/* ======== */
/* > \author Univ. of Tennessee */
/* > \author Univ. of California Berkeley */
/* > \author Univ. of Colorado Denver */
/* > \author NAG Ltd. */
/* > \date December 2016 */
/* > \ingroup aux_blas */
/* ===================================================================== */
/* Subroutine */ int xerbla_(char *srname, integer *info, ftnlen srname_len) {
/* Format strings */
static char fmt_9999[] =
"(\002 ** On entry to \002,a,\002 parameter num"
"ber \002,i2,\002 had \002,\002an illegal value\002)";
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
extern doublereal trmlen_(char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___1 = {0, 6, 0, fmt_9999, 0};
/* -- Reference BLAS level1 routine (version 3.7.0) -- */
/* -- Reference BLAS is a software package provided by Univ. of Tennessee,
* -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*/
/* December 2016 */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Intrinsic Functions .. */
/* INTRINSIC LEN_TRIM */
/* .. */
/* .. Executable Statements .. */
s_wsfe(&io___1);
do_fio(&c__1, srname, (integer)trmlen_(srname, srname_len));
do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
e_wsfe();
s_stop("", (ftnlen)0);
/* End of XERBLA */
return 0;
} /* xerbla_ */

89
third_party/blas/xerbla.f vendored
View file

@ -1,89 +0,0 @@
*> \brief \b XERBLA
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE XERBLA( SRNAME, INFO )
*
* .. Scalar Arguments ..
* CHARACTER*(*) SRNAME
* INTEGER INFO
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> XERBLA is an error handler for the LAPACK routines.
*> It is called by an LAPACK routine if an input parameter has an
*> invalid value. A message is printed and execution stops.
*>
*> Installers may consider modifying the STOP statement in order to
*> call system-specific exception-handling facilities.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SRNAME
*> \verbatim
*> SRNAME is CHARACTER*(*)
*> The name of the routine which called XERBLA.
*> \endverbatim
*>
*> \param[in] INFO
*> \verbatim
*> INFO is INTEGER
*> The position of the invalid parameter in the parameter list
*> of the calling routine.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup aux_blas
*
* =====================================================================
SUBROUTINE XERBLA( SRNAME, INFO )
*
* -- Reference BLAS level1 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER*(*) SRNAME
INTEGER INFO
* ..
*
* =====================================================================
*
* .. Intrinsic Functions ..
* INTRINSIC LEN_TRIM
* ..
* .. Executable Statements ..
*
WRITE( *, FMT = 9999 )SRNAME( 1:TRMLEN( SRNAME ) ), INFO
*
STOP
*
9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ',
$ 'an illegal value' )
*
* End of XERBLA
*
END

2
third_party/chibicc/preprocess.c vendored
View file

@ -889,7 +889,7 @@ static Token *timestamp_macro(Token *tmpl) {
struct stat st;
if (stat(tmpl->file->name, &st) != 0)
return new_str_token("??? ??? ?? ??:??:?? ????", tmpl);
char buf[30];
char buf[64];
ctime_r(&st.st_mtime, buf);
buf[24] = '\0';
return new_str_token(buf, tmpl);

2
third_party/compiler_rt/comprt.S vendored
View file

@ -1,6 +1,6 @@
#include "libc/macros.h"
/ Nop ref this to force pull the license into linkage.
// Nop ref this to force pull the license into linkage.
.section .yoink
huge_compiler_rt_license:
int3

2
third_party/compiler_rt/nexgen32e/chkstk.S vendored
View file

@ -15,7 +15,7 @@
#ifdef __x86_64__
.section .yoink
nop huge_compiler_rt_license
nopl huge_compiler_rt_license(%rip)
.previous
.text

2
third_party/compiler_rt/nexgen32e/chkstk2.S vendored
View file

@ -6,7 +6,7 @@
#ifdef __x86_64__
.section .yoink
nop huge_compiler_rt_license
nopl huge_compiler_rt_license(%rip)
.previous
// _chkstk (_alloca) routine - probe stack between %rsp and (%rsp-%rax) in 4k increments,

2
third_party/compiler_rt/nexgen32e/floatundidf.S vendored
View file

@ -18,7 +18,7 @@
#ifdef __x86_64__
.section .yoink
nop huge_compiler_rt_license
nopl huge_compiler_rt_license(%rip)
.previous
CONST_SECTION

2
third_party/compiler_rt/nexgen32e/floatundisf.S vendored
View file

@ -8,7 +8,7 @@
#ifdef __x86_64__
.section .yoink
nop huge_compiler_rt_license
nopl huge_compiler_rt_license(%rip)
.previous
CONST_SECTION

2
third_party/compiler_rt/nexgen32e/floatundixf.S vendored
View file

@ -8,7 +8,7 @@
#ifdef __x86_64__
.section .yoink
nop huge_compiler_rt_license
nopl huge_compiler_rt_license(%rip)
.previous
CONST_SECTION

2
third_party/dlmalloc/initdlmalloc.S vendored
View file

@ -19,7 +19,7 @@
#include "libc/macros.h"
.source __FILE__
/ Sneak ahead ctor list b/c runtime weakly links malloc.
// Sneak ahead ctor list b/c runtime weakly links malloc.
.init.start 800,_init_dlmalloc
push %rdi
push %rsi

1
third_party/duktape/duktape.mk vendored
View file

@ -34,6 +34,7 @@ THIRD_PARTY_DUKTAPE_A_DIRECTDEPS = \
LIBC_STR \
LIBC_STUBS \
LIBC_TIME \
LIBC_RUNTIME \
LIBC_TINYMATH \
LIBC_UNICODE \
LIBC_NEXGEN32E

2
third_party/duktape/license.S vendored
View file

@ -3,6 +3,6 @@ kDuktapeLicense:
.incbin "third_party/duktape/license.inc"
.type kDuktapeLicense,@object
.globl kDuktapeLicense
.popsection
.previous
.include "libc/disclaimer.inc"

2
third_party/f2c/README.cosmo vendored
View file

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

58
third_party/f2c/close.c vendored
View file

@ -1,58 +0,0 @@
#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
View file

@ -1,41 +0,0 @@
#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
View file

@ -1,221 +0,0 @@
#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
View file

@ -1,18 +0,0 @@
#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
View file

@ -1,198 +0,0 @@
#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_ */

55
third_party/f2c/f2c.mk vendored
View file

@ -1,55 +0,0 @@
#-*-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_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_CALLS \
LIBC_FMT \
LIBC_INTRIN \
LIBC_MEM \
LIBC_NEXGEN32E \
LIBC_RUNTIME \
LIBC_STDIO \
LIBC_STR \
LIBC_STUBS \
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): 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
View file

@ -1,97 +0,0 @@
#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
View file

@ -1,477 +0,0 @@
#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
View file

@ -1,103 +0,0 @@
#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
View file

@ -1,33 +0,0 @@
#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
View file

@ -1,25 +0,0 @@
#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_ */

23
third_party/f2c/i_len.c vendored
View file

@ -1,23 +0,0 @@
/*-*- 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 │
│ │
│ Permission to use, copy, modify, and/or distribute this software for │
│ any purpose with or without fee is hereby granted, provided that the │
│ above copyright notice and this permission notice appear in all copies. │
│ │
│ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL │
│ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED │
│ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE │
│ AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 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. │
╚─────────────────────────────────────────────────────────────────────────────*/
#include "third_party/f2c/f2c.h"
integer i_len(char *s, ftnlen n) {
return n;
}

10
third_party/f2c/internal.h vendored
View file

@ -1,10 +0,0 @@
#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
View file

@ -1,284 +0,0 @@
#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
View file

@ -1,21 +0,0 @@
#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
View file

@ -1,29 +0,0 @@
/* 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
View file

@ -1,21 +0,0 @@
#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
View file

@ -1,36 +0,0 @@
/* 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
View file

@ -1,14 +0,0 @@
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
View file

@ -1,58 +0,0 @@
#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
View file

@ -1,246 +0,0 @@
#include "libc/fmt/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
View file

@ -1,318 +0,0 @@
#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
View file

@ -1,61 +0,0 @@
#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);
}

1
third_party/getopt/getopt.mk vendored
View file

@ -31,6 +31,7 @@ THIRD_PARTY_GETOPT_A_DIRECTDEPS = \
LIBC_NEXGEN32E \
LIBC_STDIO \
LIBC_STR \
LIBC_UNICODE \
LIBC_STUBS
THIRD_PARTY_GETOPT_A_DEPS := \

1
third_party/regex/regex.mk vendored
View file

@ -20,6 +20,7 @@ THIRD_PARTY_REGEX_A_DIRECTDEPS = \
LIBC_INTRIN \
LIBC_MEM \
LIBC_NEXGEN32E \
LIBC_UNICODE \
LIBC_STR \
LIBC_STUBS

6
third_party/stb/idct-sse.S vendored
View file

@ -18,9 +18,9 @@
╚─────────────────────────────────────────────────────────────────────────────*/
#include "libc/macros.h"
/ Computes inverse discrete cosine transform.
/
/ @note used to decode jpeg
// Computes inverse discrete cosine transform.
//
// @note used to decode jpeg
.p2align 4
stbi__idct_simd$sse:
push %rbp

2
third_party/stb/ycbcr-sse2.S vendored
View file

@ -85,7 +85,7 @@ stbi__YCbCr_to_RGB_row$sse2:
7: .short 255,255,255,255,255,255,255,255
.end
/ These should be better but need to get them to work
// These should be better but need to get them to work
3: .short 11485,11485,11485,11485,11485,11485,11485,11485 # J′R m=13 99.964387%
4: .short -11277,-11277,-11277,-11277,-11277,-11277,-11277,-11277 # J′G m=15 99.935941%
5: .short 14516,14516,14516,14516,14516,14516,14516,14516 # J′B m=13 99.947219%

2
third_party/third_party.mk vendored
View file

@ -3,13 +3,11 @@
.PHONY: o/$(MODE)/third_party
o/$(MODE)/third_party: \
o/$(MODE)/third_party/blas \
o/$(MODE)/third_party/chibicc \
o/$(MODE)/third_party/compiler_rt \
o/$(MODE)/third_party/dlmalloc \
o/$(MODE)/third_party/gdtoa \
o/$(MODE)/third_party/duktape \
o/$(MODE)/third_party/f2c \
o/$(MODE)/third_party/getopt \
o/$(MODE)/third_party/lz4cli \
o/$(MODE)/third_party/musl \

2
third_party/xed/x86isa.c vendored
View file

@ -45,12 +45,10 @@ void xed_get_chip_features(struct XedChipFeatures *p, enum XedChip chip) {
p->f[0] = xed_chip_features[chip][0];
p->f[1] = xed_chip_features[chip][1];
p->f[2] = xed_chip_features[chip][2];
p->f[3] = 0;
} else {
p->f[0] = 0;
p->f[1] = 0;
p->f[2] = 0;
p->f[3] = 0;
}
}
}

4
third_party/xed/x86tab.S vendored
View file

@ -18,8 +18,8 @@
╚─────────────────────────────────────────────────────────────────────────────*/
#include "libc/macros.h"
/ Phash tables for instruction length decoding.
/ @see build/rle.py for more context here
// Phash tables for instruction length decoding.
// @see build/rle.py for more context here
.initbss 300,_init_x86tab
xed_prefix_table_bit:

13
third_party/zlib/crc32.c vendored
View file

@ -5,6 +5,7 @@
│ Use of this source code is governed by the BSD-style licenses that can │
│ be found in the third_party/zlib/LICENSE file. │
╚─────────────────────────────────────────────────────────────────────────────*/
#include "libc/bits/weaken.h"
#include "libc/dce.h"
#include "libc/nexgen32e/x86feature.h"
#include "libc/str/str.h"
@ -18,20 +19,22 @@ Copyright 1995-2017 Jean-loup Gailly and Mark Adler\"");
asm(".include \"libc/disclaimer.inc\"");
void crc_reset(struct DeflateState *const s) {
if (X86_HAVE(PCLMUL)) {
crc_fold_init(s);
if (X86_HAVE(PCLMUL) && weaken(crc_fold_init)) {
weaken(crc_fold_init)(s);
return;
}
s->strm->adler = crc32(0L, Z_NULL, 0);
}
void crc_finalize(struct DeflateState *const s) {
if (X86_HAVE(PCLMUL)) s->strm->adler = crc_fold_512to32(s);
if (X86_HAVE(PCLMUL) && weaken(crc_fold_512to32)) {
s->strm->adler = weaken(crc_fold_512to32)(s);
}
}
void copy_with_crc(z_streamp strm, Bytef *dst, long size) {
if (X86_HAVE(PCLMUL)) {
crc_fold_copy(strm->state, dst, strm->next_in, size);
if (X86_HAVE(PCLMUL) && weaken(crc_fold_copy)) {
weaken(crc_fold_copy)(strm->state, dst, strm->next_in, size);
return;
}
memcpy(dst, strm->next_in, size);

4
third_party/zlib/crcfold.c vendored
View file

@ -14,6 +14,8 @@
#include "third_party/zlib/deflate.h"
#include "third_party/zlib/internal.h"
#ifndef __llvm__
asm(".ident\t\"\\n\\n\
zlib » crc32 parallelized folding (zlib License)\\n\
Copyright 2013 Intel Corporation\\n\
@ -477,3 +479,5 @@ unsigned crc_fold_512to32(struct DeflateState *const s) {
return ~crc;
CRC_SAVE(s); /* TODO(jart): wut? */
}
#endif /* __llvm__ */