{                         P32 - 32bit Pascal Compiler                        }
{ -------------------------------------------------------------------------- }
{                       Johan Prins - jprins@knoware.nl                      }
{ ========================================================================== }
{ Main-program and parser                                                    }
{                                                   (c) Copyright 1996-1998  }
{                                                                            }
{ http://surf.to/p32                                                         }
{                                                                            }
{ -------------------------------------------------------------------------- }

{ $DEFINE pmode  -  to compile P32 in Borland Protected Mode}

{ $DEFINE debug  -  for debugging purposes}

{$IFDEF debug}
{$R+} {range checking on}
{$S+} {stack checking on}
{$Q+} {overflow checking on}
{$ENDIF}

{$IFDEF VER70}
{P32 requires a _big_ stack...}
{$M 65355, 0, 653560}
{$ENDIF}


{ $DEFINE P32IDE}

{$IFDEF P32IDE} {turn p32.pas into a unit}

unit P32;

interface

{$ELSE}

program P32;

{$ENDIF}

uses
     Dos,
     P32_cpuf,
     P32_err,    {error reporting}
     P32_prep,   {preprocessor}
     P32_scan,   {scanner, lexical analyser}
     P32_opt,    {high-level optimizer}
     P32_code,   {code generation and low-level optimizer}
     P32_symb,   {symboltable routines}
     P32_tree,   {parsetree routines}
     P32_asm,    {routines for the assembler}
     P32_unit,   {unit loading and saving routines}
     P32_cfg;    {configuration routines}

const
     TAB = ^I;
var
   makesymbolspublic:boolean;

{ forward definitions}

{$IFDEF P32IDE}
 Procedure init;
 function Main:pTree;
 function Statement:pTree;
 function Expression:pTree;
 function GetTypeDef(const name:string):pTypeRecord;
 procedure Compile(var s:string);

 implementation
{$ELSE}

function Main:pTree; forward;
function Statement:pTree; forward;
function Expression:pTree; forward;
function GetTypeDef(const name:string):pTypeRecord; forward;
procedure Compile(var s:string); forward;
{$ENDIF}

function GetStringList: stringlist;
{ Reads comma-separated strings and creates a linked list that contains
  strings with identifiers, for use in variable and type declarations. }

var
   start, str : stringlist;

begin
   CreateStringList(str);
   start:=str; {first entry}

   str^.next := NIL;     {reset pointer to next record}
   str^.name := getmemstring(GetName); {store name of identifier}
   while current_token = _comma do
     begin
       Match(_comma);
       NewStringListEntry(str);
       str^.name := getmemstring(GetName); {store name of identifier}
     end;
   GetStringList:=start;   {return pointer to first entry}
end;

function GetLabelList:stringlist;   {LB, new function got goto and labels}
{ Based on GetStringList, reads comma-separated labels, be they strings or
  integer constants, and creates a linked list that contains
  strings with identifiers, for use in label declarations. }

var
   start, str : stringlist;

begin
   CreateStringList(str);

   start:=str; {first entry}
   repeat
     str^.next := NIL;     {reset pointer to next record}
     str^.name := getmemstring(GetLabel); {store name of identifier}
     if (Current_Token = _comma) then
       begin
         Match(_comma);
         NewStringListEntry(str);
         {new(str^.next);   {create new record}
         {str:=str^.next;   {assign pointer to new record to str}
       end;
   until current_token=_separator;
   GetLabelList:=start;   {return pointer to first entry}
end;

function DoParametersOnCall:pTree;
{ Processes the parameters of a procedure/function when it's called.
  It also takes care of expression like 'WriteLn(a:3);'.            }

var p1, p2     : pTree;

begin
  if current_token=_rparen then {no parameters left}
    begin
      DoParametersOnCall:=NIL;
      exit;
    end;
  p2:=nil;

  repeat
    p1:=Expression;          {get expression}
    p2:=GenParamNode(p1,p2);
    p2^.colon:=false;
    if current_token=_colon then {do we have a ':' ? }
      begin
        Match(_colon);
        p1:=expression;      {get expression after ':'}
        p2:=GenParamNode(p1,p2);
        p2^.colon:=true;
        if current_token=_colon then
          begin
            Match(_colon);
            p1:=expression;
            p2:=GenParamNode(p1,p2);
            p2^.colon:=true;
          end;
      end;
    if current_token=_comma then Match(_comma)
                            else break;
  until false;
  DoParametersOnCall:=p2; {return tree containing parameters}
end;


function factor:pTree;

var p1,p2            : pTree;
    typ              : pTypeRecord;
    sym_field, sym   : pSymbolRecord;
    fieldname, name  : string;
    setconst         : pset;  {defined in P32_tree}
    i, s1, s2        : byte;

    procedure AddElement(var s: pset; n: byte);
    var i: integer;
    begin
      if (n < 0) or (n > 255) then
        LineError(linecount, 'Set base type out of range');
      i := n div 8;
      s^[i]:=s^[i] or (1 shl (n mod 8));
    end;

    procedure DoQualifiers;
    { This nested procedure analyses a qualifier following an identifier,
      like: '[',']', '^', '.' (array, pointer, record)}
    begin
      case current_token of
      _ptr        : begin { ^ }
                      Match(_ptr);
                      p1:=GenLeftNode(__ptr, p1);
                      typ:=typ^.PointerTo^.typedef;
                    end;
      _lbracket   : begin { [ }
                      Match(_lbracket);
                      repeat
                        case typ^.typedef of
                        _StringDef  : begin
                                        p2:=expression;
                                        OptimizeTree(p2);
                                        p1:=GenExpNode(__index, p1, p2);
                                        typ^.definition:=NewType;
                                        typ^.range:=typ^.definition;
                                        typ:=typ^.definition;
                                        typ^.typedef:=_SubRangeDef;
                                        typ^.subrangetyp:={u8bit}uchar;
                                        typ^.lowerlimit:=0;
                                        typ^.upperlimit:=255;
                                      end;
                        _ArrayDef   : begin
                                        p2:=expression;
                                        OptimizeTree(p2);
                                        p1:=GenExpNode(__index, p1, p2);
                                        typ:=typ^.definition;
                                      end;
                        _PointerDef : begin
                                        p2:=expression;
                                        p1:=GenExpNode(__index, p1, p2);
                                        typ:=typ^.PointerTo^.typedef;
                                      end;
                        else          LineError(LineCount, 'Invalid qualifier');
                        end;
                        if current_token=_comma then Match(_comma)
                                                else break;
                      until false;
                      Match(_rbracket); { ] }
                    end;
      _period     : begin { . }
                      Match(_period);
                      case typ^.typedef of
                      _RecordDef : begin
                                     fieldname:=GetName;
                                     sym:=GetPointer(GlobalTable, {field}name); {get symbol entry}
                                     if sym^.typedef=nil then Error('Record doesn''t have fields')
                                     else begin
                                            sym_field:=GetPointer(typ^.RecordTable, fieldname);{Table of vars in record}
                                            if sym_field=NIL then LineError(LineCount,'Field expected'); {no entries}
                                            p1:=GenFieldNode(sym, sym_field, p1);
                                          end;
                                     typ:=sym_field^.typedef;
                                   end;
                      else         LineError(LineCount,'Invalid qualifier');
                      end
                    end;
      else Exit;
      end;
      DoQualifiers;
    end; { end of procedure DoQualifiers}

begin
  case current_token of
   _name             : begin {identifier}
                        name := GetName;
                        sym := GetPointer(GlobalTable, name);
                        if (sym=NIL) and (ProcName<>'') then
                          sym := GetPointer(GlobalTable, ProcName+name); {nested procedure}
                            {if (sym=NIL) and then
                             { sym := GetPointer(GlobalTable, ProcName);    {recursive call }
                        if sym=NIL then
                          LineError(LineCount, 'Unknown identifier');
                        typ:=sym^.typedef;
                        case sym^.symbol of
                        _variable  : begin {it's a variable}
                                       p1:=GenVarNode(GlobalTable,sym);
                                       {sym^.dumped:=FALSE;}
                                     end;
                        _type      : begin  {typeconversion}
                                       Match(_lparen);
                                       p1:=Expression;
                                       Match(_rparen);
                                       p1:=GenTypeConvNode(p1, typ, true);
                                     end;
                        _constant   : begin {constant, declared with 'CONST'}
                                        case sym^.c of
                                        _IntegerConst,
                                        _OrdinalConst : p1:=GenOrdConstNode(sym^.n, sym^.consttyp);   { 4 }
                                        _CharConst    : p1:=GenCharConstNode(sym^.x);      { 'a' }
                                        _StringConst  : p1:=GenStrConstNode(sym^.s);      { 'test' }
                                        _RealConst    : p1:=GenRealConstNode(sym^.d);     { 3.0E10 }
                                        end;
                                        p1^.sym:=sym;
                                      end;
                        _proc,
                        _func       : begin {procedure/function call...}
                                        p1:=GenCallNode(GlobalTable,sym);
                                        if (current_token=_lparen) or
                                           (Parentheses=TRUE) then {if there are parameters, parse them}
                                          begin
                                            Match(_lparen);
                                            p1^.left:=DoParametersOnCall;
                                            Match(_rparen);
                                          end
                                        else p1^.left:=nil;
                                      end;
                        else          begin
                                        LineError(LineCount, 'Error in expression');
                                      end;
                            end;
                        DoQualifiers; {'[',']','.','^'}
                      end;
  _integer_constant : p1:=GenOrdConstNode(GetNumber, NIL);
  _real_constant    : p1:=GenRealConstNode(GetFloat);
  _string           : begin
                        Match(_lbracket);
                        p1:=Expression;
                        OptimizeTree(p1);
                        Match(_rbracket);
                      end;
  _string_constant  : begin
                        p1:=GenStrConstNode(current_string);
                        Match(_string_constant);
                      end;
  _char_constant  : begin
                      p1:=GenCharConstnode(current_string[1]);
                      Match(_char_constant);
                    end;
  _at             : begin { @ }
                      Match(_at);
                      p1:=factor;
                      p1:=GenLeftNode(__address,p1);
                    end;
  _lparen         : begin { ( }
                      Match(_lparen);
                      p1:=Expression;
                      Match(_rparen);
                    end;
  _lbracket       : begin { [ }
                      Match(_lbracket);
                      new(setconst);
                      fillchar(setconst^, sizeof(setconst^), 0);
                      if current_token <> _rbracket then
                        repeat
                          p2:=NIL;
                          p1:=Expression;
                          OptimizeTree(p1);
                          typ:=p1^.return;
                          case p1^.op of
                          __charconst : begin
                                          AddElement(setconst, ord(p1^.c));
                                          DestroyTree(p1);
                                        end;
                          __ordconst  : begin
                                          AddElement(setconst, p1^.n);
                                          DestroyTree(p1);
                                        end;
                          __subrange  : begin
                                          if p1^.left^.op  = __charconst then s1:=ord(p1^.left^.c)
                                                                         else s1:=p1^.left^.n;
                                          if p1^.right^.op = __charconst then s1:=ord(p1^.left^.c)
                                                                         else s1:=p1^.left^.n;
                                          for i:=s1 to s2 do AddElement(setconst, i);
                                          DestroyTree(p1);
                                         end;
                          else           begin
                              {               if pd=nil then
                                               pd:=p1^.resulttype;
                                             if not(is_equal(pd,p1^.resulttype)) then
                                               error(typeconflict_in_set);
                                             p2:=gennode(setelen,p1,p2);}
                                         end;
                          end;
                          if current_token=_comma then Match(_comma)
                                                  else break;
                        until false;
                        Match(_rbracket);
                      p1:=GenLeftNode(__setconst, p2);
                      p1^.cset:=setconst;
                      new(p1^.return);
                      p1^.return^.typedef:=_SetDef;
                      p1^.return^.setof:=typ;
                    end;
  _plus           : begin { + }
                      Match(_plus);
                      p1:=factor;
                    end;
  _minus          : begin { - }
                      Match(_minus);
                      p1:=factor;
                      p1:=GenLeftNode(__minus, p1);
                    end;
  _not            : begin { not }
                      Match(_not);
                      p1:=factor;
                      p1:=GenLeftNode(__not, p1);
                    end;
  _nil            : begin { nil }
                      Match(_nil);
                      {p1:=GenLeftNode(__nil, p1);}
                      p1:=GenNilNode;
                    end;
  else
                    LineError(LineCount, 'Error in expression');
  end;
  factor:=p1;
end;

function term:pTree;

var p1, p2 : pTree;

begin
  p1:=factor;
  repeat
    case current_token of
    _mul        : begin { * }
                    Match(_mul);
                    p2:=factor;
                    p1:=GenExpNode(__mul,p1,p2);
                  end;
    _slash      : begin { / }
                    Match(_slash);
                    p2:=factor;
                    p1:=GenExpNode(__slash,p1,p2);
                  end;
    _div        : begin { div }
                    Match(_div);
                    p2:=factor;
                    p1:=GenExpNode(__div,p1,p2);
                  end;
    _mod        : begin { mod }
                    Match(_mod);
                    p2:=factor;
                    p1:=GenExpNode(__mod,p1,p2);
                  end;
    _and        : begin { and }
                    Match(_and);
                    p2:=factor;
                    p1:=GenExpNode(__and,p1,p2);
                  end;
    _shl        : begin { shl }
                    Match(_shl);
                    p2:=factor;
                    p1:=GenExpNode(__shl,p1,p2);
                  end;
    _shr        : begin { shr }
                    Match(_shr);
                    p2:=factor;
                    p1:=GenExpNode(__shr,p1,p2);
                  end;
    else          break;
    end;
  until false;
  term:=p1;
end;

function simple_expression:pTree;

var p1,p2: pTree;

begin
  p1:=term;
  repeat
    case current_token of
    _plus    : begin { + }
                 Match(_plus);
                 p2:=term;
                 p1:=GenExpNode(__add,p1,p2);
               end;
    _minus   : begin { - }
                 Match(_minus);
                 p2:=term;
                 p1:=GenExpNode(__sub,p1,p2);
               end;
    _or      : begin { or }
                 Match(_or);
                 p2:=term;
                 p1:=GenExpNode(__or,p1,p2);
               end;
    _xor     : begin { xor }
                 Match(_xor);
                 p2:=term;
                 p1:=GenExpNode(__xor,p1,p2);
               end;
    else       break;
    end;
  until false;
  simple_expression:=p1;
end;

function boolean_expression:pTree;

var p1, p2 : pTree;

begin
  p1:=simple_expression;
  repeat
    case current_token of
    _less        : begin { < }
                     Match(_less);
                     p2:=simple_expression;
                     p1:=GenExpNode(__less,p1,p2);
                   end;
    _less_eq     : begin { <= }
                     Match(_less_eq);
                     p2:=simple_expression;
                     p1:=GenExpNode(__less_eq,p1,p2);
                   end;
    _greater     : begin { > }
                     Match(_greater);
                     p2:=simple_expression;
                     p1:=GenExpNode(__greater,p1,p2);
                   end;
    _greater_eq  : begin { >= }
                     Match(_greater_eq);
                     p2:=simple_expression;
                     p1:=GenExpNode(__greater_eq,p1,p2);
                   end;
    _equal       : begin { = }
                     Match(_equal);
                     p2:=simple_expression;
                     p1:=GenExpNode(__equal,p1,p2);
                   end;
    _not_eq      : begin { <> }
                     Match(_not_eq);
                     p2:=simple_expression;
                     p1:=GenExpNode(__not_eq,p1,p2);
                   end;
    _in          : begin { IN }
                     Match(_in);
                     p2:=simple_expression;
                     p1:=GenExpNode(__in,p1,p2);
                   end;
    else           break;
    end;
  until false;
  boolean_expression:=p1;
end;

function Expression:pTree;

var
    p1, p2 : pTree;

begin
  p1:=boolean_expression;
  OptimizeTree(p1);
  case current_token of
  _period2     : begin { .. }
                  Match(_period2);
                  p2:=boolean_expression;
                  OptimizeTree(p2);
                  if ((p1^.op=__ordconst) and (p2^.op=__ordconst)) or
                     ((p1^.op=__charconst) and (p2^.op=__charconst)) then
                    p1:=GenExpNode(__subrange,p1,p2)
                  else
                    p1:=GenExpNode(__float,p1,p2);
                end;
  _assign     : begin { := }
                  Match(_assign);
                  p2:=expression;
                  p1:=GenExpNode(__assign, p1, p2);
                end;
  end;
  Expression:=p1;
end;

function For_Statement:pTree;

var fromvalue, tovalue, block: pTree;
    down_to                  : boolean;
    s, sym                   : pSymbolRecord;
    typ                      : pTypeRecord;

begin
   Match(_for);
   fromvalue:=Expression;
   if fromvalue^.op<>__assign then Expected('assignment');
   if current_token=_downto then
     begin
       Match(_downto);
       down_to:=true;
     end
   else
     begin
       Match(_to);
       down_to:=false;
     end;
   tovalue:=simple_expression;
   OptimizeTree(tovalue);
   if tovalue^.op<>__ordconst then
     begin
          {add a symbol for 'to-value' to use in cmp-instruction}
{          sym:=NewSymbol;
          s:=GetPointer(GlobalTable,'_LONGINT');
          sym^.name:='LIM'+fromvalue^.left^.sym^.name;
          sym^.typedef:=s^.typedef;
          sym^.vlevel := LexLevel;
          sym^.vartype:=_Local;
          sym^.alias  := NIL;
          sym^.absreference := FALSE;
          inc(stacksize, GetSize(sym^.typedef));
          sym^.offset:=stacksize;
          sym^.typedconst:=FALSE;
          AddSymbol(GlobalTable, sym);}
     end;
   Match(_do);
   if current_token<>_separator then block:=statement
   else block:=NIL;
   For_Statement:=GenForNode(fromvalue,tovalue,block,down_to);
end;

function While_Statement:pTree;

var block, eval: pTree;

begin
   Match(_while);
   eval:=Expression;
   Match(_do);
   if current_token<>_separator then block:=statement
   else block:=NIL;
   While_Statement:=GenWhileNode(eval,block);
end;

function Repeat_Statement: pTree;

var p1, p2, block, eval: pTree;

begin
   p1:=nil;
   Match (_repeat);
   while current_token <> _until do
   begin
     if p1=NIL then begin
                      p2:=GenExpNode(__statement, NIL, statement);
                      p1:=p2;
                    end
     else           begin
                      p2^.left:=GenExpNode(__statement, NIL, statement);
                      p2:=p2^.left;
                    end;
      if current_token = _until then break;
      if current_token = _separator then Match(_separator)
   end;
   block:=GenLeftNode(__block, p1);
   Match (_Until);
   eval:=Expression;
   Repeat_Statement:=GenRepeatNode(eval, block);
end;

function If_Statement: pTree;

var eval, if_true, if_false: pTree;

begin
   Match(_if);
   eval:=Expression;
   Match(_then);
   if current_token=_else then if_true:=NIL
   else if_true:=statement;
   if current_token=_else then
     begin
       Match(_else);
       if_false:=statement;
     end
   else if_false:=NIL;
   if_statement:=GenIfNode(eval, if_true, if_false);
end;

function Break_Statement:pTree;

begin
   Match(_break);
   Break_Statement:=GenBreakNode;
end;


function Continue_Statement:pTree;

begin
   Match(_continue);
   Continue_Statement:=GenContinueNode;
end;


function Exit_Statement:pTree;

begin
   Match(_exit);
   Exit_Statement:=GenExitNode;
end;

function Goto_Statement:ptree;   {LB for goto and labels}

var sym : pSymbolRecord;

begin
  Match(_goto);
  If not MaybeLabel(Current_Token) then
    LineError(LineCount,'label identifier expected')
  else
    begin {we have a label, check it is in symboltable}
      if ProcName<>'' then
        sym := GetPointer(GlobalTable, ProcName+'_'+upcase_string)
      else
        sym := GetPointer(GlobalTable, '_'+upcase_string);
      if sym=NIL then
        LineError(LineCount,'unknown label')
      else
        goto_statement:=GenGotoNode(sym);
      Match(current_token);
    end;
end;

function Case_Statement: pTree;

var
   typ : pTypeRecord; {type of case expression}
   p1,case_expr, case_eval, case_block, case_else: pTree;

begin
  Match(_case);
  case_expr:=expression;
  OptimizeTree(case_expr);
  Match(_of);
  case_block:=NIL;
  repeat
    repeat
      case_eval:=expression;
      OptimizeTree(case_eval);
       if current_token=_comma then Match(_comma)
                              else break;
      case_block:=GenCaseBlockNode(case_block, case_eval, NIL);
    until false;
    Match(_colon);
    case_block:=GenCaseBlockNode(case_block, case_eval, statement);
    if (current_token<>_else) or (current_token<>_end) then Match(_separator);
  until (current_token=_else) or (current_token=_end);

  if (current_token=_else) then
    begin
      if current_token=_else then Match(_else);
      case_else:=statement;
      if current_token=_separator then Match(_separator);
    end
  else
    case_else:=nil;
  Match(_end);

  Case_Statement:=GenCaseNode(case_expr, case_block, case_else);
end;

function With_Statement: pTree;

var
   block, p  : pTree;
   WithTable : SymbolList;
   save1, save2,
   tmp, sym  : pSymbolRecord;
   i,j       : integer;
begin
  Match(_with);
  p:=Expression;
  OptimizeTree(p);
  if p^.return^.typedef <> _RecordDef then
    LineError(LineCount, 'Error in WITH expression')
  else
    WithTable:=p^.return^.RecordTable;

   i:=0;
   sym:=WithTable.first;
   while sym <> NIL do
   begin
     inc(i);
     sym:=sym^.next;
   end;
  save1:=GlobalTable.rear^.next;
  save2:=GlobalTable.rear;
  if GlobalTable.first<>NIL then
    begin
      GlobalTable.rear^.next:=WithTable.first;
      WithTable.first^.prev:=GlobalTable.rear;
      GlobalTable.rear:=WithTable.rear;
    end
  else
    GlobalTable:=WithTable;

  {repeat this for all expressions, separated by comma's}
  Match(_do);
  block:=NIL;
  if current_token <> _separator then
    block:=statement;

  GlobalTable.rear^.next:=save1;
  GlobalTable.rear:=save2;
  WithTable.first^.prev:=NIL;

  With_Statement:=GenWithNode(p, block);
end;

function AsmStatement:pTree;

var
    p: pTree;
    s:string;
    str, start    : stringlist;
    old: vartype;
    matchtoken: boolean;
    i, code:integer;
    hexnum:longint;
    asmtype: asmop;
begin
  Match(_asm);
  if current_token<>_end then
  begin
    CreateStringList(start);
    str:=start;
    while (current_token <> _end) do
    begin
      str^.next := NIL;
      if DirectAsm=TRUE then
        begin
          s:=current_string;
          repeat
            s:=s+look;
            GetChar;
          until look=#13;
          GetChar;
          if look=#10 then GetChar;
          GetToken;
        end
      else
        begin
          asmtype:=GetAsmType(current_string);
          if (asmtype<>_opcode) and (asmtype<>_prefix) and
             (current_token <>_at) then
            Expected('Opcode or label');

          if current_token<>_at then
            begin
              s:=current_string;
              Match(current_token);
            end
          else s:=' '; {dummy}
          if current_token<>_end then
            repeat
              if current_token = _separator then begin Match(_separator); break; end;
                case GetAsmType(current_string) of
               _opcode: begin
                          break;
                          Match(current_token);
                        end;
               _reg   : begin
                          s:=s+' '+current_string;
                          Match(current_token);
                        end;
               _prefix: begin
                          s:=s+' '+current_string;
                          Match(current_token);
                        end;
               _unknown:begin
                          matchtoken:=true;
                          case current_token of
                          _mul      : s:=s+'*';
                          _plus     : s:=s+'+';
                          _minus    : s:=s+'-';
                          _div      : s:=s+' div ';
                          _lparen   : s:=s+'(';
                          _rparen   : s:=s+')';
                          _lbracket : s:=s+'[';
                          _rbracket : s:=s+']';
                          _colon    : s:=s+':';
                          _comma    : s:=s+',';
                          _at       : begin
                                        Match(_at);
                                        s:=s+' @'+ProcName+'$'+current_string;
                                      end;
                          _char_constant: s:=s+' '''+current_string+'''';
                          _real_constant: s:=s+' '+current_string;
                          _integer_constant: begin
                                               i:=1;
                                               matchtoken:=FALSE;
                                               current_number:=GetNumber;
                                               s:=s+' '+Numb(current_number);
                                             end;
                          else begin
                                 matchtoken:=false;
                                 if current_token=_end then break;
                                 {should be an expression}
                                 p:=Factor;
                                 OptimizeTree(p);
                                 if (p^.sym^.symbol=_variable) or
                                    (p^.sym^.symbol=_func) or
                                    (p^.sym^.symbol=_proc) then
                                   begin
                                     old:=p^.sym^.vartype; {store vartyp}
                                     {hack to prevend loading of address of var-variable}
                                     if (p^.sym^.vartype=_ParmVar) or (p^.sym^.vartype=_ParmConst) then
                                       p^.sym^.vartype:=_ParmValue;
                                     InitRegisters; {reset registers}
                                     GenerateCode(p);
                                     if p^.sym^.symbol=_variable then
                                       p^.sym^.vartype:=old; {restore vartype}
                                     if p^.op=__call then
                                       s:=s+' '+p^.sym^.overloadedname
                                     else
                                       s:=s+' '+ CreateNameForAsm(p^.loc);
                                   end
                                 else
                                   if p^.sym^.symbol=_constant then
                                     begin
                                       case p^.sym^.c of
                                       _IntegerConst,
                                       _OrdinalConst  : s:=s+' '+Numb(p^.sym^.n);
                                       _CharConst     : s:=s+' '+p^.sym^.x;
                                       else             begin
                                                          InitRegisters; {reset registers}
                                                          GenerateCode(p);
                                                          s:=s+' '+ CreateNameForAsm(p^.loc);
                                                        end;
                                       end;

                                     end;
                                 DestroyTree(p);
                               end;
                          end;
                          if matchtoken then Match(current_token);
                        end;
               end;
            until (GetAsmType(current_string)=_opcode) or (current_token=_end) or (current_token=_at);
          end;
          str^.name := getmemstring(s);
          if (Current_Token = _end) then
            break
          else
            NewStringListEntry(str);
          if current_token = _end then break;
        end;
  end
    else start:=NIL;
  Match(_End);
  AsmStatement:=GenAsmNode(start);
end;

function Block_Statement:pTree;

var p1,p2:pTree;

begin
  p1:=nil;
  Match(_begin);
  while (current_token <> _end) do
    begin
      if p1=NIL then
        begin
          p2:=GenExpNode(__statement, NIL, statement);
          p1:=p2;
        end
      else
        begin
          p2^.left:=GenExpNode(__statement, NIL, statement);
          p2:=p2^.left;
        end;
      if current_token = _end then break;
      if current_token = _separator then Match(_separator)
   end;
   Match (_End);
   p1:=GenLeftNode(__block, p1);
   Block_Statement:=p1;
end;

procedure DoUnit;

var unitname: string;
    p,p1: pointer;
    sym: pSymbolRecord;
    time: longint;
    lines:longint;
    s, u: text;
    io:integer;

begin
  Match(_uses);
  repeat
    unitname:=upcase_string;
    Match(_name);
    assign(u, unitname +'.P32'); {add unit extension}
    {$I-} reset(u); {$I+}
    io:=ioresult;
    assign(s, unitname +'.PAS');
    {$I-} reset(s); {$I+}
    if ioresult <> 0 then Error(unitname +'.PAS not found');
    if (Recompile(s, u)=FALSE) and
       (CompileSystemUnit=FALSE) and
       (io=0) then
      begin
        close(s);
        close(u); {close it because loadunit reopens the file)}
        LoadUnit(unitname);
      end
     else
       begin
         close(s);
         compile(unitname);
       end;
    if current_token=_comma then Match(_comma)
                            else break;
  until false;
  Match(_separator);
end;

function GetStringType: pTypeRecord;

var p: pTree;
    typ : pTypeRecord;
    n: longint;

begin
  Match(_string);
  n:=255;
  if current_token = _lbracket then
  begin
    Match(_lbracket);
    p:=Expression;
    OptimizeTree(p);
    if (p^.op<>__OrdConst)    then Expected('ordinal constant');
    if (p^.n<1) or (p^.n>255) then LineError(LineCount, 'string too long');
    n:=p^.n;
    DestroyTree(p);
    Match(_rbracket);
  end;
  typ:=NewType;{create entry for string}
  typ^.TypeDef:= _StringDef;
  typ^.length := n;
  GetStringType:=typ;
end;



procedure DoRecordField(var rectyp:pTypeRecord; recordoffset:longint);

var
   start, str   : stringlist;
   variantstart,
   variantsize  : longint;
   typ          : pTypeRecord;
   sym          : pSymbolRecord;
   typename     : string;
   p1           : pTree;

begin
  while current_token=_name do
    begin
      str:=GetStringList;
      start:=str;
      Match(_colon);
      typ:=GetTypeDef('');
      repeat
        sym:=NewSymbol;
        sym^.name:=Str^.name^;
        sym^.symbol:=_variable;
        sym^.typedef:=typ;
        sym^.offset:=recordoffset;
        sym^.vartype:=vt;
        sym^.typedconst:=FALSE;
        sym^.dumped:=FALSE;
        AddSymbol(rectyp^.recordtable, sym);
        dec(symbolcount); {global symbolcounter...}
        inc(recordoffset, GetSize(sym^.typedef));
        str:=str^.next;
      until str=NIL;
      DestroyStringList(start);
      if current_token=_separator then Match(_separator)
                                  else break;
  end;
  rectyp^.recordsize:=recordoffset;
  if current_token=_case then {variant record}
    begin
      Match(_case);
      variantsize:=0;
      typename:='_'+upcase_string;
      sym:=GetPointer(GlobalTable, typename);
      if (sym<>NIL) or (sym^.symbol=_type) then
        begin
          if (sym^.typedef^.typedef<>_EnumeratedDef) and
             (sym^.typedef^.typedef<>_SubRangeDef) then
            LineError(LineCount,'Ordinal type expected');
          Match(_name);
        end
      else
        begin
          if current_token<>_name then LineError(LineCount,'Identifier expected');
          Match(_name);
          Match(_colon);
          sym^.typedef:=GetTypeDef('');
        end;
      Match(_of);
      variantstart:=rectyp^.recordsize;
      repeat
        repeat
          p1:=expression;
          OptimizeTree(p1);
          if (p1^.op<>__ordconst) and (p1^.op<>__charconst) then
            LineError(LineCount,'Ordinal constant expected');
            if current_token=_comma then Match(_comma)
                                    else break;
        until false;
        Match(_colon);
        Match(_lparen);
        if current_token<>_rparen then DoRecordField(rectyp, variantstart);
        if variantsize<rectyp^.recordsize then variantsize:=rectyp^.recordsize;
        rectyp^.recordsize:=variantstart;
        Match(_rparen);
        if current_token=_separator then Match(_separator)
                                    else break
      until (current_token=_end) or (current_token=_rparen);
      rectyp^.recordsize:=variantsize;
     end;
end;

function GetTypeDef(const name : string):pTypeRecord;

label constfound;

var
   p1         : pTree;
   n, n1,n2   : longint;
   d1,d2      : double;
   start, typ : pTypeRecord;
   sym        : pSymbolRecord;

begin
  case current_token of
  _name       : begin {previously defined type}
                  sym:=Getpointer(GlobalTable, '_'+upcase_string);
                  if sym^.symbol=_constant then
                    goto constfound {some stupid hack, to recognize constants}
                  else
                    if sym^.symbol<>_type then Expected('type');
                  Match(_name);
                  typ:=sym^.typedef;
                end;
  _lparen     : begin {enumerated type}
                  Match(_lparen);
                  typ:=NewType;
                  typ^.TypeDef:=_EnumeratedDef;
                  start:=typ;
                  n:=0;
                  repeat
                    {typ^.name   := GetName;}
                    typ^.number := n;
                    sym:=NewSymbol; {add symbols as constants}
                    sym^.name   := GetName{typ^.name};
                    sym^.symbol := _Constant;
                    sym^.c      := _IntegerConst;
                    sym^.n      := n;
                    sym^._public:=makesymbolspublic;
                    AddSymbol(GlobalTable,sym);
                    if current_token<>_rparen then Match(_comma)
                                              else break; {stop reading constants}
                    inc(n);
                    typ^.definition:=NewType;
                    typ:=typ^.definition;
                  until false; {endless loop}
                  Match(_rparen);
                  typ:=start;
                 end;
  _string     : begin {string type}
                  typ:=GetStringType;
                end;
  _array      : begin {array type, multidimensional}
                  Match(_array);
                  Match(_lbracket);
                  typ:=NewType;
                  typ^.TypeDef := _ArrayDef;
                  start:=typ;
                  repeat
                    typ^.range:=GetTypeDef('');
                    if not IsOrdinal(typ^.range) then Expected('ordinal type');
                    if current_token=_comma then Match(_comma)
                                            else break;
                    typ^.definition:=NewType;
                    typ:=typ^.definition;
                    typ^.typedef:=_ArrayDef;
                  until false; {endless loop}
                  Match(_rbracket);
                  Match(_of);
                  typ^.definition:=GetTypeDef('');
                  typ:=start;
                end;
  _file       : begin
                  Match(_file);
                  typ:=NewType;
                  typ^.TypeDef := _FileDef;
                  if current_token=_of then
                    begin
                      Match(_of);
                      typ^.filetyperec:=NewType;
                      typ^.filetyperec:=GetTypeDef('');
                      typ^.filetyp:=_typed;
                    end
                  else
                    typ^.filetyp:=_untyped;
                end;
  _ptr        : begin
                  Match(_ptr);
                  typ:=NewType;
                  typ^.typedef:=_PointerDef;
                  typ^.PointerTo:=NewSymbol;
                  sym:=Getpointer(GlobalTable, '_'+upcase_string);
                  if (sym=NIL) then
                    begin
                      sym:=NewSymbol;
                      sym^.name:=GetName;
                      sym^.symbol:=_type;
                      sym^.vartype:=vt;
                      sym^.typedef:=NIL;
                      sym^.forwardtype:=TRUE;
                      AddSymbol(GlobalTable, sym);
                      typ^.PointerTo:=sym;
                    end
                  else
                    begin
                      Match(_name); {eat the identifier}
                      typ^.PointerTo:=sym;
                    end;
                end;
  _set        : begin
                  Match(_set);
                  Match(_of);
                  typ:=NewType;
                  typ^.typedef:=_SetDef;
                  typ^.SetOf:=GetTypeDef('');
                  case typ^.setof^.typedef of
                  _BooleanDef   : ;
                  _EnumeratedDef: ;
                  _SubRangeDef  : begin
                                    n1:=typ^.setof^.LowerLimit;
                                    n2:=typ^.setof^.UpperLimit;
                                    if (n1 >= 0) and (n2 <= 255) then
                                      typ^.setsize:=1+(n2-n1) div 8
                                    else
                                      LineError(LineCount, 'Set base type out of range');
                                  end;
                  end;
                end;
  _record     : begin
                  typ:=NewType;
                  typ^.typedef:=_RecordDef;
                  CreateSymbolList(typ^.recordtable);
                  Match(_record);
                  DoRecordField(typ, 0);
                  if GetSize(typ)=0 then LineError(LineCount, 'Empty records not allowed');
                  Match(_end);
                end;
  _procedure  : begin
                  Match(_procedure);
                end;
  _function   : begin
                  Match(_function);
                end;
  else          begin {subrange type}
constfound:
                  p1:=Expression;
                  OptimizeTree(p1);
                  if (p1^.op=__subrange) then
                  begin
                    typ:=NewType;
                    typ^.typedef:=_SubRangeDef;
                    typ^.LowerLimit:=p1^.left^.n;
                    typ^.UpperLimit:=p1^.right^.n;
                    n1:=typ^.LowerLimit;
                    n2:=typ^.UpperLimit;
                    if n1>n2 then LineError(LineCount, 'Lower bound greater than upper bound');
                    if (p1^.left^.op=__charconst) and (p1^.right^.op=__charconst) then
                      begin
                        typ^.SubRangeTyp:=uchar;
                        typ^.LowerLimit:=ord(p1^.left^.c);
                        typ^.UpperLimit:=ord(p1^.right^.c);
                      end
                    else
                      begin
                        if (n1>=0) and (n2<=255) then
                          typ^.SubRangeTyp:=u8bit
                        else
                          if (n1>=-128) and (n2<=127) then
                            typ^.SubRangeTyp:=s8bit
                          else
                            if (n1>=0) and (n2<=65535) then
                              typ^.SubRangeTyp:=u16bit
                            else
                              if (n1>=-32768) and (n2<=32767) then
                                typ^.SubRangeTyp:=s16bit
                              else
                                if (n1>=0) and (n2<=$FFFFFFFF) then
                                  typ^.SubRangeTyp:=u32bit
                                else
                                  typ^.SubRangeTyp:=s32bit;
                      end;
                  end;
                  if (p1^.op=__float) then
                    begin
                      typ:=NewType;
                      typ^.typedef:=_RealDef;
                      typ^.FPU_LowerLimit:=p1^.left^.d;
                      typ^.FPU_UpperLimit:=p1^.right^.d;
                      d1:=typ^.FPU_LowerLimit;
                      d2:=typ^.FPU_UpperLimit;
                      typ^.FPU_RealType:=f64bit;   {We only have this FPU register}
                    end;
                    if ((p1^.op<>__float) and (p1^.op<>__subrange)) then
                       LineError(LineCount, 'Error in expression');
                    {DestroyTree(p1);}
                end;

  end;
  GetTypeDef:=typ;
end;

procedure Type_Declaration;

var
   name : string;
   fsym,
   sym  : pSymbolRecord;
   typ  : pTypeRecord;

begin
   Match(_type_);
   repeat
     name:=GetName;
     Match(_equal);
     sym:=NewSymbol;
     sym^.name   := name;
     sym^._public:=makesymbolspublic;
     sym^.symbol := _type;
     sym^.typedef:= GetTypeDef(name);
     fsym:=GetPointer(GlobalTable, sym^.name);
     if (fsym<>NIL) and (fsym^.forwardtype=TRUE) then
       begin {it's a forward type... let's update the typedef}
         fsym^.typedef:=sym^.typedef;
         fsym^.forwardtype:=FALSE;
         dispose(sym); {destroy the found symbol}
       end
     else
       AddSymbol(GlobalTable, sym);
     Match(_separator);
   until current_token <> _name;

   fsym:=GlobalTable.first;
   repeat
     if (fsym^.symbol=_type) then
       if fsym^.forwardtype=TRUE then LineError(LineCount, 'Undefined type in pointer definition ('+fsym^.name+')');
     fsym:=fsym^.next
   until fsym=NIL;
end;


procedure Var_Declaration;

var
   start, pStr      : stringlist;
   sym       : pSymbolRecord;
   typ       : pTypeRecord;
   size, a   : longint;
   abswhere      : longint;
   absolute_var  : pSymbolRecord;                     { db 14/1/98 }
   absolute_type : (none, mem_constant, var_overlay); { db 14/1/98 }
   p1            : pTree;                             { db 14/1/98 }
   s:string;

begin
  Match(_var);
  repeat
    pStr:=GetStringList;
    start:=pStr;
    Match(_colon);
    typ:=GetTypeDef('');
    {handle absolute keyword}
    absolute_type := none;
    if current_token = _absolute then
      begin
        Match(_Absolute); { gobble token... now handle expression or var reference }
        case current_token of { syntax checking }
        _name             : begin
                              absolute_type := var_overlay; {used for later reference}
                              absolute_var := GetPointer(GlobalTable, ProcName+GetName);
                              {get identifier symbol entry}
                              if absolute_var = NIL then
                                LineError(LineCount, 'Unknown identifier referenced');
                            end;
        _integer_constant : begin
                              absolute_type := mem_constant;
                              p1:=Expression; { This proc must gobble _ordconst token!! }
                              OptimizeTree(p1);
                              if p1^.op = __OrdConst then
                                abswhere := p1^.n {the memory address}
                              else
                                LineError(LineCount, 'Integer constant expected');
                              DestroyTree(p1);
                            end;
        else                LineError(LineCount, 'Variable or memory address expected');
        end;
      end;
    repeat
      sym:=NewSymbol;
      sym^.name:=pStr^.name^;
      sym^._public:=makesymbolspublic;
      sym^.symbol:=_variable;
      sym^.typedef:=typ;
      sym^.vlevel := LexLevel;
      sym^.vartype:=vt;
      sym^.alias  := NIL;
      sym^.absreference := FALSE;
      sym^.typedconst:=FALSE;
      size:=GetSize(sym^.typedef);
      {alignment}
      if absolute_type = none then {do not align absolute variables}
        begin
          a:=size and (aligndata-1);
          if a<>0 then
            inc(stacksize, aligndata-a + size)
          else
            inc(stacksize, size);
        end;
      sym^.offset:=stacksize;
      case absolute_type of
      var_overlay : begin { Copy address info only... types may vary ;) }
                      sym^.vlevel := absolute_var^.vlevel;
                      sym^.offset := absolute_var^.offset;
                      sym^.dumped := TRUE;    { don't dump it if global }
                      sym^.alias  := absolute_var; { Set alias variable }
                    end;
      mem_constant: begin
                      sym^.offset       := abswhere; { get machine address }
                      sym^.absreference := TRUE;     { Set as absolute reference }
                    end;
      end;
      AddSymbol(GlobalTable, sym);
      pStr:=pStr^.next;
    until pStr=NIL;
    Match(_separator);
  until current_token<>_name;
  DestroyStringList(start);
end;

procedure Label_Declaration;   {LB Labels}

var
   start, pStr      : stringlist;
   sym       : pSymbolRecord;
   typ       : pTypeRecord;
   size, a   : longint;

begin
  Match(_label_);
  repeat
    pStr:=GetLabelList;
    start:=pStr;
    repeat
      sym:=NewSymbol;
      sym^.name:=ProcName+pStr^.name^;
      sym^._public:=makesymbolspublic;
      sym^.symbol:=_label;
      AddSymbol(GlobalTable, sym);
      pStr:=pStr^.next;
    until pStr=NIL;
    Match(_separator);
  until not MaybeLabel(current_token);
  DestroyStringList(start);
end;

procedure TypedConst_Declaration(var typ:pTypeRecord; s:string);

var
   p1   : ptree;
   i    : longint;
   sym  : pSymbolRecord;
   con  : pConstantRecord;

begin
  case typ^.typedef of
  _SubRangeDef  : begin
                    p1:=expression;
                    OptimizeTree(p1);
                    new(con);
                    con^.c:=_IntegerConst;
                    con^.size:=GetSize(typ);
                    con^.n:=p1^.n;
                    con^.id := getmemstring(s);
                    con^.dumped:=FALSE;
                    AddConstant(ConstantTable, con, FALSE); {add name to list of constants}
                    DestroyTree(p1);
                  end;
  _EnumeratedDef: begin
                    p1:=expression;
                    OptimizeTree(p1);
                    LineError(p1^.line, 'enumerated constants not supported yet');
                    DestroyTree(p1);
                  end;
  _StringDef    : begin
                    p1:=expression;
                    OptimizeTree(p1);
                    new(con);
                    con^.c:=_StringConst;
                    con^.size:=typ^.length{p1^.length};
                    con^.s:=getmemstring(p1^.s^);
                    con^.id := getmemstring(s);
                    con^.dumped:=FALSE;
                    AddConstant(ConstantTable, con, FALSE); {add name to list of constants}
                    DestroyTree(p1);
                  end;
  _ArrayDef     : begin
                    Match(_lparen);
                    for i:=typ^.range^.lowerlimit to typ^.range^.upperlimit-1 do
                       begin
                         TypedConst_Declaration(typ^.definition, s);
                         Match(_comma);
                       end;
                    TypedConst_Declaration(typ^.definition, s); {read the last one also}
                    Match(_rparen);
                  end;
  _RecordDef    : begin
                    Match(_lparen);
                    while current_token<>_rparen do
                      begin
                        s:=GetName;
                        Match(_colon);
                        sym:=GetPointer(typ^.RecordTable, s);
                        if sym=nil then LineError(LineCount, 'Record field not found');

                        if current_token=_separator then Match(_separator)
                                                    else break;
                      end;
                    Match(_rparen);
                  end;
  else            LineError(LineCount, 'Invalid typed constant');
         end;
      end;

procedure Const_Declaration;

label again;

var
   old, p1   : pTree;
   name : string;
   typ  : pTypeRecord;
   sym  : pSymbolRecord;
   table: SymbolList;
   i:integer;

begin
  Match(_const);
  repeat
    name:=GetName;
    sym:=NewSymbol;
    sym^.name := name;
    sym^._public:=makesymbolspublic;
    sym^.vartype:= vt;
    case current_token of
    _equal      : begin
                    sym^.symbol:= _constant;
                    sym^.consttyp:=NIL; {by default constants don't have a type definition}
                    Match(_equal);
                    p1:=Expression;
                    OptimizeTree(p1);
AGAIN:
                    case p1^.op of
                    __OrdConst   : begin {Ordinal constant: 4}
                                     sym^.n:=p1^.n;
                                     sym^.c:=_OrdinalConst;
                                     AddSymbol(GlobalTable,sym);
                                   end;
                    __StringConst: begin {String constants: 'test'}
                                     sym^.s:=p1^.s^;
                                     sym^.c:=_StringConst;
                                     AddSymbol(GlobalTable,sym);
                                   end;
                    __CharConst :  begin
                                     sym^.n:=p1^.n;
                                     sym^.c:=_OrdinalConst;
                                     AddSymbol(GlobalTable,sym);
                                   end;
                    __RealConst  : begin {Real constants: 3.0E10}
                                     sym^.d:=p1^.d;
                                     sym^.c:=_RealConst;
                                     AddSymbol(GlobalTable,sym);
                                   end;
                    __Type       : begin
                                     sym^.consttyp:=p1^.convtype;
                                     old:=p1;
                                     {final typecast determines type of constant}
                                     while p1^.op=__type do
                                       p1:=p1^.left;
                                     goto AGAIN;
                                   end;
                    else LineError(LineCount, 'Error in expression');
                    end;
{Maybe!!!}          DestroyTree(p1);
                    Match(_separator);
                  end;
    _colon      : begin
                    sym^.symbol := _Variable;
                    sym^.vlevel := LexLevel;
                    sym^.vartype:= vt;
                    sym^.absreference := FALSE;
                    sym^.alias        := NIL;
                    Match(_colon);
                    typ:=GetTypeDef('');
                    Match(_equal);

                    CreateSymbolList(table);
                    TypedConst_Declaration(typ, sym^.name);
                    sym^.typedef:=typ;
                    sym^.typedconst:=TRUE;
                    sym^.dumped:=FALSE;
                    AddSymbol(GlobalTable, sym);
                    Match(_separator);
                  end;
    else Match(_equal);
    end;
  until current_token <> _name;
end;

function DoParameterList(var sym:pSymbolRecord):longint;
{ processes parameters of procedure when it's declared }

var
   global, parm   : pSymbolRecord;
   typ            : pTypeRecord;
   ParmOffset     : longint;
   v              : VarType;
   start, pStr           : stringlist;
   typename,
   overloadedname : string;

begin
  overloadedname:=sym^.name+'$';
  CreateSymbolList(sym^.parameter);
  Match (_lparen);
  ParmOffset:=8; {4 bytes for stackframe and 4 bytes to save EBP}
  if LexLevel >= 2 then {DB} { if procedure is nested then... }
    inc(ParmOffset, 4); {DB} { allow for lexical parent link above return addr }
  {DB: Note: the lexical parent link is an implicit parameter to nested
  procedures, and thus will be popped with other parameters. }
  repeat
    case current_token of
    _var     : begin
                 Match(_var);
                 v:=_ParmVar;
               end;
    _const   : begin
                 Match(_const);
                 v:=_ParmConst;
               end;
    else
        v:=_ParmValue;
    end;
    pStr:=GetStringList;
    start:=pStr;
    if current_token=_colon then
      begin
        Match(_colon);
        typename:='$'+upcase_string;
        typ:=GetTypeDef('');
      end
    else
      begin
        if OpenParameters=TRUE then
          begin
            typ:=NewType;
            typename:='$';
            typ^.typedef:=_EmptyDef;
          end
        else
          Expected('type definition');
      end;

      repeat
        parm:=NewSymbol;
        parm^.name   := pStr^.name^;
        parm^.symbol := _variable;
        parm^.vlevel := LexLevel;
        parm^.vartype:= v;
        parm^.absreference := FALSE;
        parm^.alias        := NIL;
        parm^.offset := ParmOffset;
        parm^.typedef:= typ;
        parm^.typedconst:=FALSE;
        parm^._public:=makesymbolspublic;
        AddSymbol(sym^.parameter, parm); {for later use to define check correct calling}

        dec(SymbolCount);

        global:=NewSymbol;
        global^:=parm^;
        AddSymbol(GlobalTable, global); {for local use (in this procedure only)}

        if (v=_ParmVar) or (v=_ParmConst) then
          ParmOffset := ParmOffset+4  {pointer (offset) is always 4}
        else
          begin
            if (global^.typedef^.typedef=_SubRangeDef) and (GetSize(global^.typedef)<4) then
              ParmOffset := ParmOffset+4
            else
              ParmOffset := ParmOffset+GetSize(parm^.typedef);
          end;
        pStr:=pStr^.next;
        overloadedname:=overloadedname+typename;
      until pStr=NIL;
    DestroyStringList(start); {strings aren't needed anymore}
    {read declaration until we've _not_ found a ';'}
    if current_token=_separator then Match(_separator)
                                else break;
  until false;
  Match(_rparen);
  DoParameterList:=ParmOffset-8; {total size of parameters, needed for return}
  sym^.overloadedname:=overloadedname;
end;

function DoProcedure(parseheader:boolean): pTree;

var
   NormalCaseName,
   Delname, OldName        :string;
   OldSymbolTable   : pSymbolRecord;
   LocalSize      : longint; {Size of local variables}
   ParamSize      : longint; {Size of parameters}
   NoStack        : boolean; {true when stack isn't needed}
   del, search, sym    : pSymbolRecord;
   typ:pTypeRecord;
   p1, block      : pTree;   {Parse tree}
   old_vt         : vartype;
   localsym: longint;
   startmem: longint;
   ttt: pointer;
begin
  inc(LexLevel);
  startmem:=maxavail;
  old_vt:=vt;
  sym:=NewSymbol;
  sym^._public:= makesymbolspublic;
  sym^.plevel := LexLevel;
  sym^.dumped := FALSE;
  stacksize:=0;
  case current_token of
  _function : begin
                Match(_function);
                OldName  := ProcName;
                NormalCaseName:=current_string; {this contains thee procname as read by the scanner}
                ProcName := ProcName + GetName;
                sym^.name:= ProcName;
                sym^.symbol:=_Func;
                if current_token=_lparen then
                  sym^.ParamSize:=DoParameterList(sym)
                else
                  begin
                    sym^.ParamSize:=0;
                    if LexLevel >= 2 then
                      inc(sym^.ParamSize, 4);
                    sym^.parameter.first:=NIL;
                    sym^.parameter.rear:=NIL;
                    sym^.overloadedname:=ProcName+'$';
                  end;
                Match(_colon);
                sym^.ReturnType:=GetTypeDef('');
                if sym^.returntype^.typedef=_StringDef then
                  inc(sym^.ParamSize, 4) {reserve dword for pointer to return space}
                else
                  sym^.LocalSize:=GetSize(sym^.ReturnType);
              end;
  _procedure: begin
                Match(_procedure);
                OldName  := ProcName;           {save old name}
                NormalCaseName:=current_string; {this contains thee procname as read by the scanner}
                ProcName := ProcName + GetName; {compose new name}
                sym^.name:= ProcName;
                sym^.symbol:=_Proc;
                if current_token=_lparen then sym^.ParamSize:=DoParameterList(sym)
                                         else begin
                                                sym^.ParamSize:=0;
                                                if LexLevel >= 2 then
                                                  inc(sym^.ParamSize, 4);
                                                sym^.parameter.first:=NIL;
                                                sym^.parameter.rear:=NIL;
                                                sym^.overloadedname:=ProcName+'$';
                                              end;
                sym^.ReturnType:=NIL; {no returntype}
                sym^.LocalSize:=0;
              end;
  end;
  {$IFDEF debug}
  writeln('Proc: ', procname, '...');
  {$ENDIF}
  Match(_separator);

  {let's see if there is already a procedure/function with the same name, if YES
   then we need to overload it}

  search:=GetPointer(GlobalTable, ProcName);
  if search=NIL then begin
                       sym^.nextoverloaded:=NIL;
                       AddSymbol(GlobalTable, sym)
                     end
  else {already one with the same name}
    case search^.symbol of
    _Proc, _Func  : begin
                      while (search^.overloadedname<>sym^.overloadedname) and
                            (search^.nextoverloaded<>NIL) do
                       search:=search^.nextoverloaded;
                      if search^.overloadedname=sym^.overloadedname then
                        begin
                          DestroySymbolList(sym^.parameter); {remove parameters of the read parameters}
                          sym:=search; {update sym-record to forward declarated one}
                          sym^.dumped:=FALSE;
                        end
                      else
                        begin
                          search^.nextoverloaded:=sym;
                          sym^.nextoverloaded:=NIL;
                        end;
             end;
    else     LineError(LineCount, 'Duplicate identifier');
    end;

  sym^._forward:=parseheader;
  sym^._extern:=FALSE;
  sym^._inline:=FALSE;
  sym^._underscore:=FALSE;
  sym^._system:=FALSE;
  sym^._register:=FALSE;
  sym^._assembler:=FALSE;

  localsym:=symbolcount;

  if sym^._forward=FALSE then
  begin
    case current_token of
    _far, _near,
    _interrupt    : begin
                      Match(_far);
                      Match(_separator);
                      LineError(LineCount, current_string+' ignored');
                    end;
    _inline,
    _register,
    _assembler    : begin
                      case current_token of
                      _assembler : begin
                                     Match(_assembler);
                                     sym^._assembler:=TRUE;
                                   end;
                      _register  : begin
                                     Match(_register);
                                     sym^._register:=TRUE;
                                   end;
                      _inline    : begin
                                     Match(_inline);
                                     sym^._register:=TRUE;
                                     sym^._inline:=TRUE;
                                   end;
                      end;
                      Match(_separator);
                      if current_token=_string_constant then
                        begin
                          {sym^.overloadedname:=upcase_string;}
                          sym^.overloadedname:=current_string;
                          Match(_string_constant);
                          Match(_separator);
                          {sym^._public:=TRUE; {used internally, so make it public}
                        end;
                      inc(sym^.LocalSize, stacksize);
                      block:=AsmStatement;
                      typ:=sym^.returntype;
                      sym^.returntype:=NIL;
                      if sym^._inline=TRUE then
                        begin
                          GenerateInlineProc(sym, block);
                          sym^.inlinetree:=block;
                        end
                      else
                        GenCodeProc(sym, block);
                      sym^.returntype:=typ;
                      DestroyTree(block);
                      Match(_separator);
                     end;
    _external     : begin
                      Match(_external);
                      Match(_separator);
                      sym^._underscore:=TRUE;
                      sym^._extern:=TRUE;
                      if current_token=_string_constant then
                        begin
                          sym^._underscore:=FALSE;
                          sym^.overloadedname:=current_string;
                          Match(_string_constant);
                          Match(_separator);
                        end;
                    end;
    _win32api     : begin
                      Match(_win32api);
                      Match(_separator);
                      sym^._extern:=TRUE;
                      sym^.overloadedname:='_'+NormalCaseName+'@'+Numb(sym^.paramsize);
                    end;
    else            begin
                      if current_token=_system then
                        begin
                          Match(_system);
                          Match(_separator);
                          sym^._underscore:=TRUE;
                        end;
                      if current_token=_string_constant then
                        begin
                          sym^.overloadedname:={upcase_string}current_string;
                          Match(_string_constant);
                          Match(_separator);
                        end;
                      vt:=_Local;                {all new symbols will be local}
                      block:=main;               {parse procedure}
                      inc(sym^.LocalSize, stacksize);
                      OptimizeTree(block);       {optimize}
                      GenCodeProc(sym, block);  {generate code}
                      DestroyTree(block);
                      {GenLeftNode(__proc, block);{not used at the moment}
                      Match(_separator);         { ; }
                    end;
    end;
    {delete local symbols}
    while localsym<>symbolcount do
      RemoveLastSymbol(GlobalTable);
  end
  else
   begin
     sym^._public:= TRUE;
     sym^.dumped:=TRUE;
   end;

  {remove the parameters from the global symboltable}

  search:=sym^.parameter.first;
  del:=GetPointer(GlobalTable, search^.name);
  while (del<>NIL) do
   begin
     DeleteSymbol(GlobalTable, del);
     search:=search^.next;
     if search<>NIL then del:=GetPointer(GlobalTable, search^.name)
                    else del:=NIL;
   end;

  {$IFDEF debug}
  write('memory used: ', startmem - maxavail, ' byte, left: ',maxavail,' bytes');
  if sym^._forward then writeln(' -> FORWARD')
                   else writeln;
  writeln;
  {$ENDIF}
  ProcName := OldName;
  dec(LexLevel);
  vt:=old_vt;
end;

function Statement : pTree;

label labeldone;

var p1, p2: pTree;

    sym : pSymbolRecord; {LB}

begin
  case current_token of
  _begin    : p1:=block_statement;
  _if       : p1:=if_statement;
  _case     : p1:=case_statement;
  _repeat   : p1:=repeat_statement;
  _while    : p1:=while_statement;
  _for      : p1:=for_statement;
  _asm      : p1:=asmstatement;
  _break    : p1:=break_statement;
  _continue : p1:=continue_statement;
  _exit     : p1:=exit_statement;
  _goto     : p1:=goto_statement;
  _with     : p1:=with_statement;
  _separator: ;
  else        begin
                if MaybeLabel(current_token) then
                  begin   {check for label}
                    if ProcName<>'' then
                      sym := GetPointer(GlobalTable, ProcName+'_'+upcase_string)
                    else
                      sym:=GetPointer(GlobalTable, '_'+upcase_string);
                    if sym<>NIL then
                      begin
                        if sym^.symbol=_label then
                          begin
                            Match(current_token);
                            Match(_colon);
                            if sym^.dumped = true then
                              LineError(LineCount, 'Label already defined');
                            p1 := GenlabelNode(GlobalTable, sym);
                            sym^.dumped := TRUE;
                            goto labeldone; {skip the expression routine}
                         end;
                    end;
                  end;
                  p2:=Expression;
                  p1:=p2; {returned from expression}
               end;
         end;
labeldone:
  statement:=p1;
end;

function Main: pTree;

begin
  if current_token=_uses then DoUnit;
  repeat
    case current_token of
    _const     : Const_Declaration;
    _var       :   Var_Declaration;
    _type_     :  Type_Declaration;
    _label_    : Label_Declaration;
    _procedure,
    _function  : DoProcedure(FALSE);
    else         break;
    end;
  until false;

  main:=block_statement;
end;

function ParseUnit:pTree;

var
    unitname : string;
    p        : pTree;
    sym      : pSymbolRecord;
    localsym : longint;

begin
  unitname:=upcase_string;
  Match(_name);
  Match(_separator);
  Match(_interface);
  makesymbolspublic:=TRUE;

  sym:=NewSymbol;
  sym^.name:=unitname;
  sym^.symbol:=_unit;
  AddSymbol(GlobalTable, sym);

  if current_token=_uses then DoUnit;

  repeat
    case current_token of
    _const     : Const_Declaration;
    _var       :   Var_Declaration;
    _type_     :  Type_Declaration;
    _label_    : Label_Declaration;
    _procedure,
    _function  : DoProcedure(TRUE);
    else         break;
    end;
  until false;

  makesymbolspublic:=FALSE;
  Match(_implementation);

  if current_token=_uses then DoUnit;

  localsym:=SymbolCount;

  parseunit:=main;

  {remove the local symbols}

  {***********************************************************}
  { code is correct but symbols are not dumped to the .asm so }
  { leave them global for the moment                          }
  {***********************************************************}

  {while localsym < symbolcount do
    RemoveLastSymbol(GlobalTable);}

  {***********************************************************}

  SaveUnit(unitname, sym);
end;

procedure DoProgram;
var
   tmp : string;
   lib : text;
   name, buf : string;
   done: boolean;
   sym : symbolrecord;

    p   : pTree;

begin
  makesymbolspublic:=FALSE;
  LexLevel := 0;
  vt:=_Global;
  case Current_Token of
  _program: begin
              Match(_Program);
              ProgramName := GetName;
              if current_token=_lparen then
                begin
                  Match(_lparen);
                  Match(_name);
                  repeat
                    Match(_comma);
                    Match(_name);
                    until current_token=_rparen;
                  Match(_rparen);
                end;
              Match(_separator);
              GenerateHeader;
              p:=Main;
              stacksize:=0;
              OptimizeTree(p);
              GenCodeMain(p);
              DestroyTree(p);
            end;
  __unit  : begin
              Match(__unit);
              name:=upcase_string;
              ProgramName:=name; {for correct name in sourcefile}
              GenerateHeader;
              p:=ParseUnit;
              stacksize:=0;
              OptimizeTree(p);
              GenerateCodeUnit(Name, p);
              DestroyTree(p);
            end;
  else      begin
              GenerateHeader;
              p:=Main;
              stacksize:=0;
              OptimizeTree(p);
              GenCodeMain(p);
              DestroyTree(p);
            end;
  end;
end;

procedure go;

begin
   LineCount := 1;
   GetChar;
   GetChar;
   GetToken;
   DoProgram;
end;

procedure Compile(var s:string);

var
   _P  : PathStr;
   _D  : DirStr;
   _N  : NameStr;
   _E  : ExtStr;
   temp_dest,
   temp_source,
   temp_incl: ^text;
   temp_token:token;
   temp_ahead,
   temp_look:char;
   temp_lines:longint;

begin
  {save old properties of the text files}
  temp_source:=@source^;
  temp_dest:=@dest^;
  temp_incl:=@incl^;
  temp_ahead:=ahead;
  temp_look:=look;
  temp_token:=current_token;
  temp_lines:=linecount;
  {get the filename}
  fsplit(s, _D, _N, _E);
  if _E='' then _E:='.PAS';
  s := ToUpper(_D + _N + _E);

  new(source); {create file-pointers}
  new(dest);
  new(incl);

  assign (Source^, s);
  {$I-} reset (Source^); {$I+}
  if ioresult <> 0 then Error(s+' not found');

  assign(Incl^, _N + '.ASI');
  {$I-} rewrite(Incl^); {$I+}
  if ioresult <> 0 then Error('Could not create '+s+'.ASI');

  assign(Dest^, _N + '.ASM');
  {$I-} rewrite(Dest^); {$I+}
  if ioresult <> 0 then Error('Could not create '+s+'.ASM');

  {$IFDEF P32IDE}
  CompileFileMessage(s);
  {$ELSE}
  writeln(s);
  {$ENDIF}
  go; {let's compile it!}

  close(Source^);
  dispose(source);
  source:=NIL;
  close(Dest^);
  dispose(dest);
  dest:=NIL;
  close(Incl^);
  dispose(incl);
  incl:=NIL;

  {restore old properties of the text files}
  dest:=@temp_dest^;
  source:=@temp_source^;
  incl:=@temp_incl^;
  current_token:=temp_token;
  look:=temp_look;
  ahead:=temp_ahead;
  linecount:=temp_lines;
end;

procedure AddDefaultSymbols;

var
    sym : pSymbolRecord;
    dword, typ : pTypeRecord;

begin
   sym:=NewSymbol;
   sym^.name:='_POINTER';       {name}
   sym^.symbol:=_type;          {it's a type}
   sym^._public:=TRUE;
   typ:=NewType;                {typedefinition}
   sym^.typedef:=typ;           {assign it}
   typ^.typedef:=_PointerDef;   {it's a pointer}
   typ^.PointerTo:=NIL;         {points to nothing}
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_BOOLEAN';       {name}
   sym^.symbol:=_type;          {it's a type}
   sym^._public:=TRUE;
   typ:=NewType;                {typedefinition}
   sym^.typedef:=typ;           {assign it}
   typ^.typedef:=_BooleanDef;   {it's a boolean}
   typ^.SubRangeTyp:=u8bit;
   typ^.lowerlimit:= 0;
   typ^.upperlimit:= 1;
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_DWORD';         {name}
   sym^.symbol:=_type;          {it's a type}
   sym^._public:=TRUE;
   typ:=NewType;                {typedefinition}
   sym^.typedef:=typ;           {assign it}
   typ^.typedef:=_SubRangeDef;  {it's a subrange}
   typ^.SubRangeTyp:=u32bit;
   typ^.lowerlimit:= -MaxLongInt - 1;
   typ^.upperlimit:= MaxLongInt;
   dword:=typ; {needed for the other functions}
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_DOUBLE';         {name}
   sym^.symbol:=_type;          {it's a type}
   sym^._public:=TRUE;
   typ:=NewType;                {typedefinition}
   sym^.typedef:=typ;           {assign it}
   typ^.typedef:=_RealDef;  {it's a subrange}
   typ^.SubRangeTyp:=f64bit;
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_TEXT';          {name}
   sym^.symbol:=_type;          {it's a type}
   sym^._public:=TRUE;
   typ:=NewType;                {typedefinition}
   sym^.typedef:=typ;           {assign it}
   typ^.typedef:=_FileDef;      {it's a pointer}
   typ^.filetyp:=_text;         {points to nothing}
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_WRITELN';
   sym^.symbol:=_Proc;
   sym^.internal:=in_writeln;
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_WRITE';
   sym^.symbol:=_Proc;
   sym^.internal:=in_write;
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_READLN';
   sym^.symbol:=_Proc;
   sym^.internal:=in_readln;
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_READ';
   sym^.symbol:=_Proc;
   sym^.internal:=in_read;
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_INC';
   sym^.symbol:=_Proc;
   sym^.internal:=in_inc;
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_DEC';
   sym^.symbol:=_Proc;
   sym^.internal:=in_dec;
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_SUCC';
   sym^.symbol:=_Func;
   sym^.internal:=in_succ;
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_PRED';
   sym^.symbol:=_Func;
   sym^.internal:=in_pred;
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_ORD';
   sym^.symbol:=_Func;
   sym^.internal:=in_ord;
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_CHR';
   sym^.symbol:=_Func;
   sym^.internal:=in_chr;
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_SIZEOF';
   sym^.symbol:=_Func;
   sym^.internal:=in_sizeof;
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_NEW';
   sym^.symbol:=_Proc;
   sym^.internal:=in_new;
   AddSymbol(GlobalTable, sym);

   sym:=NewSymbol;
   sym^.name:='_DISPOSE';
   sym^.symbol:=_Proc;
   sym^.internal:=in_dispose;
   AddSymbol(GlobalTable, sym);
end;


procedure Init;

var p   : pTree;
    s, u   : text;
    io  : longint;
    sysunit : string;
   _P  : PathStr;
   _D  : DirStr;
   _N  : NameStr;
   _E  : ExtStr;

var sym:pSymbolrecord;
begin
   ProcName:='';

   CreateSymbolList(GlobalTable); {contains symbols}
   CreateConstantList(ConstantTable); {contains constants}

   InitTree; {parse tree}

   LineCount   := 1;
   LabelCount  := 0;
   SymbolCount := 0;

   AddDefaultSymbols;
   InitOptimizer;

   {***************** compile system unit ********************}

   {get the system unit path+filename}
   fsplit(config.systemunit, _D, _N, _E);
   sysunit := ToUpper(_D + _N);

   assign(u, sysunit+'.P32');
   {$I-} reset(u); {$I+}
   io:=ioresult;

   assign(s, config.systemunit);
   {$I-} reset(s); {$I+}
   if ioresult <> 0 then Error(config.systemunit+' not found');

   if (Recompile(s, u)=FALSE) and
      (CompileSystemUnit=FALSE) and
      (io=0) then
     begin
       close(s);
       close(u); {close it because loadunit reopens the file)}
       LoadUnit(sysunit);
     end
   else
     begin
       close(s);
       sysunit:=config.systemunit;
       compile(sysunit);
     end;
   LineCount := 1;
end;


begin
{$IFDEF P32IDE}
{$ELSE}
  writeln('P32 ' + P32_version + ' - Free 32 bit Pascal Compiler  [' + compiledate+']');
  writeln('(C) 1996-1998 by Johan Prins, jprins@knoware.nl - http://surf.to/p32');
  writeln('CPU: ', CPUType, ', FPU: ', YesNo[FPUSupport], ', MMX: ', YesNo[MMXSupport], ', 3D: ', YesNo[S3DNow]);

  ReadConfig;
  ReadDefinition(config.asmdef);

  writeln('Target: ',  config.comment);

{$IFDEF debug}
  writeln('Memory available: ', MaxAvail,' bytes');
  writeln('TreeNode: ', sizeof(Tree_Record), ' bytes');
  writeln('SymbolNode: ', sizeof(SymbolRecord), ' bytes');
{$ENDIF}

  __filename:=GetOptions;

  if (__filename='') and not CompileSystemUnit then Error('missing filename');

  writeln('Compiling...');

  Init; {Reads system unit}

  if not CompileSystemUnit then compile(__filename); {compile it!}

  if CreateBatch=TRUE then CreateBatchFile(__filename);
  if ExecuteBatch=TRUE then ExecuteBatchFile(__filename);

  DestroyConstantList(ConstantTable);
  DestroySymbolList(GlobalTable);
{$IFDEF debug}
  writeln ('Memory available: ', MaxAvail,' bytes');
{$ENDIF}

{$ENDIF}
end.
