{                         P32 - 32bit Pascal Compiler                        }
{ -------------------------------------------------------------------------- }
{                       Johan Prins - jprins@knoware.nl                      }
{ ========================================================================== }
{                                                                            }
{                                                   (c) Copyright 1996-1998  }
{                                                                            }
{ -------------------------------------------------------------------------- }

unit P32_cfg;

interface

type
   configrec = record
              target     : string[15];
              comment,
              systemunit,
              assembler,
              linker     : string[63];
              tool       : array[1..1] of string[63];
              {asmoptions,
              linkoptions,}
              asmdef     : string[31]
            end;

var config     : configrec;
    compilerdir: string;
   __filename  : string;

procedure Usage;
procedure ReadConfig;
procedure CreateBatchFile(s:string);
procedure ExecuteBatchFile(s:string);
procedure SetCompilerDir;
function GetOptions:string;
function FileExists(filename: string): boolean;
function Execute(const prog, param:string):integer;

implementation

uses P32_code, P32_symb, P32_prep, P32_scan, P32_err, Dos, Memory
{$IFNDEF PMODE}
  , Exec
{$ENDIF}
;

type
   KeyWords = ( _unknown,
                _equal,
                _lbracket,
                _rbracket,
                _target,
                _comment,
                _systemunit,
                _assembler,
{                _asmoptions,}
                _linker,
{                _linkoptions,}
                _asmdef,
                _tool,
                _define,
                _compiler,
                _options
                );

const
    KeyNames : array [KeyWords] of string[11] =
    ('',
     '=',
     '[',
     ']',
     'TARGET',
     'COMMENT',
     'SYSTEMUNIT',
     'ASSEMBLER',
{     'ASMOPTIONS',}
     'LINKER',
{     'LINKOPTIONS',}
     'ASMDEF',
     'TOOL',
     'DEFINE',
     'COMPILER',
     'OPTIONS'
     );

   Cr  = #13;
   Lf  = #10;
   Tab = ^I;
   nr  = ord(_options);

var
   targets: array [1..16] of configrec;
   linecount,
   targetcounter: integer;
   look : char;
   ini  : text;
   s    : string;
   current: keywords;

procedure Usage;
begin
  writeln('Usage : P32 <options> <source> [.PAS]');
  writeln;
  writeln('Options:');
  writeln;
  writeln('-Ax          Align data, x: 1, 2, 4, 8, F (16)  [default=4]');
  writeln;
  writeln('-Ba          Create batch file for assembling and linking');
  writeln('-Bx          Create and execute batch file for assembling and linking');
  writeln;
  writeln('-Cs          Compile system unit');
  writeln;
  writeln('-Dl          Add commented line numbers to output file');
  writeln;
  writeln('-I           Display compiler info');
  writeln;
  writeln('-Od[+/-]     Toggle dead code elimination');
  writeln('-O1..9       Set lowlevel optimizing level');
  writeln('-Ox          Maximum lowlevel optimizing');
{  writeln('-Op386       Optimize for i386 processor');
  writeln('-Op486       Optimize for i486 processor');}
  writeln('-OpPent      Optimize for Pentium processor');
{  writeln('-OpPMMX      Optimize for Pentium MMX processor');
  writeln('-OpPPro      Optimize for Pentium Pro processor');
  writeln('-OpPII       Optimize for Pentium II processor');
  writeln('-Op6x86      Optimize for Cyrix 6x86 processor');
  writeln('-OpK5        Optimize for AMD K5 processor');}
  writeln;
  writeln('-Sc          Enable nested comments');
  writeln('-Sz          Enable C-style comments');
  writeln('-Sp          Parentheses required for procedures and functions');
  writeln;
  halt(0);
end;

procedure CompilerInfo;
begin
  WriteLn;
  WriteLn('P32 is created by:');
  WriteLn('ù Johan Prins: Main program, scanner, parser, code-generator');
  WriteLn('ù Jose A.Vericat: Some floating point routines');
  WriteLn('ù Daniel D. Bennett: Unit saving routines');
  WriteLn('ù David Boshell: floating point routines, heap routines, absolute keyword');
  WriteLn('ù Laurie Boshell: break, continue, exit statements');
  WriteLn('ù Michael Goddard: IDE, RLE compression');
  WriteLn;
  WriteLn('P32 is completely free and comes with full sources, you may use it to produce');
  WriteLn('commercial programs.');
  WriteLn('When distributing this software package you may not charge more than US $5.');
  WriteLn;
  halt(0);
end;

function ReplaceMacro(var source:string; const token, new: string):boolean;
var i, p : integer;
    ext:string;
begin
  ReplaceMacro:=FALSE;
  p := pos(token, source);
  if p<>0 then
    begin
      i:=p+length(token);
      if (length(token)+p-1=length(source)) or
         (source[i]  = '.') or
         (source[i]  = ' ') then
        begin
          delete(source, p, length(token));
          insert(new, source, p);
          ReplaceMacro:=TRUE;
        end
    end;
end;

function GetOptions:string;

var tmp, s: string;
    i: integer;

begin
  if paramcount = 0 then Usage;
  i:=1;
  s:=paramstr(i);
  while i <> (ParamCount+1) do
  begin
    if (s[1]<>'-') and (s[1]<>'/') then break;
    s:=ToUpper(s);
    case s[2] of
    '?': Usage;
    'I': CompilerInfo;
    'A': case s[3] of
         '1' : AlignData:=1;
         '2' : AlignData:=2;
         '4' : AlignData:=4;
         '8' : AlignData:=8;
         'F' : AlignData:=16;
         else  AlignData:=4;
         end;
    'B': case s[3] of
         'A': CreateBatch:=TRUE;
         'X': ExecuteBatch:=TRUE;
         end;
    'C': case s[3] of
         'S': CompileSystemUnit:=TRUE;
         end;
    'D': case s[3] of
         'L': AddLineNumbers:=TRUE;
         end;
    'M': begin {stack/heap memory-settings}
         end;
    'O': case s[3] of {optimize settings}
         '1'..'9': OptimizeLevel:=ord(s[3])-ord('0');
         'X'     : OptimizeLevel:=255;
         'D'     : if s[4]='+' then EliminateDeadCode   :=TRUE
                               else EliminateDeadCode   :=FALSE;
         'P'     : begin
                    tmp:=Copy(s, 4, length(s)-3);
                    if tmp='I386' then CPU:=i386
                    else
                    if tmp='I486' then CPU:=i486
                    else
                    if tmp='PENT' then CPU:=Pentium
                    else
                    if tmp='PMMX' then CPU:=PMMX
                    else
                    if tmp='PPro' then CPU:=PPro
                    else
                    if tmp='PII' then CPU:=PII
                    else
                    if tmp='6X86' then CPU:=C6x86
                    else
                    if tmp='K5' then CPU:=K5;
                   end;
         else      Error('-O1..9, D, P, X required');
         end;
    'S': case s[3] of
         'C': NestedComments:=TRUE;
         'Z': CstyleComments:=TRUE;
         'P': Parentheses:=TRUE;
         end;
    end;
    inc(i);
    s:=paramstr(i);
  end;
  GetOptions:={paramstr(i)}s;
end;

procedure GetChar;
begin
  if not eof(ini) then read(ini, look);
  if Look = #13 then Inc(LineCount);
end;

procedure SkipSpace;
begin
  while (look in [Cr, Lf, Tab, ' '] ) and (not eof(ini)) do
    GetChar;
end;

procedure GetToken;

label
   restart;

var
   i: integer;
   k: keywords;

begin
RESTART:
   s:='';
   k:=_unknown;
   SkipSpace;
   case Look of
   ';'  : begin
            repeat
              getchar;
            until Look = Lf;
            goto RESTART;
          end;
   '=',
   ']',
   '['  : begin
            s:=look;
            getchar;
                    for i := 0 to nr do
                      if s = KeyNames[KeyWords(i)] then
                        begin
                          k := KeyWords(i);
                          break;
                        end;
          end;
  ''''  : begin {string constant}
                    getchar;
                    {X := false;}
                    repeat
                      case look of
                      cr    : abort('String exceeds line');
                      ''''  : begin
                                getchar;
                                if look <> '''' then break
                                else begin
                                       s := s + look;
                                       getchar;
                                     end;
                              end;
                      else
                              s := s + look;
                              getchar;
                      end;
                    until false;
                  end;
   else
    {'_',
    'A'..'Z',
    'a'..'z'  : }begin {identifier}
                  while not (Look in [Cr, Lf, '=', ' ',']','[']) do
                  begin
                    s := s + upcase(Look);
                    GetChar;
                  end;
                    for i := 0 to nr do
                      if s = KeyNames[KeyWords(i)] then
                        begin
                          k := KeyWords(i);
                          break;
                        end;
                end;
   end;
   current:=k;
end;

procedure Match(x: keywords);
begin
  if Current <> X then
    begin
      if ord (X) <= nr then Error('P32.INI ('+ Numb(linecount)+') '+KeyNames[x]+'  expected');
    end
  else
  GetToken;
end;

procedure SetCompilerDir;
var
   _P  : PathStr;
   _D  : DirStr;
   _N  : NameStr;
   _E  : ExtStr;

begin
  fsplit(paramstr(0), _D, _N, _E);
  compilerdir := ToUpper(_D);
end;

procedure ReadConfig;
var t:KeyWords;
    i:integer;
    temp,
    inipath:string;
    p : pstring;
begin
{  assign(ini, GetEnv('P32') + 'P32.INI');}
{** mag, A better search for the INI file, I forgot to change my %P32% and
         caused hours of headache, never again, search current directory first!}
  assign(ini, FSearch('P32.INI','.'+GetEnv('P32')+';'+GetEnv('PATH')));
  {$I-} reset(ini); {$I+}
  if ioresult <> 0 then Error('P32.INI not found');
  LineCount:=1;
  targetcounter:=0;
  GetChar;
  repeat
    GetToken;
    if current=_lbracket then Match(_lbracket);
    case current of
    _target : begin
                GetToken; {'s' contains string now}
                inc(targetcounter);
                targets[targetcounter].target:=s;
                GetToken; {advance to next token}
                Match(_rbracket);
                while (current<>_lbracket) and not eof(ini) do
                begin
                  case current of
                  _comment   : begin
                                 Match(_comment);
                                 Match(_equal);
                                 if current<>_unknown then continue;
                                 targets[targetcounter].comment:=s;
                                 GetToken;
                               end;
                  _systemunit: begin
                                 Match(_systemunit);
                                 Match(_equal);
                                 if current<>_unknown then continue;
                                 targets[targetcounter].systemunit:=s;
                                 GetToken;
                               end;
                  _assembler : begin
                                 Match(_assembler);
                                 Match(_equal);
                                 if current<>_unknown then continue; {fix to allow no parameters}
                                 targets[targetcounter].assembler:=s;
                                 GetToken;
                               end;
                  _linker    : begin
                                 Match(_linker);
                                 Match(_equal);
                                 if current<>_unknown then continue;
                                 targets[targetcounter].linker:=s;
                                 GetToken;
                               end;
                  _asmdef    : begin
                                 Match(_asmdef);
                                 Match(_equal);
                                 if current<>_unknown then continue;
                                 targets[targetcounter].asmdef:=s;
                                 GetToken;
                               end;
                  _tool      : begin
                                 Match(_tool);
                                 Match(_equal);
                                 if current<>_unknown then continue;
                                 targets[targetcounter].tool[1]:=s;
                                 GetToken;
                               end;
                  _unknown   : Error('P32.INI ('+ Numb(linecount)+') Entry expected');
                  {_define    :
                   _switches;}
                  end;
                end;
              end;
    _compiler:begin
                Match(_compiler);
                Match(_rbracket);
                repeat
                case current of
                _options: begin
                            Match(_options);
                            Match(_equal);
                            if current=_unknown then
                              begin
                                asm
                                  mov  es, PrefixSeg
                                  mov  di, offset 080h
                                  mov  word ptr [p+2], es
                                  mov  word ptr [p], di
                                end;
                                p^:=s + ' '+ p^;
                                GetToken;
                              end
                            else
                              continue;
                          end;
                _target : begin
                            Match(_target);
                            Match(_equal);
                            i:=0;
                            repeat
                              inc(i);
                              if s=targets[i].target then break
                            until i=targetcounter;
                            config:=targets[i];
                            GetToken;
                          end;
                end;
                until (current <> _target) and (current <> _options)
              end;
    end;
  until eof(ini);
  AddStringName(directive_names,config.target);
end;


procedure CreateBatchFile(s:string);
var batch: text;
    asmstring,
    linkstring,
    toolstring,
    tmp  : string;
    sym  : pSymbolRecord;

   _D  : DirStr;
   _N  : NameStr;
   _E  : ExtStr;

begin
  assign(batch, 'C.BAT');
  rewrite(batch);
  writeln(batch, '@ECHO OFF');
  writeln(batch, 'REM  Batch file to compile: ', programname);
  writeln(batch, 'REM  Target: ', config.comment, ' (',config.target,')');
  asmstring:=config.assembler;
  linkstring:=config.linker;
  toolstring:=config.tool[1];

  fsplit(s, _D, _N, _E);
  s:=_D+_N; {rip off the extension}

  ReplaceMacro(asmstring, '$NAME', s);
  writeln(batch, asmstring);

  tmp:=s{''};
    sym:=GlobalTable.first;
    while sym^.next <> NIL do
    begin
      sym:=sym^.next;
      if sym^.symbol=_unit then
        begin
          if ReplaceMacro(asmstring, '$NAME', sym^.name) then
            writeln(batch, asmstring);
          if ReplaceMacro(linkstring, '$NAME', sym^.name) then
            writeln(batch, linkstring);
          if ReplaceMacro(toolstring, '$NAME', sym^.name) then
            writeln(batch, toolstring);
          tmp:=tmp+' '+sym^.name;
        end;
    end;


    if ReplaceMacro(asmstring, '$NAMELIST', tmp) then
      writeln(batch, asmstring);
    if ReplaceMacro(linkstring, '$NAME', s) then
      if ReplaceMacro(linkstring, '$NAMELIST', tmp) then
        writeln(batch, linkstring)
      else
        writeln(batch, linkstring)
    else if ReplaceMacro(linkstring, '$NAMELIST', tmp) then
           writeln(batch, linkstring);
    if ReplaceMacro(toolstring, '$NAMELIST', tmp) then
      writeln(batch, toolstring);

    if ReplaceMacro(toolstring, '$RESULT', s) then
      writeln(batch, toolstring);

  close(batch);
end;

procedure ExecuteBatchFile(s:string);
var result: word;
begin
  CreateBatchFile(s);
  Result:=Execute('','/C C.BAT');
  if doserror<>0 then Error('Executing batchfile');
end;

function FileExists(filename: string): boolean;
var f:file;
begin;
 {$I-} {- Turn OFF I/O checking so TP doesn't give us an error -}
 assign(f, filename);                         {- Try to open the file, read-only mode -}
 filemode:=0;
 reset(f);
 close(f);
 {$I+}
 FileExists:=(IOResult=0) and (FileName<>''); {- Check if we got an error -}
 filemode:=2;                                 {- Set everything back to normal -}
end;

function Execute(const prog, param:string):integer;
var
   OldHeapEnd: pointer;
   result: word;

begin
{$IFNDEF PMODE}
  OldHeapEnd := HeapEnd;
  HeapEnd := HeapPtr;
  SetMemTop(HeapEnd);
  Result:=Do_Exec(prog, param, USE_ALL, $FFFF, FALSE);
{$ELSE}
  Exec(prog, param);
{$ENDIF}
  {$IFDEF debug}
  WriteLn('Returned from the swap.. Results:  High byte = ',Hi(Result),' Low byte = ',Lo(Result));
  {$ENDIF}
{$IFNDEF PMode}
  HeapEnd := OldHeapEnd;
  SetMemTop(HeapEnd);
{$ENDIF}
  Execute:=Result;
end;

var p: pstring;

begin
  SetCompilerDir;
  CPU := i486;
end.
