pll2.pas

一个嵌入式系统的C代码

          TokVal := Lvar;
          ID := RC_NUM;
        END
      END
      {
      { Process operator, string, separators, etc.
      }
      ELSE BEGIN
        CASE ch OF
          ':' : BEGIN
                  ID := RC_COLON;
                  GetSourceChar(ch);
                  IF ch = '=' THEN BEGIN
                    ID := RC_ASS;
                    GetSourceChar(ch);
                  END
                END;
          '<' : BEGIN
                  ID := RC_LT;
                  GetSOurceChar(ch);
                  IF (ch = '>') THEN BEGIN
                    ID := RC_NE;
                    GetSOurceChar(ch);
                  END ELSE IF (ch = '=') THEN BEGIN
                    ID := RC_LE;
                    GetSOurceChar(ch);
                  END
                END;
          '>' : BEGIN
                  ID := RC_GT;
                  GetSourceChar(ch);
                  IF ch = '=' THEN BEGIN
                    ID := RC_GE;
                    GetSourceChar(ch);
                  END
                END;
          '''': BEGIN
                  ID := RC_STRLIT;
                  sTokLit := '';
                  REPEAT
                    GetSourceChar(ch);
                    IF ch <> '''' THEN
                      sTokLit := sTokLit + ch;
                  UNTIL ch = '''';
                  GetSourceChar(ch);
                END;
          '{' : BEGIN
                  REPEAT
                    GetSourceChar(ch);
                  UNTIL ch = '}';
                  GetSourceChar(ch);
                END
        ELSE
          BEGIN
            CASE ch OF
              '=': ID := RC_EQ;
              ',': ID := RC_SEP;
              '[': ID := RC_LSB;
              ']': ID := RC_RSB;
              '(': ID := RC_LRB;
              ')': ID := RC_RRB;
              '+': ID := RC_ADD;
              '-': ID := RC_SUB;
              '*': ID := RC_MULT;
              '#': ID := RC_FDEC;
              '%': ID := RC_FHEX;
              ';': ID := RC_SEMI;
              '.': ID := RC_STOP
            END;
            GetSourceChar(ch)
          END
        END
      END
    END;
    Lastch := ch
  END;

BEGIN
  tk.TokVal := 0;
  tk.sTokLit  := '';
  tk.ID := RC_NULL;
  WHILE (tk.ID = RC_NULL) AND (Lastch <> EOF_MARK) DO
    FetchToken
END;

{-------------
{ Check that the next token is of the passed type and issue the
{ passed error if it's not.  The current token is preserved in case
{ some unimaginable process requires it..
}
PROCEDURE CkNextToken(tkNext : RC_TOKEN; err : ERR_CODE);
BEGIN
  Tok0 := Tok1;
  GetNextToken(Tok1);
  IF Tok1.ID <> tkNext THEN
    DispError(err)
END;

{--------
{ Find passed symbol by a linear search, top to bottom, of symbol table.
{ This ensures that symbols are found where they have been most-receintly
{ defined (scope) and that a function's return type will be found when it
{ "looks" for itself (in scope) while its code offset will be found
{ when others look for it - means recursive function calls won't work!
}
FUNCTION FindSymbol (tag : TSTRING; VAR sym : SYMBOL) : BOOLEAN;
VAR
  idx : INTEGER;
  bFound : BOOLEAN;
BEGIN
  bFound := FALSE;
  idx := symTop;
  WHILE NOT bFound AND (idx > 0) DO
    IF symTable[idx].sName = tag THEN
      bFound := TRUE
    ELSE
      idx := idx - 1;
  IF bFound THEN
    sym := symTable[idx];
  FindSymbol := bFound
END;

{---------------
{ Create a new entry in the symbol table (indexed by symTop).  Before the
{ symbol is added, we search for it at the current level and issue a
{ "duplicate ident" error if we manage to find it (a Function's definition
{ and Return Value will be at different levels, OK?).
}
PROCEDURE CreateSymbol (stSym : TSTRING; tkType : SYM_TYPE; nVal : INTEGER);
VAR
  sym : SYMBOL;
  bFound : BOOLEAN;
BEGIN
  IF symTop >= MAXSYM THEN
    DispError(SYM_OVERFLOW)
  ELSE BEGIN
    bFound := FindSymbol(stSym, sym);
    IF (bFound AND (sym.Lev = BlkLev)) THEN
      DispError(DUP_IDENT)
    ELSE BEGIN
      symTop := symTop + 1;
      WITH symTable[symTop] DO BEGIN
        sName := stSym;
        Typ   := tkType;
        Lev   := BlkLev;
        Ofs   := nVal;
        Aux   := -1
      END
    END
  END
END;

{------------
{ Get value for a "constant"
}
FUNCTION GetConstVal (tk : TOKEN) : INTEGER;
VAR
  sym : SYMBOL;
  bRes : BOOLEAN;
BEGIN
  CASE Tok1.ID OF
    RC_NUM:    GetConstVal := tk.TokVal;
    RC_STRLIT: GetConstVal := INTEGER(tk.sTokLit[1]);
    RC_IDENT:  BEGIN
                 bRes := FindSymbol(Tok1.sTokLit, sym);
                 IF bRes AND (sym.Typ = TP_CONSTANT) THEN
                   GetConstVal := sym.Ofs
                 ELSE BEGIN
                   GetConstVal := -1;
                   DispError(UNDEC_IDENT)
                 END
               END
    ELSE
      DispError(NO_CONST)
  END
END;

{-----------
{ Get a constant declaration and enter its value in the symbol table..
}
PROCEDURE CreateConstant(tkIdent : TOKEN);
BEGIN
  IF tkIdent.ID <> RC_IDENT THEN
    DispError(NO_IDENT)
  ELSE BEGIN
    CkNextToken(RC_EQ, NO_EQ);
    GetNextToken(Tok1);
    CreateSymbol(tkIdent.sTokLit, TP_CONSTANT, 0);
    symTable[symTop].Ofs := GetConstVal(Tok1)
  END
END;

{------------
{ process a variable declaration
}
PROCEDURE ProcVarDecl(tkIdent : TOKEN; Offset : INTEGER);
BEGIN
  IF tkIdent.ID <> RC_IDENT THEN
    DispError(NO_IDENT)
  ELSE BEGIN
    CreateSymbol(tkIdent.sTokLit, TP_VARIABLE, Offset);
    GetNextToken(Tok1)
  END
END;

{------------
{ process declaration of a variable, fixing location (offset) in the
{ variable's symbol table entry.  Arrays also get their size set in
{ table record .. could be used for compile-time range checking, some
{ day, perhaps (?)
{ EXIT: dynamic storage requirements for block updated via VAR param.
}
PROCEDURE ProcVarType(sidx : INTEGER; VAR Offset : INTEGER);
VAR
  VarTyp : RC_TOKEN;
  idx, Asize : INTEGER;
BEGIN
  GetNextToken(Tok1);
  VarTyp := Tok1.ID;
  CASE VarTyp OF
    RC_INTEGER:
      BEGIN
        Asize := 1;
      END;
    RC_ARRAY:
      BEGIN
        CkNextToken(RC_LSB, NO_LSB);
        GetNextToken(Tok1);
        Asize := GetConstVal(Tok1);
        CkNextToken(RC_RSB, NO_RSB);
        CkNextToken(RC_OF, NO_OF);
        CkNextToken(RC_INTEGER, BAD_TYPE);
      END
    ELSE
      DispError(BAD_TYPE)
  END;
  FOR idx := sidx+1 TO symTop DO BEGIN
    symTable[idx].Ofs := Offset;
    Offset := Offset + Asize;
    IF VarTyp = RC_ARRAY THEN BEGIN
      symTable[idx].Typ := TP_ARRAY;
      symTable[idx].Aux := Asize
    END
  END
END;

{----------
{ Evaluate an expression.  Works in conjunction with "Simple Expression"
{ procedure to produce a stack oriented, "Reverse Polish Notation"
{ solution to compound expressions.  I haven't looked into this much, but
{ it looks like there will be no operator precedence in the evaluation,
{ so best use brackets in all compound expressions..
}
PROCEDURE EvalExpr;
VAR
  arg : OPR_ARG;
  op : RC_TOKEN;
BEGIN
  SimExpr;
  IF Tok1.ID IN [RC_EQ,RC_NE,RC_LT,RC_GT,RC_LE,RC_GE] THEN BEGIN
    op := Tok1.ID;
    GetNextToken(Tok1);
    SimExpr;
    CASE op OF
      RC_EQ: arg := _EQ;
      RC_NE: arg := _NE;
      RC_LT: arg := _LT;
      RC_GE: arg := _GE;
      RC_GT: arg := _GT;
      RC_LE: arg := _LE
    END;
    Assm(OPR, 0, INTEGER(arg))
  END
END;

{--------------
{ Process a FUNCTION/PROCEDURE call.  Validates that (any) required args
{ are present and correct, generates call to the address of the code and
{ reserves (any) required run-time stack space for params/return value.
}
PROCEDURE ProcSubCall(sym : SYMBOL);
VAR
  cnt : INTEGER;
BEGIN
  cnt := 0;
  IF sym.Aux > 0 THEN BEGIN
    CkNextToken(RC_LRB, NO_LRB);
    REPEAT
      GetNextToken(Tok1);
      EvalExpr;
      cnt := cnt + 1;
    UNTIL Tok1.ID <> RC_SEP;
    IF cnt <> sym.Aux THEN
      DispError(BAD_PARAM);
    IF Tok1.ID <> RC_RRB THEN
     DispError(NO_RRB);
  END;
  Assm(CAL, BlkLev-sym.Lev, sym.Ofs);
  IF sym.Aux <> 0 THEN
    Assm(INT, 0, -sym.Aux);
  GetNextToken(Tok1)
END;

{--------------
{ Evaluate a FACTOR
}
PROCEDURE EvalFactor(tk : TOKEN);
VAR
  sym : SYMBOL;
  ref1: INTEGER;
BEGIN
  CASE tk.ID OF
    RC_IDENT:
      BEGIN
        IF NOT FindSymbol(tk.sTokLit, sym) THEN
          DispError(BAD_SYM)
        ELSE BEGIN
          CASE sym.Typ OF
            TP_VARIABLE:
              BEGIN
                Assm(LOD, BlkLev-sym.Lev, Sym.Ofs);
                GetNextToken(Tok1)
              END;
            TP_CONSTANT:
              BEGIN
                Assm(LIT, 0, sym.Ofs);
                GetNextToken(Tok1)
              END;
            TP_RETURN, TP_FUNCTION:
              BEGIN
                Assm(INT, 0, 1);
                ProcSubCall(sym);
              END;
            TP_ARRAY:
              BEGIN
                ref1 := sym.Ofs;
                CkNextToken(RC_LSB, NO_LSB);
                GetNextToken(Tok1);
                EvalExpr;
                IF Tok1.ID <> RC_RSB THEN
                  DispError(NO_RSB)
                ELSE BEGIN
                  Assm(LODX, BlkLev-sym.Lev, sym.Ofs-1);
                  GetNextToken(Tok1)
                END
              END;
            TP_PROCEDURE, TP_FILE:
              DispError(BAD_EXPR)
          ELSE
            DispError(INTERNAL_BUG)
          END
        END
      END;
    RC_NUM:
      BEGIN
        Assm(LIT, 0, tk.TokVal);
        GetNextToken(Tok1)
      END;
    RC_STRLIT:
      BEGIN
        Assm(LIT, 0, INTEGER(tk.sTokLit[1]));
        GetNextToken(Tok1)
      END;
    RC_LRB:
      BEGIN
        GetNextToken(Tok1);
        EvalExpr;
        IF Tok1.ID <> RC_RRB THEN
          DispError(NO_RRB);
        GetNextToken(Tok1)
      END;
    RC_NOT:
      BEGIN
        GetNextToken(Tok1);
        EvalFactor(Tok1);
        Assm(OPR, 0, INTEGER(_NOT))
      END
  ELSE
    DispError(BAD_FAC)
  END
END;

{--------------
{ Evaluate a TERM..
}
PROCEDURE EvalTerm;
VAR
  arg : OPR_ARG;
  op : RC_TOKEN;
BEGIN
  EvalFactor(Tok1);
  WHILE Tok1.ID
  IN [RC_MULT,RC_DIV,RC_AND,RC_MOD,RC_SHL,RC_SHR,RC_XOR] DO BEGIN
    op := Tok1.ID;
    GetNextToken(Tok1);
    EvalFactor(Tok1);
    CASE op OF
      RC_MULT : arg := _MUL;
      RC_DIV  : arg := _DIV;
      RC_MOD  : arg := _MOD;
      RC_AND  : arg := _AND;
      RC_SHL  : arg := _SHL;
      RC_SHR  : arg := _SHR;
      RC_XOR  : arg := _XOR
    END;
    Assm(OPR, 0, INTEGER(arg))
  END
END;

{-----------
{ Process a SIMPLE EXPRESSION..
}
PROCEDURE SimExpr;
VAR
  arg : OPR_ARG;
  op : RC_TOKEN;
BEGIN
  IF NOT (Tok1.ID IN [RC_ADD, RC_SUB]) THEN
    EvalTerm
  ELSE BEGIN
    op := Tok1.ID;
    GetNextToken(Tok1);
    EvalTerm;
    IF op = RC_SUB THEN
      Assm(OPR, 0, INTEGER(_NEG))
  END;
  WHILE Tok1.ID IN [RC_ADD, RC_SUB, RC_OR] DO BEGIN
    op := Tok1.ID;
    GetNextToken(Tok1);
    EvalTerm;