AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
• Registrieren
Zurück Delphi-PRAXiS Programmierung allgemein Programmieren allgemein haben wir schon Ostern ? - wer findet den Fehler ?
Thema durchsuchen
Ansicht
Themen-Optionen

haben wir schon Ostern ? - wer findet den Fehler ?

Ein Thema von paule32.jk · begonnen am 21. Okt 2023 · letzter Beitrag vom 1. Nov 2023
Antwort Antwort
Benutzerbild von paule32.jk
paule32.jk

Registriert seit: 24. Sep 2022
Ort: Planet Erde
356 Beiträge
 
Delphi 11 Alexandria
 
#1

haben wir schon Ostern ? - wer findet den Fehler ?

  Alt 21. Okt 2023, 13:16
Hallo,
ich habe folgenden Code, aber irgendwo muss da noch ein Fehler sein (in Emulate):
zusammenfalten · markieren
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.
Frag doch einfach
Alles was nicht programmiert werden kann, wird gelötet
  Mit Zitat antworten Zitat
Kas Ob.

Registriert seit: 3. Sep 2023
386 Beiträge
 
#2

AW: haben wir schon Ostern ? - wer findet den Fehler ?

  Alt 21. Okt 2023, 13:30
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
markieren
Code:
buffer: Array of TInstructions;
And should be one of the following
markieren
Code:
buffer: Array of TInstruction; //   or
buffer: TInstructions;
The rest i can't say.
Kas
  Mit Zitat antworten Zitat
Redeemer

Registriert seit: 19. Jan 2009
Ort: Kirchlinteln (LK Verden)
1.108 Beiträge
 
Delphi 2009 Professional
 
#3

AW: haben wir schon Ostern ? - wer findet den Fehler ?

  Alt 21. Okt 2023, 16:19
"Hallo, ich habe irgendwas vor und habe hier knapp 1000 Zeilen Code. Irgendwo ist irgendein Fehler, wenn ich irgendwas mache."
Janni
2005 PE, 2009 PA, XE2 PA
  Mit Zitat antworten Zitat
Benutzerbild von paule32.jk
paule32.jk

Registriert seit: 24. Sep 2022
Ort: Planet Erde
356 Beiträge
 
Delphi 11 Alexandria
 
#4

AW: haben wir schon Ostern ? - wer findet den Fehler ?

  Alt 21. Okt 2023, 16:28
schon gut...
schreib ja nichts mehr dazu
Frag doch einfach
Alles was nicht programmiert werden kann, wird gelötet
  Mit Zitat antworten Zitat
TurboMagic

Registriert seit: 28. Feb 2016
Ort: Nordost Baden-Württemberg
3.023 Beiträge
 
Delphi 12 Athens
 
#5

AW: haben wir schon Ostern ? - wer findet den Fehler ?

  Alt 21. Okt 2023, 16:34
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?
  Mit Zitat antworten Zitat
Benutzerbild von paule32.jk
paule32.jk

Registriert seit: 24. Sep 2022
Ort: Planet Erde
356 Beiträge
 
Delphi 11 Alexandria
 
#6

AW: haben wir schon Ostern ? - wer findet den Fehler ?

  Alt 21. Okt 2023, 16:55
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).

markieren
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

zusammenfalten · markieren
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.
Frag doch einfach
Alles was nicht programmiert werden kann, wird gelötet
  Mit Zitat antworten Zitat
Antwort Antwort

« Vorheriges Thema | Nächstes Thema »

Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.
BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus
Gehe zu:

• Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 03:15 Uhr.
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024 by Thomas Breitkreuz