Part XI: LEXICAL SCAN REVISITED (3rd Jun 1989)

INTRODUCTION

I've got some good news and some bad news. The bad news is that this installment is not the one I promised last time. What's more, the one after this one won't be, either.

The good news is the reason for this installment: I’ve found a way to simplify and improve the lexical scanning part of the compiler. Let me explain.

BACKGROUND

If you'll remember, we talked at length about the subject of lexical scanners in Part VII, and I left you with a design for a distributed scanner that I felt was about as simple as I could make it ... more than most that I've seen elsewhere. We used that idea in Part X. The compiler structure that resulted was simple, and it got the job done.

Recently, though, I've begun to have problems, and they're the kind that send a message that you might be doing something wrong.

The whole thing came to a head when I tried to address the issue of semicolons. Several people have asked me about them, and whether or not KISS will have them separating the statements. My intention has been NOT to use semicolons, simply because I don't like them and, as you can see, they have not proved necessary.

But I know that many of you, like me, have gotten used to them, and so I set out to write a short installment to show you how they could easily be added, if you were so inclined.

Well, it turned out that they weren't easy to add at all. In fact it was darned difficult.

I guess I should have realized that something was wrong, because of the issue of newlines. In the last couple of installments we've addressed that issue, and I’ve shown you how to deal with newlines with a procedure called, appropriately enough, NewLine. In TINY Version 1.0, I sprinkled calls to this procedure in strategic spots in the code.

It seems that every time I've addressed the issue of newlines, though, I've found it to be tricky, and the resulting parser turned out to be quite fragile ... one addition or deletion here or there and things tended to go to pot. Looking back on it, I realize that there was a message in this that I just wasn't paying attention to.

When I tried to add semicolons on top of the newlines that was the last straw. I ended up with much too complex a solution. I began to realize that something fundamental had to change.

So, in a way this installment will cause us to backtrack a bit and revisit the issue of scanning all over again. Sorry about that. That's the price you pay for watching me do this in real time. But the new version is definitely an improvement, and will serve us well for what is to come.

As I said, the scanner we used in Part X was about as simple as one can get. But anything can be improved. The new scanner is more like the classical scanner, and not as simple as before. But the overall compiler structure is even simpler than before. It's also more robust, and easier to add to and/or modify. I think that's worth the time spent in this digression. So in this installment, I'll be showing you the new structure. No doubt you'll be happy to know that, while the changes affect many procedures, they aren't very profound and so we lose very little of what's been done so far.

Ironically, the new scanner is much more conventional than the old one, and is very much like the more generic scanner I showed you earlier in Part VII. Then I started trying to get clever, and I almost clevered myself clean out of business. You'd think one day I'd learn: K-I-S-S!

THE PROBLEM

The problem begins to show itself in procedure Block, which I've reproduced below: 

{---------------------------}
procedure Block;
{ Parse and Translate a Block of Statements }
begin
  Scan;
  while not(Token in ['e', 'l']) do begin
    case Token of
      'i': DoIf;
      'w': DoWhile;
      'R': DoRead;
      'W': DoWrite;
      else Assignment;
    end;
    Scan;
  end;
end;

{---------------------------}

As you can see, Block is oriented to individual program statements. At each pass through the loop, we know that we are at the beginning of a statement. We exit the block when we have scanned an END or an ELSE.

But suppose that we see a semicolon instead. The procedure as it's shown above can’t handle that, because procedure Scan only expects and can only accept tokens that begin with a letter.

I tinkered around for quite awhile to come up with a fix. I found many possible approaches, but none were very satisfying. I finally figured out the reason.

Recall that when we started with our single-character parsers, we adopted a convention that the lookahead character would always be pre-fetched. That is, we would have the character that corresponds to our current position in the input stream fetched into the global character Look, so that we could examine it as many times as needed. The rule we adopted was that EVERY recognizer, if it found its target token, would advance Look to the next character in the input stream.

That simple and fixed convention served us very well when we had single-character tokens, and it still does. It would make a lot of sense to apply the same rule to multi-character tokens.

But when we got into lexical scanning, I began to violate that simple rule. The scanner of Part X did indeed advance to the next token if it found an identifier or keyword, but it DIDN'T do that if it found a carriage return, a white-space character, or an operator.

Now, that sort of mixed-mode operation gets us into deep trouble in procedure Block, because whether or not the input stream has been advanced depends upon the kind of token we encounter. If it’s a keyword or the target of an assignment statement, the "cursor," as defined by the contents of Look, has been advanced to the next token OR to the beginning of white-space. If, on the other hand, the token is a semicolon, or if we have hit a carriage return, the cursor has NOT advanced.

Needless to say, we can add enough logic to keep us on track. But it's tricky, and makes the whole parser very fragile.

There's a much better way, and that's just to adopt that same rule that's worked so well before, to apply to TOKENS as well as single characters. In other words, we'll pre-fetch tokens just as we've always done for characters. It seems so obvious once you think about it that way.

Interestingly enough, if we do things this way the problem that we've had with newline characters goes away. We can just lump them in as white-space characters, which means that the handling of newlines becomes very trivial, and MUCH less prone to error than we've had to deal with in the past.

THE SOLUTION

Let's begin to fix the problem by re-introducing the two procedures: 

{---------------------------}
procedure GetName;
{ Get an Identifier }
begin
  SkipWhite;
  if Not IsAlpha(Look) then
    Expected('Identifier');
  Token := 'x';
  Value := '';
  repeat
    Value := Value + UpCase(Look);
    GetChar;
  until not IsAlNum(Look);
end;

{---------------------------}
procedure GetNum;
{ Get a Number }
begin
  SkipWhite;
  if not IsDigit(Look) then
    Expected('Number');
  Token := '#';
  Value := '';
  repeat
    Value := Value + Look;
    GetChar;
  until not IsDigit(Look);
end;

{---------------------------}

These two procedures are functionally almost identical to the ones I showed you in Part VII. They each fetch the current token, either an identifier or a number, into the global string Value. They also set the encoded version, Token, to the appropriate code. The input stream is left with Look containing the first character NOT part of the token.

We can do the same thing for operators, even multi-character operators, with a procedure such as: 

{---------------------------}
procedure GetOp;
{ Get an Operator }
begin
  Token := Look;
  Value := '';
  repeat
    Value := Value + Look;
    GetChar;
  until IsAlpha(Look) or IsDigit(Look) or IsWhite(Look);
end;

{---------------------------}

Note that GetOp returns, as its encoded token, the FIRST character of the operator. This is important, because it means that we can now use that single character to drive the parser, instead of the lookahead character.

We need to tie these procedures together into a single procedure that can handle all three cases. The following procedure will read any one of the token types and always leave the input stream advanced beyond it: 

{---------------------------}
procedure Next;
{ Get the Next Input Token }
begin
  SkipWhite;
  if IsAlpha(Look) then 
    GetName
  else 
    if IsDigit(Look) then 
      GetNum
    else 
      GetOp;
end;

{---------------------------}

***NOTE that here I have put SkipWhite BEFORE the calls rather than after. This means that, in general, the variable Look will NOT have a meaningful value in it, and therefore we should NOT use it as a test value for parsing, as we have been doing so far. That's the big departure from our normal approach.

Now, remember that before I was careful not to treat the carriage return (CR) and line feed (LF) characters as white space. This was because, with SkipWhite called as the last thing in the scanner, the encounter with LF would trigger a read statement. If we were on the last line of the program, we couldn't get out until we input another line with a non-white character. That's why I needed the second procedure, NewLine, to handle the CRLF's.

But now, with the call to SkipWhite coming first, that's exactly the behaviour we want. The compiler must know there's another token coming or it wouldn't be calling Next. In other words, it hasn't found the terminating END yet. So we're going to insist on more data until we find something.

All this means that we can greatly simplify both the program and the concepts, by treating CR and LF as white-space characters, and eliminating NewLine. You can do that simply by modifying the function IsWhite: 

{---------------------------}
function IsWhite(c: char): boolean;
{ Recognize White Space }
begin
  IsWhite := c in [' ', TAB, CR, LF];
end;

{---------------------------}

We've already tried similar routines in Part VII, but you might as well try these new ones out. Add them to a copy of the Cradle and call Next with the following main program: 

{---------------------------}
{ Main Program }
begin
  Init;
  repeat
    Next;
    WriteLn(Token, ' ', Value);
  until Token = '.';
end.

{---------------------------}

Compile it and verify that you can separate a program into a series of tokens, and that you get the right encoding for each token.

This ALMOST works, but not quite. There are two potential problems: First, in KISS/TINY almost all of our operators are single-character operators. The only exceptions are the relops >=, <=, and <>. It seems a shame to treat all operators as strings and do a string compare, when only a single character compare will almost always suffice. Second, and much more important, the thing doesn’t WORK when two operators appear together, as in (a+b)*(c+d). Here the string following 'b' would be interpreted as a single operator ")*(".

It's possible to fix that problem. For example, we could just give GetOp a list of legal characters, and we could treat the parentheses as different operator types than the others. But this begins to get messy.

Fortunately, there's a better way that solves all the problems. Since almost all the operators are single characters, let's just treat them that way, and let GetOp get only one character at a time. This not only simplifies GetOp, but also speeds things up quite a bit. We still have the problem of the relops, but we were treating them as special cases anyway.

So here's the final version of GetOp: 

{---------------------------}
procedure GetOp;
{ Get an Operator }
begin
  SkipWhite;
  Token := Look;
  Value := Look;
  GetChar;
end;

{---------------------------}

Note that I still give the string Value a value. If you're truly concerned about efficiency, you could leave this out. When we're expecting an operator, we will only be testing Token anyhow, so the value of the string won't matter. But to me it seems to be good practice to give the thing a value just in case.

Try this new version with some realistic-looking code. You should be able to separate any program into its individual tokens, with the caveat that the two-character relops will scan into two separate tokens. That's OK... we'll parse them that way.

Now, in Part VII the function of Next was combined with procedure Scan, which also checked every identifier against a list of keywords and encoded each one that was found. As I mentioned at the time, the last thing we would want to do is to use such a procedure in places where keywords should not appear, such as in expressions. If we did that, the keyword list would be scanned for every identifier appearing in the code. Not good.

The right way to deal with that is to simply separate the functions of fetching tokens and looking for keywords. The version of Scan shown below does NOTHING but check for keywords. Notice that it operates on the current token and does NOT advance the input stream. 

{---------------------------}
procedure Scan;
{ Scan the Current Identifier for Keywords }
begin
  if Token = 'x' then
    Token := KWcode[Lookup(Addr(KWlist), Value, NKW) + 1];
end;

{---------------------------}

There is one last detail. In the compiler there are a few places that we must actually check the string value of the token. Mainly, this is done to distinguish between the different END's, but there are a couple of other places. (I should note in passing that we could always eliminate the need for matching END characters by encoding each one to a different character.  Right now we are definitely taking the lazy man's route.)

The following version of MatchString takes the place of the character-oriented Match. Note that, like Match, it DOES advance the input stream. 

{---------------------------}
procedure MatchString(x: string);
{ Match a Specific Input String }
begin
  if Value <> x then
    Expected('''' + x + '''');
  Next;
end;

{---------------------------}

FIXING UP THE COMPILER

Armed with these new scanner procedures, we can now begin to fix the compiler to use them properly. The changes are all quite minor,  but  there  are quite a  few  places  where  changes  are necessary. Rather than showing you each place, I will give you the general idea and then just give the finished product.

First of all, the code for procedure Block doesn't change, though its function does: 

{---------------------------}
procedure Block;
{ Parse and Translate a Block of Statements }
begin
  Scan;
  while not(Token in ['e', 'l']) do begin
    case Token of
      'i': DoIf;
      'w': DoWhile;
      'R': DoRead;
      'W': DoWrite;
      else Assignment;
    end;
    Scan;
  end;
end;

{---------------------------}

Remember that the new version of Scan doesn’t advance the input stream, it only scans for keywords. The input stream must be advanced by each procedure that Block calls.

In general, we have to replace every test on Look with a similar test on Token. For example: 

{---------------------------}
procedure BoolExpression;
{ Parse and Translate a Boolean Expression }
begin
  BoolTerm;
  while IsOrOp(Token) do begin
    Push;
    case Token of
      '|': BoolOr;
      '~': BoolXor;
    end;
  end;
end;

{---------------------------}

In procedures like Add, we don't have to use Match anymore. We need only call Next to advance the input stream: 

{---------------------------}
procedure Add;
{ Recognize and Translate an Add }
begin
  Next;
  Term;
  PopAdd;
end;

{---------------------------}

Control structures are actually simpler. We just call Next to advance over the control keywords: 

{---------------------------}
procedure Block; Forward;

procedure DoIf;
{ Recognize and Translate an IF Construct }
var 
  L1, L2: string;
begin
  Next;
  BoolExpression;
  L1 := NewLabel;
  L2 := L1;
  BranchFalse(L1);
  Block;
  if Token = 'l' then begin
    Next;
    L2 := NewLabel;
    Branch(L2);
    PostLabel(L1);
    Block;
  end;
  PostLabel(L2);
  MatchString('ENDIF');
end;

{---------------------------}

That's about the extent of the REQUIRED changes. In the listing of TINY Version 1.1 below, I've also made a number of other "improvements" that aren't really required. Let me explain them briefly:

  1. I've deleted the two procedures Prog and Main, and combined their functions into the main program. They didn't seem to add to program clarity... in fact they seemed to just muddy things up a little.
  2. I've deleted the keywords PROGRAM and BEGIN from the keyword list. Each one only occurs in one place, so it's not necessary to search for it.
  3. Having been bitten by an overdose of cleverness, I've reminded myself that TINY is supposed to be a minimalist program. Therefore I’ve replaced the fancy handling of unary minus with the dumbest one I could think of. A giant step backwards in code quality, but a great simplification of the compiler. KISS is the right place to use the other version.
  4. I've added some error-checking routines such as CheckTable and CheckDup, and replaced in-line code by calls to them. This cleans up a number of routines.
  5. I've taken the error checking out of code generation routines like Store, and put it in the parser where it belongs. See Assignment, for example.
  6. There was an error in InTable and Locate that caused them to search all locations instead of only those with valid data in them. They now search only valid cells. This allows us to eliminate the initialization of the symbol table, which was done in Init.
  7. Procedure AddEntry now has two arguments, which helps to make things a bit more modular.
  8. I've cleaned up the code for the relational operators by the addition of the new procedures CompareExpression and NextExpression.
  9. I fixed an error in the Read routine... the earlier value did not check for a valid variable name.

CONCLUSION

The resulting compiler for TINY is given below. Other than the removal of the keyword PROGRAM, it parses the same language as before. It's just a bit cleaner, and more importantly it’s considerably more robust. I feel good about it.

The next installment will be another digression: the discussion of semicolons and such that got me into this mess in the first place. THEN we'll press on into procedures and types. Hang in there with me. The addition of those features will go a long way towards removing KISS from the "toy language" category. We're getting very close to being able to write a serious compiler.

TINY VERSION 1.1

Motorola 68000

Intel 8086

 
{---------------------------}
program Tiny11;

{---------------------------}
{ Constant Declarations }
const
  TAB = ^I;
  CR  = ^M;
  LF  = ^J;

  LCount: integer = 0;
  NEntry: integer = 0;


{---------------------------}
{ Type Declarations }
type
  Symbol = string[8];
  SymTab = array[1..1000] of Symbol;
  TabPtr = ^SymTab;


{---------------------------}
{ Variable Declarations }
var
  Look : char;        { Lookahead Character }
  Token: char;        { Encoded Token       }
  Value: string[16];  { Unencoded Token     }


const
  MaxEntry = 100;

var
  ST   : array[1..MaxEntry] of Symbol;
  SType: array[1..MaxEntry] of char;


{---------------------------}
{ Definition of Keywords and Token Types }
const 
  NKW =   9;
  NKW1 = 10;

const
  KWlist: array[1..NKW] of Symbol =
          ('IF', 'ELSE', 'ENDIF', 'WHILE', 'ENDWHILE',
           'READ', 'WRITE', 'VAR', 'END');

const
  KWcode: string[NKW1] = 'xileweRWve';


{---------------------------}
procedure GetChar;
{ Read New Character From Input Stream }
begin
  Read(Look);
end;

{---------------------------}
procedure Error(s: string);
{ Report an Error }
begin
  WriteLn;
  WriteLn(^G, 'Error: ', s, '.');
end;

{---------------------------}
procedure Abort(s: string);
{ Report Error and Halt }
begin
  Error(s);
  Halt;
end;

{---------------------------}
procedure Expected(s: string);
{ Report What Was Expected }
begin
  Abort(s + ' Expected');
end;

{---------------------------}
procedure Undefined(n: string);
{ Report an Undefined Identifier }
begin
  Abort('Undefined Identifier ' + n);
end;

{---------------------------}
procedure Duplicate(n: string);
{ Report a Duplicate Identifier }
begin
  Abort('Duplicate Identifier ' + n);
end;

{---------------------------}
procedure CheckIdent;
{ Check to Make Sure the 
  Current Token is an Identifier }
begin
  if Token <> 'x' then 
    Expected('Identifier');
end;

{---------------------------}
function IsAlpha(c: char): boolean;
{ Recognize an Alpha Character }
begin
  IsAlpha := UpCase(c) in ['A'..'Z'];
end;

{---------------------------}
function IsDigit(c: char): boolean;
{ Recognize a Decimal Digit }
begin
  IsDigit := c in ['0'..'9'];
end;

{---------------------------}
function IsAlNum(c: char): boolean;
{ Recognize an AlphaNumeric Character }
begin
  IsAlNum := IsAlpha(c) or IsDigit(c);
end;

{---------------------------}
function IsAddop(c: char): boolean;
{ Recognize an Addop }
begin
  IsAddop := c in ['+', '-'];
end;

{---------------------------}
function IsMulop(c: char): boolean;
{ Recognize a Mulop }
begin
  IsMulop := c in ['*', '/'];
end;

{---------------------------}
function IsOrop(c: char): boolean;
{ Recognize a Boolean Orop }
begin
  IsOrop := c in ['|', '~'];
end;

{---------------------------}
function IsRelop(c: char): boolean;
{ Recognize a Relop }
begin
  IsRelop := c in ['=', '#', '<', '>'];
end;

{---------------------------}
function IsWhite(c: char): boolean;
{ Recognize White Space }
begin
  IsWhite := c in [' ', TAB, CR, LF];
end;

{---------------------------}
procedure SkipWhite;
{ Skip Over Leading White Space }
begin
  while IsWhite(Look) do
    GetChar;
end;

{---------------------------}
function Lookup(T: TabPtr; s: string; n: integer): integer;
{ Table Lookup }
var 
  i: integer;
  found: Boolean;
begin
  found := false;
  i := n;
  while (i > 0) and not found do
    if s = T^[i] then
      found := true
    else
      dec(i);
  Lookup := i;
end;

{---------------------------}
function Locate(N: Symbol): integer;
{ Locate a Symbol in Table }
{ Returns the index of the entry.
  Zero if not present. }
begin
  Locate := Lookup(@ST, n, NEntry);
end;

{---------------------------}
function InTable(n: Symbol): Boolean;
{ Look for Symbol in Table }
begin
  InTable := Lookup(@ST, n, NEntry) <> 0;
end;

{---------------------------}
procedure CheckTable(N: Symbol);
{ Check to See if an Identifier}
{ is in the Symbol Table       }
{ Report an error if it's not. }
begin
  if not InTable(N) then
    Undefined(N);
end;

{---------------------------}
procedure CheckDup(N: Symbol);
{ Check the Symbol Table for 
  a Duplicate Identifier }
{ Report an error if identifier 
  is already in table. }
begin
  if InTable(N) then
    Duplicate(N);
end;

{---------------------------}
procedure AddEntry(N: Symbol; T: char);
{ Add a New Entry to Symbol Table }
begin
  CheckDup(N);
  if NEntry = MaxEntry then
    Abort('Symbol Table Full');
  Inc(NEntry);
  ST[NEntry] := N;
  SType[NEntry] := T;
end;

{---------------------------}
procedure GetName;
{ Get an Identifier }
begin
  SkipWhite;
  if Not IsAlpha(Look) then
    Expected('Identifier');
  Token := 'x';
  Value := '';
  repeat
    Value := Value + UpCase(Look);
    GetChar;
  until not IsAlNum(Look);
end;

{---------------------------}
procedure GetNum;
{ Get a Number }
begin
  SkipWhite;
  if not IsDigit(Look) then
    Expected('Number');
  Token := '#';
  Value := '';
  repeat
    Value := Value + Look;
    GetChar;
  until not IsDigit(Look);
end;

{---------------------------}
procedure GetOp;
{ Get an Operator }
begin
  SkipWhite;
  Token := Look;
  Value := Look;
  GetChar;
end;

{---------------------------}
procedure Next;
{ Get the Next Input Token }
begin
  SkipWhite;
  if IsAlpha(Look) then 
    GetName
  else 
    if IsDigit(Look) then
      GetNum
    else
      GetOp;
end;

{---------------------------}
procedure Scan;
{ Scan the Current Identifier for Keywords }
begin
  if Token = 'x' then
    Token := KWcode[Lookup(Addr(KWlist), Value, NKW) + 1];
end;

{---------------------------}
procedure MatchString(x: string);
{ Match a Specific Input String }
begin
  if Value <> x then
    Expected('''' + x + '''');
  Next;
end;

{---------------------------}
procedure Emit(s: string);
{ Output a String with Tab }
begin
  Write(TAB, s);
end;

{---------------------------}
procedure EmitLn(s: string);
{ Output a String with Tab and CRLF }
begin
  Emit(s);
  WriteLn;
end;

{---------------------------}
function NewLabel: string;
{ Generate a Unique Label }
var
  S: string;
begin
  Str(LCount, S);
  NewLabel := 'L' + S;
  Inc(LCount);
end;

{---------------------------}
procedure PostLabel(L: string);
{ Post a Label To Output }
begin
  WriteLn(L, ':');
end;

{---------------------------}
procedure Clear;
{ Clear the Primary Register }
begin
  EmitLn('CLR D0');
end;

{---------------------------}
procedure Negate;
{ Negate the Primary Register }
begin
  EmitLn('NEG D0');
end;

{---------------------------}
procedure NotIt;
{ Complement the Primary Register }
begin
  EmitLn('NOT D0');
end;

{---------------------------}
procedure LoadConst(n: string);
{ Load a Constant Value to Primary Register }
begin
  Emit('MOVE #');
  WriteLn(n, ',D0');
end;

{---------------------------}
procedure LoadVar(Name: string);
{ Load a Variable to Primary Register }
begin
  if not InTable(Name) then 
    Undefined(Name);
  EmitLn('MOVE ' + Name + '(PC),D0');
end;

{---------------------------}
procedure Push;
{ Push Primary onto Stack }
begin
  EmitLn('MOVE D0,-(SP)');
end;

{---------------------------}
procedure PopAdd;
{ Add Top of Stack to Primary }
begin
  EmitLn('ADD (SP)+,D0');
end;


{---------------------------}
procedure PopSub;
{ Subtract Primary from Top of Stack }
begin
  EmitLn('SUB (SP)+,D0');
  EmitLn('NEG D0');
end;


{---------------------------}
procedure PopMul;
{ Multiply Top of Stack by Primary }
begin
  EmitLn('MULS (SP)+,D0');
end;


{---------------------------}
procedure PopDiv;
{ Divide Top of Stack by Primary }
begin
  EmitLn('MOVE (SP)+,D7');
  EmitLn('EXT.L D7');
  EmitLn('DIVS D0,D7');
  EmitLn('MOVE D7,D0');
end;

{---------------------------}
procedure PopAnd;
{ AND Top of Stack with Primary }
begin
  EmitLn('AND (SP)+,D0');
end;


{---------------------------}
procedure PopOr;
{ OR Top of Stack with Primary }
begin
  EmitLn('OR (SP)+,D0');
end;


{---------------------------}
procedure PopXor;
{ XOR Top of Stack with Primary }
begin
  EmitLn('EOR (SP)+,D0');
end;


{---------------------------}
procedure PopCompare;
{ Compare Top of Stack with Primary }
begin
  EmitLn('CMP (SP)+,D0');
end;


{---------------------------}
procedure SetEqual;
{ Set D0 If Compare was = }
begin
  EmitLn('SEQ D0');
  EmitLn('EXT D0');
end;








{---------------------------}
procedure SetNEqual;
{ Set D0 If Compare was != }
begin
  EmitLn('SNE D0');
  EmitLn('EXT D0');
end;








{---------------------------}
procedure SetGreater;
{ Set D0 If Compare was > }
begin
  EmitLn('SLT D0');
  EmitLn('EXT D0');
end;








{---------------------------}
procedure SetLess;
{ Set D0 If Compare was < }
begin
  EmitLn('SGT D0');
  EmitLn('EXT D0');
end;








{---------------------------}
procedure SetLessOrEqual;
{ Set D0 If Compare was <= }
begin
  EmitLn('SGE D0');
  EmitLn('EXT D0');
end;







{---------------------------}
procedure SetGreaterOrEqual;
{ Set D0 If Compare was >= }
begin
  EmitLn('SLE D0');
  EmitLn('EXT D0');
end;








{---------------------------}
procedure Store(Name: string);
{ Store Primary to Variable }
begin
  EmitLn('LEA ' + Name + '(PC),A0');
  EmitLn('MOVE D0,(A0)')
end;

{---------------------------}
procedure Branch(L: string);
{ Branch Unconditional  }
begin
  EmitLn('BRA ' + L);
end;

{---------------------------}
procedure BranchFalse(L: string);
{ Branch False }
begin
  EmitLn('TST D0');
  EmitLn('BEQ ' + L);
end;

{---------------------------}
procedure ReadIt(Name: string);
{ Read Variable to Primary Register }
begin
  EmitLn('BSR READ');
  Store(Name);
end;

{---------------------------}
procedure WriteIt;
{ Write from Primary Register }
begin
  EmitLn('BSR WRITE');
end;

{---------------------------}
procedure Header;
{ Write Header Info }
begin
  WriteLn('WARMST', TAB, 'EQU $A01E');
end;

{---------------------------}
procedure Prolog;
{ Write the Prolog }
begin
  PostLabel('MAIN');
end;

{---------------------------}
procedure Epilog;
{ Write the Epilog }
begin
  EmitLn('DC WARMST');
  EmitLn('END MAIN');
end;

{---------------------------}
procedure Allocate(Name, Val: string);
{ Allocate Storage for a Static Variable }
begin
  WriteLn(Name, ':', TAB, 'DC ', Val);
end;

{---------------------------}
procedure BoolExpression; Forward;

procedure Factor;
{ Parse and Translate a Math Factor }
begin
  if Token = '(' then begin
    Next;
    BoolExpression;
    MatchString(')');
  end 
  else begin
    if Token = 'x' then
      LoadVar(Value)
    else
      if Token = '#' then
        LoadConst(Value)
      else 
        Expected('Math Factor');
    Next;
  end;
end;

{---------------------------}
procedure Multiply;
{ Recognize and Translate a Multiply }
begin
  Next;
  Factor;
  PopMul;
end;

{---------------------------}
procedure Divide;
{ Recognize and Translate a Divide }
begin
  Next;
  Factor;
  PopDiv;
end;

{---------------------------}
procedure Term;
{ Parse and Translate a Math Term }
begin
  Factor;
  while IsMulop(Token) do begin
    Push;
    case Token of
      '*': Multiply;
      '/': Divide;
    end;
  end;
end;

{---------------------------}
procedure Add;
{ Recognize and Translate an Add }
begin
  Next;
  Term;
  PopAdd;
end;

{---------------------------}
procedure Subtract;
{ Recognize and Translate a Subtract }
begin
  Next;
  Term;
  PopSub;
end;

{---------------------------}
procedure Expression;
{ Parse and Translate an Expression }
begin
  if IsAddop(Token) then
    Clear
  else
    Term;
  while IsAddop(Token) do begin
    Push;
    case Token of
      '+': Add;
      '-': Subtract;
    end;
  end;
end;

{---------------------------}
procedure CompareExpression;
{ Get Another Expression and Compare }
begin
  Expression;
  PopCompare;
end;

{---------------------------}
procedure NextExpression;
{ Get The Next Expression and Compare }
begin
  Next;
  CompareExpression;
end;

{---------------------------}
procedure Equal;
{ Recognize and Translate
  a Relational "Equals" }
begin
  NextExpression;
  SetEqual;
end;

{---------------------------}
procedure LessOrEqual;
{ Recognize and Translate
  a Relational "Less Than or Equal" }
begin
  NextExpression;
  SetLessOrEqual;
end;

{---------------------------}
procedure NotEqual;
{ Recognize and Translate
  a Relational "Not Equals" }
begin
  NextExpression;
  SetNEqual;
end;

{---------------------------}
procedure Less;
{ Recognize and Translate
  a Relational "Less Than" }
begin
  Next;
  case Token of
    '=': LessOrEqual;
    '>': NotEqual;
    else begin
           CompareExpression;
           SetLess;
         end;
  end;
end;

{---------------------------}
procedure Greater;
{ Recognize and Translate
  a Relational "Greater Than" }
begin
  Next;
  if Token = '=' then begin
    NextExpression;
    SetGreaterOrEqual;
  end else begin
    CompareExpression;
    SetGreater;
  end;
end;

{---------------------------}
procedure Relation;
{ Parse and Translate a Relation }
begin
  Expression;
  if IsRelop(Token) then begin
    Push;
    case Token of
      '=': Equal;
      '<': Less;
      '>': Greater;
    end;
  end;
end;

{---------------------------}
procedure NotFactor;
{ Parse and Translate
  a Boolean Factor with Leading NOT }
begin
  if Token = '!' then begin
    Next;
    Relation;
    NotIt;
  end else
    Relation;
end;

{---------------------------}
procedure BoolTerm;
{ Parse and Translate
  a Boolean Term }
begin
  NotFactor;
  while Token = '&' do begin
    Push;
    Next;
    NotFactor;
    PopAnd;
  end;
end;

{---------------------------}
procedure BoolOr;
{ Recognize and Translate
  a Boolean OR }
begin
  Next;
  BoolTerm;
  PopOr;
end;

{---------------------------}
procedure BoolXor;
{ Recognize and Translate
  an Exclusive Or }
begin
  Next;
  BoolTerm;
  PopXor;
end;

{---------------------------}
procedure BoolExpression;
{ Parse and Translate
  a Boolean Expression }
begin
  BoolTerm;
  while IsOrOp(Token) do begin
    Push;
    case Token of
      '|': BoolOr;
      '~': BoolXor;
    end;
  end;
end;

{---------------------------}
procedure Assignment;
{ Parse and Translate
  an Assignment Statement }
var
  Name: string;
begin
  CheckTable(Value);
  Name := Value;
  Next;
  MatchString('=');
  BoolExpression;
  Store(Name);
end;

{---------------------------}
procedure Block; Forward;

procedure DoIf;
{ Recognize and Translate
  an IF Construct }
var 
  L1, L2: string;
begin
  Next;
  BoolExpression;
  L1 := NewLabel;
  L2 := L1;
  BranchFalse(L1);
  Block;
  if Token = 'l' then begin
    Next;
    L2 := NewLabel;
    Branch(L2);
    PostLabel(L1);
    Block;
  end;
  PostLabel(L2);
  MatchString('ENDIF');
end;

{---------------------------}
procedure DoWhile;
{ Parse and Translate 
  a WHILE Statement }
var 
  L1, L2: string;
begin
  Next;
  L1 := NewLabel;
  L2 := NewLabel;
  PostLabel(L1);
  BoolExpression;
  BranchFalse(L2);
  Block;
  MatchString('ENDWHILE');
  Branch(L1);
  PostLabel(L2);
end;

{---------------------------}
procedure ReadVar;
{ Read a Single Variable }
begin
  CheckIdent;
  CheckTable(Value);
  ReadIt(Value);
  Next;
end;

{---------------------------}
procedure DoRead;
{ Process a Read Statement }
begin
  Next;
  MatchString('(');
  ReadVar;
  while Token = ',' do begin
    Next;
    ReadVar;
  end;
  MatchString(')');
end;

{---------------------------}
procedure DoWrite;
{ Process a Write Statement }
begin
  Next;
  MatchString('(');
  Expression;
  WriteIt;
  while Token = ',' do begin
    Next;
    Expression;
    WriteIt;
  end;
  MatchString(')');
end;

{---------------------------}
procedure Block;
{ Parse and Translate
  a Block of Statements }
begin
  Scan;
  while not(Token in ['e', 'l']) do begin
    case Token of
      'i': DoIf;
      'w': DoWhile;
      'R': DoRead;
      'W': DoWrite;
      else Assignment;
    end;
    Scan;
  end;
end;

{---------------------------}
procedure Alloc;
{ Allocate Storage for 
  a Variable }
begin
  Next;
  if Token <> 'x' then
    Expected('Variable Name');
  CheckDup(Value);
  AddEntry(Value, 'v');
  Allocate(Value, '0');
  Next;
end;

{---------------------------}
procedure TopDecls;
{ Parse and Translate Global Declarations }
begin
  Scan;
  while Token = 'v' do
    Alloc;
  while Token = ',' do
    Alloc;
end;

{---------------------------}
procedure Init;
{ Initialize }
begin
  GetChar;
  Next;
end;

{---------------------------}
{ Main Program }
begin
  Init;
  MatchString('PROGRAM');
  Header;
  TopDecls;
  MatchString('BEGIN');
  Prolog;
  Block;
  MatchString('END');
  Epilog;
end.

{---------------------------}
 
{---------------------------}
program Tiny11;

{---------------------------}
{ Constant Declarations }
const
  TAB = ^I;
  CR  = ^M;
  LF  = ^J;

  LCount: integer = 0;
  NEntry: integer = 0;


{---------------------------}
{ Type Declarations }
type
  Symbol = string[8];
  SymTab = array[1..1000] of Symbol;
  TabPtr = ^SymTab;


{---------------------------}
{ Variable Declarations }
var
  Look : char;        { Lookahead Character }
  Token: char;        { Encoded Token       }
  Value: string[16];  { Unencoded Token     }


const
  MaxEntry = 100;

var
  ST   : array[1..MaxEntry] of Symbol;
  SType: array[1..MaxEntry] of char;


{---------------------------}
{ Definition of Keywords and Token Types }
const 
  NKW =   9;
  NKW1 = 10;

const
  KWlist: array[1..NKW] of Symbol =
          ('IF', 'ELSE', 'ENDIF', 'WHILE', 'ENDWHILE',
           'READ', 'WRITE', 'VAR', 'END');

const
  KWcode: string[NKW1] = 'xileweRWve';


{---------------------------}
procedure GetChar;
{ Read New Character From Input Stream }
begin
  Read(Look);
end;

{---------------------------}
procedure Error(s: string);
{ Report an Error }
begin
  WriteLn;
  WriteLn(^G, 'Error: ', s, '.');
end;

{---------------------------}
procedure Abort(s: string);
{ Report Error and Halt }
begin
  Error(s);
  Halt;
end;

{---------------------------}
procedure Expected(s: string);
{ Report What Was Expected }
begin
  Abort(s + ' Expected');
end;

{---------------------------}
procedure Undefined(n: string);
{ Report an Undefined Identifier }
begin
  Abort('Undefined Identifier ' + n);
end;

{---------------------------}
procedure Duplicate(n: string);
{ Report a Duplicate Identifier }
begin
  Abort('Duplicate Identifier ' + n);
end;

{---------------------------}
procedure CheckIdent;
{ Check to Make Sure the 
  Current Token is an Identifier }
begin
  if Token <> 'x' then 
    Expected('Identifier');
end;

{---------------------------}
function IsAlpha(c: char): boolean;
{ Recognize an Alpha Character }
begin
  IsAlpha := UpCase(c) in ['A'..'Z'];
end;

{---------------------------}
function IsDigit(c: char): boolean;
{ Recognize a Decimal Digit }
begin
  IsDigit := c in ['0'..'9'];
end;

{---------------------------}
function IsAlNum(c: char): boolean;
{ Recognize an AlphaNumeric Character }
begin
  IsAlNum := IsAlpha(c) or IsDigit(c);
end;

{---------------------------}
function IsAddop(c: char): boolean;
{ Recognize an Addop }
begin
  IsAddop := c in ['+', '-'];
end;

{---------------------------}
function IsMulop(c: char): boolean;
{ Recognize a Mulop }
begin
  IsMulop := c in ['*', '/'];
end;

{---------------------------}
function IsOrop(c: char): boolean;
{ Recognize a Boolean Orop }
begin
  IsOrop := c in ['|', '~'];
end;

{---------------------------}
function IsRelop(c: char): boolean;
{ Recognize a Relop }
begin
  IsRelop := c in ['=', '#', '<', '>'];
end;

{---------------------------}
function IsWhite(c: char): boolean;
{ Recognize White Space }
begin
  IsWhite := c in [' ', TAB, CR, LF];
end;

{---------------------------}
procedure SkipWhite;
{ Skip Over Leading White Space }
begin
  while IsWhite(Look) do
    GetChar;
end;

{---------------------------}
function Lookup(T: TabPtr; s: string; n: integer): integer;
{ Table Lookup }
var 
  i: integer;
  found: Boolean;
begin
  found := false;
  i := n;
  while (i > 0) and not found do
    if s = T^[i] then
      found := true
    else
      dec(i);
  Lookup := i;
end;

{---------------------------}
function Locate(N: Symbol): integer;
{ Locate a Symbol in Table }
{ Returns the index of the entry.
  Zero if not present. }
begin
  Locate := Lookup(@ST, n, NEntry);
end;

{---------------------------}
function InTable(n: Symbol): Boolean;
{ Look for Symbol in Table }
begin
  InTable := Lookup(@ST, n, NEntry) <> 0;
end;

{---------------------------}
procedure CheckTable(N: Symbol);
{ Check to See if an Identifier}
{ is in the Symbol Table       }
{ Report an error if it's not. }
begin
  if not InTable(N) then
    Undefined(N);
end;

{---------------------------}
procedure CheckDup(N: Symbol);
{ Check the Symbol Table for 
  a Duplicate Identifier }
{ Report an error if identifier 
  is already in table. }
begin
  if InTable(N) then
    Duplicate(N);
end;

{---------------------------}
procedure AddEntry(N: Symbol; T: char);
{ Add a New Entry to Symbol Table }
begin
  CheckDup(N);
  if NEntry = MaxEntry then
    Abort('Symbol Table Full');
  Inc(NEntry);
  ST[NEntry] := N;
  SType[NEntry] := T;
end;

{---------------------------}
procedure GetName;
{ Get an Identifier }
begin
  SkipWhite;
  if Not IsAlpha(Look) then
    Expected('Identifier');
  Token := 'x';
  Value := '';
  repeat
    Value := Value + UpCase(Look);
    GetChar;
  until not IsAlNum(Look);
end;

{---------------------------}
procedure GetNum;
{ Get a Number }
begin
  SkipWhite;
  if not IsDigit(Look) then
    Expected('Number');
  Token := '#';
  Value := '';
  repeat
    Value := Value + Look;
    GetChar;
  until not IsDigit(Look);
end;

{---------------------------}
procedure GetOp;
{ Get an Operator }
begin
  SkipWhite;
  Token := Look;
  Value := Look;
  GetChar;
end;

{---------------------------}
procedure Next;
{ Get the Next Input Token }
begin
  SkipWhite;
  if IsAlpha(Look) then 
    GetName
  else 
    if IsDigit(Look) then
      GetNum
    else
      GetOp;
end;

{---------------------------}
procedure Scan;
{ Scan the Current Identifier for Keywords }
begin
  if Token = 'x' then
    Token := KWcode[Lookup(Addr(KWlist), Value, NKW) + 1];
end;

{---------------------------}
procedure MatchString(x: string);
{ Match a Specific Input String }
begin
  if Value <> x then
    Expected('''' + x + '''');
  Next;
end;

{---------------------------}
procedure Emit(s: string);
{ Output a String with Tab }
begin
  Write(TAB, s);
end;

{---------------------------}
procedure EmitLn(s: string);
{ Output a String with Tab and CRLF }
begin
  Emit(s);
  WriteLn;
end;

{---------------------------}
function NewLabel: string;
{ Generate a Unique Label }
var
  S: string;
begin
  Str(LCount, S);
  NewLabel := 'L' + S;
  Inc(LCount);
end;

{---------------------------}
procedure PostLabel(L: string);
{ Post a Label To Output }
begin
  WriteLn(L, ':');
end;

{---------------------------}
procedure Clear;
{ Clear the AX Register }
begin
  EmitLn('xor ax, ax');
end;

{---------------------------}
procedure Negate;
{ Negate the AX Register }
begin
  EmitLn('neg ax');
end;

{---------------------------}
procedure NotIt;
{ Complement the AX Register }
begin
  EmitLn('not ax');
end;

{---------------------------}
procedure LoadConst(n: string);
{ Load a Constant Value to AX Register }
begin
  Emit('mov ax, ');
  WriteLn(n);
end;

{---------------------------}
procedure LoadVar(Name: string);
{ Load a Variable to AX  Register }
begin
  if not InTable(Name) then 
    Undefined(Name);
  EmitLn('mov ax, ' + Name);
end;

{---------------------------}
procedure Push;
{ Push AX onto Stack }
begin
  EmitLn('push ax');
end;

{---------------------------}
procedure PopAdd;
{ Add Top of Stack to AX }
begin
  EmitLn('pop ax');
  EmitLn('add ax, bx');
end;

{---------------------------}
procedure PopSub;
{ Subtract AX from Top of Stack }
begin
  EmitLn('pop bx');
  EmitLn('sub ax, bx');
  EmitLn('neg ax');
end;

{---------------------------}
procedure PopMul;
{ Multiply Top of Stack by AX }
begin
  EmitLn('pop bx');
  EmitLn('imul ax, bx');
end;

{---------------------------}
procedure PopDiv;
{ Divide Top of Stack by AX }
begin
  EmitLn('pop bx');
  EmitLn('xchg ax, bx');
  EmitLn('cwd');
  EmitLn('idiv bx');
end;

{---------------------------}
procedure PopAnd;
{ AND Top of Stack with AX }
begin
  EmitLn('pop bx');
  EmitLn('and ax, bx');
end;

{---------------------------}
procedure PopOr;
{ OR Top of Stack with AX }
begin
  EmitLn('pop bx');
  EmitLn('or ax, bx');
end;

{---------------------------}
procedure PopXor;
{ XOR Top of Stack with AX }
begin
  EmitLn('pop bx');
  EmitLn('xor ax, bx');
end;

{---------------------------}
procedure PopCompare;
{ Compare Top of Stack with Primary }
begin
  EmitLn('pop bx');
  EmitLn('cmp ax, bx');
end;

{---------------------------}
procedure SetEqual;
{ Set AX If Compare was = }
var 
  L1 : string;
begin
  L1 := NewLabel;
  EmitLn('pop bx');
  EmitLn('cmp ax, bx');
  EmitLn('xor ax, ax');
  EmitLn('jne ' + L1);
  EmitLn('mov ax, -1');
  PostLabel(L1);
end;

{---------------------------}
procedure SetNEqual;
{ Set AX If Compare was != }
var
  L1 : string;
begin
  L1 := NewLabel;
  EmitLn('pop bx');
  EmitLn('cmp ax, bx');
  EmitLn('xor ax, ax');
  EmitLn('je ' + L1);
  EmitLn('mov ax, -1');
  PostLabel(L1);
end;

{---------------------------}
procedure SetGreater;
{ Set AX If Compare was > }
var
  L1 : string;
begin
  L1 := NewLabel;
  EmitLn('pop bx');
  EmitLn('cmp ax, bx');
  EmitLn('xor ax, ax');
  EmitLn('jle ' + L1);
  EmitLn('mov ax, -1');
  PostLabel(L1);
end;

{---------------------------}
procedure SetLess;
{ Set AX If Compare was < }
var
  L1 : string;
begin
  L1 := NewLabel;
  EmitLn('pop bx');
  EmitLn('cmp ax, bx');
  EmitLn('xor ax, ax');
  EmitLn('jge ' + L1);
  EmitLn('mov ax, -1');
  PostLabel(L1);
end;

{---------------------------}
procedure SetLessOrEqual;
{ Set AX If Compare was <= }
var
  L1 : string;
begin
  L1 := NewLabel;
  EmitLn('pop bx');
  EmitLn('cmp ax, bx');
  EmitLn('xor ax, ax');
  EmitLn('jg ' + L1);
  EmitLn('mov ax, -1');
  PostLabel(L1);end;

{---------------------------}
procedure SetGreaterOrEqual;
{ Set AX If Compare was >= }
var
  L1 : string;<
begin
  L1 := NewLabel;
  EmitLn('pop bx');
  EmitLn('cmp ax, bx');
  EmitLn('xor ax, ax');
  EmitLn('jl ' + L1);
  EmitLn('mov ax, -1');
  PostLabel(L1);
end;

{---------------------------}
procedure Store(Name: string);
{ Store AX to Variable }
begin
  EmitLn('lea bx, ' + Name);
  EmitLn('mov [bx], ax')
end;

{---------------------------}
procedure Branch(L: string);
{ Branch Unconditional  }
begin
  EmitLn('jmp ' + L);
end;

{---------------------------}
procedure BranchFalse(L: string);
{ Branch False }
begin
  EmitLn('or ax, ax');
  EmitLn('je ' + L);
end;

{---------------------------}
procedure ReadIt(Name: string);
{ Read Variable to AX Register }
begin
  EmitLn('BSR READ');
  Store(Name);
end;

{---------------------------}
procedure WriteIt;
{ Write from AX Register }
begin
  EmitLn('call Write');
end;

{---------------------------}
procedure Header;
{ Write Header Info }
begin
  WriteLn('code segment byte public '''code'''');
end;

{---------------------------}
procedure Prolog;
{ Write the Prolog }
begin
  PostLabel('main');
end;

{---------------------------}
procedure Epilog;
{ Write the Epilog }
begin
   EmitLn('code ends');
   EmitLn('end main');
end;

{---------------------------}
procedure Allocate(Name, Val: string);
{ Allocate Storage for a Static Variable }
begin
  WriteLn(Name, TAB, 'dw ', Val);
end;

{---------------------------}
procedure BoolExpression; Forward;

procedure Factor;
{ Parse and Translate a Math Factor }
begin
  if Token = '(' then begin
    Next;
    BoolExpression;
    MatchString(')');
  end 
  else begin
    if Token = 'x' then
      LoadVar(Value)
    else
      if Token = '#' then
        LoadConst(Value)
      else 
        Expected('Math Factor');
    Next;
  end;
end;

{---------------------------}
procedure Multiply;
{ Recognize and Translate a Multiply }
begin
  Next;
  Factor;
  PopMul;
end;

{---------------------------}
procedure Divide;
{ Recognize and Translate a Divide }
begin
  Next;
  Factor;
  PopDiv;
end;

{---------------------------}
procedure Term;
{ Parse and Translate a Math Term }
begin
  Factor;
  while IsMulop(Token) do begin
    Push;
    case Token of
      '*': Multiply;
      '/': Divide;
    end;
  end;
end;

{---------------------------}
procedure Add;
{ Recognize and Translate an Add }
begin
  Next;
  Term;
  PopAdd;
end;

{---------------------------}
procedure Subtract;
{ Recognize and Translate a Subtract }
begin
  Next;
  Term;
  PopSub;
end;

{---------------------------}
procedure Expression;
{ Parse and Translate an Expression }
begin
  if IsAddop(Token) then
    Clear
  else
    Term;
  while IsAddop(Token) do begin
    Push;
    case Token of
      '+': Add;
      '-': Subtract;
    end;
  end;
end;

{---------------------------}
procedure CompareExpression;
{ Get Another Expression and Compare }
begin
  Expression;
  PopCompare;
end;

{---------------------------}
procedure NextExpression;
{ Get The Next Expression and Compare }
begin
  Next;
  CompareExpression;
end;

{---------------------------}
procedure Equal;
{ Recognize and Translate
  a Relational "Equals" }
begin
  NextExpression;
  SetEqual;
end;

{---------------------------}
procedure LessOrEqual;
{ Recognize and Translate
  a Relational "Less Than or Equal" }
begin
  NextExpression;
  SetLessOrEqual;
end;

{---------------------------}
procedure NotEqual;
{ Recognize and Translate
  a Relational "Not Equals" }
begin
  NextExpression;
  SetNEqual;
end;

{---------------------------}
procedure Less;
{ Recognize and Translate
  a Relational "Less Than" }
begin
  Next;
  case Token of
    '=': LessOrEqual;
    '>': NotEqual;
    else begin
           CompareExpression;
           SetLess;
         end;
  end;
end;

{---------------------------}
procedure Greater;
{ Recognize and Translate
  a Relational "Greater Than" }
begin
  Next;
  if Token = '=' then begin
    NextExpression;
    SetGreaterOrEqual;
  end else begin
    CompareExpression;
    SetGreater;
  end;
end;

{---------------------------}
procedure Relation;
{ Parse and Translate a Relation }
begin
  Expression;
  if IsRelop(Token) then begin
    Push;
    case Token of
      '=': Equal;
      '<': Less;
      '>': Greater;
    end;
  end;
end;

{---------------------------}
procedure NotFactor;
{ Parse and Translate
  a Boolean Factor with Leading NOT }
begin
  if Token = '!' then begin
    Next;
    Relation;
    NotIt;
  end else
    Relation;
end;

{---------------------------}
procedure BoolTerm;
{ Parse and Translate
  a Boolean Term }
begin
  NotFactor;
  while Token = '&' do begin
    Push;
    Next;
    NotFactor;
    PopAnd;
  end;
end;

{---------------------------}
procedure BoolOr;
{ Recognize and Translate
  a Boolean OR }
begin
  Next;
  BoolTerm;
  PopOr;
end;

{---------------------------}
procedure BoolXor;
{ Recognize and Translate
  an Exclusive Or }
begin
  Next;
  BoolTerm;
  PopXor;
end;

{---------------------------}
procedure BoolExpression;
{ Parse and Translate
  a Boolean Expression }
begin
  BoolTerm;
  while IsOrOp(Token) do begin
    Push;
    case Token of
      '|': BoolOr;
      '~': BoolXor;
    end;
  end;
end;

{---------------------------}
procedure Assignment;
{ Parse and Translate
  an Assignment Statement }
var
  Name: string;
begin
  CheckTable(Value);
  Name := Value;
  Next;
  MatchString('=');
  BoolExpression;
  Store(Name);
end;

{---------------------------}
procedure Block; Forward;

procedure DoIf;
{ Recognize and Translate
  an IF Construct }
var 
  L1, L2: string;
begin
  Next;
  BoolExpression;
  L1 := NewLabel;
  L2 := L1;
  BranchFalse(L1);
  Block;
  if Token = 'l' then begin
    Next;
    L2 := NewLabel;
    Branch(L2);
    PostLabel(L1);
    Block;
  end;
  PostLabel(L2);
  MatchString('ENDIF');
end;

{---------------------------}
procedure DoWhile;
{ Parse and Translate 
  a WHILE Statement }
var 
  L1, L2: string;
begin
  Next;
  L1 := NewLabel;
  L2 := NewLabel;
  PostLabel(L1);
  BoolExpression;
  BranchFalse(L2);
  Block;
  MatchString('ENDWHILE');
  Branch(L1);
  PostLabel(L2);
end;

{---------------------------}
procedure ReadVar;
{ Read a Single Variable }
begin
  CheckIdent;
  CheckTable(Value);
  ReadIt(Value);
  Next;
end;

{---------------------------}
procedure DoRead;
{ Process a Read Statement }
begin
  Next;
  MatchString('(');
  ReadVar;
  while Token = ',' do begin
    Next;
    ReadVar;
  end;
  MatchString(')');
end;

{---------------------------}
procedure DoWrite;
{ Process a Write Statement }
begin
  Next;
  MatchString('(');
  Expression;
  WriteIt;
  while Token = ',' do begin
    Next;
    Expression;
    WriteIt;
  end;
  MatchString(')');
end;

{---------------------------}
procedure Block;
{ Parse and Translate
  a Block of Statements }
begin
  Scan;
  while not(Token in ['e', 'l']) do begin
    case Token of
      'i': DoIf;
      'w': DoWhile;
      'R': DoRead;
      'W': DoWrite;
      else Assignment;
    end;
    Scan;
  end;
end;

{---------------------------}
procedure Alloc;
{ Allocate Storage for 
  a Variable }
begin
  Next;
  if Token <> 'x' then
    Expected('Variable Name');
  CheckDup(Value);
  AddEntry(Value, 'v');
  Allocate(Value, '0');
  Next;
end;

{---------------------------}
procedure TopDecls;
{ Parse and Translate Global Declarations }
begin
  Scan;
  while Token = 'v' do
    Alloc;
  while Token = ',' do
    Alloc;
end;

{---------------------------}
procedure Init;
{ Initialize }
begin
  GetChar;
  Next;
end;

{---------------------------}
{ Main Program }
begin
  Init;
  MatchString('PROGRAM');
  Header;
  TopDecls;
  MatchString('BEGIN');
  Prolog;
  Block;
  MatchString('END');
  Epilog;
end.

{---------------------------}

{next}

*****************************************************************
*                                                               *
*                        COPYRIGHT NOTICE                       *
*                                                               *
*   Copyright (C) 1989 Jack W. Crenshaw. All rights reserved.   *
*                                                               *
*****************************************************************