pll2.pas

一个嵌入式系统的C代码

    CASE op OF
      RC_ADD: arg := _ADD;
      RC_SUB: arg := _SUB;
      RC_OR:  arg := _OR
    END;
    Assm(OPR, 0, INTEGER(arg))
  END
END;

{-----------
{ Process an IF..THEN..ELSE statement
}
PROCEDURE StmtIF;
VAR
  ref1, ref2 : INTEGER;
BEGIN
  GetNextToken(Tok1);
  EvalExpr;
  IF Tok1.ID <> RC_THEN THEN
    DispError(NO_THEN);
  GetNextToken(Tok1);
  Assm(JPC, 0, 0);
  ref1 := PcdPtr;
  EvalStmt;
  IF Tok1.ID <> RC_ELSE THEN
    FixFwdRef(ref1)
  ELSE BEGIN
    Assm(JMP, 0, 0);
    ref2 := PcdPtr;
    FixFwdRef(ref1);
    GetNextToken(Tok1);
    EvalStmt;
    FixFwdRef(ref2)
  END
END;

{-----------
{ Process a WHILE..DO statment
}
PROCEDURE StmtWhile;
VAR
  ref1, ref2 : INTEGER;
BEGIN
  GetNextToken(Tok1);
  ref1 := PcdPtr;
  EvalExpr;
  Assm(JPC, 0, 0);
  ref2 := PcdPtr;
  IF Tok1.ID <> RC_DO THEN
    DispError(NO_DO);
  GetNextToken(Tok1);
  EvalStmt;
  Assm(JMP, 0, ref1);
  FixFwdRef(ref2)
END;

{-----------
{ Process a REPEAT .. UNTIL statement
}
PROCEDURE StmtRepeat;
VAR
  LoopAddr : INTEGER;
BEGIN
  LoopAddr := PcdPtr;
  REPEAT
    GetNextToken(Tok1);
    EvalStmt
  UNTIL Tok1.ID <> RC_SEMI;
  IF Tok1.ID <> RC_UNTIL THEN
    DispError(NO_UNTIL);
  GetNextToken(Tok1);
  EvalExpr;
  Assm(JPC, 0, LoopAddr)
END;

{-----------
{ Process a FOR..TO/DOWNTO..DO statement
}
PROCEDURE StmtFor;
VAR
  sym : SYMBOL;
  bFd : BOOLEAN;
  arg1, arg2 : OPR_ARG;
  ref1, ref2 : INTEGER;
BEGIN
  CkNextToken(RC_IDENT, NO_IDENT);
  bFd := FindSymbol(Tok1.sTokLit, sym);
  ProcAssmnt;
  CASE Tok1.ID OF
    RC_TO:     BEGIN arg1 := _GE; arg2 := _INC END;
    RC_DOWNTO: BEGIN arg1 := _LE; arg2 := _DEC END
  ELSE
    DispError(NO_TO)
  END;
  GetNextToken(Tok1);
  EvalExpr;
  ref1 := PcdPtr;
  Assm(OPR, 0, INTEGER(_CPY));
  Assm(LOD, BlkLev-sym.Lev, sym.Ofs);
  Assm(OPR, 0, INTEGER(arg1));
  Assm(JPC, 0, 0);
  ref2 := PcdPtr;
  IF Tok1.ID <> RC_DO THEN
    DispError(NO_DO);
  GetNextToken(Tok1);
  EvalStmt;
  Assm(LOD, BlkLev-sym.Lev, sym.Ofs);
  Assm(OPR, 0, INTEGER(arg2));
  Assm(STO, BlkLev-sym.Lev, sym.Ofs);
  Assm(JMP, 0, ref1);
  FixFwdRef(ref2);
  Assm(INT, 0, -1)
END;

{-----------
{ Process CASE..OF..ELSE statement
}
PROCEDURE StmtCase;
VAR
  ref1, CaseLabs, Cases : INTEGER;
BEGIN
  GetNextToken(Tok1);
  EvalExpr;
  IF Tok1.ID <> RC_OF THEN
    DispError(NO_OF);
  Cases := 0;
  REPEAT
    CaseLabs := 0;
    REPEAT
      GetNextToken(Tok1);
      Assm(OPR, 0, INTEGER(_CPY));
      Assm(LIT, 0, GetConstVal(Tok1));
      Assm(OPR, 0, INTEGER(_EQ));
      GetNextToken(Tok1);
      IF NOT (Tok1.ID IN [RC_SEP, RC_COLON]) THEN
        DispError(NO_COLON)
      ELSE IF Tok1.ID = RC_SEP THEN BEGIN
        Assm(JPC, 1, 0);
        LiFoPush(PcdPtr);
        CaseLabs := CaseLabs + 1;
      END
    UNTIL Tok1.ID = RC_COLON;
    Assm(JPC, 0, 0);
    ref1 := PcdPtr;
    WHILE CaseLabs > 0 DO BEGIN
      FixFwdRef(LiFoPop);
      CaseLabs := CaseLabs - 1
    END;
    GetNextToken(Tok1);
    EvalStmt;
    Assm(JMP, 0, 0);
    LiFoPush(PcdPtr);
    Cases := Cases + 1;
    FixFwdRef(ref1)
  UNTIL (Tok1.ID = RC_ELSE) OR (Tok1.ID = RC_END);
  IF Tok1.ID = RC_ELSE THEN BEGIN
    GetNextToken(Tok1);
    EvalStmt;
    CkNextToken(RC_END, NO_END)
  END;
  WHILE Cases > 0 DO BEGIN
    FixFwdRef(LiFoPop);
    Cases := Cases - 1
  END;
  Assm(INT, 0, -1);
  GetNextToken(Tok1)
END;

{-----------
{ Process an assignment statement or procedure call..
}
PROCEDURE ProcAssmnt;
VAR
  sym : SYMBOL;

  {--------
  { Process your actual assignment
  }
  PROCEDURE Assignment;
  BEGIN
    IF sym.Typ = TP_ARRAY THEN BEGIN
      CkNextToken(RC_LSB, NO_LSB);
      GetNextToken(Tok1);
      EvalExpr;
      IF Tok1.ID <> RC_RSB THEN
        DIspError(NO_RSB);
    END;
    CkNextToken(RC_ASS, NO_ASS);
    GetNextToken(Tok1);
    IF Tok1.ID = RC_SYSTEM THEN
      SystemFunc
    ELSE
      EvalExpr;
    IF sym.Typ = TP_ARRAY THEN
      Assm(STOX, BlkLev-sym.Lev, sym.Ofs-1)
    ELSE
      Assm(STO, BlkLev-sym.Lev, sym.Ofs)
  END;

BEGIN
  IF NOT FindSymbol(Tok1.sTokLit, sym) THEN
    DispError(BAD_SYM)
  ELSE
    CASE sym.Typ OF
      TP_ARRAY, TP_RETURN, TP_VARIABLE: Assignment;
      TP_FUNCTION, TP_PROCEDURE:        ProcSubCall(sym)
    ELSE
      DispError(BAD_IDENT)
    END
END;

{-------
{ Proceess a compound (BEGIN..END) statement
}
PROCEDURE StmtCompound;
BEGIN
  REPEAT
    GetNextToken(Tok1);
    EvalStmt;
    IF NOT (Tok1.ID IN [RC_SEMI, RC_END]) THEN
      DispError(NO_END);
  UNTIL Tok1.ID = RC_END;
  GetNextToken(Tok1)
END;

{-------
{ Procedure for READ statement
}
PROCEDURE StmtRead;
VAR
  klg : INTEGER;
  arg : CSP_ARG;
  sym, ipf : SYMBOL;
BEGIN
  IF NOT FindSymbol('INPUT', ipf) THEN
    DispError(NO_INPUT);
  CkNextToken(RC_LRB, NO_LRB);
  REPEAT
    CkNextToken(RC_IDENT, NO_IDENT);
    IF NOT FindSymbol(Tok1.sTokLit, sym) THEN
      DispError(BAD_SYM);
    CASE sym.Typ OF
      TP_VARIABLE:
        BEGIN
          klg := 0;
        END;
      TP_ARRAY:
        BEGIN
          CkNextToken(RC_LSB, NO_LSB);
          GetNextToken(Tok1);
          EvalExpr;
          IF Tok1.ID <> RC_RSB THEN
            DispError(NO_RSB);
          klg := 16;
        END
    ELSE
      DispError(BAD_IDENT)
    END;
    GetNextToken(Tok1);
    IF Tok1.ID = RC_FDEC THEN
      arg := IN_DEC
    ELSE IF Tok1.ID = RC_FHEX THEN
      arg := IN_DEC
    ELSE
      arg := IN_CHR;
    Assm(CSP, ipf.Aux, INTEGER(arg));
    IF  arg <> IN_CHR THEN BEGIN
      Assm(OPCODE(klg+3), BlkLev-sym.Lev, sym.Ofs);
      GetNextToken(Tok1)
    END
  UNTIL Tok1.ID <> RC_SEP;
  IF Tok1.ID <> RC_RRB THEN
    DispError(NO_RRB);
  GetNextToken(Tok1)
END;

{-------
{ Procedure for WRITE and WRITELN statements..
}
PROCEDURE StmtWrite(verb : RC_TOKEN);
VAR
  opf : SYMBOL;
  arg : CSP_ARG;
  idx, Len : INTEGER;
BEGIN
  IF NOT FindSymbol('OUTPUT', opf) THEN
    DispError(NO_OUTPUT);
  GetNextToken(Tok1);
  IF (verb = RC_WRITE) AND (Tok1.ID <> RC_LRB) THEN
    DispError(NO_LRB);
  IF Tok1.ID = RC_LRB THEN BEGIN
    REPEAT
      GetNextToken(Tok1);
      IF Tok1.ID = RC_STRLIT THEN BEGIN
        Len := LENGTH(Tok1.sTokLit);
        FOR idx := 1 TO Len DO
          Assm(LIT, 0, INTEGER(Tok1.sTokLit[idx]));
        Assm(LIT, 0, Len);
        IF Len > 1 THEN
          Assm(CSP, opf.Aux, INTEGER(OUT_STR));
        GetNextToken(Tok1)
      END ELSE BEGIN
        EvalExpr;
        IF Tok1.ID = RC_FHEX THEN
          arg := OUT_HEX
        ELSE IF Tok1.ID = RC_FDEC THEN
          arg := OUT_DEC
        ELSE
          arg := OUT_CHR;
        Assm(CSP, 0, INTEGER(arg));
        IF arg <> OUT_CHR THEN
          GetNextToken(Tok1)
      END
    UNTIL Tok1.ID <> RC_SEP;
    IF Tok1.ID <> RC_RRB THEN
      DispError(NO_RRB)
  END;
  IF verb = RC_WRITELN THEN BEGIN
    Assm(LIT, 0, ACR);
    Assm(LIT, 0, ALF);
    Assm(LIT, 0, 2);
    Assm(CSP, opf.Aux, INTEGER(OUT_STR))
  END;
  IF Tok1.ID = RC_RRB THEN
    GetNextToken(Tok1)
END;

{-----------
{ Process "SYSTEM" call arguments. Note that the Semaphore open call
{ may take either an integer or string literal argument, so the
{ arg modifier is set to zero for ints and one for lits..
}
PROCEDURE SystemFunc;
VAR
  arg1 : CSP_ARG;
  idx, len, LitFlag : INTEGER;

  {----------
  { Validate the current token as a valid SYSTEM call argument
  { setting <arg1> if so.
  }
  FUNCTION FindCspArg : BOOLEAN;
  VAR
    bNotFound : BOOLEAN;
  BEGIN
    IF tok1.sTokLit = 'FORK  ' THEN BEGIN
      bNotFound := TRUE;
      arg1 := FORK
    END ELSE BEGIN
      idx := 1;
      bNotFound := TRUE;
      WHILE bNotFound AND (idx <= SYSOPS) DO BEGIN
        IF tok1.sTokLit = SYSWORD[idx] THEN BEGIN
          arg1 := CSP_ARG(INTEGER(OUT_STR) + idx);
          FindCspArg := TRUE;
          bNotFound := FALSE;
        END;
        idx := idx + 1
      END
    END;
    FindCspArg := NOT bNotFound
  END;

BEGIN
  GetNextToken(Tok1);
  IF (Tok1.ID <> RC_LRB) THEN
    DispError(NO_LRB)
  ELSE BEGIN
    GetNextToken(Tok1);
    IF NOT FindCspArg THEN
      DispError(BAD_CSP_ARG);
    GetNextToken(Tok1);
    IF arg1 = FORK THEN
      LitFlag := 0
    ELSE BEGIN
      IF Tok1.ID <> RC_SEP THEN
        DispError(BAD_IDENT);
      GetNextToken(Tok1);
      CASE Tok1.ID OF
        RC_IDENT:
          BEGIN
            EvalExpr;
            LitFlag := 0
          END;
        RC_STRLIT:
          BEGIN
            LitFlag := 1;
            Len := LENGTH(Tok1.sTokLit);
            FOR idx := 1 TO Len DO
              Assm(LIT, 0, INTEGER(Tok1.sTokLit[idx]));
            Assm(LIT, LitFlag, Len);
            GetNextToken(Tok1)
          END
      ELSE
        DispError(BAD_IDENT)
      END;
      {
      { SEMAPHORE CREATE takes a single, optional argument which we
      { we default to one if absent - this is the initial count value,
      { so omitting it defaults to a binary semaphore. Other CSP
      { funcs for shared memory take a fixed number of extra args.
      { Funcs with only one arg must be passed by the ELSE clause.
      }
      CASE arg1 OF
        SEM_CREATE:
          BEGIN
            IF Tok1.ID = RC_RRB THEN
              Assm(LIT, 0, 1)
            ELSE BEGIN
              IF Tok1.ID <> RC_SEP THEN
                DispError(BAD_IDENT);
              GetNextToken(Tok1);
              EvalExpr
            END;
          END;
        SHR_READ,
        SHR_CREATE:
          BEGIN
            IF Tok1.ID <> RC_SEP THEN
              DispError(BAD_IDENT);
            GetNextToken(Tok1);
            EvalExpr
          END;
        SHR_WRITE:
          BEGIN
            IF Tok1.ID <> RC_SEP THEN
              DispError(BAD_IDENT);
            GetNextToken(Tok1);
            EvalExpr;
            IF Tok1.ID <> RC_SEP THEN