Main Page | Data Structures | File List | Data Fields | Globals

flowcontrol.c

Go to the documentation of this file.
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 }

Generated on Fri Aug 18 14:03:39 2006 for Toke1.0 by  doxygen 1.4.4