haben wir schon Ostern ? - wer findet den Fehler ?

[paule32.jk]

Hallo,
ich habe folgenden Code, aber irgendwo muss da noch ein Fehler sein (in Emulate):

Delphi-Quellcode:

// ---------------------------------------------------------------------
// File:   copyTestScanner.pas
// Author: (c) 2023 by Jens Kallup - paule32
//         all rights reserved.
//
// only free for education, and non-profit !
// ---------------------------------------------------------------------
unit Scanner;

interface

resourcestring
  ERR_SCANNER_UNEXPECTED_CHAR = 'Error: 0: Scnner: Unexpected char found in stream.';
  ERR_PARSER_EXPECTED = 'Error 1: Parser: %s expected, %s found instead';
  ERR_PARSER_UNALLOWED_STATEMENT = 'Error 2: Parser: unallowed Statement';
  ERR_PARSER_WRONG_PROCEDURE_ENDED = 'Error 3: Parser: Procedure end %s expected, but %s found';
  ERR_PARSER_UNKNOWN_IDENT = 'Error 4: Parser: Unknown Identifier';
  ERR_PARSER_VAR_CONSTANT_EXPECTED = 'Error 5: Parser: Variable or Constant expected';
  ERR_PARSER_VAR_EXPECTED = 'Error 6: Parser: Variable expected';
  ERR_PARSER_PROCEDURE_EXPECTED = 'Error 7: Parser: Procedure expected';
  ERR_PARSER_NO_CONST_ALLOWED = 'Error 8: Parser: No Constant allowed here';

  procedure LexScanner(filename: String);

(* Testscript.pas:

   unit test;
   var a;
   begin
     a := 42;
     write a;
   end test;
 *)
implementation

uses
  Vcl.Forms, Vcl.Dialogs, System.SysUtils, Unit2;

type
  TSymbol = (
    sUnknown, sIdent, sInteger, sPlus, sMinus, sStar, sSlash, sEqual,
    sSmaller, sBigger, sBiggerEqual, sSmallerEqual, sUnEqual,
    sOpenBracket, sCloseBracket, sComma, sDot, sSemiColon, sBecomes,
    sVar, sConst, sProcedure, sBegin, sEnd, sIf, sThen,
    sElseIf, sElse, sWhile, sDo, sUnit, sWrite,
    sNone
    );

const
  cSymbols : Array[TSymbol] of String = (
    '','','','+','-','*','/','=',
    '<','>','>=','<=','#',
    '(',')',',','.',';',':=',
    'VAR','CONST','PROCEDURE','BEGIN','END','IF','THEN',
    'ELSEIF','ELSE','WHILE','DO','UNIT','WRITE',
    ''
    );
type
  TIdentType = (itConstant, itVariable, itProcedure);
  TIdent = record
    name: String;
    case kind: TIdentType of
      itConstant: (val: Integer);
      itVariable,
      itProcedure: (level,adr,size: Integer);
  end;
  TIdentList = Array of TIdent;

  TOpCode = (lit,opr,lod,sto,cal,int,jmp,jpc,wri);
  Instruction = record
    f: TOpCode; // command
    l: Byte;    // level
    a: Integer; // address
  end;

  TInstructions = Array of Instruction;
  PInstructions = ^TInstructions;

var
  Table: TIdentList;
  Code: TInstructions;

  Instructions : TInstructions;

  cx: Integer;  // code position

  ID: String;
  num: Integer;

var
  ch: Char;
  str: String;
  Symbol: TSymbol;

var
  inFile: File;
  bcFile: File of Byte;
  Line: Integer;

procedure Error(ErrorText: String);
var
  s: String;
begin
  s := Format('%d: ' + ErrorText, [Line]);
  raise Exception.Create(s);
end;

procedure ErrorExpected(Expected: Array of TSymbol; Found: TSymbol);
const
  eSymbols : Array[TSymbol] of String = (
    'Unknown','Identifier','Integer','+','-','*','/','=',
    '<','>','>=','<=','#',
    '(',')',',','.',';',':=',
    'VAR','CONST','PROCEDURE','BEGIN','END','IF','THEN',
    'ELSEIF','ELSE','WHILE','DO','UNIT','WRITE',
    '!none!'
    );
var
  ExpectedSymbol: String;
  i: Integer;
  s: String;
begin
  ExpectedSymbol := eSymbols[Expected[Low(Expected)]];
  for I := Low(Expected)+1 to High(Expected) do
  ExpectedSymbol := ExpectedSymbol + ', ' + eSymbols[Expected[i]];

  s := System.SysUtils.Format('%d: '
  + ERR_PARSER_EXPECTED,[Line,ExpectedSymbol,eSymbols[Found]]);

  raise Exception.Create(s);
end;

procedure Emulate;
const
  StackSize = 1024;
var
  p,b,t: Integer;
  i: TInstructions;
  s: Array[1..StackSize] of Integer;

  function Base(a: Integer): Integer;
  var
    b1: Integer;
  begin
    b1 := b;
    while a > 9 do
    begin
      b1 := s[b1];
      dec(a);
    end;
    base := b1;
  end;
begin
  Form2.FEditorFrame.Memo2.Lines.Add('Interpreting Code');
  showmessage('size: ' + inttostr(sizeof(instructions)));
  SetLength(i,sizeof(TInstructions)*4);
  t := 0;
  b := 1;
  p := -1;
  s[1] := 0;
  s[2] := 0;
  s[3] := 0;
  repeat
    inc(p);
    with Instructions[p] do
    begin
      case f of
        lit:
        begin
        showmessage('11111');
          inc(t);
          s[t] := a;
        end;
        lod:
        begin
        showmessage('2222');
          inc(t);
          s[t] := s[base(l)+a];
        end;
        sto:
        begin
        showmessage('3333');
          s[base(l)+a] := s[t];
          dec(t);
        end;
        cal:
        begin
        showmessage('444');
          s[t + 1] := base(l);
          s[t + 2] := b;
          s[t + 3] := p;
          b := t + 1;
          p := a;
        end;
        int: t := t + a;
        jmp: p := a;
        jpc:
        begin
          if s[t] = 0 then p := a;
          dec(t);
        end;
        wri:
        begin
        showmessage('6666');
          Form2.FEditorFrame.Memo2.Lines.Add(
          'wri: ' + IntToStr(s[t]));
          dec(t);
        end;
        opr:
        begin
          case a of
            0:
            begin
              t := b - 1;
              p := s[ t + 3];
              b := s[ t + 2];
            end;
            1:
            begin
              s[t] := -s[t];  // negation
            end;
            2:
            begin
              // addition
              dec(t);
              s[t] := s[t] + s[t + 1];
            end;
            3:
            begin
              // subtraction
              dec(t);
              s[t] := s[t] - s[t + 1];
            end;
            4:
            begin
              // multiplication
              dec(t);
              s[t] := s[t] * s[t + 1];
            end;
            5:
            begin
              // division
              dec(t);
              s[t] := s[t] div s[t + 1];
            end;
            8:
            begin
              // Equal
              dec(t);
              s[t] := Ord(s[t] = s[t + 1]);
            end;
            9:
            begin
              // unequal
              dec(t);
              s[t] := Ord(s[t] <> s[t + 1]);
            end;
            10:
            begin
              // smaller
              dec(t);
              s[t] := Ord(s[t] < s[t + 1]);
            end;
            11:
            begin
              // bigger
              dec(t);
              s[t] := Ord(s[t] > s[t + 1]);
            end;
            12:
            begin
              // biggerequal
              dec(t);
              s[t] := Ord(s[t] >= s[t + 1]);
            end;
            13:
            begin
              // smallerequal
              dec(t);
              s[t] := Ord(s[t] <= s[t + 1]);
            end; else
            begin
              raise Exception.Create('Unknown Operand');
            end;
          end;
        end; else
        begin
          raise Exception.Create('Unknown opcode');
        end;
      end;
    end;
  until p = 0;
end;

procedure Expect(Expected: TSymbol);
begin
  if Symbol <> Expected then
  ErrorExpected([Expected], Symbol);
end;

procedure GenCode(f: TOpCode; l,a: Integer);
begin
  if cx > Length(Code) - 1 then
  SetLength(code, Length(code) + 64);
  Code[cx].f := f;
  Code[cx].a := a;
  Code[cx].l := l;
  inc (cx);
end;

procedure GetSym;
  procedure GetCh;
  begin
    if not Eof(inFile) then
    BlockRead(inFile, ch, 1) else
    ch := ' ';
    ch := UpCase(ch);  // case in-sensitive

    if ch = #13 then inc(Line);
    if Ord(ch) < Ord(' ') then ch := ' ';
  end;
  var i: TSymbol;
begin
  while true do
  begin
    str := '';
    Symbol := sNone;

    while (ch = ' ') and not Eof(inFile) do
    GetCh;

    if Eof(inFile) then
    exit;

    case ch of
      // ident/reserved word
      'A'..'Z', '_':
      begin
        while ch in ['A'..'Z','_','0'..'9'] do
        begin
          str := str + ch;
          GetCh;
        end;
        Symbol := sIdent;

        for i := sUnknown to sNone do
        begin
          if str = cSymbols[I] then
          begin
            Symbol := i;
            break;
          end;
        end;

        if Symbol = sIdent then
        ID := str;

        exit;
      end;

      // symbols that consists only of one char
      ';','+','-','=','#',',','.','*','/':
      begin
        str := ch;
        Symbol := sUnknown;
        for i := sUnknown to sNone do
        begin
          if str = cSymbols[i] then
          begin
            Symbol := i;
            break;
          end;
        end;
        GetCh;
        exit;
      end;

      // chars, that can contain forward chars (=)
      ':','<','>':
      begin
        str := ch;
        GetCh;
        if ch = '=' then str := str + ch;
        GetCh;
        Symbol := sUnknown;
        for i := sUnknown to sNone do
        begin
          if str = cSymbols[i] then
          begin
            Symbol := i;
            break;
          end;
        end;
        exit;
      end;

      // parens, and comas
      '(',')':
      begin
        str := ch;
        GetCh;
        if (str = '(') and (ch = '*') then
        begin
          // skip comment
          GetCh;
          while true do
          begin
            GetCh;
            if ch = '*' then
            begin
              GetCh;
              if ch = ')' then
              begin
                Getch;
                break;
              end;
            end else
            begin
              if Eof(inFile) then
              break;
            end;
          end;
        end else
        begin
          if str = '(' then
          begin
            Symbol := sOpenBracket;
            exit;
          end else
          if str = ')' then
          begin
            Symbol := sCloseBracket;
            exit;
          end;
        end;
      end;

      // digits
      '0'..'9','$':
      begin
        Symbol := sInteger;
        str := ch;
        GetCh;
        if str = '$' then  // hex value
        begin
          while ch in ['0'..'9','A'..'F'] do
          begin
            str := str + ch;
            GetCh;
          end;
          exit;
        end else
        begin
          while ch in ['0'..'9'] do
          begin
            str := str + ch;
            GetCh;
          end;
          exit;
        end;
      end;
      else Error(ERR_SCANNER_UNEXPECTED_CHAR);
    end;
    Assert(Symbol <> sUnknown);
  end;
end;

procedure Module;
  function Position(ID: String; TablePosition: Integer): Integer;
  var
    i: Integer;
  begin
    Table[0].name := ID;
    I := TablePosition;
    while Table[I].name <> ID do
    dec(i);
    result := I;
  end;
  procedure StatementSequence(TablePosition, lev: Integer);
    procedure Statement;
      procedure Expression;
        procedure Term;
          procedure Factor;
          var
            identPos: Integer;
          begin
            if (Symbol in [sIdent]) then
            begin
              identPos := Position(ID,TablePosition);

              if identPos = 0 then
              Error(ERR_PARSER_UNKNOWN_IDENT);

              if Table[identPos].kind = itProcedure then
              Error(ERR_PARSER_VAR_CONSTANT_EXPECTED);

              case Table[identPos].kind of
                itConstant: GenCode(lit, 0,  Table[identPos].val);
                itVariable: GenCode(lod, lev-Table[identPos].level,Table[identPos].val);
              end;

              GetSym;
            end else
            if (Symbol = sInteger) then
            begin
              GenCode(lit,0,num);
              GetSym;
            end else
            if (Symbol = sOpenBracket) then
            begin
              GetSym;
              Expression;
              Expect(sCloseBracket);
              GetSym;
            end else
            ErrorExpected([sIdent, sInteger, sOpenBracket],Symbol);
          end;
        var
          operation: TSymbol;
        begin
          Factor;
          while Symbol in [sStar, sSlash] do
          begin
            Operation := Symbol;
            GetSym;
            Factor;
            case Operation of
              sStar:  GenCode(opr,0,4);
              sSlash: GenCode(opr,0,5);
            end;
          end;
        end;
      var
        Operation: TSymbol;
      begin
        if Symbol in [sPlus, sMinus] then
        begin
          Operation := Symbol;
          GetSym;
          Term;
          if Operation = sMinus then
          GenCode(opr,0,1);
        end else
        Term;
        while Symbol in [sPlus, sMinus] do
        begin
          Operation := Symbol;
          GetSym;
          Term;
          case Operation of
            sPlus:  GenCode(opr,0,2);
            sMinus: GenCode(opr,0,3);
          end;
        end;
      end;
      procedure Condition;
      var
        Operation: TSymbol;
      begin
        Expression;
        Operation := Symbol;
        GetSym;
        Expression;
        case Operation of
          sEqual: GenCode(opr,0,8);
          sSmaller:      GenCode(opr,0,10);
          sBigger:       GenCode(opr,0,11);
          sBiggerEqual:  GenCode(opr,0,12);
          sSmallerEqual: GenCode(opr,0,13);
          sUnEqual:      GenCode(opr,0, 9);
          else ErrorExpected(
          [sEqual, sSmaller, sBigger, sBiggerEqual, sSmallerEqual, sUnequal],
          Symbol)
        end;
      end;
    var
      identPos: Integer;
      ident: String;
      CodePosition1, CodePosition2: Integer;
    begin
      case Symbol of
        sIdent: begin
          ident := id;
          identPos := Position(ID, TablePosition);

          if identPos = 0 then
          Error(ERR_PARSER_UNKNOWN_IDENT);

          if Table[identPos].kind = itProcedure then
          begin
            // procedure call
            GenCode(cal,lev-Table[identPos].level,Table[identPos].adr);
            GetSym;
          end else

          if Table[identPos].kind = itVariable then
          begin
            GetSym;
            Expect(sBecomes);
            GetSym;
            Expression;
            GenCode(sto,lev-Table[identPos].level,Table[identPos].adr);
          end else
          Error(ERR_PARSER_NO_CONST_ALLOWED);
        end;
        sWrite: begin
          GetSym;
          Expression;
          GenCode(wri,0,0);
        end;
        sIf: begin
          GetSym;
          Condition;
          Expect(sThen);
          GetSym;

          CodePosition1 := cx;
          GenCode(jpc,0,0);

          StatementSequence(TablePosition,lev);
          Expect(sEnd);
          GetSym;

          CodePosition2 := cx;
          GenCode(jmp,0,0);

          Code[CodePosition1].a := cx;

          while Symbol = sElseIf do
          begin
            GetSym;
            Condition;
            Expect(sThen);
            GetSym;

            CodePosition1 := cx;
            GenCode(jpc,0,0);

            StatementSequence(TablePosition,lev);
            Expect(sEnd);
            GetSym;

            Code[CodePosition2].a := cx;
            CodePosition2 := cx;
            GenCode(jmp,0,0);

            Code[CodePosition1].a := cx;
          end;
          if Symbol = sElse then
          begin
            GetSym;
            StatementSequence(TablePosition,lev);
            Expect(sEnd);
            GetSym;
            Code[CodePosition2].a := cx;
          end;
        end;
        sWhile: begin
          GetSym;
          CodePosition2 := cx;

          Condition;
          Expect(sDo);
          GetSym;

          CodePosition1 := cx;
          GenCode(jpc,0,0);

          StatementSequence(TablePosition,lev);
          Expect(sEnd);

          GenCode(jmp,0,0);
          GetSym;

          Code[CodePosition1].a := cx;
        end;
        sBegin: begin
          GetSym;
          StatementSequence(TablePosition,lev);
          Expect(sEnd);
          GetSym;
        end;
        else begin
          //dummy error
        end;
      end;
    end;
  begin
    Statement;
    while Symbol = SSemiColon do
    begin
      GetSym;
      Statement;
    end;
  end;
  function Declarations(TablePosition: Integer; lev: Integer): Integer;
  var
    DataPos: Integer;
    InitTablePos: Integer;
    InitCodePos: Integer;

    procedure Enter(Typ: TIdentType);
    begin
      inc(TablePosition);
      if TablePosition > Length(Table) - 1 then
      SetLength(Table, Length(Table) + 16);
      with Table[TablePosition] do
      begin
        name := ID;
        kind := Typ;
        case kind of
          itVariable: begin
            level := lev;
            adr := DataPos;
            inc(DataPos);
          end;
          itConstant : val   := num;
          itProcedure: level := lev;
        end;
      end;
    end;
    procedure ProcedureDecl;
    var
      ProcedureName: String;
      ProcTablePos: Integer;
    begin
      Expect(sProcedure);
      GetSym;
      Expect(sIdent);
      Enter(itProcedure);
      ProcedureName := ID;

      GetSym;
      Expect(sSemiColon);
      GetSym;

      ProcTablePos := Declarations(TablePosition,lev+1);
      Expect(sBegin);
      GetSym;

      StatementSequence(ProcTablePos, lev+1);
      Expect(sEnd);
      GetSym;

      Expect(sIdent);
      if ProcedureName <> ID then
      begin
        Error(Format(ERR_PARSER_WRONG_PROCEDURE_ENDED,
        [ProcedureName, ID]));
      end;
      GetSym;
      Expect(sSemiColon);

      GenCode(opr,0,0);  // return back to sub caller
      GetSym;
    end;
    procedure ConstDecl;
    begin
      Expect(sIdent);
      GetSym;
      Expect(sEqual);
      GetSym;
      Expect(sInteger);
      Enter(itConstant);
      GetSym;
    end;
    procedure VarDecl;
    begin
      Expect(sIdent);
      Enter(itVariable);
      GetSym;
      while Symbol = sComma do
      begin
        GetSym;
        Expect(sIdent);
        Enter(itVariable);
        GetSym;
      end;
    end;
  begin
    DataPos := 3;
    InitTablePos := TablePosition;
    InitCodePos := cx;
    Table[TablePosition].adr := cx;

    GenCode(jmp,0,0);
    while Symbol in [sVar, sConst, sProcedure] do
    case Symbol of
      sVar: begin
        GetSym;
        VarDecl;
        Expect(sSemiColon);
        GetSym;
        while Symbol = sIdent do
        begin
          VarDecl;
          Expect(sSemiColon);
          GetSym;
        end;
      end;
      sConst: begin
        GetSym;
        ConstDecl;
        Expect(sSemiColon);
        GetSym;
        while Symbol = sIdent do
        begin
          ConstDecl;
          Expect(sSemiColon);
          GetSym;
        end;
      end;
      sProcedure: begin
        ProcedureDecl;
      end;
    end;

    Code[Table[InitTablePos].adr].a := cx;
    with Table[InitTablePos] do
    begin
      adr := cx;
      size := DataPos;
    end;

    // allocate memory space
    GenCode(int,0,DataPos);
    result := TablePosition;
  end;
var
  TablePosition: Integer;
  UnitName: String;
begin
  Expect(sUnit);
  GetSym;
  Expect(sIdent);
  UnitName := id;
  showmessage(unitname);
  GetSym;
  Expect(sSemiColon);
  GetSym;

  TablePosition := Declarations(0,0);
  Expect(sBegin);
  GetSym;
  StatementSequence(TablePosition,0);
  Expect(sEnd);

  // the end
  GenCode(jmp,0,0);

  GetSym;
  Expect(sIdent);
  if UnitName <> ID then
    raise Exception.Create(Format(
    '%d: Warning: Module ID <> End ID. Code already generated.',
    [Line]));

  GetSym;
  Expect(sSemiColon);
  GetSym;

  if Symbol <> sNone then
  raise Exception.Create(Format(
    '%d: Code after unit END is ignored!',
    [Line]));
end;

procedure LexScanner(filename: String);
var
  F: File of Instruction;
  i: Integer;
  FSize: Integer;
  s: String;
  buffer: Array of TInstructions;
begin
  try
    try
      AssignFile(inFile, filename);
      Reset(inFile,1);
      ch := ' ';
      Line := 1;
      cx := 0;
      SetLength(Table,1);
      GetSym;
      Module;

      s := ChangeFileExt(filename,'.bin');
      AssignFile(F,s);
      ReWrite(F);

      i := 0;
      while i < cx do
      begin
        Write(F,Code[i]);
        inc(i);
      end;

      with Form2.FEditorFrame.Memo2.Lines do
      begin
        Clear;
        Add('Done, no syntax errors detected... Code success');
        Add(Format('# Instructions: %d',[cx]));
        Add(Format('# Code size   : %d',[(cx) * sizeof(Instruction)]));
      end;

      Close(F);
      Close(inFile);

      AssignFile(bcFile,s);
      FileMode := 0;  // read only
      Reset(bcFile);

      FSize := FileSize(bcFile);
      SetLength(Instructions,FSize div sizeof(Instruction));
      BlockRead(bcFile,Instructions,FSize);
      Emulate;
      SetLength(Instructions,0);

    except
      on E: Exception do
      begin
        ShowMessage('Exception'
        + #13#10
        + 'Message: '
        + E.Message);
      end;
    end;
  finally
    CloseFile(bcFile);
    CloseFile(F);
    CloseFile(inFile);
  end;
end;

end.