![[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.