{                         P32 - 32bit Pascal Compiler                        }
{ -------------------------------------------------------------------------- }
{                       Johan Prins - jprins@knoware.nl                      }
{ ========================================================================== }
{ Preprocessor                                                               }
{                                                   (c) Copyright 1997-1998  }
{ Parts copied from: PREP.PAS                                                }
{                by: J R Ferguson, j.r.ferguson@iname.com                    }
{                                                                            }
{ -------------------------------------------------------------------------- }

unit P32_prep;

interface

uses P32_err;

type

    pstring     = ^string;

    stringlist  = ^_str;

    _str        = record
                    {name: string[64];}
                    name: pstring;
                    next: stringlist;
                   end;

var
   directive_names       : stringlist;
   incomment             : boolean;

   {global variables that control the compiler options}

const
   NestedComments       : boolean = FALSE;
   CstyleComments       : boolean = FALSE;
   EliminateDeadCode    : boolean = TRUE;
   OptimizeLevel        : integer = 0;
   CompileSystemUnit    : boolean = FALSE;
   AddLineNumbers       : boolean = FALSE;
   CreateBatch          : boolean = FALSE;
   ExecuteBatch         : boolean = FALSE;
   AlignData            : integer = 4;
   DirectAsm            : boolean = FALSE;
   Parentheses          : boolean = FALSE;
   OpenParameters       : boolean = TRUE;

procedure DoDirectives;
procedure AddStringName(p: stringlist; s: string);

procedure CreateStringList(var p: stringlist);
procedure DestroyStringList(var p: stringlist);
procedure NewStringListEntry(var p: stringlist);

function getmemstring(const s: string):pstring;
procedure freememstring(var p:pstring);

implementation

uses P32_scan;
{type declaration}

type
  IfStkPtr  = ^IfStkRec;
  IfStkRec  = record
                cnd,inv: boolean;
                nxt: IfStkPtr
              end;

var
  IfStack   : IfStkPtr;

{
--- Condition Stack manipulation ---
    Single linked list used as a LIFO stack
}

procedure IfCreate;
begin
  IfStack:=nil
end;

function IfEmpty: boolean;
begin
  IfEmpty:= IfStack = nil
end;

procedure IfPush(cond: boolean);
var p: IfStkPtr;
begin
  new(p);
  with p^ do begin
               cnd:= cond;
               inv:= false;
               nxt:= IfStack
             end;
  IfStack:= p;
end;

procedure IfPop;

var p: IfStkPtr;

begin
  if not IfEmpty then
    begin
      p:= IfStack;
      IfStack:= IfStack^.nxt;
      dispose(p);
    end
end;

function IfAll: boolean;
var ok: boolean;
     p: IfStkPtr;
begin
  ok:= TRUE;
  p:= IfStack;
  while ok and (p<>nil) do
    begin
      ok:= p^.cnd;
      p := p^.nxt
    end;
  IfAll:= ok;
end;

procedure IfInvert(var b:boolean);
begin
  if not IfEmpty then
    begin
      with IfStack^ do
        begin
          cnd:= not cnd;
          inv:= true;
          b:=cnd;
        end;
    end;
end;

function IfInverted: boolean;
begin
  if IfEmpty then IfInverted:= true
             else IfInverted:= IfStack^.inv
end;

procedure IfDiscard;
begin
  while not IfEmpty do IfPop
end;

{
--- Identifier Table Manipulation ---
}

procedure CreateStringList(var p: stringlist);
begin
   new(p);
   p^.next:=NIL;
   p^.name:=NIL;
end;

procedure NewStringListEntry(var p: stringlist);
begin
   new(p^.next); {create new one}
   p:=p^.next;   {assign to given entry}
   p^.name:=NIL;  {empty new entry}
   p^.next:=NIL;
end;

procedure DestroyStringList(var p: stringlist);
var start: stringlist;

begin
  start:=p;
  while start<>NIL do
    begin
      p:=start^.next;
      freememstring(start^.name);
      dispose(start);
      start:=p;
    end;
  p:=NIL;
end;

function getmemstring(const s: string):pstring;
var p:pstring;
begin
  if s='' then
    p:=NIL
  else
    begin
      GetMem(p, length(s)+1);
      p^:=s;
    end;
  getmemstring:=p;
end;

procedure freememstring(var p:pstring);

begin
  if p<>NIL then FreeMem(p, length(p^)+1);
  p:=NIL;
end;

procedure AddStringName(p: stringlist; s:string);

begin
  while p^.next<>NIL do p:=p^.next; {get latest entry}
  new(p^.next);  {create new one}
  p:=p^.next;
  p^.next:=NIL;  {only one entry added}
  p^.name:=getmemstring(s);    {add name}
end;

function FindStringName(p: stringlist; s:string):boolean;

begin
  FindStringName:=FALSE;
  while (p^.next <> NIL) and (p^.name^<>s) do p := p^.next;
  if p^.name^=s then FindStringName:=TRUE;
end;

procedure EatCode;

label restart;

begin
restart:
  GetChar;
  case Look of
  '{'  :    begin
              GetChar;
              if look='$' then
                DoDirectives
              else goto restart;
            end;
  else
  goto restart;
  end;
end;

procedure DoDirectives;

type
     directive =
      ( _none, _ifdef, _else, _endif, _define, _ad, _c, _p);

const
     directive_name: array[directive] of string[7] =
      ('','$IFDEF','$ELSE','$ENDIF', '$DEFINE', '$AD', '$C', '$P');

var
   b:boolean;
   i, current_directive: directive;

begin
  current_string:='';
  current_directive:=_none;
  {get directive}
  while (look<>' ') and (look<>'}') and (look<>'+') and (look<>'-') do
  begin
    current_string:=current_string+upcase(look);
    GetChar;
  end;

  for i := low(directive) to high(directive) do
    if current_string = directive_name[i] then current_directive:=i;

  case current_directive of
  _define: begin
             if IfInverted then
             begin
             {get the symbol}
             GetChar; {eat spaces}
             current_string:='';
             while (look<>' ') and (look<>'}') do
             begin
               current_string:=current_string+upcase(look);
               GetChar;
             end;
             AddStringName(directive_names, current_string);
             end;
           end;
  _ifdef : begin
             GetToken;
             b:=FindStringName(directive_names, current_string);
             IfPush(b);
             if b=FALSE then EatCode;
           end;
  _else :  if IfInverted then LineError(LineCount, 'Error with $ELSE')
           else begin
                  IfInvert(b);
                  if b=FALSE then EatCode;
                end;
  _endif: if IfEmpty then LineError(LineCount, 'Error with $ENDIF')
          else IfPop;
  _ad:    begin
            case look of
            '+' : DirectAsm:=TRUE;
            '-' : DirectAsm:=FALSE;
            else LineError(LineCount, 'Compiler directive requires ''+'' or ''-''');
            end
          end;
  _c:     begin
            case look of
            '+' : NestedComments:=TRUE;
            '-' : NestedComments:=FALSE;
            else LineError(LineCount, 'Compiler directive requires ''+'' or ''-''');
            end
          end;
  _p:     begin
            case look of
            '+' : OpenParameters:=TRUE;
            '-' : OpenParameters:=FALSE;
            else LineError(LineCount, 'Compiler directive requires ''+'' or ''-''');
            end
          end
  else
  {else if IfAll then }
         {case current_directive of
          {CmdDefn : IdInsert(CurArg);}
          {CmdPref : InclPref:= CurArg;}
          {CmdIncl : Process(InclPref+CurArg);}
          {else    {          CmdNone : WriteLn(OutFile^.Fvar,CurLine);}
          {end;}
  end;
end;

begin
  CreateStringList(directive_names);
  AddStringName(directive_names,'P32V040');
end.
