00001 /* 00002 * OpenBIOS - free your system! 00003 * ( FCode tokenizer ) 00004 * 00005 * This program is part of a free implementation of the IEEE 1275-1994 00006 * Standard for Boot (Initialization Configuration) Firmware. 00007 * 00008 * Copyright (C) 2001-2005 Stefan Reinauer, <stepan@openbios.org> 00009 * 00010 * This program is free software; you can redistribute it and/or modify 00011 * it under the terms of the GNU General Public License as published by 00012 * the Free Software Foundation; version 2 of the License. 00013 * 00014 * This program is distributed in the hope that it will be useful, 00015 * but WITHOUT ANY WARRANTY; without even the implied warranty of 00016 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00017 * GNU General Public License for more details. 00018 * 00019 * You should have received a copy of the GNU General Public License 00020 * along with this program; if not, write to the Free Software 00021 * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA, 02110-1301 USA 00022 * 00023 */ 00024 00025 /* ************************************************************************** 00026 * 00027 * Support Functions for tokenizing FORTH Flow-Control structures. 00028 * 00029 * (C) Copyright 2005 IBM Corporation. All Rights Reserved. 00030 * Module Author: David L. Paktor dlpaktor@us.ibm.com 00031 * 00032 **************************************************************************** */ 00033 00034 /* ************************************************************************** 00035 * 00036 * Functions Exported: 00037 * These first two do their work after the calling routine 00038 * has written the token for the required variant: 00039 * 00040 * mark_do Mark branches for "do" variants 00041 * resolve_loop Resolve "loop" variants' branches 00042 * 00043 * The remaining routines' descriptions are all similar: 00044 * Write the token(s), handle the outputs, mark 00045 * or resolve the branches, and verify correct 00046 * control-structure matching, for tokenizing 00047 * the ........................ statement in FORTH 00048 * emit_if IF 00049 * emit_else ELSE 00050 * emit_then THEN 00051 * emit_begin BEGIN 00052 * emit_again AGAIN 00053 * emit_until UNTIL 00054 * emit_while WHILE 00055 * emit_repeat REPEAT 00056 * emit_case CASE 00057 * emit_of OF 00058 * emit_endof ENDOF 00059 * emit_endcase ENDCASE 00060 * 00061 * Three additional routines deal with matters of overall balance 00062 * of the Control-Structures, and identify the start of any that 00063 * were not balanced. The first just displays Messages: 00064 * 00065 * announce_control_structs 00066 * 00067 * The other two clear and re-balance them: 00068 * 00069 * clear_control_structs_to_limit 00070 * clear_control_structs 00071 * 00072 **************************************************************************** */ 00073 00074 /* ************************************************************************** 00075 * 00076 * Still to be done: 00077 * Correct analysis of Return-Stack usage around Flow-Control 00078 * constructs, including within Do-Loops or before Loop 00079 * Elements like I and J or UNLOOP or LEAVE. 00080 * Similarly, Return-Stack usage around IF ... ELSE ... THEN 00081 * statements needs analysis. For instance, the following: 00082 * 00083 * blablabla >R yadayada IF R> gubble ELSE flubble R> THEN 00084 * 00085 * is, in fact, correct, while something like: 00086 * 00087 * blablabla >R yadayada IF R> gubble THEN 00088 * 00089 * is an error. 00090 * 00091 * Implementing an analysis that would be sufficiently accurate 00092 * to justify reporting an ERROR with certainty (rather than 00093 * a mere WARNING speculatively) would probably require full 00094 * coordination with management of Flow-Control constructs, 00095 * and so is noted here. 00096 * 00097 **************************************************************************** */ 00098 00099 #include <stdlib.h> 00100 #include <stdio.h> 00101 #include <string.h> 00102 00103 #include "types.h" 00104 #include "toke.h" 00105 #include "emit.h" 00106 #include "vocabfuncts.h" 00107 #include "scanner.h" 00108 #include "stack.h" 00109 #include "errhandler.h" 00110 #include "flowcontrol.h" 00111 #include "stream.h" 00112 00113 /* ************************************************************************** 00114 * 00115 * Global Variables Imported 00116 * opc FCode Output Buffer Position Counter 00117 * noerrors "Ignore Errors" flag, set by "-i" switch 00118 * do_loop_depth How deep we are inside DO ... LOOP variants 00119 * incolon State of tokenization; TRUE if inside COLON 00120 * statbuf The word just read from the input stream 00121 * iname Name of input file currently being processed 00122 * lineno Current line-number being processed 00123 * 00124 **************************************************************************** */ 00125 00126 /* ************************************************************************** 00127 * 00128 * Global Variables Exported 00129 * control_stack_depth Number of items on "Control-Stack" 00130 * 00131 **************************************************************************** */ 00132 00133 int control_stack_depth = 0; 00134 00135 00136 /* ************************************************************************** 00137 * 00138 * Internal Static Functions: 00139 * push_cstag Push an item onto the Control-Stack 00140 * pop_cstag Pop one item from the Control-Stack 00141 * control_stack_size_test Test C-S depth; report if error 00142 * control_structure_mismatch Print error-message 00143 * offset_too_large Print error-message 00144 * matchup_control_structure Error-check Control-Stack 00145 * matchup_two_control_structures Error-check two Control-Stack entries 00146 * emit_fc_offset Error-check and output FCode-Offset 00147 * control_structure_swap Swap control-struct branch-markers 00148 * mark_backward_target Mark target of backward-branch 00149 * resolve_backward Resolve backward-target for branch 00150 * mark_forward_branch Mark forward-branch 00151 * resolve_forward Resolve forward-branch at target 00152 * 00153 **************************************************************************** */ 00154 00155 /* ************************************************************************** 00156 * 00157 * Internal Named Constants 00158 * Note: These control-structure identifier tags -- a.k.a. cstags -- 00159 * are used to identify the matching components of particular 00160 * control-structures. They are passed as parameters, and either 00161 * "Pushed" onto the "Control-Stack", or compared with what is on 00162 * "Top" of the "Control-Stack", as an error-check. 00163 * 00164 * name used by forth words: 00165 * BEGIN_CSTAG BEGIN AGAIN UNTIL REPEAT 00166 * IF_CSTAG IF ELSE THEN 00167 * WHILE_CSTAG WHILE REPEAT THEN 00168 * DO_CSTAG DO ?DO LOOP +LOOP 00169 * CASE_CSTAG CASE OF ENDCASE 00170 * OF_CSTAG OF ENDOF 00171 * ENDOF_CSTAG ENDOF ENDCASE 00172 * 00173 * The numbers assigned are arbitrary; they were selected for a 00174 * high unlikelihood of being encountered in normal usage, 00175 * and constructed with a hint of mnemonic value in mind. 00176 * 00177 **************************************************************************** */ 00178 /* Mnemonic: */ 00179 #define BEGIN_CSTAG 0xC57be916 /* CST BEGIN */ 00180 #define IF_CSTAG 0xC57A901f /* CSTAG (0) IF */ 00181 #define WHILE_CSTAG 0xC573412e /* CST WHILE */ 00182 #define DO_CSTAG 0xC57A90d0 /* CSTAG (0) DO */ 00183 #define CASE_CSTAG 0xC57Aca5e /* CSTA CASE */ 00184 #define OF_CSTAG 0xC57A90f0 /* CSTAG OF (0) */ 00185 #define ENDOF_CSTAG 0xC57e6d0f /* CST ENDOF */ 00186 00187 00188 /* ************************************************************************** 00189 * 00190 * Control-Structure identification, matching, completion and error 00191 * messaging will be supported by a data structure, which we 00192 * will call a CSTAG-Group 00193 * 00194 * It consists of one "Data-item" and several "Marker" items, thus: 00195 * 00196 * The Data-item in most cases will be a value of OPC (the Output 00197 * Buffer Position Counter) which will be used in calculating 00198 * an offset or placing an offset or both, as the case may be, 00199 * for the control structure in question. The one exception 00200 * is for a CSTAG-Group generated by a CASE statement; its 00201 * Data-item will be an integer count of the number of "OF"s 00202 * to be resolved when the ENDCASE statement is reached. 00203 * 00204 * The CSTAG for the FORTH word, as described above 00205 * The name of the input file in which the word was encountered 00206 * (actually, a pointer to a mem-alloc'ed copy of the filename) 00207 * The line number, within the input file, of the word's invocation 00208 * The Absolute Token Number in all Source Input of the word 00209 * The FORTH word that started the structure, (used in error messages) 00210 * A flag to indicate when two CSTAG-Groups are created together, 00211 * which will be used to prevent duplicate error messages when, 00212 * for instance, a DO is mismatched with a REPEAT . 00213 * 00214 **************************************************************************** */ 00215 00216 /* ************************************************************************** 00217 * 00218 * "Control-Stack" Diagram Notation 00219 * 00220 * The CSTAG-Groups will be kept in an order resembling a data-stack, 00221 * (even though it won't be the data-stack itself). We will refer 00222 * to this list of structures as the "Control Stack", and in our 00223 * comments we will show their arrangement in a format resembling 00224 * stack-diagram remarks. 00225 * 00226 * In these "Control-Stack Diagrams", we will use the notation: 00227 * <Stmt>_{FOR|BACK}w_<TAGNAM> 00228 * to represent a CSTAG-Group generated by a <Stmt> -type of 00229 * statement, with a "FORw"ard or "BACKw"ard branch-marker and 00230 * a CSTAG of the <TAGNAM> type. 00231 * 00232 * A CASE-CSTAG-Group will have a different notation: 00233 * N_OFs...CASE_CSTAG 00234 * 00235 * In all cases, a CSTAG-Group will be manipulated as a unit. 00236 * 00237 * The notation for Control-Stack Diagram remarks will largely resemble 00238 * the classic form used in FORTH, i.e., enclosed in parentheses, 00239 * lowest item to the left, top item on the right, with a double- 00240 * hyphen to indicate "before" or "after". 00241 * 00242 * Enclosure in {curly-braces} followed by a subscript-range indicates 00243 * that the Stack-item or Group is repeated. 00244 * 00245 **************************************************************************** */ 00246 00247 /* ************************************************************************** 00248 * 00249 * We are not keeping the "Control Stack" structures on the regular 00250 * data stack because a sneaky combination of user-inputs could 00251 * throw things into chaos were we to use that scheme. Consider 00252 * what would happen if a number were put on the stack, say, in 00253 * tokenizer-escape mode, in between elements of a flow-control 00254 * structure... Theoretically, there is no reason to prohibit 00255 * that, but it would be unexpectedly problematical for most 00256 * FORTH-based tokenizers. 00257 * 00258 * Maintaining the "Control Stack" structures in a linked-list would 00259 * be a more nearly bullet-proof approach. The theory of operation 00260 * would be the same, broadly speaking, and there would be no need 00261 * to check for NOT_CSTAG and no risk of getting the elements of 00262 * the control-structures out of sync. 00263 * 00264 **************************************************************************** */ 00265 00266 /* ************************************************************************** 00267 * 00268 * Structure Name: cstag_group_t 00269 * Synopsis: Control-Structure Tag Group 00270 * 00271 * Fields: 00272 * cs_tag Control-structure identifier tag 00273 * cs_inp_fil Name of input file where C-S was started 00274 * cs_line_num Line-number in Current Source when C-S was started 00275 * cs_abs_token_num "Absolute" Token Number when C-S was started 00276 * cs_word The FORTH word that started the C-S 00277 * cs_not_dup FALSE if second "Control Stack" entry for same word 00278 * cs_datum Data-Item of the Group 00279 * prev Pointer to previous CSTAG-Group in linked-list 00280 * 00281 * All data using this structure will remain private to this file, 00282 * so we declare it here rather than in the .h file 00283 * 00284 **************************************************************************** */ 00285 00286 typedef struct cstag_group { 00287 unsigned long cs_tag; 00288 char *cs_inp_fil; 00289 unsigned int cs_line_num; 00290 unsigned int cs_abs_token_num; 00291 char *cs_word; 00292 bool cs_not_dup; 00293 unsigned long cs_datum; 00294 struct cstag_group *prev; 00295 } cstag_group_t; 00296 00297 /* ************************************************************************** 00298 * 00299 * Internal Static Variables 00300 * control_stack "Thread" Pointer to the linked-list of 00301 * "Control Stack" structure entries 00302 * not_cs_underflow Flag used to prevent duplicate messages 00303 * not_consuming_two Flag used to prevent loss of messages 00304 * didnt_print_otl Flag used to prevent duplicate messages 00305 * 00306 **************************************************************************** */ 00307 00308 static cstag_group_t *control_stack = NULL; /* "Top" of the "Stack" */ 00309 00310 /* ************************************************************************** 00311 * 00312 * not_cs_underflow is used only by routines that make two calls to 00313 * resolve a marker. It is set TRUE before the first call; if 00314 * that call had a control-stack underflow, the error-message 00315 * routine resets it to FALSE. The calling routine can then 00316 * test it as the condition for the second call. 00317 * Routines that make only one call to resolve a marker can ignore it. 00318 * 00319 **************************************************************************** */ 00320 00321 static bool not_cs_underflow; /* No need to initialize. */ 00322 00323 /* ************************************************************************** 00324 * 00325 * not_consuming_two is also used only by routines that make two calls 00326 * to resolve a marker, but for this case, those routines only need 00327 * to reset it to FALSE and not to test it; that will be done by 00328 * the control_structure_mismatch() routine when it looks at 00329 * the cs_not_dup field. If the mismatch occurred because of 00330 * a combination of control-structures that consume one each, 00331 * the message will be printed even for the second "Control Stack" 00332 * entry. The routine that changed it will have to set it back to 00333 * TRUE when it's done with it. 00334 * 00335 * didnt_print_otl is used similarly, but only for the offset-too-large 00336 * error in the DO ... LOOP type of control-structures. 00337 * 00338 **************************************************************************** */ 00339 00340 static bool not_consuming_two = TRUE; 00341 static bool didnt_print_otl = TRUE; 00342 00343 00344 /* ************************************************************************** 00345 * 00346 * Function name: push_cstag 00347 * Synopsis: Push a new CSTAG-Group onto the front ("Top") 00348 * of the (notional) Control-Stack. 00349 * 00350 * Inputs: 00351 * Parameters: 00352 * cstag ID Tag for Control-Structure to "Push" 00353 * datum The Data-Item for the new CSTAG-Group 00354 * Global Variables: 00355 * iname Name of input file currently being processed 00356 * lineno Current-Source line-number being processed 00357 * abs_tokenno "Absolute"Token Number of word being processed 00358 * statbuf The word just read, which started the C-S 00359 * Local Static Variables: 00360 * control_stack Will become the new entry's "prev" 00361 * 00362 * Outputs: 00363 * Returned Value: None 00364 * Global Variables: 00365 * control_stack_depth Incremented 00366 * Local Static Variables: 00367 * control_stack Will become the "previous" entry in the list 00368 * Items Pushed onto Control-Stack: 00369 * Top: A new CSTAG-Group, params as given 00370 * Memory Allocated 00371 * New CSTAG-Group structure 00372 * Duplicate of name of current input file 00373 * Duplicate of word just read 00374 * When Freed? 00375 * When Removing a CSTAG-Group, in pop_cstag() 00376 * 00377 **************************************************************************** */ 00378 00379 static void push_cstag( unsigned long cstag, unsigned long datum) 00380 { 00381 cstag_group_t *cs_temp; 00382 00383 cs_temp = control_stack; 00384 control_stack = safe_malloc( sizeof(cstag_group_t), "pushing CSTag"); 00385 00386 control_stack->cs_tag = cstag; 00387 control_stack->cs_inp_fil = strdup(iname); 00388 control_stack->cs_line_num = lineno; 00389 control_stack->cs_abs_token_num = abs_token_no; 00390 control_stack->cs_word = strdup(statbuf); 00391 control_stack->cs_not_dup = TRUE; 00392 control_stack->cs_datum = datum; 00393 control_stack->prev = cs_temp; 00394 00395 control_stack_depth++; 00396 00397 } 00398 00399 /* ************************************************************************** 00400 * 00401 * Function name: pop_cstag 00402 * Synopsis: Remove a CSTAG-Group from the front ("Top") of the 00403 * (notional) Control-Stack. 00404 * 00405 * Inputs: 00406 * Parameters: NONE 00407 * Global Variables: 00408 * Local Static Variables: 00409 * control_stack CSTAG-Group on "Top" 00410 * 00411 * Outputs: 00412 * Returned Value: NONE 00413 * Global Variables: 00414 * control_stack_depth Decremented 00415 * Local Static Variables: 00416 * control_stack "Previous" entry will become current 00417 * Memory Freed 00418 * mem-alloc'ed copy of input filename 00419 * mem-alloc'ed copy of Control-structure FORTH word 00420 * CSTAG-Group structure 00421 * Control-Stack, # of Items Popped: 1 00422 * 00423 * Process Explanation: 00424 * The calling routine might not check for empty Control-Stack, 00425 * so we have to be sure and check it here. 00426 * 00427 **************************************************************************** */ 00428 00429 static void pop_cstag( void) 00430 { 00431 00432 if ( control_stack != NULL ) 00433 { 00434 cstag_group_t *cs_temp; 00435 00436 cs_temp = control_stack->prev; 00437 free( control_stack->cs_word ); 00438 free( control_stack->cs_inp_fil ); 00439 free( control_stack ); 00440 control_stack = cs_temp; 00441 00442 control_stack_depth--; 00443 } 00444 } 00445 00446 /* ************************************************************************** 00447 * 00448 * Function name: control_stack_size_test 00449 * Synopsis: Detect Control Stack underflow; report if an ERROR. 00450 * 00451 * Inputs: 00452 * Parameters: 00453 * min_depth Minimum depth needed 00454 * Global Variables: 00455 * control_stack_depth Current depth of Control Stack 00456 * statbuf Word to name in error message 00457 * 00458 * Outputs: 00459 * Returned Value: TRUE if adequate depth 00460 * Local Static Variables: 00461 * not_cs_underflow Reset to FALSE if underflow detected. 00462 * Printout: 00463 * Error message is printed. 00464 * Identify the colon definition if inside one. 00465 * 00466 * Process Explanation: 00467 * Some statements need more than one item on the Control Stack; 00468 * they will do their own control_stack_depth testing and 00469 * make a separate call to this routine. 00470 * 00471 **************************************************************************** */ 00472 00473 static bool control_stack_size_test( int min_depth ) 00474 { 00475 bool retval = TRUE; 00476 00477 if ( control_stack_depth < min_depth ) 00478 { 00479 retval = FALSE; 00480 tokenization_error ( TKERROR, 00481 "Control-Stack underflow at %s", strupr(statbuf) ); 00482 in_last_colon(); 00483 00484 not_cs_underflow = FALSE; /* See expl'n early on in this file */ 00485 } 00486 00487 return( retval ); 00488 } 00489 00490 /* ************************************************************************** 00491 * 00492 * Function name: control_structure_mismatch 00493 * Synopsis: Report an ERROR after a Control Structure mismatch 00494 * was detected. 00495 * 00496 * Inputs: 00497 * Parameters: NONE 00498 * Global Variables: 00499 * statbuf Word encountered, to name in error message 00500 * Local Static Variables: 00501 * control_stack "Pushed" Control-Structure Tag Group 00502 * not_consuming_two See explanation early on in this file 00503 * Control-Stack Items: 00504 * Top: "Current" Control-Structure Tag Group 00505 * Some of its "Marker" information 00506 * will be used in the error message 00507 * 00508 * Outputs: 00509 * Returned Value: NONE 00510 * Printout: 00511 * Error message is printed 00512 * 00513 * Process Explanation: 00514 * This routine is called after a mismatch is detected, and 00515 * before the CSTAG-Group is "Popped" from the notional 00516 * Control-Stack. 00517 * If the control_stack pointer is NULL, print a different 00518 * Error message 00519 * Don't print if the "Control Stack" entry is a duplicate and 00520 * we're processing a statement that consumes two entries. 00521 * 00522 **************************************************************************** */ 00523 00524 static void control_structure_mismatch( void ) 00525 { 00526 if ( control_stack->cs_not_dup || not_consuming_two ) 00527 { 00528 tokenization_error ( TKERROR, 00529 "The %s is mismatched with the %s" , 00530 strupr(statbuf), strupr(control_stack->cs_word)); 00531 where_started( control_stack->cs_inp_fil, control_stack->cs_line_num ); 00532 } 00533 } 00534 00535 00536 /* ************************************************************************** 00537 * 00538 * Function name: offset_too_large 00539 * Synopsis: Report an ERROR after a too-large fcode-offset 00540 * was detected. 00541 * 00542 * Inputs: 00543 * Parameters: 00544 * too_large_for_16 TRUE if the offset is too large to be 00545 * expressed as a 16-bit signed number. 00546 * Global Variables: 00547 * statbuf Word encountered, to name in error message 00548 * offs16 Whether we are using 16-bit offsets 00549 * Local Static Variables: 00550 * control_stack "Pushed" Control-Structure Tag Group 00551 * didnt_print_otl Switch to prevent duplicate message 00552 * Control-Stack Items: 00553 * Top: "Current" Control-Structure Tag Group 00554 * Some of its "Marker" information 00555 * will be used in the error message 00556 * 00557 * Outputs: 00558 * Returned Value: NONE 00559 * Local Static Variables: 00560 * didnt_print_otl Will be reset to FALSE 00561 * 00562 * Printout: 00563 * Error message: 00564 * Branch offset too large between <here> and <there> 00565 * Advisory message, if we are using 8-bit offsets, will 00566 * indicate whether switching to 16-bit offsets would help 00567 * 00568 * Process Explanation: 00569 * Two branches are involved in a DO ... LOOP structure: an "outer" 00570 * forward-branch and a slightly smaller "inner" backward-branch. 00571 * In the majority of cases, if one offset exceeds the limit, 00572 * both will. There is, however, a very small but distinct 00573 * possibility that the offset for the smaller branch will not 00574 * exceed the limit while the larger one does. To prevent two 00575 * messages from being printed in the routine instance, but still 00576 * assure that one will be printed in the rare eventuality, we 00577 * utilize the flag called didnt_print_otl in conjunction 00578 * with the cs_not_dup field. 00579 * 00580 **************************************************************************** */ 00581 00582 static void offset_too_large( bool too_large_for_16 ) 00583 { 00584 if ( control_stack->cs_not_dup || didnt_print_otl ) 00585 { 00586 tokenization_error( TKERROR, 00587 "Branch offset is too large between %s and the %s" , 00588 strupr(statbuf), strupr(control_stack->cs_word)); 00589 where_started( control_stack->cs_inp_fil, control_stack->cs_line_num ); 00590 if ( INVERSE( offs16 ) ) 00591 { 00592 if ( too_large_for_16 ) 00593 { 00594 tokenization_error ( INFO, 00595 "Offset would be too large even if 16-bit offsets " 00596 "were in effect.\n"); 00597 }else{ 00598 tokenization_error ( INFO, 00599 "Offset might fit if 16-bit offsets " 00600 "(e.g., fcode-version2) were used.\n" ); 00601 } 00602 } 00603 } 00604 didnt_print_otl = FALSE; 00605 } 00606 00607 /* ************************************************************************** 00608 * 00609 * Function name: emit_fc_offset 00610 * Synopsis: Test whether the given FCode-Offset is out-of-range; 00611 * before placing it into the FCode Output Buffer. 00612 * 00613 * Inputs: 00614 * Parameters: 00615 * fc_offset The given FCode-Offset 00616 * Global Variables: 00617 * offs16 Whether we are using 16-bit offsets 00618 * noerrors "Ignore Errors" flag 00619 * 00620 * Outputs: 00621 * Returned Value: NONE 00622 * 00623 * Error Detection: 00624 * Error if the given FCode-Offset exceeds the range that can 00625 * be expressed by the size (i.e., 8- or 16- -bits) of the 00626 * offsets we are using. Call offset_too_large() to print 00627 * the Error message; also, if noerrors is in effect, issue 00628 * a Warning showing the actual offset and how it will be coded. 00629 * 00630 * Process Explanation: 00631 * For forward-branches, the OPC will have to be adjusted to 00632 * indicate the location that was reserved for the offset 00633 * to be written, rather than the current location. That 00634 * will all be handled by the calling routine. 00635 * We will rely on "C"'s type-conversion (type-casting) facilities. 00636 * Look at the offset value both as an 8-bit and as a 16-bit offset, 00637 * then determine the relevant course of action. 00638 * 00639 **************************************************************************** */ 00640 00641 static void emit_fc_offset( int fc_offset) 00642 { 00643 int fc_offs_s16 = (s16)fc_offset; 00644 int fc_offs_s8 = (s8)fc_offset; 00645 bool too_large_for_8 = BOOLVAL( fc_offset != fc_offs_s8 ); 00646 bool too_large_for_16 = BOOLVAL( fc_offset != fc_offs_s16); 00647 00648 if ( too_large_for_16 || ( INVERSE(offs16) && too_large_for_8 ) ) 00649 { 00650 offset_too_large( too_large_for_16 ); 00651 if ( noerrors ) 00652 { 00653 int coded_as = offs16 ? (int)fc_offs_s16 : (int)fc_offs_s8 ; 00654 tokenization_error( WARNING, 00655 "Actual offset is 0x%x (=dec %d), " 00656 "but it will be coded as 0x%x (=dec %d).\n", 00657 fc_offset, fc_offset, coded_as, coded_as ); 00658 } 00659 } 00660 00661 emit_offset( fc_offs_s16 ); 00662 } 00663 00664 00665 /* ************************************************************************** 00666 * 00667 * Function name: matchup_control_structure 00668 * Synopsis: Error-check. Compare the given control-structure 00669 * identifier tag with the one in the CSTAG-Group 00670 * on "Top" of the "Control Stack". 00671 * If they don't match, report an error, and, if not 00672 * "Ignoring Errors", return Error indication. 00673 * If no error, pass the Data-item back to the caller. 00674 * Do not consume the CSTAG-Group; that will be the 00675 * responsibility of the calling routine. 00676 * 00677 * Inputs: 00678 * Parameters: 00679 * cstag Control-struc ID Tag expected by calling function 00680 * Global Variables: 00681 * noerrors "Ignore Errors" flag 00682 * Local Static Variables: 00683 * control_stack "Pushed" (current) Control-Structure Tag Group 00684 * Control-Stack Items: 00685 * Top: Current CSTAG-Group 00686 * 00687 * Outputs: 00688 * Returned Value: TRUE = Successful match, no error. 00689 * 00690 * Error Detection: 00691 * Control Stack underflow or cstag mismatch. See below for details. 00692 * 00693 * Process Explanation: 00694 * If the expected cstag does not match the cs_tag from the CSTAG 00695 * Group on "Top" of the "Control Stack", print an ERROR message, 00696 * and, unless the "Ignore Errors" flag is in effect, prepare 00697 * to return FALSE. 00698 * However, if we've "underflowed" the "Control Stack", we dare not 00699 * ignore errors; that could lead to things like attempting to 00700 * write a forward-branch FCode-offset to offset ZERO, over the 00701 * FCODE- or PCI- -header block. We don't want that... 00702 * So, if the control_stack pointer is NULL, we will print an 00703 * ERROR message and immediately return FALSE. 00704 * Since we will not consume the CSTAG-Group, the calling routine 00705 * can access the Data-Item and any "Marker" information it may 00706 * still require via the local control_stack pointer. The caller 00707 * will be responsible for removing the CSTAG-Group. 00708 * 00709 * Special Exception to "Ignore Errors": 00710 * At the last usage of the CASE_CSTAG , for the ENDCASE statement, 00711 * this routine will be called to control freeing-up memory, etc. 00712 * For the OF statement, it will be called to control incrementing 00713 * the OF-count datum. 00714 * Processing an ENDCASE statement with the datum from any other 00715 * CSTAG-Group can lead to a huge loop. 00716 * Processing any other "resolver" with the datum from an ENDCASE 00717 * CSTAG-Group can lead to mistaking a very low number for an 00718 * offset into the Output Buffer and attempting to write to it. 00719 * Incrementing the datum from any other CSTAG-Group can lead to 00720 * a variety of unacceptable errors, too many to guess. 00721 * So, if either the given cstag or the cs_tag field of the "Top" 00722 * CSTAG-Group is a CASE_CSTAG , we will not ignore errors. 00723 * 00724 **************************************************************************** */ 00725 00726 static bool matchup_control_structure( unsigned long cstag ) 00727 { 00728 bool retval = FALSE; 00729 00730 if ( control_stack_size_test( 1) ) 00731 { 00732 retval = TRUE; 00733 00734 if ( control_stack->cs_tag != cstag ) 00735 { 00736 control_structure_mismatch(); 00737 00738 if ( ( INVERSE(noerrors) ) 00739 || ( cstag == CASE_CSTAG ) 00740 || ( control_stack->cs_tag == CASE_CSTAG ) 00741 ) 00742 { 00743 retval = FALSE; 00744 } 00745 } 00746 00747 } 00748 return ( retval ); 00749 } 00750 00751 /* ************************************************************************** 00752 * 00753 * Function name: control_structure_swap 00754 * Synopsis: Swap control-structure branch-marker Groups 00755 * 00756 * Inputs: 00757 * Parameters: NONE 00758 * Local Static Variables: 00759 * control_stack Pointer to "Control Stack" linked-list 00760 * Control-Stack Items: 00761 * Top: CSTAG-Group_0 00762 * Next: CSTAG-Group_1 00763 * 00764 * Outputs: 00765 * Returned Value: NONE 00766 * Local Static Variables: 00767 * control_stack Points to former "previous" and vice-versa 00768 * Items on Control-Stack: 00769 * Top: CSTAG-Group_1 00770 * Next: CSTAG-Group_0 00771 * 00772 * Error Detection: 00773 * If control-stack depth is not at least 2, CS underflow ERROR. 00774 * This might trigger other routines' error detections also... 00775 * 00776 * Extraneous Remarks: 00777 * Before control-structure identification was implemented, offsets 00778 * were kept on the data-stack, and this was a single SWAP. 00779 * When CSTAGs were added, the "Group" was only a pair kept on the 00780 * data-stack -- the CSTAG and the Data-item -- and this 00781 * became a TWO_SWAP() 00782 * For a while, when I tried keeping the CSTAG-Group on the stack, 00783 * this became a FOUR_SWAP() 00784 * That turned out to be unacceptably brittle; this way is much 00785 * more robust. 00786 * I am so glad I called this functionality out into a separate 00787 * routine, early on in the development process. 00788 * 00789 * This is the function called 1 CSROLL in section A.3.2.3.2 00790 * of the ANSI Forth spec, which likewise corresponds to the 00791 * modifier that Wil Baden, in his characteristically elegant 00792 * nomenclature, dubbed: BUT 00793 * 00794 **************************************************************************** */ 00795 00796 static void control_structure_swap( void ) 00797 { 00798 if ( control_stack_size_test( 2) ) 00799 { 00800 cstag_group_t *cs_temp; 00801 00802 cs_temp = control_stack->prev; 00803 00804 control_stack->prev = cs_temp->prev; 00805 cs_temp->prev = control_stack; 00806 control_stack = cs_temp; 00807 } 00808 } 00809 00810 /* ************************************************************************** 00811 * 00812 * Function name: matchup_two_control_structures 00813 * Synopsis: For functions that resolve two CSTAG-Groups, both 00814 * matchup both "Top of Control Stack" entries 00815 * before processing them... 00816 * 00817 * Inputs: 00818 * Parameters: 00819 * top_cstag Control-struc ID Tag expected on "Top" CS entry 00820 * next_cstag Control-struc ID Tag expected on "Next" CS entry 00821 * Local Static Variables: 00822 * not_cs_underflow Used for underflow detection. 00823 * Control-Stack Items: 00824 * Top: Current CSTAG-Group 00825 * Next: Next CSTAG-Group 00826 * 00827 * Outputs: 00828 * Returned Value: TRUE = Successful matches, no error. 00829 * Global Variables: 00830 * noerrors "Ignore Errors" flag; cleared, then restored 00831 * Local Static Variables: 00832 * not_consuming_two Cleared, then restored 00833 * Control-Stack, # of Items Popped: 2 (if matches unsuccessful) 00834 * 00835 * Error Detection: 00836 * Control Stack underflow detected by control_structure_swap() 00837 * Control Structure mismatch detected by control_structure_mismatch() 00838 * 00839 * Process Explanation: 00840 * We will use matchup_control_structure() to do the "heavy lifting". 00841 * We will not be ignoring errors in these cases. 00842 * Save the results of a match of top_cstag 00843 * Swap the top two CS entries. 00844 * If an underflow was detected, there's no more matching to be done. 00845 * Otherwise: 00846 * Save the results of a match of next_cstag 00847 * Swap the top two CS entries again, to their original order. 00848 * The result is TRUE if both matches were successful. 00849 * If the matches were not successful, consume the top two entries 00850 * (unless there's only one, in which case consume it). 00851 * 00852 **************************************************************************** */ 00853 00854 static bool matchup_two_control_structures( unsigned long top_cstag, 00855 unsigned long next_cstag) 00856 { 00857 bool retval; 00858 bool topmatch; 00859 bool nextmatch = FALSE; 00860 bool sav_noerrors = noerrors; 00861 noerrors = FALSE; 00862 not_consuming_two = FALSE; 00863 00864 not_cs_underflow = TRUE; 00865 topmatch = matchup_control_structure( top_cstag); 00866 if ( not_cs_underflow ) 00867 { 00868 control_structure_swap(); 00869 if ( not_cs_underflow ) 00870 { 00871 nextmatch = matchup_control_structure( next_cstag); 00872 control_structure_swap(); 00873 } 00874 } 00875 00876 retval = BOOLVAL( topmatch && nextmatch); 00877 00878 if ( INVERSE( retval) ) 00879 { 00880 pop_cstag(); 00881 pop_cstag(); 00882 } 00883 00884 not_consuming_two = TRUE; 00885 noerrors = sav_noerrors; 00886 return ( retval ); 00887 } 00888 00889 /* ************************************************************************** 00890 * 00891 * Function name: mark_backward_target 00892 * Synopsis: Mark the target of an expected backward-branch 00893 * 00894 * Associated FORTH words: BEGIN DO ?DO 00895 * 00896 * Inputs: 00897 * Parameters: 00898 * cstag Control-structure ID tag for calling function 00899 * Global Variables: 00900 * opc Output Buffer Position Counter 00901 * 00902 * Outputs: 00903 * Returned Value: NONE 00904 * Items Pushed onto Control-Stack: 00905 * Top: <Stmt>_BACKw_<TAGNAM> 00906 * 00907 * Process Explanation: 00908 * Just before this function is called, the token that begins the 00909 * control-structure was written to the FCode Output buffer. 00910 * OPC, the FCode Output Buffer Position Counter, is at the 00911 * destination to which the backward-branch will be targeted. 00912 * Create a CSTAG-Group with the given C-S Tag, and OPC as its datum; 00913 * push it onto the Control-Stack. 00914 * Later, when the backward-branch is installed, the FCode-offset 00915 * will be calculated as the difference between the OPC at 00916 * that time and the target-OPC we saved here. 00917 * 00918 **************************************************************************** */ 00919 00920 static void mark_backward_target(unsigned long cstag ) 00921 { 00922 push_cstag( cstag, (unsigned long)opc); 00923 } 00924 00925 /* ************************************************************************** 00926 * 00927 * Function name: mark_forward_branch 00928 * Synopsis: Mark the location of, and reserve space for, the 00929 * FCode-offset associated with a forward branch. 00930 * 00931 * Associated FORTH words: IF WHILE ELSE 00932 * 00933 * Inputs: 00934 * Parameters: 00935 * cstag Control-structure ID tag for calling function 00936 * 00937 * Outputs: 00938 * Returned Value: NONE 00939 * Items Pushed onto Control-Stack: 00940 * Top: <Stmt>_FORw_<TAGNAM> 00941 * FCode Output buffer: 00942 * Place-holder FCode-offset of zero. 00943 * 00944 * Process Explanation: 00945 * Just before this function is called, the forward-branch token 00946 * that begins the control-structure was written to the FCode 00947 * Output buffer. 00948 * It will need an FCode-offset to the destination to which it will 00949 * be targeted, once that destination is known. 00950 * Create a CSTAG-Group with the given C-S Tag, and OPC as its datum; 00951 * push it onto the Control-Stack. (This is the same action as 00952 * for marking a backward-target.) 00953 * Then write a place-holder FCode-offset of zero to the FCode 00954 * Output buffer. 00955 * Later, when the destination is known, the FCode-offset will be 00956 * calculated as the difference between the OPC at that time 00957 * and the FCode-offset location we're saving now. That offset 00958 * will be over-written onto the place-holder offset of zero at 00959 * the location in the Output buffer that we saved on the 00960 * Control-Stack in this routine. 00961 * 00962 **************************************************************************** */ 00963 00964 static void mark_forward_branch(unsigned long cstag ) 00965 { 00966 mark_backward_target(cstag ); 00967 emit_offset(0); 00968 } 00969 00970 /* ************************************************************************** 00971 * 00972 * Function name: resolve_backward 00973 * Synopsis: Resolve backward-target when a backward branch 00974 * is reached. Write FCode-offset to reach saved 00975 * target from current location. 00976 * 00977 * Associated FORTH words: AGAIN UNTIL REPEAT 00978 * LOOP +LOOP 00979 * 00980 * Inputs: 00981 * Parameters: 00982 * cstag Control-structure ID tag for calling function 00983 * Global Variables: 00984 * opc Output Buffer Position Counter 00985 * Control-Stack Items: 00986 * Top: <Stmt>_BACKw_<TAGNAM> 00987 * 00988 * Outputs: 00989 * Returned Value: NONE 00990 * Global Variables: 00991 * opc Incremented by size of an FCode-offset 00992 * Control-Stack, # of Items Popped: 1 00993 * FCode Output buffer: 00994 * FCode-offset to reach backward-target 00995 * 00996 * Error Detection: 00997 * Test for Control-structure ID tag match. 00998 * 00999 * Process Explanation: 01000 * Just before this function is called, the backward-branch token 01001 * that ends the control-structure was written to the FCode 01002 * Output buffer. 01003 * The current OPC is at the point from which the FCode-offset 01004 * is to be calculated, and at which it is to be written. 01005 * The top of the Control-Stack should have the CSTAG-Group from 01006 * the statement that prepared the backward-branch target that 01007 * we expect to resolve. Its datum is the OPC of the target 01008 * of the backward branch. 01009 * If the supplied Control-structure ID tag does not match the one 01010 * on top of the Control-Stack, announce an error. We will 01011 * still write an FCode-offset, but it will be a place-holder 01012 * of zero. 01013 * Otherwise, the FCode-offset we will write will be the difference 01014 * between the target-OPC and our current OPC. 01015 * 01016 **************************************************************************** */ 01017 01018 static void resolve_backward( unsigned long cstag) 01019 { 01020 unsigned long targ_opc; 01021 int fc_offset = 0; 01022 01023 if ( matchup_control_structure( cstag) ) 01024 { 01025 targ_opc = control_stack->cs_datum; 01026 fc_offset = targ_opc - opc; 01027 } 01028 01029 emit_fc_offset( fc_offset ); 01030 pop_cstag(); 01031 } 01032 01033 /* ************************************************************************** 01034 * 01035 * Function name: resolve_forward 01036 * Synopsis: Resolve a forward-branch when its target has been 01037 * reached. Write the FCode-offset into the space 01038 * that was reserved. 01039 * 01040 * Associated FORTH words: ELSE THEN REPEAT 01041 * LOOP +LOOP 01042 * 01043 * Inputs: 01044 * Parameters: 01045 * cstag Control-structure ID tag for calling function 01046 * Global Variables: 01047 * opc Output Buffer Position Counter 01048 * Control-Stack Items: 01049 * Top: <Stmt>_FORw_<TAGNAM> 01050 * 01051 * Outputs: 01052 * Returned Value: NONE 01053 * Global Variables: 01054 * opc Changed, then restored. 01055 * Control-Stack, # of Items Popped: 1 01056 * FCode Output buffer: 01057 * FCode-offset is written to location where space was reserved 01058 * when the forward-branch was marked. 01059 * 01060 * Error Detection: 01061 * Test for Control-structure ID tag match. 01062 * 01063 * Process Explanation: 01064 * Just before this function is called, the last token -- and 01065 * possibly, FCode-offset -- that is within the scope of 01066 * what the branch might skip was written to the FCode 01067 * Output buffer. 01068 * The current OPC is at the point from which the FCode-offset 01069 * is to be calculated, but not at which it is to be written. 01070 * The top of the Control-Stack should have the CSTAG-Group from 01071 * the statement that prepared the forward-branch we expect 01072 * to resolve, and for which our current OPC is the target. 01073 * Its datum is the OPC of the space that was reserved for 01074 * the forward-branch whose target we have just reached. 01075 * If the supplied Control-structure ID tag does not match the one 01076 * on top of the Control-Stack, announce an error and we're done. 01077 * Otherwise, the datum is used both as part of the calculation of 01078 * the FCode-offset we are about to write, and as the location 01079 * to which we will write it. 01080 * The FCode-offset is calculated as the difference between our 01081 * current OPC and the reserved OPC location. 01082 * We will not be ignoring errors in these cases, because we would 01083 * be over-writing something that might not be a place-holder 01084 * for a forward-branch at an earlier location in the FCode 01085 * Output buffer. 01086 * 01087 **************************************************************************** */ 01088 01089 static void resolve_forward( unsigned long cstag) 01090 { 01091 unsigned long resvd_opc; 01092 bool sav_noerrors = noerrors; 01093 bool cs_match_result; 01094 noerrors = FALSE; 01095 /* Restore the "ignore-errors" flag before we act on our match result 01096 * because we want it to remain in effect for emit_fc_offset() 01097 */ 01098 cs_match_result = matchup_control_structure( cstag); 01099 noerrors = sav_noerrors; 01100 01101 if ( cs_match_result ) 01102 { 01103 int saved_opc; 01104 int fc_offset; 01105 01106 resvd_opc = control_stack->cs_datum; 01107 fc_offset = opc - resvd_opc; 01108 01109 saved_opc = opc; 01110 opc = resvd_opc; 01111 01112 01113 emit_fc_offset( fc_offset ); 01114 opc = saved_opc; 01115 } 01116 pop_cstag(); 01117 } 01118 01119 01120 /* ************************************************************************** 01121 * 01122 * The functions that follow are the exported routines that 01123 * utilize the preceding support-routines to effect their 01124 * associated FORTH words. 01125 * 01126 * The routines they call will take care of most of the Error 01127 * Detection via stack-depth checking and Control-structure 01128 * ID tag matching, so those will not be called-out in the 01129 * prologues. 01130 * 01131 **************************************************************************** */ 01132 01133 01134 /* ************************************************************************** 01135 * 01136 * Function name: emit_if 01137 * Synopsis: All the actions when IF is encountered 01138 * 01139 * Associated FORTH word: IF 01140 * 01141 * Inputs: 01142 * Parameters: NONE 01143 * 01144 * Outputs: 01145 * Returned Value: NONE 01146 * Items Pushed onto Control-Stack: 01147 * Top: If_FORw_IF 01148 * FCode Output buffer: 01149 * Token for conditional branch -- b?branch -- followed by 01150 * place-holder of zero for FCode-offset 01151 * 01152 * 01153 **************************************************************************** */ 01154 01155 void emit_if( void ) 01156 { 01157 emit_token("b?branch"); 01158 mark_forward_branch( IF_CSTAG ); 01159 } 01160 01161 /* ************************************************************************** 01162 * 01163 * Function name: emit_then 01164 * Synopsis: All the actions when THEN is encountered; also 01165 * part of another forward-branch resolver's action. 01166 * 01167 * Associated FORTH words: THEN ELSE 01168 * 01169 * Inputs: 01170 * Parameters: NONE 01171 * Local Static Variables: 01172 * control_stack Points to "Top" Control-Structure Tag Group 01173 * Control-Stack Items: 01174 * Top: If_FORw_IF | While_FORw_WHILE 01175 * 01176 * Outputs: 01177 * Returned Value: NONE 01178 * Control-Stack, # of Items Popped: 1 01179 * FCode Output buffer: 01180 * Token for forward-resolve -- b(>resolve) -- then the space 01181 * reserved for the forward-branch FCode-offset is filled 01182 * in so that it reaches the token after the b(>resolve) . 01183 * 01184 * Process Explanation: 01185 * The THEN statement or the ELSE statement must be able to resolve 01186 * a WHILE statement, in order to implement the extended flow- 01187 * -control structures as described in sec. A.3.2.3.2 of the 01188 * ANSI Forth Spec. 01189 * But we must prevent the sequence IF ... BEGIN ... REPEAT from 01190 * compiling as though it were: IF ... BEGIN ... AGAIN THEN 01191 * We do this by having a separate CSTAG for WHILE and allowing 01192 * it here but not allowing the IF_CSTAG when processing REPEAT. 01193 * 01194 **************************************************************************** */ 01195 01196 void emit_then( void ) 01197 { 01198 emit_token("b(>resolve)"); 01199 if ( control_stack != NULL ) 01200 { 01201 if ( control_stack->cs_tag == WHILE_CSTAG ) 01202 { 01203 control_stack->cs_tag = IF_CSTAG; 01204 } 01205 } 01206 resolve_forward( IF_CSTAG ); 01207 } 01208 01209 01210 /* ************************************************************************** 01211 * 01212 * Function name: emit_else 01213 * Synopsis: All the actions when ELSE is encountered 01214 * 01215 * Associated FORTH word: ELSE 01216 * 01217 * Inputs: 01218 * Parameters: NONE 01219 * Global Variables: 01220 * control_stack_depth Current depth of Control Stack 01221 * Local Static Variables: 01222 * not_cs_underflow If this is FALSE after the c-s swap, it 01223 * means an underflow resulted; skip 01224 * the call to resolve the first marker. 01225 * Control-Stack Items: 01226 * Top: {If_FORw_IF}1 01227 * (Datum is OPC of earlier forward-branch; must be resolved.) 01228 * 01229 * Outputs: 01230 * Returned Value: NONE 01231 * Control-Stack, # of Items Popped: 1 01232 * Items Pushed onto Control-Stack: 01233 * Top: {If_FORw_IF}2 01234 * (Datum is current OPC, after forward-branch is placed.) 01235 * FCode Output buffer: 01236 * Token for unconditional branch -- bbranch-- followed by 01237 * place-holder of zero for FCode-offset. Then, token 01238 * for forward-resolve -- b(>resolve) -- and the space 01239 * reserved earlier for the conditional forward-branch 01240 * FCode-offset is filled in to reach the token after 01241 * the b(>resolve) . 01242 * 01243 * Error Detection: 01244 * If the "Control-Stack" is empty, bypass the forward branch 01245 * and let the call to control_structure_swap() report 01246 * the underflow error. Then use not_cs_underflow to 01247 * control whether to resolve the forward-branch. 01248 * 01249 * Process Explanation: 01250 * The final item needed within the scope of what the earlier 01251 * conditional branch might skip is an unconditional branch 01252 * over the "else"-clause to follow. After that, the earlier 01253 * conditional branch needs to be resolved. This last step 01254 * is identical to the action of THEN . 01255 * 01256 **************************************************************************** */ 01257 01258 void emit_else( void ) 01259 { 01260 if ( control_stack_depth > 0 ) 01261 { 01262 emit_token("bbranch"); 01263 mark_forward_branch( IF_CSTAG ); 01264 } 01265 not_cs_underflow = TRUE; 01266 control_structure_swap(); 01267 if ( not_cs_underflow ) 01268 { 01269 emit_then(); 01270 } 01271 } 01272 01273 01274 /* ************************************************************************** 01275 * 01276 * Function name: emit_begin 01277 * Synopsis: All the actions when BEGIN is encountered 01278 * 01279 * Associated FORTH word: BEGIN 01280 * 01281 * Inputs: 01282 * Parameters: NONE 01283 * 01284 * Outputs: 01285 * Returned Value: NONE 01286 * Items Pushed onto Control-Stack: 01287 * Top: Begin_BACKw_BEGIN 01288 * (Datum is current OPC, target of future backward-branch) 01289 * FCode Output buffer: 01290 * Token for target of backward branch -- b(<mark) 01291 * 01292 **************************************************************************** */ 01293 01294 void emit_begin( void ) 01295 { 01296 emit_token("b(<mark)"); 01297 mark_backward_target( BEGIN_CSTAG ); 01298 } 01299 01300 01301 /* ************************************************************************** 01302 * 01303 * Function name: emit_again 01304 * Synopsis: All the actions when AGAIN is encountered 01305 * 01306 * Associated FORTH words: AGAIN REPEAT 01307 * 01308 * Inputs: 01309 * Parameters: NONE 01310 * Control-Stack Items: 01311 * Top: Begin_BACKw_BEGIN 01312 * (Datum is OPC of backward-branch target at BEGIN) 01313 * 01314 * Outputs: 01315 * Returned Value: NONE 01316 * Control-Stack, # of Items Popped: 1 01317 * FCode Output buffer: 01318 * Token for unconditional branch -- bbranch -- followed by 01319 * FCode-offset that reaches just after the b(<mark) 01320 * token at the corresponding BEGIN statement. 01321 * 01322 * Process Explanation: 01323 * The FCode-offset is calculated as the difference between our 01324 * current OPC and the target-OPC saved on the Control-Stack. 01325 * 01326 **************************************************************************** */ 01327 01328 void emit_again( void ) 01329 { 01330 emit_token("bbranch"); 01331 resolve_backward( BEGIN_CSTAG ); 01332 } 01333 01334 /* ************************************************************************** 01335 * 01336 * Function name: emit_until 01337 * Synopsis: All the actions when UNTIL is encountered 01338 * 01339 * Associated FORTH word: UNTIL 01340 * 01341 * Process Explanation: 01342 * Same as AGAIN except token is conditional branch -- b?branch -- 01343 * instead of unconditional. 01344 * 01345 **************************************************************************** */ 01346 01347 void emit_until( void ) 01348 { 01349 emit_token("b?branch"); 01350 resolve_backward( BEGIN_CSTAG ); 01351 } 01352 01353 /* ************************************************************************** 01354 * 01355 * Function name: emit_while 01356 * Synopsis: All the actions when WHILE is encountered 01357 * 01358 * Associated FORTH word: WHILE 01359 * 01360 * Inputs: 01361 * Parameters: NONE 01362 * Global Variables: 01363 * control_stack_depth Number of items on "Control-Stack" 01364 * Control-Stack Items: 01365 * Top: Begin_BACKw_BEGIN 01366 * (Datum is OPC of backward-branch target) 01367 * 01368 * Outputs: 01369 * Returned Value: NONE 01370 * Control-Stack: 1 item added below top item. 01371 * Items on Control-Stack: 01372 * Top: Begin_BACKw_BEGIN 01373 * Next: While_FORw_WHILE 01374 * FCode Output buffer: 01375 * Token for conditional branch -- b?branch -- followed by 01376 * place-holder of zero for FCode-offset 01377 * 01378 * Error Detection: 01379 * If the "Control-Stack" is empty, bypass creating the branch 01380 * and let the call to control_structure_swap() report 01381 * the underflow error. 01382 * 01383 * Process Explanation: 01384 * Output a conditional forward-branch sequence, similar to IF 01385 * (except with a WHILE CSTAG), but be sure to leave the 01386 * control-structure branch-marker that was created by the 01387 * preceding BEGIN on top of the one just generated: 01388 * the BEGIN needs to be resolved first in any case, and 01389 * doing this here is the key to implementing the extended 01390 * control-flow structures as described in sec. A.3.2.3.2 01391 * of the ANSI Forth Spec. 01392 * 01393 * Extraneous Remarks: 01394 * It was for the use of this function that Wil Baden coined the 01395 * name BUT for the control-structure swap routine. The idea 01396 * was that the implementation of WHILE could be boiled down 01397 * to: IF BUT (couldn't quite fit an AND in there...;-} ) 01398 * Naturally, this implementation is a smidgeon more complicated... 01399 * 01400 **************************************************************************** */ 01401 01402 void emit_while( void ) 01403 { 01404 if ( control_stack_depth > 0 ) 01405 { 01406 emit_token("b?branch"); 01407 mark_forward_branch( WHILE_CSTAG ); 01408 } 01409 control_structure_swap(); 01410 } 01411 01412 /* ************************************************************************** 01413 * 01414 * Function name: emit_repeat 01415 * Synopsis: All the actions when REPEAT is encountered 01416 * 01417 * Associated FORTH word: REPEAT 01418 * 01419 * Inputs: 01420 * Parameters: NONE 01421 * Local Static Variables: 01422 * not_cs_underflow If FALSE after first call to resolve marker, 01423 * an underflow resulted; skip second call. 01424 * Control-Stack Items: 01425 * Top: Begin_BACKw_BEGIN 01426 * (Datum is OPC of backward-branch target at BEGIN) 01427 * Next: If_FORw_IF 01428 * (Datum is OPC of FCode-offset place-holder) 01429 * 01430 * Outputs: 01431 * Returned Value: NONE 01432 * Local Static Variables: 01433 * not_consuming_two Cleared, then restored 01434 * Control-Stack, # of Items Popped: 2 01435 * FCode Output buffer: 01436 * Token for unconditional branch -- bbranch -- followed by 01437 * FCode-offset that reaches just after the b(<mark) 01438 * token at the corresponding BEGIN statement. Then 01439 * the token for forward-resolve -- b(>resolve) -- and 01440 * the space reserved for the conditional forward-branch 01441 * FCode-offset is filled in so that it reaches the token 01442 * after the b(>resolve) . 01443 * 01444 * Process Explanation: 01445 * The action is identical to that taken for AGAIN followed 01446 * by the action for THEN. 01447 * The Local Static Variable not_consuming_two gets cleared 01448 * and restored by this routine. 01449 * 01450 **************************************************************************** */ 01451 01452 void emit_repeat( void ) 01453 { 01454 if ( matchup_two_control_structures( BEGIN_CSTAG, WHILE_CSTAG ) ) 01455 { 01456 not_cs_underflow = TRUE; 01457 not_consuming_two = FALSE; 01458 emit_again(); 01459 if ( not_cs_underflow ) 01460 { 01461 emit_token("b(>resolve)"); 01462 resolve_forward( WHILE_CSTAG ); 01463 } 01464 not_consuming_two = TRUE; 01465 } 01466 } 01467 01468 /* ************************************************************************** 01469 * 01470 * Function name: mark_do 01471 * Synopsis: Common routine for marking the branches for 01472 * the "do" variants 01473 * 01474 * Associated FORTH words: DO ?DO 01475 * 01476 * Inputs: 01477 * Parameters: NONE 01478 * 01479 * Outputs: 01480 * Returned Value: NONE 01481 * Global Variables: 01482 * do_loop_depth Incremented 01483 * Items Pushed onto Control-Stack: 01484 * Top: Do_FORw_DO 01485 * Next: Do_BACKw_DO 01486 * FCode Output buffer: 01487 * Place-holder of zero for FCode-offset 01488 * 01489 * Error Detection: 01490 * The do_loop_depth counter will be used by other routines 01491 * to detect misplaced "LEAVE", "UNLOOP", "I" and suchlike. 01492 * (Imbalanced "LOOP" statements are detected by the CSTag 01493 * matching mechanism.) 01494 * 01495 * Process Explanation: 01496 * Just before this function is called, the forward-branching token 01497 * for the "DO" variant that begins the control-structure was 01498 * written to the FCode Output buffer. 01499 * It needs an FCode-offset for a forward-branch to just after 01500 * its corresponding "LOOP" variant and the FCode-offset 01501 * associated therewith. 01502 * That "LOOP" variant's associated FCode-offset is targeted 01503 * to the token that follows the one for this "DO" variant 01504 * and its FCode-offset. 01505 * Mark the forward-branch with the C-S Tag for DO and write a 01506 * place-holder FCode-offset of zero to FCode Output. 01507 * Indicate that the mark that will be processed second (but which 01508 * was made first) is a duplicate of the one that will be 01509 * processed first. 01510 * Then mark the backward-branch target, also with the DO C-S Tag. 01511 * Finally, increment the do_loop_depth counter. 01512 * 01513 * Extraneous Remarks: 01514 * This is more complicated to describe than to code... ;-) 01515 * 01516 **************************************************************************** */ 01517 01518 void mark_do( void ) 01519 { 01520 mark_forward_branch( DO_CSTAG); 01521 control_stack->cs_not_dup = FALSE; 01522 mark_backward_target( DO_CSTAG); 01523 do_loop_depth++; 01524 } 01525 01526 01527 /* ************************************************************************** 01528 * 01529 * Function name: resolve_loop 01530 * Synopsis: Common routine for resolving the branches for 01531 * the "loop" variants. 01532 * 01533 * Associated FORTH words: LOOP +LOOP 01534 * 01535 * Inputs: 01536 * Parameters: NONE 01537 * Global Variables: 01538 * statbuf Word read from input stream (either "loop" 01539 * or "+loop"), used for Error Message. 01540 * Local Static Variables: 01541 * not_cs_underflow If FALSE after first call to resolve marker, 01542 * an underflow resulted; skip second call. 01543 * Control-Stack Items: 01544 * Top: Do_FORw_DO 01545 * Next: Do_BACKw_DO 01546 * 01547 * Outputs: 01548 * Returned Value: NONE 01549 * Global Variables: 01550 * do_loop_depth Decremented 01551 * Local Static Variables: 01552 * not_consuming_two Cleared, then restored 01553 * didnt_print_otl Set, then set again at end. 01554 * Control-Stack, # of Items Popped: 2 01555 * FCode Output buffer: 01556 * FCode-offset that reaches just after the token of the 01557 * corresponding "DO" variant. Then the space reserved 01558 * for the FCode-offset of the forward-branch associated 01559 * with the "DO" variant is filled in so that it reaches 01560 * the token just after the "DO" variant's FCode-offset. 01561 * 01562 * Error Detection: 01563 * A value of zero in do_loop_depth before it's decremented 01564 * indicates a DO ... LOOP imbalance, which is an ERROR, 01565 * but our other error-reporting mechanisms will catch it, 01566 * so we don't check or report it here. 01567 * 01568 * Process Explanation: 01569 * Just before this function is called, the backward-branching 01570 * token for the "LOOP" variant that ends the control-structure 01571 * was written to the FCode Output buffer. 01572 * It needs an FCode-offset for a backward-branch targeted just 01573 * after its corresponding "DO" variant and the FCode-offset 01574 * associated therewith. 01575 * That "DO" variant's associated FCode-offset is targeted to 01576 * the token that follows the one for this "LOOP" variant 01577 * and its FCode-offset. 01578 * Make sure there are two DO C-S Tag entries on the Control Stack. 01579 * Resolve the backward-branch, matching your target to the first 01580 * C-S Tag for DO 01581 * Then resolve the forward-branch, targeting to your new OPC 01582 * position, and also making sure you match the DO C-S Tag. 01583 * We keep track of do_loop_depth for other error-detection 01584 * by decrementing it; make sure it doesn't go below zero. 01585 * Don't bother resolving the forward-branch if we underflowed 01586 * the "Control Stack" trying to resolve the backward-branch. 01587 * If the two top C-S Tag entries are not for a DO statement, the 01588 * matchup_two_control_structures() routine will consume both 01589 * or up to two of them, and we will place a dummy offset of 01590 * zero to follow-up the backward-branching token that has 01591 * already been written. 01592 * 01593 * Extraneous Remarks: 01594 * This is only a little more complicated to describe 01595 * than to code... ;-) 01596 * 01597 **************************************************************************** */ 01598 01599 void resolve_loop( void ) 01600 { 01601 if ( INVERSE( matchup_two_control_structures( DO_CSTAG, DO_CSTAG) ) ) 01602 { 01603 emit_offset( 0 ); 01604 }else{ 01605 not_cs_underflow = TRUE; 01606 didnt_print_otl = TRUE; 01607 not_consuming_two = FALSE; 01608 resolve_backward( DO_CSTAG); 01609 if ( not_cs_underflow ) 01610 { 01611 resolve_forward( DO_CSTAG); 01612 } 01613 if ( do_loop_depth > 0 ) do_loop_depth--; 01614 not_consuming_two = TRUE; 01615 didnt_print_otl = TRUE; /* Might have gotten cleared */ 01616 } 01617 } 01618 01619 /* ************************************************************************** 01620 * 01621 * Function name: emit_case 01622 * Synopsis: All the actions when CASE is encountered 01623 * 01624 * Associated FORTH word: CASE 01625 * 01626 * Inputs: 01627 * Parameters: NONE 01628 * 01629 * Outputs: 01630 * Returned Value: NONE 01631 * Items Pushed onto Control-Stack: 01632 * Top: N_OFs=0...CASE_CSTAG 01633 * (Datum is 0 , Initial count of OF .. ENDOF pairs) 01634 * FCode Output buffer: 01635 * Token for start of a CASE structure -- b(case) 01636 * Does not require an FCode-offset. 01637 * 01638 **************************************************************************** */ 01639 01640 void emit_case( void ) 01641 { 01642 push_cstag( CASE_CSTAG, 0); 01643 emit_token("b(case)"); 01644 } 01645 01646 01647 /* ************************************************************************** 01648 * 01649 * Function name: emit_of 01650 * Synopsis: All the actions when OF is encountered 01651 * 01652 * Associated FORTH word: OF 01653 * 01654 * Inputs: 01655 * Parameters: NONE 01656 * Control-Stack Items: 01657 * Top: N_OFs...CASE_CSTAG 01658 * (Datum is OF-count, number of OF .. ENDOF pairs) 01659 * {Next and beyond}: {Endof_FORw_ENDOF}1..n_ofs 01660 * { Repeat for OF-count number of times } 01661 * 01662 * Outputs: 01663 * Returned Value: NONE 01664 * Control-Stack, 1 Item Pushed, 1 modified: 01665 * Top: Of_FORw_OF 01666 * Next: N_OFs+1...CASE_CSTAG 01667 * (Datum has been incremented) 01668 * {3rd and beyond}: {Endof_FORw_ENDOF}1..n_ofs 01669 * { Repeat for 1 through the un-incremented OF-count } 01670 * (Same as Next etcetera at input-time.) 01671 * FCode Output buffer: 01672 * Token for OF statement -- b(of) -- followed by 01673 * place-holder FCode-offset of zero 01674 * 01675 * Error Detection: 01676 * Matchup CASE-cstag before incrementing OF-count 01677 * 01678 * Process Explanation: 01679 * Main difference between this implementation and that outlined 01680 * in "the book" (see below) is that we do not directly use 01681 * the routine for the IF statement's flow-control; we will 01682 * use a different CSTAG for better mismatch detection. 01683 * 01684 * Extraneous Remarks: 01685 * This is a "by the book" (ANSI Forth spec, section A.3.2.3.2) 01686 * implementation (mostly). Incrementing the OF-count here, 01687 * after we've matched up the CSTAG, gives us (and the user) 01688 * just a little bit more protection... 01689 * 01690 **************************************************************************** */ 01691 01692 void emit_of( void ) 01693 { 01694 01695 if ( matchup_control_structure( CASE_CSTAG ) ) 01696 { 01697 emit_token("b(of)"); 01698 01699 /* 01700 * See comment-block about "Control-Stack" Diagram Notation 01701 * early on in this file. 01702 * 01703 */ 01704 01705 /* ( {Endof_FORw_ENDOF}1..n_ofs N_OFs...CASE_CSTAG -- ) */ 01706 01707 /* Increment the OF-count . */ 01708 (control_stack->cs_datum)++; 01709 01710 /* ( {Endof_FORw_ENDOF}1..n_ofs N_OFs+1...CASE_CSTAG -- ) */ 01711 01712 mark_forward_branch( OF_CSTAG ); 01713 /* ( -- {Endof_FORw_ENDOF}1..n_ofs N_OFs+1...CASE_CSTAG Of_FORw_OF ) 01714 */ 01715 } 01716 /* Leave the CSTAG-Group on the "Control-Stack" . */ 01717 } 01718 01719 01720 /* ************************************************************************** 01721 * 01722 * Function name: emit_endof 01723 * Synopsis: All the actions when ENDOF is encountered 01724 * 01725 * Associated FORTH word: ENDOF 01726 * 01727 * Inputs: 01728 * Parameters: NONE 01729 * Control-Stack Items: 01730 * Top: Of_FORw_OF 01731 * Next: N_OFs+1...CASE_CSTAG 01732 * (Datum has been incremented) 01733 * {3rd and beyond}: {Endof_FORw_ENDOF}1..n_ofs 01734 * { Repeat for 1 through the un-incremented OF-count ) 01735 * 01736 * Outputs: 01737 * Returned Value: NONE 01738 * Control-Stack, 1 Item Popped, 1 new Item Pushed. 01739 * Top: N_OFs...CASE_CSTAG 01740 * (The count itself is unchanged from input-time, but 01741 * the number of {Endof_FORw_ENDOF} CSTAG-Groups 01742 * has caught up with this number, so it is 01743 * no longer notated as " + 1 "). 01744 * {Next and beyond}: {Endof_FORw_ENDOF}1..n_ofs 01745 * { Repeat for 1 through the updated OF-count ) 01746 * FCode Output buffer: 01747 * Token for ENDOF statement -- b(endof) -- followed by 01748 * place-holder FCode-offset of zero. Then the space reserved 01749 * for the FCode-offset of the forward-branch associated 01750 * with the "OF" statement is filled in so that it reaches 01751 * the token just after the "ENDOF" statement's FCode-offset. 01752 * 01753 * Error Detection: 01754 * If control-stack depth is not at least 2, CS underflow ERROR 01755 * and no further action. 01756 * Routine that resolves the forward-branch checks for matchup error. 01757 * 01758 **************************************************************************** */ 01759 01760 void emit_endof( void ) 01761 { 01762 if ( control_stack_size_test( 2) ) 01763 { 01764 emit_token("b(endof)"); 01765 01766 /* See "Control-Stack" Diagram Notation comment-block */ 01767 01768 /* Stack-diagrams might need to be split across lines. */ 01769 01770 /* ( {Endof_FORw_ENDOF}1..n_ofs N_OFs+1...CASE_CSTAG ... 01771 * ... Of_FORw_OF -- ) 01772 */ 01773 mark_forward_branch(ENDOF_CSTAG); 01774 /* ( -- {Endof_FORw_ENDOF}1..n_ofs N_OFs+1...CASE_CSTAG ... 01775 * ... Of_FORw_OF {Endof_FORw_ENDOF}n_ofs+1 ) 01776 */ 01777 01778 control_structure_swap(); 01779 /* ( -- {Endof_FORw_ENDOF}1..n_ofs N_OFs+1...CASE_CSTAG ... 01780 * ... {Endof_FORw_ENDOF}n_ofs+1 Of_FORw_OF ) 01781 */ 01782 01783 resolve_forward( OF_CSTAG ); 01784 /* ( -- {Endof_FORw_ENDOF}1..n_ofs N_OFs+1...CASE_CSTAG ... 01785 * ... {Endof_FORw_ENDOF}n_ofs+1 ) 01786 */ 01787 01788 control_structure_swap(); 01789 /* ( -- {Endof_FORw_ENDOF}1..n_ofs ... 01790 * ... {Endof_FORw_ENDOF}n_ofs+1 ... 01791 * ... N_OFs+1...CASE_CSTAG ) 01792 */ 01793 01794 /* The number of ENDOF-tagged Forward-Marker pairs has now 01795 * caught up with the incremented OF-count; therefore, 01796 * we can notate the above as: 01797 * 01798 * ( {Endof_FORw_ENDOF}1..n_ofs N_OFs CASE_CSTAG ) 01799 * 01800 * and we are ready for another OF ... ENDOF pair, 01801 * or for the ENDCASE statement. 01802 */ 01803 } 01804 01805 } 01806 01807 /* ************************************************************************** 01808 * 01809 * Function name: emit_endcase 01810 * Synopsis: All the actions when ENDCASE is encountered 01811 * 01812 * Associated FORTH word: ENDCASE 01813 * 01814 * Inputs: 01815 * Parameters: NONE 01816 * Control-Stack Items: 01817 * Top: N_OFs...CASE_CSTAG 01818 * (Datum is OF-count, number of OF .. ENDOF pairs) 01819 * {Next and beyond}: {Endof_FORw_ENDOF}1..n_ofs 01820 * { Repeat for OF-count number of times } 01821 * 01822 * Outputs: 01823 * Returned Value: NONE 01824 * Control-Stack, # of Items Popped: OF-count + 1 01825 * FCode Output buffer: 01826 * Token for ENDCASE statement -- b(endcase) 01827 * Then the spaces reserved for the FCode-offsets of all the 01828 * forward-branches associated with the OF-count number 01829 * of ENDOF statements are filled in so that they reach 01830 * the token just after this "ENDCASE" statement. 01831 * 01832 * Error Detection: 01833 * Routine that resolves the forward-branch checks for matchup error 01834 * for each forward-branch filled in, plus the matchup routine 01835 * checks before the OF-count is retrieved. 01836 * 01837 * Process Explanation: 01838 * Retrieve the OF-count and resolve that number of ENDOF statements 01839 * 01840 * Extraneous Remarks: 01841 * The setup makes coding this routine appear fairly simple... ;-} 01842 * 01843 **************************************************************************** */ 01844 01845 void emit_endcase( void ) 01846 { 01847 unsigned long n_endofs ; 01848 if ( matchup_control_structure( CASE_CSTAG) ) 01849 { 01850 int indx; 01851 01852 emit_token("b(endcase)"); 01853 n_endofs = control_stack->cs_datum; 01854 for ( indx = 0 ; indx < n_endofs ; indx++ ) 01855 { 01856 /* Because matchup_control_structure doesn't pop the 01857 * control-stack, we have the N_OFs...CASE_CSTAG 01858 * item on top of the Endof_FORw_ENDOF item we 01859 * want to resolve. We need to keep it there so 01860 * the POP is valid for the other path as well 01861 * as at the end of this one. 01862 * So we SWAP to get at the Endof_FORw_ENDOF item. 01863 */ 01864 control_structure_swap(); 01865 resolve_forward( ENDOF_CSTAG); 01866 } 01867 } 01868 pop_cstag(); 01869 } 01870 01871 01872 /* ************************************************************************** 01873 * 01874 * Function name: control_struct_incomplete 01875 * Synopsis: Print a Message of given severity with origin info for 01876 * a control-structure that has not been completed. 01877 * 01878 * Inputs: 01879 * Parameters: 01880 * c_s_entry Control-structure about which to display 01881 * severity Severity of the messages to display. 01882 * call_cond String identifying Calling Condition; 01883 * used in the message. 01884 * 01885 * Outputs: 01886 * Returned Value: NONE 01887 * 01888 * Printout: 01889 * Message of given severity... 01890 * 01891 * Process Explanation: 01892 * The calling routine will be responsible for all filtering of 01893 * duplicate structures and the like. This routine will 01894 * simply display a message. 01895 * 01896 **************************************************************************** */ 01897 01898 static void control_struct_incomplete( 01899 int severity, 01900 char *call_cond, 01901 cstag_group_t *c_s_entry) 01902 { 01903 tokenization_error ( severity, 01904 "%s before completion of %s" , 01905 call_cond, strupr(c_s_entry->cs_word)); 01906 where_started( c_s_entry->cs_inp_fil, c_s_entry->cs_line_num ); 01907 } 01908 01909 /* ************************************************************************** 01910 * 01911 * Function name: announce_control_structs 01912 * Synopsis: Print a series of Messages (of severity as specified) 01913 * announcing that the calling event is occurring 01914 * in the context of Control-Flow structure(s), 01915 * back to the given limit. Leave the control 01916 * structures in effect. 01917 * 01918 * Inputs: 01919 * Parameters: 01920 * severity Severity of the messages to display. 01921 * call_cond String identifying Calling Condition; 01922 * used in the message. 01923 * abs_token_limit Limit, in terms of abs_token_no 01924 * Local Static Variables: 01925 * control_stack Pointer to "Top" of "Control-Stack" 01926 * 01927 * Outputs: 01928 * Returned Value: NONE 01929 * Printout: 01930 * A Message for each unresolved Control-Flow structure. 01931 * 01932 **************************************************************************** */ 01933 01934 void announce_control_structs( int severity, char *call_cond, 01935 unsigned int abs_token_limit) 01936 { 01937 cstag_group_t *cs_temp = control_stack; 01938 while ( cs_temp != NULL ) 01939 { 01940 if ( cs_temp->cs_abs_token_num < abs_token_limit ) 01941 { 01942 break; 01943 } 01944 if ( cs_temp->cs_not_dup ) 01945 { 01946 control_struct_incomplete( severity, call_cond, cs_temp ); 01947 } 01948 cs_temp = cs_temp->prev; 01949 } 01950 } 01951 01952 /* ************************************************************************** 01953 * 01954 * Function name: clear_control_structs_to_limit 01955 * Synopsis: Clear items from the "Control-Stack" back to the given 01956 * limit. Print error-messages with origin info for 01957 * control-structures that have not been completed. 01958 * 01959 * Inputs: 01960 * Parameters: 01961 * call_cond String identifying Calling Condition; 01962 * used in the Error message. 01963 * abs_token_limit Limit, in terms of abs_token_no 01964 * Global Variables: 01965 * control_stack_depth Number of items on "Control-Stack" 01966 * control_stack Pointer to "Top" of "Control-Stack" 01967 * Control-Stack Items: 01968 * The cs_inp_fil and cs_line_num tags of any item cleared 01969 * from the "Control-Stack" are used in error-messages. 01970 * 01971 * Outputs: 01972 * Returned Value: 01973 * Global Variables: 01974 * do_loop_depth Decremented when "DO" item cleared. 01975 * control_stack_depth Decremented by called routine. 01976 * Control-Stack, # of Items Popped: As many as go back to given limit 01977 * Memory Freed 01978 * By called routine. 01979 * 01980 * Error Detection: 01981 * Any item on the "Control-Stack" represents a Control-Structure 01982 * that was not completed when the Calling Condition was 01983 * encountered. Error; identify the origin of the structure. 01984 * No special actions if noerrors is set. 01985 * 01986 * Process Explanation: 01987 * The given limit corresponds to the value of abs_token_no at 01988 * the time the colon-definition (or whatever...) was created. 01989 * Any kind of Control-Structure imbalance at the end of the 01990 * colon-definition is an error and the entries must be cleared, 01991 * but the colon-definition may have been created inside nested 01992 * interpretation-time Control-Structures, and those must be 01993 * preserved. 01994 * 01995 * Of course, if this routine is called with a given limit of zero, 01996 * that would mean all the entries are to be cleared. That will 01997 * be the way clear_control_structs() is implemented. 01998 * We control the loop by the cs_abs_token_num field, but also 01999 * make sure we haven't underflowed control_stack_depth 02000 * We skip messages and other processing for items that are duplicates 02001 * of others, based on the cs_not_dup field. 02002 * If the cs_tag field is DO_CSTAG we decrement do_loop_depth 02003 * The pop_cstag() routine takes care of the rest. 02004 * 02005 * Extraneous Remarks: 02006 * This is a retrofit; necessary because we now permit definitions 02007 * to occur inside interpretation-time Control-Structures. Calls 02008 * to clear_control_structs() are already scattered around... 02009 * 02010 **************************************************************************** */ 02011 02012 void clear_control_structs_to_limit( char *call_cond, 02013 unsigned int abs_token_limit) 02014 { 02015 while ( control_stack_depth > 0 ) 02016 { 02017 if ( control_stack->cs_abs_token_num < abs_token_limit ) 02018 { 02019 break; 02020 } 02021 if ( control_stack->cs_not_dup ) 02022 { 02023 control_struct_incomplete( TKERROR, call_cond, control_stack ); 02024 if ( control_stack->cs_tag == DO_CSTAG) do_loop_depth--; 02025 } 02026 pop_cstag(); 02027 } 02028 } 02029 02030 /* ************************************************************************** 02031 * 02032 * Function name: clear_control_structs 02033 * Synopsis: Make sure the "Control-Stack" is cleared, and print 02034 * error-messages (giving origin information) for 02035 * control-structures that have not been completed. 02036 * 02037 * Inputs: 02038 * Parameters: 02039 * call_cond String identifying Calling Condition; 02040 * used in the Error message. 02041 * Global Variables: 02042 * control_stack_depth Number of items on "Control-Stack" 02043 * control_stack Pointer to "Top" of "Control-Stack" 02044 * Control-Stack Items: 02045 * The cs_inp_fil and cs_line_num tags of any item found on 02046 * the "Control-Stack" are used in error-messages. 02047 * 02048 * Outputs: 02049 * Returned Value: NONE 02050 * Global Variables: 02051 * control_stack_depth Reset to zero. 02052 * do_loop_depth Reset to zero. 02053 * Control-Stack, # of Items Popped: All of them 02054 * 02055 * Error Detection: 02056 * Any item on the "Control-Stack" represents a Control-Structure 02057 * that was not completed when the Calling Condition was 02058 * encountered. Error; identify the origin of the structure. 02059 * No special actions if noerrors is set. 02060 * 02061 * Process Explanation: 02062 * Filter the duplicate messages caused by structures (e.g., DO) 02063 * that place two entries on the "Control-Stack" by testing 02064 * the cs_not_dup field of the "Top" "Control-Stack" item, 02065 * which would indicate double-entry... 02066 * 02067 * Extraneous Remarks: 02068 * This is called before a definition of any kind, and after a 02069 * colon-definition. Flow-control constructs should *never* 02070 * be allowed to cross over between immediate-execution mode 02071 * and compilation mode. Likewise, not between device-nodes. 02072 * Also, at the end of tokenization, there should not be any 02073 * unresolved flow-control constructs. 02074 * 02075 **************************************************************************** */ 02076 02077 void clear_control_structs( char *call_cond) 02078 { 02079 clear_control_structs_to_limit( call_cond, 0); 02080 }