pll2.pas

一个嵌入式系统的C代码

PROGRAM PLL2 (Input, Output);

{--------------------------------------------------------------------------}
{                   PLL/2 .. "PASCAL LIKE LANGUAGE Number 2"               }
{                   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~               }
{ Based (very loosly) on the "PASCAL P-Code Compiler" by Kin-Man Chung and }
{ Herbert Yuen, described in "Byte", Oct 1978 for a BASIC PASCAL to P-Code }
{ Bootstrap compiler.                                                      }
{                                                                          }
{ NOTE: This program is a conversion of a rather unstructured North Star   }
{       BASIC program - to be fair, it was written on a very primitive     }
{       machine with limited memory - so it suffers from common coupling   }
{       and poor cohesion.  My excuse was the need to quickly produce a    }
{       workable, maintainable program which could compile programs to run }
{       under my Operating System Simulator.  It was done in PASCAL rather }
{       than C so that some day, perhaps, it could compile itself!  You're }
{       welcome to improve on it.                                          }
{                                                                          }
{ History:                                                                 }
{  20-DEC-92  First translation of (eeych) Basic code         Ron Chernich }
{  26-DEC-92  First fully functional compiler (v0.01)                      }
{  28-MAR-93  Not Equal parsing fawlty (simply amazing!)                   }
{  04-MAR-94  SYSTEM reserverd word added to implemet IPC                  }
{  13-APR-94  Optional count and init value for semaphore create added     }
{  18-APR-94  Shared Memory support added                                  }
{--------------------------------------------------------------------------}


CONST

  VERS = 1.20;               { Rev Lev for banner }

  ALF         =  10;         { ASCII constants    }
  ACR         =  13;

  MAXSYM      =    128;      { symbol table limit }
  MAXSTACK    =     32;      { max size for stack }
  MAXTOKEN    =      6;      { limit for tokens   }
  MAXINT      =  32767;      { Largest integer    }
  MININT      = -32768;      { smallest integer   }
  MAXPCD      =   1024;      { Assembly P-code buffer limit  }
  MAXERRORS   =     10;      { Give up after this many fubar }
  MAXLEN      =     32;      { max size for identifier       }

  MAXRESWORDS =     35;      { reserved words ..             }

  SYSOPS      =     11;      { allowable system calls ..     }

  RESWORD : ARRAY [1..MAXRESWORDS] OF STRING [MAXTOKEN] = (
              'AND   ', 'ARRAY ', 'BEGIN ', 'CASE  ', 'CONST ', 'DIV   ',
              'DO    ', 'DOWNTO', 'ELSE  ', 'END   ', 'FILE  ', 'FOR   ',
              'FUNCTI', 'IF    ', 'INTEGE', 'MOD   ', 'NOT   ', 'OF    ',
              'OR    ', 'PROCED', 'PROGRA', 'READ  ', 'REPEAT', 'SHL   ',
              'SHR   ', 'SYSTEM', 'THEN  ', 'TO    ', 'TYPE  ', 'UNTIL ',
              'VAR   ', 'WHILE ', 'WRITE ', 'WRITEL', 'XOR   '
  );

  SYSWORD : ARRAY [1..SYSOPS] OF STRING [MAXTOKEN] = (
              'SEM_CL', 'SEM_CR', 'SEM_OP', 'SEM_SI', 'SEM_WA',
              'SHR_CL', 'SHR_CR', 'SHR_OP', 'SHR_RE', 'SHR_WR', 'SHR_SI'
  );

  READ_FILE   =   1;         { GP equates for Disk services  }
  WRITE_FILE  =   2;
  EOF_MARK    =   CHR(26);


TYPE
  OPCODE   = (LIT, OPR, LOD, STO, CAL, INT, JMP, JPC, CSP,
              x9,  xa,  xb,  xc,  xd,  xe,  xf,  x10, x11,
              LODX, STOX
  );

  CSP_ARG  = (IN_CHR,     OUT_CHR,    IN_DEC,   OUT_DEC,    IN_HEX,
              OUT_HEX,    EXEC,       FORK,     OUT_STR,
              SEM_CLOSE,  SEM_CREATE, SEM_OPEN, SEM_SIGNAL, SEM_WAIT,
              SHR_CLOSE,  SHR_CREATE, SHR_OPEN, SHR_READ,   SHR_WRITE,
              SHR_SIZE
  );

  OPR_ARG  = (_RET, _NEG, _ADD, _SUB, _MUL, _DIV, LOW, _MOD,
              _EQ,  _NE,  _LT,  _GE,  _GT,  _LE,  _OR, _AND,
              _XOR, _NOT, _SHL, _SHR, _INC, _DEC, _CPY
  );


  SYM_TYPE = (TP_CONSTANT, TP_VARIABLE, TP_ARRAY, TP_FUNCTION,
              TP_PROCEDURE, TP_RETURN, TP_FILE
  );

  RC_TOKEN = (RC_NULL, RC_AND, RC_ARRAY, RC_BEGIN, RC_CASE, RC_CONST,
              RC_DIV, RC_DO, RC_DOWNTO, RC_ELSE, RC_END, RC_FILE, RC_FOR,
              RC_FUNC, RC_IF, RC_INTEGER, RC_MOD, RC_NOT, RC_OF,
              RC_OR, RC_PROC, RC_PROG, RC_READ, RC_REPEAT, RC_SHL, RC_SHR,
              RC_SYSTEM, RC_THEN, RC_TO, RC_TYPE, RC_UNTIL, RC_VAR, RC_WHILE,
              RC_WRITE, RC_WRITELN, RC_XOR,
              RC_ASS, RC_EQ, RC_LT, RC_GT, RC_GE, RC_LE, RC_NE, RC_COLON,
              RC_SEMI, RC_SEP, RC_IDENT, RC_NUM, RC_STRLIT, RC_LRB, RC_LSB,
              RC_RRB, RC_RSB, RC_ADD, RC_SUB, RC_MULT, RC_FDEC, RC_FHEX,
              RC_STOP
  );

  ERR_CODE = (CLEAN_COMPILE, NO_SOURCE, NO_TARGET, NO_CONST, NO_EQ, NO_IDENT,
              NO_COLON, NO_TALKI, NO_SEMI, UNDEC_IDENT, BAD_IDENT, NO_ASS,
              NO_THEN, NO_END, NO_DO, BAD_SYM, NO_RELOP, BAD_EXPR, NO_LRB,
              BAD_FAC, NO_BEGIN, NO_OF, BAD_HEX, NO_TO, BAD_INTEGER, NO_RRB,
              NO_LSB, NO_RSB, BAD_PARAM, BAD_TYPE, NO_PROG, NO_STOP,
              NO_UNTIL, NO_INPUT, NO_OUTPUT, DUP_IDENT, BAD_CSP_ARG,
              INTERNAL_BUG,EOF_FOUND, BUFF_FULL, SYM_OVERFLOW, STACK_OFLOW,
              STACK_UFLOW
  );

  TSTRING = STRING[MAXTOKEN];                    { Token string for pass  }

  PCODE = RECORD                                 { Pcode Instruction..    }
    OP  : OPCODE;                                { OP Code                }
    P8  : BYTE;                                  { Byte argument          }
    P16 : INTEGER;                               { Word argument          }
  END;

  PFILE = FILE OF PCODE;                         { Object file type       }

  SYMBOL = RECORD                                { Symbol Table Entry..   }
    sName : STRING[MAXLEN];                      { Symbolic name          }
    Typ   : SYM_TYPE;                            { symbol type            }
    Lev   : INTEGER;                             { level where defined    }
    Ofs   : INTEGER;                             { rel offset or CONST val}
    Aux   : INTEGER;                             { # params for Func/Proc,}
  END;                                           { # elements for array   }

  TOKEN = RECORD                                 { Decoded Source Token.. }
    ID      : RC_TOKEN;                          { Token identifier       }
    TokVal  : INTEGER;                           { value (? only)         }
    sTokLit : STRING;                            { Full ASCII source value}
  END;


VAR
  Ipf : TEXT;                                    { Source file            }
  Opf : PFILE;                                   { binary object O/P file }
  Lastch : CHAR;                                 { Last char read from IP }
  LnNo   : INTEGER;                              { Source line num counter}
  ErrCnt : INTEGER;                              { Cumulative errors      }
  idxBuf : INTEGER;                              { index for runtime store}
  PcdPtr : INTEGER;                              { Pcode address in buff  }
  symTop : INTEGER;                              { ptr Top of Symbol table}
  BlkLev : INTEGER;                              { Block level counter    }
  idxStk : INTEGER;                              { Top of FILO stack      }
  stSrcLn  : STRING;                             { Last line read from IP }
  SrcLnLen : INTEGER;                            { Length of source line  }
  Tok0, Tok1 : TOKEN;                            { Global Token structs   }
  stIn, stOut: STRING;                           { name+path for Src & Obj}
  stProgName : STRING[MAXLEN];                   { program identifier     }
  LiFo : ARRAY [1..MAXSTACK] OF INTEGER;         { stack 4 lazy recursors }
  PcdBuff  : ARRAY [1..MAXPCD] OF PCODE;         { compiled binary Pcodes }
  symTable : ARRAY [1..MAXSYM] OF SYMBOL;        { scope sensitive symbols}


{----------
{ necessary forward references..
}
PROCEDURE SimExpr;                       FORWARD;
PROCEDURE EvalStmt;                      FORWARD;
PROCEDURE ProcAssmnt;                    FORWARD;
PROCEDURE ProgBlock;                     FORWARD;
PROCEDURE FuncBlock;                     FORWARD;
PROCEDURE SystemFunc;                    FORWARD;
PROCEDURE CodeBlock (VAR nRT : INTEGER); FORWARD;


{**************************************************************************
{ Error Message printing routine - as long as these messages appear in the
{ same order as the co-responding tags in the TYPE "ERR_CODE", all will be
{ well ..
{
{ NOTE:  Error recovery in this compiler is non-existant!  After detecting
{ an error, we just carry on as if it hadn't happened - this will normally
{ produce a whole host of successive error messages which *may* or may not
{ have any real meaning.  In an IPE, the first message would invoke and
{ position the editor - the first Borland Turbo Pascal (8 bit Z80, written
{ in Ireland) worked like this.  Command line compilers try to scan forward
{ past all the mess made by the original error.  In any case, to prevent
{ screens full of krap, we will abort the compiler after <MAXERRORS> have
{ been detected.
}
PROCEDURE DispError (idx : ERR_CODE);
BEGIN
  IF (idx > CLEAN_COMPILE ) THEN BEGIN
    ErrCnt := ErrCnt + 1;
    IF (ErrCnt > MAXERRORS) OR (idx >= INTERNAL_BUG) THEN BEGIN
      WriteLn;
      WriteLn('*** Maximum errors exceded - aborting ***');
      Halt(1)
    END;
    WRITE('* Error ', INTEGER(idx):2, ' (', LnNo, '): ')
  END;
  CASE INTEGER(idx) OF
      0: WriteLn('Compiled without error.');
      1: WriteLn('Unable to open source file!');
      2: WriteLn('Unable to create p-code file!');
      3: WriteLn('Constant expected');
      4: WriteLn('"=" Expected');
      5: WriteLn('Identifier expected');
      6: WriteLn('":" or ";" missing');
      7: WriteLn('"." missing');
      8: WriteLn('";" missing');
      9: WriteLn('Undeclared identifier');
     10: WriteLn('Illegal identifier');
     11: WriteLn('":=" expected');
     12: WriteLn('THEN expected');
     13: WriteLn('";" or END expected');
     14: WriteLn('DO expected');
     15: WriteLn('Incorrect symbol (maybe ";" on previous line?)');
     16: WriteLn('Relational operator expected');
     17: WriteLn('Use of Procedure indentifier in expression');
     18: WriteLn('")" expected');
     19: WriteLn('Illegal factor');
     20: WriteLn('BEGIN expected');
     21: WriteLn('OF expected');
     22: WriteLn('Illegal HEX constant');
     23: WriteLn('TO or DOWNTO expected');
     24: WriteLn('Number out of range');
     25: WriteLn('"(" expected');
     26: WriteLn('"[" expected');
     27: WriteLn('"]" expected');
     28: WriteLn('Parameter missmatch');
     29: WriteLn('Data type not recognized');
     30: WriteLn('PROGRAM expected');
     31: WriteLn('"." expected');
     32: WriteLn('UNTIL expected');
     33: WriteLn('READ console with no INPUT declaration');
     34: WriteLn('WRITE console with no OUTPUT declaration');
     35: WriteLn('Duplicate Identifier');
     36: WriteLn('Invalid SYSTEM call');
     {
     { Errors from here on terminate compile
     }
     37: WriteLn('INTERNAL BUG!');
     38: WriteLn('Unexpected End Of File encountered!');
     39: WriteLn('PCODE BUFFER FULL!');
     30: WriteLn('Symbol Table Overflow!');
     41: WriteLn('Internal Stack Overflow!');
     42: WriteLn('Internal Stack Underflow!');
  ELSE
     WriteLn('YAB - undocumented error!')
  END
END;

{-----------------
{ Test for passed char = valid numeric
}
FUNCTION IsDigit (ch : CHAR) : BOOLEAN;
BEGIN
  IsDigit := ch IN ['0'..'9']
END;

{-----------------
{ Test for passed char = valid upper or lower char
}
FUNCTION IsChar (ch : CHAR) : BOOLEAN;
BEGIN
  IsChar := ch IN ['A'..'Z', 'a'..'z']
END;

{---------------
{ Enter passed P-code into buffer.  Global Index is pre-incremented so
{ that it always points to the last assembled p-code.
}
PROCEDURE Assm (oper : OPCODE; bParam : BYTE; wParam : INTEGER);
BEGIN
  IF PcdPtr >= MAXPCD THEN
    DispError(BUFF_FULL)
  ELSE BEGIN
    PcdPtr := PcdPtr + 1;
    PcdBuff[PcdPtr].op := oper;
    PcdBuff[PcdPtr].p8 := bParam;
    PcdBuff[PcdPtr].p16:= wParam
  END
END;

{-------------
{ Fix a forward reference. The passed index is a JMP, so set its target
{ to the current pcode pointer val.  Made a procedure for documentation
{ purposes (improves readability).  Would be nice if the compiler could
{ inline it, but this ain't C++ ..
}
PROCEDURE FixFwdRef (ref : INTEGER);
BEGIN
  PcdBuff[ref].p16 := PcdPtr
END;

{----------------
{ Push address onto stack. Used to keep track of multiple forward
{ references when recursion can't help (CASE statement for example)..
}
PROCEDURE LiFoPush(nVal : INTEGER);
BEGIN
  IF idxStk >= MAXSTACK THEN
    DispError(STACK_OFLOW)
  ELSE BEGIN
    idxStk := idxStk + 1;
    LiFo[idxStk] := nVal
  END
END;

{----------------
{ Recall from stack
}
FUNCTION LiFoPop : INTEGER;
BEGIN
  IF idxStk < 1 THEN
    DispError(STACK_UFLOW)
  ELSE BEGIN
    LiFoPop := LiFo[idxStk];
    idxStk := idxStk - 1
  END
END;

{---------------------
{ Read next source line into global buffer, skipping blank lines.  A space
{ is appended to ensure that the last token on lines which do no end in a
{ terminator will not "run onto" the first token of the next line.  An EOF
{ mark is appended to the last line preventing extraneous errors at the end
{ of file.
}
PROCEDURE GetSourceLine;
BEGIN
  REPEAT
    ReadLn(Ipf, stSrcLn);
    stSrcLn := stSrcLn + ' ';
    SrcLnLen := LENGTH(stSrcLn);
    LnNo := LnNo + 1
  UNTIL (SrcLnLen > 1) OR (EOF(Ipf));
  IF EOF(Ipf) THEN BEGIN
    SrcLnLen := SrcLnLen + 1;
    stSrcLn := stSrcLn + EOF_MARK
  END;
  idxBuf := 0
END;

{---------------
{ Read Source, character at a time..
}
PROCEDURE GetSourceChar (VAR ch : CHAR);
BEGIN
  IF idxBuf >= SrcLnLen THEN
    GetSourceLine;
  idxBuf := idxBuf + 1;
  ch := stSrcLn[idxBuf]
END;

{-------------------
{ Scan source line for next token..
}
PROCEDURE GetNextToken(VAR Tk : TOKEN);
VAR
  ch : CHAR;
  stTok : TSTRING;
  n  : INTEGER;
  Lvar : LONGINT;

  {-------------
  { Binary search reserved word table for token (there are better ways,
  { see Wirth's text "DS + A = P") but for a compiler of tiny programs
  { this will do..
  }
  FUNCTION IsReserved(stTok : TSTRING) : RC_TOKEN;
  VAR
    i, j, k : INTEGER;
  BEGIN
    WHILE LENGTH(stTok) < MAXTOKEN DO
      stTok := stTok + ' ';
    i := 1;
    j := MAXRESWORDS;
    k := (i + j) DIV 2;
    WHILE (j > i) AND (stTok <> RESWORD[k]) DO BEGIN
      IF stTok < RESWORD[k] THEN
        j := k - 1
      ELSE
        i := k + 1;
      k := (i + j) DIV 2;
    END;
    IF stTok = RESWORD[k] THEN
      IsReserved := RC_TOKEN(k)
    ELSE
      IsReserved := RC_NULL;
  END;

  {-----------
  { extract a delimited thingy from the source
  }
  PROCEDURE FetchToken;
  BEGIN
    stTok := '';
    ch := Lastch;
    WITH Tk DO BEGIN
      WHILE (ch = ' ') AND (ch <> EOF_MARK) DO
        GetSourceChar(ch);
      IF ch = EOF_MARK THEN
        DispError(EOF_FOUND);
      {
      { Process Reserved word or Identifier
      }
      IF IsChar(ch) THEN BEGIN
        n := 0;
        WHILE IsDigit(ch) OR IsChar(ch) OR (ch = '_') DO BEGIN
          IF (n < MAXTOKEN) THEN BEGIN
            stTok := stTok + UPCASE(ch);
            n := n + 1;
          END;
          GetSourceChar(ch);
        END;
        ID := IsReserved(stTok);
        IF ID = RC_NULL THEN BEGIN
          sTokLit  := stTok;
          ID := RC_IDENT
        END
      END
      {
      { Process numeric argument
      }
      ELSE IF IsDigit(ch) THEN BEGIN
        REPEAT
          sTokLit := sTokLit + ch;
          GetSourceChar(ch);
        UNTIL NOT IsDigit(ch);
        VAL(sTokLit, Lvar, TokVal);
        IF (Lvar > MAXINT) OR (Lvar < MININT) THEN
          DispError(BAD_INTEGER)
        ELSE BEGIN