c2p.pas

C,C++ To Delphi转换器 C,C++ To Delphi转换器

program c2p;

type
 pfile=^tfile;
 tfile=record
  src :text;
  dst :text;
  line:string;
  lpos:integer;
  next:pfile
 end;

 pinteger=^integer;

var
 fin,fout:pfile;

procedure closefiles;
 var
  f:pfile;
 begin
  while (fout<>fin) do begin
   close(fout^.dst);
   f:=fout;
   fout:=f^.next;
   dispose(f);
  end;
  fout:=nil;
  while (fin<>nil)do begin
   close(fin^.src);
   close(fin^.dst);
   f:=fin;
   fin:=f^.next;
   dispose(f);
  end;
  fin:=nil;
 end;

procedure error(msg:string);
 begin
  closefiles;
  writeln(msg);
  halt;
 end;

var
 eol :string[2];

procedure getline; forward;

procedure putline(s:string);
 var
  f:pfile;
 begin
  writeln(fout^.dst,s);
  while fout<>fin do begin
   close(fout^.dst);
   f:=fout;
   fout:=f^.next;
   dispose(f);
  end;
 end;

procedure aline;
 begin
  if fin^.lpos>length(fin^.line) then eol:=#13#10 else eol:='';
  while (fin^.lpos>length(fin^.line)) do getline;
 end;

procedure drop(count:integer);
 begin
  inc(fin^.lpos,count);
  aline;
 end;

function nextchar:char;
 begin
  aline;
  nextchar:=fin^.line[fin^.lpos];
 end;

function getchar:char;
 begin
  getchar:=nextchar;
  drop(1);
 end;

procedure spaces;
 begin
  while nextchar=' ' do drop(1);
 end;

procedure blanks;
 var
  s:string;
 begin
  spaces;
  while copy(fin^.line,fin^.lpos,2)='/*' do begin
   drop(2);
   s:='(*'+eol;
   while copy(fin^.line,fin^.lpos,2)<>'*/' do s:=s+getchar+eol;
   putline(s+'*)');
   drop(2);
   spaces;
  end;
 end;

procedure getline;
 begin
  fin^.lpos:=1;
  if fin=nil then begin
   fin^.line:=#27;
   exit;
  end;
  while eof(fin^.src) do begin
   close(fin^.src);
   fin:=fin^.next;
   if fin=nil then begin
    fin^.line:=#27;
    exit;
   end;
  end;
  readln(fin^.src,fin^.line);
  fin^.lpos:=1;
 end;

procedure gettoken; forward;

function IntToStr(i:integer):string;
 var
  s:string;
 begin
  Str(i,s);
  IntToStr:=s;
 end;

function date:string;
 var
  dd,mm:byte; yy:word;
 begin
  asm
   mov ah,2Ah; int 21h
   mov dd,dl; mov mm,dh; mov yy,cx
  end;
  date:=IntToStr(mm)+'-'+IntToStr(dd)+'-'+IntToStr(yy);
 end;

function openfile(filename:string):string;
 var
  f:pfile;
  i:integer;
 begin
  writeln('>',filename);
  new(f);
  assign(f^.src,filename);
  reset(f^.src);
  if ioresult<>0 then begin
   dispose(f);
   error('unable to open file '+filename);
  end;
  i:=length(filename);
  while filename[i]<>'.' do dec(i);
  filename:=copy(filename,1,i)+'pas';
  assign(f^.dst,filename);
  rewrite(f^.dst);
  if ioresult<>0 then begin
   close(f^.src);
   dispose(f);
   error('unable to open file '+filename);
  end;
  openfile:=filename;
  f^.next:=fin;
  fin:=f;
  fout:=f;
  putline('{ C2P convertion of SmallC ['+date+'] by Paul TOTH }');
  getline;
  gettoken;
 end;

var
 token:string;

 stage:pinteger; (* staging buffer address *)
 snext:pinteger; (* next addr in stage *)
 stail:pinteger; (* last addr of data in stage *)

 optimize:boolean; (* optimize output of staging buffer? *)

(* remember where we are in the queue in case we have to back up. *)
procedure setstage(var before, start:pinteger);
 begin
  before:=snext;
  if snext=nil then snext:=stage;
  start:=snext;
 end;

(* dump the staging buffer *)               (*
procedure dumpstage;
 var
  i:integer;
 begin
  stail := snext;
  snext := stage;
  while (ofs(snext) < ofs(stail)) do begin
   if (optimize) then begin
    i:=0;
    while(i<=HIGH_SEQ) do begin
     if (peep(seq[i])) then begin
{$ifdef DISOPT}
      if (isatty(output)) then writeln('                   optimized ',i);
{$endif}
      i:=0;
     end else
      inc(i);
    end;
   end;
   outcode(snext[0], snext[1]);
   inc(snext,2);
  end;
 end; *)

(*
** dump the contents of the queue.
** If start = 0, throw away contents.
** If before != 0, don't dump queue yet.
*)
procedure clearstage(before, start:pinteger);
 begin
  if(before<>nil) then begin
   snext:=before;
   exit;
  end;
{  if(start<>nil) then dumpstage; }
  snext:=nil;
 end;


type
 levelproc=function(var is:array of integer):integer;
const
 ST=0;  (* is[ST] - symbol table address, else 0 *)
 TI=1;  (* is[TI] - type of indirect obj to fetch, else 0 *)
 TA=2;  (* is[TA] - type of address, else 0 *)
 TC=3;  (* is[TC] - type of constant (INT or UINT), else 0 *)
 CV=4;  (* is[CV] - value of constant (+ auxiliary uses) *)
 OP=5;  (* is[OP] - code of highest/last binary operator *)
 SA=6;  (* is[SA] - stage address of "op 0" code, else 0 *)

(* unary drop to a lower level *)
function down1(level:levelproc;var is:array of integer):integer;
 var
  before,start:pinteger;
 begin
  setstage(before,start);
  down1:=level(is);
  if(is[TC]<>0)then clearstage(before,nil);  (* load constant later *)
 end;

function level3(var is:array of integer):integer;
 begin
  level3:=skim('||', EQ10f, 1, 0, level4, is);
 end;

function level2(var is1:array of integer):integer;
 var
  is2,is3:array[0..6] of integer;
  k,flab,endlab:integer;
  before,after:pinteger;
 begin
  k:=down1(level3, is1); { expression 1 }
  if(match('?')= 0) then begin
   level2:=k;
   exit;
  end;
  dropout(k, NE10f, flab = getlabel(), is1);
  if(down1(level2, is2)) fetch(is2);        /* expression 2 */
  else if(is2[TC]) gen(GETw1n, is2[CV]);
  need(":");
  gen(JMPm, endlab = getlabel());
  gen(LABm, flab);
  if(down1(level2, is3)) fetch(is3);        /* expression 3 */
  else if(is3[TC]) gen(GETw1n, is3[CV]);
  gen(LABm, endlab);

  is1[TC] = is1[CV] = 0;
  if(is2[TC] && is3[TC]) {                  /* expr1 ? const2 : const3 */
    is1[TA] = is1[TI] = is1[SA] = 0;
    }
  else if(is3[TC]) {                        /* expr1 ? var2 : const3 */
    is1[TA] = is2[TA];
    is1[TI] = is2[TI];
    is1[SA] = is2[SA];
    }
  else if((is2[TC])                         /* expr1 ? const2 : var3 */
       || (is2[TA] == is3[TA])) {           /* expr1 ? same2 : same3 */
    is1[TA] = is3[TA];
    is1[TI] = is3[TI];
    is1[SA] = is3[SA];
    }
  else error("mismatched expressions");
  return 0;
  }

function level1(var is:array of integer):boolean;
 var
  k,oper,oper2:integer;
  is2:array[0..6] of integer;
  is3:array[0..1] of integer;
 begin
  k:=down1(level2,is);  { voir CC3.C }
  if (is[TC])<>0 then gen(GETw1n, is[CV]);
  if match('|=') then begin oper:=OR21;  oper2:=OR12;   end else
  if match('^=') then begin oper:=XOR12; oper2:=XOR12;  end else
  if match('&=') then begin oper:=AND12; oper2:=AND12;  end else
  if match('+=') then begin oper:=ADD12; oper2:=ADD12;  end else
  if match('-=') then begin oper:=SUB12; oper2:=SUB12;  end else
  if match('*=') then begin oper:=MUL12; oper2:=MUL12u; end else
  if match('/=') then begin oper:=DIV12; oper2:=DIV12u; end else
  if match('%=') then begin oper:=MOD12; oper2:=MOD12u; end else
  if match('>>=') then begin oper:=ASR12; oper2:=ASR12; end else
  if match('<<=') then begin oper:=ASL12; oper2:=ASL12; end else
  if match('=') then begin oper:=0; oper2:=0; end else begin
   level1:=k;
   exit;
  end;
 (* have an assignment operator *)
  if (k=0) then begin
    needlval;
    level1:=0;
    exit;
  end;
  is3[ST]:=is[ST];
  is3[TI]:=is[TI];
  if (is[TI]<>0) then begin (* indirect target *)
    if (oper<>0) then begin                (* ?= *)
      gen(PUSH1, 0);                       (* save address *)
      fetch(is);                           (* fetch left side *)
    end;
    down2(oper, oper2, level1, is, is2);   (* parse right side *)
    if(oper<>0) then gen(POP2, 0);         (* retrieve address *)
  end else begin                           (* direct target *)
    if(oper<>0) then begin                 (* ?= *)
      fetch(is);                           (* fetch left side *)
      down2(oper, oper2, level1, is, is2); (* parse right side *)
    end else begin                         (*  = *)
      if(level1(is2)<>0) then fetch(is2);  (* parse right side *)
    end;
  end;
  store(is3);                              (* store result *)
  level1:=0;
 end;

procedure expression(var con,val:integer);
 var
  is:array[0..6] of integer;
 begin
  if level1(is) then fetch(is);
  con:=is[TC];
  val:=is[CV];
 end;

function constexpr(var val:integer):integer;
 var
  expr:integer;
  before,start:pinteger;
 begin
  setstage(before,start);
  expression(expr,val);
  clearstage(before,0); { scratch generated code }
  if expr=0 then error('must be constant expression');
  constexpr:=expr;
 end;

procedure number;
 begin
  while nextchar in ['0'..'9'] do token:=token+getchar;
 end;

procedure ident;
 begin
  while nextchar in ['_','a'..'z','A'..'Z','0'..'9'] do token:=token+getchar;
 end;

procedure getident;
 begin
  blanks;
  token:='';
  ident;
  if token='' then error('invalide ident');
 end;

procedure gettoken;
 begin
  blanks;
  token:=getchar;
  case token[1] of
   '#','_','a'..'z','A'..'Z': ident;
   '0'..'9':number;
  end;
  blanks;
 end;

function match(s:string):boolean;
 begin
  if token<>s then
   match:=false
  else begin
   match:=true;
   gettoken;
  end;
 end;

procedure need(s:string);
 begin
  if not match(s) then error('expected '+s+' found '+token);
 end;

function needsub:integer;
 var
  i:integer;
 begin
  if match(']') then begin
   needsub:=0;
   exit;
  end;
  if constexpr(i)=0 then i:=1;
  if i<0 then error('negative size illegal');
  need(']');
  needsub:=i;
 end;

procedure doInclude;
 { #include <filename> }
 { #include "filename" }
 var
  quote:char;
 begin
  quote:=getchar;
  if quote ='<' then quote:='>' else
  if quote<>'"' then error('invalide filename');
  gettoken;
  putline('{$I '+token+'.pas}');
  if nextchar='.' then begin token:=token+getchar; ident end;
  if nextchar<>quote then error('invalide include file name');
  openfile(token);
 end;

type
 PMacro=^TMacro;
 TMacro=record
  Name :string;
  Value:string;
  Next :PMacro;
 end;

const
 Macros:PMacro=nil;

procedure doDefine;
{ #define name value }
 var
  m:PMacro;
 begin
  getident;
  new(m);
  m^.name:=token;
  m^.next:=Macros;
  Macros:=m;
  m^.Value:='';
  while eol='' do m^.Value:=m^.Value+getchar;
  putline('{#define '+m^.name+' '+m^.value+'}');
  gettoken;
 end;

Type
 TType=(tINT);
 TClass=(STATIC,EXTERN);

procedure declare(dType:TType;dClass:TClass);
 const
  iPOINTER =1;
  iVARIABLE=2;
  iFUNCTION=3;
  iARRAY   =4;
 var
  id,dim:integer;
  name:string;
 begin
  if nextchar='*' then begin
   id:=iPOINTER;
   dim:=0;
   getchar;
  end else begin
   id:=iVARIABLE;
   dim:=1;
  end;
  getident;
  name:=token;
 { multidef...}
  if id=iVARIABLE then begin
   if nextchar='(' then begin id:=iFUNCTION; need(')'); end else
   if nextchar='[' then begin id:=iARRAY; dim:=needsub; end;
  end;
  if dClass=EXTERN then begin

  end;
  writeln(name,'...');
 end;

procedure main;
 begin
  if token='int' then declare(tINT,STATIC);
  if token='#include' then doInclude else
  if token='#define'  then doDefine else begin
   writeln('token=',token);
   error('...');
  end;
 end;

begin
 fin:=nil;
 openfile(paramstr(1));
 repeat main until false;
 error('OK');
end.