cc4.pas

C,C++ To Delphi转换器的源码

  seq[28]:=@seq28;  seq[29]:=@seq29;  seq[30]:=@seq30;  seq[31]:=@seq31;
  seq[32]:=@seq32;  seq[33]:=@seq33;  seq[34]:=@seq34;  seq[35]:=@seq35;
  seq[36]:=@seq36;  seq[37]:=@seq37;  seq[38]:=@seq38;  seq[39]:=@seq39;
  seq[40]:=@seq40;  seq[41]:=@seq41;  seq[42]:=@seq42;  seq[43]:=@seq43;
  seq[44]:=@seq44;  seq[45]:=@seq45;  seq[46]:=@seq46;  seq[47]:=@seq47;
 end;

procedure setcodes;
 begin
  setseq;
  code[ADD12]   :='\211ADD AX,BX\n';
  code[ADD1n]   :='\010?ADD AX,<n>\n??';
  code[ADD21]   :='\211ADD BX,AX\n';
  code[ADD2n]   :='\010?ADD BX,<n>\n??';
  code[ADDbpn]  :='\001ADD BYTE PTR [BX],<n>\n';
  code[ADDwpn]  :='\001ADD WORD PTR [BX],<n>\n';
  code[ADDm_]   :='\000ADD <m>';
  code[ADDSP]   :='\000?ADD SP,<n>\n??';
  code[AND12]   :='\211AND AX,BX\n';
  code[ANEG1]   :='\010NEG AX\n';
  code[ARGCNTn] :='\000?MOV CL,<n>?XOR CL,CL?\n';
  code[ASL12]   :='\011MOV CX,AX\nMOV AX,BX\nSAL AX,CL\n';
  code[ASR12]   :='\011MOV CX,AX\nMOV AX,BX\nSAR AX,CL\n';
  code[CALL1]   :='\010CALL AX\n';
  code[CALLm]   :='\020CALL <m>\n';
  code[BYTE_]   :='\000 DB ';
  code[BYTEn]   :='\000 DB <n>\n';
  code[BYTEr0]  :='\000 DB <n> DUP(0)\n';
  code[COM1]    :='\010NOT AX\n';
  code[COMMAn]  :='\000,<n>\n';
  code[DBL1]    :='\010SHL AX,1\n';
  code[DBL2]    :='\001SHL BX,1\n';
  code[DECbp]   :='\001DEC BYTE PTR [BX]\n';
  code[DECwp]   :='\001DEC WORD PTR [BX]\n';
  code[DIV12]   :='\011CWD\nIDIV BX\n';                 (* see gen() *)
  code[DIV12u]  :='\011XOR DX,DX\nDIV BX\n';            (* see gen() *)
  code[ENTER]   :='\100PUSH BP\nMOV BP,SP\n';
  code[EQ10f]   :='\010OR AX,AX\nJE $+5\nJMP _<n>\n';
  code[EQ12]    :='\211CALL __eq\n';
  code[GE10f]   :='\010OR AX,AX\nJGE $+5\nJMP _<n>\n';
  code[GE12]    :='\011CALL __ge\n';
  code[GE12u]   :='\011CALL __uge\n';
  code[GETb1m]  :='\020MOV AL,<m>\nCBW\n';
  code[GETb1mu] :='\020MOV AL,<m>\nXOR AH,AH\n';
  code[GETb1p]  :='\021MOV AL,?<n>??[BX]\nCBW\n';       (* see gen() *)
  code[GETb1pu] :='\021MOV AL,?<n>??[BX]\nXOR AH,AH\n'; (* see gen() *)
  code[GETb1s]  :='\020MOV AL,<n>[BP]\nCBW\n';
  code[GETb1su] :='\020MOV AL,<n>[BP]\nXOR AH,AH\n';
  code[GETw1m]  :='\020MOV AX,<m>\n';
  code[GETw1m_] :='\020MOV AX,<m>';
  code[GETw1n]  :='\020?MOV AX,<n>?XOR AX,AX?\n';
  code[GETw1p]  :='\021MOV AX,?<n>??[BX]\n';            (* see gen() *)
  code[GETw1s]  :='\020MOV AX,<n>[BP]\n';
  code[GETw2m]  :='\002MOV BX,<m>\n';
  code[GETw2n]  :='\002?MOV BX,<n>?XOR BX,BX?\n';
  code[GETw2p]  :='\021MOV BX,?<n>??[BX]\n';
  code[GETw2s]  :='\002MOV BX,<n>[BP]\n';
  code[GT10f]   :='\010OR AX,AX\nJG $+5\nJMP _<n>\n';
  code[GT12]    :='\010CALL __gt\n';
  code[GT12u]   :='\011CALL __ugt\n';
  code[INCbp]   :='\001INC BYTE PTR [BX]\n';
  code[INCwp]   :='\001INC WORD PTR [BX]\n';
  code[WORD_]   :='\000 DW ';
  code[WORDn]   :='\000 DW <n>\n';
  code[WORDr0]  :='\000 DW <n> DUP(0)\n';
  code[JMPm]    :='\000JMP _<n>\n';
  code[LABm]    :='\000_<n>:\n';
  code[LE10f]   :='\010OR AX,AX\nJLE $+5\nJMP _<n>\n';
  code[LE12]    :='\011CALL __le\n';
  code[LE12u]   :='\011CALL __ule\n';
  code[LNEG1]   :='\010CALL __lneg\n';
  code[LT10f]   :='\010OR AX,AX\nJL $+5\nJMP _<n>\n';
  code[LT12]    :='\011CALL __lt\n';
  code[LT12u]   :='\011CALL __ult\n';
  code[MOD12]   :='\011CWD\nIDIV BX\nMOV AX,DX\n';      (* see gen() *)
  code[MOD12u]  :='\011XOR DX,DX\nDIV BX\nMOV AX,DX\n'; (* see gen() *)
  code[MOVE21]  :='\012MOV BX,AX\n';
  code[MUL12]   :='\211IMUL BX\n';
  code[MUL12u]  :='\211MUL BX\n';
  code[NE10f]   :='\010OR AX,AX\nJNE $+5\nJMP _<n>\n';
  code[NE12]    :='\211CALL __ne\n';
  code[NEARm]   :='\000 DW _<n>\n';
  code[OR12]    :='\211OR AX,BX\n';
  code[PLUSn]   :='\000?+<n>??\n';
  code[POINT1l] :='\020MOV AX,OFFSET _<l>+<n>\n';
  code[POINT1m] :='\020MOV AX,OFFSET <m>\n';
  code[POINT1s] :='\020LEA AX,<n>[BP]\n';
  code[POINT2m] :='\002MOV BX,OFFSET <m>\n';
  code[POINT2m_]:='\002MOV BX,OFFSET <m>';
  code[POINT2s] :='\002LEA BX,<n>[BP]\n';
  code[POP2]    :='\002POP BX\n';
  code[PUSH1]   :='\110PUSH AX\n';
  code[PUSH2]   :='\101PUSH BX\n';
  code[PUSHm]   :='\100PUSH <m>\n';
  code[PUSHp]   :='\100PUSH ?<n>??[BX]\n';
  code[PUSHs]   :='\100PUSH ?<n>??[BP]\n';
  code[PUT_m_]  :='\000MOV <m>';
  code[PUTbm1]  :='\010MOV <m>,AL\n';
  code[PUTbp1]  :='\011MOV [BX],AL\n';
  code[PUTwm1]  :='\010MOV <m>,AX\n';
  code[PUTwp1]  :='\011MOV [BX],AX\n';
  code[rDEC1]   :='\010#DEC AX\n#';
  code[rDEC2]   :='\010#DEC BX\n#';
  code[REFm]    :='\000_<n>';
  code[RETURN]  :='\000?MOV SP,BP\n??POP BP\nRET\n';
  code[rINC1]   :='\010#INC AX\n#';
  code[rINC2]   :='\010#INC BX\n#';
  code[SUB_m_]  :='\000SUB <m>';
  code[SUB12]   :='\011SUB AX,BX\n';                    (* see gen() *)
  code[SUB1n]   :='\010?SUB AX,<n>\n??';
  code[SUBbpn]  :='\001SUB BYTE PTR [BX],<n>\n';
  code[SUBwpn]  :='\001SUB WORD PTR [BX],<n>\n';
  code[SWAP12]  :='\011XCHG AX,BX\n';
  code[SWAP1s]  :='\012POP BX\nXCHG AX,BX\nPUSH BX\n';
  code[SWITCH]  :='\012CALL __switch\n';
  code[XOR12]   :='\211XOR AX,BX\n';
 end;

procedure header;
 begin
  toseg(CODESEG);
  outline('extrn __eq: near');
  outline('extrn __ne: near');
  outline('extrn __le: near');
  outline('extrn __lt: near');
  outline('extrn __ge: near');
  outline('extrn __gt: near');
  outline('extrn __ule: near');
  outline('extrn __ult: near');
  outline('extrn __uge: near');
  outline('extrn __ugt: near');
  outline('extrn __lneg: near');
  outline('extrn __switch: near');
  outline('dw 0'); (* force non-zero code pointers, word alignment *)
  toseg(DATASEG);
  outline('dw 0'); (* force non-zero data pointers, word alignment *)
 end;

procedure trailer;
 var
  cp:pchar;
 begin
  cptr:=@symtab[STARTGLB];
  while (cptr < @symtab[ENDGLB]) do begin
   if (cptr[sIDENT] = chr(iFUNCTION)) and (cptr[sCLASS] = cAUTOEXT) then
    _external(@cptr[sNAME], 0, iFUNCTION);
   inc(cptr,SYMMAX);
  end;
  cp:=findglb('main');
  if (cp<>nil) and (cp[sCLASS]=cSTATIC) then
   _external('_main', 0, iFUNCTION);
  toseg(0);
  outline('END');
{$ifdef DISOPT}
    {
    int i, *count;
    printf(";opt   count\n");
    for(i = -1; ++i <= HIGH_SEQ; ) {
      count = seq[i];
      printf("; %2u   %5u\n", i, *count);
      poll(YES);
      }
    }
{$endif}
 end;


procedure setstage(var before, start:integer);
 begin
  before:=snext;
  if snext=0 then begin
   snext:=1{stage};
   start:=snext;
  end;
 end;

procedure gen(pcode, value:integer);
 var
  newcsp:integer;
 begin
  case pcode of
   GETb1pu,
   GETb1p,
   GETw1p: gen(MOVE21, 0);
   SUB12,
   MOD12,
   MOD12u,
   DIV12,
   DIV12u: gen(SWAP12, 0);
   PUSH1:  dec(csp,BPW);
   POP2:   inc(csp,BPW);
   ADDSP,
   RETURN: begin newcsp:=value; dec(value,csp); csp:=newcsp; end;
  end;
  if (snext=0) then begin
   outcode(pcode, value);
   exit;
  end;
  if snext>=slast then begin
   error('staging buffer overflow');
   exit;
  end;
  stage^[snext]:=pcode;
  stage^[snext+1]:=value;
  inc(snext,2);
 end;

procedure clearstage(var before, start:integer);
 begin
  if before<>0 then begin
   snext:=before;
   exit;
  end;
  if start>0 then dumpstage;
  snext:=0;
 end;

procedure dumpstage;
 var
  i:integer;
 begin
  stail:=snext;
  snext:=1{stage};
  while (snext < stail) do begin
   if (optimize<>0) then begin
    i:=0;
    while (i <= HIGH_SEQ) do begin
     if(peep(seq[i])<>0) then begin
{$ifdef DISOPT}
        if(isatty(output))
          fprintf(stderr, "                   optimized %2u\n", i);
{$endif}
      i:=-1;
     end;
     inc(i);
    end;
   end;
  end;
  outcode(stage^[snext], stage^[snext+1]);
  inc(snext,2);
 end;

procedure toseg(newseg:integer);
 begin
  if(oldseg = newseg) then exit;
  if(oldseg = CODESEG) then outline('CODE ENDS') else
  if(oldseg = DATASEG) then outline('DATA ENDS');
  if(newseg = CODESEG) then begin
    outline('CODE SEGMENT PUBLIC');
    outline('ASSUME CS:CODE, SS:DATA, DS:DATA');
  end else
  if(newseg = DATASEG) then outline('DATA SEGMENT PUBLIC');
  oldseg:=newseg;
 end;

procedure _public(ident:integer);
 begin
  if(ident = iFUNCTION) then toseg(CODESEG) else toseg(DATASEG);
  outstr('PUBLIC ');
  outname(ssname);
  newline;
  outname(ssname);
  if(ident = iFUNCTION) then begin
   colon;
   newline;
  end;
 end;

procedure _external(name:pchar; size, ident:integer);
 begin
  if(ident = iFUNCTION) then toseg(CODESEG) else toseg(DATASEG);
  outstr('EXTRN ');
  outname(name);
  colon;
  outsize(size, ident);
  newline;
 end;

procedure outsize(size, ident:integer);
 begin
  if (size = 1)
  and(ident <> iPOINTER)
  and(ident <> iFUNCTION) then outstr('BYTE') else
  if (ident <> iFUNCTION) then outstr('WORD') else outstr('NEAR');
 end;

procedure point;
 begin
  outline(' DW $+2');
 end;

procedure dumplits(size:integer);
 var
  j,k:integer;
 begin
  k:=0;
  while (k < litptr) do begin
   poll(1);                     (* allow program interruption *)
   if(size = 1) then gen(BYTE_,0) else gen(WORD_,0);
   j := 10;
   while(j>0) do begin
    outdec(getint(litq + k, size));
    inc(k,size);
    if(j = 0) or (k >= litptr) then begin
     newline;
     break;
    end;
    fputc(',', output);
    inc(j);
   end;
  end;
 end;

procedure dumpzero(size, count:integer);
 begin
  if count > 0 then begin
   if(size= 1) then gen(BYTEr0, count) else gen(WORDr0, count);
  end;
 end;


function peep(seq:pintegers):integer;
 var
  next,pop:integer;
  count:pintegers;
  n,skip,tmp,reply:integer;
  c:byte;
 begin
  next :=snext;
  count:=seq; inc(seq);
  peep:=NO;
  while seq<>nil do begin
   case seq^[0] of
    any  : if (next >= stail) then exit;
    pfree: if not isfree(PRI, next) then exit;
    sfree: if not isfree(SEC, next) then exit;
    comm : if (stage^[next] and COMMUTES)<>0 then exit;
    _pop : begin pop:=getpop(next); if (pop<>0) then exit; end;
    else   if (next>=stail) or (stage^[next] <> seq^[0]) then exit;
   end;
   inc(next,2);
   inc(seq);
  end;

  (****** have a match, now optimize it ******)

  inc(count);
  reply:= NO;
  skip := NO;
  inc(seq);
  while (seq<>nil) or (skip=YES) do begin
   if(skip=YES) then begin
    if seq=nil then skip:=NO;
    continue;
   end;
   if seq^[0] >= PCODES then begin
      c := seq^[0] and $FF;          (* get low byte of command *)
      n := c;                     (* and sign extend into n *)
      case seq^[0] and $FF00 of
       ife:   if(stage^[snext+1] <> n) then skip := YES;
       ifl:   if(stage^[snext+1] >= n) then skip := YES;
       go :   inc(snext,n shl 1);
       gc :   begin stage^[snext]:=stage^[snext+n shl 1]; reply:=YES; break; end;
       gv :   begin stage^[snext+1]:=stage^[snext+(n shl 1)+1]; reply:=YES; break; end;
       sum:   begin inc(stage^[snext+1],stage^[snext+(n shl 1)+1]); reply:=YES; break; end;
       neg:   begin stage^[snext+1]:=-stage^[snext+1]; reply:=YES; break; end;
       topop: begin stage^[pop]:= n; stage^[pop+1]:= stage^[snext+1]; reply:=YES; break; end;
       swv:   begin
               tmp:=stage^[snext+1];
               stage^[snext+1]:=stage^[snext+(n shl 1)+1];
               stage^[snext+(n shl 1)+1]:=tmp;
               reply:=YES; break;
              end;
      { done:  reply = YES; }
      end;
    end else stage^[snext] := seq^[0];         (* set p-code *)
   end;
   peep:=(reply);
  end;


end.