cc2.pas

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

Unit CC2;
(*
** Small-C Compiler -- Part 2 -- Front End and Miscellaneous.
** Copyright 1982, 1983, 1985, 1988 J. E. Hendrix
** All rights reserved.
*)
Interface

uses
 CLIB,CC;

(********************** input functions **********************)
procedure preprocess;
procedure keepch(c:char);
procedure ifline;
procedure _inline;
function inbyte:char;

(********************* scanning functions ********************)

(*
** test if next input string is legal symbol name
*)
function symname(sname:pchar):boolean;
procedure need(str:pchar);
procedure ns;
function match(lit:pchar):boolean;
function streq(str1,str2:pchar):integer;
function amatch(lit:pchar; len:integer):boolean;
function astreq(str1,str2:pchar; len:integer):integer;
function nextop(list:pchar):boolean;
procedure blanks;
function white:boolean;
function gch:char;
procedure bump(n:integer);
procedure kill;
procedure skip;
function endst:boolean;

(*********** symbol table management functions ***********)
function addsym(_sname:pchar; id, _type:char; size, value:integer; lgpp:pchar; class:integer):pointer;
(*
** 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;
function hash(sname:pchar):integer;
function findglb(_sname:pchar):pointer;
function findloc(_sname:pchar):pointer;
function nextsym(entry:pchar):pchar;

(******** while queue management functions *********)
procedure addwhile(ptr:pinteger);
function readwhile(ptr:pinteger):pointer;
procedure delwhile;

(****************** utility functions ********************)

(*
** test if c is alphabetic
*)
function alpha(c:char):boolean;
(*
** test if given character is alphanumeric
*)
function an(c:char):boolean;
(*
** return next avail internal label number
*)
function getlabel:integer;
(*
** get integer of length len from address addr
** (byte sequence set by "putint")
*)
function getint(addr:pchar; len:integer):integer;
(*
** put integer i of length len into address addr
** (low byte first)
*)
procedure putint(i:integer; addr:pchar; len:integer);
procedure lout(line:pchar; fd:integer);

(******************* error functions *********************)
procedure illname;
procedure multidef(sname:pchar);
procedure needlval;
procedure noiferr;
procedure error(msg:pchar);
procedure errout(msg:pchar;fp:integer);

Implementation

uses
 STDIO,CC1;

var
 lptr_1,lptr_2:char; { lptr[-1] & lptr[-2] }

procedure preprocess;
 var
  k:integer;
  c:char;
 begin
  if (ccode=YES) then begin
   line := mline;
   ifline;
   if (_eof) then exit;
  end else begin
   _inline;
   exit;
  end;
  pptr := -1;
  while (ch<>NEWLINE) and (ch<>#0) do begin
    if white then begin
     keepch(' ');
     while white do gch;
    end else
    if(ch = '"') then begin
     keepch(ch);
     gch;
     while (ch<>'"') or ((lptr_1 = '\') and (lptr_2 <> '\')) do begin
      if (ch=#0) then begin
       error('no quote');
       break;
      end;
      keepch(gch);
     end;
     gch;
     keepch('"');
    end else
    if (ch='''') then begin
     keepch('''');
     gch;
     while (ch<>#39) or ((lptr_1='\')and(lptr_2 <> '\')) do begin
      if ch=#0 then begin
       error('no apostrophe');
       break;
      end;
      keepch(gch);
     end;
     gch;
     keepch('''');
    end else
    if (ch='/') and (nch='*') then begin
     bump(2);
     while ((ch='*')and(nch='/'))=false do begin
      if(ch<>#0) then bump(1) else begin
       ifline;
       if (_eof) then break;
      end;
     end;
     bump(2);
    end else
    if an(ch) then begin
     k := 0;
     while an(ch) and (k<NAMEMAX) do begin
      msname[k]:=ch; inc(k);
      gch;
     end;
     msname[k]:=#0;
     if search(msname, macn, NAMESIZE+2, @macn[MACNEND], MACNBR, 0) then begin
      k := getint(cptr+NAMESIZE, 2);
      c:=macq[k];
      while c<>#0 do begin
       keepch(c);
       inc(k);
       c:=macq[k];
      end;
      while an(ch) do gch;
     end else begin
      k := 0;
      c:=msname[k]; inc(k);
      while (c<>#0) do begin
       keepch(c);
       c:=msname[k]; inc(k);
      end;
     end;
    end else
     keepch(gch);
   end;
  if (pptr >= LINEMAX) then error('line too long');
  keepch(#0);
  line := pline;
  bump(0);
 end;

procedure keepch(c:char);
 begin
  if (pptr < LINEMAX) then begin
   inc(pptr);
   pline[pptr] := c;
  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 not 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 _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 inbyte:char;
 begin
  while(ch=#0) do begin
   if _eof then begin inbyte:=#0; exit end;
   preprocess;
  end;
  inbyte:=gch;
 end;

function symname(sname:pchar):boolean;
 var
  k:integer;
  c:char;
 begin
  blanks;
  if not alpha(ch) then begin
   symname:=(sname=nil);
   exit;
  end;
  k:=0;
  while an(ch) do begin
   sname[k]:=gch;
   if (k < NAMEMAX) then inc(k);
  end;
  sname[k]:=#0;
  symname:=true;
 end;

procedure need(str:pchar);
 begin
  if not match(str) then error('missing token');
 end;

procedure ns;
 begin
  if not match(';') then error('no semicolon') else errflag:=0;
 end;

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

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

function amatch(lit:pchar; len:integer):boolean;
 var
  k:integer;
 begin
  blanks;
  k:=astreq(lptr, lit, len);
  if (k<>0) then begin
   bump(k);
   amatch:=true;
  end else
   amatch:=false;
 end;

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

function nextop(list:pchar):boolean;
 var
  op:array[0..3] of char;
 begin
  opindex:=0;
  blanks;
  while (true) do begin
   opsize := 0;
   while(list^ > ' ') do begin
    op[opsize]:=list^;
    inc(list);
    inc(opsize);
   end;
   op[opsize]:=#0;
   opsize:=streq(lptr,op);
   if (opsize<>0) then
    if (lptr[opsize] <> '=')
    and(lptr[opsize] <> lptr[opsize-1]) then begin
     nextop:=true;
     exit;
    end;
   if list^<>#0 then begin
    inc(list);
    inc(opindex);
   end else
    nextop:=false;
  end;
 end;

procedure blanks;
 begin
  while (true) do begin
   while(ch<>#0) do begin
    if white then gch else exit;
    if line = mline then exit;
    preprocess;
    if _eof then break;
   end;
  end;
 end;

function white:boolean;
 begin
  {avail(YES);}  (* abort on stack/symbol table overflow *)
  white:=(lptr<>nil)and(lptr^<=' ');
 end;

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

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

procedure kill;
 begin
  line^:=#0;
  bump(0);
 end;

procedure skip;
 begin
  if an(inbyte)then
   while an(ch) do gch
  else
   while an(ch) do begin
    if(ch=#0) then break;
    gch;
   end;
  blanks;
 end;

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

function addsym(_sname:pchar; id, _type:char; size, value:integer; lgpp:pchar; class:integer):pointer;
 var
  cptr3:integer;
 begin
  if(lgpp = glbptr) then begin
   cptr2:=findglb(_sname);
   if cptr2<>nil then begin
    addsym:=cptr2;
    exit;
   end;
   if(cptr=nil) then begin
    error('global symbol table overflow');
    addsym:=nil;
    exit;
   end;
  end else begin
   if (locptr > @symtab[ENDLOC-SYMMAX]) then begin
    error('local symbol table overflow');
    abort(ERRCODE);
   end;
   cptr:=lgpp;
  end;
  cptr[sIDENT] := id;
  cptr[sTYPE]  := _type;
  cptr[sCLASS] := chr(class);
  putint(size, @cptr[SIZE], 2);
  putint(value, @cptr[sOFFSET], 2);
  cptr2:=@cptr[sNAME];
  cptr3:=0{cptr2};
  while an(_sname^) do begin
   cptr2^:=_sname^;
   inc(cptr2);
   inc(_sname);
   inc(cptr3);
  end;
  if(lgpp = locptr) then begin
   cptr2^:= chr(cptr3); {cptr2 - cptr3; }        (* set length *)
   lgpp  := @cptr2[1];
  end;
  addsym:=cptr;
 end;

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)>0 then begin
    search:=true;
    exit;
   end;
   cptr:=@cptr[len];
   if cptr>=_end then cptr:=buf;
   if cptr = cptr2 then begin
    search:=(cptr=nil);
   end;
  end;
  search:=false;
 end;

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

function findglb(_sname:pchar):pointer;
 begin
  if search(_sname,@symtab[STARTGLB],SYMMAX,@symtab[ENDGLB],NUMGLBS,sNAME) then
   findglb:=cptr
  else
   findglb:=nil;
 end;

function findloc(_sname:pchar):pointer;
 begin
  cptr:=locptr;
  dec(cptr); (* search backward for block locals *)
  while (cptr > @symtab[STARTLOC]) do begin
   dec(cptr,ord(cptr^));
   if astreq(_sname, cptr, NAMEMAX)>0 then begin
    dec(cptr,sNAME);
    findloc:=cptr;
   end;
   dec(cptr,sNAME+1);
  end;
  findloc:=nil;
 end;

function nextsym(entry:pchar):pchar;
 begin
  entry:=@entry[sNAME];
  repeat inc(entry) until entry^>=' '; (* find length byte *)
  nextsym:=entry;
 end;

procedure addwhile(ptr:pinteger);
 var
  k:integer;
 begin
{  ptr[WQSP]   := csp; ??  }      (* and stk ptr *)
  ptr^[WQLOOP] := getlabel;  (* and looping label *)
  ptr^[WQEXIT] := getlabel;  (* and exit label *)
  if (wqptr = @wq^[WQMAX]) then begin
    error('control statement nesting limit');
    abort(ERRCODE);
  end;
  k := 0;
  while (k < WQSIZ) do begin
   wqptr^[1]:=ptr^[k];
   inc(wqptr);
   inc(k);
  end;
 end;

function readwhile(ptr:pinteger):pointer;
 begin
  {if(ptr <= wq) then begin
   error('out of context');
   readwhile:=nil;
  end else} begin
   dec(ptr,WQSIZ);
   readwhile:=ptr;
  end;
 end;

procedure delwhile;
 begin
  {if(wqptr > wq) wqptr -= WQSIZ;}
  dec(wqptr);
 end;

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;

function getlabel:integer;
 begin
  inc(nxtlab);
  getlabel:=nxtlab;
 end;

function getint(addr:pchar; len:integer):integer;
 var
  i:integer;
 begin
  i:=ord(addr[len-1]); (* high order byte sign extended *)
  while len>0 do begin
   dec(len);
   i:=(i shl 8) or ord(addr[len])
  end;
  getint:=i;
 end;

procedure putint(i:integer; addr:pchar; len:integer);
 begin
  while len>0 do begin
   dec(len);
   addr^:=chr(i);
   i:=i shr 8;
  end;
 end;

procedure lout(line:pchar; fd:integer);
 begin
  fputs(line, fd);
  fputc(NEWLINE, fd);
 end;

(******************* error functions *********************)

procedure illname;
 begin
  error('illegal symbol');
  skip;
 end;

procedure multidef(sname:pchar);
 begin
  error('already defined');
 end;

procedure needlval;
 begin
  error('must be lvalue');
 end;

procedure noiferr;
 begin
  error('no matching #if...');
  errflag := 0;
 end;

procedure error(msg:pchar);
 begin
  if (errflag<>0) then exit else errflag:=1;
  lout(line, stderr);
  errout(msg, stderr);
  if (alarm<>0) then fputc(#7, stderr);
  if (pause<>0) then while (fgetc(stderr) <> NEWLINE) do;
  if (listfp > 0) then errout(msg, listfp);
 end;

procedure errout(msg:pchar; fp:integer);
 var
  k:pchar;
 begin
  k:=@line[2];
  while k<lptr do begin
   fputc(' ',fp);
   inc(k);
  end;
  lout('/\', fp);
  fputs('**** ', fp);
  lout(msg, fp);
 end;


end.