1 /*
2 **********************************************************************
3 * *
4 * ML/I macro processor -- C version *
5 * *
6 * Module 3 - Main subroutines *
7 * *
8 * Copyright (C) R.D. Eager MMXVIII *
9 * P.J. Brown University of Kent MCMLXVII *
10 * *
11 **********************************************************************
12 */
13
14
15 #include "ml1.h"
16
17
advnce()18 INT advnce()
19 /* Function to advance to next character in the current text; yields
20 FALSE if at end of current text, otherwise yields TRUE. */
21 { INT c;
22 INT n;
23
24 sdb.spt++;
25 if(sdb.spt == sdb.stoppt) return(FALSE);
26 if(sdb.spt != ffpt) return(TRUE);
27
28 /* Stack is empty, and source text is being scanned - read in more text */
29
30 c = mdread();
31
32 if(nlsw && (c != EOFCH)) { /* Avoid lone EOFCH being treated as a line */
33 n = ++(*at_s2); /* Update and copy S2 */
34
35 if(tlinct == sdb.linect) tlinct = n;
36 sdb.linect = n;
37
38 if(*at_s1 != 0) { /* Insert startline */
39 *ffpt = SLREP;
40 bumpff((INT) 1);
41 }
42 }
43
44 if(c == EOFCH) { /* End of input */
45 ffpt = sdb.spt;
46 if(!nlsw) { /* Add preceding newline, if necessary */
47 *ffpt = '\n';
48 bumpff((INT) 1);
49 }
50 *ffpt = EOFCH;
51 } else {
52 nlsw = (c == '\n');
53 *ffpt = c;
54 }
55 bumpff((INT) 1);
56 return(TRUE);
57 }
58
59
60 #if ANSI
bumpff(INT n)61 VOID bumpff(INT n)
62 #else
63 VOID bumpff(n)
64 INT n;
65 #endif
66 /* Routine to increase 'ffpt', checking for stack overflow. */
67 { ffpt += n;
68 if(ffpt >= lfpt) erlso();
69 }
70
71
chatom()72 VOID chatom()
73 /* Routine to check that the argument described by 'sdb.argno' and
74 'opdb.arglen' is exactly one atom. */
75 { if(opdb.arglen == 0) erlia();
76
77 gtatom();
78
79 if(idlen != opdb.arglen) erlia();
80 }
81
82
chekid()83 VOID chekid()
84 /* Routine to check that the current text consists (after removal of
85 leading and trailing spaces) of exactly one atom. */
86 { if(!gsatom()) erlia();
87 if(gsatom()) erlia();
88 }
89
90
91 #if ANSI
ckvaly(INT * ptr,INT type)92 INT ckvaly(INT *ptr,INT type)
93 #else
94 INT ckvaly(ptr,type)
95 INT *ptr,type;
96 #endif
97 /* Function to check whether a specified construction is currently
98 valid; yields TRUE if it is, otherwise yields FALSE. */
99 { if(ptr > endpt) return(TRUE); /* Outside stacks - must be an operation macro */
100 return(ptr < (INT *)(sdb.hashpt[LHV+type-1]));
101 }
102
103
104 #if ANSI
cmpare(INT * ptr)105 INT cmpare(INT *ptr)
106 #else
107 INT cmpare(ptr)
108 INT *ptr;
109 #endif
110 /* Function to compare two atoms; yields FALSE if comparison fails,
111 otherwise yields TRUE. On return, 'infopt' points beyond the matched
112 atom. */
113 { INT i;
114
115 if(idlen != *++ptr) return(FALSE);
116 infopt = ++ptr + idlen;
117
118 for(i = 0; i < idlen; i++) {
119 if(ptr[i] != idpt[i]) return(FALSE);
120 }
121 return(TRUE);
122 }
123
124
125 #if ANSI
corect(INT n,INT ** ptr)126 static VOID corect(INT n,INT **ptr)
127 #else
128 static VOID corect(n,ptr)
129 INT n;
130 INT **ptr;
131 #endif
132 /* Routine to relocate a pointer - called from 'mkroom' and 'mkcroom'. */
133 { if((ndefpt <= *ptr) && (*ptr <= sdb.inffpt)) *ptr += n;
134 }
135
136
decalv()137 INT decalv()
138 /* Routine to restore previously stacked scan information at the end of
139 a nested construction. Yields FALSE if level of calls has become zero,
140 otherwise yields TRUE. */
141 { nestlv--;
142 if(nestlv == 0) return(FALSE);
143 delpt = (INT *) (lfpt[0]);
144 sdb.mtchpt = (INT *) (lfpt[1]);
145 sdb.mchlin = lfpt[2];
146 cllfpt = lfpt = lfpt + 3;
147 return(TRUE);
148 }
149
150
151 #if ANSI
declf(INT n)152 VOID declf(INT n)
153 #else
154 VOID declf(n)
155 INT n;
156 #endif
157 /* Routine to decrease 'lfpt', checking for stack overflow. */
158 {
159 #if ATT3B | BSD4 | FBSD32 | FBSD64 | IBMC | MSC | VMS | WIN | ZTC | ZTCX
160 lfpt -= n;
161 if(ffpt >= lfpt) erlso();
162 #endif
163 #if L1
164 if(ffpt + n >= lfpt) erlso();
165 lfpt -= n;
166 #endif
167 }
168
169
er1tst()170 VOID er1tst()
171 /* Routine to check the validity of a macro element, as described by
172 'varpt' and 'meval'; gives error if not valid. */
173 { if((varpt == NULLPT) || (meval > *varpt) || (meval <= 0)) erlme();
174 }
175
176
encall()177 VOID encall()
178 /* Routine to stack and re-initialise scanning information when a nested
179 construction is encountered. 'cllfpt' is set to point to the latest
180 block of information stacked (this is used by 'prmiss' to "back up" if
181 stack overflow occurs). */
182 { if(nestlv != 0) {
183 declf((INT) 3);
184 lfpt[0] = (INT) delpt;
185 lfpt[1] = (INT) sdb.mtchpt;
186 lfpt[2] = sdb.mchlin;
187 }
188 cllfpt = lfpt;
189 delpt = binfpt + bindic - 2;
190 sdb.mtchpt = bfndpt;
191 sdb.mchlin = sdb.linect;
192 nestlv++;
193 }
194
195
gargch()196 INT gargch()
197 /* Function to set 'sdb.spt' to point at first non-space character in the
198 current text; yields FALSE if end of current text reached, otherwise
199 yields TRUE. */
200 { while(advnce()) {
201 if(*sdb.spt != ' ') return(TRUE);
202 }
203 return(FALSE);
204 }
205
206
getexp()207 VOID getexp()
208 /* Routine to read an expression from the current text, and evaluate it.
209 Constants and variables are permitted; evaluation is from left to right
210 with no operator precedence. */
211 { INT varsw = TRUE;
212 INT sum = 0;
213 INT negval = FALSE;
214 INT *olidpt = sdb.spt;
215 #if !ANSI
216 INT *dumpt;
217 #endif
218 INT opsw = 0;
219 INT op1 = 0; /* To satisfy optimisers */
220
221 meval = 0;
222
223 while(gsatom()) {
224 INT op = *idpt;
225
226 switch(op) {
227 default:
228 if(!varsw) erlia();
229 #if ANSI
230 if(!mdnum()) (void) gmeadd();
231 #else
232 if(!mdnum()) dumpt = gmeadd();
233 #endif
234 if(negval) meval = -meval;
235 varsw = FALSE;
236 switch(opsw) {
237 case 1:
238 meval *= op1;
239
240 #if IBMC
241 #pragma checkout(suspend)
242 #endif
243 case 0:;
244 #if IBMC
245 #pragma checkout(resume)
246 #endif
247 break;
248
249 case 2:
250 if(meval == 0) erlovf();
251 meval = mddiv(op1,meval);
252 break;
253
254 case 3: meval &= op1;
255 break;
256
257 case 4: meval |= op1;
258 break;
259
260 default:
261 macerr((INT) 9);
262 }
263 opsw = 0;
264 negval = FALSE;
265 continue;
266
267 /* Minus and plus */
268
269 case '-':
270 negval = !negval;
271
272 #if IBMC
273 #pragma checkout(suspend)
274 #endif
275 case '+':;
276 #if IBMC
277 #pragma checkout(resume)
278 #endif
279 sum += meval;
280 varsw = TRUE;
281 meval = 0;
282 continue;
283
284 /* Logical and/or */
285
286 case '/':
287 case '*':
288 case '&':
289 case '|':
290 opsw = op == '*' ? 1:
291 op == '/' ? 2:
292 op == '&' ? 3:
293 4;
294 if(varsw) erlia();
295 op1 = meval;
296 varsw = TRUE;
297 meval = 0;
298 continue;
299 }
300 }
301 if(varsw) erlia();
302 meval += sum;
303 idpt = olidpt;
304 }
305
306
gmeadd()307 INT *gmeadd()
308 /* Function to decode a (possibly subscripted) macro variable name;
309 yields the address of the macro variable. In the case of a numeric
310 variable, 'meval' is set to the previous contents and 'exprsw'
311 is set to 0; otherwise 'meval' is undefined and 'exprsw' is set
312 to 1. */
313 { INT *flagpt = idpt;
314 INT *res;
315
316 for (;;) {
317 INT c = *idpt;
318
319 if((c != 'P') &&
320 (c != 'S') &&
321 #if CVARS
322 (c != 'C') &&
323 #endif
324 (c != 'T')) {
325 if(idpt == flagpt) break;
326 if(!mdnum()) break;
327 for(;;) {
328 c = *--idpt;
329 #if CVARS
330 if(c == 'C' && idpt != flagpt) erlia();
331 /* Cannot use character variable as subscript */
332 #endif
333 varpt = (c == 'T') ? sdb.tvarpt:
334 (c == 'S') ? svarpt:
335 #if CVARS
336 (c == 'C') ? cvarpt:
337 #endif
338 pvarpt;
339 er1tst();
340 res = varpt - meval;
341 meval = varpt[-meval];
342 if(idpt == flagpt) {
343 #if CVARS
344 exprsw = (c == 'C') ? 1 : 0;
345 #endif
346 return(res);
347 }
348 }
349 } else {
350 if(idpt == sdb.spt) break;
351 idpt++;
352 }
353 }
354 erlia();
355
356 /* NOTREACHED */
357 #if IBMC
358 #pragma checkout(suspend)
359 #endif
360 #if FBSD32 | FBSD64
361 #pragma clang diagnostic push
362 #pragma clang diagnostic ignored "-Wreturn-type"
363 #endif
364 }
365 #if FBSD32 | FBSD64
366 #pragma clang diagnostic pop
367 #endif
368 #if IBMC
369 #pragma checkout(resume)
370 #endif
371
372
gsatom()373 INT gsatom()
374 /* Function to extract the next non-space atom from the current text.
375 On exit, 'idpt' and 'idlen' describe the atom. Yields FALSE if at end
376 of current text, otherwise yields TRUE. */
377 { if(gargch()) {
378 if(*sdb.spt != EOFCH) {
379 sdb.spt--;
380 gtatom();
381 return(TRUE);
382 }
383 }
384 sdb.spt--;
385 return(FALSE);
386 }
387
388
gtatom()389 VOID gtatom()
390 /* Routine to extract the next atom from the current text. On exit,
391 'idpt' and 'idlen' describe the atom. */
392 { if((levl == 0) && (sdb.skval >= 0) && (ffpt - sdb.spt == 1)) {
393 /* Clear redundant information from forwards stack */
394 ffpt = sdb.inffpt;
395 sdb.spt = ffpt - 1;
396 }
397
398 if(!advnce()) longjmp(entsave,1);
399
400 if(*sdb.spt == '\n') sdb.linect++;
401
402 idpt = sdb.spt;
403 idlen = 1;
404
405 { INT c = *sdb.spt;
406
407 #if SPECAN
408 if(xisalnum(c) || (c == *at_s6)) {
409 #else
410 if(xisalnum(c)) {
411 #endif
412 while(advnce()) {
413 c = *sdb.spt;
414 #if SPECAN
415 if(!(xisalnum(c) || (c == *at_s6))) break;
416 #else
417 if(!xisalnum(c)) break;
418 #endif
419 idlen++;
420 }
421
422 /* End of identifier */
423
424 sdb.spt--; /* Backspace over character which terminated the atom */
425 }
426 }
427 }
428
429
430 #if ANSI
431 INT ludel(INT *ptr)
432 #else
433 INT ludel(ptr)
434 INT *ptr;
435 #endif
436 /* Function to search the chain headed by 'ptr' for the atom described
437 by 'idpt' and 'idlen'; yields TRUE if it is found, otherwise yields
438 FALSE. */
439 { chanpt = ptr;
440
441 #if DEBUGGING
442 if(chanpt == NULLPT) macerr((INT) 10);
443 #endif
444
445 for(;;) {
446 chlink = *chanpt;
447 if(cmpare(chanpt + 1)) return(TRUE);
448 if(chlink == ENDCHN) return(FALSE);
449 chanpt += chlink;
450 }
451 #if IBMC
452 #pragma checkout(suspend)
453 #endif
454 }
455 #if IBMC
456 #pragma checkout(resume)
457 #endif
458
459
460 #if ANSI
461 INT *lulayk(INT pridcall)
462 #else
463 INT *lulayk(pridcall)
464 INT pridcall;
465 #endif
466 /* Function to yield the address of the entry for the keyword of a
467 layout character, or NULLPT if not found. */
468 { INT *ptr = laychn;
469 INT *tptr;
470 INT *cptr;
471
472 for(;;) {
473 tptr = ptr + 1; /* Point to LID */
474 cptr = *tptr + tptr; /* Point to actual character */
475
476 /* Compare with list of layout characters,
477 unless called from 'prid' routine */
478
479 if(!pridcall && cmpare(tptr)) {
480 idpt = cptr;
481 idlen = 1;
482 return(NULLPT);
483 }
484
485 if(*cptr == *idpt) return(ptr);
486 if(ptr == kspacs) return(NULLPT);
487 /* All the layout characters have been tried */
488
489 ptr += *ptr;
490 }
491 #if IBMC
492 #pragma checkout(suspend)
493 #endif
494 }
495 #if IBMC
496 #pragma checkout(resume)
497 #endif
498
499
500 #if ANSI
501 VOID macexp(INT wrsw)
502 #else
503 VOID macexp(wrsw)
504 INT wrsw;
505 #endif
506 /* Evaluates a macro expression. */
507 { if(wrsw) erlia();
508
509 sdb.spt--; /* Backspace to before first character of expression */
510
511 #if CVARS
512 if(sdb.spt[1] != 'C') {
513 #endif
514 getexp();
515 mdconv(meval);
516 #if CVARS
517 } else {
518 INT *cp;
519
520 idpt = ++sdb.spt;
521 idlen = sdb.stoppt - sdb.spt;
522 sdb.spt = sdb.stoppt - 1;
523
524 cp = gmeadd();
525 cp = (INT *) *cp;
526 idpt = cp + 1;
527 idlen = *cp;
528 }
529 #endif
530
531 opexit();
532 }
533
534
535 #if CVARS
536 #if ANSI
537 VOID mkcroom(INT m)
538 #else
539 VOID mkcroom(m)
540 INT m;
541 #endif
542 /* Routine to create space on the forwards stack immediately below the
543 character string variable pointer array (above the character variable storage
544 space and also above the permanent variables). This space is then used to
545 allocate 'm' additional character string variables. 'ndefpt' is left pointing
546 at the first newly allocated cell. */
547 { INT **tpt;
548 INT tsw;
549 int n = (int) (m*(cvsize+2)); /* Extra space needed */
550
551 ndefpt = cvarpt - cvnum; /* Pointer to space about to be created */
552 bumpff((INT) n); /* Make space at top of forwards stack */
553 bmove(ffpt - ndefpt - n,ndefpt,ndefpt + n);
554 sdb.dbugpt = sdb.stakpt;
555
556 for(;;) {
557 #if IBMC
558 #pragma checkout(suspend)
559 #endif
560 tsw = ((struct sdbf *)(sdb.dbugpt))->dbugsw; /* Previous 'sdb.dbugsw' */
561 if(tsw == DB_REPL) break;
562 corect(n,&(((struct sdbf *)(sdb.dbugpt))->spt));
563 /* Relocate 'sdb.spt' */
564 corect(n,&(((struct sdbf *)(sdb.dbugpt))->inffpt));
565 /* Relocate 'sdb.inffpt' */
566 if(tsw == DB_SOURCE) goto mrexit;
567 corect(n,&(((struct sdbf *)(sdb.dbugpt))->stoppt));
568 /* Relocate 'sdb.stoppt' */
569 if(tsw == DB_OPARG) {
570 tpt = (INT **) (((struct sdbf *)(sdb.dbugpt))->dbugpt);
571 goto mkr2;
572 }
573 mkr1:
574 sdb.dbugpt = (INT *) (((struct sdbf *)(sdb.dbugpt))->stakpt);
575 }
576
577 tpt = (INT **) (((struct sdbf *)(sdb.dbugpt))->argpt);
578 #if IBMC
579 #pragma checkout(resume)
580 #endif
581 mkr2:
582 tpt--;
583 if(((INT *) *tpt) == NULLPT) goto mkr1;
584 corect(n,tpt);
585 goto mkr2;
586 mrexit:
587 sdb.inffpt += n;
588 cvarpt += n; /* Relocate 'cvarpt' */
589 #if IBMC
590 #pragma checkout(suspend)
591 #endif
592 }
593 #if IBMC
594 #pragma checkout(resume)
595 #endif
596 #endif
597
598
599 #if ANSI
600 VOID mkroom(INT n)
601 #else
602 VOID mkroom(n)
603 INT n;
604 #endif
605 /* Routine to create space on the forwards stack immediately below the
606 permanent variables (above the global definitions). The number of extra
607 cells required is given by 'n'. Used to make space for a new global
608 definition, or for additional permanent variables. */
609 { INT **tpt;
610 INT tsw;
611 #if CVARS
612 int i;
613 #endif
614
615 ndefpt = pvarpt - pvnum; /* Pointer to space about to be created */
616 bumpff(n); /* Make space at top of forwards stack */
617 bmove(ffpt - ndefpt - n,ndefpt,ndefpt + n);
618 sdb.dbugpt = sdb.stakpt;
619
620 for(;;) {
621 #if IBMC
622 #pragma checkout(suspend)
623 #endif
624 tsw = ((struct sdbf *)(sdb.dbugpt))->dbugsw; /* Previous 'sdb.dbugsw' */
625 if(tsw == DB_REPL) break;
626 corect(n,&(((struct sdbf *)(sdb.dbugpt))->spt));
627 /* Relocate 'sdb.spt' */
628 corect(n,&(((struct sdbf *)(sdb.dbugpt))->inffpt));
629 /* Relocate 'sdb.inffpt' */
630 if(tsw == DB_SOURCE) goto mrexit;
631 corect(n,&(((struct sdbf *)(sdb.dbugpt))->stoppt));
632 /* Relocate 'sdb.stoppt' */
633 if(tsw == DB_OPARG) {
634 tpt = (INT **) (((struct sdbf *)(sdb.dbugpt))->dbugpt);
635 goto mkr2;
636 }
637 mkr1:
638 sdb.dbugpt = (INT *) (((struct sdbf *)(sdb.dbugpt))->stakpt);
639 }
640
641 tpt = (INT **) (((struct sdbf *)(sdb.dbugpt))->argpt);
642 #if IBMC
643 #pragma checkout(resume)
644 #endif
645 mkr2:
646 tpt--;
647 if(((INT *) *tpt) == NULLPT) goto mkr1;
648 corect(n,tpt);
649 goto mkr2;
650 mrexit:
651 pvarpt += n;
652 sdb.inffpt += n;
653 #if CVARS
654 cvarpt += n; /* Relocate 'cvarpt' */
655 for(i = 1; i <= (int) cvnum; i++)
656 #if IBMC
657 #pragma checkout(suspend)
658 #endif
659 ((INT **) cvarpt)[-i] += n;
660 /* Relocate character string variable pointers */
661 #endif
662 }
663 #if IBMC
664 #pragma checkout(resume)
665 #endif
666
667
668 VOID opexit()
669 { unopdb();
670 unsdb();
671 }
672
673
674 #if ANSI
675 VOID prarg(INT sw)
676 #else
677 VOID prarg(sw)
678 INT sw;
679 #endif
680 { sdb.hashpt = opdb.mhshpt;
681 setpts(sw);
682 sdb.spt = idpt - 1;
683 sdb.stoppt = idpt + idlen;
684 if((sw == DB_EVAL) || (sw == DB_ROPARG)) {
685 /* Delete spaces if A or operation macro argument */
686 sdb.dbugsw = (sw == DB_EVAL) ? DB_SUBARG: DB_OPARG;
687 if(gsatom()) {
688 sdb.spt = idpt - 1;
689 for(;;) {
690 if((*--sdb.stoppt) != ' ') break;
691 }
692 sdb.stoppt++;
693 }
694 } else sdb.dbugsw = sw;
695 prscan();
696 }
697
698
699 VOID prscan()
700 /* Routine to initialise variables in SDB, before scanning a new piece
701 of text. */
702 { sdb.ohsw = FALSE;
703 sdb.skval = 0;
704 sdb.linect = 1;
705 sdb.labpt = NULLPT;
706 }
707
708
709 INT ressp()
710 /* Yields FALSE if not at end of call, otherwise yields TRUE. */
711 { sdb.spt = bespt;
712 bespt = ZEROPT;
713 if(bindic != EXCLMK) {
714 sdb.linect = beslin;
715 return(bindic == ENDCHN);
716 }
717
718 /* Exclusive delimiter */
719
720 idlen = 0;
721 bindic = ENDCHN;
722 sdb.spt = idpt - 1;
723 if(*idpt == '\n') sdb.linect--;
724 return(TRUE);
725 }
726
727
728 VOID sbstpl()
729 /* Routine to set 'bestpl', the switch which determines what is to
730 happen to scanned text. */
731 { bestpl = BP_COPY; /* By default, copy text to output */
732 if(oplev != 0) bestpl = BP_STACK; /* If scanning for delimiter, stack text instead */
733 if(sdb.skval != 0) bestpl = BP_NULL; /* If scanning for label, discard text */
734 }
735
736
737 #if ANSI
738 VOID setpts(INT sw)
739 #else
740 VOID setpts(sw)
741 INT sw;
742 #endif
743 /* Routine to set up 'idpt' and 'idlen' to describe the argument
744 (if 'sw' = 'DB_ROPARG' or 'DB_SUBARG' or 'DB_EVAL') or delimiter
745 (if 'sw' = 'DB_DELIM') specified by 'sdb.argno'. */
746 { INT n = sdb.argno*2;
747
748 if(sw == DB_DELIM) n++;
749 #if DEBUGGING
750 if((sw != DB_ROPARG) && (sw != DB_SUBARG) && (sw != DB_EVAL) && (sw != DB_DELIM)) macerr((INT) 11);
751 #endif
752 idpt = (INT *) (sdb.dbugpt[-n]);
753 idlen = ((INT *) (sdb.dbugpt[-n-1])) - idpt;
754 }
755
756
757 #if ANSI
758 INT sklab(INT l)
759 #else
760 INT sklab(l)
761 INT l;
762 #endif
763 /* Function to determine whether a given label is present in the current
764 text; yields TRUE if it is, otherwise yields FALSE. 'chanpt' is set to
765 the offset of the label from the end of the text. */
766 { chanpt = sdb.labpt;
767 while(chanpt != NULLPT) {
768 if(chanpt[1] == l) {
769 chanpt += 2;
770 return(TRUE);
771 }
772 chanpt = (INT *) *chanpt;
773 }
774 return(FALSE);
775 }
776
777
778 VOID stkhsh()
779 /* Routine to stack the current hash table on the backwards stack. */
780 { sdb.ohsw = TRUE;
781 declf((INT) (LHV + 5));
782 fmove((INT) (LHV + 5),sdb.hashpt,lfpt);
783 sdb.hashpt = lfpt;
784 }
785
786
787 VOID subchk()
788 { if(meval <= opdb.optyp) {
789 if(meval <= 0) meval += opdb.optyp;
790 if(meval > opdb.sqnum) return;
791 }
792
793 /* MC-SUB has null value - perform null insert */
794
795 idlen = 0;
796 opexit();
797 longjmp(bstsave,1);
798 }
799
800
801 VOID tebest()
802 { INT *fndpt = infopt - idlen - 2; /* Point to orlink */
803 INT *tidpt = idpt;
804 INT *tspt = sdb.spt; /* Save current position while looking ahead */
805 INT type;
806 #if !ANSI
807 INT dumint;
808 #endif
809
810 tlinct = sdb.linect;
811
812 for(;;) {
813 if(*infopt == SPCSMK) { /* This possibility ends with SPACES - move over any spaces in current text */
814 infopt++;
815 #if ANSI
816 (void) gargch();
817 #else
818 dumint = gargch();
819 #endif
820 sdb.spt--; /* Move back over last (non-space) character */
821 }
822
823 if(tewith(infopt)) { /* Possibility contains WITH or WITHS */
824 tbwith:
825 if(!advnce()) break; /* End of the current text - no match */
826 sdb.spt--;
827 gtatom();
828 if((*idpt == ' ') && (indic == WTHSMK)) goto tbwith;
829 if(!cmpare(infopt)) break;
830 /* Subsequent atom does not match */
831 continue;
832 }
833
834 if(indic == EXCLMK) { /* Exclusive delimiter */
835 if(bindic != EXCLMK) goto tb3;
836 } else {
837 if(bindic == EXCLMK) break;
838 /* Not exclusive delimiter */
839 }
840 if(bespt >= sdb.spt) break; /* A longer construction name has already been found */
841
842 tb3:
843 if(htabpt == NULLPT) {
844 /* Secondary delimiter case */
845
846 bestpl = BP_SDELIM;
847 } else {
848 infopt++;
849 if(*infopt == TY_STOP) {
850 /* Case of stop marker */
851 if((levl != 0) || ((sdb.skval == 0) && (skiplv == 0))) break;
852 bestpl = BP_STOP;
853 } else {
854 if((*infopt & masksw) == 0) break;
855 type = *infopt;
856 if((type == TY_INSERT) && (masksw == 1)) break;
857 if(!ckvaly(chanpt,type)) break;
858 /* This name is not currently valid */
859 infopt++;
860 bestpl = type;
861 }
862 }
863
864 bfndpt = fndpt;
865 binfpt = infopt;
866 bindic = indic;
867 bespt = sdb.spt;
868 beslin = sdb.linect;
869 break;
870 }
871
872 idpt = tidpt;
873 sdb.spt = tspt;
874 idlen = (sdb.spt - idpt) + 1;
875 sdb.linect = tlinct;
876 }
877
878
879 #if ANSI
880 INT tesdel(INT *ptr)
881 #else
882 INT tesdel(ptr)
883 INT *ptr;
884 #endif
885 /* Function to search a specified secondary delimiter chain, looking for
886 a match; yields the position within chain of the matched delimiter. */
887 { INT item = 0;
888
889 setpts(DB_DELIM);
890 chanpt = ptr;
891
892 #if DEBUGGING
893 if(chanpt == NULLPT) macerr((INT) 12);
894 #endif
895
896 for(;;) {
897 chlink = *chanpt;
898 if(cmpare(chanpt)) return(item);
899 item++;
900 if(chlink == ENDCHN) macerr((INT) 13);
901 chanpt += chlink;
902 }
903 #if IBMC
904 #pragma checkout(suspend)
905 #endif
906 }
907 #if IBMC
908 #pragma checkout(resume)
909 #endif
910
911
912 #if ANSI
913 INT tewith(INT *ptr)
914 #else
915 INT tewith(ptr)
916 INT *ptr;
917 #endif
918 /* Function to check if the item pointed at by its parameter is WITHMK
919 or WTHSMK; 'indic' is set to the item. Yields TRUE if WITH or WITHS
920 found, otherwise yields FALSE. */
921 { indic = *ptr;
922 return((indic == WITHMK) || (indic == WTHSMK));
923 }
924
925
926 VOID unopdb()
927 { ffpt = sdb.inffpt;
928 levl--;
929 if(--oplev != 0) {
930 INT *tpt = opdb.topspt;
931
932 fmove((INT) OPDBSZ,tpt,at_opdb);
933 lfpt = tpt + OPDBSZ;
934 }
935 }
936
937
938 VOID unsdb()
939 { if(sdb.dbugsw == DB_REPL) levl--;
940 tempt = sdb.stakpt;
941 fmove((INT) SDBSZ,tempt,at_sdb);
942 lfpt = tempt + SDBSZ;
943
944 /* Delete text of call if in source text */
945
946 if(levl == 0) {
947 INT size = ffpt - sdb.spt - 1;
948
949 sdb.spt++;
950 if(size != 0) fmove(size,sdb.spt,sdb.inffpt);
951 sdb.spt = sdb.inffpt - 1;
952 ffpt = sdb.inffpt + size;
953 }
954 }
955
956
957 #if ANSI
958 INT xisalnum(INT ch)
959 #else
960 INT xisalnum(ch)
961 INT ch;
962 #endif
963 /* Same as 'isalnum', but checks for characters outside the range 0 to 255
964 and handles conversion of the argument if required. */
965 { if((ch >= 0) && (ch <= 255)) return((INT) isalnum((int) ch));
966 return(FALSE);
967 }
968
969
970 #if ANSI
971 INT xisalpha(INT ch)
972 #else
973 INT xisalpha(ch)
974 INT ch;
975 #endif
976 /* Same as 'isalpha', but checks for characters outside the range 0 to 255
977 and handles conversion of the argument if required. */
978 { if((ch >= 0) && (ch <= 255)) return((INT) isalpha((int) ch));
979 return(FALSE);
980 }
981
982
983 #if ANSI
984 INT xisdigit(INT ch)
985 #else
986 INT xisdigit(ch)
987 INT ch;
988 #endif
989 /* Same as 'isdigit', but checks for characters outside the range 0 to 255
990 and handles conversion of the argument if required. */
991 { if((ch >= 0) && (ch <= 255)) return((INT) isdigit((int) ch));
992 return(FALSE);
993 }
994
995
996 #if ANSI
997 INT xisupper(INT ch)
998 #else
999 INT xisupper(ch)
1000 INT ch;
1001 #endif
1002 /* Same as 'isupper', but checks for characters outside the range 0 to 255
1003 and handles conversion of the argument if required. */
1004 { if((ch >= 0) && (ch <= 255)) return((INT) isupper((int) ch));
1005 return(FALSE);
1006 }
1007
1008 /*
1009 ***********************
1010 * *
1011 * End of module 3 *
1012 * *
1013 ***********************
1014 */
1015
1016