Article 2676 of comp.sources.unix:
Path: nntpd.lkg.dec.com!crl.dec.com!crl.dec.com!caen!usenet.cis.ufl.edu!usenet.eel.ufl.edu!news.mathworks.com!uunet!in2.uu.net!news1.digital.com!vixie!vixie!not-for-mail
From: nmm1@cus.cam.ac.uk (Nick Maclaren)
Newsgroups: comp.sources.unix
Subject: v29i023: mvstape - suite of utilities for handling IBM MVS tapes, Part04/09
Date: 4 Aug 1995 15:04:12 -0700
Organization: Vixie Enterprises
Lines: 1698
Sender: vixie@vix.com
Approved: vixie@gw.home.vix.com
Message-ID: <3vu5gs$gka@gw.home.vix.com>
References: <1.807573809.16947@gw.home.vix.com>
NNTP-Posting-Host: gw.home.vix.com

Submitted-By: nmm1@cus.cam.ac.uk (Nick Maclaren)
Posting-Number: Volume 29, Issue 23
Archive-Name: mvstape/part04

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of archive 4 (of 9)."
# Contents:  convtest.c convtest.f iebcopy.c os2.c
# Wrapped by nmm1@ursa.cus.cam.ac.uk on Fri Aug  4 15:43:58 1995
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'convtest.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'convtest.c'\"
else
echo shar: Extracting \"'convtest.c'\" \(11988 characters\)
sed "s/^X//" >'convtest.c' <<'END_OF_FILE'
X/* If the preprocessor symbol KNOTTED_SIGNALS is set, this will skip much of
Xthe REAL*4 conversion testing.  Blame Intel, Microsoft and IBM (probably in
Xthat order).  Note that these kludges assume IEEE-like arithmetic.
X
XNote that it assumes a much larger exponent range for double and long double
Xthan required by ANSI C - as far as I know, this applies to all current
Xarchitectures with the exception of one of the perverser of VAX formats. The
Xsymbol NO_IEEE_OVERFLOW may be set for compilers which gag on overflow at
Xcompile time, but will work only if IEEE limits are the ones in use. */
X
X
X
X#include <errno.h>
X#include <stdio.h>
X#include <stdlib.h>
X#include <signal.h>
X#include <float.h>
X#include <math.h>
X#include "ibmconv.h"
X
X#ifdef KNOTTED_SIGNALS
X#define EXP_LIMIT 100     /* Comfortably less than required by ANSI C */
X#else
X#define EXP_LIMIT 1000    /* Comfortably more than provided by IBM 370 */
X#endif
X
Xextern double range(int maxexp), random(void);
X
X
X
X/* These are static because some compilers generate bad code for very large
Xstack frames. */
X
Xstatic char chara[95], charc[95];
Xstatic short int2a[100], int2c[100];
Xstatic int int4a[100], int4c[100];
Xstatic long int4d[100];
Xstatic float real4a[100], real4c[100];
Xstatic double real8a[100], real8c[100];
Xstatic long double real16a[100], real16c[100];
Xstatic unsigned char charb[95], int2b[2*100], int4b[4*100], real4b[4*100],
X    real8b[8*100], real16b[16*100];
X
X
X
Xint main() {
X    FILE *file;
X    double errmax, x;
X    int i;
X
X    if ((file = fopen("convdata","rb")) == NULL) {
X        fprintf(stderr,"Unable to open input data\n");
X        exit(1);
X    }
X#ifndef KNOTTED_SIGNALS
X    signal(SIGFPE,SIG_IGN);
X#endif
X
X    for (i = 0; i < 95; ++i) chara[i] = " !\"#$%&'()*+,-./0123456789:;<=>?@"
X                "ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz"
X                "{|}~"[i];
X    (void)fread(&i,4,1,file);
X    (void)fread(charb,1,95,file);
X    (void)fread(&i,4,1,file);
X    errno = 0;
X    i = ibm_chars(charb,charc,95);
X    printf("char:  %d, %d\n",i,errno);
X    for (i = 0; i < 95; ++i)
X        if (chara[i] != charc[i]) {
X            fprintf(stderr,"Error in char: %d, %d\n",chara[i],charc[i]);
X            exit(1);
X        }
X    errno = 0;
X    i = ibm_code_page("PHXMVT");
X    printf("phxmvt:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_chars(charb,charc,95);
X    printf("phxmvt:  %d, %d\n",i,errno);
X    for (i = 0; i < 95; ++i)
X        if (chara[i] != charc[i])
X            printf("Difference: %d, %d\n",chara[i],charc[i]);
X    errno = 0;
X    i = ibm_code_page("phx8");
X    printf("phx8:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_chars(charb,charc,95);
X    printf("phx8:  %d, %d\n",i,errno);
X    for (i = 0; i < 95; ++i)
X        if (chara[i] != charc[i]) {
X            fprintf(stderr,"Error in char: %d, %d\n",chara[i],charc[i]);
X            exit(1);
X        }
X    errno = 0;
X    i = ibm_code_page("IBM037");
X    printf("ibm037:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_chars(charb,charc,95);
X    printf("ibm037:  %d, %d\n",i,errno);
X    for (i = 0; i < 95; ++i)
X        if (chara[i] != charc[i])
X            printf("Difference: %d, %d\n",chara[i],charc[i]);
X    errno = 0;
X    i = ibm_code_page("ibm500");
X    printf("ibm500:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_chars(charb,charc,95);
X    printf("ibm500:  %d, %d\n",i,errno);
X    for (i = 0; i < 95; ++i)
X        if (chara[i] != charc[i])
X            printf("Difference: %d, %d\n",chara[i],charc[i]);
X    errno = 0;
X    i = ibm_code_page("phx");
X    printf("phx:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_chars(charb,charc,95);
X    printf("phx:  %d, %d\n",i,errno);
X    for (i = 0; i < 95; ++i)
X        if (chara[i] != charc[i]) {
X            fprintf(stderr,"Error in char: %d, %d\n",chara[i],charc[i]);
X            exit(1);
X        }
X    errno = 0;
X    i = ibm_code_page("IBM999");
X    printf("ibm999:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_chars(charb,charc,0);
X    printf("char[0]:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_chars(charb,charc,-1);
X    printf("char[-1]:  %d, %d\n",i,errno);
X
X    int2a[0] = -32768;
X    int2a[1] = -32767;
X    int2a[2] = -1;
X    int2a[3] = 0;
X    int2a[4] = 1;
X    int2a[5] = 32766;
X    int2a[6] = 32767;
X    for (i = 7; i < 100; ++i) int2a[i] = 65536.0*random()-32768.0;
X    (void)fread(&i,4,1,file);
X    (void)fread(int2b,2,100,file);
X    (void)fread(&i,4,1,file);
X    errno = 0;
X    i = ibm_shorts(int2b,int2c,100);
X    printf("int2:  %d, %d\n",i,errno);
X    for (i = 0; i < 100; ++i)
X        if (int2a[i] != int2c[i]) {
X            fprintf(stderr,"Error in int2: %d, %d\n",int2a[i],int2c[i]);
X            exit(1);
X        }
X    errno = 0;
X    i = ibm_shorts(int2b,int2c,0);
X    printf("int2[0]:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_shorts(int2b,int2c,-1);
X    printf("int2[-1]:  %d, %d\n",i,errno);
X
X    int4a[0] = (-2048)*1048576;
X    int4a[1] = -2147483647;
X    int4a[2] = -1;
X    int4a[3] = 0;
X    int4a[4] = 1;
X    int4a[5] = 2147483646;
X    int4a[6] = 2147483647;
X    for (i = 7; i < 100; ++i) int4a[i] = 4294967296.0*random()-2147483648.0;
X    (void)fread(&i,4,1,file);
X    (void)fread(int4b,4,100,file);
X    (void)fread(&i,4,1,file);
X    errno = 0;
X    i = ibm_ints(int4b,int4c,100);
X    printf("int4:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_longs(int4b,int4d,100);
X    printf("int4:  %d, %d\n",i,errno);
X    for (i = 0; i < 100; ++i)
X        if (int4a[i] != int4c[i] || int4a[i] != int4d[i]) {
X            fprintf(stderr,"Error in int4: %d, %d, %d\n",
X                int4a[i],int4c[i],int4d[i]);
X            exit(1);
X        }
X    errno = 0;
X    i = ibm_ints(int4b,int4c,0);
X    printf("int4[0]:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_ints(int4b,int4c,-1);
X    printf("int4[-1]:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_longs(int4a,(long *)int4b,0);
X    printf("int4[0]:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_longs(int4a,(long *)int4b,-1);
X    printf("int4[-1]:  %d, %d\n",i,errno);
X
X#ifdef KNOTTED_SIGNALS
X    real4a[0] = -1.0e37;
X    real4a[1] = -1.0e37;
X    real4a[2] = -1.0e37;
X    real4a[3] = -1.0e-37;
X    real4a[4] = -1.0e-37;
X    real4a[5] = -1.0e-37;
X    real4a[6] = 0.0;
X    real4a[7] = 1.0e-37;
X    real4a[8] = 1.0e-37;
X    real4a[9] = 1.0e-37;
X    real4a[10] = 1.0e37;
X    real4a[11] = 1.0e37;
X    real4a[12] = 1.0e37;
X#else
X#ifdef NO_IEEE_OVERFLOW
X    real4a[0] = -3.402e38;
X    real4a[1] = -3.402e38;
X#else
X    real4a[0] = -7.237e75;    /* Warning: overflows on IEEE */
X    real4a[1] = -3.403e38;    /* Warning: overflows on IEEE */
X#endif
X    real4a[2] = -3.402e38;
X    real4a[3] = -1.176e-38;
X    real4a[4] = -1.175e-38;    /* Warning: underflows on IEEE */
X    real4a[5] = -5.398e-79;    /* Warning: underflows on IEEE */
X    real4a[6] = 0.0;
X    real4a[7] = 5.398e-79;    /* Warning: underflows on IEEE */
X    real4a[8] = 1.175e-38;    /* Warning: underflows on IEEE */
X    real4a[9] = 1.176e-38;
X    real4a[10] = 3.402e38;
X#ifdef NO_IEEE_OVERFLOW
X    real4a[11] = 3.402e38;
X    real4a[12] = 3.402e38;
X#else
X    real4a[11] = 3.403e38;    /* Warning: overflows on IEEE */
X    real4a[12] = 7.237e75;    /* Warning: overflows on IEEE */
X#endif
X#endif
X    for (i = 13; i < 100; ++i) {
X        x = range(128);
X        real4a[i] = x*(2.0L*random()-1.0L);
X    }
X    (void)fread(&i,4,1,file);
X    (void)fread(real4b,4,100,file);
X    (void)fread(&i,4,1,file);
X    errno = 0;
X    i = ibm_floats(real4b,real4c,100);
X    printf("real4:  %d, %d\n",i,errno);
X    for (i = 0; i < 13; ++i)
X        if (real4a[i] != real4c[i])
X            printf("Difference: %e, %e\n",real4a[i],real4c[i]);
X    errmax = 0.0;
X    for (i = 13; i < 100; ++i) {
X        x = fabs(real4a[i]-real4c[i]);
X        if (real4a[i] != 0.0) x /= fabs(real4a[i]);
X        if (x >= 1.9e-6) {
X#ifdef KNOTTED_SIGNALS
X            if (real4a[i] == 0.0) {
X                printf("Omitting: %e\n",real4c[i]);
X                continue;
X            }
X#endif
X            fprintf(stderr,"Error in real4: %e, %e, %e\n",
X                x,real4a[i],real4c[i]);
X            exit(1);
X        }
X        if (x > errmax) errmax = x;
X    }
X    printf("Maximum error: %e\n",errmax);
X    errno = 0;
X    i = ibm_floats(real4b,real4c,0);
X    printf("real4[0]:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_floats(real4b,real4c,-1);
X    printf("real4[-1]:  %d, %d\n",i,errno);
X
X    real8a[0] = -7.237e75;
X    real8a[1] = -3.403e38;
X    real8a[2] = -3.402e38;
X    real8a[3] = -1.176e-38;
X    real8a[4] = -1.175e-38;
X    real8a[5] = -5.398e-79;
X    real8a[6] = 0.0;
X    real8a[7] = 5.398e-79;
X    real8a[8] = 1.175e-38;
X    real8a[9] = 1.176e-38;
X    real8a[10] = 3.402e38;
X    real8a[11] = 3.403e38;
X    real8a[12] = 7.237e75;
X    for (i = 13; i < 100; ++i) {
X        x = range(252);
X        real8a[i] = x*(2.0*random()-1.0);
X    }
X    (void)fread(&i,4,1,file);
X    (void)fread(real8b,8,100,file);
X    (void)fread(&i,4,1,file);
X    errno = 0;
X    i = ibm_doubles(real8b,real8c,100);
X    printf("real8:  %d, %d\n",i,errno);
X    errmax = 0.0;
X    for (i = 0; i < 100; ++i) {
X        x = fabs(real8a[i]-real8c[i]);
X        if (real8a[i] != 0.0) x /= fabs(real8a[i]);
X        if (x >= 4.4e-16) {
X            fprintf(stderr,"Error in real8: %e, %e, %e\n",
X                x,real8a[i],real8c[i]);
X            exit(1);
X        }
X        if (x > errmax) errmax = x;
X    }
X    printf("Maximum error: %e\n",errmax);
X    errno = 0;
X    i = ibm_doubles(real8b,real8c,0);
X    printf("real8[0]:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_doubles(real8b,real8c,-1);
X    printf("real8[-1]:  %d, %d\n",i,errno);
X
X    real16a[0] = -7.237e75L;
X    real16a[1] = -3.403e38L;
X    real16a[2] = -3.402e38L;
X    real16a[3] = -1.176e-38L;
X    real16a[4] = -1.175e-38L;
X    real16a[5] = -5.398e-79L;
X    real16a[6] = 0.0L;
X    real16a[7] = 5.398e-79L;
X    real16a[8] = 1.175e-38L;
X    real16a[9] = 1.176e-38L;
X    real16a[10] = 3.402e38L;
X    real16a[11] = 3.403e38L;
X    real16a[12] = 7.237e75L;
X    for (i = 13; i < 100; ++i) {
X        x = range(252);
X        x *= random();
X        real16a[i] = x*(2.0L*random()-1.0L);
X    }
X    (void)fread(&i,4,1,file);
X    (void)fread(real16b,16,100,file);
X    (void)fread(&i,4,1,file);
X    errno = 0;
X    i = ibm_long_doubles(real16b,real16c,100);
X    printf("real16:  %d, %d\n",i,errno);
X    errmax = 0.0;
X    for (i = 0; i < 100; ++i) {
X        x = fabs(real16a[i]-real16c[i]);
X        if (real16a[i] != 0.0) x /= fabs(real16a[i]);
X        if (x >= 4.0*LDBL_EPSILON && x >= 1.2e-32) {
X            fprintf(stderr,"Error in real16: %e, %le, %le\n",
X                x,real16a[i],real16c[i]);
X            exit(1);
X        }
X        if (x > errmax) errmax = x;
X    }
X    printf("Maximum error: %e\n",errmax);
X    errno = 0;
X    i = ibm_long_doubles(real16b,real16c,0);
X    printf("real16[0]:  %d, %d\n",i,errno);
X    errno = 0;
X    i = ibm_long_doubles(real16b,real16c,-1);
X    printf("real16[-1]:  %d, %d\n",i,errno);
X
X    printf("All tests passed satisfactorily\n");
X}
X
X
X
Xdouble range (int maxexp) {
X    int i, n;
X    double x, y;
X
X    n = 2*maxexp*random()-maxexp;
X    if (abs(n) > EXP_LIMIT && maxexp < 2*EXP_LIMIT) return 0.0;
X    x = 1.0;
X    y = 2.0;
X    if (n < 0) {
X        n = -n;
X        y = 0.5;
X    }
X    for (i = 0; i < n; ++i) x = x*y;
X    return x;
X}
X
X
X
Xstatic double u[97];
Xstatic int initial = 1, ip, jp;
X
X
X
Xvoid init (void) {
X    int i, j, k, l, m, ii, jj;
X    double s, t;
X
X    i = 12;
X    j = 34;
X    k = 56;
X    l = 78;
X    for (ii = 0; ii < 97; ++ii) {
X        s = 0.0;
X        t = 0.5;
X        for (jj = 0; jj < 50; ++jj) {
X            m = (((i*j)%179)*k)%179;
X            i = j;
X            j = k;
X            k = m;
X            l = (53*l+1)%169;
X            if ((l*m)%64 >= 32) s += t;
X            t *= 0.5;
X        }
X        u[ii] = s;
X    }
X    ip = 96;
X    jp = 32;
X}
X
X
X
Xdouble random (void) {
X    double x;
X
X    if (initial != 0) {
X        initial = 0;
X        init();
X    }
X
X    x = u[ip]-u[jp];
X    if (x < 0.0) x += 1.0;
X    u[ip] = x;
X    if (--ip < 0) ip = 96;
X    if (--jp < 0) jp = 96;
X    return x;
X}
END_OF_FILE
if test 11988 -ne `wc -c <'convtest.c'`; then
    echo shar: \"'convtest.c'\" unpacked with wrong size!
fi
# end of 'convtest.c'
fi
if test -f 'convtest.f' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'convtest.f'\"
else
echo shar: Extracting \"'convtest.f'\" \(12264 characters\)
sed "s/^X//" >'convtest.f' <<'END_OF_FILE'
XC Be warned:  this assumes that the C and Fortran types map in the
XC obvious way; if they don't, chaos will ensue.  This assumption is
XC most likely to be false for long double and REAL*16, which can be
XC locked out in the conversion library.  See convtest.c for more
XC comments.
X
XC The parameter ICHECK should not be changed (it is set to 0 on a
XC 370 to generate the data).  Set KNOTT to 1 if your system has
XC completely broken signal handling - but note that this still
XC assumes ANSI C exponent ranges.  Set NOOVER to 1 if the compiler 
XC dies on floating-point overflow - but note this assumes IEEE-like
XC limits and almost no optimisation!
X
XC It also has the common UNIX non-standard feature of using backslash
XC as an escape.  When working with one of the few standard compilers
XC (e.g. HP's), this must be fixed or otherwise dealt with.
X
X        INTEGER ICHECK, KNOTT, NOOVER, KNIT
X        COMMON KNIT
X        PARAMETER (ICHECK = 1, KNOTT = 0, NOOVER = 0)
X        REAL*8 RANGE, RANDOM, ERRMAX, X
X        CHARACTER*95 PRINT/' !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJ
X     *KLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~'/
X        CHARACTER CHARA(95), CHARB(95), CHARC(95)
X        INTEGER*2 INT2A(100), INT2C(100)
X        INTEGER*4 INT4A(100), INT4C(100)
X        REAL*4 REAL4A(100), REAL4C(100), Y, Z
X        REAL*8 REAL8A(100), REAL8C(100)
X        REAL*16 REAL16A(100), REAL16C(100)
X        CHARACTER INT2B(200), INT4B(400), REAL4B(400), REAL8B(800),
X     *      REAL16B(1600)
X
X        KNIT = KNOTT
X        DO 100 I = 1,95
X  100   CHARA(I) = PRINT(I:I)
X        IF (ICHECK .EQ. 0) THEN
X            OPEN (7,FILE='convdata',FORM='UNFORMATTED')
X            WRITE (7) CHARA
X        ELSE
X            OPEN (7,FILE='convdata',STATUS='OLD',FORM='UNFORMATTED')
X            READ (7) CHARB
X            WRITE (*,*) 'CHAR: ',IBMCHARS(CHARB,CHARC,95)
X            DO 110 I = 1,95
X                IF (CHARA(I) .NE. CHARC(I)) THEN
X                    WRITE (*,*) 'Error in CHAR: ',
X     *                  ICHAR(CHARA(I)),ICHAR(CHARC(I))
X                    STOP
X                END IF
X  110       CONTINUE
X            WRITE (*,*) 'PHXMVT: ',IBMCODEPAGE("PHXMVT")
X            WRITE (*,*) 'PHXMVT: ',IBMCHARS(CHARB,CHARC,95)
X            DO 120 I = 1,95
X                IF (CHARA(I) .NE. CHARC(I))
X     *              WRITE (*,*) 'Difference: ',
X     *                  ICHAR(CHARA(I)),ICHAR(CHARC(I))
X  120       CONTINUE
X            WRITE (*,*) 'PHX8: ',IBMCODEPAGE("phx8")
X            WRITE (*,*) 'PHX8: ',IBMCHARS(CHARB,CHARC,95)
X            DO 130 I = 1,95
X                IF (CHARA(I) .NE. CHARC(I)) THEN
X                    WRITE (*,*) 'Error in CHAR: ',
X     *                  ICHAR(CHARA(I)),ICHAR(CHARC(I))
X                    STOP
X                END IF
X  130       CONTINUE
X            WRITE (*,*) 'IBM037: ',IBMCODEPAGE("IBM037")
X            WRITE (*,*) 'IBM037: ',IBMCHARS(CHARB,CHARC,95)
X            DO 140 I = 1,95
X                IF (CHARA(I) .NE. CHARC(I))
X     *              WRITE (*,*) 'Difference: ',
X     *                  ICHAR(CHARA(I)),ICHAR(CHARC(I))
X  140       CONTINUE
X            WRITE (*,*) 'IBM500: ',IBMCODEPAGE("ibm500")
X            WRITE (*,*) 'IBM500: ',IBMCHARS(CHARB,CHARC,95)
X            DO 150 I = 1,95
X                IF (CHARA(I) .NE. CHARC(I))
X     *              WRITE (*,*) 'Difference: ',
X     *                  ICHAR(CHARA(I)),ICHAR(CHARC(I))
X  150       CONTINUE
X            WRITE (*,*) 'PHX: ',IBMCODEPAGE("PHX")
X            WRITE (*,*) 'PHX: ',IBMCHARS(CHARB,CHARC,95)
X            DO 160 I = 1,95
X                IF (CHARA(I) .NE. CHARC(I)) THEN
X                    WRITE (*,*) 'Error in CHAR: ',
X     *                  ICHAR(CHARA(I)),ICHAR(CHARC(I))
X                    STOP
X                END IF
X  160       CONTINUE
X        END IF
X        WRITE (*,*) 'IBM999: ',IBMCODEPAGE("IBM999")
X        WRITE (*,*) 'CHAR(0): ',IBMCHARS(CHARA,CHARB,0)
X        WRITE (*,*) 'CHAR(-1): ',IBMCHARS(CHARA,CHARB,-1)
X
X        INT2A(1) = -32768
X        INT2A(2) = -32767
X        INT2A(3) = -1
X        INT2A(4) = 0
X        INT2A(5) = 1
X        INT2A(6) = 32766
X        INT2A(7) = 32767
X        DO 200 I = 8,100
X  200   INT2A(I) = 65536.0D0*RANDOM()-32768.0D0
X        IF (ICHECK .EQ. 0) THEN
X            WRITE (7) INT2A
X        ELSE
X            READ (7) INT2B
X            WRITE (*,*) 'INT2: ',IBMINT2S(INT2B,INT2C,100)
X            DO 210 I = 1,100
X                IF (INT2A(I) .NE. INT2C(I)) THEN
X                    WRITE (*,*) 'Error in INT2: ',INT2A(I),INT2C(I)
X                    STOP
X                END IF
X  210       CONTINUE
X        END IF
X        WRITE (*,*) 'INT2(0): ',IBMINT2S(INT2B,INT2C,0)
X        WRITE (*,*) 'INT2(-1): ',IBMINT2S(INT2B,INT2C,-1)
X
X        INT4A(1) = (-2048)*1048576
X        INT4A(2) = -2147483647
X        INT4A(3) = -1
X        INT4A(4) = 0
X        INT4A(5) = 1
X        INT4A(6) = 2147483646
X        INT4A(7) = 2147483647
X        DO 300 I = 8,100
X  300   INT4A(I) = 4294967296.0D0*RANDOM()-2147483648.0D0
X        IF (ICHECK .EQ. 0) THEN
X            WRITE (7) INT4A
X        ELSE
X            READ (7) INT4B
X            WRITE (*,*) 'INT4: ',IBMINT4S(INT4B,INT4C,100)
X            DO 310 I = 1,100
X                IF (INT4A(I) .NE. INT4C(I)) THEN
X                    WRITE (*,*) 'Error in INT4: ',INT4A(I),INT4C(I)
X                    STOP
X                END IF
X  310       CONTINUE
X        END IF
X        WRITE (*,*) 'INT4(0): ',IBMINT4S(INT4B,INT4C,0)
X        WRITE (*,*) 'INT4(-1): ',IBMINT4S(INT4B,INT4C,-1)
X
X        IF (KNOTT .NE. 0) THEN
X            REAL4A(1) = -1.0E37
X            REAL4A(2) = -1.0E37
X            REAL4A(3) = -1.0E37
X            REAL4A(4) = -1.0E-37
X            REAL4A(5) = -1.0E-37
X            REAL4A(6) = -1.0E-37
X            REAL4A(7) = 0.0E0
X            REAL4A(8) = 1.0E-37
X            REAL4A(9) = 1.0E-37
X            REAL4A(10) = 1.0E-37
X            REAL4A(11) = 1.0E37
X            REAL4A(12) = 1.0E37
X            REAL4A(13) = 1.0E37
X        ELSE
X            IF (NOOVER .NE. 0) THEN
X                REAL4A(1) = -3.402E0
X                Y = 1.0E19
X                REAL4A(2) = -3.402E0
X                Z = 1.0E38
X            ELSE
X                REAL4A(1) = -7.237E1
X                Y = 1.0E37
X                REAL4A(2) = -3.403E0
X                Z = 1.0E38
X            END IF
X            REAL4A(1) = REAL4A(1)*Y*Y
X            REAL4A(2) = REAL4A(2)*Z
X            REAL4A(3) = -3.402E38
X            REAL4A(4) = -1.176E-38
X            REAL4A(5) = -1.175E-38
X            REAL4A(6) = -5.398E-79
X            REAL4A(7) = 0.0E0
X            REAL4A(8) = 5.398E-79
X            REAL4A(9) = 1.175E-38
X            REAL4A(10) = 1.176E-38
X            REAL4A(11) = 3.402E38
X            IF (NOOVER .NE. 0) THEN
X                REAL4A(12) = 3.402E0
X                REAL4A(13) = 3.402E0
X            ELSE
X                REAL4A(12) = 3.403E0
X                REAL4A(13) = 7.237E1
X            END IF
X            REAL4A(12) = REAL4A(12)*Y*Y
X            REAL4A(13) = REAL4A(13)*Z
X        END IF
X        DO 400 I = 14,100
X            X = RANGE(128)
X            REAL4A(I) = X*(2.0D0*RANDOM()-1.0D0)
X  400   CONTINUE
X        IF (ICHECK .EQ. 0) THEN
X            WRITE (7) REAL4A
X        ELSE
X            READ (7) REAL4B
X            WRITE (*,*) 'REAL4: ',IBMREAL4S(REAL4B,REAL4C,100)
X            DO 410 I = 1,13
X                IF (REAL4A(I) .NE. REAL4C(I))
X     *              WRITE (*,*) 'Difference:',REAL4A(I),REAL4C(I)
X  410       CONTINUE
X            ERRMAX = 0.0D0
X            DO 420 I = 14,100
X                X = ABS(REAL4A(I)-REAL4C(I))
X                IF (REAL4A(I) .NE. 0.0E0) X = X/ABS(REAL4A(I))
X                IF (X .GT. 1.9E-6) THEN
X                    IF (KNOTT .NE. 0 .AND. REAL4A(I) .EQ. 0.0) THEN
X                        WRITE (*,*) 'Omitting:',REAL4C(I)
X                        GO TO 420
X                    END IF
X                    WRITE (*,*) 'Error in REAL4:',X,REAL4A(I),REAL4C(I)
X                    STOP
X                END IF
X                IF (X .GT. ERRMAX) ERRMAX = X
X  420       CONTINUE
X            WRITE (*,*) 'Maximum error: ',ERRMAX
X        END IF
X        WRITE (*,*) 'REAL4(0): ',IBMREAL4S(REAL4B,REAL4C,0)
X        WRITE (*,*) 'REAL4(-1): ',IBMREAL4S(REAL4B,REAL4C,-1)
X
X        REAL8A(1) = -7.237D75
X        REAL8A(2) = -3.403D38
X        REAL8A(3) = -3.402D38
X        REAL8A(4) = -1.176D-38
X        REAL8A(5) = -1.175D-38
X        REAL8A(6) = -5.398D-79
X        REAL8A(7) = 0.0D0
X        REAL8A(8) = 5.398D-79
X        REAL8A(9) = 1.175D-38
X        REAL8A(10) = 1.176D-38
X        REAL8A(11) = 3.402D38
X        REAL8A(12) = 3.403D38
X        REAL8A(13) = 7.237D75
X        DO 500 I = 14,100
X            X = RANGE(252)
X            REAL8A(I) = X*(2.0D0*RANDOM()-1.0D0)
X  500   CONTINUE
X        IF (ICHECK .EQ. 0) THEN
X            WRITE (7) REAL8A
X        ELSE
X            READ (7) REAL8B
X            WRITE (*,*) 'REAL8: ',IBMREAL8S(REAL8B,REAL8C,100)
X            ERRMAX = 0.0D0
X            DO 510 I = 1,100
X                X = ABS(REAL8A(I)-REAL8C(I))
X                IF (REAL8A(I) .NE. 0.0D0) X = X/ABS(REAL8A(I))
X                IF (X .GT. 4.4D-16) THEN
X                    WRITE (*,*) 'Error in REAL8:',X,REAL8A(I),REAL8C(I)
X                    STOP
X                END IF
X                IF (X .GT. ERRMAX) ERRMAX = X
X  510       CONTINUE
X            WRITE (*,*) 'Maximum error: ',ERRMAX
X        END IF
X        WRITE (*,*) 'REAL8(0): ',IBMREAL8S(REAL8B,REAL8C,0)
X        WRITE (*,*) 'REAL8(-1): ',IBMREAL8S(REAL8B,REAL8C,-1)
X
X        REAL16A(1) = -7.237Q75
X        REAL16A(2) = -3.403Q38
X        REAL16A(3) = -3.402Q38
X        REAL16A(4) = -1.176Q-38
X        REAL16A(5) = -1.175Q-38
X        REAL16A(6) = -5.398Q-79
X        REAL16A(7) = 0.0Q0
X        REAL16A(8) = 5.398Q-79
X        REAL16A(9) = 1.175Q-38
X        REAL16A(10) = 1.176Q-38
X        REAL16A(11) = 3.402Q38
X        REAL16A(12) = 3.403Q38
X        REAL16A(13) = 7.237Q75
X        DO 600 I = 14,100
X            X = RANGE(252)
X            X = X*RANDOM()
X            REAL16A(I) = X*(2.0Q0*RANDOM()-1.0Q0)
X  600   CONTINUE
X        IF (ICHECK .EQ. 0) THEN
X            WRITE (7) REAL16A
X        ELSE
X            READ (7) REAL16B
X            WRITE (*,*) 'REAL16: ',IBMREAL16S(REAL16B,REAL16C,100)
X            ERRMAX = 0.0D0
X            DO 610 I = 14,100
X                X = ABS(REAL16A(I)-REAL16C(I))
X                IF (REAL16A(I) .NE. 0.0Q0) X = X/ABS(REAL16A(I))
X                IF (X .GT. 1.3D-29) THEN
X                    WRITE (*,*) 'Error in REAL16:',
X     *                  X,REAL16A(I),REAL16C(I)
X                    STOP
X                END IF
X                IF (X .GT. ERRMAX) ERRMAX = X
X  610       CONTINUE
X            WRITE (*,*) 'Maximum error: ',ERRMAX
X        END IF
X        WRITE (*,*) 'REAL16(0): ',IBMREAL16S(REAL16B,REAL16C,0)
X        WRITE (*,*) 'REAL16(-1): ',IBMREAL16S(REAL16B,REAL16C,-1)
X
X        WRITE (*,*) 'All tests passed satisfactorily'
X        END
X
X
X
X        DOUBLE PRECISION FUNCTION RANGE (MAXEXP)
X        IMPLICIT REAL*8 (A-H, O-Z)
X        INTEGER KNIT
X        COMMON KNIT
X
X        N = 2*MAXEXP*RANDOM()-MAXEXP
X        IF (KNIT .NE. 0 .AND. ABS(N) .GT. 100 .AND. RANGE .LT. 200)
X     *          THEN
X            RANGE = 0.0D0
X        ELSE
X            RANGE = 2.0D0**N
X        END IF
X        END
X
X
X
X        SUBROUTINE INIT
X        IMPLICIT REAL*8 (A-H,O-Z)
X        DIMENSION U(97)
X        COMMON /RAND/ U,IP,JP
X        I = 12
X        J = 34
X        K = 56
X        L = 78
X        DO 20 II = 1,97
X            S = 0.0D0
X            T = 0.5D0
X            DO 10 JJ = 1,50
X                M = MOD(MOD(I*J,179)*K,179)
X                I = J
X                J = K
X                K = M
X                L = MOD(53*L+1,169)
X                IF (MOD(L*M,64) .GE. 32) S = S+T
X                T = 0.5D0*T
X   10       CONTINUE
X            U(II) = S
X   20   CONTINUE
X        IP = 97
X        JP = 33
X        END
X
X
X
X
X        DOUBLE PRECISION FUNCTION RANDOM()
X        IMPLICIT REAL*8 (A-H,O-Z)
X        DIMENSION U(97)
X        COMMON /RAND/ U,IP,JP
X        SAVE INITIAL
X        DATA INITIAL/1/
X
X        IF (INITIAL .NE. 0) THEN
X            INITIAL = 0
X            CALL INIT
X        END IF
X
X        X = U(IP)-U(JP)
X        IF (X .LT. 0.0D0) X = X+1.0D0
X        U(IP) = X
X        IP = IP-1
X        IF (IP .LE. 0) IP = 97
X        JP = JP-1
X        IF (JP .LE. 0) JP = 97
X        RANDOM = X
X        END
END_OF_FILE
if test 12264 -ne `wc -c <'convtest.f'`; then
    echo shar: \"'convtest.f'\" unpacked with wrong size!
fi
# end of 'convtest.f'
fi
if test -f 'iebcopy.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'iebcopy.c'\"
else
echo shar: Extracting \"'iebcopy.c'\" \(13305 characters\)
sed "s/^X//" >'iebcopy.c' <<'END_OF_FILE'
X/* (C) Copyright N.M. Maclaren 1993, 1994, 1995
X   (C) Copyright the University of Cambridge 1993, 1994, 1995
X   ALL RIGHTS RESERVED
X
Xiebcopy.c  -  skip to a PDS member, unpick PDS directories into an in-store
Xlist and so on.  It is very IEBCOPY-specific, because it was more hassle than
Xit was worth to use common code with TLS, even though the code is very similar
Xin several respects.  Note that it does not check allow_errors, because I do
Xnot imagine that any other systems have half-baked IEBCOPY look-alikes! */
X
X
X
X#include <stddef.h>
X
X#include "mvstape.h"
X#include "control.h"
X#include "tlspds.h"
X#include "tlsdict.h"
X#include "iebcopy.h"
X
X
X
X/* Constants and global variables that are used only in this module;
XIEBCOPY_next_segment is reset in control.c. */
X
X
Xchar *IEB_next_segment = NULL;
Xstatic int total_block_length = 0, extent_count = 0, trks_per_cyl = 0;
Xstatic IEB_EXTENT extent_list[16] = {{0}};
X
X#define minimum_lrecl     280    /* IEBCOPY always needs this */
X#define twelve_zeroes     "\0\0\0\0\0\0\0\0\0\0\0\0" /* End of directory */
X#define PDS_end_name      "\xff\xff\xff\xff\xff\xff\xff\xff" /* Yes, well */
X#define PDS_member_min    100    /* Get space for at least this many */
X
X
X
Xint read_IEB_block (void) {
X
X/* Read the next block from an IEBCOPY unloaded PDS.  This unpicks tape blocks,
Xso that IEBCOPY's weird format is transparent to the caller. */
X
X    IEB_TAPE_BLOCK *header = (IEB_TAPE_BLOCK *)actual_block_buffer;
X    int n;
X
X    if (IEB_next_segment == NULL) {
X        if ((total_block_length = read_actual_block()) <= 0)
X            return total_block_length;
X        if (get_BE_short(header->b_length) != total_block_length ||
X                get_BE_short(header->b_pad) != 0 ||
X                get_BE_short(header->r_length) != total_block_length-4 ||
X                get_BE_short(header->r_pad) != 0)
X            IO_error("invalid VS header for IEBCOPY unloaded PDS",
X                ERR_skip,ERR_private);
X        IEB_next_segment = header->data;
X    }
X    block_buffer = ((IEB_DATA_BLOCK *)IEB_next_segment)->data;
X    block_length = get_BE_short(((IEB_DATA_BLOCK *)IEB_next_segment)->datalen);
X
X/* Do what checking we can and skip over this segment, for next time. */
X
X    n = (block_buffer-actual_block_buffer)+block_length-total_block_length;
X    if (((IEB_DATA_BLOCK *)IEB_next_segment)->keylen != 0 || n > 0) {
X        IEB_next_segment = NULL;
X        IO_error("invalid format of IEBCOPY disk-image block",
X            ERR_skip,ERR_private);
X    }
X    if (block_length == 0 || n == 0)
X        IEB_next_segment = NULL;
X    else
X        IEB_next_segment = block_buffer+block_length;
X    return block_length;
X}
X
X
X
Xint check_IEB_unloaded (void) {
X
X/* This checks if a file is an IEBCOPY unloaded PDS, and returns 1 if it has
Xread a block in hand and decided that it should not have done so.  It sets
Xdataset_dsorg to dsorg_PO if the file looks like a PDS. */
X
X    IEB_TAPE_BLOCK *header = (IEB_TAPE_BLOCK *)actual_block_buffer;
X    IEB_FIRST_BLOCK *first = (IEB_FIRST_BLOCK *)header->data;
X    IEB_SECOND_BLOCK *second = (IEB_SECOND_BLOCK *)header->data;
X
X    if (tape_type != type_NL) {
X        if (dataset_recfm != (recfm_V|recfm_S) ||
X                dataset_lrecl < minimum_lrecl ||
X                (dataset_blksize != 0 && dataset_lrecl != dataset_blksize-4))
X            return 0;
X    }
X    if (read_actual_block() <= 0 || block_length < sizeof(IEB_FIRST_BLOCK)+8 ||
X            memcmp(first->identifier,IEBCOPY_identifier,3) != 0)
X        return 1;
X
X/* Give the first block a reasonable checking and unpick the DCB.  There are
Xother things that we could check, but it does not seem worth the effort. */
X
X    if (get_BE_short(header->b_length) != block_length ||
X            get_BE_short(header->b_pad) != 0 ||
X            get_BE_short(header->r_length) != block_length-4 ||
X            get_BE_short(header->r_pad) != 0 ||
X            first->dsorg[0] != MVS_DSORG_PO || first->keylen != 0)
X        IO_error("invalid header for IEBCOPY unloaded PDS",
X            ERR_skip,ERR_private);
X    if (first->indicators&indicate_corrupted)
X        IO_error("IEBCOPY marked this unloaded PDS as erroneous",
X            ERR_skip,ERR_private);
X    dataset_dsorg = dsorg_PO;
X    unpick_DCB(first->dsorg[0],first->recfm);
X    dataset_lrecl = get_BE_short(first->lrecl);
X    dataset_blksize = get_BE_short(first->blksize);
X    trks_per_cyl = get_BE_short(first->trks_per_cyl);
X
X/* Read the next block for the extent list. */
X
X    if (read_actual_block() <= 0 || block_length < sizeof(IEB_SECOND_BLOCK) ||
X            get_BE_short(header->b_length) != block_length ||
X            get_BE_short(header->b_pad) != 0 ||
X            get_BE_short(header->r_length) != block_length-4 ||
X            get_BE_short(header->r_pad) != 0)
X        IO_error("unable to read extent list for IEBCOPY unloaded PDS",
X            ERR_skip,ERR_private);
X    extent_count = second->num_extents;
X    memcpy(extent_list,second->extents,sizeof(extent_list));
X    return 1;
X}
X
X
X
XSTATIC int compare_ttrs (const void *key, const void *element) {
X
X/* This is an auxiliary for qsort() in read_IEB_directory and bsearch() in
Xnext_IEB_member.  Note that it uses the next_offset field to store the TTR. */
X
X    const PDS_STRUCT *Key = (const PDS_STRUCT *)key,
X        *Element = (const PDS_STRUCT *)element;
X    int n;
X
X    if ((n = Key->next_offset-Element->next_offset) != 0) return n;
X    n = (Element->flags&PDS_flags_head)-(Key->flags&PDS_flags_head);
X    if (n != 0) return n;
X    return (Key->name[0] != '\0' ? strcmp(Key->name,Element->name) : 0);
X}
X
X
X
Xvoid read_IEB_directory (void) {
X
X/* Read a PDS directory and turn it into a convenient array.  Note that this
Xsorts by TTR, whereas the TLS code sorts by member name, and has to handle an
Xunknown size of directory, whereas TLS knows it in advance. */
X
X    IEB_TAPE_BLOCK *header;
X    int m, n,
X        bytes_used = 0;    /* Silencing 'gcc -Wall' */
X    char *pds_dir_ptr = NULL, *pds_entry_ptr;
X    PDS_DIRECTORY *PDS_dir_ptr;
X    PDS_ENTRY pds_entry;
X    PDS_STRUCT *pds_struct_ptr;
X
X    PDS_member_count = 0;
X
X/* Read the next tape block and unpick the initial part of the header.  Note
Xthat block_buffer and block_buffer are not modified in this function. */
X
X    while (1) {
X        if (pds_dir_ptr == NULL ||
X                (char *)pds_dir_ptr >= block_buffer+block_length) {
X            if (read_actual_block() <= 0)
X                IO_error("unable to read IEBCOPY PDS directory",
X                    ERR_skip,ERR_tapeio);
X            header = (IEB_TAPE_BLOCK *)block_buffer;
X            if (debug >= 2)
X                display_buffer(stderr,block_buffer,block_length,block_length);
X            if (get_BE_short(header->b_length) != block_length ||
X                    get_BE_short(header->b_pad) != 0 ||
X                    get_BE_short(header->r_length) != block_length-4 ||
X                    get_BE_short(header->r_pad) != 0)
X                IO_error("invalid VS header for IEBCOPY PDS directory",
X                    ERR_skip,ERR_private);
X            pds_dir_ptr = header->data;
X        } else
X            ++pds_dir_ptr;
X
X/* Loop round the disk images of the directory blocks, checking for the end of
Xthe directory, bad blocks etc.  We could check that the CCHHR is zero, but this
Xmay not be true for all IEBCOPY versions. */
X
X        while (pds_dir_ptr-block_buffer != block_length) {
X            if (pds_dir_ptr+12 == block_buffer+block_length &&
X                    memcmp(pds_dir_ptr,twelve_zeroes,12) == 0)
X                goto finished;
X            PDS_dir_ptr = (PDS_DIRECTORY *)pds_dir_ptr;
X            if (pds_dir_ptr-block_buffer+sizeof(PDS_DIRECTORY) > block_length ||
X                    PDS_dir_ptr->keylen != PDS_key_length ||
X                    get_BE_short(PDS_dir_ptr->datalen) != PDS_data_length ||
X                    (bytes_used = get_BE_short(PDS_dir_ptr->bytes_used)-2) >
X                        PDS_data_length-2)
X                IO_error("invalid format of PDS directory block",
X                    ERR_skip,ERR_private);
X            pds_entry_ptr = PDS_dir_ptr->data;
X
X/* Check that the directory is not mangled, and that this is a real entry. */
X
X            while (bytes_used != 0) {
X                if (bytes_used < offsetof(PDS_ENTRY,user_data))
X                    IO_error("invalid PDS directory block",
X                        ERR_skip,ERR_private);
X                memcpy(&pds_entry,pds_entry_ptr,sizeof(pds_entry));
X                if (memcmp(pds_entry.name,PDS_end_name,
X                            sizeof(pds_entry.name)) == 0)
X                    break;
X
X/* Get some more space for the directory if necessary. */
X
X                if (PDS_member_count >= PDS_member_max) {
X                    pds_struct_ptr = PDS_member_list;
X                    errno = 0;
X                    PDS_member_max = (PDS_member_max == 0 ? PDS_member_min :
X                            2*PDS_member_max);
X                    PDS_member_list = malloc(PDS_member_max*sizeof(PDS_STRUCT));
X                    if (PDS_member_list == NULL)
X                        fatal("unable to get store for PDS directory",
X                            ERR_system);
X                    if (pds_struct_ptr != NULL) {
X                        memcpy(PDS_member_list,pds_struct_ptr,
X                            PDS_member_count*sizeof(PDS_STRUCT));
X                        free(pds_struct_ptr);
X                    }
X                }
X
X/* Copy the data from the MVS format to this program's format.  The flags are
Xneeded for handling aliases and whether this is a load module. */
X
X                get_string(PDS_member_list[PDS_member_count].name,
X                    pds_entry.name,sizeof(pds_entry.name));
X                PDS_member_list[PDS_member_count].flags =
X                        (pds_entry.flags&pds_alias_flag ? 0 : PDS_flags_head)|
X                        (pds_entry.flags&pds_ttr_bits ? PDS_flags_ttrs : 0);
X                PDS_member_list[PDS_member_count].next_offset =
X                     (pds_entry.ttr[0]<<16)+(pds_entry.ttr[1]<<8)+
X                         pds_entry.ttr[2];
X                n = 2*(pds_entry.flags&pds_length_bits)+12;
X                bytes_used -= n;
X                pds_entry_ptr += n;
X                ++PDS_member_count;
X            }
X
X/* Try the next directory block and then carry on until the end. */
X
X            pds_dir_ptr += sizeof(PDS_DIRECTORY);
X        }
X    }
Xfinished:
X
X/* Sort into TTR order and turn them into something that we can use. */
X
X    qsort(PDS_member_list,PDS_member_count,sizeof(PDS_STRUCT),compare_ttrs);
X    for (n = 0; n < PDS_member_count; ++n) {
X        m = n;
X        PDS_member_list[n].flags |= PDS_flags_head;
X        while (n < PDS_member_count &&
X                PDS_member_list[n].next_offset ==
X                    PDS_member_list[n+1].next_offset) {
X            PDS_member_list[n].next_entry = ++n;
X            PDS_member_list[n].flags &= ~PDS_flags_head;
X        }
X        PDS_member_list[n].next_entry = m;
X    }
X}
X
X
X
Xint next_IEB_member (int skip) {
X
X/* This returns the index into PDS_member_list of the next block, or -1 for
XEOF.  To do this, it must map the CCHHR of the absolute disk address to the TTR
Xusing the extent list. */
X
X    IEB_TAPE_BLOCK *header = (IEB_TAPE_BLOCK *)actual_block_buffer;
X    IEB_DATA_BLOCK *image = (IEB_DATA_BLOCK *)header->data;
X    PDS_STRUCT pds_struct_key, *pds_struct_ptr;
X    int cylinder, head, ttr, i, j;
X
X/* Skip the remainder of this member, if any, and read the next tape block. */
X
X    if (skip) while (read_IEB_block() != 0) ;
X    if ((total_block_length = read_actual_block()) <= 0)
X        return -1;
X    if (get_BE_short(header->b_length) != total_block_length ||
X            get_BE_short(header->b_pad) != 0 ||
X            get_BE_short(header->r_length) != total_block_length-4 ||
X            get_BE_short(header->r_pad) != 0)
X        IO_error("invalid VS header for IEBCOPY unloaded PDS member",
X            ERR_skip,ERR_private);
X    IEB_next_segment = header->data;
X
X/* Pick up the CCHHR and convert it to a TTR. */
X
X    cylinder = get_BE_short(image->cchhr);
X    head = get_BE_short(&image->cchhr[2]);
X    ttr = 0;
X    for (i = 0; i <= extent_count; ++i) {
X        if (i == extent_count)
X            IO_error("CCHHR of IEBCOPY block not in extent list",
X                ERR_skip,ERR_private);
X        else if (memcmp(image->cchhr,extent_list[i].lower_cchh,4) >= 0 &&
X                memcmp(image->cchhr,extent_list[i].upper_cchh,4) <= 0) {
X            j = (get_BE_short(image->cchhr)-
X                    get_BE_short(extent_list[i].lower_cchh))*trks_per_cyl+
X                get_BE_short(&image->cchhr[2])-
X                    get_BE_short(&extent_list[i].lower_cchh[2]);
X            ttr += (j << 8)+image->cchhr[4];
X            break;
X        } else
X            ttr += get_BE_short(extent_list[i].tracks)<<8;
X    }
X
X/* Now look this up in the PDS directory. */
X
X    pds_struct_key.next_offset = ttr;
X    pds_struct_key.flags = PDS_flags_head;
X    pds_struct_key.name[0] = '\0';
X    pds_struct_ptr = (PDS_STRUCT *)bsearch(&pds_struct_key,PDS_member_list,
X                PDS_member_count,sizeof(PDS_STRUCT),compare_ttrs);
X    if (pds_struct_ptr == NULL)
X        IO_error("TTR of IEBCOPY data block not in PDS directory",
X            ERR_skip,ERR_private);
X    return pds_struct_ptr-PDS_member_list;
X}
END_OF_FILE
if test 13305 -ne `wc -c <'iebcopy.c'`; then
    echo shar: \"'iebcopy.c'\" unpacked with wrong size!
fi
# end of 'iebcopy.c'
fi
if test -f 'os2.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'os2.c'\"
else
echo shar: Extracting \"'os2.c'\" \(12686 characters\)
sed "s/^X//" >'os2.c' <<'END_OF_FILE'
X/* (C) Copyright N.M. Maclaren 1994, 1995
X   (C) Copyright the University of Cambridge 1994, 1995
X   ALL RIGHTS RESERVED
X
Xos2.c - the ANSI C and POSIX emulation code, dummy tape functions for OS/2 and
Xsystem-dependent functions and data.  Most of this code is applicable to all
XMS-DOS derivatives, and so should be changed with #ifs.
X
XThe emulation functions all have the same specifications as the POSIX functions
Xwith the same names (in lower-case) or the functions in tapeio.c.  Note that
Xthe use of ANSI C does not make these functions more portable than the POSIX
Xequivalents, because they perform exactly the types of operation that operating
Xand run-time systems get wrong or implement strangely.  In any case, the
Xfollowing code is not strictly conforming, and cannot be made to be so.
X
XBe warned that the directory separator in file names passed to these functions
Xis '/' and not '\' - some libraries on MS-DOS derivatives accept both, but
Xothers do not!
X
XThe MS-DOS paranoia code at the end should work on all MS-DOS derivatives, but
Xmost of it is probably redundant for any one system.  It can be disabled by 
Xusing the -z option, anyway. */
X
X
X
X#define INCL_DOSFILEMGR
X#include <os2.h>
X
X#include "system.h"          /* Only standard headers and unifudge.h, really */
X
X#define OS2namesize 100      /* At least UNIXnamesize in mvstape.h */
X
X#define STATIC               /* Because local symbols may be stripped! */
X
X
X
X/* This is a copy of no_name_check in mvstape.c. */
X
Xstatic int no_name_check = 0;
X
X
X
Xvoid Perror (const char *string) {
X
X/* Print out a diagnostic after an error that sets errno. */
X
X    perror(string);
X}
X
X
X
X/* Set up a table of 'file descriptors'!  The numbering does not bear any
Xrelationship to that of UNIX. */
X
Xstatic FILE *IOB[10] = {
X    NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL
X};
X
X
X
XSTATIC void reverse_slashes (const char *UNIX_name, char *MSDOS_name) {
X
X/* This copies a file name, changing all '/'s to '\'s.  No diagnostics should
Xbe necessary, because all names should be valid by this stage. */
X
X    int i, k;
X
X    for (i = 0, k = ' '; k != '\0'; ++i) {
X        k = UNIX_name[i];
X        MSDOS_name[i] = (k == '/' ? '\\' : k);
X    }
X}
X
X
X
Xint Access (const char *path, int amode) {
X
X/* Check if a file is readable or writable, in the only way that seems
Xpracticable. */
X
X    FILE *file;
X    char name[OS2namesize], *mode;
X
X    reverse_slashes(path,name);
X    mode = (amode == WR_OK ? "ab" : "rb");
X    if ((file = fopen(name,mode)) == NULL) return -1;
X    fclose(file);
X    return 0;
X}
X
X
X
Xint Open (const char *path, int flag, int mode) {
X
X/* Open a file.  Only a few of the saner flag/mode combinations are used by 
Xthis program. */
X
X    int fildes;
X    char name[OS2namesize], *amode;
X
X    reverse_slashes(path,name);
X    mode = mode;
X    for (fildes = 3; fildes < 10; ++fildes) if (IOB[fildes] == NULL) break;
X    if (fildes > 10)
X        fatal("file descriptor overflow - seek expert",ERR_private);
X    switch (flag) {
Xcase O_READ: amode = "rb"; break;
Xcase O_WRITE: amode = "wb"; break;
Xcase O_EXTEND: amode = "ab"; break;
Xcase O_UPDATE: amode = "rb+"; break;
Xcase O_SCRATCH: amode = "wb+"; break;
Xdefault: fatal("unknown open flags - seek expert",ERR_private);
X    }
X    if ((IOB[fildes] = fopen(name,amode)) == NULL) return -1;
X    return fildes;
X}
X
X
X
Xint Close (int fildes) {
X
X/* Close a file. */
X
X    if (fclose(IOB[fildes]) != 0) {
X        IOB[fildes] = NULL;
X        return -1;
X    }
X    IOB[fildes] = NULL;
X    return 0;
X}
X
X
X
Xint Mkdir (const char *path, int mode) {
X
X/* Create a directory.  This needs a non-ANSI function, and the error handling
Xis ghastly and very kludgy; unfortunately, it is very hard to do better.  If
Xthis cannot set E_NODIR and E_EXISTS reliably, it should do nothing and return
Xsuccess - this will disable automatic subdirectory creation, but let the rest
Xof the code run. */
X
X    int rc;
X    char name[OS2namesize];
X
X    reverse_slashes(path,name);
X    mode = mode;
X    switch (DosCreateDir((unsigned char *)name,NULL)) {
Xcase 0: return 0;
Xcase 3: errno = E_NODIR;
X        return -1;
Xcase 5: errno = E_EXISTS;
X        return -1;
Xdefault: errno = E_OTHER;
X        return -1;
X    }
X    return 0;
X}
X
X
X
Xint Link (const char *path1, const char *path2) {
X
X/* Create a hard link for PDS aliases.  As this is not possible, it does
Xnothing and says it has succeeded - this will have the effect of ignoring 
Xaliases, quietly. */
X
X    return 0;
X}
X
X
X
Xint Unlink (const char *path) {
X
X/* Remove a link.  This will not be called, because the Link() function will
Xnever fail! */
X
X    return 0;
X}
X
X
X
Xptrdiff_t Write (int fildes, const void *buf, size_t nbyte) {
X
X/* Write a buffer of data. */
X
X    size_t result;
X
X    result = fwrite(buf,1,nbyte,IOB[fildes]);
X    if (result == 0 && ferror(IOB[fildes])) return -1;
X    return result;
X}
X
X
X
Xptrdiff_t Read (int fildes, void *buf, size_t nbyte) {
X
X/* Read a buffer of data. */
X
X    size_t result;
X
X    result = fread(buf,1,nbyte,IOB[fildes]);
X    if (result == 0 && ferror(IOB[fildes])) return -1;
X    return result;
X}
X
X
X
Xlong Lseek (int fildes, long offset, int whence) {
X
X/* Seek to a known position. */
X
X    if (fseek(IOB[fildes],offset,whence) != 0) return -1;
X    return ftell(IOB[fildes]);
X}
X
X
X
Xchar *Getlogin (void) {
X
X/* Return the login identifier.  This makes no sense under MS-DOS derivatives,
Xso this returns nothing.  It could be kludged for Novell. */
X
X    return "";
X}
X
X
X
Xunsigned int Umask (unsigned int cmask) {
X
X/* Set and return the umask.  This makes no sense under MS-DOS derivatives,
Xso this returns a standard UNIX default. */
X
X    return 0644;
X}
X
X
X
Xunsigned int Getuid (void) {
X
X/* Return the user identifier as a number.  This makes no sense under MS-DOS
Xderivatives, so this returns a standard UNIX default. */
X
X    return 100;
X}
X
X
X
Xunsigned int Getgid (void) {
X
X/* Return the group identifier as a number.  This makes no sense under MS-DOS
Xderivatives, so this returns a standard UNIX default. */
X
X    return 100;
X}
X
X
X
XSTATIC void no_tapes (void) {
X
X/* This issues a diagnostic and stops, because I cannot face the effort of
Xwriting tape support, even if I had a tape deck on a suitable system! */
X
X    fatal("the OS/2 version cannot handle real magnetic tapes",ERR_private);
X}
X
X
X
Xint basic_tape_open (const char *name) {
X
X/* Open the tape device for input and check that it seems to be a non-rewinding
Xtape. */
X
X    name = name;
X    no_tapes();
X}
X
X
X
Xint basic_tape_close (int fileno) {
X
X/* Close the tape device. */
X
X    fileno = fileno;
X    no_tapes();
X}
X
X
X
Xint basic_tape_rewind (int fileno) {
X
X/* Rewind a tape, leaving it at the load point. */
X
X    fileno = fileno;
X    no_tapes();
X}
X
X
X
Xconst char * basic_tape_status (int fileno) {
X
X/* Create a string containing some diagnostics after an I/O error or unexpected
XEOF on tape. */
X
X    fileno = fileno;
X    no_tapes();
X}
X
X
X
Xint basic_tape_skip (int fileno, int labels, int data) {
X
X/* This skips none or more label files and none or more data files. */
X
X    fileno = fileno;
X    labels = labels;
X    data = data;
X    no_tapes();
X}
X
X
X
Xint basic_tape_read (int fileno, char *buffer, int length) {
X
X/* Read an actual tape block. */
X
X    fileno = fileno;
X    buffer = buffer;
X    length = length;
X    no_tapes();
X}
X
X
X
Xvoid basic_tape_signal (void (*receiver)(const char *)) {
X
X/* Trap all of the signals that are at all likely to be caused by normal,
Xexternal events (including user action), to allow some cleaning up.  This
Xis not really necessary for disk use. */
X
X    receiver = receiver;
X}
X
X
X
X/* System-dependent definitions used by command.c and control.c.  See 
Xunifudge.h for their descriptions. */
X
Xconst char NAME_DIR_SEP = '\\';    /* Directory separator in file names */
Xconst char *NAME_CHAR_VETO = "";   /* MS-DOS does a full name check */
Xconst char *NAME_CHAR_SUB = "";    /* Hence these are not used */
X/* void CHECK_FILE_NAME(char *name);    see later */
X/* void FUDGE_FILE_NAME(char *name);    see later */
X
X
X
X/* System-dependent definitions used by unpick.c.  See unifudge.h for their
Xdescriptions. */
X
Xconst char *GOOD_EBCDIC_CCS = "\f\v"; /* EBCDIC CCs that can be handled */
Xconst char *BAD_EBCDIC_CCS = "\n\r"; /* EBCDIC CCs that cannot be handled */
Xconst char SUB_CHAR = 0xff;        /* Used for non-ASCII characters */
XANSI_CC_TABLE_TYPE ANSI_CC_TABLE = {                                 \
X    {"\r", "\r\n\f", "\r\n\r\n\r\n", "\r\n\r\n", "\r\n", "\r\n"},    \
X    {"", "\f", "\r\n\r\n", "\r\n", "", ""}                           \
X};
X
X
X
X/* The following ghastly code is because I do not trust MS-DOS derivatives (and
Xthat includes OS/2) not to go crazy when passed a bad file name - my limited
Xexperiments indicate that those systems really are as bad as I think they are!
XWithout this check, the program assumes that open/fopen will either work as the
Xuser expects or give an error. */
X
X
X
XSTATIC void bad_msdos_name (const char *message, const char *name) {
X
X    fatal("%s: '%s'\n",ERR_private,message,name);
X}
X
X
X
XSTATIC int reserved_msdos_name (const char *name, int length, int terminator) {
X
X/* Check the name against known illegal MS-DOS and OS/2 names; heaven knows
Xwhat happens if you attempt to create files with these names, but chaos is
Xlikely! */
X
X    static const char *illegal[] = {
X        "AUX", "CLOCK$", "COM1", "COM2", "COM3", "COM4", "CON", "KBDS",
X        "LPT1", "LPT2", "LPT3", "MOUSE$", "NUL", "POINTER$", "PRN", "SCREEN$",
X        NULL
X    };
X    static const char *illegal_dir[] = {
X        "PIPE", "QUEUE", "SEM", NULL
X    };
X    int i, k;
X
X    for (k = 0; illegal[k] != NULL; ++k) {
X        for (i = 0; i < length; ++i)
X            if (toupper(name[i]) != illegal[k][i]) goto diff1;
X        if (illegal[k][length] == '\0') return 1;
Xdiff1:  ;
X    }
X    if (terminator == '/')
X        for (k = 0; illegal_dir[k] != NULL; ++k) {
X            for (i = 0; i < length; ++i)
X                if (toupper(name[i]) != illegal_dir[k][i]) goto diff2;
X            if (illegal_dir[k][length] == '\0') return 1;
Xdiff2:      ;
X        }
X    return 0;
X}
X
X
X
XSTATIC int msdos_executable (const char *extension) {
X
X/* See if it looks like an executable file. */
X
X    static const char *program[] = {
X        ".BAT", ".CMD", ".COM", ".EXE", NULL
X    };
X    int i, k;
X
X    for (k = 0; program[k] != NULL; ++k) {
X        for (i = 0; extension[i] != '\0'; ++i)
X            if (toupper(extension[i]) != program[k][i]) goto diff;
X        if (program[k][i] == '\0') return 1;
Xdiff:   ;
X    }
X    return 0;
X}
X
X
X
Xvoid CHECK_FILE_NAME (char *name) {
X
X/* Upper-cases the file name and check that it is a plausible MS-DOS name; as
Xthe rules are inadequately, incorrectly and inconsistently documented, this may
Xlet some dangerous ones through with unknown (but probably chaotic) effects.  
XNote that this function is called after '\' has been kludged to '/'.
X
XThe list of legal characters is the strict MVS list (i.e. without minus sign or
XX'C0'), plus exclamation mark and underscore.  Others seem to work, but
XMicrosoft Windows 3, INFO-ZIP and/or OS/2 warn against them; they may cause
Xchaos in a few circumstances, or the warnings may be wrong. */
X
X    int length = strlen(name), i;
X    char *ptr;
X
X    if (no_name_check) return;
X    for (i = 0; i < length; ++i) {
X        if (isalpha(name[i]))
X            name[i] = toupper(name[i]);
X        else if (! isdigit(name[i]) && name[i] != '_' && name[i] != '!' &&
X                name[i] != '$' && name[i] != '@' && name[i] != '#' &&
X                name[i] != '/' && name[i] != '.' && name[i] != '*')
X            bad_msdos_name("Illegal character in MS-DOS name",name);
X    }
X    ptr = name;
X    while (1) {
X        if ((i = strcspn(ptr,"/.")) > 8 || reserved_msdos_name(ptr,i,ptr[i]) ||
X                (ptr[0] == '@' && msdos_executable(&ptr[i])))
X            bad_msdos_name("Illegal MS-DOS file or directory name",name);
X        if (ptr[i] == '\0' || ptr[i] == '.') break;
X        ptr += i+1;
X    }
X    if ((ptr = strchr(name,'.')) != NULL &&
X            (ptr == name || ptr[-1] == '/' || ptr[1] == '\0' ||
X                strpbrk(&ptr[1],"/.") != NULL || length-(ptr-name+1) > 3))
X            bad_msdos_name("Illegal use of MS-DOS extension",name);
X}
X
X
X
Xvoid FUDGE_FILE_NAME (char *name) {
X
X/* Fix up default file names, to avoid check_msdos_name rejecting them.
XCurrently, the only kludge necessary is to reduce any extension to 3
Xcharacters.  Note that check_msdos_name is always called after this, and so
Xthis need not duplicate the actions. */
X
X    char *ptr;
X
X    if (no_name_check) return;
X    if ((ptr = strchr(name,'.')) != NULL && strlen(ptr) > 4) ptr[4] = '\0';
X}
X
X
X
Xvoid SET_NO_NAME_CHECK (void) {
X
X/* Copy the -z flag to local storage, to avoid including headers. */
X
X    no_name_check = 1;
X}
END_OF_FILE
if test 12686 -ne `wc -c <'os2.c'`; then
    echo shar: \"'os2.c'\" unpacked with wrong size!
fi
# end of 'os2.c'
fi
echo shar: End of archive 4 \(of 9\).
cp /dev/null ark4isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 ; do
    if test ! -f ark${I}isdone ; then
	MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 9 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0


