p2clib.c

把pascal程序转成C语言程序 把pascal程序转成C语言程序

Void P_readlnpaoc(f, s, len)
FILE *f;
char *s;
int len;
{
    int ch;

    for (;;) {
	ch = getc(f);
	if (ch == EOF || ch == '\n')
	    break;
	if (len > 0) {
	    *s++ = ch;
	    --len;
	}
    }
    while (--len >= 0)
	*s++ = ' ';
}


/* Compute maximum legal "seek" index in file (0-based). */

long P_maxpos(f)
FILE *f;
{
    long savepos = ftell(f);
    long val;

    if (fseek(f, 0L, SEEK_END))
        return -1;
    val = ftell(f);
    if (fseek(f, savepos, SEEK_SET))
        return -1;
    return val;
}


/* Use packed array of char for a file name. */

Char *P_trimname(fn, len)
register Char *fn;
register int len;
{
    static Char fnbuf[256];
    register Char *cp = fnbuf;
    
    while (--len >= 0 && *fn && !isspace(*fn))
	*cp++ = *fn++;
    *cp = 0;
    return fnbuf;
}




/* Pascal's "memavail" doesn't make much sense in Unix with virtual memory.
   We fix memory size as 10Meg as a reasonable compromise. */

long memavail()
{
    return 10000000;            /* worry about this later! */
}

long maxavail()
{
    return memavail();
}




/* Sets are stored as an array of longs.  S[0] is the size of the set;
   S[N] is the N'th 32-bit chunk of the set.  S[0] equals the maximum
   I such that S[I] is nonzero.  S[0] is zero for an empty set.  Within
   each long, bits are packed from lsb to msb.  The first bit of the
   set is the element with ordinal value 0.  (Thus, for a "set of 5..99",
   the lowest five bits of the first long are unused and always zero.) */

/* (Sets with 32 or fewer elements are normally stored as plain longs.) */

long *P_setunion(d, s1, s2)         /* d := s1 + s2 */
register long *d, *s1, *s2;
{
    long *dbase = d++;
    register int sz1 = *s1++, sz2 = *s2++;
    while (sz1 > 0 && sz2 > 0) {
        *d++ = *s1++ | *s2++;
	sz1--, sz2--;
    }
    while (--sz1 >= 0)
	*d++ = *s1++;
    while (--sz2 >= 0)
	*d++ = *s2++;
    *dbase = d - dbase - 1;
    return dbase;
}


long *P_setint(d, s1, s2)           /* d := s1 * s2 */
register long *d, *s1, *s2;
{
    long *dbase = d++;
    register int sz1 = *s1++, sz2 = *s2++;
    while (--sz1 >= 0 && --sz2 >= 0)
        *d++ = *s1++ & *s2++;
    while (--d > dbase && !*d) ;
    *dbase = d - dbase;
    return dbase;
}


long *P_setdiff(d, s1, s2)          /* d := s1 - s2 */
register long *d, *s1, *s2;
{
    long *dbase = d++;
    register int sz1 = *s1++, sz2 = *s2++;
    while (--sz1 >= 0 && --sz2 >= 0)
        *d++ = *s1++ & ~*s2++;
    if (sz1 >= 0) {
        while (sz1-- >= 0)
            *d++ = *s1++;
    }
    while (--d > dbase && !*d) ;
    *dbase = d - dbase;
    return dbase;
}


long *P_setxor(d, s1, s2)         /* d := s1 / s2 */
register long *d, *s1, *s2;
{
    long *dbase = d++;
    register int sz1 = *s1++, sz2 = *s2++;
    while (sz1 > 0 && sz2 > 0) {
        *d++ = *s1++ ^ *s2++;
	sz1--, sz2--;
    }
    while (--sz1 >= 0)
	*d++ = *s1++;
    while (--sz2 >= 0)
	*d++ = *s2++;
    while (--d > dbase && !*d) ;
    *dbase = d - dbase;
    return dbase;
}


int P_inset(val, s)                 /* val IN s */
register unsigned val;
register long *s;
{
    register int bit;
    bit = val % SETBITS;
    val /= SETBITS;
    if (val < *s++ && ((1L<<bit) & s[val]))
	return 1;
    return 0;
}


long *P_addset(s, val)              /* s := s + [val] */
register long *s;
register unsigned val;
{
    register long *sbase = s;
    register int bit, size;
    bit = val % SETBITS;
    val /= SETBITS;
    size = *s;
    if (++val > size) {
        s += size;
        while (val > size)
            *++s = 0, size++;
        *sbase = size;
    } else
        s += val;
    *s |= 1L<<bit;
    return sbase;
}


long *P_addsetr(s, v1, v2)              /* s := s + [v1..v2] */
register long *s;
register unsigned v1, v2;
{
    register long *sbase = s;
    register int b1, b2, size;
    if ((int)v1 > (int)v2)
	return sbase;
    b1 = v1 % SETBITS;
    v1 /= SETBITS;
    b2 = v2 % SETBITS;
    v2 /= SETBITS;
    size = *s;
    v1++;
    if (++v2 > size) {
        while (v2 > size)
            s[++size] = 0;
        s[v2] = 0;
        *s = v2;
    }
    s += v1;
    if (v1 == v2) {
        *s |= (~((-2L)<<(b2-b1))) << b1;
    } else {
        *s++ |= (-1L) << b1;
        while (++v1 < v2)
            *s++ = -1;
        *s |= ~((-2L) << b2);
    }
    return sbase;
}


long *P_remset(s, val)              /* s := s - [val] */
register long *s;
register unsigned val;
{
    register int bit;
    bit = val % SETBITS;
    val /= SETBITS;
    if (++val <= *s) {
	if (!(s[val] &= ~(1L<<bit)))
	    while (*s && !s[*s])
		(*s)--;
    }
    return s;
}


int P_setequal(s1, s2)              /* s1 = s2 */
register long *s1, *s2;
{
    register int size = *s1++;
    if (*s2++ != size)
        return 0;
    while (--size >= 0) {
        if (*s1++ != *s2++)
            return 0;
    }
    return 1;
}


int P_subset(s1, s2)                /* s1 <= s2 */
register long *s1, *s2;
{
    register int sz1 = *s1++, sz2 = *s2++;
    if (sz1 > sz2)
        return 0;
    while (--sz1 >= 0) {
        if (*s1++ & ~*s2++)
            return 0;
    }
    return 1;
}


long *P_setcpy(d, s)                /* d := s */
register long *d, *s;
{
    register long *save_d = d;

#ifdef SETCPY_MEMCPY
    memcpy(d, s, (*s + 1) * sizeof(long));
#else
    register int i = *s + 1;
    while (--i >= 0)
        *d++ = *s++;
#endif
    return save_d;
}


/* s is a "smallset", i.e., a 32-bit or less set stored
   directly in a long. */

long *P_expset(d, s)                /* d := s */
register long *d;
register long s;
{
    if (s) {
	d[1] = s;
	*d = 1;
    } else
        *d = 0;
    return d;
}


long P_packset(s)                   /* convert s to a small-set */
register long *s;
{
    if (*s++)
        return *s;
    else
        return 0;
}





/* Oregon Software Pascal extensions, courtesy of William Bader */

int P_getcmdline(l, h, line)
int l, h;
Char *line;
{
    int i, len;
    char *s;
    
    h = h - l + 1;
    len = 0;
    for(i = 1; i < P_argc; i++) {
	s = P_argv[i];
	while (*s) {
	    if (len >= h) return len;
	    line[len++] = *s++;
	}
	if (len >= h) return len;
	line[len++] = ' ';
    }
    return len;
}

Void TimeStamp(Day, Month, Year, Hour, Min, Sec)
int *Day, *Month, *Year, *Hour, *Min, *Sec;
{
#ifndef NO_TIME
    struct tm *tm;
    long clock;

    time(&clock);
    tm = localtime(&clock);
    *Day = tm->tm_mday;
    *Month = tm->tm_mon + 1;		/* Jan = 0 */
    *Year = tm->tm_year;
    if (*Year < 1900)
	*Year += 1900;     /* year since 1900 */
    *Hour = tm->tm_hour;
    *Min = tm->tm_min;
    *Sec = tm->tm_sec;
#endif
}

Void VAXdate(s)
char *s;
{
    long clock;
    char *c;
    int i;
    static int where[] = {8, 9, 0, 4, 5, 6, 0, 20, 21, 22, 23};

    time(&clock);
    c = ctime(&clock);
    for (i = 0; i < 11; i++)
	s[i] = my_toupper(c[where[i]]);
    s[2] = '-';
    s[6] = '-';
}

Void VAXtime(s)
char *s;
{
    long clock;
    char *c;
    int i;

    time(&clock);
    c = ctime(&clock);
    for (i = 0; i < 8; i++)
	s[i] = c[i+11];
    s[8] = '.';
    s[9] = '0';
    s[10] = '0';
}




/* SUN Berkeley Pascal extensions */

Void P_sun_argv(s, len, n)
register char *s;
register int len, n;
{
    register char *cp;

    if ((unsigned)n < P_argc)
	cp = P_argv[n];
    else
	cp = "";
    while (*cp && --len >= 0)
	*s++ = *cp++;
    while (--len >= 0)
	*s++ = ' ';
}




int _OutMem()
{
    return _Escape(-2);
}

int _CaseCheck()
{
    return _Escape(-9);
}

int _NilCheck()
{
    return _Escape(-3);
}





/* The following is suitable for the HP Pascal operating system.
   It might want to be revised when emulating another system. */

char *_ShowEscape(buf, code, ior, prefix)
char *buf, *prefix;
int code, ior;
{
    char *bufp;

    if (prefix && *prefix) {
        strcpy(buf, prefix);
	strcat(buf, ": ");
        bufp = buf + strlen(buf);
    } else {
        bufp = buf;
    }
    if (code == -10) {
        sprintf(bufp, "Pascal system I/O error %d", ior);
        switch (ior) {
            case 3:
                strcat(buf, " (illegal I/O request)");
                break;
            case 7:
                strcat(buf, " (bad file name)");
                break;
            case FileNotFound:   /*10*/
                strcat(buf, " (file not found)");
                break;
            case FileNotOpen:    /*13*/
                strcat(buf, " (file not open)");
                break;
            case BadInputFormat: /*14*/
                strcat(buf, " (bad input format)");
                break;
            case 24:
                strcat(buf, " (not open for reading)");
                break;
            case 25:
                strcat(buf, " (not open for writing)");
                break;
            case 26:
                strcat(buf, " (not open for direct access)");
                break;
            case 28:
                strcat(buf, " (string subscript out of range)");
                break;
            case EndOfFile:      /*30*/
                strcat(buf, " (end-of-file)");
                break;
            case FileWriteError: /*38*/
		strcat(buf, " (file write error)");
		break;
        }
    } else {
        sprintf(bufp, "Pascal system error %d", code);
        switch (code) {
            case -2:
                strcat(buf, " (out of memory)");
                break;
            case -3:
                strcat(buf, " (reference to NIL pointer)");
                break;
            case -4:
                strcat(buf, " (integer overflow)");
                break;
            case -5:
                strcat(buf, " (divide by zero)");
                break;
            case -6:
                strcat(buf, " (real math overflow)");
                break;
            case -8:
                strcat(buf, " (value range error)");
                break;
            case -9:
                strcat(buf, " (CASE value range error)");
                break;
            case -12:
                strcat(buf, " (bus error)");
                break;
            case -20:
                strcat(buf, " (stopped by user)");
                break;
        }
    }
    return buf;
}


int _Escape(code)
int code;
{
    char buf[100];

    P_escapecode = code;
    if (__top_jb) {
	__p2c_jmp_buf *jb = __top_jb;
	__top_jb = jb->next;
	longjmp(jb->jbuf, 1);
    }
    if (code == 0)
        exit(EXIT_SUCCESS);
    if (code == -1)
        exit(EXIT_FAILURE);
    fprintf(stderr, "%s\n", _ShowEscape(buf, P_escapecode, P_ioresult, ""));
    exit(EXIT_FAILURE);
}

int _EscIO(code)
int code;
{
    P_ioresult = code;
    return _Escape(-10);
}

int _EscIO2(code, name)
int code;
char *name;
{
    P_ioresult = code;
    if (!__top_jb && name && *name) {
	char buf[100];
	fprintf(stderr, "%s: %s\n",
		name, _ShowEscape(buf, P_escapecode, P_ioresult, ""));
	exit(EXIT_FAILURE);
    }
    return _Escape(-10);
}



/* End. */