1 /*@z06.c:Parser:PushObj(), PushToken(), etc.@*********************************/
2 /* */
3 /* THE LOUT DOCUMENT FORMATTING SYSTEM (VERSION 3.39) */
4 /* COPYRIGHT (C) 1991, 2008 Jeffrey H. Kingston */
5 /* */
6 /* Jeffrey H. Kingston (jeff@it.usyd.edu.au) */
7 /* School of Information Technologies */
8 /* The University of Sydney 2006 */
9 /* AUSTRALIA */
10 /* */
11 /* This program is free software; you can redistribute it and/or modify */
12 /* it under the terms of the GNU General Public License as published by */
13 /* the Free Software Foundation; either Version 3, or (at your option) */
14 /* any later version. */
15 /* */
16 /* This program is distributed in the hope that it will be useful, */
17 /* but WITHOUT ANY WARRANTY; without even the implied warranty of */
18 /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
19 /* GNU General Public License for more details. */
20 /* */
21 /* You should have received a copy of the GNU General Public License */
22 /* along with this program; if not, write to the Free Software */
23 /* Foundation, Inc., 59 Temple Place, Suite 330, Boston MA 02111-1307 USA */
24 /* */
25 /* FILE: z06.c */
26 /* MODULE: Parser */
27 /* EXTERNS: InitParser(), Parse() */
28 /* */
29 /*****************************************************************************/
30 #include "externs.h"
31 #define LEFT_ASSOC 0
32 #define RIGHT_ASSOC 1
33
34 #define PREV_OP 0 /* means an operator was previous */
35 #define PREV_OBJ 1 /* prev was object not ending in RBR */
36 #define PREV_RBR 2 /* prev was object ending in RBR */
37
38 static OBJECT cross_name; /* name of the cr database */
39
40
41 #define MAX_STACK 250 /* size of parser stacks */
42 static OBJECT obj_stack[MAX_STACK]; /* stack of objects */
43 static int otop; /* top of obj_stack */
44 static OBJECT tok_stack[MAX_STACK]; /* stack of tokens */
45 static int ttop; /* top of tok_stack */
46 static int unknown_count; /* no. of unknown symbols */
47 BOOLEAN InDefinitions; /* TRUE when in definitions */
48 #if DEBUG_ON
49 static BOOLEAN debug_now = FALSE; /* TRUE when want to debug */
50 #endif
51
52
53 /*****************************************************************************/
54 /* */
55 /* OBJECT OptimizeCase(x) */
56 /* */
57 /* Optimize the @Case expression x, which is known to be of the form */
58 /* "@BackEnd @Case ...", by evaluating it immediately if its choices */
59 /* are all literal words or "else". */
60 /* */
61 /*****************************************************************************/
62
check_yield(OBJECT y,OBJECT * res_yield,BOOLEAN * all_literals)63 static void check_yield(OBJECT y, OBJECT *res_yield, BOOLEAN *all_literals)
64 { OBJECT s1, link, z;
65 Child(s1, Down(y));
66 debug1(DOP, DD, " checkyield(%s)", EchoObject(y));
67 if( is_word(type(s1)) )
68 { if( StringEqual(string(s1), BackEnd->name) ||
69 StringEqual(string(s1),STR_ELSE) )
70 if( *res_yield == nilobj ) *res_yield = y;
71 }
72 else if( type(s1) == ACAT )
73 { for( link = Down(s1); link != s1; link = NextDown(link) )
74 { Child(z, link);
75 if( type(z) == GAP_OBJ ) continue;
76 if( is_word(type(z)) )
77 { if( StringEqual(string(z), BackEnd->name) ||
78 StringEqual(string(s1), STR_ELSE))
79 if( *res_yield == nilobj ) *res_yield = y;
80 }
81 else
82 { *all_literals = FALSE;
83 *res_yield = nilobj;
84 break;
85 }
86 }
87 }
88 else
89 { *all_literals = FALSE;
90 *res_yield = nilobj;
91 }
92 debug2(DOP, DD, " checkyield returning (%s, %s)", EchoObject(*res_yield),
93 bool(*all_literals));
94 }
95
OptimizeCase(OBJECT x)96 OBJECT OptimizeCase(OBJECT x)
97 { OBJECT link, s2, y, res_yield, res; BOOLEAN all_literals;
98 debug1(DOP, DD, "OptimizeCase(%s)", EchoObject(x));
99 assert( type(x) == CASE, "OptimizeCase: type(x) != CASE!" );
100
101 Child(s2, LastDown(x));
102 all_literals = TRUE; res_yield = nilobj;
103 if( type(s2) == YIELD )
104 { check_yield(s2, &res_yield, &all_literals);
105 }
106 else if( type(s2) == ACAT )
107 { for( link = Down(s2); link != s2 && all_literals; link = NextDown(link) )
108 {
109 Child(y, link);
110 debug2(DOP, DD, " OptimizeCase examining %s %s", Image(type(y)),
111 EchoObject(y));
112 if( type(y) == GAP_OBJ ) continue;
113 if( type(y) == YIELD )
114 { check_yield(y, &res_yield, &all_literals);
115 }
116 else
117 { all_literals = FALSE;
118 res_yield = nilobj;
119 }
120 }
121 }
122 else
123 { all_literals = FALSE;
124 res_yield = nilobj;
125 }
126
127 if( all_literals && res_yield != nilobj )
128 { Child(res, LastDown(res_yield));
129 DeleteLink(Up(res));
130 DisposeObject(x);
131 }
132 else
133 { res = x;
134 }
135
136 debug1(DOP, DD, "OptimizeCase returning %s", EchoObject(res));
137 return res;
138 } /* end OptimizeCase */
139
140
141 /*****************************************************************************/
142 /* */
143 /* HuntCommandOptions(x) */
144 /* */
145 /* See if any of the command-line options apply to closure x. If so, */
146 /* change x to reflect the overriding command line option. */
147 /* */
148 /*****************************************************************************/
149
HuntCommandOptions(OBJECT x)150 static void HuntCommandOptions(OBJECT x)
151 { OBJECT colink, coname, coval, opt = nilobj, y = nilobj, link, sym; BOOLEAN found;
152 debug1(DOP, DD, "HuntCommandOptions(%s)", SymName(actual(x)));
153 sym = actual(x);
154 for( colink = Down(CommandOptions); colink != CommandOptions;
155 colink = NextDown(NextDown(colink)) )
156 {
157 Child(coname, colink);
158 Child(coval, NextDown(colink));
159 debug2(DOP, DD, " hunting \"%s\" with value \"%s\"", string(coname),
160 EchoObject(coval));
161
162 /* set found to TRUE iff coname is the name of an option of x */
163 found = FALSE;
164 for( link = Down(sym); link != sym; link = NextDown(link) )
165 { Child(opt, link);
166 if( type(opt) == NPAR && StringEqual(SymName(opt), string(coname)) )
167 { found = TRUE;
168 debug2(DOP, DD, " %s is an option of %s", string(coname),SymName(sym));
169 break;
170 }
171 }
172
173 if( found )
174 {
175 /* see whether this option is already set within x */
176 found = FALSE;
177 for( link = Down(x); link != x; link = NextDown(link) )
178 { Child(y, link);
179 if( type(y) == PAR && actual(y) == opt )
180 { found = TRUE;
181 debug2(DOP, DD, " %s is set in %s", string(coname), SymName(sym));
182 break;
183 }
184 }
185
186 if( found )
187 {
188 /* option exists already in x: replace it with oval */
189 DisposeChild(Down(y));
190 Link(y, coval);
191 debug2(DOP, DD, " replacing %s value with %s; x =", string(coname),
192 EchoObject(coval));
193 ifdebug(DOP, DD, DebugObject(x));
194 }
195 else
196 {
197 /* option applies to x but has not yet been set in x */
198 New(y, PAR);
199 Link(x, y);
200 actual(y) = opt;
201 Link(y, coval);
202 debug2(DOP, DD, " inserting %s with value %s; x =", string(coname),
203 EchoObject(coval));
204 ifdebug(DOP, DD, DebugObject(x));
205 }
206 }
207 }
208 debug1(DOP, DD, "HuntCommandOptions(%s) returning", SymName(sym));
209 } /* end HuntCommandOptions */
210
211
212 /*****************************************************************************/
213 /* */
214 /* PushObj(x) */
215 /* PushToken(t) */
216 /* OBJECT PopObj() */
217 /* OBJECT PopToken() */
218 /* OBJECT TokenTop */
219 /* OBJECT ObjTop */
220 /* */
221 /* Push and pop from the object and token stacks; examine top item. */
222 /* */
223 /*****************************************************************************/
224
225 #define PushObj(x) \
226 { zz_hold = x; \
227 if( ++otop < MAX_STACK ) obj_stack[otop] = zz_hold; \
228 else Error(6, 1, "expression is too deeply nested", \
229 FATAL, &fpos(obj_stack[otop-1])); \
230 }
231
232 #define PushToken(t) \
233 { if( ++ttop < MAX_STACK ) tok_stack[ttop] = t; \
234 else Error(6, 2, "expression is too deeply nested", \
235 FATAL, &fpos(tok_stack[ttop-1])); \
236 }
237
238 #define PopObj() obj_stack[otop--]
239 #define PopToken() tok_stack[ttop--]
240 #define TokenTop tok_stack[ttop]
241 #define ObjTop obj_stack[otop]
242
243
244 /*@::DebugStacks(), InsertSpace()@********************************************/
245 /* */
246 /* DebugStacks() */
247 /* */
248 /* Print debug output of the stacks state */
249 /* */
250 /*****************************************************************************/
251
252 #if DEBUG_ON
DebugStacks(int initial_ttop,int obj_prev)253 static void DebugStacks(int initial_ttop, int obj_prev)
254 { int i;
255 debug3(ANY, D, " obj_prev: %s; otop: %d; ttop: %d",
256 obj_prev == PREV_OP ? "PREV_OP" : obj_prev == PREV_OBJ ? "PREV_OBJ" :
257 obj_prev == PREV_RBR ? "PREV_RBR" : "???", otop, ttop);
258 for( i = 0; i <= otop; i++ )
259 debug3(ANY, D, " obj[%d] = (%s) %s", i,
260 Image(type(obj_stack[i])), EchoObject(obj_stack[i]));
261 for( i = 0; i <= ttop; i++ )
262 { if( i == initial_ttop+1 ) debug0(DOP, DD, " $");
263 debug3(ANY, D, " tok[%d] = %s (precedence %d)", i,
264 type(tok_stack[i]) == CLOSURE ?
265 SymName(actual(tok_stack[i])) : Image(type(tok_stack[i])),
266 precedence(tok_stack[i]));
267 }
268 } /* end DebugStacks */
269 #endif
270
271
272 /*****************************************************************************/
273 /* */
274 /* InsertSpace(t) */
275 /* */
276 /* Add any missing catenation operator in front of token t. */
277 /* */
278 /*****************************************************************************/
279
280 #define InsertSpace(t) \
281 if( obj_prev ) \
282 { int typ, prec; \
283 if( hspace(t) + vspace(t) > 0 ) \
284 typ = TSPACE, prec = ACAT_PREC; \
285 else if( type(t) == LBR || obj_prev == PREV_RBR ) \
286 typ = TJUXTA, prec = ACAT_PREC; \
287 else \
288 typ = TJUXTA, prec = JUXTA_PREC; \
289 debugcond1(DOP, DD, debug_now, "[ InsertSpace(%s)", Image(typ)); \
290 while( obj_prev && precedence(TokenTop) >= prec ) \
291 obj_prev = Reduce(); \
292 if( obj_prev ) \
293 { New(tmp, typ); precedence(tmp) = prec; \
294 vspace(tmp) = vspace(t); hspace(tmp) = hspace(t); \
295 width(gap(tmp)) = 0; nobreak(gap(tmp)) = TRUE; \
296 mark(gap(tmp)) = FALSE; join(gap(tmp)) = TRUE; \
297 units(gap(tmp)) = FIXED_UNIT; mode(gap(tmp)) = EDGE_MODE; \
298 FposCopy(fpos(tmp), fpos(t)); \
299 PushToken(tmp); \
300 } \
301 debugcond0(DOP, DD, debug_now, "] end InsertSpace()"); \
302 } /* end InsertSpace */
303
304
305 /*@::Shift(), ShiftObj()@*****************************************************/
306 /* */
307 /* static Shift(t, prec, rassoc, leftpar, rightpar) */
308 /* static ShiftObj(t) */
309 /* */
310 /* Shift token or object t onto the stacks; it has the attributes shown. */
311 /* */
312 /*****************************************************************************/
313
314 #define Shift(t, prec, rassoc, leftpar, rightpar) \
315 { debugcond5(DOP, DD, debug_now, "[ Shift(%s, %d, %s, %s, %s)", \
316 Image(type(t)), prec, rassoc ? "rightassoc" : "leftassoc", \
317 leftpar ? "lpar" : "nolpar", rightpar ? "rpar" : "norpar"); \
318 if( leftpar ) \
319 { for(;;) \
320 { if( !obj_prev ) \
321 { PushObj( MakeWord(WORD, STR_EMPTY, &fpos(t)) ); \
322 obj_prev = PREV_OBJ; \
323 } \
324 else if( precedence(TokenTop) >= prec + rassoc ) \
325 { obj_prev = Reduce(); \
326 if( ttop == initial_ttop ) \
327 { *token = t; \
328 debugcond0(DOP, DD, debug_now, \
329 "] ] end Shift() and Parse(); stacks are:"); \
330 ifdebugcond(DOP, DD, debug_now, \
331 DebugStacks(initial_ttop, obj_prev)); \
332 return PopObj(); \
333 } \
334 } \
335 else break; \
336 } \
337 } \
338 else InsertSpace(t); \
339 PushToken(t); \
340 if( rightpar ) obj_prev = FALSE; \
341 else \
342 { obj_prev = Reduce(); \
343 if( ttop == initial_ttop ) \
344 { *token = nilobj; \
345 debugcond0(DOP, DD, debug_now, \
346 "] ] end Shift and Parse; stacks are:"); \
347 ifdebugcond(DOP, DD, debug_now, \
348 DebugStacks(initial_ttop, obj_prev)); \
349 return PopObj(); \
350 } \
351 } \
352 debugcond0(DOP, DD, debug_now, "] end Shift()"); \
353 } /* end Shift */
354
355
356 #define ShiftObj(t, new_obj_prev) \
357 { debugcond1(DOP, DD, debug_now, "[ ShiftObj(%s)", Image(type(t))); \
358 InsertSpace(t); \
359 PushObj(t); \
360 obj_prev = new_obj_prev; \
361 debugcond0(DOP, DD, debug_now, "] end ShiftObj()"); \
362 }
363
364 /*@::Reduce()@****************************************************************/
365 /* */
366 /* static Reduce() */
367 /* */
368 /* Perform a single reduction of the stacks. */
369 /* */
370 /*****************************************************************************/
371
Reduce(void)372 static BOOLEAN Reduce(void)
373 { OBJECT p1, p2, p3, s1, s2, tmp;
374 OBJECT op; int obj_prev;
375 debugcond0(DOP, DD, debug_now, "[ Reduce()");
376 /* ifdebugcond(DOP, DD, debug_now, DebugStacks(0, TRUE)); */
377
378 op = PopToken();
379 obj_prev = PREV_OBJ;
380 switch( type(op) )
381 {
382
383 case GSTUB_INT:
384 case GSTUB_EXT:
385
386 debug0(DGT, D, "calling TransferEnd( PopObj() ) from Reduce()");
387 TransferEnd( PopObj() );
388 New(p1, NULL_CLOS);
389 PushObj(p1);
390 Dispose(op);
391 break;
392
393
394 case GSTUB_NONE:
395
396 New(p1, NULL_CLOS);
397 PushObj(p1);
398 Dispose(op);
399 break;
400
401
402 case NULL_CLOS:
403 case PAGE_LABEL:
404 case BEGIN_HEADER:
405 case END_HEADER:
406 case SET_HEADER:
407 case CLEAR_HEADER:
408 case ONE_COL:
409 case ONE_ROW:
410 case WIDE:
411 case HIGH:
412 case HSHIFT:
413 case VSHIFT:
414 case HMIRROR:
415 case VMIRROR:
416 case HSCALE:
417 case VSCALE:
418 case HCOVER:
419 case VCOVER:
420 case SCALE:
421 case KERN_SHRINK:
422 case HCONTRACT:
423 case VCONTRACT:
424 case HLIMITED:
425 case VLIMITED:
426 case HEXPAND:
427 case VEXPAND:
428 case START_HVSPAN:
429 case START_HSPAN:
430 case START_VSPAN:
431 case HSPAN:
432 case VSPAN:
433 case PADJUST:
434 case HADJUST:
435 case VADJUST:
436 case ROTATE:
437 case BACKGROUND:
438 case YIELD:
439 case BACKEND:
440 case XCHAR:
441 case FONT:
442 case SPACE:
443 case YUNIT:
444 case ZUNIT:
445 case SET_CONTEXT:
446 case GET_CONTEXT:
447 case BREAK:
448 case UNDERLINE:
449 case UNDERLINE_COLOUR:
450 case COLOUR:
451 case TEXTURE:
452 case OUTLINE:
453 case LANGUAGE:
454 case CURR_LANG:
455 case CURR_FAMILY:
456 case CURR_FACE:
457 case CURR_YUNIT:
458 case CURR_ZUNIT:
459 case COMMON:
460 case RUMP:
461 case MELD:
462 case INSERT:
463 case ONE_OF:
464 case NEXT:
465 case PLUS:
466 case MINUS:
467 case TAGGED:
468 case INCGRAPHIC:
469 case SINCGRAPHIC:
470 case PLAIN_GRAPHIC:
471 case GRAPHIC:
472 case LINK_SOURCE:
473 case LINK_DEST:
474 case LINK_URL:
475 case OPEN:
476 case RAW_VERBATIM:
477 case VERBATIM:
478
479 if( has_rpar(actual(op)) )
480 { s2 = PopObj();
481 Link(op, s2);
482 }
483 if( has_lpar(actual(op)) )
484 { s1 = PopObj();
485 Link(Down(op), s1);
486 }
487 PushObj(op);
488 break;
489
490
491 case CASE:
492
493 if( has_rpar(actual(op)) )
494 { s2 = PopObj();
495 Link(op, s2);
496 }
497 if( has_lpar(actual(op)) )
498 { s1 = PopObj();
499 Link(Down(op), s1);
500 if( type(s1) == BACKEND )
501 { op = OptimizeCase(op);
502 }
503 }
504 PushObj(op);
505 break;
506
507
508 case CROSS:
509 case FORCE_CROSS:
510
511 s2 = PopObj();
512 Link(op, s2);
513 s1 = PopObj();
514 Link(Down(op), s1);
515 if( type(s1) != CLOSURE )
516 Error(6, 3, "left parameter of %s is not a symbol (or not visible)",
517 WARN, &fpos(s1), Image(type(op)));
518 PushObj(op);
519 break;
520
521
522 case CLOSURE:
523
524 if( has_rpar(actual(op)) )
525 { New(s2, PAR);
526 tmp = PopObj();
527 Link(s2, tmp);
528 FposCopy(fpos(s2), fpos(tmp));
529 actual(s2) = ChildSym(actual(op), RPAR);
530 Link(op, s2);
531 }
532 if( has_lpar(actual(op)) )
533 { New(s1, PAR);
534 tmp = PopObj();
535 Link(s1, tmp);
536 FposCopy(fpos(s1), fpos(tmp));
537 actual(s1) = ChildSym(actual(op), LPAR);
538 Link(Down(op), s1);
539 }
540 PushObj(op);
541 break;
542
543
544 case LBR:
545
546 Error(6, 4, "unmatched %s (inserted %s)", WARN, &fpos(op),
547 KW_LBR, KW_RBR);
548 Dispose(op);
549 obj_prev = PREV_RBR;
550 break;
551
552
553 case BEGIN:
554
555 assert1(FALSE, "Reduce: unmatched", KW_BEGIN);
556 break;
557
558
559 case RBR:
560
561 if( type(TokenTop) == LBR )
562 { /* *** FposCopy(fpos(ObjTop), fpos(TokenTop)); *** */
563 Dispose( PopToken() );
564 }
565 else if( type(TokenTop) == BEGIN )
566 { if( file_num(fpos(TokenTop)) > 0 )
567 Error(6, 5, "unmatched %s; inserted %s at%s (after %s)",
568 WARN, &fpos(op), KW_RBR, KW_LBR,
569 EchoFilePos(&fpos(TokenTop)), KW_BEGIN);
570 else
571 Error(6, 6, "unmatched %s not enclosed in anything",
572 FATAL, &fpos(op), KW_RBR);
573 }
574 else
575 { assert1(FALSE, "Reduce: unmatched", KW_RBR);
576 }
577 Dispose(op);
578 obj_prev = PREV_RBR;
579 break;
580
581
582 case END:
583
584 if( type(TokenTop) != BEGIN )
585 { assert1(FALSE, "Reduce: unmatched", KW_END);
586 }
587 else
588 { if( actual(op) != actual(TokenTop) )
589 {
590 if( actual(op) == StartSym )
591 Error(6, 7, "%s %s appended at end of file to match %s at%s",
592 WARN, &fpos(op), KW_END, SymName(actual(TokenTop)),
593 KW_BEGIN, EchoFilePos(&fpos(TokenTop)) );
594 else if( actual(op) == nilobj )
595 Error(6, 8, "%s replaced by %s %s to match %s at%s",
596 WARN, &fpos(op), KW_END, KW_END,
597 actual(TokenTop) == nilobj ? AsciiToFull("??") :
598 SymName(actual(TokenTop)),
599 KW_BEGIN, EchoFilePos(&fpos(TokenTop)) );
600 else
601 Error(6, 9, "%s %s replaced by %s %s to match %s at%s",
602 WARN, &fpos(op), KW_END, SymName(actual(op)),
603 KW_END, SymName(actual(TokenTop)),
604 KW_BEGIN, EchoFilePos(&fpos(TokenTop)) );
605 }
606 Dispose( PopToken() );
607 }
608 Dispose(op);
609 obj_prev = PREV_RBR;
610 break;
611
612
613 case GAP_OBJ:
614
615 p1 = PopObj();
616 Link(op, p1);
617 PushObj(op);
618 obj_prev = PREV_OP;
619 break;
620
621
622 case VCAT:
623 case HCAT:
624 case ACAT:
625
626 p3 = PopObj(); p2 = PopObj(); p1 = PopObj();
627 if( type(p1) == type(op) )
628 { Dispose(op);
629 }
630 else
631 { Link(op, p1);
632 p1 = op;
633 }
634 Link(p1, p2);
635 Link(p1, p3);
636 PushObj(p1);
637 break;
638
639
640 case TSPACE:
641 case TJUXTA:
642
643 p2 = PopObj(); p1 = PopObj();
644 if( type(p1) != ACAT )
645 { New(tmp, ACAT);
646 Link(tmp, p1);
647 FposCopy(fpos(tmp), fpos(p1));
648 p1 = tmp;
649 }
650 type(op) = GAP_OBJ;
651 Link(p1, op);
652 Link(p1, p2);
653 PushObj(p1);
654 break;
655
656
657 default:
658
659 assert1(FALSE, "Reduce:", Image(type(op)));
660 break;
661
662 } /* end switch */
663 debugcond1(DOP, DD, debug_now, "] end Reduce(), returning %s",
664 obj_prev == PREV_OP ? "PREV_OP" : obj_prev == PREV_OBJ ? "PREV_OBJ" :
665 obj_prev == PREV_RBR ? "PREV_RBR" : "???");
666 return obj_prev;
667 } /* end Reduce */
668
669
670 /*@::SetScope(), InitParser()@************************************************/
671 /* */
672 /* SetScope(env, count, vis_only) */
673 /* */
674 /* Push scopes required to parse object whose environment is env. */
675 /* Add to *count the number of scope pushes made. */
676 /* */
677 /* If vis_only is true, we only want visible things of the top-level */
678 /* element of env to be visible in this scope. */
679 /* */
680 /*****************************************************************************/
681
SetScope(OBJECT env,int * count,BOOLEAN vis_only)682 void SetScope(OBJECT env, int *count, BOOLEAN vis_only)
683 { OBJECT link, y, yenv; BOOLEAN visible_only;
684 debugcond2(DOP,DD, debug_now, "[ SetScope(%s, %d)", EchoObject(env), *count);
685 assert( env != nilobj && type(env) == ENV, "SetScope: type(env) != ENV!" );
686 if( Down(env) != env )
687 { Child(y, Down(env));
688 assert( LastDown(y) != y, "SetScope: LastDown(y)!" );
689 link = LastDown(env) != Down(env) ? LastDown(env) : LastDown(y);
690 Child(yenv, link);
691 assert( type(yenv) == ENV, "SetScope: type(yenv) != ENV!" );
692 SetScope(yenv, count, FALSE);
693 visible_only = vis_only || (use_invocation(actual(y)) != nilobj);
694 /* i.e. from @Use clause */
695 PushScope(actual(y), FALSE, visible_only); (*count)++;
696 /*** this following was a bright idea that did not work owing to
697 allowing body parameters at times they definitely shouldn't be
698 BodyParAllowed();
699 ***/
700 }
701 debugcond1(DOP, DD, debug_now, "] SetScope returning, count = %d", *count);
702 } /* end SetScope */
703
704
705 /*****************************************************************************/
706 /* */
707 /* InitParser() */
708 /* */
709 /* Initialise the parser to contain just GstubExt. */
710 /* Remember cross_db, the name of the cross reference database, for Parse. */
711 /* */
712 /*****************************************************************************/
713
InitParser(FULL_CHAR * cross_db)714 void InitParser(FULL_CHAR *cross_db)
715 {
716 otop = -1;
717 ttop = -1;
718 unknown_count = 0;
719 InDefinitions = TRUE;
720 debug0(DOP, D, "InitParser setting InDefinitions to TRUE");
721 #if DEBUG_ON
722 debug_now = FALSE;
723 #endif
724 if( StringLength(cross_db) >= MAX_WORD )
725 Error(6, 10, "cross reference database file name %s is too long",
726 FATAL, no_fpos, cross_db);
727 cross_name = MakeWord(WORD, cross_db, no_fpos);
728 PushToken( NewToken(GSTUB_EXT, no_fpos, 0, 0, DEFAULT_PREC, StartSym) );
729 } /* end InitParser */
730
731
732 /*@::ParseEnvClosure()@*******************************************************/
733 /* */
734 /* static OBJECT ParseEnvClosure(t, encl) */
735 /* */
736 /* Parse an object which is a closure with environment. Consume the */
737 /* concluding @LClos. */
738 /* */
739 /*****************************************************************************/
740
ParseEnvClosure(OBJECT t,OBJECT encl)741 static OBJECT ParseEnvClosure(OBJECT t, OBJECT encl)
742 { OBJECT env, res, y; int count, i;
743 debugcond0(DOP, DDD, debug_now, "ParseEnvClosure(t, encl)");
744 assert( type(t) == ENV, "ParseEnvClosure: type(t) != ENV!" );
745 env = t; t = LexGetToken();
746 while( type(t) != CLOS ) switch( type(t) )
747 {
748 case LBR: count = 0;
749 SetScope(env, &count, FALSE);
750 y = Parse(&t, encl, FALSE, FALSE);
751 if( type(y) != CLOSURE )
752 {
753 debug1(DIO, D, " Parse() returning %s:", Image(type(y)));
754 ifdebug(DIO, D, DebugObject(y));
755 Error(6, 11, "syntax error in cross reference database",
756 FATAL, &fpos(y));
757 }
758 for( i = 1; i <= count; i++ ) PopScope();
759 AttachEnv(env, y);
760 debug0(DCR, DDD, " calling SetEnv from ParseEnvClosure (a)");
761 env = SetEnv(y, nilobj);
762 t = LexGetToken();
763 break;
764
765 case ENV: y = ParseEnvClosure(t, encl);
766 debug0(DCR, DDD, " calling SetEnv from ParseEnvClosure (b)");
767 env = SetEnv(y, env);
768 t = LexGetToken();
769 break;
770
771 default: Error(6, 12, "error in cross reference database",
772 FATAL, &fpos(t));
773 break;
774 }
775 Dispose(t);
776 if( Down(env) == env || Down(env) != LastDown(env) )
777 Error(6, 13, "error in cross reference database", FATAL, &fpos(env));
778 Child(res, Down(env));
779 DeleteNode(env);
780 debugcond1(DOP, DDD, debug_now, "ParseEnvClosure ret. %s", EchoObject(res));
781 assert( type(res) == CLOSURE, "ParseEnvClosure: type(res) != CLOSURE!" );
782 return res;
783 } /* end ParseEnvClosure */
784
785
786 /*@::Parse()@*****************************************************************/
787 /* */
788 /* OBJECT Parse(token, encl, defs_allowed, transfer_allowed) */
789 /* */
790 /* Parse input tokens, beginning with *token, looking for an object of the */
791 /* form { ... } or @Begin ... @End <sym>, and return the object. */
792 /* The parent definition is encl, and scope has been set appropriately. */
793 /* Parse reads up to and including the last token of the object */
794 /* (the right brace or <sym>), and returns nilobj in *token. */
795 /* */
796 /* If defs_allowed == TRUE, there may be local definitions in the object. */
797 /* In this case, encl is guaranteed to be the enclosing definition. */
798 /* */
799 /* If transfer_allowed == TRUE, the parser may transfer components to the */
800 /* galley handler as they are read. */
801 /* */
802 /* Note: the lexical analyser returns "@End \Input" at end of input, so the */
803 /* parser does not have to handle end of input separately. */
804 /* */
805 /*****************************************************************************/
806
Parse(OBJECT * token,OBJECT encl,BOOLEAN defs_allowed,BOOLEAN transfer_allowed)807 OBJECT Parse(OBJECT *token, OBJECT encl,
808 BOOLEAN defs_allowed, BOOLEAN transfer_allowed)
809 { OBJECT t, x, tmp, xsym, env, y, link, res, imps, xlink;
810 int i, offset, lnum, initial_ttop = ttop;
811 int obj_prev, scope_count, compulsory_count; BOOLEAN revealed;
812
813 debugcond4(DOP, DD, debug_now, "[ Parse(%s, %s, %s, %s)", EchoToken(*token),
814 SymName(encl), bool(defs_allowed), bool(transfer_allowed));
815 assert( type(*token) == LBR || type(*token) == BEGIN, "Parse: *token!" );
816
817 obj_prev = PREV_OP;
818 Shift(*token, precedence(*token), 0, FALSE, TRUE);
819 t = LexGetToken();
820 if( defs_allowed )
821 { ReadDefinitions(&t, encl, LOCAL);
822
823 /* if error in definitions, stop now */
824 if( ErrorSeen() )
825 Error(6, 14, "exiting now (error in definitions)", FATAL, &fpos(t));
826
827 if( encl == StartSym )
828 {
829 /* read @Use, @Database, and @Prepend commands and defs and construct env */
830 New(env, ENV);
831 for(;;)
832 {
833 if( type(t) == WORD && (
834 StringEqual(string(t), KW_DEF) ||
835 /* StringEqual(string(t), KW_FONTDEF) || */
836 StringEqual(string(t), KW_LANGDEF) ||
837 StringEqual(string(t), KW_MACRO) ||
838 StringEqual(string(t), KW_IMPORT) ||
839 StringEqual(string(t), KW_EXTEND) ||
840 StringEqual(string(t), KW_EXPORT) ) )
841 {
842 ReadDefinitions(&t, encl, LOCAL);
843
844 /* if error in definitions, stop now */
845 if( ErrorSeen() )
846 Error(6, 39, "exiting now (error in definitions)", FATAL, &fpos(t));
847
848 }
849 else if( type(t) == USE )
850 {
851 OBJECT crs, res_env; STYLE style;
852 Dispose(t); t = LexGetToken();
853 if( type(t) != LBR )
854 Error(6, 15, "%s expected after %s", FATAL, &fpos(t),KW_LBR,KW_USE);
855 debug0(DOP, DD, " Parse() calling Parse for @Use clause");
856 y = Parse(&t, encl, FALSE, FALSE);
857 if( is_cross(type(y)) )
858 { OBJECT z;
859 Child(z, Down(y));
860 if( type(z) == CLOSURE )
861 { crs = nilobj;
862 y = CrossExpand(y, env, &style, &crs, &res_env);
863 if( crs != nilobj )
864 { Error(6, 16, "%s or %s tag not allowed here",
865 FATAL, &fpos(y), KW_PRECEDING, KW_FOLLOWING);
866 }
867 HuntCommandOptions(y);
868 AttachEnv(res_env, y);
869 debug0(DCR, DDD, " calling SetEnv from Parse (a)");
870 env = SetEnv(y, env);
871 }
872 else Error(6, 17, "invalid parameter of %s", FATAL, &fpos(y), KW_USE);
873 }
874 else if( type(y) == CLOSURE )
875 { if( use_invocation(actual(y)) != nilobj )
876 Error(6, 18, "symbol %s occurs in two %s clauses",
877 FATAL, &fpos(y), SymName(actual(y)), KW_USE);
878 use_invocation(actual(y)) = y;
879 HuntCommandOptions(y);
880 AttachEnv(env, y);
881 debug0(DCR, DDD, " calling SetEnv from Parse (b)");
882 env = SetEnv(y, nilobj);
883 }
884 else Error(6, 19, "invalid parameter of %s", FATAL, &fpos(y), KW_USE);
885 PushScope(actual(y), FALSE, TRUE);
886 t = LexGetToken();
887 }
888 else if( type(t) == PREPEND || type(t) == SYS_PREPEND )
889 { ReadPrependDef(type(t), encl);
890 Dispose(t);
891 t = LexGetToken();
892 }
893 else if( type(t) == INCG_REPEATED || type(t) == SINCG_REPEATED )
894 { ReadIncGRepeatedDef(type(t), encl);
895 Dispose(t);
896 t = LexGetToken();
897 }
898 else if( type(t) == DATABASE || type(t) == SYS_DATABASE )
899 { ReadDatabaseDef(type(t), encl);
900 Dispose(t);
901 t = LexGetToken();
902 }
903 else break;
904 }
905
906 /* transition point from defs to content; turn on debugging now */
907 #if DEBUG_ON
908 debug_now = TRUE;
909 #endif
910 InDefinitions = FALSE;
911 debug0(DOP, D, "Parse() setting InDefinitions to FALSE");
912 debugcond4(DOP, DD, debug_now, "[ Parse (first) (%s, %s, %s, %s)",
913 EchoToken(*token), SymName(encl), bool(defs_allowed),
914 bool(transfer_allowed));
915
916 /* load cross-references from previous run, open new cross refs */
917 if( AllowCrossDb )
918 {
919 NewCrossDb = DbCreate(MakeWord(WORD, string(cross_name), no_fpos));
920 OldCrossDb = DbLoad(cross_name, SOURCE_PATH, FALSE, nilobj,
921 InMemoryDbIndexes);
922 }
923 else OldCrossDb = NewCrossDb = nilobj;
924
925 /* tidy up and possibly print symbol table */
926 FlattenUses();
927 ifdebug(DST, DD, DebugObject(StartSym));
928
929 TransferInit(env);
930 debug0(DMA, D, "at end of definitions:");
931 ifdebug(DMA, D, DebugMemory());
932 }
933 }
934
935 for(;;)
936 {
937 debugcond0(DOP, DD, debug_now, "");
938 ifdebugcond(DOP, DD, debug_now, DebugStacks(0, obj_prev));
939 debugcond0(DOP, DD, debug_now, "");
940 debugcond2(DOP, DD, debug_now, ">> %s (precedence %d)", EchoToken(t), precedence(t));
941
942 switch( type(t) )
943 {
944
945 case WORD:
946
947 if( string(t)[0] == CH_SYMSTART &&
948 (obj_prev != PREV_OBJ || vspace(t) + hspace(t) > 0) )
949 {
950 Error(6, 20, "symbol %s unknown or misspelt",
951 WARN, &fpos(t), string(t));
952 if( ++unknown_count > 25 )
953 {
954 Error(6, 21, "too many errors (%s lines missing or out of order?)",
955 FATAL, &fpos(t), KW_SYSINCLUDE);
956 }
957 }
958 ShiftObj(t, PREV_OBJ);
959 t = LexGetToken();
960 break;
961
962
963 case QWORD:
964
965 ShiftObj(t, PREV_OBJ);
966 t = LexGetToken();
967 break;
968
969
970 case VCAT:
971 case HCAT:
972 case ACAT:
973
974 /* clean up left context */
975 Shift(t, precedence(t), LEFT_ASSOC, TRUE, TRUE);
976
977 /* invoke transfer subroutines if appropriate */
978 /* *** if( type(t) == VCAT && !has_join(actual(t)) *** */
979 if( transfer_allowed && type(t) == VCAT && !has_join(actual(t))
980 && type(tok_stack[ttop-2]) == GSTUB_EXT )
981 {
982 debug0(DGT, DD, " calling TransferComponent from Parse:");
983 ifdebug(DGT, DD, DebugStacks(0, obj_prev));
984 TransferComponent( PopObj() );
985 New(tmp, NULL_CLOS);
986 FposCopy( fpos(tmp), fpos(t) );
987 PushObj(tmp);
988 }
989
990 /* push GAP_OBJ token, to cope with 3 parameters */
991 New(x, GAP_OBJ);
992 mark(gap(x)) = has_mark(actual(t));
993 join(gap(x)) = has_join(actual(t));
994 hspace(x) = hspace(t);
995 vspace(x) = vspace(t);
996 precedence(x) = GAP_PREC;
997 FposCopy( fpos(x), fpos(t) );
998 Shift(x, GAP_PREC, LEFT_ASSOC, FALSE, TRUE);
999
1000 /* if op is followed by space, insert {} */
1001 t = LexGetToken();
1002 if( hspace(t) + vspace(t) > 0 )
1003 { ShiftObj(MakeWord(WORD, STR_EMPTY, &fpos(x)), PREV_OBJ);
1004 }
1005 break;
1006
1007
1008 case CROSS:
1009 case FORCE_CROSS:
1010 case NULL_CLOS:
1011 case PAGE_LABEL:
1012 case BEGIN_HEADER:
1013 case END_HEADER:
1014 case SET_HEADER:
1015 case CLEAR_HEADER:
1016 case ONE_COL:
1017 case ONE_ROW:
1018 case WIDE:
1019 case HIGH:
1020 case HSHIFT:
1021 case VSHIFT:
1022 case HMIRROR:
1023 case VMIRROR:
1024 case HSCALE:
1025 case VSCALE:
1026 case HCOVER:
1027 case VCOVER:
1028 case SCALE:
1029 case KERN_SHRINK:
1030 case HCONTRACT:
1031 case VCONTRACT:
1032 case HLIMITED:
1033 case VLIMITED:
1034 case HEXPAND:
1035 case VEXPAND:
1036 case START_HVSPAN:
1037 case START_HSPAN:
1038 case START_VSPAN:
1039 case HSPAN:
1040 case VSPAN:
1041 case PADJUST:
1042 case HADJUST:
1043 case VADJUST:
1044 case ROTATE:
1045 case BACKGROUND:
1046 case CASE:
1047 case YIELD:
1048 case BACKEND:
1049 case XCHAR:
1050 case FONT:
1051 case SPACE:
1052 case YUNIT:
1053 case ZUNIT:
1054 case SET_CONTEXT:
1055 case GET_CONTEXT:
1056 case BREAK:
1057 case UNDERLINE:
1058 case UNDERLINE_COLOUR:
1059 case COLOUR:
1060 case TEXTURE:
1061 case OUTLINE:
1062 case LANGUAGE:
1063 case CURR_LANG:
1064 case CURR_FAMILY:
1065 case CURR_FACE:
1066 case CURR_YUNIT:
1067 case CURR_ZUNIT:
1068 case COMMON:
1069 case RUMP:
1070 case MELD:
1071 case INSERT:
1072 case ONE_OF:
1073 case NEXT:
1074 case TAGGED:
1075 case INCGRAPHIC:
1076 case SINCGRAPHIC:
1077 case PLAIN_GRAPHIC:
1078 case GRAPHIC:
1079 case LINK_SOURCE:
1080 case LINK_DEST:
1081 case LINK_URL:
1082
1083 /* clean up left context of t (these ops are all right associative) */
1084 Shift(t, precedence(t), RIGHT_ASSOC,
1085 has_lpar(actual(t)), has_rpar(actual(t)));
1086 t = LexGetToken();
1087 break;
1088
1089
1090 case VERBATIM:
1091 case RAW_VERBATIM:
1092
1093 /* clean up left context of t */
1094 x = t;
1095 Shift(t, precedence(t), RIGHT_ASSOC,
1096 has_lpar(actual(t)), has_rpar(actual(t)));
1097
1098 /* check for opening brace or begin following, and shift it onto the stacks */
1099 t = LexGetToken();
1100 if( type(t) != BEGIN && type(t) != LBR )
1101 Error(6, 40, "right parameter of %s or %s must be enclosed in braces",
1102 FATAL, &fpos(x), KW_VERBATIM, KW_RAWVERBATIM);
1103 actual(t) = type(x) == VERBATIM ? VerbatimSym : RawVerbatimSym;
1104 Shift(t, LBR_PREC, 0, FALSE, TRUE);
1105
1106 /* read right parameter and add it to the stacks, and reduce */
1107 y = LexScanVerbatim( (FILE *) NULL, type(t) == BEGIN, &fpos(t),
1108 type(x) == RAW_VERBATIM);
1109 ShiftObj(y, PREV_OBJ);
1110
1111 /* carry on, hopefully to the corresponding right brace or @End @Verbatim */
1112 t = LexGetToken();
1113 break;
1114
1115
1116 case PLUS:
1117 case MINUS:
1118
1119 /* clean up left context of t (these ops are all left associative) */
1120 Shift(t, precedence(t), LEFT_ASSOC,
1121 has_lpar(actual(t)), has_rpar(actual(t)));
1122 t = LexGetToken();
1123 break;
1124
1125
1126 case UNEXPECTED_EOF:
1127
1128 Error(6, 22, "unexpected end of input", FATAL, &fpos(t));
1129 break;
1130
1131
1132 case BEGIN:
1133
1134 if( actual(t) == nilobj )
1135 { Error(6, 23, "%s replaced by %s", WARN, &fpos(t), KW_BEGIN, KW_LBR);
1136 type(t) = LBR;
1137 }
1138 /* NB NO BREAK! */
1139
1140
1141 case LBR:
1142
1143 Shift(t, LBR_PREC, 0, FALSE, TRUE);
1144 t = LexGetToken();
1145 break;
1146
1147
1148 case END:
1149
1150 if( actual(t) == nilobj ) /* haven't sought following symbol yet */
1151 { x = LexGetToken();
1152 if( type(x) == CLOSURE )
1153 { actual(t) = actual(x);
1154 Dispose(x);
1155 x = nilobj;
1156 }
1157 else if( type(x) == VERBATIM )
1158 { actual(t) = VerbatimSym;
1159 Dispose(x);
1160 x = nilobj;
1161 }
1162 else if( type(x) == RAW_VERBATIM )
1163 { actual(t) = RawVerbatimSym;
1164 Dispose(x);
1165 x = nilobj;
1166 }
1167 else if( type(x) == WORD && string(x)[0] == CH_SYMSTART )
1168 { Error(6, 24, "unknown or misspelt symbol %s after %s deleted",
1169 WARN, &fpos(x), string(x), KW_END);
1170 actual(t) = nilobj;
1171 Dispose(x);
1172 x = nilobj;
1173 }
1174 else
1175 { Error(6, 25, "symbol expected after %s", WARN, &fpos(x), KW_END);
1176 actual(t) = nilobj;
1177 }
1178 }
1179 else x = nilobj;
1180 Shift(t, precedence(t), 0, TRUE, FALSE);
1181 t = (x != nilobj) ? x : LexGetToken();
1182 break;
1183
1184
1185 case RBR:
1186
1187 Shift(t, precedence(t), 0, TRUE, FALSE);
1188 t = LexGetToken();
1189 break;
1190
1191
1192 case USE:
1193 case NOT_REVEALED:
1194 case PREPEND:
1195 case SYS_PREPEND:
1196 case INCG_REPEATED:
1197 case SINCG_REPEATED:
1198 case DATABASE:
1199 case SYS_DATABASE:
1200
1201 Error(6, 26, "%s symbol out of place",
1202 INTERN, &fpos(t), SymName(actual(t)));
1203 break;
1204
1205
1206 case ENV:
1207
1208 /* only occurs in cross reference databases */
1209 res = ParseEnvClosure(t, encl);
1210 ShiftObj(res, PREV_OBJ);
1211 t = LexGetToken();
1212 break;
1213
1214
1215 case ENVA:
1216
1217 /* only occurs in cross reference databases */
1218 offset = LexNextTokenPos() -StringLength(KW_ENVA)-StringLength(KW_LBR)-1;
1219 Dispose(t); t = LexGetToken();
1220 tmp = Parse(&t, encl, FALSE, FALSE);
1221 env = SetEnv(tmp, nilobj);
1222 ShiftObj(env, PREV_OBJ);
1223 t = LexGetToken();
1224 EnvReadInsert(file_num(fpos(t)), offset, env);
1225 break;
1226
1227
1228 case ENVB:
1229
1230 /* only occurs in cross reference databases */
1231 offset = LexNextTokenPos() -StringLength(KW_ENVB)-StringLength(KW_LBR)-1;
1232 Dispose(t); t = LexGetToken();
1233 env = Parse(&t, encl, FALSE, FALSE);
1234 t = LexGetToken();
1235 res = Parse(&t, encl, FALSE, FALSE);
1236 /* env = SetEnv(res, env); fails sometimes, below is yukky patch JK */
1237 env = SetEnv(res, type(env) == ENV ? env : NULL);
1238 ShiftObj(env, PREV_OBJ);
1239 t = LexGetToken();
1240 EnvReadInsert(file_num(fpos(t)), offset, env);
1241 break;
1242
1243
1244 case ENVC:
1245
1246 /* only occurs in cross reference databases */
1247 Dispose(t); t = LexGetToken();
1248 New(res, ENV);
1249 ShiftObj(res, PREV_OBJ);
1250 break;
1251
1252
1253 case ENVD:
1254
1255 /* only occurs in cross reference databases */
1256 Dispose(t); t = LexGetToken();
1257 if( type(t) != QWORD ||
1258 sscanf((char *) string(t), "%d %d", &offset, &lnum) != 2 )
1259 Error(6, 37, "error in cross reference database", FATAL, &fpos(t));
1260 if( !EnvReadRetrieve(file_num(fpos(t)), offset, &env) )
1261 { LexPush(file_num(fpos(t)), offset, DATABASE_FILE, lnum, TRUE);
1262 Dispose(t); t = LexGetToken();
1263 env = Parse(&t, encl, FALSE, FALSE);
1264 LexPop();
1265 }
1266 else
1267 { Dispose(t);
1268 }
1269 ShiftObj(env, PREV_OBJ);
1270 t = LexGetToken();
1271 break;
1272
1273
1274 case CENV:
1275
1276 /* only occurs in cross reference databases */
1277 Dispose(t); t = LexGetToken();
1278 env = Parse(&t, encl, FALSE, FALSE);
1279 scope_count = 0;
1280 SetScope(env, &scope_count, FALSE);
1281 t = LexGetToken();
1282 res = Parse(&t, encl, FALSE, FALSE);
1283 for( i = 0; i < scope_count; i++ ) PopScope();
1284 AttachEnv(env, res);
1285 ShiftObj(res, PREV_OBJ);
1286 t = LexGetToken();
1287 break;
1288
1289
1290 case LUSE:
1291
1292 /* only occurs in cross-reference databases */
1293 /* copy invocation from use_invocation(xsym), don't read it */
1294 Dispose(t); t = LexGetToken();
1295 if( type(t) != CLOSURE )
1296 Error(6, 27, "symbol expected following %s", FATAL,&fpos(t),KW_LUSE);
1297 xsym = actual(t);
1298 if( use_invocation(xsym) == nilobj )
1299 Error(6, 28, "%s clause(s) changed from previous run",
1300 FATAL, &fpos(t), KW_USE);
1301 x = CopyObject(use_invocation(xsym), no_fpos);
1302 for( link = LastDown(x); link != x; link = PrevDown(link) )
1303 { Child(y, link);
1304 if( type(y) == ENV )
1305 { DeleteLink(link);
1306 break;
1307 }
1308 }
1309 ShiftObj(x, PREV_OBJ);
1310 t = LexGetToken();
1311 break;
1312
1313
1314 case LVIS:
1315
1316 /* only occurs in cross-reference databases */
1317 SuppressVisible();
1318 Dispose(t); t = LexGetToken();
1319 UnSuppressVisible();
1320 if( type(t) != CLOSURE )
1321 Error(6, 29, "symbol expected following %s", FATAL,&fpos(t),KW_LVIS);
1322 /* NB NO BREAK! */
1323
1324
1325 case CLOSURE:
1326
1327 x = t; xsym = actual(x);
1328
1329 /* look ahead one token, which could be an NPAR */
1330 /* or could be @NotRevealed */
1331 PushScope(xsym, TRUE, FALSE);
1332 t = LexGetToken();
1333 if( type(t) == NOT_REVEALED )
1334 { Dispose(t);
1335 t = LexGetToken();
1336 revealed = FALSE;
1337 }
1338 else revealed = TRUE;
1339 PopScope();
1340
1341 /* if x starts a cross-reference, make it a CLOSURE */
1342 if( is_cross(type(t)) )
1343 { ShiftObj(x, PREV_OBJ);
1344 break;
1345 }
1346
1347 /* clean up left context of x */
1348 Shift(x,precedence(x),right_assoc(xsym),has_lpar(xsym),has_rpar(xsym));
1349
1350 /* update uses relation if required */
1351 if( encl != StartSym && encl != nilobj )
1352 { if( has_target(xsym) )
1353 { uses_galley(encl) = TRUE;
1354 dirty(encl) = (dirty(encl) || dirty(xsym));
1355 }
1356 else if( revealed ) InsertUses(encl, xsym);
1357 }
1358
1359 /* read named parameters */
1360 compulsory_count = 0;
1361 while( (type(t) == CLOSURE && enclosing(actual(t)) == xsym
1362 && type(actual(t)) == NPAR)
1363 || (type(t) == LBR && precedence(t) != LBR_PREC) )
1364 {
1365 OBJECT new_par;
1366
1367 /* check syntax and attach the named parameter to x */
1368 if( type(t) == CLOSURE )
1369 {
1370 new_par = t;
1371 t = LexGetToken();
1372 if( type(t) != LBR )
1373 { Error(6, 30, "%s must follow named parameter %s",
1374 WARN, &fpos(new_par), KW_LBR, SymName(actual(new_par)));
1375 Dispose(new_par);
1376 break;
1377 }
1378 }
1379 else
1380 {
1381 /* compressed form of named parameter */
1382 new_par = NewToken(CLOSURE, &fpos(t), vspace(t), hspace(t),
1383 NO_PREC, ChildSymWithCode(x, precedence(t)));
1384 precedence(t) = LBR_PREC;
1385 }
1386
1387 /* add import list of the named parameter to current scope */
1388 scope_count = 0;
1389 imps = imports(actual(new_par));
1390 if( imps != nilobj )
1391 { for( link = Down(imps); link != imps; link = NextDown(link) )
1392 { Child(y, link);
1393 PushScope(actual(y), FALSE, TRUE);
1394 scope_count++;
1395 }
1396 }
1397
1398 /* read the body of the named parameter */
1399 PushScope(actual(new_par), FALSE, FALSE);
1400 tmp = Parse(&t, encl, FALSE, FALSE);
1401 PopScope();
1402 type(new_par) = PAR;
1403 Link(new_par, tmp);
1404
1405 /* pop the scopes pushed for the import list */
1406 for( i = 0; i < scope_count; i++ )
1407 PopScope();
1408
1409 /* check that new_par has not already occurred, then link it to x */
1410 for( link = Down(x); link != x; link = NextDown(link) )
1411 { Child(y, link);
1412 assert( type(y) == PAR, "Parse: type(y) != PAR!" );
1413 if( actual(new_par) == actual(y) )
1414 { Error(6, 31, "named parameter %s of %s appears twice", WARN,
1415 &fpos(new_par), SymName(actual(new_par)), SymName(actual(x)));
1416 DisposeObject(new_par);
1417 new_par = nilobj;
1418 break;
1419 }
1420 }
1421 if( new_par != nilobj )
1422 {
1423 /* keep track of the number of compulsory named parameters */
1424 if( is_compulsory(actual(new_par)) )
1425 compulsory_count++;
1426
1427 Link(x, new_par);
1428 }
1429
1430 /* get next token, possibly another NPAR */
1431 PushScope(xsym, TRUE, FALSE); /* allow NPARs only */
1432 if( t == nilobj ) t = LexGetToken();
1433 PopScope();
1434
1435 } /* end while */
1436
1437 /* report absence of compulsory parameters */
1438 debug4(DOP, DD, "%s %s %d : %d", EchoFilePos(&fpos(x)),
1439 SymName(xsym), compulsory_count, has_compulsory(xsym));
1440 if( compulsory_count < has_compulsory(xsym) )
1441 {
1442 for( xlink = Down(xsym); xlink != xsym; xlink = NextDown(xlink) )
1443 { Child(tmp, xlink);
1444 if( type(tmp) == NPAR && is_compulsory(tmp) )
1445 { for( link = Down(x); link != x; link = NextDown(link) )
1446 { Child(y, link);
1447 if( type(y) == PAR && actual(y) == tmp )
1448 break;
1449 }
1450 if( link == x )
1451 {
1452 Error(6, 38, "compulsory option %s missing from %s",
1453 WARN, &fpos(x), SymName(tmp), SymName(xsym));
1454 }
1455 }
1456 }
1457 }
1458
1459 /* record symbol name in BEGIN following, if any */
1460 if( type(t) == BEGIN )
1461 { if( !has_rpar(xsym) )
1462 Error(6, 32, "%s out of place here (%s has no right parameter)",
1463 WARN, &fpos(x), KW_BEGIN, SymName(xsym));
1464 else actual(t) = xsym;
1465 }
1466
1467 /* if x can be transferred, do so */
1468 if( transfer_allowed && has_target(xsym) &&
1469 !has_key(xsym) && filter(xsym) == nilobj )
1470 {
1471 if( !has_rpar(xsym) || uses_count(ChildSym(xsym, RPAR)) <= 1 )
1472 {
1473 debug1(DGT, D, "examining transfer of %s", SymName(xsym));
1474 ifdebug(DGT, D, DebugStacks(initial_ttop, obj_prev));
1475 i = has_rpar(xsym) ? ttop -1 : ttop;
1476 while( is_cat_op(type(tok_stack[i])) ) i--;
1477 if( (type(tok_stack[i])==LBR || type(tok_stack[i])==BEGIN)
1478 && type(tok_stack[i-1]) == GSTUB_EXT )
1479 {
1480 /* at this point it is likely that x is transferable */
1481 if( has_rpar(xsym) )
1482 { New(tmp, CLOSURE);
1483 actual(tmp) = InputSym;
1484 FposCopy( fpos(tmp), fpos(t) );
1485 ShiftObj(tmp, PREV_OBJ);
1486 obj_prev = Reduce();
1487 }
1488 x = PopObj();
1489 x = TransferBegin(x);
1490 if( type(x) == CLOSURE ) /* failure: unReduce */
1491 { if( has_rpar(xsym) )
1492 { Child(tmp, LastDown(x));
1493 assert(type(tmp)==PAR && type(actual(tmp))==RPAR,
1494 "Parse: cannot undo rpar" );
1495 DisposeChild(LastDown(x));
1496 if( has_lpar(xsym) )
1497 { Child(tmp, Down(x));
1498 assert(type(tmp)==PAR && type(actual(tmp))==LPAR,
1499 "Parse: cannot undo lpar" );
1500 Child(tmp, Down(tmp));
1501 PushObj(tmp);
1502 DeleteLink(Up(tmp));
1503 DisposeChild(Down(x));
1504 }
1505 PushToken(x); obj_prev = PREV_OP;
1506 }
1507 else
1508 { PushObj(x);
1509 obj_prev = PREV_OBJ;
1510 }
1511 }
1512 else /* success */
1513 { obj_prev = PREV_OP;
1514 Shift(x, NO_PREC, 0, FALSE, has_rpar(xsym));
1515 }
1516 }
1517 }
1518 } /* end if has_target */
1519
1520 if( filter(xsym) != nilobj )
1521 {
1522 if( type(t) == BEGIN || type(t) == LBR )
1523 {
1524 /* create filter object and copy parameter into temp file */
1525 tmp = FilterCreate((BOOLEAN) (type(t) == BEGIN), xsym, &fpos(t));
1526
1527 /* push filter object onto stacks and keep going */
1528 Shift(t, precedence(t), 0, FALSE, TRUE);
1529 ShiftObj(tmp, PREV_OBJ);
1530 t = LexGetToken();
1531 }
1532 else Error(6, 33, "right parameter of %s must be enclosed in braces",
1533 FATAL, &fpos(x), SymName(xsym));
1534 }
1535
1536 else if( has_body(xsym) )
1537 { if( type(t) == BEGIN || type(t) == LBR )
1538 { PushScope(xsym, FALSE, TRUE);
1539 PushScope(ChildSym(xsym, RPAR), FALSE, FALSE);
1540 PushObj( Parse(&t, encl, FALSE, TRUE) );
1541 obj_prev = Reduce();
1542 PopScope();
1543 PopScope();
1544 if( t == nilobj ) t = LexGetToken();
1545 }
1546 else
1547 { Error(6, 34, "body parameter of %s must be enclosed in braces",
1548 WARN, &fpos(t), SymName(xsym));
1549 }
1550 }
1551 break;
1552
1553
1554 case OPEN:
1555
1556 x = t; xsym = nilobj;
1557 Shift(t, precedence(t), RIGHT_ASSOC, TRUE, TRUE);
1558 if( type(ObjTop) == CLOSURE ) xsym = actual(ObjTop);
1559 else if( is_cross(type(ObjTop)) && Down(ObjTop) != ObjTop )
1560 { Child(tmp, Down(ObjTop));
1561 if( type(tmp) == CLOSURE ) xsym = actual(tmp);
1562 }
1563 t = LexGetToken();
1564
1565 if( xsym == nilobj )
1566 Error(6, 35, "invalid left parameter of %s", WARN, &fpos(x), KW_OPEN);
1567 else if( type(t) != BEGIN && type(t) != LBR )
1568 Error(6, 36, "right parameter of %s must be enclosed in braces",
1569 WARN, &fpos(t), KW_OPEN);
1570 else
1571 { PushScope(xsym, FALSE, TRUE);
1572 tmp = Parse(&t, encl, FALSE, FALSE);
1573 ShiftObj(tmp, PREV_RBR);
1574 PopScope();
1575 if( t == nilobj ) t = LexGetToken();
1576 obj_prev = Reduce();
1577 }
1578 break;
1579
1580
1581 default:
1582
1583 assert1(FALSE, "Parse:", Image(type(t)));
1584 break;
1585
1586 } /* end switch */
1587 } /* end for */
1588
1589 } /* end Parse */
1590