![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to rconv.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx|
Return to rconv.c CVS log | Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx |
1.1 ! root 1: /* ! 2: * File: rconv.c ! 3: * Contents: ctype, cvcset, cvint, cvnum, cvpos, cvreal, cvstr, gcvt, mkint, ! 4: * mkreal, mksubs, strprc ! 5: */ ! 6: ! 7: #include "../h/rt.h" ! 8: #include <math.h> ! 9: ! 10: /* ! 11: * Structure for mapping string names of procedures to block addresses. ! 12: */ ! 13: struct pstrnm { ! 14: char *pstrep; ! 15: struct b_proc *pblock; ! 16: }; ! 17: ! 18: extern struct b_proc ! 19: #define FncDef(p) Cat(B,p), ! 20: #include "../h/fdef.h" ! 21: Bnoproc; /* Hack to avoid ,; in expansion */ ! 22: #undef FncDef ! 23: ! 24: extern struct b_proc ! 25: Basgn, ! 26: Bbang, ! 27: Bcat, ! 28: Bcompl, ! 29: Bdiff, ! 30: Bdiv, ! 31: Beqv, ! 32: Binter, ! 33: Blconcat, ! 34: Blexeq, ! 35: Blexge, ! 36: Blexgt, ! 37: Blexle, ! 38: Blexlt, ! 39: Blexne, ! 40: Bminus, ! 41: Bmod, ! 42: Bmult, ! 43: Bneg, ! 44: Bneqv, ! 45: Bnonnull, ! 46: Bnull, ! 47: Bnumber, ! 48: Bnumeq, ! 49: Bnumge, ! 50: Bnumgt, ! 51: Bnumle, ! 52: Bnumlt, ! 53: Bnumne, ! 54: Bplus, ! 55: Bpower, ! 56: Brandom, ! 57: Brasgn, ! 58: Brefresh, ! 59: Brswap, ! 60: Bsect, ! 61: Bsize, ! 62: Bsubsc, ! 63: Bswap, ! 64: Btabmat, ! 65: Btoby, ! 66: Bunions, ! 67: Bvalue; ! 68: ! 69: struct pstrnm pntab[] = { ! 70: #define FncDef(p) "p", Cat(&B,p), ! 71: #include "../h/fdef.h" ! 72: #undef FncDef ! 73: ":=", &Basgn, ! 74: "!", &Bbang, ! 75: "||", &Bcat, ! 76: "~", &Bcompl, ! 77: "--", &Bdiff, ! 78: "/", &Bdiv, ! 79: "===", &Beqv, ! 80: "**", &Binter, ! 81: "|||", &Blconcat, ! 82: "==", &Blexeq, ! 83: ">>=", &Blexge, ! 84: ">>", &Blexgt, ! 85: "<<=", &Blexle, ! 86: "<<", &Blexlt, ! 87: "~==", &Blexne, ! 88: "-", &Bminus, ! 89: "%", &Bmod, ! 90: "*", &Bmult, ! 91: "-", &Bneg, ! 92: "~===", &Bneqv, ! 93: "\\", &Bnonnull, ! 94: "/", &Bnull, ! 95: "+", &Bnumber, ! 96: "=", &Bnumeq, ! 97: ">=", &Bnumge, ! 98: ">", &Bnumgt, ! 99: "<=", &Bnumle, ! 100: "<", &Bnumlt, ! 101: "~=", &Bnumne, ! 102: "+", &Bplus, ! 103: "^", &Bpower, ! 104: "?", &Brandom, ! 105: "<-", &Brasgn, ! 106: "^", &Brefresh, ! 107: "<->", &Brswap, ! 108: ":", &Bsect, ! 109: "*", &Bsize, ! 110: "[]", &Bsubsc, ! 111: ":=:", &Bswap, ! 112: "=", &Btabmat, ! 113: "...", &Btoby, ! 114: "++", &Bunions, ! 115: ".", &Bvalue, ! 116: 0, 0 ! 117: }; ! 118: ! 119: /* ! 120: * The array is used to establish a "type" for a character. The ! 121: * codes in use are: ! 122: * C - control character ! 123: * H - hexadecimal digit ! 124: * L - lower case alphabetic ! 125: * N - decimal digit ! 126: * P - punctuation ! 127: * S - whitespace ! 128: * U - upper case alphabetic ! 129: * ! 130: * Note that logical or'ing is used to associate more than one attribute ! 131: * with a character. ! 132: */ ! 133: ! 134: /* ! 135: * Macros for determining character type. ! 136: * ! 137: * The table cytpe classifies each character ! 138: * in one of the categories defined below. ! 139: */ ! 140: ! 141: #define _U 01 /* upper case */ ! 142: #define _L 02 /* lower case */ ! 143: #define _N 04 /* digit */ ! 144: #define _S 010 /* space */ ! 145: #define _P 020 /* punctuation */ ! 146: #define _C 040 /* control */ ! 147: #define _X 0100 /* hex digit (a-f) */ ! 148: ! 149: #define isalpha(c) (ctype[(c)&0377]&(_U|_L)) ! 150: #define isupper(c) (ctype[(c)&0377]&_U) ! 151: #define islower(c) (ctype[(c)&0377]&_L) ! 152: #define isdigit(c) (ctype[(c)&0377]&_N) ! 153: #define isxdigit(c) (ctype[(c)&0377]&(_N|_X)) ! 154: #define isspace(c) (ctype[(c)&0377]&_S) ! 155: #define ispunct(c) (ctype[(c)&0377]&_P) ! 156: #define isalnum(c) (ctype[(c)&0377]&(_U|_L|_N)) ! 157: #define isprint(c) (ctype[(c)&0377]&(_P|_U|_L|_N)) ! 158: #define iscntrl(c) (ctype[(c)&0377]&_C) ! 159: #define isascii(c) ((unsigned)(c)<=0177) ! 160: #define toupper(c) (((c)&0377)-'a'+'A') ! 161: #define tolower(c) (((c)&0377)-'A'+'a') ! 162: #define toascii(c) (((c)&0177) ! 163: #define tonum(c) (isdigit(c)?(c)-'0':10+(((c)|(040))-'a')) ! 164: ! 165: char ctype[] = { ! 166: _C, _C, _C, _C, _C, _C, _C, _C, ! 167: _C, _S, _S, _S, _S, _S, _C, _C, ! 168: _C, _C, _C, _C, _C, _C, _C, _C, ! 169: _C, _C, _C, _C, _C, _C, _C, _C, ! 170: _S, _P, _P, _P, _P, _P, _P, _P, ! 171: _P, _P, _P, _P, _P, _P, _P, _P, ! 172: _N, _N, _N, _N, _N, _N, _N, _N, ! 173: _N, _N, _P, _P, _P, _P, _P, _P, ! 174: _P, _U|_X, _U|_X, _U|_X, _U|_X, _U|_X, _U|_X, _U, ! 175: _U, _U, _U, _U, _U, _U, _U, _U, ! 176: _U, _U, _U, _U, _U, _U, _U, _U, ! 177: _U, _U, _U, _P, _P, _P, _P, _P, ! 178: _P, _L|_X, _L|_X, _L|_X, _L|_X, _L|_X, _L|_X, _L, ! 179: _L, _L, _L, _L, _L, _L, _L, _L, ! 180: _L, _L, _L, _L, _L, _L, _L, _L, ! 181: _L, _L, _L, _P, _P, _P, _P, _C, ! 182: 0, 0, 0, 0, 0, 0, 0, 0, ! 183: 0, 0, 0, 0, 0, 0, 0, 0, ! 184: 0, 0, 0, 0, 0, 0, 0, 0, ! 185: 0, 0, 0, 0, 0, 0, 0, 0, ! 186: 0, 0, 0, 0, 0, 0, 0, 0, ! 187: 0, 0, 0, 0, 0, 0, 0, 0, ! 188: 0, 0, 0, 0, 0, 0, 0, 0, ! 189: 0, 0, 0, 0, 0, 0, 0, 0, ! 190: 0, 0, 0, 0, 0, 0, 0, 0, ! 191: 0, 0, 0, 0, 0, 0, 0, 0, ! 192: 0, 0, 0, 0, 0, 0, 0, 0, ! 193: 0, 0, 0, 0, 0, 0, 0, 0, ! 194: 0, 0, 0, 0, 0, 0, 0, 0, ! 195: 0, 0, 0, 0, 0, 0, 0, 0, ! 196: 0, 0, 0, 0, 0, 0, 0, 0, ! 197: 0, 0, 0, 0, 0, 0, 0, 0 ! 198: }; ! 199: /* ! 200: * cvcset(d, cs, csbuf) - convert d to a cset and ! 201: * make cs point to it, using csbuf as a buffer if necessary. ! 202: */ ! 203: ! 204: cvcset(d, cs, csbuf) ! 205: register struct descrip *d; ! 206: int **cs, *csbuf; ! 207: { ! 208: register char *s; ! 209: register word l; ! 210: char sbuf[MaxCvtLen]; ! 211: ! 212: Inc(cv_n_cset); ! 213: ! 214: ! 215: if (!Qual(*d) && (d)->dword == D_Cset) { ! 216: Inc(cv_n_rcset); ! 217: *cs = BlkLoc(*d)->cset.bits; ! 218: return T_Cset; ! 219: } ! 220: ! 221: if (cvstr(d, sbuf) == NULL) ! 222: return NULL; ! 223: ! 224: for (l = 0; l < CsetSize; l++) ! 225: csbuf[l] = 0; ! 226: ! 227: s = StrLoc(*d); ! 228: l = StrLen(*d); ! 229: while (l--) { ! 230: Setb(*s, csbuf); ! 231: s++; ! 232: } ! 233: *cs = csbuf; ! 234: return 1; ! 235: } ! 236: ! 237: ! 238: /* ! 239: * cvint - convert the value represented by dp into an integer and write ! 240: * the value into the location referenced by i. cvint returns Integer or ! 241: * NULL depending on the outcome of the conversion. ! 242: */ ! 243: ! 244: cvint(dp, i) ! 245: register struct descrip *dp; ! 246: long *i; ! 247: { ! 248: union numeric result; ! 249: int minsh, maxsh; ! 250: ! 251: minsh = MinShort; ! 252: maxsh = MaxShort; ! 253: ! 254: #ifdef RunStats ! 255: Inc(cv_n_int); ! 256: if (!Qual(*dp) && (dp)->dword == D_Integer) ! 257: cv_n_rint++; ! 258: #endif RunStats ! 259: /* ! 260: * Use cvnum to attempt the conversion into "result". ! 261: */ ! 262: switch (cvnum(dp, &result)) { ! 263: ! 264: case T_Integer: ! 265: *i = result.integer; ! 266: return T_Integer; ! 267: ! 268: case T_Longint: ! 269: *i = result.integer; ! 270: return T_Longint; ! 271: ! 272: case T_Real: ! 273: /* ! 274: * The value converted into a real number. If it's not in the ! 275: * range of an integer, return a 0, otherwise convert the ! 276: * real value into an integer. As before, distinguish between ! 277: * integers and long integers if necessary. ! 278: */ ! 279: if (result.real > MaxLong || result.real < MinLong) ! 280: return NULL; ! 281: *i = (long)result.real; ! 282: #if IntSize == 16 ! 283: if (*i < (long)minsh || *i > (long)maxsh) ! 284: return T_Longint; ! 285: #endif IntSize == 16 ! 286: return T_Integer; ! 287: ! 288: default: ! 289: return NULL; ! 290: } ! 291: } ! 292: ! 293: ! 294: /* ! 295: * cvnum - convert the value represented by d into a numeric quantity and ! 296: * place the value into *result. Value returned is Integer, D_Real, or ! 297: * NULL. ! 298: */ ! 299: ! 300: /* >cvnum */ ! 301: cvnum(dp,result) ! 302: register struct descrip *dp; ! 303: union numeric *result; ! 304: { ! 305: static char sbuf[MaxCvtLen]; ! 306: ! 307: Inc(cv_n_num); ! 308: if (Qual(*dp)) { ! 309: qtos(dp, sbuf); ! 310: return ston(sbuf, result); ! 311: } ! 312: ! 313: switch (Type(*dp)) { ! 314: ! 315: case T_Integer: ! 316: Inc(cv_n_rnum); ! 317: result->integer = (long)IntVal(*dp); ! 318: return T_Integer; ! 319: ! 320: case T_Longint: ! 321: Inc(cv_n_rnum); ! 322: result->integer = BlkLoc(*dp)->longint.intval; ! 323: return T_Longint; ! 324: ! 325: case T_Real: ! 326: Inc(cv_n_rnum); ! 327: GetReal(dp,result->real); ! 328: return T_Real; ! 329: ! 330: default: ! 331: /* ! 332: * Try to convert the value to a string and ! 333: * then try to convert the string to an integer. ! 334: */ ! 335: if (cvstr(dp, sbuf) == NULL) ! 336: return NULL; ! 337: return ston(StrLoc(*dp), result); ! 338: } ! 339: } ! 340: /* <cvnum */ ! 341: ! 342: #define BIG 72057594037927936. /* numbers larger than 2^56 lose precision */ ! 343: ! 344: /* ! 345: * ston - convert a string to a numeric quantity if possible. ! 346: */ ! 347: static ston(s, result) ! 348: register char *s; ! 349: union numeric *result; ! 350: { ! 351: register int c; ! 352: int realflag = 0; /* indicates a real number */ ! 353: char msign = '+'; /* sign of mantissa */ ! 354: char esign = '+'; /* sign of exponent */ ! 355: double mantissa = 0; /* scaled mantissa with no fractional part */ ! 356: int scale = 0; /* number of decimal places to shift mantissa */ ! 357: int digits = 0; /* total number of digits seen */ ! 358: int sdigits = 0; /* number of significant digits seen */ ! 359: int exponent = 0; /* exponent part of real number */ ! 360: double fiveto; /* holds 5^scale */ ! 361: double power; /* holds successive squares of 5 to compute fiveto */ ! 362: int minsh, maxsh; ! 363: #ifndef VMS ! 364: extern int errno; ! 365: #else VMS ! 366: #include <errno.h> ! 367: #endif ! 368: ! 369: minsh = MinShort; ! 370: maxsh = MaxShort; ! 371: ! 372: c = *s++; ! 373: ! 374: /* ! 375: * Skip leading white space. ! 376: */ ! 377: while (isspace(c)) ! 378: c = *s++; ! 379: ! 380: /* ! 381: * Check for sign. ! 382: */ ! 383: if (c == '+' || c == '-') { ! 384: msign = c; ! 385: c = *s++; ! 386: } ! 387: ! 388: /* ! 389: * Get integer part of mantissa. ! 390: */ ! 391: while (isdigit(c)) { ! 392: digits++; ! 393: if (mantissa < BIG) { ! 394: mantissa = mantissa * 10 + (c - '0'); ! 395: if (mantissa > 0.0) ! 396: sdigits++; ! 397: } ! 398: else ! 399: scale++; ! 400: c = *s++; ! 401: } ! 402: ! 403: /* ! 404: * Check for based integer. ! 405: */ ! 406: if (c == 'r' || c == 'R') ! 407: return radix(msign, (int)mantissa, s, result); ! 408: ! 409: /* ! 410: * Get fractional part of mantissa. ! 411: */ ! 412: if (c == '.') { ! 413: realflag++; ! 414: c = *s++; ! 415: while (isdigit(c)) { ! 416: digits++; ! 417: if (mantissa < BIG) { ! 418: mantissa = mantissa * 10 + (c - '0'); ! 419: scale--; ! 420: if (mantissa > 0.0) ! 421: sdigits++; ! 422: } ! 423: c = *s++; ! 424: } ! 425: } ! 426: ! 427: /* ! 428: * Check that at least one digit has been seen so far. ! 429: */ ! 430: if (digits == 0) ! 431: return NULL; ! 432: ! 433: /* ! 434: * Get exponent part. ! 435: */ ! 436: if (c == 'e' || c == 'E') { ! 437: realflag++; ! 438: c = *s++; ! 439: if (c == '+' || c == '-') { ! 440: esign = c; ! 441: c = *s++; ! 442: } ! 443: if (!isdigit(c)) ! 444: return NULL; ! 445: while (isdigit(c)) { ! 446: exponent = exponent * 10 + (c - '0'); ! 447: c = *s++; ! 448: } ! 449: scale += (esign == '+')? exponent : -exponent; ! 450: } ! 451: ! 452: /* ! 453: * Skip trailing white space. ! 454: */ ! 455: while (isspace(c)) ! 456: c = *s++; ! 457: ! 458: /* ! 459: * Check that entire string has been consumed. ! 460: */ ! 461: if (c != '\0') ! 462: return NULL; ! 463: ! 464: /* ! 465: * Test for integer. ! 466: */ ! 467: if (!realflag && mantissa >= MinLong && mantissa <= MaxLong) { ! 468: result->integer = (msign == '+')? mantissa : -mantissa; ! 469: #if IntSize == 16 ! 470: if (result->integer < (long)minsh || result->integer > (long)maxsh) ! 471: return T_Longint; ! 472: #endif IntSize == 16 ! 473: return T_Integer; ! 474: } ! 475: ! 476: /* ! 477: * Rough tests for overflow and underflow. ! 478: */ ! 479: if (sdigits + scale > LogHuge) ! 480: return NULL; ! 481: ! 482: if (sdigits + scale < -LogHuge) { ! 483: result->real = 0.0; ! 484: return T_Real; ! 485: } ! 486: ! 487: /* ! 488: * Put the number together by multiplying the mantissa by 5^scale and ! 489: * then using ldexp() to multiply by 2^scale. ! 490: */ ! 491: ! 492: #ifdef PDP11 ! 493: /* ! 494: * Load floating point status register on PDP-11. ! 495: */ ! 496: ldfps(0200); ! 497: #endif PDP11 ! 498: exponent = (scale > 0)? scale : -scale; ! 499: fiveto = 1.0; ! 500: power = 5.0; ! 501: for (;;) { ! 502: if (exponent & 01) ! 503: fiveto *= power; ! 504: exponent >>= 1; ! 505: if (exponent == 0) ! 506: break; ! 507: power *= power; ! 508: } ! 509: if (scale > 0) ! 510: mantissa *= fiveto; ! 511: else ! 512: mantissa /= fiveto; ! 513: ! 514: errno = 0; ! 515: mantissa = ldexp(mantissa, scale); ! 516: #ifdef PDP11 ! 517: /* ! 518: * Load floating point status register on PDP-11 ! 519: */ ! 520: ldfps(03200); ! 521: #endif PDP11 ! 522: if (errno > 0 && mantissa > 0) ! 523: /* ! 524: * ldexp caused overflow. ! 525: */ ! 526: return NULL; ! 527: ! 528: result->real = (msign == '+')? mantissa : -mantissa; ! 529: return T_Real; ! 530: } ! 531: ! 532: /* ! 533: * radix - convert string s in radix r into an integer in *result. sign ! 534: * will be either '+' or '-'. ! 535: */ ! 536: static radix(sign, r, s, result) ! 537: char sign; ! 538: register int r; ! 539: register char *s; ! 540: union numeric *result; ! 541: { ! 542: register int c; ! 543: long num; ! 544: int minsh, maxsh; ! 545: ! 546: minsh = MinShort; ! 547: maxsh = MaxShort; ! 548: ! 549: if (r < 2 || r > 36) ! 550: return NULL; ! 551: ! 552: c = *s++; ! 553: num = 0L; ! 554: while (isalnum(c)) { ! 555: c = tonum(c); ! 556: if (c >= r) ! 557: return NULL; ! 558: num = num * r + c; ! 559: c = *s++; ! 560: } ! 561: ! 562: while (isspace(c)) ! 563: c = *s++; ! 564: ! 565: if (c != '\0') ! 566: return NULL; ! 567: ! 568: result->integer = (sign == '+')? num : -num; ! 569: if (result->integer < (long)minsh || result->integer > (long)maxsh) ! 570: return T_Longint; ! 571: else ! 572: return T_Integer; ! 573: } ! 574: ! 575: ! 576: /* ! 577: * cvpos - convert position to strictly positive position ! 578: * given length. ! 579: */ ! 580: ! 581: word cvpos(pos, len) ! 582: long pos; ! 583: register word len; ! 584: { ! 585: register word p; ! 586: ! 587: /* ! 588: * Return 0 if the position isn't in the range of an int. (?) ! 589: */ ! 590: if ((long)(p = pos) != pos) ! 591: return(0); ! 592: /* ! 593: * Return 0 if the position is off either end. ! 594: */ ! 595: if (p < -len || p > len + 1) ! 596: return(0); ! 597: /* ! 598: * If the position is greater than zero, just return it. Otherwise, ! 599: * convert the zero/negative position. ! 600: */ ! 601: if (pos > 0) ! 602: return p; ! 603: return (len + p + 1); ! 604: } ! 605: ! 606: ! 607: /* ! 608: * cvreal - convert to real and put the result into *r. ! 609: */ ! 610: ! 611: cvreal(d, r) ! 612: register struct descrip *d; ! 613: double *r; ! 614: { ! 615: union numeric result; ! 616: ! 617: #ifdef RunStats ! 618: Inc(cv_n_real); ! 619: if (!Qual(*d) && (d)->dword == D_Real) ! 620: cv_n_rreal++; ! 621: #endif RunStats ! 622: /* ! 623: * Use cvnum to classify the value. Cast integers into reals and ! 624: * fail if the value is non-numeric. ! 625: */ ! 626: switch (cvnum(d, &result)) { ! 627: ! 628: case T_Integer: ! 629: case T_Longint: ! 630: *r = result.integer; ! 631: return T_Real; ! 632: ! 633: case T_Real: ! 634: *r = result.real; ! 635: return T_Real; ! 636: ! 637: default: ! 638: return NULL; ! 639: } ! 640: } ! 641: ! 642: ! 643: /* ! 644: * cvstr(d,s) - convert d (in place) into a string, using s as buffer ! 645: * if necessary. cvstr returns 0 if the conversion fails, 1 if d ! 646: * wasn't a string but was converted into one, and 2 if d was already ! 647: * a string. When a string conversion takes place, sbuf gets the ! 648: * resulting string. ! 649: */ ! 650: ! 651: /* >cvstr */ ! 652: cvstr(dp, sbuf) ! 653: register struct descrip *dp; ! 654: char *sbuf; ! 655: { ! 656: double rres; ! 657: ! 658: Inc(cv_n_str); ! 659: if (Qual(*dp)) { ! 660: Inc(cv_n_rstr); ! 661: return NoCvt; /* It is already a string */ ! 662: } ! 663: ! 664: switch (Type(*dp)) { ! 665: /* ! 666: * For types that can be converted into strings, call the ! 667: * appropriate conversion routine and return its result. ! 668: * Note that the conversion routines change the descriptor ! 669: * pointed to by dp. ! 670: */ ! 671: case T_Integer: ! 672: return itos((long)IntVal(*dp), dp, sbuf); ! 673: ! 674: case T_Longint: ! 675: return itos(BlkLoc(*dp)->longint.intval, dp, sbuf); ! 676: ! 677: case T_Real: ! 678: GetReal(dp,rres); ! 679: return rtos(rres, dp, sbuf); ! 680: ! 681: case T_Cset: ! 682: return cstos(BlkLoc(*dp)->cset.bits, dp, sbuf); ! 683: ! 684: default: ! 685: /* ! 686: * The value cannot be converted to a string. ! 687: */ ! 688: return NULL; ! 689: } ! 690: } ! 691: /* <cvstr */ ! 692: ! 693: /* ! 694: * itos - convert the integer num into a string using s as a buffer and ! 695: * making q a descriptor for the resulting string. ! 696: */ ! 697: static itos(num, q, s) ! 698: long num; ! 699: struct descrip *q; ! 700: char *s; ! 701: { ! 702: register char *p; ! 703: long ival; ! 704: ! 705: p = s + MaxCvtLen - 1; ! 706: ival = num; ! 707: ! 708: *p = '\0'; ! 709: if (num >= 0L) ! 710: do { ! 711: *--p = ival % 10L + '0'; ! 712: ival /= 10L; ! 713: } while (ival != 0L); ! 714: else { ! 715: do { ! 716: *--p = '0' - (ival % 10L); ! 717: ival /= 10L; ! 718: } while (ival != 0L); ! 719: *--p = '-'; ! 720: } ! 721: ! 722: StrLen(*q) = s + MaxCvtLen - 1 - p; ! 723: StrLoc(*q) = p; ! 724: return Cvt; ! 725: } ! 726: ! 727: /* ! 728: * rtos - convert the real number n into a string using s as a buffer and ! 729: * making q a descriptor for the resulting string. ! 730: */ ! 731: rtos(n, q, s) ! 732: double n; ! 733: struct descrip *q; ! 734: char *s; ! 735: { ! 736: char *gcvt(); ! 737: /* ! 738: * gcvt does all the work. ! 739: */ ! 740: gcvt(n, 8, s); ! 741: StrLen(*q) = strlen(s); ! 742: StrLoc(*q) = s; ! 743: return Cvt; ! 744: } ! 745: ! 746: /* ! 747: * cstos - convert the cset bit array pointed at by cs into a string using ! 748: * s as a buffer and making q a descriptor for the resulting string. ! 749: */ ! 750: ! 751: /* >cstos */ ! 752: static cstos(cs, q, s) ! 753: int *cs; ! 754: struct descrip *q; ! 755: char *s; ! 756: { ! 757: register char *p; ! 758: register int i; ! 759: ! 760: p = s; ! 761: for (i = 0; i < CsetSize * CIntSize; i++) { ! 762: if (Testb(i, cs)) ! 763: *p++ = (char)i; ! 764: } ! 765: *p = '\0'; ! 766: ! 767: StrLen(*q) = p - s; ! 768: StrLoc(*q) = s; ! 769: return Cvt; ! 770: } ! 771: /* <cstos */ ! 772: ! 773: ! 774: /* ! 775: * gcvt - Convert number to a string in buf. If possible, ndigit significant ! 776: * digits are produced, otherwise a form with an exponent is used. ! 777: */ ! 778: char *ecvt(); ! 779: char * ! 780: gcvt(number, ndigit, buf) ! 781: double number; ! 782: char *buf; ! 783: { ! 784: int sign, decpt; ! 785: register char *p1, *p2; ! 786: register i; ! 787: ! 788: ! 789: p1 = ecvt(number, ndigit, &decpt, &sign); ! 790: p2 = buf; ! 791: if (sign) ! 792: *p2++ = '-'; ! 793: for (i=ndigit-1; i>0 && p1[i]=='0'; i--) ! 794: ndigit--; ! 795: if (decpt >= 0 && decpt-ndigit > 4 ! 796: || decpt < 0 && decpt < -3) { /* use E-style */ ! 797: decpt--; ! 798: *p2++ = *p1++; ! 799: *p2++ = '.'; ! 800: for (i=1; i<ndigit; i++) ! 801: *p2++ = *p1++; ! 802: *p2++ = 'e'; ! 803: if (decpt<0) { ! 804: decpt = -decpt; ! 805: *p2++ = '-'; ! 806: } ! 807: if (decpt/10 > 0) ! 808: *p2++ = decpt/10 + '0'; ! 809: *p2++ = decpt%10 + '0'; ! 810: } else { ! 811: if (decpt<=0) { ! 812: /* if (*p1!='0') */ ! 813: *p2++ = '0'; ! 814: *p2++ = '.'; ! 815: while (decpt<0) { ! 816: decpt++; ! 817: *p2++ = '0'; ! 818: } ! 819: } ! 820: for (i=1; i<=ndigit; i++) { ! 821: *p2++ = *p1++; ! 822: if (i==decpt) ! 823: *p2++ = '.'; ! 824: } ! 825: if (ndigit<decpt) { ! 826: while (ndigit++<decpt) ! 827: *p2++ = '0'; ! 828: *p2++ = '.'; ! 829: } ! 830: } ! 831: if (p2[-1]=='.') ! 832: *p2++ = '0'; ! 833: *p2 = '\0'; ! 834: return(buf); ! 835: } ! 836: ! 837: ! 838: /* ! 839: * mkint - make an integer descriptor for l in *d. A long integer is used ! 840: * if the value is too large for a regular integer. ! 841: */ ! 842: ! 843: mkint(l, d) ! 844: long l; ! 845: register struct descrip *d; ! 846: { ! 847: extern struct b_int *alclint(); ! 848: int minsh, maxsh; ! 849: ! 850: minsh = MinShort; ! 851: maxsh = MaxShort; ! 852: ! 853: if (l < (long)minsh || l > (long)maxsh) { ! 854: blkreq(sizeof(struct b_int)); ! 855: d->dword = D_Longint; ! 856: BlkLoc(*d) = (union block *)alclint(l); ! 857: } ! 858: else { ! 859: d->dword = D_Integer; ! 860: IntVal(*d) = (word)l; ! 861: } ! 862: } ! 863: ! 864: ! 865: /* ! 866: * mkreal(r, d) - make a real number descriptor and associated block ! 867: * for r and place it in *d. ! 868: */ ! 869: ! 870: mkreal(r, d) ! 871: double r; ! 872: register struct descrip *d; ! 873: { ! 874: extern struct b_real *alcreal(); ! 875: ! 876: blkreq((uword)sizeof(struct b_real)); ! 877: d->dword = D_Real; ! 878: BlkLoc(*d) = (union block *) alcreal(r); ! 879: } ! 880: ! 881: ! 882: /* ! 883: * mksubs - form a substring. var is a descriptor for the string from ! 884: * which the substring is to be formed. var may be a variable. val ! 885: * is a dereferenced version of val. The descriptor for the resulting ! 886: * substring is placed in *result. The substring starts at position ! 887: * i and extends for j characters. ! 888: */ ! 889: ! 890: mksubs(var, val, i, j, result) ! 891: register struct descrip *var, *val, *result; ! 892: word i, j; ! 893: { ! 894: extern struct b_tvsubs *alcsubs(); ! 895: ! 896: if (Qual(*var) || !Var(*var)) { ! 897: /* ! 898: * var isn't a variable, just form a descriptor that points into ! 899: * the string named by val. ! 900: */ ! 901: StrLen(*result) = j; ! 902: StrLoc(*result) = StrLoc(*val) + i - 1; ! 903: return; ! 904: } ! 905: ! 906: if ((var)->dword == D_Tvsubs) { ! 907: /* ! 908: * If var is a substring trapped variable, ! 909: * adjust the position and make var the substrung string. ! 910: */ ! 911: i += BlkLoc(*var)->tvsubs.sspos - 1; ! 912: var = &BlkLoc(*var)->tvsubs.ssvar; ! 913: } ! 914: ! 915: /* ! 916: * Make a substring trapped variable by passing the buck to alcsubs. ! 917: */ ! 918: result->dword = D_Tvsubs; ! 919: BlkLoc(*result) = (union block *) alcsubs(j, i, var); ! 920: return; ! 921: } ! 922: ! 923: ! 924: /* ! 925: * strprc - Convert the qualified string named by *d into a procedure ! 926: * descriptor if possible. n is the number of arguments that the desired ! 927: * procedure has. n is only used when the name of the procedure is ! 928: * non-alphabetic (hence, an operator). ! 929: * A return value of 1 indicates successful conversion. ! 930: * 0 indicates that the string could not be converted. ! 931: */ ! 932: strprc(d,n) ! 933: struct descrip *d; ! 934: word n; ! 935: { ! 936: extern struct descrip *gnames, *globals, *eglobals; ! 937: struct descrip *np, *gp; ! 938: struct pstrnm *p; ! 939: char *s; ! 940: word ns, l; ! 941: ! 942: /* ! 943: * Look in global name list first. ! 944: */ ! 945: np = gnames; gp = globals; ! 946: while (gp < eglobals) { ! 947: if (!lexcmp(np++,d)) ! 948: if (BlkLoc(*gp)->proc.title == T_Proc) { ! 949: StrLen(*d) = D_Proc; /* really type field */ ! 950: BlkLoc(*d) = BlkLoc(*gp); ! 951: return 1; ! 952: } ! 953: gp++; ! 954: } ! 955: /* ! 956: * The name is not a global, see if it is a builtin or an operator. ! 957: */ ! 958: s = StrLoc(*d); ! 959: l = StrLen(*d); ! 960: for (p = pntab; p->pstrep; p++) ! 961: /* ! 962: * Compare the desired name with each standard procedure/operator ! 963: * name. ! 964: */ ! 965: if (!slcmp(s,l,p->pstrep)) { ! 966: if (isalpha(*s)) { ! 967: /* ! 968: * The names are the same and s starts with an alphabetic, ! 969: * so it's the one being looked for; return it. ! 970: */ ! 971: StrLen(*d) = D_Proc; ! 972: BlkLoc(*d) = (union block *) p->pblock; ! 973: return 1; ! 974: } ! 975: if ((ns = p->pblock->nstatic) < 0) ! 976: ns = -ns; ! 977: else ! 978: ns = p->pblock->nparam; ! 979: if (n == ns) { ! 980: StrLen(*d) = D_Proc; /* really type field */ ! 981: BlkLoc(*d) = (union block *) p->pblock; ! 982: return 1; ! 983: } ! 984: } ! 985: return 0; ! 986: } ! 987: ! 988: /* ! 989: * slcmp - lexically compare l1 bytes of s1 with null-terminated s2. ! 990: */ ! 991: ! 992: slcmp(s1, l1, s2) ! 993: word l1; ! 994: char *s1,*s2; ! 995: { ! 996: register word minlen; ! 997: word l2; ! 998: ! 999: l2 = strlen(s2); ! 1000: ! 1001: minlen = (l1 <= l2) ? l1 : l2; ! 1002: ! 1003: while (minlen--) ! 1004: if (*s1++ != *s2++) ! 1005: return (int)((*--s1 & 0377) - (*--s2 & 0377)); ! 1006: ! 1007: return (int)(l1 - l2); ! 1008: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.