Einzelnen Beitrag anzeigen

Master of the Wind

Registriert seit: 20. Dez 2005
26 Beiträge
 
#23

Re: Problem bei TStringlist Freigabe

  Alt 22. Dez 2005, 14:00
Also ich schreib doch mal den ganzen Code rein also hier ist er

Kernelunit:

Delphi-Quellcode:
unit Kernelunit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, AppEvnts, typenunit,dglopengl,Inifiles;

type
  PKernel = ^TKernel;
  Tfunc=procedure (data:PKernel);stdcall;
  PFunktionsglied=^TFunktionsglied;
  TFunktionsglied=record
    davor:PFunktionsglied;
    Funktion:cardinal;
    danach:PFunktionsglied;
  end;
  
  TKonsole=class
    private
      FMsgpos:integer;
      FBGColor:TRGBi;
      Fvisible:boolean;
      Fontsize:byte;
      procedure SetBGColor(BGColor:TRGBi);
      procedure Setmsgpos(msgpos:integer);
      procedure ChangeVisible(visible:boolean);
    public
      keycodes:TInifile;
      Script:TStringlist;
      Msglist:TStringlist;
      keyboardinput:array of word;
      keycount:word;
      Scriptpos:cardinal;
      maxlines:word;
      systemfont:cardinal;
      systempfad:string;
      befehl:string;
      value:Tstrarr;
      translatedkeyarray:string;
      dauer:cardinal;
      change:boolean;
      booted:boolean;
      port:Tviewport;
      constructor create(AOwner:TComponent);
      destructor destroy;override;
      property BGColor:TRGBi read FBGColor write SetBGColor;
      property visible:boolean read Fvisible write ChangeVisible;
      property msgpos:integer read fmsgpos write Setmsgpos;
      procedure Init(port:Tviewport);
      procedure MsgToBuffer();
      procedure addmsg(text:string;color:TRGBi);
      procedure addscript(text:string);
      function TranslateKeyarray():string;
      procedure Keyinterpret(Sender: TObject; var Key: Word;
      Shift: TShiftState);
      procedure makefree;
  end;

  TOpenGL =class
    private
      fdc:Hdc;
      fhrc:hglrc;
      fviewport:TViewport;
      procedure Setdc(dc:hdc);
      procedure Sethrc(hrc:hglrc);
      procedure Setviewport(viewport:TViewport);
    public
      initialized:boolean;
      smartrenderbool:boolean;
      property dc:hdc read fdc write setdc;
      property hrc:hglrc read fhrc write sethrc;
      property viewport:TViewport read fviewport write Setviewport;
      procedure SmartInitialize(Owner:TComponent);
      procedure SmartRender(Owner:TComponent);
      procedure SmartFinalize(Owner:TComponent);
      procedure DestroyDC(Owner:TComponent);
      procedure makefree;
  end;

  TKernel = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
    procedure FormCreate(Sender: TObject);
  private
    Tempspeicher:Tvars;{ Private-Deklarationen }
  public
    tryclose:boolean;
    Konsole:TKonsole;
    OpenGL:TOpenGL;
    funcnames:TStringlist;
    functions:array of TFunc;
    deletedfunctions:array of cardinal;
    dyndllnames:Tstringlist;
    dyndlls:array of Thandle;{ Public-Deklarationen }
    renderfunctionskette:PFunktionsglied;
    procedure Initmemory();
    procedure Freememory();
    procedure Freedlls();
    function GetMemoryVars():TVars;
    function Registervariable(size:Byte):cardinal;
    procedure Freevariable(address:cardinal);
    procedure Funktionsketteabarbeiten(address:PFunktionsglied);
    procedure freefunktionskette(address:PFunktionsglied);
    function Addfunktionsglied(address:PFunktionsglied;functionindex:cardinal;position:cardinal):cardinal;
    function Delfunktionsglied(address:PFunktionsglied;position:cardinal):boolean;
    function Addfunktion(dll:THandle;name:pansichar):integer;
    function Delfunktion(index:cardinal):boolean;
    procedure beenden();
  end;




var
  Kernel: TKernel;

  procedure interpret(data:PKernel);stdcall;external 'script.dll';

implementation

{$R *.dfm}

procedure TKonsole.SetBGColor(BGColor:TRGBi);
begin
  FBGColor[0]:=BGColor[0];
  FBGColor[1]:=BGColor[1];
  FBGColor[2]:=BGColor[2];
end;

procedure TKonsole.addmsg(text:string;color:TRGBi);
begin
  msglist.Add(inttostr((color[0]*1000000)+(color[1]*1000)+(color[2]))+';'+text);
  msgpos:=msglist.Count-maxlines;
end;

procedure TKonsole.addscript(text:string);
begin
  dauer:=0;
  script.Add(text);
end;

function TKonsole.TranslateKeyarray():string;
var i,code:word;
    precode:byte;
    text:string;
begin
  result:='';
  text:='';
  if length(keyboardinput)>0 then
  begin
     for i:=0 to length(keyboardinput)-1 do
     begin
      code:=keyboardinput[i];
      precode:=code div 1000;
      code:=code mod 1000;
      case precode of
      0 : begin
            text:=keycodes.ReadString('nothing',inttostr(code),'');
          end; //Nix
      1 : begin
            text:=keycodes.ReadString('shift',inttostr(code),'');
          end; //Umschalt
      2 : begin
            text:=keycodes.ReadString('alt',inttostr(code),'');
          end; //Alt
      3 : begin
            text:=keycodes.ReadString('shiftalt',inttostr(code),'');
          end; //Alt+Umschalt
      5 : begin
            text:=keycodes.ReadString('ctrl',inttostr(code),'');
          end; //Ctrl
      6 : begin
            text:=keycodes.ReadString('shiftctrl',inttostr(code),'');
          end; //Umschalt+Ctrl
      7 : begin
            text:=keycodes.ReadString('altctrl',inttostr(code),'');
          end; //ctrl+Alt
      8 : begin
            text:=keycodes.ReadString('shiftaltctrl',inttostr(code),'');
          end;
      end; //Umschalt+Alt+Ctrl
        result:=result+text;
        change:=true;
     end;
  end;
end;

constructor TKonsole.create(AOwner:TComponent);
begin
  inherited create;
  systempfad:=extractfiledir((aowner.Owner as TApplication).ExeName);
  Script:=Tstringlist.Create;
  Script.LoadFromFile(systempfad+'\startscript.txt');
  Scriptpos:=0;
  Msglist:=TStringlist.Create;
  Msglist.LoadFromFile(systempfad+'\readme.txt');
  keycodes:=TInifile.Create(systempfad+'\keycodes.ini');
  change:=false;
  booted:=false;
  visible:=false;
  dauer:=0;
  bgcolor:=bgblue;
  fontsize:=20;
  translatedkeyarray:='';
end;

procedure TKonsole.Init(port:Tviewport);
begin
  self.port[0]:=port[0];
  self.port[1]:=port[1];
  self.port[2]:=port[2];
  self.port[3]:=port[3];
  maxlines:=port[3] div fontsize;
  dec(maxlines);
end;

procedure TKonsole.MsgToBuffer();
var line_s,color:string;
    line_b:array of Byte;
    i,j,lines:word;
    icolor:cardinal;
    r,g,b:byte;
begin
  glcolor3f(bgcolor[0]/255,bgcolor[1]/255,bgcolor[2]/255);
  glbegin(gl_quads);
  glvertex3i(port[0],port[1],-1);
  glvertex3i(port[0],port[1]+port[3],-1);
  glvertex3i(port[0]+port[2],port[1]+port[3],-1);
  glvertex3i(port[0]+port[2],port[1],-1);
  glend;
  if msglist.Count>0 then
  begin
    if maxlines>(msglist.Count-msgpos) then lines:=(msglist.Count-msgpos)
                                   else lines:=maxlines;
    for j:=1 to lines do
    begin
    line_s:=msglist.Strings[j+msgpos-1];
    color:=copy(line_s,0,ansipos(';',line_s)-1);
    line_s:=copy(line_s,ansipos(';',line_s)+1,length(line_s));
    if color='then glcolor3f(0.8,0.8,0.8)
    else
    begin
      icolor:=strtoint(color);
      r:=icolor div(1000000);
      g:=(icolor mod(1000000))div(1000);
      b:=icolor mod(1000);
      glcolor3f(1/255*r,1/255*g,1/255*b);
    end;

    glrasterpos3i(port[0],port[1]+port[3]-(fontsize*j),-1);
    gllistbase(systemfont);
    setlength(line_b,length(line_s));
    if length(line_b)>80 then setlength(line_b,80);
    if length(line_s)>0 then for i:=1 to length(line_b) do line_b[i-1]:=ord(line_s[i]);
    if length(line_b)>0 then glcalllists(length(line_b),gl_unsigned_byte,line_b);
    end;
  end;
  glcolor3f(1,1,0);
  glrasterpos3i(port[0],port[1],-1);
  gllistbase(systemfont);
  line_s:=translatedkeyarray;
  setlength(line_b,length(line_s));
  if length(line_b)>80 then setlength(line_b,80);
  if length(line_b)>0 then for i:=1 to length(line_b) do line_b[i-1]:=ord(line_s[i]);
  if length(line_b)>0 then glcalllists(length(line_b),gl_unsigned_byte,line_b);
end;

procedure TKonsole.Setmsgpos(msgpos:integer);
begin
  if msgpos>(msglist.Count-maxlines) then msgpos:=msglist.Count-maxlines;
  if msgpos<0 then msgpos:=0;
  fmsgpos:=msgpos;
  change:=true;
end;

procedure TKonsole.ChangeVisible(visible:boolean);
begin
  Fvisible:=visible;
  keycount:=0;
  setlength(keyboardinput,0);
  if visible then msgpos:=msglist.Count;
end;

procedure TKonsole.Keyinterpret(Sender:Tobject;var Key:Word;Shift:TShiftstate);
var modkey:word;
begin
  case key of
  38 : if msgpos>0 then msgpos:=msgpos-1;
  40 : if msgpos<msglist.Count-1 then msgpos:=msgpos+1;
  8 : if high(keyboardinput)>-1 then
        begin
          setlength(keyboardinput,high(keyboardinput));
          dec(keycount);
          translatedkeyarray:=translatekeyarray;
        end;
  13 : begin
          Addmsg(translatedkeyarray,yellow);
          translatedkeyarray:=translatekeyarray;
          addscript(translatedkeyarray);
          keycount:=0;
          setlength(keyboardinput,keycount);
          translatedkeyarray:=translatekeyarray;
         end;
  else begin
          inc(keycount);
          setlength(keyboardinput,keycount);
          modkey:=key;
          if ssshift in shift then modkey:=modkey+1000;
          if ssalt in shift then modkey:=modkey+2000;
          if ssCtrl in shift then modkey:=modkey+5000;
          keyboardinput[keycount-1]:=modkey;
          translatedkeyarray:=translatekeyarray;
        end;
  end;

end;

destructor TKonsole.destroy;
begin
  if assigned(Msglist) then msglist.Free; //??????????????????????????
  if assigned(script) then script.Free;
  if assigned(keycodes) then keycodes.Free;
  inherited destroy;
end;
procedure TKonsole.makefree;
begin
end;
{------------------------------------------------------------------------------}
procedure TOpenGL.Setdc(dc:hdc);
begin
  fdc:=dc;
end;

procedure TOpenGL.Sethrc(hrc:hglrc);
begin
  fhrc:=hrc;
end;

procedure TOpenGL.Setviewport(viewport:TViewport);
begin
  fviewport[0]:=viewport[0];
  fviewport[1]:=viewport[1];
  fviewport[2]:=viewport[2];
  fviewport[3]:=viewport[3];
end;

procedure TOpenGL.SmartInitialize(Owner:TComponent);
var Font : HFONT;

begin
  if (Owner is TKernel) then
  begin
    initialized:=true;
    smartrenderbool:=true;
    dc:=getdc((Owner as TKernel).Handle);
    if not InitOpenGL then
    begin
      messagedlg('Konnte OpenGL nicht initialisieren',mterror,[mbok],0);
      initialized:=false;
    end;
    hrc:= CreateRenderingContext(DC,[opDoubleBuffered],32,24,0,0,0,0);
    ActivateRenderingContext(DC,hrc);
    (Owner as TKernel).Konsole.systemfont:=glgenlists(256);
    Font:=CreateFont(16, 0, 0, 0, FW_MEDIUM, 0, 0, 0, ANSI_CHARSET, OUT_TT_PRECIS, CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY, FF_DONTCARE or DEFAULT_PITCH, 'Courier New');
    SelectObject (DC, Font);
    wglUseFontBitmaps (DC, 0, 255, (Owner as TKernel).Konsole.systemfont);
    DeleteObject(font);
  end;
end;

procedure TOpenGL.SmartRender(Owner:TComponent);

begin
  if (Owner is TKernel) then
  begin
  glMatrixMode(GL_PROJECTION);
  glloadidentity;
  glviewport(0,0,(Owner as TKernel).Width,(Owner as TKernel).Height);
  glortho(0,(Owner as TKernel).Width,0,(Owner as TKernel).Height,-1,1);
  glMatrixMode(GL_MODELVIEW);
  glclearcolor(0,0,0,0);
  glclear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
  glloadidentity;
  gldisable(gl_depth_test);
  gldisable(gl_texture_2d);
  gldisable(gl_blend);
  gldisable(gl_alpha_test);
  gldisable(gl_fog);
  gldisable(gl_lighting);
  if (Owner as TKernel).Konsole.visible then
  begin
    (Owner as Tkernel).Konsole.MsgToBuffer;
    (Owner as Tkernel).Konsole.change:=false;
  end;
  end;
end;

procedure TOpenGL.SmartFinalize(Owner:TComponent);
begin
  if (Owner is TKernel) then
  begin
    swapbuffers((Owner as TKernel).OpenGL.dc);
  end;
end;

procedure TOpengl.DestroyDC(Owner:Tcomponent);
begin
  if Owner is TKernel then
  begin
    gldeletelists((Owner as TKernel).Konsole.systemfont,256);
    initialized:=false;
    smartrenderbool:=false;
    DeactivateRenderingContext;
    DestroyRenderingContext(hrc);
    ReleaseDC((Owner as TKernel).Handle,dc);
  end;
end;

procedure TOpenGL.makefree;
begin
end;
{------------------------------------------------------------------------------}

procedure TKernel.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if key=220 then konsole.visible:=not konsole.visible;
  if konsole.visible and Opengl.initialized then Konsole.Keyinterpret(Sender,Key,Shift);
end;

procedure TKernel.ApplicationEvents1Idle(Sender: TObject;
  var Done: Boolean);

begin
  if tryclose then beenden
  else
  begin
  Funktionsketteabarbeiten(renderfunctionskette);
  if Opengl.smartrenderbool then
  begin
    Opengl.SmartRender(self);
    Opengl.SmartFinalize(self);
  end;
  end;
end;

procedure TKernel.FormCreate(Sender: TObject);
var port:Tviewport;
begin
  initmemory;
  tryclose:=false;
  port[2]:=640;
  port[3]:=240;
  if (clientWidth-port[2])>0 then port[0]:=(clientWidth-port[2]) div 2
                             else port[0]:=0;
  port[1]:=100;
  konsole:=TKonsole.Create(self);
  konsole.Init(port);
  OpenGL:=TOpengl.Create;
  Opengl.SmartInitialize(self);
  funcnames:=TStringlist.Create;
  dyndllnames:=Tstringlist.Create;
  setlength(functions,1);
  setlength(deletedfunctions,0);
  functions[high(functions)]:=interpret;
  new(renderfunctionskette);
  renderfunctionskette^.Funktion:=high(functions);
  renderfunctionskette^.danach:=nil;
  funcnames.Add('script.dll;interpret;');
end;

procedure TKernel.beenden();
begin
  Opengl.DestroyDC(self);
  Opengl.makeFree;
  Opengl.Free;
  Konsole.Free;
  freefunktionskette(renderfunctionskette.danach);
  freedlls;
  freememory;
  if assigned(funcnames) then freeandnil(funcnames);
  if assigned(dyndllnames) then freeandnil(dyndllnames);
  self.Close;
end;

procedure TKernel.Initmemory();
begin
  setlength(tempspeicher,0);
end;

procedure Tkernel.Freememory();
var i:integer;
begin
  for i:=0 to high(tempspeicher) do
  begin
    if tempspeicher[i].flag>0 then
    begin
      freemem(tempspeicher[i].address,tempspeicher[i].size);
      finalize(tempspeicher[i]);
    end;
  end;
end;
function Tkernel.GetMemoryVars:Tvars;
begin
  result:=Tempspeicher;
end;

procedure TKernel.Freedlls();
var i:integer;
begin
  for i:=0 to high(dyndlls) do
  begin
    freelibrary(dyndlls[i]);
  end;
end;

function Tkernel.Registervariable(size:Byte):cardinal;
var i:integer;
    found:boolean;
begin
  found:=false;
  if High(tempspeicher)=-1 then
  begin
    setlength(tempspeicher,1);
    getmem(tempspeicher[0].address,size);
    tempspeicher[0].size:=size;
    tempspeicher[0].flag:=1;
    result:=0;
  end
  else
  begin
    for i:=0 to high(tempspeicher) do
    begin
      if Tempspeicher[i].address=nil then
      begin
        getmem(tempspeicher[i].address,size);
        tempspeicher[i].size:=size;
        tempspeicher[i].flag:=1;
        result:=i;
        break;
        found:=true;
      end;
    end;
    if not found then
    begin
      setlength(tempspeicher,length(tempspeicher)+1);
      getmem(tempspeicher[high(tempspeicher)].address,size);
      tempspeicher[high(tempspeicher)].size:=size;
      tempspeicher[high(tempspeicher)].flag:=1;
      result:=high(tempspeicher);
    end;
  end;
end;

procedure TKernel.Freevariable(address:cardinal);
begin
  if address< high(tempspeicher) then
  begin
    freemem(tempspeicher[address].address,tempspeicher[address].size);
    tempspeicher[address].flag:=0;
  end;
end;

procedure TKernel.Funktionsketteabarbeiten(address:PFunktionsglied);
begin
  if assigned(address) then
  begin
    functions[address^.Funktion](@self);
    if not (address^.danach=nil) then Funktionsketteabarbeiten(address^.danach);
  end;
end;

procedure TKernel.freeFunktionskette(address:PFunktionsglied);
begin
  if assigned(address) then
  begin
    if not (address^.danach=nil) then Funktionsketteabarbeiten(address^.danach);
    dispose(address);
  end;
end;

function TKernel.Addfunktion(dll:THandle;name:PAnsichar):integer;
var i:integer;
begin
  result:=-1;
  if high(deletedfunctions)>-1 then
  begin
    @functions[deletedfunctions[high(deletedfunctions)]]:=getprocaddress(dll,name);
    result:=deletedfunctions[high(deletedfunctions)];
    setlength(deletedfunctions,high(deletedfunctions));
  end;
  if result=-1 then
  begin
    setlength(functions,length(functions)+1);
    setlasterror(0);
    @functions[high(functions)]:=getprocaddress(dll,name);
    i:=getlasterror;
    if i>0 then
    begin
      konsole.addmsg('SYSTEM-ERROR: '+syserrormessage(i),red);
    end;
    if @functions[high(functions)]=nil then setlength(functions,high(functions))
    else result:=high(functions);
  end;
end;

function TKernel.Delfunktion(index:cardinal):boolean;
begin
  result:=false;
  if index<length(functions) then
  begin
    setlength(deletedfunctions,length(deletedfunctions)+1);
    deletedfunctions[high(deletedfunctions)]:=index;
    result:=true;
  end;
end;


function TKernel.Addfunktionsglied(address:PFunktionsglied;functionindex:cardinal;position:cardinal):cardinal;
var i:cardinal;
    glied:PFunktionsglied;
begin
  for i:=0 to position-1 do
  begin
    if not (address.danach=nil) then address:=address^.danach
    else
    begin
      new(glied);
      address^.danach:=glied;
      glied^.Funktion:=functionindex;
      glied^.davor:=address;
      glied^.danach:=nil;
      result:=i;
    end;
  end;
  if not (address.danach=nil) then
  begin
    new(glied);
      glied^.danach:=address^.danach;
      address^.danach:=glied;
      glied^.Funktion:=functionindex;
      glied^.davor:=address;
      address:=glied^.danach;
      address^.davor:=glied;
      result:=position;
  end;
end;

function TKernel.Delfunktionsglied(address:PFunktionsglied;position:cardinal):boolean;
var i:cardinal;
    glied:PFunktionsglied;
    auserhalb:boolean;
begin
  result:=false;
  auserhalb:=false;
  for i:=0 to position-1 do
  begin
    if address.danach=nil then auserhalb:=true;
  end;
  if not auserhalb then
  begin
    glied:=address^.davor;
    glied^.danach:=address^.danach;
    dispose(address);
  end;
end;

end.
Script-dll

Delphi-Quellcode:

library Script;

{ Wichtiger Hinweis zur DLL-Speicherverwaltung: ShareMem muss sich in der
  ersten Unit der unit-Klausel der Bibliothek und des Projekts befinden (Projekt-
  Quelltext anzeigen), falls die DLL Prozeduren oder Funktionen exportiert, die
  Strings als Parameter oder Funktionsergebnisse übergeben. Das gilt für alle
  Strings, die von oder an die DLL übergeben werden -- sogar für diejenigen, die
  sich in Records und Klassen befinden. Sharemem ist die Schnittstellen-Unit zur
  Verwaltungs-DLL für gemeinsame Speicherzugriffe, BORLNDMM.DLL.
  Um die Verwendung von BORLNDMM.DLL zu vermeiden, können Sie String-
  Informationen als PChar- oder ShortString-Parameter übergeben. }

  

uses
  SysUtils,
  Classes,
  Kernelunit,
  Typenunit,
  messages,
  windows,
  AppEvnts;

{$R *.res}

function Semikolontrennung(text:string):Tstrarr;
var i,j:integer;
begin
  setlength(result,1);
  result[0]:=text;
  j:=0;
  repeat
    i:=ansipos(';',result[j]);
    if not (i=0) then
    begin
      inc(j);
      setlength(result,j+1);
      result[j]:=result[j-1];
      result[j-1]:=copy(result[j],0,i-1);
      result[j]:=copy(result[j],i+1,length(result[j]));
    end;
  until i=0;
end;

procedure load(data:PKernel);
var handle:THandle;
    initfunc:TFunc;
begin
  data^.Konsole.addmsg('Lade '+data^.Konsole.value[0],grey);
  setlength(data^.dyndlls,length(data^.dyndlls)+1);
  handle:=LoadLibrary(Pchar(data^.Konsole.systempfad+'/'+data^.Konsole.value[0]));
  if handle<>0 then
  begin
    data^.dyndlls[high(data^.dyndlls)]:=handle;
    @initfunc:=getprocaddress(handle,'init');
    if @initfunc<>nil then
    begin
      initfunc(data);
      data^.dyndllnames.Add(data^.Konsole.value[0]);
      data^.Konsole.addmsg(data^.Konsole.value[0]+' geladen!',green);
    end
    else
    begin
      freelibrary(handle);
      setlength(data^.dyndlls,high(data^.dyndlls));
      data^.Konsole.addmsg('Fehler aufgetreten (Init-Function nicht aufrufbar)'+data^.Konsole.value[0]+' nicht geladen!',red);
    end;
  end
  else
  begin
    setlength(data^.dyndlls,high(data^.dyndlls));
    freelibrary(handle);
    data^.Konsole.addmsg('Fehler aufgetreten '+data^.Konsole.value[0]+' nicht geladen!',red);
  end;
end;

procedure include(data:PKernel);
var pos,i:integer;
    path:ansistring;
begin
  if high(data^.konsole.value)<1 then
  begin
    data^.Konsole.addmsg('Zu wenig Parameter',red);
  end
  else
  begin
    pos:=data^.dyndllnames.IndexOf(data^.Konsole.value[0]);
    if pos>-1 then
    begin
      path:=data^.Konsole.value[1];
      pos:=data^.Addfunktion(data^.dyndlls[pos],@path[1]);
      if pos>-1 then
      begin
        data^.Konsole.addmsg(data^.Konsole.value[1]+' eingegliedert! Index: '+inttostr(pos),green);
        data^.funcnames.Add(data^.Konsole.value[0]+';'+data^.Konsole.value[1]);
      end
      else data^.Konsole.addmsg('Fehler beim Einbinden!'+data^.Konsole.value[1],red);
    end
    else data^.Konsole.addmsg('Unbekannte DLL!',red);
  end;
end;

procedure help(data:PKernel);
var helptext:TStringlist;
    i:integer;
begin
  helptext:=Tstringlist.Create;
  try
    if data^.Konsole.value[0]='then
    begin
      helptext.LoadFromFile(data^.konsole.systempfad+'\help\default.txt');
      data^.Konsole.addmsg('Hilfe',lgrey);
    end
    else
    begin
      helptext.LoadFromFile(data^.konsole.systempfad+'\help\'+data^.Konsole.value[0]+'.txt');
      data^.Konsole.addmsg('Hilfe für: "'+data^.Konsole.value[0]+'"',lgrey);
    end;
    for i:=0 to helptext.Count-1 do
    begin
      data^.Konsole.addmsg('* |'+helptext.Strings[i],grey);
    end;
  except
    data^.Konsole.addmsg('Hilfe für nicht verfügbar!',red);
  end;
  helptext.Free;
end;

procedure info(data:PKernel);
var i:integer;
    text:Tstrarr;
    vars:Tvars;
    str:string;
    glied:PFunktionsglied;
begin
  if (data^.Konsole.value[0]='kernel') or (data^.Konsole.value[0]='all') then
  begin
    data^.Konsole.addmsg('-- Kernel --',dred);
    data^.Konsole.addmsg('-Temporärer Speicher Variabeln / Größe |*Index',lred);
    vars:=data^.GetMemoryVars;
    for i:=0 to high(vars) do if vars[i].flag>0 then data^.Konsole.addmsg('*'+inttostr(i)+' '+inttostr(integer(vars[i].address))+'~'+inttostr(integer(vars[i].address)+vars[i].size)+' |> '+inttostr(vars[i].size),lblue);
    data^.Konsole.addmsg('-dynamische DLLs',lred);
    for i:=0 to data^.dyndllnames.Count-1 do
    begin
      data^.Konsole.addmsg(data^.dyndllnames.Strings[i],lblue);
    end;
    data^.Konsole.addmsg('-Funktionen',lred);
    for i:=0 to data^.funcnames.Count-1 do
    begin
      text:=semikolontrennung(data^.funcnames.Strings[i]);
      data^.Konsole.addmsg(text[1],lblue);
      data^.Konsole.addmsg('+ aus '+text[0],dgrey);
    end;
    data^.Konsole.addmsg('-Zuordnungen',lred);
    data^.Konsole.addmsg('--Renderfunktionen',dred);
    glied:=data^.renderfunctionskette;
    repeat
      text:=semikolontrennung(data^.funcnames.Strings[glied^.funktion]);
      data^.Konsole.addmsg(text[1],lblue);
      glied:=glied^.danach;
    until glied=nil;
  end;
  if (data^.Konsole.value[0]='konsole') or (data^.Konsole.value[0]='all') then
  begin
    data^.Konsole.addmsg('-- Konsole --',dred);
    data^.Konsole.addmsg('-Systempfad',lred);
    data^.Konsole.addmsg(data^.Konsole.systempfad,lblue);
    data^.Konsole.addmsg('-Scriptposition/Befehl',lred);
    data^.Konsole.addmsg(inttostr(data^.Konsole.Scriptpos),lblue);
    data^.Konsole.addmsg(data^.Konsole.befehl,lblue);
    str:='';
    for i:=0 to high(data^.Konsole.value) do str:=str+' | '+data^.Konsole.value[i];
    data^.Konsole.addmsg(str,lblue);
    data^.Konsole.addmsg(inttostr(data^.Konsole.dauer),lblue);
    data^.Konsole.addmsg('-Ausgabeport (links,oben,breite,höhe)',lred);
    data^.Konsole.addmsg(inttostr(data^.Konsole.port[0])+' | '+inttostr(data^.Konsole.port[1])+' | '+inttostr(data^.Konsole.port[2])+' | '+inttostr(data^.Konsole.port[3]),lblue);
    data^.Konsole.addmsg('-Hintergrundfarbe (r,g,b)',lred);
    data^.Konsole.addmsg(inttostr(data^.Konsole.bgcolor[0])+' | '+inttostr(data^.Konsole.bgcolor[1])+' | '+inttostr(data^.Konsole.bgcolor[2]),lblue);
  end;
end;

procedure list(data:PKernel);
var datei:TSearchrec;
begin
  if data^.Konsole.value[0]='helpthen
  begin
    if findfirst(data^.Konsole.systempfad+'\help\*.txt',faanyfile,datei)=0 then
    begin
      repeat
        data^.Konsole.addmsg(datei.Name,lgrey);
      until not (findnext(datei)=0);
    end;
  end;
  if data^.Konsole.value[0]='scriptthen
  begin
    if findfirst(data^.Konsole.systempfad+'\script\*.txt',faanyfile,datei)=0 then
    begin
      repeat
        data^.Konsole.addmsg(datei.Name,lgrey);
      until not (findnext(datei)=0);
    end;
  end;
  if data^.Konsole.value[0]='dllthen
  begin
    if findfirst(data^.Konsole.systempfad+'\dll\*.dll',faanyfile,datei)=0 then
    begin
      repeat
        data^.Konsole.addmsg(datei.Name,lgrey);
      until not (findnext(datei)=0);
    end;
  end;
end;

procedure close(data:PKernel);
begin
  data^.Konsole.addmsg('Schließe Konsole',green);
  data^.Konsole.visible:=false;
end;

procedure open(data:PKernel);
begin
  data^.Konsole.addmsg('Öffne Konsole',green);
  data^.Konsole.visible:=true;
end;

procedure exit(data:PKernel);
begin
  data^.Konsole.addmsg('Beende Konsole',green);
  data^.tryclose:=true;
end;

////////////////////////////////////////////////////////////////////////////////
procedure regist(data:Pkernel);
var address:integer;
    size:byte;
begin
  if data^.Konsole.value[0]<>'then
  begin
    try
      size:=strtoint(data^.Konsole.value[0]);
      if size=0 then
      begin
        data^.Konsole.addmsg('Unzulässige Größenangabe',red);
      end
      else
      begin
        address:=data^.Registervariable(strtoint(data^.Konsole.value[0]));
        data^.Konsole.addmsg('Variable der Größe: '+data^.Konsole.value[0]+' bei '+inttostr(address)+' erstellt',green);
      end;
    except
      data^.Konsole.addmsg('Unzulässige Größenangabe',red);
    end;
  end;
end;

procedure freevar(data:PKernel);
var address:integer;
begin
  if data^.Konsole.value[0]<>'then
  begin
    try
      address:=strtoint(data^.Konsole.value[0]);
      data^.Freevariable(address);
      data^.Konsole.addmsg('Variable bei: '+inttostr(address)+' freigegeben',green);
    except
      data^.Konsole.addmsg('Unzulässige Adresse!',red);
    end;
  end;
end;
////////////////////////////////////////////////////////////////////////////////


procedure interpret(data:PKernel);stdcall;
var command:string;
    done:boolean;
    text:TStrarr;
    i:integer;

begin
  repeat
    done:=false;
    if (data^.Konsole.Scriptpos<data^.Konsole.Script.Count) and (data^.Konsole.dauer=0) then
    begin
      command:=data^.Konsole.Script.Strings[data^.Konsole.Scriptpos];
      text:=semikolontrennung(command);
      data^.Konsole.befehl:=text[0];
      if high(text)>0 then
      begin
         setlength(data^.Konsole.value,1);
         data^.Konsole.value[0]:=text[1];
         for i:=2 to high(text)-1 do
         begin
           setlength(data^.Konsole.value,i);
           data^.Konsole.value[i-1]:=text[i];
         end;
      end
      else
      begin
        setlength(data^.Konsole.value,1);
        data^.Konsole.value[0]:='';
      end;
      if high(text)>1 then
      begin
        try
          data^.Konsole.dauer:=strtoint(text[high(text)]);
        except
          data^.Konsole.dauer:=1;
          data^.Konsole.addmsg('Keine gültige Tickangabe',red);
        end;
      end
      else data^.Konsole.dauer:=1;
    end;

    if data^.Konsole.Scriptpos<data^.Konsole.Script.Count then
    begin
      if data^.Konsole.befehl='loadthen
      begin
        load(data);
        done:=true;
      end;
      if data^.Konsole.befehl='includethen
      begin
        include(data);
        done:=true;
      end;
      if data^.Konsole.befehl='helpthen
      begin
        help(data);
        done:=true;
      end;
      if data^.Konsole.befehl='infothen
      begin
        info(data);
        done:=true;
      end;
      if data^.Konsole.befehl='listthen
      begin
        list(data);
        done:=true;
      end;
      if data^.Konsole.befehl='closethen
      begin
        close(data);
        done:=true;
      end;
      if data^.Konsole.befehl='openthen
      begin
        open(data);
        done:=true;
      end;
      if data^.Konsole.befehl='exitthen
      begin
        exit(data);
        done:=true;
      end;
      //////////////////////////////////////////////////////////////////////////
      if data^.Konsole.befehl='registthen
      begin
        regist(data);
        done:=true;
      end;
      if data^.Konsole.befehl='freethen
      begin
        freevar(data);
        done:=true;
      end;
      //////////////////////////////////////////////////////////////////////////
      if not done then
      begin
        data^.Konsole.dauer:=0;
        data^.Konsole.addmsg('++ Error: Befehl "'+data^.Konsole.befehl+'" unbekannt ++',red);
      end
      else dec(data^.Konsole.dauer);
      if data^.Konsole.dauer=0 then inc(data^.Konsole.Scriptpos);
    end
    else
    begin
      data^.Konsole.befehl:='';
      setlength(data^.Konsole.value,1);
      data^.Konsole.value[0]:='';
      data^.Konsole.dauer:=1;
    end;
  until data^.Konsole.dauer>0;
end;

exports interpret;

begin
end.
Typenunit

Delphi-Quellcode:

unit typenunit;

interface

type PRGBi =^TRGBi;
      TRGBi =array[0..2] of Byte;
      TRGBf =array[0..2] of single;
      TRGBAi =array[0..3] of Byte;
      TRGBAf =array[0..3] of single;
      Tviewport=array[0..3] of word;
      TStrarr=array of string[255];
      TVar=record
        address:pointer;
        size:Byte;
        flag:Byte;
      end;
      TVars=array of TVar;
      
const white:TRGBi=(255,255,255);
      black:TRGBi=(0,0,0);
      lgrey:TRGBi=(200,200,200);
      grey:TRGBi=(150,150,150);
      dgrey:TRGBi=(100,100,100);
      lred:TRGBi=(255,150,150);
      red:TRGBi=(255,0,0);
      dred:TRGBi=(100,0,0);
      lyellow:TRGBi=(255,255,150);
      yellow:TRGBi=(255,255,0);
      dyellow:TRGBi=(100,100,0);
      lgreen:TRGBi=(150,255,150);
      green:TRGBi=(0,255,0);
      dgreen:TRGBi=(0,100,0);
      lblue:TRGBi=(150,150,255);
      blue:TRGBi=(0,0,255);
      dblue:TRGBi=(0,0,100);
      bgblue:TRGBi=(10,10,50);

implementation

end.
So, ich hoffe das bringt ein bisschen Licht in die Sache, ich weiß wirklich nicht, woran das liegt...
  Mit Zitat antworten Zitat