Quelle Convert.pas Sprache: Delphi

unit Convert;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, jpeg, ExtCtrls, StrUtils, WinSock,
  ShellAPI, OptionClass, Utilities, Frame11, Interfaces;

const
  em = 3000;
  Soft     = 'Software';

   endcolor='\cf0\f0 ';
   indepth=4;

type
  Destination = (D_JAVA, D_PL1);
  Status = (s_working, s_linkage, s_procedure, s_assign,
            s_while, s_expression, s_declaration, s_null);

procedure MakeJava(FN:String;SO:TTreeView;var TR:TRichEdit);
procedure SaveAsJava(FN:String;TR:TRichEdit);
procedure traverse(tn:TTreeNode);
procedure CompileLinkGo(Hand:THandle;SDir,SClass:String);

var
os:TMemoryStream;
indent:integer;
State:Status;
TVL:LongTexts;
Working, Linkage, Actuals, Values, Method:String;
Listcounter:integer;

implementation

//-------------------------------------
//      stream out
//-------------------------------------
procedure app(S:String);
var i:integer;
begin
for i:=1 to Length(S) do
  os.WriteBuffer(S[i], 1);
end;

//-------------------------------------
//      stream out
//-------------------------------------
function colorof(H:Highlite):String;
var i:Highlite;R:String;
begin
R:='1';
for i:=low(Opt.r.Highlites) to High(Opt.r.Highlites) do
   if i=H then
     R:= inttostr(ord(i)+1);
  R:='\cf'+R+' \f1 ';
colorof:=R
end;

//-------------------------------------
//      stream out
//-------------------------------------
function endline():String;
var S:String;i:integer;
begin
  S:='';
  for i:=1 to indent do S:=S+' ';
  endline:='\par '+S;
end;

//-------------------------------------
//      express
//-------------------------------------
procedure rtfheader;
var
Header : String ;
h : Highlite; C:TColor;
rgb, r, g, b : integer; Fsk : String;
ThisFont:String;
begin
ThisFont:='Fixedsys';
//set rtf header
Header := '{\rtf1\ansi\deff0{\fonttbl{\f0\fnil\fcharset0 '+ThisFont+';}'+
           '{\f1\fmodern\fprq1\fcharset0 '+ThisFont+';}';
Header := Header + '{\colortbl;';
for h:= low(Highlite) to high(Highlite) do begin
   C := opt.r.Highlites[h];
   rgb := ColorToRGB(C);
   b := rgb mod 256;rgb := rgb div 256;
   g := rgb mod 256;rgb := rgb div 256;
   r := rgb;
   Header := Header + '\red'  + Inttostr(r);
   Header := Header + '\green'+ IntToStr(g);
   Header := Header + '\blue' + IntToStr(b);
   Header := Header + ';';
end;
Header := Header + '}';
Fsk:='';
if fsbold      in Opt.R.FontStyle then Fsk := Fsk + '\b ';
if fsunderline in Opt.R.FontStyle then Fsk := Fsk + '\u ';
if fsitalic    in Opt.R.FontStyle then Fsk := Fsk + '\i ';
Header := Header +
           '{\*\generator Msftedit 5.41.15.1507;}\viewkind4\uc1\pard\lang1031'+
           Fsk+'\f0\fs'+
           inttostr(Opt.r.fontsize*2)+'}';
app(Header)
end;

//-------------------------------------
//      class header
//-------------------------------------
procedure fileheader(S:String);
var T:String;
begin
  indent := 0;
  T:=colorof(H_Keyword)+'import '+endcolor;
  T:=T+colorof(H_Identifier)+'java.io.*'+endcolor;
  T:=T+colorof(H_String)+';'+endcolor;
  app(T+endline);
  T:=colorof(H_Keyword)+'import '+endcolor;
  T:=T+colorof(H_Identifier)+'com.ibm.math.*'+endcolor;
  T:=T+colorof(H_String)+';'+endcolor;
  app(T+endline+endline);
end;

//-------------------------------------
//      class header
//-------------------------------------
procedure classheader(S:String);
var T:String;
begin
  indent := 0;
  T:=colorof(H_Keyword);
  T:=T+'public class ';
  T:=T+endcolor;
  app(T);
  app(colorof(H_Identifier)+Stripof(S)+endcolor);
  app(colorof(H_String)+' \{'+endcolor);
  indent := indent+indepth;
  app(endline());
  State:=s_null;
end;

//-------------------------------------
//      method header
//-------------------------------------
procedure methodheader(S:String);
begin
  app(colorof(H_Keyword)+'public static void '+endcolor);
  app(S);
  Method:=S;
  indent := indent+indepth;
  Working:='';
  Linkage:='';
end;

//-------------------------------------
//      method header
//-------------------------------------
procedure methodtrailer(S:String);
begin
  app(colorof(H_String));app('\} ');app(endcolor);
  app(colorof(H_Comment));app('//'+ S);app(endcolor);
  app(endline());
end;

//-------------------------------------
//      express
//-------------------------------------
procedure classtrailer(S:String);
begin
  app(endline);
  app(colorof(H_Keyword)+'public static void '+endcolor);
  app(colorof(H_Identifier)+'main('+endcolor);
  app(colorof(H_Keyword)+'String'+endcolor);
  app(colorof(H_String)+'[] '+endcolor);
  app(colorof(H_Identifier)+'args'+endcolor);
  app(colorof(H_String)+') \{'+endcolor+endline);
  app(colorof(H_Identifier)+Method+endcolor);
  app(colorof(H_String)+'('+Actuals+');'+endcolor);
  app(colorof(H_String)+'\}'+endcolor+endline);
  indent := indent-indepth;
  app(endline);
  app(colorof(H_String));  app('\}');app(endcolor);
  app(colorof(H_Comment)); app(' //'+ S);app(endcolor);
  app('}');
  indent := 0;
end;

//-------------------------------------
//      parse
//-------------------------------------
function expression(tn:TTreeNode):String;
var S, R:String;tc:TTreeNode;
begin
  expression:='';
  if tn<>nil then begin
    S := tn.Text;R:='';
    if (S=':=') or (S='+')   or (S='-')   or (S='*')  or (S='/')
    or (S='<')  or (S='<=')  or (S='==')  or (S='>=') or (S='>') or (S='<>')
    or (S='**') or (S='rem') then begin
      tc:=tn.getFirstChild;
      if S=':=' then S:=' = ';
      R:=expression(tc)+colorof(H_String)+' '+S+endcolor+' ';
      while tc<>nil do begin
        tc:=tc.getNextSibling;
        R:=R+expression(tc)
      end
    end else if (S='Test') then begin
      tc:=tn.getFirstChild;
      R:=expression(tc)+' ';
      while tc<>nil do begin
        tc:=tc.getNextSibling;
        R:=R+expression(tc)
      end
    end else
      R := colorof(H_Identifier)+S+endcolor;
    expression:=R
  end
end;

//-------------------------------------
//      append to list
//-------------------------------------
procedure append(var S:String;T:String);
begin
  if S='' then S:=T
  else begin
    S:=S+','+T
  end
end;

//-------------------------------------
//      express
//-------------------------------------
function definitions(tn:TTreeNode;Sep:char;wrap:boolean):String;
var L, T, B, S, R, D:String;
begin
  if tn<>nil then begin
    if wrap then Listcounter := Listcounter+1;
    L := Longeur(TVL,tn);
    T := getpar(S_Typ,L);
    B := getpar(S_Bas,L);
    if          B='decimalbase' then begin
      R:=colorof(H_Keyword)+'long '   +endcolor+Functor(L);
      append(Values,inttostr(Random(GetCurrentTime MOD 29)));
    end else if B='binarybase' then begin
      R:=colorof(H_Keyword)+'long '   +endcolor+Functor(L);
      append(Values,inttostr(Random(GetCurrentTime MOD 29)));
    end else if B='octetbase' then begin
      R:=colorof(H_Keyword)+'String '+endcolor+Functor(L);
      append(Values,inttostr(Random(GetCurrentTime MOD 29)));
    end else begin
      R:=colorof(H_Identifier)+S+endcolor
    end;
    if wrap and (Listcounter>=3) then begin R:=endline()+R;ListCounter:=0 end;
    D:=definitions(tn.getNextSibling(),Sep,wrap);
    if      (D<>'')   then definitions:=R+Sep+D
    else if (Sep=';') then definitions:=R+Sep+D
    else                   definitions:=R
  end
  else definitions:='';
end;

//-------------------------------------
//      express
//-------------------------------------
procedure traverse(tn:TTreeNode);
var tc:TTreeNode;S :String;komma:boolean;
begin
  if tn<>nil then begin
    S := tn.Text;
    if          S='Data' then begin
      tc:=tn.getFirstChild();
      while tc<>nil do begin
        traverse(tc);
        tc:=tc.getNextSibling
      end
    end else if S='Working-Storage' then begin
      Listcounter:=0;
      Values:='';
      Working:=definitions(tn.getFirstChild(),';',true);
    end else if S='Linkage' then begin
      Listcounter:=0;
      Values:='';
      Linkage:=definitions(tn.getFirstChild(),',',false);
      Actuals:=Values;
    end else if S='Procedure' then begin
      if Linkage<>'' then begin
        app('('+Linkage+')'+colorof(H_String)+' \{'+endcolor+endline());
      end else
        app(colorof(H_String)+'() \{'+endcolor+endline);
      app(Working);
      traverse(tn.getFirstChild());
      indent:=indent-indepth;
    end else if S='If' then begin
      tc:=tn.getFirstChild();
      app(expression(tc)+endline());
      traverse(tc.getNextSibling)
    end else if S=':=' then begin
      S:=expression(tn);
      app(endline+S+';');
      tc:=tn.Parent.GetNextChild(tn);
      traverse(tc);
    end else if (S='interface') then begin
      tc:=tn.getFirstChild;
      S:=expression(tc);
      if tc.Text='display' then
        S:=StringReplace(S,'display','System.out.println',[rfReplaceAll]);
      app(endline+S+'(');
      tc:=tc.getNextSibling;
      komma:=false;
      while tc<>nil do begin
        if komma then app(colorof(H_String)+'+'+endcolor);
        komma:=true;
        S:=expression(tc);
        app(S);
        tc:=tc.getNextSibling;
      end;
      app(colorof(H_String)+')'+endcolor+';')
    end else if S='branch' then begin
    end else if S='perform' then begin
      app(endline+colorof(H_Keyword)+'while'+endcolor+colorof(H_String)+' (!('+endcolor);
      indent:=indent+indepth;
      tc:=tn.getFirstChild();
      app(expression(tc));
      app(colorof(H_String)+')) \{'+endcolor);
      tc:=tc.getNextSibling();
      traverse(tc);
      indent:=indent-indepth;
      app(colorof(H_String)+'\}'+endcolor);
      tc:=tn.Parent.GetNextChild(tn);
      traverse(tc);
    end else begin
      tc:=tn.getFirstChild();
      while tc<>nil do begin
        traverse(tc);
        tc:=tc.getNextSibling
      end
    end
  end
end;

//-------------------------------------
//      JavaConvert
//-------------------------------------
procedure MakeJava(FN:String;SO:TTreeView;var TR:TRichEdit);
var
streamout:TMemoryStream;
Save_Cursor:TCursor;
begin
TR.Lines.Clear;
streamout := TMemoryStream.Create;
streamout.SetSize(SO.Items.Count*32);
streamout.Position := 0;
os:=streamout;
Save_Cursor                := Screen.Cursor;
Screen.Cursor              := crHourGlass;
// now output JAVA program
RtfHeader;
fileheader(LowerCase(Application.Title));
classheader(Fn);
methodheader(SO.TopItem.Text);
traverse(SO.TopItem);
methodtrailer(SO.TopItem.Text);
classtrailer(Fn);
// and load it to richedit
streamout.Position := 0;
TR.Lines.LoadFromStream(streamout);
Screen.Cursor              := Save_Cursor;
streamout.Destroy
end;

{------------------------------------------------------------------}
{-   execute JAVA artefact                                        -}
{-                                                                -}
{------------------------------------------------------------------}
procedure CompileLinkGo(Hand:THandle;SDir,SClass:String);
var  Fse: text;CmdFile, Umleitung:String;H:Cardinal;
begin
  CmdFile:=SDir+SClass+'.cmd';
  Umleitung := '>'+StripOf(SClass)+'.txt';
  try
    AssignFile (Fse,CmdFile);
    Rewrite(fse);
    writeln(fse,'javac '+SClass+' 2'+Umleitung);
    writeln(fse,'java -cp . '+StripOf(SClass)+' 1'+Umleitung);
    writeln(fse,'pause');
    CloseFile(fse);
  except
   On E:Exception do error(em+53,'unable to create '+sdir+SMAcOut
                           +' Dir='+SDir+' Msg='+E.Message);
  end;

  H:=ShellExecuteA(Hand,'exec',PChar(CmdFile),nil,PChar(SDir), SW_HIDE);
  TerminateProcess(H,0);
end;

//-------------------------------------
//      MakeJava
//-------------------------------------
procedure SaveAsJava(FN:String;TR:TRichEdit);
begin
  TR.PlainText:=true;
  TR.Lines.SaveToFile(FN);
  TR.PlainText:=false;
end;

{------------------------------------------------------------------}
{-                                                                -}
{-   Ende dieser Quelle                                           -}
{-                                                                -}
{------------------------------------------------------------------}
end.

quality88%

¤ Dauer der Verarbeitung: 0.17 Sekunden (vorverarbeitet) ¤

Wurzel

Suchen

Beweissystem der NASA

Beweissystem Isabelle

NIST Cobol Testsuite

Cephes Mathematical Library

Wiener Entwicklungsmethode

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.