cc1.pas

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

Unit CC1;
(*
** Small-C Compiler -- Part 1 --  Top End.
** Copyright 1982, 1983, 1985, 1988 J. E. Hendrix
** All rights reserved.
*)
Interface

uses
 CLIB,
 STDIO,NOTICE,CC;
(*
** miscellaneous storage
*)
Var
  nogo,     { disable goto statements? }
  noloc,    { disable block locals? }
  opindex,  { index to matched operator }
  opsize,   { size of operator in characters }
  swactive, { inside a switch? }
  swdefault:{ default label #, else 0 }
    integer;
  swnext,   { address of next entry }
  swend,    { address of last entry }
  stage,    { staging buffer address }
  wq:       { while queue }
   pinteger;
  argcs:    { static argc }
    integer;
  argvs,    { static argv }
  wqptr:    { ptr to next entry }
   pinteger;
  litptr,   { ptr to next entry }
  macptr,   { macro buffer index }
  pptr      { ptr to parsing buffer }
   :integer;
  ch,       { current character of input line }
  nch       { next character of input line }
   :char;
  declared, { # of local bytes to declare, -1 when declared }
  iflevel,  { #if... nest level }
  skiplevel,{ level at which #if... skipping started }
  nxtlab,   { next avail label # }
  litlab,   { label # assigned to literal pool }
  csp,      { compiler relative stk ptr }
  argstk,   { function arg sp }
  argtop,   { highest formal argument offset }
  ncmp,     { # open compound statements }
  errflag   { true after 1st error in statement }
   :integer;
  _eof      { true on final input eof }
   :boolean;
  output,   { fd for output file }
  files,    { true if file list specified on cmd line }
  filearg:  { cur file arg index }
    integer;
const
  input  :integer = EOF; { fd for input file }
  input2 :integer = EOF; { fd for "#include" file }
  usexpr :integer = YES; { true if value of expression is used }
  ccode  :integer = YES; { true while parsing C code }
var
  snext,    { next addr in stage }
  stail,    { last addr of data in stage }
  slast:    { last addr in stage }
   integer;
  listfp,   { file pointer to list device }
  lastst,   { last parsed statement type }
  oldseg:   { current segment (0, DATASEG, CODESEG) }
    integer;
var
  optimize, { optimize output of staging buffer? }
  alarm,    { audible alarm on errors? }
  monitor,  { monitor function headers? }
  pause:    { pause for operator on errors? }
    byte;
  symtab,   { symbol table }
  litq,     { literal pool }
  macn,     { macro name buffer }
  macq,     { macro string buffer }
  pline,    { parsing buffer }
  mline,    { macro buffer }
  line,     { ptr to pline or mline }
  lptr      { ptr to current character in "line" }
   :pchar;
  glbptr,   { global symbol table }
  locptr:   { next local symbol table entry }
   pchar;
const
  quote = '"'; { literal string for '"' }
var
  cptr,     { work ptrs to any char buffer }
  cptr2,
  cptr3:
   pchar;
  msname:array[0..NAMESIZE-1] of char;   { macro symbol name }
  ssname:array[0..NAMESIZE-1] of char;   { static symbol name }

const
 op:array[0..15] of integer=(  { p-codes of signed binary operators }
  OR12,                        { level5 }
  XOR12,                       { level6 }
  AND12,                       { level7 }
  EQ12,   NE12,                { level8 }
  LE12,   GE12,  LT12,  GT12,  { level9 }
  ASR12,  ASL12,               { level10 }
  ADD12,  SUB12,               { level11 }
  MUL12, DIV12, MOD12          { level12 }
 );

 op2:array[0..15] of integer=( { p-codes of unsigned binary operators }
  OR12,                        { level5 }
  XOR12,                       { level6 }
  AND12,                       { level7 }
  EQ12,   NE12,                { level8 }
  LE12u,  GE12u, LT12u, GT12u, { level9 }
  ASR12,  ASL12,               { level10 }
  ADD12,  SUB12,               { level11 }
  MUL12u, DIV12u, MOD12u       { level12 }
 );

(*
** execution begins here
*)
procedure main;
(******************** high level parsing *******************)

(*
** process all input text
**
** At this level, only static declarations,
**      defines, includes and function
**      definitions are legal...
*)
procedure parse;
(*
** test for global declarations
*)
procedure dodeclare(class:integer);
(*
** declare a static variable
*)
procedure declglb(_type, class:integer);
(*
** initialize global objects
*)
procedure initials(size, ident, dim:integer);
(*
** evaluate one initializer
*)
procedure init(size, ident:integer; var dim:integer);
(*
** get required array size
*)
procedure needsub;
(*
** open an include file
*)
procedure doinclude;
(*
** define a macro symbol
*)
procedure dodefine;
procedure putmac(c:char);
(*
** begin a function
**
** called from "parse" and tries to make a function
** out of the following text
*)
procedure dofunction;
(*
** declare argument types
*)
procedure doargs(_type:integer);
(*
** parse next local or argument declaration
*)
procedure decl(_type, aid:integer; var id, sz:integer);
(******************** start 2nd level parsing *******************)

(*
** statement parser
*)
procedure statement;
(*
** declare local variables
*)
procedure declloc(_type:integer);
procedure compound;
procedure doif;
procedure dowhile;
procedure dodo;
procedure dofor;
procedure doswitch;
procedure docase;
procedure dodefault;
procedure dogoto;
procedure dolabel;
procedure addlabel;
procedure doreturn;
procedure dobreak;
procedure docont;
procedure doasm;
procedure doexpr(use:integer);
(******************** miscellaneous functions *******************)

(*
** get run options
*)
procedure ask;
(*
** input and output file opens
*)
procedure openfile;
(*
** open a file with error checking
*)
procedure mustopen(fn, mode:pchar);

Implementation

uses CC2,CC4;

procedure main;
 begin
  fputs(VERSION, stderr);
  fputs(CRIGHT1, stderr);
  swnext:=calloc(SWTABSZ, 1);
  swend :=pointer(longint(swnext)+(SWTABSZ-SWSIZ));
  stage :=calloc(STAGESIZE, 2*BPW);
  wqptr :=calloc(WQTABSZ, BPW);
  wq    :=wqptr;
  litq  :=calloc(LITABSZ, 1);
  macn  :=calloc(MACNSIZE, 1);
  macq  :=calloc(MACQSIZE, 1);
  pline :=calloc(LINESIZE, 1);
  mline :=calloc(LINESIZE, 1);
  slast :=pointer(longint(stage)+(STAGESIZE*2*BPW));
  symtab:=calloc((NUMLOCS*SYMAVG + NUMGLBS*SYMMAX), 1);
  locptr:=@symtab[STARTLOC];
  glbptr:=@symtab[STARTGLB];

  ask;            { get user options }
  openfile;       { and initial input file }
  preprocess;     { fetch first line }
  header;         { intro code }
  setcodes;       { initialize code pointer array }
  parse;          { process ALL input }
  trailer;        { follow-up code }
  fclose(output); { explicitly close output }
 end;

(******************** miscellaneous functions *******************)

(*
** get run options
*)
procedure ask;

  int i;
  i = listfp = nxtlab = 0;
  output = stdout;
  optimize = YES;
  alarm = monitor = pause = NO;
  line = mline;
  while(getarg(++i, line, LINESIZE, argcs, argvs) != EOF) {
    if(line[0] != '-' && line[0] != '/') continue;
    if(toupper(line[1]) == 'L'
    && isdigit(line[2])
    && line[3] <= ' ') {
      listfp = line[2]-'0';
      continue;
      }
    if(toupper(line[1]) == 'N'
    && toupper(line[2]) == 'O'
    && line[3] <= ' ') {
      optimize = NO;
      continue;
      }
    if(line[2] <= ' ') {
      if(toupper(line[1]) == 'A') {alarm   = YES; continue;}
      if(toupper(line[1]) == 'M') {monitor = YES; continue;}
      if(toupper(line[1]) == 'P') {pause   = YES; continue;}
      }
    fputs("usage: cc [file]... [-m] [-a] [-p] [-l#] [-no]\n", stderr);
    abort(ERRCODE);
    }
  }

(*
** input and output file opens
*)
procedure openfile; { entire function revised }
 var
  pline:string;
 begin
  input:=EOF;
  while (filearg<=paramcount) do begin
   pline:=paramstr(filearg);
   inc(filearg);
   if (pline[1]='-')or(pline[1]='/') then continue;
   if pos('.',pline)=0 then pline:=pline+'.C';
   input:=mustopen(pline,'r');
   if (files=NO){and iscons(stdout))} then begin
    outfn:=copy(pline,1,pos('.',pline))+'.asm';
    output:=mustopen(outfn,'w');
   end;
   files:=YES;
   exit;
  end;
  writeln('input...?');
  halt;
 end;

(*
** open a file with error checking
*)
function mustopen(fn,mode:string):integer;
 var
  fd:integer;
 begin
  fd:=fopen(fn,mode);
  if fd<>0 then begin
   mustopen:=fd;
   exit;
  end;
  writeln('open error on ',fn);
  halt;
 end;


begin
 filearg:=1;
end.