1 : /*
2 : * OpenBIOS - free your system!
3 : * ( FCode tokenizer )
4 : *
5 : * This program is part of a free implementation of the IEEE 1275-1994
6 : * Standard for Boot (Initialization Configuration) Firmware.
7 : *
8 : * Copyright (C) 2001-2005 Stefan Reinauer, <stepan@openbios.org>
9 : *
10 : * This program is free software; you can redistribute it and/or modify
11 : * it under the terms of the GNU General Public License as published by
12 : * the Free Software Foundation; version 2 of the License.
13 : *
14 : * This program is distributed in the hope that it will be useful,
15 : * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 : * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 : * GNU General Public License for more details.
18 : *
19 : * You should have received a copy of the GNU General Public License
20 : * along with this program; if not, write to the Free Software
21 : * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA, 02110-1301 USA
22 : *
23 : */
24 :
25 : /* **************************************************************************
26 : *
27 : * Support Functions for tokenizing FORTH Flow-Control structures.
28 : *
29 : * (C) Copyright 2005 IBM Corporation. All Rights Reserved.
30 : * Module Author: David L. Paktor dlpaktor@us.ibm.com
31 : *
32 : **************************************************************************** */
33 :
34 : /* **************************************************************************
35 : *
36 : * Functions Exported:
37 : * These first two do their work after the calling routine
38 : * has written the token for the required variant:
39 : *
40 : * mark_do Mark branches for "do" variants
41 : * resolve_loop Resolve "loop" variants' branches
42 : *
43 : * The remaining routines' descriptions are all similar:
44 : * Write the token(s), handle the outputs, mark
45 : * or resolve the branches, and verify correct
46 : * control-structure matching, for tokenizing
47 : * the ........................ statement in FORTH
48 : * emit_if IF
49 : * emit_else ELSE
50 : * emit_then THEN
51 : * emit_begin BEGIN
52 : * emit_again AGAIN
53 : * emit_until UNTIL
54 : * emit_while WHILE
55 : * emit_repeat REPEAT
56 : * emit_case CASE
57 : * emit_of OF
58 : * emit_endof ENDOF
59 : * emit_endcase ENDCASE
60 : *
61 : * Three additional routines deal with matters of overall balance
62 : * of the Control-Structures, and identify the start of any that
63 : * were not balanced. The first just displays Messages:
64 : *
65 : * announce_control_structs
66 : *
67 : * The other two clear and re-balance them:
68 : *
69 : * clear_control_structs_to_limit
70 : * clear_control_structs
71 : *
72 : **************************************************************************** */
73 :
74 : /* **************************************************************************
75 : *
76 : * Still to be done:
77 : * Correct analysis of Return-Stack usage around Flow-Control
78 : * constructs, including within Do-Loops or before Loop
79 : * Elements like I and J or UNLOOP or LEAVE.
80 : * Similarly, Return-Stack usage around IF ... ELSE ... THEN
81 : * statements needs analysis. For instance, the following:
82 : *
83 : * blablabla >R yadayada IF R> gubble ELSE flubble R> THEN
84 : *
85 : * is, in fact, correct, while something like:
86 : *
87 : * blablabla >R yadayada IF R> gubble THEN
88 : *
89 : * is an error.
90 : *
91 : * Implementing an analysis that would be sufficiently accurate
92 : * to justify reporting an ERROR with certainty (rather than
93 : * a mere WARNING speculatively) would probably require full
94 : * coordination with management of Flow-Control constructs,
95 : * and so is noted here.
96 : *
97 : **************************************************************************** */
98 :
99 : #include <stdlib.h>
100 : #include <stdio.h>
101 : #include <string.h>
102 :
103 : #include "types.h"
104 : #include "toke.h"
105 : #include "emit.h"
106 : #include "vocabfuncts.h"
107 : #include "scanner.h"
108 : #include "stack.h"
109 : #include "errhandler.h"
110 : #include "flowcontrol.h"
111 : #include "stream.h"
112 :
113 : /* **************************************************************************
114 : *
115 : * Global Variables Imported
116 : * opc FCode Output Buffer Position Counter
117 : * noerrors "Ignore Errors" flag, set by "-i" switch
118 : * do_loop_depth How deep we are inside DO ... LOOP variants
119 : * incolon State of tokenization; TRUE if inside COLON
120 : * statbuf The word just read from the input stream
121 : * iname Name of input file currently being processed
122 : * lineno Current line-number being processed
123 : *
124 : **************************************************************************** */
125 :
126 : /* **************************************************************************
127 : *
128 : * Global Variables Exported
129 : * control_stack_depth Number of items on "Control-Stack"
130 : *
131 : **************************************************************************** */
132 :
133 : int control_stack_depth = 0;
134 :
135 :
136 : /* **************************************************************************
137 : *
138 : * Internal Static Functions:
139 : * push_cstag Push an item onto the Control-Stack
140 : * pop_cstag Pop one item from the Control-Stack
141 : * control_stack_size_test Test C-S depth; report if error
142 : * control_structure_mismatch Print error-message
143 : * offset_too_large Print error-message
144 : * matchup_control_structure Error-check Control-Stack
145 : * matchup_two_control_structures Error-check two Control-Stack entries
146 : * emit_fc_offset Error-check and output FCode-Offset
147 : * control_structure_swap Swap control-struct branch-markers
148 : * mark_backward_target Mark target of backward-branch
149 : * resolve_backward Resolve backward-target for branch
150 : * mark_forward_branch Mark forward-branch
151 : * resolve_forward Resolve forward-branch at target
152 : *
153 : **************************************************************************** */
154 :
155 : /* **************************************************************************
156 : *
157 : * Internal Named Constants
158 : * Note: These control-structure identifier tags -- a.k.a. cstags --
159 : * are used to identify the matching components of particular
160 : * control-structures. They are passed as parameters, and either
161 : * "Pushed" onto the "Control-Stack", or compared with what is on
162 : * "Top" of the "Control-Stack", as an error-check.
163 : *
164 : * name used by forth words:
165 : * BEGIN_CSTAG BEGIN AGAIN UNTIL REPEAT
166 : * IF_CSTAG IF ELSE THEN
167 : * WHILE_CSTAG WHILE REPEAT THEN
168 : * DO_CSTAG DO ?DO LOOP +LOOP
169 : * CASE_CSTAG CASE OF ENDCASE
170 : * OF_CSTAG OF ENDOF
171 : * ENDOF_CSTAG ENDOF ENDCASE
172 : *
173 : * The numbers assigned are arbitrary; they were selected for a
174 : * high unlikelihood of being encountered in normal usage,
175 : * and constructed with a hint of mnemonic value in mind.
176 : *
177 : **************************************************************************** */
178 : /* Mnemonic: */
179 : #define BEGIN_CSTAG 0xC57be916 /* CST BEGIN */
180 : #define IF_CSTAG 0xC57A901f /* CSTAG (0) IF */
181 : #define WHILE_CSTAG 0xC573412e /* CST WHILE */
182 : #define DO_CSTAG 0xC57A90d0 /* CSTAG (0) DO */
183 : #define CASE_CSTAG 0xC57Aca5e /* CSTA CASE */
184 : #define OF_CSTAG 0xC57A90f0 /* CSTAG OF (0) */
185 : #define ENDOF_CSTAG 0xC57e6d0f /* CST ENDOF */
186 :
187 :
188 : /* **************************************************************************
189 : *
190 : * Control-Structure identification, matching, completion and error
191 : * messaging will be supported by a data structure, which we
192 : * will call a CSTAG-Group
193 : *
194 : * It consists of one "Data-item" and several "Marker" items, thus:
195 : *
196 : * The Data-item in most cases will be a value of OPC (the Output
197 : * Buffer Position Counter) which will be used in calculating
198 : * an offset or placing an offset or both, as the case may be,
199 : * for the control structure in question. The one exception
200 : * is for a CSTAG-Group generated by a CASE statement; its
201 : * Data-item will be an integer count of the number of "OF"s
202 : * to be resolved when the ENDCASE statement is reached.
203 : *
204 : * The CSTAG for the FORTH word, as described above
205 : * The name of the input file in which the word was encountered
206 : * (actually, a pointer to a mem-alloc'ed copy of the filename)
207 : * The line number, within the input file, of the word's invocation
208 : * The Absolute Token Number in all Source Input of the word
209 : * The FORTH word that started the structure, (used in error messages)
210 : * A flag to indicate when two CSTAG-Groups are created together,
211 : * which will be used to prevent duplicate error messages when,
212 : * for instance, a DO is mismatched with a REPEAT .
213 : *
214 : **************************************************************************** */
215 :
216 : /* **************************************************************************
217 : *
218 : * "Control-Stack" Diagram Notation
219 : *
220 : * The CSTAG-Groups will be kept in an order resembling a data-stack,
221 : * (even though it won't be the data-stack itself). We will refer
222 : * to this list of structures as the "Control Stack", and in our
223 : * comments we will show their arrangement in a format resembling
224 : * stack-diagram remarks.
225 : *
226 : * In these "Control-Stack Diagrams", we will use the notation:
227 : * <Stmt>_{FOR|BACK}w_<TAGNAM>
228 : * to represent a CSTAG-Group generated by a <Stmt> -type of
229 : * statement, with a "FORw"ard or "BACKw"ard branch-marker and
230 : * a CSTAG of the <TAGNAM> type.
231 : *
232 : * A CASE-CSTAG-Group will have a different notation:
233 : * N_OFs...CASE_CSTAG
234 : *
235 : * In all cases, a CSTAG-Group will be manipulated as a unit.
236 : *
237 : * The notation for Control-Stack Diagram remarks will largely resemble
238 : * the classic form used in FORTH, i.e., enclosed in parentheses,
239 : * lowest item to the left, top item on the right, with a double-
240 : * hyphen to indicate "before" or "after".
241 : *
242 : * Enclosure in {curly-braces} followed by a subscript-range indicates
243 : * that the Stack-item or Group is repeated.
244 : *
245 : **************************************************************************** */
246 :
247 : /* **************************************************************************
248 : *
249 : * We are not keeping the "Control Stack" structures on the regular
250 : * data stack because a sneaky combination of user-inputs could
251 : * throw things into chaos were we to use that scheme. Consider
252 : * what would happen if a number were put on the stack, say, in
253 : * tokenizer-escape mode, in between elements of a flow-control
254 : * structure... Theoretically, there is no reason to prohibit
255 : * that, but it would be unexpectedly problematical for most
256 : * FORTH-based tokenizers.
257 : *
258 : * Maintaining the "Control Stack" structures in a linked-list would
259 : * be a more nearly bullet-proof approach. The theory of operation
260 : * would be the same, broadly speaking, and there would be no need
261 : * to check for NOT_CSTAG and no risk of getting the elements of
262 : * the control-structures out of sync.
263 : *
264 : **************************************************************************** */
265 :
266 : /* **************************************************************************
267 : *
268 : * Structure Name: cstag_group_t
269 : * Synopsis: Control-Structure Tag Group
270 : *
271 : * Fields:
272 : * cs_tag Control-structure identifier tag
273 : * cs_inp_fil Name of input file where C-S was started
274 : * cs_line_num Line-number in Current Source when C-S was started
275 : * cs_abs_token_num "Absolute" Token Number when C-S was started
276 : * cs_word The FORTH word that started the C-S
277 : * cs_not_dup FALSE if second "Control Stack" entry for same word
278 : * cs_datum Data-Item of the Group
279 : * prev Pointer to previous CSTAG-Group in linked-list
280 : *
281 : * All data using this structure will remain private to this file,
282 : * so we declare it here rather than in the .h file
283 : *
284 : **************************************************************************** */
285 :
286 : typedef struct cstag_group {
287 : unsigned long cs_tag;
288 : char *cs_inp_fil;
289 : unsigned int cs_line_num;
290 : unsigned int cs_abs_token_num;
291 : char *cs_word;
292 : bool cs_not_dup;
293 : unsigned long cs_datum;
294 : struct cstag_group *prev;
295 : } cstag_group_t;
296 :
297 : /* **************************************************************************
298 : *
299 : * Internal Static Variables
300 : * control_stack "Thread" Pointer to the linked-list of
301 : * "Control Stack" structure entries
302 : * not_cs_underflow Flag used to prevent duplicate messages
303 : * not_consuming_two Flag used to prevent loss of messages
304 : * didnt_print_otl Flag used to prevent duplicate messages
305 : *
306 : **************************************************************************** */
307 :
308 : static cstag_group_t *control_stack = NULL; /* "Top" of the "Stack" */
309 :
310 : /* **************************************************************************
311 : *
312 : * not_cs_underflow is used only by routines that make two calls to
313 : * resolve a marker. It is set TRUE before the first call; if
314 : * that call had a control-stack underflow, the error-message
315 : * routine resets it to FALSE. The calling routine can then
316 : * test it as the condition for the second call.
317 : * Routines that make only one call to resolve a marker can ignore it.
318 : *
319 : **************************************************************************** */
320 :
321 : static bool not_cs_underflow; /* No need to initialize. */
322 :
323 : /* **************************************************************************
324 : *
325 : * not_consuming_two is also used only by routines that make two calls
326 : * to resolve a marker, but for this case, those routines only need
327 : * to reset it to FALSE and not to test it; that will be done by
328 : * the control_structure_mismatch() routine when it looks at
329 : * the cs_not_dup field. If the mismatch occurred because of
330 : * a combination of control-structures that consume one each,
331 : * the message will be printed even for the second "Control Stack"
332 : * entry. The routine that changed it will have to set it back to
333 : * TRUE when it's done with it.
334 : *
335 : * didnt_print_otl is used similarly, but only for the offset-too-large
336 : * error in the DO ... LOOP type of control-structures.
337 : *
338 : **************************************************************************** */
339 :
340 : static bool not_consuming_two = TRUE;
341 : static bool didnt_print_otl = TRUE;
342 :
343 :
344 : /* **************************************************************************
345 : *
346 : * Function name: push_cstag
347 : * Synopsis: Push a new CSTAG-Group onto the front ("Top")
348 : * of the (notional) Control-Stack.
349 : *
350 : * Inputs:
351 : * Parameters:
352 : * cstag ID Tag for Control-Structure to "Push"
353 : * datum The Data-Item for the new CSTAG-Group
354 : * Global Variables:
355 : * iname Name of input file currently being processed
356 : * lineno Current-Source line-number being processed
357 : * abs_tokenno "Absolute"Token Number of word being processed
358 : * statbuf The word just read, which started the C-S
359 : * Local Static Variables:
360 : * control_stack Will become the new entry's "prev"
361 : *
362 : * Outputs:
363 : * Returned Value: None
364 : * Global Variables:
365 : * control_stack_depth Incremented
366 : * Local Static Variables:
367 : * control_stack Will become the "previous" entry in the list
368 : * Items Pushed onto Control-Stack:
369 : * Top: A new CSTAG-Group, params as given
370 : * Memory Allocated
371 : * New CSTAG-Group structure
372 : * Duplicate of name of current input file
373 : * Duplicate of word just read
374 : * When Freed?
375 : * When Removing a CSTAG-Group, in pop_cstag()
376 : *
377 : **************************************************************************** */
378 :
379 : static void push_cstag( unsigned long cstag, unsigned long datum)
380 3077 : {
381 : cstag_group_t *cs_temp;
382 :
383 3077 : cs_temp = control_stack;
384 3077 : control_stack = safe_malloc( sizeof(cstag_group_t), "pushing CSTag");
385 :
386 3077 : control_stack->cs_tag = cstag;
387 3077 : control_stack->cs_inp_fil = strdup(iname);
388 3077 : control_stack->cs_line_num = lineno;
389 3077 : control_stack->cs_abs_token_num = abs_token_no;
390 3077 : control_stack->cs_word = strdup(statbuf);
391 3077 : control_stack->cs_not_dup = TRUE;
392 3077 : control_stack->cs_datum = datum;
393 3077 : control_stack->prev = cs_temp;
394 :
395 3077 : control_stack_depth++;
396 :
397 3077 : }
398 :
399 : /* **************************************************************************
400 : *
401 : * Function name: pop_cstag
402 : * Synopsis: Remove a CSTAG-Group from the front ("Top") of the
403 : * (notional) Control-Stack.
404 : *
405 : * Inputs:
406 : * Parameters: NONE
407 : * Global Variables:
408 : * Local Static Variables:
409 : * control_stack CSTAG-Group on "Top"
410 : *
411 : * Outputs:
412 : * Returned Value: NONE
413 : * Global Variables:
414 : * control_stack_depth Decremented
415 : * Local Static Variables:
416 : * control_stack "Previous" entry will become current
417 : * Memory Freed
418 : * mem-alloc'ed copy of input filename
419 : * mem-alloc'ed copy of Control-structure FORTH word
420 : * CSTAG-Group structure
421 : * Control-Stack, # of Items Popped: 1
422 : *
423 : * Process Explanation:
424 : * The calling routine might not check for empty Control-Stack,
425 : * so we have to be sure and check it here.
426 : *
427 : **************************************************************************** */
428 :
429 : static void pop_cstag( void)
430 3089 : {
431 :
432 3089 : if ( control_stack != NULL )
433 : {
434 : cstag_group_t *cs_temp;
435 :
436 3077 : cs_temp = control_stack->prev;
437 3077 : free( control_stack->cs_word );
438 3077 : free( control_stack->cs_inp_fil );
439 3077 : free( control_stack );
440 3077 : control_stack = cs_temp;
441 :
442 3077 : control_stack_depth--;
443 : }
444 3089 : }
445 :
446 : /* **************************************************************************
447 : *
448 : * Function name: control_stack_size_test
449 : * Synopsis: Detect Control Stack underflow; report if an ERROR.
450 : *
451 : * Inputs:
452 : * Parameters:
453 : * min_depth Minimum depth needed
454 : * Global Variables:
455 : * control_stack_depth Current depth of Control Stack
456 : * statbuf Word to name in error message
457 : *
458 : * Outputs:
459 : * Returned Value: TRUE if adequate depth
460 : * Local Static Variables:
461 : * not_cs_underflow Reset to FALSE if underflow detected.
462 : * Printout:
463 : * Error message is printed.
464 : * Identify the colon definition if inside one.
465 : *
466 : * Process Explanation:
467 : * Some statements need more than one item on the Control Stack;
468 : * they will do their own control_stack_depth testing and
469 : * make a separate call to this routine.
470 : *
471 : **************************************************************************** */
472 :
473 : static bool control_stack_size_test( int min_depth )
474 9955 : {
475 9955 : bool retval = TRUE;
476 :
477 9955 : if ( control_stack_depth < min_depth )
478 : {
479 17 : retval = FALSE;
480 17 : tokenization_error ( TKERROR,
481 : "Control-Stack underflow at %s", strupr(statbuf) );
482 17 : in_last_colon();
483 :
484 17 : not_cs_underflow = FALSE; /* See expl'n early on in this file */
485 : }
486 :
487 9955 : return( retval );
488 : }
489 :
490 : /* **************************************************************************
491 : *
492 : * Function name: control_structure_mismatch
493 : * Synopsis: Report an ERROR after a Control Structure mismatch
494 : * was detected.
495 : *
496 : * Inputs:
497 : * Parameters: NONE
498 : * Global Variables:
499 : * statbuf Word encountered, to name in error message
500 : * Local Static Variables:
501 : * control_stack "Pushed" Control-Structure Tag Group
502 : * not_consuming_two See explanation early on in this file
503 : * Control-Stack Items:
504 : * Top: "Current" Control-Structure Tag Group
505 : * Some of its "Marker" information
506 : * will be used in the error message
507 : *
508 : * Outputs:
509 : * Returned Value: NONE
510 : * Printout:
511 : * Error message is printed
512 : *
513 : * Process Explanation:
514 : * This routine is called after a mismatch is detected, and
515 : * before the CSTAG-Group is "Popped" from the notional
516 : * Control-Stack.
517 : * If the control_stack pointer is NULL, print a different
518 : * Error message
519 : * Don't print if the "Control Stack" entry is a duplicate and
520 : * we're processing a statement that consumes two entries.
521 : *
522 : **************************************************************************** */
523 :
524 : static void control_structure_mismatch( void )
525 51 : {
526 51 : if ( control_stack->cs_not_dup || not_consuming_two )
527 : {
528 48 : tokenization_error ( TKERROR,
529 : "The %s is mismatched with the %s" ,
530 : strupr(statbuf), strupr(control_stack->cs_word));
531 48 : where_started( control_stack->cs_inp_fil, control_stack->cs_line_num );
532 : }
533 51 : }
534 :
535 :
536 : /* **************************************************************************
537 : *
538 : * Function name: offset_too_large
539 : * Synopsis: Report an ERROR after a too-large fcode-offset
540 : * was detected.
541 : *
542 : * Inputs:
543 : * Parameters:
544 : * too_large_for_16 TRUE if the offset is too large to be
545 : * expressed as a 16-bit signed number.
546 : * Global Variables:
547 : * statbuf Word encountered, to name in error message
548 : * offs16 Whether we are using 16-bit offsets
549 : * Local Static Variables:
550 : * control_stack "Pushed" Control-Structure Tag Group
551 : * didnt_print_otl Switch to prevent duplicate message
552 : * Control-Stack Items:
553 : * Top: "Current" Control-Structure Tag Group
554 : * Some of its "Marker" information
555 : * will be used in the error message
556 : *
557 : * Outputs:
558 : * Returned Value: NONE
559 : * Local Static Variables:
560 : * didnt_print_otl Will be reset to FALSE
561 : *
562 : * Printout:
563 : * Error message:
564 : * Branch offset too large between <here> and <there>
565 : * Advisory message, if we are using 8-bit offsets, will
566 : * indicate whether switching to 16-bit offsets would help
567 : *
568 : * Process Explanation:
569 : * Two branches are involved in a DO ... LOOP structure: an "outer"
570 : * forward-branch and a slightly smaller "inner" backward-branch.
571 : * In the majority of cases, if one offset exceeds the limit,
572 : * both will. There is, however, a very small but distinct
573 : * possibility that the offset for the smaller branch will not
574 : * exceed the limit while the larger one does. To prevent two
575 : * messages from being printed in the routine instance, but still
576 : * assure that one will be printed in the rare eventuality, we
577 : * utilize the flag called didnt_print_otl in conjunction
578 : * with the cs_not_dup field.
579 : *
580 : **************************************************************************** */
581 :
582 : static void offset_too_large( bool too_large_for_16 )
583 34 : {
584 34 : if ( control_stack->cs_not_dup || didnt_print_otl )
585 : {
586 28 : tokenization_error( TKERROR,
587 : "Branch offset is too large between %s and the %s" ,
588 : strupr(statbuf), strupr(control_stack->cs_word));
589 28 : where_started( control_stack->cs_inp_fil, control_stack->cs_line_num );
590 28 : if ( INVERSE( offs16 ) )
591 : {
592 9 : if ( too_large_for_16 )
593 : {
594 0 : tokenization_error ( INFO,
595 : "Offset would be too large even if 16-bit offsets "
596 : "were in effect.\n");
597 : }else{
598 9 : tokenization_error ( INFO,
599 : "Offset might fit if 16-bit offsets "
600 : "(e.g., fcode-version2) were used.\n" );
601 : }
602 : }
603 : }
604 34 : didnt_print_otl = FALSE;
605 34 : }
606 :
607 : /* **************************************************************************
608 : *
609 : * Function name: emit_fc_offset
610 : * Synopsis: Test whether the given FCode-Offset is out-of-range;
611 : * before placing it into the FCode Output Buffer.
612 : *
613 : * Inputs:
614 : * Parameters:
615 : * fc_offset The given FCode-Offset
616 : * Global Variables:
617 : * offs16 Whether we are using 16-bit offsets
618 : * noerrors "Ignore Errors" flag
619 : *
620 : * Outputs:
621 : * Returned Value: NONE
622 : *
623 : * Error Detection:
624 : * Error if the given FCode-Offset exceeds the range that can
625 : * be expressed by the size (i.e., 8- or 16- -bits) of the
626 : * offsets we are using. Call offset_too_large() to print
627 : * the Error message; also, if noerrors is in effect, issue
628 : * a Warning showing the actual offset and how it will be coded.
629 : *
630 : * Process Explanation:
631 : * For forward-branches, the OPC will have to be adjusted to
632 : * indicate the location that was reserved for the offset
633 : * to be written, rather than the current location. That
634 : * will all be handled by the calling routine.
635 : * We will rely on "C"'s type-conversion (type-casting) facilities.
636 : * Look at the offset value both as an 8-bit and as a 16-bit offset,
637 : * then determine the relevant course of action.
638 : *
639 : **************************************************************************** */
640 :
641 : static void emit_fc_offset( int fc_offset)
642 2990 : {
643 2990 : int fc_offs_s16 = (s16)fc_offset;
644 2990 : int fc_offs_s8 = (s8)fc_offset;
645 2990 : bool too_large_for_8 = BOOLVAL( fc_offset != fc_offs_s8 );
646 2990 : bool too_large_for_16 = BOOLVAL( fc_offset != fc_offs_s16);
647 :
648 2990 : if ( too_large_for_16 || ( INVERSE(offs16) && too_large_for_8 ) )
649 : {
650 34 : offset_too_large( too_large_for_16 );
651 34 : if ( noerrors )
652 : {
653 34 : int coded_as = offs16 ? (int)fc_offs_s16 : (int)fc_offs_s8 ;
654 34 : tokenization_error( WARNING,
655 : "Actual offset is 0x%x (=dec %d), "
656 : "but it will be coded as 0x%x (=dec %d).\n",
657 : fc_offset, fc_offset, coded_as, coded_as );
658 : }
659 : }
660 :
661 2990 : emit_offset( fc_offs_s16 );
662 2990 : }
663 :
664 :
665 : /* **************************************************************************
666 : *
667 : * Function name: matchup_control_structure
668 : * Synopsis: Error-check. Compare the given control-structure
669 : * identifier tag with the one in the CSTAG-Group
670 : * on "Top" of the "Control Stack".
671 : * If they don't match, report an error, and, if not
672 : * "Ignoring Errors", return Error indication.
673 : * If no error, pass the Data-item back to the caller.
674 : * Do not consume the CSTAG-Group; that will be the
675 : * responsibility of the calling routine.
676 : *
677 : * Inputs:
678 : * Parameters:
679 : * cstag Control-struc ID Tag expected by calling function
680 : * Global Variables:
681 : * noerrors "Ignore Errors" flag
682 : * Local Static Variables:
683 : * control_stack "Pushed" (current) Control-Structure Tag Group
684 : * Control-Stack Items:
685 : * Top: Current CSTAG-Group
686 : *
687 : * Outputs:
688 : * Returned Value: TRUE = Successful match, no error.
689 : *
690 : * Error Detection:
691 : * Control Stack underflow or cstag mismatch. See below for details.
692 : *
693 : * Process Explanation:
694 : * If the expected cstag does not match the cs_tag from the CSTAG
695 : * Group on "Top" of the "Control Stack", print an ERROR message,
696 : * and, unless the "Ignore Errors" flag is in effect, prepare
697 : * to return FALSE.
698 : * However, if we've "underflowed" the "Control Stack", we dare not
699 : * ignore errors; that could lead to things like attempting to
700 : * write a forward-branch FCode-offset to offset ZERO, over the
701 : * FCODE- or PCI- -header block. We don't want that...
702 : * So, if the control_stack pointer is NULL, we will print an
703 : * ERROR message and immediately return FALSE.
704 : * Since we will not consume the CSTAG-Group, the calling routine
705 : * can access the Data-Item and any "Marker" information it may
706 : * still require via the local control_stack pointer. The caller
707 : * will be responsible for removing the CSTAG-Group.
708 : *
709 : * Special Exception to "Ignore Errors":
710 : * At the last usage of the CASE_CSTAG , for the ENDCASE statement,
711 : * this routine will be called to control freeing-up memory, etc.
712 : * For the OF statement, it will be called to control incrementing
713 : * the OF-count datum.
714 : * Processing an ENDCASE statement with the datum from any other
715 : * CSTAG-Group can lead to a huge loop.
716 : * Processing any other "resolver" with the datum from an ENDCASE
717 : * CSTAG-Group can lead to mistaking a very low number for an
718 : * offset into the Output Buffer and attempting to write to it.
719 : * Incrementing the datum from any other CSTAG-Group can lead to
720 : * a variety of unacceptable errors, too many to guess.
721 : * So, if either the given cstag or the cs_tag field of the "Top"
722 : * CSTAG-Group is a CASE_CSTAG , we will not ignore errors.
723 : *
724 : **************************************************************************** */
725 :
726 : static bool matchup_control_structure( unsigned long cstag )
727 4552 : {
728 4552 : bool retval = FALSE;
729 :
730 4552 : if ( control_stack_size_test( 1) )
731 : {
732 4541 : retval = TRUE;
733 :
734 4541 : if ( control_stack->cs_tag != cstag )
735 : {
736 51 : control_structure_mismatch();
737 :
738 51 : if ( ( INVERSE(noerrors) )
739 : || ( cstag == CASE_CSTAG )
740 : || ( control_stack->cs_tag == CASE_CSTAG )
741 : )
742 : {
743 49 : retval = FALSE;
744 : }
745 : }
746 :
747 : }
748 4552 : return ( retval );
749 : }
750 :
751 : /* **************************************************************************
752 : *
753 : * Function name: control_structure_swap
754 : * Synopsis: Swap control-structure branch-marker Groups
755 : *
756 : * Inputs:
757 : * Parameters: NONE
758 : * Local Static Variables:
759 : * control_stack Pointer to "Control Stack" linked-list
760 : * Control-Stack Items:
761 : * Top: CSTAG-Group_0
762 : * Next: CSTAG-Group_1
763 : *
764 : * Outputs:
765 : * Returned Value: NONE
766 : * Local Static Variables:
767 : * control_stack Points to former "previous" and vice-versa
768 : * Items on Control-Stack:
769 : * Top: CSTAG-Group_1
770 : * Next: CSTAG-Group_0
771 : *
772 : * Error Detection:
773 : * If control-stack depth is not at least 2, CS underflow ERROR.
774 : * This might trigger other routines' error detections also...
775 : *
776 : * Extraneous Remarks:
777 : * Before control-structure identification was implemented, offsets
778 : * were kept on the data-stack, and this was a single SWAP.
779 : * When CSTAGs were added, the "Group" was only a pair kept on the
780 : * data-stack -- the CSTAG and the Data-item -- and this
781 : * became a TWO_SWAP()
782 : * For a while, when I tried keeping the CSTAG-Group on the stack,
783 : * this became a FOUR_SWAP()
784 : * That turned out to be unacceptably brittle; this way is much
785 : * more robust.
786 : * I am so glad I called this functionality out into a separate
787 : * routine, early on in the development process.
788 : *
789 : * This is the function called 1 CSROLL in section A.3.2.3.2
790 : * of the ANSI Forth spec, which likewise corresponds to the
791 : * modifier that Wil Baden, in his characteristically elegant
792 : * nomenclature, dubbed: BUT
793 : *
794 : **************************************************************************** */
795 :
796 : static void control_structure_swap( void )
797 4110 : {
798 4110 : if ( control_stack_size_test( 2) )
799 : {
800 : cstag_group_t *cs_temp;
801 :
802 4105 : cs_temp = control_stack->prev;
803 :
804 4105 : control_stack->prev = cs_temp->prev;
805 4105 : cs_temp->prev = control_stack;
806 4105 : control_stack = cs_temp;
807 : }
808 4110 : }
809 :
810 : /* **************************************************************************
811 : *
812 : * Function name: matchup_two_control_structures
813 : * Synopsis: For functions that resolve two CSTAG-Groups, both
814 : * matchup both "Top of Control Stack" entries
815 : * before processing them...
816 : *
817 : * Inputs:
818 : * Parameters:
819 : * top_cstag Control-struc ID Tag expected on "Top" CS entry
820 : * next_cstag Control-struc ID Tag expected on "Next" CS entry
821 : * Local Static Variables:
822 : * not_cs_underflow Used for underflow detection.
823 : * Control-Stack Items:
824 : * Top: Current CSTAG-Group
825 : * Next: Next CSTAG-Group
826 : *
827 : * Outputs:
828 : * Returned Value: TRUE = Successful matches, no error.
829 : * Global Variables:
830 : * noerrors "Ignore Errors" flag; cleared, then restored
831 : * Local Static Variables:
832 : * not_consuming_two Cleared, then restored
833 : * Control-Stack, # of Items Popped: 2 (if matches unsuccessful)
834 : *
835 : * Error Detection:
836 : * Control Stack underflow detected by control_structure_swap()
837 : * Control Structure mismatch detected by control_structure_mismatch()
838 : *
839 : * Process Explanation:
840 : * We will use matchup_control_structure() to do the "heavy lifting".
841 : * We will not be ignoring errors in these cases.
842 : * Save the results of a match of top_cstag
843 : * Swap the top two CS entries.
844 : * If an underflow was detected, there's no more matching to be done.
845 : * Otherwise:
846 : * Save the results of a match of next_cstag
847 : * Swap the top two CS entries again, to their original order.
848 : * The result is TRUE if both matches were successful.
849 : * If the matches were not successful, consume the top two entries
850 : * (unless there's only one, in which case consume it).
851 : *
852 : **************************************************************************** */
853 :
854 : static bool matchup_two_control_structures( unsigned long top_cstag,
855 : unsigned long next_cstag)
856 108 : {
857 : bool retval;
858 : bool topmatch;
859 108 : bool nextmatch = FALSE;
860 108 : bool sav_noerrors = noerrors;
861 108 : noerrors = FALSE;
862 108 : not_consuming_two = FALSE;
863 :
864 108 : not_cs_underflow = TRUE;
865 108 : topmatch = matchup_control_structure( top_cstag);
866 108 : if ( not_cs_underflow )
867 : {
868 106 : control_structure_swap();
869 106 : if ( not_cs_underflow )
870 : {
871 105 : nextmatch = matchup_control_structure( next_cstag);
872 105 : control_structure_swap();
873 : }
874 : }
875 :
876 108 : retval = BOOLVAL( topmatch && nextmatch);
877 :
878 108 : if ( INVERSE( retval) )
879 : {
880 13 : pop_cstag();
881 13 : pop_cstag();
882 : }
883 :
884 108 : not_consuming_two = TRUE;
885 108 : noerrors = sav_noerrors;
886 108 : return ( retval );
887 : }
888 :
889 : /* **************************************************************************
890 : *
891 : * Function name: mark_backward_target
892 : * Synopsis: Mark the target of an expected backward-branch
893 : *
894 : * Associated FORTH words: BEGIN DO ?DO
895 : *
896 : * Inputs:
897 : * Parameters:
898 : * cstag Control-structure ID tag for calling function
899 : * Global Variables:
900 : * opc Output Buffer Position Counter
901 : *
902 : * Outputs:
903 : * Returned Value: NONE
904 : * Items Pushed onto Control-Stack:
905 : * Top: <Stmt>_BACKw_<TAGNAM>
906 : *
907 : * Process Explanation:
908 : * Just before this function is called, the token that begins the
909 : * control-structure was written to the FCode Output buffer.
910 : * OPC, the FCode Output Buffer Position Counter, is at the
911 : * destination to which the backward-branch will be targeted.
912 : * Create a CSTAG-Group with the given C-S Tag, and OPC as its datum;
913 : * push it onto the Control-Stack.
914 : * Later, when the backward-branch is installed, the FCode-offset
915 : * will be calculated as the difference between the OPC at
916 : * that time and the target-OPC we saved here.
917 : *
918 : **************************************************************************** */
919 :
920 : static void mark_backward_target(unsigned long cstag )
921 3047 : {
922 3047 : push_cstag( cstag, (unsigned long)opc);
923 3047 : }
924 :
925 : /* **************************************************************************
926 : *
927 : * Function name: mark_forward_branch
928 : * Synopsis: Mark the location of, and reserve space for, the
929 : * FCode-offset associated with a forward branch.
930 : *
931 : * Associated FORTH words: IF WHILE ELSE
932 : *
933 : * Inputs:
934 : * Parameters:
935 : * cstag Control-structure ID tag for calling function
936 : *
937 : * Outputs:
938 : * Returned Value: NONE
939 : * Items Pushed onto Control-Stack:
940 : * Top: <Stmt>_FORw_<TAGNAM>
941 : * FCode Output buffer:
942 : * Place-holder FCode-offset of zero.
943 : *
944 : * Process Explanation:
945 : * Just before this function is called, the forward-branch token
946 : * that begins the control-structure was written to the FCode
947 : * Output buffer.
948 : * It will need an FCode-offset to the destination to which it will
949 : * be targeted, once that destination is known.
950 : * Create a CSTAG-Group with the given C-S Tag, and OPC as its datum;
951 : * push it onto the Control-Stack. (This is the same action as
952 : * for marking a backward-target.)
953 : * Then write a place-holder FCode-offset of zero to the FCode
954 : * Output buffer.
955 : * Later, when the destination is known, the FCode-offset will be
956 : * calculated as the difference between the OPC at that time
957 : * and the FCode-offset location we're saving now. That offset
958 : * will be over-written onto the place-holder offset of zero at
959 : * the location in the Output buffer that we saved on the
960 : * Control-Stack in this routine.
961 : *
962 : **************************************************************************** */
963 :
964 : static void mark_forward_branch(unsigned long cstag )
965 2903 : {
966 2903 : mark_backward_target(cstag );
967 2903 : emit_offset(0);
968 2903 : }
969 :
970 : /* **************************************************************************
971 : *
972 : * Function name: resolve_backward
973 : * Synopsis: Resolve backward-target when a backward branch
974 : * is reached. Write FCode-offset to reach saved
975 : * target from current location.
976 : *
977 : * Associated FORTH words: AGAIN UNTIL REPEAT
978 : * LOOP +LOOP
979 : *
980 : * Inputs:
981 : * Parameters:
982 : * cstag Control-structure ID tag for calling function
983 : * Global Variables:
984 : * opc Output Buffer Position Counter
985 : * Control-Stack Items:
986 : * Top: <Stmt>_BACKw_<TAGNAM>
987 : *
988 : * Outputs:
989 : * Returned Value: NONE
990 : * Global Variables:
991 : * opc Incremented by size of an FCode-offset
992 : * Control-Stack, # of Items Popped: 1
993 : * FCode Output buffer:
994 : * FCode-offset to reach backward-target
995 : *
996 : * Error Detection:
997 : * Test for Control-structure ID tag match.
998 : *
999 : * Process Explanation:
1000 : * Just before this function is called, the backward-branch token
1001 : * that ends the control-structure was written to the FCode
1002 : * Output buffer.
1003 : * The current OPC is at the point from which the FCode-offset
1004 : * is to be calculated, and at which it is to be written.
1005 : * The top of the Control-Stack should have the CSTAG-Group from
1006 : * the statement that prepared the backward-branch target that
1007 : * we expect to resolve. Its datum is the OPC of the target
1008 : * of the backward branch.
1009 : * If the supplied Control-structure ID tag does not match the one
1010 : * on top of the Control-Stack, announce an error. We will
1011 : * still write an FCode-offset, but it will be a place-holder
1012 : * of zero.
1013 : * Otherwise, the FCode-offset we will write will be the difference
1014 : * between the target-OPC and our current OPC.
1015 : *
1016 : **************************************************************************** */
1017 :
1018 : static void resolve_backward( unsigned long cstag)
1019 127 : {
1020 : unsigned long targ_opc;
1021 127 : int fc_offset = 0;
1022 :
1023 127 : if ( matchup_control_structure( cstag) )
1024 : {
1025 125 : targ_opc = control_stack->cs_datum;
1026 125 : fc_offset = targ_opc - opc;
1027 : }
1028 :
1029 127 : emit_fc_offset( fc_offset );
1030 127 : pop_cstag();
1031 127 : }
1032 :
1033 : /* **************************************************************************
1034 : *
1035 : * Function name: resolve_forward
1036 : * Synopsis: Resolve a forward-branch when its target has been
1037 : * reached. Write the FCode-offset into the space
1038 : * that was reserved.
1039 : *
1040 : * Associated FORTH words: ELSE THEN REPEAT
1041 : * LOOP +LOOP
1042 : *
1043 : * Inputs:
1044 : * Parameters:
1045 : * cstag Control-structure ID tag for calling function
1046 : * Global Variables:
1047 : * opc Output Buffer Position Counter
1048 : * Control-Stack Items:
1049 : * Top: <Stmt>_FORw_<TAGNAM>
1050 : *
1051 : * Outputs:
1052 : * Returned Value: NONE
1053 : * Global Variables:
1054 : * opc Changed, then restored.
1055 : * Control-Stack, # of Items Popped: 1
1056 : * FCode Output buffer:
1057 : * FCode-offset is written to location where space was reserved
1058 : * when the forward-branch was marked.
1059 : *
1060 : * Error Detection:
1061 : * Test for Control-structure ID tag match.
1062 : *
1063 : * Process Explanation:
1064 : * Just before this function is called, the last token -- and
1065 : * possibly, FCode-offset -- that is within the scope of
1066 : * what the branch might skip was written to the FCode
1067 : * Output buffer.
1068 : * The current OPC is at the point from which the FCode-offset
1069 : * is to be calculated, but not at which it is to be written.
1070 : * The top of the Control-Stack should have the CSTAG-Group from
1071 : * the statement that prepared the forward-branch we expect
1072 : * to resolve, and for which our current OPC is the target.
1073 : * Its datum is the OPC of the space that was reserved for
1074 : * the forward-branch whose target we have just reached.
1075 : * If the supplied Control-structure ID tag does not match the one
1076 : * on top of the Control-Stack, announce an error and we're done.
1077 : * Otherwise, the datum is used both as part of the calculation of
1078 : * the FCode-offset we are about to write, and as the location
1079 : * to which we will write it.
1080 : * The FCode-offset is calculated as the difference between our
1081 : * current OPC and the reserved OPC location.
1082 : * We will not be ignoring errors in these cases, because we would
1083 : * be over-writing something that might not be a place-holder
1084 : * for a forward-branch at an earlier location in the FCode
1085 : * Output buffer.
1086 : *
1087 : **************************************************************************** */
1088 :
1089 : static void resolve_forward( unsigned long cstag)
1090 2889 : {
1091 : unsigned long resvd_opc;
1092 2889 : bool sav_noerrors = noerrors;
1093 : bool cs_match_result;
1094 2889 : noerrors = FALSE;
1095 : /* Restore the "ignore-errors" flag before we act on our match result
1096 : * because we want it to remain in effect for emit_fc_offset()
1097 : */
1098 2889 : cs_match_result = matchup_control_structure( cstag);
1099 2889 : noerrors = sav_noerrors;
1100 :
1101 2889 : if ( cs_match_result )
1102 : {
1103 : int saved_opc;
1104 : int fc_offset;
1105 :
1106 2863 : resvd_opc = control_stack->cs_datum;
1107 2863 : fc_offset = opc - resvd_opc;
1108 :
1109 2863 : saved_opc = opc;
1110 2863 : opc = resvd_opc;
1111 :
1112 :
1113 2863 : emit_fc_offset( fc_offset );
1114 2863 : opc = saved_opc;
1115 : }
1116 2889 : pop_cstag();
1117 2889 : }
1118 :
1119 :
1120 : /* **************************************************************************
1121 : *
1122 : * The functions that follow are the exported routines that
1123 : * utilize the preceding support-routines to effect their
1124 : * associated FORTH words.
1125 : *
1126 : * The routines they call will take care of most of the Error
1127 : * Detection via stack-depth checking and Control-structure
1128 : * ID tag matching, so those will not be called-out in the
1129 : * prologues.
1130 : *
1131 : **************************************************************************** */
1132 :
1133 :
1134 : /* **************************************************************************
1135 : *
1136 : * Function name: emit_if
1137 : * Synopsis: All the actions when IF is encountered
1138 : *
1139 : * Associated FORTH word: IF
1140 : *
1141 : * Inputs:
1142 : * Parameters: NONE
1143 : *
1144 : * Outputs:
1145 : * Returned Value: NONE
1146 : * Items Pushed onto Control-Stack:
1147 : * Top: If_FORw_IF
1148 : * FCode Output buffer:
1149 : * Token for conditional branch -- b?branch -- followed by
1150 : * place-holder of zero for FCode-offset
1151 : *
1152 : *
1153 : **************************************************************************** */
1154 :
1155 : void emit_if( void )
1156 196 : {
1157 196 : emit_token("b?branch");
1158 196 : mark_forward_branch( IF_CSTAG );
1159 196 : }
1160 :
1161 : /* **************************************************************************
1162 : *
1163 : * Function name: emit_then
1164 : * Synopsis: All the actions when THEN is encountered; also
1165 : * part of another forward-branch resolver's action.
1166 : *
1167 : * Associated FORTH words: THEN ELSE
1168 : *
1169 : * Inputs:
1170 : * Parameters: NONE
1171 : * Local Static Variables:
1172 : * control_stack Points to "Top" Control-Structure Tag Group
1173 : * Control-Stack Items:
1174 : * Top: If_FORw_IF | While_FORw_WHILE
1175 : *
1176 : * Outputs:
1177 : * Returned Value: NONE
1178 : * Control-Stack, # of Items Popped: 1
1179 : * FCode Output buffer:
1180 : * Token for forward-resolve -- b(>resolve) -- then the space
1181 : * reserved for the forward-branch FCode-offset is filled
1182 : * in so that it reaches the token after the b(>resolve) .
1183 : *
1184 : * Process Explanation:
1185 : * The THEN statement or the ELSE statement must be able to resolve
1186 : * a WHILE statement, in order to implement the extended flow-
1187 : * -control structures as described in sec. A.3.2.3.2 of the
1188 : * ANSI Forth Spec.
1189 : * But we must prevent the sequence IF ... BEGIN ... REPEAT from
1190 : * compiling as though it were: IF ... BEGIN ... AGAIN THEN
1191 : * We do this by having a separate CSTAG for WHILE and allowing
1192 : * it here but not allowing the IF_CSTAG when processing REPEAT.
1193 : *
1194 : **************************************************************************** */
1195 :
1196 : void emit_then( void )
1197 222 : {
1198 222 : emit_token("b(>resolve)");
1199 222 : if ( control_stack != NULL )
1200 : {
1201 217 : if ( control_stack->cs_tag == WHILE_CSTAG )
1202 : {
1203 3 : control_stack->cs_tag = IF_CSTAG;
1204 : }
1205 : }
1206 222 : resolve_forward( IF_CSTAG );
1207 222 : }
1208 :
1209 :
1210 : /* **************************************************************************
1211 : *
1212 : * Function name: emit_else
1213 : * Synopsis: All the actions when ELSE is encountered
1214 : *
1215 : * Associated FORTH word: ELSE
1216 : *
1217 : * Inputs:
1218 : * Parameters: NONE
1219 : * Global Variables:
1220 : * control_stack_depth Current depth of Control Stack
1221 : * Local Static Variables:
1222 : * not_cs_underflow If this is FALSE after the c-s swap, it
1223 : * means an underflow resulted; skip
1224 : * the call to resolve the first marker.
1225 : * Control-Stack Items:
1226 : * Top: {If_FORw_IF}1
1227 : * (Datum is OPC of earlier forward-branch; must be resolved.)
1228 : *
1229 : * Outputs:
1230 : * Returned Value: NONE
1231 : * Control-Stack, # of Items Popped: 1
1232 : * Items Pushed onto Control-Stack:
1233 : * Top: {If_FORw_IF}2
1234 : * (Datum is current OPC, after forward-branch is placed.)
1235 : * FCode Output buffer:
1236 : * Token for unconditional branch -- bbranch-- followed by
1237 : * place-holder of zero for FCode-offset. Then, token
1238 : * for forward-resolve -- b(>resolve) -- and the space
1239 : * reserved earlier for the conditional forward-branch
1240 : * FCode-offset is filled in to reach the token after
1241 : * the b(>resolve) .
1242 : *
1243 : * Error Detection:
1244 : * If the "Control-Stack" is empty, bypass the forward branch
1245 : * and let the call to control_structure_swap() report
1246 : * the underflow error. Then use not_cs_underflow to
1247 : * control whether to resolve the forward-branch.
1248 : *
1249 : * Process Explanation:
1250 : * The final item needed within the scope of what the earlier
1251 : * conditional branch might skip is an unconditional branch
1252 : * over the "else"-clause to follow. After that, the earlier
1253 : * conditional branch needs to be resolved. This last step
1254 : * is identical to the action of THEN .
1255 : *
1256 : **************************************************************************** */
1257 :
1258 : void emit_else( void )
1259 24 : {
1260 24 : if ( control_stack_depth > 0 )
1261 : {
1262 21 : emit_token("bbranch");
1263 21 : mark_forward_branch( IF_CSTAG );
1264 : }
1265 24 : not_cs_underflow = TRUE;
1266 24 : control_structure_swap();
1267 24 : if ( not_cs_underflow )
1268 : {
1269 21 : emit_then();
1270 : }
1271 24 : }
1272 :
1273 :
1274 : /* **************************************************************************
1275 : *
1276 : * Function name: emit_begin
1277 : * Synopsis: All the actions when BEGIN is encountered
1278 : *
1279 : * Associated FORTH word: BEGIN
1280 : *
1281 : * Inputs:
1282 : * Parameters: NONE
1283 : *
1284 : * Outputs:
1285 : * Returned Value: NONE
1286 : * Items Pushed onto Control-Stack:
1287 : * Top: Begin_BACKw_BEGIN
1288 : * (Datum is current OPC, target of future backward-branch)
1289 : * FCode Output buffer:
1290 : * Token for target of backward branch -- b(<mark)
1291 : *
1292 : **************************************************************************** */
1293 :
1294 : void emit_begin( void )
1295 47 : {
1296 47 : emit_token("b(<mark)");
1297 47 : mark_backward_target( BEGIN_CSTAG );
1298 47 : }
1299 :
1300 :
1301 : /* **************************************************************************
1302 : *
1303 : * Function name: emit_again
1304 : * Synopsis: All the actions when AGAIN is encountered
1305 : *
1306 : * Associated FORTH words: AGAIN REPEAT
1307 : *
1308 : * Inputs:
1309 : * Parameters: NONE
1310 : * Control-Stack Items:
1311 : * Top: Begin_BACKw_BEGIN
1312 : * (Datum is OPC of backward-branch target at BEGIN)
1313 : *
1314 : * Outputs:
1315 : * Returned Value: NONE
1316 : * Control-Stack, # of Items Popped: 1
1317 : * FCode Output buffer:
1318 : * Token for unconditional branch -- bbranch -- followed by
1319 : * FCode-offset that reaches just after the b(<mark)
1320 : * token at the corresponding BEGIN statement.
1321 : *
1322 : * Process Explanation:
1323 : * The FCode-offset is calculated as the difference between our
1324 : * current OPC and the target-OPC saved on the Control-Stack.
1325 : *
1326 : **************************************************************************** */
1327 :
1328 : void emit_again( void )
1329 33 : {
1330 33 : emit_token("bbranch");
1331 33 : resolve_backward( BEGIN_CSTAG );
1332 33 : }
1333 :
1334 : /* **************************************************************************
1335 : *
1336 : * Function name: emit_until
1337 : * Synopsis: All the actions when UNTIL is encountered
1338 : *
1339 : * Associated FORTH word: UNTIL
1340 : *
1341 : * Process Explanation:
1342 : * Same as AGAIN except token is conditional branch -- b?branch --
1343 : * instead of unconditional.
1344 : *
1345 : **************************************************************************** */
1346 :
1347 : void emit_until( void )
1348 4 : {
1349 4 : emit_token("b?branch");
1350 4 : resolve_backward( BEGIN_CSTAG );
1351 4 : }
1352 :
1353 : /* **************************************************************************
1354 : *
1355 : * Function name: emit_while
1356 : * Synopsis: All the actions when WHILE is encountered
1357 : *
1358 : * Associated FORTH word: WHILE
1359 : *
1360 : * Inputs:
1361 : * Parameters: NONE
1362 : * Global Variables:
1363 : * control_stack_depth Number of items on "Control-Stack"
1364 : * Control-Stack Items:
1365 : * Top: Begin_BACKw_BEGIN
1366 : * (Datum is OPC of backward-branch target)
1367 : *
1368 : * Outputs:
1369 : * Returned Value: NONE
1370 : * Control-Stack: 1 item added below top item.
1371 : * Items on Control-Stack:
1372 : * Top: Begin_BACKw_BEGIN
1373 : * Next: While_FORw_WHILE
1374 : * FCode Output buffer:
1375 : * Token for conditional branch -- b?branch -- followed by
1376 : * place-holder of zero for FCode-offset
1377 : *
1378 : * Error Detection:
1379 : * If the "Control-Stack" is empty, bypass creating the branch
1380 : * and let the call to control_structure_swap() report
1381 : * the underflow error.
1382 : *
1383 : * Process Explanation:
1384 : * Output a conditional forward-branch sequence, similar to IF
1385 : * (except with a WHILE CSTAG), but be sure to leave the
1386 : * control-structure branch-marker that was created by the
1387 : * preceding BEGIN on top of the one just generated:
1388 : * the BEGIN needs to be resolved first in any case, and
1389 : * doing this here is the key to implementing the extended
1390 : * control-flow structures as described in sec. A.3.2.3.2
1391 : * of the ANSI Forth Spec.
1392 : *
1393 : * Extraneous Remarks:
1394 : * It was for the use of this function that Wil Baden coined the
1395 : * name BUT for the control-structure swap routine. The idea
1396 : * was that the implementation of WHILE could be boiled down
1397 : * to: IF BUT (couldn't quite fit an AND in there...;-} )
1398 : * Naturally, this implementation is a smidgeon more complicated...
1399 : *
1400 : **************************************************************************** */
1401 :
1402 : void emit_while( void )
1403 11 : {
1404 11 : if ( control_stack_depth > 0 )
1405 : {
1406 10 : emit_token("b?branch");
1407 10 : mark_forward_branch( WHILE_CSTAG );
1408 : }
1409 11 : control_structure_swap();
1410 11 : }
1411 :
1412 : /* **************************************************************************
1413 : *
1414 : * Function name: emit_repeat
1415 : * Synopsis: All the actions when REPEAT is encountered
1416 : *
1417 : * Associated FORTH word: REPEAT
1418 : *
1419 : * Inputs:
1420 : * Parameters: NONE
1421 : * Local Static Variables:
1422 : * not_cs_underflow If FALSE after first call to resolve marker,
1423 : * an underflow resulted; skip second call.
1424 : * Control-Stack Items:
1425 : * Top: Begin_BACKw_BEGIN
1426 : * (Datum is OPC of backward-branch target at BEGIN)
1427 : * Next: If_FORw_IF
1428 : * (Datum is OPC of FCode-offset place-holder)
1429 : *
1430 : * Outputs:
1431 : * Returned Value: NONE
1432 : * Local Static Variables:
1433 : * not_consuming_two Cleared, then restored
1434 : * Control-Stack, # of Items Popped: 2
1435 : * FCode Output buffer:
1436 : * Token for unconditional branch -- bbranch -- followed by
1437 : * FCode-offset that reaches just after the b(<mark)
1438 : * token at the corresponding BEGIN statement. Then
1439 : * the token for forward-resolve -- b(>resolve) -- and
1440 : * the space reserved for the conditional forward-branch
1441 : * FCode-offset is filled in so that it reaches the token
1442 : * after the b(>resolve) .
1443 : *
1444 : * Process Explanation:
1445 : * The action is identical to that taken for AGAIN followed
1446 : * by the action for THEN.
1447 : * The Local Static Variable not_consuming_two gets cleared
1448 : * and restored by this routine.
1449 : *
1450 : **************************************************************************** */
1451 :
1452 : void emit_repeat( void )
1453 11 : {
1454 11 : if ( matchup_two_control_structures( BEGIN_CSTAG, WHILE_CSTAG ) )
1455 : {
1456 5 : not_cs_underflow = TRUE;
1457 5 : not_consuming_two = FALSE;
1458 5 : emit_again();
1459 5 : if ( not_cs_underflow )
1460 : {
1461 5 : emit_token("b(>resolve)");
1462 5 : resolve_forward( WHILE_CSTAG );
1463 : }
1464 5 : not_consuming_two = TRUE;
1465 : }
1466 11 : }
1467 :
1468 : /* **************************************************************************
1469 : *
1470 : * Function name: mark_do
1471 : * Synopsis: Common routine for marking the branches for
1472 : * the "do" variants
1473 : *
1474 : * Associated FORTH words: DO ?DO
1475 : *
1476 : * Inputs:
1477 : * Parameters: NONE
1478 : *
1479 : * Outputs:
1480 : * Returned Value: NONE
1481 : * Global Variables:
1482 : * do_loop_depth Incremented
1483 : * Items Pushed onto Control-Stack:
1484 : * Top: Do_FORw_DO
1485 : * Next: Do_BACKw_DO
1486 : * FCode Output buffer:
1487 : * Place-holder of zero for FCode-offset
1488 : *
1489 : * Error Detection:
1490 : * The do_loop_depth counter will be used by other routines
1491 : * to detect misplaced "LEAVE", "UNLOOP", "I" and suchlike.
1492 : * (Imbalanced "LOOP" statements are detected by the CSTag
1493 : * matching mechanism.)
1494 : *
1495 : * Process Explanation:
1496 : * Just before this function is called, the forward-branching token
1497 : * for the "DO" variant that begins the control-structure was
1498 : * written to the FCode Output buffer.
1499 : * It needs an FCode-offset for a forward-branch to just after
1500 : * its corresponding "LOOP" variant and the FCode-offset
1501 : * associated therewith.
1502 : * That "LOOP" variant's associated FCode-offset is targeted
1503 : * to the token that follows the one for this "DO" variant
1504 : * and its FCode-offset.
1505 : * Mark the forward-branch with the C-S Tag for DO and write a
1506 : * place-holder FCode-offset of zero to FCode Output.
1507 : * Indicate that the mark that will be processed second (but which
1508 : * was made first) is a duplicate of the one that will be
1509 : * processed first.
1510 : * Then mark the backward-branch target, also with the DO C-S Tag.
1511 : * Finally, increment the do_loop_depth counter.
1512 : *
1513 : * Extraneous Remarks:
1514 : * This is more complicated to describe than to code... ;-)
1515 : *
1516 : **************************************************************************** */
1517 :
1518 : void mark_do( void )
1519 97 : {
1520 97 : mark_forward_branch( DO_CSTAG);
1521 97 : control_stack->cs_not_dup = FALSE;
1522 97 : mark_backward_target( DO_CSTAG);
1523 97 : do_loop_depth++;
1524 97 : }
1525 :
1526 :
1527 : /* **************************************************************************
1528 : *
1529 : * Function name: resolve_loop
1530 : * Synopsis: Common routine for resolving the branches for
1531 : * the "loop" variants.
1532 : *
1533 : * Associated FORTH words: LOOP +LOOP
1534 : *
1535 : * Inputs:
1536 : * Parameters: NONE
1537 : * Global Variables:
1538 : * statbuf Word read from input stream (either "loop"
1539 : * or "+loop"), used for Error Message.
1540 : * Local Static Variables:
1541 : * not_cs_underflow If FALSE after first call to resolve marker,
1542 : * an underflow resulted; skip second call.
1543 : * Control-Stack Items:
1544 : * Top: Do_FORw_DO
1545 : * Next: Do_BACKw_DO
1546 : *
1547 : * Outputs:
1548 : * Returned Value: NONE
1549 : * Global Variables:
1550 : * do_loop_depth Decremented
1551 : * Local Static Variables:
1552 : * not_consuming_two Cleared, then restored
1553 : * didnt_print_otl Set, then set again at end.
1554 : * Control-Stack, # of Items Popped: 2
1555 : * FCode Output buffer:
1556 : * FCode-offset that reaches just after the token of the
1557 : * corresponding "DO" variant. Then the space reserved
1558 : * for the FCode-offset of the forward-branch associated
1559 : * with the "DO" variant is filled in so that it reaches
1560 : * the token just after the "DO" variant's FCode-offset.
1561 : *
1562 : * Error Detection:
1563 : * A value of zero in do_loop_depth before it's decremented
1564 : * indicates a DO ... LOOP imbalance, which is an ERROR,
1565 : * but our other error-reporting mechanisms will catch it,
1566 : * so we don't check or report it here.
1567 : *
1568 : * Process Explanation:
1569 : * Just before this function is called, the backward-branching
1570 : * token for the "LOOP" variant that ends the control-structure
1571 : * was written to the FCode Output buffer.
1572 : * It needs an FCode-offset for a backward-branch targeted just
1573 : * after its corresponding "DO" variant and the FCode-offset
1574 : * associated therewith.
1575 : * That "DO" variant's associated FCode-offset is targeted to
1576 : * the token that follows the one for this "LOOP" variant
1577 : * and its FCode-offset.
1578 : * Make sure there are two DO C-S Tag entries on the Control Stack.
1579 : * Resolve the backward-branch, matching your target to the first
1580 : * C-S Tag for DO
1581 : * Then resolve the forward-branch, targeting to your new OPC
1582 : * position, and also making sure you match the DO C-S Tag.
1583 : * We keep track of do_loop_depth for other error-detection
1584 : * by decrementing it; make sure it doesn't go below zero.
1585 : * Don't bother resolving the forward-branch if we underflowed
1586 : * the "Control Stack" trying to resolve the backward-branch.
1587 : * If the two top C-S Tag entries are not for a DO statement, the
1588 : * matchup_two_control_structures() routine will consume both
1589 : * or up to two of them, and we will place a dummy offset of
1590 : * zero to follow-up the backward-branching token that has
1591 : * already been written.
1592 : *
1593 : * Extraneous Remarks:
1594 : * This is only a little more complicated to describe
1595 : * than to code... ;-)
1596 : *
1597 : **************************************************************************** */
1598 :
1599 : void resolve_loop( void )
1600 97 : {
1601 97 : if ( INVERSE( matchup_two_control_structures( DO_CSTAG, DO_CSTAG) ) )
1602 : {
1603 7 : emit_offset( 0 );
1604 : }else{
1605 90 : not_cs_underflow = TRUE;
1606 90 : didnt_print_otl = TRUE;
1607 90 : not_consuming_two = FALSE;
1608 90 : resolve_backward( DO_CSTAG);
1609 90 : if ( not_cs_underflow )
1610 : {
1611 90 : resolve_forward( DO_CSTAG);
1612 : }
1613 90 : if ( do_loop_depth > 0 ) do_loop_depth--;
1614 90 : not_consuming_two = TRUE;
1615 90 : didnt_print_otl = TRUE; /* Might have gotten cleared */
1616 : }
1617 97 : }
1618 :
1619 : /* **************************************************************************
1620 : *
1621 : * Function name: emit_case
1622 : * Synopsis: All the actions when CASE is encountered
1623 : *
1624 : * Associated FORTH word: CASE
1625 : *
1626 : * Inputs:
1627 : * Parameters: NONE
1628 : *
1629 : * Outputs:
1630 : * Returned Value: NONE
1631 : * Items Pushed onto Control-Stack:
1632 : * Top: N_OFs=0...CASE_CSTAG
1633 : * (Datum is 0 , Initial count of OF .. ENDOF pairs)
1634 : * FCode Output buffer:
1635 : * Token for start of a CASE structure -- b(case)
1636 : * Does not require an FCode-offset.
1637 : *
1638 : **************************************************************************** */
1639 :
1640 : void emit_case( void )
1641 30 : {
1642 30 : push_cstag( CASE_CSTAG, 0);
1643 30 : emit_token("b(case)");
1644 30 : }
1645 :
1646 :
1647 : /* **************************************************************************
1648 : *
1649 : * Function name: emit_of
1650 : * Synopsis: All the actions when OF is encountered
1651 : *
1652 : * Associated FORTH word: OF
1653 : *
1654 : * Inputs:
1655 : * Parameters: NONE
1656 : * Control-Stack Items:
1657 : * Top: N_OFs...CASE_CSTAG
1658 : * (Datum is OF-count, number of OF .. ENDOF pairs)
1659 : * {Next and beyond}: {Endof_FORw_ENDOF}1..n_ofs
1660 : * { Repeat for OF-count number of times }
1661 : *
1662 : * Outputs:
1663 : * Returned Value: NONE
1664 : * Control-Stack, 1 Item Pushed, 1 modified:
1665 : * Top: Of_FORw_OF
1666 : * Next: N_OFs+1...CASE_CSTAG
1667 : * (Datum has been incremented)
1668 : * {3rd and beyond}: {Endof_FORw_ENDOF}1..n_ofs
1669 : * { Repeat for 1 through the un-incremented OF-count }
1670 : * (Same as Next etcetera at input-time.)
1671 : * FCode Output buffer:
1672 : * Token for OF statement -- b(of) -- followed by
1673 : * place-holder FCode-offset of zero
1674 : *
1675 : * Error Detection:
1676 : * Matchup CASE-cstag before incrementing OF-count
1677 : *
1678 : * Process Explanation:
1679 : * Main difference between this implementation and that outlined
1680 : * in "the book" (see below) is that we do not directly use
1681 : * the routine for the IF statement's flow-control; we will
1682 : * use a different CSTAG for better mismatch detection.
1683 : *
1684 : * Extraneous Remarks:
1685 : * This is a "by the book" (ANSI Forth spec, section A.3.2.3.2)
1686 : * implementation (mostly). Incrementing the OF-count here,
1687 : * after we've matched up the CSTAG, gives us (and the user)
1688 : * just a little bit more protection...
1689 : *
1690 : **************************************************************************** */
1691 :
1692 : void emit_of( void )
1693 1294 : {
1694 :
1695 1294 : if ( matchup_control_structure( CASE_CSTAG ) )
1696 : {
1697 1287 : emit_token("b(of)");
1698 :
1699 : /*
1700 : * See comment-block about "Control-Stack" Diagram Notation
1701 : * early on in this file.
1702 : *
1703 : */
1704 :
1705 : /* ( {Endof_FORw_ENDOF}1..n_ofs N_OFs...CASE_CSTAG -- ) */
1706 :
1707 : /* Increment the OF-count . */
1708 1287 : (control_stack->cs_datum)++;
1709 :
1710 : /* ( {Endof_FORw_ENDOF}1..n_ofs N_OFs+1...CASE_CSTAG -- ) */
1711 :
1712 1287 : mark_forward_branch( OF_CSTAG );
1713 : /* ( -- {Endof_FORw_ENDOF}1..n_ofs N_OFs+1...CASE_CSTAG Of_FORw_OF )
1714 : */
1715 : }
1716 : /* Leave the CSTAG-Group on the "Control-Stack" . */
1717 1294 : }
1718 :
1719 :
1720 : /* **************************************************************************
1721 : *
1722 : * Function name: emit_endof
1723 : * Synopsis: All the actions when ENDOF is encountered
1724 : *
1725 : * Associated FORTH word: ENDOF
1726 : *
1727 : * Inputs:
1728 : * Parameters: NONE
1729 : * Control-Stack Items:
1730 : * Top: Of_FORw_OF
1731 : * Next: N_OFs+1...CASE_CSTAG
1732 : * (Datum has been incremented)
1733 : * {3rd and beyond}: {Endof_FORw_ENDOF}1..n_ofs
1734 : * { Repeat for 1 through the un-incremented OF-count )
1735 : *
1736 : * Outputs:
1737 : * Returned Value: NONE
1738 : * Control-Stack, 1 Item Popped, 1 new Item Pushed.
1739 : * Top: N_OFs...CASE_CSTAG
1740 : * (The count itself is unchanged from input-time, but
1741 : * the number of {Endof_FORw_ENDOF} CSTAG-Groups
1742 : * has caught up with this number, so it is
1743 : * no longer notated as " + 1 ").
1744 : * {Next and beyond}: {Endof_FORw_ENDOF}1..n_ofs
1745 : * { Repeat for 1 through the updated OF-count )
1746 : * FCode Output buffer:
1747 : * Token for ENDOF statement -- b(endof) -- followed by
1748 : * place-holder FCode-offset of zero. Then the space reserved
1749 : * for the FCode-offset of the forward-branch associated
1750 : * with the "OF" statement is filled in so that it reaches
1751 : * the token just after the "ENDOF" statement's FCode-offset.
1752 : *
1753 : * Error Detection:
1754 : * If control-stack depth is not at least 2, CS underflow ERROR
1755 : * and no further action.
1756 : * Routine that resolves the forward-branch checks for matchup error.
1757 : *
1758 : **************************************************************************** */
1759 :
1760 : void emit_endof( void )
1761 1293 : {
1762 1293 : if ( control_stack_size_test( 2) )
1763 : {
1764 1292 : emit_token("b(endof)");
1765 :
1766 : /* See "Control-Stack" Diagram Notation comment-block */
1767 :
1768 : /* Stack-diagrams might need to be split across lines. */
1769 :
1770 : /* ( {Endof_FORw_ENDOF}1..n_ofs N_OFs+1...CASE_CSTAG ...
1771 : * ... Of_FORw_OF -- )
1772 : */
1773 1292 : mark_forward_branch(ENDOF_CSTAG);
1774 : /* ( -- {Endof_FORw_ENDOF}1..n_ofs N_OFs+1...CASE_CSTAG ...
1775 : * ... Of_FORw_OF {Endof_FORw_ENDOF}n_ofs+1 )
1776 : */
1777 :
1778 1292 : control_structure_swap();
1779 : /* ( -- {Endof_FORw_ENDOF}1..n_ofs N_OFs+1...CASE_CSTAG ...
1780 : * ... {Endof_FORw_ENDOF}n_ofs+1 Of_FORw_OF )
1781 : */
1782 :
1783 1292 : resolve_forward( OF_CSTAG );
1784 : /* ( -- {Endof_FORw_ENDOF}1..n_ofs N_OFs+1...CASE_CSTAG ...
1785 : * ... {Endof_FORw_ENDOF}n_ofs+1 )
1786 : */
1787 :
1788 1292 : control_structure_swap();
1789 : /* ( -- {Endof_FORw_ENDOF}1..n_ofs ...
1790 : * ... {Endof_FORw_ENDOF}n_ofs+1 ...
1791 : * ... N_OFs+1...CASE_CSTAG )
1792 : */
1793 :
1794 : /* The number of ENDOF-tagged Forward-Marker pairs has now
1795 : * caught up with the incremented OF-count; therefore,
1796 : * we can notate the above as:
1797 : *
1798 : * ( {Endof_FORw_ENDOF}1..n_ofs N_OFs CASE_CSTAG )
1799 : *
1800 : * and we are ready for another OF ... ENDOF pair,
1801 : * or for the ENDCASE statement.
1802 : */
1803 : }
1804 :
1805 1293 : }
1806 :
1807 : /* **************************************************************************
1808 : *
1809 : * Function name: emit_endcase
1810 : * Synopsis: All the actions when ENDCASE is encountered
1811 : *
1812 : * Associated FORTH word: ENDCASE
1813 : *
1814 : * Inputs:
1815 : * Parameters: NONE
1816 : * Control-Stack Items:
1817 : * Top: N_OFs...CASE_CSTAG
1818 : * (Datum is OF-count, number of OF .. ENDOF pairs)
1819 : * {Next and beyond}: {Endof_FORw_ENDOF}1..n_ofs
1820 : * { Repeat for OF-count number of times }
1821 : *
1822 : * Outputs:
1823 : * Returned Value: NONE
1824 : * Control-Stack, # of Items Popped: OF-count + 1
1825 : * FCode Output buffer:
1826 : * Token for ENDCASE statement -- b(endcase)
1827 : * Then the spaces reserved for the FCode-offsets of all the
1828 : * forward-branches associated with the OF-count number
1829 : * of ENDOF statements are filled in so that they reach
1830 : * the token just after this "ENDCASE" statement.
1831 : *
1832 : * Error Detection:
1833 : * Routine that resolves the forward-branch checks for matchup error
1834 : * for each forward-branch filled in, plus the matchup routine
1835 : * checks before the OF-count is retrieved.
1836 : *
1837 : * Process Explanation:
1838 : * Retrieve the OF-count and resolve that number of ENDOF statements
1839 : *
1840 : * Extraneous Remarks:
1841 : * The setup makes coding this routine appear fairly simple... ;-}
1842 : *
1843 : **************************************************************************** */
1844 :
1845 : void emit_endcase( void )
1846 29 : {
1847 : unsigned long n_endofs ;
1848 29 : if ( matchup_control_structure( CASE_CSTAG) )
1849 : {
1850 : int indx;
1851 :
1852 25 : emit_token("b(endcase)");
1853 25 : n_endofs = control_stack->cs_datum;
1854 1305 : for ( indx = 0 ; indx < n_endofs ; indx++ )
1855 : {
1856 : /* Because matchup_control_structure doesn't pop the
1857 : * control-stack, we have the N_OFs...CASE_CSTAG
1858 : * item on top of the Endof_FORw_ENDOF item we
1859 : * want to resolve. We need to keep it there so
1860 : * the POP is valid for the other path as well
1861 : * as at the end of this one.
1862 : * So we SWAP to get at the Endof_FORw_ENDOF item.
1863 : */
1864 1280 : control_structure_swap();
1865 1280 : resolve_forward( ENDOF_CSTAG);
1866 : }
1867 : }
1868 29 : pop_cstag();
1869 29 : }
1870 :
1871 :
1872 : /* **************************************************************************
1873 : *
1874 : * Function name: control_struct_incomplete
1875 : * Synopsis: Print a Message of given severity with origin info for
1876 : * a control-structure that has not been completed.
1877 : *
1878 : * Inputs:
1879 : * Parameters:
1880 : * c_s_entry Control-structure about which to display
1881 : * severity Severity of the messages to display.
1882 : * call_cond String identifying Calling Condition;
1883 : * used in the message.
1884 : *
1885 : * Outputs:
1886 : * Returned Value: NONE
1887 : *
1888 : * Printout:
1889 : * Message of given severity...
1890 : *
1891 : * Process Explanation:
1892 : * The calling routine will be responsible for all filtering of
1893 : * duplicate structures and the like. This routine will
1894 : * simply display a message.
1895 : *
1896 : **************************************************************************** */
1897 :
1898 : static void control_struct_incomplete(
1899 : int severity,
1900 : char *call_cond,
1901 : cstag_group_t *c_s_entry)
1902 43 : {
1903 43 : tokenization_error ( severity,
1904 : "%s before completion of %s" ,
1905 : call_cond, strupr(c_s_entry->cs_word));
1906 43 : where_started( c_s_entry->cs_inp_fil, c_s_entry->cs_line_num );
1907 43 : }
1908 :
1909 : /* **************************************************************************
1910 : *
1911 : * Function name: announce_control_structs
1912 : * Synopsis: Print a series of Messages (of severity as specified)
1913 : * announcing that the calling event is occurring
1914 : * in the context of Control-Flow structure(s),
1915 : * back to the given limit. Leave the control
1916 : * structures in effect.
1917 : *
1918 : * Inputs:
1919 : * Parameters:
1920 : * severity Severity of the messages to display.
1921 : * call_cond String identifying Calling Condition;
1922 : * used in the message.
1923 : * abs_token_limit Limit, in terms of abs_token_no
1924 : * Local Static Variables:
1925 : * control_stack Pointer to "Top" of "Control-Stack"
1926 : *
1927 : * Outputs:
1928 : * Returned Value: NONE
1929 : * Printout:
1930 : * A Message for each unresolved Control-Flow structure.
1931 : *
1932 : **************************************************************************** */
1933 :
1934 : void announce_control_structs( int severity, char *call_cond,
1935 : unsigned int abs_token_limit)
1936 251 : {
1937 251 : cstag_group_t *cs_temp = control_stack;
1938 544 : while ( cs_temp != NULL )
1939 : {
1940 43 : if ( cs_temp->cs_abs_token_num < abs_token_limit )
1941 : {
1942 1 : break;
1943 : }
1944 42 : if ( cs_temp->cs_not_dup )
1945 : {
1946 27 : control_struct_incomplete( severity, call_cond, cs_temp );
1947 : }
1948 42 : cs_temp = cs_temp->prev;
1949 : }
1950 251 : }
1951 :
1952 : /* **************************************************************************
1953 : *
1954 : * Function name: clear_control_structs_to_limit
1955 : * Synopsis: Clear items from the "Control-Stack" back to the given
1956 : * limit. Print error-messages with origin info for
1957 : * control-structures that have not been completed.
1958 : *
1959 : * Inputs:
1960 : * Parameters:
1961 : * call_cond String identifying Calling Condition;
1962 : * used in the Error message.
1963 : * abs_token_limit Limit, in terms of abs_token_no
1964 : * Global Variables:
1965 : * control_stack_depth Number of items on "Control-Stack"
1966 : * control_stack Pointer to "Top" of "Control-Stack"
1967 : * Control-Stack Items:
1968 : * The cs_inp_fil and cs_line_num tags of any item cleared
1969 : * from the "Control-Stack" are used in error-messages.
1970 : *
1971 : * Outputs:
1972 : * Returned Value:
1973 : * Global Variables:
1974 : * do_loop_depth Decremented when "DO" item cleared.
1975 : * control_stack_depth Decremented by called routine.
1976 : * Control-Stack, # of Items Popped: As many as go back to given limit
1977 : * Memory Freed
1978 : * By called routine.
1979 : *
1980 : * Error Detection:
1981 : * Any item on the "Control-Stack" represents a Control-Structure
1982 : * that was not completed when the Calling Condition was
1983 : * encountered. Error; identify the origin of the structure.
1984 : * No special actions if noerrors is set.
1985 : *
1986 : * Process Explanation:
1987 : * The given limit corresponds to the value of abs_token_no at
1988 : * the time the colon-definition (or whatever...) was created.
1989 : * Any kind of Control-Structure imbalance at the end of the
1990 : * colon-definition is an error and the entries must be cleared,
1991 : * but the colon-definition may have been created inside nested
1992 : * interpretation-time Control-Structures, and those must be
1993 : * preserved.
1994 : *
1995 : * Of course, if this routine is called with a given limit of zero,
1996 : * that would mean all the entries are to be cleared. That will
1997 : * be the way clear_control_structs() is implemented.
1998 : * We control the loop by the cs_abs_token_num field, but also
1999 : * make sure we haven't underflowed control_stack_depth
2000 : * We skip messages and other processing for items that are duplicates
2001 : * of others, based on the cs_not_dup field.
2002 : * If the cs_tag field is DO_CSTAG we decrement do_loop_depth
2003 : * The pop_cstag() routine takes care of the rest.
2004 : *
2005 : * Extraneous Remarks:
2006 : * This is a retrofit; necessary because we now permit definitions
2007 : * to occur inside interpretation-time Control-Structures. Calls
2008 : * to clear_control_structs() are already scattered around...
2009 : *
2010 : **************************************************************************** */
2011 :
2012 : void clear_control_structs_to_limit( char *call_cond,
2013 : unsigned int abs_token_limit)
2014 884 : {
2015 1786 : while ( control_stack_depth > 0 )
2016 : {
2017 27 : if ( control_stack->cs_abs_token_num < abs_token_limit )
2018 : {
2019 9 : break;
2020 : }
2021 18 : if ( control_stack->cs_not_dup )
2022 : {
2023 16 : control_struct_incomplete( TKERROR, call_cond, control_stack );
2024 16 : if ( control_stack->cs_tag == DO_CSTAG) do_loop_depth--;
2025 : }
2026 18 : pop_cstag();
2027 : }
2028 884 : }
2029 :
2030 : /* **************************************************************************
2031 : *
2032 : * Function name: clear_control_structs
2033 : * Synopsis: Make sure the "Control-Stack" is cleared, and print
2034 : * error-messages (giving origin information) for
2035 : * control-structures that have not been completed.
2036 : *
2037 : * Inputs:
2038 : * Parameters:
2039 : * call_cond String identifying Calling Condition;
2040 : * used in the Error message.
2041 : * Global Variables:
2042 : * control_stack_depth Number of items on "Control-Stack"
2043 : * control_stack Pointer to "Top" of "Control-Stack"
2044 : * Control-Stack Items:
2045 : * The cs_inp_fil and cs_line_num tags of any item found on
2046 : * the "Control-Stack" are used in error-messages.
2047 : *
2048 : * Outputs:
2049 : * Returned Value: NONE
2050 : * Global Variables:
2051 : * control_stack_depth Reset to zero.
2052 : * do_loop_depth Reset to zero.
2053 : * Control-Stack, # of Items Popped: All of them
2054 : *
2055 : * Error Detection:
2056 : * Any item on the "Control-Stack" represents a Control-Structure
2057 : * that was not completed when the Calling Condition was
2058 : * encountered. Error; identify the origin of the structure.
2059 : * No special actions if noerrors is set.
2060 : *
2061 : * Process Explanation:
2062 : * Filter the duplicate messages caused by structures (e.g., DO)
2063 : * that place two entries on the "Control-Stack" by testing
2064 : * the cs_not_dup field of the "Top" "Control-Stack" item,
2065 : * which would indicate double-entry...
2066 : *
2067 : * Extraneous Remarks:
2068 : * This is called before a definition of any kind, and after a
2069 : * colon-definition. Flow-control constructs should *never*
2070 : * be allowed to cross over between immediate-execution mode
2071 : * and compilation mode. Likewise, not between device-nodes.
2072 : * Also, at the end of tokenization, there should not be any
2073 : * unresolved flow-control constructs.
2074 : *
2075 : **************************************************************************** */
2076 :
2077 : void clear_control_structs( char *call_cond)
2078 170 : {
2079 170 : clear_control_structs_to_limit( call_cond, 0);
2080 170 : }
|
