ORCA-Pascal/parser.pas

{$optimize 7}
{------------------------------------------------------------}
{							     }
{  ORCA/Pascal 2					     }
{							     }
{  A native code compiler for the Apple IIGS.		     }
{							     }
{  By Mike Westerfield					     }
{							     }
{  Copyright March 1988					     }
{  By the Byte Works, Inc.				     }
{							     }
{------------------------------------------------------------}
 
unit parser;

interface

{$segment 'pascal'}

{$LibPrefix '0/obj/'}

uses PCommon, Scanner, CGI, Symbols, Call;

var
					{structured constants:}
					{---------------------}
  blockbegsys: setofsys;		{symbols that can start a block}
  statbegsys: setofsys;

{------------------------------------------------------------}

procedure DoConstant (fsys: setofsys; var fsp: stp; var fvalu: valu);

{ compile a constant term					}
{								}
{ parameters:							}
{    fsys - following symbols					}
{    fsp - (output) constant type				}
{    fvalu - (output) constant value				}

procedure Expression(fsys: setofsys; fprocp: ctp);
{compile an expression}

procedure InitScalars;                  
{Initialize global scalars}

procedure InitSets;
{initialize structured set constants}

  procedure Selector (fsys: setofsys; fcp,fprocp: ctp; var isMethod: boolean);

  { handle indexing arrays, field selection, dereferencing of	}
  { pointers, windowing files					}
  {								}
  { parameters:							}
  {    fsys -							}
  {    fcp -							}
  {    fprocp - identifier for program or program-level		}
  {       subroutine contining this statement			}
  {    isMethod - (returned) Did the selection resolve to a	}
  {       method call?  If so, take no further action.		}

procedure Programme(fsys:setofsys);
{Compile a program}

{------------------------------------------------------------}

implementation

const
  digmax      =	   255;			{maxcnt-1}
  workspace   =	    16;			{# bytes of work space on stack frame}

{-------------------------------------------------------------------------}
 
type
					{case statement}
					{--------------}
  cip = ^caseinfo;
  caseinfo = packed record
    next: cip;
    csstart: unsigned;
    cslab: integer;
    end;

var
					{counters:}
					{---------}
 
  lastline: integer;			{last line seen by gen}
  firstlab: integer;			{value for intlabel at start of segment}

 
					{switches:}
					{---------}
 
  inseg: boolean;			{tells if a segment is active}
  inUses: boolean;			{tells if a uses is being compiled}
  doingCast: boolean;			{casting a type?}
 
					{pointers:}
					{---------}
  fextfilep: extfilep;			{head of chain for external files}
  thisType: pStringPtr;			{pointer to name of current type}
 
 
					{msc}
					{---}

  namFound: boolean;			{has nam been found? {i.e., should line
					 #'s be generated?}

                                        {objects}
                                        {-------}
  isMethod: boolean;			{are we compiling a method?}
  objectcp: ctp;			{last procedure or function identifier}
  objectName: pString;			{object name (for methods)}
  objectType: stp;			{type of method's object}
  
					{structured constants:}
					{---------------------}
 
  constbegsys,simptypebegsys,typebegsys,selectsys,facbegsys,
  typedels: setofsys;
  inputid,outputid,erroroutputid: pString; {commonly compared identifiers}

{----Parser and Semantic Analysis-----------------------------------------}

procedure DoConstant {fsys: setofsys; var fsp: stp; var fvalu: valu};

{ compile a constant term					}
{								}
{ parameters:							}
{    fsys - following symbols					}
{    fsp - (output) constant type				}
{    fvalu - (output) constant value				}

var
  lsp: stp;
  lcp: ctp;
  sign: (none,pos,neg);
  lvp: csp;

begin {DoConstant}
lsp := nil;
fvalu.ival := 0;
if not(sy in constbegsys) then begin
  Error(22);
  Skip(fsys+constbegsys)
  end; {if}
if sy in constbegsys then begin
  if sy = stringconst then begin
    if (sy = addop) and (op in [plus,minus]) then begin
      Error(34);
      InSymbol;
      end; {if}
    if lgth = 1 then
      lsp := charptr
    else begin
      lsp := pointer(Malloc(