smallc.pas

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

Program SmallC; (* Pascal comments added *)

(* Turbo Pascal translation of original C source *)
(* (c)2001 by Paul TOTH <[e-mail]>       *)

Uses
 STDIO,NOTICE,CC, { *.H }
 CC1,CC2,CC3,CC4; { *.C }

begin
 main;
end.

{** CC2.C **}

procedure bump(n:integer);
 begin
  if n<>0 then lptr:=@lptr[n] else lptr:=line;
  ch:=lptr[0];
  if ch=#0 then nch:=#0 else nch:=lptr[1];
 end;

procedure _inline; { numerous revisions }
 var
  k,_unit:integer;
 begin
  (* poll(1); { allow operator interruption } *)
  if input=EOF then openfile;
  if _eof then exit;
  _unit:=input2;
  if _unit=EOF then _unit:=input;
  if fgets(line, LINEMAX, _unit)=nil then begin
   fclose(_unit);
   if(input2<>EOF) then
    input2 := EOF
   else
    input  := EOF;
   line:=nil;
  end
  else if (listfp<>0) then begin
   if (listfp = output) then fputc(';', output);
   fputs(line, listfp);
  end;
  bump(0);
 end;

function white:boolean;
 begin
 { avail(YES) <- check for stack overflow }
  white:=(lptr^<' ') and (lptr^<>#0);
 end;

function gch:char;
 begin
  gch:=ch;
  if ch<>#0 then bump(1);
 end;

procedure preprocess; forward;

procedure blanks;
 begin
  repeat
   while ch<>#0 do if white then gch else exit;
   if line=mline then exit;
   preprocess;
  until _eof;
 end;

{********************* scanning functions ********************}

function alpha(c:char):boolean;
 begin
  alpha:=(c='_') or isalpha(c);
 end;

function an(c:char):boolean;
 begin
  an:=alpha(c) or isdigit(c);
 end;

{ test if next input string is legal symbol name }
function symname(sname:pchar):boolean;
 var
  k:integer;
  c:char;
 begin
  blanks;
  if not alpha(ch) then begin
   symname:=(sname=nil);
  end else begin
   k:=0;
   while an(ch) do begin
    sname[k]:=gch;
    if (k<NAMEMAX) then inc(k);
   end;
  end;
  sname[k]:=#0;
  symname:=true;
 end;

function hash(sname:pchar):integer;
 var
  i:integer;
 begin
  i:=0;
  while sname^<>#0 do i:=i shl 1+ord(sname^);
  hash:=i;
 end;

function streq(str1,str2:pchar):integer;
 var
  i:integer;
 begin
  streq:=0;
  i:=0;
  while str2[i]<>#0 do begin
   if str1[i]<>str2[i] then exit;
   inc(i);
  end;
  streq:=i;
 end;

function astreq(str1,str2:pchar; len:integer):boolean;
 var
  i:integer;
 begin
  i:=0;
  while (i < len) do begin
   if (str1[i] <> str2[i]) then break;
    {*
    ** must detect end of symbol table names terminated by
    ** symbol length in binary
    *}
   if (str2[i] < ' ') then break;
   if (str1[i] < ' ') then break;
   inc(i);
  end;
  if(an(str1[i]) or an(str2[i])) then astreq:=false else astreq:=true;
 end;

{ search for symbol match
  on return cptr points to slot found or empty slot }
function search(sname, buf:pchar; len:integer; _end:pchar; max, off:integer):boolean;
 begin
  cptr :=@buf[(hash(sname) mod (max-1))*len];
  cptr2:=cptr;
  while cptr<>nil do begin
   if astreq(sname, @cptr[off], NAMEMAX) then begin search:=true; exit; end;
   cptr:=@cptr[len];
   if (cptr>=_end) then cptr:=buf;
   if cptr=cptr2 then begin search:=(cptr=nil); exit; end;
  end;
  search:=false;
 end;


function match(lit:pchar):boolean;
 var
  k:integer;
 begin
  blanks;
  k:=streq(lptr,lit);
  if k=0 then
   match:=false
  else begin
   match:=true;
   bump(k);
  end;
 end;

procedure ifline;
 begin
  while true do begin
   _inline;
   if _eof then exit;
   if match('#ifdef') then begin
    inc(iflevel);
    if skiplevel<>0 then continue;
    symname(msname);
    if search(msname, macn, NAMESIZE+2, @macn[MACNEND], MACNBR, 0) then
     skiplevel:=iflevel;
    continue;
   end;
   if match('#ifndef') then begin
    inc(iflevel);
    if skiplevel<>0 then continue;
    symname(msname);
    if search(msname, macn, NAMESIZE+2, @macn[MACNEND], MACNBR, 0) then
      skiplevel:=iflevel;
    continue;
   end;
   if match('#else') then begin
    if iflevel<>0 then begin
     if skiplevel=iflevel then skiplevel:=0 else
     if skiplevel=0 then skiplevel:=iflevel;
    end
    else noiferr;
    continue;
   end;
   if match('#endif') then begin
    if iflevel<>0 then begin
     if skiplevel=iflevel then skiplevel:=0;
     dec(iflevel);
    end
    else noiferr;
    continue;
   end;
   if skiplevel<>0 then continue;
   if ch=0 then continue;
   break;
  end;
 end;

procedure preprocess;
 var
  k:integer;
  c:char;
 begin
  if (ccode=NO) then begin  { parsing C CODE }
    line:=mline;
    ifline;
    if (eof) then exit;
  end else begin
    _inline;
    exit;
  end;
 (*
  pptr = -1;
  while(ch != NEWLINE && ch) {
    if(white()) {
      keepch(' ');
      while(white()) gch();
      }
    else if(ch == '"') {
      keepch(ch);
      gch();
      while(ch != '"' || (*(lptr-1) == 92 && *(lptr-2) != 92)) {
        if(ch == NULL) {
          error("no quote");
          break;
          }
        keepch(gch());
        }
      gch();
      keepch('"');
      }
    else if(ch == 39) {
      keepch(39);
      gch();
      while(ch != 39 || (*(lptr-1) == 92 && *(lptr-2) != 92)) {
        if(ch == NULL) {
          error("no apostrophe");
          break;
          }
        keepch(gch());
        }
      gch();
      keepch(39);
      }
    else if(ch == '/' && nch == '*') {
      bump(2);
      while((ch == '*' && nch == '/') == 0) {
        if(ch) bump(1);
        else {
          ifline();
          if(eof) break;
          }
        }
      bump(2);
      }
    else if(an(ch)) {
      k = 0;
      while(an(ch) && k < NAMEMAX) {
        msname[k++] = ch;
        gch();
        }
      msname[k] = NULL;
      if(search(msname, macn, NAMESIZE+2, MACNEND, MACNBR, 0)) {
        k = getint(cptr+NAMESIZE, 2);
        while(c = macq[k++]) keepch(c);
        while(an(ch)) gch();
        }
      else {
        k = 0;
        while(c = msname[k++]) keepch(c);
        }
      }
    else keepch(gch());
    }
  if(pptr >= LINEMAX) error("line too long");
  keepch(NULL);
  line = pline;
  bump(0);
  *)
  end;

function amatch(lit:string):boolean;
 var
  k:integer;
 begin
  blanks;
  k:=astreq(line,lit,length(lit));
  if k=0 then
   amatch:=false
  else begin
   bump(k);
   amatch:=true;
  end;
 end;

function endst:boolean;
 begin
  blanks;
  endst:=(streq(lptr,';')<>0) or (ch=0);
 end;


(******************** high level parsing *******************)

(*
** declare a static variable
*)
procedure declglb(kind, class:integer);
 var
  id,dim:integer;
 begin
  repeat
    if(endst) then exit;  (* do line *)
    if(match('*')) then  begin
     id := iPOINTER;  dim := 0;
    end else begin
     id := iVARIABLE; dim := 1;
    end;
    if(symname(ssname) = 0) then illname;
    if(findglb(ssname)) then multidef(ssname);
    if(id = iVARIABLE) then begin
      if (match('(')) then begin
       id := FUNCTION; need(')');
      end else
      if (match('[')) then begin
       id := ARRAY; dim = needsub;
      end;
    end;
    if (class = EXTERN) then doexternal(ssname, kind shr 2, id) else
    if (id <> FUNCTION) then initials(kind shr 2, id, dim);
    if (id = POINTER) then
         addsym(ssname, id, kind, BPW, 0, &glbptr, class)
    else addsym(ssname, id, kind, dim * (kind shr 2), 0, glbptr, class);
  until (match(',') = 0);
 end;

(*
** test for global declarations
*)
function dodeclare(class:integer):boolean;
 begin
  if amatch('char')  then declglb(CHR,  class) else
  if amatch('unsigned') then begin
   if amatch('char')  then declglb(UCHR, class) else
   if amatch('int')   then declglb(UINT, class);
  end else
  if amatch('int') or (class=EXTERN)) then declglb(INT,  class) else
  else begin
   dodeclare:=false;
   exit;
  end;
  ns;
  dedeclare:=true;
 end;

(*
** process all input text
**
** At this level, only static declarations,
**      defines, includes and function
**      definitions are legal...
*)
procedure parse;
begin
 while not eof(infiles[infile]) do begin
  if amatch('extern') then dodeclare(EXTERN) else
  if dodeclate(STATIC) then {} else
  if match('#asm') then doasm else
  if match('#include') then doinclude else
  if match('#define') then dodefine else dofunction;
  blanks;
 end;
end;

{ execution begins here }
begin
 writeln(VERSION);
 writeln(CRIGHT1);
 writeln(CRIGHT2); (*-*)
 getmem(swnext,SWTABSZ);
 swend:=@swnext[(SWTABSZ div SWSIZ)-1]; (* swnext+(SWTABSZ-SWSIZ); *)
 getmem(stage,STAGESIZE * 2*BPW);
 getmem(wqptr,WQTABSZ * BPW);
 wq:=wqptr;
 getmem(litq,LITABSZ);
 getmem(macn,MACNSIZE);
 getmem(macq,MACQSIZE);
 getmem(pline,LINESIZE);
 getmem(mline,LINESIZE);
 slast:=@stage[STAGESIZE];
 getmem(symtab,NUMLOCS*SYMAVG + NUMGLBS*SYMMAX);
 locptr:=symtab[STARTLOC];
 glbptr:=symtab[STARTGLB];
{ask;}
 openfile;
 preprocess;    { fetch first line } (* cc2.c *)
(* header;      { intro code }
(* setcodes;      (* initialize code pointer array *)
 parse;         (* process ALL input *)
 trailer;       (* follow-up code *)
 close(output); (* explicitly close output *)
end.