pll2.pas

一个嵌入式系统的C代码

              DispError(BAD_IDENT);
            GetNextToken(Tok1);
            EvalExpr;
          END;
        SEM_CLOSE, SEM_OPEN, SEM_WAIT,
        SEM_SIGNAL,SHR_CLOSE, SHR_OPEN, SHR_SIZE:
          BEGIN
          END
      ELSE
          DispError(BAD_IDENT)
      END
    END;
    Assm(CSP, LitFlag, INTEGER(arg1));
    IF Tok1.ID <> RC_RRB THEN
      DispError(NO_RRB);
    GetNextToken(Tok1)
  END
END;

{-----------
{ Process STATEMENT
}
PROCEDURE EvalStmt;
BEGIN
  CASE Tok1.ID OF
    RC_IDENT:   ProcAssmnt;
    RC_IF:      StmtIf;
    RC_FOR:     StmtFor;
    RC_WHILE:   StmtWhile;
    RC_CASE:    StmtCase;
    RC_REPEAT:  StmtRepeat;
    RC_BEGIN:   StmtCompound;
    RC_READ:    StmtRead;
    RC_WRITE:   StmtWrite(Tok1.ID);
    RC_WRITELN: StmtWrite(Tok1.ID);
  ELSE
    BEGIN
      DispError(BAD_SYM);
      GetNextToken(Tok1)
    END
  END
END;

{-----------
{ Process a Function/procedure block (main, even)..
{ Statement before END may (but should not) have a semi-colon.
}
PROCEDURE Statements (nRT : INTEGER);
BEGIN
  Assm(INT, 0, nRT);
  REPEAT
    GetNextToken(Tok1);
    IF Tok1.ID <> RC_END THEN
      EvalStmt;
  UNTIL Tok1.ID <> RC_SEMI;
  IF Tok1.ID <> RC_END THEN
    DispError(NO_END);
  GetNextToken(Tok1);
  Assm(OPR, 0, INTEGER(_RET))
END;

{-----------------
{ Process parameters for procedure or function..
}
PROCEDURE ProcParam (VAR k : INTEGER; STref : INTEGER);
VAR
  dummy : INTEGER;
BEGIN
  ProcVarDecl(Tok1, 0);
  k := k + 1;
  IF (Tok1.ID <> RC_COLON) AND (Tok1.ID <> RC_SEP) THEN
    DispError(NO_COLON)
  ELSE
    IF Tok1.ID = RC_COLON THEN BEGIN
      ProcVarType(STref, dummy);
      STref := symTop;
      GetNextToken(Tok1);
      IF (Tok1.ID <> RC_SEMI) AND (Tok1.ID <> RC_RRB) THEN
        DispError(NO_RRB);
    END;
  GetNextToken(Tok1)
END;

{-----------
{ Create preamble for a procedure..
{ Proc name is entered in symbol table, followed by any parameters, constants
{ and variables (at one level higher).  The offset of the parameters (if any)
{ are then adjusted to be relative to the run-time Stack Pointer, since they
{ will be passed on the stack.  Recursive calls allow imbedded procedures.
{ Finally, the procedure body statements are processed and the symbol table
{ top reset so that we "forget" everything except the procedure's name.
}
PROCEDURE ProcBlock;
VAR
  idx, params : INTEGER;
  nRT, ref1, ref2 : INTEGER;
BEGIN
  GetNextToken(Tok1);
  IF Tok1.ID <> RC_IDENT THEN
    DispError(NO_IDENT)
  ELSE BEGIN
    CreateSymbol(Tok1.sTokLit, TP_PROCEDURE, 0);
    nRT := 3;
    params := 0;
    Assm(JMP, 0, 0);
    LiFoPush(PcdPtr);
    BlkLev := BlkLev + 1;
    ref1 := symTop;
    GetNextToken(Tok1);
    IF Tok1.ID = RC_LRB THEN BEGIN
      GetNextToken(Tok1);
      ref2 := symTop;
      WHILE Tok1.ID = RC_IDENT DO
        ProcParam(params, ref2);
    END;
    IF Tok1.ID <> RC_SEMI THEN
      DispError(NO_SEMI);
    FOR idx := 1 TO params+1 DO BEGIN
      IF idx >= params THEN
        symTable[symTop-idx+1].Aux := params;
      IF idx <= params THEN
        symTable[symTop-idx+1].Ofs := -idx
    END;
    GetNextToken(Tok1);
    WHILE Tok1.ID <> RC_BEGIN DO
      CodeBlock(nRT);
    FixFwdRef(LiFoPop);
    symTable[ref1].Ofs := PcdPtr;
    Statements(nRT);
    BlkLev := BlkLev - 1;
    symTop := ref1;
    IF Tok1.ID <> RC_SEMI THEN
      DispError(NO_SEMI);
    GetNextToken(Tok1)
  END
END;

{-----------
{ Create preamble for a function..
{ Processing is very similar to a procedure (they could be merged at the
{ expense of some readabiliy) except that a function always has at least
{ one "parameter" which is the return value.  This is created as a symbol
{ table entry with the same name as the function, but a type of TP_RETURN.
{ Like the procedure, all symbols except the function's name are disgarded
{ on exit.
{
{ NOTE: At this release, function type can only be an INTEGER.
}
PROCEDURE FuncBlock;
VAR
  idx, params : INTEGER;
  ref1, ref2, nRT : INTEGER;
BEGIN
  GetNextToken(Tok1);
  IF Tok1.ID <> RC_IDENT THEN
    DispError(NO_IDENT)
  ELSE BEGIN
    CreateSymbol(Tok1.sTokLit, TP_FUNCTION, 0);
    nRT := 3;
    params := 1;
    Assm(JMP, 0, 0);
    LiFoPush(PcdPtr);
    BlkLev := BlkLev + 1;
    ref1 := symTop;
    CreateSymbol(Tok1.sTokLit, TP_RETURN, 0);
    GetNextToken(Tok1);
    IF Tok1.ID = RC_LRB THEN BEGIN
      GetNextToken(Tok1);
      ref2 := symTop;
      WHILE Tok1.ID = RC_IDENT DO
        ProcParam(params, ref2);
    END;
    IF Tok1.ID <> RC_COLON THEN
      DispError(NO_COLON);
    CkNextToken(RC_INTEGER, BAD_TYPE);
    CkNextToken(RC_SEMI, NO_SEMI);
    FOR idx := 1 TO params+1 DO BEGIN
      IF idx >= params THEN
        symTable[symTop-idx+1].Aux := params - 1;
      IF idx <= params THEN
        symTable[symTop-idx+1].Ofs := -idx
    END;
    GetNextToken(Tok1);
    WHILE Tok1.ID <> RC_BEGIN DO
      CodeBlock(nRT);
    FixFwdRef(LiFoPop);
    symTable[ref1].Ofs := PcdPtr;
    Statements(nRT);
    BlkLev := BlkLev - 1;
    symTop := ref1;
    IF Tok1.ID <> RC_SEMI THEN
      DispError(NO_SEMI);
    GetNextToken(Tok1)
  END
END;

{---------------
{ Scan source, extracting CONST definitions..
}
PROCEDURE ConstBlock;
BEGIN
  GetNextToken(Tok1);
  WHILE Tok1.ID = RC_IDENT DO BEGIN
    CreateConstant(Tok1);
    CkNextToken(RC_SEMI, NO_SEMI);
    GetNextToken(Tok1)
  END
END;

{---------------
{ Scan source vor fairables..
}
Procedure VarBlock (VAR nx : INTEGER);
VAR
  STref : INTEGER;
BEGIN
  STref := symTop;
  GetNextToken(Tok1);
  WHILE Tok1.ID = RC_IDENT DO BEGIN
    ProcVarDecl(Tok1, nx);
    IF NOT (Tok1.ID IN [RC_COLON, RC_SEP]) THEN
      DispError(NO_COLON)
    ELSE
      IF Tok1.ID = RC_COLON THEN BEGIN
        ProcVarType(STref, nx);
        CkNextToken(RC_SEMI, NO_SEMI);
        STref := symTop;
      END;
    GetNextToken(Tok1)
  END
END;

{---------------
{ Process a program block (except main)..
}
PROCEDURE CodeBlock (VAR nRT : INTEGER);
BEGIN
  CASE Tok1.ID OF
    RC_CONST: ConstBlock;
    RC_VAR:   VarBlock(nRT);
    RC_PROC:  ProcBlock;
    RC_FUNC:  FuncBlock;
  ELSE
    DispError(NO_BEGIN)
  END
END;

{------------
{ Process an entry from the Program File list..
}
PROCEDURE ProcFileVar;
BEGIN
  CreateSymbol(Tok1.sTokLit, TP_FILE, 0);
  IF (Tok1.sTokLit = 'INPUT') OR (Tok1.sTokLit = 'OUTPUT') THEN
    symTable[symTop].Aux := 0;
  GetNextToken(Tok1)
END;

{------------------------
{ Process PASCAL program block - Each Block (procedures, functions and main)
{ must "remember" their own runtime variable requirements.  This is done by
{ recursive calls to the procedures that process the Function and Program
{ blocks and by this procedure for "main".  Now read on..
}
PROCEDURE ProgBlock;
VAR
  bLoop : BOOLEAN;
  nrtx  : INTEGER;  {Run-time variable dynamic storage required for main }
BEGIN
  CkNextToken(RC_IDENT, NO_IDENT);
  stProgName := Tok1.sTokLit;
  GetNextToken(Tok1);
  IF Tok1.ID = RC_LRB THEN BEGIN
    GetNextToken(Tok1);
    WHILE Tok1.ID = RC_IDENT DO BEGIN
      ProcFileVar;
      IF Tok1.ID = RC_SEP THEN
        GetNextToken(Tok1)
    END;
    IF Tok1.ID <> RC_RRB THEN
      DispError(NO_RRB);
    GetNextToken(Tok1);
  END;
  IF Tok1.ID <> RC_SEMI THEN
    DispError(NO_SEMI);
  GetNExtToken(Tok1);
  Assm(JMP, 0, 0);
  nrtx := 3;
  bLoop := TRUE;
  WHILE bLoop DO BEGIN
    CASE Tok1.ID OF
      RC_BEGIN:
        BEGIN
          bLoop := FALSE;
          FixFwdRef(1);
          Statements(nrtx);
          IF Tok1.ID <> RC_STOP THEN
            DispError(NO_STOP)
        END;
      RC_CONST, RC_VAR, RC_FUNC, RC_PROC:
        BEGIN
          CodeBlock(nrtx);
        END
      ELSE
        BEGIN
          bLoop := FALSE;
          DispError(NO_BEGIN)
        END
    END;
    IF ErrCnt > MAXERRORS THEN BEGIN
      bLoop := FALSE;
      WriteLn('Too many errors')
    END
  END
END;

{--------------
{ Giant Initialize for compile (with apologies to Di Page-Jones)..
}
PROCEDURE GreatBigInit;
BEGIN
  idxBuf := 0;          { source line index     }
  PcdPtr := 0;          { Pcode address index   }
  symTop := 0;          { Symbol Table index    }
  BlkLev := 0;          { Level Counter         }
  idxStk := 0;          { Internal Stack index  }
  LnNo   := 0;          { current source line   }
  ErrCnt := 0;          { cumulative errors     }
  Lastch := ' ';        { last char read von IP }
  SrcLnLen := -1;       { source line length    }
END;

{-------------------
{ Form input and output file names from the passed string.
{ Assumes that input filename has extension ".PAS" (not verified)..
}
PROCEDURE SetNames (st : STRING);
VAR
  i : INTEGER;
BEGIN
  stIn := st;
  stOut := '';
  i := 1;
  WHILE (i <= Length(st)) AND (st[i] <> '.') DO BEGIN
    stOut := stOut + st[i];
    i := i + 1;
  END;
  stOut := stOut + '.PCD';
END;

{------------------------
{ Try to open a source file of the passed name.
{ Note: NO extension is assumed! It must be correctly supplied.
{ RETURNS: TRUE  .. open ok
{          FALSE .. failed for some reason
}
FUNCTION OpenTarget (Name : STRING; Mode : INTEGER) : BOOLEAN;
BEGIN
  {$I-}
    IF (Mode = READ_FILE) THEN BEGIN
      ASSIGN(Ipf, Name);
      RESET(Ipf)
    END ELSE BEGIN
      ASSIGN(Opf, Name);
      REWRITE(Opf)
    END;
  {$I+}
  OpenTarget := (IOresult = 0)
END;

{----------
{ Good run - write pcode file
}
PROCEDURE WritePcode;
VAR
  i : INTEGER;
BEGIN
  IF NOT OpenTarget(stOut, WRITE_FILE) THEN
    DispError(NO_TARGET)
  ELSE BEGIN
    FOR i := 1 TO PcdPtr DO
      WRITE(Opf, PcdBuff[i]);
    CLOSE(Opf)
  END
END;



{************************************
{
{ Main entry (naturally..)
{
{************************************
}
BEGIN
  WriteLn;
  WriteLn('------------------------------------');
  WriteLn('P-Code PASCAL Compiler  Version ', VERS:2:2);
  WriteLn('for OS Simulator.  Ron Chernich 1992');
  WriteLn('------------------------------------');
  WriteLn;
  IF (ParamCount > 0) THEN BEGIN
    SetNames(ParamStr(1));
    IF NOT OpenTarget(stIn, READ_FILE) THEN
      DispError(NO_SOURCE)
    ELSE BEGIN
      GreatBigInit;
      GetNextToken(Tok1);
      IF Tok1.ID <> RC_PROG THEN
        DispError(NO_PROG)
      ELSE
        ProgBlock;
      IF ErrCnt > 0 THEN
        WriteLn('** ', ErrCnt:2, ' Error(s) encountered **')
      ELSE BEGIN
        WRITE(stIn, ' - ');
        DispError(CLEAN_COMPILE);
        WritePcode
      END;
      Close(Ipf)
    END
  END
END.


{----------------------------------- EOF ----------------------------------}