diff options
Diffstat (limited to 'unix/as.ssol')
46 files changed, 3463 insertions, 0 deletions
diff --git a/unix/as.ssol/aclrb.c b/unix/as.ssol/aclrb.c new file mode 100644 index 00000000..8c03c7a1 --- /dev/null +++ b/unix/as.ssol/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n); +} diff --git a/unix/as.ssol/aclrc.c b/unix/as.ssol/aclrc.c new file mode 100644 index 00000000..04e0e19b --- /dev/null +++ b/unix/as.ssol/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/aclrd.c b/unix/as.ssol/aclrd.c new file mode 100644 index 00000000..0cf06b01 --- /dev/null +++ b/unix/as.ssol/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/aclri.c b/unix/as.ssol/aclri.c new file mode 100644 index 00000000..7d5b8ada --- /dev/null +++ b/unix/as.ssol/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/aclrl.c b/unix/as.ssol/aclrl.c new file mode 100644 index 00000000..91f2a0ef --- /dev/null +++ b/unix/as.ssol/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/aclrr.c b/unix/as.ssol/aclrr.c new file mode 100644 index 00000000..0426aa73 --- /dev/null +++ b/unix/as.ssol/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/aclrs.c b/unix/as.ssol/aclrs.c new file mode 100644 index 00000000..b4ff02a4 --- /dev/null +++ b/unix/as.ssol/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/amovc.c b/unix/as.ssol/amovc.c new file mode 100644 index 00000000..4cdcbe97 --- /dev/null +++ b/unix/as.ssol/amovc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/amovd.c b/unix/as.ssol/amovd.c new file mode 100644 index 00000000..caac4d07 --- /dev/null +++ b/unix/as.ssol/amovd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/amovi.c b/unix/as.ssol/amovi.c new file mode 100644 index 00000000..ff61c96d --- /dev/null +++ b/unix/as.ssol/amovi.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/amovl.c b/unix/as.ssol/amovl.c new file mode 100644 index 00000000..751efc7f --- /dev/null +++ b/unix/as.ssol/amovl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/amovr.c b/unix/as.ssol/amovr.c new file mode 100644 index 00000000..f57617bf --- /dev/null +++ b/unix/as.ssol/amovr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/amovs.c b/unix/as.ssol/amovs.c new file mode 100644 index 00000000..ba9ac5e1 --- /dev/null +++ b/unix/as.ssol/amovs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/aclrb.c b/unix/as.ssol/as.ssol/aclrb.c new file mode 100644 index 00000000..8c03c7a1 --- /dev/null +++ b/unix/as.ssol/as.ssol/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n); +} diff --git a/unix/as.ssol/as.ssol/aclrc.c b/unix/as.ssol/as.ssol/aclrc.c new file mode 100644 index 00000000..04e0e19b --- /dev/null +++ b/unix/as.ssol/as.ssol/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/aclrd.c b/unix/as.ssol/as.ssol/aclrd.c new file mode 100644 index 00000000..0cf06b01 --- /dev/null +++ b/unix/as.ssol/as.ssol/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/aclri.c b/unix/as.ssol/as.ssol/aclri.c new file mode 100644 index 00000000..7d5b8ada --- /dev/null +++ b/unix/as.ssol/as.ssol/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/aclrl.c b/unix/as.ssol/as.ssol/aclrl.c new file mode 100644 index 00000000..91f2a0ef --- /dev/null +++ b/unix/as.ssol/as.ssol/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/aclrr.c b/unix/as.ssol/as.ssol/aclrr.c new file mode 100644 index 00000000..0426aa73 --- /dev/null +++ b/unix/as.ssol/as.ssol/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/aclrs.c b/unix/as.ssol/as.ssol/aclrs.c new file mode 100644 index 00000000..b4ff02a4 --- /dev/null +++ b/unix/as.ssol/as.ssol/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/amovc.c b/unix/as.ssol/as.ssol/amovc.c new file mode 100644 index 00000000..ecba2573 --- /dev/null +++ b/unix/as.ssol/as.ssol/amovc.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/amovd.c b/unix/as.ssol/as.ssol/amovd.c new file mode 100644 index 00000000..0cfa8906 --- /dev/null +++ b/unix/as.ssol/as.ssol/amovd.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/amovi.c b/unix/as.ssol/as.ssol/amovi.c new file mode 100644 index 00000000..91bc2060 --- /dev/null +++ b/unix/as.ssol/as.ssol/amovi.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/amovl.c b/unix/as.ssol/as.ssol/amovl.c new file mode 100644 index 00000000..815fd651 --- /dev/null +++ b/unix/as.ssol/as.ssol/amovl.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/amovr.c b/unix/as.ssol/as.ssol/amovr.c new file mode 100644 index 00000000..94522ea6 --- /dev/null +++ b/unix/as.ssol/as.ssol/amovr.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/amovs.c b/unix/as.ssol/as.ssol/amovs.c new file mode 100644 index 00000000..8aa12ae7 --- /dev/null +++ b/unix/as.ssol/as.ssol/amovs.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/bytmov.c b/unix/as.ssol/as.ssol/bytmov.c new file mode 100644 index 00000000..aa43f6d1 --- /dev/null +++ b/unix/as.ssol/as.ssol/bytmov.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + if ((a + *aoff) != (b + *boff)) + memmove ((char *)b + (*boff-1), (char *)a + (*aoff-1), *nbytes); +} diff --git a/unix/as.ssol/as.ssol/enbint.s b/unix/as.ssol/as.ssol/enbint.s new file mode 100644 index 00000000..ad73e9bf --- /dev/null +++ b/unix/as.ssol/as.ssol/enbint.s @@ -0,0 +1,20 @@ + .seg "text" + .global _ieee_enbint + +! _IEEE_ENBINT -- Enable the floating point exceptions indicated by the +! bitmask passed as the only argument. The current bitmask is returned as +! the function value. + +_ieee_enbint: + set 0x0f800000,%o4 + sll %o0,23,%o1 + st %fsr,[%sp+0x44] + ld [%sp+0x44],%o0 + and %o1,%o4,%o1 + andn %o0,%o4,%o2 + or %o1,%o2,%o1 + st %o1,[%sp+0x44] + ld [%sp+0x44],%fsr + and %o0,%o4,%o0 + retl + srl %o0,23,%o0 diff --git a/unix/as.ssol/as.ssol/ieee.gx b/unix/as.ssol/as.ssol/ieee.gx new file mode 100644 index 00000000..4a00c759 --- /dev/null +++ b/unix/as.ssol/as.ssol/ieee.gx @@ -0,0 +1,366 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in <mach.h>. + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +int expon +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemap$t (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmap$t (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmap$t (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +$if (datatype == r) +% real r_quiet_nan +$else +% double precision d_quiet_nan +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + $if (datatype == r) +% ieeenn = r_quiet_NaN() + $else +% ieeenn = d_quiet_NaN() + $endif + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/unix/as.ssol/as.ssol/ieeed.x b/unix/as.ssol/as.ssol/ieeed.x new file mode 100644 index 00000000..391cf8ba --- /dev/null +++ b/unix/as.ssol/as.ssol/ieeed.x @@ -0,0 +1,335 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in <mach.h>. + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +int expon +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapd (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapd (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapd (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% double precision d_quiet_nan + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = d_quiet_NaN() + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/unix/as.ssol/as.ssol/ieeer.x b/unix/as.ssol/as.ssol/ieeer.x new file mode 100644 index 00000000..01815d30 --- /dev/null +++ b/unix/as.ssol/as.ssol/ieeer.x @@ -0,0 +1,335 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in <mach.h>. + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +int expon +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapr (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapr (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapr (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% real r_quiet_nan + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = r_quiet_NaN() + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/unix/as.ssol/as.ssol/oscmd.s b/unix/as.ssol/as.ssol/oscmd.s new file mode 100644 index 00000000..bfa82811 --- /dev/null +++ b/unix/as.ssol/as.ssol/oscmd.s @@ -0,0 +1,369 @@ + .seg "text" ! [internal] + .proc 4 + .global oscmd_ +oscmd_: +!#PROLOGUE# 0 +!#PROLOGUE# 1 + save %sp,-104,%sp + sethi %hi(VAR_SEG1+16),%l0 ! [internal] + or %l0,%lo(VAR_SEG1+16),%l0 ! [internal] + st %i1,[%fp+72] + st %i3,[%fp+80] + call _smark_,1 + mov %l0,%o0 + sethi %hi(L1D168),%o0 + add %o0,%lo(L1D168),%i3 + sethi %hi(L1D169),%o1 + add %l0,16,%o0 + add %o1,%lo(L1D169),%i4 + mov %i4,%o1 + call _salloc_,3 + mov %i3,%o2 + sethi %hi(VAR_SEG1+32),%o2 + ld [%o2+%lo(VAR_SEG1+32)],%l5 + sethi %hi(L1D164),%o3 + add %o3,%lo(L1D164),%i5 + inc 20,%l0 ! [internal] + mov %l0,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-8,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-12,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-16,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + sethi %hi(L1D148),%o0 + call _clstai_,1 + or %o0,%lo(L1D148),%o0 ! [internal] + cmp %o0,1 + be L77048 + nop + ld [%fp+72],%l6 + sethi %hi(_mem_-2),%o5 + or %o5,%lo(_mem_-2),%o5 ! [internal] + sll %l5,1,%o4 + add %o5,%o4,%o7 + mov %o7,%l7 + mov %l7,%o1 + mov %i4,%o2 + call _strpak_,3 + mov %i0,%o0 + ldsh [%l6],%l0 + tst %l0 + bne,a LY14 + sethi %hi(VAR_SEG1+36),%o0 + sethi %hi(VAR_SEG1+36),%l1 + ld [%l1+%lo(VAR_SEG1+36)],%l1 + sethi %hi(_mem_-2),%l3 + or %l3,%lo(_mem_-2),%l3 ! [internal] + sll %l1,1,%i0 + add %l3,%i0,%i0 + sethi %hi(v.16),%o0 + or %o0,%lo(v.16),%o0 ! [internal] + mov %i0,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY13 + ld [%fp+80],%i1 +LY14: ! [internal] + ld [%o0+%lo(VAR_SEG1+36)],%o0 + sethi %hi(_mem_-2),%o2 + sll %o0,1,%o1 + or %o2,%lo(_mem_-2),%o2 ! [internal] + add %o2,%o1,%o3 + mov %o3,%i0 + mov %i0,%o1 + mov %i5,%o2 + call _fmapfn_,3 + mov %l6,%o0 + ld [%fp+80],%i1 +LY13: ! [internal] + call _fnulle_,1 + mov %i2,%o0 + tst %o0 + bne,a LY12 + sethi %hi(VAR_SEG1+20),%o4 + call _fnulle_,1 + mov %i1,%o0 + tst %o0 + be,a LY11 + sethi %hi(VAR_SEG1+20),%l1 + sethi %hi(VAR_SEG1+20),%o4 +LY12: ! [internal] + ld [%o4+%lo(VAR_SEG1+20)],%o4 + sethi %hi(_mem_-2),%o7 + sll %o4,1,%o5 + or %o7,%lo(_mem_-2),%o7 ! [internal] + add %o7,%o5,%l0 + mov %l0,%i3 + sethi %hi(v.17),%o0 + or %o0,%lo(v.17),%o0 ! [internal] + mov %i3,%o1 + call _xmktep_,3 + mov %i5,%o2 + b LY10 + ldsh [%i2],%o0 +LY11: ! [internal] + ld [%l1+%lo(VAR_SEG1+20)],%l1 + sethi %hi(_mem_-2),%l3 + or %l3,%lo(_mem_-2),%l3 ! [internal] + sll %l1,1,%l2 + add %l3,%l2,%l2 + mov %l2,%i3 + sth %g0,[%i3] + ldsh [%i2],%o0 +LY10: ! [internal] + tst %o0 + bne L77021 + sethi %hi(VAR_SEG1+28),%o1 + ld [%o1+%lo(VAR_SEG1+28)],%o1 + sethi %hi(_mem_-2),%o3 + or %o3,%lo(_mem_-2),%o3 ! [internal] + sll %o1,1,%i4 + add %o3,%i4,%i4 + sethi %hi(v.18),%o0 + or %o0,%lo(v.18),%o0 ! [internal] + mov %i4,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY9 + ldsh [%i1],%o1 +L77021: + call _fnulle_,1 + mov %i2,%o0 + tst %o0 + be,a LY8 + sethi %hi(VAR_SEG1+28),%l2 + sethi %hi(VAR_SEG1+28),%o5 + ld [%o5+%lo(VAR_SEG1+28)],%o5 + sethi %hi(_mem_-2),%l0 + or %l0,%lo(_mem_-2),%l0 ! [internal] + sll %o5,1,%o7 + add %l0,%o7,%l1 + mov %i3,%o0 + b LY1 + mov %l1,%i4 +LY8: ! [internal] + ld [%l2+%lo(VAR_SEG1+28)],%l2 + sethi %hi(_mem_-2),%l4 + or %l4,%lo(_mem_-2),%l4 ! [internal] + sll %l2,1,%l3 + add %l4,%l3,%i4 + mov %i2,%o0 +LY1: ! [internal] + mov %i5,%o2 + call _fmapfn_,3 + mov %i4,%o1 + ldsh [%i1],%o1 +LY9: ! [internal] + tst %o1 + bne L77031 + sethi %hi(VAR_SEG1+24),%o2 + ld [%o2+%lo(VAR_SEG1+24)],%o2 + sethi %hi(_mem_-2),%o4 + sll %o2,1,%o3 + or %o4,%lo(_mem_-2),%o4 ! [internal] + add %o4,%o3,%o5 + mov %o5,%i2 + sethi %hi(v.19),%o0 + or %o0,%lo(v.19),%o0 ! [internal] + mov %i2,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY7 + sethi %hi(VAR_SEG1),%o4 +L77031: + call _fnulle_,1 + mov %i1,%o0 + tst %o0 + be,a LY6 + sethi %hi(VAR_SEG1+24),%l3 + sethi %hi(VAR_SEG1+24),%o7 + ld [%o7+%lo(VAR_SEG1+24)],%o7 + sethi %hi(_mem_-2),%l1 + or %l1,%lo(_mem_-2),%l1 ! [internal] + sll %o7,1,%i2 + mov %i3,%o0 + b LY2 + add %l1,%i2,%i2 +LY6: ! [internal] + ld [%l3+%lo(VAR_SEG1+24)],%l3 + sethi %hi(_mem_-2),%o0 + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %l3,1,%l4 + add %o0,%l4,%o1 + mov %o1,%i2 + mov %i1,%o0 +LY2: ! [internal] + mov %i5,%o2 + call _fmapfn_,3 + mov %i2,%o1 + sethi %hi(VAR_SEG1),%o4 +LY7: ! [internal] + or %o4,%lo(VAR_SEG1),%o4 ! [internal] + mov %i2,%o3 + mov %i4,%o2 + mov %i0,%o1 + call _koscmd_,5 + mov %l7,%o0 + ldsh [%i3],%o3 + sethi %hi(VAR_SEG1),%o2 + ld [%o2+%lo(VAR_SEG1)],%i5 + tst %o3 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + call _xerpsh_,0 + nop + call _xfdele_,1 + mov %i3,%o0 + call _xerpop_,0 + nop + tst %o0 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + sethi %hi(L1D54),%o0 + call _erract_,1 + or %o0,%lo(L1D54),%o0 ! [internal] + sethi %hi(_xercom_),%o4 + ld [%o4+%lo(_xercom_)],%o4 + tst %o4 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + b LY5 + sethi %hi(VAR_SEG1),%o0 ! [internal] +L77048: + call _xffluh_,1 + mov %i3,%o0 + sethi %hi(_mem_-2),%o0 ! [internal] + add %l5,1,%l1 + mov %l1,%i2 + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %i2,1,%l3 + mov %l3,%i3 + mov 2,%i5 + inc -2,%i0 + add %i5,%i0,%i0 + add %i3,%o0,%o1 + mov %o0,%o7 + sll %l5,1,%o5 + mov 33,%l0 + sth %l0,[%o5+%o7] + mov %o1,%i3 + mov %i0,%i5 +L77049: + ldsh [%i5],%i4 + tst %i4 + be,a LY4 + sethi %hi(_mem_-2),%o0 ! [internal] + ldsh [%i5],%i0 + cmp %i4,10 + be,a LY4 + sethi %hi(_mem_-2),%o0 ! [internal] + sth %i0,[%i3] + inc %i2 + inc 2,%i5 + b L77049 + inc 2,%i3 +LY4: ! [internal] + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %i2,1,%i2 + mov %i2,%i5 + mov %o0,%o3 + mov 10,%o4 + sth %o4,[%i5+%o3] + add %o0,2,%o5 + sth %g0,[%i5+%o5] + mov %o0,%o1 + sethi %hi(L1D168),%o7 + add %o7,%lo(L1D168),%i5 + sll %l5,1,%l0 + add %o1,%l0,%o1 + call _putlie_,2 + mov %i5,%o0 + call _xffluh_,1 + mov %i5,%o0 + sethi %hi(L1D148),%l1 + add %l1,%lo(L1D148),%i3 + mov 0,%i5 +L77055: + sethi %hi(VAR_SEG1+4),%o1 + or %o1,%lo(VAR_SEG1+4),%o1 ! [internal] + call _getci_,2 + mov %i3,%o0 + cmp %o0,-2 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + sethi %hi(VAR_SEG1+4),%l2 + ld [%l2+%lo(VAR_SEG1+4)],%l2 + cmp %l2,10 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + mov %i5,%o0 + sll %o0,1,%o0 + mov %o0,%o1 + sethi %hi(VAR_SEG1+4),%l3 + ld [%l3+%lo(VAR_SEG1+4)],%l3 + sll %o1,2,%o1 + add %o0,%o1,%o0 + add %l3,-48,%l4 + add %o0,%l4,%o0 + b L77055 + mov %o0,%i5 +LY3: ! [internal] + call _sfree_,1 + or %o0,%lo(VAR_SEG1+16),%o0 ! [internal] + mov %i5,%i3 + sethi %hi(VAR_SEG1),%o0 ! [internal] +LY5: ! [internal] + or %o0,%lo(VAR_SEG1),%o0 ! [internal] + st %i5,[%o0] + st %l5,[%o0+32] + ret + restore %g0,%i3,%o0 + .seg "data" ! [internal] + .common _mem_,8 + .common _xercom_,4 + .align 8 + .align 4 +L1D168: + .word 2 + .align 4 +L1D169: + .word 0x400 + .align 4 +L1D164: + .word 127 + .align 4 +L1D148: + .word 1 + .align 4 +L1D54: + .word 3 + .align 4 +v.16: + .half 0 + .align 4 +v.17: + .word 0x74006d + .word 0x700024 + .word 0x6e0075 + .word 0x6c006c + .skip 2 + .align 4 +v.18: + .skip 2 + .align 4 +v.19: + .skip 2 + .seg "bss" ! [internal] + .align 8 +VAR_SEG1: + .skip 40 diff --git a/unix/as.ssol/as.ssol/zrtadr.s b/unix/as.ssol/as.ssol/zrtadr.s new file mode 100644 index 00000000..22523154 --- /dev/null +++ b/unix/as.ssol/as.ssol/zrtadr.s @@ -0,0 +1,6 @@ + .seg "text" + .global zrtadr_ +zrtadr_: + mov %i7,%o0 + retl + nop diff --git a/unix/as.ssol/as.ssol/zsvjmp.s b/unix/as.ssol/as.ssol/zsvjmp.s new file mode 100644 index 00000000..b4d03439 --- /dev/null +++ b/unix/as.ssol/as.ssol/zsvjmp.s @@ -0,0 +1,32 @@ +!# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +!# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +!# the registers, effecting a call in the context of the procedure which +!# originally called ZSVJMP, but with the new status code. These are Fortran +!# callable procedures. +!# +!# (SUN/UNIX sparc version) + + .seg "text" + .global zsvjmp_ + + !# The following has nothing to do with ZSVJMP, and is included here + !# only because this assembler module is loaded with every process. + !# This code sets the value of the symbol MEM (the Mem common) to zero, + !# setting the origin for IRAF pointers to zero rather than some + !# arbitrary value, and ensuring that the MEM common is aligned for + !# all datatypes as well as page aligned. A further advantage is that + !# references to NULL pointers will cause a memory violation. + + .global _mem_ + _mem_ = 0 + + .proc 0 +zsvjmp_: + st %o1, [%o0] ! save &status in jmpbuf[0] + clr %o2 + st %o2, [%o1] ! zero the value of status + add %o0, 0x4, %o0 + set setjmp, %o1 + jmp %o1 + nop + .seg "data" diff --git a/unix/as.ssol/as.ssol/zsvjmp.s.OLD b/unix/as.ssol/as.ssol/zsvjmp.s.OLD new file mode 100644 index 00000000..7f6bb7eb --- /dev/null +++ b/unix/as.ssol/as.ssol/zsvjmp.s.OLD @@ -0,0 +1,59 @@ +!# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +!# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +!# the registers, effecting a call in the context of the procedure which +!# originally called ZSVJMP, but with the new status code. These are Fortran +!# callable procedures. +!# +!# (SUN/UNIX sparc version) + + .seg "text" + .global _zsvjmp_ + .global _zdojmp_ + + !# The following has nothing to do with ZSVJMP, and is included here + !# only because this assembler module is loaded with every process. + !# This code sets the value of the symbol MEM (the Mem common) to zero, + !# setting the origin for IRAF pointers to zero rather than some + !# arbitrary value, and ensuring that the MEM common is aligned for + !# all datatypes as well as page aligned. A further advantage is that + !# references to NULL pointers will cause a memory violation. + + .global _mem_ + _mem_ = 0 + + !# The following requires a jmpbuf of length at least 6 ints. + .proc 0 +_zsvjmp_: + save %sp, -0x60, %sp + call _sigblock + clr %o0 + st %o0, [%i0 + 0x8] + st %i1, [%i0 + 0x14] + clr %o0 + st %o0, [%i1] + st %i7, [%i0] + st %fp, [%i0 + 0x4] + add %i0, 0xc, %o1 + call _sigstack + clr %o0 + ret + restore %g0, 0x0, %o0 + + .proc 0 +_zdojmp_: + save %sp, -0x40, %sp + ta 0x3 + ld [%i0 + 0x4], %fp + sub %fp, 0x60, %sp + call _sigsetmask + ld [%i0 + 0x8], %o0 + add %i0, 0xc, %o0 + call _sigstack + clr %o1 + ld [%i0 + 0x14], %o0 + ld [%i1], %i1 + st %i1, [%o0] + ld [%i0], %i7 + ret + restore %i1, 0x0, %o0 + .seg "data" diff --git a/unix/as.ssol/as.ssol/zzdebug.c b/unix/as.ssol/as.ssol/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.ssol/as.ssol/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include <stdio.h> +#define import_spp +#define import_kernel +#define import_knames +#include <iraf.h> + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.ssol/bytmov.c b/unix/as.ssol/bytmov.c new file mode 100644 index 00000000..98a08fa4 --- /dev/null +++ b/unix/as.ssol/bytmov.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + memmove ((char *)b + (*boff-1), (char *)a + (*aoff-1), *nbytes); +} diff --git a/unix/as.ssol/enbint.s b/unix/as.ssol/enbint.s new file mode 100644 index 00000000..ad73e9bf --- /dev/null +++ b/unix/as.ssol/enbint.s @@ -0,0 +1,20 @@ + .seg "text" + .global _ieee_enbint + +! _IEEE_ENBINT -- Enable the floating point exceptions indicated by the +! bitmask passed as the only argument. The current bitmask is returned as +! the function value. + +_ieee_enbint: + set 0x0f800000,%o4 + sll %o0,23,%o1 + st %fsr,[%sp+0x44] + ld [%sp+0x44],%o0 + and %o1,%o4,%o1 + andn %o0,%o4,%o2 + or %o1,%o2,%o1 + st %o1,[%sp+0x44] + ld [%sp+0x44],%fsr + and %o0,%o4,%o0 + retl + srl %o0,23,%o0 diff --git a/unix/as.ssol/ieee.gx b/unix/as.ssol/ieee.gx new file mode 100644 index 00000000..fb3e34a4 --- /dev/null +++ b/unix/as.ssol/ieee.gx @@ -0,0 +1,318 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in <mach.h>. + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemap$t (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +$if (datatype == r) +% real r_quiet_nan +$else +% double precision d_quiet_nan +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + $if (datatype == r) +% ieeenn = r_quiet_NaN() + $else +% ieeenn = d_quiet_NaN() + $endif + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/unix/as.ssol/ieeed.x b/unix/as.ssol/ieeed.x new file mode 100644 index 00000000..081b4760 --- /dev/null +++ b/unix/as.ssol/ieeed.x @@ -0,0 +1,287 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in <mach.h>. + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemapd (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% double precision d_quiet_nan + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = d_quiet_NaN() + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/unix/as.ssol/ieeer.x b/unix/as.ssol/ieeer.x new file mode 100644 index 00000000..ab4fee53 --- /dev/null +++ b/unix/as.ssol/ieeer.x @@ -0,0 +1,287 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in <mach.h>. + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemapr (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% real r_quiet_nan + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = r_quiet_NaN() + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/unix/as.ssol/oscmd.s b/unix/as.ssol/oscmd.s new file mode 100644 index 00000000..bfa82811 --- /dev/null +++ b/unix/as.ssol/oscmd.s @@ -0,0 +1,369 @@ + .seg "text" ! [internal] + .proc 4 + .global oscmd_ +oscmd_: +!#PROLOGUE# 0 +!#PROLOGUE# 1 + save %sp,-104,%sp + sethi %hi(VAR_SEG1+16),%l0 ! [internal] + or %l0,%lo(VAR_SEG1+16),%l0 ! [internal] + st %i1,[%fp+72] + st %i3,[%fp+80] + call _smark_,1 + mov %l0,%o0 + sethi %hi(L1D168),%o0 + add %o0,%lo(L1D168),%i3 + sethi %hi(L1D169),%o1 + add %l0,16,%o0 + add %o1,%lo(L1D169),%i4 + mov %i4,%o1 + call _salloc_,3 + mov %i3,%o2 + sethi %hi(VAR_SEG1+32),%o2 + ld [%o2+%lo(VAR_SEG1+32)],%l5 + sethi %hi(L1D164),%o3 + add %o3,%lo(L1D164),%i5 + inc 20,%l0 ! [internal] + mov %l0,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-8,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-12,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-16,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + sethi %hi(L1D148),%o0 + call _clstai_,1 + or %o0,%lo(L1D148),%o0 ! [internal] + cmp %o0,1 + be L77048 + nop + ld [%fp+72],%l6 + sethi %hi(_mem_-2),%o5 + or %o5,%lo(_mem_-2),%o5 ! [internal] + sll %l5,1,%o4 + add %o5,%o4,%o7 + mov %o7,%l7 + mov %l7,%o1 + mov %i4,%o2 + call _strpak_,3 + mov %i0,%o0 + ldsh [%l6],%l0 + tst %l0 + bne,a LY14 + sethi %hi(VAR_SEG1+36),%o0 + sethi %hi(VAR_SEG1+36),%l1 + ld [%l1+%lo(VAR_SEG1+36)],%l1 + sethi %hi(_mem_-2),%l3 + or %l3,%lo(_mem_-2),%l3 ! [internal] + sll %l1,1,%i0 + add %l3,%i0,%i0 + sethi %hi(v.16),%o0 + or %o0,%lo(v.16),%o0 ! [internal] + mov %i0,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY13 + ld [%fp+80],%i1 +LY14: ! [internal] + ld [%o0+%lo(VAR_SEG1+36)],%o0 + sethi %hi(_mem_-2),%o2 + sll %o0,1,%o1 + or %o2,%lo(_mem_-2),%o2 ! [internal] + add %o2,%o1,%o3 + mov %o3,%i0 + mov %i0,%o1 + mov %i5,%o2 + call _fmapfn_,3 + mov %l6,%o0 + ld [%fp+80],%i1 +LY13: ! [internal] + call _fnulle_,1 + mov %i2,%o0 + tst %o0 + bne,a LY12 + sethi %hi(VAR_SEG1+20),%o4 + call _fnulle_,1 + mov %i1,%o0 + tst %o0 + be,a LY11 + sethi %hi(VAR_SEG1+20),%l1 + sethi %hi(VAR_SEG1+20),%o4 +LY12: ! [internal] + ld [%o4+%lo(VAR_SEG1+20)],%o4 + sethi %hi(_mem_-2),%o7 + sll %o4,1,%o5 + or %o7,%lo(_mem_-2),%o7 ! [internal] + add %o7,%o5,%l0 + mov %l0,%i3 + sethi %hi(v.17),%o0 + or %o0,%lo(v.17),%o0 ! [internal] + mov %i3,%o1 + call _xmktep_,3 + mov %i5,%o2 + b LY10 + ldsh [%i2],%o0 +LY11: ! [internal] + ld [%l1+%lo(VAR_SEG1+20)],%l1 + sethi %hi(_mem_-2),%l3 + or %l3,%lo(_mem_-2),%l3 ! [internal] + sll %l1,1,%l2 + add %l3,%l2,%l2 + mov %l2,%i3 + sth %g0,[%i3] + ldsh [%i2],%o0 +LY10: ! [internal] + tst %o0 + bne L77021 + sethi %hi(VAR_SEG1+28),%o1 + ld [%o1+%lo(VAR_SEG1+28)],%o1 + sethi %hi(_mem_-2),%o3 + or %o3,%lo(_mem_-2),%o3 ! [internal] + sll %o1,1,%i4 + add %o3,%i4,%i4 + sethi %hi(v.18),%o0 + or %o0,%lo(v.18),%o0 ! [internal] + mov %i4,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY9 + ldsh [%i1],%o1 +L77021: + call _fnulle_,1 + mov %i2,%o0 + tst %o0 + be,a LY8 + sethi %hi(VAR_SEG1+28),%l2 + sethi %hi(VAR_SEG1+28),%o5 + ld [%o5+%lo(VAR_SEG1+28)],%o5 + sethi %hi(_mem_-2),%l0 + or %l0,%lo(_mem_-2),%l0 ! [internal] + sll %o5,1,%o7 + add %l0,%o7,%l1 + mov %i3,%o0 + b LY1 + mov %l1,%i4 +LY8: ! [internal] + ld [%l2+%lo(VAR_SEG1+28)],%l2 + sethi %hi(_mem_-2),%l4 + or %l4,%lo(_mem_-2),%l4 ! [internal] + sll %l2,1,%l3 + add %l4,%l3,%i4 + mov %i2,%o0 +LY1: ! [internal] + mov %i5,%o2 + call _fmapfn_,3 + mov %i4,%o1 + ldsh [%i1],%o1 +LY9: ! [internal] + tst %o1 + bne L77031 + sethi %hi(VAR_SEG1+24),%o2 + ld [%o2+%lo(VAR_SEG1+24)],%o2 + sethi %hi(_mem_-2),%o4 + sll %o2,1,%o3 + or %o4,%lo(_mem_-2),%o4 ! [internal] + add %o4,%o3,%o5 + mov %o5,%i2 + sethi %hi(v.19),%o0 + or %o0,%lo(v.19),%o0 ! [internal] + mov %i2,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY7 + sethi %hi(VAR_SEG1),%o4 +L77031: + call _fnulle_,1 + mov %i1,%o0 + tst %o0 + be,a LY6 + sethi %hi(VAR_SEG1+24),%l3 + sethi %hi(VAR_SEG1+24),%o7 + ld [%o7+%lo(VAR_SEG1+24)],%o7 + sethi %hi(_mem_-2),%l1 + or %l1,%lo(_mem_-2),%l1 ! [internal] + sll %o7,1,%i2 + mov %i3,%o0 + b LY2 + add %l1,%i2,%i2 +LY6: ! [internal] + ld [%l3+%lo(VAR_SEG1+24)],%l3 + sethi %hi(_mem_-2),%o0 + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %l3,1,%l4 + add %o0,%l4,%o1 + mov %o1,%i2 + mov %i1,%o0 +LY2: ! [internal] + mov %i5,%o2 + call _fmapfn_,3 + mov %i2,%o1 + sethi %hi(VAR_SEG1),%o4 +LY7: ! [internal] + or %o4,%lo(VAR_SEG1),%o4 ! [internal] + mov %i2,%o3 + mov %i4,%o2 + mov %i0,%o1 + call _koscmd_,5 + mov %l7,%o0 + ldsh [%i3],%o3 + sethi %hi(VAR_SEG1),%o2 + ld [%o2+%lo(VAR_SEG1)],%i5 + tst %o3 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + call _xerpsh_,0 + nop + call _xfdele_,1 + mov %i3,%o0 + call _xerpop_,0 + nop + tst %o0 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + sethi %hi(L1D54),%o0 + call _erract_,1 + or %o0,%lo(L1D54),%o0 ! [internal] + sethi %hi(_xercom_),%o4 + ld [%o4+%lo(_xercom_)],%o4 + tst %o4 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + b LY5 + sethi %hi(VAR_SEG1),%o0 ! [internal] +L77048: + call _xffluh_,1 + mov %i3,%o0 + sethi %hi(_mem_-2),%o0 ! [internal] + add %l5,1,%l1 + mov %l1,%i2 + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %i2,1,%l3 + mov %l3,%i3 + mov 2,%i5 + inc -2,%i0 + add %i5,%i0,%i0 + add %i3,%o0,%o1 + mov %o0,%o7 + sll %l5,1,%o5 + mov 33,%l0 + sth %l0,[%o5+%o7] + mov %o1,%i3 + mov %i0,%i5 +L77049: + ldsh [%i5],%i4 + tst %i4 + be,a LY4 + sethi %hi(_mem_-2),%o0 ! [internal] + ldsh [%i5],%i0 + cmp %i4,10 + be,a LY4 + sethi %hi(_mem_-2),%o0 ! [internal] + sth %i0,[%i3] + inc %i2 + inc 2,%i5 + b L77049 + inc 2,%i3 +LY4: ! [internal] + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %i2,1,%i2 + mov %i2,%i5 + mov %o0,%o3 + mov 10,%o4 + sth %o4,[%i5+%o3] + add %o0,2,%o5 + sth %g0,[%i5+%o5] + mov %o0,%o1 + sethi %hi(L1D168),%o7 + add %o7,%lo(L1D168),%i5 + sll %l5,1,%l0 + add %o1,%l0,%o1 + call _putlie_,2 + mov %i5,%o0 + call _xffluh_,1 + mov %i5,%o0 + sethi %hi(L1D148),%l1 + add %l1,%lo(L1D148),%i3 + mov 0,%i5 +L77055: + sethi %hi(VAR_SEG1+4),%o1 + or %o1,%lo(VAR_SEG1+4),%o1 ! [internal] + call _getci_,2 + mov %i3,%o0 + cmp %o0,-2 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + sethi %hi(VAR_SEG1+4),%l2 + ld [%l2+%lo(VAR_SEG1+4)],%l2 + cmp %l2,10 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + mov %i5,%o0 + sll %o0,1,%o0 + mov %o0,%o1 + sethi %hi(VAR_SEG1+4),%l3 + ld [%l3+%lo(VAR_SEG1+4)],%l3 + sll %o1,2,%o1 + add %o0,%o1,%o0 + add %l3,-48,%l4 + add %o0,%l4,%o0 + b L77055 + mov %o0,%i5 +LY3: ! [internal] + call _sfree_,1 + or %o0,%lo(VAR_SEG1+16),%o0 ! [internal] + mov %i5,%i3 + sethi %hi(VAR_SEG1),%o0 ! [internal] +LY5: ! [internal] + or %o0,%lo(VAR_SEG1),%o0 ! [internal] + st %i5,[%o0] + st %l5,[%o0+32] + ret + restore %g0,%i3,%o0 + .seg "data" ! [internal] + .common _mem_,8 + .common _xercom_,4 + .align 8 + .align 4 +L1D168: + .word 2 + .align 4 +L1D169: + .word 0x400 + .align 4 +L1D164: + .word 127 + .align 4 +L1D148: + .word 1 + .align 4 +L1D54: + .word 3 + .align 4 +v.16: + .half 0 + .align 4 +v.17: + .word 0x74006d + .word 0x700024 + .word 0x6e0075 + .word 0x6c006c + .skip 2 + .align 4 +v.18: + .skip 2 + .align 4 +v.19: + .skip 2 + .seg "bss" ! [internal] + .align 8 +VAR_SEG1: + .skip 40 diff --git a/unix/as.ssol/zrtadr.s b/unix/as.ssol/zrtadr.s new file mode 100644 index 00000000..22523154 --- /dev/null +++ b/unix/as.ssol/zrtadr.s @@ -0,0 +1,6 @@ + .seg "text" + .global zrtadr_ +zrtadr_: + mov %i7,%o0 + retl + nop diff --git a/unix/as.ssol/zsvjmp.s b/unix/as.ssol/zsvjmp.s new file mode 100644 index 00000000..b4d03439 --- /dev/null +++ b/unix/as.ssol/zsvjmp.s @@ -0,0 +1,32 @@ +!# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +!# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +!# the registers, effecting a call in the context of the procedure which +!# originally called ZSVJMP, but with the new status code. These are Fortran +!# callable procedures. +!# +!# (SUN/UNIX sparc version) + + .seg "text" + .global zsvjmp_ + + !# The following has nothing to do with ZSVJMP, and is included here + !# only because this assembler module is loaded with every process. + !# This code sets the value of the symbol MEM (the Mem common) to zero, + !# setting the origin for IRAF pointers to zero rather than some + !# arbitrary value, and ensuring that the MEM common is aligned for + !# all datatypes as well as page aligned. A further advantage is that + !# references to NULL pointers will cause a memory violation. + + .global _mem_ + _mem_ = 0 + + .proc 0 +zsvjmp_: + st %o1, [%o0] ! save &status in jmpbuf[0] + clr %o2 + st %o2, [%o1] ! zero the value of status + add %o0, 0x4, %o0 + set setjmp, %o1 + jmp %o1 + nop + .seg "data" diff --git a/unix/as.ssol/zsvjmp.s.OLD b/unix/as.ssol/zsvjmp.s.OLD new file mode 100644 index 00000000..7f6bb7eb --- /dev/null +++ b/unix/as.ssol/zsvjmp.s.OLD @@ -0,0 +1,59 @@ +!# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +!# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +!# the registers, effecting a call in the context of the procedure which +!# originally called ZSVJMP, but with the new status code. These are Fortran +!# callable procedures. +!# +!# (SUN/UNIX sparc version) + + .seg "text" + .global _zsvjmp_ + .global _zdojmp_ + + !# The following has nothing to do with ZSVJMP, and is included here + !# only because this assembler module is loaded with every process. + !# This code sets the value of the symbol MEM (the Mem common) to zero, + !# setting the origin for IRAF pointers to zero rather than some + !# arbitrary value, and ensuring that the MEM common is aligned for + !# all datatypes as well as page aligned. A further advantage is that + !# references to NULL pointers will cause a memory violation. + + .global _mem_ + _mem_ = 0 + + !# The following requires a jmpbuf of length at least 6 ints. + .proc 0 +_zsvjmp_: + save %sp, -0x60, %sp + call _sigblock + clr %o0 + st %o0, [%i0 + 0x8] + st %i1, [%i0 + 0x14] + clr %o0 + st %o0, [%i1] + st %i7, [%i0] + st %fp, [%i0 + 0x4] + add %i0, 0xc, %o1 + call _sigstack + clr %o0 + ret + restore %g0, 0x0, %o0 + + .proc 0 +_zdojmp_: + save %sp, -0x40, %sp + ta 0x3 + ld [%i0 + 0x4], %fp + sub %fp, 0x60, %sp + call _sigsetmask + ld [%i0 + 0x8], %o0 + add %i0, 0xc, %o0 + call _sigstack + clr %o1 + ld [%i0 + 0x14], %o0 + ld [%i1], %i1 + st %i1, [%o0] + ld [%i0], %i7 + ret + restore %i1, 0x0, %o0 + .seg "data" diff --git a/unix/as.ssol/zzdebug.c b/unix/as.ssol/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.ssol/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include <stdio.h> +#define import_spp +#define import_kernel +#define import_knames +#include <iraf.h> + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} |