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.

[Kas Ob.]

Don't know about this file format, but you did ask a different question in different post, and you did a mistake in both of them.

This is wrong

Code:

buffer: Array of TInstructions;

And should be one of the following

Code:

buffer: Array of TInstruction; //   or 
buffer: TInstructions;

The rest i can't say.

[Redeemer]

"Hallo, ich habe irgendwas vor und habe hier knapp 1000 Zeilen Code. Irgendwo ist irgendein Fehler, wenn ich irgendwas mache."

[paule32.jk]

schon gut...
schreib ja nichts mehr dazu

[TurboMagic]

Das bedeutet ja nicht, dass du nix mehr schreiben sollst, sondern uns nur etwas mehr Infos gebe.
Was für eine Art Fehler? Compiler meckert oder zur Laufzeit kommt was falsches raus?
Falls ersteres welche Fehlermeldung, falls letzteres womit wurde das Programm gefüttert
und welches Ergebnis wurde erwartet?

Andere Frage: was macht das Programm eigentlich? Ich habe den Verdacht es soll irgendwie Delphi Code analysieren?

[paule32.jk]

mit analysieren gehts in die Richtung, ja.
Aber kein Compiler oder so.
Mehr Skripting Lexer, ja.
Beim kompilieren kommt kein Fehler.
Beim lesen der Datei-Daten kommt auch kein Fehler.
Nur beim ausführen - an den angeführten Stellen:

Es scheint, ich reserviere den Speicher richtigerweise,
Da ich bei:
ShowMessage('buf: ' + inttostr(FSize));

den Wert 57 erhalte.

und oberhalb der while Schleife in Emulate erhalte ich in den ersten 3 ShowMessage's
Werte > 0 (8).

Code:

// hier erhalte ich jeweils: 8
ShowMessage('mem 1: ' + inttostr(sizeof(Instructions[p])));
ShowMessage('mem 2: ' + inttostr(sizeof(Instructions[p+1])));

// hier erhalte ich einen Crash:
ShowMessage('opr: ' + inttostr(Instructions[p].a));

// und dann geht es in der Emulate Prozedure auch nicht weiter:
with Instructions[p] do

Delphi-Quellcode:

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);

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);
  PInstruction = ^TInstruction;
  TInstruction = record
    f: TOpCode; // command
    l: Byte;    // level
    a: Integer; // address
  end;

var
  Table: TIdentList;
  Instructions: Array of TInstruction;

  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;
  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)));
  t := 0;
  b := 1;
  p := -1;
  s[1] := 0;
  s[2] := 0;
  s[3] := 0;
  repeat
    inc(p);
    ShowMessage('len: ' + inttostr(sizeof(Instructions)));
    ShowMessage('mem 1: ' + inttostr(sizeof(Instructions[p])));
    ShowMessage('mem 2: ' + inttostr(sizeof(Instructions[p+1])));

    ShowMessage('opr: ' + inttostr(Instructions[p].a));

    with Instructions[p] do
    begin
    showmessage('huhu');
      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 = 4;
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(Instructions) - 1 then
  SetLength(Instructions, Length(Instructions) + 64);
  Instructions[cx].f := f;
  Instructions[cx].a := a;
  Instructions[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);

          Instructions[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;

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

            Instructions[CodePosition1].a := cx;
          end;
          if Symbol = sElse then
          begin
            GetSym;
            StatementSequence(TablePosition,lev);
            Expect(sEnd);
            GetSym;
            Instructions[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;

          Instructions[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;

    Instructions[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 TInstruction;
  i: Integer;
  FSize: Integer;
  s: String;
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,Instructions[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(Instructions)]));
      end;

      Close(F);
      Close(inFile);

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

      FSize := FileSize(bcFile);
      SetLength(Instructions,FSize);
      BlockRead(bcFile,Instructions,FSize div sizeof(TInstruction));
ShowMessage('buf: ' + inttostr(FSize));
      ShowMessage('---> ' + IntToStr(FSize div sizeof(TInstruction)));
      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.

[Kas Ob.]

I can't imagine the amount of time you are wasting of clicking enter on messages from ShowMessage, do yourself a favor and use some logging method.

The file you are loading, where did it come from ?
What is its format ?
If it is yours or not, check data aligning for that TInstruction record, you might need to declare that record as packed, just make sure it is the same size with the same padding.

You have potential problem with "p" you are starting it with -1 then using p, p+1 so this an AV waiting for you when things will start work and you need more than 4.

Not sure about your question to be honest, but sizeof(Instructions[p]) should never change and it is constant, so double checking it with p+1 is useless.

[Daniel]

@paule: Bitte versuche, Deinen Themen aussagekräftige Titel zu geben. Und eingrenzen musst du den Fehler schon selbst – es ist nicht Sinn und Zweck dieses Forums, einfach einen Haufen Code kommentarlos rein zu werfen mit der Bitte, einen Fehler zu finden. Im Kern wirst du dich schon selbst damit befassen müssen.

[paule32.jk]

@Daniel, okay. Nächste mal will ich versuchen, besser zu werden.

Aber wie schon geschrieben:
- das auslesen der Größe ist kein Problem
- habe nun "packed record" und die Datei test.bin ist nur noch 42 Byte groß
- im Designer wie auch zur Laufzeit bekomme ich eine AV, und der Debugger Stack im Designer zeigt mir nicht die richtigen Werte für:

var op: TInstruction;
op := Instruction[0].f;

an.
ich bekomme dann eine AV, und der Debugger springt dann an.
Und dort ist dann auch die Stelle, wo ich festsitze - wie ich schon schrieb, bei:

var op : TOpCode;
op := Instruction[p].f;

@kas ob:
The file is created by the source code, you can see it in this Post.
I called it 'test.source.bin' at:
LexScanner('test.source.pas');

- test.source.pas is the script source file
- in source code, i change the .pas Extension with .bin:
s := ChangeFileExt(filename,'.bin');

where "filename" is: 'test.source.pas'.

[mytbo]

Zitat von paule32.jk:

ich bekomme dann eine AV, und der Debugger springt dann an.
Und dort ist dann auch die Stelle, wo ich festsitze - wie ich schon schrieb, bei:

var op : TOpCode;
op := Instruction[p].f;

Lese bitte den Umgang mit dynamischen Arrays in der Hilfe nach:

Delphi-Quellcode:

type
  TOpCode = (ocLit, ocOpr, ocLod, ocSto, ocCal, ocInt, ocJmp, ocJpc, ocWri);
  TInstruction = record
    f: TOpCode; // command
    l: Byte; // level
    a: Integer; // address
  end;
  PInstruction = ^TInstruction;

  TInstructions = array of TInstruction;

var
  ins: PInstruction;
  insArr: TInstructions;
begin
  SetLength(insArr, 2);
  insArr[0].f := ocLit;
  insArr[1].f := ocJmp;
  for var i: Integer := Low(insArr) to High(insArr) do
    ShowMessage(Format('OpCode: %s', [System.TypInfo.GetEnumName(TypeInfo(TOpCode), Ord(insArr[i].f))]));

  for var i: Integer := 0 to Length(insArr) - 1 do
  begin
    ins := @insArr[i];
    ShowMessage(Format('OpCode: %s', [System.TypInfo.GetEnumName(TypeInfo(TOpCode), Ord(ins.f))]));
  end;

Bis bald...
Thomas