diff --git a/backup b/backup
old mode 100755
new mode 100644
index 8ee69e4..f3ec35a
--- a/backup
+++ b/backup
@@ -1 +1,29 @@
-if "{#}" != "1"
   echo Form: backup [day]
   exit 65535
end

set dest /library/mike/{1}/pascal

set list        make linkit count backup smac pascal.notes
set list {list} pascal.pas pascal.rez
set list {list} parser.pas
set list {list} call.pas
set list {list} symbols.pas symbols.asm symbols.macros
set list {list} pcommon.pas pcommon.asm pcommon.macros
set list {list} scanner.pas scanner.asm scanner.macros
set list {list} cgi.pas cgi.comments cgi.asm
set list {list} native.pas native.asm native.macros
set list {list} objout.pas objout.asm objout.macros
set list {list} dag.pas dag.asm dag.macros
set list {list} cgc.pas cgc.asm cgc.macros
set list {list} gen.pas

unset exit
create {dest} >.null >&.null
for i in {list}
   newer {dest}/{i} {i}
   if {Status} != 0
      copy -c {i} {dest}/{i}
   end
end
\ No newline at end of file
+if "{#}" != "1"
+   echo Form: backup [day]
+   exit 65535
+end
+
+set dest /library/mike/{1}/pascal
+
+set list        make linkit count backup smac pascal.notes
+set list {list} pascal.pas pascal.rez
+set list {list} parser.pas
+set list {list} call.pas
+set list {list} symbols.pas symbols.asm symbols.macros
+set list {list} pcommon.pas pcommon.asm pcommon.macros
+set list {list} scanner.pas scanner.asm scanner.macros
+set list {list} cgi.pas cgi.comments cgi.asm
+set list {list} native.pas native.asm native.macros
+set list {list} objout.pas objout.asm objout.macros
+set list {list} dag.pas dag.asm dag.macros
+set list {list} cgc.pas cgc.asm cgc.macros
+set list {list} gen.pas
+
+unset exit
+create {dest} >.null >&.null
+for i in {list}
+   newer {dest}/{i} {i}
+   if {Status} != 0
+      copy -c {i} {dest}/{i}
+   end
+end
diff --git a/call.pas b/call.pas
old mode 100755
new mode 100644
index 1c1e3d8..c5a5d77
--- a/call.pas
+++ b/call.pas
@@ -1 +1,2849 @@
-{$optimize 15}
{------------------------------------------------------------}
{							     }
{  ORCA/Pascal Call Procedure				     }
{							     }
{  The call procedure handles parsing, semantic analysis     }
{  and code generation for all procedure and function calls. }
{  This includes both user-defined and predeclared	     }
{  routines.						     }
{							     }
{  By Mike Westerfield					     }
{							     }
{  Copyright March 1988					     }
{  By the Byte Works, Inc.				     }
{							     }
{------------------------------------------------------------}

unit Call;

interface

{$segment 'Pascal2'}
{$LibPrefix '0/obj/'}

uses pcommon, scanner, cgi, symbols;

{-- Externally available variables --------------------------------------------}

type
					{subroutine calls}
                                        {----------------}
  callKinds = (cStandard, cMethod, cInherited);

					{temporary variable allocation}
					{-----------------------------}
  tempPtr = ^tempRecord;
  tempRecord = record
    last,next: tempPtr;			{doubly linked list}
    labelNum: integer; 			{label number}
    size: integer;			{size of the variable}
    end;

var
  psize: integer;			{size of the parameter space for the current stack frame}
  lc: addrrange; 			{current stack frame size}

					{temporary variable allocation}
					{-----------------------------}
  tempList: tempPtr;			{list of temp work variables}

{-- Externally available subroutines ------------------------------------------}

procedure Call (fsys: setofsys; fcp,fprocp: ctp);

{ generate a call to a procedure or function			}
{								}
{ parameters:							}
{    fsys -							}
{    fcp -							}
{    fprocp -							}


procedure CallNonStandard (fsys: setofsys; fcp,fprocp: ctp; odisp: longint;
  callKind: callKinds);

{ Handle a call to a user defined procedure/function		}
{								}
{ parameters:							}
{    fsys -							}
{    fcp -							}
{    fprocp -							}
{    odisp - disp in object for method calls; else 0		}
{    callKind - type of this call				}


procedure CheckBool;
{load a value, insuring that it is boolean}

procedure CheckBnds(fsp: stp);
{generate range checking code (if needed)}

procedure FreeTemp (labelNum, size: integer);

{ place a temporary label in the available label list		}
{								}
{ parameters:							}
{    labelNum - number of the label to free			}
{    size - size of the variable 				}
{								}
{ variables:							}
{    tempList - list of free labels				}


function GetTemp (size: integer): integer;

{ find a temporary work variable 				}
{								}
{ parameters:							}
{    size - size of the variable 				}
{								}
{ variables:							}
{    tempList - list of free labels				}
{								}
{ Returns the label number.					}


procedure Load;
{load a value onto the evaluation stack}

procedure LoadAddress;
{load the address of a variable onto the top of the stack}

procedure LoadStringAddress;
{load the address and length of a string}

procedure LoadString(kind: stringKind);
{load the address of a string constant}

function ParmSize(lsp: stp; vkind: idkind): integer;
{find the length of a parameter}

procedure ResetTemp;

{ forget all of the temporary work variables			}


procedure Store(var fattr: attr);
{store the value on top of stack}

{-- Private declarations ------------------------------------------------------}

implementation

const
  realfw      =	    16;			{field width for reals & doubles}
  longfw      =	    16;			{field width for long integers}
  intfw	      =	     8;			{field width for integers}
  boolfw      =	     8;			{field width for booleans}

var
  lkey: keyrange;			{proc/func key for std proc compilation}
{-- Imported subroutines ------------------------------------------------------}

procedure DoConstant(fsys: setofsys; var fsp: stp; var fvalu: valu); extern;
{compile a constant term}

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

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

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

{-- Private subroutines -------------------------------------------------------}

procedure Variable(fsys: setofsys; fprocp: ctp);
{compile a variable for the parm list of a standard proc/func}

var
  isMethod: boolean;			{dummy variable for Selector call}
  lcp: ctp;

begin {Variable}
if sy = ident then begin
  SearchId([varsm,field],lcp);
  InSymbol;
  end
else begin
  Error(2);
  lcp := uvarptr;
  end;
Selector(fsys, lcp, fprocp, isMethod);
glcp := lcp;
end; {Variable}

procedure GetPutClose(fsys: setofsys; fprocp: ctp);
{Compile one of the named standard procs}

begin {GetPutClose}
{compile the file variable}
Variable(fsys + [rparent],fprocp);
{load the file variable}
Load;
Gen0t(pc_stk, cgULong);
{do type checking on file variable}
if gattr.typtr <> nil then
  if gattr.typtr^.form <> files then
    Error(44);
{generate the standard proc call}
Gen1(pc_csp,lkey{get,put,opn,cls})
end; {GetPutClose}

procedure resetrewriteopen(fsys: setofsys; fprocp: ctp);

var
  key: integer;			   {open kind key; 1->read; 2->write; 3->both}
  size: longint; 		      {for remembering file size}
  lsp: stp;			      {file type}
  fkind: (stin,stout,errout,fileout); {kind of file}

begin {resetrewriteopen}
{process the file variable}
Variable(fsys+[comma,rparent],fprocp);
fkind := fileout;
if gattr.typtr = nil then
  Error(44)
else if gattr.typtr^.form = files then begin
  size := gattr.typtr^.filtype^.size;
  if glcp = outptr then begin
    fkind := stout;
    if nooutput then Error(92);
    end
  else if glcp = inptr then begin
    fkind := stin;
    if noinput then Error(91);
    end
  else if glcp = erroroutputptr then
    fkind := errout;
  end
else Error(44);
{determine the type of the open}
if lkey = 3 then
  key := 3
else
  key := lkey-4;
case key of
  1: if fkind in [stout,errout] then Error(44);
  2: if fkind = stin then Error(44);
  3: if fkind <> fileout then Error(44);
  end;
if gattr.typtr <> nil then
  if fkind = fileout then begin
    {load the file variable}
    LoadAddress;
    Gen0t(pc_stk, cgULong);
    {push the open type onto the stack}
    lsp := glcp^.idtype;
    if lsp^.form = pointerStruct then lsp := lsp^.eltype;
    Gen1t(pc_ldc, key+4*ord(lsp=textptr), cgWord);
    Gen0t(pc_stk, cgWord);
    Gen0t(pc_bno, cgWord);
    {load the length of the file}
    Gen1t(pc_ldc, ord(size), cgWord);
    Gen0t(pc_stk, cgWord);
    Gen0t(pc_bno, cgWord);
    end {if}
  else begin
    Gen1t(pc_ldc, ord(fkind), cgWord);
    Gen0t(pc_stk, cgWord);
    Gen0t(pc_bno, cgWord);
    end; {else}
{if there is another parameter, use it for the file name}
if sy = comma then begin
  if iso then Error(112);
  InSymbol;
  Expression(fsys+[rparent],fprocp);
  if gattr.typtr <> nil then
    if IsString(gattr.typtr) then begin
      LoadStringAddress;
      Gen0t(pc_bno, cgULong);
      end {if}
    else Error(44)
  else Error(44);
  end
else begin
  GenLdcLong(0);
  Gen0t(pc_stk, cgULong);
  Gen0t(pc_bno, cgULong);
  Gen1t(pc_ldc, 0, cgWord);
  Gen0t(pc_stk, cgWord);
  Gen0t(pc_bno, cgWord);
  end; {else}
{open the file}
if fkind = fileout then
  Gen1(pc_csp,3{opn})
else
  Gen1(pc_csp,115{rdr});
end; {resetrewriteopen}

procedure seek(fsys: setofsys; fprocp: ctp);
{Compile the seek statement}

begin {seek}
Variable(fsys+[comma,rparent],fprocp);
if gattr.typtr = nil then
  Error(44)
else if gattr.typtr^.form <> files then
  Error(44);
Load;
Gen0t(pc_stk, cgULong);
Match(comma,20);
Expression(fsys+[rparent],fprocp);
Load;
if gattr.typtr <> nil then begin
  if (gattr.typtr=intptr) or (gattr.typtr=byteptr) then begin
    Gen2(pc_cnv,ord(cgWord),ord(cgLong));
    gattr.typtr := longptr;
    end;
  if gattr.typtr <> longptr then Error(44);
  end
else Error(44);
Gen0t(pc_stk, cgULong);
Gen0t(pc_bno, cgULong);
Gen1(pc_csp,44{sek});
end; {seek}

procedure page(fsys: setofsys; fprocp: ctp);
{compile a page procedure call}

var
  lsp: stp;

begin {page}
if sy = lparent then begin
  InSymbol;
  Variable(fsys+[rparent],fprocp);
  lsp := gattr.typtr;
  if lsp <> nil then
    if lsp = textptr then
      if sy <> rparent then begin
	Error(4);
	Skip(fsys+[rparent]);
	end
      else InSymbol
    else Error(44)
  else Error(44);
  if glcp = outptr then begin
    Gen0(pc_nop);
    Gen1(pc_csp,32{pag});
    end {if}
  else if glcp = erroroutputptr then begin
    Gen0(pc_nop);
    Gen1(pc_csp,33{pag});
    end {else if}
  else begin
    Load;
    Gen0t(pc_stk, cgULong);
    Gen1(pc_csp,15{pag});
    end;
  end
else begin
  if nooutput then Error(92);
  Gen0(pc_nop);
  Gen1(pc_csp,32{pag});
  end;
end; {page}

procedure HaltSeed(fsys: setofsys; fprocp: ctp);
{compile a call to halt or seed}

begin {HaltSeed}
Expression(fsys+[rparent],fprocp);
Load;
if gattr.typtr <> nil then begin
  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
  end
else Error(44);
Gen0t(pc_stk, cgWord);
Gen1(pc_csp,46+lkey);
end; {HaltSeed}

procedure Delete(fsys: setofsys; fprocp: ctp);
{compile a call to the delete string procedure}

begin {Delete}
{load the string to delete characters from}
Expression(fsys+[comma,rparent],fprocp);
if gattr.typtr <> nil then
  if IsString(gattr.typtr) then begin
    if gattr.kind <> varbl then Error(44);
    LoadStringAddress;
    end
  else Error(44)
else Error(44);
{load the index}
Match(comma,20);
Expression(fsys+[comma,rparent],fprocp);
Load;
Gen0t(pc_stk, cgWord);
Gen0t(pc_bno, cgWord);
if gattr.typtr <> nil then begin
  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then
    Error(44);
  end
else Error(44);
{load the number of chars to delete}
Match(comma,20);
Expression(fsys+[rparent],fprocp);
Load;
Gen0t(pc_stk, cgWord);
Gen0t(pc_bno, cgWord);
if gattr.typtr <> nil then begin
  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
  end
else Error(44);
{call the delete procedure}
Gen1(pc_csp,68{dlt});
end; {Delete}

procedure Insert(fsys: setofsys; fprocp: ctp);
{compile a call to insert one string an another}

begin {Insert}
{load the string to insert characters into}
Expression(fsys+[comma,rparent],fprocp);
if gattr.typtr <> nil then
  if IsString(gattr.typtr) then
    LoadStringAddress
  else if gattr.typtr = charptr then begin
    Load;
    Gen0t(pc_stk, cgWord);
    GenLdcLong(-1);
    Gen0t(pc_stk, cgULong);
    Gen0t(pc_bno, cgWord);
    end
  else Error(44)
else Error(44);
{load the string to insert}
Match(comma,20);
Expression(fsys+[comma,rparent],fprocp);
if gattr.typtr <> nil then
  if IsString(gattr.typtr) then begin
    if gattr.kind <> varbl then
      Error(44);
    LoadStringAddress;
    Gen0t(pc_bno, cgWord);
    end
  else Error(44)
else Error(44);
{load the index}
Match(comma,20);
Expression(fsys+[comma,rparent],fprocp);
Load;
Gen0t(pc_stk, cgWord);
Gen0t(pc_bno, cgWord);
if gattr.typtr <> nil then begin
  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
  end
else Error(44);
{call the insert procedure}
Gen1(pc_csp,69{ins});
end; {Insert}

procedure CommandLineShellID(fsys: setofsys; fprocp: ctp);
{compile a call to CommandLine or ShellID}

begin {CommandLineShellID}
{load the string to place characters in}
Expression(fsys+[rparent],fprocp);
if gattr.typtr <> nil then
  if IsString(gattr.typtr) then begin
    if gattr.kind <> varbl then Error(44);
    LoadStringAddress;
    end
  else Error(44)
else Error(44);
{call the procedure}
Gen1(pc_csp,46+lkey);
end; {CommandLineShellID}

procedure StartGraphDesk(fsys: setofsys; fprocp: ctp);
{compile a call to StartGraph or StartDesk}

begin {StartGraphDesk}
Expression(fsys+[rparent],fprocp);
Load;
Gen0t(pc_stk, cgWord);
if gattr.typtr <> nil then begin
  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then
    Error(44);
  end
else Error(44);
Gen1(pc_csp,46+lkey);
end; {StartGraphDesk}

procedure EndGraphDesk;
{compile a call to EndGraph or EndDesk}

begin {EndGraphDesk}
Gen0(pc_nop);
Gen1(pc_csp,46+lkey);
end; {EndGraphDesk}

procedure DoRead (fsys: setofsys; fprocp: ctp);

{ compile a read procedure call					}
{								}
{ Parameters:							}
{    fsys -							}
{    fprocp -							}

var
   lattr,tattr: attr;
   lsp : stp;
   needBno: boolean;			{do we need a pc_bno?}
   test: boolean;
   standardIn: boolean;		        {is the read from standard input?}
   llb: unsigned; 		        {for allocating temporary space}
   inLocalPtr: boolean;		        {is file ptr in local area?}

begin {DoRead}
inLocalPtr := false;
standardIn := true;
lattr.typtr := textptr;
if sy = lparent then begin
   InSymbol;
   Variable(fsys + [comma, rparent], fprocp);
   if glcp <> nil then
      with glcp^ do
         if klass = varsm then begin
	    if vcontvar then
               Error(97);
	    if vlev <> level then
               vrestrict := true;
	    end; {if}
   lsp := gattr.typtr;
   test := false;
   if lsp <> nil then
      if lsp^.form = files then

         {handle reads from files}
         with gattr, lsp^ do begin
	    if (lkey = 13{readln}) and (typtr <> textptr) then
               Error(44);
	    if access = indrct then begin
	       Load;
	       llb := GetTemp(ptrsize);
	       Gen3t(pc_str, llb, 0, 0, cgULong);
	       inLocalPtr := true;
	       dplab := llb;
               gattr.isPacked := false;
	       kind := varbl;
	       access := drct;
	       vlevel := level;
	       FreeTemp(llb, ptrsize);
	       end; {if}
	    lattr := gattr;
	    standardIn := glcp = inptr;
	    if sy = rparent then begin
	       if lkey = 7{read} then
                  Error(44);
	       test := true;
	       end {if}
	    else if sy <> comma then begin
	       Error(44);
	       Skip(fsys + [comma, rparent]);
	       end; {else if}
	    if sy = comma then begin
	       InSymbol;
	       Variable(fsys + [comma, rparent], fprocp);
	       end {if}
	    else
               test := true;
	    end {with}
         else if noinput then
            Error(91);
   if lattr.typtr = textptr then begin

      {read from a text file}
      if not test then
         repeat
	    if glcp <> nil then
	       with glcp^ do
	          if klass = varsm then begin
	             if vcontvar then
                        Error(97);
	             if vlev <> level then
                        vrestrict := true;
	             end; {if}
            needBno := false;
	    if IsString(gattr.typtr) then begin
	       if gattr.kind <> expr then begin
	          LoadAddress;
	          Gen0t(pc_stk, cgULong);
	          Gen1t(pc_ldc, StrLen(gattr.typtr), cgWord);
	          Gen0t(pc_stk, cgWord);
	          Gen0t(pc_bno, cgWord);
                  needBno := true;
	          end;         {if}
	       end {if}
	    else begin
	       if gattr.typtr <> nil then
	          if (gattr.access<>drct) or
	             (gattr.typtr^.form in [arrays,records,objects,files]) then
	             LoadAddress;
	       end; {else}
	    tattr := gattr;
	    if not standardIn then begin
	       gattr := lattr;
	       if inLocalPtr then
	          Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
	       else
	          Load;
	       Gen0t(pc_stk, cgULong);
               if needBno then
	          Gen0t(pc_bno, cgULong);
	       end; {if}
	    if tattr.typtr <> nil then
	       if (tattr.typtr^.form <= subrange) or IsString(tattr.typtr) then
                  begin
	          if standardIn then
                     Gen0(pc_nop);
	          if CompTypes(intptr, tattr.typtr) then begin
	             if standardIn then
		        Gen1(pc_csp, 59{rii})
	             else
		        Gen1(pc_csp, 5{rdi});
	             CheckBnds(tattr.typtr);
	             Store(tattr);
	             end {if}
	          else if CompTypes(longptr, tattr.typtr) then begin
	             if standardIn then
		        Gen1(pc_csp, 98{ril})
	             else
		        Gen1(pc_csp, 99{rdl});
	             CheckBnds(tattr.typtr);
	             Store(tattr);
	             end {else if}
	          else if CompTypes(charptr, tattr.typtr) then begin
	             if standardIn then
		        Gen1(pc_csp, 58{ric})
	             else
		        Gen1(pc_csp, 7{rdc});
	             CheckBnds(tattr.typtr);
	             Store(tattr);
	             end {else if}
	          else if CompTypes(realptr, tattr.typtr) then begin
	             if standardIn then
		        Gen1(pc_csp, 61{rir})
	             else
		        Gen1(pc_csp, 6{rdr});
	             CheckBnds(tattr.typtr);
	             Store(tattr);
	             end {else if}
	          else if CompTypes(stringptr, tattr.typtr) then begin
	             if standardIn then
		        Gen1(pc_csp, 84{ris})
	             else
		        Gen1(pc_csp, 50{rds});
	             end {esle if}
	          else
                     Error(44);
                  end {if}
	       else
                  Error(44);
	    test := sy <> comma;
	    if not test then begin
	       InSymbol;
	       Variable(fsys + [comma, rparent], fprocp);
	       end; {if}
         until test;
      end {if}
   else if not test then begin

      {do non-text reads}
      repeat
         if glcp <> nil then
	    with glcp^ do
	       if klass = varsm then begin
	          if vcontvar then
                     Error(97);
	          if vlev <> level then
                     vrestrict := true;
	          end; {if}
         if gattr.typtr <> nil then
	    if (gattr.access<>drct) or
	       (gattr.typtr^.form in [arrays,records,files]) then
	       LoadAddress;
         tattr := gattr;
         if not CompTypes(gattr.typtr, lattr.typtr^.filtype) then
            if not CompObjects(gattr.typtr, lattr.typtr^.filtype) then
               Error(44);
         gattr := lattr;
         if inLocalPtr then
	    Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
         else
	    Load;
         with gattr do begin
	    typtr := lattr.typtr^.filtype;
	    kind := varbl;
            isPacked := false;
	    access := indrct;
	    idplmt := 0;
	    end; {with}
         if gattr.typtr^.form in [scalar,subrange,pointerStruct,power,objects]
            then
	    Load
         else
	    LoadAddress;
         case tattr.typtr^.form of
	    scalar,subrange: begin
	       CheckBnds(tattr.typtr);
	       Store(tattr);
	       end;
	    pointerStruct,power,objects:
	       Store(tattr);
	    arrays,records:
	       Gen2(pc_mov, long(tattr.typtr^.size).msw,
                  long(tattr.typtr^.size).lsw);
	    files: Error(71);
	    end; {case}

         {get the next file variable}
         gattr := lattr;
         if inLocalPtr then
	    Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
         else
	    Load;
         Gen0t(pc_stk, cgULong);
         Gen1(pc_csp, 1{get});
         test := sy <> comma;
         if not test then begin
	    InSymbol;
	    Variable(fsys+[comma,rparent], fprocp);
	    end; {if}
      until test;
      end; {else if not test}
   Match(rparent, 4);
   end {if}
else if lkey = 7{read} then
   Error(44);
if lkey = 13{readln} then begin
   if standardIn then begin
      Gen0(pc_nop);
      Gen1(pc_csp, 60{rin});
      end {if}
   else begin
      gattr := lattr;
      if inLocalPtr then
         Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
      else
         Load;
      Gen0t(pc_stk, cgULong);
      Gen1(pc_csp, 13{rln})
      end; {else}
   end; {if}
end; {DoRead}

procedure DoWrite(fsys: setofsys; fprocp: ctp);
{compile a call to write, writeln}

var
  lsp: stp;
  default,defaultr : boolean;
  llkey: keyrange;
  lcp: ctp;
  len: addrrange;
  lattr,tattr: attr;
  test: boolean;
  standardOut,errorOut: boolean;      {is the write to the console?}
  llb: unsigned; 		      {for allocating temporary space}
  inLocalPtr: boolean;		      {is file ptr in local area?}

  procedure LoadFile;
  {load the file variable}

  begin {LoadFile}
  gattr := lattr;
  if inLocalPtr then
    Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
  else
    Load;
  end; {LoadFile}

begin {DoWrite}
inLocalPtr := false;
llkey := lkey;
standardOut := true;
errorOut := false;
lattr.typtr := textptr;
if sy = lparent then begin
  InSymbol;
  Expression(fsys + [comma,colon,rparent],fprocp);
  lsp := gattr.typtr;
  test := false;
  if lsp <> nil then
    if lsp^.form = files then
      with gattr, lsp^ do begin
	if access = indrct then begin
	  Load;
	  llb := GetTemp(ptrsize);
	  Gen3t(pc_str, llb, 0, 0, cgULong);
          gattr.isPacked := false;
	  kind := varbl;
	  access := drct;
	  vlevel := level;
	  dplab := llb;
	  inLocalPtr := true;
	  FreeTemp(llb, ptrsize);
	  end;
	lattr := gattr;
	standardOut := glcp = outptr;
	errorOut := glcp = erroroutputptr;
	if (lkey = 14{writeln}) and (typtr <> textptr) then Error(44);
	if sy = rparent then begin
	  if llkey = 8{write} then Error(44);
	  test := true;
	  end
	else if sy <> comma then begin
	  Error(44);
	  Skip(fsys+[comma,rparent]);
	  end;
	if sy = comma then begin
	  InSymbol;
	  if lattr.typtr = textptr then
	    Expression(fsys+[comma,colon,rparent],fprocp);
	  end
	else test := true
	end
    else if nooutput then Error(92);
  if lattr.typtr = textptr then begin

    {text file reads}
    if not test then
      repeat
	lsp := gattr.typtr;
	if lsp^.form = subrange then
          lsp := lsp^.rangetype;
	if lsp <> nil then
	  if lsp^.form <= subrange then begin
	    Load;
	    if (lsp = intptr) or (lsp = byteptr) or (lsp = charptr)
	      or (lsp = boolptr) then
	      Gen0t(pc_stk, cgWord)
	    else if lsp = longptr then
	      Gen0t(pc_stk, cgLong)
	    else if IsReal(lsp) then
	      Gen0t(pc_stk, cgExtended)
	    else if lsp <> nil then
	      Gen0t(pc_stk, cgULong);
	    end {if}
	  else begin
	    if IsString(gattr.typtr) then
	      LoadStringAddress
	    else begin
	      LoadAddress;
	      Gen0t(pc_stk, cgULong);
	      end; {else}
	    end;
	if sy = colon then begin
	  InSymbol;
	  Expression(fsys + [comma,colon,rparent],fprocp);
	  Load;
	  Gen0t(pc_stk, cgWord);
	  Gen0t(pc_bno, cgWord);
	  if gattr.typtr <> nil then
	    if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then
	      Error(44);
	  if debug then
            Gen2t(pc_chk, 0, maxint, cgUWord);
	  default := false;
	  end
	else default := true;
	if sy = colon then begin
	  InSymbol;
	  Expression(fsys + [comma,rparent],fprocp);
	  Load;
	  Gen0t(pc_stk, cgWord);
	  Gen0t(pc_bno, cgWord);
	  if gattr.typtr <> nil then
	    if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then
	      Error(44);
	  if not IsReal(lsp) then
            Error(50);
	  defaultr := false;
	  end
	else defaultr := true;
	if (lsp = intptr) or (lsp = byteptr) then begin
	  if default then begin
	    Gen1t(pc_ldc, intfw, cgWord);
	    Gen0t(pc_stk, cgWord);
	    Gen0t(pc_bno, cgWord);
	    end; {if}
	  if standardOut then
	    Gen1(pc_csp,16{woi})
	  else if errorOut then
	    Gen1(pc_csp,42{wei})
	  else begin
	    LoadFile;
	    Gen0t(pc_stk, cgULong);
	    Gen0t(pc_bno, cgULong);
	    Gen1(pc_csp,9{wri});
	    end;
	  end
	else if lsp = longptr then begin
	  if default then begin
	    Gen1t(pc_ldc, longfw, cgWord);
	    Gen0t(pc_stk, cgWord);
	    Gen0t(pc_bno, cgWord);
	    end; {if}
	  if standardOut then
	    Gen1(pc_csp,100{wol})
	  else if errorOut then
	    Gen1(pc_csp,101{wel})
	  else begin
	    LoadFile;
	    Gen0t(pc_stk, cgULong);
	    Gen0t(pc_bno, cgULong);
	    Gen1(pc_csp,102{wrl});
	    end;
	  end
	else if IsReal(lsp) then begin
	  if default then begin
	    Gen1t(pc_ldc, realfw, cgWord);
	    Gen0t(pc_stk, cgWord);
	    Gen0t(pc_bno, cgWord);
	    end; {if}
	  if defaultr then begin
	    Gen1t(pc_ldc, 0, cgWord);
	    Gen0t(pc_stk, cgWord);
	    Gen0t(pc_bno, cgWord);
	    end; {if}
	  if standardOut then
	    Gen1(pc_csp,62{wor})
	  else if errorOut then
	    Gen1(pc_csp,53{wer})
	  else begin
	    LoadFile;
	    Gen0t(pc_stk, cgULong);
	    Gen0t(pc_bno, cgULong);
	    Gen1(pc_csp,10{wrr});
	    end; {else}
	  end {else if}
	else if lsp = charptr then begin
	  if standardOut then
	    if default then
	      Gen1(pc_csp,40{wol})
	    else
	      Gen1(pc_csp,37{woc})
	  else if errorOut then
	    if default then
	      Gen1(pc_csp,41{wel})
	    else
	      Gen1(pc_csp,39{wec})
	  else begin
	    if default then begin
	      Gen1t(pc_ldc, 1, cgWord);
	      Gen0t(pc_stk, cgWord);
	      Gen0t(pc_bno, cgWord);
	      end; {if}
	    LoadFile;
	    Gen0t(pc_stk, cgULong);
	    Gen0t(pc_bno, cgULong);
	    Gen1(pc_csp,8{wrc});
	    end;
	  end
	else if lsp = boolptr then begin
	  if default then begin
	    Gen1t(pc_ldc, boolfw, cgWord);
	    Gen0t(pc_stk, cgWord);
	    Gen0t(pc_bno, cgWord);
	    end; {if}
	  if standardOut then
	    Gen1(pc_csp,29{wob})
	  else if errorOut then
	    Gen1(pc_csp,31{web})
	  else begin
	    LoadFile;
	    Gen0t(pc_stk, cgULong);
	    Gen0t(pc_bno, cgULong);
	    Gen1(pc_csp,46{wrb});
	    end;
	  end
	else if lsp <> nil then begin
	  if IsString(lsp) then begin
	    if default then begin
	      Gen1t(pc_ldc, $8000, cgWord);
	      Gen0t(pc_stk, cgWord);
	      Gen0t(pc_bno, cgWord);
	      end; {if}
	    if standardOut then
	      Gen1(pc_csp,21{wos})
	    else if errorOut then
	      Gen1(pc_csp,25{wes})
	    else begin
	      LoadFile;
	      Gen0t(pc_stk, cgULong);
	      Gen0t(pc_bno, cgULong);
	      Gen1(pc_csp,45{wrs});
	      end;
	    end
	  else Error(44);
	  end;
	test := sy <> comma;
	if not test then begin
	  InSymbol;
	  Expression(fsys + [comma,colon,rparent],fprocp)
	  end
      until test;
    end
  else if not test then begin

    {handle non-text files}
    repeat
      {assign the Expression to the file variable}
      LoadFile;
      tattr := gattr;
      with tattr do begin
	typtr := gattr.typtr^.filtype;
        isPacked := false;
	kind := varbl;
	access := indrct;
	idplmt := 0;
	end;
      if debug then
        GenL2t(pc_chk, 1, maxaddr, cgULong);
      Expression(fsys+[comma,colon,rparent],fprocp);
      lsp := gattr.typtr;
      if (lsp^.form <= subrange) or (lsp^.form = objects) then
        Load
      else
        LoadAddress;
      if not CompTypes(lsp,lattr.typtr^.filtype) then
        if not CompObjects(lsp,lattr.typtr^.filtype) then
          Error(44);
      case tattr.typtr^.form of
	scalar,subrange: begin
	  CheckBnds(tattr.typtr);
	  Store(tattr);
	  end;
	pointerStruct,power,objects:
	  Store(tattr);
	arrays,records:
	  Gen2(pc_mov, long(tattr.typtr^.size).msw, long(tattr.typtr^.size).lsw);
	files: Error(71);
	end; {case}
      {write the file variable to the file}
      LoadFile;
      Gen0t(pc_stk, cgULong);
      Gen1(pc_csp,2{put});
      test := sy<>comma;
      if not test then InSymbol;
    until test;
    end; {else if not test}
  Match(rparent,4);
  end
else if lkey = 8{write} then Error(44);
if lkey = 14{writeln} then begin
  if standardOut then begin
    Gen0(pc_nop);
    Gen1(pc_csp,26{wol});
    end {if}
  else if errorOut then begin
    Gen0(pc_nop);
    Gen1(pc_csp,27{wel});
    end {else if}
  else begin
    LoadFile;
    Gen0t(pc_stk, cgULong);
    Gen1(pc_csp,14{wln});
    end;
  end;
end; {DoWrite}

procedure DoPack(fsys: setofsys; fprocp: ctp);
{compile a call to pack}

var
  lsp,lsp1: stp;
  elSize: longint;		      {element size}
  lmin,lmax: longint;		      {subrange of unpacked array}

begin {DoPack}
{get the unpacked array}
Variable(fsys + [comma,rparent],fprocp);
LoadAddress;
Gen0t(pc_stk, cgULong);
if gattr.typtr <> nil then
  with gattr.typtr^ do
    if (form = arrays) and (ispacked = pkunpacked) then begin
      Gen1t(pc_ldc, long(aeltype^.size).lsw, cgUWord);
      Gen0t(pc_stk, cgUWord);
      Gen0t(pc_bno, cgUWord);
      GenLdcLong(size div aeltype^.size);
      Gen0t(pc_stk, cgULong);
      Gen0t(pc_bno, cgULong);
      lsp := inxtype;
      lsp1 := aeltype;
      GetBounds(lsp,lmin,lmax);
      end
    else Error(44);
Match(comma,20);
{get the staring index}
Expression(fsys + [comma,rparent],fprocp);
Load;
if CompTypes(longptr, lsp) then
  if (gattr.typtr = intptr) or (gattr.typtr = bytePtr) then begin
    Gen2(pc_cnv,ord(cgWord),ord(cgLong));
    gattr.typtr := longptr;
    end; {end}
if gattr.typtr <> nil then
  if gattr.typtr^.form <> scalar then
    Error(44)
  else if not CompTypes(lsp,gattr.typtr) then
    Error(44);
if not CompTypes(longptr, gattr.typtr) then begin
  Gen2(pc_cnv, ord(GetType(gattr.typtr, false)), ord(cgLong));
  gattr.typtr := longptr;
  end; {end}
Match(comma,20);
if lmin <> 0 then begin
  GenLdcLong(lmin);
  Gen0(pc_sbl);
  end; {if}
Gen0t(pc_stk, cgULong);
Gen0t(pc_bno, cgULong);
{get the packed array}
Variable(fsys + [rparent],fprocp);
LoadAddress;
Gen0t(pc_stk, cgULong);
Gen0t(pc_bno, cgULong);
if gattr.typtr <> nil then
  with gattr.typtr^ do
    if (form = arrays) and (ispacked = pkpacked) then begin
      if not CompTypes(aeltype,lsp1) then Error(44);
      elSize := aelType^.size;
      if (aelType = charptr) or (aelType = boolptr) then
	elSize := packedCharSize;
      Gen1t(pc_ldc, long(elSize).lsw, cgUWord);
      Gen0t(pc_stk, cgUWord);
      Gen0t(pc_bno, cgUWord);
      GenLdcLong(size div elSize);
      Gen0t(pc_stk, cgULong);
      Gen0t(pc_bno, cgULong);
      end {if}
    else Error(44);
{move the elements}
Gen1(pc_csp, 51{pak});
end; {DoPack}

procedure DoUnpack(fsys: setofsys; fprocp: ctp);
{compile a call to unpack}

var
  lsp,lsp1: stp;
  elSize: longint;		      {element size}
  lmin,lmax: longint;		      {subrange of unpacked array}

begin {DoUnpack}
Variable(fsys + [comma,rparent],fprocp);
LoadAddress;
Gen0t(pc_stk, cgULong);
if gattr.typtr <> nil then
  with gattr.typtr^ do
    if (form = arrays) and (ispacked = pkpacked) then begin
      elSize := aelType^.size;
      if (aelType = charptr) or (aelType = boolptr) then
	elSize := packedCharSize;
      lsp1 := aeltype;
      Gen1t(pc_ldc, long(elSize).lsw, cgWord);
      Gen0t(pc_stk, cgUWord);
      Gen0t(pc_bno, cgUWord);
      GenLdcLong(size div elSize);
      Gen0t(pc_stk, cgULong);
      Gen0t(pc_bno, cgULong);
      end
    else Error(44);
Match(comma,20);
Variable(fsys + [comma,rparent],fprocp);
LoadAddress;
Gen0t(pc_stk, cgULong);
Gen0t(pc_bno, cgULong);
if gattr.typtr <> nil then
  with gattr.typtr^ do
    if (form = arrays) and (ispacked = pkunpacked) then begin
      if not CompTypes(aeltype,lsp1) then Error(44);
      Gen1t(pc_ldc, long(aeltype^.size).lsw, cgWord);
      Gen0t(pc_stk, cgUWord);
      Gen0t(pc_bno, cgUWord);
      GenLdcLong(size div aeltype^.size);
      Gen0t(pc_stk, cgULong);
      Gen0t(pc_bno, cgULong);
      lsp := inxtype;
      GetBounds(lsp,lmin,lmax);
      end
    else Error(44);
Match(comma,20);
Expression(fsys + [rparent],fprocp);
Load;
if CompTypes(longptr, lsp) then
  if (gattr.typtr = intptr) or (gattr.typtr = bytePtr) then begin
    Gen2(pc_cnv, ord(cgWord), ord(cgLong));
    gattr.typtr := longptr;
    end; {end}
if gattr.typtr <> nil then
  if gattr.typtr^.form <> scalar then
    Error(44)
  else if not CompTypes(lsp,gattr.typtr) then
    Error(44);
if not CompTypes(longptr, gattr.typtr) then begin
  Gen2(pc_cnv, ord(GetType(gattr.typtr, false)), ord(cgLong));
  gattr.typtr := longptr;
  end; {end}
if lmin <> 0 then begin
  GenLdcLong(lmin);
  Gen0(pc_sbl);
  end; {if}
Gen0t(pc_stk, cgULong);
Gen0t(pc_bno, cgULong);
Gen1(pc_csp, 52{upk});
end; {DoUnpack}


procedure DoNew (fsys: setofsys; fprocp: ctp);

{ compile a call to new						}
{								}
{ parameters:							}
{    fsys -							}
{    fprocp -							}

label 1;

var
  lattr: attr;				{pointer/object variable's gattr}
  lsize: addrrange;			{amount of memory to allocate}
  lsp,lsp1: stp;
  lval: valu;
  ofld: ctp;				{object field list}
  varts: integer;


  function InitMethods (lcp: ctp): unsigned;

  { Set the address for all methods in a new object		}
  {								}
  { parameters:							}
  {    lsp - head of object field tree				}
  {								}
  { returns: Number of methods					}

  var
     count: unsigned;

  begin {InitMethods}
  count := 0;
  if lcp^.llink <> nil then
    count := InitMethods(lcp^.llink);
  if lcp^.rlink <> nil then
    count := count + InitMethods(lcp^.rlink);
  if lcp^.klass in [proc,func] then begin
    count := count + 1;
    Gen0Name(pc_lad, lcp^.pfoname);
    Gen0t(pc_stk, cgULong);
    GenLdcLong(lcp^.pfaddr);
    Gen0t(pc_stk, cgULong);
    Gen0t(pc_bno, cgULong);
    Gen0t(pc_bno, cgULong);
    end; {if}
  InitMethods := count;
  end; {InitMethods}


begin {DoNew}
{get the pointer to allocate}
Variable(fsys + [comma,rparent],fprocp);
lattr := gattr;
LoadAddress;
Gen0t(pc_stk, cgULong);

{examine the variable to see how much memory to allocate}
lsp := nil;
varts := 0;
lsize := 0;
ofld := nil;
if gattr.typtr <> nil then
  with gattr.typtr^ do
    if form = pointerStruct then begin
      if eltype <> nil then begin
	lsize := eltype^.size;
	if eltype^.form = records then
          lsp := eltype^.recvar;
	end; {if}
      end {if}
    else if form = objects then begin
      lsize := objsize;
      ofld := objfld;
      end {else if}
    else
      Error(44);

{handle the variant parts}
while sy = comma do begin
  InSymbol;
  DoConstant(fsys + [comma,rparent],lsp1,lval);
  varts := varts+1;
  if lsp = nil then
    Error(82)
  else if lsp^.form <> tagfld then
    Error(86)
  else if lsp^.tagfieldp <> nil then
    if CompTypes(lsp^.tagfieldp^.idtype,lsp1) then begin
      lsp1 := lsp^.fstvar;
      while lsp1 <> nil do
	with lsp1^ do
	  if varval = lval.ival then begin
	    lsize := size;
	    lsp := subvar;
	    goto 1;
	    end {if}
	  else
	    lsp1 := nxtvar;
      end {if}
    else
      Error(44);
1:  end {while} ;

{for objects, set up size, generation, and method addresses}
if ofld <> nil then begin
  if lattr.typtr <> nil then begin
    Gen1t(pc_ldc, lattr.typtr^.objlevel, cgUWord);
    Gen0t(pc_stk, cgUWord);
    Gen0t(pc_bno, cgUWord);
    end; {if}
  GenLdcLong(lsize);
  Gen0t(pc_stk, cgULong);
  Gen0t(pc_bno, cgULong);
  Gen1t(pc_ldc, InitMethods(ofld), cgUWord);
  Gen0t(pc_stk, cgUWord);
  Gen0t(pc_bno, cgUWord);

{generate the call to allocate memory}
  Gen1(pc_csp,118{newobj});
  end {if}
else if lsize < maxint then begin
  Gen1t(pc_ldc, long(lsize).lsw, cgWord);
  Gen0t(pc_stk, cgWord);
  Gen0t(pc_bno, cgWord);
  Gen1(pc_csp,11{new});
  end {if}
else begin
  if lsize > $010000 then
    if smallMemoryModel then
      Error(122);
  GenLdcLong(lsize);
  Gen0t(pc_stk, cgULong);
  Gen0t(pc_bno, cgULong);
  Gen1(pc_csp,116{new4});
  end; {else}

{if this points to a file, zero the area}
gattr := lattr;
if gattr.typtr <> nil then
  if gattr.typtr^.form <> objects then
    if gattr.typtr^.hasSFile then begin
      Gen1t(pc_ldc, ord(gattr.typtr^.size), cgWord);
      Gen0t(pc_stk, cgWord);
      Load;
      Gen0t(pc_stk, cgULong);
      Gen0t(pc_bno, cgULong);
      Gen1(pc_csp,35{clr});
      end; {if}
end; {DoNew}


procedure DoSizeof;
{compile a call to sizeof}

var
  lcp: ctp;

begin {DoSizeof}
Match(lparent,9);
SearchId([types,varsm], lcp);
if lcp^.idtype^.size < maxint then begin
  Gen1t(pc_ldc, ord(lcp^.idtype^.size), cgWord);
  gattr.typtr := intptr;
  end {if}
else begin
  GenLdcLong(lcp^.idtype^.size);
  gattr.typtr := longptr;
  end; {else}
InSymbol;
end; {DoSizeof}


procedure DoDispose (fsys: setofsys; fprocp: ctp);

{ Compile a call to dispose					}
{								}
{ parameters:							}
{    fsys -							}
{    fprocp -							}

label 1;

var
  lsp,lsp1: stp;
  lval: valu;

begin {DoDispose}
{get the pointer to dispose}
Expression(fsys+[rparent,comma],fprocp);

if gattr.typtr <> nil then
  if gattr.typtr^.form = pointerStruct then begin
    {dispose of a pointer}
    Load;
    Gen0t(pc_stk, cgULong);
    Gen1(pc_csp,17{dsp});
    lsp := nil;
    with gattr.typtr^ do
      if eltype <> nil then
	if eltype^.form = records then
          lsp := eltype^.recvar;
    while sy = comma do begin
      InSymbol;
      DoConstant(fsys+[comma,rparent],lsp1,lval);
      if lsp = nil then Error(82)
      else if lsp^.form <> tagfld then
        Error(86)
      else if lsp^.tagfieldp <> nil then
	if CompTypes(lsp^.tagfieldp^.idtype,lsp1) then begin
	  lsp1 := lsp^.fstvar;
	  while lsp1 <> nil do
	    with lsp1^ do
	      if varval = lval.ival then begin
		lsp := subvar;
                goto 1;
		end {if}
	      else
                lsp1 := nxtvar;
	  lsp := nil;
	  end {if}
	else
          Error(44);
1:	end; {while}
    end {if}
  else if gattr.typtr^.form = objects then begin
    {dispose of an object}
    Load;
    if debug then
      GenL2t(pc_chk, 1, maxaddr, cgULong);
    Gen0t(pc_stk, cgULong);
    Gen1(pc_csp,17{dsp});
    end {else if}
  else
    Error(44);
end; {DoDispose}

procedure Abs;
{compile an absolute value function call}

begin {Abs}
if gattr.typtr <> nil then
  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
    Gen0(pc_abi)
  else if IsReal(gattr.typtr) then
    Gen0(pc_abr)
  else if gattr.typtr = longptr then
    Gen0(pc_abl)
  else begin
    Error(51);
    gattr.typtr := intptr;
    end;
end; {Abs}

procedure Sqr;
{compile a call to the square function}

begin {Sqr}
if gattr.typtr <> nil then
  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
    Gen0(pc_sqi)
  else if IsReal(gattr.typtr) then
    Gen0(pc_sqr)
  else if gattr.typtr = longptr then
    Gen0(pc_sql)
  else begin
    Error(51);
    gattr.typtr := intptr;
    end;
end; {Sqr}

procedure TruncRound;
{compile trunc and round calls}

begin {TruncRound}
if gattr.typtr <> nil then
  if not IsReal(gattr.typtr) then
    Error(51);
if lkey = 3{trunc} then begin
  Gen2(pc_cnv,ord(cgReal),ord(cgWord));
  gattr.typtr := intptr;
  end {if}
else if lkey = 42{trunc4} then begin
  Gen2(pc_cnv,ord(cgReal),ord(cgLong));
  gattr.typtr := longptr;
  end {else if}
else if lkey = 43{round4} then begin
  Gen0(pc_rn4);
  gattr.typtr := longptr;
  end {else if}
else begin
  Gen0(pc_rnd);
  gattr.typtr := intptr;
  end; {else}
end; {TruncRound}

procedure DoOdd;
{compile a call to the odd function}

begin {DoOdd}
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
  Gen0(pc_odd)
else if gattr.typtr = longptr then
  Gen0(pc_odl)
else
  Error(51);
gattr.typtr := boolptr;
end; {DoOdd}

procedure DoOrd;
{compile the ord function}

begin {DoOrd}
if gattr.typtr <> nil then
  if gattr.typtr^.form > pointerStruct then
    Error(51)
  else if (gattr.typtr^.form = pointerStruct) or (gattr.typtr = longptr) then
    begin
    if iso then Error(112);
    Gen2(pc_cnv,ord(cgLong),ord(cgWord));
    end
  else if not (GetType(gattr.typtr, gattr.isPacked)
    in [cgByte,cgUByte,cgWord,cgUWord]) then
    Error(51);
gattr.typtr := intptr;
end; {DoOrd}

procedure DoOrd4;

{ compile the ord4 function					}

begin {DoOrd4}
if gattr.typtr <> nil then
   if gattr.typtr^.form > pointerStruct then
      Error(51)
   else if GetType(gattr.typtr, gattr.isPacked)
      in [cgByte,cgUByte,cgWord,cgUWord] then
      Gen2(pc_cnv,ord(cgWord),ord(cgLong))
   else if not (GetType(gattr.typtr, gattr.isPacked) in [cgLong,cgULong]) then
      Error(51);
gattr.typtr := longptr;
end; {DoOrd4}

procedure DoPointer;
{compile the Pointer function}

begin {DoPointer}
if gattr.typtr <> nil then
  if gattr.typtr^.form > pointerStruct then
    Error(51)
  else if (gattr.typtr^.form <> pointerStruct) and (gattr.typtr <> longptr)
    then
    Gen2(pc_cnv,ord(cgWord),ord(cgLong));
  {else the value is already 4 bytes}
gattr.typtr := nilptr;
end; {DoPointer}

procedure DoChr;
{compile a call to the chr function}

begin {DoChr}
if gattr.typtr <> nil then
  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(51);
{gen0(59( chr ));}
gattr.typtr := charptr;
end; {DoChr}

procedure PredSucc;
{compile a call to pred or succ}

begin {PredSucc}
if gattr.typtr <> nil then
  if (gattr.typtr^.form <> scalar) or IsReal(gattr.typtr) then
    Error(51);
if lkey = 8{pred} then
  Gen1t(pc_dec, 1, GetType(gattr.typtr, gattr.isPacked))
else
  Gen1t(pc_inc, 1, GetType(gattr.typtr, gattr.isPacked));
CheckBnds(gattr.typtr);
end; {PredSucc}

procedure DoEOF (fsys: setofsys; fprocp: ctp);

{ compile a call to eof or eoln					}
{								}
{ Parameters:							}
{    fsys -							}
{    fprocp -							}

begin {DoEOF}
if sy = lparent then begin

   {handle a call for a given file}
   InSymbol;
   Variable(fsys + [rparent],fprocp);
   Match(rparent,4);
   if lkey = 11{eoln} then
      if gattr.typtr <> textptr then
         Error(44);
   if gattr.typtr <> nil then
      if gattr.typtr^.form <> files then
         Error(51);
   if glcp = inptr then
      if lkey=10{eof} then
	 Gen1tName(pc_ldo, 0, cgUWord, @'~EOFINPUT')
      else
	 Gen1tName(pc_ldo, 0, cgUWord, @'~EOLNINPUT')
   else begin
      Load;
      Gen0t(pc_stk, cgULong);
      Gen1t(pc_csp, 38+lkey{eof,eol}, cgUByte);
      end; {else}
   end {if}
else begin

   {handle a call for standard in}
   if noinput then
      Error(91);
   Gen0(pc_nop);
   Gen1t(pc_csp, 175+lkey{eof,eol}, cgUByte);
   end; {else}
gattr.typtr := boolptr;
end; {DoEOF}


procedure trans;
{compile transendental functions}

var
  tkey: keyrange;		      {so we can change the number}

begin {trans}
tkey := lkey;
if gattr.typtr <> nil then
  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then begin
    gen2(pc_cnv,ord(cgWord),ord(cgReal));
    gattr.typtr := realptr;
    end
  else if gattr.typtr = longptr then begin
    Gen2(pc_cnv,ord(cgLong),ord(cgReal));
    gattr.typtr := realptr;
    end;
if not IsReal(gattr.typtr) then
  Error(59);
case tkey of
   12: Gen0(pc_sin);
   13: Gen0(pc_cos);
   14: Gen0(pc_exp);
   15: Gen0(pc_sqt);
   16: Gen0(pc_log);
   17: Gen0(pc_atn);
   36: Gen0(pc_tan);
   37: Gen0(pc_acs);
   38: Gen0(pc_asn);
   otherwise:
     Error(113);
   end; {case}
end; {trans}

procedure DoArctan2(fsys: setofsys; fprocp: ctp);
{compile a call to Arctan2}

begin {DoArctan2}
Match(lparent,9);
Expression(fsys+[comma,rparent],fprocp);
Load;
if gattr.typtr <> nil then
  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then begin
    gen2(pc_cnv,ord(cgWord),ord(cgReal));
    gattr.typtr := realptr;
    end
  else if gattr.typtr = longptr then begin
    Gen2(pc_cnv,ord(cgLong),ord(cgReal));
    gattr.typtr := realptr;
    end;
if not IsReal(gattr.typtr) then
  Error(59);
Match(comma,20);
Expression(fsys+[rparent],fprocp);
Load;
if gattr.typtr <> nil then
  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then begin
    gen2(pc_cnv,ord(cgWord),ord(cgReal));
    gattr.typtr := realptr;
    end
  else if gattr.typtr = longptr then begin
    Gen2(pc_cnv,ord(cgLong),ord(cgReal));
    gattr.typtr := realptr;
    end;
if not IsReal(gattr.typtr) then
  Error(59);
Gen0(pc_at2);
end; {DoArctan2}

procedure DoUserID;
{compile a call to UserID}

begin {DoUserID}
Gen1tName(pc_ldo, 0, cgUWord, @'~USER_ID');
gattr.typtr := intptr;
end; {DoUserID}

procedure ToolError;
{compile a call to tollerror}

begin {ToolError}
Gen1tName(pc_ldo, 0, cgUWord, @'~TOOLERROR');
gattr.typtr := intptr;
end; {ToolError}

procedure Cnvfs(fsys: setofsys; fprocp: ctp);
{compile a call to Cnvrs or Cnvds}

begin {Cnvfs}
{load the value to convert}
Match(lparent,9);
Expression(fsys+[comma,rparent],fprocp);
Load;
if gattr.typtr <> nil then
  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then begin
    Gen2(pc_cnv,ord(cgWord),ord(cgReal));
    gattr.typtr := realptr;
    end
  else if (gattr.typtr = longptr) then begin
    Gen2(pc_cnv,ord(cgLong),ord(cgReal));
    gattr.typtr := realptr;
    end;
if not IsReal(gattr.typtr) then
  Error(59);
Gen0t(pc_stk, cgExtended);
{load the two required field widths}
Match(comma,20);
Expression(fsys+[comma,rparent],fprocp);
Load;
Gen0t(pc_stk, cgWord);
Gen0t(pc_bno, cgWord);
if gattr.typtr <> nil then begin
  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
  end
else Error(44);
Match(comma,20);
Expression(fsys+[rparent],fprocp);
Load;
Gen0t(pc_stk, cgWord);
Gen0t(pc_bno, cgWord);
if gattr.typtr <> nil then begin
  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
  end
else Error(44);
Gen1t(pc_csp,77{cfs},cgString);
gattr.typtr := stringptr;
gattr.kind := expr;
stringHeap := true;
end; {Cnvfs}

procedure Cnvis;
{compile a call to Cnvis}

begin {Cnvis}
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
  Gen2(pc_cnv,ord(cgWord),ord(cgLong))
else if gattr.typtr <> longptr then Error(44);
Gen0t(pc_stk, cgULong);
Gen1t(pc_csp,78{cis},cgString);
gattr.typtr := stringptr;
gattr.kind := expr;
stringHeap := true;
end; {Cnvis}

procedure CnvSF(fsys: setofsys; fprocp: ctp);
{compile a call to CnvSR or CnvSD}

begin {Cnvsf}
Match(lparent,9);
Expression(fsys+[rparent],fprocp);
if gattr.typtr <> nil then
  if IsString(gattr.typtr) then
    LoadStringAddress
  else Error(44)
else Error(44);
gattr.typtr := realptr;
Gen1t(pc_csp,79{csf},cgReal);
end; {Cnvsf}

procedure CnvSI(fsys: setofsys; fprocp: ctp);
{compile a call to CnvSI}

begin {Cnvsi}
Match(lparent,9);
Expression(fsys+[rparent],fprocp);
if gattr.typtr <> nil then
  if IsString(gattr.typtr) then
    LoadStringAddress
  else Error(44)
else Error(44);
gattr.typtr := intptr;
Gen1t(pc_csp,80{csi},cgWord);
end; {Cnvsi}

procedure CnvSL(fsys: setofsys; fprocp: ctp);
{compile a call to CnvSL}

begin {Cnvsl}
Match(lparent,9);
Expression(fsys+[rparent],fprocp);
if gattr.typtr <> nil then
  if IsString(gattr.typtr) then
    LoadStringAddress
  else Error(44)
else Error(44);
gattr.typtr := longptr;
Gen1t(pc_csp,81{csl},cgLong);
end; {Cnvsl}

procedure Randomf;
{generate a random real or double}

begin {Randomf}
Gen0(pc_nop);
gattr.typtr := realptr;
Gen1t(pc_csp,82{rnf},cgReal);
end; {Randomf}

procedure RandomInteger;
{generate a random integer}

begin {RandomInteger}
Gen0(pc_nop);
gattr.typtr := intptr;
Gen1t(pc_csp,83{rni},cgWord);
end; {RandomInteger}

procedure RandomLongInt;
{generate a random longint}

begin {RandomLongInt}
Gen0(pc_nop);
gattr.typtr := longptr;
Gen1t(pc_csp,83{rni},cgLong);
end; {RandomLongint}

procedure Concat(fsys: setofsys; fprocp: ctp);
{concatonate a series of strings}

var
  numStrings: integer;		      {# of strings to concatonate}
  stop: boolean; 		      {loop termination var}

begin {Concat}
stringHeap := true;
numStrings := 0;
{mark stack so parameters are tagged}
{load the strings}
Match(lparent,9);
repeat
  Expression(fsys+[comma,rparent],fprocp);
  if gattr.typtr <> nil then
    if IsString(gattr.typtr) then
      LoadStringAddress
    else if gattr.typtr = charptr then begin
      Load;
      Gen0t(pc_stk, cgUWord);
      GenLdcLong(-1);
      Gen0t(pc_stk, cgULong);
      Gen0t(pc_bno, cgULong);
      end
    else Error(44)
  else Error(44);
  stop := sy <> comma;
  if not stop then InSymbol;
  numStrings := numStrings+1;
  if numStrings <> 1 then
    Gen0t(pc_bno, cgULong);
until stop or eofl;
Match(rparent,4);
Gen1t(pc_ldc, numStrings, cgWord);
Gen0t(pc_stk, cgWord);
Gen0t(pc_bno, cgWord);
{call the concat function}
Gen1t(pc_csp,85{cat},cgString);
gattr.typtr := stringptr;
gattr.kind := expr;
end; {Concat}

procedure Copy(fsys: setofsys; fprocp: ctp);
{compile a call to copy characters from a string}

begin {Copy}
stringHeap := true;
{load the string to copy characters from}
Match(lparent,9);
Expression(fsys+[comma,rparent],fprocp);
if gattr.typtr <> nil then
  if IsString(gattr.typtr) then
    LoadStringAddress
  else Error(44)
else Error(44);
{load the index}
Match(comma,20);
Expression(fsys+[comma,rparent],fprocp);
Load;
Gen0t(pc_stk, cgWord);
Gen0t(pc_bno, cgWord);
if gattr.typtr <> nil then begin
  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
  end
else Error(44);
{load the number of chars to copy}
Match(comma,20);
Expression(fsys+[rparent],fprocp);
Load;
Gen0t(pc_stk, cgWord);
Gen0t(pc_bno, cgWord);
if gattr.typtr <> nil then begin
  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
  end
else Error(44);
{call the copy function}
Gen1t(pc_csp,86{cpy},cgString);
gattr.typtr := stringptr;
gattr.kind := expr;
end; {Copy}

procedure DoLength(fsys: setofsys; fprocp: ctp);
{compile a call to Length}

begin {DoLength}
{load the string}
Match(lparent,9);
Expression(fsys+[comma,rparent],fprocp);
if gattr.typtr <> nil then
  if IsString(gattr.typtr) then
    LoadStringAddress
  else if gattr.typtr = charptr then begin
    Load;
    Gen0t(pc_stk, cgUWord);
    GenLdcLong(-1);
    Gen0t(pc_stk, cgULong);
    Gen0t(pc_bno, cgULong);
    end
  else Error(44)
else Error(44);
gattr.typtr := intptr;
Gen1t(pc_csp,87{lgt},cgWord);
end; {DoLength}

procedure Pos(fsys: setofsys; fprocp: ctp);
{compile a call to find the position of one string in another}

begin {Pos}
{load the strings}
Match(lparent,9);
Expression(fsys+[comma,rparent],fprocp);
if gattr.typtr <> nil then
  if IsString(gattr.typtr) then
    LoadStringAddress
  else if gattr.typtr = charptr then begin
    Load;
    Gen0t(pc_stk, cgUWord);
    GenLdcLong(-1);
    Gen0t(pc_stk, cgULong);
    Gen0t(pc_bno, cgULong);
    end
  else Error(44)
else Error(44);
Match(comma,20);
Expression(fsys+[rparent],fprocp);
if gattr.typtr <> nil then
  if IsString(gattr.typtr) then
    LoadStringAddress
  else if gattr.typtr = charptr then begin
    Load;
    Gen0t(pc_stk, cgUWord);
    GenLdcLong(-1);
    Gen0t(pc_stk, cgULong);
    Gen0t(pc_bno, cgULong);
    end
  else Error(44)
else Error(44);
Gen0t(pc_bno, cgWord);
{call the pos function}
Gen1t(pc_csp,88{pos},cgWord);
gattr.typtr := intptr;
end; {Pos}


procedure DoMember (fsys: setofsys; fprocp: ctp);

{ Compile a call to the member function				}
{								}
{ paremeters:							}
{    fsys - follow symbols					}
{    fprocp - identifier for program or program-level		}
{       subroutine contining this statement			}

var
  lcp: ctp;				{work identifier}

begin {DoMember}
Match(lparent, 9);
Expression(fsys+[comma], fprocp);
Load;
Match(comma,20);
if sy = ident then begin
  SearchId([types], lcp);
  InSymbol;
  if lcp <> nil then
    if lcp^.idtype <> nil then
      if gattr.typtr <> nil then begin
	Gen0t(pc_stk, cgULong);
	if CompObjects(lcp^.idtype, gattr.typtr) then
	  Gen1t(pc_ldc, lcp^.idtype^.objlevel, cgUWord)
        else               
	  Gen1t(pc_ldc, 0, cgUWord);
	Gen0t(pc_stk, cgUWord);
	Gen0t(pc_bno, cgUWord);
        Gen1t(pc_csp, 117{mbr}, cgUWord);
        end; {if}
  end {if}
else
  Error(2);
gattr.typtr := boolptr;
end; {DoMember}

{-- Externally available subroutines ------------------------------------------}

procedure Call {fsys: setofsys; fcp,fprocp: ctp};

{ generate a call to a procedure or function			}
{								}
{ parameters:							}
{    fsys - follow symbols					}
{    fcp -							}
{    fprocp -							}

var
  tkey: keyrange;		      {for saving lkey on recursive fn calls}

begin {Call}
tkey := lkey;
if fcp^.pfdeckind = standard then begin
  lkey := fcp^.key;
  if fcp^.klass = proc then begin

    {compile standard procedure calls}
    if iso then
      if lkey in [3,4,12,16,18..29] then
        Error(112);
    if not(lkey in [7,8,13..15,28,29]) then
      Match(lparent,9);
    case lkey of
      1,2,4: getputclose(fsys,fprocp);
      3,5,6: resetrewriteopen(fsys,fprocp);
      7,13: DoRead(fsys,fprocp);
      8,14: DoWrite(fsys,fprocp);
      9:    DoPack(fsys,fprocp);
      10:   DoUnpack(fsys,fprocp);
      11:   DoNew(fsys,fprocp);
      17:   DoDispose(fsys,fprocp);
      15:   page(fsys,fprocp);
      19:   seek(fsys,fprocp);
      20,21: HaltSeed(fsys,fprocp);
      22:   Delete(fsys,fprocp);
      23:   Insert(fsys,fprocp);
      24,25: CommandLineShellID(fsys,fprocp);
      26,27: StartGraphDesk(fsys,fprocp);
      28,29: EndGraphDesk;
      end; {case}
    if not(lkey in [7,8,13..15,28,29]) then
      Match(rparent,4);
    end
  else begin

    {compile standard function calls}
    if iso then
      if lkey in [18..44] then
        Error(112);
    if not(lkey in [10,11,19,21..34,39..41,44]) then begin
      Match(lparent, 9);
      Expression(fsys+[rparent], fprocp);
      Load;
      end; {if}
    case lkey of
      1:     abs;
      2:     sqr;
      3,4,42,43: truncround;
      5:     DoOdd;
      6:     DoOrd;
      7:     DoChr;
      8,9:   predsucc;
      10,11: DoEOF(fsys,fprocp);
      12,13,14,15,16,17,36,37,38: trans;
      18:    DoOrd4;
      19,32: Cnvfs(fsys,fprocp);
      20:    Cnvis;
      21,33: Cnvsf(fsys,fprocp);
      22:    Cnvsi(fsys,fprocp);
      23:    Cnvsl(fsys,fprocp);
      24,31: Randomf;
      25:    RandomInteger;
      26:    RandomLongInt;
      27:    Concat(fsys,fprocp);
      28:    Copy(fsys,fprocp);
      29:    DoLength(fsys,fprocp);
      30:    Pos(fsys,fprocp);
      34:    DoUserID;
      35:    DoPointer;
      39:    DoArctan2(fsys,fprocp);
      40:    ToolError;
      41:    DoSizeof;
      44:    DoMember(fsys, fprocp);
      end;
    if not (lkey in [10,11,24..27,31,34,40]) then
      Match(rparent,4);
    end;
  end {else}
else
  CallNonStandard(fsys, fcp, fprocp, 0, cStandard);
lkey := tkey;
end; {Call}


procedure CallNonStandard {fsys: setofsys; fcp,fprocp: ctp; odisp: longint;
  callKind: callKinds};

{ Handle a call to a user defined procedure/function		}
{								}
{ parameters:							}
{    fsys -							}
{    fcp -							}
{    fprocp -							}
{    odisp - disp in object for method calls; else 0		}
{    callKind - type of this call				}

label 1,2,3;

var
  nxt,lcp: ctp;
  lattr: attr;				{for forming fake parm types}
  lsp: stp;
  i: integer;
  typeNum: baseTypeEnum;
  pcount: unsigned;			{number of parameters processed}


  procedure CheckParm (lcp1,lcp2: ctp);

  { insure that the parm list matches the definition		}
  {								}
  { parameters:							}
  {    lcp1, lcp2 - parameter lists to check			}

  label 1;

  begin {CheckParm}
  if lcp1 = nil then begin
    if lcp2 <> nil then Error(52);
    end
  else begin
    while lcp1 <> nil do begin
      if lcp2 = nil then begin Error(52); goto 1; end;
      if (lcp1^.idtype <> lcp2^.idtype) or (lcp1^.klass<>lcp2^.klass)
	then begin Error(59); goto 1; end
      else begin
	if lcp1^.klass = varsm then begin
	  if (lcp1^.vkind <> lcp2^.vkind) or
	    (lcp1^.vitem <> lcp2^.vitem) then
	    begin Error(59); goto 1; end
	  end
	else {lcp1^.klass = proc or func} begin
	  CheckParm(lcp1^.pfnext,lcp2^.pfnext);
	  if lcp1^.klass = func then
	    if lcp1^.idtype <> lcp2^.idtype then Error(53);
	  end;
	end;
      lcp1 := lcp1^.next;
      lcp2 := lcp2^.next;
      end;
    if lcp2 <> nil then begin Error(52); goto 1; end;
    end;
1:  end; {CheckParm}


begin {CallNonStandard}
{get the head of the parameter list; preload indirect call addresses}
with fcp^ do
  if pfkind = formal then begin
    nxt := pfnext;
    if callKind = cStandard then begin
      Gen3t(pc_lod, pflabel, 0, level-pflev, cgULong);
      Gen3t(pc_lod, pflabel, 4, level-pflev, cgUWord);
      Gen0t(pc_bno, cgUWord);
      end; {if}
    end {if}
  else begin
    nxt := pfparms;
    if callKind <> cStandard then
      nxt := nxt^.next; {skip SELF}
    end; {else}                       

{for methods, the 'SELF' parameter has already been pushed}
if callKind in [cMethod,cInherited] then
  pcount := 1
else
  pcount := 0;

{compile the call's parameter list}
if sy = lparent then begin
  repeat
    InSymbol;
    {check for too many parms}
    if nxt = nil then begin
      Error(52);
      goto 1;
      end;
    {handle procs and funcs in parm list}
    if nxt^.klass in [proc,func] then begin
      if sy <> ident then begin
	Error(2);
	Skip(fsys + [comma,rparent]);
	end
      else begin
	if nxt^.klass = proc then
          SearchId([proc],lcp)
	else begin
	  SearchId([func],lcp);
	  if lcp^.idtype <> nxt^.idtype then
            Error(53);
	  end; {else}
	if lcp <> nil then with lcp^ do begin
	  if pfkind = formal then begin
	    CheckParm(pfnext,nxt^.pfnext);
            Gen3t(pc_lod, pflabel, 4, level-pflev, cgUWord);
	    Gen0t(pc_stk, cgUWord);
	    if pcount <> 0 then
	      Gen0t(pc_bno, cgUWord);
	    pcount := pcount+1;
	    Gen3t(pc_lod, pflabel, 0, level-pflev, cgULong);
	    end {if}
	  else begin
	    CheckParm(pfparms, nxt^.pfnext);
            Gen1(pc_lsl, level-pflev);
	    Gen0t(pc_stk, cgUWord);
	    if pcount <> 0 then
	      Gen0t(pc_bno, cgUWord);
	    pcount := pcount+1;
	    if pflev = 1 then
	      Gen0Name(pc_lad,lcp^.name)
	    else
	      Gen1(pc_lla, pfname);
	    end;
	  Gen0t(pc_stk, cgULong);
	  end;
	InSymbol;
	if not (sy in fsys + [comma,rparent]) then begin
	  Error(6);
	  Skip(fsys + [comma,rparent]);
	  end;
	end;
      goto 2;
      end;
    {handle expressions in parm list}
    if sy = stringConst then
      if nxt <> nil then
	if nxt^.vkind = actual then
	  if IsString(nxt^.idtype) then begin
	    if StrLen(nxt^.idtype) < 0 then
	      LoadString(lengthString)
	    else
	      LoadString(nullString);
	    InSymbol;
	    goto 3;
	    end; {if}
1:  Expression(fsys + [comma,rparent],fprocp);
3:  if gattr.typtr <> nil then
      if nxt <> nil then begin
	lsp := nxt^.idtype;
	if lsp <> nil then begin
	  if (nxt^.vkind = actual) then begin
	    if lsp^.form <= power then begin
	      if gattr.typtr^.form <= power then
		Load
	      else
		LoadAddress;
	      CheckBnds(lsp);
	      if IsReal(lsp) then begin
		if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
		  begin
		  Gen2(pc_cnv,ord(cgWord),ord(cgExtended));
		  gattr.typtr := realptr;
		  end
		else if gattr.typtr = longptr then begin
		  Gen2(pc_cnv,ord(cgLong),ord(cgExtended));
		  gattr.typtr := realptr;
		  end;
		end
	      else if lsp = longptr then begin
		if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
		  begin
		  Gen2(pc_cnv, ord(cgWord), ord(cgLong));
		  gattr.typtr := longptr;
		  end;
                end {else if}
              else if nxt^.vuniv then
                if ParmSize(lsp, actual) = 4 then
                  if ParmSize(gattr.typtr, actual) = 2 then begin
		    Gen2(pc_cnv, ord(cgWord), ord(cgLong));
		    gattr.typtr := longptr;
                    end; {if}
              case GetType(gattr.typtr, gattr.isPacked) of
		cgByte,cgUByte,cgWord,cgUWord:
		  Gen0t(pc_stk, cgWord);
                cgLong,cgULong,cgString:
		  Gen0t(pc_stk, cgLong);
		cgReal,cgDouble,cgComp,cgExtended:
		  Gen0t(pc_stk, cgExtended);
                cgSet:
		  Gen1(pc_siz, ord(lsp^.size));
		otherwise: ;
		end; {case}
	      end
	    else if gattr.typtr^.form = objects then begin
	      Load;
	      if debug then
		GenL2t(pc_chk, 1, maxaddr, cgULong);
	      Gen0t(pc_stk, cgULong);
              end {else if}
	    else if gattr.typtr^.form = records then begin
	      {value records <= 4 bytes passed by value; otherwise    }
	      { pass an address					      }
	      if gattr.typtr^.size <= 4 then
		if gattr.typtr^.size <= 2 then begin
		  lattr := gattr;
		  gattr.typtr := intptr;
		  Load;
		  Gen0t(pc_stk, cgWord);
		  gattr := lattr;
		  end {if}
		else begin
		  lattr := gattr;
		  gattr.typtr := longptr;
		  Load;
		  Gen0t(pc_stk, cgLong);
		  gattr := lattr;
		  end {else}
	      else begin
		LoadAddress;
		Gen0t(pc_stk, cgULong);
		end;
	      end {else if}
            else if IsString(lsp) then begin
              if gattr.kind = expr then begin
	        LoadAddress;
	        Gen0t(pc_stk, cgULong);
                if StrLen(lsp) < 0 then
                  Gen1t(pc_csp, 119{fxp}, cgULong)
                else
                  Gen1t(pc_csp, 120{fxc}, cgULong);
                end {if}
              else
	        LoadAddress;
	      Gen0t(pc_stk, cgULong);
	      end {else if}
	    else begin
	      LoadAddress;
	      Gen0t(pc_stk, cgULong);
	      end; {else}
	    if not CompTypes(lsp,gattr.typtr) then
	      if (ParmSize(lsp,actual) <> ParmSize(gattr.typtr,actual)) then
		Error(67);
	    end
	  else begin
	    if lsp <> gattr.typtr then
	      if not nxt^.vuniv then
		Error(67);
	    if gattr.kind = varbl then begin
	      LoadAddress;
	      Gen0t(pc_stk, cgULong);
	      end {if}
	    else
	      Error(78);
	    if glcp <> nil then with glcp^ do begin
	      if klass = varsm then begin
		if vcontvar then Error(97);
		if vlev <> level then vrestrict := true;
		end
	      else if klass = field then
		if fldvar then Error(95);
	      end;
	    if gispacked then Error(95);
	    end;
	  end
	end;
2:  {next parm in definition}
    if nxt <> nil then
      nxt := nxt^.next;
    if pcount <> 0 then
      Gen0t(pc_bno, cgWord);
    pcount := pcount+1;
  until sy <> comma;
  Match(rparent,4);
  end; {if}
if pcount = 0 then
  Gen0(pc_nop);

{check for not enough parameters}
if nxt <> nil then
  Error(52);

{generate the call}
with fcp^ do begin
  if klass <> func then
    typeNum := cgVoid
  else begin
    if idtype = realptr then
      typeNum := cgReal
    else if idtype = doubleptr then
      typeNum := cgDouble
    else if idtype = compptr then
      typeNum := cgComp
    else if idtype = extendedptr then
      typeNum := cgExtended
    else if idtype = longptr then
      typeNum := cgLong
    else if idtype^.form = pointerStruct then
      typeNum := cgULong
    else
      typeNum := cgWord;
    end; {else}
  if callKind = cMethod then
    GenL1t(pc_cum, odisp, typeNum)
  else if pfkind = formal then
    Gen0t(pc_cui, typeNum)
  else {if pfkind = actual then}
    case pfdirective of
      drnone,drforw,drextern: {standard calls}
	if pflev = 1 then
	  Gen1tName(pc_cup, level-pflev, typeNum, fcp^.pfoname)
	else
	  Gen2t(pc_cup, pfname, level-pflev, typeNum);
      drprodos: {in line prodos call}
	Gen1(pc_pds, pfcallnum);
      drtool1,drtool2,drvector: begin {in line tool call with passed parms}
	if pfdirective = drtool1 then
	   Gen2t(pc_tl1, pftoolnum, pfcallnum, typeNum)
	else if pfdirective = drtool2 then
	   Gen2t(pc_tl2, pftoolnum, pfcallnum, typeNum)
	else
           Gen1L1t(pc_vct, pfcallnum, pfaddr, typeNum);
	if klass = func then
	  if idtype = boolptr then begin
	    Gen1t(pc_ldc, 0, cgWord);
	    Gen0t(pc_neq, cgWord);
	    end; {if}
	end;
      end; {case}
  end;
{for functions, set the return type}
gattr.typtr := fcp^.idtype
end; {CallNonStandard}


procedure CheckBool;
{load a value, insuring that it is boolean}

begin {CheckBool}
load;
if gattr.typtr <> nil then
  if gattr.typtr <> boolptr then Error(60);
end; {CheckBool}

procedure CheckBnds{fsp: stp};
{generate range checking code (if needed)}

var
  lmin,lmax: integer;

begin {CheckBnds}
if debug then
  if fsp <> nil then
    if fsp = charptr then
      Gen2t(pc_chk, ordminchar, ordmaxchar, cgUWord)
    else if fsp^.form = subrange then
      if fsp^.rangetype = longptr then
        GenL2t(pc_chk, fsp^.min, fsp^.max, cgULong)
      else
        Gen2t(pc_chk, long(fsp^.min).lsw, long(fsp^.max).lsw, cgUWord);
end; {CheckBnds}


procedure FreeTemp{labelNum, size: integer};

{ place a temporary label in the available label list		}
{								}
{ parameters:							}
{    labelNum - number of the label to free			}
{    size - size of the variable 				}
{								}
{ variables:							}
{    tempList - list of free labels				}

var
   tl: tempPtr;				{work pointer}

begin {FreeTemp}
new(tl);
tl^.next := tempList;
tl^.last := nil;
tl^.labelNum := labelNum;
tl^.size := size;
if tempList <> nil then
   tempList^.last := tl;
tempList := tl;
end; {FreeTemp}


function GetTemp{size: integer): integer};

{ find a temporary work variable 				}
{								}
{ parameters:							}
{    size - size of the variable 				}
{								}
{ variables:							}
{    tempList - list of free labels				}
{								}
{ Returns the label number.					}

label 1;

var
   ln: integer;				{label number}
   tl: tempPtr;				{work pointer}

begin {GetTemp}
{try to find a temp from the existing list}
tl := tempList;
while tl <> nil do begin
   if tl^.size = size then begin

      {found an old one - use it}
      if tl^.last = nil then
	 tempList := tl^.next
      else
	 tl^.last^.next := tl^.next;
      if tl^.next <> nil then
	 tl^.next^.last := tl^.last;
      GetTemp := tl^.labelNum;
      goto 1;
      end; {if}
   tl := tl^.next;
   end; {while}

{none found - get a new one}
ln := GetLocalLabel;
GetTemp := ln;
Gen2(dc_loc, ln, size);
1:
end; {GetTemp}


procedure Load;
{load a value onto the evaluation stack}

var
  lmt: addrrange;			{temp disp}
  ltype: stp;				{base type}

begin {Load}
with gattr do
  if typtr <> nil then begin
    ltype := typtr;
    if ltype^.form = subrange then
      ltype := ltype^.rangetype;
    case kind of
      cst:   if (ltype^.form = scalar) and (not IsReal(ltype)) then
	       if ltype = boolptr then
		 Gen1t(pc_ldc, cval.ival, cgUWord)
	       else if ltype=charptr then
		 Gen1t(pc_ldc, cval.ival, cgUWord)
	       else if ltype = longptr then
		 GenLdcLong(cval.valp^.lval)
	       else if cval.ival >= 0 then
		 Gen1t(pc_ldc, cval.ival, cgUWord)
               else
		 Gen1t(pc_ldc, cval.ival, cgWord)
	     else if ltype = nilptr then
	       GenLdcLong(0)
	     else if IsReal(ltype) then
	       GenLdcReal(cval.valp^.rval)
	     else
	       GenLdcSet(cval.valp^);
      varbl: begin
	     if access = drct then
	       if dpdisp > maxint then begin
		 lmt := dpdisp;
		 if vlevel <= 1 then
		   Gen1Name(pc_lao, 0, aname)
		 else
		   Gen3(pc_lda, gattr.dplab, 0, 0);
		 access := indrct;
		 idplmt := lmt;
		 end; {if}
	     case access of
	       drct:   if ltype^.form = power then begin
			 if vlevel<=1 then
			   Gen2tName(pc_ldo, long(dpdisp).lsw, ord(typtr^.size),
			     cgSet, aname)
			 else
			   Gen4t(pc_lod, gattr.dplab, long(dpdisp).lsw,
                             level-vlevel, ord(typtr^.size), cgSet);
			 end {if}
		       else begin
			 if vlevel<=1 then
			   Gen1tName(pc_ldo, long(dpdisp).lsw,
                             GetType(typtr, isPacked), aname)
			 else
			   Gen3t(pc_lod, gattr.dplab, long(dpdisp).lsw,
                             level-vlevel, GetType(typtr, isPacked));
			 end; {else}
	       indrct: begin
		       if idplmt >= maxint then begin
			 GenLdcLong(idplmt);
			 Gen0(pc_adl);
			 idplmt := 0;
			 end; {if}
		       if ltype^.form = power then
			 Gen2t(pc_ind, ord(idplmt), ord(typtr^.size), cgSet)
		       else
			 Gen1t(pc_ind, ord(idplmt), GetType(typtr, isPacked));
		       end;
	       inxd:   Error(113)
	       end; {case}
             end;
      otherwise:
      end;
    typtr := ltype;
    kind := expr;
    end;
end; {Load}

procedure LoadAddress;
{load the address of a variable onto the top of the stack}

var
  lmt: addrrange;			{temp disp}

begin {LoadAddress}
with gattr do
  if typtr <> nil then begin
    if typtr^.form = subrange then
      typtr := typtr^.rangetype;
    case kind of
      cst:   if IsString(typtr) then
	       GenPS(pc_lca, @cval.valp^.sval)
	     else
	       Error(113);
      varbl: begin
	     if access = drct then
	       if dpdisp > maxint then begin
		 lmt := dpdisp;
		 if vlevel <= 1 then
		   Gen1Name(pc_lao, 0, aname)
		 else
		   Gen3(pc_lda, gattr.dplab, 0, 0);
		 access := indrct;
		 idplmt := lmt;
		 end; {if}
	     case access of
	       drct:   if vlevel <= 1 then
			 Gen1Name(pc_lao, long(dpdisp).lsw, aname)
		       else
			 Gen3(pc_lda, dplab, level-vlevel, long(dpdisp).lsw);
	       indrct: begin
		       if idplmt >= maxint then begin
			 GenLdcLong(idplmt);
			 Gen0(pc_adl);
			 end {if}
		       else
			 Gen1t(pc_inc,ord(idplmt),cgULong);
		       end;
	       inxd:   Error(113)
	       end; {case}
	     end;
      expr:  if typtr <> stringPtr then Error(113);
      end;
    kind := varbl;
    access := indrct;
    idplmt := 0;
    end
end; {LoadAddress}

procedure LoadStringAddress;
{load the address and length of a string}

var
  lattr: attr;

begin {LoadStringAddress}
lattr := gattr;
LoadAddress;
Gen0t(pc_stk, cgULong);
if lattr.kind <> expr then begin
  Gen1t(pc_ldc, StrLen(gattr.typtr), cgUWord);
  Gen0t(pc_stk, cgUWord);
  Gen0t(pc_bno, cgUWord);
  end; {if}
end; {LoadStringAddress}

procedure LoadString {kind: stringKind};

{ load the address of a string constant				}
{								}
{ parameters:							}
{    kind - string kind						}

var
   i: unsigned;				{loop variable}
   len: unsigned;			{length of the string}
   tch: char;				{temp for building string from char}

begin {LoadString}
if lgth = 1 then begin			{if the length is 1, make a string   }
   tch := chr(val.ival); 		{ from a character		     }
   val.valp := pointer(Malloc(sizeof(constantRec)));
   with val.valp^ do begin
      cclass := strg;
      sval[0] := chr(1);
      sval[1] := tch;
      end; {with}
   end; {if}
with val.valp^ do begin
   if lgth = 0 then begin		{for a nul string, use two zeros}
      sval[0] := chr(2);
      sval[1] := chr(0);
      sval[2] := chr(0);
      end {if}
   else if kind = lengthString then begin {add the length byte}
      len := length(sval);
      for i := len downto 1 do
	 sval[i+1] := sval[i];
      sval[1] := sval[0];
      sval[0] := chr(len+2);
      end {else}
   else					{bump the length for the null terminator}
      sval[0] := succ(sval[0]);
   sval[ord(sval[0])] := chr(0);	{place a trailing nul on the string}
   gattr.cval := val;			{set up for the load}
   gattr.typtr := stringptr;
   gattr.kind := cst;
   gattr.isPacked := false;
   end; {with}
end; {LoadString}


function ParmSize {lsp: stp; vkind: idkind): integer};

{ find the length of a parameter				}
{								}
{ parameters:							}
{    lsp -							}
{    vkind -							}
{								}
{ Returns: stack size of parameter, in bytes			}

begin {ParmSize}
ParmSize := ptrsize;
if lsp <> nil then
  with lsp^ do
    if vkind = actual then
      if form <= power then begin
	ParmSize := ord(size);
	if IsReal(lsp) then
	  ParmSize := extSize
	else if lsp = byteptr then
	  ParmSize := intSize;
	end {if}
      else if form = records then
	if size <= 2 then
	  ParmSize := 2;
end; {ParmSize}


procedure ResetTemp;

{ forget all of the temporary work variables			}

var
   tl: tempPtr;				{work pointer}

begin {ResetTemp}
while tempList <> nil do begin
  tl := tempList;
  tempList := tl^.next;
  dispose(tl);
  end; {while}
end; {ResetTemp}


procedure Store{var fattr: attr};
{store the value on top of stack}

var
  lmt: addrrange;			{temp disp}

begin {Store}
with fattr do
  if typtr <> nil then begin
    case access of
      drct:   if typtr^.form = power then begin
		if vlevel <= 1 then
		  Gen2tName(pc_sro, long(dpdisp).lsw, ord(typtr^.size), cgSet,
		    aname)
		else
		  Gen4t(pc_str, dplab, long(dpdisp).lsw, level-vlevel,
		    ord(typtr^.size), cgSet);
		end
	      else begin
		if vlevel <= 1 then
		  Gen1tName(pc_sro, long(dpdisp).lsw, GetType(typtr, isPacked),
                    aname)
		else
		  Gen3t(pc_str, dplab, long(dpdisp).lsw, level-vlevel,
		    GetType(typtr, isPacked));
		end;
      indrct: begin
	      if typtr^.form = power then
		Gen1t(pc_sto, ord(typtr^.size), cgSet)
	      else
		Gen0t(pc_sto, GetType(typtr, isPacked));
	      end;
      inxd:   Error(113)
      end; {case}
    end; {if}
end; {Store}

end.
\ No newline at end of file
+{$optimize 15}
+{------------------------------------------------------------}
+{							     }
+{  ORCA/Pascal Call Procedure				     }
+{							     }
+{  The call procedure handles parsing, semantic analysis     }
+{  and code generation for all procedure and function calls. }
+{  This includes both user-defined and predeclared	     }
+{  routines.						     }
+{							     }
+{  By Mike Westerfield					     }
+{							     }
+{  Copyright March 1988					     }
+{  By the Byte Works, Inc.				     }
+{							     }
+{------------------------------------------------------------}
+
+unit Call;
+
+interface
+
+{$segment 'Pascal2'}
+{$LibPrefix '0/obj/'}
+
+uses pcommon, scanner, cgi, symbols;
+
+{-- Externally available variables --------------------------------------------}
+
+type
+					{subroutine calls}
+                                        {----------------}
+  callKinds = (cStandard, cMethod, cInherited);
+
+					{temporary variable allocation}
+					{-----------------------------}
+  tempPtr = ^tempRecord;
+  tempRecord = record
+    last,next: tempPtr;			{doubly linked list}
+    labelNum: integer; 			{label number}
+    size: integer;			{size of the variable}
+    end;
+
+var
+  psize: integer;			{size of the parameter space for the current stack frame}
+  lc: addrrange; 			{current stack frame size}
+
+					{temporary variable allocation}
+					{-----------------------------}
+  tempList: tempPtr;			{list of temp work variables}
+
+{-- Externally available subroutines ------------------------------------------}
+
+procedure Call (fsys: setofsys; fcp,fprocp: ctp);
+
+{ generate a call to a procedure or function			}
+{								}
+{ parameters:							}
+{    fsys -							}
+{    fcp -							}
+{    fprocp -							}
+
+
+procedure CallNonStandard (fsys: setofsys; fcp,fprocp: ctp; odisp: longint;
+  callKind: callKinds);
+
+{ Handle a call to a user defined procedure/function		}
+{								}
+{ parameters:							}
+{    fsys -							}
+{    fcp -							}
+{    fprocp -							}
+{    odisp - disp in object for method calls; else 0		}
+{    callKind - type of this call				}
+
+
+procedure CheckBool;
+{load a value, insuring that it is boolean}
+
+procedure CheckBnds(fsp: stp);
+{generate range checking code (if needed)}
+
+procedure FreeTemp (labelNum, size: integer);
+
+{ place a temporary label in the available label list		}
+{								}
+{ parameters:							}
+{    labelNum - number of the label to free			}
+{    size - size of the variable 				}
+{								}
+{ variables:							}
+{    tempList - list of free labels				}
+
+
+function GetTemp (size: integer): integer;
+
+{ find a temporary work variable 				}
+{								}
+{ parameters:							}
+{    size - size of the variable 				}
+{								}
+{ variables:							}
+{    tempList - list of free labels				}
+{								}
+{ Returns the label number.					}
+
+
+procedure Load;
+{load a value onto the evaluation stack}
+
+procedure LoadAddress;
+{load the address of a variable onto the top of the stack}
+
+procedure LoadStringAddress;
+{load the address and length of a string}
+
+procedure LoadString(kind: stringKind);
+{load the address of a string constant}
+
+function ParmSize(lsp: stp; vkind: idkind): integer;
+{find the length of a parameter}
+
+procedure ResetTemp;
+
+{ forget all of the temporary work variables			}
+
+
+procedure Store(var fattr: attr);
+{store the value on top of stack}
+
+{-- Private declarations ------------------------------------------------------}
+
+implementation
+
+const
+  realfw      =	    16;			{field width for reals & doubles}
+  longfw      =	    16;			{field width for long integers}
+  intfw	      =	     8;			{field width for integers}
+  boolfw      =	     8;			{field width for booleans}
+
+var
+  lkey: keyrange;			{proc/func key for std proc compilation}
+{-- Imported subroutines ------------------------------------------------------}
+
+procedure DoConstant(fsys: setofsys; var fsp: stp; var fvalu: valu); extern;
+{compile a constant term}
+
+procedure Expression(fsys: setofsys; fprocp: ctp); extern;
+{compile an expression}
+
+  procedure Selector (fsys: setofsys; fcp,fprocp: ctp; var isMethod: boolean);
+  extern;
+
+  { handle indexing arrays, field selection, dereferencing of	}
+  { pointers, windowing files					}
+  {								}
+  { parameters:							}
+  {    fsys -							}
+  {    fcp -							}
+  {    fprocp -							}
+  {    isMethod - (returned) Did the selection resolve to a	}
+  {       method call?  If so, take no further action.		}
+
+{-- Private subroutines -------------------------------------------------------}
+
+procedure Variable(fsys: setofsys; fprocp: ctp);
+{compile a variable for the parm list of a standard proc/func}
+
+var
+  isMethod: boolean;			{dummy variable for Selector call}
+  lcp: ctp;
+
+begin {Variable}
+if sy = ident then begin
+  SearchId([varsm,field],lcp);
+  InSymbol;
+  end
+else begin
+  Error(2);
+  lcp := uvarptr;
+  end;
+Selector(fsys, lcp, fprocp, isMethod);
+glcp := lcp;
+end; {Variable}
+
+procedure GetPutClose(fsys: setofsys; fprocp: ctp);
+{Compile one of the named standard procs}
+
+begin {GetPutClose}
+{compile the file variable}
+Variable(fsys + [rparent],fprocp);
+{load the file variable}
+Load;
+Gen0t(pc_stk, cgULong);
+{do type checking on file variable}
+if gattr.typtr <> nil then
+  if gattr.typtr^.form <> files then
+    Error(44);
+{generate the standard proc call}
+Gen1(pc_csp,lkey{get,put,opn,cls})
+end; {GetPutClose}
+
+procedure resetrewriteopen(fsys: setofsys; fprocp: ctp);
+
+var
+  key: integer;			   {open kind key; 1->read; 2->write; 3->both}
+  size: longint; 		      {for remembering file size}
+  lsp: stp;			      {file type}
+  fkind: (stin,stout,errout,fileout); {kind of file}
+
+begin {resetrewriteopen}
+{process the file variable}
+Variable(fsys+[comma,rparent],fprocp);
+fkind := fileout;
+if gattr.typtr = nil then
+  Error(44)
+else if gattr.typtr^.form = files then begin
+  size := gattr.typtr^.filtype^.size;
+  if glcp = outptr then begin
+    fkind := stout;
+    if nooutput then Error(92);
+    end
+  else if glcp = inptr then begin
+    fkind := stin;
+    if noinput then Error(91);
+    end
+  else if glcp = erroroutputptr then
+    fkind := errout;
+  end
+else Error(44);
+{determine the type of the open}
+if lkey = 3 then
+  key := 3
+else
+  key := lkey-4;
+case key of
+  1: if fkind in [stout,errout] then Error(44);
+  2: if fkind = stin then Error(44);
+  3: if fkind <> fileout then Error(44);
+  end;
+if gattr.typtr <> nil then
+  if fkind = fileout then begin
+    {load the file variable}
+    LoadAddress;
+    Gen0t(pc_stk, cgULong);
+    {push the open type onto the stack}
+    lsp := glcp^.idtype;
+    if lsp^.form = pointerStruct then lsp := lsp^.eltype;
+    Gen1t(pc_ldc, key+4*ord(lsp=textptr), cgWord);
+    Gen0t(pc_stk, cgWord);
+    Gen0t(pc_bno, cgWord);
+    {load the length of the file}
+    Gen1t(pc_ldc, ord(size), cgWord);
+    Gen0t(pc_stk, cgWord);
+    Gen0t(pc_bno, cgWord);
+    end {if}
+  else begin
+    Gen1t(pc_ldc, ord(fkind), cgWord);
+    Gen0t(pc_stk, cgWord);
+    Gen0t(pc_bno, cgWord);
+    end; {else}
+{if there is another parameter, use it for the file name}
+if sy = comma then begin
+  if iso then Error(112);
+  InSymbol;
+  Expression(fsys+[rparent],fprocp);
+  if gattr.typtr <> nil then
+    if IsString(gattr.typtr) then begin
+      LoadStringAddress;
+      Gen0t(pc_bno, cgULong);
+      end {if}
+    else Error(44)
+  else Error(44);
+  end
+else begin
+  GenLdcLong(0);
+  Gen0t(pc_stk, cgULong);
+  Gen0t(pc_bno, cgULong);
+  Gen1t(pc_ldc, 0, cgWord);
+  Gen0t(pc_stk, cgWord);
+  Gen0t(pc_bno, cgWord);
+  end; {else}
+{open the file}
+if fkind = fileout then
+  Gen1(pc_csp,3{opn})
+else
+  Gen1(pc_csp,115{rdr});
+end; {resetrewriteopen}
+
+procedure seek(fsys: setofsys; fprocp: ctp);
+{Compile the seek statement}
+
+begin {seek}
+Variable(fsys+[comma,rparent],fprocp);
+if gattr.typtr = nil then
+  Error(44)
+else if gattr.typtr^.form <> files then
+  Error(44);
+Load;
+Gen0t(pc_stk, cgULong);
+Match(comma,20);
+Expression(fsys+[rparent],fprocp);
+Load;
+if gattr.typtr <> nil then begin
+  if (gattr.typtr=intptr) or (gattr.typtr=byteptr) then begin
+    Gen2(pc_cnv,ord(cgWord),ord(cgLong));
+    gattr.typtr := longptr;
+    end;
+  if gattr.typtr <> longptr then Error(44);
+  end
+else Error(44);
+Gen0t(pc_stk, cgULong);
+Gen0t(pc_bno, cgULong);
+Gen1(pc_csp,44{sek});
+end; {seek}
+
+procedure page(fsys: setofsys; fprocp: ctp);
+{compile a page procedure call}
+
+var
+  lsp: stp;
+
+begin {page}
+if sy = lparent then begin
+  InSymbol;
+  Variable(fsys+[rparent],fprocp);
+  lsp := gattr.typtr;
+  if lsp <> nil then
+    if lsp = textptr then
+      if sy <> rparent then begin
+	Error(4);
+	Skip(fsys+[rparent]);
+	end
+      else InSymbol
+    else Error(44)
+  else Error(44);
+  if glcp = outptr then begin
+    Gen0(pc_nop);
+    Gen1(pc_csp,32{pag});
+    end {if}
+  else if glcp = erroroutputptr then begin
+    Gen0(pc_nop);
+    Gen1(pc_csp,33{pag});
+    end {else if}
+  else begin
+    Load;
+    Gen0t(pc_stk, cgULong);
+    Gen1(pc_csp,15{pag});
+    end;
+  end
+else begin
+  if nooutput then Error(92);
+  Gen0(pc_nop);
+  Gen1(pc_csp,32{pag});
+  end;
+end; {page}
+
+procedure HaltSeed(fsys: setofsys; fprocp: ctp);
+{compile a call to halt or seed}
+
+begin {HaltSeed}
+Expression(fsys+[rparent],fprocp);
+Load;
+if gattr.typtr <> nil then begin
+  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
+  end
+else Error(44);
+Gen0t(pc_stk, cgWord);
+Gen1(pc_csp,46+lkey);
+end; {HaltSeed}
+
+procedure Delete(fsys: setofsys; fprocp: ctp);
+{compile a call to the delete string procedure}
+
+begin {Delete}
+{load the string to delete characters from}
+Expression(fsys+[comma,rparent],fprocp);
+if gattr.typtr <> nil then
+  if IsString(gattr.typtr) then begin
+    if gattr.kind <> varbl then Error(44);
+    LoadStringAddress;
+    end
+  else Error(44)
+else Error(44);
+{load the index}
+Match(comma,20);
+Expression(fsys+[comma,rparent],fprocp);
+Load;
+Gen0t(pc_stk, cgWord);
+Gen0t(pc_bno, cgWord);
+if gattr.typtr <> nil then begin
+  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then
+    Error(44);
+  end
+else Error(44);
+{load the number of chars to delete}
+Match(comma,20);
+Expression(fsys+[rparent],fprocp);
+Load;
+Gen0t(pc_stk, cgWord);
+Gen0t(pc_bno, cgWord);
+if gattr.typtr <> nil then begin
+  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
+  end
+else Error(44);
+{call the delete procedure}
+Gen1(pc_csp,68{dlt});
+end; {Delete}
+
+procedure Insert(fsys: setofsys; fprocp: ctp);
+{compile a call to insert one string an another}
+
+begin {Insert}
+{load the string to insert characters into}
+Expression(fsys+[comma,rparent],fprocp);
+if gattr.typtr <> nil then
+  if IsString(gattr.typtr) then
+    LoadStringAddress
+  else if gattr.typtr = charptr then begin
+    Load;
+    Gen0t(pc_stk, cgWord);
+    GenLdcLong(-1);
+    Gen0t(pc_stk, cgULong);
+    Gen0t(pc_bno, cgWord);
+    end
+  else Error(44)
+else Error(44);
+{load the string to insert}
+Match(comma,20);
+Expression(fsys+[comma,rparent],fprocp);
+if gattr.typtr <> nil then
+  if IsString(gattr.typtr) then begin
+    if gattr.kind <> varbl then
+      Error(44);
+    LoadStringAddress;
+    Gen0t(pc_bno, cgWord);
+    end
+  else Error(44)
+else Error(44);
+{load the index}
+Match(comma,20);
+Expression(fsys+[comma,rparent],fprocp);
+Load;
+Gen0t(pc_stk, cgWord);
+Gen0t(pc_bno, cgWord);
+if gattr.typtr <> nil then begin
+  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
+  end
+else Error(44);
+{call the insert procedure}
+Gen1(pc_csp,69{ins});
+end; {Insert}
+
+procedure CommandLineShellID(fsys: setofsys; fprocp: ctp);
+{compile a call to CommandLine or ShellID}
+
+begin {CommandLineShellID}
+{load the string to place characters in}
+Expression(fsys+[rparent],fprocp);
+if gattr.typtr <> nil then
+  if IsString(gattr.typtr) then begin
+    if gattr.kind <> varbl then Error(44);
+    LoadStringAddress;
+    end
+  else Error(44)
+else Error(44);
+{call the procedure}
+Gen1(pc_csp,46+lkey);
+end; {CommandLineShellID}
+
+procedure StartGraphDesk(fsys: setofsys; fprocp: ctp);
+{compile a call to StartGraph or StartDesk}
+
+begin {StartGraphDesk}
+Expression(fsys+[rparent],fprocp);
+Load;
+Gen0t(pc_stk, cgWord);
+if gattr.typtr <> nil then begin
+  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then
+    Error(44);
+  end
+else Error(44);
+Gen1(pc_csp,46+lkey);
+end; {StartGraphDesk}
+
+procedure EndGraphDesk;
+{compile a call to EndGraph or EndDesk}
+
+begin {EndGraphDesk}
+Gen0(pc_nop);
+Gen1(pc_csp,46+lkey);
+end; {EndGraphDesk}
+
+procedure DoRead (fsys: setofsys; fprocp: ctp);
+
+{ compile a read procedure call					}
+{								}
+{ Parameters:							}
+{    fsys -							}
+{    fprocp -							}
+
+var
+   lattr,tattr: attr;
+   lsp : stp;
+   needBno: boolean;			{do we need a pc_bno?}
+   test: boolean;
+   standardIn: boolean;		        {is the read from standard input?}
+   llb: unsigned; 		        {for allocating temporary space}
+   inLocalPtr: boolean;		        {is file ptr in local area?}
+
+begin {DoRead}
+inLocalPtr := false;
+standardIn := true;
+lattr.typtr := textptr;
+if sy = lparent then begin
+   InSymbol;
+   Variable(fsys + [comma, rparent], fprocp);
+   if glcp <> nil then
+      with glcp^ do
+         if klass = varsm then begin
+	    if vcontvar then
+               Error(97);
+	    if vlev <> level then
+               vrestrict := true;
+	    end; {if}
+   lsp := gattr.typtr;
+   test := false;
+   if lsp <> nil then
+      if lsp^.form = files then
+
+         {handle reads from files}
+         with gattr, lsp^ do begin
+	    if (lkey = 13{readln}) and (typtr <> textptr) then
+               Error(44);
+	    if access = indrct then begin
+	       Load;
+	       llb := GetTemp(ptrsize);
+	       Gen3t(pc_str, llb, 0, 0, cgULong);
+	       inLocalPtr := true;
+	       dplab := llb;
+               gattr.isPacked := false;
+	       kind := varbl;
+	       access := drct;
+	       vlevel := level;
+	       FreeTemp(llb, ptrsize);
+	       end; {if}
+	    lattr := gattr;
+	    standardIn := glcp = inptr;
+	    if sy = rparent then begin
+	       if lkey = 7{read} then
+                  Error(44);
+	       test := true;
+	       end {if}
+	    else if sy <> comma then begin
+	       Error(44);
+	       Skip(fsys + [comma, rparent]);
+	       end; {else if}
+	    if sy = comma then begin
+	       InSymbol;
+	       Variable(fsys + [comma, rparent], fprocp);
+	       end {if}
+	    else
+               test := true;
+	    end {with}
+         else if noinput then
+            Error(91);
+   if lattr.typtr = textptr then begin
+
+      {read from a text file}
+      if not test then
+         repeat
+	    if glcp <> nil then
+	       with glcp^ do
+	          if klass = varsm then begin
+	             if vcontvar then
+                        Error(97);
+	             if vlev <> level then
+                        vrestrict := true;
+	             end; {if}
+            needBno := false;
+	    if IsString(gattr.typtr) then begin
+	       if gattr.kind <> expr then begin
+	          LoadAddress;
+	          Gen0t(pc_stk, cgULong);
+	          Gen1t(pc_ldc, StrLen(gattr.typtr), cgWord);
+	          Gen0t(pc_stk, cgWord);
+	          Gen0t(pc_bno, cgWord);
+                  needBno := true;
+	          end;         {if}
+	       end {if}
+	    else begin
+	       if gattr.typtr <> nil then
+	          if (gattr.access<>drct) or
+	             (gattr.typtr^.form in [arrays,records,objects,files]) then
+	             LoadAddress;
+	       end; {else}
+	    tattr := gattr;
+	    if not standardIn then begin
+	       gattr := lattr;
+	       if inLocalPtr then
+	          Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
+	       else
+	          Load;
+	       Gen0t(pc_stk, cgULong);
+               if needBno then
+	          Gen0t(pc_bno, cgULong);
+	       end; {if}
+	    if tattr.typtr <> nil then
+	       if (tattr.typtr^.form <= subrange) or IsString(tattr.typtr) then
+                  begin
+	          if standardIn then
+                     Gen0(pc_nop);
+	          if CompTypes(intptr, tattr.typtr) then begin
+	             if standardIn then
+		        Gen1(pc_csp, 59{rii})
+	             else
+		        Gen1(pc_csp, 5{rdi});
+	             CheckBnds(tattr.typtr);
+	             Store(tattr);
+	             end {if}
+	          else if CompTypes(longptr, tattr.typtr) then begin
+	             if standardIn then
+		        Gen1(pc_csp, 98{ril})
+	             else
+		        Gen1(pc_csp, 99{rdl});
+	             CheckBnds(tattr.typtr);
+	             Store(tattr);
+	             end {else if}
+	          else if CompTypes(charptr, tattr.typtr) then begin
+	             if standardIn then
+		        Gen1(pc_csp, 58{ric})
+	             else
+		        Gen1(pc_csp, 7{rdc});
+	             CheckBnds(tattr.typtr);
+	             Store(tattr);
+	             end {else if}
+	          else if CompTypes(realptr, tattr.typtr) then begin
+	             if standardIn then
+		        Gen1(pc_csp, 61{rir})
+	             else
+		        Gen1(pc_csp, 6{rdr});
+	             CheckBnds(tattr.typtr);
+	             Store(tattr);
+	             end {else if}
+	          else if CompTypes(stringptr, tattr.typtr) then begin
+	             if standardIn then
+		        Gen1(pc_csp, 84{ris})
+	             else
+		        Gen1(pc_csp, 50{rds});
+	             end {esle if}
+	          else
+                     Error(44);
+                  end {if}
+	       else
+                  Error(44);
+	    test := sy <> comma;
+	    if not test then begin
+	       InSymbol;
+	       Variable(fsys + [comma, rparent], fprocp);
+	       end; {if}
+         until test;
+      end {if}
+   else if not test then begin
+
+      {do non-text reads}
+      repeat
+         if glcp <> nil then
+	    with glcp^ do
+	       if klass = varsm then begin
+	          if vcontvar then
+                     Error(97);
+	          if vlev <> level then
+                     vrestrict := true;
+	          end; {if}
+         if gattr.typtr <> nil then
+	    if (gattr.access<>drct) or
+	       (gattr.typtr^.form in [arrays,records,files]) then
+	       LoadAddress;
+         tattr := gattr;
+         if not CompTypes(gattr.typtr, lattr.typtr^.filtype) then
+            if not CompObjects(gattr.typtr, lattr.typtr^.filtype) then
+               Error(44);
+         gattr := lattr;
+         if inLocalPtr then
+	    Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
+         else
+	    Load;
+         with gattr do begin
+	    typtr := lattr.typtr^.filtype;
+	    kind := varbl;
+            isPacked := false;
+	    access := indrct;
+	    idplmt := 0;
+	    end; {with}
+         if gattr.typtr^.form in [scalar,subrange,pointerStruct,power,objects]
+            then
+	    Load
+         else
+	    LoadAddress;
+         case tattr.typtr^.form of
+	    scalar,subrange: begin
+	       CheckBnds(tattr.typtr);
+	       Store(tattr);
+	       end;
+	    pointerStruct,power,objects:
+	       Store(tattr);
+	    arrays,records:
+	       Gen2(pc_mov, long(tattr.typtr^.size).msw,
+                  long(tattr.typtr^.size).lsw);
+	    files: Error(71);
+	    end; {case}
+
+         {get the next file variable}
+         gattr := lattr;
+         if inLocalPtr then
+	    Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
+         else
+	    Load;
+         Gen0t(pc_stk, cgULong);
+         Gen1(pc_csp, 1{get});
+         test := sy <> comma;
+         if not test then begin
+	    InSymbol;
+	    Variable(fsys+[comma,rparent], fprocp);
+	    end; {if}
+      until test;
+      end; {else if not test}
+   Match(rparent, 4);
+   end {if}
+else if lkey = 7{read} then
+   Error(44);
+if lkey = 13{readln} then begin
+   if standardIn then begin
+      Gen0(pc_nop);
+      Gen1(pc_csp, 60{rin});
+      end {if}
+   else begin
+      gattr := lattr;
+      if inLocalPtr then
+         Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
+      else
+         Load;
+      Gen0t(pc_stk, cgULong);
+      Gen1(pc_csp, 13{rln})
+      end; {else}
+   end; {if}
+end; {DoRead}
+
+procedure DoWrite(fsys: setofsys; fprocp: ctp);
+{compile a call to write, writeln}
+
+var
+  lsp: stp;
+  default,defaultr : boolean;
+  llkey: keyrange;
+  lcp: ctp;
+  len: addrrange;
+  lattr,tattr: attr;
+  test: boolean;
+  standardOut,errorOut: boolean;      {is the write to the console?}
+  llb: unsigned; 		      {for allocating temporary space}
+  inLocalPtr: boolean;		      {is file ptr in local area?}
+
+  procedure LoadFile;
+  {load the file variable}
+
+  begin {LoadFile}
+  gattr := lattr;
+  if inLocalPtr then
+    Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
+  else
+    Load;
+  end; {LoadFile}
+
+begin {DoWrite}
+inLocalPtr := false;
+llkey := lkey;
+standardOut := true;
+errorOut := false;
+lattr.typtr := textptr;
+if sy = lparent then begin
+  InSymbol;
+  Expression(fsys + [comma,colon,rparent],fprocp);
+  lsp := gattr.typtr;
+  test := false;
+  if lsp <> nil then
+    if lsp^.form = files then
+      with gattr, lsp^ do begin
+	if access = indrct then begin
+	  Load;
+	  llb := GetTemp(ptrsize);
+	  Gen3t(pc_str, llb, 0, 0, cgULong);
+          gattr.isPacked := false;
+	  kind := varbl;
+	  access := drct;
+	  vlevel := level;
+	  dplab := llb;
+	  inLocalPtr := true;
+	  FreeTemp(llb, ptrsize);
+	  end;
+	lattr := gattr;
+	standardOut := glcp = outptr;
+	errorOut := glcp = erroroutputptr;
+	if (lkey = 14{writeln}) and (typtr <> textptr) then Error(44);
+	if sy = rparent then begin
+	  if llkey = 8{write} then Error(44);
+	  test := true;
+	  end
+	else if sy <> comma then begin
+	  Error(44);
+	  Skip(fsys+[comma,rparent]);
+	  end;
+	if sy = comma then begin
+	  InSymbol;
+	  if lattr.typtr = textptr then
+	    Expression(fsys+[comma,colon,rparent],fprocp);
+	  end
+	else test := true
+	end
+    else if nooutput then Error(92);
+  if lattr.typtr = textptr then begin
+
+    {text file reads}
+    if not test then
+      repeat
+	lsp := gattr.typtr;
+	if lsp^.form = subrange then
+          lsp := lsp^.rangetype;
+	if lsp <> nil then
+	  if lsp^.form <= subrange then begin
+	    Load;
+	    if (lsp = intptr) or (lsp = byteptr) or (lsp = charptr)
+	      or (lsp = boolptr) then
+	      Gen0t(pc_stk, cgWord)
+	    else if lsp = longptr then
+	      Gen0t(pc_stk, cgLong)
+	    else if IsReal(lsp) then
+	      Gen0t(pc_stk, cgExtended)
+	    else if lsp <> nil then
+	      Gen0t(pc_stk, cgULong);
+	    end {if}
+	  else begin
+	    if IsString(gattr.typtr) then
+	      LoadStringAddress
+	    else begin
+	      LoadAddress;
+	      Gen0t(pc_stk, cgULong);
+	      end; {else}
+	    end;
+	if sy = colon then begin
+	  InSymbol;
+	  Expression(fsys + [comma,colon,rparent],fprocp);
+	  Load;
+	  Gen0t(pc_stk, cgWord);
+	  Gen0t(pc_bno, cgWord);
+	  if gattr.typtr <> nil then
+	    if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then
+	      Error(44);
+	  if debug then
+            Gen2t(pc_chk, 0, maxint, cgUWord);
+	  default := false;
+	  end
+	else default := true;
+	if sy = colon then begin
+	  InSymbol;
+	  Expression(fsys + [comma,rparent],fprocp);
+	  Load;
+	  Gen0t(pc_stk, cgWord);
+	  Gen0t(pc_bno, cgWord);
+	  if gattr.typtr <> nil then
+	    if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then
+	      Error(44);
+	  if not IsReal(lsp) then
+            Error(50);
+	  defaultr := false;
+	  end
+	else defaultr := true;
+	if (lsp = intptr) or (lsp = byteptr) then begin
+	  if default then begin
+	    Gen1t(pc_ldc, intfw, cgWord);
+	    Gen0t(pc_stk, cgWord);
+	    Gen0t(pc_bno, cgWord);
+	    end; {if}
+	  if standardOut then
+	    Gen1(pc_csp,16{woi})
+	  else if errorOut then
+	    Gen1(pc_csp,42{wei})
+	  else begin
+	    LoadFile;
+	    Gen0t(pc_stk, cgULong);
+	    Gen0t(pc_bno, cgULong);
+	    Gen1(pc_csp,9{wri});
+	    end;
+	  end
+	else if lsp = longptr then begin
+	  if default then begin
+	    Gen1t(pc_ldc, longfw, cgWord);
+	    Gen0t(pc_stk, cgWord);
+	    Gen0t(pc_bno, cgWord);
+	    end; {if}
+	  if standardOut then
+	    Gen1(pc_csp,100{wol})
+	  else if errorOut then
+	    Gen1(pc_csp,101{wel})
+	  else begin
+	    LoadFile;
+	    Gen0t(pc_stk, cgULong);
+	    Gen0t(pc_bno, cgULong);
+	    Gen1(pc_csp,102{wrl});
+	    end;
+	  end
+	else if IsReal(lsp) then begin
+	  if default then begin
+	    Gen1t(pc_ldc, realfw, cgWord);
+	    Gen0t(pc_stk, cgWord);
+	    Gen0t(pc_bno, cgWord);
+	    end; {if}
+	  if defaultr then begin
+	    Gen1t(pc_ldc, 0, cgWord);
+	    Gen0t(pc_stk, cgWord);
+	    Gen0t(pc_bno, cgWord);
+	    end; {if}
+	  if standardOut then
+	    Gen1(pc_csp,62{wor})
+	  else if errorOut then
+	    Gen1(pc_csp,53{wer})
+	  else begin
+	    LoadFile;
+	    Gen0t(pc_stk, cgULong);
+	    Gen0t(pc_bno, cgULong);
+	    Gen1(pc_csp,10{wrr});
+	    end; {else}
+	  end {else if}
+	else if lsp = charptr then begin
+	  if standardOut then
+	    if default then
+	      Gen1(pc_csp,40{wol})
+	    else
+	      Gen1(pc_csp,37{woc})
+	  else if errorOut then
+	    if default then
+	      Gen1(pc_csp,41{wel})
+	    else
+	      Gen1(pc_csp,39{wec})
+	  else begin
+	    if default then begin
+	      Gen1t(pc_ldc, 1, cgWord);
+	      Gen0t(pc_stk, cgWord);
+	      Gen0t(pc_bno, cgWord);
+	      end; {if}
+	    LoadFile;
+	    Gen0t(pc_stk, cgULong);
+	    Gen0t(pc_bno, cgULong);
+	    Gen1(pc_csp,8{wrc});
+	    end;
+	  end
+	else if lsp = boolptr then begin
+	  if default then begin
+	    Gen1t(pc_ldc, boolfw, cgWord);
+	    Gen0t(pc_stk, cgWord);
+	    Gen0t(pc_bno, cgWord);
+	    end; {if}
+	  if standardOut then
+	    Gen1(pc_csp,29{wob})
+	  else if errorOut then
+	    Gen1(pc_csp,31{web})
+	  else begin
+	    LoadFile;
+	    Gen0t(pc_stk, cgULong);
+	    Gen0t(pc_bno, cgULong);
+	    Gen1(pc_csp,46{wrb});
+	    end;
+	  end
+	else if lsp <> nil then begin
+	  if IsString(lsp) then begin
+	    if default then begin
+	      Gen1t(pc_ldc, $8000, cgWord);
+	      Gen0t(pc_stk, cgWord);
+	      Gen0t(pc_bno, cgWord);
+	      end; {if}
+	    if standardOut then
+	      Gen1(pc_csp,21{wos})
+	    else if errorOut then
+	      Gen1(pc_csp,25{wes})
+	    else begin
+	      LoadFile;
+	      Gen0t(pc_stk, cgULong);
+	      Gen0t(pc_bno, cgULong);
+	      Gen1(pc_csp,45{wrs});
+	      end;
+	    end
+	  else Error(44);
+	  end;
+	test := sy <> comma;
+	if not test then begin
+	  InSymbol;
+	  Expression(fsys + [comma,colon,rparent],fprocp)
+	  end
+      until test;
+    end
+  else if not test then begin
+
+    {handle non-text files}
+    repeat
+      {assign the Expression to the file variable}
+      LoadFile;
+      tattr := gattr;
+      with tattr do begin
+	typtr := gattr.typtr^.filtype;
+        isPacked := false;
+	kind := varbl;
+	access := indrct;
+	idplmt := 0;
+	end;
+      if debug then
+        GenL2t(pc_chk, 1, maxaddr, cgULong);
+      Expression(fsys+[comma,colon,rparent],fprocp);
+      lsp := gattr.typtr;
+      if (lsp^.form <= subrange) or (lsp^.form = objects) then
+        Load
+      else
+        LoadAddress;
+      if not CompTypes(lsp,lattr.typtr^.filtype) then
+        if not CompObjects(lsp,lattr.typtr^.filtype) then
+          Error(44);
+      case tattr.typtr^.form of
+	scalar,subrange: begin
+	  CheckBnds(tattr.typtr);
+	  Store(tattr);
+	  end;
+	pointerStruct,power,objects:
+	  Store(tattr);
+	arrays,records:
+	  Gen2(pc_mov, long(tattr.typtr^.size).msw, long(tattr.typtr^.size).lsw);
+	files: Error(71);
+	end; {case}
+      {write the file variable to the file}
+      LoadFile;
+      Gen0t(pc_stk, cgULong);
+      Gen1(pc_csp,2{put});
+      test := sy<>comma;
+      if not test then InSymbol;
+    until test;
+    end; {else if not test}
+  Match(rparent,4);
+  end
+else if lkey = 8{write} then Error(44);
+if lkey = 14{writeln} then begin
+  if standardOut then begin
+    Gen0(pc_nop);
+    Gen1(pc_csp,26{wol});
+    end {if}
+  else if errorOut then begin
+    Gen0(pc_nop);
+    Gen1(pc_csp,27{wel});
+    end {else if}
+  else begin
+    LoadFile;
+    Gen0t(pc_stk, cgULong);
+    Gen1(pc_csp,14{wln});
+    end;
+  end;
+end; {DoWrite}
+
+procedure DoPack(fsys: setofsys; fprocp: ctp);
+{compile a call to pack}
+
+var
+  lsp,lsp1: stp;
+  elSize: longint;		      {element size}
+  lmin,lmax: longint;		      {subrange of unpacked array}
+
+begin {DoPack}
+{get the unpacked array}
+Variable(fsys + [comma,rparent],fprocp);
+LoadAddress;
+Gen0t(pc_stk, cgULong);
+if gattr.typtr <> nil then
+  with gattr.typtr^ do
+    if (form = arrays) and (ispacked = pkunpacked) then begin
+      Gen1t(pc_ldc, long(aeltype^.size).lsw, cgUWord);
+      Gen0t(pc_stk, cgUWord);
+      Gen0t(pc_bno, cgUWord);
+      GenLdcLong(size div aeltype^.size);
+      Gen0t(pc_stk, cgULong);
+      Gen0t(pc_bno, cgULong);
+      lsp := inxtype;
+      lsp1 := aeltype;
+      GetBounds(lsp,lmin,lmax);
+      end
+    else Error(44);
+Match(comma,20);
+{get the staring index}
+Expression(fsys + [comma,rparent],fprocp);
+Load;
+if CompTypes(longptr, lsp) then
+  if (gattr.typtr = intptr) or (gattr.typtr = bytePtr) then begin
+    Gen2(pc_cnv,ord(cgWord),ord(cgLong));
+    gattr.typtr := longptr;
+    end; {end}
+if gattr.typtr <> nil then
+  if gattr.typtr^.form <> scalar then
+    Error(44)
+  else if not CompTypes(lsp,gattr.typtr) then
+    Error(44);
+if not CompTypes(longptr, gattr.typtr) then begin
+  Gen2(pc_cnv, ord(GetType(gattr.typtr, false)), ord(cgLong));
+  gattr.typtr := longptr;
+  end; {end}
+Match(comma,20);
+if lmin <> 0 then begin
+  GenLdcLong(lmin);
+  Gen0(pc_sbl);
+  end; {if}
+Gen0t(pc_stk, cgULong);
+Gen0t(pc_bno, cgULong);
+{get the packed array}
+Variable(fsys + [rparent],fprocp);
+LoadAddress;
+Gen0t(pc_stk, cgULong);
+Gen0t(pc_bno, cgULong);
+if gattr.typtr <> nil then
+  with gattr.typtr^ do
+    if (form = arrays) and (ispacked = pkpacked) then begin
+      if not CompTypes(aeltype,lsp1) then Error(44);
+      elSize := aelType^.size;
+      if (aelType = charptr) or (aelType = boolptr) then
+	elSize := packedCharSize;
+      Gen1t(pc_ldc, long(elSize).lsw, cgUWord);
+      Gen0t(pc_stk, cgUWord);
+      Gen0t(pc_bno, cgUWord);
+      GenLdcLong(size div elSize);
+      Gen0t(pc_stk, cgULong);
+      Gen0t(pc_bno, cgULong);
+      end {if}
+    else Error(44);
+{move the elements}
+Gen1(pc_csp, 51{pak});
+end; {DoPack}
+
+procedure DoUnpack(fsys: setofsys; fprocp: ctp);
+{compile a call to unpack}
+
+var
+  lsp,lsp1: stp;
+  elSize: longint;		      {element size}
+  lmin,lmax: longint;		      {subrange of unpacked array}
+
+begin {DoUnpack}
+Variable(fsys + [comma,rparent],fprocp);
+LoadAddress;
+Gen0t(pc_stk, cgULong);
+if gattr.typtr <> nil then
+  with gattr.typtr^ do
+    if (form = arrays) and (ispacked = pkpacked) then begin
+      elSize := aelType^.size;
+      if (aelType = charptr) or (aelType = boolptr) then
+	elSize := packedCharSize;
+      lsp1 := aeltype;
+      Gen1t(pc_ldc, long(elSize).lsw, cgWord);
+      Gen0t(pc_stk, cgUWord);
+      Gen0t(pc_bno, cgUWord);
+      GenLdcLong(size div elSize);
+      Gen0t(pc_stk, cgULong);
+      Gen0t(pc_bno, cgULong);
+      end
+    else Error(44);
+Match(comma,20);
+Variable(fsys + [comma,rparent],fprocp);
+LoadAddress;
+Gen0t(pc_stk, cgULong);
+Gen0t(pc_bno, cgULong);
+if gattr.typtr <> nil then
+  with gattr.typtr^ do
+    if (form = arrays) and (ispacked = pkunpacked) then begin
+      if not CompTypes(aeltype,lsp1) then Error(44);
+      Gen1t(pc_ldc, long(aeltype^.size).lsw, cgWord);
+      Gen0t(pc_stk, cgUWord);
+      Gen0t(pc_bno, cgUWord);
+      GenLdcLong(size div aeltype^.size);
+      Gen0t(pc_stk, cgULong);
+      Gen0t(pc_bno, cgULong);
+      lsp := inxtype;
+      GetBounds(lsp,lmin,lmax);
+      end
+    else Error(44);
+Match(comma,20);
+Expression(fsys + [rparent],fprocp);
+Load;
+if CompTypes(longptr, lsp) then
+  if (gattr.typtr = intptr) or (gattr.typtr = bytePtr) then begin
+    Gen2(pc_cnv, ord(cgWord), ord(cgLong));
+    gattr.typtr := longptr;
+    end; {end}
+if gattr.typtr <> nil then
+  if gattr.typtr^.form <> scalar then
+    Error(44)
+  else if not CompTypes(lsp,gattr.typtr) then
+    Error(44);
+if not CompTypes(longptr, gattr.typtr) then begin
+  Gen2(pc_cnv, ord(GetType(gattr.typtr, false)), ord(cgLong));
+  gattr.typtr := longptr;
+  end; {end}
+if lmin <> 0 then begin
+  GenLdcLong(lmin);
+  Gen0(pc_sbl);
+  end; {if}
+Gen0t(pc_stk, cgULong);
+Gen0t(pc_bno, cgULong);
+Gen1(pc_csp, 52{upk});
+end; {DoUnpack}
+
+
+procedure DoNew (fsys: setofsys; fprocp: ctp);
+
+{ compile a call to new						}
+{								}
+{ parameters:							}
+{    fsys -							}
+{    fprocp -							}
+
+label 1;
+
+var
+  lattr: attr;				{pointer/object variable's gattr}
+  lsize: addrrange;			{amount of memory to allocate}
+  lsp,lsp1: stp;
+  lval: valu;
+  ofld: ctp;				{object field list}
+  varts: integer;
+
+
+  function InitMethods (lcp: ctp): unsigned;
+
+  { Set the address for all methods in a new object		}
+  {								}
+  { parameters:							}
+  {    lsp - head of object field tree				}
+  {								}
+  { returns: Number of methods					}
+
+  var
+     count: unsigned;
+
+  begin {InitMethods}
+  count := 0;
+  if lcp^.llink <> nil then
+    count := InitMethods(lcp^.llink);
+  if lcp^.rlink <> nil then
+    count := count + InitMethods(lcp^.rlink);
+  if lcp^.klass in [proc,func] then begin
+    count := count + 1;
+    Gen0Name(pc_lad, lcp^.pfoname);
+    Gen0t(pc_stk, cgULong);
+    GenLdcLong(lcp^.pfaddr);
+    Gen0t(pc_stk, cgULong);
+    Gen0t(pc_bno, cgULong);
+    Gen0t(pc_bno, cgULong);
+    end; {if}
+  InitMethods := count;
+  end; {InitMethods}
+
+
+begin {DoNew}
+{get the pointer to allocate}
+Variable(fsys + [comma,rparent],fprocp);
+lattr := gattr;
+LoadAddress;
+Gen0t(pc_stk, cgULong);
+
+{examine the variable to see how much memory to allocate}
+lsp := nil;
+varts := 0;
+lsize := 0;
+ofld := nil;
+if gattr.typtr <> nil then
+  with gattr.typtr^ do
+    if form = pointerStruct then begin
+      if eltype <> nil then begin
+	lsize := eltype^.size;
+	if eltype^.form = records then
+          lsp := eltype^.recvar;
+	end; {if}
+      end {if}
+    else if form = objects then begin
+      lsize := objsize;
+      ofld := objfld;
+      end {else if}
+    else
+      Error(44);
+
+{handle the variant parts}
+while sy = comma do begin
+  InSymbol;
+  DoConstant(fsys + [comma,rparent],lsp1,lval);
+  varts := varts+1;
+  if lsp = nil then
+    Error(82)
+  else if lsp^.form <> tagfld then
+    Error(86)
+  else if lsp^.tagfieldp <> nil then
+    if CompTypes(lsp^.tagfieldp^.idtype,lsp1) then begin
+      lsp1 := lsp^.fstvar;
+      while lsp1 <> nil do
+	with lsp1^ do
+	  if varval = lval.ival then begin
+	    lsize := size;
+	    lsp := subvar;
+	    goto 1;
+	    end {if}
+	  else
+	    lsp1 := nxtvar;
+      end {if}
+    else
+      Error(44);
+1:  end {while} ;
+
+{for objects, set up size, generation, and method addresses}
+if ofld <> nil then begin
+  if lattr.typtr <> nil then begin
+    Gen1t(pc_ldc, lattr.typtr^.objlevel, cgUWord);
+    Gen0t(pc_stk, cgUWord);
+    Gen0t(pc_bno, cgUWord);
+    end; {if}
+  GenLdcLong(lsize);
+  Gen0t(pc_stk, cgULong);
+  Gen0t(pc_bno, cgULong);
+  Gen1t(pc_ldc, InitMethods(ofld), cgUWord);
+  Gen0t(pc_stk, cgUWord);
+  Gen0t(pc_bno, cgUWord);
+
+{generate the call to allocate memory}
+  Gen1(pc_csp,118{newobj});
+  end {if}
+else if lsize < maxint then begin
+  Gen1t(pc_ldc, long(lsize).lsw, cgWord);
+  Gen0t(pc_stk, cgWord);
+  Gen0t(pc_bno, cgWord);
+  Gen1(pc_csp,11{new});
+  end {if}
+else begin
+  if lsize > $010000 then
+    if smallMemoryModel then
+      Error(122);
+  GenLdcLong(lsize);
+  Gen0t(pc_stk, cgULong);
+  Gen0t(pc_bno, cgULong);
+  Gen1(pc_csp,116{new4});
+  end; {else}
+
+{if this points to a file, zero the area}
+gattr := lattr;
+if gattr.typtr <> nil then
+  if gattr.typtr^.form <> objects then
+    if gattr.typtr^.hasSFile then begin
+      Gen1t(pc_ldc, ord(gattr.typtr^.size), cgWord);
+      Gen0t(pc_stk, cgWord);
+      Load;
+      Gen0t(pc_stk, cgULong);
+      Gen0t(pc_bno, cgULong);
+      Gen1(pc_csp,35{clr});
+      end; {if}
+end; {DoNew}
+
+
+procedure DoSizeof;
+{compile a call to sizeof}
+
+var
+  lcp: ctp;
+
+begin {DoSizeof}
+Match(lparent,9);
+SearchId([types,varsm], lcp);
+if lcp^.idtype^.size < maxint then begin
+  Gen1t(pc_ldc, ord(lcp^.idtype^.size), cgWord);
+  gattr.typtr := intptr;
+  end {if}
+else begin
+  GenLdcLong(lcp^.idtype^.size);
+  gattr.typtr := longptr;
+  end; {else}
+InSymbol;
+end; {DoSizeof}
+
+
+procedure DoDispose (fsys: setofsys; fprocp: ctp);
+
+{ Compile a call to dispose					}
+{								}
+{ parameters:							}
+{    fsys -							}
+{    fprocp -							}
+
+label 1;
+
+var
+  lsp,lsp1: stp;
+  lval: valu;
+
+begin {DoDispose}
+{get the pointer to dispose}
+Expression(fsys+[rparent,comma],fprocp);
+
+if gattr.typtr <> nil then
+  if gattr.typtr^.form = pointerStruct then begin
+    {dispose of a pointer}
+    Load;
+    Gen0t(pc_stk, cgULong);
+    Gen1(pc_csp,17{dsp});
+    lsp := nil;
+    with gattr.typtr^ do
+      if eltype <> nil then
+	if eltype^.form = records then
+          lsp := eltype^.recvar;
+    while sy = comma do begin
+      InSymbol;
+      DoConstant(fsys+[comma,rparent],lsp1,lval);
+      if lsp = nil then Error(82)
+      else if lsp^.form <> tagfld then
+        Error(86)
+      else if lsp^.tagfieldp <> nil then
+	if CompTypes(lsp^.tagfieldp^.idtype,lsp1) then begin
+	  lsp1 := lsp^.fstvar;
+	  while lsp1 <> nil do
+	    with lsp1^ do
+	      if varval = lval.ival then begin
+		lsp := subvar;
+                goto 1;
+		end {if}
+	      else
+                lsp1 := nxtvar;
+	  lsp := nil;
+	  end {if}
+	else
+          Error(44);
+1:	end; {while}
+    end {if}
+  else if gattr.typtr^.form = objects then begin
+    {dispose of an object}
+    Load;
+    if debug then
+      GenL2t(pc_chk, 1, maxaddr, cgULong);
+    Gen0t(pc_stk, cgULong);
+    Gen1(pc_csp,17{dsp});
+    end {else if}
+  else
+    Error(44);
+end; {DoDispose}
+
+procedure Abs;
+{compile an absolute value function call}
+
+begin {Abs}
+if gattr.typtr <> nil then
+  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
+    Gen0(pc_abi)
+  else if IsReal(gattr.typtr) then
+    Gen0(pc_abr)
+  else if gattr.typtr = longptr then
+    Gen0(pc_abl)
+  else begin
+    Error(51);
+    gattr.typtr := intptr;
+    end;
+end; {Abs}
+
+procedure Sqr;
+{compile a call to the square function}
+
+begin {Sqr}
+if gattr.typtr <> nil then
+  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
+    Gen0(pc_sqi)
+  else if IsReal(gattr.typtr) then
+    Gen0(pc_sqr)
+  else if gattr.typtr = longptr then
+    Gen0(pc_sql)
+  else begin
+    Error(51);
+    gattr.typtr := intptr;
+    end;
+end; {Sqr}
+
+procedure TruncRound;
+{compile trunc and round calls}
+
+begin {TruncRound}
+if gattr.typtr <> nil then
+  if not IsReal(gattr.typtr) then
+    Error(51);
+if lkey = 3{trunc} then begin
+  Gen2(pc_cnv,ord(cgReal),ord(cgWord));
+  gattr.typtr := intptr;
+  end {if}
+else if lkey = 42{trunc4} then begin
+  Gen2(pc_cnv,ord(cgReal),ord(cgLong));
+  gattr.typtr := longptr;
+  end {else if}
+else if lkey = 43{round4} then begin
+  Gen0(pc_rn4);
+  gattr.typtr := longptr;
+  end {else if}
+else begin
+  Gen0(pc_rnd);
+  gattr.typtr := intptr;
+  end; {else}
+end; {TruncRound}
+
+procedure DoOdd;
+{compile a call to the odd function}
+
+begin {DoOdd}
+if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
+  Gen0(pc_odd)
+else if gattr.typtr = longptr then
+  Gen0(pc_odl)
+else
+  Error(51);
+gattr.typtr := boolptr;
+end; {DoOdd}
+
+procedure DoOrd;
+{compile the ord function}
+
+begin {DoOrd}
+if gattr.typtr <> nil then
+  if gattr.typtr^.form > pointerStruct then
+    Error(51)
+  else if (gattr.typtr^.form = pointerStruct) or (gattr.typtr = longptr) then
+    begin
+    if iso then Error(112);
+    Gen2(pc_cnv,ord(cgLong),ord(cgWord));
+    end
+  else if not (GetType(gattr.typtr, gattr.isPacked)
+    in [cgByte,cgUByte,cgWord,cgUWord]) then
+    Error(51);
+gattr.typtr := intptr;
+end; {DoOrd}
+
+procedure DoOrd4;
+
+{ compile the ord4 function					}
+
+begin {DoOrd4}
+if gattr.typtr <> nil then
+   if gattr.typtr^.form > pointerStruct then
+      Error(51)
+   else if GetType(gattr.typtr, gattr.isPacked)
+      in [cgByte,cgUByte,cgWord,cgUWord] then
+      Gen2(pc_cnv,ord(cgWord),ord(cgLong))
+   else if not (GetType(gattr.typtr, gattr.isPacked) in [cgLong,cgULong]) then
+      Error(51);
+gattr.typtr := longptr;
+end; {DoOrd4}
+
+procedure DoPointer;
+{compile the Pointer function}
+
+begin {DoPointer}
+if gattr.typtr <> nil then
+  if gattr.typtr^.form > pointerStruct then
+    Error(51)
+  else if (gattr.typtr^.form <> pointerStruct) and (gattr.typtr <> longptr)
+    then
+    Gen2(pc_cnv,ord(cgWord),ord(cgLong));
+  {else the value is already 4 bytes}
+gattr.typtr := nilptr;
+end; {DoPointer}
+
+procedure DoChr;
+{compile a call to the chr function}
+
+begin {DoChr}
+if gattr.typtr <> nil then
+  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(51);
+{gen0(59( chr ));}
+gattr.typtr := charptr;
+end; {DoChr}
+
+procedure PredSucc;
+{compile a call to pred or succ}
+
+begin {PredSucc}
+if gattr.typtr <> nil then
+  if (gattr.typtr^.form <> scalar) or IsReal(gattr.typtr) then
+    Error(51);
+if lkey = 8{pred} then
+  Gen1t(pc_dec, 1, GetType(gattr.typtr, gattr.isPacked))
+else
+  Gen1t(pc_inc, 1, GetType(gattr.typtr, gattr.isPacked));
+CheckBnds(gattr.typtr);
+end; {PredSucc}
+
+procedure DoEOF (fsys: setofsys; fprocp: ctp);
+
+{ compile a call to eof or eoln					}
+{								}
+{ Parameters:							}
+{    fsys -							}
+{    fprocp -							}
+
+begin {DoEOF}
+if sy = lparent then begin
+
+   {handle a call for a given file}
+   InSymbol;
+   Variable(fsys + [rparent],fprocp);
+   Match(rparent,4);
+   if lkey = 11{eoln} then
+      if gattr.typtr <> textptr then
+         Error(44);
+   if gattr.typtr <> nil then
+      if gattr.typtr^.form <> files then
+         Error(51);
+   if glcp = inptr then
+      if lkey=10{eof} then
+	 Gen1tName(pc_ldo, 0, cgUWord, @'~EOFINPUT')
+      else
+	 Gen1tName(pc_ldo, 0, cgUWord, @'~EOLNINPUT')
+   else begin
+      Load;
+      Gen0t(pc_stk, cgULong);
+      Gen1t(pc_csp, 38+lkey{eof,eol}, cgUByte);
+      end; {else}
+   end {if}
+else begin
+
+   {handle a call for standard in}
+   if noinput then
+      Error(91);
+   Gen0(pc_nop);
+   Gen1t(pc_csp, 175+lkey{eof,eol}, cgUByte);
+   end; {else}
+gattr.typtr := boolptr;
+end; {DoEOF}
+
+
+procedure trans;
+{compile transendental functions}
+
+var
+  tkey: keyrange;		      {so we can change the number}
+
+begin {trans}
+tkey := lkey;
+if gattr.typtr <> nil then
+  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then begin
+    gen2(pc_cnv,ord(cgWord),ord(cgReal));
+    gattr.typtr := realptr;
+    end
+  else if gattr.typtr = longptr then begin
+    Gen2(pc_cnv,ord(cgLong),ord(cgReal));
+    gattr.typtr := realptr;
+    end;
+if not IsReal(gattr.typtr) then
+  Error(59);
+case tkey of
+   12: Gen0(pc_sin);
+   13: Gen0(pc_cos);
+   14: Gen0(pc_exp);
+   15: Gen0(pc_sqt);
+   16: Gen0(pc_log);
+   17: Gen0(pc_atn);
+   36: Gen0(pc_tan);
+   37: Gen0(pc_acs);
+   38: Gen0(pc_asn);
+   otherwise:
+     Error(113);
+   end; {case}
+end; {trans}
+
+procedure DoArctan2(fsys: setofsys; fprocp: ctp);
+{compile a call to Arctan2}
+
+begin {DoArctan2}
+Match(lparent,9);
+Expression(fsys+[comma,rparent],fprocp);
+Load;
+if gattr.typtr <> nil then
+  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then begin
+    gen2(pc_cnv,ord(cgWord),ord(cgReal));
+    gattr.typtr := realptr;
+    end
+  else if gattr.typtr = longptr then begin
+    Gen2(pc_cnv,ord(cgLong),ord(cgReal));
+    gattr.typtr := realptr;
+    end;
+if not IsReal(gattr.typtr) then
+  Error(59);
+Match(comma,20);
+Expression(fsys+[rparent],fprocp);
+Load;
+if gattr.typtr <> nil then
+  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then begin
+    gen2(pc_cnv,ord(cgWord),ord(cgReal));
+    gattr.typtr := realptr;
+    end
+  else if gattr.typtr = longptr then begin
+    Gen2(pc_cnv,ord(cgLong),ord(cgReal));
+    gattr.typtr := realptr;
+    end;
+if not IsReal(gattr.typtr) then
+  Error(59);
+Gen0(pc_at2);
+end; {DoArctan2}
+
+procedure DoUserID;
+{compile a call to UserID}
+
+begin {DoUserID}
+Gen1tName(pc_ldo, 0, cgUWord, @'~USER_ID');
+gattr.typtr := intptr;
+end; {DoUserID}
+
+procedure ToolError;
+{compile a call to tollerror}
+
+begin {ToolError}
+Gen1tName(pc_ldo, 0, cgUWord, @'~TOOLERROR');
+gattr.typtr := intptr;
+end; {ToolError}
+
+procedure Cnvfs(fsys: setofsys; fprocp: ctp);
+{compile a call to Cnvrs or Cnvds}
+
+begin {Cnvfs}
+{load the value to convert}
+Match(lparent,9);
+Expression(fsys+[comma,rparent],fprocp);
+Load;
+if gattr.typtr <> nil then
+  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then begin
+    Gen2(pc_cnv,ord(cgWord),ord(cgReal));
+    gattr.typtr := realptr;
+    end
+  else if (gattr.typtr = longptr) then begin
+    Gen2(pc_cnv,ord(cgLong),ord(cgReal));
+    gattr.typtr := realptr;
+    end;
+if not IsReal(gattr.typtr) then
+  Error(59);
+Gen0t(pc_stk, cgExtended);
+{load the two required field widths}
+Match(comma,20);
+Expression(fsys+[comma,rparent],fprocp);
+Load;
+Gen0t(pc_stk, cgWord);
+Gen0t(pc_bno, cgWord);
+if gattr.typtr <> nil then begin
+  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
+  end
+else Error(44);
+Match(comma,20);
+Expression(fsys+[rparent],fprocp);
+Load;
+Gen0t(pc_stk, cgWord);
+Gen0t(pc_bno, cgWord);
+if gattr.typtr <> nil then begin
+  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
+  end
+else Error(44);
+Gen1t(pc_csp,77{cfs},cgString);
+gattr.typtr := stringptr;
+gattr.kind := expr;
+stringHeap := true;
+end; {Cnvfs}
+
+procedure Cnvis;
+{compile a call to Cnvis}
+
+begin {Cnvis}
+if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
+  Gen2(pc_cnv,ord(cgWord),ord(cgLong))
+else if gattr.typtr <> longptr then Error(44);
+Gen0t(pc_stk, cgULong);
+Gen1t(pc_csp,78{cis},cgString);
+gattr.typtr := stringptr;
+gattr.kind := expr;
+stringHeap := true;
+end; {Cnvis}
+
+procedure CnvSF(fsys: setofsys; fprocp: ctp);
+{compile a call to CnvSR or CnvSD}
+
+begin {Cnvsf}
+Match(lparent,9);
+Expression(fsys+[rparent],fprocp);
+if gattr.typtr <> nil then
+  if IsString(gattr.typtr) then
+    LoadStringAddress
+  else Error(44)
+else Error(44);
+gattr.typtr := realptr;
+Gen1t(pc_csp,79{csf},cgReal);
+end; {Cnvsf}
+
+procedure CnvSI(fsys: setofsys; fprocp: ctp);
+{compile a call to CnvSI}
+
+begin {Cnvsi}
+Match(lparent,9);
+Expression(fsys+[rparent],fprocp);
+if gattr.typtr <> nil then
+  if IsString(gattr.typtr) then
+    LoadStringAddress
+  else Error(44)
+else Error(44);
+gattr.typtr := intptr;
+Gen1t(pc_csp,80{csi},cgWord);
+end; {Cnvsi}
+
+procedure CnvSL(fsys: setofsys; fprocp: ctp);
+{compile a call to CnvSL}
+
+begin {Cnvsl}
+Match(lparent,9);
+Expression(fsys+[rparent],fprocp);
+if gattr.typtr <> nil then
+  if IsString(gattr.typtr) then
+    LoadStringAddress
+  else Error(44)
+else Error(44);
+gattr.typtr := longptr;
+Gen1t(pc_csp,81{csl},cgLong);
+end; {Cnvsl}
+
+procedure Randomf;
+{generate a random real or double}
+
+begin {Randomf}
+Gen0(pc_nop);
+gattr.typtr := realptr;
+Gen1t(pc_csp,82{rnf},cgReal);
+end; {Randomf}
+
+procedure RandomInteger;
+{generate a random integer}
+
+begin {RandomInteger}
+Gen0(pc_nop);
+gattr.typtr := intptr;
+Gen1t(pc_csp,83{rni},cgWord);
+end; {RandomInteger}
+
+procedure RandomLongInt;
+{generate a random longint}
+
+begin {RandomLongInt}
+Gen0(pc_nop);
+gattr.typtr := longptr;
+Gen1t(pc_csp,83{rni},cgLong);
+end; {RandomLongint}
+
+procedure Concat(fsys: setofsys; fprocp: ctp);
+{concatonate a series of strings}
+
+var
+  numStrings: integer;		      {# of strings to concatonate}
+  stop: boolean; 		      {loop termination var}
+
+begin {Concat}
+stringHeap := true;
+numStrings := 0;
+{mark stack so parameters are tagged}
+{load the strings}
+Match(lparent,9);
+repeat
+  Expression(fsys+[comma,rparent],fprocp);
+  if gattr.typtr <> nil then
+    if IsString(gattr.typtr) then
+      LoadStringAddress
+    else if gattr.typtr = charptr then begin
+      Load;
+      Gen0t(pc_stk, cgUWord);
+      GenLdcLong(-1);
+      Gen0t(pc_stk, cgULong);
+      Gen0t(pc_bno, cgULong);
+      end
+    else Error(44)
+  else Error(44);
+  stop := sy <> comma;
+  if not stop then InSymbol;
+  numStrings := numStrings+1;
+  if numStrings <> 1 then
+    Gen0t(pc_bno, cgULong);
+until stop or eofl;
+Match(rparent,4);
+Gen1t(pc_ldc, numStrings, cgWord);
+Gen0t(pc_stk, cgWord);
+Gen0t(pc_bno, cgWord);
+{call the concat function}
+Gen1t(pc_csp,85{cat},cgString);
+gattr.typtr := stringptr;
+gattr.kind := expr;
+end; {Concat}
+
+procedure Copy(fsys: setofsys; fprocp: ctp);
+{compile a call to copy characters from a string}
+
+begin {Copy}
+stringHeap := true;
+{load the string to copy characters from}
+Match(lparent,9);
+Expression(fsys+[comma,rparent],fprocp);
+if gattr.typtr <> nil then
+  if IsString(gattr.typtr) then
+    LoadStringAddress
+  else Error(44)
+else Error(44);
+{load the index}
+Match(comma,20);
+Expression(fsys+[comma,rparent],fprocp);
+Load;
+Gen0t(pc_stk, cgWord);
+Gen0t(pc_bno, cgWord);
+if gattr.typtr <> nil then begin
+  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
+  end
+else Error(44);
+{load the number of chars to copy}
+Match(comma,20);
+Expression(fsys+[rparent],fprocp);
+Load;
+Gen0t(pc_stk, cgWord);
+Gen0t(pc_bno, cgWord);
+if gattr.typtr <> nil then begin
+  if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
+  end
+else Error(44);
+{call the copy function}
+Gen1t(pc_csp,86{cpy},cgString);
+gattr.typtr := stringptr;
+gattr.kind := expr;
+end; {Copy}
+
+procedure DoLength(fsys: setofsys; fprocp: ctp);
+{compile a call to Length}
+
+begin {DoLength}
+{load the string}
+Match(lparent,9);
+Expression(fsys+[comma,rparent],fprocp);
+if gattr.typtr <> nil then
+  if IsString(gattr.typtr) then
+    LoadStringAddress
+  else if gattr.typtr = charptr then begin
+    Load;
+    Gen0t(pc_stk, cgUWord);
+    GenLdcLong(-1);
+    Gen0t(pc_stk, cgULong);
+    Gen0t(pc_bno, cgULong);
+    end
+  else Error(44)
+else Error(44);
+gattr.typtr := intptr;
+Gen1t(pc_csp,87{lgt},cgWord);
+end; {DoLength}
+
+procedure Pos(fsys: setofsys; fprocp: ctp);
+{compile a call to find the position of one string in another}
+
+begin {Pos}
+{load the strings}
+Match(lparent,9);
+Expression(fsys+[comma,rparent],fprocp);
+if gattr.typtr <> nil then
+  if IsString(gattr.typtr) then
+    LoadStringAddress
+  else if gattr.typtr = charptr then begin
+    Load;
+    Gen0t(pc_stk, cgUWord);
+    GenLdcLong(-1);
+    Gen0t(pc_stk, cgULong);
+    Gen0t(pc_bno, cgULong);
+    end
+  else Error(44)
+else Error(44);
+Match(comma,20);
+Expression(fsys+[rparent],fprocp);
+if gattr.typtr <> nil then
+  if IsString(gattr.typtr) then
+    LoadStringAddress
+  else if gattr.typtr = charptr then begin
+    Load;
+    Gen0t(pc_stk, cgUWord);
+    GenLdcLong(-1);
+    Gen0t(pc_stk, cgULong);
+    Gen0t(pc_bno, cgULong);
+    end
+  else Error(44)
+else Error(44);
+Gen0t(pc_bno, cgWord);
+{call the pos function}
+Gen1t(pc_csp,88{pos},cgWord);
+gattr.typtr := intptr;
+end; {Pos}
+
+
+procedure DoMember (fsys: setofsys; fprocp: ctp);
+
+{ Compile a call to the member function				}
+{								}
+{ paremeters:							}
+{    fsys - follow symbols					}
+{    fprocp - identifier for program or program-level		}
+{       subroutine contining this statement			}
+
+var
+  lcp: ctp;				{work identifier}
+
+begin {DoMember}
+Match(lparent, 9);
+Expression(fsys+[comma], fprocp);
+Load;
+Match(comma,20);
+if sy = ident then begin
+  SearchId([types], lcp);
+  InSymbol;
+  if lcp <> nil then
+    if lcp^.idtype <> nil then
+      if gattr.typtr <> nil then begin
+	Gen0t(pc_stk, cgULong);
+	if CompObjects(lcp^.idtype, gattr.typtr) then
+	  Gen1t(pc_ldc, lcp^.idtype^.objlevel, cgUWord)
+        else               
+	  Gen1t(pc_ldc, 0, cgUWord);
+	Gen0t(pc_stk, cgUWord);
+	Gen0t(pc_bno, cgUWord);
+        Gen1t(pc_csp, 117{mbr}, cgUWord);
+        end; {if}
+  end {if}
+else
+  Error(2);
+gattr.typtr := boolptr;
+end; {DoMember}
+
+{-- Externally available subroutines ------------------------------------------}
+
+procedure Call {fsys: setofsys; fcp,fprocp: ctp};
+
+{ generate a call to a procedure or function			}
+{								}
+{ parameters:							}
+{    fsys - follow symbols					}
+{    fcp -							}
+{    fprocp -							}
+
+var
+  tkey: keyrange;		      {for saving lkey on recursive fn calls}
+
+begin {Call}
+tkey := lkey;
+if fcp^.pfdeckind = standard then begin
+  lkey := fcp^.key;
+  if fcp^.klass = proc then begin
+
+    {compile standard procedure calls}
+    if iso then
+      if lkey in [3,4,12,16,18..29] then
+        Error(112);
+    if not(lkey in [7,8,13..15,28,29]) then
+      Match(lparent,9);
+    case lkey of
+      1,2,4: getputclose(fsys,fprocp);
+      3,5,6: resetrewriteopen(fsys,fprocp);
+      7,13: DoRead(fsys,fprocp);
+      8,14: DoWrite(fsys,fprocp);
+      9:    DoPack(fsys,fprocp);
+      10:   DoUnpack(fsys,fprocp);
+      11:   DoNew(fsys,fprocp);
+      17:   DoDispose(fsys,fprocp);
+      15:   page(fsys,fprocp);
+      19:   seek(fsys,fprocp);
+      20,21: HaltSeed(fsys,fprocp);
+      22:   Delete(fsys,fprocp);
+      23:   Insert(fsys,fprocp);
+      24,25: CommandLineShellID(fsys,fprocp);
+      26,27: StartGraphDesk(fsys,fprocp);
+      28,29: EndGraphDesk;
+      end; {case}
+    if not(lkey in [7,8,13..15,28,29]) then
+      Match(rparent,4);
+    end
+  else begin
+
+    {compile standard function calls}
+    if iso then
+      if lkey in [18..44] then
+        Error(112);
+    if not(lkey in [10,11,19,21..34,39..41,44]) then begin
+      Match(lparent, 9);
+      Expression(fsys+[rparent], fprocp);
+      Load;
+      end; {if}
+    case lkey of
+      1:     abs;
+      2:     sqr;
+      3,4,42,43: truncround;
+      5:     DoOdd;
+      6:     DoOrd;
+      7:     DoChr;
+      8,9:   predsucc;
+      10,11: DoEOF(fsys,fprocp);
+      12,13,14,15,16,17,36,37,38: trans;
+      18:    DoOrd4;
+      19,32: Cnvfs(fsys,fprocp);
+      20:    Cnvis;
+      21,33: Cnvsf(fsys,fprocp);
+      22:    Cnvsi(fsys,fprocp);
+      23:    Cnvsl(fsys,fprocp);
+      24,31: Randomf;
+      25:    RandomInteger;
+      26:    RandomLongInt;
+      27:    Concat(fsys,fprocp);
+      28:    Copy(fsys,fprocp);
+      29:    DoLength(fsys,fprocp);
+      30:    Pos(fsys,fprocp);
+      34:    DoUserID;
+      35:    DoPointer;
+      39:    DoArctan2(fsys,fprocp);
+      40:    ToolError;
+      41:    DoSizeof;
+      44:    DoMember(fsys, fprocp);
+      end;
+    if not (lkey in [10,11,24..27,31,34,40]) then
+      Match(rparent,4);
+    end;
+  end {else}
+else
+  CallNonStandard(fsys, fcp, fprocp, 0, cStandard);
+lkey := tkey;
+end; {Call}
+
+
+procedure CallNonStandard {fsys: setofsys; fcp,fprocp: ctp; odisp: longint;
+  callKind: callKinds};
+
+{ Handle a call to a user defined procedure/function		}
+{								}
+{ parameters:							}
+{    fsys -							}
+{    fcp -							}
+{    fprocp -							}
+{    odisp - disp in object for method calls; else 0		}
+{    callKind - type of this call				}
+
+label 1,2,3;
+
+var
+  nxt,lcp: ctp;
+  lattr: attr;				{for forming fake parm types}
+  lsp: stp;
+  i: integer;
+  typeNum: baseTypeEnum;
+  pcount: unsigned;			{number of parameters processed}
+
+
+  procedure CheckParm (lcp1,lcp2: ctp);
+
+  { insure that the parm list matches the definition		}
+  {								}
+  { parameters:							}
+  {    lcp1, lcp2 - parameter lists to check			}
+
+  label 1;
+
+  begin {CheckParm}
+  if lcp1 = nil then begin
+    if lcp2 <> nil then Error(52);
+    end
+  else begin
+    while lcp1 <> nil do begin
+      if lcp2 = nil then begin Error(52); goto 1; end;
+      if (lcp1^.idtype <> lcp2^.idtype) or (lcp1^.klass<>lcp2^.klass)
+	then begin Error(59); goto 1; end
+      else begin
+	if lcp1^.klass = varsm then begin
+	  if (lcp1^.vkind <> lcp2^.vkind) or
+	    (lcp1^.vitem <> lcp2^.vitem) then
+	    begin Error(59); goto 1; end
+	  end
+	else {lcp1^.klass = proc or func} begin
+	  CheckParm(lcp1^.pfnext,lcp2^.pfnext);
+	  if lcp1^.klass = func then
+	    if lcp1^.idtype <> lcp2^.idtype then Error(53);
+	  end;
+	end;
+      lcp1 := lcp1^.next;
+      lcp2 := lcp2^.next;
+      end;
+    if lcp2 <> nil then begin Error(52); goto 1; end;
+    end;
+1:  end; {CheckParm}
+
+
+begin {CallNonStandard}
+{get the head of the parameter list; preload indirect call addresses}
+with fcp^ do
+  if pfkind = formal then begin
+    nxt := pfnext;
+    if callKind = cStandard then begin
+      Gen3t(pc_lod, pflabel, 0, level-pflev, cgULong);
+      Gen3t(pc_lod, pflabel, 4, level-pflev, cgUWord);
+      Gen0t(pc_bno, cgUWord);
+      end; {if}
+    end {if}
+  else begin
+    nxt := pfparms;
+    if callKind <> cStandard then
+      nxt := nxt^.next; {skip SELF}
+    end; {else}                       
+
+{for methods, the 'SELF' parameter has already been pushed}
+if callKind in [cMethod,cInherited] then
+  pcount := 1
+else
+  pcount := 0;
+
+{compile the call's parameter list}
+if sy = lparent then begin
+  repeat
+    InSymbol;
+    {check for too many parms}
+    if nxt = nil then begin
+      Error(52);
+      goto 1;
+      end;
+    {handle procs and funcs in parm list}
+    if nxt^.klass in [proc,func] then begin
+      if sy <> ident then begin
+	Error(2);
+	Skip(fsys + [comma,rparent]);
+	end
+      else begin
+	if nxt^.klass = proc then
+          SearchId([proc],lcp)
+	else begin
+	  SearchId([func],lcp);
+	  if lcp^.idtype <> nxt^.idtype then
+            Error(53);
+	  end; {else}
+	if lcp <> nil then with lcp^ do begin
+	  if pfkind = formal then begin
+	    CheckParm(pfnext,nxt^.pfnext);
+            Gen3t(pc_lod, pflabel, 4, level-pflev, cgUWord);
+	    Gen0t(pc_stk, cgUWord);
+	    if pcount <> 0 then
+	      Gen0t(pc_bno, cgUWord);
+	    pcount := pcount+1;
+	    Gen3t(pc_lod, pflabel, 0, level-pflev, cgULong);
+	    end {if}
+	  else begin
+	    CheckParm(pfparms, nxt^.pfnext);
+            Gen1(pc_lsl, level-pflev);
+	    Gen0t(pc_stk, cgUWord);
+	    if pcount <> 0 then
+	      Gen0t(pc_bno, cgUWord);
+	    pcount := pcount+1;
+	    if pflev = 1 then
+	      Gen0Name(pc_lad,lcp^.name)
+	    else
+	      Gen1(pc_lla, pfname);
+	    end;
+	  Gen0t(pc_stk, cgULong);
+	  end;
+	InSymbol;
+	if not (sy in fsys + [comma,rparent]) then begin
+	  Error(6);
+	  Skip(fsys + [comma,rparent]);
+	  end;
+	end;
+      goto 2;
+      end;
+    {handle expressions in parm list}
+    if sy = stringConst then
+      if nxt <> nil then
+	if nxt^.vkind = actual then
+	  if IsString(nxt^.idtype) then begin
+	    if StrLen(nxt^.idtype) < 0 then
+	      LoadString(lengthString)
+	    else
+	      LoadString(nullString);
+	    InSymbol;
+	    goto 3;
+	    end; {if}
+1:  Expression(fsys + [comma,rparent],fprocp);
+3:  if gattr.typtr <> nil then
+      if nxt <> nil then begin
+	lsp := nxt^.idtype;
+	if lsp <> nil then begin
+	  if (nxt^.vkind = actual) then begin
+	    if lsp^.form <= power then begin
+	      if gattr.typtr^.form <= power then
+		Load
+	      else
+		LoadAddress;
+	      CheckBnds(lsp);
+	      if IsReal(lsp) then begin
+		if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
+		  begin
+		  Gen2(pc_cnv,ord(cgWord),ord(cgExtended));
+		  gattr.typtr := realptr;
+		  end
+		else if gattr.typtr = longptr then begin
+		  Gen2(pc_cnv,ord(cgLong),ord(cgExtended));
+		  gattr.typtr := realptr;
+		  end;
+		end
+	      else if lsp = longptr then begin
+		if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
+		  begin
+		  Gen2(pc_cnv, ord(cgWord), ord(cgLong));
+		  gattr.typtr := longptr;
+		  end;
+                end {else if}
+              else if nxt^.vuniv then
+                if ParmSize(lsp, actual) = 4 then
+                  if ParmSize(gattr.typtr, actual) = 2 then begin
+		    Gen2(pc_cnv, ord(cgWord), ord(cgLong));
+		    gattr.typtr := longptr;
+                    end; {if}
+              case GetType(gattr.typtr, gattr.isPacked) of
+		cgByte,cgUByte,cgWord,cgUWord:
+		  Gen0t(pc_stk, cgWord);
+                cgLong,cgULong,cgString:
+		  Gen0t(pc_stk, cgLong);
+		cgReal,cgDouble,cgComp,cgExtended:
+		  Gen0t(pc_stk, cgExtended);
+                cgSet:
+		  Gen1(pc_siz, ord(lsp^.size));
+		otherwise: ;
+		end; {case}
+	      end
+	    else if gattr.typtr^.form = objects then begin
+	      Load;
+	      if debug then
+		GenL2t(pc_chk, 1, maxaddr, cgULong);
+	      Gen0t(pc_stk, cgULong);
+              end {else if}
+	    else if gattr.typtr^.form = records then begin
+	      {value records <= 4 bytes passed by value; otherwise    }
+	      { pass an address					      }
+	      if gattr.typtr^.size <= 4 then
+		if gattr.typtr^.size <= 2 then begin
+		  lattr := gattr;
+		  gattr.typtr := intptr;
+		  Load;
+		  Gen0t(pc_stk, cgWord);
+		  gattr := lattr;
+		  end {if}
+		else begin
+		  lattr := gattr;
+		  gattr.typtr := longptr;
+		  Load;
+		  Gen0t(pc_stk, cgLong);
+		  gattr := lattr;
+		  end {else}
+	      else begin
+		LoadAddress;
+		Gen0t(pc_stk, cgULong);
+		end;
+	      end {else if}
+            else if IsString(lsp) then begin
+              if gattr.kind = expr then begin
+	        LoadAddress;
+	        Gen0t(pc_stk, cgULong);
+                if StrLen(lsp) < 0 then
+                  Gen1t(pc_csp, 119{fxp}, cgULong)
+                else
+                  Gen1t(pc_csp, 120{fxc}, cgULong);
+                end {if}
+              else
+	        LoadAddress;
+	      Gen0t(pc_stk, cgULong);
+	      end {else if}
+	    else begin
+	      LoadAddress;
+	      Gen0t(pc_stk, cgULong);
+	      end; {else}
+	    if not CompTypes(lsp,gattr.typtr) then
+	      if (ParmSize(lsp,actual) <> ParmSize(gattr.typtr,actual)) then
+		Error(67);
+	    end
+	  else begin
+	    if lsp <> gattr.typtr then
+	      if not nxt^.vuniv then
+		Error(67);
+	    if gattr.kind = varbl then begin
+	      LoadAddress;
+	      Gen0t(pc_stk, cgULong);
+	      end {if}
+	    else
+	      Error(78);
+	    if glcp <> nil then with glcp^ do begin
+	      if klass = varsm then begin
+		if vcontvar then Error(97);
+		if vlev <> level then vrestrict := true;
+		end
+	      else if klass = field then
+		if fldvar then Error(95);
+	      end;
+	    if gispacked then Error(95);
+	    end;
+	  end
+	end;
+2:  {next parm in definition}
+    if nxt <> nil then
+      nxt := nxt^.next;
+    if pcount <> 0 then
+      Gen0t(pc_bno, cgWord);
+    pcount := pcount+1;
+  until sy <> comma;
+  Match(rparent,4);
+  end; {if}
+if pcount = 0 then
+  Gen0(pc_nop);
+
+{check for not enough parameters}
+if nxt <> nil then
+  Error(52);
+
+{generate the call}
+with fcp^ do begin
+  if klass <> func then
+    typeNum := cgVoid
+  else begin
+    if idtype = realptr then
+      typeNum := cgReal
+    else if idtype = doubleptr then
+      typeNum := cgDouble
+    else if idtype = compptr then
+      typeNum := cgComp
+    else if idtype = extendedptr then
+      typeNum := cgExtended
+    else if idtype = longptr then
+      typeNum := cgLong
+    else if idtype^.form = pointerStruct then
+      typeNum := cgULong
+    else
+      typeNum := cgWord;
+    end; {else}
+  if callKind = cMethod then
+    GenL1t(pc_cum, odisp, typeNum)
+  else if pfkind = formal then
+    Gen0t(pc_cui, typeNum)
+  else {if pfkind = actual then}
+    case pfdirective of
+      drnone,drforw,drextern: {standard calls}
+	if pflev = 1 then
+	  Gen1tName(pc_cup, level-pflev, typeNum, fcp^.pfoname)
+	else
+	  Gen2t(pc_cup, pfname, level-pflev, typeNum);
+      drprodos: {in line prodos call}
+	Gen1(pc_pds, pfcallnum);
+      drtool1,drtool2,drvector: begin {in line tool call with passed parms}
+	if pfdirective = drtool1 then
+	   Gen2t(pc_tl1, pftoolnum, pfcallnum, typeNum)
+	else if pfdirective = drtool2 then
+	   Gen2t(pc_tl2, pftoolnum, pfcallnum, typeNum)
+	else
+           Gen1L1t(pc_vct, pfcallnum, pfaddr, typeNum);
+	if klass = func then
+	  if idtype = boolptr then begin
+	    Gen1t(pc_ldc, 0, cgWord);
+	    Gen0t(pc_neq, cgWord);
+	    end; {if}
+	end;
+      end; {case}
+  end;
+{for functions, set the return type}
+gattr.typtr := fcp^.idtype
+end; {CallNonStandard}
+
+
+procedure CheckBool;
+{load a value, insuring that it is boolean}
+
+begin {CheckBool}
+load;
+if gattr.typtr <> nil then
+  if gattr.typtr <> boolptr then Error(60);
+end; {CheckBool}
+
+procedure CheckBnds{fsp: stp};
+{generate range checking code (if needed)}
+
+var
+  lmin,lmax: integer;
+
+begin {CheckBnds}
+if debug then
+  if fsp <> nil then
+    if fsp = charptr then
+      Gen2t(pc_chk, ordminchar, ordmaxchar, cgUWord)
+    else if fsp^.form = subrange then
+      if fsp^.rangetype = longptr then
+        GenL2t(pc_chk, fsp^.min, fsp^.max, cgULong)
+      else
+        Gen2t(pc_chk, long(fsp^.min).lsw, long(fsp^.max).lsw, cgUWord);
+end; {CheckBnds}
+
+
+procedure FreeTemp{labelNum, size: integer};
+
+{ place a temporary label in the available label list		}
+{								}
+{ parameters:							}
+{    labelNum - number of the label to free			}
+{    size - size of the variable 				}
+{								}
+{ variables:							}
+{    tempList - list of free labels				}
+
+var
+   tl: tempPtr;				{work pointer}
+
+begin {FreeTemp}
+new(tl);
+tl^.next := tempList;
+tl^.last := nil;
+tl^.labelNum := labelNum;
+tl^.size := size;
+if tempList <> nil then
+   tempList^.last := tl;
+tempList := tl;
+end; {FreeTemp}
+
+
+function GetTemp{size: integer): integer};
+
+{ find a temporary work variable 				}
+{								}
+{ parameters:							}
+{    size - size of the variable 				}
+{								}
+{ variables:							}
+{    tempList - list of free labels				}
+{								}
+{ Returns the label number.					}
+
+label 1;
+
+var
+   ln: integer;				{label number}
+   tl: tempPtr;				{work pointer}
+
+begin {GetTemp}
+{try to find a temp from the existing list}
+tl := tempList;
+while tl <> nil do begin
+   if tl^.size = size then begin
+
+      {found an old one - use it}
+      if tl^.last = nil then
+	 tempList := tl^.next
+      else
+	 tl^.last^.next := tl^.next;
+      if tl^.next <> nil then
+	 tl^.next^.last := tl^.last;
+      GetTemp := tl^.labelNum;
+      goto 1;
+      end; {if}
+   tl := tl^.next;
+   end; {while}
+
+{none found - get a new one}
+ln := GetLocalLabel;
+GetTemp := ln;
+Gen2(dc_loc, ln, size);
+1:
+end; {GetTemp}
+
+
+procedure Load;
+{load a value onto the evaluation stack}
+
+var
+  lmt: addrrange;			{temp disp}
+  ltype: stp;				{base type}
+
+begin {Load}
+with gattr do
+  if typtr <> nil then begin
+    ltype := typtr;
+    if ltype^.form = subrange then
+      ltype := ltype^.rangetype;
+    case kind of
+      cst:   if (ltype^.form = scalar) and (not IsReal(ltype)) then
+	       if ltype = boolptr then
+		 Gen1t(pc_ldc, cval.ival, cgUWord)
+	       else if ltype=charptr then
+		 Gen1t(pc_ldc, cval.ival, cgUWord)
+	       else if ltype = longptr then
+		 GenLdcLong(cval.valp^.lval)
+	       else if cval.ival >= 0 then
+		 Gen1t(pc_ldc, cval.ival, cgUWord)
+               else
+		 Gen1t(pc_ldc, cval.ival, cgWord)
+	     else if ltype = nilptr then
+	       GenLdcLong(0)
+	     else if IsReal(ltype) then
+	       GenLdcReal(cval.valp^.rval)
+	     else
+	       GenLdcSet(cval.valp^);
+      varbl: begin
+	     if access = drct then
+	       if dpdisp > maxint then begin
+		 lmt := dpdisp;
+		 if vlevel <= 1 then
+		   Gen1Name(pc_lao, 0, aname)
+		 else
+		   Gen3(pc_lda, gattr.dplab, 0, 0);
+		 access := indrct;
+		 idplmt := lmt;
+		 end; {if}
+	     case access of
+	       drct:   if ltype^.form = power then begin
+			 if vlevel<=1 then
+			   Gen2tName(pc_ldo, long(dpdisp).lsw, ord(typtr^.size),
+			     cgSet, aname)
+			 else
+			   Gen4t(pc_lod, gattr.dplab, long(dpdisp).lsw,
+                             level-vlevel, ord(typtr^.size), cgSet);
+			 end {if}
+		       else begin
+			 if vlevel<=1 then
+			   Gen1tName(pc_ldo, long(dpdisp).lsw,
+                             GetType(typtr, isPacked), aname)
+			 else
+			   Gen3t(pc_lod, gattr.dplab, long(dpdisp).lsw,
+                             level-vlevel, GetType(typtr, isPacked));
+			 end; {else}
+	       indrct: begin
+		       if idplmt >= maxint then begin
+			 GenLdcLong(idplmt);
+			 Gen0(pc_adl);
+			 idplmt := 0;
+			 end; {if}
+		       if ltype^.form = power then
+			 Gen2t(pc_ind, ord(idplmt), ord(typtr^.size), cgSet)
+		       else
+			 Gen1t(pc_ind, ord(idplmt), GetType(typtr, isPacked));
+		       end;
+	       inxd:   Error(113)
+	       end; {case}
+             end;
+      otherwise:
+      end;
+    typtr := ltype;
+    kind := expr;
+    end;
+end; {Load}
+
+procedure LoadAddress;
+{load the address of a variable onto the top of the stack}
+
+var
+  lmt: addrrange;			{temp disp}
+
+begin {LoadAddress}
+with gattr do
+  if typtr <> nil then begin
+    if typtr^.form = subrange then
+      typtr := typtr^.rangetype;
+    case kind of
+      cst:   if IsString(typtr) then
+	       GenPS(pc_lca, @cval.valp^.sval)
+	     else
+	       Error(113);
+      varbl: begin
+	     if access = drct then
+	       if dpdisp > maxint then begin
+		 lmt := dpdisp;
+		 if vlevel <= 1 then
+		   Gen1Name(pc_lao, 0, aname)
+		 else
+		   Gen3(pc_lda, gattr.dplab, 0, 0);
+		 access := indrct;
+		 idplmt := lmt;
+		 end; {if}
+	     case access of
+	       drct:   if vlevel <= 1 then
+			 Gen1Name(pc_lao, long(dpdisp).lsw, aname)
+		       else
+			 Gen3(pc_lda, dplab, level-vlevel, long(dpdisp).lsw);
+	       indrct: begin
+		       if idplmt >= maxint then begin
+			 GenLdcLong(idplmt);
+			 Gen0(pc_adl);
+			 end {if}
+		       else
+			 Gen1t(pc_inc,ord(idplmt),cgULong);
+		       end;
+	       inxd:   Error(113)
+	       end; {case}
+	     end;
+      expr:  if typtr <> stringPtr then Error(113);
+      end;
+    kind := varbl;
+    access := indrct;
+    idplmt := 0;
+    end
+end; {LoadAddress}
+
+procedure LoadStringAddress;
+{load the address and length of a string}
+
+var
+  lattr: attr;
+
+begin {LoadStringAddress}
+lattr := gattr;
+LoadAddress;
+Gen0t(pc_stk, cgULong);
+if lattr.kind <> expr then begin
+  Gen1t(pc_ldc, StrLen(gattr.typtr), cgUWord);
+  Gen0t(pc_stk, cgUWord);
+  Gen0t(pc_bno, cgUWord);
+  end; {if}
+end; {LoadStringAddress}
+
+procedure LoadString {kind: stringKind};
+
+{ load the address of a string constant				}
+{								}
+{ parameters:							}
+{    kind - string kind						}
+
+var
+   i: unsigned;				{loop variable}
+   len: unsigned;			{length of the string}
+   tch: char;				{temp for building string from char}
+
+begin {LoadString}
+if lgth = 1 then begin			{if the length is 1, make a string   }
+   tch := chr(val.ival); 		{ from a character		     }
+   val.valp := pointer(Malloc(sizeof(constantRec)));
+   with val.valp^ do begin
+      cclass := strg;
+      sval[0] := chr(1);
+      sval[1] := tch;
+      end; {with}
+   end; {if}
+with val.valp^ do begin
+   if lgth = 0 then begin		{for a nul string, use two zeros}
+      sval[0] := chr(2);
+      sval[1] := chr(0);
+      sval[2] := chr(0);
+      end {if}
+   else if kind = lengthString then begin {add the length byte}
+      len := length(sval);
+      for i := len downto 1 do
+	 sval[i+1] := sval[i];
+      sval[1] := sval[0];
+      sval[0] := chr(len+2);
+      end {else}
+   else					{bump the length for the null terminator}
+      sval[0] := succ(sval[0]);
+   sval[ord(sval[0])] := chr(0);	{place a trailing nul on the string}
+   gattr.cval := val;			{set up for the load}
+   gattr.typtr := stringptr;
+   gattr.kind := cst;
+   gattr.isPacked := false;
+   end; {with}
+end; {LoadString}
+
+
+function ParmSize {lsp: stp; vkind: idkind): integer};
+
+{ find the length of a parameter				}
+{								}
+{ parameters:							}
+{    lsp -							}
+{    vkind -							}
+{								}
+{ Returns: stack size of parameter, in bytes			}
+
+begin {ParmSize}
+ParmSize := ptrsize;
+if lsp <> nil then
+  with lsp^ do
+    if vkind = actual then
+      if form <= power then begin
+	ParmSize := ord(size);
+	if IsReal(lsp) then
+	  ParmSize := extSize
+	else if lsp = byteptr then
+	  ParmSize := intSize;
+	end {if}
+      else if form = records then
+	if size <= 2 then
+	  ParmSize := 2;
+end; {ParmSize}
+
+
+procedure ResetTemp;
+
+{ forget all of the temporary work variables			}
+
+var
+   tl: tempPtr;				{work pointer}
+
+begin {ResetTemp}
+while tempList <> nil do begin
+  tl := tempList;
+  tempList := tl^.next;
+  dispose(tl);
+  end; {while}
+end; {ResetTemp}
+
+
+procedure Store{var fattr: attr};
+{store the value on top of stack}
+
+var
+  lmt: addrrange;			{temp disp}
+
+begin {Store}
+with fattr do
+  if typtr <> nil then begin
+    case access of
+      drct:   if typtr^.form = power then begin
+		if vlevel <= 1 then
+		  Gen2tName(pc_sro, long(dpdisp).lsw, ord(typtr^.size), cgSet,
+		    aname)
+		else
+		  Gen4t(pc_str, dplab, long(dpdisp).lsw, level-vlevel,
+		    ord(typtr^.size), cgSet);
+		end
+	      else begin
+		if vlevel <= 1 then
+		  Gen1tName(pc_sro, long(dpdisp).lsw, GetType(typtr, isPacked),
+                    aname)
+		else
+		  Gen3t(pc_str, dplab, long(dpdisp).lsw, level-vlevel,
+		    GetType(typtr, isPacked));
+		end;
+      indrct: begin
+	      if typtr^.form = power then
+		Gen1t(pc_sto, ord(typtr^.size), cgSet)
+	      else
+		Gen0t(pc_sto, GetType(typtr, isPacked));
+	      end;
+      inxd:   Error(113)
+      end; {case}
+    end; {if}
+end; {Store}
+
+end.
diff --git a/cgc.asm b/cgc.asm
old mode 100755
new mode 100644
index e03b76f..de71d4c
--- a/cgc.asm
+++ b/cgc.asm
@@ -1 +1,34 @@
-	mcopy	cgc.macros
****************************************************************
*
*  CnvSX - Convert floating point to SANE extended
*
*  Inputs:
*        rec - pointer to a record
*
****************************************************************
*
CnvSX    start
rec      equ   4                        record containing values
rec_real equ   0                        disp to real value
rec_ext  equ   8                        disp to extended (SANE) value

         tsc                            set up DP
         phd
         tcd
         ph4   rec                      push addr of real number
         clc                            push addr of SANE number
         lda   rec
         adc   #rec_ext
         tax
         lda   rec+2
         adc   #0
         pha
         phx
         fd2x                           convert TOS to extended
         move4 0,4                      return
         pld
         pla
         pla
         rtl
         end
\ No newline at end of file
+	mcopy	cgc.macros
+****************************************************************
+*
+*  CnvSX - Convert floating point to SANE extended
+*
+*  Inputs:
+*        rec - pointer to a record
+*
+****************************************************************
+*
+CnvSX    start
+rec      equ   4                        record containing values
+rec_real equ   0                        disp to real value
+rec_ext  equ   8                        disp to extended (SANE) value
+
+         tsc                            set up DP
+         phd
+         tcd
+         ph4   rec                      push addr of real number
+         clc                            push addr of SANE number
+         lda   rec
+         adc   #rec_ext
+         tax
+         lda   rec+2
+         adc   #0
+         pha
+         phx
+         fd2x                           convert TOS to extended
+         move4 0,4                      return
+         pld
+         pla
+         pla
+         rtl
+         end
diff --git a/cgc.macros b/cgc.macros
old mode 100755
new mode 100644
index cf7e582..2a32ccc
--- a/cgc.macros
+++ b/cgc.macros
@@ -1 +1,188 @@
- macro
&l move4 &m1,&m2
 lclb &yistwo
&l ~setm
 ~lda &m1
 ~sta &m2
 ~lda.h &m1
 ~sta.h &m2
 ~restm
 mend
 macro
&l ph4 &n1
 aif "&n1"="*",.f
 lclc &c
&l anop
&c amid &n1,1,1
 aif "&c"="#",.d
 aif s:longa=1,.a
 rep #%00100000
.a
 aif "&c"<>"{",.b
&c amid &n1,l:&n1,1
 aif "&c"<>"}",.g
&n1 amid &n1,2,l:&n1-2
 ldy #2
 lda (&n1),y
 pha
 lda (&n1)
 pha
 ago .e
.b
 aif "&c"<>"[",.c
 ldy #2
 lda &n1,y
 pha
 lda &n1
 pha
 ago .e
.c
 aif "&c"<>"<",.c1
&n1 amid &n1,2,l:&n1-1
 pei &n1+2
 pei &n1
 ago .e
.c1
 lda &n1+2
 pha
 lda &n1
 pha
 ago .e
.d
&n1 amid &n1,2,l:&n1-1
 pea +(&n1)|-16
 pea &n1
 ago .f
.e
 aif s:longa=1,.f
 sep #%00100000
.f
 mexit
.g
 mnote "Missing closing '}'",16
 mend
 macro
&l ~lda &op
 lclc &c
&c amid "&op",1,1
 aif "&c"<>"{",.b
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
&l lda &op
 mend
 macro
&l ~lda.h &op
&l anop
 lclc &c
&c amid "&op",1,1
 aif "&c"="[",.b
 aif "&c"<>"{",.d
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
 aif &yistwo,.c
&yistwo setb 1
 ldy #2
.c
&op setc "&op,y"
 lda &op
 mexit
.d
 aif "&c"<>"#",.e
&op amid "&op",2,l:&op-1
&op setc "#^&op"
 lda &op
 mexit
.e
 lda 2+&op
 mend
 macro
&l ~restm
&l anop
 aif (&~la+&~li)=2,.i
 sep #32*(.not.&~la)+16*(.not.&~li)
 aif &~la,.h
 longa off
.h
 aif &~li,.i
 longi off
.i
 mend
 macro
&l ~setm
&l anop
 aif c:&~la,.b
 gblb &~la
 gblb &~li
.b
&~la setb s:longa
&~li setb s:longi
 aif s:longa.and.s:longi,.a
 rep #32*(.not.&~la)+16*(.not.&~li)
 longa on
 longi on
.a
 mend
 macro
&l ~sta &op
 lclc &c
&c amid "&op",1,1
 aif "&c"<>"{",.b
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
&l sta &op
 mend
 macro
&l ~sta.h &op
&l anop
 lclc &c
&c amid "&op",1,1
 aif "&c"="[",.b
 aif "&c"<>"{",.d
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
 aif &yistwo,.c
&yistwo setb 1
 ldy #2
.c
&op setc "&op,y"
 sta &op
 mexit
.d
 sta 2+&op
 mend
 MACRO
&LAB FD2X
&LAB PEA $010E
 LDX #$090A
 JSL $E10000
 MEND
 MACRO
&LAB FX2C
&LAB PEA $0510
 LDX #$090A
 JSL $E10000
 MEND
\ No newline at end of file
+ macro
+&l move4 &m1,&m2
+ lclb &yistwo
+&l ~setm
+ ~lda &m1
+ ~sta &m2
+ ~lda.h &m1
+ ~sta.h &m2
+ ~restm
+ mend
+ macro
+&l ph4 &n1
+ aif "&n1"="*",.f
+ lclc &c
+&l anop
+&c amid &n1,1,1
+ aif "&c"="#",.d
+ aif s:longa=1,.a
+ rep #%00100000
+.a
+ aif "&c"<>"{",.b
+&c amid &n1,l:&n1,1
+ aif "&c"<>"}",.g
+&n1 amid &n1,2,l:&n1-2
+ ldy #2
+ lda (&n1),y
+ pha
+ lda (&n1)
+ pha
+ ago .e
+.b
+ aif "&c"<>"[",.c
+ ldy #2
+ lda &n1,y
+ pha
+ lda &n1
+ pha
+ ago .e
+.c
+ aif "&c"<>"<",.c1
+&n1 amid &n1,2,l:&n1-1
+ pei &n1+2
+ pei &n1
+ ago .e
+.c1
+ lda &n1+2
+ pha
+ lda &n1
+ pha
+ ago .e
+.d
+&n1 amid &n1,2,l:&n1-1
+ pea +(&n1)|-16
+ pea &n1
+ ago .f
+.e
+ aif s:longa=1,.f
+ sep #%00100000
+.f
+ mexit
+.g
+ mnote "Missing closing '}'",16
+ mend
+ macro
+&l ~lda &op
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"<>"{",.b
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+&l lda &op
+ mend
+ macro
+&l ~lda.h &op
+&l anop
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"="[",.b
+ aif "&c"<>"{",.d
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+ aif &yistwo,.c
+&yistwo setb 1
+ ldy #2
+.c
+&op setc "&op,y"
+ lda &op
+ mexit
+.d
+ aif "&c"<>"#",.e
+&op amid "&op",2,l:&op-1
+&op setc "#^&op"
+ lda &op
+ mexit
+.e
+ lda 2+&op
+ mend
+ macro
+&l ~restm
+&l anop
+ aif (&~la+&~li)=2,.i
+ sep #32*(.not.&~la)+16*(.not.&~li)
+ aif &~la,.h
+ longa off
+.h
+ aif &~li,.i
+ longi off
+.i
+ mend
+ macro
+&l ~setm
+&l anop
+ aif c:&~la,.b
+ gblb &~la
+ gblb &~li
+.b
+&~la setb s:longa
+&~li setb s:longi
+ aif s:longa.and.s:longi,.a
+ rep #32*(.not.&~la)+16*(.not.&~li)
+ longa on
+ longi on
+.a
+ mend
+ macro
+&l ~sta &op
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"<>"{",.b
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+&l sta &op
+ mend
+ macro
+&l ~sta.h &op
+&l anop
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"="[",.b
+ aif "&c"<>"{",.d
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+ aif &yistwo,.c
+&yistwo setb 1
+ ldy #2
+.c
+&op setc "&op,y"
+ sta &op
+ mexit
+.d
+ sta 2+&op
+ mend
+ MACRO
+&LAB FD2X
+&LAB PEA $010E
+ LDX #$090A
+ JSL $E10000
+ MEND
+ MACRO
+&LAB FX2C
+&LAB PEA $0510
+ LDX #$090A
+ JSL $E10000
+ MEND
diff --git a/cgc.pas b/cgc.pas
old mode 100755
new mode 100644
index 6735084..af800ab
--- a/cgc.pas
+++ b/cgc.pas
@@ -1 +1,251 @@
-{$optimize -1}
{---------------------------------------------------------------}
{                                                               }
{  ORCA Code Generator Common                                   }
{                                                               }
{  This unit contains the command constants, types,             }
{  variables and procedures used throughout the code            }
{  generator, but which are not available to the compiler.      }
{                                                               }
{---------------------------------------------------------------}
{                                                               }
{  These routines are defined in the compiler, but used from    }
{  the code generator.                                          }
{                                                               }
{  Error - flag an error                                        }
{  CMalloc - Clear and allocate memory from a pool.             }
{  Malloc - Allocate memory from a pool.                        }
{                                                               }
{---------------------------------------------------------------}

unit CGC;

interface

{$LibPrefix '0/obj/'}

uses PCommon, CGI;

{$segment 'cg'}

const
                                        {Code Generation}
                                        {---------------}
   maxCBuff     =       191;            {length of constant buffer}

                                        {65816 native code generation}
                                        {----------------------------}
                                        {instruction modifier flags}
   shift8                 =      1;     {shift operand left 8 bits}
   shift16                =      2;     {shift operand left 16 bits}
   toolCall               =      4;     {generate a tool call}
   stringReference        =      8;     {generate a string reference}
   usertoolCall           =     16;     {generate a usertool call}
   isPrivate              =     32;     {is the label private?}
   constantOpnd           =     64;     {the absolute operand is a constant}
   localLab               =    128;     {the operand is a local lab}
   sub1                   =    256;     {subtract 1 from the operand}

   m_adc_abs              =    $6D;     {op code #s for 65816 instructions}
   m_adc_dir              =    $65;
   m_adc_imm              =    $69;
   m_adc_s                =    $63;
   m_and_abs              =    $2D;
   m_and_dir              =    $25;
   m_and_imm              =    $29;
   m_and_s                =    $23;
   m_asl_a                =    $0A;
   m_bcc                  =    $90;
   m_bcs                  =    $B0;
   m_beq                  =    $F0;
   m_bit_imm              =    $89;
   m_bmi                  =    $30;
   m_bne                  =    $D0;
   m_bpl                  =    $10;
   m_bra                  =    $80;
   m_brl                  =    $82;
   m_bvs                  =    $70;
   m_clc                  =    $18;
   m_cmp_abs              =    $CD;
   m_cmp_dir              =    $C5;
   m_cmp_dirX             =    $D5;
   m_cmp_imm              =    $C9;
   m_cmp_long             =    $CF;
   m_cmp_s                =    $C3;
   m_cop                  =    $02;
   m_cpx_abs              =    236;
   m_cpx_dir              =    228;
   m_cpx_imm              =    224;
   m_dea                  =     58;
   m_dec_abs              =    206;
   m_dec_absX             =    $DE;
   m_dec_dir              =    198;
   m_dec_dirX             =    214;
   m_dex                  =    202;
   m_dey                  =    136;
   m_eor_abs              =     77;
   m_eor_dir              =     69;
   m_eor_imm              =     73;
   m_eor_s                =     67;
   m_ina                  =     26;
   m_inc_abs              =    238;
   m_inc_absX             =    $FE;
   m_inc_dir              =    230;
   m_inc_dirX             =    246;
   m_inx                  =    232;
   m_iny                  =    200;
   m_jml                  =     92;
   m_jsl                  =     34;
   m_lda_abs              =    173;
   m_lda_absx             =    189;
   m_lda_dir              =    165;
   m_lda_dirx             =    181;
   m_lda_imm              =    169;
   m_lda_indl             =    167;
   m_lda_indly            =    183;
   m_lda_long             =    175;
   m_lda_longx            =    191;
   m_lda_s                =    163;
   m_ldx_abs              =    174;
   m_ldx_dir              =    166;
   m_ldx_imm              =    162;
   m_ldy_abs              =    172;
   m_ldy_absX             =    188;
   m_ldy_dir              =    164;
   m_ldy_dirX             =    180;
   m_ldy_imm              =    160;
   m_lsr_a                =     74;
   m_mvn                  =     84;
   m_ora_abs              =     13;
   m_ora_dir              =      5;
   m_ora_dirX             =     21;
   m_ora_imm              =      9;
   m_ora_longX            =     31;
   m_ora_s                =      3;
   m_pea                  =    244;
   m_pei_dir              =    212;
   m_pha                  =     72;
   m_phb                  =    139;
   m_phd                  =     11;
   m_phk                  =    $4B;
   m_phx                  =    218;
   m_phy                  =     90;
   m_php                  =      8;
   m_pla                  =    104;
   m_plb                  =    171;
   m_pld                  =     43;
   m_plx                  =    250;
   m_ply                  =    122;
   m_plp                  =     40;
   m_rep                  =    194;
   m_rtl                  =    107;
   m_rts                  =     96;
   m_sbc_abs              =    237;
   m_sbc_dir              =    229;
   m_sbc_imm              =    233;
   m_sbc_s                =    227;
   m_sec                  =     56;
   m_sep                  =    226;
   m_sta_abs              =    141;
   m_sta_absX             =    157;
   m_sta_dir              =    133;
   m_sta_dirX             =    149;
   m_sta_indl             =    135;
   m_sta_indlY            =    151;
   m_sta_long             =    143;
   m_sta_longX            =    159;
   m_sta_s                =    131;
   m_stx_dir              =    134;
   m_stx_abs              =    142;
   m_sty_abs              =    140;
   m_sty_dir              =    132;
   m_sty_dirX             =    148;
   m_stz_abs              =    156;
   m_stz_absX             =    158;
   m_stz_dir              =    100;
   m_stz_dirX             =    116;
   m_tax                  =    170;
   m_tay                  =    168;
   m_tcd                  =     91;
   m_tcs                  =     27;
   m_tdc                  =    123;
   m_tsx                  =    $BA;
   m_txa                  =    138;
   m_txs                  =    $9A;
   m_txy                  =    155;
   m_tya                  =    152;
   m_tyx                  =    187;
   m_tsb_dir              =    $04;
   m_tsb_abs              =    $0C;
   m_tsc                  =     59;
   m_xba                  =    $EB;

   d_lab                  =    256;
   d_end                  =    257;
   d_bmov                 =    258;
   d_add                  =    259;
   d_pin                  =    260;
   d_wrd                  =    261;
   d_sym                  =    262;
   d_cns                  =    263;

   max_opcode             =    263;

type
                                        {pcode code generation}
                                        {---------------------}
   realrec = record                     {used to convert from real to in-SANE}
      itsReal: double;
      inSANE: packed array[1..10] of byte;
      inCOMP: packed array[1..8] of byte;
      end;

                                        {65816 native code generation}
                                        {----------------------------}
   labelptr = ^labelentry;              {pointer to a forward ref node}
   labelentry = record                  {forward ref node}
      addr: integer;
      next: labelptr;
      end;

   labelrec = record                    {label record}
      defined: boolean;                 {Note: form used in objout.asm}
      chain: labelptr;
      case boolean of
         true : (val: longint);
         false: (ival,hval: integer);
      end;

var
                                        {msc}
                                        {---}
   blkcnt: integer;                     {number of bytes in current segment}

                                        {buffers}
                                        {-------}
   cbufflen: 0..maxcbuff;               {number of bytes now in cbuff}
   segDisp: integer;                    {disp in the current segment}

                                        {65816 native code generation}
                                        {----------------------------}
   labeltab: array[0..maxlabel] of labelrec; {label table}
   localLabel: array[0..maxLocalLabel] of integer; {local variable label table}
   pc: longint;                         {program counter}

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

procedure CnvSX (rec: realrec); extern;

{ convert a real number to SANE extended format                 }
{                                                               }
{ parameters:                                                   }
{       rec - record containing the value to convert; also      }
{               has space for the result                        }

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

implementation

end.

{$append 'CGC.asm'}
\ No newline at end of file
+{$optimize -1}
+{---------------------------------------------------------------}
+{                                                               }
+{  ORCA Code Generator Common                                   }
+{                                                               }
+{  This unit contains the command constants, types,             }
+{  variables and procedures used throughout the code            }
+{  generator, but which are not available to the compiler.      }
+{                                                               }
+{---------------------------------------------------------------}
+{                                                               }
+{  These routines are defined in the compiler, but used from    }
+{  the code generator.                                          }
+{                                                               }
+{  Error - flag an error                                        }
+{  CMalloc - Clear and allocate memory from a pool.             }
+{  Malloc - Allocate memory from a pool.                        }
+{                                                               }
+{---------------------------------------------------------------}
+
+unit CGC;
+
+interface
+
+{$LibPrefix '0/obj/'}
+
+uses PCommon, CGI;
+
+{$segment 'cg'}
+
+const
+                                        {Code Generation}
+                                        {---------------}
+   maxCBuff     =       191;            {length of constant buffer}
+
+                                        {65816 native code generation}
+                                        {----------------------------}
+                                        {instruction modifier flags}
+   shift8                 =      1;     {shift operand left 8 bits}
+   shift16                =      2;     {shift operand left 16 bits}
+   toolCall               =      4;     {generate a tool call}
+   stringReference        =      8;     {generate a string reference}
+   usertoolCall           =     16;     {generate a usertool call}
+   isPrivate              =     32;     {is the label private?}
+   constantOpnd           =     64;     {the absolute operand is a constant}
+   localLab               =    128;     {the operand is a local lab}
+   sub1                   =    256;     {subtract 1 from the operand}
+
+   m_adc_abs              =    $6D;     {op code #s for 65816 instructions}
+   m_adc_dir              =    $65;
+   m_adc_imm              =    $69;
+   m_adc_s                =    $63;
+   m_and_abs              =    $2D;
+   m_and_dir              =    $25;
+   m_and_imm              =    $29;
+   m_and_s                =    $23;
+   m_asl_a                =    $0A;
+   m_bcc                  =    $90;
+   m_bcs                  =    $B0;
+   m_beq                  =    $F0;
+   m_bit_imm              =    $89;
+   m_bmi                  =    $30;
+   m_bne                  =    $D0;
+   m_bpl                  =    $10;
+   m_bra                  =    $80;
+   m_brl                  =    $82;
+   m_bvs                  =    $70;
+   m_clc                  =    $18;
+   m_cmp_abs              =    $CD;
+   m_cmp_dir              =    $C5;
+   m_cmp_dirX             =    $D5;
+   m_cmp_imm              =    $C9;
+   m_cmp_long             =    $CF;
+   m_cmp_s                =    $C3;
+   m_cop                  =    $02;
+   m_cpx_abs              =    236;
+   m_cpx_dir              =    228;
+   m_cpx_imm              =    224;
+   m_dea                  =     58;
+   m_dec_abs              =    206;
+   m_dec_absX             =    $DE;
+   m_dec_dir              =    198;
+   m_dec_dirX             =    214;
+   m_dex                  =    202;
+   m_dey                  =    136;
+   m_eor_abs              =     77;
+   m_eor_dir              =     69;
+   m_eor_imm              =     73;
+   m_eor_s                =     67;
+   m_ina                  =     26;
+   m_inc_abs              =    238;
+   m_inc_absX             =    $FE;
+   m_inc_dir              =    230;
+   m_inc_dirX             =    246;
+   m_inx                  =    232;
+   m_iny                  =    200;
+   m_jml                  =     92;
+   m_jsl                  =     34;
+   m_lda_abs              =    173;
+   m_lda_absx             =    189;
+   m_lda_dir              =    165;
+   m_lda_dirx             =    181;
+   m_lda_imm              =    169;
+   m_lda_indl             =    167;
+   m_lda_indly            =    183;
+   m_lda_long             =    175;
+   m_lda_longx            =    191;
+   m_lda_s                =    163;
+   m_ldx_abs              =    174;
+   m_ldx_dir              =    166;
+   m_ldx_imm              =    162;
+   m_ldy_abs              =    172;
+   m_ldy_absX             =    188;
+   m_ldy_dir              =    164;
+   m_ldy_dirX             =    180;
+   m_ldy_imm              =    160;
+   m_lsr_a                =     74;
+   m_mvn                  =     84;
+   m_ora_abs              =     13;
+   m_ora_dir              =      5;
+   m_ora_dirX             =     21;
+   m_ora_imm              =      9;
+   m_ora_longX            =     31;
+   m_ora_s                =      3;
+   m_pea                  =    244;
+   m_pei_dir              =    212;
+   m_pha                  =     72;
+   m_phb                  =    139;
+   m_phd                  =     11;
+   m_phk                  =    $4B;
+   m_phx                  =    218;
+   m_phy                  =     90;
+   m_php                  =      8;
+   m_pla                  =    104;
+   m_plb                  =    171;
+   m_pld                  =     43;
+   m_plx                  =    250;
+   m_ply                  =    122;
+   m_plp                  =     40;
+   m_rep                  =    194;
+   m_rtl                  =    107;
+   m_rts                  =     96;
+   m_sbc_abs              =    237;
+   m_sbc_dir              =    229;
+   m_sbc_imm              =    233;
+   m_sbc_s                =    227;
+   m_sec                  =     56;
+   m_sep                  =    226;
+   m_sta_abs              =    141;
+   m_sta_absX             =    157;
+   m_sta_dir              =    133;
+   m_sta_dirX             =    149;
+   m_sta_indl             =    135;
+   m_sta_indlY            =    151;
+   m_sta_long             =    143;
+   m_sta_longX            =    159;
+   m_sta_s                =    131;
+   m_stx_dir              =    134;
+   m_stx_abs              =    142;
+   m_sty_abs              =    140;
+   m_sty_dir              =    132;
+   m_sty_dirX             =    148;
+   m_stz_abs              =    156;
+   m_stz_absX             =    158;
+   m_stz_dir              =    100;
+   m_stz_dirX             =    116;
+   m_tax                  =    170;
+   m_tay                  =    168;
+   m_tcd                  =     91;
+   m_tcs                  =     27;
+   m_tdc                  =    123;
+   m_tsx                  =    $BA;
+   m_txa                  =    138;
+   m_txs                  =    $9A;
+   m_txy                  =    155;
+   m_tya                  =    152;
+   m_tyx                  =    187;
+   m_tsb_dir              =    $04;
+   m_tsb_abs              =    $0C;
+   m_tsc                  =     59;
+   m_xba                  =    $EB;
+
+   d_lab                  =    256;
+   d_end                  =    257;
+   d_bmov                 =    258;
+   d_add                  =    259;
+   d_pin                  =    260;
+   d_wrd                  =    261;
+   d_sym                  =    262;
+   d_cns                  =    263;
+
+   max_opcode             =    263;
+
+type
+                                        {pcode code generation}
+                                        {---------------------}
+   realrec = record                     {used to convert from real to in-SANE}
+      itsReal: double;
+      inSANE: packed array[1..10] of byte;
+      inCOMP: packed array[1..8] of byte;
+      end;
+
+                                        {65816 native code generation}
+                                        {----------------------------}
+   labelptr = ^labelentry;              {pointer to a forward ref node}
+   labelentry = record                  {forward ref node}
+      addr: integer;
+      next: labelptr;
+      end;
+
+   labelrec = record                    {label record}
+      defined: boolean;                 {Note: form used in objout.asm}
+      chain: labelptr;
+      case boolean of
+         true : (val: longint);
+         false: (ival,hval: integer);
+      end;
+
+var
+                                        {msc}
+                                        {---}
+   blkcnt: integer;                     {number of bytes in current segment}
+
+                                        {buffers}
+                                        {-------}
+   cbufflen: 0..maxcbuff;               {number of bytes now in cbuff}
+   segDisp: integer;                    {disp in the current segment}
+
+                                        {65816 native code generation}
+                                        {----------------------------}
+   labeltab: array[0..maxlabel] of labelrec; {label table}
+   localLabel: array[0..maxLocalLabel] of integer; {local variable label table}
+   pc: longint;                         {program counter}
+
+{---------------------------------------------------------------}
+
+procedure CnvSX (rec: realrec); extern;
+
+{ convert a real number to SANE extended format                 }
+{                                                               }
+{ parameters:                                                   }
+{       rec - record containing the value to convert; also      }
+{               has space for the result                        }
+
+{---------------------------------------------------------------}
+
+implementation
+
+end.
+
+{$append 'CGC.asm'}
diff --git a/cgi.asm b/cgi.asm
old mode 100755
new mode 100644
index 042b7aa..1fc40ed
--- a/cgi.asm
+++ b/cgi.asm
@@ -1 +1,28 @@
-****************************************************************
*
*  InitLabels - initialize the labels array
*
*  Outputs:
*        labelTab - initialized
*        intLabel - initialized
*
****************************************************************
*
InitLabels start
maxLabel equ   2400

!                                       with labelTab[0] do begin
         lda   #-1                         val := -1;
         sta   labelTab+6
         sta   labelTab+8
         stz   labelTab                    defined := false;
         stz   labelTab+2                  chain := nil;
         stz   labelTab+4
!                                          end; {with}
         ldx   #labelTab                for i := 1 to maxLabel do
         ldy   #labelTab+10                labelTab[i] := labelTab[0];
         lda   #maxLabel*10-1
         mvn   labelTab,labelTab
         stz   intLabel                 intLabel := 0;
         rtl
         end
\ No newline at end of file
+****************************************************************
+*
+*  InitLabels - initialize the labels array
+*
+*  Outputs:
+*        labelTab - initialized
+*        intLabel - initialized
+*
+****************************************************************
+*
+InitLabels start
+maxLabel equ   2400
+
+!                                       with labelTab[0] do begin
+         lda   #-1                         val := -1;
+         sta   labelTab+6
+         sta   labelTab+8
+         stz   labelTab                    defined := false;
+         stz   labelTab+2                  chain := nil;
+         stz   labelTab+4
+!                                          end; {with}
+         ldx   #labelTab                for i := 1 to maxLabel do
+         ldy   #labelTab+10                labelTab[i] := labelTab[0];
+         lda   #maxLabel*10-1
+         mvn   labelTab,labelTab
+         stz   intLabel                 intLabel := 0;
+         rtl
+         end
diff --git a/cgi.comments b/cgi.comments
old mode 100755
new mode 100644
index 7dcf594..86db2a7
--- a/cgi.comments
+++ b/cgi.comments
@@ -1 +1,962 @@
-{-- Misc. pcodes -----------------------------------------------}
{								}
{  dc_cns - generate a constant value				}
{								}
{  GenL1(dc_cns, lval, count);					}
{  GenR1t(dc_cns, rval, count, type);				}
{  Gen2t(dc_cns, ival, count, type);				}
{  GenS(dc_cns, sptr);						}
{								}
{  Creates COUNT occurrances of the constant lval, rval or	}
{  ival, based on the type.  In Gen2t can accept byte or word	}
{  types.  In the case of GenS, the operand is a string		}
{  constant, and no repeat count is allowed.			}
{								}
{								}
{  dc_glb - generate global label				}
{								}
{  Gen2Name(dc_glb, r, q, lab)					}
{								}
{  Creates a global label in the current segment with the name	}
{  LAB^.  If Q is 1, the label is marked as private to the	}
{  current segment, otherwise it is marked as public.  R bytes	}
{  of space are reserved.					}
{								}
{								}
{  dc_dst - generate global storage				}
{								}
{  Gen1(dc_dst, q)						}
{								}
{  Creates q bytes of storage (initialized to 0) at the		}
{  current location.						}
{								}
{								}
{  pc_lnm - line number						}
{								}
{  Gen2(pc_lnm, lc, flag)					}
{								}
{  Sets the current line number for the traceback facility and	}
{  debugger.  This p-code should only be generated after the	}
{  pc_ent and pc_nam (if any), and should not be generated	}
{  outside of a subroutine.  Lc is the line number, while flag	}
{  indicates the type of debugging action on this line:		}
{								}
{	0 - step/trace						}
{	1 - break point						}
{	2 - auto-go						}
{								}
{								}
{  pc_mov - move memory						}
{								}
{  Gen2(pc_mov, banks, bytes)					}
{								}
{  The top of stack contains a source address, and TOS-1 has a	}
{  destination address.	 The destination address is  removed,	}
{  and BYTES bytes are moved from the source to the		}
{  destination.	 BANKS is the number of full banks to move; it	}
{  is used when 64K or more must be moved.  The memory areas	}
{  must not overlap.						}
{								}
{								}
{  pc_nam - subroutine name					}
{								}
{  GenPS(pc_nam, str)						}
{								}
{  Sets the subroutine name for the traceback facility,		}
{  debugger, and profiler.  Str is a pointer to the subroutine	}
{  name.  The following global variables should be set to	}
{  appropriate values when this p-code is used:			}
{								}
{	debugFlag - are we generating debug code?		}
{	profileFlag - are we profiling?				}
{	traceBack - are we doing tracebacks?			}
{	includeFile - current source file name			}
{								}
{-- Pcodes involved expressions --------------------------------}
{								}
{  pc_abi - integer absolute value				}
{  pc_abl - longint absolute value				}
{  pc_abr - real absolute value					}
{								}
{  Gen0(pc_abi)		cgByte,cgUByte,cgWord,cgUWord		}
{  Gen0(pc_abl)		cgLong,cgULong				}
{  Gen0(pc_abr)		cgReal,cgDouble,cgComp,cgExtended	}
{								}
{  The value on the top of the evaluation stack is replaced	}
{  by its absolute value.					}
{								}
{								}
{  pc_acs - arc cosine						}
{								}
{  Gen0 (pc_acs)						}
{								}
{  Replace the top of stack with its arc cosine.		}
{								}
{								}
{  pc_adi - integer addition					}
{  pc_adl - long addition					}
{  pc_adr - real addition					}
{								}
{  Gen0(pc_adi)		cgByte,cgUByte,cgWord,cgUWord		}
{  Gen0(pc_adl)		cgLong,cgULong				}
{  Gen0(pc_adr)		cgReal,cgDouble,cgComp,cgExtended	}
{								}
{  The two values on the top of the evaluation stack are 	}
{  removed and added.  The result is placed back on the stack.	}
{								}
{								}
{  pc_and - logical and						}
{  pc_lnd - long logical and					}
{								}
{  Gen0(pc_and)		cgByte,cgUByte,cgWord,cgUWord		}
{  Gen0(pc_lnd)		cgLong,cgULong				}
{								}
{  The two values on the top of the evaluation stack are 	}
{  removed and anded.  The result is placed back on the stack.	}
{  Zero is treated as false, and any other value as true.  The	}
{  and is a logical and.  See pc_bnd for a bitwise and.		}
{								}
{  If the first operand is false, the second operand is not	}
{  evaluated.							}
{								}
{								}
{  pc_asn - arc sine						}
{								}
{  Gen0 (pc_asn)						}
{								}
{  Replace the top of stack with its arc sine.			}
{								}
{								}
{  pc_atn - arc tangent						}
{								}
{  Gen0 (pc_atn)						}
{								}
{  Replace the top of stack with its arc tangent.		}
{								}
{								}
{  pc_at2 - two argument arc tangent				}
{								}
{  Gen0 (pc_at2)						}
{								}
{  Removes two real arguments from the stack, replacing then	}
{  with their two-argument arc-tangent.				}
{								}
{								}
{  pc_bnd - bitwise and						}
{  pc_bal - long bitwise and					}
{								}
{  Gen0(pc_bnd)		cgByte,cgUByte,cgWord,cgUWord		}
{  Gen0(pc_bal)		cgLong,cgULong				}
{								}
{  The two values on the top of the evaluation stack are 	}
{  removed and anded.  The result is placed back on the stack.	}
{								}
{								}
{  pc_bno - binary operand no-operation				}
{								}
{  Gen0t(pc_bno, type)						}
{								}
{  The left operand is evaluated and discarded, followed by	}
{  the evaluation of the right operand.	 The type is the type	}
{  of the right operand; it is used in case a pc_pop is		}
{  attached to remove a result left on the stack.  This		}
{  instruction is used by C for the comma operator and for	}
{  parameter lists for function and procedure calls, and by	}
{  pc_tri to hold the two expressions.				}
{								}
{								}
{  pc_bnt - bitwise negation					}
{  pc_bnl - long bitwise negation				}
{								}
{  Gen0(pc_bnt)		cgByte,cgUByte,cgWord,cgUWord		}
{  Gen0(pc_bnl)		cgLong,cgULong				}
{								}
{  The value on the top of the evaluation stack is removed,	}
{  exclusive ored with $FFFF, and replaced.  (One's compliment.)}
{								}
{								}
{  pc_bor - bitwise or						}
{  pc_blr - long bitwise or					}
{								}
{  Gen0(pc_bor)		cgByte,cgUByte,cgWord,cgUWord		}
{  Gen0(pc_blr)		cgLong,cgULong				}
{								}
{  The two values on the top of the evaluation stack are 	}
{  removed and ored.  The result is placed back on the stack.	}
{								}
{								}
{  pc_bxr - exclusive or 					}
{  pc_blx - long exclusive or					}
{								}
{  Gen0(pc_bxr)		cgByte,cgUByte,cgWord,cgUWord		}
{  Gen0(pc_blx)		cgLong,cgULong				}
{								}
{  The two values on the top of the evaluation stack are 	}
{  removed and exclusive ored.	The result is placed back on	}
{  the stack.							}
{								}
{								}
{  pc_cbf - copy bit field					}
{								}
{  pc_chk - check subrange					}
{								}
{  Gen2t(pc_chk, low, high, type)	cgByte,cgUByte,cgWord,	}
{					cgUWord			}
{  GenL2t(pc_chk, low, high, type)	cgLong,cgULong		}
{								}
{  Make sure the value on the top of stack is in [low..high].	}
{								}
{								}
{  pc_cop - copy to a local variable				}
{								}
{  Gen2t(pc_cop, label, disp, type)				}
{								}
{  Saves the value on the top of the evaluation stack to DISP	}
{  bytes past the local label LABEL.  TYPE is the type of the	}
{  value being saved.						}
{								}
{								}
{  pc_cos - cosine						}
{								}
{  Gen0 (pc_cos)						}
{								}
{  Replace the top of stack with its cosine.			}
{								}
{								}
{  pc_cnv - convert from one scalar type to another		}
{  pc_cnn - convert from one scalar type to another		}
{								}
{  Gen2(pc_cnv, from, to)					}
{  Gen2(pc_cnn, from, to)					}
{								}
{  Converts from one scalar type to another.  The from and to	}
{  parameters are ordinal values of type baseTypeEnum.	The	}
{  table below shows what from values (along the left edge) and }
{  to values (along the top) are allowed, and what action is	}
{  taken for each combination.	CgDouble, cgComp or cgExtended	}
{  may be used anywhere that cgReal is used, with the same	}
{  results.							}
{								}
{  The pc_cnn form converts the value at tos-1.	 The value at	}
{  tos is assumed to be the same size as the result type.	}
{									}
{		cgByte	cgUByte cgWord	cgUWord cgLong	cgULong cgReal	}
{	cgByte					extend	extend	float	}
{	cgUByte					padd	padd	float	}
{	cgWord					extend	extend	float	}
{	cgUWord					extend	extend	float	}
{	cgLong	discard discard discard discard			float	}
{	cgULong discard discard discard discard			float	}
{	cgReal	trunc	trunc	trunc	trunc	trunc	trunc		}
{									}
{  The meaning of the operationd shown in the table is:		}
{								}
{	(blank) No action is taken, but the instruction is	}
{		accepted by the code generator.			}
{	extend	The value is sign extended to the proper length.}
{	padd	The value is padded on the left with zero bits	}
{		to extend it to the proper length.		}
{	discard Extra bits are discarded to reach the proper	}
{		length, starting with the most significant bit. }
{	float	An integer value is converted to a real value.	}
{	trunc	A real value is converted to the largest 	}
{		integer value that is less than or equal to the }
{		real value.					}
{								}
{								}
{  pc_cpo - copy to a global variable				}
{								}
{  Gen1tName (pc_cpo, disp, type, name)				}
{								}
{  Saves the value on the top of the evaluation stack to the	}
{  global label NAME.  DISP is a fixed displacement past the	}
{  names label to load from.  (Used for records.)    TYPE is	}
{  the type of the value being loaded.				}
{								}
{								}
{  pc_dec - decrement						}
{								}
{  Gen1t(pc_dec, val, type)					}
{								}
{  The value on the top of the stack is removed, decremented by }
{  VAL and returned to the stack.  Type may be cgByte, cgUByte, }
{  cgWord, cgUWord, cgLong or cgULong.	In all cases, the	}
{  amount to decrement by is a positive signed integer.		}
{								}
{								}
{  pc_dif - set difference					}
{								}
{  Gen0(pc_dif)							}
{								}
{  Two sets are removed from the top of stack.  All elements	}
{  in the set at TOS are removed from the set at TOS-1, and the	}
{  resulting set is pushed.					}
{								}
{								}
{  pc_dvi - integer divide					}
{  pc_udi - unsigned integer divide				}
{  pc_dvl - long integer divide					}
{  pc_udl - unsigned long divide 				}
{  pc_dvr - real divide						}
{								}
{  Gen0(pc_dvi)		cgByte,cgWord				}
{  Gen0(pc_udi)		cgUByte,cgUWord				}
{  Gen0(pc_dvl)		cgLong					}
{  Gen0(pc_udl)		cgULong					}
{  Gen0(pc_dvr)		cgReal,cgDouble,cgComp,cgExtended	}
{								}
{  The two values on the top of the evaluation stack are 	}
{  removed and divided.	 The result is placed back on the	}
{  stack.  The result type is the same as the argument type.	}
{								}
{								}
{  pc_equ,pc_geq,pc_grt,pc_leq,pc_les,pc_neq - compares		}
{								}
{  Gen0t(pc_equ, type)						}
{  Gen2t(pc_equ, size1, size2, type)				}
{								}
{  The two values on the top of the evaluation stack are 	}
{  removed and compared.  A boolean result is placed back on	}
{  the stack.  The second form is used to compare strings; the	}
{  two parameters are the size of the Standard Pascal string	}
{  array, or -1 for p-Strings.					}
{								}
{								}
{  pc_exp - exponent						}
{								}
{  Gen0 (pc_exp)						}
{								}
{  Replace the top of stack with its exponent.			}
{								}
{								}
{  pc_fix - fix a floating-point variable			}
{								}
{  Gen1t(pc_fix, lab, type)					}
{								}
{  Change a floating-point value (generally a passed parameter)	}
{  from extended to either cgReal or cgDouble.			}
{								}
{								}
{  pc_inc - increment						}
{								}
{  Gen1t(pc_inc, val, type)					}
{								}
{  The value on the top of the stack is removed, incremented by }
{  VAL and returned to the stack.  Type may be cgByte, cgUByte, }
{  cgWord, cgUWord, cgLong or cgULong.	In all cases, the	}
{  amount to increment by is a positive signed integer.		}
{								}
{								}
{  pc_ind - load indirect					}
{								}
{  Gen1t (pc_ind, disp, type)					}
{  Gen2t (pc_ind, disp, size, type)				}
{								}
{  A value of type TYPE is loaded from DISP bytes past the	}
{  address that is on the evaluation stack.  The address is	}
{  removed from the stack and replaced with the value.		}
{								}
{  Gen2t is used for sets, where SIZE is the size of the set.	}
{								}
{								}
{  pc_inn - set inclusion					}
{								}
{  Gen0 (pc_inn)						}
{								}
{  The top of stack is a set, and the next value on the stack	}
{  is a word.  The values are pulled.  TRUE is pushed if the	}
{  word value is in the set; FALSE is pushed if not.		}
{								}
{								}
{  pc_int - set intersection					}
{								}
{  Gen0(pc_int)							}
{								}
{  Two sets are removed from the top of stack.  The		}
{  intersection of the two sets is pushed.			}
{								}
{								}
{  pc_ior - logical or						}
{  pc_lor - long logical or					}
{								}
{  Gen0(pc_ior)		cgByte,cgUByte,cgWord,cgUWord		}
{  Gen0(pc_lor)		cgLong,cgULong				}
{								}
{  The two values on the top of the evaluation stack are 	}
{  removed and ored.  The result is placed back on the stack.	}
{  Zero is treated as false, and any other value as true.  The	}
{  or is a logical or.	See pc_bor for a bitwise or.		}
{								}
{								}
{  pc_ixa - integer indexed address				}
{								}
{  Gen0t(pc_ixa, type)						}
{								}
{  TOS is an integer, which is added to TOS-1, which is a long	}
{  integer.  This instruction is generally used for computing	}
{  short array indexes.						}
{								}
{  TYPE can be cgWord or cgUWord; the type indicates whether	}
{  the addition is signed or unsigned.				}
{								}
{								}
{  pc_lad - load the address of a subroutine			}
{								}
{  Gen0Name(pc_lad, name);					}
{								}
{  Loads the address of the subroutine NAME.			}
{								}
{								}
{  pc_lao - load a global address				}
{								}
{  Gen1Name(pc_lao, disp, name); 				}
{								}
{  Loads the address of DISP bytes past the global variable	}
{  NAME onto the stack.						}
{								}
{								}
{  pc_lca - load a string constant address			}
{								}
{  GenPS(pc_lca, str)						}
{								}
{  Loads the address of a string onto the stack.  Str is a	}
{  pointer to a string constant. 				}
{								}
{								}
{  pc_lda - load a local address 				}
{								}
{  Gen3(pc_lda, label, level, disp)				}
{								}
{  Loads the address of DISP bytes past the local label LABEL.	}
{  LEVEL is the number of stack frames to traverse.		}
{								}
{								}
{  pc_ldc - load a constant					}
{								}
{  Gen1t(pc_ldc, val, type)					}
{  GenLdcLong(val)						}
{  GenLdcReal(val)						}
{								}
{  Loads a constant value.  Special calls for long and real	}
{  values are provided due to the unique parameter requirements.}
{								}
{								}
{  pc_ldo - load from a global variable				}
{								}
{  Gen1tName (pc_ldo, disp, type, name)				}
{  Gen2tName (pc_ldo, disp, size, type, name)			}
{								}
{  Loads a value from the global label NAME and places it on	}
{  the evaluation stack.  DISP is a fixed displacement past the }
{  names label to load from.  (Used for records.)    TYPE is	}
{  the type of the value being loaded.				}
{								}
{  Gen2tName is used for sets, where SIZE is the size of the	}
{  set.								}
{								}
{								}
{  pc_lla - load the address of a local label			}
{								}
{  Gen1(pc_lda, label)						}
{								}
{  Loads the address LABEL.  This is generally used to load the	}
{  address of a procedure.					}
{								}
{								}
{  pc_lsl - load static link					}
{								}
{  Gen1(pc_lsl, level)						}
{								}
{  Loads the address of the stack frame LEVEL static links	}
{  back.							}
{								}
{								}
{  pc_lod - load from a local variable				}
{								}
{  Gen3t(pc_lod, label, disp, level, type)			}
{  Gen4t(pc_lod, label, disp, level, size, type) 		}
{								}
{  Loads a value from DISP bytes past the local label LABEL and }
{  places it on the evaluation stack.  TYPE is the type is the	}
{  value being loaded.	LEVEL is the number of stack frames to	}
{  skip; it is 0 for the local stack frame.			}
{								}
{  Gen4t is used for sets, where SIZE is the size of the set.	}
{								}
{								}
{  pc_log - logarithm						}
{								}
{  Gen0 (pc_log)						}
{								}
{  Replace the top of stack with its log.			}
{								}
{								}
{  pc_mod - integer modulus					}
{  pc_uim - unsigned integer modulus				}
{  pc_mdl - long modulus 					}
{  pc_ulm - unsigned long modulus				}
{								}
{  Gen0(pc_mod)		cgByte,cgWord				}
{  Gen0(pc_uim)		cgUByte,cgUWord				}
{  Gen0(pc_mdl)		cgLong					}
{  Gen0(pc_ulm)		cgULong					}
{								}
{  The two values on the top of the evaluation stack are 	}
{  removed and a molulus operation is performed.  The result is }
{  placed back on the stack.  The result, like the arguments,	}
{  is an integer.						}
{								}
{								}
{  pc_mpi - integer multiply					}
{  pc_umi - unsigned integer multiply				}
{  pc_mpl - long integer multiply				}
{  pc_uml - unsigned long multiply				}
{  pc_mpr - real multiply					}
{								}
{  Gen0(pc_mpi)		cgByte,cgWord				}
{  Gen0(pc_umi)		cgUByte,cgUWord				}
{  Gen0(pc_mpl)		cgLong					}
{  Gen0(pc_uml)		cgULong					}
{  Gen0(pc_mpr)		cgReal,cgDouble,cgComp,cgExtended	}
{								}
{  The two values on the top of the evaluation stack are 	}
{  removed and multiplied.  The result is placed back on the	}
{  stack.  The result type is the same as the argument type.	}
{								}
{								}
{  pc_ngi - integer negation					}
{  pc_ngl - long negation					}
{  pc_ngr - real negation					}
{								}
{  Gen0(pc_ngi)		cgByte,cgUByte,cgWord,cgUWord		}
{  Gen0(pc_ngl)		cgLong,cgULong				}
{  Gen0(pc_ngr)		cgReal,cgDouble,cgComp,cgExtended	}
{								}
{  The value on the top of the evaluation stack is removed,	}
{  subtracted from 0, and replaced.  (Two's compliment.)        }
{								}
{								}
{  Gen0(pc_nop)							}
{								}
{  This operand is a leaf node.	 It does nothing.  It is used	}
{  to create a null expression tree for functions and		}
{  procedures that have no parameters.				}
{								}
{								}
{  pc_not - logical negation					}
{								}
{  Gen0(pc_not)							}
{								}
{  The value on the top of the evaluation stack is removed,	}
{  logically negated, and replaced.				}
{								}
{								}
{  pc_odd - is an integer odd?					}
{  pc_odl - is a long integer odd?				}
{								}
{  Gen0 (pc_odd)						}
{  Gen0 (pc_odl)						}
{								}
{  The top of stack is an integer.  It is removed, and replaced	}
{  with a boolean TRUE if the integer is odd, or FALSE if the	}
{  integer is even.						}
{								}
{								}
{  pc_pop - pop a value from the stack				}
{								}
{  Gen0t(pc_pop, type)						}
{								}
{  The value on the top of the evaluation stack is removed.	}
{								}
{								}
{  pc_rnd - round						}
{  pc_rn4 - round						}
{								}
{  Gen0 (pc_rnd)	returns cgWord				}
{  Gen0 (pc_rn4)	returns cgLong				}
{								}
{  TOP is a real value; it is removed and replaced with the	}
{  closest integer value.					}
{								}
{								}
{  pc_sbi - integer subtraction					}
{  pc_sbl - long subtraction					}
{  pc_sbr - real subtraction					}
{								}
{  Gen0(pc_sbi)		cgByte,cgUByte,cgWord,cgUWord		}
{  Gen0(pc_sbl)		cgLong,cgULong				}
{  Gen0(pc_sbr)		cgReal,cgDouble,cgComp,cgExtended	}
{								}
{  The two values on the top of the evaluation stack are 	}
{  removed.  TOS-1 - TOS is placed back on the stack.		}
{								}
{								}
{  pc_sgs - singleton set					}
{								}
{  Gen0(pc_sgs)							}
{								}
{  Two integer values on the top of stack for a subrange of	}
{  TOS-1..TOS.  The integers are removed, and a set with the	}
{  equivalent elements is pushed.				}
{								}
{								}
{  pc_shl - shift left						}
{  pc_sll - shift left long					}
{								}
{  Gen0(pc_shl)		cgByte,cgUByte,cgWord,cgUWord		}
{  Gen0(pc_sll)		cgLong,cgULong				}
{								}
{  The value at tos-1 is shifted left by the number of bits	}
{  specified by tos.  The result is an integer, which replaces	}
{  the operands on the stack.  The right bit positions are	}
{  filled with zeros.						}
{								}
{								}
{  pc_shr - shift right						}
{  pc_usr - unsigned shift right 				}
{  pc_slr - long shift right					}
{  pc_vsr - unsigned long shift right				}
{								}
{  Gen0(pc_shr)		cgByte,cgWord				}
{  Gen0(pc_usr)		cgUByte,cgUWord				}
{  Gen0(pc_slr)		cgLong					}
{  Gen0(pc_vsr)		cgULong					}
{								}
{  The value at tos-1 is shifted right by the number of bits	}
{  specified by tos.  The result is an integer, which replaces	}
{  the operands on the stack.  This is a signed shift:	the	}
{  leftmost bit position is filled in with a copy of the 	}
{  orignial leftmost bit.					}
{								}
{  Pc_usr is the unsigned form.	 The operation is the same,	}
{  except that the leftmost bit is replaced with a zero. 	}
{  Pc_vsr is used for unsigned long operations.			}
{								}
{								}
{  pc_sin - sine						}
{								}
{  Gen0 (pc_sin)						}
{								}
{  Replace the top of stack with its sine.			}
{								}
{								}
{  pc_siz - set the size of a set				}
{								}
{  Gen1(pc_siz, size)						}
{								}
{  The top of stack is a set; it is forces to the specified	}
{  size.							}
{								}
{								}
{  pc_stk - stack an operand					}
{								}
{  Gen0t(pc_stk, type)						}
{								}
{  The value on top of the evaluation stack is to be left there }
{  as a parameter to a subsequent procedure or function call.	}
{  This p-code "caps" the expression tree, giving the code	}
{  generator something to do with the expression result. 	}
{								}
{								}
{  pc_sro - store to a global variable				}
{								}
{  Gen1tName (pc_sro, disp, type, name)				}
{  Gen2tName (pc_sro, disp, size, type, name)			}
{								}
{  Saves the value from the top of the evaluation stack to the	}
{  global label NAME.  DISP is a fixed displacement past the	}
{  names label to load from.  (Used for records.)    TYPE is	}
{  the type of the value being loaded.				}
{								}
{  Gen2tName is used for sets, where SIZE is the size of the	}
{  set.								}
{								}
{								}
{  pc_sto - store indirect					}
{								}
{  Gen0t(pc_sto, type)						}
{  Gen1t(pc_sto, size, type)					}
{								}
{  Two values are removed from the evaluation stack.  TOS is of }
{  type TYPE, while TOS-1 is a pointer.	 The value is stored at	}
{  the location pointed to by the pointer.			}
{								}
{  Gen1t is used for sets, where SIZE is the size of the set.	}
{								}
{								}
{  pc_str - store to a local variable				}
{								}
{  Gen3t(pc_str, label, disp, level, type)			}
{  Gen4t(pc_str, label, disp, level, size, type) 		}
{								}
{  Saves the value on the top of the evaluation stack to DISP	}
{  bytes past the local label LABEL.  TYPE is the type of the	}
{  value being saved.						}
{								}
{  Gen4t is used for sets, where SIZE is the size of the set.	}
{								}
{								}
{  pc_sqr - square a real number				}
{  pc_sqi - square an integer					}
{  pc_sql - square a long integer				}
{								}
{  Gen0 (pc_sqr)						}
{  Gen0 (pc_sqi)						}
{  Gen0 (pc_sql)						}
{								}
{  Replace the top of stack with its square.			}
{								}
{								}
{  pc_sqt - square root of a real number			}
{								}
{  Gen0 (pc_sqt)						}
{								}
{  Replace the top of stack with its square root.		}
{								}
{								}
{  pc_tan - tangent						}
{								}
{  Gen0 (pc_tan)						}
{								}
{  Replace the top of stack with its tangent.			}
{								}
{								}
{  pc_uni - set union						}
{								}
{  Gen0(pc_uni)							}
{								}
{  Two sets are removed from the top of stack.  The union of	}
{  the two sets is pushed.					}
{								}
{-- Flow of control --------------------------------------------}
{								}
{  dc_lab - define a label					}
{								}
{  Gen1(pc_lab, lab)						}
{								}
{  Defines label number lab at the current location.		}
{								}
{								}
{  pc_add - address						}
{								}
{  Gen1(pc_add, lab)						}
{								}
{  Generates a two-byte address that points to the label lab.	}
{  This is used to create branch tables for pc_xjp		}
{  instructions. 						}
{								}
{								}
{  pc_fjp - jump if false					}
{								}
{  Gen1(pc_fjp, lab)						}
{								}
{  A boolean value is removed from the top of the evaluation	}
{  stack.  If the value is false, execution continues with the	}
{  instruction after the label lab; otherwise execution		}
{  continues with the instruction after this one.		}
{								}
{								}
{  pc_tjp - jump if true 					}
{								}
{  Gen1(pc_tjp, lab)						}
{								}
{  A boolean value is removed from the top of the evaluation	}
{  stack.  If the value is true, execution continues with the	}
{  instruction after the label lab; otherwise execution		}
{  continues with the instruction after this one.		}
{								}
{								}
{  pc_prs - pop return stack					}
{								}
{  Gen0(pc_prs)							}
{								}
{  Pop one static frame (and any intervening dynamic frames)	}
{  from the return stack.  This is used for pc_ujp instructions }
{  that branch outside the current subroutine.			}
{								}
{								}
{  pc_pwr - raise a number to a power.				}
{								}
{  Gen0 (pc_pwr)						}
{								}
{  Replace the top of stack with TOS-1 raised to the TOS power.	}
{								}
{								}
{  pc_ujp - jump 						}
{								}
{  Gen1(pc_ujp, lab)						}
{  Gen0Name(pc_ujp, lab) 					}
{								}
{  Execution continues with the instruction after the label	}
{  LAB.	 This can be a numbered, local label (Gen1) or a named,	}
{  global label (Gen0Name).					}
{								}
{								}
{  pc_xjp - indexed jump 					}
{								}
{  Gen1(pc_xjp, val)						}
{								}
{  The top of stack contains an integer, which is removed.  If	}
{  it is less than zero or greater than VAL, it is replaced by	}
{  VAL.	 The result is then used to index into a jump table,	}
{  formed using pc_add instructions, which follows immediately	}
{  after the pc_xjp instruction. 				}
{								}
{-- Pcodes involved with calling and defining procedures -------}
{								}
{  dc_str - start a segment					}
{								}
{  Gen2Name(dc_str, p1, p2, name)				}
{								}
{  Starts a new object segment with the name name^.  P1 is the	}
{  segment kind, while p2 is the length code (1 for data, 0 for }
{  code segments).						}
{								}
{								}
{  dc_pin - procedure entry point				}
{								}
{  Gen0(dc_pin)							}
{								}
{  A code segment does not have to be entered at the first byte }
{  when called.	 This directive is used one time in each code	}
{  segment to indicate the actual entry point.			}
{								}
{								}
{  dc_enp - end a segment					}
{								}
{  Gen0(dc_enp)							}
{								}
{  This directive closes the current segment.			}
{								}
{								}
{  pc_ent - enter a subroutine					}
{								}
{  Gen0(pc_ent)							}
{								}
{  This pcode is used at the beginning of every subroutine.  It }
{  marks the beginning of a new stack frame definition.		}
{  Subsequent dc_loc and dc_prm cause space to be allocated	}
{  from this stack frame.					}
{								}
{								}
{  pc_ret - return from a subroutine				}
{								}
{  Gen0t(pc_ret, type)						}
{								}
{  This pcode is used to return from a function or a procedure. }
{  The type is the type of the function, and is used to tell	}
{  the code generator what type of value to return.  The value	}
{  to return is assumed to be stored defaultStackSize bytes	}
{  into the stack frame. 					}
{								}
{								}
{  pc_cui - call user procedure, indirect			}
{								}
{  Gen0t(pc_cui, ftype)						}
{								}
{  TOS-1 is the address of a procedure or function to call.	}
{  TOS is the static level for the procedure.  These values are	}
{  removed from the stack, and the procedure is called.		}
{								}
{								}
{  pc_cum - call user method					}
{								}
{  GenL1t(pc_cum, disp, ftype)					}
{								}
{  A series of parameters is on the stack; the first is the	}
{  SELF parameter.  DISP is a displacement into the object	}
{  where the address of the method to call can be found.	}
{								}
{								}
{  pc_cup - call user procedure					}
{								}
{  Gen1tName(pc_cup, level, ftype, name)			}
{  Gen2t(pc_cup, label, level, ftype)				}
{								}
{  Calls a user procedure or function.	FTYPE is the return	}
{  type.  NAME is the name of a global procedure; LABEL is used	}
{  for local procedures.  LEVEL is the ???			}
{								}
{								}
{  pc_csp - call standard procedure				}
{								}
{  Gen1(pc_csp, proc)						}
{								}
{  Calls a standard procedure or function.  PROC is the		}
{  procedure or function name.					}
{								}
{								}
{  dc_loc - define local label					}
{								}
{  Gen2(dc_loc, label, size)					}
{								}
{  Defines a local label using the label parameter as a label	}
{  number.  Size bytes are reserved on the stack frame.	 Label	}
{  numbers should be assigned by the compiler, starting with	}
{  number 1.  Label 0 is reserved for refering to the return	}
{  value of a function (if any). 				}
{								}
{								}
{  dc_prm - define parameter					}
{								}
{  Gen3(dc_prm, label, size, disp)				}
{								}
{  Defines a label used to refer to a parameter.  See dc_loc	}
{  for a discussion of the label and size parameters.  The disp }
{  parameter is the number of bytes of parameter that will be	}
{  pushed after this one; i.e., the disp from the return addr	}
{  to this parameter.						}
{								}
{								}
{  dc_fun - define function variable				}
{								}
{  Gen2(dc_fun, label, size)					}
{								}
{  Defines a label used to refer to the function return value.	}
{  This works like dc_loc, but requires special tracking so the }
{  pc_ret statement can find the value.				}
{								}
{								}
{  pc_pds - call ProDOS						}
{								}
{  Gen1(pc_pds, callNum) 					}
{								}
{  Calls ProDOS.  CALLNUM is the ProDOS call number.  The	}
{  address of the parameter block is on the stack.		}
{								}
{								}
{  pc_tl1 - call a tool						}
{  pc_tl2 - call a tool						}
{								}
{  Gen2t(pc_tl1, toolNum, callNum, type) 			}
{								}
{  Calls a tool.  The tool number is TOOLNUM; the tool call	}
{  is CALLNUM.  TYPE is the return type, which must be one of	}
{  the integer types or cgVoid.  pc_tl1 calls the system entry	}
{  point, while pc_tl2 calls the user tool entry point.		}
{								}
{								}
{  pc_vct - call a tool through a vector			}
{								}
{  Gen1L1t(pc_vct, call, vector, type) 				}
{								}
{  Generates a call using toolbox conventions.  TOS contains	}
{  the parameters.  Space for the returned value of type TYPE	}
{  is pushed on the stack, CALL is loaded into the X register,	}
{  and a JSL VECTOR is performed.  On return, A is saved at	}
{  ~TOOLERROR and any function value is loaded into the		}
{  registers.							}
{								}
{								}
{  dc_sym - generate a symbol table				}
{								}
{  Gen1Name(dc_sym, doGLobals, pointer(table)			}
{								}
{  Generates a symbol table for the debugger.  TABLE is the	}
{  address of the sybol table, which will be passed back to a	}
{  subroutine called GenSymbols, which must be supplied by the	}
{  compiler.  DOGLOBALS is a flag the compiler can set for its	}
{  own purposes.  C uses the flag to note that the symbol	}
{  table being created is for main, so global symbols should be }
{  included.							}
{								}
\ No newline at end of file
+{-- Misc. pcodes -----------------------------------------------}
+{								}
+{  dc_cns - generate a constant value				}
+{								}
+{  GenL1(dc_cns, lval, count);					}
+{  GenR1t(dc_cns, rval, count, type);				}
+{  Gen2t(dc_cns, ival, count, type);				}
+{  GenS(dc_cns, sptr);						}
+{								}
+{  Creates COUNT occurrances of the constant lval, rval or	}
+{  ival, based on the type.  In Gen2t can accept byte or word	}
+{  types.  In the case of GenS, the operand is a string		}
+{  constant, and no repeat count is allowed.			}
+{								}
+{								}
+{  dc_glb - generate global label				}
+{								}
+{  Gen2Name(dc_glb, r, q, lab)					}
+{								}
+{  Creates a global label in the current segment with the name	}
+{  LAB^.  If Q is 1, the label is marked as private to the	}
+{  current segment, otherwise it is marked as public.  R bytes	}
+{  of space are reserved.					}
+{								}
+{								}
+{  dc_dst - generate global storage				}
+{								}
+{  Gen1(dc_dst, q)						}
+{								}
+{  Creates q bytes of storage (initialized to 0) at the		}
+{  current location.						}
+{								}
+{								}
+{  pc_lnm - line number						}
+{								}
+{  Gen2(pc_lnm, lc, flag)					}
+{								}
+{  Sets the current line number for the traceback facility and	}
+{  debugger.  This p-code should only be generated after the	}
+{  pc_ent and pc_nam (if any), and should not be generated	}
+{  outside of a subroutine.  Lc is the line number, while flag	}
+{  indicates the type of debugging action on this line:		}
+{								}
+{	0 - step/trace						}
+{	1 - break point						}
+{	2 - auto-go						}
+{								}
+{								}
+{  pc_mov - move memory						}
+{								}
+{  Gen2(pc_mov, banks, bytes)					}
+{								}
+{  The top of stack contains a source address, and TOS-1 has a	}
+{  destination address.	 The destination address is  removed,	}
+{  and BYTES bytes are moved from the source to the		}
+{  destination.	 BANKS is the number of full banks to move; it	}
+{  is used when 64K or more must be moved.  The memory areas	}
+{  must not overlap.						}
+{								}
+{								}
+{  pc_nam - subroutine name					}
+{								}
+{  GenPS(pc_nam, str)						}
+{								}
+{  Sets the subroutine name for the traceback facility,		}
+{  debugger, and profiler.  Str is a pointer to the subroutine	}
+{  name.  The following global variables should be set to	}
+{  appropriate values when this p-code is used:			}
+{								}
+{	debugFlag - are we generating debug code?		}
+{	profileFlag - are we profiling?				}
+{	traceBack - are we doing tracebacks?			}
+{	includeFile - current source file name			}
+{								}
+{-- Pcodes involved expressions --------------------------------}
+{								}
+{  pc_abi - integer absolute value				}
+{  pc_abl - longint absolute value				}
+{  pc_abr - real absolute value					}
+{								}
+{  Gen0(pc_abi)		cgByte,cgUByte,cgWord,cgUWord		}
+{  Gen0(pc_abl)		cgLong,cgULong				}
+{  Gen0(pc_abr)		cgReal,cgDouble,cgComp,cgExtended	}
+{								}
+{  The value on the top of the evaluation stack is replaced	}
+{  by its absolute value.					}
+{								}
+{								}
+{  pc_acs - arc cosine						}
+{								}
+{  Gen0 (pc_acs)						}
+{								}
+{  Replace the top of stack with its arc cosine.		}
+{								}
+{								}
+{  pc_adi - integer addition					}
+{  pc_adl - long addition					}
+{  pc_adr - real addition					}
+{								}
+{  Gen0(pc_adi)		cgByte,cgUByte,cgWord,cgUWord		}
+{  Gen0(pc_adl)		cgLong,cgULong				}
+{  Gen0(pc_adr)		cgReal,cgDouble,cgComp,cgExtended	}
+{								}
+{  The two values on the top of the evaluation stack are 	}
+{  removed and added.  The result is placed back on the stack.	}
+{								}
+{								}
+{  pc_and - logical and						}
+{  pc_lnd - long logical and					}
+{								}
+{  Gen0(pc_and)		cgByte,cgUByte,cgWord,cgUWord		}
+{  Gen0(pc_lnd)		cgLong,cgULong				}
+{								}
+{  The two values on the top of the evaluation stack are 	}
+{  removed and anded.  The result is placed back on the stack.	}
+{  Zero is treated as false, and any other value as true.  The	}
+{  and is a logical and.  See pc_bnd for a bitwise and.		}
+{								}
+{  If the first operand is false, the second operand is not	}
+{  evaluated.							}
+{								}
+{								}
+{  pc_asn - arc sine						}
+{								}
+{  Gen0 (pc_asn)						}
+{								}
+{  Replace the top of stack with its arc sine.			}
+{								}
+{								}
+{  pc_atn - arc tangent						}
+{								}
+{  Gen0 (pc_atn)						}
+{								}
+{  Replace the top of stack with its arc tangent.		}
+{								}
+{								}
+{  pc_at2 - two argument arc tangent				}
+{								}
+{  Gen0 (pc_at2)						}
+{								}
+{  Removes two real arguments from the stack, replacing then	}
+{  with their two-argument arc-tangent.				}
+{								}
+{								}
+{  pc_bnd - bitwise and						}
+{  pc_bal - long bitwise and					}
+{								}
+{  Gen0(pc_bnd)		cgByte,cgUByte,cgWord,cgUWord		}
+{  Gen0(pc_bal)		cgLong,cgULong				}
+{								}
+{  The two values on the top of the evaluation stack are 	}
+{  removed and anded.  The result is placed back on the stack.	}
+{								}
+{								}
+{  pc_bno - binary operand no-operation				}
+{								}
+{  Gen0t(pc_bno, type)						}
+{								}
+{  The left operand is evaluated and discarded, followed by	}
+{  the evaluation of the right operand.	 The type is the type	}
+{  of the right operand; it is used in case a pc_pop is		}
+{  attached to remove a result left on the stack.  This		}
+{  instruction is used by C for the comma operator and for	}
+{  parameter lists for function and procedure calls, and by	}
+{  pc_tri to hold the two expressions.				}
+{								}
+{								}
+{  pc_bnt - bitwise negation					}
+{  pc_bnl - long bitwise negation				}
+{								}
+{  Gen0(pc_bnt)		cgByte,cgUByte,cgWord,cgUWord		}
+{  Gen0(pc_bnl)		cgLong,cgULong				}
+{								}
+{  The value on the top of the evaluation stack is removed,	}
+{  exclusive ored with $FFFF, and replaced.  (One's compliment.)}
+{								}
+{								}
+{  pc_bor - bitwise or						}
+{  pc_blr - long bitwise or					}
+{								}
+{  Gen0(pc_bor)		cgByte,cgUByte,cgWord,cgUWord		}
+{  Gen0(pc_blr)		cgLong,cgULong				}
+{								}
+{  The two values on the top of the evaluation stack are 	}
+{  removed and ored.  The result is placed back on the stack.	}
+{								}
+{								}
+{  pc_bxr - exclusive or 					}
+{  pc_blx - long exclusive or					}
+{								}
+{  Gen0(pc_bxr)		cgByte,cgUByte,cgWord,cgUWord		}
+{  Gen0(pc_blx)		cgLong,cgULong				}
+{								}
+{  The two values on the top of the evaluation stack are 	}
+{  removed and exclusive ored.	The result is placed back on	}
+{  the stack.							}
+{								}
+{								}
+{  pc_cbf - copy bit field					}
+{								}
+{  pc_chk - check subrange					}
+{								}
+{  Gen2t(pc_chk, low, high, type)	cgByte,cgUByte,cgWord,	}
+{					cgUWord			}
+{  GenL2t(pc_chk, low, high, type)	cgLong,cgULong		}
+{								}
+{  Make sure the value on the top of stack is in [low..high].	}
+{								}
+{								}
+{  pc_cop - copy to a local variable				}
+{								}
+{  Gen2t(pc_cop, label, disp, type)				}
+{								}
+{  Saves the value on the top of the evaluation stack to DISP	}
+{  bytes past the local label LABEL.  TYPE is the type of the	}
+{  value being saved.						}
+{								}
+{								}
+{  pc_cos - cosine						}
+{								}
+{  Gen0 (pc_cos)						}
+{								}
+{  Replace the top of stack with its cosine.			}
+{								}
+{								}
+{  pc_cnv - convert from one scalar type to another		}
+{  pc_cnn - convert from one scalar type to another		}
+{								}
+{  Gen2(pc_cnv, from, to)					}
+{  Gen2(pc_cnn, from, to)					}
+{								}
+{  Converts from one scalar type to another.  The from and to	}
+{  parameters are ordinal values of type baseTypeEnum.	The	}
+{  table below shows what from values (along the left edge) and }
+{  to values (along the top) are allowed, and what action is	}
+{  taken for each combination.	CgDouble, cgComp or cgExtended	}
+{  may be used anywhere that cgReal is used, with the same	}
+{  results.							}
+{								}
+{  The pc_cnn form converts the value at tos-1.	 The value at	}
+{  tos is assumed to be the same size as the result type.	}
+{									}
+{		cgByte	cgUByte cgWord	cgUWord cgLong	cgULong cgReal	}
+{	cgByte					extend	extend	float	}
+{	cgUByte					padd	padd	float	}
+{	cgWord					extend	extend	float	}
+{	cgUWord					extend	extend	float	}
+{	cgLong	discard discard discard discard			float	}
+{	cgULong discard discard discard discard			float	}
+{	cgReal	trunc	trunc	trunc	trunc	trunc	trunc		}
+{									}
+{  The meaning of the operationd shown in the table is:		}
+{								}
+{	(blank) No action is taken, but the instruction is	}
+{		accepted by the code generator.			}
+{	extend	The value is sign extended to the proper length.}
+{	padd	The value is padded on the left with zero bits	}
+{		to extend it to the proper length.		}
+{	discard Extra bits are discarded to reach the proper	}
+{		length, starting with the most significant bit. }
+{	float	An integer value is converted to a real value.	}
+{	trunc	A real value is converted to the largest 	}
+{		integer value that is less than or equal to the }
+{		real value.					}
+{								}
+{								}
+{  pc_cpo - copy to a global variable				}
+{								}
+{  Gen1tName (pc_cpo, disp, type, name)				}
+{								}
+{  Saves the value on the top of the evaluation stack to the	}
+{  global label NAME.  DISP is a fixed displacement past the	}
+{  names label to load from.  (Used for records.)    TYPE is	}
+{  the type of the value being loaded.				}
+{								}
+{								}
+{  pc_dec - decrement						}
+{								}
+{  Gen1t(pc_dec, val, type)					}
+{								}
+{  The value on the top of the stack is removed, decremented by }
+{  VAL and returned to the stack.  Type may be cgByte, cgUByte, }
+{  cgWord, cgUWord, cgLong or cgULong.	In all cases, the	}
+{  amount to decrement by is a positive signed integer.		}
+{								}
+{								}
+{  pc_dif - set difference					}
+{								}
+{  Gen0(pc_dif)							}
+{								}
+{  Two sets are removed from the top of stack.  All elements	}
+{  in the set at TOS are removed from the set at TOS-1, and the	}
+{  resulting set is pushed.					}
+{								}
+{								}
+{  pc_dvi - integer divide					}
+{  pc_udi - unsigned integer divide				}
+{  pc_dvl - long integer divide					}
+{  pc_udl - unsigned long divide 				}
+{  pc_dvr - real divide						}
+{								}
+{  Gen0(pc_dvi)		cgByte,cgWord				}
+{  Gen0(pc_udi)		cgUByte,cgUWord				}
+{  Gen0(pc_dvl)		cgLong					}
+{  Gen0(pc_udl)		cgULong					}
+{  Gen0(pc_dvr)		cgReal,cgDouble,cgComp,cgExtended	}
+{								}
+{  The two values on the top of the evaluation stack are 	}
+{  removed and divided.	 The result is placed back on the	}
+{  stack.  The result type is the same as the argument type.	}
+{								}
+{								}
+{  pc_equ,pc_geq,pc_grt,pc_leq,pc_les,pc_neq - compares		}
+{								}
+{  Gen0t(pc_equ, type)						}
+{  Gen2t(pc_equ, size1, size2, type)				}
+{								}
+{  The two values on the top of the evaluation stack are 	}
+{  removed and compared.  A boolean result is placed back on	}
+{  the stack.  The second form is used to compare strings; the	}
+{  two parameters are the size of the Standard Pascal string	}
+{  array, or -1 for p-Strings.					}
+{								}
+{								}
+{  pc_exp - exponent						}
+{								}
+{  Gen0 (pc_exp)						}
+{								}
+{  Replace the top of stack with its exponent.			}
+{								}
+{								}
+{  pc_fix - fix a floating-point variable			}
+{								}
+{  Gen1t(pc_fix, lab, type)					}
+{								}
+{  Change a floating-point value (generally a passed parameter)	}
+{  from extended to either cgReal or cgDouble.			}
+{								}
+{								}
+{  pc_inc - increment						}
+{								}
+{  Gen1t(pc_inc, val, type)					}
+{								}
+{  The value on the top of the stack is removed, incremented by }
+{  VAL and returned to the stack.  Type may be cgByte, cgUByte, }
+{  cgWord, cgUWord, cgLong or cgULong.	In all cases, the	}
+{  amount to increment by is a positive signed integer.		}
+{								}
+{								}
+{  pc_ind - load indirect					}
+{								}
+{  Gen1t (pc_ind, disp, type)					}
+{  Gen2t (pc_ind, disp, size, type)				}
+{								}
+{  A value of type TYPE is loaded from DISP bytes past the	}
+{  address that is on the evaluation stack.  The address is	}
+{  removed from the stack and replaced with the value.		}
+{								}
+{  Gen2t is used for sets, where SIZE is the size of the set.	}
+{								}
+{								}
+{  pc_inn - set inclusion					}
+{								}
+{  Gen0 (pc_inn)						}
+{								}
+{  The top of stack is a set, and the next value on the stack	}
+{  is a word.  The values are pulled.  TRUE is pushed if the	}
+{  word value is in the set; FALSE is pushed if not.		}
+{								}
+{								}
+{  pc_int - set intersection					}
+{								}
+{  Gen0(pc_int)							}
+{								}
+{  Two sets are removed from the top of stack.  The		}
+{  intersection of the two sets is pushed.			}
+{								}
+{								}
+{  pc_ior - logical or						}
+{  pc_lor - long logical or					}
+{								}
+{  Gen0(pc_ior)		cgByte,cgUByte,cgWord,cgUWord		}
+{  Gen0(pc_lor)		cgLong,cgULong				}
+{								}
+{  The two values on the top of the evaluation stack are 	}
+{  removed and ored.  The result is placed back on the stack.	}
+{  Zero is treated as false, and any other value as true.  The	}
+{  or is a logical or.	See pc_bor for a bitwise or.		}
+{								}
+{								}
+{  pc_ixa - integer indexed address				}
+{								}
+{  Gen0t(pc_ixa, type)						}
+{								}
+{  TOS is an integer, which is added to TOS-1, which is a long	}
+{  integer.  This instruction is generally used for computing	}
+{  short array indexes.						}
+{								}
+{  TYPE can be cgWord or cgUWord; the type indicates whether	}
+{  the addition is signed or unsigned.				}
+{								}
+{								}
+{  pc_lad - load the address of a subroutine			}
+{								}
+{  Gen0Name(pc_lad, name);					}
+{								}
+{  Loads the address of the subroutine NAME.			}
+{								}
+{								}
+{  pc_lao - load a global address				}
+{								}
+{  Gen1Name(pc_lao, disp, name); 				}
+{								}
+{  Loads the address of DISP bytes past the global variable	}
+{  NAME onto the stack.						}
+{								}
+{								}
+{  pc_lca - load a string constant address			}
+{								}
+{  GenPS(pc_lca, str)						}
+{								}
+{  Loads the address of a string onto the stack.  Str is a	}
+{  pointer to a string constant. 				}
+{								}
+{								}
+{  pc_lda - load a local address 				}
+{								}
+{  Gen3(pc_lda, label, level, disp)				}
+{								}
+{  Loads the address of DISP bytes past the local label LABEL.	}
+{  LEVEL is the number of stack frames to traverse.		}
+{								}
+{								}
+{  pc_ldc - load a constant					}
+{								}
+{  Gen1t(pc_ldc, val, type)					}
+{  GenLdcLong(val)						}
+{  GenLdcReal(val)						}
+{								}
+{  Loads a constant value.  Special calls for long and real	}
+{  values are provided due to the unique parameter requirements.}
+{								}
+{								}
+{  pc_ldo - load from a global variable				}
+{								}
+{  Gen1tName (pc_ldo, disp, type, name)				}
+{  Gen2tName (pc_ldo, disp, size, type, name)			}
+{								}
+{  Loads a value from the global label NAME and places it on	}
+{  the evaluation stack.  DISP is a fixed displacement past the }
+{  names label to load from.  (Used for records.)    TYPE is	}
+{  the type of the value being loaded.				}
+{								}
+{  Gen2tName is used for sets, where SIZE is the size of the	}
+{  set.								}
+{								}
+{								}
+{  pc_lla - load the address of a local label			}
+{								}
+{  Gen1(pc_lda, label)						}
+{								}
+{  Loads the address LABEL.  This is generally used to load the	}
+{  address of a procedure.					}
+{								}
+{								}
+{  pc_lsl - load static link					}
+{								}
+{  Gen1(pc_lsl, level)						}
+{								}
+{  Loads the address of the stack frame LEVEL static links	}
+{  back.							}
+{								}
+{								}
+{  pc_lod - load from a local variable				}
+{								}
+{  Gen3t(pc_lod, label, disp, level, type)			}
+{  Gen4t(pc_lod, label, disp, level, size, type) 		}
+{								}
+{  Loads a value from DISP bytes past the local label LABEL and }
+{  places it on the evaluation stack.  TYPE is the type is the	}
+{  value being loaded.	LEVEL is the number of stack frames to	}
+{  skip; it is 0 for the local stack frame.			}
+{								}
+{  Gen4t is used for sets, where SIZE is the size of the set.	}
+{								}
+{								}
+{  pc_log - logarithm						}
+{								}
+{  Gen0 (pc_log)						}
+{								}
+{  Replace the top of stack with its log.			}
+{								}
+{								}
+{  pc_mod - integer modulus					}
+{  pc_uim - unsigned integer modulus				}
+{  pc_mdl - long modulus 					}
+{  pc_ulm - unsigned long modulus				}
+{								}
+{  Gen0(pc_mod)		cgByte,cgWord				}
+{  Gen0(pc_uim)		cgUByte,cgUWord				}
+{  Gen0(pc_mdl)		cgLong					}
+{  Gen0(pc_ulm)		cgULong					}
+{								}
+{  The two values on the top of the evaluation stack are 	}
+{  removed and a molulus operation is performed.  The result is }
+{  placed back on the stack.  The result, like the arguments,	}
+{  is an integer.						}
+{								}
+{								}
+{  pc_mpi - integer multiply					}
+{  pc_umi - unsigned integer multiply				}
+{  pc_mpl - long integer multiply				}
+{  pc_uml - unsigned long multiply				}
+{  pc_mpr - real multiply					}
+{								}
+{  Gen0(pc_mpi)		cgByte,cgWord				}
+{  Gen0(pc_umi)		cgUByte,cgUWord				}
+{  Gen0(pc_mpl)		cgLong					}
+{  Gen0(pc_uml)		cgULong					}
+{  Gen0(pc_mpr)		cgReal,cgDouble,cgComp,cgExtended	}
+{								}
+{  The two values on the top of the evaluation stack are 	}
+{  removed and multiplied.  The result is placed back on the	}
+{  stack.  The result type is the same as the argument type.	}
+{								}
+{								}
+{  pc_ngi - integer negation					}
+{  pc_ngl - long negation					}
+{  pc_ngr - real negation					}
+{								}
+{  Gen0(pc_ngi)		cgByte,cgUByte,cgWord,cgUWord		}
+{  Gen0(pc_ngl)		cgLong,cgULong				}
+{  Gen0(pc_ngr)		cgReal,cgDouble,cgComp,cgExtended	}
+{								}
+{  The value on the top of the evaluation stack is removed,	}
+{  subtracted from 0, and replaced.  (Two's compliment.)        }
+{								}
+{								}
+{  Gen0(pc_nop)							}
+{								}
+{  This operand is a leaf node.	 It does nothing.  It is used	}
+{  to create a null expression tree for functions and		}
+{  procedures that have no parameters.				}
+{								}
+{								}
+{  pc_not - logical negation					}
+{								}
+{  Gen0(pc_not)							}
+{								}
+{  The value on the top of the evaluation stack is removed,	}
+{  logically negated, and replaced.				}
+{								}
+{								}
+{  pc_odd - is an integer odd?					}
+{  pc_odl - is a long integer odd?				}
+{								}
+{  Gen0 (pc_odd)						}
+{  Gen0 (pc_odl)						}
+{								}
+{  The top of stack is an integer.  It is removed, and replaced	}
+{  with a boolean TRUE if the integer is odd, or FALSE if the	}
+{  integer is even.						}
+{								}
+{								}
+{  pc_pop - pop a value from the stack				}
+{								}
+{  Gen0t(pc_pop, type)						}
+{								}
+{  The value on the top of the evaluation stack is removed.	}
+{								}
+{								}
+{  pc_rnd - round						}
+{  pc_rn4 - round						}
+{								}
+{  Gen0 (pc_rnd)	returns cgWord				}
+{  Gen0 (pc_rn4)	returns cgLong				}
+{								}
+{  TOP is a real value; it is removed and replaced with the	}
+{  closest integer value.					}
+{								}
+{								}
+{  pc_sbi - integer subtraction					}
+{  pc_sbl - long subtraction					}
+{  pc_sbr - real subtraction					}
+{								}
+{  Gen0(pc_sbi)		cgByte,cgUByte,cgWord,cgUWord		}
+{  Gen0(pc_sbl)		cgLong,cgULong				}
+{  Gen0(pc_sbr)		cgReal,cgDouble,cgComp,cgExtended	}
+{								}
+{  The two values on the top of the evaluation stack are 	}
+{  removed.  TOS-1 - TOS is placed back on the stack.		}
+{								}
+{								}
+{  pc_sgs - singleton set					}
+{								}
+{  Gen0(pc_sgs)							}
+{								}
+{  Two integer values on the top of stack for a subrange of	}
+{  TOS-1..TOS.  The integers are removed, and a set with the	}
+{  equivalent elements is pushed.				}
+{								}
+{								}
+{  pc_shl - shift left						}
+{  pc_sll - shift left long					}
+{								}
+{  Gen0(pc_shl)		cgByte,cgUByte,cgWord,cgUWord		}
+{  Gen0(pc_sll)		cgLong,cgULong				}
+{								}
+{  The value at tos-1 is shifted left by the number of bits	}
+{  specified by tos.  The result is an integer, which replaces	}
+{  the operands on the stack.  The right bit positions are	}
+{  filled with zeros.						}
+{								}
+{								}
+{  pc_shr - shift right						}
+{  pc_usr - unsigned shift right 				}
+{  pc_slr - long shift right					}
+{  pc_vsr - unsigned long shift right				}
+{								}
+{  Gen0(pc_shr)		cgByte,cgWord				}
+{  Gen0(pc_usr)		cgUByte,cgUWord				}
+{  Gen0(pc_slr)		cgLong					}
+{  Gen0(pc_vsr)		cgULong					}
+{								}
+{  The value at tos-1 is shifted right by the number of bits	}
+{  specified by tos.  The result is an integer, which replaces	}
+{  the operands on the stack.  This is a signed shift:	the	}
+{  leftmost bit position is filled in with a copy of the 	}
+{  orignial leftmost bit.					}
+{								}
+{  Pc_usr is the unsigned form.	 The operation is the same,	}
+{  except that the leftmost bit is replaced with a zero. 	}
+{  Pc_vsr is used for unsigned long operations.			}
+{								}
+{								}
+{  pc_sin - sine						}
+{								}
+{  Gen0 (pc_sin)						}
+{								}
+{  Replace the top of stack with its sine.			}
+{								}
+{								}
+{  pc_siz - set the size of a set				}
+{								}
+{  Gen1(pc_siz, size)						}
+{								}
+{  The top of stack is a set; it is forces to the specified	}
+{  size.							}
+{								}
+{								}
+{  pc_stk - stack an operand					}
+{								}
+{  Gen0t(pc_stk, type)						}
+{								}
+{  The value on top of the evaluation stack is to be left there }
+{  as a parameter to a subsequent procedure or function call.	}
+{  This p-code "caps" the expression tree, giving the code	}
+{  generator something to do with the expression result. 	}
+{								}
+{								}
+{  pc_sro - store to a global variable				}
+{								}
+{  Gen1tName (pc_sro, disp, type, name)				}
+{  Gen2tName (pc_sro, disp, size, type, name)			}
+{								}
+{  Saves the value from the top of the evaluation stack to the	}
+{  global label NAME.  DISP is a fixed displacement past the	}
+{  names label to load from.  (Used for records.)    TYPE is	}
+{  the type of the value being loaded.				}
+{								}
+{  Gen2tName is used for sets, where SIZE is the size of the	}
+{  set.								}
+{								}
+{								}
+{  pc_sto - store indirect					}
+{								}
+{  Gen0t(pc_sto, type)						}
+{  Gen1t(pc_sto, size, type)					}
+{								}
+{  Two values are removed from the evaluation stack.  TOS is of }
+{  type TYPE, while TOS-1 is a pointer.	 The value is stored at	}
+{  the location pointed to by the pointer.			}
+{								}
+{  Gen1t is used for sets, where SIZE is the size of the set.	}
+{								}
+{								}
+{  pc_str - store to a local variable				}
+{								}
+{  Gen3t(pc_str, label, disp, level, type)			}
+{  Gen4t(pc_str, label, disp, level, size, type) 		}
+{								}
+{  Saves the value on the top of the evaluation stack to DISP	}
+{  bytes past the local label LABEL.  TYPE is the type of the	}
+{  value being saved.						}
+{								}
+{  Gen4t is used for sets, where SIZE is the size of the set.	}
+{								}
+{								}
+{  pc_sqr - square a real number				}
+{  pc_sqi - square an integer					}
+{  pc_sql - square a long integer				}
+{								}
+{  Gen0 (pc_sqr)						}
+{  Gen0 (pc_sqi)						}
+{  Gen0 (pc_sql)						}
+{								}
+{  Replace the top of stack with its square.			}
+{								}
+{								}
+{  pc_sqt - square root of a real number			}
+{								}
+{  Gen0 (pc_sqt)						}
+{								}
+{  Replace the top of stack with its square root.		}
+{								}
+{								}
+{  pc_tan - tangent						}
+{								}
+{  Gen0 (pc_tan)						}
+{								}
+{  Replace the top of stack with its tangent.			}
+{								}
+{								}
+{  pc_uni - set union						}
+{								}
+{  Gen0(pc_uni)							}
+{								}
+{  Two sets are removed from the top of stack.  The union of	}
+{  the two sets is pushed.					}
+{								}
+{-- Flow of control --------------------------------------------}
+{								}
+{  dc_lab - define a label					}
+{								}
+{  Gen1(pc_lab, lab)						}
+{								}
+{  Defines label number lab at the current location.		}
+{								}
+{								}
+{  pc_add - address						}
+{								}
+{  Gen1(pc_add, lab)						}
+{								}
+{  Generates a two-byte address that points to the label lab.	}
+{  This is used to create branch tables for pc_xjp		}
+{  instructions. 						}
+{								}
+{								}
+{  pc_fjp - jump if false					}
+{								}
+{  Gen1(pc_fjp, lab)						}
+{								}
+{  A boolean value is removed from the top of the evaluation	}
+{  stack.  If the value is false, execution continues with the	}
+{  instruction after the label lab; otherwise execution		}
+{  continues with the instruction after this one.		}
+{								}
+{								}
+{  pc_tjp - jump if true 					}
+{								}
+{  Gen1(pc_tjp, lab)						}
+{								}
+{  A boolean value is removed from the top of the evaluation	}
+{  stack.  If the value is true, execution continues with the	}
+{  instruction after the label lab; otherwise execution		}
+{  continues with the instruction after this one.		}
+{								}
+{								}
+{  pc_prs - pop return stack					}
+{								}
+{  Gen0(pc_prs)							}
+{								}
+{  Pop one static frame (and any intervening dynamic frames)	}
+{  from the return stack.  This is used for pc_ujp instructions }
+{  that branch outside the current subroutine.			}
+{								}
+{								}
+{  pc_pwr - raise a number to a power.				}
+{								}
+{  Gen0 (pc_pwr)						}
+{								}
+{  Replace the top of stack with TOS-1 raised to the TOS power.	}
+{								}
+{								}
+{  pc_ujp - jump 						}
+{								}
+{  Gen1(pc_ujp, lab)						}
+{  Gen0Name(pc_ujp, lab) 					}
+{								}
+{  Execution continues with the instruction after the label	}
+{  LAB.	 This can be a numbered, local label (Gen1) or a named,	}
+{  global label (Gen0Name).					}
+{								}
+{								}
+{  pc_xjp - indexed jump 					}
+{								}
+{  Gen1(pc_xjp, val)						}
+{								}
+{  The top of stack contains an integer, which is removed.  If	}
+{  it is less than zero or greater than VAL, it is replaced by	}
+{  VAL.	 The result is then used to index into a jump table,	}
+{  formed using pc_add instructions, which follows immediately	}
+{  after the pc_xjp instruction. 				}
+{								}
+{-- Pcodes involved with calling and defining procedures -------}
+{								}
+{  dc_str - start a segment					}
+{								}
+{  Gen2Name(dc_str, p1, p2, name)				}
+{								}
+{  Starts a new object segment with the name name^.  P1 is the	}
+{  segment kind, while p2 is the length code (1 for data, 0 for }
+{  code segments).						}
+{								}
+{								}
+{  dc_pin - procedure entry point				}
+{								}
+{  Gen0(dc_pin)							}
+{								}
+{  A code segment does not have to be entered at the first byte }
+{  when called.	 This directive is used one time in each code	}
+{  segment to indicate the actual entry point.			}
+{								}
+{								}
+{  dc_enp - end a segment					}
+{								}
+{  Gen0(dc_enp)							}
+{								}
+{  This directive closes the current segment.			}
+{								}
+{								}
+{  pc_ent - enter a subroutine					}
+{								}
+{  Gen0(pc_ent)							}
+{								}
+{  This pcode is used at the beginning of every subroutine.  It }
+{  marks the beginning of a new stack frame definition.		}
+{  Subsequent dc_loc and dc_prm cause space to be allocated	}
+{  from this stack frame.					}
+{								}
+{								}
+{  pc_ret - return from a subroutine				}
+{								}
+{  Gen0t(pc_ret, type)						}
+{								}
+{  This pcode is used to return from a function or a procedure. }
+{  The type is the type of the function, and is used to tell	}
+{  the code generator what type of value to return.  The value	}
+{  to return is assumed to be stored defaultStackSize bytes	}
+{  into the stack frame. 					}
+{								}
+{								}
+{  pc_cui - call user procedure, indirect			}
+{								}
+{  Gen0t(pc_cui, ftype)						}
+{								}
+{  TOS-1 is the address of a procedure or function to call.	}
+{  TOS is the static level for the procedure.  These values are	}
+{  removed from the stack, and the procedure is called.		}
+{								}
+{								}
+{  pc_cum - call user method					}
+{								}
+{  GenL1t(pc_cum, disp, ftype)					}
+{								}
+{  A series of parameters is on the stack; the first is the	}
+{  SELF parameter.  DISP is a displacement into the object	}
+{  where the address of the method to call can be found.	}
+{								}
+{								}
+{  pc_cup - call user procedure					}
+{								}
+{  Gen1tName(pc_cup, level, ftype, name)			}
+{  Gen2t(pc_cup, label, level, ftype)				}
+{								}
+{  Calls a user procedure or function.	FTYPE is the return	}
+{  type.  NAME is the name of a global procedure; LABEL is used	}
+{  for local procedures.  LEVEL is the ???			}
+{								}
+{								}
+{  pc_csp - call standard procedure				}
+{								}
+{  Gen1(pc_csp, proc)						}
+{								}
+{  Calls a standard procedure or function.  PROC is the		}
+{  procedure or function name.					}
+{								}
+{								}
+{  dc_loc - define local label					}
+{								}
+{  Gen2(dc_loc, label, size)					}
+{								}
+{  Defines a local label using the label parameter as a label	}
+{  number.  Size bytes are reserved on the stack frame.	 Label	}
+{  numbers should be assigned by the compiler, starting with	}
+{  number 1.  Label 0 is reserved for refering to the return	}
+{  value of a function (if any). 				}
+{								}
+{								}
+{  dc_prm - define parameter					}
+{								}
+{  Gen3(dc_prm, label, size, disp)				}
+{								}
+{  Defines a label used to refer to a parameter.  See dc_loc	}
+{  for a discussion of the label and size parameters.  The disp }
+{  parameter is the number of bytes of parameter that will be	}
+{  pushed after this one; i.e., the disp from the return addr	}
+{  to this parameter.						}
+{								}
+{								}
+{  dc_fun - define function variable				}
+{								}
+{  Gen2(dc_fun, label, size)					}
+{								}
+{  Defines a label used to refer to the function return value.	}
+{  This works like dc_loc, but requires special tracking so the }
+{  pc_ret statement can find the value.				}
+{								}
+{								}
+{  pc_pds - call ProDOS						}
+{								}
+{  Gen1(pc_pds, callNum) 					}
+{								}
+{  Calls ProDOS.  CALLNUM is the ProDOS call number.  The	}
+{  address of the parameter block is on the stack.		}
+{								}
+{								}
+{  pc_tl1 - call a tool						}
+{  pc_tl2 - call a tool						}
+{								}
+{  Gen2t(pc_tl1, toolNum, callNum, type) 			}
+{								}
+{  Calls a tool.  The tool number is TOOLNUM; the tool call	}
+{  is CALLNUM.  TYPE is the return type, which must be one of	}
+{  the integer types or cgVoid.  pc_tl1 calls the system entry	}
+{  point, while pc_tl2 calls the user tool entry point.		}
+{								}
+{								}
+{  pc_vct - call a tool through a vector			}
+{								}
+{  Gen1L1t(pc_vct, call, vector, type) 				}
+{								}
+{  Generates a call using toolbox conventions.  TOS contains	}
+{  the parameters.  Space for the returned value of type TYPE	}
+{  is pushed on the stack, CALL is loaded into the X register,	}
+{  and a JSL VECTOR is performed.  On return, A is saved at	}
+{  ~TOOLERROR and any function value is loaded into the		}
+{  registers.							}
+{								}
+{								}
+{  dc_sym - generate a symbol table				}
+{								}
+{  Gen1Name(dc_sym, doGLobals, pointer(table)			}
+{								}
+{  Generates a symbol table for the debugger.  TABLE is the	}
+{  address of the sybol table, which will be passed back to a	}
+{  subroutine called GenSymbols, which must be supplied by the	}
+{  compiler.  DOGLOBALS is a flag the compiler can set for its	}
+{  own purposes.  C uses the flag to note that the symbol	}
+{  table being created is for main, so global symbols should be }
+{  included.							}
+{								}
diff --git a/cgi.pas b/cgi.pas
old mode 100755
new mode 100644
index 9ae5e3e..72d235e
--- a/cgi.pas
+++ b/cgi.pas
@@ -1 +1,1250 @@
-{$optimize -1}
{---------------------------------------------------------------}
{								}
{  ORCA Code Generator Interface 				}
{								}
{  This unit serves as the glue code attaching a compiler	}
{  to the code generator.  It provides subroutines in a		}
{  format that is convinient for the compiler during		}
{  semantic analysis, and produces intermediate code records	}
{  as output.  These intermediate code records are then		}
{  passed on to the code generator for optimization and		}
{  native code generation.					}
{								}
{$copy 'cgi.comments'}
{---------------------------------------------------------------}

unit CodeGeneratorInterface;

interface

{$segment 'cg'}
             
{$LibPrefix '0/obj/'}

uses PCommon;

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

const
					{Code Generation}
					{---------------}
   maxLocalLabel =	300;		{max # local variables}
   maxString	=	8000;		{max # chars in string space}

					{Error interface: these constants map  }
					{code generator error numbers into the }
					{numbers used by the compiler's Error  }
					{subroutine.			       }
					{--------------------------------------}
   cge1			=	113;	{compiler error}
   cge2			=	111;	{implementation restriction: too many local labels}
   cge3			=	132;	{implementation restriction: string space exhausted}

					{size of internal types}
					{----------------------}
   cgByteSize		=	1;
   cgWordSize		=	2;
   cgLongSize		=	4;
   cgPointerSize 	=	4;
   cgRealSize		=	4;
   cgDoubleSize		=	8;
   cgCompSize		=	8;
   cgExtendedSize	=      10;

					{token buffer (.int file)}
                                        {------------------------}
					{NOTE: tokenBuffSize also defined in objout.asm}
   tokenBuffSize = 4095;		{size of the token buffer}

type
					{misc}
					{----}
   segNameType = packed array[1..10] of char; {segment name}

					{p code}
					{------}
   pcodes =				{pcode names}
      (pc_adi,pc_adr,pc_and,pc_dvi,pc_dvr,pc_cnn,pc_cnv,pc_ior,pc_mod,pc_mpi,
       pc_mpr,pc_ngi,pc_ngr,pc_not,pc_sbi,pc_sbr,pc_sto,pc_dec,dc_loc,pc_ent,
       pc_fjp,pc_inc,pc_ind,pc_ixa,pc_lao,pc_lca,pc_ldo,pc_mov,pc_ret,pc_sro,
       pc_xjp,pc_cup,pc_equ,pc_geq,pc_grt,pc_lda,pc_ldc,pc_leq,pc_les,pc_lod,
       pc_neq,pc_str,pc_ujp,pc_add,pc_lnm,pc_nam,pc_cui,pc_cum,pc_tjp,dc_lab,
       pc_usr,pc_umi,pc_udi,pc_lla,pc_lsl,pc_lad,pc_uim,dc_enp,pc_stk,dc_glb,
       dc_dst,dc_str,pc_cop,pc_cpo,pc_tl1,pc_tl2,dc_pin,pc_shl,pc_shr,pc_bnd,
       pc_bor,pc_bxr,pc_bnt,pc_bnl,pc_mpl,pc_dvl,pc_mdl,pc_sll,pc_slr,pc_bal,
       pc_ngl,pc_adl,pc_sbl,pc_blr,pc_blx,pc_siz,dc_sym,pc_lnd,pc_lor,pc_vsr,
       pc_uml,pc_udl,pc_ulm,pc_pds,dc_cns,dc_prm,pc_bno,pc_nop,pc_csp,pc_chk,
       pc_abi,pc_abr,pc_abl,pc_sqi,pc_sql,pc_sqr,pc_rnd,pc_rn4,pc_odd,pc_odl,
       pc_at2,pc_sgs,pc_uni,pc_pwr,pc_int,pc_dif,pc_inn,pc_prs,pc_fix,dc_fun,
       pc_sin,pc_cos,pc_exp,pc_sqt,pc_log,pc_atn,pc_tan,pc_acs,pc_asn,pc_vct);

					{intermediate code}
					{-----------------}
   baseTypeEnum = (cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,
		   cgReal,cgDouble,cgComp,cgExtended,cgString,cgVoid,
		   cgSet);

   setPtr = ^setRecord;			{set constant}
   setRecord = record
      smax: integer;
      sval: packed array[1..setsize] of char;
      end;

   icptr = ^intermediate_code;
   intermediate_code = record		{intermediate code record}
      opcode: pcodes;			{operation code}
      p,q,r,s: integer;			{operands}
      lab: pStringPtr;			{named label pointer}
      next: icptr;			{ptr to next statement}
      left, right: icptr;		{leaves for trees}
      parents: integer;			{number of parents}
      case optype: baseTypeEnum of
	 cgByte,
	 cgUByte,
	 cgWord,
	 cgUWord 	: (opnd: longint; llab,slab: integer);
	 cgLong,
	 cgULong 	: (lval,lval2: longint);
	 cgReal,
	 cgDouble,
	 cgComp,
	 cgExtended	: (rval: double);
	 cgString	: (str: pStringPtr);
	 cgSet		: (setp: setPtr);
	 cgVoid		: (pval: longint; pstr: pStringPtr);
      end;

					{basic blocks}
					{------------}
   iclist = ^iclistRecord;		{used to form lists of records}
   iclistRecord = record
      next: iclist;
      op: icptr;
      end;

   blockPtr = ^block;			{basic block edges}
   blockListPtr = ^blockListRecord;	{lists of blocks}
   block = record
      last, next: blockPtr;		{for doubly linked list of blocks}
      dfn: integer;			{depth first order index}
      visited: boolean;			{has this node been visited?}
      code: icptr;			{code in the block}
      c_in: iclist;			{list of reaching definitions}
      c_out: iclist;			{valid definitions on exit}
      c_gen: iclist;			{generated definitions}
      dom: blockListPtr; 		{dominators of this block}
      end;

   blockListRecord = record		{lists of blocks}
      next, last: blockListPtr;
      dfn: integer;
      end;

					{65816 native code generation}
					{----------------------------}
   addressingMode = (implied,immediate, {65816 addressing modes}
      longabs,longrelative,relative,absolute,direct,gnrLabel,gnrSpace,
      gnrConstant,genaddress,special,longabsolute);

var
					{misc}
					{----}
   keepflag: integer;			{keep flag}
   currentSegment,defaultSegment: segNameType; {current & default seg names}
   symLength: integer;                  {length of debug symbol table}


					{DAG construction}
					{----------------}
   DAGhead: icPtr;			{1st ic in DAG list}
   DAGblocks: blockPtr;			{list of basic blocks}


					{variables used to control the }
					{quality or characteristics of }
					{code			       }
					{------------------------------}
   cLineOptimize: boolean;		{+o flag set?}
   code: icptr;				{current intermediate code record}
   codeGeneration: boolean;		{is code generation on?}
   commonSubexpression: boolean; 	{do common subexpression removal?}
   debugFlag: boolean;			{generate debugger calls?}
   floatCard: integer;			{0 -> SANE; 1 -> FPE}
   floatSlot: integer;			{FPE slot}
   isDynamic: boolean;			{are segments dynamic?}
   jslOptimizations: boolean;		{do jsl optimizations?}
   loopOptimizations: boolean;		{do loop optimizations?}
   npeephole: boolean;			{do native code peephole optimizations?}
   peephole: boolean;			{do peephole optimization?}
   profileFlag: boolean; 		{generate profiling code?}
   rangeCheck: boolean;			{generate range checks?}
   registers: boolean;			{do register optimizations?}
   saveStack: boolean;			{save, restore caller's stack reg?}
   segmentKind: integer; 		{kind field of segment (ored with start/data)}
   smallMemoryModel: boolean;		{is the small model in use?}
   stackSize: integer;			{amount of stack space to reserve}
   stringsize: 0..maxstring;		{amount of string space left}
   stringspace: packed array[1..maxstring] of char; {string table}
   toolParms: boolean;			{generate tool format paramaters?}
   traceBack: boolean;			{generate traceback code?}

					{current instruction info}
					{------------------------}
   isJSL: boolean;			{is the current opcode a jsl?}

					{desk accessory variables}
					{------------------------}
   isNewDeskAcc: boolean;		{is this a new desk acc?}
   isClassicDeskAcc: boolean;		{is this a classic desk acc?}
   isCDev: boolean;			{is this a control panel device?}
   isNBA: boolean;			{is this a new button action?}
   isXCMD: boolean;			{is this an XCMD?}
   rtl: boolean; 			{return with an rtl?}

   openName,closeName,actionName,	{names of the required procedures}
      initName: pStringPtr;
   refreshPeriod: integer;		{refresh period}
   eventMask: integer;			{event mask}
   menuLine: pString;			{name in menu bar}

					{token buffer (.int file)}
                                        {------------------------}
   tokenDisp: 0..tokenBuffSize;		{disp in token buffer}
   tokenLen: longint;			{size of token buffer}
   tokenHandle: handle;			{token file handle}
   tokenNameGS: gsosOutStringPtr;	{token file name}
   tokenPtr: ptr;			{pointer to active part of token file}

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

procedure CloseToken;

{ close the token file (.int file)				}


procedure CodeGenFini;

{ terminal processing						}


procedure CodeGenInit (keepName: gsosOutStringPtr; keepFlag: integer;
		       partial: boolean);

{ code generator initialization					}
{								}
{ parameters:							}
{	keepName - name of the output file			}
{	keepFlag - keep status:					}
{		0 - don't keep the output                       }
{		1 - create a new object module			}
{		2 - a .root already exists			}
{		3 - at least on .letter file exists		}
{	partial - is this a partial compile?			}


procedure CodeGenScalarInit;

{ initialize codegen scalars					}


procedure DefaultSegName (s: segNameType);

{ set the default segment name					}
{								}
{ parameters:							}
{    s - segment name						}


procedure Gen0 (fop: pcodes);

{ generate an implied operand instruction			}
{								}
{ parameters:							}
{	fop - operation code					}


procedure Gen1 (fop: pcodes; fp2: integer);

{ generate an instruction with one numeric operand		}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp2 - operand						}


procedure Gen2 (fop: pcodes; fp1, fp2: integer);

{ generate an instruction with two numeric operands		}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	fp2 - second operand					}


procedure Gen3 (fop: pcodes; fp1, fp2, fp3: integer);

{ generate an instruction with three numeric operands		}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	fp2 - second operand					}
{	fp3 - third operand					}


procedure Gen0t (fop: pcodes; tp: baseTypeEnum);

{ generate a typed implied operand instruction			}
{								}
{ parameters:							}
{	fop - operation code					}
{	tp - base type						}


procedure Gen1t (fop: pcodes; fp1: integer; tp: baseTypeEnum);

{ generate a typed instruction with two numeric operands 	}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - operand						}
{	tp - base type						}


procedure Gen2t (fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum);

{ generate a typed instruction with two numeric operands 	}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	fp2 - second operand					}
{	tp - base type						}


procedure Gen3t (fop: pcodes; fp1, fp2, fp3: integer; tp: baseTypeEnum);

{ generate a typed instruction with three numeric operands	}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	fp2 - second operand					}
{	fp3 - third operand					}
{	tp - base type						}


procedure Gen4t (fop: pcodes; fp1, fp2, fp3, fp4: integer; tp: baseTypeEnum);

{ generate a typed instruction with four numeric operands	}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	fp2 - second operand					}
{	fp3 - third operand					}
{	fp4 - fourth operand					}
{	tp - base type						}


procedure Gen0Name (fop: pcodes; name: pStringPtr);

{ generate a p-code with a name					}
{								}
{ parameters:							}
{	fop - operation code					}
{	name - named label					}


procedure Gen1Name (fop: pcodes; fp1: integer; name: pStringPtr);

{ generate a one operand p-code with a name			}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	name - named label					}


procedure Gen2Name (fop: pcodes; fp1, fp2: integer; name: pStringPtr);

{ generate a two operand p-code with a name			}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	fp2 - second operand					}
{	name - named label					}


procedure Gen1tName (fop: pcodes; fp1: integer; tp: baseTypeEnum;
		     name: pStringPtr);

{ generate a typed one operand p-code with a name		}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	tp - base type						}
{	name - named label					}


procedure Gen2tName (fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum;
		     name: pStringPtr);

{ generate a typed two operand p-code with a name		}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	fp2 - second operand					}
{	tp - base type						}
{	name - named label					}


procedure Gen1L1t (fop: pcodes; fp1: integer; lval: longint; tp: baseTypeEnum);

{ generate an instruction with one integer and one longint	}
{                                                               }
{ parameters:                                                   }
{	fop - operation code					}
{	fp1 - integer parameter					}
{       lval - longint parameter				}
{	tp - base type						}
                                                                       

procedure GenL1t (fop: pcodes; lval: longint; tp: baseTypeEnum);

{ generate an instruction that uses a longint			}
{                                                               }
{ parameters:                                                   }
{	fop - operation code					}
{       lval - longint parameter				}
{	tp - base type						}
                                                                       

procedure GenL2t (fop: pcodes; lval, lval2: longint; tp: baseTypeEnum);

{ generate an instruction that uses two longints		}
{                                                               }
{ parameters:                                                   }
{	fop - operation code					}
{       lval, lval2 - longint parameters			}
{	tp - base type						}
                                                                       

procedure GenLdcLong (lval: longint);

{ load a long constant						}
{								}
{ parameters:							}
{	lval - value to load					}


procedure GenLdcReal (rval: double);

{ load a real constant						}
{								}
{ parameters:							}
{	rval - value to load					}


procedure GenLdcSet (cval: constantRec);

{ load a set constant						}
{								}
{ parameters:							}
{	cval - value to load					}


procedure GenPS (fop: pcodes; str: pStringPtr);

{ generate an instruction that uses a p-string operand		}
{								}
{ parameters:							}
{	fop - operation code					}
{	str - pointer to string					}


procedure InitLabels; extern;

{ initialize the labels array for a procedure			}


{procedure InitWriteCode; 		    {debug}

{ initialize the intermediate code opcode table			}


procedure NextSegName (s: segNameType);

{ set the segment name for the next segment created		}
{								}
{ parameters:							}
{    s - segment name						}


{procedure PrintBlocks (tag: pStringPtr; bp: blockPtr); {debug}

{ print a series of basic blocks 				}
{								}
{ parameters:							}
{    tag - label for lines					}
{    bp - first block to print					}


{procedure WriteCode (code: icptr);	{debug}

{ print an intermediate code instruction 			}
{								}
{ Parameters:							}
{    code - intermediate code instruction to write		}

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

implementation

{var
   opt: array[pcodes] of packed array[1..3] of char; {debug}

function NewHandle (blockSize: longint; userID, memAttributes: integer;
                    memLocation: univ ptr): handle; tool ($02, $09);

{Imported from ObjOut.pas:}

procedure CloseObj; extern;

{ close the current obj file					}


procedure TokenOut (b: byte); extern;

{ Write a byte to the interface file				}
{								}
{ parameters:							}
{    b - byte to write						}


{Imported from DAG.pas:}

procedure DAG (code: icptr); extern;

{ place an op code in a DAG or tree				}
{								}
{ parameters:							}
{	code - opcode						}


{Imported from Native.pas:}

procedure InitFile (keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean);
extern;

{ Set up the object file 					}
{								}
{ parameters:							}
{    keepName - name of the output file				}
{    keepFlag - keep status:					}
{	0 - don't keep the output				}
{	1 - create a new object module				}
{	2 - a .root already exists				}
{	3 - at least on .letter file exists			}
{    partial - is this a partial compile?			}

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

{ copy 'cgi.debug'}			{debug}

procedure CloseToken;

{ close the token file (.int file)				}

var
   dsRec: destroyOSDCB;			{DestroyGS record}
   ffRec: fastFileDCBGS;		{FastFile record}
   i: 1..8;				{loop/index variable}

begin {CloseToken}
if GetFileType(tokenNameGS^) = BIN then begin
   dsRec.pCount := 1;			{destroy any old file}
   dsRec.pathname := @tokenNameGS^.theString;
   DestroyGS(dsRec);
   end; {if}
if doingUnit and codegeneration then begin
   ffRec.pCount := 13;
   ffRec.action := 3 {save} ;
   ffRec.flags := $C000;
   ffRec.fileHandle := tokenHandle;
   ffRec.pathName := @tokenNameGS^.theString;
   ffRec.access := $00C3;
   ffRec.fileType := DVU;
   ffRec.auxType := AuxUnit;
   ffRec.storageType := 1;
   for i := 1 to 8 do
      ffRec.createDate[i] := 0;
   ffRec.modDate := ffRec.createDate;
   ffRec.option := nil;
   ffRec.fileLength := tokenLen + tokenDisp;
   FastFileGS(ffRec);
   if ToolError <> 0 then
      TermError(12, nil);
   ffRec.action := 7 {purge} ;
   ffRec.fileHandle := tokenHandle;
   FastFileGS(ffRec);
   if ToolError <> 0 then
      TermError(12, nil);
   end; {if}
end; {CloseToken}


procedure CodeGenFini;

{ terminal processing						}

begin {CodeGenFini}
CloseObj;				{close the open object file}
end; {CodeGenFini}


procedure CodeGenInit {keepName: gsosOutStringPtr; keepFlag: integer;
		       partial: boolean};

{ code generator initialization					}
{								}
{ parameters:							}
{	keepName - name of the output file			}
{	keepFlag - keep status:					}
{		0 - don't keep the output                       }
{		1 - create a new object module			}
{		2 - a .root already exists			}
{		3 - at least on .letter file exists		}
{	partial - is this a partial compile?			}

const
   usesVersion = 1;			{current uses file format version}

begin {CodeGenInit}
{initialize the debug tables		{debug}
{InitWriteCode;				{debug}

{initialize the label table}
InitLabels;

codeGeneration := true;			{turn on code generation}

{set up the DAG variables}
DAGhead := nil;				{no ics in DAG list}

InitFile(keepName, keepFlag, partial);	{open the keep file}

if doingUnit then begin
   new(tokenNameGS);			{create the token file name}
   tokenNameGS^ := keepName^;
   if tokenNameGS^.theString.size < maxPath then
      tokenNameGS^.theString.theString[tokenNameGS^.theString.size+1] := chr(0);
   tokenNameGS^.theString.theString := concat(tokenNameGS^.theString.theString, '.int');
   tokenNameGS^.theString.size := length(tokenNameGS^.theString.theString);
   if memoryFlag then			{memory-based compiles are not allowed}
      TermError(10, nil);
   tokenHandle :=			{get a token buffer}
      NewHandle(tokenBuffSize+1, UserID, $8000, nil);
   if ToolError <> 0 then
      TermError(3, nil);
   tokenPtr := tokenHandle^;
   tokenDisp := 0;
   tokenLen := 0;
   TokenOut(usesVersion);
   end; {if}
end; {CodeGenInit}


procedure CodeGenScalarInit;

{ initialize codegen scalars					}

begin {CodeGenScalarInit}
isJSL := false;				{the current opcode is not a jsl}
isNewDeskAcc := false;			{assume a normal program}
isCDev := false;
isClassicDeskAcc := false;
isNBA := false;
isXCMD := false;
codeGeneration := false; 		{code generation is not turned on yet}
currentSegment := '          ';		{start with the blank segment}
defaultSegment := '          ';
smallMemoryModel := true;		{small memory model}
dataBank := false;			{don't save/restore data bank}
stackSize := 0;				{default to the launcher's stack size}
toolParms := false;			{generate tool format parameters?}
rtl := false;				{return with a ~QUIT}
floatCard := 0;				{use SANE}
floatSlot := 0;				{default to slot 0}
stringSize := 0; 			{no strings, yet}

rangeCheck := false;			{don't generate range checks}
profileFlag := false;			{don't generate profiling code}
debugFlag := false;			{don't generate debug code}
traceBack := false;			{don't generate traceback code}

registers := cLineOptimize;		{don't do register optimizations}
peepHole := cLineOptimize;		{not doing peephole optimization (yet)}
npeepHole := cLineOptimize;
commonSubexpression := cLineOptimize;	{not doing common subexpression elimination}
loopOptimizations := cLineOptimize;	{not doing loop optimizations, yet}
jslOptimizations := cLineOptimize;	{not doing jsl optimizations, yet}

{allocate the initial p-code}
code := pointer(Calloc(sizeof(intermediate_code)));
code^.optype := cgWord;
end; {CodeGenScalarInit}


procedure DefaultSegName {s: segNameType};

{ set the default segment name					}
{								}
{ parameters:							}
{    s - segment name						}

begin {DefaultSegName}
currentSegment := s;
defaultSegment := s;
end; {DefaultSegName}


procedure Gen0 {fop: pcodes};

{ generate an implied operand instruction			}
{								}
{ parameters:							}
{	fop - operation code					}

begin {Gen0}
if codeGeneration then begin

   {generate the intermediate code instruction}
   code^.opcode := fop;
{  if printSymbols then			{debug}
{     WriteCode(code);			{debug}
   DAG(code);				{generate the code}

   {initialize volitile variables for next intermediate code}
   code := pointer(Calloc(sizeof(intermediate_code)));
   {code^.lab := nil;}
   code^.optype := cgWord;
   end; {if}
end; {Gen0}


procedure Gen1 {fop: pcodes; fp2: integer};

{ generate an instruction with one numeric operand		}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp2 - operand						}

begin {Gen1}
if codeGeneration then begin
   if fop = pc_ret then
      code^.optype := cgVoid;
   code^.q := fp2;
   Gen0(fop);
   end; {if}
end; {Gen1}


procedure Gen2 {fop: pcodes; fp1, fp2: integer};

{ generate an instruction with two numeric operands		}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	fp2 - second operand					}

label 1;

var
   lcode: icptr; 			{local copy of code}

begin {Gen2}
if codeGeneration then begin
   lcode := code;
   case fop of

      dc_fun,pc_lnm,pc_tl1,pc_tl2,pc_lda,dc_loc,pc_mov: begin
	 lcode^.r := fp1;
	 lcode^.q := fp2;
	 end;

      pc_cnn,pc_cnv:
	 if fp1 = fp2 then
	    goto 1
	 else if (baseTypeEnum(fp1) in [cgReal,cgDouble,cgComp,cgExtended])
	    and (baseTypeEnum(fp2) in [cgReal,cgDouble,cgComp,cgExtended]) then
	    goto 1
	 else if (baseTypeEnum(fp1) in [cgUByte,cgWord,cgUWord])
	    and (baseTypeEnum(fp2) in [cgWord,cgUWord]) then
	    goto 1
	 else if (baseTypeEnum(fp1) in [cgByte,cgUByte])
	    and (baseTypeEnum(fp2) in [cgByte,cgUByte]) then
	    goto 1
	 else
	    lcode^.q := (fp1 << 4) | fp2;

      otherwise:
	 Error(cge1);
      end; {case}

   Gen0(fop);
   end; {if}
1:
end; {Gen2}


procedure Gen3 {fop: pcodes; fp1, fp2, fp3: integer};

{ generate an instruction with three numeric operands		}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	fp2 - second operand					}
{	fp3 - third operand					}

var
   lcode: icptr; 			{local copy of code}

begin {Gen3}
if codeGeneration then begin
   lcode := code;
   if fop = pc_lda then begin
      lcode^.s := fp1;
      lcode^.p := fp2;
      lcode^.q := fp3;
      end {if}
   else begin
      lcode^.s := fp1;
      lcode^.q := fp2;
      lcode^.r := fp3;
      end; {else}
   Gen0(fop);
   end; {if}
end; {Gen3}


procedure Gen0t {fop: pcodes; tp: baseTypeEnum};

{ generate a typed implied operand instruction			}
{								}
{ parameters:							}
{	fop - operation code					}
{	tp - base type						}

begin {Gen0t}
if codeGeneration then begin
   code^.optype := tp;
   Gen0(fop);
   end; {if}
end; {Gen0t}


procedure Gen1t {fop: pcodes; fp1: integer; tp: baseTypeEnum};

{ generate a typed instruction with two numeric operands 	}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - operand						}
{	tp - base type						}

var
   lcode: icptr; 			{local copy of code}

begin {Gen1t}
if codeGeneration then begin
   lcode := code;
   lcode^.optype := tp;
   lcode^.q := fp1;
   Gen0(fop);
   end; {if}
end; {Gen1t}


procedure Gen2t {fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum};

{ generate a typed instruction with two numeric operands 	}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	fp2 - second operand					}
{	tp - base type						}

var
   lcode: icptr; 			{local copy of code}

begin {Gen2t}
if codeGeneration then begin
   lcode := code;
   lcode^.optype := tp;
   lcode^.r := fp1;
   lcode^.q := fp2;
   Gen0(fop);
   end; {if}
end; {Gen2t}


procedure Gen3t {fop: pcodes; fp1, fp2, fp3: integer; tp: baseTypeEnum};

{ generate a typed instruction with three numeric operands	}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	fp2 - second operand					}
{	fp3 - third operand					}
{	tp - base type						}

var
   lcode: icptr; 			{local copy of code}

begin {Gen3t}
if codeGeneration then begin
   lcode := code;
   lcode^.optype := tp;
   if fop in [pc_lod, pc_str] then begin
      lcode^.r := fp1;
      lcode^.q := fp2;
      lcode^.p := fp3;
      end {if}
   else begin
      lcode^.s := fp1;
      lcode^.q := fp2;
      lcode^.r := fp3;
      end; {else if}
   Gen0(fop);
   end; {if}
end; {Gen3t}


procedure Gen4t {fop: pcodes; fp1, fp2, fp3, fp4: integer; tp: baseTypeEnum};

{ generate a typed instruction with four numeric operands	}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	fp2 - second operand					}
{	fp3 - third operand					}
{	fp4 - fourth operand					}
{	tp - base type						}

var
   lcode: icptr; 			{local copy of code}

begin {Gen4t}
if codeGeneration then begin
   lcode := code;
   lcode^.optype := tp;
   lcode^.r := fp1;
   lcode^.q := fp2;
   lcode^.p := fp3;
   lcode^.s := fp4;
   Gen0(fop);
   end; {if}
end; {Gen4t}


procedure Gen0Name {fop: pcodes; name: pStringPtr};

{ generate a p-code with a name					}
{								}
{ parameters:							}
{	fop - operation code					}
{	name - named label					}

begin {Gen0Name}
if codeGeneration then begin
   code^.lab := name;
   Gen0(fop);
   end; {if}
end; {Gen0Name}


procedure Gen1Name {fop: pcodes; fp1: integer; name: pStringPtr};

{ generate a one operand p-code with a name			}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	name - named label					}

var
   lcode: icptr; 			{local copy of code}

begin {Gen1Name}
if codeGeneration then begin
   lcode := code;
   lcode^.q := fp1;
   lcode^.lab := name;
   Gen0(fop);
   end; {if}
end; {Gen1Name}


procedure Gen2Name {fop: pcodes; fp1, fp2: integer; name: pStringPtr};

{ generate a two operand p-code with a name			}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	fp2 - second operand					}
{	name - named label					}

var
   lcode: icptr; 			{local copy of code}

begin {Gen2Name}
if codeGeneration then begin
   lcode := code;
   lcode^.q := fp2;
   lcode^.r := fp1;
   lcode^.lab := name;
   Gen0(fop);
   end; {if}
end; {Gen2Name}


procedure Gen1tName {fop: pcodes; fp1: integer; tp: baseTypeEnum;
		     name: pStringPtr};

{ generate a typed one operand p-code with a name		}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	tp - base type						}
{	name - named label					}

var
   lcode: icptr; 			{local copy of code}

begin {Gen1tName}
if codeGeneration then begin
   lcode := code;
   lcode^.q := fp1;
   lcode^.lab := name;
   lcode^.optype := tp;
   Gen0(fop);
   end; {if}
end; {Gen1tName}


procedure Gen2tName {fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum;
		     name: pStringPtr};

{ generate a typed two operand p-code with a name		}
{								}
{ parameters:							}
{	fop - operation code					}
{	fp1 - first operand					}
{	fp2 - second operand					}
{	tp - base type						}
{	name - named label					}

var
   lcode: icptr; 			{local copy of code}

begin {Gen2tName}
if codeGeneration then begin
   lcode := code;
   lcode^.r := fp1;
   lcode^.q := fp2;
   lcode^.lab := name;
   lcode^.optype := tp;
   Gen0(fop);
   end; {if}
end; {Gen2tName}


procedure Gen1L1t {fop: pcodes; fp1: integer; lval: longint; tp: baseTypeEnum};

{ generate an instruction with one integer and one longint	}
{                                                               }
{ parameters:                                                   }
{	fop - operation code					}
{	fp1 - integer parameter					}
{       lval - longint parameter				}
{	tp - base type						}
                                                                       
var
   lcode: icptr; 			{local copy of code}

begin {Gen1L1t}
if codeGeneration then begin
   lcode := code;
   lcode^.optype := tp;
   lcode^.q := fp1;
   lcode^.lval := lval;
   Gen0(fop);
   end; {if}
end; {Gen1L1t}


procedure GenL1t {fop: pcodes; lval: longint; tp: baseTypeEnum};

{ generate an instruction that uses a longint			}
{                                                               }
{ parameters:                                                   }
{	fop - operation code					}
{       lval - longint parameter				}
{	tp - base type						}
                                                                       
var
   lcode: icptr; 			{local copy of code}

begin {GenL1t}
if codeGeneration then begin
   lcode := code;
   lcode^.optype := tp;
   lcode^.lval := lval;
   Gen0(fop);
   end; {if}
end; {GenL1t}


procedure GenL2t {fop: pcodes; lval, lval2: longint; tp: baseTypeEnum};

{ generate an instruction that uses a longint and an int        }
{                                                               }
{ parameters:                                                   }
{	fop - operation code					}
{       lval, lval2 - longint parameters			}
{	tp - base type						}
                                                                       
var
   lcode: icptr; 			{local copy of code}

begin {GenL2t}
if codeGeneration then begin
   lcode := code;
   lcode^.optype := tp;
   lcode^.lval := lval;
   lcode^.lval2 := lval2;
   Gen0(fop);
   end; {if}
end; {GenL2t}


procedure GenLdcLong {lval: longint};

{ load a long constant						}
{								}
{ parameters:							}
{	lval - value to load					}

var
   lcode: icptr; 			{local copy of code}

begin {GenLdcLong}
if codeGeneration then begin
   lcode := code;
   if lval >= 0 then
     lcode^.optype := cgULong
   else
     lcode^.optype := cgLong;
   lcode^.lval := lval;
   Gen0(pc_ldc);
   end; {if}
end; {GenLdcLong}


procedure GenLdcReal {rval: double};

{ load a real constant						}
{								}
{ parameters:							}
{	rval - value to load					}

var
   lcode: icptr; 			{local copy of code}

begin {GenLdcReal}
if codeGeneration then begin
   lcode := code;
   lcode^.optype := cgReal;
   lcode^.rval := rval;
   Gen0(pc_ldc);
   end; {if}
end; {GenLdcReal}


procedure GenLdcSet {cval: constantRec};

{ load a set constant						}
{								}
{ parameters:							}
{	cval - value to load					}

var
   i, k: unsigned;			{loop/index variables}
   lcode: icptr; 			{local copy of code}

begin {GenLdcSet}
if codeGeneration then begin
   lcode := code;
   lcode^.optype := cgSet;
   i := cval.pmax div 8 + 1;
   lcode^.setp := pointer(Calloc(3+i));
   with lcode^.setp^ do begin
      smax := i;
      for k := 1 to i do
         sval[k] := cval.ch[k-1];
      end; {with}
   Gen0(pc_ldc);
   end; {if}
end; {GenLdcSet}


procedure GenPS {fop: pcodes; str: pStringPtr};

{ generate an instruction that uses a p-string operand		}
{								}
{ parameters:							}
{	fop - operation code					}
{	str - pointer to string					}

var
   lcode: icptr; 			{local copy of code}

begin {GenPS}
if codeGeneration then begin
   lcode := code;
   lcode^.q := length(str^);
   lcode^.optype := cgString;
   lcode^.str := str;
   Gen0(fop);
   end; {if}
end; {GenPS}


procedure NextSegName {s: segNameType};

{ set the segment name for the next segment created		}
{								}
{ parameters:							}
{    s - segment name						}

begin {NextSegmentName}
currentSegment := s;
end; {NextSegmentName}

end.

{$append 'cgi.asm'}
\ No newline at end of file
+{$optimize -1}
+{---------------------------------------------------------------}
+{								}
+{  ORCA Code Generator Interface 				}
+{								}
+{  This unit serves as the glue code attaching a compiler	}
+{  to the code generator.  It provides subroutines in a		}
+{  format that is convinient for the compiler during		}
+{  semantic analysis, and produces intermediate code records	}
+{  as output.  These intermediate code records are then		}
+{  passed on to the code generator for optimization and		}
+{  native code generation.					}
+{								}
+{$copy 'cgi.comments'}
+{---------------------------------------------------------------}
+
+unit CodeGeneratorInterface;
+
+interface
+
+{$segment 'cg'}
+             
+{$LibPrefix '0/obj/'}
+
+uses PCommon;
+
+{---------------------------------------------------------------}
+
+const
+					{Code Generation}
+					{---------------}
+   maxLocalLabel =	300;		{max # local variables}
+   maxString	=	8000;		{max # chars in string space}
+
+					{Error interface: these constants map  }
+					{code generator error numbers into the }
+					{numbers used by the compiler's Error  }
+					{subroutine.			       }
+					{--------------------------------------}
+   cge1			=	113;	{compiler error}
+   cge2			=	111;	{implementation restriction: too many local labels}
+   cge3			=	132;	{implementation restriction: string space exhausted}
+
+					{size of internal types}
+					{----------------------}
+   cgByteSize		=	1;
+   cgWordSize		=	2;
+   cgLongSize		=	4;
+   cgPointerSize 	=	4;
+   cgRealSize		=	4;
+   cgDoubleSize		=	8;
+   cgCompSize		=	8;
+   cgExtendedSize	=      10;
+
+					{token buffer (.int file)}
+                                        {------------------------}
+					{NOTE: tokenBuffSize also defined in objout.asm}
+   tokenBuffSize = 4095;		{size of the token buffer}
+
+type
+					{misc}
+					{----}
+   segNameType = packed array[1..10] of char; {segment name}
+
+					{p code}
+					{------}
+   pcodes =				{pcode names}
+      (pc_adi,pc_adr,pc_and,pc_dvi,pc_dvr,pc_cnn,pc_cnv,pc_ior,pc_mod,pc_mpi,
+       pc_mpr,pc_ngi,pc_ngr,pc_not,pc_sbi,pc_sbr,pc_sto,pc_dec,dc_loc,pc_ent,
+       pc_fjp,pc_inc,pc_ind,pc_ixa,pc_lao,pc_lca,pc_ldo,pc_mov,pc_ret,pc_sro,
+       pc_xjp,pc_cup,pc_equ,pc_geq,pc_grt,pc_lda,pc_ldc,pc_leq,pc_les,pc_lod,
+       pc_neq,pc_str,pc_ujp,pc_add,pc_lnm,pc_nam,pc_cui,pc_cum,pc_tjp,dc_lab,
+       pc_usr,pc_umi,pc_udi,pc_lla,pc_lsl,pc_lad,pc_uim,dc_enp,pc_stk,dc_glb,
+       dc_dst,dc_str,pc_cop,pc_cpo,pc_tl1,pc_tl2,dc_pin,pc_shl,pc_shr,pc_bnd,
+       pc_bor,pc_bxr,pc_bnt,pc_bnl,pc_mpl,pc_dvl,pc_mdl,pc_sll,pc_slr,pc_bal,
+       pc_ngl,pc_adl,pc_sbl,pc_blr,pc_blx,pc_siz,dc_sym,pc_lnd,pc_lor,pc_vsr,
+       pc_uml,pc_udl,pc_ulm,pc_pds,dc_cns,dc_prm,pc_bno,pc_nop,pc_csp,pc_chk,
+       pc_abi,pc_abr,pc_abl,pc_sqi,pc_sql,pc_sqr,pc_rnd,pc_rn4,pc_odd,pc_odl,
+       pc_at2,pc_sgs,pc_uni,pc_pwr,pc_int,pc_dif,pc_inn,pc_prs,pc_fix,dc_fun,
+       pc_sin,pc_cos,pc_exp,pc_sqt,pc_log,pc_atn,pc_tan,pc_acs,pc_asn,pc_vct);
+
+					{intermediate code}
+					{-----------------}
+   baseTypeEnum = (cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,
+		   cgReal,cgDouble,cgComp,cgExtended,cgString,cgVoid,
+		   cgSet);
+
+   setPtr = ^setRecord;			{set constant}
+   setRecord = record
+      smax: integer;
+      sval: packed array[1..setsize] of char;
+      end;
+
+   icptr = ^intermediate_code;
+   intermediate_code = record		{intermediate code record}
+      opcode: pcodes;			{operation code}
+      p,q,r,s: integer;			{operands}
+      lab: pStringPtr;			{named label pointer}
+      next: icptr;			{ptr to next statement}
+      left, right: icptr;		{leaves for trees}
+      parents: integer;			{number of parents}
+      case optype: baseTypeEnum of
+	 cgByte,
+	 cgUByte,
+	 cgWord,
+	 cgUWord 	: (opnd: longint; llab,slab: integer);
+	 cgLong,
+	 cgULong 	: (lval,lval2: longint);
+	 cgReal,
+	 cgDouble,
+	 cgComp,
+	 cgExtended	: (rval: double);
+	 cgString	: (str: pStringPtr);
+	 cgSet		: (setp: setPtr);
+	 cgVoid		: (pval: longint; pstr: pStringPtr);
+      end;
+
+					{basic blocks}
+					{------------}
+   iclist = ^iclistRecord;		{used to form lists of records}
+   iclistRecord = record
+      next: iclist;
+      op: icptr;
+      end;
+
+   blockPtr = ^block;			{basic block edges}
+   blockListPtr = ^blockListRecord;	{lists of blocks}
+   block = record
+      last, next: blockPtr;		{for doubly linked list of blocks}
+      dfn: integer;			{depth first order index}
+      visited: boolean;			{has this node been visited?}
+      code: icptr;			{code in the block}
+      c_in: iclist;			{list of reaching definitions}
+      c_out: iclist;			{valid definitions on exit}
+      c_gen: iclist;			{generated definitions}
+      dom: blockListPtr; 		{dominators of this block}
+      end;
+
+   blockListRecord = record		{lists of blocks}
+      next, last: blockListPtr;
+      dfn: integer;
+      end;
+
+					{65816 native code generation}
+					{----------------------------}
+   addressingMode = (implied,immediate, {65816 addressing modes}
+      longabs,longrelative,relative,absolute,direct,gnrLabel,gnrSpace,
+      gnrConstant,genaddress,special,longabsolute);
+
+var
+					{misc}
+					{----}
+   keepflag: integer;			{keep flag}
+   currentSegment,defaultSegment: segNameType; {current & default seg names}
+   symLength: integer;                  {length of debug symbol table}
+
+
+					{DAG construction}
+					{----------------}
+   DAGhead: icPtr;			{1st ic in DAG list}
+   DAGblocks: blockPtr;			{list of basic blocks}
+
+
+					{variables used to control the }
+					{quality or characteristics of }
+					{code			       }
+					{------------------------------}
+   cLineOptimize: boolean;		{+o flag set?}
+   code: icptr;				{current intermediate code record}
+   codeGeneration: boolean;		{is code generation on?}
+   commonSubexpression: boolean; 	{do common subexpression removal?}
+   debugFlag: boolean;			{generate debugger calls?}
+   floatCard: integer;			{0 -> SANE; 1 -> FPE}
+   floatSlot: integer;			{FPE slot}
+   isDynamic: boolean;			{are segments dynamic?}
+   jslOptimizations: boolean;		{do jsl optimizations?}
+   loopOptimizations: boolean;		{do loop optimizations?}
+   npeephole: boolean;			{do native code peephole optimizations?}
+   peephole: boolean;			{do peephole optimization?}
+   profileFlag: boolean; 		{generate profiling code?}
+   rangeCheck: boolean;			{generate range checks?}
+   registers: boolean;			{do register optimizations?}
+   saveStack: boolean;			{save, restore caller's stack reg?}
+   segmentKind: integer; 		{kind field of segment (ored with start/data)}
+   smallMemoryModel: boolean;		{is the small model in use?}
+   stackSize: integer;			{amount of stack space to reserve}
+   stringsize: 0..maxstring;		{amount of string space left}
+   stringspace: packed array[1..maxstring] of char; {string table}
+   toolParms: boolean;			{generate tool format paramaters?}
+   traceBack: boolean;			{generate traceback code?}
+
+					{current instruction info}
+					{------------------------}
+   isJSL: boolean;			{is the current opcode a jsl?}
+
+					{desk accessory variables}
+					{------------------------}
+   isNewDeskAcc: boolean;		{is this a new desk acc?}
+   isClassicDeskAcc: boolean;		{is this a classic desk acc?}
+   isCDev: boolean;			{is this a control panel device?}
+   isNBA: boolean;			{is this a new button action?}
+   isXCMD: boolean;			{is this an XCMD?}
+   rtl: boolean; 			{return with an rtl?}
+
+   openName,closeName,actionName,	{names of the required procedures}
+      initName: pStringPtr;
+   refreshPeriod: integer;		{refresh period}
+   eventMask: integer;			{event mask}
+   menuLine: pString;			{name in menu bar}
+
+					{token buffer (.int file)}
+                                        {------------------------}
+   tokenDisp: 0..tokenBuffSize;		{disp in token buffer}
+   tokenLen: longint;			{size of token buffer}
+   tokenHandle: handle;			{token file handle}
+   tokenNameGS: gsosOutStringPtr;	{token file name}
+   tokenPtr: ptr;			{pointer to active part of token file}
+
+{---------------------------------------------------------------}
+
+procedure CloseToken;
+
+{ close the token file (.int file)				}
+
+
+procedure CodeGenFini;
+
+{ terminal processing						}
+
+
+procedure CodeGenInit (keepName: gsosOutStringPtr; keepFlag: integer;
+		       partial: boolean);
+
+{ code generator initialization					}
+{								}
+{ parameters:							}
+{	keepName - name of the output file			}
+{	keepFlag - keep status:					}
+{		0 - don't keep the output                       }
+{		1 - create a new object module			}
+{		2 - a .root already exists			}
+{		3 - at least on .letter file exists		}
+{	partial - is this a partial compile?			}
+
+
+procedure CodeGenScalarInit;
+
+{ initialize codegen scalars					}
+
+
+procedure DefaultSegName (s: segNameType);
+
+{ set the default segment name					}
+{								}
+{ parameters:							}
+{    s - segment name						}
+
+
+procedure Gen0 (fop: pcodes);
+
+{ generate an implied operand instruction			}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+
+
+procedure Gen1 (fop: pcodes; fp2: integer);
+
+{ generate an instruction with one numeric operand		}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp2 - operand						}
+
+
+procedure Gen2 (fop: pcodes; fp1, fp2: integer);
+
+{ generate an instruction with two numeric operands		}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	fp2 - second operand					}
+
+
+procedure Gen3 (fop: pcodes; fp1, fp2, fp3: integer);
+
+{ generate an instruction with three numeric operands		}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	fp2 - second operand					}
+{	fp3 - third operand					}
+
+
+procedure Gen0t (fop: pcodes; tp: baseTypeEnum);
+
+{ generate a typed implied operand instruction			}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	tp - base type						}
+
+
+procedure Gen1t (fop: pcodes; fp1: integer; tp: baseTypeEnum);
+
+{ generate a typed instruction with two numeric operands 	}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - operand						}
+{	tp - base type						}
+
+
+procedure Gen2t (fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum);
+
+{ generate a typed instruction with two numeric operands 	}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	fp2 - second operand					}
+{	tp - base type						}
+
+
+procedure Gen3t (fop: pcodes; fp1, fp2, fp3: integer; tp: baseTypeEnum);
+
+{ generate a typed instruction with three numeric operands	}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	fp2 - second operand					}
+{	fp3 - third operand					}
+{	tp - base type						}
+
+
+procedure Gen4t (fop: pcodes; fp1, fp2, fp3, fp4: integer; tp: baseTypeEnum);
+
+{ generate a typed instruction with four numeric operands	}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	fp2 - second operand					}
+{	fp3 - third operand					}
+{	fp4 - fourth operand					}
+{	tp - base type						}
+
+
+procedure Gen0Name (fop: pcodes; name: pStringPtr);
+
+{ generate a p-code with a name					}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	name - named label					}
+
+
+procedure Gen1Name (fop: pcodes; fp1: integer; name: pStringPtr);
+
+{ generate a one operand p-code with a name			}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	name - named label					}
+
+
+procedure Gen2Name (fop: pcodes; fp1, fp2: integer; name: pStringPtr);
+
+{ generate a two operand p-code with a name			}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	fp2 - second operand					}
+{	name - named label					}
+
+
+procedure Gen1tName (fop: pcodes; fp1: integer; tp: baseTypeEnum;
+		     name: pStringPtr);
+
+{ generate a typed one operand p-code with a name		}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	tp - base type						}
+{	name - named label					}
+
+
+procedure Gen2tName (fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum;
+		     name: pStringPtr);
+
+{ generate a typed two operand p-code with a name		}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	fp2 - second operand					}
+{	tp - base type						}
+{	name - named label					}
+
+
+procedure Gen1L1t (fop: pcodes; fp1: integer; lval: longint; tp: baseTypeEnum);
+
+{ generate an instruction with one integer and one longint	}
+{                                                               }
+{ parameters:                                                   }
+{	fop - operation code					}
+{	fp1 - integer parameter					}
+{       lval - longint parameter				}
+{	tp - base type						}
+                                                                       
+
+procedure GenL1t (fop: pcodes; lval: longint; tp: baseTypeEnum);
+
+{ generate an instruction that uses a longint			}
+{                                                               }
+{ parameters:                                                   }
+{	fop - operation code					}
+{       lval - longint parameter				}
+{	tp - base type						}
+                                                                       
+
+procedure GenL2t (fop: pcodes; lval, lval2: longint; tp: baseTypeEnum);
+
+{ generate an instruction that uses two longints		}
+{                                                               }
+{ parameters:                                                   }
+{	fop - operation code					}
+{       lval, lval2 - longint parameters			}
+{	tp - base type						}
+                                                                       
+
+procedure GenLdcLong (lval: longint);
+
+{ load a long constant						}
+{								}
+{ parameters:							}
+{	lval - value to load					}
+
+
+procedure GenLdcReal (rval: double);
+
+{ load a real constant						}
+{								}
+{ parameters:							}
+{	rval - value to load					}
+
+
+procedure GenLdcSet (cval: constantRec);
+
+{ load a set constant						}
+{								}
+{ parameters:							}
+{	cval - value to load					}
+
+
+procedure GenPS (fop: pcodes; str: pStringPtr);
+
+{ generate an instruction that uses a p-string operand		}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	str - pointer to string					}
+
+
+procedure InitLabels; extern;
+
+{ initialize the labels array for a procedure			}
+
+
+{procedure InitWriteCode; 		    {debug}
+
+{ initialize the intermediate code opcode table			}
+
+
+procedure NextSegName (s: segNameType);
+
+{ set the segment name for the next segment created		}
+{								}
+{ parameters:							}
+{    s - segment name						}
+
+
+{procedure PrintBlocks (tag: pStringPtr; bp: blockPtr); {debug}
+
+{ print a series of basic blocks 				}
+{								}
+{ parameters:							}
+{    tag - label for lines					}
+{    bp - first block to print					}
+
+
+{procedure WriteCode (code: icptr);	{debug}
+
+{ print an intermediate code instruction 			}
+{								}
+{ Parameters:							}
+{    code - intermediate code instruction to write		}
+
+{---------------------------------------------------------------}
+
+implementation
+
+{var
+   opt: array[pcodes] of packed array[1..3] of char; {debug}
+
+function NewHandle (blockSize: longint; userID, memAttributes: integer;
+                    memLocation: univ ptr): handle; tool ($02, $09);
+
+{Imported from ObjOut.pas:}
+
+procedure CloseObj; extern;
+
+{ close the current obj file					}
+
+
+procedure TokenOut (b: byte); extern;
+
+{ Write a byte to the interface file				}
+{								}
+{ parameters:							}
+{    b - byte to write						}
+
+
+{Imported from DAG.pas:}
+
+procedure DAG (code: icptr); extern;
+
+{ place an op code in a DAG or tree				}
+{								}
+{ parameters:							}
+{	code - opcode						}
+
+
+{Imported from Native.pas:}
+
+procedure InitFile (keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean);
+extern;
+
+{ Set up the object file 					}
+{								}
+{ parameters:							}
+{    keepName - name of the output file				}
+{    keepFlag - keep status:					}
+{	0 - don't keep the output				}
+{	1 - create a new object module				}
+{	2 - a .root already exists				}
+{	3 - at least on .letter file exists			}
+{    partial - is this a partial compile?			}
+
+{---------------------------------------------------------------}
+
+{ copy 'cgi.debug'}			{debug}
+
+procedure CloseToken;
+
+{ close the token file (.int file)				}
+
+var
+   dsRec: destroyOSDCB;			{DestroyGS record}
+   ffRec: fastFileDCBGS;		{FastFile record}
+   i: 1..8;				{loop/index variable}
+
+begin {CloseToken}
+if GetFileType(tokenNameGS^) = BIN then begin
+   dsRec.pCount := 1;			{destroy any old file}
+   dsRec.pathname := @tokenNameGS^.theString;
+   DestroyGS(dsRec);
+   end; {if}
+if doingUnit and codegeneration then begin
+   ffRec.pCount := 13;
+   ffRec.action := 3 {save} ;
+   ffRec.flags := $C000;
+   ffRec.fileHandle := tokenHandle;
+   ffRec.pathName := @tokenNameGS^.theString;
+   ffRec.access := $00C3;
+   ffRec.fileType := DVU;
+   ffRec.auxType := AuxUnit;
+   ffRec.storageType := 1;
+   for i := 1 to 8 do
+      ffRec.createDate[i] := 0;
+   ffRec.modDate := ffRec.createDate;
+   ffRec.option := nil;
+   ffRec.fileLength := tokenLen + tokenDisp;
+   FastFileGS(ffRec);
+   if ToolError <> 0 then
+      TermError(12, nil);
+   ffRec.action := 7 {purge} ;
+   ffRec.fileHandle := tokenHandle;
+   FastFileGS(ffRec);
+   if ToolError <> 0 then
+      TermError(12, nil);
+   end; {if}
+end; {CloseToken}
+
+
+procedure CodeGenFini;
+
+{ terminal processing						}
+
+begin {CodeGenFini}
+CloseObj;				{close the open object file}
+end; {CodeGenFini}
+
+
+procedure CodeGenInit {keepName: gsosOutStringPtr; keepFlag: integer;
+		       partial: boolean};
+
+{ code generator initialization					}
+{								}
+{ parameters:							}
+{	keepName - name of the output file			}
+{	keepFlag - keep status:					}
+{		0 - don't keep the output                       }
+{		1 - create a new object module			}
+{		2 - a .root already exists			}
+{		3 - at least on .letter file exists		}
+{	partial - is this a partial compile?			}
+
+const
+   usesVersion = 1;			{current uses file format version}
+
+begin {CodeGenInit}
+{initialize the debug tables		{debug}
+{InitWriteCode;				{debug}
+
+{initialize the label table}
+InitLabels;
+
+codeGeneration := true;			{turn on code generation}
+
+{set up the DAG variables}
+DAGhead := nil;				{no ics in DAG list}
+
+InitFile(keepName, keepFlag, partial);	{open the keep file}
+
+if doingUnit then begin
+   new(tokenNameGS);			{create the token file name}
+   tokenNameGS^ := keepName^;
+   if tokenNameGS^.theString.size < maxPath then
+      tokenNameGS^.theString.theString[tokenNameGS^.theString.size+1] := chr(0);
+   tokenNameGS^.theString.theString := concat(tokenNameGS^.theString.theString, '.int');
+   tokenNameGS^.theString.size := length(tokenNameGS^.theString.theString);
+   if memoryFlag then			{memory-based compiles are not allowed}
+      TermError(10, nil);
+   tokenHandle :=			{get a token buffer}
+      NewHandle(tokenBuffSize+1, UserID, $8000, nil);
+   if ToolError <> 0 then
+      TermError(3, nil);
+   tokenPtr := tokenHandle^;
+   tokenDisp := 0;
+   tokenLen := 0;
+   TokenOut(usesVersion);
+   end; {if}
+end; {CodeGenInit}
+
+
+procedure CodeGenScalarInit;
+
+{ initialize codegen scalars					}
+
+begin {CodeGenScalarInit}
+isJSL := false;				{the current opcode is not a jsl}
+isNewDeskAcc := false;			{assume a normal program}
+isCDev := false;
+isClassicDeskAcc := false;
+isNBA := false;
+isXCMD := false;
+codeGeneration := false; 		{code generation is not turned on yet}
+currentSegment := '          ';		{start with the blank segment}
+defaultSegment := '          ';
+smallMemoryModel := true;		{small memory model}
+dataBank := false;			{don't save/restore data bank}
+stackSize := 0;				{default to the launcher's stack size}
+toolParms := false;			{generate tool format parameters?}
+rtl := false;				{return with a ~QUIT}
+floatCard := 0;				{use SANE}
+floatSlot := 0;				{default to slot 0}
+stringSize := 0; 			{no strings, yet}
+
+rangeCheck := false;			{don't generate range checks}
+profileFlag := false;			{don't generate profiling code}
+debugFlag := false;			{don't generate debug code}
+traceBack := false;			{don't generate traceback code}
+
+registers := cLineOptimize;		{don't do register optimizations}
+peepHole := cLineOptimize;		{not doing peephole optimization (yet)}
+npeepHole := cLineOptimize;
+commonSubexpression := cLineOptimize;	{not doing common subexpression elimination}
+loopOptimizations := cLineOptimize;	{not doing loop optimizations, yet}
+jslOptimizations := cLineOptimize;	{not doing jsl optimizations, yet}
+
+{allocate the initial p-code}
+code := pointer(Calloc(sizeof(intermediate_code)));
+code^.optype := cgWord;
+end; {CodeGenScalarInit}
+
+
+procedure DefaultSegName {s: segNameType};
+
+{ set the default segment name					}
+{								}
+{ parameters:							}
+{    s - segment name						}
+
+begin {DefaultSegName}
+currentSegment := s;
+defaultSegment := s;
+end; {DefaultSegName}
+
+
+procedure Gen0 {fop: pcodes};
+
+{ generate an implied operand instruction			}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+
+begin {Gen0}
+if codeGeneration then begin
+
+   {generate the intermediate code instruction}
+   code^.opcode := fop;
+{  if printSymbols then			{debug}
+{     WriteCode(code);			{debug}
+   DAG(code);				{generate the code}
+
+   {initialize volitile variables for next intermediate code}
+   code := pointer(Calloc(sizeof(intermediate_code)));
+   {code^.lab := nil;}
+   code^.optype := cgWord;
+   end; {if}
+end; {Gen0}
+
+
+procedure Gen1 {fop: pcodes; fp2: integer};
+
+{ generate an instruction with one numeric operand		}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp2 - operand						}
+
+begin {Gen1}
+if codeGeneration then begin
+   if fop = pc_ret then
+      code^.optype := cgVoid;
+   code^.q := fp2;
+   Gen0(fop);
+   end; {if}
+end; {Gen1}
+
+
+procedure Gen2 {fop: pcodes; fp1, fp2: integer};
+
+{ generate an instruction with two numeric operands		}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	fp2 - second operand					}
+
+label 1;
+
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {Gen2}
+if codeGeneration then begin
+   lcode := code;
+   case fop of
+
+      dc_fun,pc_lnm,pc_tl1,pc_tl2,pc_lda,dc_loc,pc_mov: begin
+	 lcode^.r := fp1;
+	 lcode^.q := fp2;
+	 end;
+
+      pc_cnn,pc_cnv:
+	 if fp1 = fp2 then
+	    goto 1
+	 else if (baseTypeEnum(fp1) in [cgReal,cgDouble,cgComp,cgExtended])
+	    and (baseTypeEnum(fp2) in [cgReal,cgDouble,cgComp,cgExtended]) then
+	    goto 1
+	 else if (baseTypeEnum(fp1) in [cgUByte,cgWord,cgUWord])
+	    and (baseTypeEnum(fp2) in [cgWord,cgUWord]) then
+	    goto 1
+	 else if (baseTypeEnum(fp1) in [cgByte,cgUByte])
+	    and (baseTypeEnum(fp2) in [cgByte,cgUByte]) then
+	    goto 1
+	 else
+	    lcode^.q := (fp1 << 4) | fp2;
+
+      otherwise:
+	 Error(cge1);
+      end; {case}
+
+   Gen0(fop);
+   end; {if}
+1:
+end; {Gen2}
+
+
+procedure Gen3 {fop: pcodes; fp1, fp2, fp3: integer};
+
+{ generate an instruction with three numeric operands		}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	fp2 - second operand					}
+{	fp3 - third operand					}
+
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {Gen3}
+if codeGeneration then begin
+   lcode := code;
+   if fop = pc_lda then begin
+      lcode^.s := fp1;
+      lcode^.p := fp2;
+      lcode^.q := fp3;
+      end {if}
+   else begin
+      lcode^.s := fp1;
+      lcode^.q := fp2;
+      lcode^.r := fp3;
+      end; {else}
+   Gen0(fop);
+   end; {if}
+end; {Gen3}
+
+
+procedure Gen0t {fop: pcodes; tp: baseTypeEnum};
+
+{ generate a typed implied operand instruction			}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	tp - base type						}
+
+begin {Gen0t}
+if codeGeneration then begin
+   code^.optype := tp;
+   Gen0(fop);
+   end; {if}
+end; {Gen0t}
+
+
+procedure Gen1t {fop: pcodes; fp1: integer; tp: baseTypeEnum};
+
+{ generate a typed instruction with two numeric operands 	}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - operand						}
+{	tp - base type						}
+
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {Gen1t}
+if codeGeneration then begin
+   lcode := code;
+   lcode^.optype := tp;
+   lcode^.q := fp1;
+   Gen0(fop);
+   end; {if}
+end; {Gen1t}
+
+
+procedure Gen2t {fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum};
+
+{ generate a typed instruction with two numeric operands 	}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	fp2 - second operand					}
+{	tp - base type						}
+
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {Gen2t}
+if codeGeneration then begin
+   lcode := code;
+   lcode^.optype := tp;
+   lcode^.r := fp1;
+   lcode^.q := fp2;
+   Gen0(fop);
+   end; {if}
+end; {Gen2t}
+
+
+procedure Gen3t {fop: pcodes; fp1, fp2, fp3: integer; tp: baseTypeEnum};
+
+{ generate a typed instruction with three numeric operands	}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	fp2 - second operand					}
+{	fp3 - third operand					}
+{	tp - base type						}
+
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {Gen3t}
+if codeGeneration then begin
+   lcode := code;
+   lcode^.optype := tp;
+   if fop in [pc_lod, pc_str] then begin
+      lcode^.r := fp1;
+      lcode^.q := fp2;
+      lcode^.p := fp3;
+      end {if}
+   else begin
+      lcode^.s := fp1;
+      lcode^.q := fp2;
+      lcode^.r := fp3;
+      end; {else if}
+   Gen0(fop);
+   end; {if}
+end; {Gen3t}
+
+
+procedure Gen4t {fop: pcodes; fp1, fp2, fp3, fp4: integer; tp: baseTypeEnum};
+
+{ generate a typed instruction with four numeric operands	}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	fp2 - second operand					}
+{	fp3 - third operand					}
+{	fp4 - fourth operand					}
+{	tp - base type						}
+
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {Gen4t}
+if codeGeneration then begin
+   lcode := code;
+   lcode^.optype := tp;
+   lcode^.r := fp1;
+   lcode^.q := fp2;
+   lcode^.p := fp3;
+   lcode^.s := fp4;
+   Gen0(fop);
+   end; {if}
+end; {Gen4t}
+
+
+procedure Gen0Name {fop: pcodes; name: pStringPtr};
+
+{ generate a p-code with a name					}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	name - named label					}
+
+begin {Gen0Name}
+if codeGeneration then begin
+   code^.lab := name;
+   Gen0(fop);
+   end; {if}
+end; {Gen0Name}
+
+
+procedure Gen1Name {fop: pcodes; fp1: integer; name: pStringPtr};
+
+{ generate a one operand p-code with a name			}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	name - named label					}
+
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {Gen1Name}
+if codeGeneration then begin
+   lcode := code;
+   lcode^.q := fp1;
+   lcode^.lab := name;
+   Gen0(fop);
+   end; {if}
+end; {Gen1Name}
+
+
+procedure Gen2Name {fop: pcodes; fp1, fp2: integer; name: pStringPtr};
+
+{ generate a two operand p-code with a name			}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	fp2 - second operand					}
+{	name - named label					}
+
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {Gen2Name}
+if codeGeneration then begin
+   lcode := code;
+   lcode^.q := fp2;
+   lcode^.r := fp1;
+   lcode^.lab := name;
+   Gen0(fop);
+   end; {if}
+end; {Gen2Name}
+
+
+procedure Gen1tName {fop: pcodes; fp1: integer; tp: baseTypeEnum;
+		     name: pStringPtr};
+
+{ generate a typed one operand p-code with a name		}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	tp - base type						}
+{	name - named label					}
+
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {Gen1tName}
+if codeGeneration then begin
+   lcode := code;
+   lcode^.q := fp1;
+   lcode^.lab := name;
+   lcode^.optype := tp;
+   Gen0(fop);
+   end; {if}
+end; {Gen1tName}
+
+
+procedure Gen2tName {fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum;
+		     name: pStringPtr};
+
+{ generate a typed two operand p-code with a name		}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	fp1 - first operand					}
+{	fp2 - second operand					}
+{	tp - base type						}
+{	name - named label					}
+
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {Gen2tName}
+if codeGeneration then begin
+   lcode := code;
+   lcode^.r := fp1;
+   lcode^.q := fp2;
+   lcode^.lab := name;
+   lcode^.optype := tp;
+   Gen0(fop);
+   end; {if}
+end; {Gen2tName}
+
+
+procedure Gen1L1t {fop: pcodes; fp1: integer; lval: longint; tp: baseTypeEnum};
+
+{ generate an instruction with one integer and one longint	}
+{                                                               }
+{ parameters:                                                   }
+{	fop - operation code					}
+{	fp1 - integer parameter					}
+{       lval - longint parameter				}
+{	tp - base type						}
+                                                                       
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {Gen1L1t}
+if codeGeneration then begin
+   lcode := code;
+   lcode^.optype := tp;
+   lcode^.q := fp1;
+   lcode^.lval := lval;
+   Gen0(fop);
+   end; {if}
+end; {Gen1L1t}
+
+
+procedure GenL1t {fop: pcodes; lval: longint; tp: baseTypeEnum};
+
+{ generate an instruction that uses a longint			}
+{                                                               }
+{ parameters:                                                   }
+{	fop - operation code					}
+{       lval - longint parameter				}
+{	tp - base type						}
+                                                                       
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {GenL1t}
+if codeGeneration then begin
+   lcode := code;
+   lcode^.optype := tp;
+   lcode^.lval := lval;
+   Gen0(fop);
+   end; {if}
+end; {GenL1t}
+
+
+procedure GenL2t {fop: pcodes; lval, lval2: longint; tp: baseTypeEnum};
+
+{ generate an instruction that uses a longint and an int        }
+{                                                               }
+{ parameters:                                                   }
+{	fop - operation code					}
+{       lval, lval2 - longint parameters			}
+{	tp - base type						}
+                                                                       
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {GenL2t}
+if codeGeneration then begin
+   lcode := code;
+   lcode^.optype := tp;
+   lcode^.lval := lval;
+   lcode^.lval2 := lval2;
+   Gen0(fop);
+   end; {if}
+end; {GenL2t}
+
+
+procedure GenLdcLong {lval: longint};
+
+{ load a long constant						}
+{								}
+{ parameters:							}
+{	lval - value to load					}
+
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {GenLdcLong}
+if codeGeneration then begin
+   lcode := code;
+   if lval >= 0 then
+     lcode^.optype := cgULong
+   else
+     lcode^.optype := cgLong;
+   lcode^.lval := lval;
+   Gen0(pc_ldc);
+   end; {if}
+end; {GenLdcLong}
+
+
+procedure GenLdcReal {rval: double};
+
+{ load a real constant						}
+{								}
+{ parameters:							}
+{	rval - value to load					}
+
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {GenLdcReal}
+if codeGeneration then begin
+   lcode := code;
+   lcode^.optype := cgReal;
+   lcode^.rval := rval;
+   Gen0(pc_ldc);
+   end; {if}
+end; {GenLdcReal}
+
+
+procedure GenLdcSet {cval: constantRec};
+
+{ load a set constant						}
+{								}
+{ parameters:							}
+{	cval - value to load					}
+
+var
+   i, k: unsigned;			{loop/index variables}
+   lcode: icptr; 			{local copy of code}
+
+begin {GenLdcSet}
+if codeGeneration then begin
+   lcode := code;
+   lcode^.optype := cgSet;
+   i := cval.pmax div 8 + 1;
+   lcode^.setp := pointer(Calloc(3+i));
+   with lcode^.setp^ do begin
+      smax := i;
+      for k := 1 to i do
+         sval[k] := cval.ch[k-1];
+      end; {with}
+   Gen0(pc_ldc);
+   end; {if}
+end; {GenLdcSet}
+
+
+procedure GenPS {fop: pcodes; str: pStringPtr};
+
+{ generate an instruction that uses a p-string operand		}
+{								}
+{ parameters:							}
+{	fop - operation code					}
+{	str - pointer to string					}
+
+var
+   lcode: icptr; 			{local copy of code}
+
+begin {GenPS}
+if codeGeneration then begin
+   lcode := code;
+   lcode^.q := length(str^);
+   lcode^.optype := cgString;
+   lcode^.str := str;
+   Gen0(fop);
+   end; {if}
+end; {GenPS}
+
+
+procedure NextSegName {s: segNameType};
+
+{ set the segment name for the next segment created		}
+{								}
+{ parameters:							}
+{    s - segment name						}
+
+begin {NextSegmentName}
+currentSegment := s;
+end; {NextSegmentName}
+
+end.
+
+{$append 'cgi.asm'}
diff --git a/count b/count
old mode 100755
new mode 100644
index b705717..19fa98e
--- a/count
+++ b/count
@@ -1 +1,32 @@
-echo Pascal:

set list cg.pas stage3.pas stage3.save stage3.gentree
set list {list} cg.writecode native.pas
set list {list} pascal.pas pascal.exp pascal.body
set list {list} symbols.pas cgi.pas call.pas

wc -l {list}

echo Assembly:

set list sc.asm sc.insymbol sc.options ob.asm symbols.asm

wc -l {list}

echo Special Macros:

set list sc.smac sym.smac

wc -l {list}

echo Link and Make files:

set list lk backup make msym mcg count msc mcall mpascal

wc -l {list}

echo Macros:

set list sc.macros ob.macros sym.macros

wc -l {list}
\ No newline at end of file
+echo Pascal:
+
+set list cg.pas stage3.pas stage3.save stage3.gentree
+set list {list} cg.writecode native.pas
+set list {list} pascal.pas pascal.exp pascal.body
+set list {list} symbols.pas cgi.pas call.pas
+
+wc -l {list}
+
+echo Assembly:
+
+set list sc.asm sc.insymbol sc.options ob.asm symbols.asm
+
+wc -l {list}
+
+echo Special Macros:
+
+set list sc.smac sym.smac
+
+wc -l {list}
+
+echo Link and Make files:
+
+set list lk backup make msym mcg count msc mcall mpascal
+
+wc -l {list}
+
+echo Macros:
+
+set list sc.macros ob.macros sym.macros
+
+wc -l {list}
diff --git a/dag.asm b/dag.asm
old mode 100755
new mode 100644
index ebc8a08..9b045d8
--- a/dag.asm
+++ b/dag.asm
@@ -1 +1,238 @@
-	mcopy dag.macros
****************************************************************
*
*  function udiv(x,y: longint): longint;
*
*  Inputs:
*        num1 - numerator
*        num2 - denominator
*
*  Outputs:
*        ans - result
*
****************************************************************
*
udiv     start
ans      equ   0                        answer
rem      equ   4                        remainder

         subroutine (4:num1,4:num2),8
;
;  Initialize
;
         stz   rem                      rem = 0
         stz   rem+2
         move4 num1,ans                 ans = num1
         lda   num2                     check for division by zero
         ora   num2+2
         beq   dv9

         lda   num2+2                   do 16 bit divides separately
         ora   ans+2
         beq   dv5
;
;  32 bit divide
;
         ldy   #32                      32 bits to go
dv3      asl   ans                      roll up the next number
         rol   ans+2
         rol   ans+4
         rol   ans+6
         sec                            subtract for this digit
         lda   ans+4
         sbc   num1
         tax
         lda   ans+6
         sbc   num2+2
         bcc   dv4                      branch if minus
         stx   ans+4                    turn the bit on
         sta   ans+6
         inc   ans
dv4      dey                            next bit
         bne   dv3
         bra   dv9                      go do the sign
;
;  16 bit divide
;
dv5      lda   #0                       initialize the remainder
         ldy   #16                      16 bits to go
dv6      asl   ans                      roll up the next number
         rol   a
         sec                            subtract the digit
         sbc   num2
         bcs   dv7
         adc   num2                     digit is 0
         dey
         bne   dv6
         bra   dv8
dv7      inc   ans                      digit is 1
         dey
         bne   dv6

dv8      sta   ans+4                    save the remainder
;
;  Return the result
;
dv9      return 4:ans                   move answer
         end

****************************************************************
*
*  function umod(x,y: longint): longint;
*
*  Inputs:
*        num1 - numerator
*        num2 - denominator
*
*  Outputs:
*        ans+4 - result
*
****************************************************************
*
umod     start
ans      equ   0                        answer
rem      equ   4                        remainder

         subroutine (4:num1,4:num2),8
;
;  Initialize
;
         stz   rem                      rem = 0
         stz   rem+2
         move4 num1,ans                 ans = num1
         lda   num2                     check for division by zero
         ora   num2+2
         beq   dv9

         lda   num2+2                   do 16 bit divides separately
         ora   ans+2
         beq   dv5
;
;  32 bit divide
;
         ldy   #32                      32 bits to go
dv3      asl   ans                      roll up the next number
         rol   ans+2
         rol   ans+4
         rol   ans+6
         sec                            subtract for this digit
         lda   ans+4
         sbc   num1
         tax
         lda   ans+6
         sbc   num2+2
         bcc   dv4                      branch if minus
         stx   ans+4                    turn the bit on
         sta   ans+6
         inc   ans
dv4      dey                            next bit
         bne   dv3
         bra   dv9                      go do the sign
;
;  16 bit divide
;
dv5      lda   #0                       initialize the remainder
         ldy   #16                      16 bits to go
dv6      asl   ans                      roll up the next number
         rol   a
         sec                            subtract the digit
         sbc   num2
         bcs   dv7
         adc   num2                     digit is 0
         dey
         bne   dv6
         bra   dv8
dv7      inc   ans                      digit is 1
         dey
         bne   dv6

dv8      sta   ans+4                    save the remainder
;
;  Return the result
;
dv9      return 4:ans+4                 move answer
         end

****************************************************************
*
*  function umul(x,y: longint): longint;
*
*  Inputs:
*        num2,num1 - operands
*
*  Outputs:
*        ans - result
*
****************************************************************
*
umul     start
ans      equ   0                        answer

         subroutine (4:num1,4:num2),8
;
;  Initialize the sign and split on precision.
;
         stz   ans+4                    set up the multiplier
         stz   ans+6
         lda   num1
         sta   ans
         lda   num1+2
         sta   ans+2
         beq   ml3                      branch if the multiplier is 16 bit
;
;  Do a 32 bit by 32 bit multiply.
;
         ldy   #32                      32 bit multiply
         jsr   ml1
         brl   ml7

ml1      lda   ans                      SYSS1*SYSS1+2+SYSS1+2 -> SYSS1,SYSS1+2
         lsr   a
         bcc   ml2
         clc                            add multiplicand to the partial product
         lda   ans+4
         adc   num2
         sta   ans+4
         lda   ans+6
         adc   num2+2
         sta   ans+6
ml2      ror   ans+6                    shift the interem result
         ror   ans+4
         ror   ans+2
         ror   ans
         dey                            loop til done
         bne   ml1
         rts
;
;  Do and 16 bit by 32 bit multiply.
;
ml3      lda   num2+2                   branch if 16x16 is possible
         beq   ml4

         ldy   #16                      set up for 16 bits
         jsr   ml1                      do the multiply
         lda   ans+2                    move the answer
         sta   ans
         lda   ans+4
         sta   ans+2
         bra   ml7
;
;  Do a 16 bit by 16 bit multiply.
;
ml4      ldy   #16                      set the 16 bit counter
         ldx   ans                      move the low word
         stx   ans+2
ml5      lsr   ans+2                    test the bit
         bcc   ml6                      branch if the bit is off
         clc
         adc   num2
ml6      ror   a                        shift the answer
         ror   ans
         dey                            loop
         bne   ml5
         sta   ans+2                    save the high word
;
;  Return the result.
;
ml7      return 4:ans                   fix the stack
         end
\ No newline at end of file
+	mcopy dag.macros
+****************************************************************
+*
+*  function udiv(x,y: longint): longint;
+*
+*  Inputs:
+*        num1 - numerator
+*        num2 - denominator
+*
+*  Outputs:
+*        ans - result
+*
+****************************************************************
+*
+udiv     start
+ans      equ   0                        answer
+rem      equ   4                        remainder
+
+         subroutine (4:num1,4:num2),8
+;
+;  Initialize
+;
+         stz   rem                      rem = 0
+         stz   rem+2
+         move4 num1,ans                 ans = num1
+         lda   num2                     check for division by zero
+         ora   num2+2
+         beq   dv9
+
+         lda   num2+2                   do 16 bit divides separately
+         ora   ans+2
+         beq   dv5
+;
+;  32 bit divide
+;
+         ldy   #32                      32 bits to go
+dv3      asl   ans                      roll up the next number
+         rol   ans+2
+         rol   ans+4
+         rol   ans+6
+         sec                            subtract for this digit
+         lda   ans+4
+         sbc   num1
+         tax
+         lda   ans+6
+         sbc   num2+2
+         bcc   dv4                      branch if minus
+         stx   ans+4                    turn the bit on
+         sta   ans+6
+         inc   ans
+dv4      dey                            next bit
+         bne   dv3
+         bra   dv9                      go do the sign
+;
+;  16 bit divide
+;
+dv5      lda   #0                       initialize the remainder
+         ldy   #16                      16 bits to go
+dv6      asl   ans                      roll up the next number
+         rol   a
+         sec                            subtract the digit
+         sbc   num2
+         bcs   dv7
+         adc   num2                     digit is 0
+         dey
+         bne   dv6
+         bra   dv8
+dv7      inc   ans                      digit is 1
+         dey
+         bne   dv6
+
+dv8      sta   ans+4                    save the remainder
+;
+;  Return the result
+;
+dv9      return 4:ans                   move answer
+         end
+
+****************************************************************
+*
+*  function umod(x,y: longint): longint;
+*
+*  Inputs:
+*        num1 - numerator
+*        num2 - denominator
+*
+*  Outputs:
+*        ans+4 - result
+*
+****************************************************************
+*
+umod     start
+ans      equ   0                        answer
+rem      equ   4                        remainder
+
+         subroutine (4:num1,4:num2),8
+;
+;  Initialize
+;
+         stz   rem                      rem = 0
+         stz   rem+2
+         move4 num1,ans                 ans = num1
+         lda   num2                     check for division by zero
+         ora   num2+2
+         beq   dv9
+
+         lda   num2+2                   do 16 bit divides separately
+         ora   ans+2
+         beq   dv5
+;
+;  32 bit divide
+;
+         ldy   #32                      32 bits to go
+dv3      asl   ans                      roll up the next number
+         rol   ans+2
+         rol   ans+4
+         rol   ans+6
+         sec                            subtract for this digit
+         lda   ans+4
+         sbc   num1
+         tax
+         lda   ans+6
+         sbc   num2+2
+         bcc   dv4                      branch if minus
+         stx   ans+4                    turn the bit on
+         sta   ans+6
+         inc   ans
+dv4      dey                            next bit
+         bne   dv3
+         bra   dv9                      go do the sign
+;
+;  16 bit divide
+;
+dv5      lda   #0                       initialize the remainder
+         ldy   #16                      16 bits to go
+dv6      asl   ans                      roll up the next number
+         rol   a
+         sec                            subtract the digit
+         sbc   num2
+         bcs   dv7
+         adc   num2                     digit is 0
+         dey
+         bne   dv6
+         bra   dv8
+dv7      inc   ans                      digit is 1
+         dey
+         bne   dv6
+
+dv8      sta   ans+4                    save the remainder
+;
+;  Return the result
+;
+dv9      return 4:ans+4                 move answer
+         end
+
+****************************************************************
+*
+*  function umul(x,y: longint): longint;
+*
+*  Inputs:
+*        num2,num1 - operands
+*
+*  Outputs:
+*        ans - result
+*
+****************************************************************
+*
+umul     start
+ans      equ   0                        answer
+
+         subroutine (4:num1,4:num2),8
+;
+;  Initialize the sign and split on precision.
+;
+         stz   ans+4                    set up the multiplier
+         stz   ans+6
+         lda   num1
+         sta   ans
+         lda   num1+2
+         sta   ans+2
+         beq   ml3                      branch if the multiplier is 16 bit
+;
+;  Do a 32 bit by 32 bit multiply.
+;
+         ldy   #32                      32 bit multiply
+         jsr   ml1
+         brl   ml7
+
+ml1      lda   ans                      SYSS1*SYSS1+2+SYSS1+2 -> SYSS1,SYSS1+2
+         lsr   a
+         bcc   ml2
+         clc                            add multiplicand to the partial product
+         lda   ans+4
+         adc   num2
+         sta   ans+4
+         lda   ans+6
+         adc   num2+2
+         sta   ans+6
+ml2      ror   ans+6                    shift the interem result
+         ror   ans+4
+         ror   ans+2
+         ror   ans
+         dey                            loop til done
+         bne   ml1
+         rts
+;
+;  Do and 16 bit by 32 bit multiply.
+;
+ml3      lda   num2+2                   branch if 16x16 is possible
+         beq   ml4
+
+         ldy   #16                      set up for 16 bits
+         jsr   ml1                      do the multiply
+         lda   ans+2                    move the answer
+         sta   ans
+         lda   ans+4
+         sta   ans+2
+         bra   ml7
+;
+;  Do a 16 bit by 16 bit multiply.
+;
+ml4      ldy   #16                      set the 16 bit counter
+         ldx   ans                      move the low word
+         stx   ans+2
+ml5      lsr   ans+2                    test the bit
+         bcc   ml6                      branch if the bit is off
+         clc
+         adc   num2
+ml6      ror   a                        shift the answer
+         ror   ans
+         dey                            loop
+         bne   ml5
+         sta   ans+2                    save the high word
+;
+;  Return the result.
+;
+ml7      return 4:ans                   fix the stack
+         end
diff --git a/dag.macros b/dag.macros
old mode 100755
new mode 100644
index c34e1e5..aae326f
--- a/dag.macros
+++ b/dag.macros
@@ -1 +1,154 @@
- MACRO
&lab subroutine &parms,&work
&lab anop
 aif c:&work,.a
 lclc &work
&work setc 0
.a
 gbla &totallen
 gbla &worklen
&worklen seta &work
&totallen seta 0
 aif c:&parms=0,.e
 lclc &len
 lclc &p
 lcla &i
&i seta c:&parms
.b
&p setc &parms(&i)
&len amid &p,2,1
 aif "&len"=":",.c
&len amid &p,1,2
&p amid &p,4,l:&p-3
 ago .d
.c
&len amid &p,1,1
&p amid &p,3,l:&p-2
.d
&p equ &totallen+3+&work
&totallen seta &totallen+&len
&i seta &i-1
 aif &i,^b
.e
 tsc
 sec
 sbc #&work
 tcs
 inc a
 phd
 tcd
 mend
 MACRO
&lab return &r
&lab anop
 lclc &len
 aif c:&r,.a
 lclc &r
&r setc 0
&len setc 0
 ago .h
.a
&len amid &r,2,1
 aif "&len"=":",.b
&len amid &r,1,2
&r amid &r,4,l:&r-3
 ago .c
.b
&len amid &r,1,1
&r amid &r,3,l:&r-2
.c
 aif &len<>2,.d
 ldy &r
 ago .h
.d
 aif &len<>4,.e
 ldx &r+2
 ldy &r
 ago .h
.e
 aif &len<>10,.g
 aif &totallen=0,.f
 lda &worklen+1
 sta &worklen+&totallen+1
 lda &worklen
 sta &worklen+&totallen
.f
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 phb
 plx
 ply
 lda &r+8
 pha
 lda &r+6
 pha
 lda &r+4
 pha
 lda &r+2
 pha
 lda &r
 pha
 phy
 phx
 plb
 rtl
 mexit
.g
 mnote 'Not a valid return length',16
 mexit
.h
 aif &totallen=0,.i
 lda &worklen+1
 sta &worklen+&totallen+1
 lda &worklen
 sta &worklen+&totallen
.i
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 aif &len=0,.j
 tya
.j
 rtl
 mend
 MACRO
&LAB MOVE4 &F,&T
&LAB ~SETM
 LDA 2+&F
 STA 2+&T
 LDA &F
 STA &T
 ~RESTM
 MEND
 MACRO
&LAB ~SETM
&LAB ANOP
 AIF C:&~LA,.B
 GBLB &~LA
 GBLB &~LI
.B
&~LA SETB S:LONGA
&~LI SETB S:LONGI
 AIF S:LONGA.AND.S:LONGI,.A
 REP #32*(.NOT.&~LA)+16*(.NOT.&~LI)
 LONGA ON
 LONGI ON
.A
 MEND
 MACRO
&LAB ~RESTM
&LAB ANOP
 AIF (&~LA+&~LI)=2,.I
 SEP #32*(.NOT.&~LA)+16*(.NOT.&~LI)
 AIF &~LA,.H
 LONGA OFF
.H
 AIF &~LI,.I
 LONGI OFF
.I
 MEND
\ No newline at end of file
+ MACRO
+&lab subroutine &parms,&work
+&lab anop
+ aif c:&work,.a
+ lclc &work
+&work setc 0
+.a
+ gbla &totallen
+ gbla &worklen
+&worklen seta &work
+&totallen seta 0
+ aif c:&parms=0,.e
+ lclc &len
+ lclc &p
+ lcla &i
+&i seta c:&parms
+.b
+&p setc &parms(&i)
+&len amid &p,2,1
+ aif "&len"=":",.c
+&len amid &p,1,2
+&p amid &p,4,l:&p-3
+ ago .d
+.c
+&len amid &p,1,1
+&p amid &p,3,l:&p-2
+.d
+&p equ &totallen+3+&work
+&totallen seta &totallen+&len
+&i seta &i-1
+ aif &i,^b
+.e
+ tsc
+ sec
+ sbc #&work
+ tcs
+ inc a
+ phd
+ tcd
+ mend
+ MACRO
+&lab return &r
+&lab anop
+ lclc &len
+ aif c:&r,.a
+ lclc &r
+&r setc 0
+&len setc 0
+ ago .h
+.a
+&len amid &r,2,1
+ aif "&len"=":",.b
+&len amid &r,1,2
+&r amid &r,4,l:&r-3
+ ago .c
+.b
+&len amid &r,1,1
+&r amid &r,3,l:&r-2
+.c
+ aif &len<>2,.d
+ ldy &r
+ ago .h
+.d
+ aif &len<>4,.e
+ ldx &r+2
+ ldy &r
+ ago .h
+.e
+ aif &len<>10,.g
+ aif &totallen=0,.f
+ lda &worklen+1
+ sta &worklen+&totallen+1
+ lda &worklen
+ sta &worklen+&totallen
+.f
+ pld
+ tsc
+ clc
+ adc #&worklen+&totallen
+ tcs
+ phb
+ plx
+ ply
+ lda &r+8
+ pha
+ lda &r+6
+ pha
+ lda &r+4
+ pha
+ lda &r+2
+ pha
+ lda &r
+ pha
+ phy
+ phx
+ plb
+ rtl
+ mexit
+.g
+ mnote 'Not a valid return length',16
+ mexit
+.h
+ aif &totallen=0,.i
+ lda &worklen+1
+ sta &worklen+&totallen+1
+ lda &worklen
+ sta &worklen+&totallen
+.i
+ pld
+ tsc
+ clc
+ adc #&worklen+&totallen
+ tcs
+ aif &len=0,.j
+ tya
+.j
+ rtl
+ mend
+ MACRO
+&LAB MOVE4 &F,&T
+&LAB ~SETM
+ LDA 2+&F
+ STA 2+&T
+ LDA &F
+ STA &T
+ ~RESTM
+ MEND
+ MACRO
+&LAB ~SETM
+&LAB ANOP
+ AIF C:&~LA,.B
+ GBLB &~LA
+ GBLB &~LI
+.B
+&~LA SETB S:LONGA
+&~LI SETB S:LONGI
+ AIF S:LONGA.AND.S:LONGI,.A
+ REP #32*(.NOT.&~LA)+16*(.NOT.&~LI)
+ LONGA ON
+ LONGI ON
+.A
+ MEND
+ MACRO
+&LAB ~RESTM
+&LAB ANOP
+ AIF (&~LA+&~LI)=2,.I
+ SEP #32*(.NOT.&~LA)+16*(.NOT.&~LI)
+ AIF &~LA,.H
+ LONGA OFF
+.H
+ AIF &~LI,.I
+ LONGI OFF
+.I
+ MEND
diff --git a/dag.pas b/dag.pas
old mode 100755
new mode 100644
index c883d82..0c75f84
--- a/dag.pas
+++ b/dag.pas
@@ -1 +1,5466 @@
-{$optimize 15}
{---------------------------------------------------------------}
{                                                               }
{  DAG Creation							}
{                                                               }
{  Places intermediate codes into DAGs and trees.		}
{                                                               }
{---------------------------------------------------------------}

unit DAG;

interface

{$segment 'cg'}

{$LibPrefix '0/obj/'}

uses PCommon, CGI, CGC, Gen;

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

procedure DAG (code: icptr);

{ place an op code in a DAG or tree				}
{                                                               }
{ parameters:                                                   }
{       code - opcode						}

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

implementation

const
   peepSpinRate = 20;			{PeepHoleOptimize spin rate}

var
   c_ind: iclist;			{vars that can be changed by indirect stores}
   maxLoc: integer;			{max local label number used by compiler}
   memberOp: icptr;			{operation found by Member}
   optimizations: array[pcodes] of integer; {starting indexes into peeptable}
   peepSpin: 0..peepSpinRate;		{spinner delay for PeepHoleOptimize}
   peepTablesInitialized: boolean;	{have the peephole tables been initialized?}
   prsFound: boolean;			{are there any pc_prs opcodes?}
   rescan: boolean;			{redo the optimization pass?}

{-- External unsigned math routines ----------------------------}

function udiv (x,y: longint): longint; extern;

function umod (x,y: longint): longint; extern;

function umul (x,y: longint): longint; extern;

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

function SetsEqual (s1, s2: setPtr): boolean;

{ See if two sets are equal					}
{								}
{ parameters:							}
{    s1, s2 - sets to compare					}
{								}
{ Returns: True if the sets are equal, else false		}

label 1;

var
   i: unsigned;				{loop/index variable}

begin {SetsEqual}
SetsEqual := false;
if s1^.smax = s2^.smax then begin
   for i := 1 to s1^.smax do
      if s1^.sval[i] <> s2^.sval[i] then
         goto 1;
   SetsEqual := true;
   end; {if}
1: ;
end; {SetsEqual}


function CodesMatch (op1, op2: icptr; exact: boolean): boolean;

{ Check to see if the trees op1 and op2 are equivalent		}
{								}
{ parameters:							}
{    op1, op2 - trees to check					}
{    exact - is an exact of operands match required?		}
{								}
{ Returns: True if trees are equivalent, else false.		}


   function OpsEqual (op1, op2: icptr): boolean;

   { See if the operands are equal				}
   {								}
   { parameters:						}
   {    op1, op2 - operations to check				}
   {								}
   { Returns: True if the operands are equivalent, else		}
   {    false.							}

   var
      result: boolean;			{temp result}

   begin {OpsEqual}
   result := false;
   case op1^.opcode of
      pc_cup, pc_cum, pc_cui, pc_csp, pc_tl1, pc_tl2, pc_vct, pc_pds, pc_bno:
         {this rule prevents optimizations from removing sensitive operations}
         ;

      pc_adi, pc_adl, pc_adr, pc_and, pc_lnd, pc_bnd, pc_bal, pc_bor,
      pc_blr, pc_bxr, pc_blx, pc_equ, pc_neq, pc_ior, pc_lor, pc_mpi,
      pc_umi, pc_mpl, pc_uml, pc_mpr, pc_int, pc_uni: begin
         if op1^.left = op2^.left then
            if op1^.right = op2^.right then
               result := true;
         if not result then
            if op1^.left = op2^.right then
               if op1^.right = op2^.left then
                  result := true;
         if not result then
            if not exact then
               if CodesMatch(op1^.left, op2^.left, false) then
        	  if CodesMatch(op1^.right, op2^.right, false) then
                     result := true;
         if not result then
            if not exact then
               if CodesMatch(op1^.left, op2^.right, false) then
        	  if CodesMatch(op1^.right, op2^.left, false) then
                     result := true;
         end;

      otherwise: begin
         if op1^.left = op2^.left then
            if op1^.right = op2^.right then
               result := true;
         if not result then
            if not exact then
               if CodesMatch(op1^.left, op2^.left, false) then
        	  if CodesMatch(op1^.right, op2^.right, false) then
                     result := true;
         end;                 
      end; {case}
   OpsEqual := result;
   end; {OpsEqual}


   function LabsEqual (l1, l2: pStringPtr): boolean;

   { See if the labels are equal				}
   {								}
   { parameters:						}
   {    l1, l2 - labels to check				}
   {								}
   { Returns: True if the labels are equal, else false		}

   begin {LabsEqual}
   if (l1 = nil) and (l2 = nil) then
      LabsEqual := true
   else if (l1 <> nil) and (l2 <> nil) then
      LabsEqual := l1^ = l2^
   else
      LabsEqual := false;
   end; {LabsEqual}


begin {CodesMatch}
CodesMatch := false;
if (op1 = nil) and (op2 = nil) then
   CodesMatch := true
else if (op1 <> nil) and (op2 <> nil) then
   if op1^.opcode = op2^.opcode then
      if op1^.q = op2^.q then
	 if op1^.r = op2^.r then
            if op1^.s = op2^.s then
               if LabsEqual(op1^.lab, op2^.lab) then
        	  if OpsEqual(op1, op2) then
                     if op1^.optype = op2^.optype then
                	case op1^.optype of
                           cgByte, cgUByte, cgWord, cgUWord:
                              if op1^.opnd = op2^.opnd then
                        	 if op1^.llab = op2^.llab then
                                    if op1^.slab = op2^.slab then
                                       CodesMatch := true;
                           cgLong, cgULong:
                              if op1^.lval = op2^.lval then
                        	 CodesMatch := true;
                           cgReal, cgDouble, cgComp, cgExtended:
                              if op1^.rval = op2^.rval then
                        	 CodesMatch := true;
                           cgString:
                              CodesMatch := op1^.str^ = op2^.str^;
                           cgSet:
                              CodesMatch := SetsEqual(op1^.setp, op2^.setp);
                           cgVoid:
                              CodesMatch := true;
                           end; {case}
end; {CodesMatch}

{- Peephole Optimization ---------------------------------------}

function Base (val: longint): integer;

{ Assuming val is a power of 2, find ln(val) base 2		}
{								}
{ parameters:							}
{    val - value for which to find the base			}
{								}
{ Returns: ln(val), base 2					}

var
   i: integer;                    	{base counter}

begin {Base}
i := 0;
while not odd(val) do begin
   val := val >> 1;
   i := i+1;
   end; {while}
Base := i;
end; {Base}


procedure BinOps (var op1, op2: icptr);

{ Make sure the operands are of the same type			}
{								}
{ parameters:							}
{    op1, op2: two pc_ldc operands				}

var
   opt1, opt2: baseTypeEnum;		{temp operand types}

begin {BinOps}
opt1 := op1^.optype;
opt2 := op2^.optype;
if opt1 = cgByte then begin
   op1^.optype := cgWord;
   opt1 := cgWord;
   end {if}
else if opt1 = cgUByte then begin
   op1^.optype := cgUWord;
   opt1 := cgUWord;
   end {else if}
else if opt1 in [cgReal, cgDouble, cgComp] then begin
   op1^.optype := cgExtended;
   opt1 := cgExtended;
   end; {else if}
if opt2 = cgByte then begin
   op2^.optype := cgWord;
   opt2 := cgWord;
   end {if}
else if opt2 = cgUByte then begin
   op2^.optype := cgUWord;
   opt2 := cgUWord;
   end {else if}
else if opt2 in [cgReal, cgDouble, cgComp] then begin
   op2^.optype := cgExtended;
   opt2 := cgExtended;
   end; {else if}

if opt1 <> opt2 then begin
   case opt1 of
      cgWord:
         case opt2 of
            cgUWord:
               op1^.optype := cgUWord;
            cgLong, cgULong: begin
               op1^.lval := op1^.q;
               op1^.optype := opt2;
               end;
            cgExtended: begin
               op1^.rval := op1^.q;
               op1^.optype := cgExtended;
               end;
            otherwise: ;
            end; {case}
      cgUWord:
         case opt2 of
            cgWord:
               op2^.optype := cgUWord;
            cgLong, cgULong: begin
               op1^.lval := ord4(op1^.q) & $0000FFFF;
               op1^.optype := opt2;
               end;
            cgExtended: begin
               op1^.rval := ord4(op1^.q) & $0000FFFF;
               op1^.optype := cgExtended;
               end;
            otherwise: ;     
            end; {case}
      cgLong:
         case opt2 of
            cgWord: begin
               op2^.lval := op2^.q;
               op2^.optype := cgLong;
               end;
            cgUWord: begin
               op2^.lval := ord4(op2^.q) & $0000FFFF;
               op2^.optype := cgLong;
               end;
            cgULong:
               op1^.optype := cgULong;
            cgExtended: begin
               op1^.rval := op1^.lval;
               op1^.optype := cgExtended;
               end;
            otherwise: ;
            end; {case}
      cgULong:
         case opt2 of
            cgWord: begin
               op2^.lval := op2^.q;
               op2^.optype := cgLong;
               end;
            cgUWord: begin
               op2^.lval := ord4(op2^.q) & $0000FFFF;
               op2^.optype := cgLong;
               end;
            cgLong:
               op2^.optype := cgULong;
            cgExtended: begin
               op1^.rval := op1^.lval;
               if op1^.rval < 0.0 then
                  op1^.rval := 4294967296.0 + op1^.rval;
               op1^.optype := cgExtended;
               end;
            otherwise: ;
            end; {case}
      cgExtended: begin
         case opt2 of
            cgWord:
               op2^.rval := op2^.q;
            cgUWord:
               op2^.rval := ord4(op2^.q) & $0000FFFF;
            cgLong:
               op2^.rval := op2^.lval;
            cgULong: begin
               op2^.rval := op2^.lval;
               if op2^.rval < 0.0 then
                  op2^.rval := 4294967296.0 + op2^.rval;
               end;
            otherwise: ;
            end; {case}
         op2^.optype := cgExtended;
         end;
      otherwise: ;
      end; {case}
   end; {if}
end; {BinOps}


procedure CheckLabels;

{ remove unused dc_lab labels					}

type
   nameTypePtr = ^nameType;		{named label list element}
   nameType = record
      next: nameTypePtr;
      lab: pStringPtr;
      end;
					{used label array}
   usedArray = packed array[0..maxLabel] of boolean;

var
   lop: icptr;				{predecessor of op}
   op: icptr;				{used to trace the opcode list}
   usedLabels: ^usedArray;		{used numeric label array}
   usedNames: nameTypePtr;		{used named labels list}


   procedure BuildLabels;

   { build the used label array and list			}

   var
      lab: 0..maxLabel;			{loop/index variable}
      op: icptr;			{used to trace the opcode list}


      procedure RecordName (lab: pStringPtr);

      { record a named label					}
      {								}
      { parameters:						}
      {    lab - label name to record				}

      var
         found: boolean;		{was the name in the list already?}
         np: nameTypePtr;		{name pointer}

      begin {RecordName}
      found := false;
      np := usedNames;
      while np <> nil do
         if np^.lab^ = lab^ then begin
            np := nil;
            found := true;
            end {if}
         else
            np := np^.next;
      if not found then begin
         new(np);
         np^.next := usedNames;
         usedNames := np;
         np^.lab := lab;
         end; {if}
      end; {RecordName}


      procedure CheckCup (op: icptr);

      { Check for labels in procedure calls			}
      {								}
      { parameters:						}
      {    op - label to check					}

      begin {CheckCup}
      if op^.opcode = pc_cup then
         if op^.lab = nil then begin
            if op^.r <= maxLabel then
               usedLabels^[op^.r] := true;
            end {if}
         else
            RecordName(op^.lab);
      if op^.left <> nil then
         CheckCup(op^.left);
      if op^.right <> nil then
         CheckCup(op^.right);
      end; {CheckCup}


   begin {BuildLabels}
   new(usedLabels);			{no numbered labels}
   for lab := 0 to maxLabel do
      usedLabels^[lab] := false;
   usedNames := nil;			{no named labels}

   op := DAGhead;
   while op <> nil do begin
      if op^.opcode in [pc_add, pc_fjp, pc_tjp, pc_ujp] then
         if op^.lab = nil then begin
            if op^.q <= maxLabel then
               usedLabels^[op^.q] := true;
            end {if}
         else
            RecordName(op^.lab);
      CheckCup(op);
      op := op^.next;
      end; {while}
   end; {BuildLabels}


   procedure DisposeLabels;

   { dispose of the dynamic memory allocated by BuildLabels	}

   var
      p1, p2: nameTypePtr;		{work pointers}

   begin {DisposeLabels}
   dispose(usedLabels);
   p1 := usedNames;
   while p1 <> nil do begin
      p2 := p1;
      p1 := p2^.next;
      dispose(p2);
      end; {while}
   end; {DisposeLabels}


   function Used (q: integer; lab: pStringPtr): boolean;

   { see if a label is used					}
   {								}
   { parameters:						}
   {    q - label number to check				}
   {    lab - named label to check				}
   {								}
   { Returns: True if the label is used, else false.		}

   var
      np: nameTypePtr;			{used to trace usedNames list}

   begin {Used}
   if lab = nil then 
      if q <= maxLabel then
         Used := usedLabels^[q]
      else
         Used := true
   else begin
      np := usedNames;
      Used := false;
      while np <> nil do
         if np^.lab^ = lab^ then begin
            np := nil;
            Used := true;
            end {if}
         else
            np := np^.next;
      end; {else}
   end; {Used}


begin {CheckLabels}
BuildLabels;				{build a list of used labels}

op := DAGhead;				{get rid of unused labels}
while op^.next <> nil do begin
   lop := op;
   op := op^.next;
   if op^.opcode = dc_lab then begin
      Spin;
      if op^.lab = nil then
	 if not Used(op^.q, op^.lab) then begin
            lop^.next := op^.next;
            op := lop;
            rescan := true;
            end; {if}
      end; {if}
   end; {while}

DisposeLabels;				{get rid of label lists}
end; {CheckLabels}


procedure RemoveDeadCode (op: icptr);

{ remove dead code following an unconditional branch		}
{								}
{ parameters:							}
{    op - unconditional branch opcode				}

begin {RemoveDeadCode}
while not (op^.next^.opcode in [dc_lab, dc_enp, dc_cns, dc_glb,
   dc_dst, dc_str, dc_pin, pc_ent, dc_loc, dc_prm, dc_fun, dc_sym]) do begin
   op^.next := op^.next^.next;
   rescan := true;
   end; {while}
end; {RemoveDeadCode}


function NoFunctions (op: icptr): boolean;

{ are there any function calls?					}
{								}
{ parameters:							}
{    op - operation tree to search				}
{								}
{ returns: True if there are no pc_cup or pc_cui operations	}
{    in the tree, else false.					}

begin {NoFunctions}
if op = nil then
   NoFunctions := true
else if op^.opcode in [pc_cup,pc_cui,pc_cum,pc_csp,pc_tl1,pc_tl2,pc_vct,pc_pds]
   then
   NoFunctions := false
else
   NoFunctions := NoFunctions(op^.left) or NoFunctions(op^.right);
end; {NoFunctions}


function OneBit (val: longint): boolean;

{ See if there is exactly one bit set in val			}
{								}
{ parameters:							}
{    val - value to check					}
{								}
{ Returns: True if exactly one bit is set, else false		}

begin {OneBit}
if val = 0 then
   OneBit := false
else begin
   while not odd(val) do
      val := val >> 1;
   OneBit := val = 1;
   end; {else}
end; {OneBit}


function TypeSize (tp: baseTypeEnum): integer;

{ Find the size, in bytes, of a variable			}
{								}
{ parameters:							}
{    tp - base type of the variable				}

begin {TypeSize}
case tp of
   cgByte,cgUByte:   TypeSize := cgByteSize;
   cgWord,cgUWord:   TypeSize := cgWordSize;
   cgLong,cgULong:   TypeSize := cgLongSize;
   cgReal:           TypeSize := cgRealSize;
   cgDouble:         TypeSize := cgDoubleSize;
   cgComp:           TypeSize := cgCompSize;
   cgExtended:       TypeSize := cgExtendedSize;
   cgString:	     TypeSize := cgByteSize;
   cgVoid,cgSet:     TypeSize := cgLongSize;
   end; {case}
end; {TypeSize}


function LabelsMatch (op1, op2: icptr): boolean;

{ See if the labels from two instructions match			}
{								}
{ parameters:							}
{    op1, op2 - instructions to check				}
{								}
{ Returns: True for match, otherwise false			}

begin {LabelsMatch}
if (op1^.lab = nil) and (op2^.lab = nil) then
   LabelsMatch := op1^.q = op2^.q
else if (op1^.lab <> nil) and (op2^.lab <> nil) then
   LabelsMatch := op1^.lab^ = op2^.lab^
else
   LabelsMatch := false;
end; {LabelsMatch}                                  


procedure PeepHoleOptimization (var opv: icptr);

{ do peephole optimization on a list of opcodes			}
{								}
{ parameters:							}
{    opv - pointer to the first opcode				}
{								}
{ Notes:							}
{    1.	Many optimizations assume the children have already	}
{	been optimized.  In particular, many optimizations	}
{	depend on pc_ldc operands being on a specific side of	}
{	a child's expression tree.  (e.g. pc_fjp and pc_equ)	}

var
   done: boolean;			{optimization done test}
   doit: boolean;			{should we do the optimization?}
   i,j: integer;			{general work variables}
   lq, lval: longint;			{temps for long calculations}
   op2,op3: icptr;			{temp opcodes}
   op: icptr;				{copy of op (for efficiency)}
   opcode: pcodes;			{temp opcode}
   optype: baseTypeEnum;		{temp optype}
   q: integer;				{temp for integer calculations}
   rval: double;			{temp for real calculations}
   set1,set2: setPtr;			{work set pointer}

   fromtype, totype, firstType: record	{for converting numbers to optypes}
      case boolean of
         true:  (i: integer);
         false: (optype: baseTypeEnum);
      end;


   function IsUnsigned (op: icptr): boolean;

   { Check to see if the operand is unsigned			}
   {								}
   { parameters:						}
   {    op - opcode to check					}

   begin {IsUnsigned}
   case op^.opcode of

      pc_abi, pc_abl, pc_equ, pc_geq, pc_grt, pc_lad, pc_lao, pc_lca,
      pc_lda, pc_leq, pc_les, pc_lla, pc_neq, pc_not, pc_odd, pc_odl,
      pc_sqi, pc_sql, pc_udi, pc_udl, pc_uim, pc_ulm, pc_umi, pc_uml,
      pc_usr, pc_vsr:
         IsUnsigned := true;

      pc_adi, pc_adl, pc_and, pc_ior, pc_lnd, pc_lor:
         IsUnsigned := IsUnsigned(op^.left) and IsUnsigned(op^.right);

      pc_cnv:
         IsUnsigned := (op^.q & $00F0 >> 4) in
            [ord(cgUByte), ord(cgUWord), ord(cgULong)];

      pc_cop, pc_cpo, pc_cui, pc_cum, pc_cup, pc_ind, pc_ldo, pc_lod:
         IsUnsigned := op^.optype in [cgUByte, cgUWord, cgULong];

      pc_inc:
         IsUnsigned := IsUnsigned(op^.left);

      pc_ldc:
         case op^.optype of
            cgByte, cgWord: IsUnsigned := op^.q >= 0;
            cgLong: IsUnsigned := op^.lval >= 0;
            cgUByte,cgUWord,cgULong: IsUnsigned := true;
            otherwise: IsUnsigned := false;
            end;

      otherwise:
         IsUnsigned := false;
      end;
   end; {IsUnsigned}


   function SideEffects (op: icptr): boolean;

   { Check a tree for operations that have side effects	}
   {								}
   { parameters:						}
   {    op - tree to check					}

   var
      result: boolean;		{temp result}

   begin {SideEffects}
   if op = nil then
      SideEffects := false
   else if op^.opcode in
      [pc_mov,pc_cop,pc_cpo,pc_sro,pc_sto,pc_str,pc_cui,pc_cup,pc_tl1,
       pc_tl1,pc_pds,pc_csp,pc_prs,pc_fix,pc_cum,pc_vct] then
      SideEffects := true
   else
      SideEffects := SideEffects(op^.left) or SideEffects(op^.right);
   end; {SideEffects}


   procedure MakeWordSet (op: icptr);

   { Convert the tree from set operations to equivalent word	}
   { operations							}
   {								}
   { parameters:						}
   {    op - tree to convert					}

   var
      c: record				{conversion record}
         case boolean of
            true:  (b1, b2: byte);
            false: (ival: integer);
         end;
      op2,op3: icptr;			{temp opcodes}
      opcode: pcodes;			{op^.opcode}

   begin {MakeWordSet}
   opcode := op^.opcode;
   if opcode = pc_ldc then begin
      op^.optype := cgUWord;
      c.ival := 0;
      if op^.setp^.smax <> 0 then begin
         c.b1 := ord(op^.setp^.sval[1]);
         if op^.setp^.smax <> 1 then
            c.b2 := ord(op^.setp^.sval[2]);
         end; {if}
      op^.setp := nil;
      op^.q := c.ival;
      end {if}
   else if opcode = pc_ldo then begin
      op^.optype := cgUWord;
      op^.q := op^.r;
      op^.r := 0;
      end {else if}
   else if opcode = pc_lod then begin
      op^.optype := cgUWord;
      op^.s := 0;
      end {else if}
   else if opcode = pc_sgs then begin
      op^.right^.q := 1;
      op2 := op^.left;
      op^.left := op^.right;
      op^.right := op2;
      op^.opcode := pc_shl;
      end {else if}
   else if opcode = pc_inn then begin
      MakeWordSet(op^.right);
      op2 := pointer(Calloc(sizeof(intermediate_code)));
      op2^.optype := cgUWord;
      op2^.opcode := pc_ldc;
      op2^.q := 1;
      op3 := pointer(Calloc(sizeof(intermediate_code)));
      op3^.optype := cgWord;
      op3^.opcode := pc_shl;
      op3^.left := op2;
      op3^.right := op^.left;
      op^.left := op3;
      op^.opcode := pc_bnd;
      end {else if}
   else if opcode = pc_dif then begin
      MakeWordSet(op^.left);
      MakeWordSet(op^.right);
      op2 := pointer(Calloc(sizeof(intermediate_code)));
      op2^.optype := cgWord;
      op2^.opcode := pc_bnt;
      op2^.left := op^.right;
      op^.right := op2;
      op^.opcode := pc_bnd;
      end {else if}
   else if opcode = pc_int then begin
      MakeWordSet(op^.left);
      MakeWordSet(op^.right);
      op^.opcode := pc_bnd;
      end {else if}
   else if opcode = pc_uni then begin
      MakeWordSet(op^.left);
      MakeWordSet(op^.right);
      op^.opcode := pc_bor;
      end; {else if}
   end; {MakeWordSet}


   function WordSet (op: icptr): boolean;

   { See if the tree consists entirely of set operations that	}
   { can be converted to word operations			}
   {								}
   { parameters:						}
   {    op - tree to check					}
   {								}
   { Returns: True if so, false if not				}

   var
      opcode: pcodes;			{op^.opcode}

   begin {WordSet}
   opcode := op^.opcode;
   if opcode = pc_ldc then
      WordSet := op^.setp^.smax <= 2
   else if opcode = pc_ldo then
      WordSet := op^.q = 2
   else if opcode = pc_lod then
      WordSet := op^.s = 2
   else if opcode in [pc_dif,pc_int,pc_uni] then
      WordSet := WordSet(op^.left) and WordSet(op^.right)
   else if opcode = pc_inn then
      WordSet := WordSet(op^.right) and IsUnsigned(op^.left)
   else if opcode = pc_sgs then
      if op^.right^.opcode = pc_ldc then
         WordSet := op^.right^.q = $8000
      else
         WordSet := false
   else
      WordSet := false;
   end; {WordSet}


   procedure MakeLongSet (op: icptr);

   { Convert the tree from set operations to equivalent long	}
   { operations							}
   {								}
   { parameters:						}
   {    op - tree to convert					}

   var
      c: record				{conversion record}
         case boolean of
            true:  (b1, b2, b3, b4: byte);
            false: (lval: longint);
         end;
      op2,op3: icptr;			{temp opcodes}
      opcode: pcodes;			{op^.opcode}

   begin {MakeLongSet}
   opcode := op^.opcode;
   if opcode = pc_ldc then begin
      op^.optype := cgULong;
      c.lval := 0;
      if op^.setp^.smax <> 0 then begin
         c.b1 := ord(op^.setp^.sval[1]);
         if op^.setp^.smax <> 1 then begin
            c.b2 := ord(op^.setp^.sval[2]);
            if op^.setp^.smax <> 2 then begin
               c.b3 := ord(op^.setp^.sval[3]);
               if op^.setp^.smax <> 3 then 
        	  c.b4 := ord(op^.setp^.sval[4]);
               end; {if}
            end; {if}
         end; {if}
      op^.setp := nil;
      op^.lval := c.lval;
      end {if}
   else if opcode = pc_ldo then begin
      op^.optype := cgULong;
      op^.q := op^.r;
      op^.r := 0;
      end {else if}
   else if opcode = pc_lod then begin
      op^.optype := cgULong;
      op^.s := 0;
      end {else if}
   else if opcode = pc_dif then begin
      MakeLongSet(op^.left);
      MakeLongSet(op^.right);
      op2 := pointer(Calloc(sizeof(intermediate_code)));
      op2^.optype := cgWord;
      op2^.opcode := pc_bnl;
      op2^.left := op^.right;
      op^.right := op2;
      op^.opcode := pc_bal;
      end {else if}
   else if opcode = pc_int then begin
      MakeLongSet(op^.left);
      MakeLongSet(op^.right);
      op^.opcode := pc_bal;
      end {else if}
   else if opcode = pc_uni then begin
      MakeLongSet(op^.left);
      MakeLongSet(op^.right);
      op^.opcode := pc_blr;
      end; {else if}
   end; {MakeLongSet}


   function LongSet (op: icptr): boolean;

   { See if the tree consists entirely of set operations that	}
   { can be converted to long operations			}
   {								}
   { parameters:						}
   {    op - tree to check					}
   {								}
   { Returns: True if so, false if not				}

   var
      opcode: pcodes;			{op^.opcode}

   begin {LongSet}
   opcode := op^.opcode;
   if opcode = pc_ldc then
      LongSet := op^.setp^.smax <= 4
   else if opcode = pc_ldo then
      LongSet := op^.q = 4
   else if opcode = pc_lod then
      LongSet := op^.s = 4
   else if opcode in [pc_dif,pc_int,pc_uni] then
      LongSet := LongSet(op^.left) and LongSet(op^.right)
   else
      LongSet := false;
   end; {LongSet}


   procedure JumpOptimizations (op: icptr; newOpcode: pcodes);

   { handle common code for jump optimizations			}
   {								}
   { parameters:						}
   {    op - jump opcode					}
   {    newOpcode - opcode to use if the jump sense is reversed	}

   var
      done: boolean;			{optimization done test}
      topcode: pcodes;			{temp opcode}

   begin {JumpOptimizations}
   topcode := op^.left^.opcode;
   if topcode = pc_inn then
      if WordSet(op^.left) then begin
         MakeWordSet(op^.left);
         topcode := op^.left^.opcode;
         end; {if}
   if topcode = pc_not then begin
      op^.left := op^.left^.left;
      op^.opcode := newOpcode;
      PeepHoleOptimization(opv);
      end {else if}
   else if topcode in [pc_neq,pc_equ] then begin
      with op^.left^.right^ do
         if opcode = pc_ldc then
            if optype in [cgByte,cgUByte,cgWord,cgUWord] then
               if q = 0 then begin
                  op^.left := op^.left^.left;
                  if topcode = pc_equ then
                     op^.opcode := newOpcode;
                  end; {if}
      end; {else if}
   if op^.next^.opcode = dc_lab then
      if LabelsMatch(op^.next, op) then
         if not SideEffects(op^.left) then begin
            rescan := true;
            opv := op^.next;
            end; {else if}
   end; {JumpOptimizations}


   procedure RealStoreOptimizations (op, opl: icptr);

   { do strength reductions associated with stores of reals	}
   {								}
   { parameters:						}
   {    op - real store to optimize				}
   {    opl - load operand for the store operation		}

   var
      disp: 0..9;			{disp to the word to change}
      same: boolean;			{are the operands the same?}
      op2: icptr;			{new opcode}
      opt: icptr;			{temp opcode}

      cnvrl: record			{for stuffing a real in a long space}
	 case boolean of
            true:  (lval: longint);
            false: (rval: real);
	 end;

   begin {RealStoreOptimizations}
   if opl^.opcode = pc_ngr then begin
      same := false;
      with opl^.left^ do
         if op^.opcode = pc_sro then begin
            if opcode = pc_ldo then
               if q = op^.q then
                  if optype = op^.optype then
                     if lab^ = op^.lab^ then
                        same := true;
            end {if}
         else {if op^.opcode = pc_str then}
            if opcode = pc_lod then
               if q = op^.q then
                  if r = op^.r then
                     if optype = op^.optype then
                        same := true;
      if same then begin
         case op^.optype of
            cgReal: disp := 3;
            cgDouble: disp := 7;
            cgExtended: disp := 9;
            cgComp: disp := 11;
            end; {case}
         opl^.left^.optype := cgWord;
         opl^.left^.q := opl^.left^.q + disp;
         op^.optype := cgWord;
         op^.q := op^.q + disp;
         op2 := pointer(Calloc(sizeof(intermediate_code)));
         op2^.opcode := pc_ldc;
         op2^.optype := cgWord;
         op2^.q := $0080;
         opl^.right := op2;
         opl^.opcode := pc_bxr;
         end {if}
      else if op^.optype = cgReal then begin
         opt := opl^.left;
         if opt^.opcode in [pc_ind,pc_ldo,pc_lod] then
            if opt^.optype = cgReal then begin
               opt^.optype := cgLong;
               op^.optype := cgLong;
               op2 := pointer(Calloc(sizeof(intermediate_code)));
               op2^.opcode := pc_ldc;
               op2^.optype := cgLong;
               op2^.lval := $80000000;
	       opl^.right := op2;
               opl^.opcode := pc_blx;
               end; {if}
         end; {else if}
      end {if}
   else if op^.optype = cgReal then begin
      if opl^.opcode = pc_ldc then begin
         cnvrl.rval := opl^.rval;
         opl^.lval := cnvrl.lval;
         opl^.optype := cgLong;
         op^.optype := cgLong;
         end {if}
      else if opl^.opcode in [pc_ind,pc_ldo,pc_lod] then
         if opl^.optype = cgReal then begin
            opl^.optype := cgLong;
            op^.optype := cgLong;
            end; {if}
      end; {if}
   end; {RealStoreOptimizations}


   procedure ReplaceLoads (ldop, stop, tree: icptr);

   { Replace any pc_lod operations in tree that load from the	}
   { location stored to by the pc_str operation stop by ldop	}
   {								}
   { parameters:						}
   {    ldop - operation to replace the pc_lods with		}
   {    stop - pc_str operation					}
   {    tree - tree to check for pc_lod operations		}
   {								}
   { Notes: ldop must be an instruction, not a tree		}

   begin {ReplaceLoads}
   if tree^.left <> nil then
      ReplaceLoads(ldop, stop, tree^.left);
   if tree^.right <> nil then
      ReplaceLoads(ldop, stop, tree^.right);
   if tree^.opcode = pc_lod then
      if tree^.optype = stop^.optype then
         if tree^.q = stop^.q then
            if tree^.r = stop^.r then
               tree^ := ldop^;
   end; {ReplaceLoads}


   procedure ReverseChildren (op: icptr);

   { reverse the children of a node				}
   {								}
   { parameters:						}
   {    op - node for which to reverse the children		}

   var
      opt: icptr;			{temp opcode pointer}

   begin {ReverseChildren}
   opt := op^.right;
   op^.right := op^.left;
   op^.left := opt;
   end; {ReverseChildren}


   procedure ZeroIntermediateCode (op: icptr);

   { Set all fields in the record to 0, nil, etc.		}
   {								}
   { Parameters:						}
   {    op - intermediate code record to clear			}

   begin {ZeroIntermediateCode}
   op^.q := 0;
   op^.r := 0;
   op^.s := 0;
   op^.lab := nil;
   op^.next := nil;
   op^.left := nil;
   op^.right := nil;
   op^.optype := cgWord;
   op^.opnd := 0;
   op^.llab := 0;
   op^.slab := 0;
   end; {ZeroIntermediateCode}


begin {PeepHoleOptimization}
if peepSpin = 0 then begin		{spinner}
   peepSpin := peepSpinRate;
   Spin;
   end {if}
else
   peepSpin := peepSpin-1;
{if printSymbols then begin write('Optimize: '); WriteCode(opv); end; {debug}
op := opv;				{copy for efficiency}
if op^.left <> nil then			{optimize the children}
   PeepHoleOptimization(op^.left);
if op^.right <> nil then
   PeepHoleOptimization(op^.right);
case op^.opcode of			{check for optimizations of this node}
   pc_add: begin			{pc_add}
      if op^.next^.opcode <> pc_add then
         RemoveDeadCode(op);
      end; {case pc_add}

   pc_adi: begin			{pc_adi}
      if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin
         op^.left^.q := op^.left^.q + op^.right^.q;
         opv := op^.left;
         end {if}
      else begin
         if op^.left^.opcode = pc_ldc then
            ReverseChildren(op);
         if op^.right^.opcode = pc_ldc then begin
            q := op^.right^.q;
            if q = 0 then
               opv := op^.left
            else if q > 0 then begin
               op^.opcode := pc_inc;
               op^.q := q;
               op^.right := nil;
               end {else if}
            else {if q < 0 then} begin
               op^.opcode := pc_dec;
               op^.q := -q;
               op^.right := nil;
               end; {else if}
            end {if}
         else if op^.left^.opcode in [pc_inc,pc_dec] then begin
            if op^.right^.opcode in [pc_inc,pc_dec] then begin
               op2 := op^.left;
               if op^.left^.opcode = pc_inc then
                  q := op^.left^.q
               else
                  q := -op^.left^.q;
               if op^.right^.opcode = pc_inc then
                  q := q + op^.right^.q
               else
                  q := q - op^.right^.q;
               if q >= 0 then begin
                  op2^.opcode := pc_inc;
                  op2^.q := q;
                  end {if}
               else begin
                  op2^.opcode := pc_dec;
                  op2^.q := -q;
                  end; {else}
               op^.left := op^.left^.left;
               op^.right := op^.right^.left;
               op2^.left := op;
               opv := op2;
               PeepHoleOptimization(opv);
               end; {if}
            end {else if}
         else if CodesMatch(op^.left, op^.right, false) then begin
            if NoFunctions(op^.left) then begin
               ZeroIntermediateCode(op^.right);
               with op^.right^ do begin
                  opcode := pc_ldc;
                  q := 1;
                  optype := cgWord;
                  end; {with}
               op^.opcode := pc_shl;
               PeepHoleOptimization(opv);
               end; {if}
            end; {else if}
         end; {else}
      end; {case pc_adi}

   pc_adl: begin			{pc_adl}
      if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin
         op^.left^.lval := op^.left^.lval + op^.right^.lval;
         opv := op^.left;
         end {if}
      else begin
         if op^.left^.opcode = pc_ldc then
            ReverseChildren(op);
         if op^.right^.opcode = pc_ldc then begin
            lval := op^.right^.lval;
            if lval = 0 then
               opv := op^.left
            else if (lval >= 0) and (lval <= maxint) then begin
               op^.opcode := pc_inc;
               op^.optype := cgLong;
               op^.q := ord(lval);
               op^.right := nil;
               end {else if}
            else if (lval > -maxint) and (lval < 0) then begin
               op^.opcode := pc_dec;
               op^.optype := cgLong;
               op^.q := -ord(lval); 
               op^.right := nil;
               end; {else if}
            end {if}
         else if CodesMatch(op^.left, op^.right, false) then
            if NoFunctions(op^.left) then begin
               ZeroIntermediateCode(op^.right);
               with op^.right^ do begin
                  opcode := pc_ldc;
                  lval := 1;
                  optype := cgLong;
                  end; {with}
               op^.opcode := pc_sll;
               end; {if}
         if op^.right^.opcode in [pc_lao,pc_lda,pc_ixa] then
            ReverseChildren(op);
         if op^.left^.opcode in [pc_lao,pc_lda,pc_ixa] then
            if op^.right^.opcode = pc_sll then begin
               if op^.right^.right^.opcode = pc_ldc then
                  if (op^.right^.right^.lval & $FFFF8000) = 0 then
                     if op^.right^.left^.opcode = pc_cnv then begin
                	fromtype.i := (op^.right^.left^.q & $00F0) >> 4;
                	if fromType.optype in [cgByte,cgUByte,cgWord,cgUWord] then
                           begin
                           if fromType.optype = cgByte then
                              op^.right^.left^.q := $02
                           else if fromType.optype = cgUByte then
                              op^.right^.left^.q := $13
                           else
                              op^.right^.left := op^.right^.left^.left;
                           with op^.right^.right^ do begin
                              lq := lval;
                              lval := 0;
                              q := long(lq).lsw;
                              optype := cgUWord;
                              end; {with}
                           op^.right^.opcode := pc_shl;
                           op^.opcode := pc_ixa;
                           PeepHoleOptimization(opv);
                           end; {if}
                	end; {if}
               end {if}
            else if op^.right^.opcode = pc_cnv then begin
               fromtype.i := (op^.right^.q & $00F0) >> 4;
               if fromtype.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin
                  if fromType.optype = cgByte then
                     op^.right^.q := $02
                  else if fromType.optype = cgUByte then
                     op^.right^.q := $13
                  else
                     op^.right := op^.right^.left;
                  op^.opcode := pc_ixa;
                  PeepHoleOptimization(opv);
                  end; {if}
               end; {else if}
         end; {else}
      end; {case pc_adl}

   pc_adr: begin			{pc_adr}
      if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin
         op^.left^.rval := op^.left^.rval + op^.right^.rval;
         opv := op^.left;
         end {if}
      else begin
         if op^.left^.opcode = pc_ldc then
            ReverseChildren(op);
         if op^.right^.opcode = pc_ldc then begin
            if op^.right^.rval = 0.0 then
               opv := op^.left;
            end; {if}
         end; {else}   
      end; {case pc_adr}

   pc_and: begin			{pc_and}
      if op^.right^.opcode = pc_ldc then begin
         if op^.left^.opcode = pc_ldc then begin
            op^.left^.q := ord((op^.left^.q <> 0) and (op^.right^.q <> 0));
            opv := op^.left;
            end {if}
         else begin
            if op^.right^.q = 0 then 
               if not SideEffects(op^.left) then 
                  opv := op^.right;
            end {else}
         end {if}
      else if op^.left^.opcode = pc_ldc then
         if op^.left^.q = 0 then
            opv := op^.left;
      end; {case pc_and}

   pc_bal: begin			{pc_bal}
      if op^.left^.opcode = pc_ldc then
         ReverseChildren(op);
      if op^.left^.opcode = pc_ldc then begin
         op^.left^.lval := op^.left^.lval & op^.right^.lval;
         opv := op^.left;
         end {if}
      else if op^.right^.opcode = pc_ldc then begin
         if op^.right^.lval = 0 then
            opv := op^.right
         else if op^.right^.lval = -1 then
            opv := op^.left;
         end; {else if}
      end; {case pc_bal}

   pc_blr: begin			{pc_blr}
      if op^.left^.opcode = pc_ldc then
         ReverseChildren(op);
      if op^.left^.opcode = pc_ldc then begin
         op^.left^.lval := op^.left^.lval | op^.right^.lval;
         opv := op^.left;
         end {if}
      else if op^.right^.opcode = pc_ldc then begin
         if op^.right^.lval = -1 then
            opv := op^.right
         else if op^.right^.lval = 0 then
            opv := op^.left;
         end; {else if}
      end; {case pc_blr}

   pc_blx: begin			{pc_blx}
      if op^.left^.opcode = pc_ldc then
         ReverseChildren(op);
      if op^.left^.opcode = pc_ldc then begin
         op^.left^.lval := op^.left^.lval ! op^.right^.lval;
         opv := op^.left;
         end {if}
      else if op^.right^.opcode = pc_ldc then begin
         if op^.right^.lval = 0 then
            opv := op^.left
         else if op^.right^.lval = -1 then begin
            op^.opcode := pc_bnl;
            op^.right := nil;
            end; {else if}
         end; {else if}
      end; {case pc_blx}

   pc_bnd: begin			{pc_bnd}
      if op^.left^.opcode = pc_ldc then
         ReverseChildren(op);
      if op^.left^.opcode = pc_ldc then begin
         op^.left^.q := op^.left^.q & op^.right^.q;
         opv := op^.left;
         end {if}
      else if op^.right^.opcode = pc_ldc then begin
         if op^.right^.q = 0 then
            opv := op^.right
         else if op^.right^.q = -1 then
            opv := op^.left;
         end; {else if}
      end; {case pc_bnd}

   pc_bnl: begin			{pc_bnl}
      if op^.left^.opcode = pc_ldc then begin
         op^.left^.lval := op^.left^.lval ! $FFFFFFFF;
         opv := op^.left;
         end; {if}
      end; {case pc_bnl}

   pc_bno: begin			{pc_bno}
      if op^.left^.opcode = pc_str then
         if op^.left^.left^.opcode in [pc_lda,pc_lao] then begin
            ReplaceLoads(op^.left^.left, op^.left, op^.right);
            opv := op^.right;
            end; {if}
      end; {case pc_bno}

   pc_bnt: begin			{pc_bnt}
      if op^.left^.opcode = pc_ldc then begin
         op^.left^.q := op^.left^.q ! $FFFF;
         opv := op^.left;
         end; {if}
      end; {case pc_bnt}

   pc_bor: begin			{pc_bor}
      if op^.left^.opcode = pc_ldc then
         ReverseChildren(op);
      if op^.left^.opcode = pc_ldc then begin
         op^.left^.q := op^.left^.q | op^.right^.q;
         opv := op^.left;
         end {if}
      else if op^.right^.opcode = pc_ldc then begin
         if op^.right^.q = -1 then
            opv := op^.right
         else if op^.right^.q = 0 then
            opv := op^.left;
         end; {else if}
      end; {case pc_bor}

   pc_bxr: begin			{pc_bxr}
      if op^.left^.opcode = pc_ldc then
         ReverseChildren(op);
      if op^.left^.opcode = pc_ldc then begin
         op^.left^.q := op^.left^.q ! op^.right^.q;
         opv := op^.left;
         end {if}
      else if op^.right^.opcode = pc_ldc then begin
         if op^.right^.q = 0 then
            opv := op^.left
         else if op^.right^.q = -1 then begin
            op^.opcode := pc_bnt;
            op^.right := nil;
            end; {else if}
         end; {else if}
      end; {case pc_bxr}

   pc_cnv: begin			{pc_cnv}
      fromtype.i := (op^.q & $00F0) >> 4;
      totype.i := op^.q & $000F;
      if op^.left^.opcode = pc_ldc then begin
	 case fromtype.optype of
            cgByte,cgWord:
               case totype.optype of
        	  cgByte,cgUByte,cgWord,cgUWord: ;
        	  cgLong,cgULong: begin
                     lval := op^.left^.q;
                     op^.left^.q := 0;
                     op^.left^.lval := lval;
                     end;
        	  cgReal,cgDouble,cgComp,cgExtended: begin
                     rval := op^.left^.q;
                     op^.left^.q := 0;
                     op^.left^.rval := rval;
                     end;
                  otherwise: ;
        	  end; {case}                             
            cgUByte,cgUWord:
               case totype.optype of
        	  cgByte,cgUByte,cgWord,cgUWord: ;
        	  cgLong,cgULong: begin
                     lval := ord4(op^.left^.q) & $0000FFFF;
                     op^.left^.q := 0;
                     op^.left^.lval := lval;
                     end;
        	  cgReal,cgDouble,cgComp,cgExtended: begin
                     rval := ord4(op^.left^.q) & $0000FFFF;
                     op^.left^.q := 0;
                     op^.left^.rval := rval;
                     end;
                  otherwise: ;
        	  end; {case}                             
            cgLong:
               case totype.optype of
        	  cgByte,cgUByte,cgWord,cgUWord: begin
                     q := long(op^.left^.lval).lsw;                
                     op^.left^.lval := 0;
                     op^.left^.q := q;
                     end;
        	  cgLong, cgULong: ;
        	  cgReal,cgDouble,cgComp,cgExtended: begin
                     rval := op^.left^.lval;
                     op^.left^.lval := 0;
                     op^.left^.rval := rval;
                     end;
                  otherwise: ;
        	  end; {case}
            cgULong:
               case totype.optype of
        	  cgByte,cgUByte,cgWord,cgUWord: begin
                     q := long(op^.left^.lval).lsw;
                     op^.left^.lval := 0;
                     op^.left^.q := q;
                     end;
        	  cgLong, cgULong: ;
        	  cgReal,cgDouble,cgComp,cgExtended: begin
                     lval := op^.left^.lval;
                     op^.left^.lval := 0;
                     if lval >= 0 then
                        rval := lval
                     else
                        rval := (lval & $7FFFFFFF) + 2147483648.0;
                     op^.left^.rval := rval;
                     end;
                  otherwise: ;
        	  end; {case}
            cgReal,cgDouble,cgComp,cgExtended: begin
               rval := op^.left^.rval;
               case totype.optype of
        	  cgByte: begin
                     if rval < -128.0 then
                        q := -128
                     else if rval > 127.0 then
                        q := 127
                     else
                        q := trunc(rval);
                     op^.left^.rval := 0.0;
                     op^.left^.q := q;
                     end;
        	  cgUByte: begin
                     if rval < 0.0 then
                        q := 0
                     else if rval > 255.0 then
                        q := 255
                     else
                        q := trunc(rval);
                     op^.left^.rval := 0.0;
                     op^.left^.q := q;
                     end;
        	  cgWord: begin
                     if rval < -32768.0 then
                        lval := -32768
                     else if rval > 32767.0 then
                        lval := 32767
                     else
                        lval := trunc(rval);
                     op^.left^.rval := 0.0;
                     op^.left^.q := long(lval).lsw;
                     end;
        	  cgUWord: begin
                     if rval < 0.0 then
                        lval := 0
                     else if rval > 65535.0 then
                        lval := 65535
                     else
                        lval := trunc4(rval);
                     op^.left^.rval := 0.0;
                     op^.left^.q := long(lval).lsw;
                     end;
        	  cgLong,cgULong: begin
                     if totype.optype = cgULong then begin
                        if rval < 0 then
                           rval := 0
                        else if rval > 2147483647.0 then
                           rval := rval - 4294967296.0
                        end; {if}
                     if rval < -2147483648.0 then
                        lval := $80000000
                     else if rval > 2147483647.0 then
                        lval := 2147483647
                     else
                        lval := trunc4(rval);
                     op^.left^.rval := 0.0;
                     op^.left^.lval := lval;
                     end;
        	  cgReal,cgDouble,cgComp,cgExtended: ;
                  otherwise: ;
                  end;
               end; {case}        
            otherwise: ;
            end; {case}
         if fromtype.optype in
            [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgReal,cgDouble,
            cgComp,cgExtended] then
            if totype.optype in
               [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgReal,cgDouble,
               cgComp,cgExtended] then begin
               op^.left^.optype := totype.optype;
               opv := op^.left;
               end; {if}
         end {if}
      else if op^.left^.opcode = pc_cnv then begin
         doit := false;
         firsttype.i := (op^.q & $00F0) >> 4;
         if fromType.optype in [cgReal,cgDouble,cgComp,cgExtended] then begin
            if toType.optype in [cgReal,cgDouble,cgComp,cgExtended] then
               doit := true;
            end {if}
         else begin
            if firstType.optype in [cgByte,cgWord,cgLong] then
               if fromType.optype in [cgByte,cgWord,cgLong] then
                  if toType.optype in [cgByte,cgWord,cgLong] then
                     doit := true;
            if firstType.optype in [cgUByte,cgUWord,cgULong] then
               if fromType.optype in [cgUByte,cgUWord,cgULong] then
                  if toType.optype in [cgUByte,cgUWord,cgLong] then
                     doit := true;
            if TypeSize(firstType.optype) = TypeSize(fromType.optype) then
               if TypeSize(firstType.optype) = TypeSize(toType.optype) then
                  doit := true;
            end; {else}
         if doit then begin
            op^.q := (op^.left^.q & $00F0) | (op^.q & $000F);
            op^.left := op^.left^.left;
            PeepHoleOptimization(opv);
            end; {if}
         end {else if}
      else if op^.left^.opcode in [pc_lod,pc_ldo,pc_ind] then begin
         if fromtype.optype in [cgWord,cgUWord] then
            if totype.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin
               op^.left^.optype := totype.optype;
               opv := op^.left;
               end; {if}
         if fromtype.optype in [cgLong,cgULong] then
            if totype.optype in [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong]
               then begin
               op^.left^.optype := totype.optype;
               opv := op^.left;
               end; {if}
         end {else if}
      else if op^.q in [$40,$41,$50,$51] then begin
         {any long type to byte type}
         with op^.left^ do
            if opcode = pc_bal then
               if right^.opcode = pc_ldc then
                  if right^.lval = 255 then begin
                     op^.left := op^.left^.left;
                     PeepHoleOptimization(opv);
                     end; {if}
         with op^.left^ do    
            if opcode in [pc_slr,pc_vsr] then
               if right^.opcode = pc_ldc then
                  if left^.opcode in [pc_lod,pc_ldo,pc_ind] then begin
                     lq := right^.lval;
                     if long(lq).msw = 0 then
                        if long(lq).lsw in [8,16,24] then begin
                           lq := lq div 8;
                           left^.q := left^.q + long(lq).lsw;
                           op^.left := left;
                	   PeepHoleOptimization(opv);
                	   end; {if}
                     end; {if}
         end; {else if}                     
      end; {case pc_cnv}

   pc_csp: begin			{pc_csp}
      if op^.q = 91 then begin		{string move}
         op2 := op^.left^.left^.right^.left;
         op3 := op^.left^.right^.right^.left;
         if op2^.opcode = pc_ldc then
            if op3^.opcode = pc_ldc then
               if op2^.q = op3^.q then begin
                  q := op2^.q;
                  if q < -1 then q := 1-q;
                  if q > 0 then begin
                     op^.opcode := pc_mov;
                     op^.right := op^.left^.right^.left^.left;
                     op^.left := op^.left^.left^.left^.left;
                     op^.q := q;
                     op^.r := 0;
                     PeepHoleOptimization(opv);
                     end; {if}  
                  end; {if}
         end {if}
      else if op^.next <> nil then
         if op^.next^.opcode = pc_csp then
            if op^.next^.q = 26 then begin
               if op^.q in [16,19,21,29,37] then begin
                  if op^.q = 16 then
                     op^.q := 34
                  else if op^.q = 19 then
                     op^.q := 12
                  else
                     op^.q := op^.q-1;
                  op^.next := op^.next^.next;
                  end; {if}
               end {if}
            else if op^.next^.q = 27 then begin
               if op^.q in [39,42,25,31,23] then begin
                  if op^.q = 42 then
                     op^.q := 43
                  else
                     op^.q := op^.q-1;
                  op^.next := op^.next^.next;
                  end; {if}
               end; {else if}
      end; {case pc_csp}

   pc_dec: begin			{pc_dec}
      if op^.q = 0 then
         opv := op^.left
      else begin
	 opcode := op^.left^.opcode;
	 if opcode = pc_dec then begin
            if ord4(op^.left^.q) + ord4(op^.q) < ord4(maxint) then begin
               op^.q := op^.q + op^.left^.q;
               op^.left := op^.left^.left;
               end; {if}
            end {if}
	 else if opcode = pc_inc then begin
            q := op^.q - op^.left^.q;
            if q < 0 then begin
               q := -q;
               op^.opcode := pc_inc;
               end; {if}
            op^.q := q;
            op^.left := op^.left^.left;
            PeepHoleOptimization(opv);
            end {else if}
         else if opcode = pc_ldc then begin
            if op^.optype in [cgLong, cgULong] then begin
               op^.left^.lval := op^.left^.lval - op^.q;
               opv := op^.left;
               end {if}
            else if op^.optype in [cgUByte, cgByte, cgUWord, cgWord] then begin
               op^.left^.q := op^.left^.q - op^.q;
               opv := op^.left;
               end; {else if}
            end; {else if}
         end; {else}
      end; {case pc_dec}

   pc_dvi: begin			{pc_dvi}
      if op^.right^.opcode = pc_ldc then begin
         if op^.left^.opcode = pc_ldc then begin
            if op^.right^.q <> 0 then begin
               op^.left^.q := op^.left^.q div op^.right^.q;
               opv := op^.left;
               end; {if}
            end {if}
         else if op^.right^.q = 1 then
            opv := op^.left;
         end {if}
      else if IsUnsigned(op^.left) and IsUnsigned(op^.right) then begin
         op^.opcode := pc_udi;
         PeepHoleOptimization(opv);
         end; {else if}
      end; {case pc_dvi}

   pc_dvl: begin			{pc_dvl}
      if op^.right^.opcode = pc_ldc then begin
         if op^.left^.opcode = pc_ldc then begin
            if op^.right^.lval <> 0 then begin
               op^.left^.lval := op^.left^.lval div op^.right^.lval;
               opv := op^.left;
               end; {if}
            end {if}
         else if op^.right^.lval = 1 then
            opv := op^.left;
         end {if}
      else if IsUnsigned(op^.left) and IsUnsigned(op^.right) then begin
         op^.opcode := pc_udl;
         PeepHoleOptimization(opv);
         end; {else if}
      end; {case pc_dvl}

   pc_dvr: begin			{pc_dvr}
      if op^.right^.opcode = pc_ldc then begin
         if op^.left^.opcode = pc_ldc then begin
            if op^.right^.rval <> 0.0 then begin
               op^.left^.rval := op^.left^.rval/op^.right^.rval;
               opv := op^.left;
               end; {if}
            end {if}
         else if op^.right^.rval = 1.0 then
            opv := op^.left;
         end; {if}
      end; {case pc_dvr}

   pc_equ: begin			{pc_equ}
      if op^.optype = cgSet then
         if WordSet(op^.left) then begin
            if WordSet(op^.right) then begin
               MakeWordSet(op^.left);
               MakeWordSet(op^.right);
               op^.optype := cgUWord;
               end; {if}
            end {if}
         else if LongSet(op^.left) then
            if LongSet(op^.right) then begin
               MakeLongSet(op^.left);
               MakeLongSet(op^.right);
               op^.optype := cgULong;
               end; {if}
      if IsUnsigned(op^.left) and IsUnsigned(op^.right) then
         if op^.optype = cgWord then
            op^.optype := cgUWord
         else if op^.optype = cgLong then
            op^.optype := cgULong
         else if op^.optype = cgByte then
            op^.optype := cgUByte;
      if op^.left^.opcode = pc_ldc then
         ReverseChildren(op);
      if op^.right^.opcode = pc_ldc then begin
	 if op^.left^.opcode = pc_ldc then begin
            BinOps(op^.left, op^.right);
            case op^.left^.optype of
               cgByte,cgUByte,cgWord,cgUWord: begin
        	  op^.opcode := pc_ldc;
        	  op^.q := ord(op^.left^.q = op^.right^.q);
        	  op^.left := nil;
        	  op^.right := nil;
        	  end;
               cgLong,cgULong: begin
        	  op^.opcode := pc_ldc;
        	  op^.q := ord(op^.left^.lval = op^.right^.lval);
        	  op^.left := nil;
        	  op^.right := nil;
        	  end;
               cgReal,cgDouble,cgComp,cgExtended: begin
        	  op^.opcode := pc_ldc;
        	  op^.q := ord(op^.left^.rval = op^.right^.rval);
        	  op^.left := nil;
        	  op^.right := nil;
        	  end;
               cgSet: begin
        	  op^.opcode := pc_ldc;
        	  op^.q := ord(SetsEqual(op^.left^.setp, op^.right^.setp));
        	  op^.left := nil;
        	  op^.right := nil;
        	  end;
               cgVoid: begin
        	  op^.opcode := pc_ldc;
        	  op^.q := ord(op^.left^.pval = op^.right^.pval);
        	  op^.left := nil;
        	  op^.right := nil;
        	  end;
               end; {case}
            op^.optype := cgUWord;
            end {if}
         else if op^.right^.optype in [cgByte, cgUByte, cgWord, cgUWord] then begin
            if op^.right^.q <> 0 then
               if op^.left^.opcode in
         	  [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt]
                  then begin
                  opv := op^.left;
                  opv^.next := op^.next;
                  end; {if}
            end {else if}
         else if op^.right^.optype in [cgLong, cgULong] then begin
            if op^.right^.lval <> 0 then
               if op^.left^.opcode in
         	  [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt]
                  then begin
                  opv := op^.left;
                  opv^.next := op^.next;
                  end; {if}
            end; {else if}
         end; {if}                      
      end; {case pc_equ}

   pc_fjp: begin			{pc_fjp}
      opcode := op^.left^.opcode;
      if opcode = pc_ldc then begin
         if op^.left^.optype in [cgByte, cgUByte, cgWord, cgUWord] then begin
            if op^.left^.q <> 0 then begin
               opv := op^.next;
               rescan := true;
               end {if}
            else begin
               op^.opcode := pc_ujp;
               op^.left := nil;
               PeepHoleOptimization(opv);
               end; {else}
            end {if}
         end {if}
      else if opcode = pc_and then begin
         op2 := op^.left;
         op2^.next := op^.next;
         op^.next := op2;
         op^.left := op2^.left;
         op2^.left := op2^.right;
         op2^.right := nil;
         op2^.opcode := pc_fjp;
         op2^.q := op^.q;
         PeepHoleOptimization(opv);
         end {else if}
      else if opcode = pc_ior then begin
         op2 := op^.left;
         op2^.next := op^.next;
         op^.next := op2;
         op^.left := op2^.left;
         op2^.left := op2^.right;
         op2^.right := nil;
         op2^.opcode := pc_fjp;
         op2^.q := op^.q;
         op^.opcode := pc_tjp;
         op3 := pointer(Calloc(sizeof(intermediate_code)));
         op3^.opcode := dc_lab;
         op3^.optype := cgWord;
         op3^.q := GenLabel;
         op3^.next := op2^.next;
         op2^.next := op3;
         op^.q := op3^.q;
         PeepHoleOptimization(opv);
         end {else if}
      else
         JumpOptimizations(op, pc_tjp);
      end; {case pc_fjp}

   pc_geq,pc_grt,pc_les:		{pc_geq, pc_grt, pc_les}
      if IsUnsigned(op^.left) and IsUnsigned(op^.right) then
         if op^.optype = cgWord then
            op^.optype := cgUWord
         else if op^.optype = cgLong then
            op^.optype := cgULong
         else if op^.optype = cgByte then
            op^.optype := cgUByte;

   pc_inc: begin			{pc_inc}
      if op^.q = 0 then
         opv := op^.left
      else begin
	 opcode := op^.left^.opcode;
	 if opcode = pc_inc then begin
            if ord4(op^.left^.q) + ord4(op^.q) < ord4(maxint) then begin
               op^.q := op^.q + op^.left^.q;
               op^.left := op^.left^.left;
               end; {if}
            end {if}
	 else if opcode = pc_dec then begin
            q := op^.q - op^.left^.q;
            if q < 0 then begin
               q := -q;
               op^.opcode := pc_dec;
               end; {if}
            op^.q := q;
            op^.left := op^.left^.left;
            PeepHoleOptimization(opv);
            end {else if}
         else if opcode = pc_ldc then begin
            if op^.optype in [cgLong, cgULong] then begin
               op^.left^.lval := op^.left^.lval + op^.q;
               opv := op^.left;
               end {if}
            else if op^.optype in [cgUByte, cgByte, cgUWord, cgWord] then begin
               op^.left^.q := op^.left^.q + op^.q;
               opv := op^.left;
               end; {else if}
            end {else if}
         else if opcode in [pc_lao,pc_lda] then begin
            op^.left^.q := op^.left^.q + op^.q;
            opv := op^.left;
            end; {else if}
         end; {else}
      end; {case pc_inc}

   pc_ind: begin			{pc_ind}
      if op^.optype <> cgSet then begin
	 opcode := op^.left^.opcode;
	 if opcode = pc_lda then begin
            op^.left^.opcode := pc_lod;
            op^.left^.optype := op^.optype;
            op^.left^.q := op^.left^.q + op^.q;
            op^.left^.r := op^.left^.s;
            op^.left^.s := 0;
            opv := op^.left;
            end {if}
	 else if opcode = pc_lao then begin
            op^.left^.opcode := pc_ldo;
            op^.left^.optype := op^.optype;
            op^.left^.q := op^.left^.q + op^.q;
            opv := op^.left;
            end; {else if}
         end; {if}
      end; {case pc_ind}

   pc_int: begin			{pc_int}
      if op^.left^.opcode = pc_ldc then
         if op^.right^.opcode = pc_ldc then begin
            if op^.left^.setp^.smax > op^.right^.setp^.smax then
               ReverseChildren(op);
            set1 := op^.left^.setp;
            set2 := op^.right^.setp;
            for i := 1 to set1^.smax do
               set1^.sval[i] := chr(ord(set1^.sval[i]) & ord(set2^.sval[i]));
            i := set1^.smax;
            while (i <> 1) and (ord(set1^.sval[i]) = 0) do
               i := i-1;
            set1^.smax := i;
            opv := op^.left;
            end; {if}
      end; {case pc_int}

   pc_ior: begin			{pc_ior}
      if op^.right^.opcode = pc_ldc then begin
         if op^.left^.opcode = pc_ldc then begin
            op^.left^.q := ord((op^.left^.q <> 0) or (op^.right^.q <> 0));
            opv := op^.left;
            end {if}
         else begin
            if op^.right^.q <> 0 then begin
               if not SideEffects(op^.left) then begin
                  op^.right^.q := 1;
                  opv := op^.right;
                  end; {if}
               end {if}
            else
               op^.opcode := pc_neq;
            end {if}
         end {if}
      else if op^.left^.opcode = pc_ldc then
         if op^.left^.q <> 0 then begin
            op^.left^.q := 1;
            opv := op^.left;
            end; {if}
      end; {case pc_ior}

   pc_ixa: begin			{pc_ixa}
      if op^.right^.opcode = pc_ldc then begin
         optype := op^.right^.optype;
         if optype in [cgUByte, cgByte, cgUWord, cgWord] then begin
            lval := op^.right^.q;
            if optype = cgUByte then
               lval := lval & $000000FF
            else if optype = cgUWord then
               lval := lval & $0000FFFF;
            done := false;
            if op^.left^.opcode in [pc_lao, pc_lda] then begin
               lq := op^.left^.q + lval;
               if (lq >= 0) and (lq < maxint) then begin
                  done := true;
                  op^.left^.q := ord(lq);
                  opv := op^.left;
                  end; {if}
               end; {if}
            if not done then begin
               op^.right^.lval := lval;
               op^.right^.optype := cgLong;
               op^.opcode := pc_adl;
               PeepHoleOptimization(opv);
               end; {if}
            end; {if}                   
         end {if}
      else if op^.left^.opcode = pc_lao then begin
         if op^.right^.opcode = pc_inc then begin
            lq := ord4(op^.right^.q) + ord4(op^.left^.q);
            if lq < maxint then begin
               op^.left^.q := ord(lq);
               op^.right := op^.right^.left;
               end; {if}
            PeepHoleOptimization(opv);
            end; {if}
         end {else if}
      else if op^.left^.opcode = pc_ixa then begin
         op2 := op^.left;
         op^.left := op^.left^.left;
         op2^.left := op^.right;
         op2^.opcode := pc_adi;
         op^.right := op2;
         end; {else if}
      end; {case pc_ixa}

   pc_leq: begin			{pc_leq}
      if IsUnsigned(op^.left) and IsUnsigned(op^.right) then
         if op^.optype = cgWord then
            op^.optype := cgUWord
         else if op^.optype = cgLong then
            op^.optype := cgULong
         else if op^.optype = cgByte then
            op^.optype := cgUByte;
      if op^.optype in [cgWord,cgUWord] then
         if op^.right^.opcode = pc_ldc then
            if op^.right^.q < maxint then begin
               op^.right^.q := op^.right^.q + 1;
               op^.opcode := pc_les;
               end; {if}
      end; {case pc_lnm}

   pc_lnd: begin			{pc_lnd}
      if op^.right^.opcode = pc_ldc then begin
         if op^.left^.opcode = pc_ldc then begin
            op^.left^.q := ord((op^.left^.lval <> 0) and (op^.right^.lval <> 0));
            op^.left^.optype := cgWord;
            opv := op^.left;
            end {if}
         else begin
            if op^.right^.lval = 0 then begin
               if not SideEffects(op^.left) then  begin
                  with op^.right^ do begin
                     lval := 0;
                     optype := cgWord;
                     q := 0;
                     end; {with}
                  opv := op^.right;
                  end; {if}
               end {if}
            else
               op^.opcode := pc_neq;
            end; {if}
         end {if}
      else if op^.left^.opcode = pc_ldc then
         if op^.left^.lval = 0 then begin
            with op^.left^ do begin
               lval := 0;
               optype := cgWord;
               q := 0;
               end; {with}
            opv := op^.left;
            end; {if}
      end; {case pc_lnd}

   pc_lnm: begin			{pc_lnm}
      if op^.next^.opcode = pc_lnm then begin
         opv := op^.next;
         rescan := true;
         end; {if}
      end; {case pc_lnm}

   pc_lor: begin			{pc_lor}
      if op^.right^.opcode = pc_ldc then begin
         if op^.left^.opcode = pc_ldc then begin
            op^.left^.q := ord((op^.left^.lval <> 0) or (op^.right^.lval <> 0));
            optype := cgWord;
            opv := op^.left;
            end {if}
         else begin
            if op^.right^.lval <> 0 then begin
               if not SideEffects(op^.left) then begin
                  op^.right^.lval := 0;
                  op^.right^.q := 1;
                  op^.right^.optype := cgWord;
                  opv := op^.right;
                  end; {if}
               end {if}
            else begin
               op^.opcode := pc_neq;
               op^.optype := cgLong;
               end; {else}
            end; {if}
         end {if}
      else if op^.left^.opcode = pc_ldc then
         if op^.left^.lval <> 0 then begin
            op^.left^.lval := 0;
            op^.left^.q := 1;
            op^.left^.optype := cgWord;
            opv := op^.left;
            end; {if}
      end; {case pc_lor}

   pc_mdl: begin			{pc_mdl}
      if op^.right^.opcode = pc_ldc then  begin
         if op^.left^.opcode = pc_ldc then 
            if op^.right^.lval <> 0 then begin
               op^.left^.lval := op^.left^.lval mod op^.right^.lval;
               opv := op^.left;
               end; {if}
         end {if}
      else if IsUnsigned(op^.left) and IsUnsigned(op^.right) then begin
         op^.opcode := pc_ulm;
         PeepHoleOptimization(opv);
         end; {else if}
      end; {case pc_mdl}

   pc_mod: begin			{pc_mod}
      if op^.right^.opcode = pc_ldc then  begin
         if op^.left^.opcode = pc_ldc then 
            if op^.right^.q <> 0 then begin
               op^.left^.q := op^.left^.q mod op^.right^.q;
               opv := op^.left;
               end; {if}
         end {if}
      else if IsUnsigned(op^.left) and IsUnsigned(op^.right) then begin
         op^.opcode := pc_uim;
         PeepHoleOptimization(opv);
         end; {else if}
      end; {case pc_mod}

   pc_mpi, pc_umi: begin		{pc_mpi, pc_umi}
      if IsUnsigned(op^.left) and IsUnsigned(op^.right) then
         op^.opcode := pc_umi;
      if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin
         if op^.opcode = pc_mpi then
            op^.left^.q := op^.left^.q*op^.right^.q
         else {if op^.opcode = pc_umi then} begin
            lval := umul(op^.left^.q & $0000FFFF, op^.right^.q & $0000FFFF);
            op^.left^.q := long(lval).lsw;
            end; {else}
         opv := op^.left;
         end {if}
      else begin
         if op^.left^.opcode = pc_ldc then
            ReverseChildren(op);
         if op^.right^.opcode = pc_ldc then begin
            q := op^.right^.q;
            if q = 1 then
               opv := op^.left
            else if q = 0 then begin
               if NoFunctions(op^.left) then
                  opv := op^.right;
               end {else if}
            else if (q = -1) and (op^.opcode = pc_mpi) then begin
               op^.opcode := pc_ngi;
               op^.right := nil;
               end {else if}
            else if OneBit(q) then begin
               op^.right^.q := Base(q);
               op^.opcode := pc_shl;
               PeepHoleOptimization(opv);
               end; {else if}
            end; {if}
         end; {else}
      end; {case pc_mpi, pc_umi}

   pc_mpl, pc_uml: begin		{pc_mpl, pc_uml}
      if IsUnsigned(op^.left) and IsUnsigned(op^.right) then
         op^.opcode := pc_uml;
      if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin
         if op^.opcode = pc_mpl then
            op^.left^.lval := op^.left^.lval*op^.right^.lval
         else {if op^.opcode = pc_uml then}
            op^.left^.lval := umul(op^.left^.lval, op^.right^.lval);
         opv := op^.left;
         end {if}
      else begin
         if op^.left^.opcode = pc_ldc then
            ReverseChildren(op);
         if op^.right^.opcode = pc_ldc then begin
            lval := op^.right^.lval;
            if lval = 1 then
               opv := op^.left
            else if lval = 0 then begin
               if NoFunctions(op^.left) then
                  opv := op^.right;
               end {else if}
            else if (lval = -1) and (op^.opcode = pc_mpl) then begin
               op^.opcode := pc_ngl;
               op^.right := nil;
               end {else if}
            else if OneBit(lval) then begin
               op^.right^.lval := Base(lval);
               op^.opcode := pc_sll;
               end; {else if}
            end; {if}
         end; {else}
      end; {case pc_mpl, pc_uml}

   pc_mpr: begin			{pc_mpr}
      if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin
         op^.left^.rval := op^.left^.rval*op^.right^.rval;
         opv := op^.left;
         end {if}
      else begin
         if op^.left^.opcode = pc_ldc then
            ReverseChildren(op);
         if op^.right^.opcode = pc_ldc then begin
            rval := op^.right^.rval;
            if rval = 1.0 then
               opv := op^.left
            else if rval = 0.0 then
               if NoFunctions(op^.left) then
                  opv := op^.right;
            end; {if}
         end; {else}
      end; {case pc_mpr}

   pc_neq: begin			{pc_neq}
      if op^.optype = cgSet then
         if WordSet(op^.left) then begin
            if WordSet(op^.right) then begin
               MakeWordSet(op^.left);
               MakeWordSet(op^.right);
               op^.optype := cgUWord;
               end; {if}
            end {if}
         else if LongSet(op^.left) then
            if LongSet(op^.right) then begin
               MakeLongSet(op^.left);
               MakeLongSet(op^.right);
               op^.optype := cgULong;
               end; {if}
      if IsUnsigned(op^.left) and IsUnsigned(op^.right) then
         if op^.optype = cgWord then
            op^.optype := cgUWord
         else if op^.optype = cgLong then
            op^.optype := cgULong
         else if op^.optype = cgByte then
            op^.optype := cgUByte;
      if op^.left^.opcode = pc_ldc then
         ReverseChildren(op);
      if op^.right^.opcode = pc_ldc then begin
	 if op^.left^.opcode = pc_ldc then begin
            BinOps(op^.left, op^.right);
            case op^.left^.optype of
               cgByte,cgUByte,cgWord,cgUWord: begin
        	  op^.opcode := pc_ldc;
        	  op^.q := ord(op^.left^.q <> op^.right^.q);
        	  op^.left := nil;
        	  op^.right := nil;
        	  end;
               cgLong,cgULong: begin
        	  op^.opcode := pc_ldc;
        	  op^.q := ord(op^.left^.lval <> op^.right^.lval);
        	  op^.left := nil;
        	  op^.right := nil;
        	  end;
               cgReal,cgDouble,cgComp,cgExtended: begin
        	  op^.opcode := pc_ldc;
        	  op^.q := ord(op^.left^.rval <> op^.right^.rval);
        	  op^.left := nil;
        	  op^.right := nil;
        	  end;
               cgSet: begin
        	  op^.opcode := pc_ldc;
        	  op^.q := ord(not SetsEqual(op^.left^.setp, op^.right^.setp));
        	  op^.left := nil;
        	  op^.right := nil;
        	  end;
               cgVoid: begin
        	  op^.opcode := pc_ldc;
        	  op^.q := ord(op^.left^.pval <> op^.right^.pval);
        	  op^.left := nil;
        	  op^.right := nil;
        	  end;
               end; {case}
            op^.optype := cgUWord;
            end {if}
         else if op^.right^.optype in [cgByte, cgUByte, cgWord, cgUWord] then begin
            if op^.right^.q = 0 then
               if op^.left^.opcode in
         	  [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt]
                  then begin
                  opv := op^.left;
                  opv^.next := op^.next;
                  end; {if}
            end {else if}
         else if op^.right^.optype in [cgLong, cgULong] then begin
            if op^.right^.lval = 0 then
               if op^.left^.opcode in
         	  [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt]
                  then begin
                  opv := op^.left;
                  opv^.next := op^.next;
                  end; {if}
            end; {else if}
         end; {if}                      
      end; {case pc_neq}

   pc_ngi: begin			{pc_ngi}
      if op^.left^.opcode = pc_ldc then begin
         op^.left^.q := -op^.left^.q;
         op^.left^.optype := cgWord;
         opv := op^.left;
         end; {if}
      end; {case pc_ngi}

   pc_ngl: begin			{pc_ngl}
      if op^.left^.opcode = pc_ldc then begin
         op^.left^.lval := -op^.left^.lval;
         op^.left^.optype := cgLong;
         opv := op^.left;           
         end; {if}
      end; {case pc_ngl}

   pc_ngr: begin			{pc_ngr}
      if op^.left^.opcode = pc_ldc then begin
         op^.left^.rval := -op^.left^.rval;
         opv := op^.left;
         end; {if}
      end; {case pc_ngr}

   pc_not: begin			{pc_not}
      opcode := op^.left^.opcode;
      if opcode = pc_ldc then begin
         if op^.left^.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin
            op^.left^.q := ord(op^.left^.q = 0);
            opv := op^.left;
            end {if}
         else if op^.left^.optype in [cgLong,cgULong] then begin
            q := ord(op^.left^.lval = 0);
            lval := 0;
            op^.left^.q := q;
            op^.left^.optype := cgWord;
            opv := op^.left;
            end; {else if}
         end {if}
      else if opcode = pc_equ then begin
         op^.left^.opcode := pc_neq;
         opv := op^.left;
         end {else if}
      else if opcode = pc_neq then begin
         op^.left^.opcode := pc_equ;
         opv := op^.left;
         end {else if}
      else if opcode = pc_geq then begin
         if op^.left^.optype <> cgSet then begin
            op^.left^.opcode := pc_les;
            opv := op^.left;
            end; {if}
         end {else if}
      else if opcode = pc_grt then begin
         op^.left^.opcode := pc_leq;
         opv := op^.left;
         end {else if}
      else if opcode = pc_les then begin
         op^.left^.opcode := pc_geq;
         opv := op^.left;
         end {else if}
      else if opcode = pc_leq then begin
         if op^.left^.optype <> cgSet then begin
            op^.left^.opcode := pc_grt;
            opv := op^.left;
            end; {if}
         end; {else if}
      end; {case pc_not}

   pc_ret: begin			{pc_ret}
      RemoveDeadCode(op);
      end; {case pc_ret}

   pc_sbi: begin			{pc_sbi}
      if op^.left^.opcode = pc_ldc then begin
         if op^.right^.opcode = pc_ldc then begin
            op^.left^.q := op^.left^.q - op^.right^.q;
            opv := op^.left;
            end {if}
         else if op^.left^.q = 0 then begin
            op^.opcode := pc_ngi;
            op^.left := op^.right;
            op^.right := nil;
            end; {else if}
         end {if}
      else if op^.right^.opcode = pc_ldc then begin
         q := op^.right^.q;
         if q = 0 then
            opv := op^.left
         else if (q > 0) then begin
            op^.opcode := pc_dec;
            op^.q := q;
            op^.right := nil;
            end {else if}
         else {if q < 0) then} begin
            op^.opcode := pc_inc;
            op^.q := -q;
            op^.right := nil;
            end; {else if}
         end {if}
      else if op^.left^.opcode in [pc_inc,pc_dec] then
         if op^.right^.opcode in [pc_inc,pc_dec] then begin
            op2 := op^.left;
            if op^.left^.opcode = pc_inc then
               q := op^.left^.q
            else
               q := -op^.left^.q;
            if op^.right^.opcode = pc_inc then
               q := q - op^.right^.q
            else
               q := q + op^.right^.q;
            if q >= 0 then begin
               op2^.opcode := pc_inc;
               op2^.q := q;
               end {if}
            else begin
               op2^.opcode := pc_dec;
               op2^.q := -q;
               end; {else}
            op^.left := op^.left^.left;
            op^.right := op^.right^.left;
            op2^.left := op;
            opv := op2;
            PeepHoleOptimization(opv);
            end; {if}
      end; {case pc_sbi}

   pc_sbl: begin			{pc_sbl}
      if op^.left^.opcode = pc_ldc then begin
         if op^.right^.opcode = pc_ldc then begin
            op^.left^.lval := op^.left^.lval - op^.right^.lval;
            opv := op^.left;
            end {if}
         else if op^.left^.lval = 0 then begin
            op^.opcode := pc_ngl;
            op^.left := op^.right;
            op^.right := nil;
            end; {else if}
         end {if}
      else if op^.right^.opcode = pc_ldc then begin
         lval := op^.right^.lval;
         if lval = 0 then
            opv := op^.left
         else if (lval > 0) and (lval <= maxint) then begin
            op^.opcode := pc_dec;
            op^.q := ord(lval);
            op^.right := nil;
            op^.optype := cgLong;
            end {else if}
         else if (lval > -maxint) and (lval < 0) then begin
            op^.opcode := pc_inc;
            op^.q := -ord(lval);
            op^.right := nil;
            op^.optype := cgLong;
            end; {else if}       
         end; {if}
      end; {case pc_sbl}

   pc_sbr: begin			{pc_sbr}
      if op^.left^.opcode = pc_ldc then begin
         if op^.right^.opcode = pc_ldc then begin
            op^.left^.rval := op^.left^.rval - op^.right^.rval;
            opv := op^.left;
            end {if}
         else if op^.left^.rval = 0.0 then begin
            op^.opcode := pc_ngr;
            op^.left := op^.right;
            op^.right := nil;
            end; {else if}
         end {if}
      else if op^.right^.opcode = pc_ldc then begin
         if op^.right^.rval = 0.0 then
            opv := op^.left;
         end; {if}
      end; {case pc_sbr}

   pc_sgs: begin			{pc_sgs}
      if op^.left^.opcode = pc_ldc then
         if op^.right^.opcode = pc_ldc then begin
            set1 := pointer(Calloc(sizeof(setRecord)));
            q := op^.right^.q;
            if q = $8000 then
               q := op^.left^.q;
            set1^.smax := q div 8 + 1;
            for i := op^.left^.q to q do begin
               j := i div 8 + 1;
               set1^.sval[j] := chr(ord(set1^.sval[j]) | ($0001 << (i mod 8)));
               end; {for}
            op^.left := nil;
            op^.right := nil;
            op^.opcode := pc_ldc;
            op^.optype := cgSet;
            op^.setp := set1;
            end; {if}
      end; {case pc_sgs}

   pc_shl: begin			{pc_shl}
      if op^.right^.opcode = pc_ldc then begin
         opcode := op^.left^.opcode;
         if opcode = pc_shl then begin
            if op^.left^.right^.opcode = pc_ldc then begin
               op^.right^.q := op^.right^.q + op^.left^.right^.q;
               op^.left := op^.left^.left;
               end; {if}
            end {if}
         else if opcode = pc_inc then begin
            op2 := op^.left;
            op^.left := op2^.left;
            op2^.q := op2^.q << op^.right^.q;
            op2^.left := op;
            opv := op2;
            PeepHoleOptimization(op2^.left);
            end; {else if}
         end; {if}
      end; {case pc_shl}

   pc_shr:				{pc_shr}
      if IsUnsigned(op^.left) then
         op^.opcode := pc_usr;

   pc_slr:				{pc_slr}
      if IsUnsigned(op^.left) then
         op^.opcode := pc_vsr;

   pc_sro: begin			{pc_sro}
      if op^.optype in [cgReal,cgDouble,cgComp,cgExtended] then
         RealStoreOptimizations(op, op^.left)
      else if op^.optype = cgSet then begin
         if op^.q = 2 then begin
            if WordSet(op^.left) then begin
               MakeWordSet(op^.left);
               op^.q := op^.r;
               op^.r := 0;
               op^.optype := cgUWord;
               PeepHoleOptimization(opv);
               end; {if}
            end {if}
         else if op^.q = 4 then begin
            if LongSet(op^.left) then begin
               MakeLongSet(op^.left);
               op^.q := op^.r;
               op^.r := 0;
               op^.optype := cgULong;
               PeepHoleOptimization(opv);
               end; {if}
            end; {else if}
         end; {else if}
      end; {case pc_sro}

   pc_sto: begin			{pc_sto}
      if op^.optype in [cgReal,cgDouble,cgComp,cgExtended] then
         RealStoreOptimizations(op, op^.right);
      if op^.optype <> cgSet then begin
	 if op^.left^.opcode = pc_lao then begin
            op^.q := op^.left^.q;
            op^.lab := op^.left^.lab;
            op^.opcode := pc_sro;
            op^.left := op^.right;
            op^.right := nil;
            end {if}
	 else if op^.left^.opcode = pc_lda then begin
            op^.q := op^.left^.q;
            op^.r := op^.left^.s;
            op^.p := op^.left^.p;
            op^.opcode := pc_str;
            op^.left := op^.right;
            op^.right := nil;
            end; {if}
         end; {if}
      end; {case pc_sto}

   pc_str: begin			{pc_str}
      if op^.optype in [cgReal,cgDouble,cgComp,cgExtended] then
         RealStoreOptimizations(op, op^.left)
      else if op^.optype = cgSet then begin
         if op^.s = 2 then begin
            if WordSet(op^.left) then begin
               MakeWordSet(op^.left);
               op^.s := 0;
               op^.optype := cgUWord;
               PeepHoleOptimization(opv);
               end; {if}
            end {if}
         else if op^.s = 4 then begin
            if LongSet(op^.left) then begin
               MakeLongSet(op^.left);
               op^.s := 0;
               op^.optype := cgULong;
               PeepHoleOptimization(opv);
               end; {if}
            end; {else if}
         end; {else if}
      end; {case pc_str}

   pc_tjp: begin			{pc_tjp}
      opcode := op^.left^.opcode;
      if opcode = pc_ldc then begin
         if op^.left^.optype in [cgByte, cgUByte, cgWord, cgUWord] then
            if op^.left^.q = 0 then begin
               opv := op^.next;
               rescan := true;
               end {if}
            else begin
               op^.opcode := pc_ujp;
               op^.left := nil;
               PeepHoleOptimization(opv);
               end; {else}
         end {if}
      else if opcode = pc_ior then begin
         op2 := op^.left;
         op2^.next := op^.next;
         op^.next := op2;
         op^.left := op2^.left;
         op2^.left := op2^.right;
         op2^.right := nil;
         op2^.opcode := pc_tjp;
         op2^.q := op^.q;
         PeepHoleOptimization(opv);
         end {else if}
      else if opcode = pc_and then begin
         op2 := op^.left;
         op2^.next := op^.next;
         op^.next := op2;
         op^.left := op2^.left;
         op2^.left := op2^.right;
         op2^.right := nil;
         op2^.opcode := pc_tjp;
         op2^.q := op^.q;
         op^.opcode := pc_fjp;
         op3 := pointer(Calloc(sizeof(intermediate_code)));
         op3^.opcode := dc_lab;
         op3^.optype := cgWord;
         op3^.q := GenLabel;
         op3^.next := op2^.next;
         op2^.next := op3;
         op^.q := op3^.q;
         PeepHoleOptimization(opv);
         end {else if}
      else
         JumpOptimizations(op, pc_fjp);
      end; {case pc_tjp}

   pc_udi: begin			{pc_udi}
      if op^.right^.opcode = pc_ldc then begin
         q := op^.right^.q;
         if op^.left^.opcode = pc_ldc then begin
            if q <> 0 then begin
               op^.left^.q := ord(udiv(op^.left^.q & $0000FFFF, q & $0000FFFF));
               opv := op^.left;
               end; {if}
            end {if}
         else if q = 1 then
            opv := op^.left
         else if OneBit(q) then begin
            op^.right^.q := Base(q);
            op^.opcode := pc_usr;
            end; {else if}
         end; {if}
      end; {case pc_udi}

   pc_udl: begin			{pc_udl}
      if op^.right^.opcode = pc_ldc then begin
         lq := op^.right^.lval;
         if op^.left^.opcode = pc_ldc then begin
            if lq <> 0 then begin
               op^.left^.lval := udiv(op^.left^.lval, lq);
               opv := op^.left;
               end; {if}
            end {if}
         else if lq = 1 then
            opv := op^.left
         else if OneBit(lq) then begin
            op^.right^.lval := Base(lq);
            op^.opcode := pc_vsr;
            end; {else if}
         end; {if}
      end; {case pc_udl}

   pc_uim: begin			{pc_uim}
      if op^.right^.opcode = pc_ldc then 
         if op^.left^.opcode = pc_ldc then 
            if op^.right^.q <> 0 then begin
               op^.left^.q :=
                  ord(umod(op^.left^.q & $0000FFFF, op^.right^.q & $0000FFFF));
               opv := op^.left;
               end; {if}
      end; {case pc_uim}

   pc_ujp: begin			{pc_ujp}
      RemoveDeadCode(op);
      if op^.next^.opcode = dc_lab then begin
         if LabelsMatch(op, op^.next) then begin
            opv := op^.next;
            rescan := true;
            end {if}
         else if op^.next^.next^.opcode = dc_lab then
            if LabelsMatch(op^.next^.next, op) then begin
               opv := op^.next;
               rescan := true;
               end; {if}
         end; {if}
      end; {case pc_ujp}

   pc_ulm: begin			{pc_ulm}
      if op^.right^.opcode = pc_ldc then 
         if op^.left^.opcode = pc_ldc then 
            if op^.right^.lval <> 0 then begin
               op^.left^.lval := umod(op^.left^.lval, op^.right^.lval);
               opv := op^.left;
               end; {if}
      end; {case pc_ulm}

   pc_uni: begin			{pc_uni}
      if op^.left^.opcode = pc_ldc then
         if op^.right^.opcode = pc_ldc then begin
            if op^.left^.setp^.smax < op^.right^.setp^.smax then
               ReverseChildren(op);
            set1 := op^.left^.setp;
            set2 := op^.right^.setp;
            for i := 1 to set1^.smax do
               set1^.sval[i] := chr(ord(set1^.sval[i]) | ord(set2^.sval[i]));
            opv := op^.left;
            end; {if}
      end; {case pc_uni}

   otherwise: ;
   end; {case}
end; {PeepHoleOptimization}

{- Common Subexpression Elimination ----------------------------}

function MatchLoc (op1, op2: icptr): boolean;

{ See if two loads, stores or copies refer to the same		}
{ location							}
{								}
{ parameters:							}
{    op1, op2 - operations to check				}
{								}
{ Returns: True if they do, false if they don't.		}

begin {MatchLoc}
MatchLoc := false;
if (op1^.opcode in [pc_str,pc_cop,pc_lod,pc_lda])
   and (op2^.opcode in [pc_str,pc_cop,pc_lod,pc_lda]) then begin
   if op1^.r = op2^.r then
      MatchLoc := true;
   end {if}
else if (op1^.opcode in [pc_sro,pc_cpo,pc_ldo,pc_lao])
   and (op2^.opcode in [pc_sro,pc_cpo,pc_ldo,pc_lao]) then
   if op1^.lab^ = op2^.lab^ then
      MatchLoc := true;
end; {MatchLoc}                       


function Member (op: icptr; list: iclist): boolean;

{ See if the operand of a load is referenced in a list		}
{								}
{ parameters:							}
{    op - load to check						}
{    list - list to check					}
{								}
{ Returns: True if op is in list, else false.			}
{								}
{ Notes: As a side effect, this subroutine sets memberOp to	}
{    point to any matching member; memberOp is undefined if	}
{    there is no matching member.				}

begin {Member}
Member := false;
while list <> nil do begin
   if MatchLoc(op, list^.op) then begin
      Member := true;
      memberOp := list^.op;
      list := nil;
      end {if}
   else
      list := list^.next;
   end; {while}
end; {Member}


function TypeOf (op: icptr): baseTypeEnum;

{ find the type for the expression tree				}
{								}
{ parameters:							}
{    op - tree for which to find the type			}
{								}
{ Returns: base type						}

var
   q: integer;				{op^.q}

begin {TypeOf}
case op^.opcode of
   pc_ldc, pc_ldo, pc_lod, pc_dec, pc_inc, pc_ind, pc_cop, pc_cpo:
      TypeOf := op^.optype;

   pc_lad, pc_lao, pc_lca, pc_lda, pc_ixa, pc_abl, pc_udl, pc_ulm,
   pc_uml, pc_vsr, pc_sql:
      TypeOf := cgULong;

   pc_nop, pc_bnt, pc_ngi, pc_not, pc_adi, pc_and, pc_lnd, pc_bnd,
   pc_bor, pc_bxr, pc_dvi, pc_equ, pc_geq, pc_grt, pc_leq, pc_les,
   pc_neq, pc_ior, pc_lor, pc_mod, pc_mpi, pc_sbi, pc_shl, pc_shr,
   pc_rnd:
      TypeOf := cgWord;

   pc_udi, pc_uim, pc_umi, pc_usr, pc_sqi, pc_odd, pc_odl, pc_inn,
   pc_abi:
      TypeOf := cgUWord;
                         
   pc_bnl, pc_ngl, pc_adl, pc_bal, pc_blr, pc_blx, pc_dvl, pc_mdl,
   pc_mpl, pc_sbl, pc_sll, pc_slr, pc_rn4:
      TypeOf := cgLong;

   pc_ngr, pc_adr, pc_dvr, pc_mpr, pc_sbr, pc_abr, pc_sqr, pc_at2,
   pc_pwr, pc_sin, pc_cos, pc_exp, pc_sqt, pc_log, pc_atn, pc_tan,
   pc_acs, pc_asn:
      TypeOf := cgExtended;

   pc_sgs, pc_uni, pc_dif, pc_siz:
      TypeOf := cgSet;

   pc_cnn, pc_cnv:                                        
      TypeOf := baseTypeEnum(op^.q & $000F);

   pc_chk, pc_stk:
      TypeOf := TypeOf(op^.left);

   pc_bno:
      TypeOf := TypeOf(op^.right);

   pc_csp: begin
      q := op^.q;
      if q in [1..4,8..10,12..17,19,20..46,48..53,60,
         62,66..69,71..75,84..86,91..92,96..97,100..102,115] then
         TypeOf := cgVoid
      else if q in [5,7,58..59,70,80,87..89] then
         TypeOf := cgWord
      else if q in [6,61,79,82] then
         TypeOf := cgExtended
      else if q in [11,116] then
         TypeOf := cgULong
      else if q in [76,81,83,98..99] then
         TypeOf := cgLong
      else if q in [77..78,93] then
         TypeOf := cgString;
      end;

   otherwise: Error(cge1);       
   end; {case}
end; {TypeOf}

{$optimize  7}

procedure CommonSubexpressionElimination;

{ Remove common subexpressions					}

type
   localPtr = ^localRecord;		{list of local temp variables}
   localRecord = record
      next: localPtr;			{next label in list}
      inUse: boolean;			{is this temp already in use?}
      size: integer;			{size of the temp area}
      lab: integer;			{label number}
      end;

var
   bb: blockPtr;			{used to trace basic block lists}
   done: boolean;			{for loop termination tests}
   op: icptr;				{used to trace operation lists, trees}
   lop: icptr;				{predecessor of op}
   temps: localPtr;			{list of temp variables}


   procedure DisposeTemps;

   { dispose of the list of temp variables			}

   var
      tp: localPtr;			{temp pointer}

   begin {DisposeTemps}
   while temps <> nil do begin
      tp := temps;
      temps := tp^.next;
      dispose(tp);
      end; {while}
   end; {DisposeTemps}


   function GetTemp (bb: blockPtr; size: integer): integer;

   { Allocate a temp storage location				}
   {								}
   { parameters:						}
   {    bb - block in which the temp is allocated		}
   {    size - size of the temp					}
   {								}
   { Returns: local label number for the temp			}

   var
      ip: icptr;			{used to find insertion point for dc_loc}
      lab: integer;			{label number}
      loc: icptr;			{for dc_loc instruction}
      tp: localPtr;			{used to trace lists, allocate new items}

   begin {GetTemp}
   lab := 0;				{no label found, yet}
   tp := temps;				{try for a temp of the exact size}
   while tp <> nil do begin
      if not tp^.inUse then
         if tp^.size = size then begin
            lab := tp^.lab;
            tp^.inUse := true;
            tp := nil;
            end; {if}
      if tp <> nil then
         tp := tp^.next;
      end; {while}
   if lab = 0 then begin		{try for a larger temp}
      tp := temps;
      while tp <> nil do begin
	 if not tp^.inUse then
            if tp^.size > size then begin
               lab := tp^.lab;
               tp^.inUse := true;
               tp := nil;        
               end; {if}
	 if tp <> nil then
            tp := tp^.next;
	 end; {while}
      end; {if}
   if lab = 0 then begin		{allocate a new temp}
      loc := pointer(Calloc(sizeof(intermediate_code)));
      loc^.opcode := dc_loc;
      loc^.optype := cgWord;
      maxLoc := maxLoc + 1;
      loc^.r := maxLoc;
      lab := maxLoc;
      loc^.q := size;
      if bb^.code = nil then begin
	 loc^.next := nil;
	 bb^.code := loc;
         end {if}
      else begin
         ip := bb^.code;
         while ip^.next <> nil do
            ip := ip^.next;
	 loc^.next := nil;
	 ip^.next := loc;
         end; {else}
      new(tp);
      tp^.next := temps;
      temps := tp;
      tp^.inUse := true;
      tp^.size := loc^.q;
      tp^.lab := lab;
      end; {if}
   GetTemp := lab;			{return the temp label number}
   end; {GetTemp}


   procedure ResetTemps;

   { Mark all temps as available				}

   var
      tp: localPtr;			{temp pointer}

   begin {ResetTemps}
   tp := temps;
   while tp <> nil do begin
      tp^.inUse := false;
      tp := tp^.next;
      end; {while}
   end; {ResetTemps}


   procedure CheckForBlocks (op: icptr);

   { Scan a tree for blocked instructions			}
   {								}
   { parameters:						}
   {    op - tree to check					}
   {								}
   { Notes: Some code takes less time to execute than saving	}
   {    and storing the intermediate value.  This subroutine	}
   {    identifies such patterns.				}


      function Block (op: icptr): boolean;

      { See if the pattern should be blocked			}
      {								}
      { parameters:						}
      {    op - pattern to check				}
      {								}
      { Returns: True if the pattern should be blocked, else	}
      {    false.						}

      var
         opcode: pcodes;		{temp opcode}

      begin {Block}
      Block := false;
      opcode := op^.opcode;
      if opcode = pc_ixa then begin
         if op^.left^.opcode in [pc_lao,pc_lca,pc_lda] then
            Block := true;
         end {else if}
      else if opcode = pc_shl then begin
         if op^.right^.opcode = pc_ldc then
            if op^.right^.q = 1 then
               if op^.parents <= 3 then
                  Block := true;
         end {else if}
      else if opcode in [pc_stk, pc_siz] then
         Block := true
      else if opcode = pc_cnv then
         if op^.q & $000F = ord(cgVoid) then
            Block := true;
      end; {Block}


      function Max (a, b: integer): integer;

      { Return the larger of two integers			}
      {								}
      { parameters:						}
      {    a, b - integers to check				}
      {								}
      { Returns: a if a > b, else b				}

      begin {Max}
      if a > b then
         Max := a
      else
         Max := b;
      end; {Max}


   begin {CheckForBlocks}
   if Block(op) then begin
      if op^.left <> nil then		{handle a blocked instruction}
         op^.left^.parents := op^.left^.parents + Max(op^.parents - 1, 0);
      if op^.right <> nil then
         op^.right^.parents := op^.right^.parents + Max(op^.parents - 1, 0);
      op^.parents := 1;
      end; {if}
   if op^.left <> nil then		{check the children}
      CheckForBlocks(op^.left);
   if op^.right <> nil then
      CheckForBlocks(op^.right);
   end; {CheckForBlocks}


   procedure CheckTree (var op: icptr; bb: blockPtr);

   { check the trees used by op for common subexpressions	}
   {								}
   { parameters:						}
   {    op - operation to check					}
   {    bb - start of the current BASIC block			}

   var
      op2: icptr;			{result from Match calls}
      op3: icptr;			{used to trace the codes in a block}


      function Match (var op: icptr; tree: icptr): icptr;

      { Check for matches to op in tree				}
      {								}
      { parameters:						}
      {    op - operation to check				}
      {    tree - tree to examine for matches			}
      {								}
      { Returns: pointer to matching node or nil if none found	}

      var
         op2: icptr;			{result from recursive Match calls}
         kill, start, stop: boolean;	{used by Scan}
         skip: boolean;			{used to see if children should be scanned}


         procedure Combine (var op1, op2: icptr);

         { Op2 is a save or copy of the same value as op1; use a copy	}
         { for op2.							}
         {								}
         { parameters:							}
         {    op1 - first copy or save					}
         {    op2 - copy or save to optimize				}

         var
            op3: icptr;				{work pointer}

         begin {Combine}
         done := false;				{force another labeling pass}
	 op3 := op2;				{remove op2 from the list}
         if op3^.opcode in [pc_str,pc_sro] then begin
            if op3^.opcode = pc_str then
               op3^.opcode := pc_cop
            else
               op3^.opcode := pc_cpo;
            op2 := op3^.next;
            op3^.next := nil;
            end {if}
         else
            op2 := op3^.left;
         op1^.left := op3;			{place in the new location}
         end; {Combine}


         function SameTree (list, op1, op2: icptr): boolean;

         { Are op1 and op2 in the same expression tree?			}
         {								}
         { parameters:							}
         {    list - list of expression trees				}
         {    op1, op2 - operations to check				}


            function InTree (tree, op: icptr): boolean;

            { See if op is in the tree					}
            {								}
            { parameters:						}
            {    tree - expression tree to check			}
            {    op - operatio to look for				}

            begin {InTree}
            if tree = nil then
               InTree := false
            else if tree = op then
               InTree := true
            else
               InTree := InTree(tree^.left, op) or InTree(tree^.right, op);
            end; {InTree}


         begin {SameTree}
         SameTree := false;
         while list <> nil do
            if InTree(list, op1) then begin
               SameTree := InTree(list, op2);
               list := nil;
               end {if}
            else
               list := list^.next;
         end; {SameTree}


         procedure Scan (list, op1, op2: icptr);

         { Check to see if any operation between op1 and op2 kills the	}
         { optimization							}
         {								}
         { parameters:							}
         {    list - instruction stream					}
         {    op1 - starting operation					}
         {    op2 - ending operation					}
         {								}
         { globals:							}
         {    kill - set to true if the optimization must be blocked,	}
         {       or false if it can be performed			}
         {    start - has op1 been found?  (initialize to false)	}
         {    stop - has kill been set?	 (initialize to false)		}

         var
            done: boolean;			{loop termination test}

         begin {Scan}
         repeat
            done := true;
            if not start then			{see if it is time to start}
               if list = op1 then
        	  start := true;
            if list^.left <> nil then		{scan the children}
               Scan(list^.left, op1, op2);
            if not stop then
               if list^.right <> nil then
        	  Scan(list^.right, op1, op2);
            if start then			{check for a kill or termination}
               if not stop then
        	  if list = op2 then begin
        	     kill := false;
        	     stop := true;
        	     end {if}
        	  else if list^.opcode in [pc_str,pc_sro,pc_cop,pc_cpo]
                     then begin
        	     if MatchLoc(list, op2) then begin
                	kill := true;
                	stop := true;
                	end {if}
        	     end {else if}
        	  else if list^.opcode in [pc_sto,pc_cup,pc_cui,pc_tl1,pc_tl2,
                     pc_pds,pc_csp,pc_cum,pc_vct] then
        	     if Member(op1, c_ind) then begin
                	kill := true;
                	stop := true;
                	end; {if}
            if not stop then			{scan forward in the stream}
               if list^.next <> nil then begin
                  list := list^.next;
                  done := false;
                  end; {if}
         until done;
         end; {Scan}


      begin {Match}
      op2 := nil;			{check for an exact match}
      skip := false;
      if CodesMatch(op, tree, true) then begin
         if op = tree then
            op2 := tree
         else begin
            start := false;
            stop := false;
            Scan(bb^.code, tree, op);
            if not kill then
               op2 := tree;
            end; {else}
         end {if}
					{check for stores of a common value}
      else if op^.opcode in [pc_str,pc_sro,pc_cop,pc_cpo] then
         if tree^.opcode in [pc_str,pc_sro,pc_cop,pc_cpo] then
            if op^.left = tree^.left then begin
               start := false;
               stop := false;
               Scan(bb^.code, tree, op);
               if not kill then
                  if not SameTree(bb^.code, op, tree) then
                     if (op^.left^.opcode <> pc_ldc) or (op^.left^.q <> 0)
                        or (not (op^.left^.optype in [cgByte,cgUByte,cgWord,cgUWord]))
                        then begin
                        Combine(tree, op);
                        skip := true;
                        end; {if}
               end; {if}
      if not skip then begin		{check for matches in the children}
         if op2 = nil then
	    if tree^.left <> nil then
               op2 := Match(op, tree^.left);
         if op2 = nil then
            if tree^.right <> nil then
               op2 := Match(op, tree^.right);
         end; {if}
      Match := op2;
      end; {Match}


   begin {CheckTree}
   op^.parents := 0;			{zero the parent counter}
   if op^.left <> nil then		{check the children}
      CheckTree(op^.left, bb);
   if op^.right <> nil then
      CheckTree(op^.right, bb);
   if op^.next = nil then		{look for a match to the current code}
      if not (op^.opcode in
         [pc_cup,pc_cui,pc_cum,pc_tl1,pc_tl2,pc_vct,pc_csp,pc_pds,pc_bno]) then
         begin
	 op2 := nil;
	 op3 := bb^.code;
	 while (op2 = nil) and (op3 <> nil) do begin
	    op2 := Match(op, op3);
	    if op2 <> nil then
               if op2^.next = nil then begin
        	  op := op2;
        	  bb := nil;
        	  op3 := nil;
        	  end ;{if}
	    if op3 <> nil then
               op3 := op3^.next;
	    end; {while}
	 end; {if}
   end; {CheckTree}


   procedure CountParents (op: icptr);

   { increment the parent counter for all children of this node	}
   {								}
   { parameters:						}
   {    op - node for which to check the children		}

   begin {CountParents}
   if op^.parents = 0 then begin
      if op^.left <> nil then begin
	 CountParents(op^.left);
	 op^.left^.parents := op^.left^.parents + 1;
	 end; {if}
      if op^.right <> nil then begin
	 CountParents(op^.right);
	 op^.right^.parents := op^.right^.parents + 1;
	 end; {if}
      end; {if}
   end; {CountParents}


   procedure CreateTemps (var op: icptr; bb: blockPtr; var lop: icptr);

   { create temps for nodes with multiple parents		}
   {								}
   { parameters:						}
   {    op - node for which to create temps			}
   {    bb - current basic block				}
   {    lop - predecessor to op					}

   var
      children: boolean;		{does this node have children?}
      llab: integer;			{local label number; for temp}
      op2, str: icptr;			{new opcodes}
      optype: baseTypeEnum;		{type of the temp variable}

   begin {CreateTemps}
   children := false;			{create temps for the children}
   if op^.left <> nil then begin
      children := true;
      CreateTemps(op^.left, bb, lop);
      end; {if}
   if op^.right <> nil then begin
      children := true;
      CreateTemps(op^.right, bb, lop);
      end; {if}
   if children then
      if op^.parents > 1 then begin
         optype := TypeOf(op);		{create a temp label}
         llab := GetTemp(bb, TypeSize(optype));
					{make a copy of the duplicated tree}
         op2 := pointer(Calloc(sizeof(intermediate_code)));
         op2^ := op^;
         op^.opcode := pc_lod;		{substitute a load of the temp}
         op^.optype := optype;
         op^.parents := 1;
         op^.r := llab;
         op^.q := 0;
         op^.left := nil;
         op^.right := nil;
					{store the temp result}
         str := pointer(Calloc(sizeof(intermediate_code)));
         str^.opcode := pc_str;
         str^.optype := optype;
         str^.r := llab;
         str^.q := 0;
         str^.left := op2;
         if lop = nil then begin	{insert the store in the basic block}
            str^.next := bb^.code;
            bb^.code := str;
            end {if}
         else begin
            str^.next := lop^.next;
            lop^.next := str;
            end; {else}
         lop := str;
         end; {if}
   end; {CreateTemps}


begin {CommonSubexpressionElimination}
temps := nil;				{no temps allocated, yet}
repeat					{identify common parts}
   done := true;
   bb := DAGblocks;
   while bb <> nil do begin
      Spin;
      op := bb^.code;
      if op <> nil then begin
	 CheckTree(bb^.code, bb);
	 while op^.next <> nil do begin
            CheckTree(op^.next, bb);
            if op^.next <> nil then
	       op := op^.next;
	    end; {while}
	 end; {if}
      bb := bb^.next;
      end; {while}
until done;
bb := DAGblocks;			{count the number of parents}
while bb <> nil do begin
   op := bb^.code;
   Spin;
   while op <> nil do begin
      CountParents(op);
      op := op^.next;
      end; {while}
   bb := bb^.next;
   end; {while}
bb := DAGblocks;			{check for blocked instructions}
while bb <> nil do begin
   op := bb^.code;
   Spin;
   while op <> nil do begin
      CheckForBlocks(op);
      op := op^.next;
      end; {while}
   bb := bb^.next;
   end; {while}
bb := DAGblocks;			{create temps for common subexpressions}
while bb <> nil do begin
   op := bb^.code;
   lop := nil;
   ResetTemps;
   Spin;
   while op <> nil do begin
      if op^.opcode = pc_ent then
         DisposeTemps;
      CreateTemps(op, bb, lop);
      lop := op;
      op := op^.next;
      end; {while}
   bb := bb^.next;
   end; {while}
DisposeTemps;				{get rid of the temp variable list}
end; {CommonSubexpressionElimination}

{- Loop Optimizations ------------------------------------------}

procedure AddOperation (op: icptr; var lp: iclist);

{ Add an operation to an operation list				}
{								}
{ parameters:							}
{    op - operation to add					}
{    lp - list to add the operation to				}

var
   inList: boolean;			{is op already in the list?}
   llp: iclist;				{work pointer}

begin {AddOperation}
llp := lp;
inList := false;
while llp <> nil do
   if MatchLoc(llp^.op, op) then begin
      inList := true;
      llp := nil;
      end {if}
   else
      llp := llp^.next;
if not inList then begin
   new(llp);
   llp^.next := lp;
   lp := llp;
   llp^.op := op;
   end; {if}
end; {AddOperation}


procedure DisposeBlkList (var blk: blockListPtr);

{ dispose of all entries in the block list			}
{								}
{ parameters:							}
{    blk - list of blocks to dispose of				}

var
   bk1, bk2: blockListPtr;		{work pointers}

begin {DisposeBlkList}
bk1 := blk;
blk := nil;
while bk1 <> nil do begin
   bk2 := bk1;
   bk1 := bk2^.next;
   dispose(bk2);
   end; {while}
end; {DisposeBlkList}


procedure DisposeOpList (var oplist: iclist);

{ dispose of all entries in the list				}
{								}
{ parameters:							}
{    oplist - operation list to dispose of			}

var
   op1, op2: iclist;			{work pointers}

begin {DisposeOpList}
op1 := oplist;
oplist := nil;
while op1 <> nil do begin
   op2 := op1;
   op1 := op2^.next;
   dispose(op2);
   end; {while}
end; {DisposeOpList}


procedure DumpLoopLists;

{ dispose of lists created by ReachingDefinitions and Dominators}

var
   bb: blockPtr;			{used to trace basic block list}
   dom: blockListPtr;			{used to dispose of a dominator}
   
begin {DumpLoopLists}
bb := DAGBlocks;
while bb <> nil do begin
   DisposeOpList(bb^.c_in);		{dump the reaching definition lists}
   DisposeOpList(bb^.c_out);
   DisposeOpList(bb^.c_gen);
   DisposeBlkList(bb^.dom);
   while bb^.dom <> nil do begin	{dump the dominator lists}
      dom := bb^.dom;
      bb^.dom := dom^.next;
      dispose(dom);
      end; {while}
   bb := bb^.next;
   end; {while}
end; {DumpLoopLists}


procedure AddLoads (jp: icptr; var lp: iclist);

{ Add any load addresses from the children of this		}
{ operation							}
{								}
{ parameters:							}
{    jp - operation to check					}
{    lp - list to add the loads to				}

begin {AddLoads}
if jp^.opcode in [pc_lda,pc_lao,pc_lod,pc_lod] then
   AddOperation(jp, lp)
else begin
   if jp^.left <> nil then
      AddLoads(jp^.left, lp);
   if jp^.right <> nil then
      AddLoads(jp^.right, lp);
   end {else}
end; {AddLoads}


procedure FlagIndirectUses;

{ Find all variables that could be changed by an indirect	}
{ access.							}

var
   bb: blockPtr;			{used to trace block list}


   procedure Check (op: icptr; doingInd: boolean);

   { Check op and its children & followers for dangerous	}
   { references							}
   {								}
   { parameters:						}
   {    op - operation to check					}
   {    doingInd - are we doing a pc_ind?  If so, pc_lda's	}
   {       are safe						}

   var
      lDoingInd: boolean;		{local doingInd}

   begin {Check}
   while op <> nil do begin
      if op^.opcode = pc_ind then
         lDoingInd := true
      else
         lDoingInd := doingInd;
      if op^.left <> nil then
         Check(op^.left, lDoingInd);
      if op^.right <> nil then
         Check(op^.right, lDoingInd);
      if op^.opcode in [pc_lao,pc_cpo,pc_ldo,pc_sro] then
         AddOperation(op, c_ind)
      else if op^.opcode = pc_ind then begin
         if op^.left^.opcode = pc_ind then
            AddLoads(op^.left^.left, c_ind);
         end {else if}
      else if op^.opcode = pc_csp then begin
         if op^.q = 1{get} then
            AddLoads(op^.left, c_ind);
         end {else if}
      else if op^.opcode = pc_sto then
         AddLoads(op^.left, c_ind)
      else if op^.opcode = pc_lda then
         if not doingInd then
            AddOperation(op, c_ind);
      op := op^.next;
      end; {while}
   end; {Check}


begin {FlagIndirectUses}
c_ind := nil;
bb := DAGBlocks;
while bb <> nil do begin
   Check(bb^.code, false);
   bb := bb^.next;
   end; {while}
end; {FlagIndirectUses}


procedure DoLoopOptimization;

{ Perform optimizations related to loops and data flow		}

type
   dftptr = ^dftrecord;			{depth first tree edges}
   dftrecord = record
      next: dftptr;
      from, dest: blockPtr;
      end;

var
   backEdge: dftptr;			{list of back edges}
   dft: dftptr;				{depth first tree}
   dft2: dftptr;			{work pointer}


   function DFN (i: integer): blockPtr;

   { find the basic block with dfn index of i			}
   {								}
   { parameters:						}
   {    i - index to look for					}
   {								}
   { Returns: block pointer, or nil if there is none		}

   var
      bb: blockPtr;			{used to trace block list}

   begin {DFN}
   bb := DAGBlocks;
   DFN := nil;
   while bb <> nil do begin
      if bb^.dfn = i then begin
         DFN := bb;
         bb := nil;
         end
      else
         bb := bb^.next;
      end; {while}
   end; {DFN}


   function MemberDFNList (dfn: integer; bl: blockListPtr): boolean;

   { See if dfn is a member of the list bl			}
   {								}
   { parameters:						}
   {    dfn - block number to check				}
   {    bl - list of block numbers to check			}
   {								}
   { Returns: True if dfn is in bl, else false.			}

   begin {MemberDFNList}
   MemberDFNList := false;
   while bl <> nil do
      if bl^.dfn = dfn then begin
         MemberDFNList := true;
         bl := nil;
         end {if}
      else
         bl := bl^.next;
   end; {MemberDFNList}


   function FindDAG (op: icptr): blockPtr;

   { Find the DAG containing label for op			}
   {								}
   { parameters:						}
   {    op - instruction with a label				}
   {								}
   { Returns: pointer to the proper basic block			}

   var
      bb: blockPtr;			{used to trace basic block list}

   begin {FindDAG}
   bb := DAGBlocks;
   FindDAG := nil;
   while bb <> nil do begin
      if bb^.code^.opcode = dc_lab then
         if LabelsMatch(bb^.code, op) then begin
            FindDAG := bb;
            bb := nil;
            end; {if}
      if bb <> nil then
         bb := bb^.next;
      end; {while}
   end; {FindDAG}


   procedure DepthFirstOrder;

   { Number the DAG for depth first order			}

   var
      bb: blockPtr;			{used to trace basic block lists}
      i: integer;			{dfn index}


      procedure Search (bb: blockPtr);

      { Search this block					}
      {								}
      { parameters:						}
      {    bb - basic block to search				}

      var
         blk: blockPtr;			{work block}
         ndft: dftptr;			{for new tree entries}
         op: icptr;			{used to trace operation list}


         function NotUnconditional: boolean;

         { See if the block ends with something other than an	}
         { unconditional jump					}
         {							}
         { Returns: True if the block ends with something other	}
         {    than pc_ujp or pc_add, else false			}

         var
            op: icptr;			{used to trace the list}

         begin {NotUnconditional}
         NotUnconditional := true;
         op := bb^.code;
         if op <> nil then begin
            while op^.next <> nil do
               op := op^.next;
            if op^.opcode in [pc_add,pc_ujp] then
               NotUnconditional := false;
            end; {if}
         end; {NotUnconditional}


      begin {Search}
      Spin;
      if bb <> nil then
	 if not bb^.visited then begin
	    bb^.visited := true;
            if NotUnconditional then
               if bb^.next <> nil then begin
                  new(ndft);
                  ndft^.next := dft;
                  dft := ndft;
                  ndft^.from := bb;
                  ndft^.dest := bb^.next;
                  Search(bb^.next);
                  end; {if}
	    op := bb^.code;
	    while op <> nil do begin
               if op^.opcode in [pc_ujp, pc_fjp, pc_tjp, pc_add] then begin
                  blk := FindDAG(op);
                  new(ndft);
                  if blk^.visited then begin
                     ndft^.next := backEdge;                        
                     backEdge := ndft;
                     end {if}
                  else begin
                     ndft^.next := dft;
                     dft := ndft;
        	     Search(blk);
                     end; {else}
                  ndft^.from := bb;
                  ndft^.dest := blk;
                  end; {if}
               op := op^.next;
               end; {while}
            bb^.dfn := i;
            i := i-1;
            end; {if}
      end; {Search}


   begin {DepthFirstOrder}
   dft := nil;
   backEdge := nil;
   i := 0;
   bb := DAGblocks;
   while bb <> nil do begin
      bb^.visited := false;
      i := i+1;
      bb := bb^.next;
      end; {while}
   Search(DAGBlocks);
   end; {DepthFirstOrder}


   procedure Dominators;

   { Find a list of dominators for each node			}

   var
      bb: blockPtr;			{used to trace the block list}
      change: boolean;			{for loop termination test}
      i, j: integer;			{loop variables}
      maxdfn, mindfn: integer;		{max and min dfn values used}


      procedure Add (var dom: blockListPtr; dfn: integer);

      { Add dfn to the list of dominators			}
      {								}
      { parameters:						}
      {    dom - dominator list					}
      {    dfn - new dominator number				}

      var
         dp: blockListPtr;		{new node}

      begin {Add}
      new(dp);
      dp^.last := nil;
      dp^.next := dom;
      dom^.last := dp;
      dom := dp;
      dp^.dfn := dfn;
      end; {Add}


      procedure CheckPredecessors (bb: blockPtr; bl: dftptr);

      { Eliminate nodes that don't dominate a predecessor	}
      {								}
      { parameters:						}
      {    bb - block being checked				}
      {    bl - list of edges to check for predecessors		}

      var
         dp: blockListPtr;		{list of dominator numbers}
         tdp: blockListPtr;		{used to remove a dominator entry}

      begin {CheckPredecessors}
      while bl <> nil do begin
         if bl^.dest = bb then begin
            dp := bb^.dom;
            while dp <> nil do
               if dp^.dfn <> bb^.dfn then
                  if not MemberDFNList(dp^.dfn, bl^.from^.dom) then begin
                     change := true;
                     tdp := dp;
                     if tdp^.last = nil then
                        bb^.dom := tdp^.next
                     else
                        tdp^.last^.next := tdp^.next;
                     if tdp^.next <> nil then
                        tdp^.next^.last := tdp^.last;
                     dp := tdp^.next;
                     dispose(tdp);
                     end {if}
                  else
                     dp := dp^.next
               else
                  dp := dp^.next;
            end; {if}
         bl := bl^.next;
         end; {while}
      end; {CheckPredecessors}


   begin {Dominators}
   Spin;
   maxdfn := 0;				{find the largest dfn}
   bb := DAGBlocks;
   while bb <> nil do begin
      if bb^.dfn > maxdfn then
         maxdfn := bb^.dfn;
      bb := bb^.next;
      end; {while}
   Add(DAGBlocks^.dom, DAGBlocks^.dfn);	{the first node is it's own dominator}
   mindfn := DAGBlocks^.dfn;		{assume all other nodes are dominated by every other node}
   for i := mindfn+1 to maxdfn do begin
      bb := DFN(i);
      if bb <> nil then
         for j := mindfn to maxdfn do
            Add(bb^.dom, j);
      end; {for}
   repeat				{iterate to the true set of dominators}
      change := false;
      for i := mindfn+1 to maxdfn do begin
         bb := DFN(i);
         CheckPredecessors(bb, dft);
         CheckPredecessors(bb, backEdge);
         end; {for}
   until not change;
   end; {Dominators}


   procedure ReachingDefinitions;

   { find the list of reaching definitions for each basic block	}

   var
      bb: blockPtr;			{block being scanned}
      change: boolean;			{loop termination test}
      i: integer;			{node index number}
      newIn: iclist;			{list of inputs}


      function Gen (op: icptr): iclist;

      { find a list of generated values				}
      {								}
      { parameters:						}
      {    op - list of intermediate codes to scan		}
      {								}
      { Returns: list of generated definitions			}

      var
         gp: iclist;			{list of generated definitions}
         indFound: boolean;		{has an indirect store been found?}


         procedure Check (ip: icptr);

         { Add any result from ip to gp				}
         {							}
         { parameters:						}
         {    ip - instruction to check				}

         var
            lc_ind: iclist;		{used to trace the c_ind list}

         begin {Check}
         if ip^.left <> nil then
            Check(ip^.left);
         if ip^.right <> nil then
            Check(ip^.right);
         if ip^.opcode in
            [pc_str,pc_sro,pc_cop,pc_cpo] then
            AddOperation(ip, gp)
         else if ip^.opcode in [pc_mov,pc_sto] then
            AddLoads(ip, gp);
         if not indFound then
            if ip^.opcode in [pc_sto,pc_cup,pc_cui,pc_tl1,
                pc_tl2,pc_vct,pc_csp,pc_pds,pc_cum] then begin
               lc_ind := c_ind;
               while lc_ind <> nil do begin
                  AddOperation(lc_ind^.op, gp);
                  lc_ind := lc_ind^.next;
                  end; {while}
               indFound := true;
               end; {if}
         end; {Check}                                         


      begin {Gen}
      indFound := false;
      gp := nil;
      while op <> nil do begin
         Check(op);
         op := op^.next;
         end; {while}
      Gen := gp;
      end; {Gen}


      function EqualSets (l1, l2: iclist): boolean;

      { See if two sets of stores and copies are equivalent	}
      {								}
      { parameters:						}
      {    l1, l2 - lists of copies and stores			}
      {								}
      { Returns: True if the lists are equivalent, else false	}
      {								}
      { Notes: The members of each list are assumed to be	}
      {    unique within that list.				}

      var
         c1, c2: integer;		{number of elements in the sets}
         l3: iclist;			{used to trace the lists}
         matchFound: boolean;		{was a match found?}

      begin {EqualSets}
      EqualSets := false;		{assume they are not equal}
      c1 := 0;				{count the elements of l1}
      l3 := l1;
      while l3 <> nil do begin
         c1 := c1+1;
         l3 := l3^.next;
         end; {while}
      c2 := 0;				{count the elements of l2}
      l3 := l2;
      while l3 <> nil do begin
         c2 := c2+1;
         l3 := l3^.next;
         end; {while}
      if c1 = c2 then begin		{make sure each member of l1 is in l2}
         EqualSets := true;
         while l1 <> nil do begin
            matchFound := false;
            l3 := l2;
            while l3 <> nil do begin
               if MatchLoc(l1^.op, l3^.op) then begin
                  l3 := nil;
                  matchFound := true;
                  end {if}
               else
                  l3 := l3^.next;
               end; {while}
            if not matchFound then begin
               EqualSets := false;
               l1 := nil;
               end {if}
            else
               l1 := l1^.next;
            end; {while}
         end; {if}
      end; {EqualSets}


      function Union (l1, l2: iclist): iclist;

      { Returns a list that is the union of two input lists	}
      {								}
      { parameters:						}
      {    l1, l2 - lists					}
      {								}
      { Returns: New, dynamically allocated list that includes	}
      {    all of the members in l1 and l2.			}
      {								}
      { Notes:							}
      {    1.  If there are duplicates, the member from l1 is	}
      {        returned.					}
      {    2.  It is assumed that all members of l1 and l2 are	}
      {        unique within their own list.			}
      {    3.  The original lists are not disturbed.		}
      {    4.  The caller is responsible for disposing of the	}
      {        memory used by the list.				}

      var
         lp: iclist;			{new list pointer}
         np: iclist;			{new list member pointer}
         tp: iclist;			{temp list pointer}

      begin {Union}
      lp := nil;
      tp := l1;
      while tp <> nil do begin
         new(np);
         np^.next := lp;
         lp := np;
         np^.op := tp^.op;
         tp := tp^.next;
         end; {while}
      while l2 <> nil do begin
         if not Member(l2^.op, l1) then begin
            new(np);
            np^.next := lp;
            lp := np;
            np^.op := l2^.op;
            end; {if}
         l2 := l2^.next;
         end; {while}
      Union := lp;
      end; {Union}


      function UnionOfPredecessors (bptr: blockPtr): iclist;

      { create a union of the outputs of predecessors to bptr	}
      {								}
      { parameters:						}
      {    bptr - block for which to look for predecessors	}
      {								}
      { Returns: Resulting set					}

      var
         bp: dftptr;			{used to trace edge lists}
         plist: iclist;			{result list}
         tlist: iclist;			{temp result list}

      begin {UnionOfPredecessors}
      plist := nil;
      bp := dft;
      while bp <> nil do begin
         if bp^.dest = bptr then begin
            tlist := Union(plist, bp^.from^.c_out);
            DisposeOpList(plist);
            plist := tlist;
            end; {if}
         bp := bp^.next;
         end; {while}
      bp := backEdge;
      while bp <> nil do begin
         if bp^.dest = bptr then begin
            tlist := Union(plist, bp^.from^.c_out);
            DisposeOpList(plist);
            plist := tlist;
            end; {if}
         bp := bp^.next;
         end; {while}
      UnionOfPredecessors := plist;
      end; {UnionOfPredecessors}


   begin {ReachingDefinitions}
   i := 1;				{initialize the lists}
   repeat
      bb := DFN(i);
      if bb <> nil then begin
         bb^.c_in := nil;
         bb^.c_gen := Gen(bb^.code);
         bb^.c_out := Union(nil, bb^.c_gen);
         end; {if}
      i := i+1;
   until bb = nil;
   repeat				{iterate to a solution}
      change := false;
      i := 1;
      repeat
	 Spin;
         bb := DFN(i);
         if bb <> nil then begin
            newIn := UnionOfPredecessors(bb);
            if not EqualSets(bb^.c_in, newIn) then begin
               {IN[n] := newIn}
               DisposeOpList(bb^.c_in);
               bb^.c_in := newIn;
               newIn := nil;
               {OUT[n] := IN[n] - KILL[n] U GEN[n]}
               DisposeOpList(bb^.c_out);
               bb^.c_out := Union(bb^.c_in, nil);
               change := true;
               end; {if}
            DisposeOpList(newIn);
            end; {if}
         i := i+1;
      until bb = nil;
   until not change;
   end; {ReachingDefinitions}


   procedure LoopInvariantRemoval;

   { Remove all loop invariant computations			}

   type
      loopPtr = ^loopRecord;		{blocks in a list}
      loopRecord = record
	 next: loopPtr;			{next entry}
	 block: blockPtr;		{code block}
         exit: boolean;			{is this a loop exit?}
	 end;

      loopListPtr = ^loopListRecord;	{list of loop lists}
      loopListRecord = record
	 next: loopListPtr;
	 loop: loopPtr;
	 end;

   var
      icount: integer;			{order invariant found}
      loops: loopListPtr;		{list of loops}
      lp: loopPtr;			{used to trace loop lists}
      llp: loopListPtr;			{used to trace the list of loops}



      procedure FindLoops;

      { Create a list of the natural loops			}

      var
         blk: blockPtr;			{target block for a jump}
	 bp: dftptr;			{used to trace the back edges}
         lp, lp2: loopPtr;		{used to reverse the list}
	 llp: loopListPtr;		{loop list header entry}
	 llp2: loopListPtr;		{used to reverse the list}
         op: icptr;			{used to trace the opcode list}


	 procedure Add (block: blockPtr);

	 { Add a block to the current loop list				}
	 {								}
	 { parameters:							}
	 {    block - block to add					}

	 var
            lp: loopPtr;			{new loop entry}

	 begin {Add}
	 new(lp);
	 lp^.next := llp^.loop;
	 llp^.loop := lp;
	 lp^.block := block;
         lp^.exit := false;
	 end; {Add}


         function InLoop (blk: blockPtr; lp: loopPtr): boolean;

         { See if the block is in the loop				}
         {								}
         { parameters:							}
         {    blk - block to check for					}
         {    lp - loop list						}
         {								}
         { Returns: True if blk is in the list, else false		}

         begin {InLoop}
         InLoop := false;
         while lp <> nil do begin
            if lp^.block = blk then begin
               lp := nil;
               InLoop := true;
               end {if}
            else
               lp := lp^.next;
            end; {while}
         end; {InLoop}


	 procedure Insert (block: blockPtr);

	 { Insert a block into the loop list				}
	 {								}
	 { parameters:							}
	 {    block - block to add					}


            procedure AddPredecessors (block: blockPtr; bl: dftptr);

            { add any predecessors to the loop				}
            {								}
            { parameters:						}
            {    block - block for which to check for			}
            {       predecessors					}
            {    bl - list of edges to check				}

            begin {AddPredecessors}
            while bl <> nil do begin
               if bl^.dest = block then
        	  Insert(bl^.from);
               bl := bl^.next;
               end; {while}
            end; {AddPredecessors}


            function InLoop (block: blockPtr; lp: loopPtr): boolean;

            { See if a block is in the loop				}
            {								}
            { parameters:						}
            {    block - block to check					}
            {    lp - list of blocks in the loop			}
            {								}
            { Returns: True if the block is in the loop, else false	}

            begin {InLoop}
            InLoop := false;
            while lp <> nil do
               if lp^.block = block then begin
        	  InLoop := true;
        	  lp := nil;
        	  end {if}
               else
        	  lp := lp^.next;
            end; {InLoop}


	 begin {Insert}
	 if not InLoop(block, llp^.loop) then begin
            Add(block);
            AddPredecessors(block, dft);
            AddPredecessors(block, backEdge);
            end; {if}
	 end; {Insert}


      begin {FindLoops}
      loops := nil;
      bp := backEdge;			{scan the back edges}
      while bp <> nil do begin
	 if MemberDFNList(bp^.dest^.dfn, bp^.from^.dom) then begin
            new(llp);			{create a new loop list entry}
            llp^.next := loops;
            loops := llp;
            llp^.loop := nil;
            Add(bp^.dest);
            Insert(bp^.from);
            lp := llp^.loop;		{reverse the list}
            llp^.loop := nil;
            while lp <> nil do begin
               lp2 := lp;
               lp := lp2^.next;
               lp2^.next := llp^.loop;
               llp^.loop := lp2;
               end; {while}
            lp := llp^.loop;		{mark the exits}
            while lp <> nil do begin
               op := lp^.block^.code;
               while op <> nil do begin
        	  if op^.opcode in [pc_ujp, pc_fjp, pc_tjp, pc_add] then begin
                     blk := FindDAG(op);
                     if not InLoop(blk, llp^.loop) then
                        lp^.exit := true;
                     if op^.opcode in [pc_fjp,pc_tjp] then
                        if not InLoop(lp^.block^.next, llp^.loop) then
                           lp^.exit := true;
                     end; {if}
                  op := op^.next;                        
                  end; {while}
               lp := lp^.next;
               end; {while}
            end; {if}
	 bp := bp^.next;
	 end; {while}
      llp := loops;			{reverse the loop list}
      loops := nil;
      while llp <> nil do begin
	 llp2 := llp;
	 llp := llp2^.next;
	 llp2^.next := loops;
	 loops := llp2;
	 end; {while}
      end; {FindLoops}


      function MarkInvariants (lp: loopPtr): boolean;

      { Make a pass over the opcodes, marking those that are	}
      { invariant.						}
      {								}
      { parameters:						}
      {    lp - loop to scan					}
      {								}
      { Returns: True if any new nodes were marked, else false.	}

      var
         count: integer;		{number of generating blocks}
         indirectStores: boolean;	{does the loop contain indirect stores or function calls?}
         inhibit: boolean;		{inhibit stores?}
         lp2: loopPtr;			{used to trace the loop}
         op: icptr;			{used to trace the instruction list}
         opcode: pcodes;		{op^.opcode; for efficiency}


         procedure Check (op: icptr; olp: loopPtr);

         { See if this node or its children is invariant		}
         {								}
         { parameters:							}
         {    op - node to check					}
         {    olp - loop entry for the block containing the store	}

         var
            invariant: boolean;		{are the operands invariant?}


            function IndirectInhibit (op: icptr): boolean;

            { See if a store should be inhibited due to indirect	}
            { accesses							}
            {								}
            { parameters:						}
            {    op - instruction to check				}
            {								}
            { Returns: True if the instruction should be inhibited,	}
            {    else false.						}

            begin {IndirectInhibit}
            IndirectInhibit := false;
            if indirectStores then
               if Member(op, c_ind) then
                  IndirectInhibit := true;
            end; {IndirectInhibit}


            function NoOtherStoresOrUses (lp, olp: loopPtr; op: icptr): boolean;

            { Check for invalid stores					}
            {								}
            { parameters:						}
            {    lp - loop to check					}
            {    olp - loop entry for the block containing the store	}
            {    op - store to check					}
            {								}
            { Returns: True if the store is valid, false if not.	}
            {								}
            { Notes: Specifically, these two rules are inforced:	}
            {    1. No other stores to the same location appear in the	}
            {       loop.						}
            {    2. All uses of the value in the loop can be reached	}
            {       only by the assign.					}

            var
               lp2: loopPtr;			{used to trace the loop list}
               op2: icptr;			{used to trace code list}


               function SafeLoad (sop, lop: icptr; sbk, lbk: blockPtr): boolean;

               { See if a load is in a safe position			}
               {							}
               { parameters:						}
               {    sop - save opcode that may need to be left in loop	}
               {    lop - load operation that may inhibit the save	}
               {    sbk - block containing the save			}
               {    lbk - block containing the load			}


                  function First (op1, op2, stream: icptr): icptr;

                  { See which operation comes first				}
                  {								}
                  { parmeters:							}
                  {    op1, op2 - instructions to check				}
                  {    stream - start of block containing the instructions	}
                  {								}
                  { Returns: First operation found, or nil if missing		}

                  var
                     op: icptr;				{temp opcode}

                  begin {First}
                  if stream = op1 then
                     First := op1
                  else if stream = op2 then
                     First := op2
                  else begin
                     op := nil;
                     if stream^.left <> nil then
                        op := First(op1, op2, stream^.left);
                     if op = nil then
                        if stream^.right <> nil then
                           op := First(op1, op2, stream^.right);
                     if op = nil then
                        if stream^.next <> nil then
                           op := First(op1, op2, stream^.next);
                     First := op;
                     end; {else}     
                  end; {First}


               begin {SafeLoad}
               if sbk = lbk then
                  SafeLoad := First(sop, lop, sbk^.code) = sop
               else
                  SafeLoad := MemberDFNList(sbk^.dfn, lbk^.dom);
               end; {SafeLoad}


               function MatchStores (op, tree: icptr; opbk, treebk: blockPtr):
                  boolean;

               { Check the tree for stores to the same location as op	}
               {							}
               { parameters:						}
               {    op - store to check for				}
               {    tree - operation tree to check			}
               {    opbk - block containing op				}
               {    treebk - block containing tree			}
               {							}
               { Returns: True if there are matching stores, else false	}

               var
                  result: boolean;		{function result}

               begin {MatchStores}
               result := false;
               if tree^.opcode in [pc_str,pc_cop,pc_sro,pc_cpo] then begin
                  if tree <> op then 
                     result := MatchLoc(op, tree);
                  end {if}
               else if tree^.opcode in [pc_ldo,pc_lod] then
                  if MatchLoc(op, tree) then
                     result := not SafeLoad(op, tree, opbk, treebk);
               if not result then
                  if tree^.left <> nil then
                     result := MatchStores(op, tree^.left, opbk, treebk);
               if not result then
                  if tree^.right <> nil then
                     result := MatchStores(op, tree^.right, opbk, treebk);
               MatchStores := result;
               end; {MatchStores}


            begin {NoOtherStoresOrUses}
            NoOtherStoresOrUses := true;
            lp2 := lp;
            while lp2 <> nil do begin
               op2 := lp2^.block^.code;
               while op2 <> nil do
                  if MatchStores(op, op2, olp^.block, lp2^.block) then begin
                     op2 := nil;
                     lp2 := nil;
                     NoOtherStoresOrUses := false;
                     end {if}
                  else
                     op2 := op2^.next;
               if lp2 <> nil then
                  lp2 := lp2^.next;
               end; {while}
            end; {NoOtherStoresOrUses}


            function NumberOfGens (op: icptr; lp: loopPtr): integer;

            { Count the number of nodes that generate op		}
            {								}
            { parameters:						}
            {    op - instruction to check				}
            {    lp - loop to check					}

            var
               count: integer;			{number of generators}

            begin {NumberOfGens}
            count := 0;
            while lp <> nil do begin
               if Member(op, lp^.block^.c_gen) then
                  count := count+1;
               lp := lp^.next;
               end; {while}
            NumberOfGens := count;
            end; {NumberOfGens}


            function PreviousStore (op, list: icptr): boolean;

            { See if the last save was invariant			}
            {								}
            { parameters:						}
            {    op - load operation					}
            {    list - block containing the load			}
            {								}
            { Returns: True if the previous store was invariant, else	}
            {    false.							}

            var
               indop: icptr;			{any indirect operation after strop}
               strop: icptr;			{last matching store before op}


               procedure Check (lop: icptr);

               { Stop if this is lop; save if it is a matching store	}
               {							}
               { parameters:						}
               {    lop - check this operation and it's children	}

               begin {Check}
               if lop^.left <> nil then
                  Check(lop^.left);
               if list <> nil then
                  if lop^.right <> nil then
                     Check(lop^.right);
               if list <> nil then
                  if lop = op then
                     list := nil
                  else if (lop^.opcode in [pc_str,pc_cop])
                     and MatchLoc(op, lop) then begin
                     strop := lop;
                     indop := nil;
                     end {else if}
                  else if op^.opcode in [pc_sto,pc_cup,
                      pc_cui,pc_tl1,pc_tl2,pc_vct,pc_pds,pc_csp,pc_cum] then
                     indop := op;
               end; {Check}


               function Inhibit (indop, op: icptr): boolean;

               { See if op should be inhibited due to indirect stores	}
               {							}
               { parameters:						}
               {    indop - inhibiting indirect store or nil		}
               {    op - instruction to check				}

               begin {Inhibit}
               Inhibit := false;
               if indop <> nil then
                  if Member(op, c_ind) then
                     Inhibit := true;
               end; {Inhibit}


            begin {PreviousStore}
            indop := nil;
            strop := nil;
            while list <> nil do begin
               Check(list);
               if list <> nil then
                  list := list^.next;
               end; {while}
            PreviousStore := false;
            if strop <> nil then
               if strop^.parents <> 0 then
                  if not Inhibit(indop, op) then
                     PreviousStore := true;
            end; {PreviousStore}


         begin {Check}
         if op^.parents = 0 then begin
            invariant := true;
            if op^.left <> nil then begin
               Check(op^.left, olp);
               if op^.left^.parents = 0 then
        	  invariant := false;
               end; {if}
            if op^.right <> nil then begin
               Check(op^.right, olp);
               if op^.right^.parents = 0 then
        	  invariant := false;
               end; {if}
            if invariant then begin
               opcode := op^.opcode;
               if opcode in
        	  [pc_adi,pc_adl,pc_adr,pc_and,pc_lnd,pc_bnd,pc_bal,pc_bnt,
                   pc_bnl,pc_bor,pc_blr,pc_bxr,pc_blx,pc_bno,pc_dec,pc_dvi,
                   pc_udi,pc_dvl,pc_udl,pc_dvr,pc_equ,pc_neq,pc_grt,pc_les,
                   pc_geq,pc_leq,pc_inc,pc_ind,pc_ior,pc_lor,pc_ixa,pc_lad,
                   pc_lca,pc_lda,pc_ldc,pc_mod,pc_uim,pc_mdl,pc_ulm,pc_mpi,
                   pc_umi,pc_mpl,pc_uml,pc_mpr,pc_ngi,pc_ngl,pc_ngr,pc_not,
                   pc_sbi,pc_sbl,pc_sbr,pc_shl,pc_sll,pc_shr,pc_usr,pc_slr,
                   pc_vsr,pc_chk,pc_abi,pc_abr,pc_abl,pc_sqi,pc_sql,pc_sqr,
                   pc_rnd,pc_rn4,pc_odd,pc_odl,pc_at2,pc_sgs,pc_uni,pc_pwr,
                   pc_int,pc_dif,pc_inn,pc_sin,pc_cos,pc_exp,pc_sqt,pc_log,
                   pc_atn,pc_tan,pc_acs,pc_asn,pc_abl]
                  then begin                                       
        	  op^.parents := icount;
                  icount := icount+1;
                  end {if}
               else if opcode = pc_cnv then begin
        	  if op^.q & $000F <> ord(cgVoid) then begin
        	     op^.parents := icount;
                     icount := icount+1;
                     end; {if}
                  end {else if}
               else if opcode in [pc_sro,pc_sto,pc_str,pc_cop,pc_cpo] then begin
                  if not inhibit then
                     if not IndirectInhibit(op) then
                	if NoOtherStoresOrUses(lp, olp, op) then begin
        		   op^.parents := icount;
                	   icount := icount+1;
                	   end; {if}
                  end {else if}
               else if opcode in [pc_lao,pc_ldo,pc_lod] then begin
        	  {invariant if there is an immediately preceeding invariant store}
        	  if PreviousStore(op, lp2^.block^.code) then begin
                     op^.parents := icount;
                     icount := icount+1;
                     end {if}
        	  else if not Member(op, lp2^.block^.c_gen) then begin
                     {invariant if there are no generators in the loop}
                     count := NumberOfGens(op, lp);
                     if count = 0 then begin
                        op^.parents := icount;       
                        icount := icount+1;
                        end {if}
                     else if count = 1 then begin
                	{invariant if there is one generator AND the generator}
                        {is not in the current block AND no reaching          }
                        {definitions for the loop AND generating statement is }
                        {invariant                                            }
                	if memberOp^.parents <> 0 then
                           if not Member(op, lp^.block^.c_in) then begin
                	      op^.parents := icount;
                	      icount := icount+1;
                              end; {if}
                	end; {else if}
                     end; {else}
        	  end {else if}
               end; {if}
            if op^.parents <> 0 then
               MarkInvariants := true;
            end; {if}
         end; {Check}


         function CheckForIndirectStores (lp: loopPtr): boolean;

         { See if there are any indirect stores or function calls in	}
         { the loop							}
         {								}
         { parameters:							}
         {    lp - loop to check					}
         {								}
         { Returns: True if there are indirect stores or function	}
         {    calls, else false.					}


            function CheckOps (op: icptr): boolean;

            { Check this operation list					}
            {								}
            { parameters:						}
            {    op - operation list to check				}
            {								}
            { Returns: True if an indirect store or function call is	}
            {    found, else false.					}

            var
               result: boolean;			{value to return}

            begin {CheckOps}
            result := false;
            while op <> nil do begin
               if op^.opcode in [pc_sto,pc_cup,pc_cui,
                   pc_tl1,pc_tl2,pc_vct,pc_pds,pc_csp,pc_mov,pc_cum] then begin
                  result := true;
                  op := nil;
                  end {if}
               else begin
                  if op^.left <> nil then
                     result := CheckOps(op^.left);
                  if not result then
                     if op^.right <> nil then
                        result := CheckOps(op^.right);
                  if result then
                     op := nil;
                  end; {if}
               if op <> nil then
                  op := op^.next;
               end; {while}
            CheckOps := result;
            end; {CheckOps}


         begin {CheckForIndirectStores}
         CheckForIndirectStores := false;
         while lp <> nil do
            if CheckOps(lp^.block^.code) then begin
               CheckForIndirectStores := true;
               lp := nil;
               end {if}
            else
               lp := lp^.next;
         end; {CheckForIndirectStores}


         function DominatesExits (dfn: integer; lp: loopPtr): boolean;

         { See if this block dominates all loop exits			}
         {								}
         { parameters:							}
         {    dfn - block that must dominate exits			}
         {    lp - loop list						}
         {								}
         { Returns: True if the block dominates all exits, else false.	}

         var
            dom: blockListPtr;			{used to trace dominator list}

         begin {DominatesExits}
         DominatesExits := true;
         while lp <> nil do begin
            if lp^.exit then begin
               dom := lp^.block^.dom;
               while dom <> nil do 
                  if dom^.dfn = dfn then
                     dom := nil
                  else begin
                     dom := dom^.next;
                     if dom = nil then begin
                        lp := nil;
                        DominatesExits := false;
                        end; {if}
                     end; {else}
               end; {if}
            if lp <> nil then
               lp := lp^.next;
            end; {while}
         end; {DominatesExits}


      begin {MarkInvariants}
      MarkInvariants := false;
      lp2 := lp;
      while lp2 <> nil do begin
         inhibit := not DominatesExits(lp2^.block^.dfn, lp);
         indirectStores := CheckForIndirectStores(lp);
         op := lp2^.block^.code;
         while op <> nil do begin
            Check(op, lp2);
            op := op^.next;
            end; {while}
         lp2 := lp2^.next;
         end; {while}
      end; {MarkInvariants}


      procedure RemoveInvariants (llp: loopListPtr);

      { Remove loop invariant calculations			}
      {								}
      { parameters:						}
      {    llp - pointer to the loop entry to process		}

      var
         icount, oldIcount: integer;	{invariant order counters}
         nhp: blockPtr;			{new loop hedaer pointer}
         op1, op2, op3: icptr;		{used to reverse the code list}


         procedure CreateHeader;

         { Create the new loop header					}
         {								}
         { Notes: As a side effect, CreateHeader sets nhp to point to	}
         {    the new loop header.					}

         var
            lp: loopPtr;			{new loop list entry}
            ohp: blockPtr;			{old loop hedaer pointer}

         begin {CreateHeader}
         nhp := pointer(Calloc(sizeof(block)));	{create the new block}
         ohp := llp^.loop^.block;		{insert it in the block list}
         nhp^.last := ohp^.last;
         if nhp^.last <> nil then
            nhp^.last^.next := nhp;
         nhp^.next := ohp;
         ohp^.last := nhp;
	 new(lp);				{add it to the loop list}
	 lp^.next := llp^.loop;
	 llp^.loop := lp;
	 lp^.block := nhp;
         lp^.exit := false;
         end; {CreateHeader}


         function FindInvariant (ic: integer): integer;

         { Find the next invariant calculation				}
         {								}
         { parameters:							}
         {    ic - base count; the new count must exceed this		}
         {								}
         { Returns: count for the invariant record to remove		}

         var
            lp: loopPtr;			{used to trace loop list}
            op: icptr;				{used to trace code list}
            nic: integer;			{lowest count > ic}


            procedure Check (op: icptr);

            { See if op or its children represent a newer invariant	}
            { calculation than the one numbered nic			}
            {								}
            { parameters:						}
            {    op - instruction to check				}
            {								}
            { Notes: Rejecting pc_bno here is rather odd, but it allows	}
            {    expressions _containing_ pc_bno to be removed without	}
            {    messing up pc_tri operations by allowing pc_bno to be	}
            {    removed as the top level of an expression.		}

            begin {Check}
            if op^.parents = 0 then begin
               if op^.left <> nil then
                  Check(op^.left);
               if op^.right <> nil then
                  Check(op^.right);
               end {if}
            else begin
               if op^.parents < nic then
                  if op^.parents > ic then
                     if op^.opcode <> pc_bno then
                        nic := op^.parents;
               end; {else}
            end; {Check}


         begin {FindInvariant}
         nic := maxint;
         lp := llp^.loop;
         while (lp <> nil) and (nic <> ic+1) do begin
            op := lp^.block^.code;
            while op <> nil do begin
               Check(op);
               op := op^.next;
               end; {while}
            lp := lp^.next;
            end; {while}
         FindInvariant := nic;
         end; {FindInvariant}


         procedure RemoveInvariant (ic: integer);

         { Move the invariant calculation to the header			}
         {								}
         { parameters:							}
         {    ic - index number for instruction to remove		}

         var
            done: boolean;			{loop termination test}
            lp: loopPtr;			{used to trace loop list}
            op: icptr;				{used to trace code list}


            procedure Check (op: icptr);

            { See if a child of op is the target instruction to move	}
            { (If so, move it.)						}
            {								}
            { parameters:						}
            {    op - instruction to check				}


               procedure Remove (var op: icptr);

               { Move a calculation to the loop header			}
               {							}
               { parameters:						}
               {    op - invariant calculation to move			}

               var
		  loc, op2, str: icptr;		{new opcodes}
		  optype: baseTypeEnum;		{type of the temp variable}

               begin {Remove}
               if (op^.left <> nil) or (op^.right <> nil) then begin
        	  optype := TypeOf(op);		{create a temp label}
        	  loc := pointer(Calloc(sizeof(intermediate_code)));
        	  loc^.opcode := dc_loc;
        	  loc^.optype := cgWord;
        	  maxLoc := maxLoc + 1;
        	  loc^.r := maxLoc;
        	  loc^.q := TypeSize(optype);
        	  loc^.next := nhp^.code;
        	  nhp^.code := loc;
						{make a copy of the tree}
        	  op2 := pointer(Malloc(sizeof(intermediate_code)));
        	  op2^ := op^;
        	  op^.opcode := pc_lod;		{substitute a load of the temp}
        	  op^.optype := optype;
        	  op^.r := loc^.r;
        	  op^.q := 0;
        	  op^.left := nil;
        	  op^.right := nil;
						{store the temp result}
        	  str := pointer(Calloc(sizeof(intermediate_code)));
        	  str^.opcode := pc_str;
        	  str^.optype := optype;
        	  str^.r := loc^.r;
        	  str^.q := 0;
        	  str^.left := op2;
        	  str^.next := loc^.next;	{insert the store in the basic block}
        	  loc^.next := str;
                  end; {if}
               done := true;
               end; {Remove}


            begin {Check}
            if op^.left <> nil then begin
               if op^.left^.parents = ic then
                  Remove(op^.left);
               if not done then
                  Check(op^.left);
               end; {if}
            if not done then
               if op^.right <> nil then begin
        	  if op^.right^.parents = ic then 
                     Remove(op^.right);
                  if not done then
                     Check(op^.right);
                  end; {if}
            end; {Check}   


            procedure RemoveTop (var op: icptr);

            { Move a top-level instruction to the header		}
            {								}
            { parameters:						}
            {    op - top level instruction to remove			}

            var
               op2: icptr;			{temp operation}

            begin {RemoveTop}
            op2 := op;
            op := op^.next;
            op2^.next := nhp^.code;
            nhp^.code := op2;
            end; {RemoveTop}


         begin {RemoveInvariant}
         lp := llp^.loop;
         done := false;
         while not done do begin
            op := lp^.block^.code;
            if op <> nil then
               if op^.parents = ic then begin
        	  RemoveTop(lp^.block^.code);
        	  done := true;
        	  end {if}
               else begin
        	  Check(op);
        	  while (op^.next <> nil) and (not done) do begin
                     if op^.next^.parents = ic then begin
                	RemoveTop(op^.next);
                	done := true;
                	end {if}
                     else
                	Check(op^.next);
                     if op^.next <> nil then
        		op := op^.next;
        	     end; {while}
        	  end; {else}
            lp := lp^.next;
            if lp = nil then
               done := true;
            end; {while}
         end; {RemoveInvariant}


      begin {RemoveInvariants}
      CreateHeader;			{create a loop header block}
      icount := 0;			{find & remove all invariants}
      repeat
         oldIcount := icount;
         icount := FindInvariant (icount);
         if icount <> maxint then
            RemoveInvariant(icount);
      until icount = maxint;
      op1 := nhp^.code;			{reverse the new code list}
      op2 := nil;
      while op1 <> nil do begin
         op3 := op1;
         op1 := op1^.next;
         op3^.next := op2;
         op2 := op3;
         end; {while}
      nhp^.code := op2;
      end; {RemoveInvariants}


      procedure ZeroParents (lp: loopPtr);

      { Zero the parents field in all nodes			}
      {								}
      { parameters:						}
      {    lp - loop for which to zero the parents		}

      var
         op: icptr;			{used to trace the opcode list}


         procedure Zero (op: icptr);

         { Zero the parents field for this node and its		}
         { children.						}
         {							}
         { parameters:						}
         {    op - node to zero					}

         begin {Zero}
         op^.parents := 0;
         if op^.left <> nil then
            Zero(op^.left);
         if op^.right <> nil then
            Zero(op^.right);
         end; {Zero}

            
      begin {ZeroParents}
      while lp <> nil do begin
         op := lp^.block^.code;
         while op <> nil do begin
            Zero(op);
            op := op^.next;
            end; {while}
         lp := lp^.next;
         end; {while}
      end; {ZeroParents}


   begin {LoopInvariantRemoval}
   Spin;
   FindLoops;				{find a list of natural loops}

   llp := loops;			{scan the loops...}
   icount := 1;
   while llp <> nil do begin
      Spin;
      ZeroParents(llp^.loop);		{set the parents field to zero}
      while MarkInvariants(llp^.loop) do {mark the loop invariant computations}
         ;
      if icount <> 1 then
	 RemoveInvariants(llp);		{remove loop invariant calculations}
      llp := llp^.next;
      end; {while}


   while loops <> nil do begin		{dispose of the loop lists}
      while loops^.loop <> nil do begin
	 lp := loops^.loop;
	 loops^.loop := lp^.next;
	 dispose(lp);
	 end; {while}
      llp := loops;
      loops := llp^.next;
      dispose(llp);
      end; {while}
   end; {LoopInvariantRemoval}


   function RemoveDeadNodes: boolean;

   { Checks for and removes unreachable nodes			}
   {								}
   { Returns: True if there were dead nodes, else false		}

   var
      bb, bb2: blockPtr;		{used to trace basic block lists}

   begin {RemoveDeadNodes}
   RemoveDeadNodes := false;
   bb := DAGblocks;
   bb2 := bb^.next;
   while bb2 <> nil do
      if not bb2^.visited then begin
         RemoveDeadNodes := true;
         bb2 := bb2^.next;
         bb^.next := bb2;
         end {if}
      else begin
         bb := bb2;
         bb2 := bb2^.next;
         end; {else}
   end; {RemoveDeadNodes}
   

begin {DoLoopOptimization}
repeat
   DepthFirstOrder;			{create the depth first tree}
until not RemoveDeadNodes;
ReachingDefinitions;			{find reaching definitions}
Dominators;				{find the lists of dominators}
LoopInvariantRemoval;			{remove loop invariant computations}
while dft <> nil do begin		{dispose of the depth first tree}
   dft2 := dft;
   dft := dft2^.next;
   dispose(dft2);
   end; {while}
while backEdge <> nil do begin		{dispose of the back edge list}
   dft2 := backEdge;
   backEdge := dft2^.next;
   dispose(dft2);
   end; {while}
end; {DoLoopOptimization}

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

procedure DAG {code: icptr};

{ place an op code in a DAG or tree				}
{                                                               }
{ parameters:                                                   }
{       code - opcode						}

var
   temp: icptr;				{temp node}


   procedure Generate;

   { generate the code for the current procedure		}

   var
      op: icptr;			{temp opcode pointers}


      procedure BasicBlocks;

      { Break the code up into basic blocks			}

      var
         blast: blockPtr;		{last block pointer}
         bp: blockPtr;			{current block pointer}
         cb: icptr;			{last code in block pointer}
         cp: icptr;			{current code pointer}

      begin {BasicBlocks}
      cp := DAGhead;
      DAGblocks := nil;
      if cp <> nil then begin
         bp := pointer(Calloc(sizeof(block)));
         DAGblocks := bp;
         blast := bp;
         bp^.code := cp;
         cb := cp;
         cp := cp^.next;
         cb^.next := nil;
         while cp <> nil do
					{labels start a new block}
            if cp^.opcode = dc_lab then begin
               Spin;
               bp := pointer(Calloc(sizeof(block)));
               bp^.last := blast;
               blast^.next := bp;
               blast := bp;
               bp^.code := cp;
               cb := cp;
               cp := cp^.next;
               cb^.next := nil;
               end {if}
					{conditionals are followed by a new block}
            else if cp^.opcode in [pc_fjp, pc_tjp, pc_ujp, pc_ret, pc_xjp] then
               begin
               Spin;
               while cp^.next^.opcode = pc_add do begin
                  cb^.next := cp;
        	  cb := cp;
        	  cp := cp^.next;
        	  cb^.next := nil;
                  end; {while}
               cb^.next := cp;
               cb := cp;
               cp := cp^.next;
               cb^.next := nil;
               bp := pointer(Calloc(sizeof(block)));
               bp^.last := blast;
               blast^.next := bp;
               blast := bp;
               bp^.code := cp;
               cb := cp;
               cp := cp^.next;
               cb^.next := nil;
               end {else if}
            else begin			{all other statements get added to a block}
               cb^.next := cp;
               cb := cp;
               cp := cp^.next;
               cb^.next := nil;
               end; {else}
         end; {if}
      end; {BasicBlocks}


   begin {Generate}             
   if peepHole then begin		{peephole optimization}
      peepSpin := 0;
      repeat
         rescan := false;
	 PeepHoleOptimization(DAGhead);	
	 op := DAGHead;
	 while op^.next <> nil do begin
            PeepHoleOptimization(op^.next);
            op := op^.next;
            end; {while}
 	 CheckLabels;
      until not rescan;
      end; {if}
   BasicBlocks;				{build the basic blocks}
   if (commonSubexpression or loopOptimizations) and (not prsFound) then
      FlagIndirectUses;			{create a list of all indirect uses}
   if commonSubexpression and		{common sub-expression removal}
      (not prsFound) then
      CommonSubexpressionElimination;
   if loopOptimizations and		{loop optimizations}
      (not prsFound) then
      DoLoopOptimization;
{  if printSymbols then			{debug}
{     PrintBlocks(@'DAG: ', DAGblocks);	{debug}
   if (commonSubexpression or loopOptimizations) and (not prsFound) then
      DisposeOpList(c_ind);		{dispose of indirect use list}
   Gen(DAGblocks);			{generate native code}
   if loopOptimizations and		{dump and dynamic space}
      (not prsFound) then
      DumpLoopLists;
   DAGhead := nil;			{reset the DAG pointers}
   end; {Generate}


   procedure Push (code: icptr);

   { place a node on the operation stack			}
   {								}
   { parameters:						}
   {    code - node						}

   begin {Push}
   code^.next := DAGhead;
   DAGhead := code;
   end; {Push}


   function Pop: icptr;

   { pop a node from the operation stack			}
   {								}
   { returns: node pointer or nil				}

   var
      node: icptr;			{node poped}
      tn: icptr;			{temp node}

   begin {Pop}
   node := DAGhead;
   if node = nil then
      Error(cge1)
   else begin
      DAGhead := node^.next;
      node^.next := nil;
      end; {else}
   if node^.opcode = dc_loc then begin
      tn := node;
      node := Pop;
      Push(tn);
      end; {if}
   Pop := node;
   end; {Pop}


   procedure Reverse;

   { Reverse the operation stack				}

   var
      list, temp: icptr;		{work pointers}

   begin {Reverse}
   list := nil;
   while DAGhead <> nil do begin
      temp := DAGhead;
      DAGhead := temp^.next;
      temp^.next := list;
      list := temp;
      end; {while}
   DAGhead := list;
   end; {Reverse}


begin {DAG}
case code^.opcode of

   pc_abi, pc_abl, pc_abr, pc_acs, pc_asn, pc_atn,
   pc_bnl, pc_bnt,
   pc_chk, pc_cos, pc_cnv, pc_csp, pc_cum,
   pc_cup, pc_dec, pc_exp, pc_fjp, pc_inc,
   pc_ind, pc_log, pc_ngi, pc_ngl, pc_ngr, pc_not, pc_odd,
   pc_odl, pc_pds, pc_rnd, pc_rn4, pc_sin,
   pc_siz, pc_sqi, pc_sql, pc_sqr, pc_sqt,
   pc_sro, pc_stk, pc_str, pc_tan, pc_tjp, pc_tl1, pc_tl2, pc_vct, pc_xjp:
      begin
      code^.left := Pop;
      Push(code);
      end;

   pc_adi, pc_adl, pc_adr, pc_and, pc_at2,
   pc_bal, pc_blr, pc_blx, pc_bnd, pc_bno, pc_bor, pc_bxr,
   pc_cui, pc_dif, pc_dvi, pc_dvl, pc_dvr, pc_equ,
   pc_geq, pc_grt, pc_inn, pc_int, pc_ior,
   pc_ixa, pc_leq, pc_les, pc_mdl, pc_mod, pc_mov, pc_mpi, pc_mpl, pc_mpr,
   pc_neq, pc_pwr, pc_sbi, pc_sbl, pc_sbr, pc_sgs,
   pc_shl, pc_shr, pc_sll, pc_slr, pc_sto, pc_udi, pc_udl, pc_uim, pc_ulm,
   pc_umi, pc_uml, pc_uni, pc_usr, pc_vsr:
      begin
      code^.right := Pop;
      code^.left := Pop;
      Push(code);
      end;

   dc_dst, dc_glb, dc_lab, dc_pin, dc_sym,
   pc_add, pc_ent, pc_fix, pc_lad, pc_lao, pc_lca, pc_lda, pc_ldc, pc_ldo,
   pc_lla, pc_lnm, pc_lod, pc_lsl, pc_nam, pc_nop, pc_ret, pc_ujp:
      Push(code);

   pc_prs:
      begin
      Push(code);
      prsFound := true;
      end;

   pc_cnn:
      begin
      code^.opcode := pc_cnv;
      temp := Pop;
      code^.left := Pop;
      Push(code);
      Push(temp);
      end;

   dc_fun, dc_loc: begin
      Push(code);
      if code^.r > maxLoc then
         maxLoc := code^.r;
      end;

   dc_prm: begin
      Push(code);
      if code^.s > maxLoc then
         maxLoc := code^.s;
      end;

   dc_str: begin
      Push(code);
      maxLoc := 0;
      prsFound := false;
      end;

   dc_enp: begin
      Push(code);
      Reverse;
      Generate;
      end;

   otherwise:
      Error(cge1);			{invalid opcode}
   end; {case}
end; {DAG}

end.

{$append 'dag.asm'}
\ No newline at end of file
+{$optimize 15}
+{---------------------------------------------------------------}
+{                                                               }
+{  DAG Creation							}
+{                                                               }
+{  Places intermediate codes into DAGs and trees.		}
+{                                                               }
+{---------------------------------------------------------------}
+
+unit DAG;
+
+interface
+
+{$segment 'cg'}
+
+{$LibPrefix '0/obj/'}
+
+uses PCommon, CGI, CGC, Gen;
+
+{---------------------------------------------------------------}
+
+procedure DAG (code: icptr);
+
+{ place an op code in a DAG or tree				}
+{                                                               }
+{ parameters:                                                   }
+{       code - opcode						}
+
+{---------------------------------------------------------------}
+
+implementation
+
+const
+   peepSpinRate = 20;			{PeepHoleOptimize spin rate}
+
+var
+   c_ind: iclist;			{vars that can be changed by indirect stores}
+   maxLoc: integer;			{max local label number used by compiler}
+   memberOp: icptr;			{operation found by Member}
+   optimizations: array[pcodes] of integer; {starting indexes into peeptable}
+   peepSpin: 0..peepSpinRate;		{spinner delay for PeepHoleOptimize}
+   peepTablesInitialized: boolean;	{have the peephole tables been initialized?}
+   prsFound: boolean;			{are there any pc_prs opcodes?}
+   rescan: boolean;			{redo the optimization pass?}
+
+{-- External unsigned math routines ----------------------------}
+
+function udiv (x,y: longint): longint; extern;
+
+function umod (x,y: longint): longint; extern;
+
+function umul (x,y: longint): longint; extern;
+
+{---------------------------------------------------------------}
+
+function SetsEqual (s1, s2: setPtr): boolean;
+
+{ See if two sets are equal					}
+{								}
+{ parameters:							}
+{    s1, s2 - sets to compare					}
+{								}
+{ Returns: True if the sets are equal, else false		}
+
+label 1;
+
+var
+   i: unsigned;				{loop/index variable}
+
+begin {SetsEqual}
+SetsEqual := false;
+if s1^.smax = s2^.smax then begin
+   for i := 1 to s1^.smax do
+      if s1^.sval[i] <> s2^.sval[i] then
+         goto 1;
+   SetsEqual := true;
+   end; {if}
+1: ;
+end; {SetsEqual}
+
+
+function CodesMatch (op1, op2: icptr; exact: boolean): boolean;
+
+{ Check to see if the trees op1 and op2 are equivalent		}
+{								}
+{ parameters:							}
+{    op1, op2 - trees to check					}
+{    exact - is an exact of operands match required?		}
+{								}
+{ Returns: True if trees are equivalent, else false.		}
+
+
+   function OpsEqual (op1, op2: icptr): boolean;
+
+   { See if the operands are equal				}
+   {								}
+   { parameters:						}
+   {    op1, op2 - operations to check				}
+   {								}
+   { Returns: True if the operands are equivalent, else		}
+   {    false.							}
+
+   var
+      result: boolean;			{temp result}
+
+   begin {OpsEqual}
+   result := false;
+   case op1^.opcode of
+      pc_cup, pc_cum, pc_cui, pc_csp, pc_tl1, pc_tl2, pc_vct, pc_pds, pc_bno:
+         {this rule prevents optimizations from removing sensitive operations}
+         ;
+
+      pc_adi, pc_adl, pc_adr, pc_and, pc_lnd, pc_bnd, pc_bal, pc_bor,
+      pc_blr, pc_bxr, pc_blx, pc_equ, pc_neq, pc_ior, pc_lor, pc_mpi,
+      pc_umi, pc_mpl, pc_uml, pc_mpr, pc_int, pc_uni: begin
+         if op1^.left = op2^.left then
+            if op1^.right = op2^.right then
+               result := true;
+         if not result then
+            if op1^.left = op2^.right then
+               if op1^.right = op2^.left then
+                  result := true;
+         if not result then
+            if not exact then
+               if CodesMatch(op1^.left, op2^.left, false) then
+        	  if CodesMatch(op1^.right, op2^.right, false) then
+                     result := true;
+         if not result then
+            if not exact then
+               if CodesMatch(op1^.left, op2^.right, false) then
+        	  if CodesMatch(op1^.right, op2^.left, false) then
+                     result := true;
+         end;
+
+      otherwise: begin
+         if op1^.left = op2^.left then
+            if op1^.right = op2^.right then
+               result := true;
+         if not result then
+            if not exact then
+               if CodesMatch(op1^.left, op2^.left, false) then
+        	  if CodesMatch(op1^.right, op2^.right, false) then
+                     result := true;
+         end;                 
+      end; {case}
+   OpsEqual := result;
+   end; {OpsEqual}
+
+
+   function LabsEqual (l1, l2: pStringPtr): boolean;
+
+   { See if the labels are equal				}
+   {								}
+   { parameters:						}
+   {    l1, l2 - labels to check				}
+   {								}
+   { Returns: True if the labels are equal, else false		}
+
+   begin {LabsEqual}
+   if (l1 = nil) and (l2 = nil) then
+      LabsEqual := true
+   else if (l1 <> nil) and (l2 <> nil) then
+      LabsEqual := l1^ = l2^
+   else
+      LabsEqual := false;
+   end; {LabsEqual}
+
+
+begin {CodesMatch}
+CodesMatch := false;
+if (op1 = nil) and (op2 = nil) then
+   CodesMatch := true
+else if (op1 <> nil) and (op2 <> nil) then
+   if op1^.opcode = op2^.opcode then
+      if op1^.q = op2^.q then
+	 if op1^.r = op2^.r then
+            if op1^.s = op2^.s then
+               if LabsEqual(op1^.lab, op2^.lab) then
+        	  if OpsEqual(op1, op2) then
+                     if op1^.optype = op2^.optype then
+                	case op1^.optype of
+                           cgByte, cgUByte, cgWord, cgUWord:
+                              if op1^.opnd = op2^.opnd then
+                        	 if op1^.llab = op2^.llab then
+                                    if op1^.slab = op2^.slab then
+                                       CodesMatch := true;
+                           cgLong, cgULong:
+                              if op1^.lval = op2^.lval then
+                        	 CodesMatch := true;
+                           cgReal, cgDouble, cgComp, cgExtended:
+                              if op1^.rval = op2^.rval then
+                        	 CodesMatch := true;
+                           cgString:
+                              CodesMatch := op1^.str^ = op2^.str^;
+                           cgSet:
+                              CodesMatch := SetsEqual(op1^.setp, op2^.setp);
+                           cgVoid:
+                              CodesMatch := true;
+                           end; {case}
+end; {CodesMatch}
+
+{- Peephole Optimization ---------------------------------------}
+
+function Base (val: longint): integer;
+
+{ Assuming val is a power of 2, find ln(val) base 2		}
+{								}
+{ parameters:							}
+{    val - value for which to find the base			}
+{								}
+{ Returns: ln(val), base 2					}
+
+var
+   i: integer;                    	{base counter}
+
+begin {Base}
+i := 0;
+while not odd(val) do begin
+   val := val >> 1;
+   i := i+1;
+   end; {while}
+Base := i;
+end; {Base}
+
+
+procedure BinOps (var op1, op2: icptr);
+
+{ Make sure the operands are of the same type			}
+{								}
+{ parameters:							}
+{    op1, op2: two pc_ldc operands				}
+
+var
+   opt1, opt2: baseTypeEnum;		{temp operand types}
+
+begin {BinOps}
+opt1 := op1^.optype;
+opt2 := op2^.optype;
+if opt1 = cgByte then begin
+   op1^.optype := cgWord;
+   opt1 := cgWord;
+   end {if}
+else if opt1 = cgUByte then begin
+   op1^.optype := cgUWord;
+   opt1 := cgUWord;
+   end {else if}
+else if opt1 in [cgReal, cgDouble, cgComp] then begin
+   op1^.optype := cgExtended;
+   opt1 := cgExtended;
+   end; {else if}
+if opt2 = cgByte then begin
+   op2^.optype := cgWord;
+   opt2 := cgWord;
+   end {if}
+else if opt2 = cgUByte then begin
+   op2^.optype := cgUWord;
+   opt2 := cgUWord;
+   end {else if}
+else if opt2 in [cgReal, cgDouble, cgComp] then begin
+   op2^.optype := cgExtended;
+   opt2 := cgExtended;
+   end; {else if}
+
+if opt1 <> opt2 then begin
+   case opt1 of
+      cgWord:
+         case opt2 of
+            cgUWord:
+               op1^.optype := cgUWord;
+            cgLong, cgULong: begin
+               op1^.lval := op1^.q;
+               op1^.optype := opt2;
+               end;
+            cgExtended: begin
+               op1^.rval := op1^.q;
+               op1^.optype := cgExtended;
+               end;
+            otherwise: ;
+            end; {case}
+      cgUWord:
+         case opt2 of
+            cgWord:
+               op2^.optype := cgUWord;
+            cgLong, cgULong: begin
+               op1^.lval := ord4(op1^.q) & $0000FFFF;
+               op1^.optype := opt2;
+               end;
+            cgExtended: begin
+               op1^.rval := ord4(op1^.q) & $0000FFFF;
+               op1^.optype := cgExtended;
+               end;
+            otherwise: ;     
+            end; {case}
+      cgLong:
+         case opt2 of
+            cgWord: begin
+               op2^.lval := op2^.q;
+               op2^.optype := cgLong;
+               end;
+            cgUWord: begin
+               op2^.lval := ord4(op2^.q) & $0000FFFF;
+               op2^.optype := cgLong;
+               end;
+            cgULong:
+               op1^.optype := cgULong;
+            cgExtended: begin
+               op1^.rval := op1^.lval;
+               op1^.optype := cgExtended;
+               end;
+            otherwise: ;
+            end; {case}
+      cgULong:
+         case opt2 of
+            cgWord: begin
+               op2^.lval := op2^.q;
+               op2^.optype := cgLong;
+               end;
+            cgUWord: begin
+               op2^.lval := ord4(op2^.q) & $0000FFFF;
+               op2^.optype := cgLong;
+               end;
+            cgLong:
+               op2^.optype := cgULong;
+            cgExtended: begin
+               op1^.rval := op1^.lval;
+               if op1^.rval < 0.0 then
+                  op1^.rval := 4294967296.0 + op1^.rval;
+               op1^.optype := cgExtended;
+               end;
+            otherwise: ;
+            end; {case}
+      cgExtended: begin
+         case opt2 of
+            cgWord:
+               op2^.rval := op2^.q;
+            cgUWord:
+               op2^.rval := ord4(op2^.q) & $0000FFFF;
+            cgLong:
+               op2^.rval := op2^.lval;
+            cgULong: begin
+               op2^.rval := op2^.lval;
+               if op2^.rval < 0.0 then
+                  op2^.rval := 4294967296.0 + op2^.rval;
+               end;
+            otherwise: ;
+            end; {case}
+         op2^.optype := cgExtended;
+         end;
+      otherwise: ;
+      end; {case}
+   end; {if}
+end; {BinOps}
+
+
+procedure CheckLabels;
+
+{ remove unused dc_lab labels					}
+
+type
+   nameTypePtr = ^nameType;		{named label list element}
+   nameType = record
+      next: nameTypePtr;
+      lab: pStringPtr;
+      end;
+					{used label array}
+   usedArray = packed array[0..maxLabel] of boolean;
+
+var
+   lop: icptr;				{predecessor of op}
+   op: icptr;				{used to trace the opcode list}
+   usedLabels: ^usedArray;		{used numeric label array}
+   usedNames: nameTypePtr;		{used named labels list}
+
+
+   procedure BuildLabels;
+
+   { build the used label array and list			}
+
+   var
+      lab: 0..maxLabel;			{loop/index variable}
+      op: icptr;			{used to trace the opcode list}
+
+
+      procedure RecordName (lab: pStringPtr);
+
+      { record a named label					}
+      {								}
+      { parameters:						}
+      {    lab - label name to record				}
+
+      var
+         found: boolean;		{was the name in the list already?}
+         np: nameTypePtr;		{name pointer}
+
+      begin {RecordName}
+      found := false;
+      np := usedNames;
+      while np <> nil do
+         if np^.lab^ = lab^ then begin
+            np := nil;
+            found := true;
+            end {if}
+         else
+            np := np^.next;
+      if not found then begin
+         new(np);
+         np^.next := usedNames;
+         usedNames := np;
+         np^.lab := lab;
+         end; {if}
+      end; {RecordName}
+
+
+      procedure CheckCup (op: icptr);
+
+      { Check for labels in procedure calls			}
+      {								}
+      { parameters:						}
+      {    op - label to check					}
+
+      begin {CheckCup}
+      if op^.opcode = pc_cup then
+         if op^.lab = nil then begin
+            if op^.r <= maxLabel then
+               usedLabels^[op^.r] := true;
+            end {if}
+         else
+            RecordName(op^.lab);
+      if op^.left <> nil then
+         CheckCup(op^.left);
+      if op^.right <> nil then
+         CheckCup(op^.right);
+      end; {CheckCup}
+
+
+   begin {BuildLabels}
+   new(usedLabels);			{no numbered labels}
+   for lab := 0 to maxLabel do
+      usedLabels^[lab] := false;
+   usedNames := nil;			{no named labels}
+
+   op := DAGhead;
+   while op <> nil do begin
+      if op^.opcode in [pc_add, pc_fjp, pc_tjp, pc_ujp] then
+         if op^.lab = nil then begin
+            if op^.q <= maxLabel then
+               usedLabels^[op^.q] := true;
+            end {if}
+         else
+            RecordName(op^.lab);
+      CheckCup(op);
+      op := op^.next;
+      end; {while}
+   end; {BuildLabels}
+
+
+   procedure DisposeLabels;
+
+   { dispose of the dynamic memory allocated by BuildLabels	}
+
+   var
+      p1, p2: nameTypePtr;		{work pointers}
+
+   begin {DisposeLabels}
+   dispose(usedLabels);
+   p1 := usedNames;
+   while p1 <> nil do begin
+      p2 := p1;
+      p1 := p2^.next;
+      dispose(p2);
+      end; {while}
+   end; {DisposeLabels}
+
+
+   function Used (q: integer; lab: pStringPtr): boolean;
+
+   { see if a label is used					}
+   {								}
+   { parameters:						}
+   {    q - label number to check				}
+   {    lab - named label to check				}
+   {								}
+   { Returns: True if the label is used, else false.		}
+
+   var
+      np: nameTypePtr;			{used to trace usedNames list}
+
+   begin {Used}
+   if lab = nil then 
+      if q <= maxLabel then
+         Used := usedLabels^[q]
+      else
+         Used := true
+   else begin
+      np := usedNames;
+      Used := false;
+      while np <> nil do
+         if np^.lab^ = lab^ then begin
+            np := nil;
+            Used := true;
+            end {if}
+         else
+            np := np^.next;
+      end; {else}
+   end; {Used}
+
+
+begin {CheckLabels}
+BuildLabels;				{build a list of used labels}
+
+op := DAGhead;				{get rid of unused labels}
+while op^.next <> nil do begin
+   lop := op;
+   op := op^.next;
+   if op^.opcode = dc_lab then begin
+      Spin;
+      if op^.lab = nil then
+	 if not Used(op^.q, op^.lab) then begin
+            lop^.next := op^.next;
+            op := lop;
+            rescan := true;
+            end; {if}
+      end; {if}
+   end; {while}
+
+DisposeLabels;				{get rid of label lists}
+end; {CheckLabels}
+
+
+procedure RemoveDeadCode (op: icptr);
+
+{ remove dead code following an unconditional branch		}
+{								}
+{ parameters:							}
+{    op - unconditional branch opcode				}
+
+begin {RemoveDeadCode}
+while not (op^.next^.opcode in [dc_lab, dc_enp, dc_cns, dc_glb,
+   dc_dst, dc_str, dc_pin, pc_ent, dc_loc, dc_prm, dc_fun, dc_sym]) do begin
+   op^.next := op^.next^.next;
+   rescan := true;
+   end; {while}
+end; {RemoveDeadCode}
+
+
+function NoFunctions (op: icptr): boolean;
+
+{ are there any function calls?					}
+{								}
+{ parameters:							}
+{    op - operation tree to search				}
+{								}
+{ returns: True if there are no pc_cup or pc_cui operations	}
+{    in the tree, else false.					}
+
+begin {NoFunctions}
+if op = nil then
+   NoFunctions := true
+else if op^.opcode in [pc_cup,pc_cui,pc_cum,pc_csp,pc_tl1,pc_tl2,pc_vct,pc_pds]
+   then
+   NoFunctions := false
+else
+   NoFunctions := NoFunctions(op^.left) or NoFunctions(op^.right);
+end; {NoFunctions}
+
+
+function OneBit (val: longint): boolean;
+
+{ See if there is exactly one bit set in val			}
+{								}
+{ parameters:							}
+{    val - value to check					}
+{								}
+{ Returns: True if exactly one bit is set, else false		}
+
+begin {OneBit}
+if val = 0 then
+   OneBit := false
+else begin
+   while not odd(val) do
+      val := val >> 1;
+   OneBit := val = 1;
+   end; {else}
+end; {OneBit}
+
+
+function TypeSize (tp: baseTypeEnum): integer;
+
+{ Find the size, in bytes, of a variable			}
+{								}
+{ parameters:							}
+{    tp - base type of the variable				}
+
+begin {TypeSize}
+case tp of
+   cgByte,cgUByte:   TypeSize := cgByteSize;
+   cgWord,cgUWord:   TypeSize := cgWordSize;
+   cgLong,cgULong:   TypeSize := cgLongSize;
+   cgReal:           TypeSize := cgRealSize;
+   cgDouble:         TypeSize := cgDoubleSize;
+   cgComp:           TypeSize := cgCompSize;
+   cgExtended:       TypeSize := cgExtendedSize;
+   cgString:	     TypeSize := cgByteSize;
+   cgVoid,cgSet:     TypeSize := cgLongSize;
+   end; {case}
+end; {TypeSize}
+
+
+function LabelsMatch (op1, op2: icptr): boolean;
+
+{ See if the labels from two instructions match			}
+{								}
+{ parameters:							}
+{    op1, op2 - instructions to check				}
+{								}
+{ Returns: True for match, otherwise false			}
+
+begin {LabelsMatch}
+if (op1^.lab = nil) and (op2^.lab = nil) then
+   LabelsMatch := op1^.q = op2^.q
+else if (op1^.lab <> nil) and (op2^.lab <> nil) then
+   LabelsMatch := op1^.lab^ = op2^.lab^
+else
+   LabelsMatch := false;
+end; {LabelsMatch}                                  
+
+
+procedure PeepHoleOptimization (var opv: icptr);
+
+{ do peephole optimization on a list of opcodes			}
+{								}
+{ parameters:							}
+{    opv - pointer to the first opcode				}
+{								}
+{ Notes:							}
+{    1.	Many optimizations assume the children have already	}
+{	been optimized.  In particular, many optimizations	}
+{	depend on pc_ldc operands being on a specific side of	}
+{	a child's expression tree.  (e.g. pc_fjp and pc_equ)	}
+
+var
+   done: boolean;			{optimization done test}
+   doit: boolean;			{should we do the optimization?}
+   i,j: integer;			{general work variables}
+   lq, lval: longint;			{temps for long calculations}
+   op2,op3: icptr;			{temp opcodes}
+   op: icptr;				{copy of op (for efficiency)}
+   opcode: pcodes;			{temp opcode}
+   optype: baseTypeEnum;		{temp optype}
+   q: integer;				{temp for integer calculations}
+   rval: double;			{temp for real calculations}
+   set1,set2: setPtr;			{work set pointer}
+
+   fromtype, totype, firstType: record	{for converting numbers to optypes}
+      case boolean of
+         true:  (i: integer);
+         false: (optype: baseTypeEnum);
+      end;
+
+
+   function IsUnsigned (op: icptr): boolean;
+
+   { Check to see if the operand is unsigned			}
+   {								}
+   { parameters:						}
+   {    op - opcode to check					}
+
+   begin {IsUnsigned}
+   case op^.opcode of
+
+      pc_abi, pc_abl, pc_equ, pc_geq, pc_grt, pc_lad, pc_lao, pc_lca,
+      pc_lda, pc_leq, pc_les, pc_lla, pc_neq, pc_not, pc_odd, pc_odl,
+      pc_sqi, pc_sql, pc_udi, pc_udl, pc_uim, pc_ulm, pc_umi, pc_uml,
+      pc_usr, pc_vsr:
+         IsUnsigned := true;
+
+      pc_adi, pc_adl, pc_and, pc_ior, pc_lnd, pc_lor:
+         IsUnsigned := IsUnsigned(op^.left) and IsUnsigned(op^.right);
+
+      pc_cnv:
+         IsUnsigned := (op^.q & $00F0 >> 4) in
+            [ord(cgUByte), ord(cgUWord), ord(cgULong)];
+
+      pc_cop, pc_cpo, pc_cui, pc_cum, pc_cup, pc_ind, pc_ldo, pc_lod:
+         IsUnsigned := op^.optype in [cgUByte, cgUWord, cgULong];
+
+      pc_inc:
+         IsUnsigned := IsUnsigned(op^.left);
+
+      pc_ldc:
+         case op^.optype of
+            cgByte, cgWord: IsUnsigned := op^.q >= 0;
+            cgLong: IsUnsigned := op^.lval >= 0;
+            cgUByte,cgUWord,cgULong: IsUnsigned := true;
+            otherwise: IsUnsigned := false;
+            end;
+
+      otherwise:
+         IsUnsigned := false;
+      end;
+   end; {IsUnsigned}
+
+
+   function SideEffects (op: icptr): boolean;
+
+   { Check a tree for operations that have side effects	}
+   {								}
+   { parameters:						}
+   {    op - tree to check					}
+
+   var
+      result: boolean;		{temp result}
+
+   begin {SideEffects}
+   if op = nil then
+      SideEffects := false
+   else if op^.opcode in
+      [pc_mov,pc_cop,pc_cpo,pc_sro,pc_sto,pc_str,pc_cui,pc_cup,pc_tl1,
+       pc_tl1,pc_pds,pc_csp,pc_prs,pc_fix,pc_cum,pc_vct] then
+      SideEffects := true
+   else
+      SideEffects := SideEffects(op^.left) or SideEffects(op^.right);
+   end; {SideEffects}
+
+
+   procedure MakeWordSet (op: icptr);
+
+   { Convert the tree from set operations to equivalent word	}
+   { operations							}
+   {								}
+   { parameters:						}
+   {    op - tree to convert					}
+
+   var
+      c: record				{conversion record}
+         case boolean of
+            true:  (b1, b2: byte);
+            false: (ival: integer);
+         end;
+      op2,op3: icptr;			{temp opcodes}
+      opcode: pcodes;			{op^.opcode}
+
+   begin {MakeWordSet}
+   opcode := op^.opcode;
+   if opcode = pc_ldc then begin
+      op^.optype := cgUWord;
+      c.ival := 0;
+      if op^.setp^.smax <> 0 then begin
+         c.b1 := ord(op^.setp^.sval[1]);
+         if op^.setp^.smax <> 1 then
+            c.b2 := ord(op^.setp^.sval[2]);
+         end; {if}
+      op^.setp := nil;
+      op^.q := c.ival;
+      end {if}
+   else if opcode = pc_ldo then begin
+      op^.optype := cgUWord;
+      op^.q := op^.r;
+      op^.r := 0;
+      end {else if}
+   else if opcode = pc_lod then begin
+      op^.optype := cgUWord;
+      op^.s := 0;
+      end {else if}
+   else if opcode = pc_sgs then begin
+      op^.right^.q := 1;
+      op2 := op^.left;
+      op^.left := op^.right;
+      op^.right := op2;
+      op^.opcode := pc_shl;
+      end {else if}
+   else if opcode = pc_inn then begin
+      MakeWordSet(op^.right);
+      op2 := pointer(Calloc(sizeof(intermediate_code)));
+      op2^.optype := cgUWord;
+      op2^.opcode := pc_ldc;
+      op2^.q := 1;
+      op3 := pointer(Calloc(sizeof(intermediate_code)));
+      op3^.optype := cgWord;
+      op3^.opcode := pc_shl;
+      op3^.left := op2;
+      op3^.right := op^.left;
+      op^.left := op3;
+      op^.opcode := pc_bnd;
+      end {else if}
+   else if opcode = pc_dif then begin
+      MakeWordSet(op^.left);
+      MakeWordSet(op^.right);
+      op2 := pointer(Calloc(sizeof(intermediate_code)));
+      op2^.optype := cgWord;
+      op2^.opcode := pc_bnt;
+      op2^.left := op^.right;
+      op^.right := op2;
+      op^.opcode := pc_bnd;
+      end {else if}
+   else if opcode = pc_int then begin
+      MakeWordSet(op^.left);
+      MakeWordSet(op^.right);
+      op^.opcode := pc_bnd;
+      end {else if}
+   else if opcode = pc_uni then begin
+      MakeWordSet(op^.left);
+      MakeWordSet(op^.right);
+      op^.opcode := pc_bor;
+      end; {else if}
+   end; {MakeWordSet}
+
+
+   function WordSet (op: icptr): boolean;
+
+   { See if the tree consists entirely of set operations that	}
+   { can be converted to word operations			}
+   {								}
+   { parameters:						}
+   {    op - tree to check					}
+   {								}
+   { Returns: True if so, false if not				}
+
+   var
+      opcode: pcodes;			{op^.opcode}
+
+   begin {WordSet}
+   opcode := op^.opcode;
+   if opcode = pc_ldc then
+      WordSet := op^.setp^.smax <= 2
+   else if opcode = pc_ldo then
+      WordSet := op^.q = 2
+   else if opcode = pc_lod then
+      WordSet := op^.s = 2
+   else if opcode in [pc_dif,pc_int,pc_uni] then
+      WordSet := WordSet(op^.left) and WordSet(op^.right)
+   else if opcode = pc_inn then
+      WordSet := WordSet(op^.right) and IsUnsigned(op^.left)
+   else if opcode = pc_sgs then
+      if op^.right^.opcode = pc_ldc then
+         WordSet := op^.right^.q = $8000
+      else
+         WordSet := false
+   else
+      WordSet := false;
+   end; {WordSet}
+
+
+   procedure MakeLongSet (op: icptr);
+
+   { Convert the tree from set operations to equivalent long	}
+   { operations							}
+   {								}
+   { parameters:						}
+   {    op - tree to convert					}
+
+   var
+      c: record				{conversion record}
+         case boolean of
+            true:  (b1, b2, b3, b4: byte);
+            false: (lval: longint);
+         end;
+      op2,op3: icptr;			{temp opcodes}
+      opcode: pcodes;			{op^.opcode}
+
+   begin {MakeLongSet}
+   opcode := op^.opcode;
+   if opcode = pc_ldc then begin
+      op^.optype := cgULong;
+      c.lval := 0;
+      if op^.setp^.smax <> 0 then begin
+         c.b1 := ord(op^.setp^.sval[1]);
+         if op^.setp^.smax <> 1 then begin
+            c.b2 := ord(op^.setp^.sval[2]);
+            if op^.setp^.smax <> 2 then begin
+               c.b3 := ord(op^.setp^.sval[3]);
+               if op^.setp^.smax <> 3 then 
+        	  c.b4 := ord(op^.setp^.sval[4]);
+               end; {if}
+            end; {if}
+         end; {if}
+      op^.setp := nil;
+      op^.lval := c.lval;
+      end {if}
+   else if opcode = pc_ldo then begin
+      op^.optype := cgULong;
+      op^.q := op^.r;
+      op^.r := 0;
+      end {else if}
+   else if opcode = pc_lod then begin
+      op^.optype := cgULong;
+      op^.s := 0;
+      end {else if}
+   else if opcode = pc_dif then begin
+      MakeLongSet(op^.left);
+      MakeLongSet(op^.right);
+      op2 := pointer(Calloc(sizeof(intermediate_code)));
+      op2^.optype := cgWord;
+      op2^.opcode := pc_bnl;
+      op2^.left := op^.right;
+      op^.right := op2;
+      op^.opcode := pc_bal;
+      end {else if}
+   else if opcode = pc_int then begin
+      MakeLongSet(op^.left);
+      MakeLongSet(op^.right);
+      op^.opcode := pc_bal;
+      end {else if}
+   else if opcode = pc_uni then begin
+      MakeLongSet(op^.left);
+      MakeLongSet(op^.right);
+      op^.opcode := pc_blr;
+      end; {else if}
+   end; {MakeLongSet}
+
+
+   function LongSet (op: icptr): boolean;
+
+   { See if the tree consists entirely of set operations that	}
+   { can be converted to long operations			}
+   {								}
+   { parameters:						}
+   {    op - tree to check					}
+   {								}
+   { Returns: True if so, false if not				}
+
+   var
+      opcode: pcodes;			{op^.opcode}
+
+   begin {LongSet}
+   opcode := op^.opcode;
+   if opcode = pc_ldc then
+      LongSet := op^.setp^.smax <= 4
+   else if opcode = pc_ldo then
+      LongSet := op^.q = 4
+   else if opcode = pc_lod then
+      LongSet := op^.s = 4
+   else if opcode in [pc_dif,pc_int,pc_uni] then
+      LongSet := LongSet(op^.left) and LongSet(op^.right)
+   else
+      LongSet := false;
+   end; {LongSet}
+
+
+   procedure JumpOptimizations (op: icptr; newOpcode: pcodes);
+
+   { handle common code for jump optimizations			}
+   {								}
+   { parameters:						}
+   {    op - jump opcode					}
+   {    newOpcode - opcode to use if the jump sense is reversed	}
+
+   var
+      done: boolean;			{optimization done test}
+      topcode: pcodes;			{temp opcode}
+
+   begin {JumpOptimizations}
+   topcode := op^.left^.opcode;
+   if topcode = pc_inn then
+      if WordSet(op^.left) then begin
+         MakeWordSet(op^.left);
+         topcode := op^.left^.opcode;
+         end; {if}
+   if topcode = pc_not then begin
+      op^.left := op^.left^.left;
+      op^.opcode := newOpcode;
+      PeepHoleOptimization(opv);
+      end {else if}
+   else if topcode in [pc_neq,pc_equ] then begin
+      with op^.left^.right^ do
+         if opcode = pc_ldc then
+            if optype in [cgByte,cgUByte,cgWord,cgUWord] then
+               if q = 0 then begin
+                  op^.left := op^.left^.left;
+                  if topcode = pc_equ then
+                     op^.opcode := newOpcode;
+                  end; {if}
+      end; {else if}
+   if op^.next^.opcode = dc_lab then
+      if LabelsMatch(op^.next, op) then
+         if not SideEffects(op^.left) then begin
+            rescan := true;
+            opv := op^.next;
+            end; {else if}
+   end; {JumpOptimizations}
+
+
+   procedure RealStoreOptimizations (op, opl: icptr);
+
+   { do strength reductions associated with stores of reals	}
+   {								}
+   { parameters:						}
+   {    op - real store to optimize				}
+   {    opl - load operand for the store operation		}
+
+   var
+      disp: 0..9;			{disp to the word to change}
+      same: boolean;			{are the operands the same?}
+      op2: icptr;			{new opcode}
+      opt: icptr;			{temp opcode}
+
+      cnvrl: record			{for stuffing a real in a long space}
+	 case boolean of
+            true:  (lval: longint);
+            false: (rval: real);
+	 end;
+
+   begin {RealStoreOptimizations}
+   if opl^.opcode = pc_ngr then begin
+      same := false;
+      with opl^.left^ do
+         if op^.opcode = pc_sro then begin
+            if opcode = pc_ldo then
+               if q = op^.q then
+                  if optype = op^.optype then
+                     if lab^ = op^.lab^ then
+                        same := true;
+            end {if}
+         else {if op^.opcode = pc_str then}
+            if opcode = pc_lod then
+               if q = op^.q then
+                  if r = op^.r then
+                     if optype = op^.optype then
+                        same := true;
+      if same then begin
+         case op^.optype of
+            cgReal: disp := 3;
+            cgDouble: disp := 7;
+            cgExtended: disp := 9;
+            cgComp: disp := 11;
+            end; {case}
+         opl^.left^.optype := cgWord;
+         opl^.left^.q := opl^.left^.q + disp;
+         op^.optype := cgWord;
+         op^.q := op^.q + disp;
+         op2 := pointer(Calloc(sizeof(intermediate_code)));
+         op2^.opcode := pc_ldc;
+         op2^.optype := cgWord;
+         op2^.q := $0080;
+         opl^.right := op2;
+         opl^.opcode := pc_bxr;
+         end {if}
+      else if op^.optype = cgReal then begin
+         opt := opl^.left;
+         if opt^.opcode in [pc_ind,pc_ldo,pc_lod] then
+            if opt^.optype = cgReal then begin
+               opt^.optype := cgLong;
+               op^.optype := cgLong;
+               op2 := pointer(Calloc(sizeof(intermediate_code)));
+               op2^.opcode := pc_ldc;
+               op2^.optype := cgLong;
+               op2^.lval := $80000000;
+	       opl^.right := op2;
+               opl^.opcode := pc_blx;
+               end; {if}
+         end; {else if}
+      end {if}
+   else if op^.optype = cgReal then begin
+      if opl^.opcode = pc_ldc then begin
+         cnvrl.rval := opl^.rval;
+         opl^.lval := cnvrl.lval;
+         opl^.optype := cgLong;
+         op^.optype := cgLong;
+         end {if}
+      else if opl^.opcode in [pc_ind,pc_ldo,pc_lod] then
+         if opl^.optype = cgReal then begin
+            opl^.optype := cgLong;
+            op^.optype := cgLong;
+            end; {if}
+      end; {if}
+   end; {RealStoreOptimizations}
+
+
+   procedure ReplaceLoads (ldop, stop, tree: icptr);
+
+   { Replace any pc_lod operations in tree that load from the	}
+   { location stored to by the pc_str operation stop by ldop	}
+   {								}
+   { parameters:						}
+   {    ldop - operation to replace the pc_lods with		}
+   {    stop - pc_str operation					}
+   {    tree - tree to check for pc_lod operations		}
+   {								}
+   { Notes: ldop must be an instruction, not a tree		}
+
+   begin {ReplaceLoads}
+   if tree^.left <> nil then
+      ReplaceLoads(ldop, stop, tree^.left);
+   if tree^.right <> nil then
+      ReplaceLoads(ldop, stop, tree^.right);
+   if tree^.opcode = pc_lod then
+      if tree^.optype = stop^.optype then
+         if tree^.q = stop^.q then
+            if tree^.r = stop^.r then
+               tree^ := ldop^;
+   end; {ReplaceLoads}
+
+
+   procedure ReverseChildren (op: icptr);
+
+   { reverse the children of a node				}
+   {								}
+   { parameters:						}
+   {    op - node for which to reverse the children		}
+
+   var
+      opt: icptr;			{temp opcode pointer}
+
+   begin {ReverseChildren}
+   opt := op^.right;
+   op^.right := op^.left;
+   op^.left := opt;
+   end; {ReverseChildren}
+
+
+   procedure ZeroIntermediateCode (op: icptr);
+
+   { Set all fields in the record to 0, nil, etc.		}
+   {								}
+   { Parameters:						}
+   {    op - intermediate code record to clear			}
+
+   begin {ZeroIntermediateCode}
+   op^.q := 0;
+   op^.r := 0;
+   op^.s := 0;
+   op^.lab := nil;
+   op^.next := nil;
+   op^.left := nil;
+   op^.right := nil;
+   op^.optype := cgWord;
+   op^.opnd := 0;
+   op^.llab := 0;
+   op^.slab := 0;
+   end; {ZeroIntermediateCode}
+
+
+begin {PeepHoleOptimization}
+if peepSpin = 0 then begin		{spinner}
+   peepSpin := peepSpinRate;
+   Spin;
+   end {if}
+else
+   peepSpin := peepSpin-1;
+{if printSymbols then begin write('Optimize: '); WriteCode(opv); end; {debug}
+op := opv;				{copy for efficiency}
+if op^.left <> nil then			{optimize the children}
+   PeepHoleOptimization(op^.left);
+if op^.right <> nil then
+   PeepHoleOptimization(op^.right);
+case op^.opcode of			{check for optimizations of this node}
+   pc_add: begin			{pc_add}
+      if op^.next^.opcode <> pc_add then
+         RemoveDeadCode(op);
+      end; {case pc_add}
+
+   pc_adi: begin			{pc_adi}
+      if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin
+         op^.left^.q := op^.left^.q + op^.right^.q;
+         opv := op^.left;
+         end {if}
+      else begin
+         if op^.left^.opcode = pc_ldc then
+            ReverseChildren(op);
+         if op^.right^.opcode = pc_ldc then begin
+            q := op^.right^.q;
+            if q = 0 then
+               opv := op^.left
+            else if q > 0 then begin
+               op^.opcode := pc_inc;
+               op^.q := q;
+               op^.right := nil;
+               end {else if}
+            else {if q < 0 then} begin
+               op^.opcode := pc_dec;
+               op^.q := -q;
+               op^.right := nil;
+               end; {else if}
+            end {if}
+         else if op^.left^.opcode in [pc_inc,pc_dec] then begin
+            if op^.right^.opcode in [pc_inc,pc_dec] then begin
+               op2 := op^.left;
+               if op^.left^.opcode = pc_inc then
+                  q := op^.left^.q
+               else
+                  q := -op^.left^.q;
+               if op^.right^.opcode = pc_inc then
+                  q := q + op^.right^.q
+               else
+                  q := q - op^.right^.q;
+               if q >= 0 then begin
+                  op2^.opcode := pc_inc;
+                  op2^.q := q;
+                  end {if}
+               else begin
+                  op2^.opcode := pc_dec;
+                  op2^.q := -q;
+                  end; {else}
+               op^.left := op^.left^.left;
+               op^.right := op^.right^.left;
+               op2^.left := op;
+               opv := op2;
+               PeepHoleOptimization(opv);
+               end; {if}
+            end {else if}
+         else if CodesMatch(op^.left, op^.right, false) then begin
+            if NoFunctions(op^.left) then begin
+               ZeroIntermediateCode(op^.right);
+               with op^.right^ do begin
+                  opcode := pc_ldc;
+                  q := 1;
+                  optype := cgWord;
+                  end; {with}
+               op^.opcode := pc_shl;
+               PeepHoleOptimization(opv);
+               end; {if}
+            end; {else if}
+         end; {else}
+      end; {case pc_adi}
+
+   pc_adl: begin			{pc_adl}
+      if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin
+         op^.left^.lval := op^.left^.lval + op^.right^.lval;
+         opv := op^.left;
+         end {if}
+      else begin
+         if op^.left^.opcode = pc_ldc then
+            ReverseChildren(op);
+         if op^.right^.opcode = pc_ldc then begin
+            lval := op^.right^.lval;
+            if lval = 0 then
+               opv := op^.left
+            else if (lval >= 0) and (lval <= maxint) then begin
+               op^.opcode := pc_inc;
+               op^.optype := cgLong;
+               op^.q := ord(lval);
+               op^.right := nil;
+               end {else if}
+            else if (lval > -maxint) and (lval < 0) then begin
+               op^.opcode := pc_dec;
+               op^.optype := cgLong;
+               op^.q := -ord(lval); 
+               op^.right := nil;
+               end; {else if}
+            end {if}
+         else if CodesMatch(op^.left, op^.right, false) then
+            if NoFunctions(op^.left) then begin
+               ZeroIntermediateCode(op^.right);
+               with op^.right^ do begin
+                  opcode := pc_ldc;
+                  lval := 1;
+                  optype := cgLong;
+                  end; {with}
+               op^.opcode := pc_sll;
+               end; {if}
+         if op^.right^.opcode in [pc_lao,pc_lda,pc_ixa] then
+            ReverseChildren(op);
+         if op^.left^.opcode in [pc_lao,pc_lda,pc_ixa] then
+            if op^.right^.opcode = pc_sll then begin
+               if op^.right^.right^.opcode = pc_ldc then
+                  if (op^.right^.right^.lval & $FFFF8000) = 0 then
+                     if op^.right^.left^.opcode = pc_cnv then begin
+                	fromtype.i := (op^.right^.left^.q & $00F0) >> 4;
+                	if fromType.optype in [cgByte,cgUByte,cgWord,cgUWord] then
+                           begin
+                           if fromType.optype = cgByte then
+                              op^.right^.left^.q := $02
+                           else if fromType.optype = cgUByte then
+                              op^.right^.left^.q := $13
+                           else
+                              op^.right^.left := op^.right^.left^.left;
+                           with op^.right^.right^ do begin
+                              lq := lval;
+                              lval := 0;
+                              q := long(lq).lsw;
+                              optype := cgUWord;
+                              end; {with}
+                           op^.right^.opcode := pc_shl;
+                           op^.opcode := pc_ixa;
+                           PeepHoleOptimization(opv);
+                           end; {if}
+                	end; {if}
+               end {if}
+            else if op^.right^.opcode = pc_cnv then begin
+               fromtype.i := (op^.right^.q & $00F0) >> 4;
+               if fromtype.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin
+                  if fromType.optype = cgByte then
+                     op^.right^.q := $02
+                  else if fromType.optype = cgUByte then
+                     op^.right^.q := $13
+                  else
+                     op^.right := op^.right^.left;
+                  op^.opcode := pc_ixa;
+                  PeepHoleOptimization(opv);
+                  end; {if}
+               end; {else if}
+         end; {else}
+      end; {case pc_adl}
+
+   pc_adr: begin			{pc_adr}
+      if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin
+         op^.left^.rval := op^.left^.rval + op^.right^.rval;
+         opv := op^.left;
+         end {if}
+      else begin
+         if op^.left^.opcode = pc_ldc then
+            ReverseChildren(op);
+         if op^.right^.opcode = pc_ldc then begin
+            if op^.right^.rval = 0.0 then
+               opv := op^.left;
+            end; {if}
+         end; {else}   
+      end; {case pc_adr}
+
+   pc_and: begin			{pc_and}
+      if op^.right^.opcode = pc_ldc then begin
+         if op^.left^.opcode = pc_ldc then begin
+            op^.left^.q := ord((op^.left^.q <> 0) and (op^.right^.q <> 0));
+            opv := op^.left;
+            end {if}
+         else begin
+            if op^.right^.q = 0 then 
+               if not SideEffects(op^.left) then 
+                  opv := op^.right;
+            end {else}
+         end {if}
+      else if op^.left^.opcode = pc_ldc then
+         if op^.left^.q = 0 then
+            opv := op^.left;
+      end; {case pc_and}
+
+   pc_bal: begin			{pc_bal}
+      if op^.left^.opcode = pc_ldc then
+         ReverseChildren(op);
+      if op^.left^.opcode = pc_ldc then begin
+         op^.left^.lval := op^.left^.lval & op^.right^.lval;
+         opv := op^.left;
+         end {if}
+      else if op^.right^.opcode = pc_ldc then begin
+         if op^.right^.lval = 0 then
+            opv := op^.right
+         else if op^.right^.lval = -1 then
+            opv := op^.left;
+         end; {else if}
+      end; {case pc_bal}
+
+   pc_blr: begin			{pc_blr}
+      if op^.left^.opcode = pc_ldc then
+         ReverseChildren(op);
+      if op^.left^.opcode = pc_ldc then begin
+         op^.left^.lval := op^.left^.lval | op^.right^.lval;
+         opv := op^.left;
+         end {if}
+      else if op^.right^.opcode = pc_ldc then begin
+         if op^.right^.lval = -1 then
+            opv := op^.right
+         else if op^.right^.lval = 0 then
+            opv := op^.left;
+         end; {else if}
+      end; {case pc_blr}
+
+   pc_blx: begin			{pc_blx}
+      if op^.left^.opcode = pc_ldc then
+         ReverseChildren(op);
+      if op^.left^.opcode = pc_ldc then begin
+         op^.left^.lval := op^.left^.lval ! op^.right^.lval;
+         opv := op^.left;
+         end {if}
+      else if op^.right^.opcode = pc_ldc then begin
+         if op^.right^.lval = 0 then
+            opv := op^.left
+         else if op^.right^.lval = -1 then begin
+            op^.opcode := pc_bnl;
+            op^.right := nil;
+            end; {else if}
+         end; {else if}
+      end; {case pc_blx}
+
+   pc_bnd: begin			{pc_bnd}
+      if op^.left^.opcode = pc_ldc then
+         ReverseChildren(op);
+      if op^.left^.opcode = pc_ldc then begin
+         op^.left^.q := op^.left^.q & op^.right^.q;
+         opv := op^.left;
+         end {if}
+      else if op^.right^.opcode = pc_ldc then begin
+         if op^.right^.q = 0 then
+            opv := op^.right
+         else if op^.right^.q = -1 then
+            opv := op^.left;
+         end; {else if}
+      end; {case pc_bnd}
+
+   pc_bnl: begin			{pc_bnl}
+      if op^.left^.opcode = pc_ldc then begin
+         op^.left^.lval := op^.left^.lval ! $FFFFFFFF;
+         opv := op^.left;
+         end; {if}
+      end; {case pc_bnl}
+
+   pc_bno: begin			{pc_bno}
+      if op^.left^.opcode = pc_str then
+         if op^.left^.left^.opcode in [pc_lda,pc_lao] then begin
+            ReplaceLoads(op^.left^.left, op^.left, op^.right);
+            opv := op^.right;
+            end; {if}
+      end; {case pc_bno}
+
+   pc_bnt: begin			{pc_bnt}
+      if op^.left^.opcode = pc_ldc then begin
+         op^.left^.q := op^.left^.q ! $FFFF;
+         opv := op^.left;
+         end; {if}
+      end; {case pc_bnt}
+
+   pc_bor: begin			{pc_bor}
+      if op^.left^.opcode = pc_ldc then
+         ReverseChildren(op);
+      if op^.left^.opcode = pc_ldc then begin
+         op^.left^.q := op^.left^.q | op^.right^.q;
+         opv := op^.left;
+         end {if}
+      else if op^.right^.opcode = pc_ldc then begin
+         if op^.right^.q = -1 then
+            opv := op^.right
+         else if op^.right^.q = 0 then
+            opv := op^.left;
+         end; {else if}
+      end; {case pc_bor}
+
+   pc_bxr: begin			{pc_bxr}
+      if op^.left^.opcode = pc_ldc then
+         ReverseChildren(op);
+      if op^.left^.opcode = pc_ldc then begin
+         op^.left^.q := op^.left^.q ! op^.right^.q;
+         opv := op^.left;
+         end {if}
+      else if op^.right^.opcode = pc_ldc then begin
+         if op^.right^.q = 0 then
+            opv := op^.left
+         else if op^.right^.q = -1 then begin
+            op^.opcode := pc_bnt;
+            op^.right := nil;
+            end; {else if}
+         end; {else if}
+      end; {case pc_bxr}
+
+   pc_cnv: begin			{pc_cnv}
+      fromtype.i := (op^.q & $00F0) >> 4;
+      totype.i := op^.q & $000F;
+      if op^.left^.opcode = pc_ldc then begin
+	 case fromtype.optype of
+            cgByte,cgWord:
+               case totype.optype of
+        	  cgByte,cgUByte,cgWord,cgUWord: ;
+        	  cgLong,cgULong: begin
+                     lval := op^.left^.q;
+                     op^.left^.q := 0;
+                     op^.left^.lval := lval;
+                     end;
+        	  cgReal,cgDouble,cgComp,cgExtended: begin
+                     rval := op^.left^.q;
+                     op^.left^.q := 0;
+                     op^.left^.rval := rval;
+                     end;
+                  otherwise: ;
+        	  end; {case}                             
+            cgUByte,cgUWord:
+               case totype.optype of
+        	  cgByte,cgUByte,cgWord,cgUWord: ;
+        	  cgLong,cgULong: begin
+                     lval := ord4(op^.left^.q) & $0000FFFF;
+                     op^.left^.q := 0;
+                     op^.left^.lval := lval;
+                     end;
+        	  cgReal,cgDouble,cgComp,cgExtended: begin
+                     rval := ord4(op^.left^.q) & $0000FFFF;
+                     op^.left^.q := 0;
+                     op^.left^.rval := rval;
+                     end;
+                  otherwise: ;
+        	  end; {case}                             
+            cgLong:
+               case totype.optype of
+        	  cgByte,cgUByte,cgWord,cgUWord: begin
+                     q := long(op^.left^.lval).lsw;                
+                     op^.left^.lval := 0;
+                     op^.left^.q := q;
+                     end;
+        	  cgLong, cgULong: ;
+        	  cgReal,cgDouble,cgComp,cgExtended: begin
+                     rval := op^.left^.lval;
+                     op^.left^.lval := 0;
+                     op^.left^.rval := rval;
+                     end;
+                  otherwise: ;
+        	  end; {case}
+            cgULong:
+               case totype.optype of
+        	  cgByte,cgUByte,cgWord,cgUWord: begin
+                     q := long(op^.left^.lval).lsw;
+                     op^.left^.lval := 0;
+                     op^.left^.q := q;
+                     end;
+        	  cgLong, cgULong: ;
+        	  cgReal,cgDouble,cgComp,cgExtended: begin
+                     lval := op^.left^.lval;
+                     op^.left^.lval := 0;
+                     if lval >= 0 then
+                        rval := lval
+                     else
+                        rval := (lval & $7FFFFFFF) + 2147483648.0;
+                     op^.left^.rval := rval;
+                     end;
+                  otherwise: ;
+        	  end; {case}
+            cgReal,cgDouble,cgComp,cgExtended: begin
+               rval := op^.left^.rval;
+               case totype.optype of
+        	  cgByte: begin
+                     if rval < -128.0 then
+                        q := -128
+                     else if rval > 127.0 then
+                        q := 127
+                     else
+                        q := trunc(rval);
+                     op^.left^.rval := 0.0;
+                     op^.left^.q := q;
+                     end;
+        	  cgUByte: begin
+                     if rval < 0.0 then
+                        q := 0
+                     else if rval > 255.0 then
+                        q := 255
+                     else
+                        q := trunc(rval);
+                     op^.left^.rval := 0.0;
+                     op^.left^.q := q;
+                     end;
+        	  cgWord: begin
+                     if rval < -32768.0 then
+                        lval := -32768
+                     else if rval > 32767.0 then
+                        lval := 32767
+                     else
+                        lval := trunc(rval);
+                     op^.left^.rval := 0.0;
+                     op^.left^.q := long(lval).lsw;
+                     end;
+        	  cgUWord: begin
+                     if rval < 0.0 then
+                        lval := 0
+                     else if rval > 65535.0 then
+                        lval := 65535
+                     else
+                        lval := trunc4(rval);
+                     op^.left^.rval := 0.0;
+                     op^.left^.q := long(lval).lsw;
+                     end;
+        	  cgLong,cgULong: begin
+                     if totype.optype = cgULong then begin
+                        if rval < 0 then
+                           rval := 0
+                        else if rval > 2147483647.0 then
+                           rval := rval - 4294967296.0
+                        end; {if}
+                     if rval < -2147483648.0 then
+                        lval := $80000000
+                     else if rval > 2147483647.0 then
+                        lval := 2147483647
+                     else
+                        lval := trunc4(rval);
+                     op^.left^.rval := 0.0;
+                     op^.left^.lval := lval;
+                     end;
+        	  cgReal,cgDouble,cgComp,cgExtended: ;
+                  otherwise: ;
+                  end;
+               end; {case}        
+            otherwise: ;
+            end; {case}
+         if fromtype.optype in
+            [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgReal,cgDouble,
+            cgComp,cgExtended] then
+            if totype.optype in
+               [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgReal,cgDouble,
+               cgComp,cgExtended] then begin
+               op^.left^.optype := totype.optype;
+               opv := op^.left;
+               end; {if}
+         end {if}
+      else if op^.left^.opcode = pc_cnv then begin
+         doit := false;
+         firsttype.i := (op^.q & $00F0) >> 4;
+         if fromType.optype in [cgReal,cgDouble,cgComp,cgExtended] then begin
+            if toType.optype in [cgReal,cgDouble,cgComp,cgExtended] then
+               doit := true;
+            end {if}
+         else begin
+            if firstType.optype in [cgByte,cgWord,cgLong] then
+               if fromType.optype in [cgByte,cgWord,cgLong] then
+                  if toType.optype in [cgByte,cgWord,cgLong] then
+                     doit := true;
+            if firstType.optype in [cgUByte,cgUWord,cgULong] then
+               if fromType.optype in [cgUByte,cgUWord,cgULong] then
+                  if toType.optype in [cgUByte,cgUWord,cgLong] then
+                     doit := true;
+            if TypeSize(firstType.optype) = TypeSize(fromType.optype) then
+               if TypeSize(firstType.optype) = TypeSize(toType.optype) then
+                  doit := true;
+            end; {else}
+         if doit then begin
+            op^.q := (op^.left^.q & $00F0) | (op^.q & $000F);
+            op^.left := op^.left^.left;
+            PeepHoleOptimization(opv);
+            end; {if}
+         end {else if}
+      else if op^.left^.opcode in [pc_lod,pc_ldo,pc_ind] then begin
+         if fromtype.optype in [cgWord,cgUWord] then
+            if totype.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin
+               op^.left^.optype := totype.optype;
+               opv := op^.left;
+               end; {if}
+         if fromtype.optype in [cgLong,cgULong] then
+            if totype.optype in [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong]
+               then begin
+               op^.left^.optype := totype.optype;
+               opv := op^.left;
+               end; {if}
+         end {else if}
+      else if op^.q in [$40,$41,$50,$51] then begin
+         {any long type to byte type}
+         with op^.left^ do
+            if opcode = pc_bal then
+               if right^.opcode = pc_ldc then
+                  if right^.lval = 255 then begin
+                     op^.left := op^.left^.left;
+                     PeepHoleOptimization(opv);
+                     end; {if}
+         with op^.left^ do    
+            if opcode in [pc_slr,pc_vsr] then
+               if right^.opcode = pc_ldc then
+                  if left^.opcode in [pc_lod,pc_ldo,pc_ind] then begin
+                     lq := right^.lval;
+                     if long(lq).msw = 0 then
+                        if long(lq).lsw in [8,16,24] then begin
+                           lq := lq div 8;
+                           left^.q := left^.q + long(lq).lsw;
+                           op^.left := left;
+                	   PeepHoleOptimization(opv);
+                	   end; {if}
+                     end; {if}
+         end; {else if}                     
+      end; {case pc_cnv}
+
+   pc_csp: begin			{pc_csp}
+      if op^.q = 91 then begin		{string move}
+         op2 := op^.left^.left^.right^.left;
+         op3 := op^.left^.right^.right^.left;
+         if op2^.opcode = pc_ldc then
+            if op3^.opcode = pc_ldc then
+               if op2^.q = op3^.q then begin
+                  q := op2^.q;
+                  if q < -1 then q := 1-q;
+                  if q > 0 then begin
+                     op^.opcode := pc_mov;
+                     op^.right := op^.left^.right^.left^.left;
+                     op^.left := op^.left^.left^.left^.left;
+                     op^.q := q;
+                     op^.r := 0;
+                     PeepHoleOptimization(opv);
+                     end; {if}  
+                  end; {if}
+         end {if}
+      else if op^.next <> nil then
+         if op^.next^.opcode = pc_csp then
+            if op^.next^.q = 26 then begin
+               if op^.q in [16,19,21,29,37] then begin
+                  if op^.q = 16 then
+                     op^.q := 34
+                  else if op^.q = 19 then
+                     op^.q := 12
+                  else
+                     op^.q := op^.q-1;
+                  op^.next := op^.next^.next;
+                  end; {if}
+               end {if}
+            else if op^.next^.q = 27 then begin
+               if op^.q in [39,42,25,31,23] then begin
+                  if op^.q = 42 then
+                     op^.q := 43
+                  else
+                     op^.q := op^.q-1;
+                  op^.next := op^.next^.next;
+                  end; {if}
+               end; {else if}
+      end; {case pc_csp}
+
+   pc_dec: begin			{pc_dec}
+      if op^.q = 0 then
+         opv := op^.left
+      else begin
+	 opcode := op^.left^.opcode;
+	 if opcode = pc_dec then begin
+            if ord4(op^.left^.q) + ord4(op^.q) < ord4(maxint) then begin
+               op^.q := op^.q + op^.left^.q;
+               op^.left := op^.left^.left;
+               end; {if}
+            end {if}
+	 else if opcode = pc_inc then begin
+            q := op^.q - op^.left^.q;
+            if q < 0 then begin
+               q := -q;
+               op^.opcode := pc_inc;
+               end; {if}
+            op^.q := q;
+            op^.left := op^.left^.left;
+            PeepHoleOptimization(opv);
+            end {else if}
+         else if opcode = pc_ldc then begin
+            if op^.optype in [cgLong, cgULong] then begin
+               op^.left^.lval := op^.left^.lval - op^.q;
+               opv := op^.left;
+               end {if}
+            else if op^.optype in [cgUByte, cgByte, cgUWord, cgWord] then begin
+               op^.left^.q := op^.left^.q - op^.q;
+               opv := op^.left;
+               end; {else if}
+            end; {else if}
+         end; {else}
+      end; {case pc_dec}
+
+   pc_dvi: begin			{pc_dvi}
+      if op^.right^.opcode = pc_ldc then begin
+         if op^.left^.opcode = pc_ldc then begin
+            if op^.right^.q <> 0 then begin
+               op^.left^.q := op^.left^.q div op^.right^.q;
+               opv := op^.left;
+               end; {if}
+            end {if}
+         else if op^.right^.q = 1 then
+            opv := op^.left;
+         end {if}
+      else if IsUnsigned(op^.left) and IsUnsigned(op^.right) then begin
+         op^.opcode := pc_udi;
+         PeepHoleOptimization(opv);
+         end; {else if}
+      end; {case pc_dvi}
+
+   pc_dvl: begin			{pc_dvl}
+      if op^.right^.opcode = pc_ldc then begin
+         if op^.left^.opcode = pc_ldc then begin
+            if op^.right^.lval <> 0 then begin
+               op^.left^.lval := op^.left^.lval div op^.right^.lval;
+               opv := op^.left;
+               end; {if}
+            end {if}
+         else if op^.right^.lval = 1 then
+            opv := op^.left;
+         end {if}
+      else if IsUnsigned(op^.left) and IsUnsigned(op^.right) then begin
+         op^.opcode := pc_udl;
+         PeepHoleOptimization(opv);
+         end; {else if}
+      end; {case pc_dvl}
+
+   pc_dvr: begin			{pc_dvr}
+      if op^.right^.opcode = pc_ldc then begin
+         if op^.left^.opcode = pc_ldc then begin
+            if op^.right^.rval <> 0.0 then begin
+               op^.left^.rval := op^.left^.rval/op^.right^.rval;
+               opv := op^.left;
+               end; {if}
+            end {if}
+         else if op^.right^.rval = 1.0 then
+            opv := op^.left;
+         end; {if}
+      end; {case pc_dvr}
+
+   pc_equ: begin			{pc_equ}
+      if op^.optype = cgSet then
+         if WordSet(op^.left) then begin
+            if WordSet(op^.right) then begin
+               MakeWordSet(op^.left);
+               MakeWordSet(op^.right);
+               op^.optype := cgUWord;
+               end; {if}
+            end {if}
+         else if LongSet(op^.left) then
+            if LongSet(op^.right) then begin
+               MakeLongSet(op^.left);
+               MakeLongSet(op^.right);
+               op^.optype := cgULong;
+               end; {if}
+      if IsUnsigned(op^.left) and IsUnsigned(op^.right) then
+         if op^.optype = cgWord then
+            op^.optype := cgUWord
+         else if op^.optype = cgLong then
+            op^.optype := cgULong
+         else if op^.optype = cgByte then
+            op^.optype := cgUByte;
+      if op^.left^.opcode = pc_ldc then
+         ReverseChildren(op);
+      if op^.right^.opcode = pc_ldc then begin
+	 if op^.left^.opcode = pc_ldc then begin
+            BinOps(op^.left, op^.right);
+            case op^.left^.optype of
+               cgByte,cgUByte,cgWord,cgUWord: begin
+        	  op^.opcode := pc_ldc;
+        	  op^.q := ord(op^.left^.q = op^.right^.q);
+        	  op^.left := nil;
+        	  op^.right := nil;
+        	  end;
+               cgLong,cgULong: begin
+        	  op^.opcode := pc_ldc;
+        	  op^.q := ord(op^.left^.lval = op^.right^.lval);
+        	  op^.left := nil;
+        	  op^.right := nil;
+        	  end;
+               cgReal,cgDouble,cgComp,cgExtended: begin
+        	  op^.opcode := pc_ldc;
+        	  op^.q := ord(op^.left^.rval = op^.right^.rval);
+        	  op^.left := nil;
+        	  op^.right := nil;
+        	  end;
+               cgSet: begin
+        	  op^.opcode := pc_ldc;
+        	  op^.q := ord(SetsEqual(op^.left^.setp, op^.right^.setp));
+        	  op^.left := nil;
+        	  op^.right := nil;
+        	  end;
+               cgVoid: begin
+        	  op^.opcode := pc_ldc;
+        	  op^.q := ord(op^.left^.pval = op^.right^.pval);
+        	  op^.left := nil;
+        	  op^.right := nil;
+        	  end;
+               end; {case}
+            op^.optype := cgUWord;
+            end {if}
+         else if op^.right^.optype in [cgByte, cgUByte, cgWord, cgUWord] then begin
+            if op^.right^.q <> 0 then
+               if op^.left^.opcode in
+         	  [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt]
+                  then begin
+                  opv := op^.left;
+                  opv^.next := op^.next;
+                  end; {if}
+            end {else if}
+         else if op^.right^.optype in [cgLong, cgULong] then begin
+            if op^.right^.lval <> 0 then
+               if op^.left^.opcode in
+         	  [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt]
+                  then begin
+                  opv := op^.left;
+                  opv^.next := op^.next;
+                  end; {if}
+            end; {else if}
+         end; {if}                      
+      end; {case pc_equ}
+
+   pc_fjp: begin			{pc_fjp}
+      opcode := op^.left^.opcode;
+      if opcode = pc_ldc then begin
+         if op^.left^.optype in [cgByte, cgUByte, cgWord, cgUWord] then begin
+            if op^.left^.q <> 0 then begin
+               opv := op^.next;
+               rescan := true;
+               end {if}
+            else begin
+               op^.opcode := pc_ujp;
+               op^.left := nil;
+               PeepHoleOptimization(opv);
+               end; {else}
+            end {if}
+         end {if}
+      else if opcode = pc_and then begin
+         op2 := op^.left;
+         op2^.next := op^.next;
+         op^.next := op2;
+         op^.left := op2^.left;
+         op2^.left := op2^.right;
+         op2^.right := nil;
+         op2^.opcode := pc_fjp;
+         op2^.q := op^.q;
+         PeepHoleOptimization(opv);
+         end {else if}
+      else if opcode = pc_ior then begin
+         op2 := op^.left;
+         op2^.next := op^.next;
+         op^.next := op2;
+         op^.left := op2^.left;
+         op2^.left := op2^.right;
+         op2^.right := nil;
+         op2^.opcode := pc_fjp;
+         op2^.q := op^.q;
+         op^.opcode := pc_tjp;
+         op3 := pointer(Calloc(sizeof(intermediate_code)));
+         op3^.opcode := dc_lab;
+         op3^.optype := cgWord;
+         op3^.q := GenLabel;
+         op3^.next := op2^.next;
+         op2^.next := op3;
+         op^.q := op3^.q;
+         PeepHoleOptimization(opv);
+         end {else if}
+      else
+         JumpOptimizations(op, pc_tjp);
+      end; {case pc_fjp}
+
+   pc_geq,pc_grt,pc_les:		{pc_geq, pc_grt, pc_les}
+      if IsUnsigned(op^.left) and IsUnsigned(op^.right) then
+         if op^.optype = cgWord then
+            op^.optype := cgUWord
+         else if op^.optype = cgLong then
+            op^.optype := cgULong
+         else if op^.optype = cgByte then
+            op^.optype := cgUByte;
+
+   pc_inc: begin			{pc_inc}
+      if op^.q = 0 then
+         opv := op^.left
+      else begin
+	 opcode := op^.left^.opcode;
+	 if opcode = pc_inc then begin
+            if ord4(op^.left^.q) + ord4(op^.q) < ord4(maxint) then begin
+               op^.q := op^.q + op^.left^.q;
+               op^.left := op^.left^.left;
+               end; {if}
+            end {if}
+	 else if opcode = pc_dec then begin
+            q := op^.q - op^.left^.q;
+            if q < 0 then begin
+               q := -q;
+               op^.opcode := pc_dec;
+               end; {if}
+            op^.q := q;
+            op^.left := op^.left^.left;
+            PeepHoleOptimization(opv);
+            end {else if}
+         else if opcode = pc_ldc then begin
+            if op^.optype in [cgLong, cgULong] then begin
+               op^.left^.lval := op^.left^.lval + op^.q;
+               opv := op^.left;
+               end {if}
+            else if op^.optype in [cgUByte, cgByte, cgUWord, cgWord] then begin
+               op^.left^.q := op^.left^.q + op^.q;
+               opv := op^.left;
+               end; {else if}
+            end {else if}
+         else if opcode in [pc_lao,pc_lda] then begin
+            op^.left^.q := op^.left^.q + op^.q;
+            opv := op^.left;
+            end; {else if}
+         end; {else}
+      end; {case pc_inc}
+
+   pc_ind: begin			{pc_ind}
+      if op^.optype <> cgSet then begin
+	 opcode := op^.left^.opcode;
+	 if opcode = pc_lda then begin
+            op^.left^.opcode := pc_lod;
+            op^.left^.optype := op^.optype;
+            op^.left^.q := op^.left^.q + op^.q;
+            op^.left^.r := op^.left^.s;
+            op^.left^.s := 0;
+            opv := op^.left;
+            end {if}
+	 else if opcode = pc_lao then begin
+            op^.left^.opcode := pc_ldo;
+            op^.left^.optype := op^.optype;
+            op^.left^.q := op^.left^.q + op^.q;
+            opv := op^.left;
+            end; {else if}
+         end; {if}
+      end; {case pc_ind}
+
+   pc_int: begin			{pc_int}
+      if op^.left^.opcode = pc_ldc then
+         if op^.right^.opcode = pc_ldc then begin
+            if op^.left^.setp^.smax > op^.right^.setp^.smax then
+               ReverseChildren(op);
+            set1 := op^.left^.setp;
+            set2 := op^.right^.setp;
+            for i := 1 to set1^.smax do
+               set1^.sval[i] := chr(ord(set1^.sval[i]) & ord(set2^.sval[i]));
+            i := set1^.smax;
+            while (i <> 1) and (ord(set1^.sval[i]) = 0) do
+               i := i-1;
+            set1^.smax := i;
+            opv := op^.left;
+            end; {if}
+      end; {case pc_int}
+
+   pc_ior: begin			{pc_ior}
+      if op^.right^.opcode = pc_ldc then begin
+         if op^.left^.opcode = pc_ldc then begin
+            op^.left^.q := ord((op^.left^.q <> 0) or (op^.right^.q <> 0));
+            opv := op^.left;
+            end {if}
+         else begin
+            if op^.right^.q <> 0 then begin
+               if not SideEffects(op^.left) then begin
+                  op^.right^.q := 1;
+                  opv := op^.right;
+                  end; {if}
+               end {if}
+            else
+               op^.opcode := pc_neq;
+            end {if}
+         end {if}
+      else if op^.left^.opcode = pc_ldc then
+         if op^.left^.q <> 0 then begin
+            op^.left^.q := 1;
+            opv := op^.left;
+            end; {if}
+      end; {case pc_ior}
+
+   pc_ixa: begin			{pc_ixa}
+      if op^.right^.opcode = pc_ldc then begin
+         optype := op^.right^.optype;
+         if optype in [cgUByte, cgByte, cgUWord, cgWord] then begin
+            lval := op^.right^.q;
+            if optype = cgUByte then
+               lval := lval & $000000FF
+            else if optype = cgUWord then
+               lval := lval & $0000FFFF;
+            done := false;
+            if op^.left^.opcode in [pc_lao, pc_lda] then begin
+               lq := op^.left^.q + lval;
+               if (lq >= 0) and (lq < maxint) then begin
+                  done := true;
+                  op^.left^.q := ord(lq);
+                  opv := op^.left;
+                  end; {if}
+               end; {if}
+            if not done then begin
+               op^.right^.lval := lval;
+               op^.right^.optype := cgLong;
+               op^.opcode := pc_adl;
+               PeepHoleOptimization(opv);
+               end; {if}
+            end; {if}                   
+         end {if}
+      else if op^.left^.opcode = pc_lao then begin
+         if op^.right^.opcode = pc_inc then begin
+            lq := ord4(op^.right^.q) + ord4(op^.left^.q);
+            if lq < maxint then begin
+               op^.left^.q := ord(lq);
+               op^.right := op^.right^.left;
+               end; {if}
+            PeepHoleOptimization(opv);
+            end; {if}
+         end {else if}
+      else if op^.left^.opcode = pc_ixa then begin
+         op2 := op^.left;
+         op^.left := op^.left^.left;
+         op2^.left := op^.right;
+         op2^.opcode := pc_adi;
+         op^.right := op2;
+         end; {else if}
+      end; {case pc_ixa}
+
+   pc_leq: begin			{pc_leq}
+      if IsUnsigned(op^.left) and IsUnsigned(op^.right) then
+         if op^.optype = cgWord then
+            op^.optype := cgUWord
+         else if op^.optype = cgLong then
+            op^.optype := cgULong
+         else if op^.optype = cgByte then
+            op^.optype := cgUByte;
+      if op^.optype in [cgWord,cgUWord] then
+         if op^.right^.opcode = pc_ldc then
+            if op^.right^.q < maxint then begin
+               op^.right^.q := op^.right^.q + 1;
+               op^.opcode := pc_les;
+               end; {if}
+      end; {case pc_lnm}
+
+   pc_lnd: begin			{pc_lnd}
+      if op^.right^.opcode = pc_ldc then begin
+         if op^.left^.opcode = pc_ldc then begin
+            op^.left^.q := ord((op^.left^.lval <> 0) and (op^.right^.lval <> 0));
+            op^.left^.optype := cgWord;
+            opv := op^.left;
+            end {if}
+         else begin
+            if op^.right^.lval = 0 then begin
+               if not SideEffects(op^.left) then  begin
+                  with op^.right^ do begin
+                     lval := 0;
+                     optype := cgWord;
+                     q := 0;
+                     end; {with}
+                  opv := op^.right;
+                  end; {if}
+               end {if}
+            else
+               op^.opcode := pc_neq;
+            end; {if}
+         end {if}
+      else if op^.left^.opcode = pc_ldc then
+         if op^.left^.lval = 0 then begin
+            with op^.left^ do begin
+               lval := 0;
+               optype := cgWord;
+               q := 0;
+               end; {with}
+            opv := op^.left;
+            end; {if}
+      end; {case pc_lnd}
+
+   pc_lnm: begin			{pc_lnm}
+      if op^.next^.opcode = pc_lnm then begin
+         opv := op^.next;
+         rescan := true;
+         end; {if}
+      end; {case pc_lnm}
+
+   pc_lor: begin			{pc_lor}
+      if op^.right^.opcode = pc_ldc then begin
+         if op^.left^.opcode = pc_ldc then begin
+            op^.left^.q := ord((op^.left^.lval <> 0) or (op^.right^.lval <> 0));
+            optype := cgWord;
+            opv := op^.left;
+            end {if}
+         else begin
+            if op^.right^.lval <> 0 then begin
+               if not SideEffects(op^.left) then begin
+                  op^.right^.lval := 0;
+                  op^.right^.q := 1;
+                  op^.right^.optype := cgWord;
+                  opv := op^.right;
+                  end; {if}
+               end {if}
+            else begin
+               op^.opcode := pc_neq;
+               op^.optype := cgLong;
+               end; {else}
+            end; {if}
+         end {if}
+      else if op^.left^.opcode = pc_ldc then
+         if op^.left^.lval <> 0 then begin
+            op^.left^.lval := 0;
+            op^.left^.q := 1;
+            op^.left^.optype := cgWord;
+            opv := op^.left;
+            end; {if}
+      end; {case pc_lor}
+
+   pc_mdl: begin			{pc_mdl}
+      if op^.right^.opcode = pc_ldc then  begin
+         if op^.left^.opcode = pc_ldc then 
+            if op^.right^.lval <> 0 then begin
+               op^.left^.lval := op^.left^.lval mod op^.right^.lval;
+               opv := op^.left;
+               end; {if}
+         end {if}
+      else if IsUnsigned(op^.left) and IsUnsigned(op^.right) then begin
+         op^.opcode := pc_ulm;
+         PeepHoleOptimization(opv);
+         end; {else if}
+      end; {case pc_mdl}
+
+   pc_mod: begin			{pc_mod}
+      if op^.right^.opcode = pc_ldc then  begin
+         if op^.left^.opcode = pc_ldc then 
+            if op^.right^.q <> 0 then begin
+               op^.left^.q := op^.left^.q mod op^.right^.q;
+               opv := op^.left;
+               end; {if}
+         end {if}
+      else if IsUnsigned(op^.left) and IsUnsigned(op^.right) then begin
+         op^.opcode := pc_uim;
+         PeepHoleOptimization(opv);
+         end; {else if}
+      end; {case pc_mod}
+
+   pc_mpi, pc_umi: begin		{pc_mpi, pc_umi}
+      if IsUnsigned(op^.left) and IsUnsigned(op^.right) then
+         op^.opcode := pc_umi;
+      if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin
+         if op^.opcode = pc_mpi then
+            op^.left^.q := op^.left^.q*op^.right^.q
+         else {if op^.opcode = pc_umi then} begin
+            lval := umul(op^.left^.q & $0000FFFF, op^.right^.q & $0000FFFF);
+            op^.left^.q := long(lval).lsw;
+            end; {else}
+         opv := op^.left;
+         end {if}
+      else begin
+         if op^.left^.opcode = pc_ldc then
+            ReverseChildren(op);
+         if op^.right^.opcode = pc_ldc then begin
+            q := op^.right^.q;
+            if q = 1 then
+               opv := op^.left
+            else if q = 0 then begin
+               if NoFunctions(op^.left) then
+                  opv := op^.right;
+               end {else if}
+            else if (q = -1) and (op^.opcode = pc_mpi) then begin
+               op^.opcode := pc_ngi;
+               op^.right := nil;
+               end {else if}
+            else if OneBit(q) then begin
+               op^.right^.q := Base(q);
+               op^.opcode := pc_shl;
+               PeepHoleOptimization(opv);
+               end; {else if}
+            end; {if}
+         end; {else}
+      end; {case pc_mpi, pc_umi}
+
+   pc_mpl, pc_uml: begin		{pc_mpl, pc_uml}
+      if IsUnsigned(op^.left) and IsUnsigned(op^.right) then
+         op^.opcode := pc_uml;
+      if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin
+         if op^.opcode = pc_mpl then
+            op^.left^.lval := op^.left^.lval*op^.right^.lval
+         else {if op^.opcode = pc_uml then}
+            op^.left^.lval := umul(op^.left^.lval, op^.right^.lval);
+         opv := op^.left;
+         end {if}
+      else begin
+         if op^.left^.opcode = pc_ldc then
+            ReverseChildren(op);
+         if op^.right^.opcode = pc_ldc then begin
+            lval := op^.right^.lval;
+            if lval = 1 then
+               opv := op^.left
+            else if lval = 0 then begin
+               if NoFunctions(op^.left) then
+                  opv := op^.right;
+               end {else if}
+            else if (lval = -1) and (op^.opcode = pc_mpl) then begin
+               op^.opcode := pc_ngl;
+               op^.right := nil;
+               end {else if}
+            else if OneBit(lval) then begin
+               op^.right^.lval := Base(lval);
+               op^.opcode := pc_sll;
+               end; {else if}
+            end; {if}
+         end; {else}
+      end; {case pc_mpl, pc_uml}
+
+   pc_mpr: begin			{pc_mpr}
+      if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin
+         op^.left^.rval := op^.left^.rval*op^.right^.rval;
+         opv := op^.left;
+         end {if}
+      else begin
+         if op^.left^.opcode = pc_ldc then
+            ReverseChildren(op);
+         if op^.right^.opcode = pc_ldc then begin
+            rval := op^.right^.rval;
+            if rval = 1.0 then
+               opv := op^.left
+            else if rval = 0.0 then
+               if NoFunctions(op^.left) then
+                  opv := op^.right;
+            end; {if}
+         end; {else}
+      end; {case pc_mpr}
+
+   pc_neq: begin			{pc_neq}
+      if op^.optype = cgSet then
+         if WordSet(op^.left) then begin
+            if WordSet(op^.right) then begin
+               MakeWordSet(op^.left);
+               MakeWordSet(op^.right);
+               op^.optype := cgUWord;
+               end; {if}
+            end {if}
+         else if LongSet(op^.left) then
+            if LongSet(op^.right) then begin
+               MakeLongSet(op^.left);
+               MakeLongSet(op^.right);
+               op^.optype := cgULong;
+               end; {if}
+      if IsUnsigned(op^.left) and IsUnsigned(op^.right) then
+         if op^.optype = cgWord then
+            op^.optype := cgUWord
+         else if op^.optype = cgLong then
+            op^.optype := cgULong
+         else if op^.optype = cgByte then
+            op^.optype := cgUByte;
+      if op^.left^.opcode = pc_ldc then
+         ReverseChildren(op);
+      if op^.right^.opcode = pc_ldc then begin
+	 if op^.left^.opcode = pc_ldc then begin
+            BinOps(op^.left, op^.right);
+            case op^.left^.optype of
+               cgByte,cgUByte,cgWord,cgUWord: begin
+        	  op^.opcode := pc_ldc;
+        	  op^.q := ord(op^.left^.q <> op^.right^.q);
+        	  op^.left := nil;
+        	  op^.right := nil;
+        	  end;
+               cgLong,cgULong: begin
+        	  op^.opcode := pc_ldc;
+        	  op^.q := ord(op^.left^.lval <> op^.right^.lval);
+        	  op^.left := nil;
+        	  op^.right := nil;
+        	  end;
+               cgReal,cgDouble,cgComp,cgExtended: begin
+        	  op^.opcode := pc_ldc;
+        	  op^.q := ord(op^.left^.rval <> op^.right^.rval);
+        	  op^.left := nil;
+        	  op^.right := nil;
+        	  end;
+               cgSet: begin
+        	  op^.opcode := pc_ldc;
+        	  op^.q := ord(not SetsEqual(op^.left^.setp, op^.right^.setp));
+        	  op^.left := nil;
+        	  op^.right := nil;
+        	  end;
+               cgVoid: begin
+        	  op^.opcode := pc_ldc;
+        	  op^.q := ord(op^.left^.pval <> op^.right^.pval);
+        	  op^.left := nil;
+        	  op^.right := nil;
+        	  end;
+               end; {case}
+            op^.optype := cgUWord;
+            end {if}
+         else if op^.right^.optype in [cgByte, cgUByte, cgWord, cgUWord] then begin
+            if op^.right^.q = 0 then
+               if op^.left^.opcode in
+         	  [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt]
+                  then begin
+                  opv := op^.left;
+                  opv^.next := op^.next;
+                  end; {if}
+            end {else if}
+         else if op^.right^.optype in [cgLong, cgULong] then begin
+            if op^.right^.lval = 0 then
+               if op^.left^.opcode in
+         	  [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt]
+                  then begin
+                  opv := op^.left;
+                  opv^.next := op^.next;
+                  end; {if}
+            end; {else if}
+         end; {if}                      
+      end; {case pc_neq}
+
+   pc_ngi: begin			{pc_ngi}
+      if op^.left^.opcode = pc_ldc then begin
+         op^.left^.q := -op^.left^.q;
+         op^.left^.optype := cgWord;
+         opv := op^.left;
+         end; {if}
+      end; {case pc_ngi}
+
+   pc_ngl: begin			{pc_ngl}
+      if op^.left^.opcode = pc_ldc then begin
+         op^.left^.lval := -op^.left^.lval;
+         op^.left^.optype := cgLong;
+         opv := op^.left;           
+         end; {if}
+      end; {case pc_ngl}
+
+   pc_ngr: begin			{pc_ngr}
+      if op^.left^.opcode = pc_ldc then begin
+         op^.left^.rval := -op^.left^.rval;
+         opv := op^.left;
+         end; {if}
+      end; {case pc_ngr}
+
+   pc_not: begin			{pc_not}
+      opcode := op^.left^.opcode;
+      if opcode = pc_ldc then begin
+         if op^.left^.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin
+            op^.left^.q := ord(op^.left^.q = 0);
+            opv := op^.left;
+            end {if}
+         else if op^.left^.optype in [cgLong,cgULong] then begin
+            q := ord(op^.left^.lval = 0);
+            lval := 0;
+            op^.left^.q := q;
+            op^.left^.optype := cgWord;
+            opv := op^.left;
+            end; {else if}
+         end {if}
+      else if opcode = pc_equ then begin
+         op^.left^.opcode := pc_neq;
+         opv := op^.left;
+         end {else if}
+      else if opcode = pc_neq then begin
+         op^.left^.opcode := pc_equ;
+         opv := op^.left;
+         end {else if}
+      else if opcode = pc_geq then begin
+         if op^.left^.optype <> cgSet then begin
+            op^.left^.opcode := pc_les;
+            opv := op^.left;
+            end; {if}
+         end {else if}
+      else if opcode = pc_grt then begin
+         op^.left^.opcode := pc_leq;
+         opv := op^.left;
+         end {else if}
+      else if opcode = pc_les then begin
+         op^.left^.opcode := pc_geq;
+         opv := op^.left;
+         end {else if}
+      else if opcode = pc_leq then begin
+         if op^.left^.optype <> cgSet then begin
+            op^.left^.opcode := pc_grt;
+            opv := op^.left;
+            end; {if}
+         end; {else if}
+      end; {case pc_not}
+
+   pc_ret: begin			{pc_ret}
+      RemoveDeadCode(op);
+      end; {case pc_ret}
+
+   pc_sbi: begin			{pc_sbi}
+      if op^.left^.opcode = pc_ldc then begin
+         if op^.right^.opcode = pc_ldc then begin
+            op^.left^.q := op^.left^.q - op^.right^.q;
+            opv := op^.left;
+            end {if}
+         else if op^.left^.q = 0 then begin
+            op^.opcode := pc_ngi;
+            op^.left := op^.right;
+            op^.right := nil;
+            end; {else if}
+         end {if}
+      else if op^.right^.opcode = pc_ldc then begin
+         q := op^.right^.q;
+         if q = 0 then
+            opv := op^.left
+         else if (q > 0) then begin
+            op^.opcode := pc_dec;
+            op^.q := q;
+            op^.right := nil;
+            end {else if}
+         else {if q < 0) then} begin
+            op^.opcode := pc_inc;
+            op^.q := -q;
+            op^.right := nil;
+            end; {else if}
+         end {if}
+      else if op^.left^.opcode in [pc_inc,pc_dec] then
+         if op^.right^.opcode in [pc_inc,pc_dec] then begin
+            op2 := op^.left;
+            if op^.left^.opcode = pc_inc then
+               q := op^.left^.q
+            else
+               q := -op^.left^.q;
+            if op^.right^.opcode = pc_inc then
+               q := q - op^.right^.q
+            else
+               q := q + op^.right^.q;
+            if q >= 0 then begin
+               op2^.opcode := pc_inc;
+               op2^.q := q;
+               end {if}
+            else begin
+               op2^.opcode := pc_dec;
+               op2^.q := -q;
+               end; {else}
+            op^.left := op^.left^.left;
+            op^.right := op^.right^.left;
+            op2^.left := op;
+            opv := op2;
+            PeepHoleOptimization(opv);
+            end; {if}
+      end; {case pc_sbi}
+
+   pc_sbl: begin			{pc_sbl}
+      if op^.left^.opcode = pc_ldc then begin
+         if op^.right^.opcode = pc_ldc then begin
+            op^.left^.lval := op^.left^.lval - op^.right^.lval;
+            opv := op^.left;
+            end {if}
+         else if op^.left^.lval = 0 then begin
+            op^.opcode := pc_ngl;
+            op^.left := op^.right;
+            op^.right := nil;
+            end; {else if}
+         end {if}
+      else if op^.right^.opcode = pc_ldc then begin
+         lval := op^.right^.lval;
+         if lval = 0 then
+            opv := op^.left
+         else if (lval > 0) and (lval <= maxint) then begin
+            op^.opcode := pc_dec;
+            op^.q := ord(lval);
+            op^.right := nil;
+            op^.optype := cgLong;
+            end {else if}
+         else if (lval > -maxint) and (lval < 0) then begin
+            op^.opcode := pc_inc;
+            op^.q := -ord(lval);
+            op^.right := nil;
+            op^.optype := cgLong;
+            end; {else if}       
+         end; {if}
+      end; {case pc_sbl}
+
+   pc_sbr: begin			{pc_sbr}
+      if op^.left^.opcode = pc_ldc then begin
+         if op^.right^.opcode = pc_ldc then begin
+            op^.left^.rval := op^.left^.rval - op^.right^.rval;
+            opv := op^.left;
+            end {if}
+         else if op^.left^.rval = 0.0 then begin
+            op^.opcode := pc_ngr;
+            op^.left := op^.right;
+            op^.right := nil;
+            end; {else if}
+         end {if}
+      else if op^.right^.opcode = pc_ldc then begin
+         if op^.right^.rval = 0.0 then
+            opv := op^.left;
+         end; {if}
+      end; {case pc_sbr}
+
+   pc_sgs: begin			{pc_sgs}
+      if op^.left^.opcode = pc_ldc then
+         if op^.right^.opcode = pc_ldc then begin
+            set1 := pointer(Calloc(sizeof(setRecord)));
+            q := op^.right^.q;
+            if q = $8000 then
+               q := op^.left^.q;
+            set1^.smax := q div 8 + 1;
+            for i := op^.left^.q to q do begin
+               j := i div 8 + 1;
+               set1^.sval[j] := chr(ord(set1^.sval[j]) | ($0001 << (i mod 8)));
+               end; {for}
+            op^.left := nil;
+            op^.right := nil;
+            op^.opcode := pc_ldc;
+            op^.optype := cgSet;
+            op^.setp := set1;
+            end; {if}
+      end; {case pc_sgs}
+
+   pc_shl: begin			{pc_shl}
+      if op^.right^.opcode = pc_ldc then begin
+         opcode := op^.left^.opcode;
+         if opcode = pc_shl then begin
+            if op^.left^.right^.opcode = pc_ldc then begin
+               op^.right^.q := op^.right^.q + op^.left^.right^.q;
+               op^.left := op^.left^.left;
+               end; {if}
+            end {if}
+         else if opcode = pc_inc then begin
+            op2 := op^.left;
+            op^.left := op2^.left;
+            op2^.q := op2^.q << op^.right^.q;
+            op2^.left := op;
+            opv := op2;
+            PeepHoleOptimization(op2^.left);
+            end; {else if}
+         end; {if}
+      end; {case pc_shl}
+
+   pc_shr:				{pc_shr}
+      if IsUnsigned(op^.left) then
+         op^.opcode := pc_usr;
+
+   pc_slr:				{pc_slr}
+      if IsUnsigned(op^.left) then
+         op^.opcode := pc_vsr;
+
+   pc_sro: begin			{pc_sro}
+      if op^.optype in [cgReal,cgDouble,cgComp,cgExtended] then
+         RealStoreOptimizations(op, op^.left)
+      else if op^.optype = cgSet then begin
+         if op^.q = 2 then begin
+            if WordSet(op^.left) then begin
+               MakeWordSet(op^.left);
+               op^.q := op^.r;
+               op^.r := 0;
+               op^.optype := cgUWord;
+               PeepHoleOptimization(opv);
+               end; {if}
+            end {if}
+         else if op^.q = 4 then begin
+            if LongSet(op^.left) then begin
+               MakeLongSet(op^.left);
+               op^.q := op^.r;
+               op^.r := 0;
+               op^.optype := cgULong;
+               PeepHoleOptimization(opv);
+               end; {if}
+            end; {else if}
+         end; {else if}
+      end; {case pc_sro}
+
+   pc_sto: begin			{pc_sto}
+      if op^.optype in [cgReal,cgDouble,cgComp,cgExtended] then
+         RealStoreOptimizations(op, op^.right);
+      if op^.optype <> cgSet then begin
+	 if op^.left^.opcode = pc_lao then begin
+            op^.q := op^.left^.q;
+            op^.lab := op^.left^.lab;
+            op^.opcode := pc_sro;
+            op^.left := op^.right;
+            op^.right := nil;
+            end {if}
+	 else if op^.left^.opcode = pc_lda then begin
+            op^.q := op^.left^.q;
+            op^.r := op^.left^.s;
+            op^.p := op^.left^.p;
+            op^.opcode := pc_str;
+            op^.left := op^.right;
+            op^.right := nil;
+            end; {if}
+         end; {if}
+      end; {case pc_sto}
+
+   pc_str: begin			{pc_str}
+      if op^.optype in [cgReal,cgDouble,cgComp,cgExtended] then
+         RealStoreOptimizations(op, op^.left)
+      else if op^.optype = cgSet then begin
+         if op^.s = 2 then begin
+            if WordSet(op^.left) then begin
+               MakeWordSet(op^.left);
+               op^.s := 0;
+               op^.optype := cgUWord;
+               PeepHoleOptimization(opv);
+               end; {if}
+            end {if}
+         else if op^.s = 4 then begin
+            if LongSet(op^.left) then begin
+               MakeLongSet(op^.left);
+               op^.s := 0;
+               op^.optype := cgULong;
+               PeepHoleOptimization(opv);
+               end; {if}
+            end; {else if}
+         end; {else if}
+      end; {case pc_str}
+
+   pc_tjp: begin			{pc_tjp}
+      opcode := op^.left^.opcode;
+      if opcode = pc_ldc then begin
+         if op^.left^.optype in [cgByte, cgUByte, cgWord, cgUWord] then
+            if op^.left^.q = 0 then begin
+               opv := op^.next;
+               rescan := true;
+               end {if}
+            else begin
+               op^.opcode := pc_ujp;
+               op^.left := nil;
+               PeepHoleOptimization(opv);
+               end; {else}
+         end {if}
+      else if opcode = pc_ior then begin
+         op2 := op^.left;
+         op2^.next := op^.next;
+         op^.next := op2;
+         op^.left := op2^.left;
+         op2^.left := op2^.right;
+         op2^.right := nil;
+         op2^.opcode := pc_tjp;
+         op2^.q := op^.q;
+         PeepHoleOptimization(opv);
+         end {else if}
+      else if opcode = pc_and then begin
+         op2 := op^.left;
+         op2^.next := op^.next;
+         op^.next := op2;
+         op^.left := op2^.left;
+         op2^.left := op2^.right;
+         op2^.right := nil;
+         op2^.opcode := pc_tjp;
+         op2^.q := op^.q;
+         op^.opcode := pc_fjp;
+         op3 := pointer(Calloc(sizeof(intermediate_code)));
+         op3^.opcode := dc_lab;
+         op3^.optype := cgWord;
+         op3^.q := GenLabel;
+         op3^.next := op2^.next;
+         op2^.next := op3;
+         op^.q := op3^.q;
+         PeepHoleOptimization(opv);
+         end {else if}
+      else
+         JumpOptimizations(op, pc_fjp);
+      end; {case pc_tjp}
+
+   pc_udi: begin			{pc_udi}
+      if op^.right^.opcode = pc_ldc then begin
+         q := op^.right^.q;
+         if op^.left^.opcode = pc_ldc then begin
+            if q <> 0 then begin
+               op^.left^.q := ord(udiv(op^.left^.q & $0000FFFF, q & $0000FFFF));
+               opv := op^.left;
+               end; {if}
+            end {if}
+         else if q = 1 then
+            opv := op^.left
+         else if OneBit(q) then begin
+            op^.right^.q := Base(q);
+            op^.opcode := pc_usr;
+            end; {else if}
+         end; {if}
+      end; {case pc_udi}
+
+   pc_udl: begin			{pc_udl}
+      if op^.right^.opcode = pc_ldc then begin
+         lq := op^.right^.lval;
+         if op^.left^.opcode = pc_ldc then begin
+            if lq <> 0 then begin
+               op^.left^.lval := udiv(op^.left^.lval, lq);
+               opv := op^.left;
+               end; {if}
+            end {if}
+         else if lq = 1 then
+            opv := op^.left
+         else if OneBit(lq) then begin
+            op^.right^.lval := Base(lq);
+            op^.opcode := pc_vsr;
+            end; {else if}
+         end; {if}
+      end; {case pc_udl}
+
+   pc_uim: begin			{pc_uim}
+      if op^.right^.opcode = pc_ldc then 
+         if op^.left^.opcode = pc_ldc then 
+            if op^.right^.q <> 0 then begin
+               op^.left^.q :=
+                  ord(umod(op^.left^.q & $0000FFFF, op^.right^.q & $0000FFFF));
+               opv := op^.left;
+               end; {if}
+      end; {case pc_uim}
+
+   pc_ujp: begin			{pc_ujp}
+      RemoveDeadCode(op);
+      if op^.next^.opcode = dc_lab then begin
+         if LabelsMatch(op, op^.next) then begin
+            opv := op^.next;
+            rescan := true;
+            end {if}
+         else if op^.next^.next^.opcode = dc_lab then
+            if LabelsMatch(op^.next^.next, op) then begin
+               opv := op^.next;
+               rescan := true;
+               end; {if}
+         end; {if}
+      end; {case pc_ujp}
+
+   pc_ulm: begin			{pc_ulm}
+      if op^.right^.opcode = pc_ldc then 
+         if op^.left^.opcode = pc_ldc then 
+            if op^.right^.lval <> 0 then begin
+               op^.left^.lval := umod(op^.left^.lval, op^.right^.lval);
+               opv := op^.left;
+               end; {if}
+      end; {case pc_ulm}
+
+   pc_uni: begin			{pc_uni}
+      if op^.left^.opcode = pc_ldc then
+         if op^.right^.opcode = pc_ldc then begin
+            if op^.left^.setp^.smax < op^.right^.setp^.smax then
+               ReverseChildren(op);
+            set1 := op^.left^.setp;
+            set2 := op^.right^.setp;
+            for i := 1 to set1^.smax do
+               set1^.sval[i] := chr(ord(set1^.sval[i]) | ord(set2^.sval[i]));
+            opv := op^.left;
+            end; {if}
+      end; {case pc_uni}
+
+   otherwise: ;
+   end; {case}
+end; {PeepHoleOptimization}
+
+{- Common Subexpression Elimination ----------------------------}
+
+function MatchLoc (op1, op2: icptr): boolean;
+
+{ See if two loads, stores or copies refer to the same		}
+{ location							}
+{								}
+{ parameters:							}
+{    op1, op2 - operations to check				}
+{								}
+{ Returns: True if they do, false if they don't.		}
+
+begin {MatchLoc}
+MatchLoc := false;
+if (op1^.opcode in [pc_str,pc_cop,pc_lod,pc_lda])
+   and (op2^.opcode in [pc_str,pc_cop,pc_lod,pc_lda]) then begin
+   if op1^.r = op2^.r then
+      MatchLoc := true;
+   end {if}
+else if (op1^.opcode in [pc_sro,pc_cpo,pc_ldo,pc_lao])
+   and (op2^.opcode in [pc_sro,pc_cpo,pc_ldo,pc_lao]) then
+   if op1^.lab^ = op2^.lab^ then
+      MatchLoc := true;
+end; {MatchLoc}                       
+
+
+function Member (op: icptr; list: iclist): boolean;
+
+{ See if the operand of a load is referenced in a list		}
+{								}
+{ parameters:							}
+{    op - load to check						}
+{    list - list to check					}
+{								}
+{ Returns: True if op is in list, else false.			}
+{								}
+{ Notes: As a side effect, this subroutine sets memberOp to	}
+{    point to any matching member; memberOp is undefined if	}
+{    there is no matching member.				}
+
+begin {Member}
+Member := false;
+while list <> nil do begin
+   if MatchLoc(op, list^.op) then begin
+      Member := true;
+      memberOp := list^.op;
+      list := nil;
+      end {if}
+   else
+      list := list^.next;
+   end; {while}
+end; {Member}
+
+
+function TypeOf (op: icptr): baseTypeEnum;
+
+{ find the type for the expression tree				}
+{								}
+{ parameters:							}
+{    op - tree for which to find the type			}
+{								}
+{ Returns: base type						}
+
+var
+   q: integer;				{op^.q}
+
+begin {TypeOf}
+case op^.opcode of
+   pc_ldc, pc_ldo, pc_lod, pc_dec, pc_inc, pc_ind, pc_cop, pc_cpo:
+      TypeOf := op^.optype;
+
+   pc_lad, pc_lao, pc_lca, pc_lda, pc_ixa, pc_abl, pc_udl, pc_ulm,
+   pc_uml, pc_vsr, pc_sql:
+      TypeOf := cgULong;
+
+   pc_nop, pc_bnt, pc_ngi, pc_not, pc_adi, pc_and, pc_lnd, pc_bnd,
+   pc_bor, pc_bxr, pc_dvi, pc_equ, pc_geq, pc_grt, pc_leq, pc_les,
+   pc_neq, pc_ior, pc_lor, pc_mod, pc_mpi, pc_sbi, pc_shl, pc_shr,
+   pc_rnd:
+      TypeOf := cgWord;
+
+   pc_udi, pc_uim, pc_umi, pc_usr, pc_sqi, pc_odd, pc_odl, pc_inn,
+   pc_abi:
+      TypeOf := cgUWord;
+                         
+   pc_bnl, pc_ngl, pc_adl, pc_bal, pc_blr, pc_blx, pc_dvl, pc_mdl,
+   pc_mpl, pc_sbl, pc_sll, pc_slr, pc_rn4:
+      TypeOf := cgLong;
+
+   pc_ngr, pc_adr, pc_dvr, pc_mpr, pc_sbr, pc_abr, pc_sqr, pc_at2,
+   pc_pwr, pc_sin, pc_cos, pc_exp, pc_sqt, pc_log, pc_atn, pc_tan,
+   pc_acs, pc_asn:
+      TypeOf := cgExtended;
+
+   pc_sgs, pc_uni, pc_dif, pc_siz:
+      TypeOf := cgSet;
+
+   pc_cnn, pc_cnv:                                        
+      TypeOf := baseTypeEnum(op^.q & $000F);
+
+   pc_chk, pc_stk:
+      TypeOf := TypeOf(op^.left);
+
+   pc_bno:
+      TypeOf := TypeOf(op^.right);
+
+   pc_csp: begin
+      q := op^.q;
+      if q in [1..4,8..10,12..17,19,20..46,48..53,60,
+         62,66..69,71..75,84..86,91..92,96..97,100..102,115] then
+         TypeOf := cgVoid
+      else if q in [5,7,58..59,70,80,87..89] then
+         TypeOf := cgWord
+      else if q in [6,61,79,82] then
+         TypeOf := cgExtended
+      else if q in [11,116] then
+         TypeOf := cgULong
+      else if q in [76,81,83,98..99] then
+         TypeOf := cgLong
+      else if q in [77..78,93] then
+         TypeOf := cgString;
+      end;
+
+   otherwise: Error(cge1);       
+   end; {case}
+end; {TypeOf}
+
+{$optimize  7}
+
+procedure CommonSubexpressionElimination;
+
+{ Remove common subexpressions					}
+
+type
+   localPtr = ^localRecord;		{list of local temp variables}
+   localRecord = record
+      next: localPtr;			{next label in list}
+      inUse: boolean;			{is this temp already in use?}
+      size: integer;			{size of the temp area}
+      lab: integer;			{label number}
+      end;
+
+var
+   bb: blockPtr;			{used to trace basic block lists}
+   done: boolean;			{for loop termination tests}
+   op: icptr;				{used to trace operation lists, trees}
+   lop: icptr;				{predecessor of op}
+   temps: localPtr;			{list of temp variables}
+
+
+   procedure DisposeTemps;
+
+   { dispose of the list of temp variables			}
+
+   var
+      tp: localPtr;			{temp pointer}
+
+   begin {DisposeTemps}
+   while temps <> nil do begin
+      tp := temps;
+      temps := tp^.next;
+      dispose(tp);
+      end; {while}
+   end; {DisposeTemps}
+
+
+   function GetTemp (bb: blockPtr; size: integer): integer;
+
+   { Allocate a temp storage location				}
+   {								}
+   { parameters:						}
+   {    bb - block in which the temp is allocated		}
+   {    size - size of the temp					}
+   {								}
+   { Returns: local label number for the temp			}
+
+   var
+      ip: icptr;			{used to find insertion point for dc_loc}
+      lab: integer;			{label number}
+      loc: icptr;			{for dc_loc instruction}
+      tp: localPtr;			{used to trace lists, allocate new items}
+
+   begin {GetTemp}
+   lab := 0;				{no label found, yet}
+   tp := temps;				{try for a temp of the exact size}
+   while tp <> nil do begin
+      if not tp^.inUse then
+         if tp^.size = size then begin
+            lab := tp^.lab;
+            tp^.inUse := true;
+            tp := nil;
+            end; {if}
+      if tp <> nil then
+         tp := tp^.next;
+      end; {while}
+   if lab = 0 then begin		{try for a larger temp}
+      tp := temps;
+      while tp <> nil do begin
+	 if not tp^.inUse then
+            if tp^.size > size then begin
+               lab := tp^.lab;
+               tp^.inUse := true;
+               tp := nil;        
+               end; {if}
+	 if tp <> nil then
+            tp := tp^.next;
+	 end; {while}
+      end; {if}
+   if lab = 0 then begin		{allocate a new temp}
+      loc := pointer(Calloc(sizeof(intermediate_code)));
+      loc^.opcode := dc_loc;
+      loc^.optype := cgWord;
+      maxLoc := maxLoc + 1;
+      loc^.r := maxLoc;
+      lab := maxLoc;
+      loc^.q := size;
+      if bb^.code = nil then begin
+	 loc^.next := nil;
+	 bb^.code := loc;
+         end {if}
+      else begin
+         ip := bb^.code;
+         while ip^.next <> nil do
+            ip := ip^.next;
+	 loc^.next := nil;
+	 ip^.next := loc;
+         end; {else}
+      new(tp);
+      tp^.next := temps;
+      temps := tp;
+      tp^.inUse := true;
+      tp^.size := loc^.q;
+      tp^.lab := lab;
+      end; {if}
+   GetTemp := lab;			{return the temp label number}
+   end; {GetTemp}
+
+
+   procedure ResetTemps;
+
+   { Mark all temps as available				}
+
+   var
+      tp: localPtr;			{temp pointer}
+
+   begin {ResetTemps}
+   tp := temps;
+   while tp <> nil do begin
+      tp^.inUse := false;
+      tp := tp^.next;
+      end; {while}
+   end; {ResetTemps}
+
+
+   procedure CheckForBlocks (op: icptr);
+
+   { Scan a tree for blocked instructions			}
+   {								}
+   { parameters:						}
+   {    op - tree to check					}
+   {								}
+   { Notes: Some code takes less time to execute than saving	}
+   {    and storing the intermediate value.  This subroutine	}
+   {    identifies such patterns.				}
+
+
+      function Block (op: icptr): boolean;
+
+      { See if the pattern should be blocked			}
+      {								}
+      { parameters:						}
+      {    op - pattern to check				}
+      {								}
+      { Returns: True if the pattern should be blocked, else	}
+      {    false.						}
+
+      var
+         opcode: pcodes;		{temp opcode}
+
+      begin {Block}
+      Block := false;
+      opcode := op^.opcode;
+      if opcode = pc_ixa then begin
+         if op^.left^.opcode in [pc_lao,pc_lca,pc_lda] then
+            Block := true;
+         end {else if}
+      else if opcode = pc_shl then begin
+         if op^.right^.opcode = pc_ldc then
+            if op^.right^.q = 1 then
+               if op^.parents <= 3 then
+                  Block := true;
+         end {else if}
+      else if opcode in [pc_stk, pc_siz] then
+         Block := true
+      else if opcode = pc_cnv then
+         if op^.q & $000F = ord(cgVoid) then
+            Block := true;
+      end; {Block}
+
+
+      function Max (a, b: integer): integer;
+
+      { Return the larger of two integers			}
+      {								}
+      { parameters:						}
+      {    a, b - integers to check				}
+      {								}
+      { Returns: a if a > b, else b				}
+
+      begin {Max}
+      if a > b then
+         Max := a
+      else
+         Max := b;
+      end; {Max}
+
+
+   begin {CheckForBlocks}
+   if Block(op) then begin
+      if op^.left <> nil then		{handle a blocked instruction}
+         op^.left^.parents := op^.left^.parents + Max(op^.parents - 1, 0);
+      if op^.right <> nil then
+         op^.right^.parents := op^.right^.parents + Max(op^.parents - 1, 0);
+      op^.parents := 1;
+      end; {if}
+   if op^.left <> nil then		{check the children}
+      CheckForBlocks(op^.left);
+   if op^.right <> nil then
+      CheckForBlocks(op^.right);
+   end; {CheckForBlocks}
+
+
+   procedure CheckTree (var op: icptr; bb: blockPtr);
+
+   { check the trees used by op for common subexpressions	}
+   {								}
+   { parameters:						}
+   {    op - operation to check					}
+   {    bb - start of the current BASIC block			}
+
+   var
+      op2: icptr;			{result from Match calls}
+      op3: icptr;			{used to trace the codes in a block}
+
+
+      function Match (var op: icptr; tree: icptr): icptr;
+
+      { Check for matches to op in tree				}
+      {								}
+      { parameters:						}
+      {    op - operation to check				}
+      {    tree - tree to examine for matches			}
+      {								}
+      { Returns: pointer to matching node or nil if none found	}
+
+      var
+         op2: icptr;			{result from recursive Match calls}
+         kill, start, stop: boolean;	{used by Scan}
+         skip: boolean;			{used to see if children should be scanned}
+
+
+         procedure Combine (var op1, op2: icptr);
+
+         { Op2 is a save or copy of the same value as op1; use a copy	}
+         { for op2.							}
+         {								}
+         { parameters:							}
+         {    op1 - first copy or save					}
+         {    op2 - copy or save to optimize				}
+
+         var
+            op3: icptr;				{work pointer}
+
+         begin {Combine}
+         done := false;				{force another labeling pass}
+	 op3 := op2;				{remove op2 from the list}
+         if op3^.opcode in [pc_str,pc_sro] then begin
+            if op3^.opcode = pc_str then
+               op3^.opcode := pc_cop
+            else
+               op3^.opcode := pc_cpo;
+            op2 := op3^.next;
+            op3^.next := nil;
+            end {if}
+         else
+            op2 := op3^.left;
+         op1^.left := op3;			{place in the new location}
+         end; {Combine}
+
+
+         function SameTree (list, op1, op2: icptr): boolean;
+
+         { Are op1 and op2 in the same expression tree?			}
+         {								}
+         { parameters:							}
+         {    list - list of expression trees				}
+         {    op1, op2 - operations to check				}
+
+
+            function InTree (tree, op: icptr): boolean;
+
+            { See if op is in the tree					}
+            {								}
+            { parameters:						}
+            {    tree - expression tree to check			}
+            {    op - operatio to look for				}
+
+            begin {InTree}
+            if tree = nil then
+               InTree := false
+            else if tree = op then
+               InTree := true
+            else
+               InTree := InTree(tree^.left, op) or InTree(tree^.right, op);
+            end; {InTree}
+
+
+         begin {SameTree}
+         SameTree := false;
+         while list <> nil do
+            if InTree(list, op1) then begin
+               SameTree := InTree(list, op2);
+               list := nil;
+               end {if}
+            else
+               list := list^.next;
+         end; {SameTree}
+
+
+         procedure Scan (list, op1, op2: icptr);
+
+         { Check to see if any operation between op1 and op2 kills the	}
+         { optimization							}
+         {								}
+         { parameters:							}
+         {    list - instruction stream					}
+         {    op1 - starting operation					}
+         {    op2 - ending operation					}
+         {								}
+         { globals:							}
+         {    kill - set to true if the optimization must be blocked,	}
+         {       or false if it can be performed			}
+         {    start - has op1 been found?  (initialize to false)	}
+         {    stop - has kill been set?	 (initialize to false)		}
+
+         var
+            done: boolean;			{loop termination test}
+
+         begin {Scan}
+         repeat
+            done := true;
+            if not start then			{see if it is time to start}
+               if list = op1 then
+        	  start := true;
+            if list^.left <> nil then		{scan the children}
+               Scan(list^.left, op1, op2);
+            if not stop then
+               if list^.right <> nil then
+        	  Scan(list^.right, op1, op2);
+            if start then			{check for a kill or termination}
+               if not stop then
+        	  if list = op2 then begin
+        	     kill := false;
+        	     stop := true;
+        	     end {if}
+        	  else if list^.opcode in [pc_str,pc_sro,pc_cop,pc_cpo]
+                     then begin
+        	     if MatchLoc(list, op2) then begin
+                	kill := true;
+                	stop := true;
+                	end {if}
+        	     end {else if}
+        	  else if list^.opcode in [pc_sto,pc_cup,pc_cui,pc_tl1,pc_tl2,
+                     pc_pds,pc_csp,pc_cum,pc_vct] then
+        	     if Member(op1, c_ind) then begin
+                	kill := true;
+                	stop := true;
+                	end; {if}
+            if not stop then			{scan forward in the stream}
+               if list^.next <> nil then begin
+                  list := list^.next;
+                  done := false;
+                  end; {if}
+         until done;
+         end; {Scan}
+
+
+      begin {Match}
+      op2 := nil;			{check for an exact match}
+      skip := false;
+      if CodesMatch(op, tree, true) then begin
+         if op = tree then
+            op2 := tree
+         else begin
+            start := false;
+            stop := false;
+            Scan(bb^.code, tree, op);
+            if not kill then
+               op2 := tree;
+            end; {else}
+         end {if}
+					{check for stores of a common value}
+      else if op^.opcode in [pc_str,pc_sro,pc_cop,pc_cpo] then
+         if tree^.opcode in [pc_str,pc_sro,pc_cop,pc_cpo] then
+            if op^.left = tree^.left then begin
+               start := false;
+               stop := false;
+               Scan(bb^.code, tree, op);
+               if not kill then
+                  if not SameTree(bb^.code, op, tree) then
+                     if (op^.left^.opcode <> pc_ldc) or (op^.left^.q <> 0)
+                        or (not (op^.left^.optype in [cgByte,cgUByte,cgWord,cgUWord]))
+                        then begin
+                        Combine(tree, op);
+                        skip := true;
+                        end; {if}
+               end; {if}
+      if not skip then begin		{check for matches in the children}
+         if op2 = nil then
+	    if tree^.left <> nil then
+               op2 := Match(op, tree^.left);
+         if op2 = nil then
+            if tree^.right <> nil then
+               op2 := Match(op, tree^.right);
+         end; {if}
+      Match := op2;
+      end; {Match}
+
+
+   begin {CheckTree}
+   op^.parents := 0;			{zero the parent counter}
+   if op^.left <> nil then		{check the children}
+      CheckTree(op^.left, bb);
+   if op^.right <> nil then
+      CheckTree(op^.right, bb);
+   if op^.next = nil then		{look for a match to the current code}
+      if not (op^.opcode in
+         [pc_cup,pc_cui,pc_cum,pc_tl1,pc_tl2,pc_vct,pc_csp,pc_pds,pc_bno]) then
+         begin
+	 op2 := nil;
+	 op3 := bb^.code;
+	 while (op2 = nil) and (op3 <> nil) do begin
+	    op2 := Match(op, op3);
+	    if op2 <> nil then
+               if op2^.next = nil then begin
+        	  op := op2;
+        	  bb := nil;
+        	  op3 := nil;
+        	  end ;{if}
+	    if op3 <> nil then
+               op3 := op3^.next;
+	    end; {while}
+	 end; {if}
+   end; {CheckTree}
+
+
+   procedure CountParents (op: icptr);
+
+   { increment the parent counter for all children of this node	}
+   {								}
+   { parameters:						}
+   {    op - node for which to check the children		}
+
+   begin {CountParents}
+   if op^.parents = 0 then begin
+      if op^.left <> nil then begin
+	 CountParents(op^.left);
+	 op^.left^.parents := op^.left^.parents + 1;
+	 end; {if}
+      if op^.right <> nil then begin
+	 CountParents(op^.right);
+	 op^.right^.parents := op^.right^.parents + 1;
+	 end; {if}
+      end; {if}
+   end; {CountParents}
+
+
+   procedure CreateTemps (var op: icptr; bb: blockPtr; var lop: icptr);
+
+   { create temps for nodes with multiple parents		}
+   {								}
+   { parameters:						}
+   {    op - node for which to create temps			}
+   {    bb - current basic block				}
+   {    lop - predecessor to op					}
+
+   var
+      children: boolean;		{does this node have children?}
+      llab: integer;			{local label number; for temp}
+      op2, str: icptr;			{new opcodes}
+      optype: baseTypeEnum;		{type of the temp variable}
+
+   begin {CreateTemps}
+   children := false;			{create temps for the children}
+   if op^.left <> nil then begin
+      children := true;
+      CreateTemps(op^.left, bb, lop);
+      end; {if}
+   if op^.right <> nil then begin
+      children := true;
+      CreateTemps(op^.right, bb, lop);
+      end; {if}
+   if children then
+      if op^.parents > 1 then begin
+         optype := TypeOf(op);		{create a temp label}
+         llab := GetTemp(bb, TypeSize(optype));
+					{make a copy of the duplicated tree}
+         op2 := pointer(Calloc(sizeof(intermediate_code)));
+         op2^ := op^;
+         op^.opcode := pc_lod;		{substitute a load of the temp}
+         op^.optype := optype;
+         op^.parents := 1;
+         op^.r := llab;
+         op^.q := 0;
+         op^.left := nil;
+         op^.right := nil;
+					{store the temp result}
+         str := pointer(Calloc(sizeof(intermediate_code)));
+         str^.opcode := pc_str;
+         str^.optype := optype;
+         str^.r := llab;
+         str^.q := 0;
+         str^.left := op2;
+         if lop = nil then begin	{insert the store in the basic block}
+            str^.next := bb^.code;
+            bb^.code := str;
+            end {if}
+         else begin
+            str^.next := lop^.next;
+            lop^.next := str;
+            end; {else}
+         lop := str;
+         end; {if}
+   end; {CreateTemps}
+
+
+begin {CommonSubexpressionElimination}
+temps := nil;				{no temps allocated, yet}
+repeat					{identify common parts}
+   done := true;
+   bb := DAGblocks;
+   while bb <> nil do begin
+      Spin;
+      op := bb^.code;
+      if op <> nil then begin
+	 CheckTree(bb^.code, bb);
+	 while op^.next <> nil do begin
+            CheckTree(op^.next, bb);
+            if op^.next <> nil then
+	       op := op^.next;
+	    end; {while}
+	 end; {if}
+      bb := bb^.next;
+      end; {while}
+until done;
+bb := DAGblocks;			{count the number of parents}
+while bb <> nil do begin
+   op := bb^.code;
+   Spin;
+   while op <> nil do begin
+      CountParents(op);
+      op := op^.next;
+      end; {while}
+   bb := bb^.next;
+   end; {while}
+bb := DAGblocks;			{check for blocked instructions}
+while bb <> nil do begin
+   op := bb^.code;
+   Spin;
+   while op <> nil do begin
+      CheckForBlocks(op);
+      op := op^.next;
+      end; {while}
+   bb := bb^.next;
+   end; {while}
+bb := DAGblocks;			{create temps for common subexpressions}
+while bb <> nil do begin
+   op := bb^.code;
+   lop := nil;
+   ResetTemps;
+   Spin;
+   while op <> nil do begin
+      if op^.opcode = pc_ent then
+         DisposeTemps;
+      CreateTemps(op, bb, lop);
+      lop := op;
+      op := op^.next;
+      end; {while}
+   bb := bb^.next;
+   end; {while}
+DisposeTemps;				{get rid of the temp variable list}
+end; {CommonSubexpressionElimination}
+
+{- Loop Optimizations ------------------------------------------}
+
+procedure AddOperation (op: icptr; var lp: iclist);
+
+{ Add an operation to an operation list				}
+{								}
+{ parameters:							}
+{    op - operation to add					}
+{    lp - list to add the operation to				}
+
+var
+   inList: boolean;			{is op already in the list?}
+   llp: iclist;				{work pointer}
+
+begin {AddOperation}
+llp := lp;
+inList := false;
+while llp <> nil do
+   if MatchLoc(llp^.op, op) then begin
+      inList := true;
+      llp := nil;
+      end {if}
+   else
+      llp := llp^.next;
+if not inList then begin
+   new(llp);
+   llp^.next := lp;
+   lp := llp;
+   llp^.op := op;
+   end; {if}
+end; {AddOperation}
+
+
+procedure DisposeBlkList (var blk: blockListPtr);
+
+{ dispose of all entries in the block list			}
+{								}
+{ parameters:							}
+{    blk - list of blocks to dispose of				}
+
+var
+   bk1, bk2: blockListPtr;		{work pointers}
+
+begin {DisposeBlkList}
+bk1 := blk;
+blk := nil;
+while bk1 <> nil do begin
+   bk2 := bk1;
+   bk1 := bk2^.next;
+   dispose(bk2);
+   end; {while}
+end; {DisposeBlkList}
+
+
+procedure DisposeOpList (var oplist: iclist);
+
+{ dispose of all entries in the list				}
+{								}
+{ parameters:							}
+{    oplist - operation list to dispose of			}
+
+var
+   op1, op2: iclist;			{work pointers}
+
+begin {DisposeOpList}
+op1 := oplist;
+oplist := nil;
+while op1 <> nil do begin
+   op2 := op1;
+   op1 := op2^.next;
+   dispose(op2);
+   end; {while}
+end; {DisposeOpList}
+
+
+procedure DumpLoopLists;
+
+{ dispose of lists created by ReachingDefinitions and Dominators}
+
+var
+   bb: blockPtr;			{used to trace basic block list}
+   dom: blockListPtr;			{used to dispose of a dominator}
+   
+begin {DumpLoopLists}
+bb := DAGBlocks;
+while bb <> nil do begin
+   DisposeOpList(bb^.c_in);		{dump the reaching definition lists}
+   DisposeOpList(bb^.c_out);
+   DisposeOpList(bb^.c_gen);
+   DisposeBlkList(bb^.dom);
+   while bb^.dom <> nil do begin	{dump the dominator lists}
+      dom := bb^.dom;
+      bb^.dom := dom^.next;
+      dispose(dom);
+      end; {while}
+   bb := bb^.next;
+   end; {while}
+end; {DumpLoopLists}
+
+
+procedure AddLoads (jp: icptr; var lp: iclist);
+
+{ Add any load addresses from the children of this		}
+{ operation							}
+{								}
+{ parameters:							}
+{    jp - operation to check					}
+{    lp - list to add the loads to				}
+
+begin {AddLoads}
+if jp^.opcode in [pc_lda,pc_lao,pc_lod,pc_lod] then
+   AddOperation(jp, lp)
+else begin
+   if jp^.left <> nil then
+      AddLoads(jp^.left, lp);
+   if jp^.right <> nil then
+      AddLoads(jp^.right, lp);
+   end {else}
+end; {AddLoads}
+
+
+procedure FlagIndirectUses;
+
+{ Find all variables that could be changed by an indirect	}
+{ access.							}
+
+var
+   bb: blockPtr;			{used to trace block list}
+
+
+   procedure Check (op: icptr; doingInd: boolean);
+
+   { Check op and its children & followers for dangerous	}
+   { references							}
+   {								}
+   { parameters:						}
+   {    op - operation to check					}
+   {    doingInd - are we doing a pc_ind?  If so, pc_lda's	}
+   {       are safe						}
+
+   var
+      lDoingInd: boolean;		{local doingInd}
+
+   begin {Check}
+   while op <> nil do begin
+      if op^.opcode = pc_ind then
+         lDoingInd := true
+      else
+         lDoingInd := doingInd;
+      if op^.left <> nil then
+         Check(op^.left, lDoingInd);
+      if op^.right <> nil then
+         Check(op^.right, lDoingInd);
+      if op^.opcode in [pc_lao,pc_cpo,pc_ldo,pc_sro] then
+         AddOperation(op, c_ind)
+      else if op^.opcode = pc_ind then begin
+         if op^.left^.opcode = pc_ind then
+            AddLoads(op^.left^.left, c_ind);
+         end {else if}
+      else if op^.opcode = pc_csp then begin
+         if op^.q = 1{get} then
+            AddLoads(op^.left, c_ind);
+         end {else if}
+      else if op^.opcode = pc_sto then
+         AddLoads(op^.left, c_ind)
+      else if op^.opcode = pc_lda then
+         if not doingInd then
+            AddOperation(op, c_ind);
+      op := op^.next;
+      end; {while}
+   end; {Check}
+
+
+begin {FlagIndirectUses}
+c_ind := nil;
+bb := DAGBlocks;
+while bb <> nil do begin
+   Check(bb^.code, false);
+   bb := bb^.next;
+   end; {while}
+end; {FlagIndirectUses}
+
+
+procedure DoLoopOptimization;
+
+{ Perform optimizations related to loops and data flow		}
+
+type
+   dftptr = ^dftrecord;			{depth first tree edges}
+   dftrecord = record
+      next: dftptr;
+      from, dest: blockPtr;
+      end;
+
+var
+   backEdge: dftptr;			{list of back edges}
+   dft: dftptr;				{depth first tree}
+   dft2: dftptr;			{work pointer}
+
+
+   function DFN (i: integer): blockPtr;
+
+   { find the basic block with dfn index of i			}
+   {								}
+   { parameters:						}
+   {    i - index to look for					}
+   {								}
+   { Returns: block pointer, or nil if there is none		}
+
+   var
+      bb: blockPtr;			{used to trace block list}
+
+   begin {DFN}
+   bb := DAGBlocks;
+   DFN := nil;
+   while bb <> nil do begin
+      if bb^.dfn = i then begin
+         DFN := bb;
+         bb := nil;
+         end
+      else
+         bb := bb^.next;
+      end; {while}
+   end; {DFN}
+
+
+   function MemberDFNList (dfn: integer; bl: blockListPtr): boolean;
+
+   { See if dfn is a member of the list bl			}
+   {								}
+   { parameters:						}
+   {    dfn - block number to check				}
+   {    bl - list of block numbers to check			}
+   {								}
+   { Returns: True if dfn is in bl, else false.			}
+
+   begin {MemberDFNList}
+   MemberDFNList := false;
+   while bl <> nil do
+      if bl^.dfn = dfn then begin
+         MemberDFNList := true;
+         bl := nil;
+         end {if}
+      else
+         bl := bl^.next;
+   end; {MemberDFNList}
+
+
+   function FindDAG (op: icptr): blockPtr;
+
+   { Find the DAG containing label for op			}
+   {								}
+   { parameters:						}
+   {    op - instruction with a label				}
+   {								}
+   { Returns: pointer to the proper basic block			}
+
+   var
+      bb: blockPtr;			{used to trace basic block list}
+
+   begin {FindDAG}
+   bb := DAGBlocks;
+   FindDAG := nil;
+   while bb <> nil do begin
+      if bb^.code^.opcode = dc_lab then
+         if LabelsMatch(bb^.code, op) then begin
+            FindDAG := bb;
+            bb := nil;
+            end; {if}
+      if bb <> nil then
+         bb := bb^.next;
+      end; {while}
+   end; {FindDAG}
+
+
+   procedure DepthFirstOrder;
+
+   { Number the DAG for depth first order			}
+
+   var
+      bb: blockPtr;			{used to trace basic block lists}
+      i: integer;			{dfn index}
+
+
+      procedure Search (bb: blockPtr);
+
+      { Search this block					}
+      {								}
+      { parameters:						}
+      {    bb - basic block to search				}
+
+      var
+         blk: blockPtr;			{work block}
+         ndft: dftptr;			{for new tree entries}
+         op: icptr;			{used to trace operation list}
+
+
+         function NotUnconditional: boolean;
+
+         { See if the block ends with something other than an	}
+         { unconditional jump					}
+         {							}
+         { Returns: True if the block ends with something other	}
+         {    than pc_ujp or pc_add, else false			}
+
+         var
+            op: icptr;			{used to trace the list}
+
+         begin {NotUnconditional}
+         NotUnconditional := true;
+         op := bb^.code;
+         if op <> nil then begin
+            while op^.next <> nil do
+               op := op^.next;
+            if op^.opcode in [pc_add,pc_ujp] then
+               NotUnconditional := false;
+            end; {if}
+         end; {NotUnconditional}
+
+
+      begin {Search}
+      Spin;
+      if bb <> nil then
+	 if not bb^.visited then begin
+	    bb^.visited := true;
+            if NotUnconditional then
+               if bb^.next <> nil then begin
+                  new(ndft);
+                  ndft^.next := dft;
+                  dft := ndft;
+                  ndft^.from := bb;
+                  ndft^.dest := bb^.next;
+                  Search(bb^.next);
+                  end; {if}
+	    op := bb^.code;
+	    while op <> nil do begin
+               if op^.opcode in [pc_ujp, pc_fjp, pc_tjp, pc_add] then begin
+                  blk := FindDAG(op);
+                  new(ndft);
+                  if blk^.visited then begin
+                     ndft^.next := backEdge;                        
+                     backEdge := ndft;
+                     end {if}
+                  else begin
+                     ndft^.next := dft;
+                     dft := ndft;
+        	     Search(blk);
+                     end; {else}
+                  ndft^.from := bb;
+                  ndft^.dest := blk;
+                  end; {if}
+               op := op^.next;
+               end; {while}
+            bb^.dfn := i;
+            i := i-1;
+            end; {if}
+      end; {Search}
+
+
+   begin {DepthFirstOrder}
+   dft := nil;
+   backEdge := nil;
+   i := 0;
+   bb := DAGblocks;
+   while bb <> nil do begin
+      bb^.visited := false;
+      i := i+1;
+      bb := bb^.next;
+      end; {while}
+   Search(DAGBlocks);
+   end; {DepthFirstOrder}
+
+
+   procedure Dominators;
+
+   { Find a list of dominators for each node			}
+
+   var
+      bb: blockPtr;			{used to trace the block list}
+      change: boolean;			{for loop termination test}
+      i, j: integer;			{loop variables}
+      maxdfn, mindfn: integer;		{max and min dfn values used}
+
+
+      procedure Add (var dom: blockListPtr; dfn: integer);
+
+      { Add dfn to the list of dominators			}
+      {								}
+      { parameters:						}
+      {    dom - dominator list					}
+      {    dfn - new dominator number				}
+
+      var
+         dp: blockListPtr;		{new node}
+
+      begin {Add}
+      new(dp);
+      dp^.last := nil;
+      dp^.next := dom;
+      dom^.last := dp;
+      dom := dp;
+      dp^.dfn := dfn;
+      end; {Add}
+
+
+      procedure CheckPredecessors (bb: blockPtr; bl: dftptr);
+
+      { Eliminate nodes that don't dominate a predecessor	}
+      {								}
+      { parameters:						}
+      {    bb - block being checked				}
+      {    bl - list of edges to check for predecessors		}
+
+      var
+         dp: blockListPtr;		{list of dominator numbers}
+         tdp: blockListPtr;		{used to remove a dominator entry}
+
+      begin {CheckPredecessors}
+      while bl <> nil do begin
+         if bl^.dest = bb then begin
+            dp := bb^.dom;
+            while dp <> nil do
+               if dp^.dfn <> bb^.dfn then
+                  if not MemberDFNList(dp^.dfn, bl^.from^.dom) then begin
+                     change := true;
+                     tdp := dp;
+                     if tdp^.last = nil then
+                        bb^.dom := tdp^.next
+                     else
+                        tdp^.last^.next := tdp^.next;
+                     if tdp^.next <> nil then
+                        tdp^.next^.last := tdp^.last;
+                     dp := tdp^.next;
+                     dispose(tdp);
+                     end {if}
+                  else
+                     dp := dp^.next
+               else
+                  dp := dp^.next;
+            end; {if}
+         bl := bl^.next;
+         end; {while}
+      end; {CheckPredecessors}
+
+
+   begin {Dominators}
+   Spin;
+   maxdfn := 0;				{find the largest dfn}
+   bb := DAGBlocks;
+   while bb <> nil do begin
+      if bb^.dfn > maxdfn then
+         maxdfn := bb^.dfn;
+      bb := bb^.next;
+      end; {while}
+   Add(DAGBlocks^.dom, DAGBlocks^.dfn);	{the first node is it's own dominator}
+   mindfn := DAGBlocks^.dfn;		{assume all other nodes are dominated by every other node}
+   for i := mindfn+1 to maxdfn do begin
+      bb := DFN(i);
+      if bb <> nil then
+         for j := mindfn to maxdfn do
+            Add(bb^.dom, j);
+      end; {for}
+   repeat				{iterate to the true set of dominators}
+      change := false;
+      for i := mindfn+1 to maxdfn do begin
+         bb := DFN(i);
+         CheckPredecessors(bb, dft);
+         CheckPredecessors(bb, backEdge);
+         end; {for}
+   until not change;
+   end; {Dominators}
+
+
+   procedure ReachingDefinitions;
+
+   { find the list of reaching definitions for each basic block	}
+
+   var
+      bb: blockPtr;			{block being scanned}
+      change: boolean;			{loop termination test}
+      i: integer;			{node index number}
+      newIn: iclist;			{list of inputs}
+
+
+      function Gen (op: icptr): iclist;
+
+      { find a list of generated values				}
+      {								}
+      { parameters:						}
+      {    op - list of intermediate codes to scan		}
+      {								}
+      { Returns: list of generated definitions			}
+
+      var
+         gp: iclist;			{list of generated definitions}
+         indFound: boolean;		{has an indirect store been found?}
+
+
+         procedure Check (ip: icptr);
+
+         { Add any result from ip to gp				}
+         {							}
+         { parameters:						}
+         {    ip - instruction to check				}
+
+         var
+            lc_ind: iclist;		{used to trace the c_ind list}
+
+         begin {Check}
+         if ip^.left <> nil then
+            Check(ip^.left);
+         if ip^.right <> nil then
+            Check(ip^.right);
+         if ip^.opcode in
+            [pc_str,pc_sro,pc_cop,pc_cpo] then
+            AddOperation(ip, gp)
+         else if ip^.opcode in [pc_mov,pc_sto] then
+            AddLoads(ip, gp);
+         if not indFound then
+            if ip^.opcode in [pc_sto,pc_cup,pc_cui,pc_tl1,
+                pc_tl2,pc_vct,pc_csp,pc_pds,pc_cum] then begin
+               lc_ind := c_ind;
+               while lc_ind <> nil do begin
+                  AddOperation(lc_ind^.op, gp);
+                  lc_ind := lc_ind^.next;
+                  end; {while}
+               indFound := true;
+               end; {if}
+         end; {Check}                                         
+
+
+      begin {Gen}
+      indFound := false;
+      gp := nil;
+      while op <> nil do begin
+         Check(op);
+         op := op^.next;
+         end; {while}
+      Gen := gp;
+      end; {Gen}
+
+
+      function EqualSets (l1, l2: iclist): boolean;
+
+      { See if two sets of stores and copies are equivalent	}
+      {								}
+      { parameters:						}
+      {    l1, l2 - lists of copies and stores			}
+      {								}
+      { Returns: True if the lists are equivalent, else false	}
+      {								}
+      { Notes: The members of each list are assumed to be	}
+      {    unique within that list.				}
+
+      var
+         c1, c2: integer;		{number of elements in the sets}
+         l3: iclist;			{used to trace the lists}
+         matchFound: boolean;		{was a match found?}
+
+      begin {EqualSets}
+      EqualSets := false;		{assume they are not equal}
+      c1 := 0;				{count the elements of l1}
+      l3 := l1;
+      while l3 <> nil do begin
+         c1 := c1+1;
+         l3 := l3^.next;
+         end; {while}
+      c2 := 0;				{count the elements of l2}
+      l3 := l2;
+      while l3 <> nil do begin
+         c2 := c2+1;
+         l3 := l3^.next;
+         end; {while}
+      if c1 = c2 then begin		{make sure each member of l1 is in l2}
+         EqualSets := true;
+         while l1 <> nil do begin
+            matchFound := false;
+            l3 := l2;
+            while l3 <> nil do begin
+               if MatchLoc(l1^.op, l3^.op) then begin
+                  l3 := nil;
+                  matchFound := true;
+                  end {if}
+               else
+                  l3 := l3^.next;
+               end; {while}
+            if not matchFound then begin
+               EqualSets := false;
+               l1 := nil;
+               end {if}
+            else
+               l1 := l1^.next;
+            end; {while}
+         end; {if}
+      end; {EqualSets}
+
+
+      function Union (l1, l2: iclist): iclist;
+
+      { Returns a list that is the union of two input lists	}
+      {								}
+      { parameters:						}
+      {    l1, l2 - lists					}
+      {								}
+      { Returns: New, dynamically allocated list that includes	}
+      {    all of the members in l1 and l2.			}
+      {								}
+      { Notes:							}
+      {    1.  If there are duplicates, the member from l1 is	}
+      {        returned.					}
+      {    2.  It is assumed that all members of l1 and l2 are	}
+      {        unique within their own list.			}
+      {    3.  The original lists are not disturbed.		}
+      {    4.  The caller is responsible for disposing of the	}
+      {        memory used by the list.				}
+
+      var
+         lp: iclist;			{new list pointer}
+         np: iclist;			{new list member pointer}
+         tp: iclist;			{temp list pointer}
+
+      begin {Union}
+      lp := nil;
+      tp := l1;
+      while tp <> nil do begin
+         new(np);
+         np^.next := lp;
+         lp := np;
+         np^.op := tp^.op;
+         tp := tp^.next;
+         end; {while}
+      while l2 <> nil do begin
+         if not Member(l2^.op, l1) then begin
+            new(np);
+            np^.next := lp;
+            lp := np;
+            np^.op := l2^.op;
+            end; {if}
+         l2 := l2^.next;
+         end; {while}
+      Union := lp;
+      end; {Union}
+
+
+      function UnionOfPredecessors (bptr: blockPtr): iclist;
+
+      { create a union of the outputs of predecessors to bptr	}
+      {								}
+      { parameters:						}
+      {    bptr - block for which to look for predecessors	}
+      {								}
+      { Returns: Resulting set					}
+
+      var
+         bp: dftptr;			{used to trace edge lists}
+         plist: iclist;			{result list}
+         tlist: iclist;			{temp result list}
+
+      begin {UnionOfPredecessors}
+      plist := nil;
+      bp := dft;
+      while bp <> nil do begin
+         if bp^.dest = bptr then begin
+            tlist := Union(plist, bp^.from^.c_out);
+            DisposeOpList(plist);
+            plist := tlist;
+            end; {if}
+         bp := bp^.next;
+         end; {while}
+      bp := backEdge;
+      while bp <> nil do begin
+         if bp^.dest = bptr then begin
+            tlist := Union(plist, bp^.from^.c_out);
+            DisposeOpList(plist);
+            plist := tlist;
+            end; {if}
+         bp := bp^.next;
+         end; {while}
+      UnionOfPredecessors := plist;
+      end; {UnionOfPredecessors}
+
+
+   begin {ReachingDefinitions}
+   i := 1;				{initialize the lists}
+   repeat
+      bb := DFN(i);
+      if bb <> nil then begin
+         bb^.c_in := nil;
+         bb^.c_gen := Gen(bb^.code);
+         bb^.c_out := Union(nil, bb^.c_gen);
+         end; {if}
+      i := i+1;
+   until bb = nil;
+   repeat				{iterate to a solution}
+      change := false;
+      i := 1;
+      repeat
+	 Spin;
+         bb := DFN(i);
+         if bb <> nil then begin
+            newIn := UnionOfPredecessors(bb);
+            if not EqualSets(bb^.c_in, newIn) then begin
+               {IN[n] := newIn}
+               DisposeOpList(bb^.c_in);
+               bb^.c_in := newIn;
+               newIn := nil;
+               {OUT[n] := IN[n] - KILL[n] U GEN[n]}
+               DisposeOpList(bb^.c_out);
+               bb^.c_out := Union(bb^.c_in, nil);
+               change := true;
+               end; {if}
+            DisposeOpList(newIn);
+            end; {if}
+         i := i+1;
+      until bb = nil;
+   until not change;
+   end; {ReachingDefinitions}
+
+
+   procedure LoopInvariantRemoval;
+
+   { Remove all loop invariant computations			}
+
+   type
+      loopPtr = ^loopRecord;		{blocks in a list}
+      loopRecord = record
+	 next: loopPtr;			{next entry}
+	 block: blockPtr;		{code block}
+         exit: boolean;			{is this a loop exit?}
+	 end;
+
+      loopListPtr = ^loopListRecord;	{list of loop lists}
+      loopListRecord = record
+	 next: loopListPtr;
+	 loop: loopPtr;
+	 end;
+
+   var
+      icount: integer;			{order invariant found}
+      loops: loopListPtr;		{list of loops}
+      lp: loopPtr;			{used to trace loop lists}
+      llp: loopListPtr;			{used to trace the list of loops}
+
+
+
+      procedure FindLoops;
+
+      { Create a list of the natural loops			}
+
+      var
+         blk: blockPtr;			{target block for a jump}
+	 bp: dftptr;			{used to trace the back edges}
+         lp, lp2: loopPtr;		{used to reverse the list}
+	 llp: loopListPtr;		{loop list header entry}
+	 llp2: loopListPtr;		{used to reverse the list}
+         op: icptr;			{used to trace the opcode list}
+
+
+	 procedure Add (block: blockPtr);
+
+	 { Add a block to the current loop list				}
+	 {								}
+	 { parameters:							}
+	 {    block - block to add					}
+
+	 var
+            lp: loopPtr;			{new loop entry}
+
+	 begin {Add}
+	 new(lp);
+	 lp^.next := llp^.loop;
+	 llp^.loop := lp;
+	 lp^.block := block;
+         lp^.exit := false;
+	 end; {Add}
+
+
+         function InLoop (blk: blockPtr; lp: loopPtr): boolean;
+
+         { See if the block is in the loop				}
+         {								}
+         { parameters:							}
+         {    blk - block to check for					}
+         {    lp - loop list						}
+         {								}
+         { Returns: True if blk is in the list, else false		}
+
+         begin {InLoop}
+         InLoop := false;
+         while lp <> nil do begin
+            if lp^.block = blk then begin
+               lp := nil;
+               InLoop := true;
+               end {if}
+            else
+               lp := lp^.next;
+            end; {while}
+         end; {InLoop}
+
+
+	 procedure Insert (block: blockPtr);
+
+	 { Insert a block into the loop list				}
+	 {								}
+	 { parameters:							}
+	 {    block - block to add					}
+
+
+            procedure AddPredecessors (block: blockPtr; bl: dftptr);
+
+            { add any predecessors to the loop				}
+            {								}
+            { parameters:						}
+            {    block - block for which to check for			}
+            {       predecessors					}
+            {    bl - list of edges to check				}
+
+            begin {AddPredecessors}
+            while bl <> nil do begin
+               if bl^.dest = block then
+        	  Insert(bl^.from);
+               bl := bl^.next;
+               end; {while}
+            end; {AddPredecessors}
+
+
+            function InLoop (block: blockPtr; lp: loopPtr): boolean;
+
+            { See if a block is in the loop				}
+            {								}
+            { parameters:						}
+            {    block - block to check					}
+            {    lp - list of blocks in the loop			}
+            {								}
+            { Returns: True if the block is in the loop, else false	}
+
+            begin {InLoop}
+            InLoop := false;
+            while lp <> nil do
+               if lp^.block = block then begin
+        	  InLoop := true;
+        	  lp := nil;
+        	  end {if}
+               else
+        	  lp := lp^.next;
+            end; {InLoop}
+
+
+	 begin {Insert}
+	 if not InLoop(block, llp^.loop) then begin
+            Add(block);
+            AddPredecessors(block, dft);
+            AddPredecessors(block, backEdge);
+            end; {if}
+	 end; {Insert}
+
+
+      begin {FindLoops}
+      loops := nil;
+      bp := backEdge;			{scan the back edges}
+      while bp <> nil do begin
+	 if MemberDFNList(bp^.dest^.dfn, bp^.from^.dom) then begin
+            new(llp);			{create a new loop list entry}
+            llp^.next := loops;
+            loops := llp;
+            llp^.loop := nil;
+            Add(bp^.dest);
+            Insert(bp^.from);
+            lp := llp^.loop;		{reverse the list}
+            llp^.loop := nil;
+            while lp <> nil do begin
+               lp2 := lp;
+               lp := lp2^.next;
+               lp2^.next := llp^.loop;
+               llp^.loop := lp2;
+               end; {while}
+            lp := llp^.loop;		{mark the exits}
+            while lp <> nil do begin
+               op := lp^.block^.code;
+               while op <> nil do begin
+        	  if op^.opcode in [pc_ujp, pc_fjp, pc_tjp, pc_add] then begin
+                     blk := FindDAG(op);
+                     if not InLoop(blk, llp^.loop) then
+                        lp^.exit := true;
+                     if op^.opcode in [pc_fjp,pc_tjp] then
+                        if not InLoop(lp^.block^.next, llp^.loop) then
+                           lp^.exit := true;
+                     end; {if}
+                  op := op^.next;                        
+                  end; {while}
+               lp := lp^.next;
+               end; {while}
+            end; {if}
+	 bp := bp^.next;
+	 end; {while}
+      llp := loops;			{reverse the loop list}
+      loops := nil;
+      while llp <> nil do begin
+	 llp2 := llp;
+	 llp := llp2^.next;
+	 llp2^.next := loops;
+	 loops := llp2;
+	 end; {while}
+      end; {FindLoops}
+
+
+      function MarkInvariants (lp: loopPtr): boolean;
+
+      { Make a pass over the opcodes, marking those that are	}
+      { invariant.						}
+      {								}
+      { parameters:						}
+      {    lp - loop to scan					}
+      {								}
+      { Returns: True if any new nodes were marked, else false.	}
+
+      var
+         count: integer;		{number of generating blocks}
+         indirectStores: boolean;	{does the loop contain indirect stores or function calls?}
+         inhibit: boolean;		{inhibit stores?}
+         lp2: loopPtr;			{used to trace the loop}
+         op: icptr;			{used to trace the instruction list}
+         opcode: pcodes;		{op^.opcode; for efficiency}
+
+
+         procedure Check (op: icptr; olp: loopPtr);
+
+         { See if this node or its children is invariant		}
+         {								}
+         { parameters:							}
+         {    op - node to check					}
+         {    olp - loop entry for the block containing the store	}
+
+         var
+            invariant: boolean;		{are the operands invariant?}
+
+
+            function IndirectInhibit (op: icptr): boolean;
+
+            { See if a store should be inhibited due to indirect	}
+            { accesses							}
+            {								}
+            { parameters:						}
+            {    op - instruction to check				}
+            {								}
+            { Returns: True if the instruction should be inhibited,	}
+            {    else false.						}
+
+            begin {IndirectInhibit}
+            IndirectInhibit := false;
+            if indirectStores then
+               if Member(op, c_ind) then
+                  IndirectInhibit := true;
+            end; {IndirectInhibit}
+
+
+            function NoOtherStoresOrUses (lp, olp: loopPtr; op: icptr): boolean;
+
+            { Check for invalid stores					}
+            {								}
+            { parameters:						}
+            {    lp - loop to check					}
+            {    olp - loop entry for the block containing the store	}
+            {    op - store to check					}
+            {								}
+            { Returns: True if the store is valid, false if not.	}
+            {								}
+            { Notes: Specifically, these two rules are inforced:	}
+            {    1. No other stores to the same location appear in the	}
+            {       loop.						}
+            {    2. All uses of the value in the loop can be reached	}
+            {       only by the assign.					}
+
+            var
+               lp2: loopPtr;			{used to trace the loop list}
+               op2: icptr;			{used to trace code list}
+
+
+               function SafeLoad (sop, lop: icptr; sbk, lbk: blockPtr): boolean;
+
+               { See if a load is in a safe position			}
+               {							}
+               { parameters:						}
+               {    sop - save opcode that may need to be left in loop	}
+               {    lop - load operation that may inhibit the save	}
+               {    sbk - block containing the save			}
+               {    lbk - block containing the load			}
+
+
+                  function First (op1, op2, stream: icptr): icptr;
+
+                  { See which operation comes first				}
+                  {								}
+                  { parmeters:							}
+                  {    op1, op2 - instructions to check				}
+                  {    stream - start of block containing the instructions	}
+                  {								}
+                  { Returns: First operation found, or nil if missing		}
+
+                  var
+                     op: icptr;				{temp opcode}
+
+                  begin {First}
+                  if stream = op1 then
+                     First := op1
+                  else if stream = op2 then
+                     First := op2
+                  else begin
+                     op := nil;
+                     if stream^.left <> nil then
+                        op := First(op1, op2, stream^.left);
+                     if op = nil then
+                        if stream^.right <> nil then
+                           op := First(op1, op2, stream^.right);
+                     if op = nil then
+                        if stream^.next <> nil then
+                           op := First(op1, op2, stream^.next);
+                     First := op;
+                     end; {else}     
+                  end; {First}
+
+
+               begin {SafeLoad}
+               if sbk = lbk then
+                  SafeLoad := First(sop, lop, sbk^.code) = sop
+               else
+                  SafeLoad := MemberDFNList(sbk^.dfn, lbk^.dom);
+               end; {SafeLoad}
+
+
+               function MatchStores (op, tree: icptr; opbk, treebk: blockPtr):
+                  boolean;
+
+               { Check the tree for stores to the same location as op	}
+               {							}
+               { parameters:						}
+               {    op - store to check for				}
+               {    tree - operation tree to check			}
+               {    opbk - block containing op				}
+               {    treebk - block containing tree			}
+               {							}
+               { Returns: True if there are matching stores, else false	}
+
+               var
+                  result: boolean;		{function result}
+
+               begin {MatchStores}
+               result := false;
+               if tree^.opcode in [pc_str,pc_cop,pc_sro,pc_cpo] then begin
+                  if tree <> op then 
+                     result := MatchLoc(op, tree);
+                  end {if}
+               else if tree^.opcode in [pc_ldo,pc_lod] then
+                  if MatchLoc(op, tree) then
+                     result := not SafeLoad(op, tree, opbk, treebk);
+               if not result then
+                  if tree^.left <> nil then
+                     result := MatchStores(op, tree^.left, opbk, treebk);
+               if not result then
+                  if tree^.right <> nil then
+                     result := MatchStores(op, tree^.right, opbk, treebk);
+               MatchStores := result;
+               end; {MatchStores}
+
+
+            begin {NoOtherStoresOrUses}
+            NoOtherStoresOrUses := true;
+            lp2 := lp;
+            while lp2 <> nil do begin
+               op2 := lp2^.block^.code;
+               while op2 <> nil do
+                  if MatchStores(op, op2, olp^.block, lp2^.block) then begin
+                     op2 := nil;
+                     lp2 := nil;
+                     NoOtherStoresOrUses := false;
+                     end {if}
+                  else
+                     op2 := op2^.next;
+               if lp2 <> nil then
+                  lp2 := lp2^.next;
+               end; {while}
+            end; {NoOtherStoresOrUses}
+
+
+            function NumberOfGens (op: icptr; lp: loopPtr): integer;
+
+            { Count the number of nodes that generate op		}
+            {								}
+            { parameters:						}
+            {    op - instruction to check				}
+            {    lp - loop to check					}
+
+            var
+               count: integer;			{number of generators}
+
+            begin {NumberOfGens}
+            count := 0;
+            while lp <> nil do begin
+               if Member(op, lp^.block^.c_gen) then
+                  count := count+1;
+               lp := lp^.next;
+               end; {while}
+            NumberOfGens := count;
+            end; {NumberOfGens}
+
+
+            function PreviousStore (op, list: icptr): boolean;
+
+            { See if the last save was invariant			}
+            {								}
+            { parameters:						}
+            {    op - load operation					}
+            {    list - block containing the load			}
+            {								}
+            { Returns: True if the previous store was invariant, else	}
+            {    false.							}
+
+            var
+               indop: icptr;			{any indirect operation after strop}
+               strop: icptr;			{last matching store before op}
+
+
+               procedure Check (lop: icptr);
+
+               { Stop if this is lop; save if it is a matching store	}
+               {							}
+               { parameters:						}
+               {    lop - check this operation and it's children	}
+
+               begin {Check}
+               if lop^.left <> nil then
+                  Check(lop^.left);
+               if list <> nil then
+                  if lop^.right <> nil then
+                     Check(lop^.right);
+               if list <> nil then
+                  if lop = op then
+                     list := nil
+                  else if (lop^.opcode in [pc_str,pc_cop])
+                     and MatchLoc(op, lop) then begin
+                     strop := lop;
+                     indop := nil;
+                     end {else if}
+                  else if op^.opcode in [pc_sto,pc_cup,
+                      pc_cui,pc_tl1,pc_tl2,pc_vct,pc_pds,pc_csp,pc_cum] then
+                     indop := op;
+               end; {Check}
+
+
+               function Inhibit (indop, op: icptr): boolean;
+
+               { See if op should be inhibited due to indirect stores	}
+               {							}
+               { parameters:						}
+               {    indop - inhibiting indirect store or nil		}
+               {    op - instruction to check				}
+
+               begin {Inhibit}
+               Inhibit := false;
+               if indop <> nil then
+                  if Member(op, c_ind) then
+                     Inhibit := true;
+               end; {Inhibit}
+
+
+            begin {PreviousStore}
+            indop := nil;
+            strop := nil;
+            while list <> nil do begin
+               Check(list);
+               if list <> nil then
+                  list := list^.next;
+               end; {while}
+            PreviousStore := false;
+            if strop <> nil then
+               if strop^.parents <> 0 then
+                  if not Inhibit(indop, op) then
+                     PreviousStore := true;
+            end; {PreviousStore}
+
+
+         begin {Check}
+         if op^.parents = 0 then begin
+            invariant := true;
+            if op^.left <> nil then begin
+               Check(op^.left, olp);
+               if op^.left^.parents = 0 then
+        	  invariant := false;
+               end; {if}
+            if op^.right <> nil then begin
+               Check(op^.right, olp);
+               if op^.right^.parents = 0 then
+        	  invariant := false;
+               end; {if}
+            if invariant then begin
+               opcode := op^.opcode;
+               if opcode in
+        	  [pc_adi,pc_adl,pc_adr,pc_and,pc_lnd,pc_bnd,pc_bal,pc_bnt,
+                   pc_bnl,pc_bor,pc_blr,pc_bxr,pc_blx,pc_bno,pc_dec,pc_dvi,
+                   pc_udi,pc_dvl,pc_udl,pc_dvr,pc_equ,pc_neq,pc_grt,pc_les,
+                   pc_geq,pc_leq,pc_inc,pc_ind,pc_ior,pc_lor,pc_ixa,pc_lad,
+                   pc_lca,pc_lda,pc_ldc,pc_mod,pc_uim,pc_mdl,pc_ulm,pc_mpi,
+                   pc_umi,pc_mpl,pc_uml,pc_mpr,pc_ngi,pc_ngl,pc_ngr,pc_not,
+                   pc_sbi,pc_sbl,pc_sbr,pc_shl,pc_sll,pc_shr,pc_usr,pc_slr,
+                   pc_vsr,pc_chk,pc_abi,pc_abr,pc_abl,pc_sqi,pc_sql,pc_sqr,
+                   pc_rnd,pc_rn4,pc_odd,pc_odl,pc_at2,pc_sgs,pc_uni,pc_pwr,
+                   pc_int,pc_dif,pc_inn,pc_sin,pc_cos,pc_exp,pc_sqt,pc_log,
+                   pc_atn,pc_tan,pc_acs,pc_asn,pc_abl]
+                  then begin                                       
+        	  op^.parents := icount;
+                  icount := icount+1;
+                  end {if}
+               else if opcode = pc_cnv then begin
+        	  if op^.q & $000F <> ord(cgVoid) then begin
+        	     op^.parents := icount;
+                     icount := icount+1;
+                     end; {if}
+                  end {else if}
+               else if opcode in [pc_sro,pc_sto,pc_str,pc_cop,pc_cpo] then begin
+                  if not inhibit then
+                     if not IndirectInhibit(op) then
+                	if NoOtherStoresOrUses(lp, olp, op) then begin
+        		   op^.parents := icount;
+                	   icount := icount+1;
+                	   end; {if}
+                  end {else if}
+               else if opcode in [pc_lao,pc_ldo,pc_lod] then begin
+        	  {invariant if there is an immediately preceeding invariant store}
+        	  if PreviousStore(op, lp2^.block^.code) then begin
+                     op^.parents := icount;
+                     icount := icount+1;
+                     end {if}
+        	  else if not Member(op, lp2^.block^.c_gen) then begin
+                     {invariant if there are no generators in the loop}
+                     count := NumberOfGens(op, lp);
+                     if count = 0 then begin
+                        op^.parents := icount;       
+                        icount := icount+1;
+                        end {if}
+                     else if count = 1 then begin
+                	{invariant if there is one generator AND the generator}
+                        {is not in the current block AND no reaching          }
+                        {definitions for the loop AND generating statement is }
+                        {invariant                                            }
+                	if memberOp^.parents <> 0 then
+                           if not Member(op, lp^.block^.c_in) then begin
+                	      op^.parents := icount;
+                	      icount := icount+1;
+                              end; {if}
+                	end; {else if}
+                     end; {else}
+        	  end {else if}
+               end; {if}
+            if op^.parents <> 0 then
+               MarkInvariants := true;
+            end; {if}
+         end; {Check}
+
+
+         function CheckForIndirectStores (lp: loopPtr): boolean;
+
+         { See if there are any indirect stores or function calls in	}
+         { the loop							}
+         {								}
+         { parameters:							}
+         {    lp - loop to check					}
+         {								}
+         { Returns: True if there are indirect stores or function	}
+         {    calls, else false.					}
+
+
+            function CheckOps (op: icptr): boolean;
+
+            { Check this operation list					}
+            {								}
+            { parameters:						}
+            {    op - operation list to check				}
+            {								}
+            { Returns: True if an indirect store or function call is	}
+            {    found, else false.					}
+
+            var
+               result: boolean;			{value to return}
+
+            begin {CheckOps}
+            result := false;
+            while op <> nil do begin
+               if op^.opcode in [pc_sto,pc_cup,pc_cui,
+                   pc_tl1,pc_tl2,pc_vct,pc_pds,pc_csp,pc_mov,pc_cum] then begin
+                  result := true;
+                  op := nil;
+                  end {if}
+               else begin
+                  if op^.left <> nil then
+                     result := CheckOps(op^.left);
+                  if not result then
+                     if op^.right <> nil then
+                        result := CheckOps(op^.right);
+                  if result then
+                     op := nil;
+                  end; {if}
+               if op <> nil then
+                  op := op^.next;
+               end; {while}
+            CheckOps := result;
+            end; {CheckOps}
+
+
+         begin {CheckForIndirectStores}
+         CheckForIndirectStores := false;
+         while lp <> nil do
+            if CheckOps(lp^.block^.code) then begin
+               CheckForIndirectStores := true;
+               lp := nil;
+               end {if}
+            else
+               lp := lp^.next;
+         end; {CheckForIndirectStores}
+
+
+         function DominatesExits (dfn: integer; lp: loopPtr): boolean;
+
+         { See if this block dominates all loop exits			}
+         {								}
+         { parameters:							}
+         {    dfn - block that must dominate exits			}
+         {    lp - loop list						}
+         {								}
+         { Returns: True if the block dominates all exits, else false.	}
+
+         var
+            dom: blockListPtr;			{used to trace dominator list}
+
+         begin {DominatesExits}
+         DominatesExits := true;
+         while lp <> nil do begin
+            if lp^.exit then begin
+               dom := lp^.block^.dom;
+               while dom <> nil do 
+                  if dom^.dfn = dfn then
+                     dom := nil
+                  else begin
+                     dom := dom^.next;
+                     if dom = nil then begin
+                        lp := nil;
+                        DominatesExits := false;
+                        end; {if}
+                     end; {else}
+               end; {if}
+            if lp <> nil then
+               lp := lp^.next;
+            end; {while}
+         end; {DominatesExits}
+
+
+      begin {MarkInvariants}
+      MarkInvariants := false;
+      lp2 := lp;
+      while lp2 <> nil do begin
+         inhibit := not DominatesExits(lp2^.block^.dfn, lp);
+         indirectStores := CheckForIndirectStores(lp);
+         op := lp2^.block^.code;
+         while op <> nil do begin
+            Check(op, lp2);
+            op := op^.next;
+            end; {while}
+         lp2 := lp2^.next;
+         end; {while}
+      end; {MarkInvariants}
+
+
+      procedure RemoveInvariants (llp: loopListPtr);
+
+      { Remove loop invariant calculations			}
+      {								}
+      { parameters:						}
+      {    llp - pointer to the loop entry to process		}
+
+      var
+         icount, oldIcount: integer;	{invariant order counters}
+         nhp: blockPtr;			{new loop hedaer pointer}
+         op1, op2, op3: icptr;		{used to reverse the code list}
+
+
+         procedure CreateHeader;
+
+         { Create the new loop header					}
+         {								}
+         { Notes: As a side effect, CreateHeader sets nhp to point to	}
+         {    the new loop header.					}
+
+         var
+            lp: loopPtr;			{new loop list entry}
+            ohp: blockPtr;			{old loop hedaer pointer}
+
+         begin {CreateHeader}
+         nhp := pointer(Calloc(sizeof(block)));	{create the new block}
+         ohp := llp^.loop^.block;		{insert it in the block list}
+         nhp^.last := ohp^.last;
+         if nhp^.last <> nil then
+            nhp^.last^.next := nhp;
+         nhp^.next := ohp;
+         ohp^.last := nhp;
+	 new(lp);				{add it to the loop list}
+	 lp^.next := llp^.loop;
+	 llp^.loop := lp;
+	 lp^.block := nhp;
+         lp^.exit := false;
+         end; {CreateHeader}
+
+
+         function FindInvariant (ic: integer): integer;
+
+         { Find the next invariant calculation				}
+         {								}
+         { parameters:							}
+         {    ic - base count; the new count must exceed this		}
+         {								}
+         { Returns: count for the invariant record to remove		}
+
+         var
+            lp: loopPtr;			{used to trace loop list}
+            op: icptr;				{used to trace code list}
+            nic: integer;			{lowest count > ic}
+
+
+            procedure Check (op: icptr);
+
+            { See if op or its children represent a newer invariant	}
+            { calculation than the one numbered nic			}
+            {								}
+            { parameters:						}
+            {    op - instruction to check				}
+            {								}
+            { Notes: Rejecting pc_bno here is rather odd, but it allows	}
+            {    expressions _containing_ pc_bno to be removed without	}
+            {    messing up pc_tri operations by allowing pc_bno to be	}
+            {    removed as the top level of an expression.		}
+
+            begin {Check}
+            if op^.parents = 0 then begin
+               if op^.left <> nil then
+                  Check(op^.left);
+               if op^.right <> nil then
+                  Check(op^.right);
+               end {if}
+            else begin
+               if op^.parents < nic then
+                  if op^.parents > ic then
+                     if op^.opcode <> pc_bno then
+                        nic := op^.parents;
+               end; {else}
+            end; {Check}
+
+
+         begin {FindInvariant}
+         nic := maxint;
+         lp := llp^.loop;
+         while (lp <> nil) and (nic <> ic+1) do begin
+            op := lp^.block^.code;
+            while op <> nil do begin
+               Check(op);
+               op := op^.next;
+               end; {while}
+            lp := lp^.next;
+            end; {while}
+         FindInvariant := nic;
+         end; {FindInvariant}
+
+
+         procedure RemoveInvariant (ic: integer);
+
+         { Move the invariant calculation to the header			}
+         {								}
+         { parameters:							}
+         {    ic - index number for instruction to remove		}
+
+         var
+            done: boolean;			{loop termination test}
+            lp: loopPtr;			{used to trace loop list}
+            op: icptr;				{used to trace code list}
+
+
+            procedure Check (op: icptr);
+
+            { See if a child of op is the target instruction to move	}
+            { (If so, move it.)						}
+            {								}
+            { parameters:						}
+            {    op - instruction to check				}
+
+
+               procedure Remove (var op: icptr);
+
+               { Move a calculation to the loop header			}
+               {							}
+               { parameters:						}
+               {    op - invariant calculation to move			}
+
+               var
+		  loc, op2, str: icptr;		{new opcodes}
+		  optype: baseTypeEnum;		{type of the temp variable}
+
+               begin {Remove}
+               if (op^.left <> nil) or (op^.right <> nil) then begin
+        	  optype := TypeOf(op);		{create a temp label}
+        	  loc := pointer(Calloc(sizeof(intermediate_code)));
+        	  loc^.opcode := dc_loc;
+        	  loc^.optype := cgWord;
+        	  maxLoc := maxLoc + 1;
+        	  loc^.r := maxLoc;
+        	  loc^.q := TypeSize(optype);
+        	  loc^.next := nhp^.code;
+        	  nhp^.code := loc;
+						{make a copy of the tree}
+        	  op2 := pointer(Malloc(sizeof(intermediate_code)));
+        	  op2^ := op^;
+        	  op^.opcode := pc_lod;		{substitute a load of the temp}
+        	  op^.optype := optype;
+        	  op^.r := loc^.r;
+        	  op^.q := 0;
+        	  op^.left := nil;
+        	  op^.right := nil;
+						{store the temp result}
+        	  str := pointer(Calloc(sizeof(intermediate_code)));
+        	  str^.opcode := pc_str;
+        	  str^.optype := optype;
+        	  str^.r := loc^.r;
+        	  str^.q := 0;
+        	  str^.left := op2;
+        	  str^.next := loc^.next;	{insert the store in the basic block}
+        	  loc^.next := str;
+                  end; {if}
+               done := true;
+               end; {Remove}
+
+
+            begin {Check}
+            if op^.left <> nil then begin
+               if op^.left^.parents = ic then
+                  Remove(op^.left);
+               if not done then
+                  Check(op^.left);
+               end; {if}
+            if not done then
+               if op^.right <> nil then begin
+        	  if op^.right^.parents = ic then 
+                     Remove(op^.right);
+                  if not done then
+                     Check(op^.right);
+                  end; {if}
+            end; {Check}   
+
+
+            procedure RemoveTop (var op: icptr);
+
+            { Move a top-level instruction to the header		}
+            {								}
+            { parameters:						}
+            {    op - top level instruction to remove			}
+
+            var
+               op2: icptr;			{temp operation}
+
+            begin {RemoveTop}
+            op2 := op;
+            op := op^.next;
+            op2^.next := nhp^.code;
+            nhp^.code := op2;
+            end; {RemoveTop}
+
+
+         begin {RemoveInvariant}
+         lp := llp^.loop;
+         done := false;
+         while not done do begin
+            op := lp^.block^.code;
+            if op <> nil then
+               if op^.parents = ic then begin
+        	  RemoveTop(lp^.block^.code);
+        	  done := true;
+        	  end {if}
+               else begin
+        	  Check(op);
+        	  while (op^.next <> nil) and (not done) do begin
+                     if op^.next^.parents = ic then begin
+                	RemoveTop(op^.next);
+                	done := true;
+                	end {if}
+                     else
+                	Check(op^.next);
+                     if op^.next <> nil then
+        		op := op^.next;
+        	     end; {while}
+        	  end; {else}
+            lp := lp^.next;
+            if lp = nil then
+               done := true;
+            end; {while}
+         end; {RemoveInvariant}
+
+
+      begin {RemoveInvariants}
+      CreateHeader;			{create a loop header block}
+      icount := 0;			{find & remove all invariants}
+      repeat
+         oldIcount := icount;
+         icount := FindInvariant (icount);
+         if icount <> maxint then
+            RemoveInvariant(icount);
+      until icount = maxint;
+      op1 := nhp^.code;			{reverse the new code list}
+      op2 := nil;
+      while op1 <> nil do begin
+         op3 := op1;
+         op1 := op1^.next;
+         op3^.next := op2;
+         op2 := op3;
+         end; {while}
+      nhp^.code := op2;
+      end; {RemoveInvariants}
+
+
+      procedure ZeroParents (lp: loopPtr);
+
+      { Zero the parents field in all nodes			}
+      {								}
+      { parameters:						}
+      {    lp - loop for which to zero the parents		}
+
+      var
+         op: icptr;			{used to trace the opcode list}
+
+
+         procedure Zero (op: icptr);
+
+         { Zero the parents field for this node and its		}
+         { children.						}
+         {							}
+         { parameters:						}
+         {    op - node to zero					}
+
+         begin {Zero}
+         op^.parents := 0;
+         if op^.left <> nil then
+            Zero(op^.left);
+         if op^.right <> nil then
+            Zero(op^.right);
+         end; {Zero}
+
+            
+      begin {ZeroParents}
+      while lp <> nil do begin
+         op := lp^.block^.code;
+         while op <> nil do begin
+            Zero(op);
+            op := op^.next;
+            end; {while}
+         lp := lp^.next;
+         end; {while}
+      end; {ZeroParents}
+
+
+   begin {LoopInvariantRemoval}
+   Spin;
+   FindLoops;				{find a list of natural loops}
+
+   llp := loops;			{scan the loops...}
+   icount := 1;
+   while llp <> nil do begin
+      Spin;
+      ZeroParents(llp^.loop);		{set the parents field to zero}
+      while MarkInvariants(llp^.loop) do {mark the loop invariant computations}
+         ;
+      if icount <> 1 then
+	 RemoveInvariants(llp);		{remove loop invariant calculations}
+      llp := llp^.next;
+      end; {while}
+
+
+   while loops <> nil do begin		{dispose of the loop lists}
+      while loops^.loop <> nil do begin
+	 lp := loops^.loop;
+	 loops^.loop := lp^.next;
+	 dispose(lp);
+	 end; {while}
+      llp := loops;
+      loops := llp^.next;
+      dispose(llp);
+      end; {while}
+   end; {LoopInvariantRemoval}
+
+
+   function RemoveDeadNodes: boolean;
+
+   { Checks for and removes unreachable nodes			}
+   {								}
+   { Returns: True if there were dead nodes, else false		}
+
+   var
+      bb, bb2: blockPtr;		{used to trace basic block lists}
+
+   begin {RemoveDeadNodes}
+   RemoveDeadNodes := false;
+   bb := DAGblocks;
+   bb2 := bb^.next;
+   while bb2 <> nil do
+      if not bb2^.visited then begin
+         RemoveDeadNodes := true;
+         bb2 := bb2^.next;
+         bb^.next := bb2;
+         end {if}
+      else begin
+         bb := bb2;
+         bb2 := bb2^.next;
+         end; {else}
+   end; {RemoveDeadNodes}
+   
+
+begin {DoLoopOptimization}
+repeat
+   DepthFirstOrder;			{create the depth first tree}
+until not RemoveDeadNodes;
+ReachingDefinitions;			{find reaching definitions}
+Dominators;				{find the lists of dominators}
+LoopInvariantRemoval;			{remove loop invariant computations}
+while dft <> nil do begin		{dispose of the depth first tree}
+   dft2 := dft;
+   dft := dft2^.next;
+   dispose(dft2);
+   end; {while}
+while backEdge <> nil do begin		{dispose of the back edge list}
+   dft2 := backEdge;
+   backEdge := dft2^.next;
+   dispose(dft2);
+   end; {while}
+end; {DoLoopOptimization}
+
+{---------------------------------------------------------------}
+
+procedure DAG {code: icptr};
+
+{ place an op code in a DAG or tree				}
+{                                                               }
+{ parameters:                                                   }
+{       code - opcode						}
+
+var
+   temp: icptr;				{temp node}
+
+
+   procedure Generate;
+
+   { generate the code for the current procedure		}
+
+   var
+      op: icptr;			{temp opcode pointers}
+
+
+      procedure BasicBlocks;
+
+      { Break the code up into basic blocks			}
+
+      var
+         blast: blockPtr;		{last block pointer}
+         bp: blockPtr;			{current block pointer}
+         cb: icptr;			{last code in block pointer}
+         cp: icptr;			{current code pointer}
+
+      begin {BasicBlocks}
+      cp := DAGhead;
+      DAGblocks := nil;
+      if cp <> nil then begin
+         bp := pointer(Calloc(sizeof(block)));
+         DAGblocks := bp;
+         blast := bp;
+         bp^.code := cp;
+         cb := cp;
+         cp := cp^.next;
+         cb^.next := nil;
+         while cp <> nil do
+					{labels start a new block}
+            if cp^.opcode = dc_lab then begin
+               Spin;
+               bp := pointer(Calloc(sizeof(block)));
+               bp^.last := blast;
+               blast^.next := bp;
+               blast := bp;
+               bp^.code := cp;
+               cb := cp;
+               cp := cp^.next;
+               cb^.next := nil;
+               end {if}
+					{conditionals are followed by a new block}
+            else if cp^.opcode in [pc_fjp, pc_tjp, pc_ujp, pc_ret, pc_xjp] then
+               begin
+               Spin;
+               while cp^.next^.opcode = pc_add do begin
+                  cb^.next := cp;
+        	  cb := cp;
+        	  cp := cp^.next;
+        	  cb^.next := nil;
+                  end; {while}
+               cb^.next := cp;
+               cb := cp;
+               cp := cp^.next;
+               cb^.next := nil;
+               bp := pointer(Calloc(sizeof(block)));
+               bp^.last := blast;
+               blast^.next := bp;
+               blast := bp;
+               bp^.code := cp;
+               cb := cp;
+               cp := cp^.next;
+               cb^.next := nil;
+               end {else if}
+            else begin			{all other statements get added to a block}
+               cb^.next := cp;
+               cb := cp;
+               cp := cp^.next;
+               cb^.next := nil;
+               end; {else}
+         end; {if}
+      end; {BasicBlocks}
+
+
+   begin {Generate}             
+   if peepHole then begin		{peephole optimization}
+      peepSpin := 0;
+      repeat
+         rescan := false;
+	 PeepHoleOptimization(DAGhead);	
+	 op := DAGHead;
+	 while op^.next <> nil do begin
+            PeepHoleOptimization(op^.next);
+            op := op^.next;
+            end; {while}
+ 	 CheckLabels;
+      until not rescan;
+      end; {if}
+   BasicBlocks;				{build the basic blocks}
+   if (commonSubexpression or loopOptimizations) and (not prsFound) then
+      FlagIndirectUses;			{create a list of all indirect uses}
+   if commonSubexpression and		{common sub-expression removal}
+      (not prsFound) then
+      CommonSubexpressionElimination;
+   if loopOptimizations and		{loop optimizations}
+      (not prsFound) then
+      DoLoopOptimization;
+{  if printSymbols then			{debug}
+{     PrintBlocks(@'DAG: ', DAGblocks);	{debug}
+   if (commonSubexpression or loopOptimizations) and (not prsFound) then
+      DisposeOpList(c_ind);		{dispose of indirect use list}
+   Gen(DAGblocks);			{generate native code}
+   if loopOptimizations and		{dump and dynamic space}
+      (not prsFound) then
+      DumpLoopLists;
+   DAGhead := nil;			{reset the DAG pointers}
+   end; {Generate}
+
+
+   procedure Push (code: icptr);
+
+   { place a node on the operation stack			}
+   {								}
+   { parameters:						}
+   {    code - node						}
+
+   begin {Push}
+   code^.next := DAGhead;
+   DAGhead := code;
+   end; {Push}
+
+
+   function Pop: icptr;
+
+   { pop a node from the operation stack			}
+   {								}
+   { returns: node pointer or nil				}
+
+   var
+      node: icptr;			{node poped}
+      tn: icptr;			{temp node}
+
+   begin {Pop}
+   node := DAGhead;
+   if node = nil then
+      Error(cge1)
+   else begin
+      DAGhead := node^.next;
+      node^.next := nil;
+      end; {else}
+   if node^.opcode = dc_loc then begin
+      tn := node;
+      node := Pop;
+      Push(tn);
+      end; {if}
+   Pop := node;
+   end; {Pop}
+
+
+   procedure Reverse;
+
+   { Reverse the operation stack				}
+
+   var
+      list, temp: icptr;		{work pointers}
+
+   begin {Reverse}
+   list := nil;
+   while DAGhead <> nil do begin
+      temp := DAGhead;
+      DAGhead := temp^.next;
+      temp^.next := list;
+      list := temp;
+      end; {while}
+   DAGhead := list;
+   end; {Reverse}
+
+
+begin {DAG}
+case code^.opcode of
+
+   pc_abi, pc_abl, pc_abr, pc_acs, pc_asn, pc_atn,
+   pc_bnl, pc_bnt,
+   pc_chk, pc_cos, pc_cnv, pc_csp, pc_cum,
+   pc_cup, pc_dec, pc_exp, pc_fjp, pc_inc,
+   pc_ind, pc_log, pc_ngi, pc_ngl, pc_ngr, pc_not, pc_odd,
+   pc_odl, pc_pds, pc_rnd, pc_rn4, pc_sin,
+   pc_siz, pc_sqi, pc_sql, pc_sqr, pc_sqt,
+   pc_sro, pc_stk, pc_str, pc_tan, pc_tjp, pc_tl1, pc_tl2, pc_vct, pc_xjp:
+      begin
+      code^.left := Pop;
+      Push(code);
+      end;
+
+   pc_adi, pc_adl, pc_adr, pc_and, pc_at2,
+   pc_bal, pc_blr, pc_blx, pc_bnd, pc_bno, pc_bor, pc_bxr,
+   pc_cui, pc_dif, pc_dvi, pc_dvl, pc_dvr, pc_equ,
+   pc_geq, pc_grt, pc_inn, pc_int, pc_ior,
+   pc_ixa, pc_leq, pc_les, pc_mdl, pc_mod, pc_mov, pc_mpi, pc_mpl, pc_mpr,
+   pc_neq, pc_pwr, pc_sbi, pc_sbl, pc_sbr, pc_sgs,
+   pc_shl, pc_shr, pc_sll, pc_slr, pc_sto, pc_udi, pc_udl, pc_uim, pc_ulm,
+   pc_umi, pc_uml, pc_uni, pc_usr, pc_vsr:
+      begin
+      code^.right := Pop;
+      code^.left := Pop;
+      Push(code);
+      end;
+
+   dc_dst, dc_glb, dc_lab, dc_pin, dc_sym,
+   pc_add, pc_ent, pc_fix, pc_lad, pc_lao, pc_lca, pc_lda, pc_ldc, pc_ldo,
+   pc_lla, pc_lnm, pc_lod, pc_lsl, pc_nam, pc_nop, pc_ret, pc_ujp:
+      Push(code);
+
+   pc_prs:
+      begin
+      Push(code);
+      prsFound := true;
+      end;
+
+   pc_cnn:
+      begin
+      code^.opcode := pc_cnv;
+      temp := Pop;
+      code^.left := Pop;
+      Push(code);
+      Push(temp);
+      end;
+
+   dc_fun, dc_loc: begin
+      Push(code);
+      if code^.r > maxLoc then
+         maxLoc := code^.r;
+      end;
+
+   dc_prm: begin
+      Push(code);
+      if code^.s > maxLoc then
+         maxLoc := code^.s;
+      end;
+
+   dc_str: begin
+      Push(code);
+      maxLoc := 0;
+      prsFound := false;
+      end;
+
+   dc_enp: begin
+      Push(code);
+      Reverse;
+      Generate;
+      end;
+
+   otherwise:
+      Error(cge1);			{invalid opcode}
+   end; {case}
+end; {DAG}
+
+end.
+
+{$append 'dag.asm'}
diff --git a/gen.pas b/gen.pas
old mode 100755
new mode 100644
index 966b2ad..8993860
--- a/gen.pas
+++ b/gen.pas
@@ -1 +1,5965 @@
-{$optimize -1}
{---------------------------------------------------------------}
{								}
{  Gen								}
{								}
{  Generates native code from intermediate code instructions.	}
{								}
{---------------------------------------------------------------}

unit Gen;

interface

{$segment 'gen'}

{$LibPrefix '0/obj/'}

uses PCommon, CGI, CGC, ObjOut, Native;

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

procedure Gen (blk: blockPtr);

{ Generates native code for a list of blocks			}
{								}
{ parameters:							}
{    blk - first of the list of blocks				}

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

implementation

const
   A_X		=	1;		{longword locations}
   onStack	=	2;
   inPointer	=	4;
   localAddress =	8;
   globalLabel	=      16;
   constant	=      32;

					{stack frame locations}
					{---------------------}
   returnSize		=	3;	{size of return address}

type
					{possible locations for 4 byte values}
   longType = record			{desciption of current four byte value}
      preference: integer;		{where you want the value}
      where: integer;			{where the value is at}
      fixedDisp: boolean;		{is the displacement a fixed value?}
      isLong: boolean;			{is long addr required for named labs?}
      disp: integer;			{fixed displacement/local addr}
      lval: longint;			{value}
      lab: pStringPtr;			 {global label name}
      end;

var
   enpFound: boolean;			{was the dc_enp found?}
   gLong: longType;			{info about last long value}
   namePushed: boolean;			{has a name been pushed in this proc?}
   skipLoad: boolean;			{skip load for a pc_lli, etc?}

					{stack frame locations}
					{---------------------}
   bankLoc: integer;			{disp in dp where bank reg is stored}
   dworkLoc: integer;			{disp in dp of 4 byte work spage for cg}
   funLoc: integer;			{loc of fn ret value in stack frame}
   localSize: integer;			{local space for current proc}
   parameterSize: integer;		{# bytes of parameters for current proc}
   staticLoc: integer;			{loc of static link}
   
{---------------------------------------------------------------}

procedure GenTree (op: icptr); forward;

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

function Complex (op: icptr): boolean;

{ determine if loading the intermediate code involves anything	}
{ but one reg							}
{								}
{ parameters:							}
{    code - intermediate code to check				}
{								}
{ NOTE: for one and two byte values only!!!			}

begin {Complex}
Complex := true;
if op^.opcode in [pc_ldo,pc_ldc] then
   Complex := false
else if op^.opcode = pc_lod then
   if op^.p = 0 then
      if localLabel[op^.r] + op^.q < 256 then
	 Complex := false;
if op^.optype in [cgByte,cgUByte] then
   Complex := true;
end; {Complex}


procedure DoOp(op_imm, op_abs, op_dir: integer; icode: icptr; disp: integer);

{ Do an operation.						}
{								}
{ Parameters:							}
{    op_imm,op_abs,op_dir - op codes for the various		}
{	addressing modes 					}
{    icode - intermediate code record				}
{    disp - disp past the location (1 or 2)			}

var
   val: integer; 		     {value for immediate operations}
   lval: longint;		     {long value for immediate operations}

begin {DoOp}
if icode^.opcode = pc_ldc then begin
   lval := icode^.lval;
   if disp = 0 then
      val := long(lval).lsw
   else
      val := long(lval).msw;
   GenNative(op_imm, immediate, val, nil, 0);
   end {if}
else if icode^.opcode in [pc_lod,pc_str] then
   GenNative(op_dir, direct, localLabel[icode^.r] + icode^.q + disp, nil, 0)
else {if icode^.opcode in [pc_ldo, pc_sro] then}
   GenNative(op_abs, absolute, icode^.q + disp, icode^.lab, 0);
end; {DoOp}


procedure GetPointer (op: icptr);

{ convert a tree into a usable pointer for indirect		}
{ loads/stores							}
{								}
{ parameters:							}
{    op - pointer tree						}

begin {GetPointer}
gLong.preference := A_X+inPointer+localAddress+globalLabel;
GenTree(op);
if gLong.where = onStack then begin
   GenImplied(m_pla);
   GenImplied(m_plx);
   gLong.where := A_X;
   end; {if}
if gLong.where = A_X then begin
   GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
   GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0);
   gLong.where := inPointer;
   gLong.fixedDisp := true;
   gLong.disp := dworkLoc;
   end; {else if}
end; {GetPointer}


procedure IncAddr (size: integer);

{ add a two byte constant to a four byte value - generally an	}
{ address							}
{								}
{ parameters:							}
{    size - integer to add					}

var
   lab1: integer;			{branch point}

begin {IncAddr}
if size <> 0 then
   case gLong.where of

      onStack: begin
	 lab1 := GenLabel;
	 GenImplied(m_pla);
	 if size = 1 then begin
	    GenImplied(m_ina);
	    GenNative(m_bne, relative, lab1, nil, 0);
	    end {if}
	 else begin
	    GenImplied(m_clc);
	    GenNative(m_adc_imm, immediate, size, nil, 0);
	    GenNative(m_bcc, relative, lab1, nil, 0);
	    end; {else}
	 GenImplied(m_plx);
	 GenImplied(m_inx);
	 GenImplied(m_phx);
	 GenLab(lab1);
	 GenImplied(m_pha);
	 end;

      A_X: begin
	 lab1 := GenLabel;
	 if size = 1 then begin
	    GenImplied(m_ina);
	    GenNative(m_bne, relative, lab1, nil, 0);
	    end {if}
	 else begin
	    GenImplied(m_clc);
	    GenNative(m_adc_imm, immediate, size, nil, 0);
	    GenNative(m_bcc, relative, lab1, nil, 0);
	    end; {else}
	 GenImplied(m_inx);
	 GenLab(lab1);
	 end;

      inPointer:
	 if gLong.fixedDisp then begin
	    gLong.fixedDisp := false;
	    GenNative(m_ldy_imm, immediate, size, nil, 0);
	    end {if}
	 else if size <= 4 then begin
	    while size <> 0 do begin
	       GenImplied(m_iny);
	       size := size - 1;
	       end; {while}
	    end {else if}
	 else begin
	    GenImplied(m_tya);
	    GenImplied(m_clc);
	    GenNative(m_adc_imm, immediate, size, nil, 0);
	    GenImplied(m_tay);
	    end; {else}

      localAddress,globalLabel:
	 gLong.disp := gLong.disp+size;

      otherwise:
	 Error(cge1);
      end; {case}
end; {IncAddr}


procedure LoadX (op: icptr);

{ Load X with a two byte value					}
{                                                               }
{ parameters:                                                   }
{    op - value to load						}

var
   q, r: integer;
   lab: pStringPtr;

begin {LoadX}
q := op^.q;
r := op^.r;
lab := op^.lab;
case op^.opcode of
   pc_lao,pc_lda:
      Error(cge1);
   pc_ldc:
      GenNative(m_ldx_imm, immediate, q, nil, 0);
   pc_ldo:
      GenNative(m_ldx_abs, absolute, q, lab, 0);
   pc_lod:
      GenNative(m_ldx_dir, direct, localLabel[r] + q, nil, 0);
   otherwise:
      Error(cge1);
   end; {case}
end; {LoadX}


procedure OperA (mop: integer; op: icptr);

{ Do an operation on op that has addr modes equivalent to STA	}
{								}
{ parameters:							}
{    op - node to generate the leaf for				}
{    mop - operation						}

var
   loc: integer; 			{stack frame position}
   opcode: pcodes;			{temp storage}

begin {OperA}
opcode := op^.opcode;
case opcode of

   pc_ldo: begin
      {this shortcut is valid for cmp, adc, and, ora, sbc, eor}
      mop := mop+4;
      if smallMemoryModel then
         GenNative(mop, absolute, op^.q, op^.lab, 0)
      else
         GenNative(mop+2, longAbs, op^.q, op^.lab, 0);
      end; {case pc_ldo}

   pc_lod: begin
      {this shortcut is valid for cmp, adc, and, ora, sbc, eor}
      mop := mop-4;
      loc := localLabel[op^.r];
      loc := loc + op^.q;
      GenNative(mop, direct, loc, nil, 0);
      end; {case pc_lod}

   pc_ldc:
      GenNative(mop, immediate, op^.q, nil, 0);

   otherwise:
      Error(cge1);
   end; {case}
end; {OperA}


function NeedsCondition (opcode: pcodes): boolean;

{ See if the operation is one that doesn't set the condition	}
{ code reliably							}
{								}
{ Parameters:							}
{    opcodes - operation to check				}
{								}
{ Returns: True if the condition code is not set properly for	}
{    an operand type of cgByte,cgUByte,cgWord,cgUWord, else	}
{    false							}

begin {NeedsCondition}
NeedsCondition := opcode in
   [pc_and,pc_ior,pc_cui,pc_cup,pc_lor,pc_lnd,
    pc_cop,pc_cpo,pc_dvi,pc_mpi,pc_adi,pc_sbi,pc_mod,pc_bno];
end; {NeedsCondition}


function SameLoc (load, save: icptr): boolean;

{ See if load and save represent the same location (which must	}
{ be a direct page value or a global label).			}
{								}
{ parameters:							}
{    load - load operation					}
{    save - save operation					}
{								}
{ Returns: True the the same location is used, else false	}

begin {SameLoc}
SameLoc := false;
if save <> nil then begin
   if load^.opcode = pc_lod then begin
      if localLabel[load^.r] + load^.q < 254 then
	 if save^.opcode = pc_str then
	    if save^.q = load^.q then
	       if save^.r = load^.r then
	          if save^.p = load^.p then
		     SameLoc := true;
      end {if}
   else if smallMemoryModel then
      if load^.opcode = pc_ldo then
	 if save^.opcode = pc_sro then
	    if load^.lab^ = save^.lab^ then
	       if load^.q = save^.q then
		  SameLoc := true;
   end; {if}
end; {SameLoc}


procedure SaveRetValue (optype: baseTypeEnum);

{ save a value returned by a function                           }
{                                                               }
{ parameters:                                                   }
{    optype - function type					}

begin {SaveRetValue}
if optype in [cgLong,cgULong] then begin
   if (A_X & gLong.preference) = 0 then begin
      gLong.where := onStack;
      GenImplied(m_phx);
      GenImplied(m_pha);
      end
   else
      gLong.where := A_X;
   end {if}
else if optype in [cgReal,cgDouble,cgExtended,cgComp] then
   GenCall(85);
end; {SaveRetValue}


procedure StaticLink (levels: integer; guardA: boolean; inA: boolean);

{ Returns the start of the needed stack frame in X.		}
{								}
{ parameters:							}
{    levels - number of static levels to traverse		}
{    guardA - if true, A is preserved				}
{    inA - if true, the result is returned in A, rather than X	}
{								}
{ Note: gardA and inA should not both be true			}

var
   i: integer;				{loop variable}

begin {StaticLink}
if inA and (levels = 1) then
   GenNative(m_lda_dir, direct, staticLoc, nil, 0)
else
   GenNative(m_ldx_dir, direct, staticLoc, nil, 0);
if levels > 1 then begin
   if guardA then
      GenImplied(m_tay);
   for i := 2 to levels do begin
      GenNative(m_lda_longX, longAbsolute, staticLoc, nil, 0);
      if not (inA and (levels = i)) then
	 GenImplied(m_tax);
      end; {for}
   if guardA then
      GenImplied(m_tya);
   end; {if}
end; {StaticLink}

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

procedure GenAdlSbl (op, save: icptr);

{ generate code for pc_adl, pc_sbl				}
{								}
{ parameters:							}
{    op - pc_adl or pc_sbl operation				}
{    save - save location (pc_str or pc_sro) or nil		}

var
   bcc,clc,adc_imm,inc_dir,adc_abs,	{for op-code insensitive code}
      adc_dir,inc_abs,adc_s: integer;
   disp: integer;			{direct page location}
   lab1: integer;			{label number}
   lLong: longType;			{used to reserve gLong}
   nd: icptr;				{for swapping left/right children}
   opcode: pcodes;			{temp storage; for efficiency}
   simpleStore: boolean; 		{is the store absolute or direct?}
   val: longint; 			{long constant value}


   function Simple (icode: icptr): boolean;

   { See if the intermediate code is simple; i.e., can be	}
   { reached by direct page or absolute addressing.		}

   var
      load: icptr;			{left opcode}

   begin {Simple}
   Simple := false;
   if icode^.opcode = pc_ldc then
      Simple := true
   else if icode^.opcode in [pc_lod,pc_str] then begin
      if localLabel[icode^.r] + icode^.q < 254 then
         if icode^.p = 0 then
	    Simple := true;
      end {else if}
   else if icode^.opcode in [pc_ldo,pc_sro] then
      Simple := smallMemoryModel;
   end; {Simple}


begin {GenAdlSbl}
{determine where the result goes}
if save <> nil then
   gLong.preference :=
      A_X+onStack+inPointer+localAddress+globalLabel+constant;
lLong := gLong;

{set up the master instructions}
opcode := op^.opcode;
if opcode = pc_adl then begin
   clc := m_clc;
   bcc := m_bcc;
   adc_imm := m_adc_imm;
   adc_abs := m_adc_abs;
   adc_dir := m_adc_dir;
   adc_s   := m_adc_s;
   inc_dir := m_inc_dir;
   inc_abs := m_inc_abs;
   end {if}
else begin
   clc := m_sec;
   bcc := m_bcs;
   adc_imm := m_sbc_imm;
   adc_abs := m_sbc_abs;
   adc_dir := m_sbc_dir;
   adc_s   := m_sbc_s;
   inc_dir := m_dec_dir;
   inc_abs := m_dec_abs;
   end; {else}

{if the lhs is a constant, swap the nodes}
if ((op^.left^.opcode = pc_ldc) and (opcode = pc_adl)) then begin
   nd := op^.left;
   op^.left := op^.right;
   op^.right := nd;
   end; {if}

{handle a constant rhs}
if op^.right^.opcode = pc_ldc then
   val := op^.right^.lval
else
   val := -1;
if SameLoc(op^.left, save) and (save^.p = 0) and (long(val).msw = 0) then begin
   lab1 := GenLabel;
   if val = 1 then begin
      if opcode = pc_adl then begin
	 DoOp(0, m_inc_abs, m_inc_dir, op^.left, 0);
	 GenNative(m_bne, relative, lab1, nil, 0);
	 DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2);
	 GenLab(lab1);
	 end {if}
      else {if opcode = pc_sbl then} begin
	 DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
	 GenNative(m_beq, relative, lab1, nil, 0);
	 DoOp(0, m_dec_abs, m_dec_dir, op^.left, 0);
	 GenLab(lab1);
	 DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2);
	 end; {else}
      end {if}
   else begin {rhs in [2..65535]}
      GenImplied(clc);
      DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
      GenNative(adc_imm, immediate, long(val).lsw, nil, 0);
      DoOp(0, m_sta_abs, m_sta_dir, op^.left, 0);
      GenNative(bcc, relative, lab1, nil, 0);
      if opcode = pc_adl then
	 DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2)
      else
	 DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2);
      GenLab(lab1);
      end; {else}
   end {if constant rhs}

else begin
   simpleStore := false;
   if save <> nil then
      simpleStore := Simple(save);
   if (opcode = pc_adl) and Simple(op^.left) then begin
      nd := op^.left;
      op^.left := op^.right;
      op^.right := nd;
      end; {if}
   if simpleStore and Simple(op^.right) then begin
      if Simple(op^.left) then begin
	 GenImplied(clc);
	 DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0);
	 DoOp(0, m_sta_abs, m_sta_dir, save, 0);
	 DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 2);
	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2);
	 DoOp(0, m_sta_abs, m_sta_dir, save, 2);
	 end {if}
      else begin
	 gLong.preference := A_X;
	 GenTree(op^.left);
	 GenImplied(clc);
	 if gLong.where = onStack then
	    GenImplied(m_pla);
	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0);
	 DoOp(0, m_sta_abs, m_sta_dir, save, 0);
	 if gLong.where = onStack then
	    GenImplied(m_pla)
	 else
	    GenImplied(m_txa);
	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2);
	 DoOp(0, m_sta_abs, m_sta_dir, save, 2);
	 end; {else}
      end {if}
   else if Simple(op^.right) and (save = nil) then begin
      gLong.preference := gLong.preference & A_X;
      GenTree(op^.left);
      GenImplied(clc);
      if gLong.where = onStack then begin
	 GenImplied(m_pla);
	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0);
	 GenImplied(m_pha);
	 GenNative(m_lda_s, direct, 3, nil, 0);
	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2);
	 GenNative(m_sta_s, direct, 3, nil, 0);
	 end {if}
      else begin
	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0);
	 GenImplied(m_tay);
	 GenImplied(m_txa);
	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2);
	 GenImplied(m_tax);
	 GenImplied(m_tya);
	 end; {else}
      end {else if}
   else begin {doing it the hard way}
      gLong.preference := onStack;
      GenTree(op^.right);
      gLong.preference := onStack;
      GenTree(op^.left);
      GenImplied(clc);
      GenImplied(m_pla);
      GenNative(adc_s, direct, 3, nil, 0);
      GenNative(m_sta_s, direct, 3, nil, 0);
      GenImplied(m_pla);
      GenNative(adc_s, direct, 3, nil, 0);
      GenNative(m_sta_s, direct, 3, nil, 0);
      if save = nil then
	 gLong.where := onStack
      else if save^.opcode = pc_str then begin
	 disp := localLabel[save^.r] + save^.q;
         if save^.p <> 0 then begin
	    StaticLink(save^.p, false, false);
	    GenImplied(m_pla);
	    GenNative(m_sta_longX, longAbsolute, disp, nil, 0);
	    GenImplied(m_pla);
	    GenNative(m_sta_longX, longAbsolute, disp+2, nil, 0);
            end {if}
	 else if disp < 254 then begin
	    GenImplied(m_pla);
	    GenNative(m_sta_dir, direct, disp, nil, 0);
	    GenImplied(m_pla);
	    GenNative(m_sta_dir, direct, disp+2, nil, 0);
	    end {else if}
	 else begin
	    GenNative(m_ldx_imm, immediate, disp, nil, 0);
	    GenImplied(m_pla);
	    GenNative(m_sta_dirX, direct, 0, nil, 0);
	    GenImplied(m_pla);
	    GenNative(m_sta_dirX, direct, 2, nil, 0);
	    end; {else}
	 end {else if}
      else {if save^.opcode = pc_sro then} begin
	 GenImplied(m_pla);
	 if smallMemoryModel then
	    GenNative(m_sta_abs, absolute, save^.q, save^.lab, 0)
	 else
	    GenNative(m_sta_long, longabsolute, save^.q, save^.lab, 0);
	 GenImplied(m_pla);
	 if smallMemoryModel then
	    GenNative(m_sta_abs, absolute, save^.q+2, save^.lab, 0)
	 else
	    GenNative(m_sta_long, longabsolute, save^.q+2, save^.lab, 0);
	 end; {else}
      end; {else}
   end; {else}
end; {GenAdlSbl}


procedure GenCmp (op: icptr; rOpcode: pcodes; lb: integer);

{ generate code for pc_les, pc_leq, pc_grt or pc_geq		}
{								}
{ parameters:							}
{    op - operation						}
{    rOpcode - Opcode that will use the result of the		}
{	compare.  If the result is used by a tjp or fjp, 	}
{	this procedure generated special code and does the	}
{	branch internally.					}
{    lb - For fjp, tjp, this is the label to branch to if	}
{	     the condition is satisfied. 			}

var
   i: integer;				{loop variable}
   lab1,lab2,lab3,lab4: integer; 	{label numbers}
   num: integer; 			{constant to compare to}
   nop: icptr;				{new opcode}


   procedure Switch;

   { switch the operands 					}

   var
      nd: icptr; 			{used to switch nodes}
      t: integer;			{used to switch string lengths}

   begin {Switch}
   nd := op^.left;
   op^.left := op^.right;
   op^.right := nd;
   if op^.optype = cgString then begin
      t := op^.r;
      op^.r := op^.q;
      op^.q := t;
      end; {if}
   end; {Switch}

begin {GenCmp}
{To reduct the number of possibilities that must be handled, pc_les  }
{and pc_leq compares are reduced to their equivalent pc_grt and	     }
{pc_geq instructions.						     }
if op^.opcode = pc_les then begin
   Switch;
   op^.opcode := pc_grt;
   end {if}
else if op^.opcode = pc_leq then begin
   Switch;
   op^.opcode := pc_geq;
   end; {else if}

{To take advantage of shortcuts, switch operands if generating	  }
{for a tjp or fjp with a constant left operand.			  }
if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin
   if op^.left^.opcode = pc_ldc then begin
      if rOpcode in [pc_tjp,pc_fjp] then begin
	 if op^.opcode = pc_geq then
	    op^.opcode := pc_grt
	 else
	    op^.opcode := pc_geq;
	 if rOpcode = pc_tjp then
	    rOpcode := pc_fjp
	 else
	    rOpcode := pc_tjp;
	 Switch;
	 end; {if}
      end; {if}

   {If constant operands are involved, change > to >=		}
   if op^.opcode = pc_grt then begin
      if op^.left^.opcode = pc_ldc then begin
         if (op^.left^.q > 0) or
            ((op^.optype in [cgWord, cgByte]) and (op^.left^.q > -maxint)) then
            begin
            nop := pointer(malloc(sizeof(intermediate_code)));
            nop^ := op^.left^;
            op^.left := nop;
            nop^.q := nop^.q - 1;
            op^.opcode := pc_geq;
            end; {if}
         end {if}
      else if op^.right^.opcode = pc_ldc then
         if op^.right^.q < maxint then begin
            nop := pointer(malloc(sizeof(intermediate_code)));
            nop^ := op^.right^;                              
            op^.right := nop;
            nop^.q := nop^.q + 1;
            op^.opcode := pc_geq;
            end; {if}
      end; {if}
   end; {if}

{Short cuts are available for single-word operands where the	  }
{right operand is a constant.					  }
if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
   (op^.right^.opcode = pc_ldc) then begin
   GenTree(op^.left);
   num := op^.right^.q;
   lab1 := GenLabel;
   if rOpcode = pc_fjp then begin
      if op^.optype in [cgByte,cgWord] then begin
         if NeedsCondition(op^.left^.opcode) then
            GenImplied(m_tax);
	 if (num >= 0) and (num < 4) then begin
	    if op^.opcode = pc_geq then begin
	       if num <> 0 then begin
		  lab2 := GenLabel;
		  GenNative(m_bmi, relative, lab2, nil, 0);
		  for i := 1 to num do
		     GenImplied(m_dea);
		  end; {if}
	       GenNative(m_bpl, relative, lab1, nil, 0);
	       if num <> 0 then
		  GenLab(lab2);
	       GenNative(m_brl, longrelative, lb, nil, 0);
	       GenLab(lab1);
	       end {if}
	    else {if opcode = pc_grt then} begin
	       lab2 := GenLabel;
	       GenNative(m_bmi, relative, lab2, nil, 0);
	       for i := 0 to num do
		  GenImplied(m_dea);
	       GenNative(m_bpl, relative, lab1, nil, 0);
	       GenLab(lab2);
	       GenNative(m_brl, longrelative, lb, nil, 0);
	       GenLab(lab1);
	       end; {else if}
	    end {if (num >= 0) and (num < 4)}
	 else begin
	    lab2 := GenLabel;
	    if num > 0 then
	       GenNative(m_bmi, relative, lab1, nil, 0)
	    else
	       GenNative(m_bpl, relative, lab1, nil, 0);
	    GenNative(m_cmp_imm, immediate, num, nil, 0);
	    if op^.opcode = pc_grt then begin
	       lab3 := GenLabel;
	       GenNative(m_beq, relative, lab3, nil, 0);
	       GenNative(m_bcs, relative, lab2, nil, 0);
	       GenLab(lab3);
	       end
	    else
	       GenNative(m_bcs, relative, lab2, nil, 0);
	    if num > 0 then begin
	       GenLab(lab1);
	       GenNative(m_brl, longrelative, lb, nil, 0);
	       end {if}
	    else begin
	       GenNative(m_brl, longrelative, lb, nil, 0);
	       GenLab(lab1);
	       end; {else}
	    GenLab(lab2);
	    end; {else if}
	 end {if}
      else {if optype in [cgUByte,cgUWord] then} begin
	 GenNative(m_cmp_imm, immediate, num, nil, 0);
	 if op^.opcode = pc_grt then begin
	    lab2 := GenLabel;
	    GenNative(m_beq, relative, lab2, nil, 0);
	    end; {if}
	 GenNative(m_bcs, relative, lab1, nil, 0);
	 if op^.opcode = pc_grt then
	    GenLab(lab2);
	 GenNative(m_brl, longrelative, lb, nil, 0);
	 GenLab(lab1);
	 end; {else}
      end {if rOpcode = pc_fjp}
   else if rOpcode = pc_tjp then begin
      if op^.optype in [cgByte,cgWord] then begin
         if NeedsCondition(op^.left^.opcode) then
            GenImplied(m_tax);
	 if (num >= 0) and (num < 4) then begin
	    lab2 := GenLabel;
	    if op^.opcode = pc_geq then begin
	       GenNative(m_bmi, relative, lab1, nil, 0);
	       if num > 0 then begin
		  for i := 1 to num do
		  GenImplied(m_dea);
		  GenNative(m_bmi, relative, lab2, nil, 0);
		  end; {if}
	       GenNative(m_brl, longrelative, lb, nil, 0);
	       end {if}
	    else {if op^.opcode = pc_grt then} begin
	       if num > 0 then begin
		  GenNative(m_bmi, relative, lab1, nil, 0);
		  for i := 0 to num do
		     GenImplied(m_dea);
		  GenNative(m_bmi, relative, lab2, nil, 0);
		  end {if}
	       else begin
		  GenNative(m_beq, relative, lab1, nil, 0);
		  GenNative(m_bmi, relative, lab2, nil, 0);
		  end; {else}
	       GenNative(m_brl, longrelative, lb, nil, 0);
	       end; {else}
	    GenLab(lab2);
	    GenLab(lab1);
	    end {if (num >= 0) and (num < 4)}
	 else begin
	    lab2 := GenLabel;
	    if num > 0 then
	       GenNative(m_bmi, relative, lab1, nil, 0)
	    else
	       GenNative(m_bpl, relative, lab1, nil, 0);
	    GenNative(m_cmp_imm, immediate, num, nil, 0);
	    if op^.opcode = pc_grt then begin
	       lab3 := GenLabel;
	       GenNative(m_beq, relative, lab3, nil, 0);
	       end; {if}
	    GenNative(m_bcc, relative, lab2, nil, 0);
	    if num > 0 then begin
	       GenNative(m_brl, longrelative, lb, nil, 0);
	       GenLab(lab2);
	       GenLab(lab1);
	       end {if}
	    else begin
	       GenLab(lab1);
	       GenNative(m_brl, longrelative, lb, nil, 0);
	       GenLab(lab2);
	       end; {else}
	    if op^.opcode = pc_grt then
	       GenLab(lab3);
	    end; {else}
	 end {if}
      else {if optype in [cgUByte,cgUWord] then} begin
	 GenNative(m_cmp_imm, immediate, num, nil, 0);
	 GenNative(m_bcc, relative, lab1, nil, 0);
	 if op^.opcode = pc_grt then begin
	    lab2 := GenLabel;
	    GenNative(m_beq, relative, lab1, nil, 0);
	    end; {if}
	 GenNative(m_brl, longrelative, lb, nil, 0);
	 if op^.opcode = pc_grt then
	    GenLab(lab2);
	 GenLab(lab1);
	 end; {else}
      end {if rOpcode = pc_tjp}
   else if op^.optype in [cgByte,cgWord] then begin
      lab2 := GenLabel;
      GenNative(m_ldx_imm, immediate, 1, nil, 0);
      GenImplied(m_sec);
      GenNative(m_sbc_imm, immediate, num, nil, 0);
      if op^.opcode = pc_grt then begin
	 lab3 := GenLabel;
	 GenNative(m_beq, relative, lab3, nil, 0);
	 end; {if}
      GenNative(m_bvs, relative, lab1, nil, 0);
      GenNative(m_eor_imm, immediate, $8000, nil, 0);
      GenLab(lab1);
      GenNative(m_bmi, relative, lab2, nil, 0);
      if op^.opcode = pc_grt then
	 GenLab(lab3);
      GenImplied(m_dex);
      GenLab(lab2);
      GenImplied(m_txa);
      end {else if}
   else begin
      GenNative(m_ldx_imm, immediate, 0, nil, 0);
      GenNative(m_cmp_imm, immediate, num, nil, 0);
      GenNative(m_bcc, relative, lab1, nil, 0);
      if op^.opcode = pc_grt then
	 GenNative(m_beq, relative, lab1, nil, 0);
      GenImplied(m_inx);
      GenLab(lab1);
      GenImplied(m_txa);
      end; {else if}
   end {if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
      (op^.right^.opcode = pc_ldc)}

{This section of code handles the cases where the above short	  }
{cuts cannot be used.						  }
else
   case op^.optype of

      cgByte,cgUByte,cgWord,cgUWord: begin
	 if Complex(op^.right) then begin
	    GenTree(op^.right);
	    if Complex(op^.left) then begin
	       GenImplied(m_pha);
	       GenTree(op^.left);
	       GenImplied(m_ply);
	       GenNative(m_sty_dir, direct, dworkLoc, nil, 0);
	       end {if}
	    else begin
	       GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
	       GenTree(op^.left);
	       end; {else}
	    if not (rOpcode in [pc_fjp,pc_tjp]) then
	       GenNative(m_ldx_imm, immediate, 1, nil, 0);
	    if op^.optype in [cgByte,cgWord] then begin
	       GenImplied(m_sec);
	       GenNative(m_sbc_dir, direct, dworkLoc, nil, 0);
	       end {if}
	    else
	       GenNative(m_cmp_dir, direct, dworkLoc, nil, 0);
	    end {if}
	 else begin
	    GenTree(op^.left);
	    if not (rOpcode in [pc_fjp,pc_tjp]) then
	       GenNative(m_ldx_imm, immediate, 1, nil, 0);
	    if op^.optype in [cgByte,cgWord] then begin
	       GenImplied(m_sec);
	       OperA(m_sbc_imm, op^.right);
	       end {if}
	    else
	       OperA(m_cmp_imm, op^.right);
	    end; {else}
	 if rOpcode = pc_fjp then begin
	    lab2 := GenLabel;
	    if op^.opcode = pc_grt then begin
	       lab3 := GenLabel;
	       GenNative(m_beq, relative, lab3, nil, 0);
	       end; {if}
	    if op^.optype in [cgByte,cgWord] then begin
	       lab1 := GenLabel;
	       GenNative(m_bvs, relative, lab1, nil, 0);
	       GenNative(m_eor_imm, immediate, $8000, nil, 0);
	       GenLab(lab1);
	       GenNative(m_bmi, relative, lab2, nil, 0);
	       end {if}
	    else
	       GenNative(m_bcs, relative, lab2, nil, 0);
	    if op^.opcode = pc_grt then
	       GenLab(lab3);
	    GenNative(m_brl, longrelative, lb, nil, 0);
	    GenLab(lab2);
	    end {if}
	 else if rOpcode = pc_tjp then begin
	    lab2 := GenLabel;
	    if op^.opcode = pc_grt then begin
	       lab3 := GenLabel;
	       GenNative(m_beq, relative, lab3, nil, 0);
	       end; {if}
	    if op^.optype in [cgByte,cgWord] then begin
	       lab1 := GenLabel;
	       GenNative(m_bvs, relative, lab1, nil, 0);
	       GenNative(m_eor_imm, immediate, $8000, nil, 0);
	       GenLab(lab1);
	       GenNative(m_bpl, relative, lab2, nil, 0);
	       end {if}
	    else
	       GenNative(m_bcc, relative, lab2, nil, 0);
	    GenNative(m_brl, longrelative, lb, nil, 0);
	    if op^.opcode = pc_grt then
	       GenLab(lab3);
	    GenLab(lab2);
	    end {else if}
	 else begin
	    lab2 := GenLabel;
	    if op^.opcode = pc_grt then begin
	       lab3 := GenLabel;
	       GenNative(m_beq, relative, lab3, nil, 0);
	       end; {if}
	    if op^.optype in [cgByte,cgWord] then begin
	       lab1 := GenLabel;
	       GenNative(m_bvs, relative, lab1, nil, 0);
	       GenNative(m_eor_imm, immediate, $8000, nil, 0);
	       GenLab(lab1);
	       GenNative(m_bmi, relative, lab2, nil, 0);
	       end {if}
	    else
	       GenNative(m_bcs, relative, lab2, nil, 0);
	    if op^.opcode = pc_grt then
	       GenLab(lab3);
	    GenImplied(m_dex);
	    GenLab(lab2);
	    GenImplied(m_txa);
	    end; {else}
	 end; {case optype of cgByte,cgUByte,cgWord,cgUWord}

      cgULong: begin
	 gLong.preference := onStack;
	 GenTree(op^.right);
	 gLong.preference := A_X;
	 GenTree(op^.left);
	 if gLong.where = onStack then begin
	    GenImplied(m_ply);
	    GenImplied(m_pla);
	    end {if}
	 else begin
	    GenImplied(m_tay);
	    GenImplied(m_txa);
	    end; {else}
	 lab1 := GenLabel;
	 GenNative(m_ldx_imm, immediate, 1, nil, 0);
	 GenNative(m_cmp_s, direct, 3, nil, 0);
	 GenNative(m_bne, relative, lab1, nil, 0);
	 GenImplied(m_tya);
	 GenNative(m_cmp_s, direct, 1, nil, 0);
	 GenLab(lab1);
	 lab2 := GenLabel;
	 if op^.opcode = pc_grt then begin
	    lab3 := GenLabel;
	    GenNative(m_beq, relative, lab3, nil, 0);
	    end; {if}
	 GenNative(m_bcs, relative, lab2, nil, 0);
	 if op^.opcode = pc_grt then
	    GenLab(lab3);
	 GenImplied(m_dex);
	 GenLab(lab2);
	 GenImplied(m_pla);
	 GenImplied(m_pla);
	 GenImplied(m_txa);
	 if rOpcode = pc_fjp then begin
	    lab4 := GenLabel;
	    GenNative(m_bne, relative, lab4, nil, 0);
	    GenNative(m_brl, longrelative, lb, nil, 0);
	    GenLab(lab4);
	    end {if}
	 else if rOpcode = pc_tjp then begin
	    lab4 := GenLabel;
	    GenNative(m_beq, relative, lab4, nil, 0);
	    GenNative(m_brl, longrelative, lb, nil, 0);
	    GenLab(lab4);
	    end; {else if}
	 end;

      cgReal,cgDouble,cgComp,cgExtended,cgSet: begin
	 GenTree(op^.left);
	 GenTree(op^.right);
         if op^.opType = cgSet then
            GenCall(74)
	 else {if op^.opType in [cgReal,cgDouble,cgComp,cgExtended] then}
            if op^.opcode = pc_geq then
	       GenCall(71)
	    else
	       GenCall(70);
	 if (rOpcode = pc_fjp) or (rOpcode = pc_tjp) then begin
	    lab1 := GenLabel;
	    if rOpcode = pc_fjp then
	       GenNative(m_bne, relative, lab1, nil, 0)
	    else
	       GenNative(m_beq, relative, lab1, nil, 0);
	    GenNative(m_brl,longrelative,lb,nil,0);
	    GenLab(lab1);
	    end; {if}
	 end; {case optype of cgReal..cgExtended,cgSet}

      cgString: begin
	 gLong.preference := onStack;
	 GenTree(op^.left);
	 if op^.left^.opcode <> pc_csp then begin
	    if op^.r = -1 then begin
	       GenImplied(m_pha);
	       GenImplied(m_pha);
	       end; {if}
	    GenNative(m_pea, immediate, op^.r, nil, 0);
	    end; {if}
	 gLong.preference := onStack;
	 GenTree(op^.right);
	 if op^.right^.opcode <> pc_csp then begin
	    if op^.q = -1 then begin
	       GenImplied(m_pha);
	       GenImplied(m_pha);
	       end; {if}
	    GenNative(m_pea, immediate, op^.q, nil, 0);
	    end; {if}
         if op^.opcode = pc_geq then
	    GenCall(73)
	 else
	    GenCall(72);
	 if (rOpcode = pc_fjp) or (rOpcode = pc_tjp) then begin
	    lab1 := GenLabel;
	    if rOpcode = pc_fjp then
	       GenNative(m_bne, relative, lab1, nil, 0)
	    else
	       GenNative(m_beq, relative, lab1, nil, 0);
	    GenNative(m_brl,longrelative,lb,nil,0);
	    GenLab(lab1);
	    end; {if}
	 end; {case optype of cgString}

      cgLong: begin
	 gLong.preference := onStack;
	 GenTree(op^.left);
	 if op^.opcode = pc_geq then begin
	    gLong.preference := A_X;
	    GenTree(op^.right);
	    if gLong.where = onStack then begin
	       GenImplied(m_pla);
	       GenImplied(m_plx);
	       end; {if}
	    num := 139;
	    end {if}
	 else begin
	    gLong.preference := onStack;
	    GenTree(op^.right);
	    num := 138;
	    end; {else}
	 GenCall(num);
	 if (rOpcode = pc_fjp) or (rOpcode = pc_tjp) then begin
	    lab1 := GenLabel;
	    if rOpcode = pc_fjp then
	       GenNative(m_bne, relative, lab1, nil, 0)
	    else
	       GenNative(m_beq, relative, lab1, nil, 0);
	    GenNative(m_brl, longrelative, lb, nil, 0);
	    GenLab(lab1);
	    end; {if}
	 end; {case optype of cgLong}

      otherwise:
	 Error(cge1);
      end; {case}
end; {GenCmp}


procedure GenCnv (op: icptr);

{ generate a pc_cnv instruction					}

const                                {note: these constants list all legal }
                                     {      conversions; others are ignored}
   cReal             = $06;
   cDouble           = $07;
   cComp             = $08;
   cExtended         = $09;

   byteToWord        = $02;
   byteToUword       = $03;
   byteToLong        = $04;
   byteToUlong       = $05;
   byteToReal        = $06;
   byteToDouble      = $07;
   ubyteToLong       = $14;
   ubyteToUlong      = $15;
   ubyteToReal       = $16;
   ubyteToDouble     = $17;
   wordToByte        = $20;
   wordToUByte       = $21;
   wordToLong        = $24;
   wordToUlong       = $25;
   wordToReal        = $26;
   wordToDouble      = $27;
   uwordToByte       = $30;
   uwordToUByte      = $31;
   uwordToLong       = $34;
   uwordToUlong      = $35;
   uwordToReal       = $36;
   uwordToDouble     = $37;
   longTobyte        = $40;
   longToUbyte       = $41;
   longToWord        = $42;
   longToUword       = $43;
   longToReal        = $46;
   longToDouble      = $47;
   ulongTobyte       = $50;
   ulongToUbyte      = $51;
   ulongToWord       = $52;
   ulongToUword      = $53;
   ulongToReal       = $56;
   ulongToDouble     = $57;
   realTobyte        = $60;
   realToUbyte       = $61;
   realToWord        = $62;
   realToUword       = $63;
   realToLong        = $64;
   realToUlong       = $65;
   doubleTobyte      = $70;
   doubleToUbyte     = $71;
   doubleToWord      = $72;
   doubleToUword     = $73;
   doubleToLong      = $74;
   doubleToUlong     = $75;

var
   fromReal: boolean;			{are we converting from a real?}
   lab1: integer;			{used for branches}
   lLong: longType;			{used to reserve gLong}

begin {GenCnv}
lLong := gLong;
gLong.preference := onStack+A_X+constant;
gLong.where := onStack;
if ((op^.q & $00F0) >> 4) in [cDouble,cExtended,cComp] then begin
   op^.q := (op^.q & $000F) | (cReal * 16);
   fromReal := true;
   end {if}
else
   fromReal := false;
if (op^.q & $000F) in [cDouble,cExtended,cComp] then
   op^.q := (op^.q & $00F0) | cReal;
GenTree(op^.left);
if op^.q in [wordToLong,wordToUlong] then begin
   lab1 := GenLabel;
   GenNative(m_ldx_imm, immediate, 0, nil, 0);
   GenImplied(m_tay);
   GenNative(m_bpl, relative, lab1, nil, 0);
   GenImplied(m_dex);
   GenLab(lab1);
   if (lLong.preference & A_X) <> 0 then
      gLong.where := A_X
   else begin
      gLong.where := onStack;
      GenImplied(m_phx);
      GenImplied(m_pha);
      end; {else}
   end {if}
else if op^.q in [byteToLong,byteToUlong] then begin
   lab1 := GenLabel;
   GenNative(m_ldx_imm, immediate, 0, nil, 0);
   GenNative(m_bit_imm, immediate, $0080, nil, 0);
   GenNative(m_beq, relative, lab1, nil, 0);
   GenImplied(m_dex);
   GenNative(m_ora_imm, immediate, $FF00, nil, 0);
   GenLab(lab1);
   if (lLong.preference & A_X) <> 0 then
      gLong.where := A_X
   else begin
      gLong.where := onStack;
      GenImplied(m_phx);
      GenImplied(m_pha);
      end; {else}
   end {if}
else if op^.q in [byteToWord,byteToUword] then begin
   lab1 := GenLabel;
   GenNative(m_bit_imm, immediate, $0080, nil, 0);
   GenNative(m_beq, relative, lab1, nil, 0);
   GenNative(m_ora_imm, immediate, $FF00, nil, 0);
   GenLab(lab1);
   end {if}
else if op^.q in [ubyteToLong,ubyteToUlong,uwordToLong,uwordToUlong] then
   begin
   if (lLong.preference & A_X) <> 0 then begin
      gLong.where := A_X;
      GenNative(m_ldx_imm, immediate, 0, nil, 0);
      end {if}
   else begin
      gLong.where := onStack;
      GenNative(m_pea, immediate, 0, nil, 0);
      GenImplied(m_pha);
      end; {else}
   end {else if}
else if op^.q in [wordToByte,wordToUbyte,uwordToByte,uwordToUbyte] then
   GenNative(m_and_imm, immediate, $00FF, nil, 0)
else if op^.q in [byteToReal,uByteToReal,wordToReal,uWordToReal] then
   GenCall(36)
else if op^.q in [longToByte,longToUbyte,ulongToByte,ulongToUbyte] then begin
   if gLong.where = A_X then
      GenNative(m_and_imm, immediate, $00FF, nil, 0)
   else if gLong.where = constant then
      GenNative(m_lda_imm, immediate, long(gLong.lval).lsw & $00FF, nil, 0)
   else {if gLong.where = onStack then} begin
      GenImplied(m_pla);
      GenImplied(m_plx);
      GenNative(m_and_imm, immediate, $00FF, nil, 0);
      end; {else if}
   end {else if}
else if op^.q in [longToWord,longToUword,ulongToWord,ulongToUword] then begin
   {Note: if the result is in A_X, no further action is needed}
   if gLong.where = constant then
      GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0)
   else if gLong.where = onStack then begin
      GenImplied(m_pla);
      GenImplied(m_plx);
      end; {else if}
   end {else if}
else if op^.q in [longToReal,uLongToReal] then begin
   if gLong.where = constant then begin
      GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
      GenNative(m_ldx_imm, immediate, long(gLong.lval).msw, nil, 0);
      end {if}
   else if gLong.where = onStack then begin
      GenImplied(m_pla);
      GenImplied(m_plx);
      end; {else if}
   GenCall(166);
   end {else}
else if op^.q in [realToByte,realToUbyte,realToWord,realToUWord] then begin
   GenCall(37);
   if (op^.q & $00FF) in [0,1] then
      GenNative(m_and_imm, immediate, $00FF, nil, 0);
   end {else if}
else if op^.q in [realToLong,realToUlong] then begin
   GenCall(150);
   if (lLong.preference & A_X) <> 0 then
      gLong.where := A_X
   else begin
      gLong.where := onStack;
      GenImplied(m_phx);
      GenImplied(m_pha);
      end; {else}
   end {else if}
else if (lLong.preference & gLong.where = 0)
   and ((op^.q & $000F) <> ord(cgVoid)) then begin
   if gLong.where = constant then begin
      GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0);
      GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0);
      end {if}
   else if gLong.where = A_X then begin
      GenImplied(m_phx);
      GenImplied(m_pha);
      end; {else if}
   gLong.where := onStack;
   end; {else if}
end; {GenCnv}


procedure GenEquNeq (op: icptr; opcode: pcodes; lb: integer);

{ generate a pc_equ or pc_neq instruction			}
{								}
{ parameters:							}
{    op - node to generate the compare for			}
{    opcode - Opcode that will use the result of the compare.	}
{	If the result is used by a tjp or fjp, this procedure	}
{	 generates special code and does the branch internally.	}
{    lb - For fjp, tjp, this is the label to branch to if	}
{	 the condition is satisfied.				}

var
   nd: icptr;				{work node}
   num: integer; 			{constant to compare to}
   lab1,lab2: integer;			{label numbers}
   bne: integer; 			{instruction for a pc_equ bne branch}
   beq: integer; 			{instruction for a pc_equ beq branch}
   lLong: longType;			{local long value information}
   leftOp,rightOp: pcodes;		{opcode codes to left, right}


   procedure DoOr (op: icptr);

   { or the two halves of a four byte value			}
   {								}
   { parameters: 						}
   {	operand to or						}

   var
      disp: integer;			{disp of value on stack frame}

   begin {DoOr}
   with op^ do begin
      if opcode = pc_ldo then begin
	 GenNative(m_lda_abs, absolute, q, lab, 0);
	 GenNative(m_ora_abs, absolute, q+2, lab, 0);
	 end {if}
      else begin
	 disp := localLabel[r] + q;
	 if disp < 254 then begin
	    GenNative(m_lda_dir, direct, disp, nil, 0);
	    GenNative(m_ora_dir, direct, disp+2, nil, 0);
	    end {else if}
	 else begin
	    GenNative(m_ldx_imm, immediate, disp, nil, 0);
	    GenNative(m_lda_dirX, direct, 0, nil, 0);
	    GenNative(m_ora_dirX, direct, 2, nil, 0);
	    end; {else}
	 end; {else}
      end; {with}
   end; {DoOr}


   procedure DoCmp (op: icPtr);

   { compare a long value in A_X to a local or global scalar	}
   {								}
   { parameters: 						}
   {	op - value to compare to 				}

   var
      disp: integer;			{disp of value on stack frame}
      lab1: integer;			{label numbers}

   begin {DoCmp}
   lab1 := GenLabel;
   with op^ do begin
      if opcode = pc_ldo then begin
	 GenNative(m_cmp_abs, absolute, q, lab, 0);
	 GenNative(m_bne, relative, lab1, nil, 0);
	 GenNative(m_cpx_abs, absolute, q+2, lab, 0);
	 end {if}
      else begin
	 disp := localLabel[r] + q;
	 if disp < 254 then begin
	    GenNative(m_cmp_dir, direct, disp, nil, 0);
	    GenNative(m_bne, relative, lab1, nil, 0);
	    GenNative(m_cpx_dir, direct, disp+2, nil, 0);
	    end {if}
	 else begin
	    GenImplied(m_txy);
	    GenNative(m_ldx_imm, immediate, disp, nil, 0);
	    GenNative(m_cmp_dirX, direct, 0, nil, 0);
	    GenNative(m_bne, relative, lab1, nil, 0);
	    GenImplied(m_tya);
	    GenNative(m_cmp_dirX, direct, 2, nil, 0);
	    end; {else}
	 end; {else}
      GenLab(lab1);
      end; {with}
   end; {DoCmp}


begin {GenEquNeq}
if op^.opcode = pc_equ then begin
   bne := m_bne;
   beq := m_beq;
   end {if}
else begin
   bne := m_beq;
   beq := m_bne;
   end; {else}
if op^.optype <> cgString then begin
   if op^.left^.opcode in [pc_lod,pc_ldo] then begin
      nd := op^.left;
      op^.left := op^.right;
      op^.right := nd;
      end; {if}
   if op^.left^.opcode = pc_ldc then begin
      nd := op^.left;
      op^.left := op^.right;
      op^.right := nd;
      end; {if}
   end; {if}
leftOp := op^.left^.opcode;		{set op codes for fast access}
rightOp := op^.right^.opcode;
if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
   (rightOp = pc_ldc) then begin
   GenTree(op^.left);
   num := op^.right^.q;
   lab1 := GenLabel;
   if opcode in [pc_fjp,pc_tjp] then begin
      if num <> 0 then
	 GenNative(m_cmp_imm, immediate, num, nil, 0)
      else if NeedsCondition(leftOp) then
	 GenImplied(m_tay);
      if opcode = pc_fjp then
	 GenNative(beq, relative, lab1, nil, 0)
      else
	 GenNative(bne, relative, lab1, nil, 0);
      GenNative(m_brl, longrelative, lb, nil, 0);
      GenLab(lab1);
      end {if}
   else begin
      GenNative(m_ldx_imm, immediate, 0, nil, 0);
      GenNative(m_cmp_imm, immediate, num, nil, 0);
      GenNative(bne, relative, lab1, nil, 0);
      GenImplied(m_inx);
      GenLab(lab1);
      GenImplied(m_txa);
      end; {else}
   end {if}
else if (op^.optype in [cgLong,cgULong])
   and ((leftOp = pc_ldo) or ((leftOp = pc_lod) and (op^.left^.p = 0)))
   and (rightOp = pc_ldc) and (op^.right^.lval = 0) then begin
   if opcode in [pc_fjp,pc_tjp] then begin
      DoOr(op^.left);
      lab1 := GenLabel;
      if opcode = pc_fjp then
	 GenNative(beq, relative, lab1, nil, 0)
      else
	 GenNative(bne, relative, lab1, nil, 0);
      GenNative(m_brl, longrelative, lb, nil, 0);
      GenLab(lab1);
      end {if}
   else if op^.opcode = pc_equ then begin
      lab1 := GenLabel;
      lab2 := GenLabel;
      DoOr(op^.left);
      GenNative(bne, relative, lab1, nil, 0);
      GenNative(m_lda_imm, immediate, 1, nil, 0);
      GenNative(m_bra, relative, lab2, nil, 0);
      GenLab(lab1);
      GenNative(m_lda_imm, immediate, 0, nil, 0);
      GenLab(lab2);
      end {else if}
   else {if op^.opcode = pc_neq then} begin
      lab1 := GenLabel;
      DoOr(op^.left);
      GenNative(m_beq, relative, lab1, nil, 0);
      GenNative(m_lda_imm, immediate, 1, nil, 0);
      GenLab(lab1);
      end; {else if}
   end {else if}
else if (op^.optype in [cgLong,cgULong])
   and ((rightOp = pc_ldo) or ((rightOp = pc_lod) and (op^.right^.p = 0)))
   then begin
   gLong.preference := A_X;
   GenTree(op^.left);
   if gLong.where = onStack then begin
      GenImplied(m_pla);
      GenImplied(m_plx);
      end; {if}
   if opcode in [pc_fjp,pc_tjp] then begin
      DoCmp(op^.right);
      lab1 := GenLabel;
      if opcode = pc_fjp then
	 GenNative(beq, relative, lab1, nil, 0)
      else
	 GenNative(bne, relative, lab1, nil, 0);
      GenNative(m_brl, longrelative, lb, nil, 0);
      GenLab(lab1);
      end {if}
   else begin
      lab1 := GenLabel;
      lab2 := GenLabel;
      DoCmp(op^.right);
      GenNative(bne, relative, lab1, nil, 0);
      GenNative(m_lda_imm, immediate, 1, nil, 0);
      GenNative(m_bra, relative, lab2, nil, 0);
      GenLab(lab1);
      GenNative(m_lda_imm, immediate, 0, nil, 0);
      GenLab(lab2);
      end; {else}
   end {else if}
else
   case op^.optype of

      cgByte,cgUByte,cgWord,cgUWord: begin
	 if not Complex(op^.left) then
	    if Complex(op^.right) then begin
	       nd := op^.left;
	       op^.left := op^.right;
	       op^.right := nd;
	       end; {if}
	 GenTree(op^.left);
	 if Complex(op^.right) or (not (opcode in [pc_fjp,pc_tjp])) then begin
	    GenImplied(m_pha);
	    GenTree(op^.right);
	    GenImplied(m_sec);
	    GenNative(m_sbc_s, direct, 1, nil, 0);
	    GenImplied(m_plx);
	    GenImplied(m_tax);
	    if opcode in [pc_fjp,pc_tjp] then begin
	       lab1 := GenLabel;
	       if opcode = pc_fjp then
		  GenNative(beq, relative, lab1, nil, 0)
	       else
		  GenNative(bne, relative, lab1, nil, 0);
	       GenNative(m_brl, longrelative, lb, nil, 0);
	       GenLab(lab1);
	       end {if}
	    else begin
	       lab1 := GenLabel;
	       GenNative(m_beq, relative, lab1, nil, 0);
	       GenNative(m_lda_imm, immediate, 1, nil, 0);
	       GenLab(lab1);
	       if op^.opcode = pc_equ then
		  GenNative(m_eor_imm, immediate, 1, nil, 0);
	       end; {else}
	    end {if}
	 else begin
	    OperA(m_cmp_imm, op^.right);
	    lab1 := GenLabel;
	    if opcode = pc_fjp then
	       GenNative(beq, relative, lab1, nil, 0)
	    else
	       GenNative(bne, relative, lab1, nil, 0);
	    GenNative(m_brl, longrelative, lb, nil, 0);
	    GenLab(lab1);
	    end; {else}
	 end; {case optype of cgByte,cgUByte,cgWord,cgUWord}

      cgLong,cgULong: begin
	 gLong.preference := onStack;
	 GenTree(op^.left);
	 lLong := gLong;
	 gLong.preference := A_X;
	 GenTree(op^.right);
	 if gLong.where = onStack then begin
	    GenImplied(m_pla);
	    GenImplied(m_plx);
	    end; {if}
	 GenNative(m_ldy_imm, immediate, 1, nil, 0);
	 GenNative(m_cmp_s, direct, 1, nil, 0);
	 lab1 := GenLabel;
	 GenNative(m_beq, relative, lab1, nil, 0);
	 GenImplied(m_dey);
	 GenLab(lab1);
	 GenImplied(m_txa);
	 GenNative(m_cmp_s, direct, 3, nil, 0);
	 lab1 := GenLabel;
	 GenNative(m_beq, relative, lab1, nil, 0);
	 GenNative(m_ldy_imm, immediate, 0, nil, 0);
	 GenLab(lab1);
	 GenImplied(m_pla);
	 GenImplied(m_pla);
	 GenImplied(m_tya);
	 if opcode in [pc_fjp,pc_tjp] then begin
	    lab1 := GenLabel;
	    if opcode = pc_fjp then
	       GenNative(bne, relative, lab1, nil, 0)
	    else
	       GenNative(beq, relative, lab1, nil, 0);
	    GenNative(m_brl, longrelative, lb, nil, 0);
	    GenLab(lab1);
	    end {if}
	 else if op^.opcode = pc_neq then
	    GenNative(m_eor_imm, immediate, 1, nil, 0);
	 end; {case optype of cgLong,cgULong}

      cgReal,cgDouble,cgComp,cgExtended,cgSet: begin
         gLong.preference := onStack;
	 GenTree(op^.left);
         gLong.preference := onStack;
	 GenTree(op^.right);         
         if op^.optype = cgSet then
	    GenCall(30)
         else
	    GenCall(31);
	 if opcode in [pc_fjp,pc_tjp] then begin
	    lab1 := GenLabel;
	    if opcode = pc_fjp then
	       GenNative(bne, relative, lab1, nil, 0)
	    else
	       GenNative(beq, relative, lab1, nil, 0);
	    GenNative(m_brl, longrelative, lb, nil, 0);
	    GenLab(lab1);
	    end {if}
	 else if op^.opcode = pc_neq then
	    GenNative(m_eor_imm, immediate, 1, nil, 0);
	 end; {case optype of cgReal..cgExtended, cgSet}

      cgString: begin
         gLong.preference := onStack;
	 GenTree(op^.left);
         if op^.left^.opcode <> pc_csp then begin
            if op^.r = -1 then begin
               GenImplied(m_pha);
               GenImplied(m_pha);
               end; {if}
            GenNative(m_pea, immediate, op^.r, nil, 0);
            end; {if}
         gLong.preference := onStack;
	 GenTree(op^.right);
         if op^.right^.opcode <> pc_csp then begin
            if op^.q = -1 then begin
               GenImplied(m_pha);
               GenImplied(m_pha);
               end; {if}
            GenNative(m_pea, immediate, op^.q, nil, 0);
            end; {if}
	 GenCall(69);
	 if opcode in [pc_fjp,pc_tjp] then begin
	    lab1 := GenLabel;
	    if opcode = pc_fjp then
	       GenNative(bne, relative, lab1, nil, 0)
	    else
	       GenNative(beq, relative, lab1, nil, 0);
	    GenNative(m_brl, longrelative, lb, nil, 0);
	    GenLab(lab1);
	    end {if}
	 else if op^.opcode = pc_neq then
	    GenNative(m_eor_imm, immediate, 1, nil, 0);
	 end; {case optype of cgString}

      otherwise:
	 Error(cge1);
      end; {case}
end; {GenEquNeq}


procedure GenIncDec (op, save: icptr);

{ generate code for pc_inc, pc_dec				}
{								}
{ parameters:							}
{    op - pc_inc or pc_dec operation				}
{    save - save location (pc_str or pc_sro) or nil		}

var
   disp: integer;			{disp in stack frame}
   lab1: integer;			{branch point}
   opcode: pcodes;			{temp storage for op code}
   short: boolean;			{doing a one-byte save?}
   size: integer;			{number to increment by}
   clc,ina,adc: integer; 		{instructions to generate}

begin {GenIncDec}
{set up local variables}
opcode := op^.opcode;
size := op^.q;

if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin
   if SameLoc(op^.left, save) and (save^.p = 0) and (size = 1) then begin
      if opcode = pc_inc then
	 DoOp(0, m_inc_abs, m_inc_dir, op^.left, 0)
      else {if opcode = pc_dec then}
	 DoOp(0, m_dec_abs, m_dec_dir, op^.left, 0);
      end {if}
   else begin
      GenTree(op^.left);
      if opcode = pc_inc then begin
	 clc := m_clc;
	 ina := m_ina;
	 adc := m_adc_imm;
	 end {if}
      else begin
	 clc := m_sec;
	 ina := m_dea;
	 adc := m_sbc_imm;
	 end; {else}
      if size = 1 then
	 GenImplied(ina)
      else if size = 2 then begin
	 GenImplied(ina);
	 GenImplied(ina);
	 end {else if}
      else if size <> 0 then begin
	 GenImplied(clc);
	 GenNative(adc, immediate, size, nil, 0);
	 if rangeCheck then
	    GenCall(147);
	 end; {else if}
      if save <> nil then begin
         short := save^.optype in [cgByte,cgUByte];
	 if save^.opcode = pc_str then begin
	    disp := localLabel[save^.r] + save^.q;
            if save^.p <> 0 then begin
	       StaticLink(save^.p, true, false);
               if short then
	          GenNative(m_sep, immediate, 32, nil, 0);
	       GenNative(m_sta_longX, longAbsolute, disp, nil, 0);
               end {if}
	    else if disp < 254 then begin
               if short then
	          GenNative(m_sep, immediate, 32, nil, 0);
	       GenNative(m_sta_dir, direct, disp, nil, 0);
               end {else if}
	    else begin
               if short then
	          GenNative(m_sep, immediate, 32, nil, 0);
	       GenNative(m_ldx_imm, immediate, disp, nil, 0);
	       GenNative(m_sta_dirX, direct, 0, nil, 0);
	       end; {else}
	    end {else if}
	 else {if save^.opcode = pc_sro then} begin
            if short then
	       GenNative(m_sep, immediate, 32, nil, 0);
	    if smallMemoryModel then
	       GenNative(m_sta_abs, absolute, save^.q, save^.lab, 0)
	    else
	       GenNative(m_sta_long, longabsolute, save^.q, save^.lab, 0);
	    end; {else}
         if short then
	    GenNative(m_rep, immediate, 32, nil, 0);
         end; {if}
      end {else}
   end {if}
else if op^.optype in [cgLong,cgULong] then begin
   if SameLoc(op^.left, save) and (save^.p = 0) then begin
      lab1 := GenLabel;
      if size = 1 then begin
	 if opcode = pc_inc then begin
	    DoOp(0, m_inc_abs, m_inc_dir, op^.left, 0);
	    GenNative(m_bne, relative, lab1, nil, 0);
	    DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2);
	    GenLab(lab1);
	    end {if}
	 else {if opcode = pc_dec then} begin
	    DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
	    GenNative(m_bne, relative, lab1, nil, 0);
	    DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2);
	    GenLab(lab1);
	    DoOp(0, m_dec_abs, m_dec_dir, op^.left, 0);
	    end; {else}
	 end {if}
      else if opcode = pc_inc then begin
	 GenImplied(m_clc);
	 DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
	 GenNative(m_adc_imm, immediate, size, nil, 0);
	 DoOp(0, m_sta_abs, m_sta_dir, op^.left, 0);
	 GenNative(m_bcc, relative, lab1, nil, 0);
	 DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2);
	 GenLab(lab1);
	 end {else if}
      else begin
	 GenImplied(m_sec);
	 DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
	 GenNative(m_sbc_imm, immediate, size, nil, 0);
	 DoOp(0, m_sta_abs, m_sta_dir, op^.left, 0);
	 GenNative(m_bcs, relative, lab1, nil, 0);
	 DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2);
	 GenLab(lab1);
	 end; {else}
      end {if}
   else begin
      if save <> nil then
	 gLong.preference := A_X
      else
	 gLong.preference := gLong.preference & (A_X | inpointer);
      if opcode = pc_dec then
	 gLong.preference := gLong.preference & A_X;
      GenTree(op^.left);
      if opcode = pc_inc then
	 IncAddr(size)
      else begin
	 lab1 := GenLabel;
	 if gLong.where = A_X then begin
	    GenImplied(m_sec);
	    GenNative(m_sbc_imm, immediate, size, nil, 0);
	    GenNative(m_bcs, relative, lab1, nil, 0);
	    GenImplied(m_dex);
	    end {if}
	 else begin
	    GenImplied(m_sec);
	    GenNative(m_lda_s, direct, 1, nil, 0);
	    GenNative(m_sbc_imm, immediate, size, nil, 0);
	    GenNative(m_sta_s, direct, 1, nil, 0);
	    GenNative(m_bcs, relative, lab1, nil, 0);
	    GenNative(m_lda_s, direct, 3, nil, 0);
	    GenImplied(m_dea);
	    GenNative(m_sta_s, direct, 3, nil, 0);
	    end; {else}
	 GenLab(lab1);
	 end; {else}
      if save <> nil then
	 if save^.opcode = pc_str then begin
	    disp := localLabel[save^.r] + save^.q;
            if save^.p <> 0 then begin
	       if gLong.where = A_X then begin
                  GenImplied(m_phx);
                  GenImplied(m_pha);
                  end; {if}
	       StaticLink(save^.p, false, false);
	       GenImplied(m_pla);
	       GenNative(m_sta_longX, longAbsolute, disp, nil, 0);
	       GenImplied(m_pla);
	       GenNative(m_sta_longX, longAbsolute, disp+2, nil, 0);
               end {if}
	    else if disp < 254 then begin
	       if gLong.where = onStack then
		  GenImplied(m_pla);
	       GenNative(m_sta_dir, direct, disp, nil, 0);
	       if gLong.where = onStack then
		  GenImplied(m_plx);
	       GenNative(m_stx_dir, direct, disp+2, nil, 0);
	       end {else if}
	    else begin
	       if gLong.where = A_X then
		  GenImplied(m_txy);
	       GenNative(m_ldx_imm, immediate, disp, nil, 0);
	       if gLong.where = onStack then
		  GenImplied(m_pla);
	       GenNative(m_sta_dirX, direct, 0, nil, 0);
	       if gLong.where = onStack then
		  GenImplied(m_pla)
	       else
		  GenImplied(m_tya);
	       GenNative(m_sta_dirX, direct, 2, nil, 0);
	       end; {else}
	    end {else if}
	 else {if save^.opcode = pc_sro then} begin
	    if gLong.where = onStack then
	       GenImplied(m_pla);
	    if smallMemoryModel then
	       GenNative(m_sta_abs, absolute, save^.q, save^.lab, 0)
	    else
	       GenNative(m_sta_long, longabsolute, save^.q, save^.lab, 0);
	    if smallMemoryModel then begin
	       if gLong.where = onStack then
		  GenImplied(m_plx);
	       GenNative(m_stx_abs, absolute, save^.q+2, save^.lab, 0)
	       end {if}
	    else begin
	       if gLong.where = onStack then
		  GenImplied(m_pla)
	       else
		  GenImplied(m_txa);
	       GenNative(m_sta_long, longabsolute, save^.q+2, save^.lab, 0);
	       end; {else}
	    end; {else}
      end; {else}
   end; {else if}
end; {GenIncDec}


procedure GenInd (op: icptr);

{ Generate code for a pc_ind					}

var
   lab1: integer;			{label}
   lLong: longType;			{requested address type}
   optype: baseTypeEnum; 		{op^.optype}
   q: integer;				{op^.q}

begin {GenInd}
optype := op^.optype;
q := op^.q;
case optype of
   cgReal,cgDouble,cgComp,cgExtended: begin
      gLong.preference := onStack;
      GenTree(op^.left);
      if q <> 0 then
	 IncAddr(q);
      if optype = cgReal then
	 GenCall(25)
      else if optype = cgDouble then
	 GenCall(18)
      else if optype = cgComp then
	 GenCall(163)
      else if optype = cgExtended then
	 GenCall(164);
      end; {case cgReal,cgDouble,cgComp,cgExtended}

   cgLong,cgULong: begin
      lLong := gLong;
      GetPointer(op^.left);
      if gLong.where = inPointer then begin
	 if q = 0 then begin
	    if gLong.fixedDisp then begin
	       GenNative(m_ldy_imm, immediate, 2, nil, 0);
	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
	       if (A_X & lLong.preference) <> 0 then
		  GenImplied(m_tax)
	       else
		  GenImplied(m_pha);
	       GenNative(m_lda_indl, direct, gLong.disp, nil, 0);
	       end {if}
	    else begin
	       GenImplied(m_iny);
	       GenImplied(m_iny);
	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
	       if (A_X & lLong.preference) <> 0 then
		  GenImplied(m_tax)
	       else
		  GenImplied(m_pha);
	       GenImplied(m_dey);
	       GenImplied(m_dey);
	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
	       end; {else}
	    if (A_X & lLong.preference) = 0 then
	       GenImplied(m_pha);
	    end {if q = 0}
	 else begin
	    if gLong.fixedDisp then begin
	       GenNative(m_ldy_imm, immediate, q+2, nil, 0);
	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
	       if (A_X & lLong.preference) <> 0 then
		  GenImplied(m_tax)
	       else
		  GenImplied(m_pha);
	       GenNative(m_ldy_imm, immediate, q, nil, 0);
	       end {if}
	    else begin
	       GenImplied(m_tya);
	       GenImplied(m_clc);
	       GenNative(m_adc_imm, immediate, q+2, nil, 0);
	       GenImplied(m_tay);
	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
	       if (A_X & lLong.preference) <> 0 then
		  GenImplied(m_tax)
	       else
		  GenImplied(m_pha);
	       GenImplied(m_dey);
	       GenImplied(m_dey);
	       end; {else}
	    GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
	    if (A_X & lLong.preference) = 0 then
	       GenImplied(m_pha);
	    end; {else}
	 end {if glong.where = inPointer}
      else if gLong.where = localAddress then begin
	 gLong.disp := gLong.disp+q;
	 if gLong.fixedDisp then
	    if (gLong.disp < 254) and (gLong.disp >= 0) then begin
	       GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
	       GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
	       end {if}
	    else begin
	       GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
	       GenNative(m_lda_dirX, direct, 0, nil, 0);
	       GenNative(m_ldy_dirX, direct, 2, nil, 0);
	       GenImplied(m_tyx);
	       end {else}
	 else begin
	    if (gLong.disp >= 254) or (gLong.disp < 0) then begin
	       GenImplied(m_txa);
	       GenImplied(m_clc);
	       GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
	       GenImplied(m_tax);
	       gLong.disp := 0;
	       end; {if}
	    GenNative(m_ldy_dirX, direct, gLong.disp+2, nil, 0);
	    GenNative(m_lda_dirX, direct, gLong.disp, nil, 0);
	    GenImplied(m_tyx);
	    end; {else}
	 if (A_X & lLong.preference) = 0 then begin
	    GenImplied(m_phx);
	    GenImplied(m_pha);
	    end; {if}
	 end {else if gLong.where = localAddress}
      else {if gLong.where = globalLabel then} begin
	 gLong.disp := gLong.disp+q;
	 if gLong.fixedDisp then
	    if smallMemoryModel then begin
	       GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0);
	       GenNative(m_ldx_abs, absolute, gLong.disp+2, gLong.lab, 0);
	       end {if}
	    else begin
	       GenNative(m_lda_long, longAbs, gLong.disp+2, gLong.lab, 0);
	       GenImplied(m_tax);
	       GenNative(m_lda_long, longAbs, gLong.disp, gLong.lab, 0);
	       end {else}
	 else
	    if smallMemoryModel then begin
	       GenNative(m_ldy_absX, absolute, gLong.disp+2, gLong.lab, 0);
	       GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0);
	       GenImplied(m_tyx);
	       end {if}
	    else begin
	       GenNative(m_lda_longX, longAbs, gLong.disp+2, gLong.lab, 0);
	       GenImplied(m_tay);
	       GenNative(m_lda_longX, longAbs, gLong.disp, gLong.lab, 0);
	       GenImplied(m_tyx);
	       end; {else}
	 if (A_X & lLong.preference) = 0 then begin
	    GenImplied(m_phx);
	    GenImplied(m_pha);
	    end; {if}
	 end; {else}
      if (A_X & lLong.preference) <> 0 then
	 gLong.where := A_X
      else
	 gLong.where := onStack;
      end; {cgLong,cgULong}

   cgByte,cgUByte,cgWord,cgUWord: begin
      GetPointer(op^.left);
      if gLong.where = inPointer then begin
	 if q = 0 then
	    if gLong.fixedDisp then
	       GenNative(m_lda_indl, direct, gLong.disp, nil, 0)
	    else
	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0)
	 else
	    if gLong.fixedDisp then begin
	       GenNative(m_ldy_imm, immediate, q, nil, 0);
	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0)
	       end {if}
	    else begin
	       GenImplied(m_tya);
	       GenImplied(m_clc);
	       GenNative(m_adc_imm, immediate, q, nil, 0);
	       GenImplied(m_tay);
	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0)
	       end; {else}
	 end {if}
      else if gLong.where = localAddress then begin
	 gLong.disp := gLong.disp+q;
	 if gLong.fixedDisp then
	    if (gLong.disp & $FF00) = 0 then
	       GenNative(m_lda_dir, direct, gLong.disp, nil, 0)
	    else begin
	       GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
	       GenNative(m_lda_dirX, direct, 0, nil, 0);
	       end {else}
	 else
	    if (gLong.disp & $FF00) = 0 then
	       GenNative(m_lda_dirX, direct, gLong.disp, nil, 0)
	    else begin
	       GenImplied(m_txa);
	       GenImplied(m_clc);
	       GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
	       GenImplied(m_tax);
	       GenNative(m_lda_dirX, direct, 0, nil, 0);
	       end {else}
	 end {else if}
      else {if gLong.where = globalLabel then} begin
	 gLong.disp := gLong.disp+q;
	 if gLong.fixedDisp then
	    if smallMemoryModel then
	       GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0)
	    else
	       GenNative(m_lda_long, longAbs, gLong.disp, gLong.lab, 0)
	 else
	    if smallMemoryModel then
	       GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0)
	    else
	       GenNative(m_lda_longX, longAbs, gLong.disp, gLong.lab, 0)
	 end; {else}
      if optype in [cgByte,cgUByte] then begin
	 GenNative(m_and_imm, immediate, 255, nil, 0);
	 if optype = cgByte then begin
	    GenNative(m_cmp_imm, immediate, 128, nil, 0);
	    lab1 := GenLabel;
	    GenNative(m_bcc, relative, lab1, nil, 0);
	    GenNative(m_ora_imm, immediate, $FF00, nil, 0);
	    GenLab(lab1);
	    end; {if}
	 end; {if}
      end; {case cgByte,cgUByte,cgWord,cgUWord}

   cgSet: begin
      gLong.preference := onStack;
      GenTree(op^.left);
      if op^.r <> 0 then
	 IncAddr(op^.r);
      GenNative(m_pea, immediate, q, nil, 0);
      GenCall(28);
      end; {case cgSet}

   otherwise: ;
   end; {case}
end; {GenInd}


procedure GenIxa (op: icptr);

{ Generate code for a pc_ixa					}

var
   lab1: integer;			{branch label}
   lLong: longType;			{type of address}
   zero: boolean;			{is the index 0?}


   procedure Index;

   { Get the index size						}

   var
      lLong: longType;			{temp for preserving left node info}

   begin {Index}
   zero := false;
   with op^.right^ do begin
      if opcode = pc_ldc then begin
	 if q = 0 then
	    zero := true
	 else
	    GenNative(m_lda_imm, immediate, q, nil, 0);
	 end {if}
      else begin
	 lLong := gLong;
	 GenTree(op^.right);
	 gLong := lLong;
	 end; {else}
      end; {with}
   end; {Index}


begin {GenIxa}
if smallMemoryModel then begin
   lLong := gLong;
   gLong.preference := inPointer+localAddress+globalLabel;
   GenTree(op^.left);
   case gLong.where of

      onStack: begin
	 Index;
	 if not zero then begin
	    GenImplied(m_clc);
	    GenNative(m_adc_s, direct, 1, nil, 0);
	    GenNative(m_sta_s, direct, 1, nil, 0);
	    lab1 := GenLabel;
	    GenNative(m_bcc, relative, lab1, nil, 0);
	    GenNative(m_lda_s, direct, 3, nil, 0);
	    GenImplied(m_ina);
	    GenNative(m_sta_s, direct, 3, nil, 0);
	    GenLab(lab1);
	    end; {if}
	 end; {case onStack}

      inPointer: begin
	 if not gLong.fixedDisp then begin
	    if Complex(op^.right) then begin
	       GenImplied(m_phy);
	       Index;
	       if not zero then begin
		  GenImplied(m_clc);
		  GenNative(m_adc_s, direct, 1, nil, 0);
		  GenNative(m_sta_s, direct, 1, nil, 0);
		  end; {if}
	       GenImplied(m_ply);
	       end {if}
	    else begin
	       GenImplied(m_tya);
	       GenImplied(m_clc);
	       OperA(m_adc_imm, op^.right);
	       GenImplied(m_tay);
	       end; {else}
	    end {if}
	 else begin
	    Index;
	    if not zero then begin
	       GenImplied(m_tay);
	       gLong.fixedDisp := false;
	       end; {if}
	    end; {else}
	 if (inPointer & lLong.preference) = 0 then begin
	    if not gLong.fixedDisp then begin
	       GenImplied(m_tya);
	       GenImplied(m_clc);
	       GenNative(m_adc_dir, direct, gLong.disp, nil, 0);
	       GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
	       lab1 := GenLabel;
	       GenNative(m_bcc, relative, lab1, nil, 0);
	       GenImplied(m_inx);
	       GenLab(lab1);
	       end {if}
	    else begin
	       GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
	       GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
	       end; {else}
	    GenImplied(m_phx);
	    GenImplied(m_pha);
	    gLong.where := onStack;
	    end; {if}
	 end; {case inPointer}

      localAddress,globalLabel: begin
	 if not gLong.fixedDisp then begin
	    if Complex(op^.right) then begin
	       GenImplied(m_phx);
	       Index;
	       if not zero then begin
		  GenImplied(m_clc);
		  GenNative(m_adc_s, direct, 1, nil, 0);
		  GenNative(m_sta_s, direct, 1, nil, 0);
		  end; {if}
	       GenImplied(m_plx);
	       end {if}
	    else begin
	       GenImplied(m_txa);
	       GenImplied(m_clc);
	       OperA(m_adc_imm, op^.right);
	       GenImplied(m_tax);
	       end; {else}
	    end {if}
	 else if Complex(op^.right) then begin
	    Index;
	    if not zero then begin
	       GenImplied(m_tax);
	       gLong.fixedDisp := false;
	       end; {if}
	    end {else if}
	 else begin
	    LoadX(op^.right);
	    gLong.fixedDisp := false;
	    end; {else}
	 if (lLong.preference & gLong.where) = 0 then begin
	    if (lLong.preference & inPointer) <> 0 then begin
	       if gLong.where = localAddress then begin
		  if not gLong.fixedDisp then begin
		     GenNative(m_stz_dir, direct, dworkLoc+2, nil, 0);
		     GenImplied(m_phx);
		     GenImplied(m_tdc);
		     GenImplied(m_clc);
		     if gLong.disp <> 0 then
			GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
		     GenNative(m_adc_s, direct, 1, nil, 0);
		     GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
		     GenImplied(m_plx);
		     end {if}
		  else begin
		     GenNative(m_stz_dir, direct, dworkLoc+2, nil, 0);
		     GenImplied(m_tdc);
		     GenImplied(m_clc);
		     GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
		     GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
		     end; {else}
		  end {if}
	       else begin
		  if not gLong.fixedDisp then begin
		     GenImplied(m_txa);
		     GenImplied(m_clc);
		     GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0);
		     GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
		     GenNative(m_ldx_imm, immediate, gLong.disp, gLong.lab, shift16);
		     lab1 := GenLabel;
		     GenNative(m_bcc, relative, lab1, nil, 0);
		     GenImplied(m_inx);
		     GenLab(lab1);
		     GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0);
		     end {if}
		  else begin
		     GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16);
		     GenNative(m_sta_dir, direct, dworkLoc+2, nil, 0);
		     GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0);
		     GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
		     end; {else}
		  end; {else}
	       gLong.where := inPointer;
	       gLong.fixedDisp := true;
	       gLong.disp := dworkLoc;
	       end {if}
	    else begin
	       if gLong.where = localAddress then begin
		  if not gLong.fixedDisp then begin
		     GenNative(m_pea, immediate, 0, nil, 0);
		     GenImplied(m_phx);
		     GenImplied(m_tdc);
		     GenImplied(m_clc);
		     GenNative(m_adc_s, direct, 1, nil, 0);
		     if gLong.disp <> 0 then
			GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
		     GenNative(m_sta_s, direct, 1, nil, 0);
		     end {if}
		  else begin
		     GenNative(m_pea, immediate, 0, nil, 0);
		     GenImplied(m_tdc);
		     GenImplied(m_clc);
		     GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
		     GenImplied(m_pha);
		     end; {else}
		  end {if}
	       else begin
		  if not gLong.fixedDisp then begin
		     GenImplied(m_txa);
		     GenImplied(m_clc);
		     GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0);
		     GenNative(m_ldx_imm, immediate, gLong.disp, gLong.lab, shift16);
		     lab1 := GenLabel;
		     GenNative(m_bcc, relative, lab1, nil, 0);
		     GenImplied(m_inx);
		     GenLab(lab1);
		     GenImplied(m_phx);
		     GenImplied(m_pha);
		     end {if}
		  else begin
		     GenNative(m_pea, immediate, gLong.disp, gLong.lab, shift16);
		     GenNative(m_pea, immediate, gLong.disp, gLong.lab, 0);
		     end; {else}
		  end; {else}
	       gLong.where := onStack;
	       end; {else}
	    end; {if}
	 end; {case localAddress,globalLabel}
      otherwise:
	 Error(cge1);
      end; {case}
   end {if smallMemoryModel or (op^.right^.opcode = pc_ldc)}
else begin
   gLong.preference := onStack;
   GenTree(op^.left);
   GenTree(op^.right);
   if op^.optype in [cgByte,cgWord] then begin
      lab1 := GenLabel;
      GenNative(m_ldx_imm, immediate, $0000, nil, 0);
      GenImplied(m_tay);
      GenNative(m_bpl, relative, lab1, nil, 0);
      GenImplied(m_dex);
      GenLab(lab1);
      GenImplied(m_phx);
      GenImplied(m_pha);
      end {else if}
   else begin
      GenNative(m_pea, immediate, 0, nil, 0);
      GenImplied(m_pha);
      end; {else}
   GenImplied(m_clc);
   GenImplied(m_pla);
   GenNative(m_adc_s, direct, 3, nil, 0);
   GenNative(m_sta_s, direct, 3, nil, 0);
   GenImplied(m_pla);
   GenNative(m_adc_s, direct, 3, nil, 0);
   GenNative(m_sta_s, direct, 3, nil, 0);
   gLong.where := onStack;
   end; {else}
end; {GenIxa}


procedure GenLogic (op: icptr);

{ generate a pc_and, pc_ior, pc_bnd, pc_bor or pc_bxr		}

var
   lab1,lab2: integer;			{label}
   nd: icptr;				{temp node pointer}
   opcode: pcodes;			{operation code}

begin {GenLogic}
opcode := op^.opcode;
if not Complex(op^.left) then
   if Complex(op^.right) then begin
      nd := op^.left;
      op^.left := op^.right;
      op^.right := nd;
      end; {if}
GenTree(op^.left);
if Complex(op^.right) then begin
   GenImplied(m_pha);
   GenTree(op^.right);
   case opcode of
      pc_and,pc_bnd: GenNative(m_and_s, direct, 1, nil, 0);
      pc_ior,pc_bor: GenNative(m_ora_s, direct, 1, nil, 0);
      pc_bxr: GenNative(m_eor_s, direct, 1, nil, 0);
      otherwise:
	 Error(cge1);
      end; {case}
   GenImplied(m_plx);
   GenImplied(m_tax);
   end {if}
else
   case opcode of
      pc_and,pc_bnd: OperA(m_and_imm, op^.right);
      pc_ior,pc_bor: OperA(m_ora_imm, op^.right);
      pc_bxr: OperA(m_eor_imm, op^.right);
      otherwise:
	 Error(cge1);
      end; {case}
end; {GenLogic}


procedure GenSroCpo (op: icptr);

{ Generate code for a pc_sro or pc_cpo			}

var
   lab: pStringPtr;			{op^.lab}
   lab1: integer;			{branch point}
   lval: longint;			{op^.left^.lval}
   opcode: pcodes;			{op^.opcode}
   optype: baseTypeEnum; 		{op^.optype}
   q: integer;				{op^.q}
   special: boolean;			{special save?}

begin {GenSroCpo}
opcode := op^.opcode;
optype := op^.optype;
q := op^.q;
lab := op^.lab;
case optype of
   cgByte, cgUByte: begin
      if (opcode = pc_sro) and (op^.left^.opcode in [pc_inc,pc_dec]) then
	 GenIncDec(op^.left, op)
      else begin
	 if smallMemoryModel and (op^.left^.opcode = pc_ldc)
	    and (op^.left^.q = 0) then begin
	    GenNative(m_sep, immediate, 32, nil, 0);
	    GenNative(m_stz_abs, absolute, q, lab, 0);
	    end {if}
	 else begin
	    if op^.opcode = pc_sro then
	       if op^.left^.opcode = pc_cnv then
		  if (op^.left^.q >> 4) in [ord(cgWord),ord(cgUWord)] then
		     op^.left := op^.left^.left;
	    if (op^.left^.opcode in [pc_ldc,pc_ldc,pc_lod])
               and (op^.left^.p = 0) then begin
	       GenNative(m_sep, immediate, 32, nil, 0);
	       GenTree(op^.left);
	       end {if}
	    else begin
	       GenTree(op^.left);
	       GenNative(m_sep, immediate, 32, nil, 0);
	       end; {else}
	    if smallMemoryModel then
	       GenNative(m_sta_abs, absolute, q, lab, 0)
	    else
	       GenNative(m_sta_long, longabsolute, q, lab, 0);
	    end; {else}
	 GenNative(m_rep, immediate, 32, nil, 0);
         end; {else}
      end;

   cgWord, cgUWord:
      if (opcode = pc_sro) and (op^.left^.opcode in [pc_inc,pc_dec]) then
	 GenIncDec(op^.left, op)
      else begin
	 if smallMemoryModel and (op^.left^.opcode = pc_ldc)
	    and (op^.left^.q = 0) then
	    GenNative(m_stz_abs, absolute, q, lab, 0)
	 else begin
	    GenTree(op^.left);
	    if smallMemoryModel then
	       GenNative(m_sta_abs, absolute, q, lab, 0)
	    else
	       GenNative(m_sta_long, longabsolute, q, lab, 0);
	    end; {else}
         end; {else}

   cgReal, cgDouble, cgComp, cgExtended: begin
      GenTree(op^.left);
      GenNative(m_pea, immediate, q, lab, shift16);
      GenNative(m_pea, immediate, q, lab, 0);
      if opcode = pc_sro then begin
	 if optype = cgReal then
	    GenCall(23)
	 else if optype = cgDouble then
	    GenCall(87)
	 else if optype = cgComp then
	    GenCall(157)
	 else {if optype = cgExtended then}
	    GenCall(158);
	 end {if}
      else {if opcode = pc_cpo then} begin
	 if optype = cgReal then
	    GenCall(159)
	 else if optype = cgDouble then
	    GenCall(160)
	 else if optype = cgComp then
	    GenCall(161)
	 else {if optype = cgExtended then}
	    GenCall(162);
	 end; {else}
      end;

   cgSet: begin
      GenTree(op^.left);
      GenNative(m_pea, immediate, op^.r, lab, shift16);
      GenNative(m_pea, immediate, op^.r, lab, 0);
      GenNative(m_pea, immediate, q, nil, 0);
      GenCall(24);
      end;

   cgLong, cgULong: begin
      if (opcode = pc_sro) and (op^.left^.opcode in [pc_adl,pc_sbl]) then
	 GenAdlSbl(op^.left, op)
      else if (opcode = pc_sro) and (op^.left^.opcode in [pc_inc,pc_dec]) then
	 GenIncDec(op^.left, op)
      else if smallMemoryModel and (op^.left^.opcode = pc_ldc) then begin
	 lval := op^.left^.lval;
	 if long(lval).lsw = 0 then
	    GenNative(m_stz_abs, absolute, q, lab, 0)
	 else begin
	    GenNative(m_lda_imm, immediate, long(lval).lsw, nil, 0);
	    GenNative(m_sta_abs, absolute, q, lab, 0)
	    end; {else}
	 if long(lval).msw = 0 then
	    GenNative(m_stz_abs, absolute, q+2, lab, 0)
	 else begin
	    GenNative(m_ldx_imm, immediate, long(lval).msw, nil, 0);
	    GenNative(m_stx_abs, absolute, q+2, lab, 0)
	    end; {else}
	 if op^.opcode = pc_cpo then
	    GenTree(op^.left);
	 end {if}
      else begin
	 if op^.opcode = pc_sro then
	    gLong.preference := A_X | inPointer | localAddress | globalLabel | constant
	 else
	    gLong.preference := gLong.preference &
	       (A_X | inPointer | localAddress | globalLabel | constant);
	 GenTree(op^.left);
	 case gLong.where of

	    A_X: begin
	       if smallMemoryModel then begin
		  GenNative(m_stx_abs, absolute, q+2, lab, 0);
		  GenNative(m_sta_abs, absolute, q, lab, 0);
		  end {if}
	       else begin
		  GenNative(m_sta_long, longabsolute, q, lab, 0);
		  if opcode = pc_cpo then
		     GenImplied(m_pha);
		  GenImplied(m_txa);
		  GenNative(m_sta_long, longabsolute, q+2, lab, 0);
		  if opcode = pc_cpo then
		     GenImplied(m_pla);
		  end; {else}
	       end;

	    onStack: begin
	       if opcode = pc_sro then
		  GenImplied(m_pla)
	       else {if opcode = pc_cpo then}
		  GenNative(m_lda_s, direct, 1, nil, 0);
	       if smallMemoryModel then
		  GenNative(m_sta_abs, absolute, q, lab, 0)
	       else
		  GenNative(m_sta_long, longabsolute, q, lab, 0);
	       if opcode = pc_sro then
		  GenImplied(m_pla)
	       else {if opcode = pc_cpo then}
		  GenNative(m_lda_s, direct, 3, nil, 0);
	       if smallMemoryModel then
		  GenNative(m_sta_abs, absolute, q+2, lab, 0)
	       else
		  GenNative(m_sta_long, longabsolute, q+2, lab, 0);
	       end;

	    inPointer: begin
	       GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
	       if gLong.fixedDisp then
		  GenNative(m_lda_dir, direct, gLong.disp, nil, 0)
	       else begin
		  GenImplied(m_tya);
		  GenImplied(m_clc);
		  GenNative(m_adc_dir, direct, gLong.disp, nil, 0);
		  if not smallMemoryModel then begin
		     lab1 := GenLabel;
		     GenNative(m_bcc, relative, lab1, nil, 0);
		     GenImplied(m_inx);
		     GenLab(lab1);
		     end; {if}
		  end; {else}
	       if smallMemoryModel then begin
		  GenNative(m_stx_abs, absolute, q+2, lab, 0);
		  GenNative(m_sta_abs, absolute, q, lab, 0);
		  end {if}
	       else begin
		  GenNative(m_sta_long, longabsolute, q, lab, 0);
		  if opcode = pc_cpo then
		     GenImplied(m_pha);
		  GenImplied(m_txa);
		  GenNative(m_sta_long, longabsolute, q+2, lab, 0);
		  if opcode = pc_cpo then
		     GenImplied(m_pla);
		  end; {else}
	       gLong.where := A_X;
	       end;

	    localAddress: begin
	       if smallMemoryModel then
		  GenNative(m_stz_abs, absolute, q+2, lab, 0)
	       else begin
		  GenNative(m_lda_imm, immediate, 0, nil, 0);
		  GenNative(m_sta_long, longabsolute, q+2, lab, 0);
		  end; {else}
	       GenImplied(m_tdc);
	       GenImplied(m_clc);
	       GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
	       if not gLong.fixedDisp then begin
		  GenImplied(m_phx);
		  GenNative(m_adc_s, direct, 1, nil, 0);
		  GenImplied(m_plx);
		  end; {if}
	       if smallMemoryModel then
		  GenNative(m_sta_abs, absolute, q, lab, 0)
	       else
		  GenNative(m_sta_long, longabsolute, q, lab, 0);
	       end;

	    globalLabel:
	       if gLong.fixedDisp then begin
		  if smallMemoryModel then begin
		     GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0);
		     GenNative(m_ldx_imm, immediate, gLong.disp, gLong.lab, shift16);
		     GenNative(m_stx_abs, absolute, q+2, lab, 0);
		     GenNative(m_sta_abs, absolute, q, lab, 0);
		     end {if}
		  else begin
		     GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16);
		     GenNative(m_sta_long, longabsolute, q+2, lab, 0);
		     if opcode = pc_cpo then
			GenImplied(m_tax);
		     GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0);
		     GenNative(m_sta_long, longabsolute, q, lab, 0);
		     end; {else}
		  gLong.where := A_X;
		  end {if}
	       else begin
		  GenImplied(m_txa);
		  GenImplied(m_clc);
		  GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0);
		  if smallMemoryModel then
		     GenNative(m_sta_abs, absolute, q, lab, 0)
		  else
		     GenNative(m_sta_long, longabsolute, q, lab, 0);
		  GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16);
		  GenNative(m_adc_imm, immediate, 0, nil, 0);
		  if smallMemoryModel then
		     GenNative(m_sta_abs, absolute, q+2, lab, 0)
		  else
		     GenNative(m_sta_long, longabsolute, q+2, lab, 0);
		  end; {else}

	    constant: begin
	       if gLong.lval = 0 then begin
		  if smallMemoryModel then begin
		     GenNative(m_stz_abs, absolute, q+2, lab, 0);
		     GenNative(m_stz_abs, absolute, q, lab, 0);
		     end {if}
		  else begin
		     GenNative(m_lda_imm, immediate, 0, nil, 0);
		     GenNative(m_sta_long, longabsolute, q+2, lab, 0);
		     GenNative(m_sta_long, longabsolute, q, lab, 0);
		     end; {else}
		  end {if}
	       else if not smallMemoryModel then begin
		  GenNative(m_lda_imm, immediate, long(gLong.lval).msw, nil, 0);
		  GenNative(m_sta_long, longabsolute, q+2, lab, 0);
		  GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
		  GenNative(m_sta_long, longabsolute, q, lab, 0);
		  end {else if}
	       else begin
		  if long(gLong.lval).msw = 0 then
		     GenNative(m_stz_abs, absolute, q+2, lab, 0)
		  else begin
		     GenNative(m_ldx_imm, immediate, long(gLong.lval).msw, nil, 0);
		     GenNative(m_stx_abs, absolute, q+2, lab, 0);
		     end; {else}
		  if long(gLong.lval).lsw = 0 then
		     GenNative(m_stz_abs, absolute, q, lab, 0)
		  else begin
		     GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
		     GenNative(m_sta_abs, absolute, q, lab, 0);
		     end; {else}
		  if (long(gLong.lval).lsw <> 0) and (long(gLong.lval).msw <> 0) then
		     gLong.where := A_X;
		  end; {else}
	       end; {case constant}

	    otherwise:
	       Error(cge1);
	    end; {case}
	 end; {else}
      end; {case CGLong, cgULong}

   end; {case}
end; {GenSroCpo}


procedure GenSto (op: icptr);

{ Generate code for a pc_sto          			}

var
   disp: integer;			{disp in stack frame}
   opcode: pcodes;			{temp storage for op code}
   optype: baseTypeEnum; 		{operand type}
   short: boolean;			{use short registers?}
   simple: boolean;			{is the load a simple load?}
   preference: integer;			{old preference}
   lLong: longType;			{address record for left node}
   zero: boolean;			{is the operand a constant zero?}


   procedure LoadLSW;

   { load the least significant word of a four byte value	}

   begin {LoadLSW}
   if lLong.where = onStack then
      if opcode = pc_sto then
	 GenImplied(m_pla)
      else
	 GenNative(m_lda_s, direct, 1, nil, 0)
   else if lLong.where <> A_X then
      GenNative(m_lda_imm, immediate, long(lLong.lval).lsw, nil, 0);
   end; {LoadLSW}


   procedure LoadMSW;

   { load the most significant word of a four byte value 	}
   {								}
   { Note: LoadLSW MUST be called first! 			}

   begin {LoadMSW}
   gLong.where := A_X;
   if lLong.where = onStack then
      if opcode = pc_sto then
	 GenImplied(m_pla)
      else begin
	 GenNative(m_lda_s, direct, 3, nil, 0);
	 gLong.where := onStack;
	 end {else}
   else if lLong.where = A_X then
      GenImplied(m_txa)
   else
      GenNative(m_lda_imm, immediate, long(lLong.lval).msw, nil, 0);
   end; {LoadMSW}


   procedure LoadWord;

   { Get the operand for a cgByte, cgUByte, cgWord or cgUWord	}
   { into the accumulator					}

   begin {LoadWord}
   if simple then begin
      with op^.right^ do
	 if opcode = pc_ldc then
	    GenNative(m_lda_imm, immediate, q, nil, 0)
	 else if opcode = pc_lod then
	    GenNative(m_lda_dir, direct, localLabel[r] + q, nil, 0)
	 else {if opcode = pc_ldo then}
	    if smallMemoryModel then
	       GenNative(m_lda_abs, absolute, q, lab, 0)
	    else
	       GenNative(m_lda_long, longAbs, q, lab, 0);
      end {if}
   else begin
      GenImplied(m_pla);
      if short then
	 GenNative(m_sep, immediate, 32, nil, 0);
      end {else}
   end; {LoadWord}


begin {GenSto}
opcode := op^.opcode;
optype := op^.optype;
case optype of

   cgReal,cgDouble,cgComp,cgExtended: begin
      GenTree(op^.right);
      gLong.preference := onStack;
      GenTree(op^.left);
      if optype = cgReal then begin
	 if opcode = pc_sto then
	    GenCall(23)
	 else
	    GenCall(159);
	 end {if}
      else if optype = cgDouble then begin
	 if opcode = pc_sto then
	    GenCall(87)
	 else
	    GenCall(160);
	 end {else if}
      else if optype = cgComp then begin
	 if opcode = pc_sto then
	    GenCall(157)
	 else
	    GenCall(161);
	 end {else if}
      else {if optype = cgExtended then} begin
	 if opcode = pc_sto then
	    GenCall(158)
	 else
	    GenCall(162);
	 end; {else}
      end; {case cgReal,cgDouble,cgComp,cgExtended}

   cgSet: begin
      gLong.preference := onStack;
      GenTree(op^.right);
      gLong.preference := onStack;
      GenTree(op^.left);
      GenNative(m_pea, immediate, op^.q, nil, 0);
      GenCall(24);
      end;

   cgLong,cgULong: begin
      preference := gLong.preference;
      gLong.preference := onStack+constant;
      GenTree(op^.right);
      lLong := gLong;
      gLong.preference := localAddress+inPointer+globalLabel+A_X;
      GenTree(op^.left);
      if gLong.where = onStack then begin
	 GenImplied(m_pla);
	 GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
	 GenImplied(m_pla);
	 GenNative(m_sta_dir, direct, dworkLoc+2, nil, 0);
	 LoadLSW;
	 GenNative(m_sta_indl, direct, dworkLoc, nil, 0);
	 GenNative(m_ldy_imm, immediate, 2, nil, 0);
	 LoadMSW;
	 GenNative(m_sta_indly, direct, dworkLoc, nil, 0);
	 end {if}
      else if gLong.where = A_X then begin
	 GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
	 GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0);
	 LoadLSW;
	 GenNative(m_sta_indl, direct, dworkLoc, nil, 0);
	 GenNative(m_ldy_imm, immediate, 2, nil, 0);
	 LoadMSW;
	 GenNative(m_sta_indly, direct, dworkLoc, nil, 0);
	 end {if}
      else if gLong.where = localAddress then begin
	 LoadLSW;
	 if gLong.fixedDisp then
	    if (gLong.disp & $FF00) = 0 then
	       GenNative(m_sta_dir, direct, gLong.disp, nil, 0)
	    else begin
	       GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
	       GenNative(m_sta_dirX, direct, 0, nil, 0);
	       end {else}
	 else begin
	    if (gLong.disp >= 254) or (gLong.disp < 0) then begin
	       GenImplied(m_tay);
	       GenImplied(m_txa);
	       GenImplied(m_clc);
	       GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
	       GenImplied(m_tax);
	       GenImplied(m_tya);
	       gLong.disp := 0;
	       end; {if}
	    GenNative(m_sta_dirX, direct, gLong.disp, nil, 0);
	    end; {else}
	 LoadMSW;
	 if gLong.fixedDisp then
	    if ((gLong.disp+2) & $FF00) = 0 then
	       GenNative(m_sta_dir, direct, gLong.disp+2, nil, 0)
	    else begin
	       GenNative(m_ldx_imm, immediate, gLong.disp+2, nil, 0);
	       GenNative(m_sta_dirX, direct, 0, nil, 0);
	       end {else}
	 else begin
	    if (gLong.disp >= 254) or (gLong.disp < 0) then begin
	       GenImplied(m_tay);
	       GenImplied(m_txa);
	       GenImplied(m_clc);
	       GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
	       GenImplied(m_tax);
	       GenImplied(m_tya);
	       gLong.disp := 0;
	       end; {if}
	    GenNative(m_sta_dirX, direct, gLong.disp+2, nil, 0);
	    end; {else}
	 end {else if}
      else if gLong.where = globalLabel then begin
	 LoadLSW;
	 if gLong.fixedDisp then
	    if smallMemoryModel then
	       GenNative(m_sta_abs, absolute, gLong.disp, gLong.lab, 0)
	    else
	       GenNative(m_sta_long, longAbs, gLong.disp, gLong.lab, 0)
	 else
	    if smallMemoryModel then
	       GenNative(m_sta_absX, absolute, gLong.disp, gLong.lab, 0)
	    else
	       GenNative(m_sta_longX, longAbs, gLong.disp, gLong.lab, 0);
	 LoadMSW;
	 if gLong.fixedDisp then
	    if smallMemoryModel then
	       GenNative(m_sta_abs, absolute, gLong.disp+2, gLong.lab, 0)
	    else
	       GenNative(m_sta_long, longAbs, gLong.disp+2, gLong.lab, 0)
	 else
	    if smallMemoryModel then
	       GenNative(m_sta_absX, absolute, gLong.disp+2, gLong.lab, 0)
	    else
	       GenNative(m_sta_longX, longAbs, gLong.disp+2, gLong.lab, 0);
	 end {else if}
      else begin
	 LoadLSW;
	 if gLong.fixedDisp = true then begin
	    GenNative(m_sta_indl, direct, gLong.disp, nil, 0);
	    GenNative(m_ldy_imm, immediate, 2, nil, 0);
	    end {if}
	 else begin
	    GenNative(m_sta_indlY, direct, gLong.disp, nil, 0);
	    GenImplied(m_iny);
	    GenImplied(m_iny);
	    end; {else}
	 LoadMSW;
	 GenNative(m_sta_indly, direct, gLong.Disp, nil, 0);
	 end; {else}
      end; {case cgLong,cgULong}

   cgByte,cgUByte,cgWord,cgUWord: begin
      short := optype in [cgByte,cgUByte];
      simple := false;
      zero := false;
      if op^.opcode = pc_sto then begin
	 if short then
	    if op^.right^.opcode = pc_cnv then
	       if (op^.right^.q >> 4) in [ord(cgWord),ord(cgUWord)] then
		  op^.right := op^.right^.left;
	 with op^.right^ do begin
	    if opcode = pc_ldo then
	       simple := true
	    else if opcode = pc_lod then
	       simple := (localLabel[r] + q < 256) and (p = 0)
	    else if opcode = pc_ldc then begin
	       simple := true;
	       zero := q = 0;
	       end; {else if}
	    end; {with}
	 end; {if}
      if not (zero or simple) then begin
	 GenTree(op^.right);
	 GenImplied(m_pha);
	 end; {if}
      GetPointer(op^.left);
      if short then
	 if simple then
	    GenNative(m_sep, immediate, 32, nil, 0);
      if gLong.where = inPointer then begin
	 if zero then
	    GenNative(m_lda_imm, immediate, 0, nil, 0)
	 else
	    LoadWord;
	 if gLong.fixedDisp then
	    GenNative(m_sta_indl, direct, gLong.disp, nil, 0)
	 else
	    GenNative(m_sta_indlY, direct, gLong.disp, nil, 0);
	 end {if}
      else if gLong.where = localAddress then begin
	 if gLong.fixedDisp then
	    if (gLong.disp & $FF00) = 0 then
	       if zero then
		  GenNative(m_stz_dir, direct, gLong.disp, nil, 0)
	       else begin
		  LoadWord;
		  GenNative(m_sta_dir, direct, gLong.disp, nil, 0);
		  end {else}
	    else begin
	       if zero then begin
		  GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
		  GenNative(m_stz_dirX, direct, 0, nil, 0);
		  end {if}
	       else begin
		  LoadWord;
		  GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
		  GenNative(m_sta_dirX, direct, 0, nil, 0);
		  end; {else}
	       end {else}
	 else begin
	    if (gLong.disp & $FF00) <> 0 then begin
	       GenImplied(m_txa);
	       GenImplied(m_clc);
	       GenNative(m_adc_imm, immediate, glong.disp, nil, 0);
	       GenImplied(m_tax);
	       gLong.disp := 0;
	       end; {if}
	    if zero then
	       GenNative(m_stz_dirX, direct, gLong.disp, nil, 0)
	    else begin
	       LoadWord;
	       GenNative(m_sta_dirX, direct, gLong.disp, nil, 0);
	       end; {else}
	    end; {else}
	 end {else if}
      else {if gLong.where = globalLabel then} begin
	 if zero then begin
	    if not smallMemoryModel then
	       GenNative(m_lda_imm, immediate, 0, nil, 0);
	    end {if}
	 else
	    LoadWord;
	 if gLong.fixedDisp then
	    if smallMemoryModel then
	       if zero then
		  GenNative(m_stz_abs, absolute, gLong.disp, gLong.lab, 0)
	       else
		  GenNative(m_sta_abs, absolute, gLong.disp, gLong.lab, 0)
	    else
	       GenNative(m_sta_long, longAbs, gLong.disp, gLong.lab, 0)
	 else
	    if smallMemoryModel then
	       if zero then
		  GenNative(m_stz_absX, absolute, gLong.disp, gLong.lab, 0)
	       else
		  GenNative(m_sta_absX, absolute, gLong.disp, gLong.lab, 0)
	    else
	       GenNative(m_sta_longX, longAbs, gLong.disp, gLong.lab, 0);
	 end; {else}
      if short then
	 GenNative(m_rep, immediate, 32, nil, 0);
      end; {case cgByte,cgUByte,cgWord,cgUWord}

   otherwise:
      Error(cge1);
   end; {case}
end; {GenSto}


procedure GenStrCop (op: icptr);

{ Generate code for a pc_str or pc_cop				}

var
   disp: integer;			{store location}
   optype: baseTypeEnum; 		{op^.optype}
   special: boolean;			{use special processing?}
   zero: boolean;			{is the operand a constant zero?}

begin {GenStrCop}
disp := localLabel[op^.r] + op^.q;
optype := op^.optype;
case optype of
   cgByte, cgUByte, cgWord, cgUWord: begin
      if (op^.opcode = pc_str) and (op^.left^.opcode in [pc_inc,pc_dec]) then
	 GenIncDec(op^.left, op)
      else begin
	 zero := false;
	 if op^.left^.opcode = pc_ldc then
	    if op^.opcode = pc_str then
	       if op^.p = 0 then
		  if op^.left^.q = 0 then
	             zero := true;
	 if not zero then begin
	    if optype in [cgByte,cgUByte] then begin
	       if op^.opcode = pc_str then
		  if op^.left^.opcode = pc_cnv then
		     if (op^.left^.q >> 4) in [ord(cgWord),ord(cgUWord)] then
			op^.left := op^.left^.left;
	       if (op^.left^.opcode in [pc_ldc,pc_ldc,pc_lod])
                  and (op^.opcode = pc_str)
        	  and (op^.left^.p = 0) then begin
		  GenNative(m_sep, immediate, 32, nil, 0);
		  GenTree(op^.left);
		  end {if}
	       else begin
		  GenTree(op^.left);
		  GenNative(m_sep, immediate, 32, nil, 0);
		  end; {else}
	       end {if}
	    else
	       GenTree(op^.left);
	    end {if}
	 else
	    if optype in [cgByte,cgUByte] then
	       GenNative(m_sep, immediate, 32, nil, 0);
	 if op^.p <> 0 then begin
	    StaticLink(op^.p, true, false);
	    GenNative(m_sta_longx, longabsolute, disp, nil, 0);
	    end {if}
	 else if disp > 255 then begin
	    GenNative(m_ldx_imm, immediate, disp, nil, 0);
	    if zero then
	       GenNative(m_stz_dirx, direct, 0, nil, 0)
	    else
	       GenNative(m_sta_dirx, direct, 0, nil, 0);
	    end {else if}
	 else
	    if zero then
	       GenNative(m_stz_dir, direct, disp, nil, 0)
	    else
	       GenNative(m_sta_dir, direct, disp, nil, 0);
	 if optype in [cgByte,cgUByte] then
	    GenNative(m_rep, immediate, 32, nil, 0);
         end; {else}
      end;

   cgReal, cgDouble, cgComp, cgExtended: begin
      GenTree(op^.left);
      GenNative(m_pea, immediate, 0, nil, 0);
      if op^.p = 0 then
	 GenImplied(m_tdc)
      else
	 StaticLink(op^.p, false, true);
      GenImplied(m_clc);
      GenNative(m_adc_imm, immediate, disp, nil, 0);
      GenImplied(m_pha);
      if op^.opcode = pc_str then begin
	 if optype = cgReal then
	    GenCall(23)
	 else if optype = cgDouble then
	    GenCall(87)
	 else if optype = cgComp then
	    GenCall(157)
	 else {if optype = cgExtended then}
	    GenCall(158);
	 end {if}
      else begin
	 if optype = cgReal then
	    GenCall(159)
	 else if optype = cgDouble then
	    GenCall(160)
	 else if optype = cgComp then
	    GenCall(161)
	 else {if optype = cgExtended then}
	    GenCall(162);
	 end; {else}
      end;

   cgLong, cgULong: begin
      if (op^.opcode = pc_str) and (op^.left^.opcode in [pc_adl,pc_sbl]) then
	 GenAdlSbl(op^.left, op)
      else if (op^.opcode = pc_str) and (op^.left^.opcode in [pc_inc,pc_dec]) then
	 GenIncDec(op^.left, op)
      else begin
	 if op^.opcode = pc_str then
            if op^.p = 0 then
	       gLong.preference :=
		  A_X+onStack+inPointer+localAddress+globalLabel+constant
            else
	       gLong.preference :=
		  onStack+constant
	 else
	    gLong.preference := onStack;
	 GenTree(op^.left);
	 case gLong.where of

	    A_X:
	       if disp < 254 then begin
		  GenNative(m_stx_dir, direct, disp+2, nil, 0);
		  GenNative(m_sta_dir, direct, disp, nil, 0);
		  end {else if}
	       else begin
		  GenImplied(m_txy);
		  GenNative(m_ldx_imm, immediate, disp, nil, 0);
		  GenNative(m_sta_dirX, direct, 0, nil, 0);
		  GenNative(m_sty_dirX, direct, 2, nil, 0);
		  if op^.opcode = pc_cop then
		     GenImplied(m_tyx);
		  end; {else}

	    onStack:
	       if op^.p <> 0 then begin
	          StaticLink(op^.p, false, false);
		  if op^.opcode = pc_str then
		     GenImplied(m_pla)
		  else {if op^.opcode = pc_cop then}
		     GenNative(m_lda_s, direct, 1, nil, 0);
		  GenNative(m_sta_longX, longAbsolute, disp, nil, 0);
		  if op^.opcode = pc_str then
		     GenImplied(m_pla)
		  else {if op^.opcode = pc_cop then}
		     GenNative(m_lda_s, direct, 3, nil, 0);
		  GenNative(m_sta_longX, longAbsolute, disp+2, nil, 0);
                  end {if}
               else if disp < 254 then begin
		  if op^.opcode = pc_str then
		     GenImplied(m_pla)
		  else {if op^.opcode = pc_cop then}
		     GenNative(m_lda_s, direct, 1, nil, 0);
		  GenNative(m_sta_dir, direct, disp, nil, 0);
		  if op^.opcode = pc_str then
		     GenImplied(m_pla)
		  else {if op^.opcode = pc_cop then}
		     GenNative(m_lda_s, direct, 3, nil, 0);
		  GenNative(m_sta_dir, direct, disp+2, nil, 0);
		  end {else if}
	       else begin
		  GenNative(m_ldx_imm, immediate, disp, nil, 0);
		  if op^.opcode = pc_str then
		     GenImplied(m_pla)
		  else {if op^.opcode = pc_cop then}
		     GenNative(m_lda_s, direct, 1, nil, 0);
		  GenNative(m_sta_dirX, direct, 0, nil, 0);
		  if op^.opcode = pc_str then
		     GenImplied(m_pla)
		  else {if op^.opcode = pc_cop then}
		     GenNative(m_lda_s, direct, 3, nil, 0);
		  GenNative(m_sta_dirX, direct, 2, nil, 0);
		  end; {else}

	    inPointer: begin
	       if (disp < 254) and (gLong.disp < 254) and gLong.fixedDisp
		  and (disp >= 0) and (gLong.disp >= 0) then begin
		  GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
		  GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
		  GenNative(m_sta_dir, direct, disp, nil, 0);
		  GenNative(m_stx_dir, direct, disp+2, nil, 0);
		  end {if}
	       else if (disp < 254) and (gLong.disp < 254)
		  and (disp >= 0) and (gLong.disp >= 0)
		  and (op^.opcode = pc_str) then begin
		  GenImplied(m_tya);
		  GenImplied(m_clc);
		  GenNative(m_adc_dir, direct, gLong.disp, nil, 0);
		  GenNative(m_sta_dir, direct, disp, nil, 0);
		  GenNative(m_lda_dir, direct, gLong.disp+2, nil, 0);
		  GenNative(m_adc_imm, immediate, 0, nil, 0);
		  GenNative(m_sta_dir, direct, disp+2, nil, 0);
		  end {else if}
	       else begin
		  GenNative(m_ldx_imm, immediate, disp, nil, 0);
		  if not gLong.fixedDisp then begin
		     GenImplied(m_tya);
		     GenImplied(m_clc);
		     GenNative(m_adc_dir, direct, gLong.disp, nil, 0);
		     end {if}
		  else
		     GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
		  GenNative(m_sta_dirX, direct, 0, nil, 0);
		  GenNative(m_lda_dir, direct, gLong.disp+2, nil, 0);
		  if not gLong.fixedDisp then
		     GenNative(m_adc_imm, immediate, 0, nil, 0);
		  GenNative(m_sta_dirX, direct, 2, nil, 0);
		  end; {else}
	       end;

	    localAddress:
	       if disp < 254 then begin
		  GenNative(m_stz_dir, direct, disp+2, nil, 0);
		  GenImplied(m_tdc);
		  GenImplied(m_clc);
		  GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
		  if not gLong.fixedDisp then begin
		     GenImplied(m_phx);
		     GenNative(m_adc_s, direct, 1, nil, 0);
		     GenImplied(m_plx);
		     end; {if}
		  GenNative(m_sta_dir, direct, disp, nil, 0);
		  end {else if disp < 254}
	       else begin
		  if not gLong.fixedDisp then
		     GenImplied(m_phx);
		  GenNative(m_ldx_imm, immediate, disp, nil, 0);
		  GenImplied(m_tdc);
		  GenImplied(m_clc);
		  GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
		  if not gLong.fixedDisp then begin
		     GenNative(m_adc_s, direct, 1, nil, 0);
		     GenImplied(m_ply);
		     end; {if}
		  GenNative(m_sta_dirX, direct, 0, nil, 0);
		  GenNative(m_stz_dirX, direct, 2, nil, 0);
		  end; {else}

	    globalLabel: begin
	       if not gLong.fixedDisp then
		  GenImplied(m_txa)
	       else if disp > 253 then
		  GenNative(m_ldx_imm, immediate, disp, nil, 0);
	       if gLong.fixedDisp then
		  GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0)
	       else begin
		  GenImplied(m_clc);
		  GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0);
		  end; {else}
	       if disp < 254 then
		  GenNative(m_sta_dir, direct, disp, nil, 0)
	       else
		  GenNative(m_sta_dirX, direct, 0, nil, 0);
	       GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16);
	       if not gLong.fixedDisp then
		  GenNative(m_adc_imm, immediate, 0, nil, 0);
	       if disp < 254 then
		  GenNative(m_sta_dir, direct, disp+2, nil, 0)
	       else
		  GenNative(m_sta_dirX, direct, 2, nil, 0);
	       end;

	    constant:
	       if op^.p <> 0 then begin
	          StaticLink(op^.p, false, false);
		  GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
		  GenNative(m_sta_longX, longAbsolute, disp, nil, 0);
		  GenNative(m_lda_imm, immediate, long(gLong.lval).msw, nil, 0);
		  GenNative(m_sta_longX, longAbsolute, disp+2, nil, 0);
                  end {if}
	       else if disp < 254 then begin
		  GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
		  GenNative(m_sta_dir, direct, disp, nil, 0);
		  GenNative(m_lda_imm, immediate, long(gLong.lval).msw, nil, 0);
		  GenNative(m_sta_dir, direct, disp+2, nil, 0);
		  end {else}
	       else begin
		  GenNative(m_ldx_imm, immediate, disp, nil, 0);
		  GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
		  GenNative(m_sta_dirX, direct, 0, nil, 0);
		  GenNative(m_lda_imm, immediate, long(gLong.lval).msw, nil, 0);
		  GenNative(m_sta_dirX, direct, 2, nil, 0);
		  end; {else}

	    otherwise:
	       Error(cge1);
	    end; {case}
	 end; {else}
      end;

   cgSet: begin
      GenTree(op^.left);
      GenNative(m_pea, immediate, 0, nil, 0);
      if op^.p = 0 then
	 GenImplied(m_tdc)
      else
	 StaticLink(op^.p, false, true);
      GenImplied(m_clc);
      GenNative(m_adc_imm, immediate, disp, nil, 0);
      GenImplied(m_pha);
      GenNative(m_pea, immediate, op^.s, nil, 0);
      GenCall(24);
      end;

   otherwise: ;

   end; {case}
end; {GenStrCop}


procedure DirEnp;

{ Generate code for a dc_enp					}

begin {DirEnp}
enpFound := true;
GenImplied(d_end);
EndSeg;
InitLabels;
end; {DirEnp}


{$optimize 15}

procedure GenTree {op: icptr};

{ generate code for op and its children				}
{								}
{ parameters:							}
{    op - opcode for which to generate code			}


   procedure GenAbiBntNgiNotOddSqi (op: icptr);

   { Generate code for a pc_abi, pc_bnt, pc_ngi pc_not, pc_odd, pc_sqi }

   var
      lab1: integer;

   begin {GenAbiBntNgiNotOddSqi}
   GenTree(op^.left);
   case op^.opcode of
      pc_abi: begin
	 lab1 := GenLabel;
         GenImplied(m_tax);
	 GenNative(m_bpl, relative, lab1, nil, 0);
	 GenNative(m_eor_imm, immediate, -1, nil, 0);
	 GenImplied(m_ina);
	 GenLab(lab1);
	 end;

      pc_bnt:
	 GenNative(m_eor_imm, immediate, -1, nil, 0);

      pc_ngi: begin
	 GenNative(m_eor_imm, immediate, -1, nil, 0);
	 GenImplied(m_ina);
	 end; {case pc_ngi}

      pc_not:
	 GenNative(m_eor_imm, immediate, 1, nil, 0);

      pc_odd:
	 GenNative(m_and_imm, immediate, 1, nil, 0);

      pc_sqi: begin
	 GenImplied(m_tax);
	 GenCall(32);
	 if rangeCheck then
	    GenCall(147);
	 end;
      end; {case}
   end; {GenAbiBntNgiNotOddSqi}


   procedure GenAblBnlNglOdlSql (op: icptr);

   { Generate code for a pc_abl, pc_bnl, pc_ngl, pc_odl, pc_sql	}

   var
      lab1: integer;			{branch point}

   begin {GenAblBnlNglOdlSql}
   gLong.preference := onStack;
   GenTree(op^.left);
   case op^.opcode of
      pc_abl: begin
	 lab1 := GenLabel;
	 GenNative(m_lda_s, direct, 3, nil, 0);
	 GenNative(m_bpl, relative, lab1, nil, 0);
	 GenImplied(m_sec);
	 GenNative(m_lda_imm, immediate, 0, nil, 0);
	 GenNative(m_sbc_s, direct, 1, nil, 0);
	 GenNative(m_sta_s, direct, 1, nil, 0);
	 GenNative(m_lda_imm, immediate, 0, nil, 0);
	 GenNative(m_sbc_s, direct, 3, nil, 0);
	 GenNative(m_sta_s, direct, 3, nil, 0);
	 GenLab(lab1);
	 end;

      pc_bnl: begin
	 GenNative(m_lda_s, direct, 1, nil, 0);
	 GenNative(m_eor_imm, immediate, -1, nil, 0);
	 GenNative(m_sta_s, direct, 1, nil, 0);
	 GenNative(m_lda_s, direct, 3, nil, 0);
	 GenNative(m_eor_imm, immediate, -1, nil, 0);
	 GenNative(m_sta_s, direct, 3, nil, 0);
	 end;

      pc_ngl: begin
	 GenImplied(m_sec);
	 GenNative(m_lda_imm, immediate, 0, nil, 0);
	 GenNative(m_sbc_s, direct, 1, nil, 0);
	 GenNative(m_sta_s, direct, 1, nil, 0);
	 GenNative(m_lda_imm, immediate, 0, nil, 0);
	 GenNative(m_sbc_s, direct, 3, nil, 0);
	 GenNative(m_sta_s, direct, 3, nil, 0);
	 end;

      pc_odl: begin
	 GenImplied(m_pla);
	 GenImplied(m_plx);
	 GenNative(m_and_imm, immediate, 1, nil, 0);
	 end;

      pc_sql: begin
	 GenNative(m_lda_s, direct, 3, nil, 0);
	 GenImplied(m_pha);
	 GenNative(m_lda_s, direct, 3, nil, 0);
	 GenImplied(m_pha);
	 GenCall(133);
	 end;
      end; {case}
   gLong.where := onStack;
   end; {GenAblBnlNglOdlSql}


   procedure GenAbrNgr (op: icptr);

   { generate a pc_abr or pc_ngr				}

   begin {GenAbrNgr}
   GenTree(op^.left);
   GenNative(m_lda_s, direct, 9, nil, 0);
   if op^.opcode = pc_abr then
      GenNative(m_and_imm, immediate, $7FFF, nil, 0)
   else {op^.opcode = pc_ngr}
      GenNative(m_eor_imm, immediate, $8000, nil, 0);
   GenNative(m_sta_s, direct, 9, nil, 0);
   end; {GenAbrNgr}


   procedure GenAdi (op: icptr);

   { generate a pc_adi						}

   var
      nd: icptr;

   begin {GenAdi}
   if not Complex(op^.left) then
      if Complex(op^.right) then begin
	 nd := op^.left;
	 op^.left := op^.right;
	 op^.right := nd;
	 end; {if}
   GenTree(op^.left);
   if Complex(op^.right) then begin
      GenImplied(m_pha);
      GenTree(op^.right);
      GenImplied(m_clc);
      GenNative(m_adc_s, direct, 1, nil, 0);
      GenImplied(m_plx);
      end {if}
   else begin
      GenImplied(m_clc);
      OperA(m_adc_imm, op^.right);
      end; {else}
   if rangeCheck then
      GenCall(147);
   end; {GenAdi}


   procedure GenAt2 (op: icptr);

   { Generate code for a pc_at2					}

   begin {GenAt2}
   GenTree(op^.left);
   GenTree(op^.right);
   GenCall(123);
   end; {GenAt2}


   procedure GenBinLong (op: icptr);

   { generate one of: pc_blr, pc_blx, pc_bal, pc_dvl, pc_mdl,	}
   {    pc_mpl, pc_sll, pc_slr, pc_udl, pc_ulm, pc_uml, pc_vsr	}

   var
      nd: icptr;			{for swapping left/right children}


      procedure GenOp (ops, opi: integer);

      { generate a binary operation				}
      {								}
      { parameters:						}
      {    ops - stack version of operation			}
      {    opi - immediate version of operation			}

      var
	 lab1: integer;			{label number}

      begin {GenOp}
      GenImplied(m_pla);
      if gLong.where = constant then begin
	 GenNative(opi, immediate, long(gLong.lval).lsw, nil, 0);
	 GenImplied(m_pha);
	 GenNative(m_lda_s, direct, 3, nil, 0);
	 GenNative(opi, immediate, long(gLong.lval).msw, nil, 0);
	 GenNative(m_sta_s, direct, 3, nil, 0);
	 end {if}
      else begin
	 GenNative(ops, direct, 3, nil, 0);
	 GenNative(m_sta_s, direct, 3, nil, 0);
	 GenImplied(m_pla);
	 GenNative(ops, direct, 3, nil, 0);
	 GenNative(m_sta_s, direct, 3, nil, 0);
	 end; {else}
      end; {GenOp}


   begin {GenBinLong}
   if (op^.left^.opcode = pc_ldc) and
      (op^.opcode in [pc_blr,pc_blx,pc_bal]) then begin
      nd := op^.left;
      op^.left := op^.right;
      op^.right := nd;
      end; {if}
   gLong.preference := onStack;
   GenTree(op^.left);
   if op^.opcode in [pc_blr,pc_blx,pc_bal] then begin
      gLong.preference := constant;
      GenTree(op^.right);
      end {if}
   else if op^.opcode in [pc_mdl,pc_uml,pc_udl,pc_ulm] then begin
      gLong.preference := A_X;
      GenTree(op^.right);
      if gLong.where = onStack then begin
         GenImplied(m_pla);
         GenImplied(m_plx);
         end; {if}
      end {else if}
   else begin
      gLong.preference := onStack;
      GenTree(op^.right);
      end; {else}
   case op^.opcode of

      pc_blr: GenOp(m_ora_s, m_ora_imm);

      pc_blx: GenOp(m_eor_s, m_eor_imm);

      pc_bal: GenOp(m_and_s, m_and_imm);

      pc_dvl: GenCall(134);

      pc_mdl: GenCall(135);

      pc_mpl: GenCall(133);

      pc_sll: GenCall(136);

      pc_slr: GenCall(171);

      pc_udl: GenCall(173);

      pc_ulm: GenCall(174);

      pc_uml: GenCall(172);

      pc_vsr: GenCall(170);

      otherwise: Error(cge1);
      end; {case}
   gLong.where := onStack;
   end; {GenBinLong}


   procedure GenBno (op: icptr);

   { Generate code for a pc_bno					}

   var
      lLong: longType;			{requested address type}

   begin {GenBno}
   lLong := gLong;
   GenTree(op^.left);
   gLong := lLong;
   GenTree(op^.right);
   end; {GenBno}


   procedure GenChk (op: icptr);

   { Generate code for a pc_chk					}

   begin {GenChk}
   gLong.preference := onStack;
   GenTree(op^.left);
   case op^.optype of
      otherwise:
         Error(cge1);
      cgByte,cgUByte,cgWord,cgUWord: begin
	 GenNative(m_ldx_imm, immediate, op^.r, nil, 0);
	 GenNative(m_ldy_imm, immediate, op^.q, nil, 0);
	 GenCall(33);
	 end;
      cgLong,cgULong:
         if (op^.lval = 1) and (op^.lval2 = maxaddr) then
            GenCall(34)
         else begin
	    GenNative(m_pea, immediate, long(op^.lval).msw, nil, 0);
	    GenNative(m_pea, immediate, long(op^.lval).lsw, nil, 0);
	    GenNative(m_pea, immediate, long(op^.lval2).msw, nil, 0);
	    GenNative(m_pea, immediate, long(op^.lval2).lsw, nil, 0);
            GenCall(179);
            end; {else}
     end; {case}
   end; {GenChk}


   procedure GenCsp (op: icptr);

   { Generate code for a pc_csp					}
   {								}
   { parameters:						}
   {    op - operation						}

   var
      lLong: longType;			   {used to reserve gLong}

   begin {GenCsp}
   lLong := gLong;
   gLong.preference := onStack;
   GenTree(op^.left);
   gLong := lLong;
   case op^.q of
      otherwise:
	 Error(cge1);
      1, {get from a file}
      2, {put to a file}
      3, {open}
      4, {close}
      5, {read an integer}
      6, {read a real}
      7, {read a character from a file}
      8, {write a character to a file}
      9, {write an integer to a file}
      10, {write real to a file}
      11, {new}
      13, {readln}
      14, {write an end of line}
      15, {write a form feed}
      17, {dispose}
      26, {writeln to stout}
      27, {writeln to errout}
      35, {clear an area of memory}
      44, {seek a file record}
      45, {write a string}
      46, {write a boolean}
      48, {eof(f)}
      49, {eoln(f)}
      58, {read character from input}
      59, {read int from input}
      60, {readln(input)}
      61, {read real from input}
      62, {write real to output}
     185, {eof(input)}
     186: {eoln(input)}
	 GenCall(op^.q);
      12: {writeln string}
	 GenCall(155);
      19: {write string}
	 GenCall(153);
      22: {writeln string to error out}
	 GenCall(156);
      23: {write string to error out}
	 GenCall(154);
      16,34,42,43: begin {variations on write integer}
	 GenNative(m_pea, immediate, ord((op^.q=34) or (op^.q=43)), nil, 0);
	 GenNative(m_pea, immediate, ord(op^.q>=42), nil, 0);
	 GenCall(21);
	 end;
      20,21,24,25: begin {variations on write constant string}
	GenNative(m_pea, immediate, ord(not odd(op^.q)), nil, 0);
	GenNative(m_pea, immediate, ord(op^.q>=24), nil, 0);
	GenCall(19);
	end;
      28,29,30,31: begin {variations on write boolean}
	GenNative(m_pea, immediate, ord(not odd(op^.q)), nil, 0);
	GenNative(m_pea, immediate, ord(op^.q>=30), nil, 0);
	GenCall(20);
	end;
      32: begin {form feed to standard out}
	GenNative(m_pea, immediate, 12, nil, 0);
	GenCall(151);
	end;
      33: begin {form feed to error out}
	GenNative(m_pea, immediate, 12, nil, 0);
	GenCall(152);
	end;
      36,37,38,39: begin {variations on write character}
	GenNative(m_pea, immediate, ord(not odd(op^.q)), nil, 0);
	GenNative(m_pea, immediate, ord(op^.q>=38), nil, 0);
	GenCall(22);
	end;
      40,41: {write a single character}
	GenCall(151+op^.q-40);
      50:
	GenCall(109);
      51, {pack}
      52: {unpack}
	GenCall(op^.q+74);
      53: {write real to error out}
	GenCall(128);
      66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,82,85,
      86,87,88,90,91,92,93:
	GenCall(op^.q+25);
      81, {cnvsl}
      83: {random int and longint} begin
	GenCall(op^.q+25);
	if op^.optype = cgLong then
	  if (gLong.preference & A_X) = 0 then begin
	    gLong.where := onStack;
	    GenImplied(m_phx);
	    GenImplied(m_pha);
	    end
	  else
	    gLong.where := A_X;
	end;
      84:
	GenCall(79);
      95: {nop};
      96, {new open record}
      97: {dispose open record}
	GenCall(op^.q+35);
      98, {read long from stin}
      99: {read long from file} begin
	GenCall(op^.q+42);
	gLong.where := onStack;
	end;
      102: {write long to file}
	GenCall(144);
      100, {write long to stout}
      101: {write long to errout} begin
	GenNative(m_pea, immediate, 0, nil, 0);
	GenNative(m_pea, immediate, ord(odd(op^.q)), nil, 0);
	GenCall(143);
	end;
      115: {redirect input/output}
	GenCall(148);
      116: {four-byte new}
	GenCall(180);
      117: {Member}
        GenCall(181);
      118: {NewObject}
        GenCall(182);
      119,120: begin {FixString}
        GenCall(op^.q + 64);
	gLong.where := onStack;
        end;
      end; {case}
   end; {GenCsp}


   procedure GenCui (op: icptr);

   { Generate code for a pc_cui					}

   var
      lab1: integer;			{return point}
      lLong: longType;			{used to reserve gLong}

   begin {GenCui}
   {generate parameters}
   lLong := gLong;			{place the operands on the stack}
   GenTree(op^.right);
   gLong.preference := onStack;		{get the address to call}
   GenTree(op^.left^.left);
   gLong := lLong;

   lab1 := GenLabel;			{create a return label}
   GenNative(m_lda_s, direct, 1, nil, 0); {place the call/return addrs on stack}
   GenImplied(m_dea);
   GenImplied(m_pha);
   GenNative(m_sep, immediate, 32, nil, 0);
   GenNative(m_lda_s, direct, 5, nil, 0);
   GenNative(m_sta_s, direct, 3, nil, 0);
   GenNative(m_lda_imm, genAddress, lab1, nil, shift16);
   GenNative(m_sta_s, direct, 6, nil, 0);
   GenNative(m_rep, immediate, 32, nil, 0);
   GenNative(m_lda_imm, genAddress, lab1, nil, sub1);
   GenNative(m_sta_s, direct, 4, nil, 0);

   GenTree(op^.left^.right);		{get the static level}
   GenImplied(m_tax);

   GenImplied(m_rtl);			{indirect call}
   GenLab(lab1);

   gLong.where := A_X;			{save the returned value}
   SaveRetValue(op^.optype);
   end; {GenCui}


   procedure GenCum (op: icptr);

   { Generate code for a pc_cum					}

   var
      lab1, lab2: integer;		{return point; jsl patch location}
      sDisp: unsigned;			{size of the parameters}


      function Size (op: icptr): unsigned;

      { Find the length of the parameters in the tree		}
      {								}
      { parameters:						}
      {    op - tree to scan					}
      {								}
      { returns: Length of the parameters			}

      begin {Size}
      if op^.opcode = pc_bno then
         Size := Size(op^.left) + Size(op^.right)
      else if op^.opcode = pc_stk then
         case op^.optype of
	    cgByte,cgUByte,cgWord,cgUWord: Size := cgWordSize;
            cgLong,cgULong,cgString,cgVoid: Size := cgLongSize;
	    cgReal,cgDouble,cgComp,cgExtended: Size := cgExtendedSize;
	    cgSet: Size := op^.left^.q;
            end {case}
      else
         Size := 0;
      end; {Size}


   begin {GenCum}
   {generate parameters}
   sDisp := Size(op^.left);		{find the disp of the SELF parm}
   GenTree(op^.left);			{place the operands on the stack}

   lab1 := GenLabel;			{create a return/jsl label}
   if jslOptimizations then begin

      {use self-modifying code for an indirect call}
      lab2 := GenLabel;
      GenImplied(m_phd);
      GenImplied(m_tsc);
      GenImplied(m_tcd);
      GenNative(m_ldy_imm, immediate, long(op^.lval).lsw + 1, nil, 0);
      GenNative(m_lda_indly, direct, sDisp - 1, nil, 0);
      GenNative(m_sta_long, longAbs, lab2, nil, 0);
      GenImplied(m_dey);
      GenNative(m_lda_indly, direct, sDisp - 1, nil, 0);
      GenNative(m_sta_long, longAbs, lab1, nil, 0);
      GenImplied(m_pld);
      GenImplied(m_jsl);
      GenLab(lab1);
      GenImplied(m_jsl);
      GenLab(lab2);
      GenImplied(m_jsl);
      GenImplied(m_jsl);
      end {if}        
   else begin

      {do a ROMable indirect call}

      {place the return addr on the stack}
      GenImplied(m_phk);
      GenNative(m_lda_imm, genAddress, lab1, nil, sub1);
      GenImplied(m_pha);

      {get the address to call}
      if op^.lval < maxint-2 then begin
	 GenNative(m_lda_s, direct, sDisp+2, nil, 0);
	 GenNative(m_sta_dir, direct, dWorkLoc+2, nil, 0);
	 GenNative(m_lda_s, direct, sDisp, nil, 0);
	 GenNative(m_sta_dir, direct, dWorkLoc, nil, 0);
	 GenNative(m_ldy_imm, immediate, long(op^.lval).lsw+2, nil, 0);
	 GenNative(m_sep, immediate, 32, nil, 0);
	 GenNative(m_lda_indly, direct, dWorkLoc, nil, 0);
	 GenImplied(m_pha);
	 GenNative(m_rep, immediate, 32, nil, 0);
	 GenNative(m_ldy_imm, immediate, long(op^.lval).lsw, nil, 0);
	 GenNative(m_lda_indly, direct, dWorkLoc, nil, 0);
	 GenImplied(m_dea);
	 GenImplied(m_pha);
	 end {if}
      else begin
	 GenImplied(m_clc);
	 GenNative(m_lda_s, direct, sDisp, nil, 0);
	 GenNative(m_adc_imm, immediate, long(op^.lval).lsw, nil, 0);
	 GenNative(m_sta_dir, direct, dWorkLoc, nil, 0);
	 GenNative(m_lda_s, direct, sDisp+2, nil, 0);
	 GenNative(m_adc_imm, immediate, long(op^.lval).msw, nil, 0);
	 GenNative(m_sta_dir, direct, dWorkLoc+2, nil, 0);
	 GenNative(m_ldy_imm, immediate, 2, nil, 0);
	 GenNative(m_sep, immediate, 32, nil, 0);
	 GenNative(m_lda_indly, direct, dWorkLoc, nil, 0);
	 GenImplied(m_pha);
	 GenNative(m_rep, immediate, 32, nil, 0);
	 GenNative(m_lda_indl, direct, dWorkLoc, nil, 0);
	 GenImplied(m_pha);
	 end; {else}

      {indirect call}
      GenImplied(m_rtl);
      GenLab(lab1);
      end; {else}

   gLong.where := A_X;			{save the returned value}
   SaveRetValue(op^.optype);
   end; {GenCum}


   procedure GenCup (op: icptr);

   { Generate code for a pc_cup					}

   var
      lLong: longType;			   {used to reserve gLong}

   begin {GenCup}
   {generate parameters}
   lLong := gLong;
   GenTree(op^.left);
   gLong := lLong;

   {create the static link}
   if (op^.lab = nil) or (not noGlobalLabels) then begin
      if op^.q = 0 then begin
	 GenImplied(m_tdc);
	 GenImplied(m_tax);
	 end {if}
      else
	 StaticLink(op^.q, false, false);
      end; {if}

   {generate the jsl}
   if op^.lab = nil then
      GenNative(m_jsl, longAbs, op^.r, nil, 0)
   else   
      GenNative(m_jsl, longAbs, 0, op^.lab, 0);

   {save the returned value}
   gLong.where := A_X;
   SaveRetValue(op^.optype);
   end; {GenCup}


   procedure GenDifIntUni (op: icptr);

   { Generate code for a pc_dif, pc_int, pc_uni			}

   var
      snum: integer;			{call number}

   begin {GenDifIntUni}
   GenTree(op^.left);
   GenTree(op^.right);
   case op^.opcode of
      pc_dif: snum := 38;
      pc_int: snum := 39;
      pc_uni: snum := 40;
      end; {case}
   GenCall(snum);
   end; {GenDifIntUni}


   procedure GenDviMod (op: icptr);

   { Generate code for a pc_dvi, pc_mod, pc_udi or pc_uim	}

   var
      opcode: pcodes;			{temp storage}

   begin {GenDviMod}
   if Complex(op^.right) then begin
      GenTree(op^.right);
      if Complex(op^.left) then begin
	 GenImplied(m_pha);
	 GenTree(op^.left);
	 GenImplied(m_plx);
	 end {if}
      else begin
	 GenImplied(m_tax);
	 GenTree(op^.left);
	 end; {else}
      end {if}
   else begin
      GenTree(op^.left);
      LoadX(op^.right);
      end; {else}
   opcode := op^.opcode;
   if opcode = pc_mod then
      GenCall(124)
   else if opcode = pc_dvi then
      GenCall(41)
   else {if opcode in [pc_udi,pc_uim] then} begin
      GenCall(165);
      if opcode = pc_uim then
	 GenImplied(m_txa);
      end; {else}
   if rangeCheck then
      GenCall(147);
   end; {GenDviMod}


   procedure GenEnt;

   { Generate code for a pc_ent					}

   begin {GenEnt}
   if rangeCheck then begin		{if range checking is on, check for a stack overflow}
      GenNative(m_pea, immediate, localSize - returnSize - 1, nil, 0);
      GenCall(129);
      end; {if}

   if localSize = 0 then begin		{create the stack frame}
      if parameterSize <> 0 then begin
	 GenImplied(m_tsc);
	 GenImplied(m_phd);
	 GenImplied(m_tcd);
	 end; {if}
      end {if}
   else if localSize = 2 then begin
      GenImplied(m_phx);
      GenImplied(m_tsc);
      GenImplied(m_phd);
      GenImplied(m_tcd);
      end {else if}
   else begin
      GenImplied(m_tsc);
      GenImplied(m_sec);
      GenNative(m_sbc_imm, immediate, localSize, nil, 0);
      GenImplied(m_tcs);
      GenImplied(m_phd);
      GenImplied(m_tcd);
      end; {if}

   if staticLoc <> 0 then		{set up the static link}
      if localSize <> 2 then
         GenNative(m_stx_dir, direct, staticLoc, nil, 0);

   if dataBank then begin		{preserve and set data bank}
      GenImplied(m_phb);
      GenImplied(m_phb);
      GenImplied(m_pla);
      GenNative(m_sta_dir, direct, bankLoc, nil, 0);
      GenNative(m_pea, immediate, 0, @'~GLOBALS', shift8);
      GenImplied(m_plb);
      GenImplied(m_plb);
      end; {if}

   {no pc_nam (yet)}
   namePushed := false;
   end; {GenEnt}


   procedure GenFix (op: icptr);

   { Generate code for a pc_fix					}

   begin {GenFix}
   GenNative(m_pea, immediate, localLabel[op^.q], nil, 0);
   if op^.optype = cgReal then
      GenCall(83)
   else if op^.optype = cgDouble then
      GenCall(86)
   else if op^.optype = cgComp then
      GenCall(178)
   end; {GenFix}


   procedure GenFjpTjp (op: icptr);

   { Generate code for a pc_fjp or pc_tjp			}

   var
      lab1: integer;			{branch point}
      opcode: pcodes;			{op^.left^.opcode}

   begin {GenFjpTjp}
   if op^.left^.opcode in [pc_equ,pc_geq,pc_grt,pc_les,pc_leq,pc_neq] then
      if op^.left^.opcode in [pc_equ,pc_neq] then
	 GenEquNeq(op^.left, op^.opcode, op^.q)
      else
	 GenCmp(op^.left, op^.opcode, op^.q)
   else begin
      lab1 := GenLabel;
      GenTree(op^.left);
      opcode := op^.left^.opcode;
      if NeedsCondition(opcode) then
	 GenImplied(m_tax)
      else if opcode = pc_ind then
         if op^.left^.optype in [cgByte,cgUByte] then
	    GenImplied(m_tax);
      if op^.opcode = pc_fjp then                    
	 GenNative(m_bne, relative, lab1, nil, 0)
      else {if op^.opcode = pc_tjp then}
	 GenNative(m_beq, relative, lab1, nil, 0);
      GenNative(m_brl, longrelative, op^.q, nil, 0);
      GenLab(lab1);
      end; {else}
   end; {GenFjpTjp}


   procedure GenInn (op: icptr);

   { Generate code for a pc_inn					}

   label 1;

   const
      maxCard = 8;			{largest constant set cardinality to
					 use branches on}

   var
      lab1: integer;			{branch label}
      i,j: integer;			{loop counters}
      byte: integer;			{one byte of the set array}
      card: integer;			{cardinality of the set}
      constants: array[1..maxCard] of integer; {ord of set elements}
      done: boolean;			{used to see if the operation is done}
      lop: pcodes;			{op code of top of set tree}

   begin {GenInn}
   done := false;
   GenTree(op^.left);
   lop := op^.right^.opcode;
   if lop = pc_ldc then
      with op^.right^.setp^ do begin
	 card := 0;
	 for i := 1 to smax do begin
	    byte := ord(sval[i]);
	    if byte <> 0 then
	       for j := 0 to 7 do begin
		  if odd(byte) then begin
		     if card = maxCard then
			goto 1;
		     card := card+1;
		     constants[card] := (i-1)*8+j;
		     end; {if}
		  byte := byte >> 1;
		  end; {for}
	    end; {for}
	 lab1 := GenLabel;
	 GenNative(m_ldx_imm, immediate, 1, nil, 0);
	 for i := 1 to card do begin
	    GenNative(m_cmp_imm, immediate, constants[i], nil, 0);
	    GenNative(m_beq, relative, lab1, nil, 0);
	    end; {for}
	 GenImplied(m_dex);
	 GenLab(lab1);
	 GenImplied(m_txa);
	 done := true;
	 end; {with}
1: if not done then begin
      GenImplied(m_pha);
      if lop = pc_ldo then begin
	 with op^.right^ do begin
	    GenNative(m_pea, immediate, r, lab, shift16);
	    GenNative(m_pea, immediate, r, lab, 0);
	    GenNative(m_pea, immediate, q, nil, 0);
	    GenCall(130);
	    end; {with}
	 end {if}
      else if lop = pc_lod then begin
	 with op^.right^ do begin
	    GenNative(m_pea, immediate, 0, nil, 0);
	    if p = 0 then
	       GenImplied(m_tdc)
	    else
	       StaticLink(p, false, true);
	    GenImplied(m_clc);
	    GenNative(m_adc_imm, immediate, localLabel[r]+q, nil, 0);
	    GenImplied(m_pha);
	    GenNative(m_pea, immediate, s, nil, 0);
	    GenCall(130);
	    end; {with}
	 end{else if}
      else begin
	 GenTree(op^.right);
	 GenCall(42);
	 end; {else}
      end; {if}
   end; {GenInn}


   procedure GenLaoLad (op: icptr);

   { Generate code for a pc_lao, pc_lad				}

   var
      q: integer;			{displacement}

   begin {GenLaoLad}
   if op^.opcode = pc_lad then
      q := 0
   else
      q := op^.q;
   if (globalLabel & gLong.preference) <> 0 then begin
      gLong.fixedDisp := true;
      gLong.where := globalLabel;
      gLong.disp := q;
      gLong.lab := op^.lab;
      end {if}
   else if (A_X & gLong.preference) <> 0 then begin
      gLong.where := A_X;
      GenNative(m_ldx_imm, immediate, q, op^.lab, shift16);
      GenNative(m_lda_imm, immediate, q, op^.lab, 0);
      end {else if}
   else begin
      gLong.where := onStack;
      GenNative(m_pea, immediate, q, op^.lab, shift16);
      GenNative(m_pea, immediate, q, op^.lab, 0);
      end; {else}
   end; {GenLaoLad}


   procedure GenLca (op: icptr);

   { Generate code for a pc_lca					}

   var
      i: integer;			{loop/index variable}
      len: unsigned;			{string length}

   begin {GenLca}
   gLong.where := onStack;
   GenNative(m_pea, immediate, stringSize, nil, stringReference+shift16);
   GenNative(m_pea, immediate, stringSize, nil, stringReference);
   len := op^.q;
   if maxString-stringSize >= len then begin
      for i := 1 to op^.q do
	 stringSpace[i+stringSize] := op^.str^[i];
      stringSize := stringSize+len;
      end
   else
      Error(cge3);
   op^.optype := cgULong;
   end; {GenLca}


   procedure GenLda (op: icptr);

   { Generate code for a pc_lda					}

   begin {GenLda}
   if ((localAddress & gLong.preference) <> 0) and (op^.p = 0) then begin
      gLong.fixedDisp := true;
      gLong.where := localAddress;
      gLong.disp := localLabel[op^.s] + op^.q;
      end {if}
   else if (A_X & gLong.preference) <> 0 then begin
      gLong.where := A_X;
      if op^.p = 0 then
	 GenImplied(m_tdc)
      else
	 StaticLink(op^.p, false, true);
      GenImplied(m_clc);
      GenNative(m_adc_imm, immediate, localLabel[op^.s] + op^.q, nil, 0);
      GenNative(m_ldx_imm, immediate, 0, nil, 0);
      end {else if}
   else begin
      gLong.where := onStack;
      GenNative(m_pea, immediate, 0, nil, 0);
      if op^.p = 0 then
	 GenImplied(m_tdc)
      else
	 StaticLink(op^.p, false, true);
      GenImplied(m_clc);
      GenNative(m_adc_imm, immediate, localLabel[op^.s] + op^.q, nil, 0);
      GenImplied(m_pha);
      end; {else}
   end; {GenLda}


   procedure GenLdc (op: icptr);

   { Generate code for a pc_ldc					}

   type
      kind = (vint, vbyte, vreal);	{kinds of equivalenced data}

   var
      i: unsigned;			{loop/index variable}
      rec: realrec;			{conversion record}
      switch: packed record		{used for type conversion}
	 case rkind: kind of
	    vint: (i: integer);
	    vbyte: (b1, b2, b3, b4, b5, b6, b7, b8: byte);
	    vreal: (r: double);
	 end;

   begin {GenLdc}
   case op^.optype of
      cgByte: begin
	 if op^.q > 127 then
	    op^.q := op^.q | $FF00;
	 GenNative(m_lda_imm, immediate, op^.q, nil, 0);
	 end;

      cgUByte, cgWord, cgUWord:
	 GenNative(m_lda_imm, immediate, op^.q, nil, 0);

      cgReal, cgDouble, cgComp, cgExtended: begin
	 rec.itsReal := op^.rval;
	 CnvSX(rec);
	 i := 10;
	 while i <> 0 do begin
	    switch.b1 := rec.inSANE[i-1];
	    switch.b2 := rec.inSANE[i];
	    GenNative(m_pea, immediate, switch.i, nil, 0);
	    i := i-2;
	    end; {while}
	 end;

      cgLong, cgULong:
	 if (constant & gLong.preference) <> 0 then begin
	    gLong.where := constant;
	    gLong.lval := op^.lval;
	    end
	 else if (A_X & gLong.preference) <> 0 then begin
	    gLong.where := A_X;
	    GenNative(m_lda_imm, immediate, long(op^.lval).lsw, nil, 0);
	    GenNative(m_ldx_imm, immediate, long(op^.lval).msw, nil, 0);
	    end
	 else begin
	    gLong.where := onStack;
	    GenNative(m_pea, immediate, long(op^.lval).msw, nil, 0);
	    GenNative(m_pea, immediate, long(op^.lval).lsw, nil, 0);
	    end;

      cgSet: begin
	 with op^.setp^ do begin
	    if odd(smax) then begin
	      smax := smax+1;
	      sval[smax] := chr(0);
	      end; {if}
	    i := smax;
	    while i <> 0 do begin
	       switch.b1 := ord(sval[i-1]);
	       switch.b2 := ord(sval[i]);
	       GenNative(m_pea, immediate, switch.i, nil, 0);
	       i := i-2;
	       end; {while}
	    GenNative(m_pea, immediate, smax, nil, 0);
	    end; {with}     
	 end;

      otherwise:
	 Error(cge1);
      end; {case}
   end; {GenLdc}     


   procedure GenLdo (op: icptr);

   { Generate code for a pc_ldo					}

   var
      i: unsigned;			{set size}
      lab1: unsigned;			{branch point}

   begin {GenLdo}
   case op^.optype of
      cgWord, cgUWord:
	 if smallMemoryModel then
	    GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0)
	 else
	    GenNative(m_lda_long, longAbs, op^.q, op^.lab, 0);

      cgByte, cgUByte: begin
	 if smallMemoryModel then
	    GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0)
	 else
	    GenNative(m_lda_long, longAbs, op^.q, op^.lab, 0);
	 GenNative(m_and_imm, immediate, 255, nil, 0);
	 if op^.optype = cgByte then begin
	    GenNative(m_bit_imm, immediate, $0080, nil, 0);
	    lab1 := GenLabel;
	    GenNative(m_beq, relative, lab1, nil, 0);
	    GenNative(m_ora_imm, immediate, $FF00, nil, 0);
	    GenLab(lab1);
	    GenNative(m_cmp_imm, immediate, $0000, nil, 0);
	    end; {if}
	 end;

      cgReal, cgDouble, cgComp, cgExtended: begin
	 GenNative(m_pea, immediate, op^.q, op^.lab, shift16);
	 GenNative(m_pea, immediate, op^.q, op^.lab, 0);
	 if op^.optype = cgReal then
	    GenCall(25)
	 else if op^.optype = cgDouble then
	    GenCall(18)
	 else if op^.optype = cgComp then
	    GenCall(163)
	 else {if op^.optype = cgExtended then}
	    GenCall(164);
	 end;

      cgLong, cgULong: begin
	 if (A_X & gLong.preference) <> 0 then
	    gLong.where := A_X
	 else
	    gLong.where := onStack;
	 if smallMemoryModel then begin
	    GenNative(m_ldx_abs, absolute, op^.q+2, op^.lab, 0);
	    GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0);
	    if gLong.where = onStack then begin
	       GenImplied(m_phx);
	       GenImplied(m_pha);
	       end; {if}
	    end {if}
	 else begin
	    GenNative(m_lda_long, longabsolute, op^.q+2, op^.lab, 0);
	    if gLong.where = onStack then
	       GenImplied(m_pha)
	    else
	       GenImplied(m_tax);
	    GenNative(m_lda_long, longabsolute, op^.q, op^.lab, 0);
	    if gLong.where = onStack then
	       GenImplied(m_pha);
	    end; {else}
	 end; {case cgLong,cgULong}

      cgSet: begin
	 if op^.q <= 8 then begin
	    i := op^.q;
	    if odd(i) then begin
	       i := i-1;
	       GenNative(m_sep, immediate, 32, nil, 0);
	       GenNative(m_lda_abs, absolute, op^.r+i, op^.lab, 0);
	       GenImplied(m_pha);
	       GenNative(m_rep, immediate, 32, nil, 0);
	       end; {if}
	    while i <> 0 do begin
	       i := i-2;
	       GenNative(m_lda_abs, absolute, op^.r+i, op^.lab, 0);
	       GenImplied(m_pha);
	       end; {while}
	    GenNative(m_pea, immediate, op^.q, nil, 0);
	    end {if}
	 else begin
	    GenNative(m_pea, immediate, op^.r, op^.lab, shift16);
	    GenNative(m_pea, immediate, op^.r, op^.lab, 0);
	    GenNative(m_pea, immediate, op^.q, nil,0);
	    GenCall(28);
	    end; {else}
	 end; {case cgSet}

      otherwise:
	 Error(cge1);
      end; {case}
   end; {GenLdo}


   procedure GenLla (op: icptr);

   { Generate code for a pc_lla					}

   begin {GenLla}
   gLong.where := onStack;
   GenNative(m_pea, genAddress, op^.q, nil, shift16);
   GenNative(m_pea, genAddress, op^.q, nil, 0);
   end; {GenLla}


   procedure GenLnm (op: icptr);

   { Generate code for a pc_lnm					}

   begin {GenLnm}
   if op^.left <> nil then
      GenTree(op^.left);
   if traceBack then begin
      GenNative(m_pea, immediate, op^.r, nil, 0);
      GenCall(75);
      end; {if}
   if debugFlag then begin
      GenNative(m_cop, immediate, op^.q, nil, 0);
      GenNative(d_wrd, special, op^.r, nil, 0);
      end; {if}
   end; {GenLnm}


   procedure GenLod (op: icptr);

   { Generate code for a pc_lod					}

   var
      disp: integer;			{load location}
      i: unsigned;			{loop/index variable}
      lab1: unsigned;			{branch point}
      optype: baseTypeEnum;		{op^.optype}

   begin {GenLod}
   disp := localLabel[op^.r] + op^.q;
   optype := op^.optype;
   case optype of
      cgReal, cgDouble, cgComp, cgExtended: begin
	 GenNative(m_pea, immediate, 0, nil, 0);
	 if op^.p = 0 then
	    GenImplied(m_tdc)
	 else
	    StaticLink(op^.p, false, true);
	 GenImplied(m_clc);
	 GenNative(m_adc_imm, immediate, disp, nil, 0);
	 GenImplied(m_pha);
	 if optype = cgReal then
	    GenCall(25)
	 else if optype = cgDouble then
	    GenCall(18)
	 else if optype = cgComp then
	    GenCall(163)
	 else {if optype = cgExtended then}
	    GenCall(164);
	 end;

      cgLong, cgULong: begin
	 if op^.p <> 0 then begin
	    gLong.where := onStack;
	    StaticLink(op^.p, false, false);
	    GenNative(m_lda_longx, longabsolute, disp+2, nil, 0);
	    GenImplied(m_pha);
	    GenNative(m_lda_longx, longabsolute, disp, nil, 0);
	    GenImplied(m_pha);
	    end {if}
         else if ((inPointer & gLong.preference) <> 0) and (disp < 254) then
	    begin
	    gLong.where := inPointer;
	    gLong.fixedDisp := true;
	    gLong.disp := disp;
	    end {else if}
	 else if ((A_X & gLong.preference) <> 0) and (disp < 254) then begin
	    gLong.where := A_X;
	    GenNative(m_ldx_dir, direct, disp+2, nil, 0);
	    GenNative(m_lda_dir, direct, disp, nil, 0);
	    end {else if}
	 else begin
	    gLong.where := onStack;
	    if disp >= 254 then begin
	       GenNative(m_ldx_imm, immediate, disp, nil, 0);
	       GenNative(m_lda_dirx, direct, 2, nil, 0);
	       GenImplied(m_pha);
	       GenNative(m_lda_dirx, direct, 0, nil, 0);
	       GenImplied(m_pha);
	       end {if}
	    else begin
	       GenNative(m_pei_dir, direct, disp+2, nil, 0);
	       GenNative(m_pei_dir, direct, disp, nil, 0);
	       end; {else}
	    end; {else}
	 end;

      cgByte, cgUByte, cgWord, cgUWord: begin
         if op^.p <> 0 then begin
	    StaticLink(op^.p, false, false);
	    GenNative(m_lda_longx, longabsolute, disp, nil, 0);
            end {if}
	 else if disp >= 256 then begin
	    GenNative(m_ldx_imm, immediate, disp, nil, 0);
	    GenNative(m_lda_dirx, direct, 0, nil, 0);
	    end {else if}
	 else
	    GenNative(m_lda_dir, direct, disp, nil, 0);
	 if optype in [cgByte,cgUByte] then begin
	    GenNative(m_and_imm, immediate, $00FF, nil, 0);
	    if optype = cgByte then begin
	       GenNative(m_bit_imm, immediate, $0080, nil, 0);
	       lab1 := GenLabel;
	       GenNative(m_beq, relative, lab1, nil, 0);
	       GenNative(m_ora_imm, immediate, $FF00, nil, 0);
	       GenLab(lab1);
	       GenNative(m_cmp_imm, immediate, $0000, nil, 0);
	       end; {if}
	    end;
	 end;

      cgSet:
	 if (op^.p = 0) and (disp < 248) and (op^.s <= 8) then begin
	    i := op^.s;
	    if odd(i) then begin
	       i := i-1;
	       GenNative(m_sep, immediate, 32, nil, 0);
	       GenNative(m_lda_dir, direct, disp+i, nil, 0);
	       GenImplied(m_pha);
	       GenNative(m_rep, immediate, 32, nil, 0);
	       end; {if}
	    while i <> 0 do begin
	       i := i-2;
	       GenNative(m_pei_dir, direct, disp+i, nil, 0);
	       end; {end}
	    GenNative(m_pea, immediate, op^.s, nil, 0);
	    end {if}
	 else begin
	    GenNative(m_pea, immediate, 0, nil, 0);
	    if op^.p = 0 then
	       GenImplied(m_tdc)
	    else
	       StaticLink(op^.p, false, true);
	    GenImplied(m_clc);
	    GenNative(m_adc_imm, immediate, disp, nil, 0);
	    GenImplied(m_pha);
	    GenNative(m_pea, immediate, op^.s, nil, 0);
	    GenCall(28);
	    end; {else}

      otherwise:
	 Error(cge1);

      end; {case}
   end; {GenLod}


   procedure GenLsl (op: icptr);

   { Generate code for a pc_lsl					}
   
   begin {GenLsl}
   if op^.q = 0 then
      GenImplied(m_tdc)
   else
      StaticLink(op^.q, false, true);
   end; {GenLsl}


   procedure GenMov (op: icptr; duplicate: boolean);

   { Generate code for a pc_mov					}
   {								}
   { parameters:						}
   {    op - pc_mov instruction					}
   {    duplicate - should the source address be left on the	}
   {       stack?						}

   var
      banks: integer;			{number of banks to move}


      procedure Load (opcode: integer; op: icptr);

      { generate a load immediate based on instruction type	}
      {								}
      { parameters:						}
      {    opcode - native code load operation			}
      {    op - node to load					}

      var
	 i: integer;

      begin {Load}
      if op^.opcode = pc_lao then
         GenNative(opcode, immediate, op^.q, op^.lab, 0)
      else begin
         GenNative(opcode, immediate, stringsize, nil, StringReference);
         if maxstring-stringsize >= op^.q then begin
            for i := 1 to op^.q do
               stringspace[i+stringsize] := op^.str^[i];
            stringsize := stringsize + op^.q;
            end {if}
         else
            Error(cge3);
         end; {else}
      end; {Load}


   begin {GenMov}
   {determine if the destination address must be left on the stack}
   if smallMemoryModel
      and (not duplicate)
      and (op^.left^.opcode in [pc_lao,pc_lca])
      and (op^.right^.opcode in [pc_lao,pc_lca]) then begin

      {take advantage of any available short cuts}
      Load(m_ldy_imm, op^.left);
      Load(m_ldx_imm, op^.right);
      GenNative(m_lda_imm, immediate, op^.q-1, nil, 0);
      GenImplied(m_phb);
      GenImplied(m_mvn);
      with op^.left^ do
	 if opcode = pc_lao then
            GenNative(d_bmov, immediate, q, lab, shift16)
	 else
            GenNative(d_bmov, immediate, 0, nil, stringReference+shift16);
      with op^.right^ do
	 if opcode = pc_lao then
            GenNative(d_bmov, immediate, q, lab, shift16)
	 else
            GenNative(d_bmov, immediate, 0, nil, stringReference+shift16);
      GenImplied(m_plb);
      end {if}
   else begin

      {no short cuts are available - do it the hard way}
      gLong.preference := onStack;
      GenTree(op^.left);
      gLong.preference := onStack;
      GenTree(op^.right);
      banks := op^.r;
      if banks <> 0 then
	 GenNative(m_pea, immediate, banks, nil, 0);
      GenNative(m_pea, immediate, op^.q, nil, 0);
      if banks = 0 then begin
	 if duplicate then
            GenCall(167)
	 else
            GenCall(80);
	 end {if}
      else
	 if duplicate then
            GenCall(169)
	 else
            GenCall(168);
      end; {else}
   end; {GenMov}


   procedure GenMpi (op: icptr);

   { Generate code for a pc_mpi or pc_umi			}
   
   var
      nd: icptr;

   begin {GenMpi}
   if not Complex(op^.left) then
      if Complex(op^.right) then begin
	 nd := op^.left;
	 op^.left := op^.right;
	 op^.right := nd;
	 end; {if}
   GenTree(op^.left);
   if Complex(op^.right) then begin
      GenImplied(m_pha);
      GenTree(op^.right);
      GenImplied(m_plx);
      end {if}
   else
      LoadX(op^.right);
   if op^.opcode = pc_mpi then
      GenCall(32)
   else {pc_umi}
      GenCall(142);
   if rangeCheck then
      GenCall(147);
   end; {GenMpi}


   procedure GenNam (op: icptr);                    

   { Generate code for a pc_nam					}

   var
      i: integer;			{loop/index variable}
      len: integer;			{length of the file name}


      function ToUpper (ch: char): char;

      { Return the uppercase equivalent of the input character	}

      begin {ToUpper}
      if (ch >= 'a') and (ch <= 'z') then
	 ch := chr(ord(ch)-ord('a')+ord('A'));
      ToUpper := ch;
      end; {ToUpper}


   begin {GenNam}
   {generate a call to install the name in the traceback facility}
   if traceBack then begin
      GenNative(m_pea, immediate, stringSize, nil, stringReference+shift16);
      GenNative(m_pea, immediate, stringSize, nil, stringReference);
      GenCall(76);
      namePushed := true;
      end; {if}

   {send the name to the profiler}
   if profileFlag then begin
      GenNative(m_cop, immediate, 3, nil, 0);
      GenNative(d_add, genaddress, stringSize, nil, stringReference);
      GenNative(d_add, genaddress, stringSize, nil, stringReference+shift16);
      end; {if}

   {place the name in the string buffer}
   len := length(op^.str^);
   if maxString-stringSize >= len+1 then begin
      stringSpace[stringSize+1] := chr(len);
      for i := 1 to len do
         stringSpace[i+stringSize+1] := op^.str^[i];
      stringSize := stringSize + len + 1;
      end {if}
   else
      Error(cge3);

   {send the file name to the debugger}
   if debugFlag then begin
      GenNative(m_cop, immediate, 6, nil, 0);
      GenNative(d_add, genaddress, stringSize, nil, stringReference);
      GenNative(d_add, genaddress, stringSize, nil, stringReference+shift16);
      len := fNameGS.theString.size;
      if len > 255 then
         len := 255;
      if maxString-stringSize >= len+1 then begin
         stringSpace[stringSize+1] := chr(len);
         for i := 1 to len do
            stringSpace[i+stringSize+1] :=
               ToUpper(fNameGS.theString.theString[i]);
         stringSize := stringSize + len + 1;
         end {if}
      else
         Error(cge3);
      end; {if}
   end; {GenNam}


   procedure GenPds (op: icptr);

   { Generate code for a pc_pds					}

   begin {GenPds}
   gLong.preference := A_X;
   GenTree(op^.left);
   if gLong.where = onStack then begin
      GenImplied(m_pla);
      GenImplied(m_plx);
      end; {if}
   GenNative(m_ldy_imm, immediate, op^.q, nil, 0);
   GenCall(47);
   end; {GenPds}


   procedure GenPrs (op: icptr);

   { Generate code for a pc_prs					}

   begin {GenPrs}
   GenNative(m_lda_dir, direct, staticLoc, nil, 0);
   GenImplied(m_tcd);
   GenImplied(m_dea);
   GenImplied(m_dea);
   GenImplied(m_tcs);
   end; {GenPrs}


   procedure GenPwr (op: icptr);

   { Generate code for a pc_pwr					}

   begin {GenPwr}
   GenTree(op^.left);
   GenTree(op^.right);
   GenCall(90);
   end; {GenPwr}


   procedure GenRealBinOp (op: icptr);

   { Generate code for a pc_adr, pc_dvr, pc_mpr, pc_sbr		}

   var
      nd: icptr;			{temp pointer}
      snum: integer;			{library subroutine numbers}
      ss,sd,sc,se: integer;		{sane call numbers}

   begin {GenRealBinOp}
   case op^.opcode of
      pc_adr: begin
	 snum := 50;
	 ss := $0200;
	 sd := $0100;
	 sc := $0500;
	 se := $0000;
	 end;

      pc_dvr: begin
	 snum := 51;
	 ss := $0206;
	 sd := $0106;
	 sc := $0506;
	 se := $0006;
	 end;

      pc_mpr: begin
	 snum := 52;
	 ss := $0204;
	 sd := $0104;
	 sc := $0504;
	 se := $0004;
	 end;

      pc_sbr: begin
	 snum := 53;
	 ss := $0202;
	 sd := $0102;
	 sc := $0502;
	 se := $0002;
	 end;
      end; {case}

   if op^.opcode in [pc_mpr,pc_adr] then
      if op^.left^.opcode in [pc_lod,pc_ldo] then begin
         nd := op^.left;
         op^.left := op^.right;
         op^.right := nd;
         end; {if}
   GenTree(op^.left);
   if (op^.right^.opcode in [pc_lod,pc_ldo]) and (floatCard = 0) then
      with op^.right^ do begin
	 if opcode = pc_lod then begin
            GenNative(m_pea, immediate, 0, nil, 0);
	    if p = 0 then
	       GenImplied(m_tdc)
	    else
	       StaticLink(p, false, true);
            GenImplied(m_clc);
            GenNative(m_adc_imm, immediate, localLabel[r] + q, nil, 0);
            GenImplied(m_pha);              
            end {if}
	 else begin
            GenNative(m_pea, immediate, q, lab, shift16);
            GenNative(m_pea, immediate, q, lab, 0);
            end; {else}
	 GenNative(m_pea, immediate, 0, nil, 0);
	 GenImplied(m_tsc);
	 GenImplied(m_clc);
	 GenNative(m_adc_imm, immediate, 7, nil, 0);
	 GenImplied(m_pha);
	 if optype = cgReal then
            sd := ss
	 else if optype = cgExtended then
            sd := se
	 else if optype = cgComp then
            sd := sc;
	 GenNative(m_pea, immediate, sd, nil, 0);
	 GenNative(m_ldx_imm, immediate, $090A, nil, 0);
	 GenNative(m_jsl, longAbs, 0, nil, toolCall);
	 end {with}
   else begin
      GenTree(op^.right);
      GenCall(snum);
      end; {else}
   end; {GenRealBinOp}


   procedure GenRealUnOp (op: icptr);

   { Generate code for a pc_sqr, pc_sqt, pc_sin, pc_cos,	}
   {    pc_atn, pc_log, pc_exp, pc_tan, pc_acs, pc_asn		}

   var
      snum: integer;

   begin {GenRealUnOp}
   GenTree(op^.left);
   case op^.opcode of
      pc_sqr: snum := 54;
      pc_sqt: snum := 55;
      pc_sin: snum := 63;
      pc_cos: snum := 64;
      pc_atn: snum := 65;
      pc_log: snum := 66;
      pc_exp: snum := 67;
      pc_tan: snum := 120;
      pc_acs: snum := 121;
      pc_asn: snum := 122;
      end; {case}
   GenCall(snum);
   end; {GenRealUnOp}


   procedure GenRet (op: icptr);

   { Generate code for a pc_ret					}

   var
      size: integer;			{localSize + parameterSize}

   begin {GenRet}
   {pop the name record}
   if namePushed then
      GenCall(77);

   {generate an exit code for the debugger's benefit}
   if debugFlag then
      GenNative(m_cop, immediate, 4, nil, 0);

   {if anything needs to be removed from the stack, move the return val}
   size := localSize + parameterSize;
   if parameterSize <> 0 then begin
      if localSize > 254 then begin
	 GenNative(m_ldx_imm, immediate, localSize+1, nil, 0);
	 GenNative(m_lda_dirx, direct, 0, nil, 0);
	 GenNative(m_ldy_dirx, direct, 1, nil, 0);
	 GenNative(m_ldx_imm, immediate,
	    localSize+parameterSize+1, nil, 0);
	 GenNative(m_sta_dirx, direct, 0, nil, 0);
	 GenNative(m_sty_dirx, direct, 1, nil, 0);
	 end {if}
      else begin
	 GenNative(m_lda_dir, direct, localSize+2, nil, 0);
	 if localSize+parameterSize > 254 then begin
	    GenNative(m_ldx_imm, immediate,
	       localSize+parameterSize+1, nil, 0);
	    GenNative(m_sta_dirx, direct, 1, nil, 0);
	    GenNative(m_lda_dir, direct, localSize+1, nil, 0);
	    GenNative(m_sta_dirx, direct, 0, nil, 0);
	    end {if}
	 else begin
	    GenNative(m_sta_dir, direct,
	       localSize+parameterSize+2, nil, 0);
	    GenNative(m_lda_dir, direct, localSize+1, nil, 0);
	    GenNative(m_sta_dir, direct,
	       localSize+parameterSize+1, nil, 0);
	    end; {else}
	 end; {else}
      end; {if}

   {load the value to return}
   case op^.optype of

      cgVoid: ;

      cgByte,cgUByte: begin
	 GenNative(m_lda_dir, direct, funLoc, nil, 0);
	 GenNative(m_and_imm, immediate, $00FF, nil, 0);
	 if size <> 2 then
	    GenImplied(m_tay);
	 end;

      cgWord,cgUWord:
	 if size = 2 then
	    GenNative(m_lda_dir, direct, funLoc, nil, 0)
	 else
	    GenNative(m_ldy_dir, direct, funLoc, nil, 0);

      cgReal,cgDouble,cgExtended,cgComp: begin
         GenNative(m_pea, immediate, 0, nil, 0);
	 GenImplied(m_tdc);
         GenImplied(m_clc);
         GenNative(m_adc_imm, immediate, funLoc, nil, 0);
         GenImplied(m_pha);              
         if op^.optype = cgReal then
	    GenCall(81)
         else if op^.optype = cgDouble then
	    GenCall(84)
         else if op^.optype = cgExtended then
	    GenCall(176)
         else {if op^.optype = cgComp then}
	    GenCall(177);
         end;

      cgLong,cgULong: begin
	 GenNative(m_ldx_dir, direct, funLoc+2, nil, 0);
	 GenNative(m_ldy_dir, direct, funLoc, nil, 0);
	 end;

      otherwise:
	 Error(cge1);
      end; {case}

   {restore data bank reg}
   if dataBank then begin
      GenNative(m_lda_dir, direct, bankLoc, nil, 0);
      GenImplied(m_pha);
      GenImplied(m_plb);
      GenImplied(m_plb);
      end; {if}

   {get rid of the stack frame space}
   if size <> 0 then
      GenImplied(m_pld);
   if size = 2 then
      GenImplied(m_ply)
   else if size <> 0 then begin
      GenImplied(m_tsc);
      GenImplied(m_clc);
      GenNative(m_adc_imm, immediate, size, nil, 0);
      GenImplied(m_tcs);
      end; {if}

   {put return value in correct place}
   case op^.optype of
      cgByte,cgUByte,cgWord,cgUWord: begin
	 if size <> 2 then
	    GenImplied(m_tya);
	 if toolParms then	  {save value on stack for tools}
	    GenNative(m_sta_s, direct, returnSize+1, nil, 0);
	 end;

      cgLong,cgULong,cgReal,cgDouble,cgComp,cgExtended: begin
	 GenImplied(m_tya);
	 if toolParms then begin  {save value on stack for tools}
	    GenNative(m_sta_s, direct, returnSize+1, nil, 0);
	    GenImplied(m_txa);
	    GenNative(m_sta_s, direct, returnSize+3, nil, 0);
	    end; {if}
	 end;

      cgVoid: ;

      otherwise:
	 Error(cge1);
      end; {case}

   {return to the caller}
   GenImplied(m_rtl);
   end; {GenRet}


   procedure GenRnd (op: icptr);

   { Generate code for a pc_rnd					}

   begin {GenRnd}
   GenTree(op^.left);
   GenCall(68);
   end; {GenRnd}


   procedure GenRn4 (op: icptr);

   { Generate code for a pc_rn4					}

   var
      lLong: longType;			   {used to reserve gLong}

   begin {GenRn4}
   lLong := gLong;
   GenTree(op^.left);
   GenCall(149);
   if (lLong.preference & A_X) <> 0 then
      gLong.where := A_X
   else begin
      gLong.where := onStack;
      GenImplied(m_phx);
      GenImplied(m_pha);
      end; {else}
   end; {GenRn4}


   procedure GenSbi (op: icptr);

   { Generate code for a pc_sbi					}
   
   begin {GenSbi}
   if Complex(op^.left) or Complex(op^.right) then begin
      GenTree(op^.right);
      if Complex(op^.left) then begin
	 GenImplied(m_pha);
	 GenTree(op^.left);
	 GenImplied(m_sec);
	 GenNative(m_sbc_s, direct, 1, nil, 0);
	 GenImplied(m_plx);
         end {if}
      else begin
         GenNative(m_eor_imm, immediate, $FFFF, nil, 0);
	 GenImplied(m_sec);
         OperA(m_adc_imm, op^.left);
         end; {else}
      end {if}
   else begin
      GenTree(op^.left);
      GenImplied(m_sec);
      OperA(m_sbc_imm, op^.right);
      end; {else}
   if rangeCheck then
      GenCall(147);
   end; {GenSbi}


   procedure GenShlShrUsr (op: icptr);

   { Generate code for a pc_shl, pc_shr or pc_usr		}

   var
      i,op1,op2,num: integer;		{temp variables}

   begin {GenShlShrUsr}
   {get the standard native operations}
   if op^.opcode = pc_shl then begin
      op1 := m_asl_a;
      op2 := m_lsr_a;
      end {if}
   else begin
      op1 := m_lsr_a;
      op2 := m_asl_a;
      end; {else}

   {take short cuts if they are legal}
   if (op^.right^.opcode = pc_ldc) and (op^.opcode <> pc_shr) then begin
      num := op^.right^.q;
      if (num > 16) or (num < -16) then
	 GenNative(m_lda_imm, immediate, 0, nil, 0)
      else if num > 0 then begin
	 GenTree(op^.left);
         if num >= 8 then begin
            GenImplied(m_xba);
            if op1 = m_lsr_a then
               i := $00FF
            else
               i := $FF00;
            GenNative(m_and_imm, immediate, i, nil, 0);
            num := num-8;
            end; {if}
	 for i := 1 to num do
            GenImplied(op1);
	 end {else if}
      else if num < 0 then begin
	 GenTree(op^.left);
         if num <= -8 then begin
            GenImplied(m_xba);
            if op2 = m_lsr_a then
               i := $00FF
            else
               i := $FF00;
            GenNative(m_and_imm, immediate, i, nil, 0);
            num := num+8;
            end; {if}    
	 for i := 1 to -num do
            GenImplied(op2);
	 end {else if}
      else
	 GenTree(op^.left);
      end {if}
   else begin
      GenTree(op^.left);
      if Complex(op^.right) then begin
	 GenImplied(m_pha);
	 GenTree(op^.right);
	 GenImplied(m_tax);
	 GenImplied(m_pla);
	 end {if}
      else
	 LoadX(op^.right);
      if op^.opcode = pc_shl then
	 GenCall(88)
      else if op^.opcode = pc_shr then
	 GenCall(89)
      else {if op^.opcode = pc_usr then}
	 GenCall(175);
      end; {else}
   end; {GenShlShrUsr}
   

   procedure GenSiz (op: icptr);

   { Generate code for a pc_siz					}

   const
      unknownSize = 999;		{used to indicate an unknown set size}

   var   
      size: integer;			{size of the set being passed}


      function SetSize (op: icptr): unsigned;

      { find the size of the set generated by the tree passed	}
      {								}
      { parameters:						}
      {    op - tree to examine					}
      {								}
      { returns: Size of set					}

      var
	 ls, rs: unsigned;		{temp set sizes}

      begin {SetSize}
      case op^.opcode of
	 pc_uni,pc_int,pc_dif: begin
	    ls := SetSize(op^.left);
	    rs := SetSize(op^.right);
	    if ls < rs then
	       SetSize := rs
	    else
	       SetSize := ls;
	    end;
	 pc_sgs,pc_ixa,pc_ind:
	    SetSize := unknownSize;
	 pc_ldo:
	    SetSize := op^.q;
	 pc_ldc: begin
	    ls := op^.setp^.smax;
	    if odd(ls) then
               ls := ls+1;
	    SetSize := ls;
	    end;
	 pc_lod:
	    SetSize := op^.s;
	 otherwise: begin
	    SetSize := unknownSize;
	    Error(cge1);
	    end;
	 end; {case}
      end; {SetSize}

      
   begin {GenSiz}
   size := SetSize(op^.left);
   if (size <> unknownSize) and (size <= op^.q) then begin
      if odd(size-op^.q) then begin
	 GenNative(m_pea, immediate, 0, nil, 0);
	 GenImplied(m_phb);
	 GenImplied(m_pla);
	 size := size+1;
	 end; {if}
      while size < op^.q do begin
	 GenNative(m_pea, immediate, 0, nil, 0);
	 size := size+2;
	 end; {while}
      GenTree(op^.left);
      GenImplied(m_pla);
      end {if}
   else begin
      GenTree(op^.left);
      GenNative(m_pea, immediate, op^.q, nil, 0);
      GenCall(78);
      end; {else}
   end; {GenSiz}


   procedure GenSgs (op: icptr);

   { Generate code for a pc_sgs					}
   {								}
   { (Convert an integer range into a set)			}

   begin {GenSgs}
   GenTree(op^.left);
   GenImplied(m_pha);
   GenTree(op^.right);
   GenImplied(m_pha);
   GenCall(16);
   end; {GenSgs}


   procedure GenStk (op: icptr);

   { Generate code for a pc_stk					}

   var
      lab1: integer;			{branch point}

   begin {GenStk}
   glong.preference := onStack;		{generate the operand}
   GenTree(op^.left);
   if op^.optype in			{do the stk}
      [cgByte, cgUByte, cgWord, cgUWord] then
      GenImplied(m_pha);
   end; {GenStk}


   procedure GenTl1 (op: icptr);

   { Generate code for a pc_tl1, pc_tl2				}

   type
      kind = (vint, vbyte);		{kinds of equivalenced data}

   var        
      lLong: longType;			{used to reserve gLong}
      str: pStringPtr;			{string constant pointer}
      switch: packed record		{used for type conversion}
	 case rkind: kind of
	    vint: (i: integer);
	    vbyte: (b1, b2: byte);
	 end;
   
   begin {GenTl1}
   {push space for the return value}
   if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then
      GenImplied(m_pha)
   else if op^.optype in [cgLong,cgULong] then begin
      GenImplied(m_pha);
      GenImplied(m_pha);
      end; {else if}

   {generate parameters}
   lLong := gLong;
   GenTree(op^.left);
   gLong := lLong;

   {generate the tool call}
   switch.b2 := op^.q;
   switch.b1 := op^.r;
   GenNative(m_ldx_imm,immediate,switch.i,nil,0);
   if op^.opcode = pc_tl1 then
      GenNative(m_jsl, longAbs, 0, nil, toolCall)
   else
      GenNative(m_jsl, longAbs, 0, nil, usertoolCall);
   str := @'~TOOLERROR';
   if smallMemoryModel then
      GenNative(m_sta_abs, absolute, 0, str, 0)
   else
      GenNative(m_sta_long, longAbs, 0, str, 0);
      
   {save the returned value}
   if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then
      GenImplied(m_pla)
   else if op^.optype in [cgLong,cgULong] then
      gLong.where := onStack;
   end; {GenTl1}


   procedure GenUjp (op: icptr);

   { Generate code for a pc_ujp					}

   begin {GenUjp}
   if op^.lab = nil then
      GenNative(m_brl, longrelative, op^.q, nil, 0)
   else
      GenNative(m_jml, longAbs, 0, op^.lab, 0);
   end; {GenUjp}


   procedure GenVct (op: icptr);

   { Generate code for a pc_vct					}

   type
      kind = (vint, vbyte);		{kinds of equivalenced data}

   var        
      lLong: longType;			{used to reserve gLong}
      str: pStringPtr;			{string constant pointer}
   
   begin {GenVct}
   {push space for the return value}
   if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then
      GenImplied(m_pha)
   else if op^.optype in [cgLong,cgULong] then begin
      GenImplied(m_pha);
      GenImplied(m_pha);
      end; {else if}

   {generate parameters}
   lLong := gLong;
   GenTree(op^.left);
   gLong := lLong;

   {generate the tool call}
   GenNative(m_ldx_imm,immediate,op^.q,nil,0);
   if op^.opcode = pc_tl1 then
      GenNative(m_jsl, longAbsolute, 0, op^.lval, constantOpnd)
   else
      GenNative(m_jsl, longAbsolute, 0, op^.lval, constantOpnd);
   str := @'~TOOLERROR';
   if smallMemoryModel then
      GenNative(m_sta_abs, absolute, 0, str, 0)
   else
      GenNative(m_sta_long, longAbs, 0, str, 0);
      
   {save the returned value}
   if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then
      GenImplied(m_pla)
   else if op^.optype in [cgLong,cgULong] then
      gLong.where := onStack;
   end; {GenVct}


   procedure GenXjp (op: icptr);

   { Generate code for a pc_xjp					}

   var
      lab1,lab2: integer;
      q: integer;

   begin {GenXjp}
   q := op^.q;
   lab1 := GenLabel;
   GenTree(op^.left);
   GenNative(m_cmp_imm, immediate, q, nil, 0);
   GenNative(m_bcc, relative, lab1, nil, 0);
   GenNative(m_lda_imm, immediate, q, nil, 0);
   GenLab(lab1);
   GenImplied(m_asl_a);
   GenImplied(m_tax);
   lab1 := GenLabel;
   lab2 := GenLabel;
   GenNative(m_lda_longx, longAbs, lab2, nil, 0);
   GenNative(m_beq,relative,lab1,nil,0);
   GenImplied(m_pha);
   GenImplied(m_rts);
   GenLab(lab1);
   GenCall(12);
   GenLab(lab2);
   end; {GenXjp}


   procedure DirLab (op: icptr);

   { Generate code for a dc_lab					}

   begin {DirLab}
   if op^.lab = nil then
      GenLab(op^.q)
   else
      GenNative(d_lab, gnrLabel, 0, op^.lab, isPrivate);
   end; {DirLab}


   procedure DirStr (op: icptr);

   { Generate code for a dc_str					}

   begin {DirStr}
   skipLoad := false;
   InitNative;
   Header(op^.lab, op^.r, op^.q);
   end; {DirStr}


   procedure DirSym (op: icptr);

   { Generate code for a dc_sym					}

   begin {DirSym}
   if debugFlag then
      GenNative(d_sym, special, op^.q, pointer(op^.lab), 0);
   end; {DirSym}


begin {GenTree}
{if printSymbols then begin write('GEN: '); WriteCode(op); end; {debug}
Spin;
case op^.opcode of
   dc_dst: GenNative(d_lab, gnrSpace, op^.q, nil, 0);
   dc_enp: DirEnp;
   dc_glb: GenNative(d_lab, gnrLabel, op^.r, op^.lab, isPrivate*op^.q);
   dc_lab: DirLab(op);
   dc_fun,dc_loc,dc_prm: ;
   dc_pin: GenNative(d_pin, special, 0, nil, 0);
   dc_str: DirStr(op);
   dc_sym: DirSym(op);

   pc_abi,pc_bnt,pc_ngi,pc_not,pc_odd,pc_sqi: GenAbiBntNgiNotOddSqi(op);
   pc_abl,pc_bnl,pc_ngl,pc_odl,pc_sql: GenAblBnlNglOdlSql(op);
   pc_abr,pc_ngr: GenAbrNgr(op);
   pc_add: GenNative(d_add, genaddress, op^.q, nil, sub1);
   pc_adi: GenAdi(op);
   pc_adl,pc_sbl: GenAdlSbl(op, nil);
   pc_adr,pc_dvr,pc_mpr,pc_sbr: GenRealBinOp(op);
   pc_and,pc_bnd,pc_bor,pc_bxr,pc_ior: GenLogic(op);
   pc_atn,pc_cos,pc_exp,pc_log,pc_sin,pc_sqr,pc_sqt,pc_tan,pc_acs,pc_asn:
      GenRealUnOp(op);
   pc_at2: GenAt2(op);
   pc_blr,pc_blx,pc_bal,pc_dvl,pc_mdl,pc_mpl,pc_sll,pc_slr,pc_udl,pc_ulm,
      pc_uml,pc_vsr: GenBinLong(op);
   pc_bno: GenBno(op);
   pc_chk: GenChk(op);
   pc_cnv: GenCnv(op);
   pc_csp: GenCsp(op);
   pc_cui: GenCui(op);
   pc_cum: GenCum(op);
   pc_cup: GenCup(op);
   pc_dec,pc_inc: GenIncDec(op, nil);
   pc_dif,pc_int,pc_uni: GenDifIntUni(op);
   pc_dvi,pc_mod,pc_udi,pc_uim: GenDviMod(op);
   pc_ent: GenEnt;
   pc_equ,pc_neq: GenEquNeq(op, op^.opcode, 0);
   pc_fix: GenFix(op);
   pc_fjp,pc_tjp: GenFjpTjp(op);
   pc_geq,pc_grt,pc_leq,pc_les: GenCmp(op, op^.opcode, 0);
   pc_ind: GenInd(op);
   pc_inn: GenInn(op);
   pc_ixa: GenIxa(op);
   pc_lao,pc_lad: GenLaoLad(op);
   pc_lca: GenLca(op);
   pc_lda: GenLda(op);  
   pc_ldc: GenLdc(op);
   pc_ldo: GenLdo(op);
   pc_lod: GenLod(op);
   pc_lla: GenLla(op);
   pc_lnm: GenLnm(op);
   pc_lsl: GenLsl(op);
   pc_mov: GenMov(op, false);
   pc_mpi,pc_umi: GenMpi(op);
   pc_nam: GenNam(op);
   pc_nop: ;     
   pc_pds: GenPds(op);
   pc_prs: GenPrs(op);
   pc_pwr: GenPwr(op);
   pc_ret: GenRet(op);
   pc_rnd: GenRnd(op);
   pc_rn4: GenRn4(op);
   pc_sbi: GenSbi(op);
   pc_shl,pc_shr,pc_usr: GenShlShrUsr(op);
   pc_siz: GenSiz(op);
   pc_sgs: GenSgs(op);
   pc_sro,pc_cpo: GenSroCpo(op);
   pc_stk: GenStk(op);
   pc_sto: GenSto(op);
   pc_str,pc_cop: GenStrCop(op);
   pc_tl1,pc_tl2: GenTl1(op);
   pc_ujp: GenUjp(op);
   pc_vct: GenVct(op);
   pc_xjp: GenXjp(op);

   otherwise: begin
      Error(cge1);
      writeln('Undefined in GenTree: ', ord(op^.opcode):1);
      end;
   end; {case}
end; {GenTree}

{$optimize -1}

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

procedure Gen {blk: blockPtr};

{ Generates native code for a list of blocks			}
{								}
{ parameters:							}
{    blk - first of the list of blocks				}

type
   sfPtr = ^sfRecord;			{stack frame record}
   sfRecord = record
      next: sfPtr;			{next record}
      bankLoc: integer;			{disp in dp where bank reg is stored}
      dworkLoc: integer;		{disp in dp of 4 byte work spage for cg}
      funLoc: integer;			{loc of fn ret value in stack frame}
      localSize: integer;		{local space for current proc}
      parameterSize: integer;		{# bytes of parameters for current proc}
      staticLoc: integer;		{loc of static link}
      end;

var
   gop: icptr;				{used to trace code lists}
   sfList: sfPtr;			{stack frame list}
   sfLast: sfPtr;			{stack frame temp variable}

   
   procedure StackFrame (blk: blockPtr; gop: icptr);

   { Set up a stack frame for a new pc_ent			}
   {								}
   { parameters:						}
   {    blk - starting block					}
   {    gop - starting pc_ent					}

   label 1, 2, 3;

   const
      locSize = 4;			{variables <= this size allocated first}

   var
      bk: blockPtr; 			{used to trace block lists}
      minSize: integer;			{location for the next local label}
      needScan2: boolean;		{do we need the 2nd dc_loc scan?}
      op: icptr;			{used to trace code lists}
      sf: sfPtr;			{new stack frame record}


      procedure DirLoc1 (op: icptr);

      { allocates stack frame locations for small dc_loc	}

      begin {DirLoc1}
      if op^.q <= locSize then begin
	 if op^.r < maxLocalLabel then begin
	    localLabel[op^.r] := minSize;
	    minSize := minSize + op^.q;
	    end {if}
	 else
	    Error(cge2);
	 end {if}
      else
         needScan2 := true;
      end; {DirLoc1}


      procedure DirLoc2 (op: icptr);

      { allocates stack frame locations for large dc_loc	}

      begin {DirLoc2}
      if op^.q > locSize then begin
	 if op^.r < maxLocalLabel then begin
	    localLabel[op^.r] := minSize;
	    minSize := minSize + op^.q;
	    end {if}
	 else
	    Error(cge2);
	 end; {if}
      end; {DirLoc2}


      procedure DirPrm (op: icptr);

      { allocates stack frame locations for parameters		}

      begin {DirPrm}
      if op^.s < maxLocalLabel then
	 localLabel[op^.s] := localSize + returnSize + 1 + op^.r
      else
	 Error(cge2);
      end; {DirPrm}


      procedure Scan (op: icptr);

      { scans the code stream for instructions that effect the	}
      { size of the stack frame					}
      {								}
      { parameters: 						}
      {	op - scan this opcode and its children			}

      var
	 opcode: pcodes;		{op^.opcode}
	 size: integer;			{function return value size}

      begin {Scan}
      if op^.left <> nil then
	 Scan(op^.left);
      if op^.right <> nil then
	 Scan(op^.right);
      opcode := op^.opcode;
      if ((opcode = pc_cup) and ((op^.lab = nil) or (not noGlobalLabels)))
         or (opcode = pc_prs)
         or (op^.p <> 0) then begin
         if staticLoc = 0 then begin
            staticLoc := 1;
	    if dworkLoc <> 0 then
	       dworkLoc := dworkLoc + 2;
	    minSize := minSize + 2;
	    localSize := localSize + 2;
            end; {if}      
         end; {if}
      if opcode = dc_loc then
	 localSize := localSize + op^.q
      else if opcode = dc_fun then
	 localSize := localSize + op^.q
      else if opcode = dc_prm then
	 parameterSize := parameterSize + op^.q
      else if opcode in [pc_les,pc_leq,pc_grt,pc_geq] then begin
         if op^.optype in [cgByte,cgWord,cgUByte,cgUWord] then
            if Complex(op^.left) or Complex(op^.right) then
	       if dworkLoc = 0 then begin
		  dworkLoc := minSize;
		  minSize := minSize + 4;
		  localSize := localSize + 4;
		  end; {if}                              
	 end {else if}
      else if opcode in [pc_sto,pc_ind,pc_lor,pc_lnd,pc_ixa,pc_cum]
	 then begin
	 if dworkLoc = 0 then begin
	    dworkLoc := minSize;
	    minSize := minSize + 4;
	    localSize := localSize + 4;
	    end; {if}                              
	 end; {else if}
      end; {Scan}


   begin {StackFrame}
   while blk <> nil do begin
      new(sf);				{allocate a new stack frame}
      if sfList = nil then
	 sfList := sf
      else
	 sfLast^.next := sf;
      sfLast := sf;
      sf^.next := nil;
      localSize := 0;			{determine the size of the stack frame}
      parameterSize := 0;
      staticLoc := 0;
      funLoc := 0;
      dworkLoc := 0;
      minSize := 1;
      bk := blk;
      op := gop^.next;
      repeat
	 while op <> nil do begin
            if op^.opcode = pc_ent then
               goto 1;
	    Scan(op);
	    op := op^.next;
	    end; {while}
	 while (op = nil) and (bk <> nil) do begin
	    bk := bk^.next;
	    if bk <> nil then
               op := bk^.code;
            end; {while}
      until op = nil;
   1: if dataBank then begin
	 bankLoc := minSize;
	 minSize := minSize + 2;
	 localSize := localSize + 2;
	 end; {if}
      needScan2 := false;			{allocate locations for the values}
      bk := blk;
      op := gop^.next;
      repeat
	 while op <> nil do begin
            if op^.opcode = pc_ent then
               goto 2
	    else if op^.opcode = dc_loc then
	       DirLoc1(op)
	    else if op^.opcode = dc_fun then begin
	       DirLoc1(op);
               funLoc := localLabel[op^.r];
               end {else if}
	    else if op^.opcode = dc_prm then
	       DirPrm(op);
	    op := op^.next;
	    end; {while}
	 while (op = nil) and (bk <> nil) do begin
	    bk := bk^.next;
	    if bk <> nil then
               op := bk^.code;
            end; {while}
      until op = nil;
   2: if needScan2 then begin
	 bk := blk;
	 op := gop^.next;
	 repeat
	    while op <> nil do begin
               if op^.opcode = pc_ent then
        	  goto 3
	       else if op^.opcode = dc_loc then
		  DirLoc2(op)
	       else if op^.opcode = dc_fun then begin
		  DirLoc2(op);
        	  funLoc := localLabel[op^.r];
        	  end; {else if}
	       op := op^.next;              
	       end; {while}
	    while (op = nil) and (bk <> nil) do begin
	       bk := bk^.next;
	       if bk <> nil then
        	  op := bk^.code;
               end; {while}
	 until op = nil;
	 end; {if}
3:    blk := bk;			{get ready for next scan}
      gop := op;
      sf^.localSize := localSize;	{record the stack frame info}
      sf^.parameterSize := parameterSize;
      sf^.staticLoc := staticLoc;
      sf^.funLoc := funLoc;
      sf^.dworkLoc := dworkLoc;
      sf^.bankLoc := bankLoc;
      end; {while}
   end; {StackFrame}


begin {Gen}
enpFound := false;			{dc_enp not found, yet}
sfList := nil;				{no stack frame list}
while blk <> nil do begin		{generate code for the block}
   gop := blk^.code;
   while gop <> nil do begin
      if gop^.opcode = pc_ent then begin
         if sfList = nil then
            StackFrame(blk, gop);
	 localSize := sfList^.localSize;
	 parameterSize := sfList^.parameterSize;
	 staticLoc := sfList^.staticLoc;
	 funLoc := sfList^.funLoc;
	 dworkLoc := sfList^.dworkLoc;
	 bankLoc := sfList^.bankLoc;
         sfLast := sfList;
         sfList := sfList^.next;
         dispose(sfLast);
         end; {if}
      GenTree(gop);
      gop := gop^.next;
      end; {while}
   blk := blk^.next;
   end; {while}
if not enpFound then			{if dc_enp was optimized out, fake one}
   DirEnp;
end; {Gen}

end.
\ No newline at end of file
+{$optimize -1}
+{---------------------------------------------------------------}
+{								}
+{  Gen								}
+{								}
+{  Generates native code from intermediate code instructions.	}
+{								}
+{---------------------------------------------------------------}
+
+unit Gen;
+
+interface
+
+{$segment 'gen'}
+
+{$LibPrefix '0/obj/'}
+
+uses PCommon, CGI, CGC, ObjOut, Native;
+
+{---------------------------------------------------------------}
+
+procedure Gen (blk: blockPtr);
+
+{ Generates native code for a list of blocks			}
+{								}
+{ parameters:							}
+{    blk - first of the list of blocks				}
+
+{---------------------------------------------------------------}
+
+implementation
+
+const
+   A_X		=	1;		{longword locations}
+   onStack	=	2;
+   inPointer	=	4;
+   localAddress =	8;
+   globalLabel	=      16;
+   constant	=      32;
+
+					{stack frame locations}
+					{---------------------}
+   returnSize		=	3;	{size of return address}
+
+type
+					{possible locations for 4 byte values}
+   longType = record			{desciption of current four byte value}
+      preference: integer;		{where you want the value}
+      where: integer;			{where the value is at}
+      fixedDisp: boolean;		{is the displacement a fixed value?}
+      isLong: boolean;			{is long addr required for named labs?}
+      disp: integer;			{fixed displacement/local addr}
+      lval: longint;			{value}
+      lab: pStringPtr;			 {global label name}
+      end;
+
+var
+   enpFound: boolean;			{was the dc_enp found?}
+   gLong: longType;			{info about last long value}
+   namePushed: boolean;			{has a name been pushed in this proc?}
+   skipLoad: boolean;			{skip load for a pc_lli, etc?}
+
+					{stack frame locations}
+					{---------------------}
+   bankLoc: integer;			{disp in dp where bank reg is stored}
+   dworkLoc: integer;			{disp in dp of 4 byte work spage for cg}
+   funLoc: integer;			{loc of fn ret value in stack frame}
+   localSize: integer;			{local space for current proc}
+   parameterSize: integer;		{# bytes of parameters for current proc}
+   staticLoc: integer;			{loc of static link}
+   
+{---------------------------------------------------------------}
+
+procedure GenTree (op: icptr); forward;
+
+{---------------------------------------------------------------}
+
+function Complex (op: icptr): boolean;
+
+{ determine if loading the intermediate code involves anything	}
+{ but one reg							}
+{								}
+{ parameters:							}
+{    code - intermediate code to check				}
+{								}
+{ NOTE: for one and two byte values only!!!			}
+
+begin {Complex}
+Complex := true;
+if op^.opcode in [pc_ldo,pc_ldc] then
+   Complex := false
+else if op^.opcode = pc_lod then
+   if op^.p = 0 then
+      if localLabel[op^.r] + op^.q < 256 then
+	 Complex := false;
+if op^.optype in [cgByte,cgUByte] then
+   Complex := true;
+end; {Complex}
+
+
+procedure DoOp(op_imm, op_abs, op_dir: integer; icode: icptr; disp: integer);
+
+{ Do an operation.						}
+{								}
+{ Parameters:							}
+{    op_imm,op_abs,op_dir - op codes for the various		}
+{	addressing modes 					}
+{    icode - intermediate code record				}
+{    disp - disp past the location (1 or 2)			}
+
+var
+   val: integer; 		     {value for immediate operations}
+   lval: longint;		     {long value for immediate operations}
+
+begin {DoOp}
+if icode^.opcode = pc_ldc then begin
+   lval := icode^.lval;
+   if disp = 0 then
+      val := long(lval).lsw
+   else
+      val := long(lval).msw;
+   GenNative(op_imm, immediate, val, nil, 0);
+   end {if}
+else if icode^.opcode in [pc_lod,pc_str] then
+   GenNative(op_dir, direct, localLabel[icode^.r] + icode^.q + disp, nil, 0)
+else {if icode^.opcode in [pc_ldo, pc_sro] then}
+   GenNative(op_abs, absolute, icode^.q + disp, icode^.lab, 0);
+end; {DoOp}
+
+
+procedure GetPointer (op: icptr);
+
+{ convert a tree into a usable pointer for indirect		}
+{ loads/stores							}
+{								}
+{ parameters:							}
+{    op - pointer tree						}
+
+begin {GetPointer}
+gLong.preference := A_X+inPointer+localAddress+globalLabel;
+GenTree(op);
+if gLong.where = onStack then begin
+   GenImplied(m_pla);
+   GenImplied(m_plx);
+   gLong.where := A_X;
+   end; {if}
+if gLong.where = A_X then begin
+   GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
+   GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0);
+   gLong.where := inPointer;
+   gLong.fixedDisp := true;
+   gLong.disp := dworkLoc;
+   end; {else if}
+end; {GetPointer}
+
+
+procedure IncAddr (size: integer);
+
+{ add a two byte constant to a four byte value - generally an	}
+{ address							}
+{								}
+{ parameters:							}
+{    size - integer to add					}
+
+var
+   lab1: integer;			{branch point}
+
+begin {IncAddr}
+if size <> 0 then
+   case gLong.where of
+
+      onStack: begin
+	 lab1 := GenLabel;
+	 GenImplied(m_pla);
+	 if size = 1 then begin
+	    GenImplied(m_ina);
+	    GenNative(m_bne, relative, lab1, nil, 0);
+	    end {if}
+	 else begin
+	    GenImplied(m_clc);
+	    GenNative(m_adc_imm, immediate, size, nil, 0);
+	    GenNative(m_bcc, relative, lab1, nil, 0);
+	    end; {else}
+	 GenImplied(m_plx);
+	 GenImplied(m_inx);
+	 GenImplied(m_phx);
+	 GenLab(lab1);
+	 GenImplied(m_pha);
+	 end;
+
+      A_X: begin
+	 lab1 := GenLabel;
+	 if size = 1 then begin
+	    GenImplied(m_ina);
+	    GenNative(m_bne, relative, lab1, nil, 0);
+	    end {if}
+	 else begin
+	    GenImplied(m_clc);
+	    GenNative(m_adc_imm, immediate, size, nil, 0);
+	    GenNative(m_bcc, relative, lab1, nil, 0);
+	    end; {else}
+	 GenImplied(m_inx);
+	 GenLab(lab1);
+	 end;
+
+      inPointer:
+	 if gLong.fixedDisp then begin
+	    gLong.fixedDisp := false;
+	    GenNative(m_ldy_imm, immediate, size, nil, 0);
+	    end {if}
+	 else if size <= 4 then begin
+	    while size <> 0 do begin
+	       GenImplied(m_iny);
+	       size := size - 1;
+	       end; {while}
+	    end {else if}
+	 else begin
+	    GenImplied(m_tya);
+	    GenImplied(m_clc);
+	    GenNative(m_adc_imm, immediate, size, nil, 0);
+	    GenImplied(m_tay);
+	    end; {else}
+
+      localAddress,globalLabel:
+	 gLong.disp := gLong.disp+size;
+
+      otherwise:
+	 Error(cge1);
+      end; {case}
+end; {IncAddr}
+
+
+procedure LoadX (op: icptr);
+
+{ Load X with a two byte value					}
+{                                                               }
+{ parameters:                                                   }
+{    op - value to load						}
+
+var
+   q, r: integer;
+   lab: pStringPtr;
+
+begin {LoadX}
+q := op^.q;
+r := op^.r;
+lab := op^.lab;
+case op^.opcode of
+   pc_lao,pc_lda:
+      Error(cge1);
+   pc_ldc:
+      GenNative(m_ldx_imm, immediate, q, nil, 0);
+   pc_ldo:
+      GenNative(m_ldx_abs, absolute, q, lab, 0);
+   pc_lod:
+      GenNative(m_ldx_dir, direct, localLabel[r] + q, nil, 0);
+   otherwise:
+      Error(cge1);
+   end; {case}
+end; {LoadX}
+
+
+procedure OperA (mop: integer; op: icptr);
+
+{ Do an operation on op that has addr modes equivalent to STA	}
+{								}
+{ parameters:							}
+{    op - node to generate the leaf for				}
+{    mop - operation						}
+
+var
+   loc: integer; 			{stack frame position}
+   opcode: pcodes;			{temp storage}
+
+begin {OperA}
+opcode := op^.opcode;
+case opcode of
+
+   pc_ldo: begin
+      {this shortcut is valid for cmp, adc, and, ora, sbc, eor}
+      mop := mop+4;
+      if smallMemoryModel then
+         GenNative(mop, absolute, op^.q, op^.lab, 0)
+      else
+         GenNative(mop+2, longAbs, op^.q, op^.lab, 0);
+      end; {case pc_ldo}
+
+   pc_lod: begin
+      {this shortcut is valid for cmp, adc, and, ora, sbc, eor}
+      mop := mop-4;
+      loc := localLabel[op^.r];
+      loc := loc + op^.q;
+      GenNative(mop, direct, loc, nil, 0);
+      end; {case pc_lod}
+
+   pc_ldc:
+      GenNative(mop, immediate, op^.q, nil, 0);
+
+   otherwise:
+      Error(cge1);
+   end; {case}
+end; {OperA}
+
+
+function NeedsCondition (opcode: pcodes): boolean;
+
+{ See if the operation is one that doesn't set the condition	}
+{ code reliably							}
+{								}
+{ Parameters:							}
+{    opcodes - operation to check				}
+{								}
+{ Returns: True if the condition code is not set properly for	}
+{    an operand type of cgByte,cgUByte,cgWord,cgUWord, else	}
+{    false							}
+
+begin {NeedsCondition}
+NeedsCondition := opcode in
+   [pc_and,pc_ior,pc_cui,pc_cup,pc_lor,pc_lnd,
+    pc_cop,pc_cpo,pc_dvi,pc_mpi,pc_adi,pc_sbi,pc_mod,pc_bno];
+end; {NeedsCondition}
+
+
+function SameLoc (load, save: icptr): boolean;
+
+{ See if load and save represent the same location (which must	}
+{ be a direct page value or a global label).			}
+{								}
+{ parameters:							}
+{    load - load operation					}
+{    save - save operation					}
+{								}
+{ Returns: True the the same location is used, else false	}
+
+begin {SameLoc}
+SameLoc := false;
+if save <> nil then begin
+   if load^.opcode = pc_lod then begin
+      if localLabel[load^.r] + load^.q < 254 then
+	 if save^.opcode = pc_str then
+	    if save^.q = load^.q then
+	       if save^.r = load^.r then
+	          if save^.p = load^.p then
+		     SameLoc := true;
+      end {if}
+   else if smallMemoryModel then
+      if load^.opcode = pc_ldo then
+	 if save^.opcode = pc_sro then
+	    if load^.lab^ = save^.lab^ then
+	       if load^.q = save^.q then
+		  SameLoc := true;
+   end; {if}
+end; {SameLoc}
+
+
+procedure SaveRetValue (optype: baseTypeEnum);
+
+{ save a value returned by a function                           }
+{                                                               }
+{ parameters:                                                   }
+{    optype - function type					}
+
+begin {SaveRetValue}
+if optype in [cgLong,cgULong] then begin
+   if (A_X & gLong.preference) = 0 then begin
+      gLong.where := onStack;
+      GenImplied(m_phx);
+      GenImplied(m_pha);
+      end
+   else
+      gLong.where := A_X;
+   end {if}
+else if optype in [cgReal,cgDouble,cgExtended,cgComp] then
+   GenCall(85);
+end; {SaveRetValue}
+
+
+procedure StaticLink (levels: integer; guardA: boolean; inA: boolean);
+
+{ Returns the start of the needed stack frame in X.		}
+{								}
+{ parameters:							}
+{    levels - number of static levels to traverse		}
+{    guardA - if true, A is preserved				}
+{    inA - if true, the result is returned in A, rather than X	}
+{								}
+{ Note: gardA and inA should not both be true			}
+
+var
+   i: integer;				{loop variable}
+
+begin {StaticLink}
+if inA and (levels = 1) then
+   GenNative(m_lda_dir, direct, staticLoc, nil, 0)
+else
+   GenNative(m_ldx_dir, direct, staticLoc, nil, 0);
+if levels > 1 then begin
+   if guardA then
+      GenImplied(m_tay);
+   for i := 2 to levels do begin
+      GenNative(m_lda_longX, longAbsolute, staticLoc, nil, 0);
+      if not (inA and (levels = i)) then
+	 GenImplied(m_tax);
+      end; {for}
+   if guardA then
+      GenImplied(m_tya);
+   end; {if}
+end; {StaticLink}
+
+{---------------------------------------------------------------}
+
+procedure GenAdlSbl (op, save: icptr);
+
+{ generate code for pc_adl, pc_sbl				}
+{								}
+{ parameters:							}
+{    op - pc_adl or pc_sbl operation				}
+{    save - save location (pc_str or pc_sro) or nil		}
+
+var
+   bcc,clc,adc_imm,inc_dir,adc_abs,	{for op-code insensitive code}
+      adc_dir,inc_abs,adc_s: integer;
+   disp: integer;			{direct page location}
+   lab1: integer;			{label number}
+   lLong: longType;			{used to reserve gLong}
+   nd: icptr;				{for swapping left/right children}
+   opcode: pcodes;			{temp storage; for efficiency}
+   simpleStore: boolean; 		{is the store absolute or direct?}
+   val: longint; 			{long constant value}
+
+
+   function Simple (icode: icptr): boolean;
+
+   { See if the intermediate code is simple; i.e., can be	}
+   { reached by direct page or absolute addressing.		}
+
+   var
+      load: icptr;			{left opcode}
+
+   begin {Simple}
+   Simple := false;
+   if icode^.opcode = pc_ldc then
+      Simple := true
+   else if icode^.opcode in [pc_lod,pc_str] then begin
+      if localLabel[icode^.r] + icode^.q < 254 then
+         if icode^.p = 0 then
+	    Simple := true;
+      end {else if}
+   else if icode^.opcode in [pc_ldo,pc_sro] then
+      Simple := smallMemoryModel;
+   end; {Simple}
+
+
+begin {GenAdlSbl}
+{determine where the result goes}
+if save <> nil then
+   gLong.preference :=
+      A_X+onStack+inPointer+localAddress+globalLabel+constant;
+lLong := gLong;
+
+{set up the master instructions}
+opcode := op^.opcode;
+if opcode = pc_adl then begin
+   clc := m_clc;
+   bcc := m_bcc;
+   adc_imm := m_adc_imm;
+   adc_abs := m_adc_abs;
+   adc_dir := m_adc_dir;
+   adc_s   := m_adc_s;
+   inc_dir := m_inc_dir;
+   inc_abs := m_inc_abs;
+   end {if}
+else begin
+   clc := m_sec;
+   bcc := m_bcs;
+   adc_imm := m_sbc_imm;
+   adc_abs := m_sbc_abs;
+   adc_dir := m_sbc_dir;
+   adc_s   := m_sbc_s;
+   inc_dir := m_dec_dir;
+   inc_abs := m_dec_abs;
+   end; {else}
+
+{if the lhs is a constant, swap the nodes}
+if ((op^.left^.opcode = pc_ldc) and (opcode = pc_adl)) then begin
+   nd := op^.left;
+   op^.left := op^.right;
+   op^.right := nd;
+   end; {if}
+
+{handle a constant rhs}
+if op^.right^.opcode = pc_ldc then
+   val := op^.right^.lval
+else
+   val := -1;
+if SameLoc(op^.left, save) and (save^.p = 0) and (long(val).msw = 0) then begin
+   lab1 := GenLabel;
+   if val = 1 then begin
+      if opcode = pc_adl then begin
+	 DoOp(0, m_inc_abs, m_inc_dir, op^.left, 0);
+	 GenNative(m_bne, relative, lab1, nil, 0);
+	 DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2);
+	 GenLab(lab1);
+	 end {if}
+      else {if opcode = pc_sbl then} begin
+	 DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
+	 GenNative(m_beq, relative, lab1, nil, 0);
+	 DoOp(0, m_dec_abs, m_dec_dir, op^.left, 0);
+	 GenLab(lab1);
+	 DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2);
+	 end; {else}
+      end {if}
+   else begin {rhs in [2..65535]}
+      GenImplied(clc);
+      DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
+      GenNative(adc_imm, immediate, long(val).lsw, nil, 0);
+      DoOp(0, m_sta_abs, m_sta_dir, op^.left, 0);
+      GenNative(bcc, relative, lab1, nil, 0);
+      if opcode = pc_adl then
+	 DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2)
+      else
+	 DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2);
+      GenLab(lab1);
+      end; {else}
+   end {if constant rhs}
+
+else begin
+   simpleStore := false;
+   if save <> nil then
+      simpleStore := Simple(save);
+   if (opcode = pc_adl) and Simple(op^.left) then begin
+      nd := op^.left;
+      op^.left := op^.right;
+      op^.right := nd;
+      end; {if}
+   if simpleStore and Simple(op^.right) then begin
+      if Simple(op^.left) then begin
+	 GenImplied(clc);
+	 DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
+	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0);
+	 DoOp(0, m_sta_abs, m_sta_dir, save, 0);
+	 DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 2);
+	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2);
+	 DoOp(0, m_sta_abs, m_sta_dir, save, 2);
+	 end {if}
+      else begin
+	 gLong.preference := A_X;
+	 GenTree(op^.left);
+	 GenImplied(clc);
+	 if gLong.where = onStack then
+	    GenImplied(m_pla);
+	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0);
+	 DoOp(0, m_sta_abs, m_sta_dir, save, 0);
+	 if gLong.where = onStack then
+	    GenImplied(m_pla)
+	 else
+	    GenImplied(m_txa);
+	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2);
+	 DoOp(0, m_sta_abs, m_sta_dir, save, 2);
+	 end; {else}
+      end {if}
+   else if Simple(op^.right) and (save = nil) then begin
+      gLong.preference := gLong.preference & A_X;
+      GenTree(op^.left);
+      GenImplied(clc);
+      if gLong.where = onStack then begin
+	 GenImplied(m_pla);
+	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0);
+	 GenImplied(m_pha);
+	 GenNative(m_lda_s, direct, 3, nil, 0);
+	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2);
+	 GenNative(m_sta_s, direct, 3, nil, 0);
+	 end {if}
+      else begin
+	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0);
+	 GenImplied(m_tay);
+	 GenImplied(m_txa);
+	 DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2);
+	 GenImplied(m_tax);
+	 GenImplied(m_tya);
+	 end; {else}
+      end {else if}
+   else begin {doing it the hard way}
+      gLong.preference := onStack;
+      GenTree(op^.right);
+      gLong.preference := onStack;
+      GenTree(op^.left);
+      GenImplied(clc);
+      GenImplied(m_pla);
+      GenNative(adc_s, direct, 3, nil, 0);
+      GenNative(m_sta_s, direct, 3, nil, 0);
+      GenImplied(m_pla);
+      GenNative(adc_s, direct, 3, nil, 0);
+      GenNative(m_sta_s, direct, 3, nil, 0);
+      if save = nil then
+	 gLong.where := onStack
+      else if save^.opcode = pc_str then begin
+	 disp := localLabel[save^.r] + save^.q;
+         if save^.p <> 0 then begin
+	    StaticLink(save^.p, false, false);
+	    GenImplied(m_pla);
+	    GenNative(m_sta_longX, longAbsolute, disp, nil, 0);
+	    GenImplied(m_pla);
+	    GenNative(m_sta_longX, longAbsolute, disp+2, nil, 0);
+            end {if}
+	 else if disp < 254 then begin
+	    GenImplied(m_pla);
+	    GenNative(m_sta_dir, direct, disp, nil, 0);
+	    GenImplied(m_pla);
+	    GenNative(m_sta_dir, direct, disp+2, nil, 0);
+	    end {else if}
+	 else begin
+	    GenNative(m_ldx_imm, immediate, disp, nil, 0);
+	    GenImplied(m_pla);
+	    GenNative(m_sta_dirX, direct, 0, nil, 0);
+	    GenImplied(m_pla);
+	    GenNative(m_sta_dirX, direct, 2, nil, 0);
+	    end; {else}
+	 end {else if}
+      else {if save^.opcode = pc_sro then} begin
+	 GenImplied(m_pla);
+	 if smallMemoryModel then
+	    GenNative(m_sta_abs, absolute, save^.q, save^.lab, 0)
+	 else
+	    GenNative(m_sta_long, longabsolute, save^.q, save^.lab, 0);
+	 GenImplied(m_pla);
+	 if smallMemoryModel then
+	    GenNative(m_sta_abs, absolute, save^.q+2, save^.lab, 0)
+	 else
+	    GenNative(m_sta_long, longabsolute, save^.q+2, save^.lab, 0);
+	 end; {else}
+      end; {else}
+   end; {else}
+end; {GenAdlSbl}
+
+
+procedure GenCmp (op: icptr; rOpcode: pcodes; lb: integer);
+
+{ generate code for pc_les, pc_leq, pc_grt or pc_geq		}
+{								}
+{ parameters:							}
+{    op - operation						}
+{    rOpcode - Opcode that will use the result of the		}
+{	compare.  If the result is used by a tjp or fjp, 	}
+{	this procedure generated special code and does the	}
+{	branch internally.					}
+{    lb - For fjp, tjp, this is the label to branch to if	}
+{	     the condition is satisfied. 			}
+
+var
+   i: integer;				{loop variable}
+   lab1,lab2,lab3,lab4: integer; 	{label numbers}
+   num: integer; 			{constant to compare to}
+   nop: icptr;				{new opcode}
+
+
+   procedure Switch;
+
+   { switch the operands 					}
+
+   var
+      nd: icptr; 			{used to switch nodes}
+      t: integer;			{used to switch string lengths}
+
+   begin {Switch}
+   nd := op^.left;
+   op^.left := op^.right;
+   op^.right := nd;
+   if op^.optype = cgString then begin
+      t := op^.r;
+      op^.r := op^.q;
+      op^.q := t;
+      end; {if}
+   end; {Switch}
+
+begin {GenCmp}
+{To reduct the number of possibilities that must be handled, pc_les  }
+{and pc_leq compares are reduced to their equivalent pc_grt and	     }
+{pc_geq instructions.						     }
+if op^.opcode = pc_les then begin
+   Switch;
+   op^.opcode := pc_grt;
+   end {if}
+else if op^.opcode = pc_leq then begin
+   Switch;
+   op^.opcode := pc_geq;
+   end; {else if}
+
+{To take advantage of shortcuts, switch operands if generating	  }
+{for a tjp or fjp with a constant left operand.			  }
+if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin
+   if op^.left^.opcode = pc_ldc then begin
+      if rOpcode in [pc_tjp,pc_fjp] then begin
+	 if op^.opcode = pc_geq then
+	    op^.opcode := pc_grt
+	 else
+	    op^.opcode := pc_geq;
+	 if rOpcode = pc_tjp then
+	    rOpcode := pc_fjp
+	 else
+	    rOpcode := pc_tjp;
+	 Switch;
+	 end; {if}
+      end; {if}
+
+   {If constant operands are involved, change > to >=		}
+   if op^.opcode = pc_grt then begin
+      if op^.left^.opcode = pc_ldc then begin
+         if (op^.left^.q > 0) or
+            ((op^.optype in [cgWord, cgByte]) and (op^.left^.q > -maxint)) then
+            begin
+            nop := pointer(malloc(sizeof(intermediate_code)));
+            nop^ := op^.left^;
+            op^.left := nop;
+            nop^.q := nop^.q - 1;
+            op^.opcode := pc_geq;
+            end; {if}
+         end {if}
+      else if op^.right^.opcode = pc_ldc then
+         if op^.right^.q < maxint then begin
+            nop := pointer(malloc(sizeof(intermediate_code)));
+            nop^ := op^.right^;                              
+            op^.right := nop;
+            nop^.q := nop^.q + 1;
+            op^.opcode := pc_geq;
+            end; {if}
+      end; {if}
+   end; {if}
+
+{Short cuts are available for single-word operands where the	  }
+{right operand is a constant.					  }
+if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
+   (op^.right^.opcode = pc_ldc) then begin
+   GenTree(op^.left);
+   num := op^.right^.q;
+   lab1 := GenLabel;
+   if rOpcode = pc_fjp then begin
+      if op^.optype in [cgByte,cgWord] then begin
+         if NeedsCondition(op^.left^.opcode) then
+            GenImplied(m_tax);
+	 if (num >= 0) and (num < 4) then begin
+	    if op^.opcode = pc_geq then begin
+	       if num <> 0 then begin
+		  lab2 := GenLabel;
+		  GenNative(m_bmi, relative, lab2, nil, 0);
+		  for i := 1 to num do
+		     GenImplied(m_dea);
+		  end; {if}
+	       GenNative(m_bpl, relative, lab1, nil, 0);
+	       if num <> 0 then
+		  GenLab(lab2);
+	       GenNative(m_brl, longrelative, lb, nil, 0);
+	       GenLab(lab1);
+	       end {if}
+	    else {if opcode = pc_grt then} begin
+	       lab2 := GenLabel;
+	       GenNative(m_bmi, relative, lab2, nil, 0);
+	       for i := 0 to num do
+		  GenImplied(m_dea);
+	       GenNative(m_bpl, relative, lab1, nil, 0);
+	       GenLab(lab2);
+	       GenNative(m_brl, longrelative, lb, nil, 0);
+	       GenLab(lab1);
+	       end; {else if}
+	    end {if (num >= 0) and (num < 4)}
+	 else begin
+	    lab2 := GenLabel;
+	    if num > 0 then
+	       GenNative(m_bmi, relative, lab1, nil, 0)
+	    else
+	       GenNative(m_bpl, relative, lab1, nil, 0);
+	    GenNative(m_cmp_imm, immediate, num, nil, 0);
+	    if op^.opcode = pc_grt then begin
+	       lab3 := GenLabel;
+	       GenNative(m_beq, relative, lab3, nil, 0);
+	       GenNative(m_bcs, relative, lab2, nil, 0);
+	       GenLab(lab3);
+	       end
+	    else
+	       GenNative(m_bcs, relative, lab2, nil, 0);
+	    if num > 0 then begin
+	       GenLab(lab1);
+	       GenNative(m_brl, longrelative, lb, nil, 0);
+	       end {if}
+	    else begin
+	       GenNative(m_brl, longrelative, lb, nil, 0);
+	       GenLab(lab1);
+	       end; {else}
+	    GenLab(lab2);
+	    end; {else if}
+	 end {if}
+      else {if optype in [cgUByte,cgUWord] then} begin
+	 GenNative(m_cmp_imm, immediate, num, nil, 0);
+	 if op^.opcode = pc_grt then begin
+	    lab2 := GenLabel;
+	    GenNative(m_beq, relative, lab2, nil, 0);
+	    end; {if}
+	 GenNative(m_bcs, relative, lab1, nil, 0);
+	 if op^.opcode = pc_grt then
+	    GenLab(lab2);
+	 GenNative(m_brl, longrelative, lb, nil, 0);
+	 GenLab(lab1);
+	 end; {else}
+      end {if rOpcode = pc_fjp}
+   else if rOpcode = pc_tjp then begin
+      if op^.optype in [cgByte,cgWord] then begin
+         if NeedsCondition(op^.left^.opcode) then
+            GenImplied(m_tax);
+	 if (num >= 0) and (num < 4) then begin
+	    lab2 := GenLabel;
+	    if op^.opcode = pc_geq then begin
+	       GenNative(m_bmi, relative, lab1, nil, 0);
+	       if num > 0 then begin
+		  for i := 1 to num do
+		  GenImplied(m_dea);
+		  GenNative(m_bmi, relative, lab2, nil, 0);
+		  end; {if}
+	       GenNative(m_brl, longrelative, lb, nil, 0);
+	       end {if}
+	    else {if op^.opcode = pc_grt then} begin
+	       if num > 0 then begin
+		  GenNative(m_bmi, relative, lab1, nil, 0);
+		  for i := 0 to num do
+		     GenImplied(m_dea);
+		  GenNative(m_bmi, relative, lab2, nil, 0);
+		  end {if}
+	       else begin
+		  GenNative(m_beq, relative, lab1, nil, 0);
+		  GenNative(m_bmi, relative, lab2, nil, 0);
+		  end; {else}
+	       GenNative(m_brl, longrelative, lb, nil, 0);
+	       end; {else}
+	    GenLab(lab2);
+	    GenLab(lab1);
+	    end {if (num >= 0) and (num < 4)}
+	 else begin
+	    lab2 := GenLabel;
+	    if num > 0 then
+	       GenNative(m_bmi, relative, lab1, nil, 0)
+	    else
+	       GenNative(m_bpl, relative, lab1, nil, 0);
+	    GenNative(m_cmp_imm, immediate, num, nil, 0);
+	    if op^.opcode = pc_grt then begin
+	       lab3 := GenLabel;
+	       GenNative(m_beq, relative, lab3, nil, 0);
+	       end; {if}
+	    GenNative(m_bcc, relative, lab2, nil, 0);
+	    if num > 0 then begin
+	       GenNative(m_brl, longrelative, lb, nil, 0);
+	       GenLab(lab2);
+	       GenLab(lab1);
+	       end {if}
+	    else begin
+	       GenLab(lab1);
+	       GenNative(m_brl, longrelative, lb, nil, 0);
+	       GenLab(lab2);
+	       end; {else}
+	    if op^.opcode = pc_grt then
+	       GenLab(lab3);
+	    end; {else}
+	 end {if}
+      else {if optype in [cgUByte,cgUWord] then} begin
+	 GenNative(m_cmp_imm, immediate, num, nil, 0);
+	 GenNative(m_bcc, relative, lab1, nil, 0);
+	 if op^.opcode = pc_grt then begin
+	    lab2 := GenLabel;
+	    GenNative(m_beq, relative, lab1, nil, 0);
+	    end; {if}
+	 GenNative(m_brl, longrelative, lb, nil, 0);
+	 if op^.opcode = pc_grt then
+	    GenLab(lab2);
+	 GenLab(lab1);
+	 end; {else}
+      end {if rOpcode = pc_tjp}
+   else if op^.optype in [cgByte,cgWord] then begin
+      lab2 := GenLabel;
+      GenNative(m_ldx_imm, immediate, 1, nil, 0);
+      GenImplied(m_sec);
+      GenNative(m_sbc_imm, immediate, num, nil, 0);
+      if op^.opcode = pc_grt then begin
+	 lab3 := GenLabel;
+	 GenNative(m_beq, relative, lab3, nil, 0);
+	 end; {if}
+      GenNative(m_bvs, relative, lab1, nil, 0);
+      GenNative(m_eor_imm, immediate, $8000, nil, 0);
+      GenLab(lab1);
+      GenNative(m_bmi, relative, lab2, nil, 0);
+      if op^.opcode = pc_grt then
+	 GenLab(lab3);
+      GenImplied(m_dex);
+      GenLab(lab2);
+      GenImplied(m_txa);
+      end {else if}
+   else begin
+      GenNative(m_ldx_imm, immediate, 0, nil, 0);
+      GenNative(m_cmp_imm, immediate, num, nil, 0);
+      GenNative(m_bcc, relative, lab1, nil, 0);
+      if op^.opcode = pc_grt then
+	 GenNative(m_beq, relative, lab1, nil, 0);
+      GenImplied(m_inx);
+      GenLab(lab1);
+      GenImplied(m_txa);
+      end; {else if}
+   end {if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
+      (op^.right^.opcode = pc_ldc)}
+
+{This section of code handles the cases where the above short	  }
+{cuts cannot be used.						  }
+else
+   case op^.optype of
+
+      cgByte,cgUByte,cgWord,cgUWord: begin
+	 if Complex(op^.right) then begin
+	    GenTree(op^.right);
+	    if Complex(op^.left) then begin
+	       GenImplied(m_pha);
+	       GenTree(op^.left);
+	       GenImplied(m_ply);
+	       GenNative(m_sty_dir, direct, dworkLoc, nil, 0);
+	       end {if}
+	    else begin
+	       GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
+	       GenTree(op^.left);
+	       end; {else}
+	    if not (rOpcode in [pc_fjp,pc_tjp]) then
+	       GenNative(m_ldx_imm, immediate, 1, nil, 0);
+	    if op^.optype in [cgByte,cgWord] then begin
+	       GenImplied(m_sec);
+	       GenNative(m_sbc_dir, direct, dworkLoc, nil, 0);
+	       end {if}
+	    else
+	       GenNative(m_cmp_dir, direct, dworkLoc, nil, 0);
+	    end {if}
+	 else begin
+	    GenTree(op^.left);
+	    if not (rOpcode in [pc_fjp,pc_tjp]) then
+	       GenNative(m_ldx_imm, immediate, 1, nil, 0);
+	    if op^.optype in [cgByte,cgWord] then begin
+	       GenImplied(m_sec);
+	       OperA(m_sbc_imm, op^.right);
+	       end {if}
+	    else
+	       OperA(m_cmp_imm, op^.right);
+	    end; {else}
+	 if rOpcode = pc_fjp then begin
+	    lab2 := GenLabel;
+	    if op^.opcode = pc_grt then begin
+	       lab3 := GenLabel;
+	       GenNative(m_beq, relative, lab3, nil, 0);
+	       end; {if}
+	    if op^.optype in [cgByte,cgWord] then begin
+	       lab1 := GenLabel;
+	       GenNative(m_bvs, relative, lab1, nil, 0);
+	       GenNative(m_eor_imm, immediate, $8000, nil, 0);
+	       GenLab(lab1);
+	       GenNative(m_bmi, relative, lab2, nil, 0);
+	       end {if}
+	    else
+	       GenNative(m_bcs, relative, lab2, nil, 0);
+	    if op^.opcode = pc_grt then
+	       GenLab(lab3);
+	    GenNative(m_brl, longrelative, lb, nil, 0);
+	    GenLab(lab2);
+	    end {if}
+	 else if rOpcode = pc_tjp then begin
+	    lab2 := GenLabel;
+	    if op^.opcode = pc_grt then begin
+	       lab3 := GenLabel;
+	       GenNative(m_beq, relative, lab3, nil, 0);
+	       end; {if}
+	    if op^.optype in [cgByte,cgWord] then begin
+	       lab1 := GenLabel;
+	       GenNative(m_bvs, relative, lab1, nil, 0);
+	       GenNative(m_eor_imm, immediate, $8000, nil, 0);
+	       GenLab(lab1);
+	       GenNative(m_bpl, relative, lab2, nil, 0);
+	       end {if}
+	    else
+	       GenNative(m_bcc, relative, lab2, nil, 0);
+	    GenNative(m_brl, longrelative, lb, nil, 0);
+	    if op^.opcode = pc_grt then
+	       GenLab(lab3);
+	    GenLab(lab2);
+	    end {else if}
+	 else begin
+	    lab2 := GenLabel;
+	    if op^.opcode = pc_grt then begin
+	       lab3 := GenLabel;
+	       GenNative(m_beq, relative, lab3, nil, 0);
+	       end; {if}
+	    if op^.optype in [cgByte,cgWord] then begin
+	       lab1 := GenLabel;
+	       GenNative(m_bvs, relative, lab1, nil, 0);
+	       GenNative(m_eor_imm, immediate, $8000, nil, 0);
+	       GenLab(lab1);
+	       GenNative(m_bmi, relative, lab2, nil, 0);
+	       end {if}
+	    else
+	       GenNative(m_bcs, relative, lab2, nil, 0);
+	    if op^.opcode = pc_grt then
+	       GenLab(lab3);
+	    GenImplied(m_dex);
+	    GenLab(lab2);
+	    GenImplied(m_txa);
+	    end; {else}
+	 end; {case optype of cgByte,cgUByte,cgWord,cgUWord}
+
+      cgULong: begin
+	 gLong.preference := onStack;
+	 GenTree(op^.right);
+	 gLong.preference := A_X;
+	 GenTree(op^.left);
+	 if gLong.where = onStack then begin
+	    GenImplied(m_ply);
+	    GenImplied(m_pla);
+	    end {if}
+	 else begin
+	    GenImplied(m_tay);
+	    GenImplied(m_txa);
+	    end; {else}
+	 lab1 := GenLabel;
+	 GenNative(m_ldx_imm, immediate, 1, nil, 0);
+	 GenNative(m_cmp_s, direct, 3, nil, 0);
+	 GenNative(m_bne, relative, lab1, nil, 0);
+	 GenImplied(m_tya);
+	 GenNative(m_cmp_s, direct, 1, nil, 0);
+	 GenLab(lab1);
+	 lab2 := GenLabel;
+	 if op^.opcode = pc_grt then begin
+	    lab3 := GenLabel;
+	    GenNative(m_beq, relative, lab3, nil, 0);
+	    end; {if}
+	 GenNative(m_bcs, relative, lab2, nil, 0);
+	 if op^.opcode = pc_grt then
+	    GenLab(lab3);
+	 GenImplied(m_dex);
+	 GenLab(lab2);
+	 GenImplied(m_pla);
+	 GenImplied(m_pla);
+	 GenImplied(m_txa);
+	 if rOpcode = pc_fjp then begin
+	    lab4 := GenLabel;
+	    GenNative(m_bne, relative, lab4, nil, 0);
+	    GenNative(m_brl, longrelative, lb, nil, 0);
+	    GenLab(lab4);
+	    end {if}
+	 else if rOpcode = pc_tjp then begin
+	    lab4 := GenLabel;
+	    GenNative(m_beq, relative, lab4, nil, 0);
+	    GenNative(m_brl, longrelative, lb, nil, 0);
+	    GenLab(lab4);
+	    end; {else if}
+	 end;
+
+      cgReal,cgDouble,cgComp,cgExtended,cgSet: begin
+	 GenTree(op^.left);
+	 GenTree(op^.right);
+         if op^.opType = cgSet then
+            GenCall(74)
+	 else {if op^.opType in [cgReal,cgDouble,cgComp,cgExtended] then}
+            if op^.opcode = pc_geq then
+	       GenCall(71)
+	    else
+	       GenCall(70);
+	 if (rOpcode = pc_fjp) or (rOpcode = pc_tjp) then begin
+	    lab1 := GenLabel;
+	    if rOpcode = pc_fjp then
+	       GenNative(m_bne, relative, lab1, nil, 0)
+	    else
+	       GenNative(m_beq, relative, lab1, nil, 0);
+	    GenNative(m_brl,longrelative,lb,nil,0);
+	    GenLab(lab1);
+	    end; {if}
+	 end; {case optype of cgReal..cgExtended,cgSet}
+
+      cgString: begin
+	 gLong.preference := onStack;
+	 GenTree(op^.left);
+	 if op^.left^.opcode <> pc_csp then begin
+	    if op^.r = -1 then begin
+	       GenImplied(m_pha);
+	       GenImplied(m_pha);
+	       end; {if}
+	    GenNative(m_pea, immediate, op^.r, nil, 0);
+	    end; {if}
+	 gLong.preference := onStack;
+	 GenTree(op^.right);
+	 if op^.right^.opcode <> pc_csp then begin
+	    if op^.q = -1 then begin
+	       GenImplied(m_pha);
+	       GenImplied(m_pha);
+	       end; {if}
+	    GenNative(m_pea, immediate, op^.q, nil, 0);
+	    end; {if}
+         if op^.opcode = pc_geq then
+	    GenCall(73)
+	 else
+	    GenCall(72);
+	 if (rOpcode = pc_fjp) or (rOpcode = pc_tjp) then begin
+	    lab1 := GenLabel;
+	    if rOpcode = pc_fjp then
+	       GenNative(m_bne, relative, lab1, nil, 0)
+	    else
+	       GenNative(m_beq, relative, lab1, nil, 0);
+	    GenNative(m_brl,longrelative,lb,nil,0);
+	    GenLab(lab1);
+	    end; {if}
+	 end; {case optype of cgString}
+
+      cgLong: begin
+	 gLong.preference := onStack;
+	 GenTree(op^.left);
+	 if op^.opcode = pc_geq then begin
+	    gLong.preference := A_X;
+	    GenTree(op^.right);
+	    if gLong.where = onStack then begin
+	       GenImplied(m_pla);
+	       GenImplied(m_plx);
+	       end; {if}
+	    num := 139;
+	    end {if}
+	 else begin
+	    gLong.preference := onStack;
+	    GenTree(op^.right);
+	    num := 138;
+	    end; {else}
+	 GenCall(num);
+	 if (rOpcode = pc_fjp) or (rOpcode = pc_tjp) then begin
+	    lab1 := GenLabel;
+	    if rOpcode = pc_fjp then
+	       GenNative(m_bne, relative, lab1, nil, 0)
+	    else
+	       GenNative(m_beq, relative, lab1, nil, 0);
+	    GenNative(m_brl, longrelative, lb, nil, 0);
+	    GenLab(lab1);
+	    end; {if}
+	 end; {case optype of cgLong}
+
+      otherwise:
+	 Error(cge1);
+      end; {case}
+end; {GenCmp}
+
+
+procedure GenCnv (op: icptr);
+
+{ generate a pc_cnv instruction					}
+
+const                                {note: these constants list all legal }
+                                     {      conversions; others are ignored}
+   cReal             = $06;
+   cDouble           = $07;
+   cComp             = $08;
+   cExtended         = $09;
+
+   byteToWord        = $02;
+   byteToUword       = $03;
+   byteToLong        = $04;
+   byteToUlong       = $05;
+   byteToReal        = $06;
+   byteToDouble      = $07;
+   ubyteToLong       = $14;
+   ubyteToUlong      = $15;
+   ubyteToReal       = $16;
+   ubyteToDouble     = $17;
+   wordToByte        = $20;
+   wordToUByte       = $21;
+   wordToLong        = $24;
+   wordToUlong       = $25;
+   wordToReal        = $26;
+   wordToDouble      = $27;
+   uwordToByte       = $30;
+   uwordToUByte      = $31;
+   uwordToLong       = $34;
+   uwordToUlong      = $35;
+   uwordToReal       = $36;
+   uwordToDouble     = $37;
+   longTobyte        = $40;
+   longToUbyte       = $41;
+   longToWord        = $42;
+   longToUword       = $43;
+   longToReal        = $46;
+   longToDouble      = $47;
+   ulongTobyte       = $50;
+   ulongToUbyte      = $51;
+   ulongToWord       = $52;
+   ulongToUword      = $53;
+   ulongToReal       = $56;
+   ulongToDouble     = $57;
+   realTobyte        = $60;
+   realToUbyte       = $61;
+   realToWord        = $62;
+   realToUword       = $63;
+   realToLong        = $64;
+   realToUlong       = $65;
+   doubleTobyte      = $70;
+   doubleToUbyte     = $71;
+   doubleToWord      = $72;
+   doubleToUword     = $73;
+   doubleToLong      = $74;
+   doubleToUlong     = $75;
+
+var
+   fromReal: boolean;			{are we converting from a real?}
+   lab1: integer;			{used for branches}
+   lLong: longType;			{used to reserve gLong}
+
+begin {GenCnv}
+lLong := gLong;
+gLong.preference := onStack+A_X+constant;
+gLong.where := onStack;
+if ((op^.q & $00F0) >> 4) in [cDouble,cExtended,cComp] then begin
+   op^.q := (op^.q & $000F) | (cReal * 16);
+   fromReal := true;
+   end {if}
+else
+   fromReal := false;
+if (op^.q & $000F) in [cDouble,cExtended,cComp] then
+   op^.q := (op^.q & $00F0) | cReal;
+GenTree(op^.left);
+if op^.q in [wordToLong,wordToUlong] then begin
+   lab1 := GenLabel;
+   GenNative(m_ldx_imm, immediate, 0, nil, 0);
+   GenImplied(m_tay);
+   GenNative(m_bpl, relative, lab1, nil, 0);
+   GenImplied(m_dex);
+   GenLab(lab1);
+   if (lLong.preference & A_X) <> 0 then
+      gLong.where := A_X
+   else begin
+      gLong.where := onStack;
+      GenImplied(m_phx);
+      GenImplied(m_pha);
+      end; {else}
+   end {if}
+else if op^.q in [byteToLong,byteToUlong] then begin
+   lab1 := GenLabel;
+   GenNative(m_ldx_imm, immediate, 0, nil, 0);
+   GenNative(m_bit_imm, immediate, $0080, nil, 0);
+   GenNative(m_beq, relative, lab1, nil, 0);
+   GenImplied(m_dex);
+   GenNative(m_ora_imm, immediate, $FF00, nil, 0);
+   GenLab(lab1);
+   if (lLong.preference & A_X) <> 0 then
+      gLong.where := A_X
+   else begin
+      gLong.where := onStack;
+      GenImplied(m_phx);
+      GenImplied(m_pha);
+      end; {else}
+   end {if}
+else if op^.q in [byteToWord,byteToUword] then begin
+   lab1 := GenLabel;
+   GenNative(m_bit_imm, immediate, $0080, nil, 0);
+   GenNative(m_beq, relative, lab1, nil, 0);
+   GenNative(m_ora_imm, immediate, $FF00, nil, 0);
+   GenLab(lab1);
+   end {if}
+else if op^.q in [ubyteToLong,ubyteToUlong,uwordToLong,uwordToUlong] then
+   begin
+   if (lLong.preference & A_X) <> 0 then begin
+      gLong.where := A_X;
+      GenNative(m_ldx_imm, immediate, 0, nil, 0);
+      end {if}
+   else begin
+      gLong.where := onStack;
+      GenNative(m_pea, immediate, 0, nil, 0);
+      GenImplied(m_pha);
+      end; {else}
+   end {else if}
+else if op^.q in [wordToByte,wordToUbyte,uwordToByte,uwordToUbyte] then
+   GenNative(m_and_imm, immediate, $00FF, nil, 0)
+else if op^.q in [byteToReal,uByteToReal,wordToReal,uWordToReal] then
+   GenCall(36)
+else if op^.q in [longToByte,longToUbyte,ulongToByte,ulongToUbyte] then begin
+   if gLong.where = A_X then
+      GenNative(m_and_imm, immediate, $00FF, nil, 0)
+   else if gLong.where = constant then
+      GenNative(m_lda_imm, immediate, long(gLong.lval).lsw & $00FF, nil, 0)
+   else {if gLong.where = onStack then} begin
+      GenImplied(m_pla);
+      GenImplied(m_plx);
+      GenNative(m_and_imm, immediate, $00FF, nil, 0);
+      end; {else if}
+   end {else if}
+else if op^.q in [longToWord,longToUword,ulongToWord,ulongToUword] then begin
+   {Note: if the result is in A_X, no further action is needed}
+   if gLong.where = constant then
+      GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0)
+   else if gLong.where = onStack then begin
+      GenImplied(m_pla);
+      GenImplied(m_plx);
+      end; {else if}
+   end {else if}
+else if op^.q in [longToReal,uLongToReal] then begin
+   if gLong.where = constant then begin
+      GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
+      GenNative(m_ldx_imm, immediate, long(gLong.lval).msw, nil, 0);
+      end {if}
+   else if gLong.where = onStack then begin
+      GenImplied(m_pla);
+      GenImplied(m_plx);
+      end; {else if}
+   GenCall(166);
+   end {else}
+else if op^.q in [realToByte,realToUbyte,realToWord,realToUWord] then begin
+   GenCall(37);
+   if (op^.q & $00FF) in [0,1] then
+      GenNative(m_and_imm, immediate, $00FF, nil, 0);
+   end {else if}
+else if op^.q in [realToLong,realToUlong] then begin
+   GenCall(150);
+   if (lLong.preference & A_X) <> 0 then
+      gLong.where := A_X
+   else begin
+      gLong.where := onStack;
+      GenImplied(m_phx);
+      GenImplied(m_pha);
+      end; {else}
+   end {else if}
+else if (lLong.preference & gLong.where = 0)
+   and ((op^.q & $000F) <> ord(cgVoid)) then begin
+   if gLong.where = constant then begin
+      GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0);
+      GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0);
+      end {if}
+   else if gLong.where = A_X then begin
+      GenImplied(m_phx);
+      GenImplied(m_pha);
+      end; {else if}
+   gLong.where := onStack;
+   end; {else if}
+end; {GenCnv}
+
+
+procedure GenEquNeq (op: icptr; opcode: pcodes; lb: integer);
+
+{ generate a pc_equ or pc_neq instruction			}
+{								}
+{ parameters:							}
+{    op - node to generate the compare for			}
+{    opcode - Opcode that will use the result of the compare.	}
+{	If the result is used by a tjp or fjp, this procedure	}
+{	 generates special code and does the branch internally.	}
+{    lb - For fjp, tjp, this is the label to branch to if	}
+{	 the condition is satisfied.				}
+
+var
+   nd: icptr;				{work node}
+   num: integer; 			{constant to compare to}
+   lab1,lab2: integer;			{label numbers}
+   bne: integer; 			{instruction for a pc_equ bne branch}
+   beq: integer; 			{instruction for a pc_equ beq branch}
+   lLong: longType;			{local long value information}
+   leftOp,rightOp: pcodes;		{opcode codes to left, right}
+
+
+   procedure DoOr (op: icptr);
+
+   { or the two halves of a four byte value			}
+   {								}
+   { parameters: 						}
+   {	operand to or						}
+
+   var
+      disp: integer;			{disp of value on stack frame}
+
+   begin {DoOr}
+   with op^ do begin
+      if opcode = pc_ldo then begin
+	 GenNative(m_lda_abs, absolute, q, lab, 0);
+	 GenNative(m_ora_abs, absolute, q+2, lab, 0);
+	 end {if}
+      else begin
+	 disp := localLabel[r] + q;
+	 if disp < 254 then begin
+	    GenNative(m_lda_dir, direct, disp, nil, 0);
+	    GenNative(m_ora_dir, direct, disp+2, nil, 0);
+	    end {else if}
+	 else begin
+	    GenNative(m_ldx_imm, immediate, disp, nil, 0);
+	    GenNative(m_lda_dirX, direct, 0, nil, 0);
+	    GenNative(m_ora_dirX, direct, 2, nil, 0);
+	    end; {else}
+	 end; {else}
+      end; {with}
+   end; {DoOr}
+
+
+   procedure DoCmp (op: icPtr);
+
+   { compare a long value in A_X to a local or global scalar	}
+   {								}
+   { parameters: 						}
+   {	op - value to compare to 				}
+
+   var
+      disp: integer;			{disp of value on stack frame}
+      lab1: integer;			{label numbers}
+
+   begin {DoCmp}
+   lab1 := GenLabel;
+   with op^ do begin
+      if opcode = pc_ldo then begin
+	 GenNative(m_cmp_abs, absolute, q, lab, 0);
+	 GenNative(m_bne, relative, lab1, nil, 0);
+	 GenNative(m_cpx_abs, absolute, q+2, lab, 0);
+	 end {if}
+      else begin
+	 disp := localLabel[r] + q;
+	 if disp < 254 then begin
+	    GenNative(m_cmp_dir, direct, disp, nil, 0);
+	    GenNative(m_bne, relative, lab1, nil, 0);
+	    GenNative(m_cpx_dir, direct, disp+2, nil, 0);
+	    end {if}
+	 else begin
+	    GenImplied(m_txy);
+	    GenNative(m_ldx_imm, immediate, disp, nil, 0);
+	    GenNative(m_cmp_dirX, direct, 0, nil, 0);
+	    GenNative(m_bne, relative, lab1, nil, 0);
+	    GenImplied(m_tya);
+	    GenNative(m_cmp_dirX, direct, 2, nil, 0);
+	    end; {else}
+	 end; {else}
+      GenLab(lab1);
+      end; {with}
+   end; {DoCmp}
+
+
+begin {GenEquNeq}
+if op^.opcode = pc_equ then begin
+   bne := m_bne;
+   beq := m_beq;
+   end {if}
+else begin
+   bne := m_beq;
+   beq := m_bne;
+   end; {else}
+if op^.optype <> cgString then begin
+   if op^.left^.opcode in [pc_lod,pc_ldo] then begin
+      nd := op^.left;
+      op^.left := op^.right;
+      op^.right := nd;
+      end; {if}
+   if op^.left^.opcode = pc_ldc then begin
+      nd := op^.left;
+      op^.left := op^.right;
+      op^.right := nd;
+      end; {if}
+   end; {if}
+leftOp := op^.left^.opcode;		{set op codes for fast access}
+rightOp := op^.right^.opcode;
+if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
+   (rightOp = pc_ldc) then begin
+   GenTree(op^.left);
+   num := op^.right^.q;
+   lab1 := GenLabel;
+   if opcode in [pc_fjp,pc_tjp] then begin
+      if num <> 0 then
+	 GenNative(m_cmp_imm, immediate, num, nil, 0)
+      else if NeedsCondition(leftOp) then
+	 GenImplied(m_tay);
+      if opcode = pc_fjp then
+	 GenNative(beq, relative, lab1, nil, 0)
+      else
+	 GenNative(bne, relative, lab1, nil, 0);
+      GenNative(m_brl, longrelative, lb, nil, 0);
+      GenLab(lab1);
+      end {if}
+   else begin
+      GenNative(m_ldx_imm, immediate, 0, nil, 0);
+      GenNative(m_cmp_imm, immediate, num, nil, 0);
+      GenNative(bne, relative, lab1, nil, 0);
+      GenImplied(m_inx);
+      GenLab(lab1);
+      GenImplied(m_txa);
+      end; {else}
+   end {if}
+else if (op^.optype in [cgLong,cgULong])
+   and ((leftOp = pc_ldo) or ((leftOp = pc_lod) and (op^.left^.p = 0)))
+   and (rightOp = pc_ldc) and (op^.right^.lval = 0) then begin
+   if opcode in [pc_fjp,pc_tjp] then begin
+      DoOr(op^.left);
+      lab1 := GenLabel;
+      if opcode = pc_fjp then
+	 GenNative(beq, relative, lab1, nil, 0)
+      else
+	 GenNative(bne, relative, lab1, nil, 0);
+      GenNative(m_brl, longrelative, lb, nil, 0);
+      GenLab(lab1);
+      end {if}
+   else if op^.opcode = pc_equ then begin
+      lab1 := GenLabel;
+      lab2 := GenLabel;
+      DoOr(op^.left);
+      GenNative(bne, relative, lab1, nil, 0);
+      GenNative(m_lda_imm, immediate, 1, nil, 0);
+      GenNative(m_bra, relative, lab2, nil, 0);
+      GenLab(lab1);
+      GenNative(m_lda_imm, immediate, 0, nil, 0);
+      GenLab(lab2);
+      end {else if}
+   else {if op^.opcode = pc_neq then} begin
+      lab1 := GenLabel;
+      DoOr(op^.left);
+      GenNative(m_beq, relative, lab1, nil, 0);
+      GenNative(m_lda_imm, immediate, 1, nil, 0);
+      GenLab(lab1);
+      end; {else if}
+   end {else if}
+else if (op^.optype in [cgLong,cgULong])
+   and ((rightOp = pc_ldo) or ((rightOp = pc_lod) and (op^.right^.p = 0)))
+   then begin
+   gLong.preference := A_X;
+   GenTree(op^.left);
+   if gLong.where = onStack then begin
+      GenImplied(m_pla);
+      GenImplied(m_plx);
+      end; {if}
+   if opcode in [pc_fjp,pc_tjp] then begin
+      DoCmp(op^.right);
+      lab1 := GenLabel;
+      if opcode = pc_fjp then
+	 GenNative(beq, relative, lab1, nil, 0)
+      else
+	 GenNative(bne, relative, lab1, nil, 0);
+      GenNative(m_brl, longrelative, lb, nil, 0);
+      GenLab(lab1);
+      end {if}
+   else begin
+      lab1 := GenLabel;
+      lab2 := GenLabel;
+      DoCmp(op^.right);
+      GenNative(bne, relative, lab1, nil, 0);
+      GenNative(m_lda_imm, immediate, 1, nil, 0);
+      GenNative(m_bra, relative, lab2, nil, 0);
+      GenLab(lab1);
+      GenNative(m_lda_imm, immediate, 0, nil, 0);
+      GenLab(lab2);
+      end; {else}
+   end {else if}
+else
+   case op^.optype of
+
+      cgByte,cgUByte,cgWord,cgUWord: begin
+	 if not Complex(op^.left) then
+	    if Complex(op^.right) then begin
+	       nd := op^.left;
+	       op^.left := op^.right;
+	       op^.right := nd;
+	       end; {if}
+	 GenTree(op^.left);
+	 if Complex(op^.right) or (not (opcode in [pc_fjp,pc_tjp])) then begin
+	    GenImplied(m_pha);
+	    GenTree(op^.right);
+	    GenImplied(m_sec);
+	    GenNative(m_sbc_s, direct, 1, nil, 0);
+	    GenImplied(m_plx);
+	    GenImplied(m_tax);
+	    if opcode in [pc_fjp,pc_tjp] then begin
+	       lab1 := GenLabel;
+	       if opcode = pc_fjp then
+		  GenNative(beq, relative, lab1, nil, 0)
+	       else
+		  GenNative(bne, relative, lab1, nil, 0);
+	       GenNative(m_brl, longrelative, lb, nil, 0);
+	       GenLab(lab1);
+	       end {if}
+	    else begin
+	       lab1 := GenLabel;
+	       GenNative(m_beq, relative, lab1, nil, 0);
+	       GenNative(m_lda_imm, immediate, 1, nil, 0);
+	       GenLab(lab1);
+	       if op^.opcode = pc_equ then
+		  GenNative(m_eor_imm, immediate, 1, nil, 0);
+	       end; {else}
+	    end {if}
+	 else begin
+	    OperA(m_cmp_imm, op^.right);
+	    lab1 := GenLabel;
+	    if opcode = pc_fjp then
+	       GenNative(beq, relative, lab1, nil, 0)
+	    else
+	       GenNative(bne, relative, lab1, nil, 0);
+	    GenNative(m_brl, longrelative, lb, nil, 0);
+	    GenLab(lab1);
+	    end; {else}
+	 end; {case optype of cgByte,cgUByte,cgWord,cgUWord}
+
+      cgLong,cgULong: begin
+	 gLong.preference := onStack;
+	 GenTree(op^.left);
+	 lLong := gLong;
+	 gLong.preference := A_X;
+	 GenTree(op^.right);
+	 if gLong.where = onStack then begin
+	    GenImplied(m_pla);
+	    GenImplied(m_plx);
+	    end; {if}
+	 GenNative(m_ldy_imm, immediate, 1, nil, 0);
+	 GenNative(m_cmp_s, direct, 1, nil, 0);
+	 lab1 := GenLabel;
+	 GenNative(m_beq, relative, lab1, nil, 0);
+	 GenImplied(m_dey);
+	 GenLab(lab1);
+	 GenImplied(m_txa);
+	 GenNative(m_cmp_s, direct, 3, nil, 0);
+	 lab1 := GenLabel;
+	 GenNative(m_beq, relative, lab1, nil, 0);
+	 GenNative(m_ldy_imm, immediate, 0, nil, 0);
+	 GenLab(lab1);
+	 GenImplied(m_pla);
+	 GenImplied(m_pla);
+	 GenImplied(m_tya);
+	 if opcode in [pc_fjp,pc_tjp] then begin
+	    lab1 := GenLabel;
+	    if opcode = pc_fjp then
+	       GenNative(bne, relative, lab1, nil, 0)
+	    else
+	       GenNative(beq, relative, lab1, nil, 0);
+	    GenNative(m_brl, longrelative, lb, nil, 0);
+	    GenLab(lab1);
+	    end {if}
+	 else if op^.opcode = pc_neq then
+	    GenNative(m_eor_imm, immediate, 1, nil, 0);
+	 end; {case optype of cgLong,cgULong}
+
+      cgReal,cgDouble,cgComp,cgExtended,cgSet: begin
+         gLong.preference := onStack;
+	 GenTree(op^.left);
+         gLong.preference := onStack;
+	 GenTree(op^.right);         
+         if op^.optype = cgSet then
+	    GenCall(30)
+         else
+	    GenCall(31);
+	 if opcode in [pc_fjp,pc_tjp] then begin
+	    lab1 := GenLabel;
+	    if opcode = pc_fjp then
+	       GenNative(bne, relative, lab1, nil, 0)
+	    else
+	       GenNative(beq, relative, lab1, nil, 0);
+	    GenNative(m_brl, longrelative, lb, nil, 0);
+	    GenLab(lab1);
+	    end {if}
+	 else if op^.opcode = pc_neq then
+	    GenNative(m_eor_imm, immediate, 1, nil, 0);
+	 end; {case optype of cgReal..cgExtended, cgSet}
+
+      cgString: begin
+         gLong.preference := onStack;
+	 GenTree(op^.left);
+         if op^.left^.opcode <> pc_csp then begin
+            if op^.r = -1 then begin
+               GenImplied(m_pha);
+               GenImplied(m_pha);
+               end; {if}
+            GenNative(m_pea, immediate, op^.r, nil, 0);
+            end; {if}
+         gLong.preference := onStack;
+	 GenTree(op^.right);
+         if op^.right^.opcode <> pc_csp then begin
+            if op^.q = -1 then begin
+               GenImplied(m_pha);
+               GenImplied(m_pha);
+               end; {if}
+            GenNative(m_pea, immediate, op^.q, nil, 0);
+            end; {if}
+	 GenCall(69);
+	 if opcode in [pc_fjp,pc_tjp] then begin
+	    lab1 := GenLabel;
+	    if opcode = pc_fjp then
+	       GenNative(bne, relative, lab1, nil, 0)
+	    else
+	       GenNative(beq, relative, lab1, nil, 0);
+	    GenNative(m_brl, longrelative, lb, nil, 0);
+	    GenLab(lab1);
+	    end {if}
+	 else if op^.opcode = pc_neq then
+	    GenNative(m_eor_imm, immediate, 1, nil, 0);
+	 end; {case optype of cgString}
+
+      otherwise:
+	 Error(cge1);
+      end; {case}
+end; {GenEquNeq}
+
+
+procedure GenIncDec (op, save: icptr);
+
+{ generate code for pc_inc, pc_dec				}
+{								}
+{ parameters:							}
+{    op - pc_inc or pc_dec operation				}
+{    save - save location (pc_str or pc_sro) or nil		}
+
+var
+   disp: integer;			{disp in stack frame}
+   lab1: integer;			{branch point}
+   opcode: pcodes;			{temp storage for op code}
+   short: boolean;			{doing a one-byte save?}
+   size: integer;			{number to increment by}
+   clc,ina,adc: integer; 		{instructions to generate}
+
+begin {GenIncDec}
+{set up local variables}
+opcode := op^.opcode;
+size := op^.q;
+
+if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin
+   if SameLoc(op^.left, save) and (save^.p = 0) and (size = 1) then begin
+      if opcode = pc_inc then
+	 DoOp(0, m_inc_abs, m_inc_dir, op^.left, 0)
+      else {if opcode = pc_dec then}
+	 DoOp(0, m_dec_abs, m_dec_dir, op^.left, 0);
+      end {if}
+   else begin
+      GenTree(op^.left);
+      if opcode = pc_inc then begin
+	 clc := m_clc;
+	 ina := m_ina;
+	 adc := m_adc_imm;
+	 end {if}
+      else begin
+	 clc := m_sec;
+	 ina := m_dea;
+	 adc := m_sbc_imm;
+	 end; {else}
+      if size = 1 then
+	 GenImplied(ina)
+      else if size = 2 then begin
+	 GenImplied(ina);
+	 GenImplied(ina);
+	 end {else if}
+      else if size <> 0 then begin
+	 GenImplied(clc);
+	 GenNative(adc, immediate, size, nil, 0);
+	 if rangeCheck then
+	    GenCall(147);
+	 end; {else if}
+      if save <> nil then begin
+         short := save^.optype in [cgByte,cgUByte];
+	 if save^.opcode = pc_str then begin
+	    disp := localLabel[save^.r] + save^.q;
+            if save^.p <> 0 then begin
+	       StaticLink(save^.p, true, false);
+               if short then
+	          GenNative(m_sep, immediate, 32, nil, 0);
+	       GenNative(m_sta_longX, longAbsolute, disp, nil, 0);
+               end {if}
+	    else if disp < 254 then begin
+               if short then
+	          GenNative(m_sep, immediate, 32, nil, 0);
+	       GenNative(m_sta_dir, direct, disp, nil, 0);
+               end {else if}
+	    else begin
+               if short then
+	          GenNative(m_sep, immediate, 32, nil, 0);
+	       GenNative(m_ldx_imm, immediate, disp, nil, 0);
+	       GenNative(m_sta_dirX, direct, 0, nil, 0);
+	       end; {else}
+	    end {else if}
+	 else {if save^.opcode = pc_sro then} begin
+            if short then
+	       GenNative(m_sep, immediate, 32, nil, 0);
+	    if smallMemoryModel then
+	       GenNative(m_sta_abs, absolute, save^.q, save^.lab, 0)
+	    else
+	       GenNative(m_sta_long, longabsolute, save^.q, save^.lab, 0);
+	    end; {else}
+         if short then
+	    GenNative(m_rep, immediate, 32, nil, 0);
+         end; {if}
+      end {else}
+   end {if}
+else if op^.optype in [cgLong,cgULong] then begin
+   if SameLoc(op^.left, save) and (save^.p = 0) then begin
+      lab1 := GenLabel;
+      if size = 1 then begin
+	 if opcode = pc_inc then begin
+	    DoOp(0, m_inc_abs, m_inc_dir, op^.left, 0);
+	    GenNative(m_bne, relative, lab1, nil, 0);
+	    DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2);
+	    GenLab(lab1);
+	    end {if}
+	 else {if opcode = pc_dec then} begin
+	    DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
+	    GenNative(m_bne, relative, lab1, nil, 0);
+	    DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2);
+	    GenLab(lab1);
+	    DoOp(0, m_dec_abs, m_dec_dir, op^.left, 0);
+	    end; {else}
+	 end {if}
+      else if opcode = pc_inc then begin
+	 GenImplied(m_clc);
+	 DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
+	 GenNative(m_adc_imm, immediate, size, nil, 0);
+	 DoOp(0, m_sta_abs, m_sta_dir, op^.left, 0);
+	 GenNative(m_bcc, relative, lab1, nil, 0);
+	 DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2);
+	 GenLab(lab1);
+	 end {else if}
+      else begin
+	 GenImplied(m_sec);
+	 DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
+	 GenNative(m_sbc_imm, immediate, size, nil, 0);
+	 DoOp(0, m_sta_abs, m_sta_dir, op^.left, 0);
+	 GenNative(m_bcs, relative, lab1, nil, 0);
+	 DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2);
+	 GenLab(lab1);
+	 end; {else}
+      end {if}
+   else begin
+      if save <> nil then
+	 gLong.preference := A_X
+      else
+	 gLong.preference := gLong.preference & (A_X | inpointer);
+      if opcode = pc_dec then
+	 gLong.preference := gLong.preference & A_X;
+      GenTree(op^.left);
+      if opcode = pc_inc then
+	 IncAddr(size)
+      else begin
+	 lab1 := GenLabel;
+	 if gLong.where = A_X then begin
+	    GenImplied(m_sec);
+	    GenNative(m_sbc_imm, immediate, size, nil, 0);
+	    GenNative(m_bcs, relative, lab1, nil, 0);
+	    GenImplied(m_dex);
+	    end {if}
+	 else begin
+	    GenImplied(m_sec);
+	    GenNative(m_lda_s, direct, 1, nil, 0);
+	    GenNative(m_sbc_imm, immediate, size, nil, 0);
+	    GenNative(m_sta_s, direct, 1, nil, 0);
+	    GenNative(m_bcs, relative, lab1, nil, 0);
+	    GenNative(m_lda_s, direct, 3, nil, 0);
+	    GenImplied(m_dea);
+	    GenNative(m_sta_s, direct, 3, nil, 0);
+	    end; {else}
+	 GenLab(lab1);
+	 end; {else}
+      if save <> nil then
+	 if save^.opcode = pc_str then begin
+	    disp := localLabel[save^.r] + save^.q;
+            if save^.p <> 0 then begin
+	       if gLong.where = A_X then begin
+                  GenImplied(m_phx);
+                  GenImplied(m_pha);
+                  end; {if}
+	       StaticLink(save^.p, false, false);
+	       GenImplied(m_pla);
+	       GenNative(m_sta_longX, longAbsolute, disp, nil, 0);
+	       GenImplied(m_pla);
+	       GenNative(m_sta_longX, longAbsolute, disp+2, nil, 0);
+               end {if}
+	    else if disp < 254 then begin
+	       if gLong.where = onStack then
+		  GenImplied(m_pla);
+	       GenNative(m_sta_dir, direct, disp, nil, 0);
+	       if gLong.where = onStack then
+		  GenImplied(m_plx);
+	       GenNative(m_stx_dir, direct, disp+2, nil, 0);
+	       end {else if}
+	    else begin
+	       if gLong.where = A_X then
+		  GenImplied(m_txy);
+	       GenNative(m_ldx_imm, immediate, disp, nil, 0);
+	       if gLong.where = onStack then
+		  GenImplied(m_pla);
+	       GenNative(m_sta_dirX, direct, 0, nil, 0);
+	       if gLong.where = onStack then
+		  GenImplied(m_pla)
+	       else
+		  GenImplied(m_tya);
+	       GenNative(m_sta_dirX, direct, 2, nil, 0);
+	       end; {else}
+	    end {else if}
+	 else {if save^.opcode = pc_sro then} begin
+	    if gLong.where = onStack then
+	       GenImplied(m_pla);
+	    if smallMemoryModel then
+	       GenNative(m_sta_abs, absolute, save^.q, save^.lab, 0)
+	    else
+	       GenNative(m_sta_long, longabsolute, save^.q, save^.lab, 0);
+	    if smallMemoryModel then begin
+	       if gLong.where = onStack then
+		  GenImplied(m_plx);
+	       GenNative(m_stx_abs, absolute, save^.q+2, save^.lab, 0)
+	       end {if}
+	    else begin
+	       if gLong.where = onStack then
+		  GenImplied(m_pla)
+	       else
+		  GenImplied(m_txa);
+	       GenNative(m_sta_long, longabsolute, save^.q+2, save^.lab, 0);
+	       end; {else}
+	    end; {else}
+      end; {else}
+   end; {else if}
+end; {GenIncDec}
+
+
+procedure GenInd (op: icptr);
+
+{ Generate code for a pc_ind					}
+
+var
+   lab1: integer;			{label}
+   lLong: longType;			{requested address type}
+   optype: baseTypeEnum; 		{op^.optype}
+   q: integer;				{op^.q}
+
+begin {GenInd}
+optype := op^.optype;
+q := op^.q;
+case optype of
+   cgReal,cgDouble,cgComp,cgExtended: begin
+      gLong.preference := onStack;
+      GenTree(op^.left);
+      if q <> 0 then
+	 IncAddr(q);
+      if optype = cgReal then
+	 GenCall(25)
+      else if optype = cgDouble then
+	 GenCall(18)
+      else if optype = cgComp then
+	 GenCall(163)
+      else if optype = cgExtended then
+	 GenCall(164);
+      end; {case cgReal,cgDouble,cgComp,cgExtended}
+
+   cgLong,cgULong: begin
+      lLong := gLong;
+      GetPointer(op^.left);
+      if gLong.where = inPointer then begin
+	 if q = 0 then begin
+	    if gLong.fixedDisp then begin
+	       GenNative(m_ldy_imm, immediate, 2, nil, 0);
+	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
+	       if (A_X & lLong.preference) <> 0 then
+		  GenImplied(m_tax)
+	       else
+		  GenImplied(m_pha);
+	       GenNative(m_lda_indl, direct, gLong.disp, nil, 0);
+	       end {if}
+	    else begin
+	       GenImplied(m_iny);
+	       GenImplied(m_iny);
+	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
+	       if (A_X & lLong.preference) <> 0 then
+		  GenImplied(m_tax)
+	       else
+		  GenImplied(m_pha);
+	       GenImplied(m_dey);
+	       GenImplied(m_dey);
+	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
+	       end; {else}
+	    if (A_X & lLong.preference) = 0 then
+	       GenImplied(m_pha);
+	    end {if q = 0}
+	 else begin
+	    if gLong.fixedDisp then begin
+	       GenNative(m_ldy_imm, immediate, q+2, nil, 0);
+	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
+	       if (A_X & lLong.preference) <> 0 then
+		  GenImplied(m_tax)
+	       else
+		  GenImplied(m_pha);
+	       GenNative(m_ldy_imm, immediate, q, nil, 0);
+	       end {if}
+	    else begin
+	       GenImplied(m_tya);
+	       GenImplied(m_clc);
+	       GenNative(m_adc_imm, immediate, q+2, nil, 0);
+	       GenImplied(m_tay);
+	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
+	       if (A_X & lLong.preference) <> 0 then
+		  GenImplied(m_tax)
+	       else
+		  GenImplied(m_pha);
+	       GenImplied(m_dey);
+	       GenImplied(m_dey);
+	       end; {else}
+	    GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
+	    if (A_X & lLong.preference) = 0 then
+	       GenImplied(m_pha);
+	    end; {else}
+	 end {if glong.where = inPointer}
+      else if gLong.where = localAddress then begin
+	 gLong.disp := gLong.disp+q;
+	 if gLong.fixedDisp then
+	    if (gLong.disp < 254) and (gLong.disp >= 0) then begin
+	       GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
+	       GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
+	       end {if}
+	    else begin
+	       GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
+	       GenNative(m_lda_dirX, direct, 0, nil, 0);
+	       GenNative(m_ldy_dirX, direct, 2, nil, 0);
+	       GenImplied(m_tyx);
+	       end {else}
+	 else begin
+	    if (gLong.disp >= 254) or (gLong.disp < 0) then begin
+	       GenImplied(m_txa);
+	       GenImplied(m_clc);
+	       GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
+	       GenImplied(m_tax);
+	       gLong.disp := 0;
+	       end; {if}
+	    GenNative(m_ldy_dirX, direct, gLong.disp+2, nil, 0);
+	    GenNative(m_lda_dirX, direct, gLong.disp, nil, 0);
+	    GenImplied(m_tyx);
+	    end; {else}
+	 if (A_X & lLong.preference) = 0 then begin
+	    GenImplied(m_phx);
+	    GenImplied(m_pha);
+	    end; {if}
+	 end {else if gLong.where = localAddress}
+      else {if gLong.where = globalLabel then} begin
+	 gLong.disp := gLong.disp+q;
+	 if gLong.fixedDisp then
+	    if smallMemoryModel then begin
+	       GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0);
+	       GenNative(m_ldx_abs, absolute, gLong.disp+2, gLong.lab, 0);
+	       end {if}
+	    else begin
+	       GenNative(m_lda_long, longAbs, gLong.disp+2, gLong.lab, 0);
+	       GenImplied(m_tax);
+	       GenNative(m_lda_long, longAbs, gLong.disp, gLong.lab, 0);
+	       end {else}
+	 else
+	    if smallMemoryModel then begin
+	       GenNative(m_ldy_absX, absolute, gLong.disp+2, gLong.lab, 0);
+	       GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0);
+	       GenImplied(m_tyx);
+	       end {if}
+	    else begin
+	       GenNative(m_lda_longX, longAbs, gLong.disp+2, gLong.lab, 0);
+	       GenImplied(m_tay);
+	       GenNative(m_lda_longX, longAbs, gLong.disp, gLong.lab, 0);
+	       GenImplied(m_tyx);
+	       end; {else}
+	 if (A_X & lLong.preference) = 0 then begin
+	    GenImplied(m_phx);
+	    GenImplied(m_pha);
+	    end; {if}
+	 end; {else}
+      if (A_X & lLong.preference) <> 0 then
+	 gLong.where := A_X
+      else
+	 gLong.where := onStack;
+      end; {cgLong,cgULong}
+
+   cgByte,cgUByte,cgWord,cgUWord: begin
+      GetPointer(op^.left);
+      if gLong.where = inPointer then begin
+	 if q = 0 then
+	    if gLong.fixedDisp then
+	       GenNative(m_lda_indl, direct, gLong.disp, nil, 0)
+	    else
+	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0)
+	 else
+	    if gLong.fixedDisp then begin
+	       GenNative(m_ldy_imm, immediate, q, nil, 0);
+	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0)
+	       end {if}
+	    else begin
+	       GenImplied(m_tya);
+	       GenImplied(m_clc);
+	       GenNative(m_adc_imm, immediate, q, nil, 0);
+	       GenImplied(m_tay);
+	       GenNative(m_lda_indly, direct, gLong.disp, nil, 0)
+	       end; {else}
+	 end {if}
+      else if gLong.where = localAddress then begin
+	 gLong.disp := gLong.disp+q;
+	 if gLong.fixedDisp then
+	    if (gLong.disp & $FF00) = 0 then
+	       GenNative(m_lda_dir, direct, gLong.disp, nil, 0)
+	    else begin
+	       GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
+	       GenNative(m_lda_dirX, direct, 0, nil, 0);
+	       end {else}
+	 else
+	    if (gLong.disp & $FF00) = 0 then
+	       GenNative(m_lda_dirX, direct, gLong.disp, nil, 0)
+	    else begin
+	       GenImplied(m_txa);
+	       GenImplied(m_clc);
+	       GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
+	       GenImplied(m_tax);
+	       GenNative(m_lda_dirX, direct, 0, nil, 0);
+	       end {else}
+	 end {else if}
+      else {if gLong.where = globalLabel then} begin
+	 gLong.disp := gLong.disp+q;
+	 if gLong.fixedDisp then
+	    if smallMemoryModel then
+	       GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0)
+	    else
+	       GenNative(m_lda_long, longAbs, gLong.disp, gLong.lab, 0)
+	 else
+	    if smallMemoryModel then
+	       GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0)
+	    else
+	       GenNative(m_lda_longX, longAbs, gLong.disp, gLong.lab, 0)
+	 end; {else}
+      if optype in [cgByte,cgUByte] then begin
+	 GenNative(m_and_imm, immediate, 255, nil, 0);
+	 if optype = cgByte then begin
+	    GenNative(m_cmp_imm, immediate, 128, nil, 0);
+	    lab1 := GenLabel;
+	    GenNative(m_bcc, relative, lab1, nil, 0);
+	    GenNative(m_ora_imm, immediate, $FF00, nil, 0);
+	    GenLab(lab1);
+	    end; {if}
+	 end; {if}
+      end; {case cgByte,cgUByte,cgWord,cgUWord}
+
+   cgSet: begin
+      gLong.preference := onStack;
+      GenTree(op^.left);
+      if op^.r <> 0 then
+	 IncAddr(op^.r);
+      GenNative(m_pea, immediate, q, nil, 0);
+      GenCall(28);
+      end; {case cgSet}
+
+   otherwise: ;
+   end; {case}
+end; {GenInd}
+
+
+procedure GenIxa (op: icptr);
+
+{ Generate code for a pc_ixa					}
+
+var
+   lab1: integer;			{branch label}
+   lLong: longType;			{type of address}
+   zero: boolean;			{is the index 0?}
+
+
+   procedure Index;
+
+   { Get the index size						}
+
+   var
+      lLong: longType;			{temp for preserving left node info}
+
+   begin {Index}
+   zero := false;
+   with op^.right^ do begin
+      if opcode = pc_ldc then begin
+	 if q = 0 then
+	    zero := true
+	 else
+	    GenNative(m_lda_imm, immediate, q, nil, 0);
+	 end {if}
+      else begin
+	 lLong := gLong;
+	 GenTree(op^.right);
+	 gLong := lLong;
+	 end; {else}
+      end; {with}
+   end; {Index}
+
+
+begin {GenIxa}
+if smallMemoryModel then begin
+   lLong := gLong;
+   gLong.preference := inPointer+localAddress+globalLabel;
+   GenTree(op^.left);
+   case gLong.where of
+
+      onStack: begin
+	 Index;
+	 if not zero then begin
+	    GenImplied(m_clc);
+	    GenNative(m_adc_s, direct, 1, nil, 0);
+	    GenNative(m_sta_s, direct, 1, nil, 0);
+	    lab1 := GenLabel;
+	    GenNative(m_bcc, relative, lab1, nil, 0);
+	    GenNative(m_lda_s, direct, 3, nil, 0);
+	    GenImplied(m_ina);
+	    GenNative(m_sta_s, direct, 3, nil, 0);
+	    GenLab(lab1);
+	    end; {if}
+	 end; {case onStack}
+
+      inPointer: begin
+	 if not gLong.fixedDisp then begin
+	    if Complex(op^.right) then begin
+	       GenImplied(m_phy);
+	       Index;
+	       if not zero then begin
+		  GenImplied(m_clc);
+		  GenNative(m_adc_s, direct, 1, nil, 0);
+		  GenNative(m_sta_s, direct, 1, nil, 0);
+		  end; {if}
+	       GenImplied(m_ply);
+	       end {if}
+	    else begin
+	       GenImplied(m_tya);
+	       GenImplied(m_clc);
+	       OperA(m_adc_imm, op^.right);
+	       GenImplied(m_tay);
+	       end; {else}
+	    end {if}
+	 else begin
+	    Index;
+	    if not zero then begin
+	       GenImplied(m_tay);
+	       gLong.fixedDisp := false;
+	       end; {if}
+	    end; {else}
+	 if (inPointer & lLong.preference) = 0 then begin
+	    if not gLong.fixedDisp then begin
+	       GenImplied(m_tya);
+	       GenImplied(m_clc);
+	       GenNative(m_adc_dir, direct, gLong.disp, nil, 0);
+	       GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
+	       lab1 := GenLabel;
+	       GenNative(m_bcc, relative, lab1, nil, 0);
+	       GenImplied(m_inx);
+	       GenLab(lab1);
+	       end {if}
+	    else begin
+	       GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
+	       GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
+	       end; {else}
+	    GenImplied(m_phx);
+	    GenImplied(m_pha);
+	    gLong.where := onStack;
+	    end; {if}
+	 end; {case inPointer}
+
+      localAddress,globalLabel: begin
+	 if not gLong.fixedDisp then begin
+	    if Complex(op^.right) then begin
+	       GenImplied(m_phx);
+	       Index;
+	       if not zero then begin
+		  GenImplied(m_clc);
+		  GenNative(m_adc_s, direct, 1, nil, 0);
+		  GenNative(m_sta_s, direct, 1, nil, 0);
+		  end; {if}
+	       GenImplied(m_plx);
+	       end {if}
+	    else begin
+	       GenImplied(m_txa);
+	       GenImplied(m_clc);
+	       OperA(m_adc_imm, op^.right);
+	       GenImplied(m_tax);
+	       end; {else}
+	    end {if}
+	 else if Complex(op^.right) then begin
+	    Index;
+	    if not zero then begin
+	       GenImplied(m_tax);
+	       gLong.fixedDisp := false;
+	       end; {if}
+	    end {else if}
+	 else begin
+	    LoadX(op^.right);
+	    gLong.fixedDisp := false;
+	    end; {else}
+	 if (lLong.preference & gLong.where) = 0 then begin
+	    if (lLong.preference & inPointer) <> 0 then begin
+	       if gLong.where = localAddress then begin
+		  if not gLong.fixedDisp then begin
+		     GenNative(m_stz_dir, direct, dworkLoc+2, nil, 0);
+		     GenImplied(m_phx);
+		     GenImplied(m_tdc);
+		     GenImplied(m_clc);
+		     if gLong.disp <> 0 then
+			GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
+		     GenNative(m_adc_s, direct, 1, nil, 0);
+		     GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
+		     GenImplied(m_plx);
+		     end {if}
+		  else begin
+		     GenNative(m_stz_dir, direct, dworkLoc+2, nil, 0);
+		     GenImplied(m_tdc);
+		     GenImplied(m_clc);
+		     GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
+		     GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
+		     end; {else}
+		  end {if}
+	       else begin
+		  if not gLong.fixedDisp then begin
+		     GenImplied(m_txa);
+		     GenImplied(m_clc);
+		     GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0);
+		     GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
+		     GenNative(m_ldx_imm, immediate, gLong.disp, gLong.lab, shift16);
+		     lab1 := GenLabel;
+		     GenNative(m_bcc, relative, lab1, nil, 0);
+		     GenImplied(m_inx);
+		     GenLab(lab1);
+		     GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0);
+		     end {if}
+		  else begin
+		     GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16);
+		     GenNative(m_sta_dir, direct, dworkLoc+2, nil, 0);
+		     GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0);
+		     GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
+		     end; {else}
+		  end; {else}
+	       gLong.where := inPointer;
+	       gLong.fixedDisp := true;
+	       gLong.disp := dworkLoc;
+	       end {if}
+	    else begin
+	       if gLong.where = localAddress then begin
+		  if not gLong.fixedDisp then begin
+		     GenNative(m_pea, immediate, 0, nil, 0);
+		     GenImplied(m_phx);
+		     GenImplied(m_tdc);
+		     GenImplied(m_clc);
+		     GenNative(m_adc_s, direct, 1, nil, 0);
+		     if gLong.disp <> 0 then
+			GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
+		     GenNative(m_sta_s, direct, 1, nil, 0);
+		     end {if}
+		  else begin
+		     GenNative(m_pea, immediate, 0, nil, 0);
+		     GenImplied(m_tdc);
+		     GenImplied(m_clc);
+		     GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
+		     GenImplied(m_pha);
+		     end; {else}
+		  end {if}
+	       else begin
+		  if not gLong.fixedDisp then begin
+		     GenImplied(m_txa);
+		     GenImplied(m_clc);
+		     GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0);
+		     GenNative(m_ldx_imm, immediate, gLong.disp, gLong.lab, shift16);
+		     lab1 := GenLabel;
+		     GenNative(m_bcc, relative, lab1, nil, 0);
+		     GenImplied(m_inx);
+		     GenLab(lab1);
+		     GenImplied(m_phx);
+		     GenImplied(m_pha);
+		     end {if}
+		  else begin
+		     GenNative(m_pea, immediate, gLong.disp, gLong.lab, shift16);
+		     GenNative(m_pea, immediate, gLong.disp, gLong.lab, 0);
+		     end; {else}
+		  end; {else}
+	       gLong.where := onStack;
+	       end; {else}
+	    end; {if}
+	 end; {case localAddress,globalLabel}
+      otherwise:
+	 Error(cge1);
+      end; {case}
+   end {if smallMemoryModel or (op^.right^.opcode = pc_ldc)}
+else begin
+   gLong.preference := onStack;
+   GenTree(op^.left);
+   GenTree(op^.right);
+   if op^.optype in [cgByte,cgWord] then begin
+      lab1 := GenLabel;
+      GenNative(m_ldx_imm, immediate, $0000, nil, 0);
+      GenImplied(m_tay);
+      GenNative(m_bpl, relative, lab1, nil, 0);
+      GenImplied(m_dex);
+      GenLab(lab1);
+      GenImplied(m_phx);
+      GenImplied(m_pha);
+      end {else if}
+   else begin
+      GenNative(m_pea, immediate, 0, nil, 0);
+      GenImplied(m_pha);
+      end; {else}
+   GenImplied(m_clc);
+   GenImplied(m_pla);
+   GenNative(m_adc_s, direct, 3, nil, 0);
+   GenNative(m_sta_s, direct, 3, nil, 0);
+   GenImplied(m_pla);
+   GenNative(m_adc_s, direct, 3, nil, 0);
+   GenNative(m_sta_s, direct, 3, nil, 0);
+   gLong.where := onStack;
+   end; {else}
+end; {GenIxa}
+
+
+procedure GenLogic (op: icptr);
+
+{ generate a pc_and, pc_ior, pc_bnd, pc_bor or pc_bxr		}
+
+var
+   lab1,lab2: integer;			{label}
+   nd: icptr;				{temp node pointer}
+   opcode: pcodes;			{operation code}
+
+begin {GenLogic}
+opcode := op^.opcode;
+if not Complex(op^.left) then
+   if Complex(op^.right) then begin
+      nd := op^.left;
+      op^.left := op^.right;
+      op^.right := nd;
+      end; {if}
+GenTree(op^.left);
+if Complex(op^.right) then begin
+   GenImplied(m_pha);
+   GenTree(op^.right);
+   case opcode of
+      pc_and,pc_bnd: GenNative(m_and_s, direct, 1, nil, 0);
+      pc_ior,pc_bor: GenNative(m_ora_s, direct, 1, nil, 0);
+      pc_bxr: GenNative(m_eor_s, direct, 1, nil, 0);
+      otherwise:
+	 Error(cge1);
+      end; {case}
+   GenImplied(m_plx);
+   GenImplied(m_tax);
+   end {if}
+else
+   case opcode of
+      pc_and,pc_bnd: OperA(m_and_imm, op^.right);
+      pc_ior,pc_bor: OperA(m_ora_imm, op^.right);
+      pc_bxr: OperA(m_eor_imm, op^.right);
+      otherwise:
+	 Error(cge1);
+      end; {case}
+end; {GenLogic}
+
+
+procedure GenSroCpo (op: icptr);
+
+{ Generate code for a pc_sro or pc_cpo			}
+
+var
+   lab: pStringPtr;			{op^.lab}
+   lab1: integer;			{branch point}
+   lval: longint;			{op^.left^.lval}
+   opcode: pcodes;			{op^.opcode}
+   optype: baseTypeEnum; 		{op^.optype}
+   q: integer;				{op^.q}
+   special: boolean;			{special save?}
+
+begin {GenSroCpo}
+opcode := op^.opcode;
+optype := op^.optype;
+q := op^.q;
+lab := op^.lab;
+case optype of
+   cgByte, cgUByte: begin
+      if (opcode = pc_sro) and (op^.left^.opcode in [pc_inc,pc_dec]) then
+	 GenIncDec(op^.left, op)
+      else begin
+	 if smallMemoryModel and (op^.left^.opcode = pc_ldc)
+	    and (op^.left^.q = 0) then begin
+	    GenNative(m_sep, immediate, 32, nil, 0);
+	    GenNative(m_stz_abs, absolute, q, lab, 0);
+	    end {if}
+	 else begin
+	    if op^.opcode = pc_sro then
+	       if op^.left^.opcode = pc_cnv then
+		  if (op^.left^.q >> 4) in [ord(cgWord),ord(cgUWord)] then
+		     op^.left := op^.left^.left;
+	    if (op^.left^.opcode in [pc_ldc,pc_ldc,pc_lod])
+               and (op^.left^.p = 0) then begin
+	       GenNative(m_sep, immediate, 32, nil, 0);
+	       GenTree(op^.left);
+	       end {if}
+	    else begin
+	       GenTree(op^.left);
+	       GenNative(m_sep, immediate, 32, nil, 0);
+	       end; {else}
+	    if smallMemoryModel then
+	       GenNative(m_sta_abs, absolute, q, lab, 0)
+	    else
+	       GenNative(m_sta_long, longabsolute, q, lab, 0);
+	    end; {else}
+	 GenNative(m_rep, immediate, 32, nil, 0);
+         end; {else}
+      end;
+
+   cgWord, cgUWord:
+      if (opcode = pc_sro) and (op^.left^.opcode in [pc_inc,pc_dec]) then
+	 GenIncDec(op^.left, op)
+      else begin
+	 if smallMemoryModel and (op^.left^.opcode = pc_ldc)
+	    and (op^.left^.q = 0) then
+	    GenNative(m_stz_abs, absolute, q, lab, 0)
+	 else begin
+	    GenTree(op^.left);
+	    if smallMemoryModel then
+	       GenNative(m_sta_abs, absolute, q, lab, 0)
+	    else
+	       GenNative(m_sta_long, longabsolute, q, lab, 0);
+	    end; {else}
+         end; {else}
+
+   cgReal, cgDouble, cgComp, cgExtended: begin
+      GenTree(op^.left);
+      GenNative(m_pea, immediate, q, lab, shift16);
+      GenNative(m_pea, immediate, q, lab, 0);
+      if opcode = pc_sro then begin
+	 if optype = cgReal then
+	    GenCall(23)
+	 else if optype = cgDouble then
+	    GenCall(87)
+	 else if optype = cgComp then
+	    GenCall(157)
+	 else {if optype = cgExtended then}
+	    GenCall(158);
+	 end {if}
+      else {if opcode = pc_cpo then} begin
+	 if optype = cgReal then
+	    GenCall(159)
+	 else if optype = cgDouble then
+	    GenCall(160)
+	 else if optype = cgComp then
+	    GenCall(161)
+	 else {if optype = cgExtended then}
+	    GenCall(162);
+	 end; {else}
+      end;
+
+   cgSet: begin
+      GenTree(op^.left);
+      GenNative(m_pea, immediate, op^.r, lab, shift16);
+      GenNative(m_pea, immediate, op^.r, lab, 0);
+      GenNative(m_pea, immediate, q, nil, 0);
+      GenCall(24);
+      end;
+
+   cgLong, cgULong: begin
+      if (opcode = pc_sro) and (op^.left^.opcode in [pc_adl,pc_sbl]) then
+	 GenAdlSbl(op^.left, op)
+      else if (opcode = pc_sro) and (op^.left^.opcode in [pc_inc,pc_dec]) then
+	 GenIncDec(op^.left, op)
+      else if smallMemoryModel and (op^.left^.opcode = pc_ldc) then begin
+	 lval := op^.left^.lval;
+	 if long(lval).lsw = 0 then
+	    GenNative(m_stz_abs, absolute, q, lab, 0)
+	 else begin
+	    GenNative(m_lda_imm, immediate, long(lval).lsw, nil, 0);
+	    GenNative(m_sta_abs, absolute, q, lab, 0)
+	    end; {else}
+	 if long(lval).msw = 0 then
+	    GenNative(m_stz_abs, absolute, q+2, lab, 0)
+	 else begin
+	    GenNative(m_ldx_imm, immediate, long(lval).msw, nil, 0);
+	    GenNative(m_stx_abs, absolute, q+2, lab, 0)
+	    end; {else}
+	 if op^.opcode = pc_cpo then
+	    GenTree(op^.left);
+	 end {if}
+      else begin
+	 if op^.opcode = pc_sro then
+	    gLong.preference := A_X | inPointer | localAddress | globalLabel | constant
+	 else
+	    gLong.preference := gLong.preference &
+	       (A_X | inPointer | localAddress | globalLabel | constant);
+	 GenTree(op^.left);
+	 case gLong.where of
+
+	    A_X: begin
+	       if smallMemoryModel then begin
+		  GenNative(m_stx_abs, absolute, q+2, lab, 0);
+		  GenNative(m_sta_abs, absolute, q, lab, 0);
+		  end {if}
+	       else begin
+		  GenNative(m_sta_long, longabsolute, q, lab, 0);
+		  if opcode = pc_cpo then
+		     GenImplied(m_pha);
+		  GenImplied(m_txa);
+		  GenNative(m_sta_long, longabsolute, q+2, lab, 0);
+		  if opcode = pc_cpo then
+		     GenImplied(m_pla);
+		  end; {else}
+	       end;
+
+	    onStack: begin
+	       if opcode = pc_sro then
+		  GenImplied(m_pla)
+	       else {if opcode = pc_cpo then}
+		  GenNative(m_lda_s, direct, 1, nil, 0);
+	       if smallMemoryModel then
+		  GenNative(m_sta_abs, absolute, q, lab, 0)
+	       else
+		  GenNative(m_sta_long, longabsolute, q, lab, 0);
+	       if opcode = pc_sro then
+		  GenImplied(m_pla)
+	       else {if opcode = pc_cpo then}
+		  GenNative(m_lda_s, direct, 3, nil, 0);
+	       if smallMemoryModel then
+		  GenNative(m_sta_abs, absolute, q+2, lab, 0)
+	       else
+		  GenNative(m_sta_long, longabsolute, q+2, lab, 0);
+	       end;
+
+	    inPointer: begin
+	       GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
+	       if gLong.fixedDisp then
+		  GenNative(m_lda_dir, direct, gLong.disp, nil, 0)
+	       else begin
+		  GenImplied(m_tya);
+		  GenImplied(m_clc);
+		  GenNative(m_adc_dir, direct, gLong.disp, nil, 0);
+		  if not smallMemoryModel then begin
+		     lab1 := GenLabel;
+		     GenNative(m_bcc, relative, lab1, nil, 0);
+		     GenImplied(m_inx);
+		     GenLab(lab1);
+		     end; {if}
+		  end; {else}
+	       if smallMemoryModel then begin
+		  GenNative(m_stx_abs, absolute, q+2, lab, 0);
+		  GenNative(m_sta_abs, absolute, q, lab, 0);
+		  end {if}
+	       else begin
+		  GenNative(m_sta_long, longabsolute, q, lab, 0);
+		  if opcode = pc_cpo then
+		     GenImplied(m_pha);
+		  GenImplied(m_txa);
+		  GenNative(m_sta_long, longabsolute, q+2, lab, 0);
+		  if opcode = pc_cpo then
+		     GenImplied(m_pla);
+		  end; {else}
+	       gLong.where := A_X;
+	       end;
+
+	    localAddress: begin
+	       if smallMemoryModel then
+		  GenNative(m_stz_abs, absolute, q+2, lab, 0)
+	       else begin
+		  GenNative(m_lda_imm, immediate, 0, nil, 0);
+		  GenNative(m_sta_long, longabsolute, q+2, lab, 0);
+		  end; {else}
+	       GenImplied(m_tdc);
+	       GenImplied(m_clc);
+	       GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
+	       if not gLong.fixedDisp then begin
+		  GenImplied(m_phx);
+		  GenNative(m_adc_s, direct, 1, nil, 0);
+		  GenImplied(m_plx);
+		  end; {if}
+	       if smallMemoryModel then
+		  GenNative(m_sta_abs, absolute, q, lab, 0)
+	       else
+		  GenNative(m_sta_long, longabsolute, q, lab, 0);
+	       end;
+
+	    globalLabel:
+	       if gLong.fixedDisp then begin
+		  if smallMemoryModel then begin
+		     GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0);
+		     GenNative(m_ldx_imm, immediate, gLong.disp, gLong.lab, shift16);
+		     GenNative(m_stx_abs, absolute, q+2, lab, 0);
+		     GenNative(m_sta_abs, absolute, q, lab, 0);
+		     end {if}
+		  else begin
+		     GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16);
+		     GenNative(m_sta_long, longabsolute, q+2, lab, 0);
+		     if opcode = pc_cpo then
+			GenImplied(m_tax);
+		     GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0);
+		     GenNative(m_sta_long, longabsolute, q, lab, 0);
+		     end; {else}
+		  gLong.where := A_X;
+		  end {if}
+	       else begin
+		  GenImplied(m_txa);
+		  GenImplied(m_clc);
+		  GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0);
+		  if smallMemoryModel then
+		     GenNative(m_sta_abs, absolute, q, lab, 0)
+		  else
+		     GenNative(m_sta_long, longabsolute, q, lab, 0);
+		  GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16);
+		  GenNative(m_adc_imm, immediate, 0, nil, 0);
+		  if smallMemoryModel then
+		     GenNative(m_sta_abs, absolute, q+2, lab, 0)
+		  else
+		     GenNative(m_sta_long, longabsolute, q+2, lab, 0);
+		  end; {else}
+
+	    constant: begin
+	       if gLong.lval = 0 then begin
+		  if smallMemoryModel then begin
+		     GenNative(m_stz_abs, absolute, q+2, lab, 0);
+		     GenNative(m_stz_abs, absolute, q, lab, 0);
+		     end {if}
+		  else begin
+		     GenNative(m_lda_imm, immediate, 0, nil, 0);
+		     GenNative(m_sta_long, longabsolute, q+2, lab, 0);
+		     GenNative(m_sta_long, longabsolute, q, lab, 0);
+		     end; {else}
+		  end {if}
+	       else if not smallMemoryModel then begin
+		  GenNative(m_lda_imm, immediate, long(gLong.lval).msw, nil, 0);
+		  GenNative(m_sta_long, longabsolute, q+2, lab, 0);
+		  GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
+		  GenNative(m_sta_long, longabsolute, q, lab, 0);
+		  end {else if}
+	       else begin
+		  if long(gLong.lval).msw = 0 then
+		     GenNative(m_stz_abs, absolute, q+2, lab, 0)
+		  else begin
+		     GenNative(m_ldx_imm, immediate, long(gLong.lval).msw, nil, 0);
+		     GenNative(m_stx_abs, absolute, q+2, lab, 0);
+		     end; {else}
+		  if long(gLong.lval).lsw = 0 then
+		     GenNative(m_stz_abs, absolute, q, lab, 0)
+		  else begin
+		     GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
+		     GenNative(m_sta_abs, absolute, q, lab, 0);
+		     end; {else}
+		  if (long(gLong.lval).lsw <> 0) and (long(gLong.lval).msw <> 0) then
+		     gLong.where := A_X;
+		  end; {else}
+	       end; {case constant}
+
+	    otherwise:
+	       Error(cge1);
+	    end; {case}
+	 end; {else}
+      end; {case CGLong, cgULong}
+
+   end; {case}
+end; {GenSroCpo}
+
+
+procedure GenSto (op: icptr);
+
+{ Generate code for a pc_sto          			}
+
+var
+   disp: integer;			{disp in stack frame}
+   opcode: pcodes;			{temp storage for op code}
+   optype: baseTypeEnum; 		{operand type}
+   short: boolean;			{use short registers?}
+   simple: boolean;			{is the load a simple load?}
+   preference: integer;			{old preference}
+   lLong: longType;			{address record for left node}
+   zero: boolean;			{is the operand a constant zero?}
+
+
+   procedure LoadLSW;
+
+   { load the least significant word of a four byte value	}
+
+   begin {LoadLSW}
+   if lLong.where = onStack then
+      if opcode = pc_sto then
+	 GenImplied(m_pla)
+      else
+	 GenNative(m_lda_s, direct, 1, nil, 0)
+   else if lLong.where <> A_X then
+      GenNative(m_lda_imm, immediate, long(lLong.lval).lsw, nil, 0);
+   end; {LoadLSW}
+
+
+   procedure LoadMSW;
+
+   { load the most significant word of a four byte value 	}
+   {								}
+   { Note: LoadLSW MUST be called first! 			}
+
+   begin {LoadMSW}
+   gLong.where := A_X;
+   if lLong.where = onStack then
+      if opcode = pc_sto then
+	 GenImplied(m_pla)
+      else begin
+	 GenNative(m_lda_s, direct, 3, nil, 0);
+	 gLong.where := onStack;
+	 end {else}
+   else if lLong.where = A_X then
+      GenImplied(m_txa)
+   else
+      GenNative(m_lda_imm, immediate, long(lLong.lval).msw, nil, 0);
+   end; {LoadMSW}
+
+
+   procedure LoadWord;
+
+   { Get the operand for a cgByte, cgUByte, cgWord or cgUWord	}
+   { into the accumulator					}
+
+   begin {LoadWord}
+   if simple then begin
+      with op^.right^ do
+	 if opcode = pc_ldc then
+	    GenNative(m_lda_imm, immediate, q, nil, 0)
+	 else if opcode = pc_lod then
+	    GenNative(m_lda_dir, direct, localLabel[r] + q, nil, 0)
+	 else {if opcode = pc_ldo then}
+	    if smallMemoryModel then
+	       GenNative(m_lda_abs, absolute, q, lab, 0)
+	    else
+	       GenNative(m_lda_long, longAbs, q, lab, 0);
+      end {if}
+   else begin
+      GenImplied(m_pla);
+      if short then
+	 GenNative(m_sep, immediate, 32, nil, 0);
+      end {else}
+   end; {LoadWord}
+
+
+begin {GenSto}
+opcode := op^.opcode;
+optype := op^.optype;
+case optype of
+
+   cgReal,cgDouble,cgComp,cgExtended: begin
+      GenTree(op^.right);
+      gLong.preference := onStack;
+      GenTree(op^.left);
+      if optype = cgReal then begin
+	 if opcode = pc_sto then
+	    GenCall(23)
+	 else
+	    GenCall(159);
+	 end {if}
+      else if optype = cgDouble then begin
+	 if opcode = pc_sto then
+	    GenCall(87)
+	 else
+	    GenCall(160);
+	 end {else if}
+      else if optype = cgComp then begin
+	 if opcode = pc_sto then
+	    GenCall(157)
+	 else
+	    GenCall(161);
+	 end {else if}
+      else {if optype = cgExtended then} begin
+	 if opcode = pc_sto then
+	    GenCall(158)
+	 else
+	    GenCall(162);
+	 end; {else}
+      end; {case cgReal,cgDouble,cgComp,cgExtended}
+
+   cgSet: begin
+      gLong.preference := onStack;
+      GenTree(op^.right);
+      gLong.preference := onStack;
+      GenTree(op^.left);
+      GenNative(m_pea, immediate, op^.q, nil, 0);
+      GenCall(24);
+      end;
+
+   cgLong,cgULong: begin
+      preference := gLong.preference;
+      gLong.preference := onStack+constant;
+      GenTree(op^.right);
+      lLong := gLong;
+      gLong.preference := localAddress+inPointer+globalLabel+A_X;
+      GenTree(op^.left);
+      if gLong.where = onStack then begin
+	 GenImplied(m_pla);
+	 GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
+	 GenImplied(m_pla);
+	 GenNative(m_sta_dir, direct, dworkLoc+2, nil, 0);
+	 LoadLSW;
+	 GenNative(m_sta_indl, direct, dworkLoc, nil, 0);
+	 GenNative(m_ldy_imm, immediate, 2, nil, 0);
+	 LoadMSW;
+	 GenNative(m_sta_indly, direct, dworkLoc, nil, 0);
+	 end {if}
+      else if gLong.where = A_X then begin
+	 GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
+	 GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0);
+	 LoadLSW;
+	 GenNative(m_sta_indl, direct, dworkLoc, nil, 0);
+	 GenNative(m_ldy_imm, immediate, 2, nil, 0);
+	 LoadMSW;
+	 GenNative(m_sta_indly, direct, dworkLoc, nil, 0);
+	 end {if}
+      else if gLong.where = localAddress then begin
+	 LoadLSW;
+	 if gLong.fixedDisp then
+	    if (gLong.disp & $FF00) = 0 then
+	       GenNative(m_sta_dir, direct, gLong.disp, nil, 0)
+	    else begin
+	       GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
+	       GenNative(m_sta_dirX, direct, 0, nil, 0);
+	       end {else}
+	 else begin
+	    if (gLong.disp >= 254) or (gLong.disp < 0) then begin
+	       GenImplied(m_tay);
+	       GenImplied(m_txa);
+	       GenImplied(m_clc);
+	       GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
+	       GenImplied(m_tax);
+	       GenImplied(m_tya);
+	       gLong.disp := 0;
+	       end; {if}
+	    GenNative(m_sta_dirX, direct, gLong.disp, nil, 0);
+	    end; {else}
+	 LoadMSW;
+	 if gLong.fixedDisp then
+	    if ((gLong.disp+2) & $FF00) = 0 then
+	       GenNative(m_sta_dir, direct, gLong.disp+2, nil, 0)
+	    else begin
+	       GenNative(m_ldx_imm, immediate, gLong.disp+2, nil, 0);
+	       GenNative(m_sta_dirX, direct, 0, nil, 0);
+	       end {else}
+	 else begin
+	    if (gLong.disp >= 254) or (gLong.disp < 0) then begin
+	       GenImplied(m_tay);
+	       GenImplied(m_txa);
+	       GenImplied(m_clc);
+	       GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
+	       GenImplied(m_tax);
+	       GenImplied(m_tya);
+	       gLong.disp := 0;
+	       end; {if}
+	    GenNative(m_sta_dirX, direct, gLong.disp+2, nil, 0);
+	    end; {else}
+	 end {else if}
+      else if gLong.where = globalLabel then begin
+	 LoadLSW;
+	 if gLong.fixedDisp then
+	    if smallMemoryModel then
+	       GenNative(m_sta_abs, absolute, gLong.disp, gLong.lab, 0)
+	    else
+	       GenNative(m_sta_long, longAbs, gLong.disp, gLong.lab, 0)
+	 else
+	    if smallMemoryModel then
+	       GenNative(m_sta_absX, absolute, gLong.disp, gLong.lab, 0)
+	    else
+	       GenNative(m_sta_longX, longAbs, gLong.disp, gLong.lab, 0);
+	 LoadMSW;
+	 if gLong.fixedDisp then
+	    if smallMemoryModel then
+	       GenNative(m_sta_abs, absolute, gLong.disp+2, gLong.lab, 0)
+	    else
+	       GenNative(m_sta_long, longAbs, gLong.disp+2, gLong.lab, 0)
+	 else
+	    if smallMemoryModel then
+	       GenNative(m_sta_absX, absolute, gLong.disp+2, gLong.lab, 0)
+	    else
+	       GenNative(m_sta_longX, longAbs, gLong.disp+2, gLong.lab, 0);
+	 end {else if}
+      else begin
+	 LoadLSW;
+	 if gLong.fixedDisp = true then begin
+	    GenNative(m_sta_indl, direct, gLong.disp, nil, 0);
+	    GenNative(m_ldy_imm, immediate, 2, nil, 0);
+	    end {if}
+	 else begin
+	    GenNative(m_sta_indlY, direct, gLong.disp, nil, 0);
+	    GenImplied(m_iny);
+	    GenImplied(m_iny);
+	    end; {else}
+	 LoadMSW;
+	 GenNative(m_sta_indly, direct, gLong.Disp, nil, 0);
+	 end; {else}
+      end; {case cgLong,cgULong}
+
+   cgByte,cgUByte,cgWord,cgUWord: begin
+      short := optype in [cgByte,cgUByte];
+      simple := false;
+      zero := false;
+      if op^.opcode = pc_sto then begin
+	 if short then
+	    if op^.right^.opcode = pc_cnv then
+	       if (op^.right^.q >> 4) in [ord(cgWord),ord(cgUWord)] then
+		  op^.right := op^.right^.left;
+	 with op^.right^ do begin
+	    if opcode = pc_ldo then
+	       simple := true
+	    else if opcode = pc_lod then
+	       simple := (localLabel[r] + q < 256) and (p = 0)
+	    else if opcode = pc_ldc then begin
+	       simple := true;
+	       zero := q = 0;
+	       end; {else if}
+	    end; {with}
+	 end; {if}
+      if not (zero or simple) then begin
+	 GenTree(op^.right);
+	 GenImplied(m_pha);
+	 end; {if}
+      GetPointer(op^.left);
+      if short then
+	 if simple then
+	    GenNative(m_sep, immediate, 32, nil, 0);
+      if gLong.where = inPointer then begin
+	 if zero then
+	    GenNative(m_lda_imm, immediate, 0, nil, 0)
+	 else
+	    LoadWord;
+	 if gLong.fixedDisp then
+	    GenNative(m_sta_indl, direct, gLong.disp, nil, 0)
+	 else
+	    GenNative(m_sta_indlY, direct, gLong.disp, nil, 0);
+	 end {if}
+      else if gLong.where = localAddress then begin
+	 if gLong.fixedDisp then
+	    if (gLong.disp & $FF00) = 0 then
+	       if zero then
+		  GenNative(m_stz_dir, direct, gLong.disp, nil, 0)
+	       else begin
+		  LoadWord;
+		  GenNative(m_sta_dir, direct, gLong.disp, nil, 0);
+		  end {else}
+	    else begin
+	       if zero then begin
+		  GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
+		  GenNative(m_stz_dirX, direct, 0, nil, 0);
+		  end {if}
+	       else begin
+		  LoadWord;
+		  GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
+		  GenNative(m_sta_dirX, direct, 0, nil, 0);
+		  end; {else}
+	       end {else}
+	 else begin
+	    if (gLong.disp & $FF00) <> 0 then begin
+	       GenImplied(m_txa);
+	       GenImplied(m_clc);
+	       GenNative(m_adc_imm, immediate, glong.disp, nil, 0);
+	       GenImplied(m_tax);
+	       gLong.disp := 0;
+	       end; {if}
+	    if zero then
+	       GenNative(m_stz_dirX, direct, gLong.disp, nil, 0)
+	    else begin
+	       LoadWord;
+	       GenNative(m_sta_dirX, direct, gLong.disp, nil, 0);
+	       end; {else}
+	    end; {else}
+	 end {else if}
+      else {if gLong.where = globalLabel then} begin
+	 if zero then begin
+	    if not smallMemoryModel then
+	       GenNative(m_lda_imm, immediate, 0, nil, 0);
+	    end {if}
+	 else
+	    LoadWord;
+	 if gLong.fixedDisp then
+	    if smallMemoryModel then
+	       if zero then
+		  GenNative(m_stz_abs, absolute, gLong.disp, gLong.lab, 0)
+	       else
+		  GenNative(m_sta_abs, absolute, gLong.disp, gLong.lab, 0)
+	    else
+	       GenNative(m_sta_long, longAbs, gLong.disp, gLong.lab, 0)
+	 else
+	    if smallMemoryModel then
+	       if zero then
+		  GenNative(m_stz_absX, absolute, gLong.disp, gLong.lab, 0)
+	       else
+		  GenNative(m_sta_absX, absolute, gLong.disp, gLong.lab, 0)
+	    else
+	       GenNative(m_sta_longX, longAbs, gLong.disp, gLong.lab, 0);
+	 end; {else}
+      if short then
+	 GenNative(m_rep, immediate, 32, nil, 0);
+      end; {case cgByte,cgUByte,cgWord,cgUWord}
+
+   otherwise:
+      Error(cge1);
+   end; {case}
+end; {GenSto}
+
+
+procedure GenStrCop (op: icptr);
+
+{ Generate code for a pc_str or pc_cop				}
+
+var
+   disp: integer;			{store location}
+   optype: baseTypeEnum; 		{op^.optype}
+   special: boolean;			{use special processing?}
+   zero: boolean;			{is the operand a constant zero?}
+
+begin {GenStrCop}
+disp := localLabel[op^.r] + op^.q;
+optype := op^.optype;
+case optype of
+   cgByte, cgUByte, cgWord, cgUWord: begin
+      if (op^.opcode = pc_str) and (op^.left^.opcode in [pc_inc,pc_dec]) then
+	 GenIncDec(op^.left, op)
+      else begin
+	 zero := false;
+	 if op^.left^.opcode = pc_ldc then
+	    if op^.opcode = pc_str then
+	       if op^.p = 0 then
+		  if op^.left^.q = 0 then
+	             zero := true;
+	 if not zero then begin
+	    if optype in [cgByte,cgUByte] then begin
+	       if op^.opcode = pc_str then
+		  if op^.left^.opcode = pc_cnv then
+		     if (op^.left^.q >> 4) in [ord(cgWord),ord(cgUWord)] then
+			op^.left := op^.left^.left;
+	       if (op^.left^.opcode in [pc_ldc,pc_ldc,pc_lod])
+                  and (op^.opcode = pc_str)
+        	  and (op^.left^.p = 0) then begin
+		  GenNative(m_sep, immediate, 32, nil, 0);
+		  GenTree(op^.left);
+		  end {if}
+	       else begin
+		  GenTree(op^.left);
+		  GenNative(m_sep, immediate, 32, nil, 0);
+		  end; {else}
+	       end {if}
+	    else
+	       GenTree(op^.left);
+	    end {if}
+	 else
+	    if optype in [cgByte,cgUByte] then
+	       GenNative(m_sep, immediate, 32, nil, 0);
+	 if op^.p <> 0 then begin
+	    StaticLink(op^.p, true, false);
+	    GenNative(m_sta_longx, longabsolute, disp, nil, 0);
+	    end {if}
+	 else if disp > 255 then begin
+	    GenNative(m_ldx_imm, immediate, disp, nil, 0);
+	    if zero then
+	       GenNative(m_stz_dirx, direct, 0, nil, 0)
+	    else
+	       GenNative(m_sta_dirx, direct, 0, nil, 0);
+	    end {else if}
+	 else
+	    if zero then
+	       GenNative(m_stz_dir, direct, disp, nil, 0)
+	    else
+	       GenNative(m_sta_dir, direct, disp, nil, 0);
+	 if optype in [cgByte,cgUByte] then
+	    GenNative(m_rep, immediate, 32, nil, 0);
+         end; {else}
+      end;
+
+   cgReal, cgDouble, cgComp, cgExtended: begin
+      GenTree(op^.left);
+      GenNative(m_pea, immediate, 0, nil, 0);
+      if op^.p = 0 then
+	 GenImplied(m_tdc)
+      else
+	 StaticLink(op^.p, false, true);
+      GenImplied(m_clc);
+      GenNative(m_adc_imm, immediate, disp, nil, 0);
+      GenImplied(m_pha);
+      if op^.opcode = pc_str then begin
+	 if optype = cgReal then
+	    GenCall(23)
+	 else if optype = cgDouble then
+	    GenCall(87)
+	 else if optype = cgComp then
+	    GenCall(157)
+	 else {if optype = cgExtended then}
+	    GenCall(158);
+	 end {if}
+      else begin
+	 if optype = cgReal then
+	    GenCall(159)
+	 else if optype = cgDouble then
+	    GenCall(160)
+	 else if optype = cgComp then
+	    GenCall(161)
+	 else {if optype = cgExtended then}
+	    GenCall(162);
+	 end; {else}
+      end;
+
+   cgLong, cgULong: begin
+      if (op^.opcode = pc_str) and (op^.left^.opcode in [pc_adl,pc_sbl]) then
+	 GenAdlSbl(op^.left, op)
+      else if (op^.opcode = pc_str) and (op^.left^.opcode in [pc_inc,pc_dec]) then
+	 GenIncDec(op^.left, op)
+      else begin
+	 if op^.opcode = pc_str then
+            if op^.p = 0 then
+	       gLong.preference :=
+		  A_X+onStack+inPointer+localAddress+globalLabel+constant
+            else
+	       gLong.preference :=
+		  onStack+constant
+	 else
+	    gLong.preference := onStack;
+	 GenTree(op^.left);
+	 case gLong.where of
+
+	    A_X:
+	       if disp < 254 then begin
+		  GenNative(m_stx_dir, direct, disp+2, nil, 0);
+		  GenNative(m_sta_dir, direct, disp, nil, 0);
+		  end {else if}
+	       else begin
+		  GenImplied(m_txy);
+		  GenNative(m_ldx_imm, immediate, disp, nil, 0);
+		  GenNative(m_sta_dirX, direct, 0, nil, 0);
+		  GenNative(m_sty_dirX, direct, 2, nil, 0);
+		  if op^.opcode = pc_cop then
+		     GenImplied(m_tyx);
+		  end; {else}
+
+	    onStack:
+	       if op^.p <> 0 then begin
+	          StaticLink(op^.p, false, false);
+		  if op^.opcode = pc_str then
+		     GenImplied(m_pla)
+		  else {if op^.opcode = pc_cop then}
+		     GenNative(m_lda_s, direct, 1, nil, 0);
+		  GenNative(m_sta_longX, longAbsolute, disp, nil, 0);
+		  if op^.opcode = pc_str then
+		     GenImplied(m_pla)
+		  else {if op^.opcode = pc_cop then}
+		     GenNative(m_lda_s, direct, 3, nil, 0);
+		  GenNative(m_sta_longX, longAbsolute, disp+2, nil, 0);
+                  end {if}
+               else if disp < 254 then begin
+		  if op^.opcode = pc_str then
+		     GenImplied(m_pla)
+		  else {if op^.opcode = pc_cop then}
+		     GenNative(m_lda_s, direct, 1, nil, 0);
+		  GenNative(m_sta_dir, direct, disp, nil, 0);
+		  if op^.opcode = pc_str then
+		     GenImplied(m_pla)
+		  else {if op^.opcode = pc_cop then}
+		     GenNative(m_lda_s, direct, 3, nil, 0);
+		  GenNative(m_sta_dir, direct, disp+2, nil, 0);
+		  end {else if}
+	       else begin
+		  GenNative(m_ldx_imm, immediate, disp, nil, 0);
+		  if op^.opcode = pc_str then
+		     GenImplied(m_pla)
+		  else {if op^.opcode = pc_cop then}
+		     GenNative(m_lda_s, direct, 1, nil, 0);
+		  GenNative(m_sta_dirX, direct, 0, nil, 0);
+		  if op^.opcode = pc_str then
+		     GenImplied(m_pla)
+		  else {if op^.opcode = pc_cop then}
+		     GenNative(m_lda_s, direct, 3, nil, 0);
+		  GenNative(m_sta_dirX, direct, 2, nil, 0);
+		  end; {else}
+
+	    inPointer: begin
+	       if (disp < 254) and (gLong.disp < 254) and gLong.fixedDisp
+		  and (disp >= 0) and (gLong.disp >= 0) then begin
+		  GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
+		  GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
+		  GenNative(m_sta_dir, direct, disp, nil, 0);
+		  GenNative(m_stx_dir, direct, disp+2, nil, 0);
+		  end {if}
+	       else if (disp < 254) and (gLong.disp < 254)
+		  and (disp >= 0) and (gLong.disp >= 0)
+		  and (op^.opcode = pc_str) then begin
+		  GenImplied(m_tya);
+		  GenImplied(m_clc);
+		  GenNative(m_adc_dir, direct, gLong.disp, nil, 0);
+		  GenNative(m_sta_dir, direct, disp, nil, 0);
+		  GenNative(m_lda_dir, direct, gLong.disp+2, nil, 0);
+		  GenNative(m_adc_imm, immediate, 0, nil, 0);
+		  GenNative(m_sta_dir, direct, disp+2, nil, 0);
+		  end {else if}
+	       else begin
+		  GenNative(m_ldx_imm, immediate, disp, nil, 0);
+		  if not gLong.fixedDisp then begin
+		     GenImplied(m_tya);
+		     GenImplied(m_clc);
+		     GenNative(m_adc_dir, direct, gLong.disp, nil, 0);
+		     end {if}
+		  else
+		     GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
+		  GenNative(m_sta_dirX, direct, 0, nil, 0);
+		  GenNative(m_lda_dir, direct, gLong.disp+2, nil, 0);
+		  if not gLong.fixedDisp then
+		     GenNative(m_adc_imm, immediate, 0, nil, 0);
+		  GenNative(m_sta_dirX, direct, 2, nil, 0);
+		  end; {else}
+	       end;
+
+	    localAddress:
+	       if disp < 254 then begin
+		  GenNative(m_stz_dir, direct, disp+2, nil, 0);
+		  GenImplied(m_tdc);
+		  GenImplied(m_clc);
+		  GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
+		  if not gLong.fixedDisp then begin
+		     GenImplied(m_phx);
+		     GenNative(m_adc_s, direct, 1, nil, 0);
+		     GenImplied(m_plx);
+		     end; {if}
+		  GenNative(m_sta_dir, direct, disp, nil, 0);
+		  end {else if disp < 254}
+	       else begin
+		  if not gLong.fixedDisp then
+		     GenImplied(m_phx);
+		  GenNative(m_ldx_imm, immediate, disp, nil, 0);
+		  GenImplied(m_tdc);
+		  GenImplied(m_clc);
+		  GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
+		  if not gLong.fixedDisp then begin
+		     GenNative(m_adc_s, direct, 1, nil, 0);
+		     GenImplied(m_ply);
+		     end; {if}
+		  GenNative(m_sta_dirX, direct, 0, nil, 0);
+		  GenNative(m_stz_dirX, direct, 2, nil, 0);
+		  end; {else}
+
+	    globalLabel: begin
+	       if not gLong.fixedDisp then
+		  GenImplied(m_txa)
+	       else if disp > 253 then
+		  GenNative(m_ldx_imm, immediate, disp, nil, 0);
+	       if gLong.fixedDisp then
+		  GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0)
+	       else begin
+		  GenImplied(m_clc);
+		  GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0);
+		  end; {else}
+	       if disp < 254 then
+		  GenNative(m_sta_dir, direct, disp, nil, 0)
+	       else
+		  GenNative(m_sta_dirX, direct, 0, nil, 0);
+	       GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16);
+	       if not gLong.fixedDisp then
+		  GenNative(m_adc_imm, immediate, 0, nil, 0);
+	       if disp < 254 then
+		  GenNative(m_sta_dir, direct, disp+2, nil, 0)
+	       else
+		  GenNative(m_sta_dirX, direct, 2, nil, 0);
+	       end;
+
+	    constant:
+	       if op^.p <> 0 then begin
+	          StaticLink(op^.p, false, false);
+		  GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
+		  GenNative(m_sta_longX, longAbsolute, disp, nil, 0);
+		  GenNative(m_lda_imm, immediate, long(gLong.lval).msw, nil, 0);
+		  GenNative(m_sta_longX, longAbsolute, disp+2, nil, 0);
+                  end {if}
+	       else if disp < 254 then begin
+		  GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
+		  GenNative(m_sta_dir, direct, disp, nil, 0);
+		  GenNative(m_lda_imm, immediate, long(gLong.lval).msw, nil, 0);
+		  GenNative(m_sta_dir, direct, disp+2, nil, 0);
+		  end {else}
+	       else begin
+		  GenNative(m_ldx_imm, immediate, disp, nil, 0);
+		  GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
+		  GenNative(m_sta_dirX, direct, 0, nil, 0);
+		  GenNative(m_lda_imm, immediate, long(gLong.lval).msw, nil, 0);
+		  GenNative(m_sta_dirX, direct, 2, nil, 0);
+		  end; {else}
+
+	    otherwise:
+	       Error(cge1);
+	    end; {case}
+	 end; {else}
+      end;
+
+   cgSet: begin
+      GenTree(op^.left);
+      GenNative(m_pea, immediate, 0, nil, 0);
+      if op^.p = 0 then
+	 GenImplied(m_tdc)
+      else
+	 StaticLink(op^.p, false, true);
+      GenImplied(m_clc);
+      GenNative(m_adc_imm, immediate, disp, nil, 0);
+      GenImplied(m_pha);
+      GenNative(m_pea, immediate, op^.s, nil, 0);
+      GenCall(24);
+      end;
+
+   otherwise: ;
+
+   end; {case}
+end; {GenStrCop}
+
+
+procedure DirEnp;
+
+{ Generate code for a dc_enp					}
+
+begin {DirEnp}
+enpFound := true;
+GenImplied(d_end);
+EndSeg;
+InitLabels;
+end; {DirEnp}
+
+
+{$optimize 15}
+
+procedure GenTree {op: icptr};
+
+{ generate code for op and its children				}
+{								}
+{ parameters:							}
+{    op - opcode for which to generate code			}
+
+
+   procedure GenAbiBntNgiNotOddSqi (op: icptr);
+
+   { Generate code for a pc_abi, pc_bnt, pc_ngi pc_not, pc_odd, pc_sqi }
+
+   var
+      lab1: integer;
+
+   begin {GenAbiBntNgiNotOddSqi}
+   GenTree(op^.left);
+   case op^.opcode of
+      pc_abi: begin
+	 lab1 := GenLabel;
+         GenImplied(m_tax);
+	 GenNative(m_bpl, relative, lab1, nil, 0);
+	 GenNative(m_eor_imm, immediate, -1, nil, 0);
+	 GenImplied(m_ina);
+	 GenLab(lab1);
+	 end;
+
+      pc_bnt:
+	 GenNative(m_eor_imm, immediate, -1, nil, 0);
+
+      pc_ngi: begin
+	 GenNative(m_eor_imm, immediate, -1, nil, 0);
+	 GenImplied(m_ina);
+	 end; {case pc_ngi}
+
+      pc_not:
+	 GenNative(m_eor_imm, immediate, 1, nil, 0);
+
+      pc_odd:
+	 GenNative(m_and_imm, immediate, 1, nil, 0);
+
+      pc_sqi: begin
+	 GenImplied(m_tax);
+	 GenCall(32);
+	 if rangeCheck then
+	    GenCall(147);
+	 end;
+      end; {case}
+   end; {GenAbiBntNgiNotOddSqi}
+
+
+   procedure GenAblBnlNglOdlSql (op: icptr);
+
+   { Generate code for a pc_abl, pc_bnl, pc_ngl, pc_odl, pc_sql	}
+
+   var
+      lab1: integer;			{branch point}
+
+   begin {GenAblBnlNglOdlSql}
+   gLong.preference := onStack;
+   GenTree(op^.left);
+   case op^.opcode of
+      pc_abl: begin
+	 lab1 := GenLabel;
+	 GenNative(m_lda_s, direct, 3, nil, 0);
+	 GenNative(m_bpl, relative, lab1, nil, 0);
+	 GenImplied(m_sec);
+	 GenNative(m_lda_imm, immediate, 0, nil, 0);
+	 GenNative(m_sbc_s, direct, 1, nil, 0);
+	 GenNative(m_sta_s, direct, 1, nil, 0);
+	 GenNative(m_lda_imm, immediate, 0, nil, 0);
+	 GenNative(m_sbc_s, direct, 3, nil, 0);
+	 GenNative(m_sta_s, direct, 3, nil, 0);
+	 GenLab(lab1);
+	 end;
+
+      pc_bnl: begin
+	 GenNative(m_lda_s, direct, 1, nil, 0);
+	 GenNative(m_eor_imm, immediate, -1, nil, 0);
+	 GenNative(m_sta_s, direct, 1, nil, 0);
+	 GenNative(m_lda_s, direct, 3, nil, 0);
+	 GenNative(m_eor_imm, immediate, -1, nil, 0);
+	 GenNative(m_sta_s, direct, 3, nil, 0);
+	 end;
+
+      pc_ngl: begin
+	 GenImplied(m_sec);
+	 GenNative(m_lda_imm, immediate, 0, nil, 0);
+	 GenNative(m_sbc_s, direct, 1, nil, 0);
+	 GenNative(m_sta_s, direct, 1, nil, 0);
+	 GenNative(m_lda_imm, immediate, 0, nil, 0);
+	 GenNative(m_sbc_s, direct, 3, nil, 0);
+	 GenNative(m_sta_s, direct, 3, nil, 0);
+	 end;
+
+      pc_odl: begin
+	 GenImplied(m_pla);
+	 GenImplied(m_plx);
+	 GenNative(m_and_imm, immediate, 1, nil, 0);
+	 end;
+
+      pc_sql: begin
+	 GenNative(m_lda_s, direct, 3, nil, 0);
+	 GenImplied(m_pha);
+	 GenNative(m_lda_s, direct, 3, nil, 0);
+	 GenImplied(m_pha);
+	 GenCall(133);
+	 end;
+      end; {case}
+   gLong.where := onStack;
+   end; {GenAblBnlNglOdlSql}
+
+
+   procedure GenAbrNgr (op: icptr);
+
+   { generate a pc_abr or pc_ngr				}
+
+   begin {GenAbrNgr}
+   GenTree(op^.left);
+   GenNative(m_lda_s, direct, 9, nil, 0);
+   if op^.opcode = pc_abr then
+      GenNative(m_and_imm, immediate, $7FFF, nil, 0)
+   else {op^.opcode = pc_ngr}
+      GenNative(m_eor_imm, immediate, $8000, nil, 0);
+   GenNative(m_sta_s, direct, 9, nil, 0);
+   end; {GenAbrNgr}
+
+
+   procedure GenAdi (op: icptr);
+
+   { generate a pc_adi						}
+
+   var
+      nd: icptr;
+
+   begin {GenAdi}
+   if not Complex(op^.left) then
+      if Complex(op^.right) then begin
+	 nd := op^.left;
+	 op^.left := op^.right;
+	 op^.right := nd;
+	 end; {if}
+   GenTree(op^.left);
+   if Complex(op^.right) then begin
+      GenImplied(m_pha);
+      GenTree(op^.right);
+      GenImplied(m_clc);
+      GenNative(m_adc_s, direct, 1, nil, 0);
+      GenImplied(m_plx);
+      end {if}
+   else begin
+      GenImplied(m_clc);
+      OperA(m_adc_imm, op^.right);
+      end; {else}
+   if rangeCheck then
+      GenCall(147);
+   end; {GenAdi}
+
+
+   procedure GenAt2 (op: icptr);
+
+   { Generate code for a pc_at2					}
+
+   begin {GenAt2}
+   GenTree(op^.left);
+   GenTree(op^.right);
+   GenCall(123);
+   end; {GenAt2}
+
+
+   procedure GenBinLong (op: icptr);
+
+   { generate one of: pc_blr, pc_blx, pc_bal, pc_dvl, pc_mdl,	}
+   {    pc_mpl, pc_sll, pc_slr, pc_udl, pc_ulm, pc_uml, pc_vsr	}
+
+   var
+      nd: icptr;			{for swapping left/right children}
+
+
+      procedure GenOp (ops, opi: integer);
+
+      { generate a binary operation				}
+      {								}
+      { parameters:						}
+      {    ops - stack version of operation			}
+      {    opi - immediate version of operation			}
+
+      var
+	 lab1: integer;			{label number}
+
+      begin {GenOp}
+      GenImplied(m_pla);
+      if gLong.where = constant then begin
+	 GenNative(opi, immediate, long(gLong.lval).lsw, nil, 0);
+	 GenImplied(m_pha);
+	 GenNative(m_lda_s, direct, 3, nil, 0);
+	 GenNative(opi, immediate, long(gLong.lval).msw, nil, 0);
+	 GenNative(m_sta_s, direct, 3, nil, 0);
+	 end {if}
+      else begin
+	 GenNative(ops, direct, 3, nil, 0);
+	 GenNative(m_sta_s, direct, 3, nil, 0);
+	 GenImplied(m_pla);
+	 GenNative(ops, direct, 3, nil, 0);
+	 GenNative(m_sta_s, direct, 3, nil, 0);
+	 end; {else}
+      end; {GenOp}
+
+
+   begin {GenBinLong}
+   if (op^.left^.opcode = pc_ldc) and
+      (op^.opcode in [pc_blr,pc_blx,pc_bal]) then begin
+      nd := op^.left;
+      op^.left := op^.right;
+      op^.right := nd;
+      end; {if}
+   gLong.preference := onStack;
+   GenTree(op^.left);
+   if op^.opcode in [pc_blr,pc_blx,pc_bal] then begin
+      gLong.preference := constant;
+      GenTree(op^.right);
+      end {if}
+   else if op^.opcode in [pc_mdl,pc_uml,pc_udl,pc_ulm] then begin
+      gLong.preference := A_X;
+      GenTree(op^.right);
+      if gLong.where = onStack then begin
+         GenImplied(m_pla);
+         GenImplied(m_plx);
+         end; {if}
+      end {else if}
+   else begin
+      gLong.preference := onStack;
+      GenTree(op^.right);
+      end; {else}
+   case op^.opcode of
+
+      pc_blr: GenOp(m_ora_s, m_ora_imm);
+
+      pc_blx: GenOp(m_eor_s, m_eor_imm);
+
+      pc_bal: GenOp(m_and_s, m_and_imm);
+
+      pc_dvl: GenCall(134);
+
+      pc_mdl: GenCall(135);
+
+      pc_mpl: GenCall(133);
+
+      pc_sll: GenCall(136);
+
+      pc_slr: GenCall(171);
+
+      pc_udl: GenCall(173);
+
+      pc_ulm: GenCall(174);
+
+      pc_uml: GenCall(172);
+
+      pc_vsr: GenCall(170);
+
+      otherwise: Error(cge1);
+      end; {case}
+   gLong.where := onStack;
+   end; {GenBinLong}
+
+
+   procedure GenBno (op: icptr);
+
+   { Generate code for a pc_bno					}
+
+   var
+      lLong: longType;			{requested address type}
+
+   begin {GenBno}
+   lLong := gLong;
+   GenTree(op^.left);
+   gLong := lLong;
+   GenTree(op^.right);
+   end; {GenBno}
+
+
+   procedure GenChk (op: icptr);
+
+   { Generate code for a pc_chk					}
+
+   begin {GenChk}
+   gLong.preference := onStack;
+   GenTree(op^.left);
+   case op^.optype of
+      otherwise:
+         Error(cge1);
+      cgByte,cgUByte,cgWord,cgUWord: begin
+	 GenNative(m_ldx_imm, immediate, op^.r, nil, 0);
+	 GenNative(m_ldy_imm, immediate, op^.q, nil, 0);
+	 GenCall(33);
+	 end;
+      cgLong,cgULong:
+         if (op^.lval = 1) and (op^.lval2 = maxaddr) then
+            GenCall(34)
+         else begin
+	    GenNative(m_pea, immediate, long(op^.lval).msw, nil, 0);
+	    GenNative(m_pea, immediate, long(op^.lval).lsw, nil, 0);
+	    GenNative(m_pea, immediate, long(op^.lval2).msw, nil, 0);
+	    GenNative(m_pea, immediate, long(op^.lval2).lsw, nil, 0);
+            GenCall(179);
+            end; {else}
+     end; {case}
+   end; {GenChk}
+
+
+   procedure GenCsp (op: icptr);
+
+   { Generate code for a pc_csp					}
+   {								}
+   { parameters:						}
+   {    op - operation						}
+
+   var
+      lLong: longType;			   {used to reserve gLong}
+
+   begin {GenCsp}
+   lLong := gLong;
+   gLong.preference := onStack;
+   GenTree(op^.left);
+   gLong := lLong;
+   case op^.q of
+      otherwise:
+	 Error(cge1);
+      1, {get from a file}
+      2, {put to a file}
+      3, {open}
+      4, {close}
+      5, {read an integer}
+      6, {read a real}
+      7, {read a character from a file}
+      8, {write a character to a file}
+      9, {write an integer to a file}
+      10, {write real to a file}
+      11, {new}
+      13, {readln}
+      14, {write an end of line}
+      15, {write a form feed}
+      17, {dispose}
+      26, {writeln to stout}
+      27, {writeln to errout}
+      35, {clear an area of memory}
+      44, {seek a file record}
+      45, {write a string}
+      46, {write a boolean}
+      48, {eof(f)}
+      49, {eoln(f)}
+      58, {read character from input}
+      59, {read int from input}
+      60, {readln(input)}
+      61, {read real from input}
+      62, {write real to output}
+     185, {eof(input)}
+     186: {eoln(input)}
+	 GenCall(op^.q);
+      12: {writeln string}
+	 GenCall(155);
+      19: {write string}
+	 GenCall(153);
+      22: {writeln string to error out}
+	 GenCall(156);
+      23: {write string to error out}
+	 GenCall(154);
+      16,34,42,43: begin {variations on write integer}
+	 GenNative(m_pea, immediate, ord((op^.q=34) or (op^.q=43)), nil, 0);
+	 GenNative(m_pea, immediate, ord(op^.q>=42), nil, 0);
+	 GenCall(21);
+	 end;
+      20,21,24,25: begin {variations on write constant string}
+	GenNative(m_pea, immediate, ord(not odd(op^.q)), nil, 0);
+	GenNative(m_pea, immediate, ord(op^.q>=24), nil, 0);
+	GenCall(19);
+	end;
+      28,29,30,31: begin {variations on write boolean}
+	GenNative(m_pea, immediate, ord(not odd(op^.q)), nil, 0);
+	GenNative(m_pea, immediate, ord(op^.q>=30), nil, 0);
+	GenCall(20);
+	end;
+      32: begin {form feed to standard out}
+	GenNative(m_pea, immediate, 12, nil, 0);
+	GenCall(151);
+	end;
+      33: begin {form feed to error out}
+	GenNative(m_pea, immediate, 12, nil, 0);
+	GenCall(152);
+	end;
+      36,37,38,39: begin {variations on write character}
+	GenNative(m_pea, immediate, ord(not odd(op^.q)), nil, 0);
+	GenNative(m_pea, immediate, ord(op^.q>=38), nil, 0);
+	GenCall(22);
+	end;
+      40,41: {write a single character}
+	GenCall(151+op^.q-40);
+      50:
+	GenCall(109);
+      51, {pack}
+      52: {unpack}
+	GenCall(op^.q+74);
+      53: {write real to error out}
+	GenCall(128);
+      66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,82,85,
+      86,87,88,90,91,92,93:
+	GenCall(op^.q+25);
+      81, {cnvsl}
+      83: {random int and longint} begin
+	GenCall(op^.q+25);
+	if op^.optype = cgLong then
+	  if (gLong.preference & A_X) = 0 then begin
+	    gLong.where := onStack;
+	    GenImplied(m_phx);
+	    GenImplied(m_pha);
+	    end
+	  else
+	    gLong.where := A_X;
+	end;
+      84:
+	GenCall(79);
+      95: {nop};
+      96, {new open record}
+      97: {dispose open record}
+	GenCall(op^.q+35);
+      98, {read long from stin}
+      99: {read long from file} begin
+	GenCall(op^.q+42);
+	gLong.where := onStack;
+	end;
+      102: {write long to file}
+	GenCall(144);
+      100, {write long to stout}
+      101: {write long to errout} begin
+	GenNative(m_pea, immediate, 0, nil, 0);
+	GenNative(m_pea, immediate, ord(odd(op^.q)), nil, 0);
+	GenCall(143);
+	end;
+      115: {redirect input/output}
+	GenCall(148);
+      116: {four-byte new}
+	GenCall(180);
+      117: {Member}
+        GenCall(181);
+      118: {NewObject}
+        GenCall(182);
+      119,120: begin {FixString}
+        GenCall(op^.q + 64);
+	gLong.where := onStack;
+        end;
+      end; {case}
+   end; {GenCsp}
+
+
+   procedure GenCui (op: icptr);
+
+   { Generate code for a pc_cui					}
+
+   var
+      lab1: integer;			{return point}
+      lLong: longType;			{used to reserve gLong}
+
+   begin {GenCui}
+   {generate parameters}
+   lLong := gLong;			{place the operands on the stack}
+   GenTree(op^.right);
+   gLong.preference := onStack;		{get the address to call}
+   GenTree(op^.left^.left);
+   gLong := lLong;
+
+   lab1 := GenLabel;			{create a return label}
+   GenNative(m_lda_s, direct, 1, nil, 0); {place the call/return addrs on stack}
+   GenImplied(m_dea);
+   GenImplied(m_pha);
+   GenNative(m_sep, immediate, 32, nil, 0);
+   GenNative(m_lda_s, direct, 5, nil, 0);
+   GenNative(m_sta_s, direct, 3, nil, 0);
+   GenNative(m_lda_imm, genAddress, lab1, nil, shift16);
+   GenNative(m_sta_s, direct, 6, nil, 0);
+   GenNative(m_rep, immediate, 32, nil, 0);
+   GenNative(m_lda_imm, genAddress, lab1, nil, sub1);
+   GenNative(m_sta_s, direct, 4, nil, 0);
+
+   GenTree(op^.left^.right);		{get the static level}
+   GenImplied(m_tax);
+
+   GenImplied(m_rtl);			{indirect call}
+   GenLab(lab1);
+
+   gLong.where := A_X;			{save the returned value}
+   SaveRetValue(op^.optype);
+   end; {GenCui}
+
+
+   procedure GenCum (op: icptr);
+
+   { Generate code for a pc_cum					}
+
+   var
+      lab1, lab2: integer;		{return point; jsl patch location}
+      sDisp: unsigned;			{size of the parameters}
+
+
+      function Size (op: icptr): unsigned;
+
+      { Find the length of the parameters in the tree		}
+      {								}
+      { parameters:						}
+      {    op - tree to scan					}
+      {								}
+      { returns: Length of the parameters			}
+
+      begin {Size}
+      if op^.opcode = pc_bno then
+         Size := Size(op^.left) + Size(op^.right)
+      else if op^.opcode = pc_stk then
+         case op^.optype of
+	    cgByte,cgUByte,cgWord,cgUWord: Size := cgWordSize;
+            cgLong,cgULong,cgString,cgVoid: Size := cgLongSize;
+	    cgReal,cgDouble,cgComp,cgExtended: Size := cgExtendedSize;
+	    cgSet: Size := op^.left^.q;
+            end {case}
+      else
+         Size := 0;
+      end; {Size}
+
+
+   begin {GenCum}
+   {generate parameters}
+   sDisp := Size(op^.left);		{find the disp of the SELF parm}
+   GenTree(op^.left);			{place the operands on the stack}
+
+   lab1 := GenLabel;			{create a return/jsl label}
+   if jslOptimizations then begin
+
+      {use self-modifying code for an indirect call}
+      lab2 := GenLabel;
+      GenImplied(m_phd);
+      GenImplied(m_tsc);
+      GenImplied(m_tcd);
+      GenNative(m_ldy_imm, immediate, long(op^.lval).lsw + 1, nil, 0);
+      GenNative(m_lda_indly, direct, sDisp - 1, nil, 0);
+      GenNative(m_sta_long, longAbs, lab2, nil, 0);
+      GenImplied(m_dey);
+      GenNative(m_lda_indly, direct, sDisp - 1, nil, 0);
+      GenNative(m_sta_long, longAbs, lab1, nil, 0);
+      GenImplied(m_pld);
+      GenImplied(m_jsl);
+      GenLab(lab1);
+      GenImplied(m_jsl);
+      GenLab(lab2);
+      GenImplied(m_jsl);
+      GenImplied(m_jsl);
+      end {if}        
+   else begin
+
+      {do a ROMable indirect call}
+
+      {place the return addr on the stack}
+      GenImplied(m_phk);
+      GenNative(m_lda_imm, genAddress, lab1, nil, sub1);
+      GenImplied(m_pha);
+
+      {get the address to call}
+      if op^.lval < maxint-2 then begin
+	 GenNative(m_lda_s, direct, sDisp+2, nil, 0);
+	 GenNative(m_sta_dir, direct, dWorkLoc+2, nil, 0);
+	 GenNative(m_lda_s, direct, sDisp, nil, 0);
+	 GenNative(m_sta_dir, direct, dWorkLoc, nil, 0);
+	 GenNative(m_ldy_imm, immediate, long(op^.lval).lsw+2, nil, 0);
+	 GenNative(m_sep, immediate, 32, nil, 0);
+	 GenNative(m_lda_indly, direct, dWorkLoc, nil, 0);
+	 GenImplied(m_pha);
+	 GenNative(m_rep, immediate, 32, nil, 0);
+	 GenNative(m_ldy_imm, immediate, long(op^.lval).lsw, nil, 0);
+	 GenNative(m_lda_indly, direct, dWorkLoc, nil, 0);
+	 GenImplied(m_dea);
+	 GenImplied(m_pha);
+	 end {if}
+      else begin
+	 GenImplied(m_clc);
+	 GenNative(m_lda_s, direct, sDisp, nil, 0);
+	 GenNative(m_adc_imm, immediate, long(op^.lval).lsw, nil, 0);
+	 GenNative(m_sta_dir, direct, dWorkLoc, nil, 0);
+	 GenNative(m_lda_s, direct, sDisp+2, nil, 0);
+	 GenNative(m_adc_imm, immediate, long(op^.lval).msw, nil, 0);
+	 GenNative(m_sta_dir, direct, dWorkLoc+2, nil, 0);
+	 GenNative(m_ldy_imm, immediate, 2, nil, 0);
+	 GenNative(m_sep, immediate, 32, nil, 0);
+	 GenNative(m_lda_indly, direct, dWorkLoc, nil, 0);
+	 GenImplied(m_pha);
+	 GenNative(m_rep, immediate, 32, nil, 0);
+	 GenNative(m_lda_indl, direct, dWorkLoc, nil, 0);
+	 GenImplied(m_pha);
+	 end; {else}
+
+      {indirect call}
+      GenImplied(m_rtl);
+      GenLab(lab1);
+      end; {else}
+
+   gLong.where := A_X;			{save the returned value}
+   SaveRetValue(op^.optype);
+   end; {GenCum}
+
+
+   procedure GenCup (op: icptr);
+
+   { Generate code for a pc_cup					}
+
+   var
+      lLong: longType;			   {used to reserve gLong}
+
+   begin {GenCup}
+   {generate parameters}
+   lLong := gLong;
+   GenTree(op^.left);
+   gLong := lLong;
+
+   {create the static link}
+   if (op^.lab = nil) or (not noGlobalLabels) then begin
+      if op^.q = 0 then begin
+	 GenImplied(m_tdc);
+	 GenImplied(m_tax);
+	 end {if}
+      else
+	 StaticLink(op^.q, false, false);
+      end; {if}
+
+   {generate the jsl}
+   if op^.lab = nil then
+      GenNative(m_jsl, longAbs, op^.r, nil, 0)
+   else   
+      GenNative(m_jsl, longAbs, 0, op^.lab, 0);
+
+   {save the returned value}
+   gLong.where := A_X;
+   SaveRetValue(op^.optype);
+   end; {GenCup}
+
+
+   procedure GenDifIntUni (op: icptr);
+
+   { Generate code for a pc_dif, pc_int, pc_uni			}
+
+   var
+      snum: integer;			{call number}
+
+   begin {GenDifIntUni}
+   GenTree(op^.left);
+   GenTree(op^.right);
+   case op^.opcode of
+      pc_dif: snum := 38;
+      pc_int: snum := 39;
+      pc_uni: snum := 40;
+      end; {case}
+   GenCall(snum);
+   end; {GenDifIntUni}
+
+
+   procedure GenDviMod (op: icptr);
+
+   { Generate code for a pc_dvi, pc_mod, pc_udi or pc_uim	}
+
+   var
+      opcode: pcodes;			{temp storage}
+
+   begin {GenDviMod}
+   if Complex(op^.right) then begin
+      GenTree(op^.right);
+      if Complex(op^.left) then begin
+	 GenImplied(m_pha);
+	 GenTree(op^.left);
+	 GenImplied(m_plx);
+	 end {if}
+      else begin
+	 GenImplied(m_tax);
+	 GenTree(op^.left);
+	 end; {else}
+      end {if}
+   else begin
+      GenTree(op^.left);
+      LoadX(op^.right);
+      end; {else}
+   opcode := op^.opcode;
+   if opcode = pc_mod then
+      GenCall(124)
+   else if opcode = pc_dvi then
+      GenCall(41)
+   else {if opcode in [pc_udi,pc_uim] then} begin
+      GenCall(165);
+      if opcode = pc_uim then
+	 GenImplied(m_txa);
+      end; {else}
+   if rangeCheck then
+      GenCall(147);
+   end; {GenDviMod}
+
+
+   procedure GenEnt;
+
+   { Generate code for a pc_ent					}
+
+   begin {GenEnt}
+   if rangeCheck then begin		{if range checking is on, check for a stack overflow}
+      GenNative(m_pea, immediate, localSize - returnSize - 1, nil, 0);
+      GenCall(129);
+      end; {if}
+
+   if localSize = 0 then begin		{create the stack frame}
+      if parameterSize <> 0 then begin
+	 GenImplied(m_tsc);
+	 GenImplied(m_phd);
+	 GenImplied(m_tcd);
+	 end; {if}
+      end {if}
+   else if localSize = 2 then begin
+      GenImplied(m_phx);
+      GenImplied(m_tsc);
+      GenImplied(m_phd);
+      GenImplied(m_tcd);
+      end {else if}
+   else begin
+      GenImplied(m_tsc);
+      GenImplied(m_sec);
+      GenNative(m_sbc_imm, immediate, localSize, nil, 0);
+      GenImplied(m_tcs);
+      GenImplied(m_phd);
+      GenImplied(m_tcd);
+      end; {if}
+
+   if staticLoc <> 0 then		{set up the static link}
+      if localSize <> 2 then
+         GenNative(m_stx_dir, direct, staticLoc, nil, 0);
+
+   if dataBank then begin		{preserve and set data bank}
+      GenImplied(m_phb);
+      GenImplied(m_phb);
+      GenImplied(m_pla);
+      GenNative(m_sta_dir, direct, bankLoc, nil, 0);
+      GenNative(m_pea, immediate, 0, @'~GLOBALS', shift8);
+      GenImplied(m_plb);
+      GenImplied(m_plb);
+      end; {if}
+
+   {no pc_nam (yet)}
+   namePushed := false;
+   end; {GenEnt}
+
+
+   procedure GenFix (op: icptr);
+
+   { Generate code for a pc_fix					}
+
+   begin {GenFix}
+   GenNative(m_pea, immediate, localLabel[op^.q], nil, 0);
+   if op^.optype = cgReal then
+      GenCall(83)
+   else if op^.optype = cgDouble then
+      GenCall(86)
+   else if op^.optype = cgComp then
+      GenCall(178)
+   end; {GenFix}
+
+
+   procedure GenFjpTjp (op: icptr);
+
+   { Generate code for a pc_fjp or pc_tjp			}
+
+   var
+      lab1: integer;			{branch point}
+      opcode: pcodes;			{op^.left^.opcode}
+
+   begin {GenFjpTjp}
+   if op^.left^.opcode in [pc_equ,pc_geq,pc_grt,pc_les,pc_leq,pc_neq] then
+      if op^.left^.opcode in [pc_equ,pc_neq] then
+	 GenEquNeq(op^.left, op^.opcode, op^.q)
+      else
+	 GenCmp(op^.left, op^.opcode, op^.q)
+   else begin
+      lab1 := GenLabel;
+      GenTree(op^.left);
+      opcode := op^.left^.opcode;
+      if NeedsCondition(opcode) then
+	 GenImplied(m_tax)
+      else if opcode = pc_ind then
+         if op^.left^.optype in [cgByte,cgUByte] then
+	    GenImplied(m_tax);
+      if op^.opcode = pc_fjp then                    
+	 GenNative(m_bne, relative, lab1, nil, 0)
+      else {if op^.opcode = pc_tjp then}
+	 GenNative(m_beq, relative, lab1, nil, 0);
+      GenNative(m_brl, longrelative, op^.q, nil, 0);
+      GenLab(lab1);
+      end; {else}
+   end; {GenFjpTjp}
+
+
+   procedure GenInn (op: icptr);
+
+   { Generate code for a pc_inn					}
+
+   label 1;
+
+   const
+      maxCard = 8;			{largest constant set cardinality to
+					 use branches on}
+
+   var
+      lab1: integer;			{branch label}
+      i,j: integer;			{loop counters}
+      byte: integer;			{one byte of the set array}
+      card: integer;			{cardinality of the set}
+      constants: array[1..maxCard] of integer; {ord of set elements}
+      done: boolean;			{used to see if the operation is done}
+      lop: pcodes;			{op code of top of set tree}
+
+   begin {GenInn}
+   done := false;
+   GenTree(op^.left);
+   lop := op^.right^.opcode;
+   if lop = pc_ldc then
+      with op^.right^.setp^ do begin
+	 card := 0;
+	 for i := 1 to smax do begin
+	    byte := ord(sval[i]);
+	    if byte <> 0 then
+	       for j := 0 to 7 do begin
+		  if odd(byte) then begin
+		     if card = maxCard then
+			goto 1;
+		     card := card+1;
+		     constants[card] := (i-1)*8+j;
+		     end; {if}
+		  byte := byte >> 1;
+		  end; {for}
+	    end; {for}
+	 lab1 := GenLabel;
+	 GenNative(m_ldx_imm, immediate, 1, nil, 0);
+	 for i := 1 to card do begin
+	    GenNative(m_cmp_imm, immediate, constants[i], nil, 0);
+	    GenNative(m_beq, relative, lab1, nil, 0);
+	    end; {for}
+	 GenImplied(m_dex);
+	 GenLab(lab1);
+	 GenImplied(m_txa);
+	 done := true;
+	 end; {with}
+1: if not done then begin
+      GenImplied(m_pha);
+      if lop = pc_ldo then begin
+	 with op^.right^ do begin
+	    GenNative(m_pea, immediate, r, lab, shift16);
+	    GenNative(m_pea, immediate, r, lab, 0);
+	    GenNative(m_pea, immediate, q, nil, 0);
+	    GenCall(130);
+	    end; {with}
+	 end {if}
+      else if lop = pc_lod then begin
+	 with op^.right^ do begin
+	    GenNative(m_pea, immediate, 0, nil, 0);
+	    if p = 0 then
+	       GenImplied(m_tdc)
+	    else
+	       StaticLink(p, false, true);
+	    GenImplied(m_clc);
+	    GenNative(m_adc_imm, immediate, localLabel[r]+q, nil, 0);
+	    GenImplied(m_pha);
+	    GenNative(m_pea, immediate, s, nil, 0);
+	    GenCall(130);
+	    end; {with}
+	 end{else if}
+      else begin
+	 GenTree(op^.right);
+	 GenCall(42);
+	 end; {else}
+      end; {if}
+   end; {GenInn}
+
+
+   procedure GenLaoLad (op: icptr);
+
+   { Generate code for a pc_lao, pc_lad				}
+
+   var
+      q: integer;			{displacement}
+
+   begin {GenLaoLad}
+   if op^.opcode = pc_lad then
+      q := 0
+   else
+      q := op^.q;
+   if (globalLabel & gLong.preference) <> 0 then begin
+      gLong.fixedDisp := true;
+      gLong.where := globalLabel;
+      gLong.disp := q;
+      gLong.lab := op^.lab;
+      end {if}
+   else if (A_X & gLong.preference) <> 0 then begin
+      gLong.where := A_X;
+      GenNative(m_ldx_imm, immediate, q, op^.lab, shift16);
+      GenNative(m_lda_imm, immediate, q, op^.lab, 0);
+      end {else if}
+   else begin
+      gLong.where := onStack;
+      GenNative(m_pea, immediate, q, op^.lab, shift16);
+      GenNative(m_pea, immediate, q, op^.lab, 0);
+      end; {else}
+   end; {GenLaoLad}
+
+
+   procedure GenLca (op: icptr);
+
+   { Generate code for a pc_lca					}
+
+   var
+      i: integer;			{loop/index variable}
+      len: unsigned;			{string length}
+
+   begin {GenLca}
+   gLong.where := onStack;
+   GenNative(m_pea, immediate, stringSize, nil, stringReference+shift16);
+   GenNative(m_pea, immediate, stringSize, nil, stringReference);
+   len := op^.q;
+   if maxString-stringSize >= len then begin
+      for i := 1 to op^.q do
+	 stringSpace[i+stringSize] := op^.str^[i];
+      stringSize := stringSize+len;
+      end
+   else
+      Error(cge3);
+   op^.optype := cgULong;
+   end; {GenLca}
+
+
+   procedure GenLda (op: icptr);
+
+   { Generate code for a pc_lda					}
+
+   begin {GenLda}
+   if ((localAddress & gLong.preference) <> 0) and (op^.p = 0) then begin
+      gLong.fixedDisp := true;
+      gLong.where := localAddress;
+      gLong.disp := localLabel[op^.s] + op^.q;
+      end {if}
+   else if (A_X & gLong.preference) <> 0 then begin
+      gLong.where := A_X;
+      if op^.p = 0 then
+	 GenImplied(m_tdc)
+      else
+	 StaticLink(op^.p, false, true);
+      GenImplied(m_clc);
+      GenNative(m_adc_imm, immediate, localLabel[op^.s] + op^.q, nil, 0);
+      GenNative(m_ldx_imm, immediate, 0, nil, 0);
+      end {else if}
+   else begin
+      gLong.where := onStack;
+      GenNative(m_pea, immediate, 0, nil, 0);
+      if op^.p = 0 then
+	 GenImplied(m_tdc)
+      else
+	 StaticLink(op^.p, false, true);
+      GenImplied(m_clc);
+      GenNative(m_adc_imm, immediate, localLabel[op^.s] + op^.q, nil, 0);
+      GenImplied(m_pha);
+      end; {else}
+   end; {GenLda}
+
+
+   procedure GenLdc (op: icptr);
+
+   { Generate code for a pc_ldc					}
+
+   type
+      kind = (vint, vbyte, vreal);	{kinds of equivalenced data}
+
+   var
+      i: unsigned;			{loop/index variable}
+      rec: realrec;			{conversion record}
+      switch: packed record		{used for type conversion}
+	 case rkind: kind of
+	    vint: (i: integer);
+	    vbyte: (b1, b2, b3, b4, b5, b6, b7, b8: byte);
+	    vreal: (r: double);
+	 end;
+
+   begin {GenLdc}
+   case op^.optype of
+      cgByte: begin
+	 if op^.q > 127 then
+	    op^.q := op^.q | $FF00;
+	 GenNative(m_lda_imm, immediate, op^.q, nil, 0);
+	 end;
+
+      cgUByte, cgWord, cgUWord:
+	 GenNative(m_lda_imm, immediate, op^.q, nil, 0);
+
+      cgReal, cgDouble, cgComp, cgExtended: begin
+	 rec.itsReal := op^.rval;
+	 CnvSX(rec);
+	 i := 10;
+	 while i <> 0 do begin
+	    switch.b1 := rec.inSANE[i-1];
+	    switch.b2 := rec.inSANE[i];
+	    GenNative(m_pea, immediate, switch.i, nil, 0);
+	    i := i-2;
+	    end; {while}
+	 end;
+
+      cgLong, cgULong:
+	 if (constant & gLong.preference) <> 0 then begin
+	    gLong.where := constant;
+	    gLong.lval := op^.lval;
+	    end
+	 else if (A_X & gLong.preference) <> 0 then begin
+	    gLong.where := A_X;
+	    GenNative(m_lda_imm, immediate, long(op^.lval).lsw, nil, 0);
+	    GenNative(m_ldx_imm, immediate, long(op^.lval).msw, nil, 0);
+	    end
+	 else begin
+	    gLong.where := onStack;
+	    GenNative(m_pea, immediate, long(op^.lval).msw, nil, 0);
+	    GenNative(m_pea, immediate, long(op^.lval).lsw, nil, 0);
+	    end;
+
+      cgSet: begin
+	 with op^.setp^ do begin
+	    if odd(smax) then begin
+	      smax := smax+1;
+	      sval[smax] := chr(0);
+	      end; {if}
+	    i := smax;
+	    while i <> 0 do begin
+	       switch.b1 := ord(sval[i-1]);
+	       switch.b2 := ord(sval[i]);
+	       GenNative(m_pea, immediate, switch.i, nil, 0);
+	       i := i-2;
+	       end; {while}
+	    GenNative(m_pea, immediate, smax, nil, 0);
+	    end; {with}     
+	 end;
+
+      otherwise:
+	 Error(cge1);
+      end; {case}
+   end; {GenLdc}     
+
+
+   procedure GenLdo (op: icptr);
+
+   { Generate code for a pc_ldo					}
+
+   var
+      i: unsigned;			{set size}
+      lab1: unsigned;			{branch point}
+
+   begin {GenLdo}
+   case op^.optype of
+      cgWord, cgUWord:
+	 if smallMemoryModel then
+	    GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0)
+	 else
+	    GenNative(m_lda_long, longAbs, op^.q, op^.lab, 0);
+
+      cgByte, cgUByte: begin
+	 if smallMemoryModel then
+	    GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0)
+	 else
+	    GenNative(m_lda_long, longAbs, op^.q, op^.lab, 0);
+	 GenNative(m_and_imm, immediate, 255, nil, 0);
+	 if op^.optype = cgByte then begin
+	    GenNative(m_bit_imm, immediate, $0080, nil, 0);
+	    lab1 := GenLabel;
+	    GenNative(m_beq, relative, lab1, nil, 0);
+	    GenNative(m_ora_imm, immediate, $FF00, nil, 0);
+	    GenLab(lab1);
+	    GenNative(m_cmp_imm, immediate, $0000, nil, 0);
+	    end; {if}
+	 end;
+
+      cgReal, cgDouble, cgComp, cgExtended: begin
+	 GenNative(m_pea, immediate, op^.q, op^.lab, shift16);
+	 GenNative(m_pea, immediate, op^.q, op^.lab, 0);
+	 if op^.optype = cgReal then
+	    GenCall(25)
+	 else if op^.optype = cgDouble then
+	    GenCall(18)
+	 else if op^.optype = cgComp then
+	    GenCall(163)
+	 else {if op^.optype = cgExtended then}
+	    GenCall(164);
+	 end;
+
+      cgLong, cgULong: begin
+	 if (A_X & gLong.preference) <> 0 then
+	    gLong.where := A_X
+	 else
+	    gLong.where := onStack;
+	 if smallMemoryModel then begin
+	    GenNative(m_ldx_abs, absolute, op^.q+2, op^.lab, 0);
+	    GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0);
+	    if gLong.where = onStack then begin
+	       GenImplied(m_phx);
+	       GenImplied(m_pha);
+	       end; {if}
+	    end {if}
+	 else begin
+	    GenNative(m_lda_long, longabsolute, op^.q+2, op^.lab, 0);
+	    if gLong.where = onStack then
+	       GenImplied(m_pha)
+	    else
+	       GenImplied(m_tax);
+	    GenNative(m_lda_long, longabsolute, op^.q, op^.lab, 0);
+	    if gLong.where = onStack then
+	       GenImplied(m_pha);
+	    end; {else}
+	 end; {case cgLong,cgULong}
+
+      cgSet: begin
+	 if op^.q <= 8 then begin
+	    i := op^.q;
+	    if odd(i) then begin
+	       i := i-1;
+	       GenNative(m_sep, immediate, 32, nil, 0);
+	       GenNative(m_lda_abs, absolute, op^.r+i, op^.lab, 0);
+	       GenImplied(m_pha);
+	       GenNative(m_rep, immediate, 32, nil, 0);
+	       end; {if}
+	    while i <> 0 do begin
+	       i := i-2;
+	       GenNative(m_lda_abs, absolute, op^.r+i, op^.lab, 0);
+	       GenImplied(m_pha);
+	       end; {while}
+	    GenNative(m_pea, immediate, op^.q, nil, 0);
+	    end {if}
+	 else begin
+	    GenNative(m_pea, immediate, op^.r, op^.lab, shift16);
+	    GenNative(m_pea, immediate, op^.r, op^.lab, 0);
+	    GenNative(m_pea, immediate, op^.q, nil,0);
+	    GenCall(28);
+	    end; {else}
+	 end; {case cgSet}
+
+      otherwise:
+	 Error(cge1);
+      end; {case}
+   end; {GenLdo}
+
+
+   procedure GenLla (op: icptr);
+
+   { Generate code for a pc_lla					}
+
+   begin {GenLla}
+   gLong.where := onStack;
+   GenNative(m_pea, genAddress, op^.q, nil, shift16);
+   GenNative(m_pea, genAddress, op^.q, nil, 0);
+   end; {GenLla}
+
+
+   procedure GenLnm (op: icptr);
+
+   { Generate code for a pc_lnm					}
+
+   begin {GenLnm}
+   if op^.left <> nil then
+      GenTree(op^.left);
+   if traceBack then begin
+      GenNative(m_pea, immediate, op^.r, nil, 0);
+      GenCall(75);
+      end; {if}
+   if debugFlag then begin
+      GenNative(m_cop, immediate, op^.q, nil, 0);
+      GenNative(d_wrd, special, op^.r, nil, 0);
+      end; {if}
+   end; {GenLnm}
+
+
+   procedure GenLod (op: icptr);
+
+   { Generate code for a pc_lod					}
+
+   var
+      disp: integer;			{load location}
+      i: unsigned;			{loop/index variable}
+      lab1: unsigned;			{branch point}
+      optype: baseTypeEnum;		{op^.optype}
+
+   begin {GenLod}
+   disp := localLabel[op^.r] + op^.q;
+   optype := op^.optype;
+   case optype of
+      cgReal, cgDouble, cgComp, cgExtended: begin
+	 GenNative(m_pea, immediate, 0, nil, 0);
+	 if op^.p = 0 then
+	    GenImplied(m_tdc)
+	 else
+	    StaticLink(op^.p, false, true);
+	 GenImplied(m_clc);
+	 GenNative(m_adc_imm, immediate, disp, nil, 0);
+	 GenImplied(m_pha);
+	 if optype = cgReal then
+	    GenCall(25)
+	 else if optype = cgDouble then
+	    GenCall(18)
+	 else if optype = cgComp then
+	    GenCall(163)
+	 else {if optype = cgExtended then}
+	    GenCall(164);
+	 end;
+
+      cgLong, cgULong: begin
+	 if op^.p <> 0 then begin
+	    gLong.where := onStack;
+	    StaticLink(op^.p, false, false);
+	    GenNative(m_lda_longx, longabsolute, disp+2, nil, 0);
+	    GenImplied(m_pha);
+	    GenNative(m_lda_longx, longabsolute, disp, nil, 0);
+	    GenImplied(m_pha);
+	    end {if}
+         else if ((inPointer & gLong.preference) <> 0) and (disp < 254) then
+	    begin
+	    gLong.where := inPointer;
+	    gLong.fixedDisp := true;
+	    gLong.disp := disp;
+	    end {else if}
+	 else if ((A_X & gLong.preference) <> 0) and (disp < 254) then begin
+	    gLong.where := A_X;
+	    GenNative(m_ldx_dir, direct, disp+2, nil, 0);
+	    GenNative(m_lda_dir, direct, disp, nil, 0);
+	    end {else if}
+	 else begin
+	    gLong.where := onStack;
+	    if disp >= 254 then begin
+	       GenNative(m_ldx_imm, immediate, disp, nil, 0);
+	       GenNative(m_lda_dirx, direct, 2, nil, 0);
+	       GenImplied(m_pha);
+	       GenNative(m_lda_dirx, direct, 0, nil, 0);
+	       GenImplied(m_pha);
+	       end {if}
+	    else begin
+	       GenNative(m_pei_dir, direct, disp+2, nil, 0);
+	       GenNative(m_pei_dir, direct, disp, nil, 0);
+	       end; {else}
+	    end; {else}
+	 end;
+
+      cgByte, cgUByte, cgWord, cgUWord: begin
+         if op^.p <> 0 then begin
+	    StaticLink(op^.p, false, false);
+	    GenNative(m_lda_longx, longabsolute, disp, nil, 0);
+            end {if}
+	 else if disp >= 256 then begin
+	    GenNative(m_ldx_imm, immediate, disp, nil, 0);
+	    GenNative(m_lda_dirx, direct, 0, nil, 0);
+	    end {else if}
+	 else
+	    GenNative(m_lda_dir, direct, disp, nil, 0);
+	 if optype in [cgByte,cgUByte] then begin
+	    GenNative(m_and_imm, immediate, $00FF, nil, 0);
+	    if optype = cgByte then begin
+	       GenNative(m_bit_imm, immediate, $0080, nil, 0);
+	       lab1 := GenLabel;
+	       GenNative(m_beq, relative, lab1, nil, 0);
+	       GenNative(m_ora_imm, immediate, $FF00, nil, 0);
+	       GenLab(lab1);
+	       GenNative(m_cmp_imm, immediate, $0000, nil, 0);
+	       end; {if}
+	    end;
+	 end;
+
+      cgSet:
+	 if (op^.p = 0) and (disp < 248) and (op^.s <= 8) then begin
+	    i := op^.s;
+	    if odd(i) then begin
+	       i := i-1;
+	       GenNative(m_sep, immediate, 32, nil, 0);
+	       GenNative(m_lda_dir, direct, disp+i, nil, 0);
+	       GenImplied(m_pha);
+	       GenNative(m_rep, immediate, 32, nil, 0);
+	       end; {if}
+	    while i <> 0 do begin
+	       i := i-2;
+	       GenNative(m_pei_dir, direct, disp+i, nil, 0);
+	       end; {end}
+	    GenNative(m_pea, immediate, op^.s, nil, 0);
+	    end {if}
+	 else begin
+	    GenNative(m_pea, immediate, 0, nil, 0);
+	    if op^.p = 0 then
+	       GenImplied(m_tdc)
+	    else
+	       StaticLink(op^.p, false, true);
+	    GenImplied(m_clc);
+	    GenNative(m_adc_imm, immediate, disp, nil, 0);
+	    GenImplied(m_pha);
+	    GenNative(m_pea, immediate, op^.s, nil, 0);
+	    GenCall(28);
+	    end; {else}
+
+      otherwise:
+	 Error(cge1);
+
+      end; {case}
+   end; {GenLod}
+
+
+   procedure GenLsl (op: icptr);
+
+   { Generate code for a pc_lsl					}
+   
+   begin {GenLsl}
+   if op^.q = 0 then
+      GenImplied(m_tdc)
+   else
+      StaticLink(op^.q, false, true);
+   end; {GenLsl}
+
+
+   procedure GenMov (op: icptr; duplicate: boolean);
+
+   { Generate code for a pc_mov					}
+   {								}
+   { parameters:						}
+   {    op - pc_mov instruction					}
+   {    duplicate - should the source address be left on the	}
+   {       stack?						}
+
+   var
+      banks: integer;			{number of banks to move}
+
+
+      procedure Load (opcode: integer; op: icptr);
+
+      { generate a load immediate based on instruction type	}
+      {								}
+      { parameters:						}
+      {    opcode - native code load operation			}
+      {    op - node to load					}
+
+      var
+	 i: integer;
+
+      begin {Load}
+      if op^.opcode = pc_lao then
+         GenNative(opcode, immediate, op^.q, op^.lab, 0)
+      else begin
+         GenNative(opcode, immediate, stringsize, nil, StringReference);
+         if maxstring-stringsize >= op^.q then begin
+            for i := 1 to op^.q do
+               stringspace[i+stringsize] := op^.str^[i];
+            stringsize := stringsize + op^.q;
+            end {if}
+         else
+            Error(cge3);
+         end; {else}
+      end; {Load}
+
+
+   begin {GenMov}
+   {determine if the destination address must be left on the stack}
+   if smallMemoryModel
+      and (not duplicate)
+      and (op^.left^.opcode in [pc_lao,pc_lca])
+      and (op^.right^.opcode in [pc_lao,pc_lca]) then begin
+
+      {take advantage of any available short cuts}
+      Load(m_ldy_imm, op^.left);
+      Load(m_ldx_imm, op^.right);
+      GenNative(m_lda_imm, immediate, op^.q-1, nil, 0);
+      GenImplied(m_phb);
+      GenImplied(m_mvn);
+      with op^.left^ do
+	 if opcode = pc_lao then
+            GenNative(d_bmov, immediate, q, lab, shift16)
+	 else
+            GenNative(d_bmov, immediate, 0, nil, stringReference+shift16);
+      with op^.right^ do
+	 if opcode = pc_lao then
+            GenNative(d_bmov, immediate, q, lab, shift16)
+	 else
+            GenNative(d_bmov, immediate, 0, nil, stringReference+shift16);
+      GenImplied(m_plb);
+      end {if}
+   else begin
+
+      {no short cuts are available - do it the hard way}
+      gLong.preference := onStack;
+      GenTree(op^.left);
+      gLong.preference := onStack;
+      GenTree(op^.right);
+      banks := op^.r;
+      if banks <> 0 then
+	 GenNative(m_pea, immediate, banks, nil, 0);
+      GenNative(m_pea, immediate, op^.q, nil, 0);
+      if banks = 0 then begin
+	 if duplicate then
+            GenCall(167)
+	 else
+            GenCall(80);
+	 end {if}
+      else
+	 if duplicate then
+            GenCall(169)
+	 else
+            GenCall(168);
+      end; {else}
+   end; {GenMov}
+
+
+   procedure GenMpi (op: icptr);
+
+   { Generate code for a pc_mpi or pc_umi			}
+   
+   var
+      nd: icptr;
+
+   begin {GenMpi}
+   if not Complex(op^.left) then
+      if Complex(op^.right) then begin
+	 nd := op^.left;
+	 op^.left := op^.right;
+	 op^.right := nd;
+	 end; {if}
+   GenTree(op^.left);
+   if Complex(op^.right) then begin
+      GenImplied(m_pha);
+      GenTree(op^.right);
+      GenImplied(m_plx);
+      end {if}
+   else
+      LoadX(op^.right);
+   if op^.opcode = pc_mpi then
+      GenCall(32)
+   else {pc_umi}
+      GenCall(142);
+   if rangeCheck then
+      GenCall(147);
+   end; {GenMpi}
+
+
+   procedure GenNam (op: icptr);                    
+
+   { Generate code for a pc_nam					}
+
+   var
+      i: integer;			{loop/index variable}
+      len: integer;			{length of the file name}
+
+
+      function ToUpper (ch: char): char;
+
+      { Return the uppercase equivalent of the input character	}
+
+      begin {ToUpper}
+      if (ch >= 'a') and (ch <= 'z') then
+	 ch := chr(ord(ch)-ord('a')+ord('A'));
+      ToUpper := ch;
+      end; {ToUpper}
+
+
+   begin {GenNam}
+   {generate a call to install the name in the traceback facility}
+   if traceBack then begin
+      GenNative(m_pea, immediate, stringSize, nil, stringReference+shift16);
+      GenNative(m_pea, immediate, stringSize, nil, stringReference);
+      GenCall(76);
+      namePushed := true;
+      end; {if}
+
+   {send the name to the profiler}
+   if profileFlag then begin
+      GenNative(m_cop, immediate, 3, nil, 0);
+      GenNative(d_add, genaddress, stringSize, nil, stringReference);
+      GenNative(d_add, genaddress, stringSize, nil, stringReference+shift16);
+      end; {if}
+
+   {place the name in the string buffer}
+   len := length(op^.str^);
+   if maxString-stringSize >= len+1 then begin
+      stringSpace[stringSize+1] := chr(len);
+      for i := 1 to len do
+         stringSpace[i+stringSize+1] := op^.str^[i];
+      stringSize := stringSize + len + 1;
+      end {if}
+   else
+      Error(cge3);
+
+   {send the file name to the debugger}
+   if debugFlag then begin
+      GenNative(m_cop, immediate, 6, nil, 0);
+      GenNative(d_add, genaddress, stringSize, nil, stringReference);
+      GenNative(d_add, genaddress, stringSize, nil, stringReference+shift16);
+      len := fNameGS.theString.size;
+      if len > 255 then
+         len := 255;
+      if maxString-stringSize >= len+1 then begin
+         stringSpace[stringSize+1] := chr(len);
+         for i := 1 to len do
+            stringSpace[i+stringSize+1] :=
+               ToUpper(fNameGS.theString.theString[i]);
+         stringSize := stringSize + len + 1;
+         end {if}
+      else
+         Error(cge3);
+      end; {if}
+   end; {GenNam}
+
+
+   procedure GenPds (op: icptr);
+
+   { Generate code for a pc_pds					}
+
+   begin {GenPds}
+   gLong.preference := A_X;
+   GenTree(op^.left);
+   if gLong.where = onStack then begin
+      GenImplied(m_pla);
+      GenImplied(m_plx);
+      end; {if}
+   GenNative(m_ldy_imm, immediate, op^.q, nil, 0);
+   GenCall(47);
+   end; {GenPds}
+
+
+   procedure GenPrs (op: icptr);
+
+   { Generate code for a pc_prs					}
+
+   begin {GenPrs}
+   GenNative(m_lda_dir, direct, staticLoc, nil, 0);
+   GenImplied(m_tcd);
+   GenImplied(m_dea);
+   GenImplied(m_dea);
+   GenImplied(m_tcs);
+   end; {GenPrs}
+
+
+   procedure GenPwr (op: icptr);
+
+   { Generate code for a pc_pwr					}
+
+   begin {GenPwr}
+   GenTree(op^.left);
+   GenTree(op^.right);
+   GenCall(90);
+   end; {GenPwr}
+
+
+   procedure GenRealBinOp (op: icptr);
+
+   { Generate code for a pc_adr, pc_dvr, pc_mpr, pc_sbr		}
+
+   var
+      nd: icptr;			{temp pointer}
+      snum: integer;			{library subroutine numbers}
+      ss,sd,sc,se: integer;		{sane call numbers}
+
+   begin {GenRealBinOp}
+   case op^.opcode of
+      pc_adr: begin
+	 snum := 50;
+	 ss := $0200;
+	 sd := $0100;
+	 sc := $0500;
+	 se := $0000;
+	 end;
+
+      pc_dvr: begin
+	 snum := 51;
+	 ss := $0206;
+	 sd := $0106;
+	 sc := $0506;
+	 se := $0006;
+	 end;
+
+      pc_mpr: begin
+	 snum := 52;
+	 ss := $0204;
+	 sd := $0104;
+	 sc := $0504;
+	 se := $0004;
+	 end;
+
+      pc_sbr: begin
+	 snum := 53;
+	 ss := $0202;
+	 sd := $0102;
+	 sc := $0502;
+	 se := $0002;
+	 end;
+      end; {case}
+
+   if op^.opcode in [pc_mpr,pc_adr] then
+      if op^.left^.opcode in [pc_lod,pc_ldo] then begin
+         nd := op^.left;
+         op^.left := op^.right;
+         op^.right := nd;
+         end; {if}
+   GenTree(op^.left);
+   if (op^.right^.opcode in [pc_lod,pc_ldo]) and (floatCard = 0) then
+      with op^.right^ do begin
+	 if opcode = pc_lod then begin
+            GenNative(m_pea, immediate, 0, nil, 0);
+	    if p = 0 then
+	       GenImplied(m_tdc)
+	    else
+	       StaticLink(p, false, true);
+            GenImplied(m_clc);
+            GenNative(m_adc_imm, immediate, localLabel[r] + q, nil, 0);
+            GenImplied(m_pha);              
+            end {if}
+	 else begin
+            GenNative(m_pea, immediate, q, lab, shift16);
+            GenNative(m_pea, immediate, q, lab, 0);
+            end; {else}
+	 GenNative(m_pea, immediate, 0, nil, 0);
+	 GenImplied(m_tsc);
+	 GenImplied(m_clc);
+	 GenNative(m_adc_imm, immediate, 7, nil, 0);
+	 GenImplied(m_pha);
+	 if optype = cgReal then
+            sd := ss
+	 else if optype = cgExtended then
+            sd := se
+	 else if optype = cgComp then
+            sd := sc;
+	 GenNative(m_pea, immediate, sd, nil, 0);
+	 GenNative(m_ldx_imm, immediate, $090A, nil, 0);
+	 GenNative(m_jsl, longAbs, 0, nil, toolCall);
+	 end {with}
+   else begin
+      GenTree(op^.right);
+      GenCall(snum);
+      end; {else}
+   end; {GenRealBinOp}
+
+
+   procedure GenRealUnOp (op: icptr);
+
+   { Generate code for a pc_sqr, pc_sqt, pc_sin, pc_cos,	}
+   {    pc_atn, pc_log, pc_exp, pc_tan, pc_acs, pc_asn		}
+
+   var
+      snum: integer;
+
+   begin {GenRealUnOp}
+   GenTree(op^.left);
+   case op^.opcode of
+      pc_sqr: snum := 54;
+      pc_sqt: snum := 55;
+      pc_sin: snum := 63;
+      pc_cos: snum := 64;
+      pc_atn: snum := 65;
+      pc_log: snum := 66;
+      pc_exp: snum := 67;
+      pc_tan: snum := 120;
+      pc_acs: snum := 121;
+      pc_asn: snum := 122;
+      end; {case}
+   GenCall(snum);
+   end; {GenRealUnOp}
+
+
+   procedure GenRet (op: icptr);
+
+   { Generate code for a pc_ret					}
+
+   var
+      size: integer;			{localSize + parameterSize}
+
+   begin {GenRet}
+   {pop the name record}
+   if namePushed then
+      GenCall(77);
+
+   {generate an exit code for the debugger's benefit}
+   if debugFlag then
+      GenNative(m_cop, immediate, 4, nil, 0);
+
+   {if anything needs to be removed from the stack, move the return val}
+   size := localSize + parameterSize;
+   if parameterSize <> 0 then begin
+      if localSize > 254 then begin
+	 GenNative(m_ldx_imm, immediate, localSize+1, nil, 0);
+	 GenNative(m_lda_dirx, direct, 0, nil, 0);
+	 GenNative(m_ldy_dirx, direct, 1, nil, 0);
+	 GenNative(m_ldx_imm, immediate,
+	    localSize+parameterSize+1, nil, 0);
+	 GenNative(m_sta_dirx, direct, 0, nil, 0);
+	 GenNative(m_sty_dirx, direct, 1, nil, 0);
+	 end {if}
+      else begin
+	 GenNative(m_lda_dir, direct, localSize+2, nil, 0);
+	 if localSize+parameterSize > 254 then begin
+	    GenNative(m_ldx_imm, immediate,
+	       localSize+parameterSize+1, nil, 0);
+	    GenNative(m_sta_dirx, direct, 1, nil, 0);
+	    GenNative(m_lda_dir, direct, localSize+1, nil, 0);
+	    GenNative(m_sta_dirx, direct, 0, nil, 0);
+	    end {if}
+	 else begin
+	    GenNative(m_sta_dir, direct,
+	       localSize+parameterSize+2, nil, 0);
+	    GenNative(m_lda_dir, direct, localSize+1, nil, 0);
+	    GenNative(m_sta_dir, direct,
+	       localSize+parameterSize+1, nil, 0);
+	    end; {else}
+	 end; {else}
+      end; {if}
+
+   {load the value to return}
+   case op^.optype of
+
+      cgVoid: ;
+
+      cgByte,cgUByte: begin
+	 GenNative(m_lda_dir, direct, funLoc, nil, 0);
+	 GenNative(m_and_imm, immediate, $00FF, nil, 0);
+	 if size <> 2 then
+	    GenImplied(m_tay);
+	 end;
+
+      cgWord,cgUWord:
+	 if size = 2 then
+	    GenNative(m_lda_dir, direct, funLoc, nil, 0)
+	 else
+	    GenNative(m_ldy_dir, direct, funLoc, nil, 0);
+
+      cgReal,cgDouble,cgExtended,cgComp: begin
+         GenNative(m_pea, immediate, 0, nil, 0);
+	 GenImplied(m_tdc);
+         GenImplied(m_clc);
+         GenNative(m_adc_imm, immediate, funLoc, nil, 0);
+         GenImplied(m_pha);              
+         if op^.optype = cgReal then
+	    GenCall(81)
+         else if op^.optype = cgDouble then
+	    GenCall(84)
+         else if op^.optype = cgExtended then
+	    GenCall(176)
+         else {if op^.optype = cgComp then}
+	    GenCall(177);
+         end;
+
+      cgLong,cgULong: begin
+	 GenNative(m_ldx_dir, direct, funLoc+2, nil, 0);
+	 GenNative(m_ldy_dir, direct, funLoc, nil, 0);
+	 end;
+
+      otherwise:
+	 Error(cge1);
+      end; {case}
+
+   {restore data bank reg}
+   if dataBank then begin
+      GenNative(m_lda_dir, direct, bankLoc, nil, 0);
+      GenImplied(m_pha);
+      GenImplied(m_plb);
+      GenImplied(m_plb);
+      end; {if}
+
+   {get rid of the stack frame space}
+   if size <> 0 then
+      GenImplied(m_pld);
+   if size = 2 then
+      GenImplied(m_ply)
+   else if size <> 0 then begin
+      GenImplied(m_tsc);
+      GenImplied(m_clc);
+      GenNative(m_adc_imm, immediate, size, nil, 0);
+      GenImplied(m_tcs);
+      end; {if}
+
+   {put return value in correct place}
+   case op^.optype of
+      cgByte,cgUByte,cgWord,cgUWord: begin
+	 if size <> 2 then
+	    GenImplied(m_tya);
+	 if toolParms then	  {save value on stack for tools}
+	    GenNative(m_sta_s, direct, returnSize+1, nil, 0);
+	 end;
+
+      cgLong,cgULong,cgReal,cgDouble,cgComp,cgExtended: begin
+	 GenImplied(m_tya);
+	 if toolParms then begin  {save value on stack for tools}
+	    GenNative(m_sta_s, direct, returnSize+1, nil, 0);
+	    GenImplied(m_txa);
+	    GenNative(m_sta_s, direct, returnSize+3, nil, 0);
+	    end; {if}
+	 end;
+
+      cgVoid: ;
+
+      otherwise:
+	 Error(cge1);
+      end; {case}
+
+   {return to the caller}
+   GenImplied(m_rtl);
+   end; {GenRet}
+
+
+   procedure GenRnd (op: icptr);
+
+   { Generate code for a pc_rnd					}
+
+   begin {GenRnd}
+   GenTree(op^.left);
+   GenCall(68);
+   end; {GenRnd}
+
+
+   procedure GenRn4 (op: icptr);
+
+   { Generate code for a pc_rn4					}
+
+   var
+      lLong: longType;			   {used to reserve gLong}
+
+   begin {GenRn4}
+   lLong := gLong;
+   GenTree(op^.left);
+   GenCall(149);
+   if (lLong.preference & A_X) <> 0 then
+      gLong.where := A_X
+   else begin
+      gLong.where := onStack;
+      GenImplied(m_phx);
+      GenImplied(m_pha);
+      end; {else}
+   end; {GenRn4}
+
+
+   procedure GenSbi (op: icptr);
+
+   { Generate code for a pc_sbi					}
+   
+   begin {GenSbi}
+   if Complex(op^.left) or Complex(op^.right) then begin
+      GenTree(op^.right);
+      if Complex(op^.left) then begin
+	 GenImplied(m_pha);
+	 GenTree(op^.left);
+	 GenImplied(m_sec);
+	 GenNative(m_sbc_s, direct, 1, nil, 0);
+	 GenImplied(m_plx);
+         end {if}
+      else begin
+         GenNative(m_eor_imm, immediate, $FFFF, nil, 0);
+	 GenImplied(m_sec);
+         OperA(m_adc_imm, op^.left);
+         end; {else}
+      end {if}
+   else begin
+      GenTree(op^.left);
+      GenImplied(m_sec);
+      OperA(m_sbc_imm, op^.right);
+      end; {else}
+   if rangeCheck then
+      GenCall(147);
+   end; {GenSbi}
+
+
+   procedure GenShlShrUsr (op: icptr);
+
+   { Generate code for a pc_shl, pc_shr or pc_usr		}
+
+   var
+      i,op1,op2,num: integer;		{temp variables}
+
+   begin {GenShlShrUsr}
+   {get the standard native operations}
+   if op^.opcode = pc_shl then begin
+      op1 := m_asl_a;
+      op2 := m_lsr_a;
+      end {if}
+   else begin
+      op1 := m_lsr_a;
+      op2 := m_asl_a;
+      end; {else}
+
+   {take short cuts if they are legal}
+   if (op^.right^.opcode = pc_ldc) and (op^.opcode <> pc_shr) then begin
+      num := op^.right^.q;
+      if (num > 16) or (num < -16) then
+	 GenNative(m_lda_imm, immediate, 0, nil, 0)
+      else if num > 0 then begin
+	 GenTree(op^.left);
+         if num >= 8 then begin
+            GenImplied(m_xba);
+            if op1 = m_lsr_a then
+               i := $00FF
+            else
+               i := $FF00;
+            GenNative(m_and_imm, immediate, i, nil, 0);
+            num := num-8;
+            end; {if}
+	 for i := 1 to num do
+            GenImplied(op1);
+	 end {else if}
+      else if num < 0 then begin
+	 GenTree(op^.left);
+         if num <= -8 then begin
+            GenImplied(m_xba);
+            if op2 = m_lsr_a then
+               i := $00FF
+            else
+               i := $FF00;
+            GenNative(m_and_imm, immediate, i, nil, 0);
+            num := num+8;
+            end; {if}    
+	 for i := 1 to -num do
+            GenImplied(op2);
+	 end {else if}
+      else
+	 GenTree(op^.left);
+      end {if}
+   else begin
+      GenTree(op^.left);
+      if Complex(op^.right) then begin
+	 GenImplied(m_pha);
+	 GenTree(op^.right);
+	 GenImplied(m_tax);
+	 GenImplied(m_pla);
+	 end {if}
+      else
+	 LoadX(op^.right);
+      if op^.opcode = pc_shl then
+	 GenCall(88)
+      else if op^.opcode = pc_shr then
+	 GenCall(89)
+      else {if op^.opcode = pc_usr then}
+	 GenCall(175);
+      end; {else}
+   end; {GenShlShrUsr}
+   
+
+   procedure GenSiz (op: icptr);
+
+   { Generate code for a pc_siz					}
+
+   const
+      unknownSize = 999;		{used to indicate an unknown set size}
+
+   var   
+      size: integer;			{size of the set being passed}
+
+
+      function SetSize (op: icptr): unsigned;
+
+      { find the size of the set generated by the tree passed	}
+      {								}
+      { parameters:						}
+      {    op - tree to examine					}
+      {								}
+      { returns: Size of set					}
+
+      var
+	 ls, rs: unsigned;		{temp set sizes}
+
+      begin {SetSize}
+      case op^.opcode of
+	 pc_uni,pc_int,pc_dif: begin
+	    ls := SetSize(op^.left);
+	    rs := SetSize(op^.right);
+	    if ls < rs then
+	       SetSize := rs
+	    else
+	       SetSize := ls;
+	    end;
+	 pc_sgs,pc_ixa,pc_ind:
+	    SetSize := unknownSize;
+	 pc_ldo:
+	    SetSize := op^.q;
+	 pc_ldc: begin
+	    ls := op^.setp^.smax;
+	    if odd(ls) then
+               ls := ls+1;
+	    SetSize := ls;
+	    end;
+	 pc_lod:
+	    SetSize := op^.s;
+	 otherwise: begin
+	    SetSize := unknownSize;
+	    Error(cge1);
+	    end;
+	 end; {case}
+      end; {SetSize}
+
+      
+   begin {GenSiz}
+   size := SetSize(op^.left);
+   if (size <> unknownSize) and (size <= op^.q) then begin
+      if odd(size-op^.q) then begin
+	 GenNative(m_pea, immediate, 0, nil, 0);
+	 GenImplied(m_phb);
+	 GenImplied(m_pla);
+	 size := size+1;
+	 end; {if}
+      while size < op^.q do begin
+	 GenNative(m_pea, immediate, 0, nil, 0);
+	 size := size+2;
+	 end; {while}
+      GenTree(op^.left);
+      GenImplied(m_pla);
+      end {if}
+   else begin
+      GenTree(op^.left);
+      GenNative(m_pea, immediate, op^.q, nil, 0);
+      GenCall(78);
+      end; {else}
+   end; {GenSiz}
+
+
+   procedure GenSgs (op: icptr);
+
+   { Generate code for a pc_sgs					}
+   {								}
+   { (Convert an integer range into a set)			}
+
+   begin {GenSgs}
+   GenTree(op^.left);
+   GenImplied(m_pha);
+   GenTree(op^.right);
+   GenImplied(m_pha);
+   GenCall(16);
+   end; {GenSgs}
+
+
+   procedure GenStk (op: icptr);
+
+   { Generate code for a pc_stk					}
+
+   var
+      lab1: integer;			{branch point}
+
+   begin {GenStk}
+   glong.preference := onStack;		{generate the operand}
+   GenTree(op^.left);
+   if op^.optype in			{do the stk}
+      [cgByte, cgUByte, cgWord, cgUWord] then
+      GenImplied(m_pha);
+   end; {GenStk}
+
+
+   procedure GenTl1 (op: icptr);
+
+   { Generate code for a pc_tl1, pc_tl2				}
+
+   type
+      kind = (vint, vbyte);		{kinds of equivalenced data}
+
+   var        
+      lLong: longType;			{used to reserve gLong}
+      str: pStringPtr;			{string constant pointer}
+      switch: packed record		{used for type conversion}
+	 case rkind: kind of
+	    vint: (i: integer);
+	    vbyte: (b1, b2: byte);
+	 end;
+   
+   begin {GenTl1}
+   {push space for the return value}
+   if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then
+      GenImplied(m_pha)
+   else if op^.optype in [cgLong,cgULong] then begin
+      GenImplied(m_pha);
+      GenImplied(m_pha);
+      end; {else if}
+
+   {generate parameters}
+   lLong := gLong;
+   GenTree(op^.left);
+   gLong := lLong;
+
+   {generate the tool call}
+   switch.b2 := op^.q;
+   switch.b1 := op^.r;
+   GenNative(m_ldx_imm,immediate,switch.i,nil,0);
+   if op^.opcode = pc_tl1 then
+      GenNative(m_jsl, longAbs, 0, nil, toolCall)
+   else
+      GenNative(m_jsl, longAbs, 0, nil, usertoolCall);
+   str := @'~TOOLERROR';
+   if smallMemoryModel then
+      GenNative(m_sta_abs, absolute, 0, str, 0)
+   else
+      GenNative(m_sta_long, longAbs, 0, str, 0);
+      
+   {save the returned value}
+   if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then
+      GenImplied(m_pla)
+   else if op^.optype in [cgLong,cgULong] then
+      gLong.where := onStack;
+   end; {GenTl1}
+
+
+   procedure GenUjp (op: icptr);
+
+   { Generate code for a pc_ujp					}
+
+   begin {GenUjp}
+   if op^.lab = nil then
+      GenNative(m_brl, longrelative, op^.q, nil, 0)
+   else
+      GenNative(m_jml, longAbs, 0, op^.lab, 0);
+   end; {GenUjp}
+
+
+   procedure GenVct (op: icptr);
+
+   { Generate code for a pc_vct					}
+
+   type
+      kind = (vint, vbyte);		{kinds of equivalenced data}
+
+   var        
+      lLong: longType;			{used to reserve gLong}
+      str: pStringPtr;			{string constant pointer}
+   
+   begin {GenVct}
+   {push space for the return value}
+   if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then
+      GenImplied(m_pha)
+   else if op^.optype in [cgLong,cgULong] then begin
+      GenImplied(m_pha);
+      GenImplied(m_pha);
+      end; {else if}
+
+   {generate parameters}
+   lLong := gLong;
+   GenTree(op^.left);
+   gLong := lLong;
+
+   {generate the tool call}
+   GenNative(m_ldx_imm,immediate,op^.q,nil,0);
+   if op^.opcode = pc_tl1 then
+      GenNative(m_jsl, longAbsolute, 0, op^.lval, constantOpnd)
+   else
+      GenNative(m_jsl, longAbsolute, 0, op^.lval, constantOpnd);
+   str := @'~TOOLERROR';
+   if smallMemoryModel then
+      GenNative(m_sta_abs, absolute, 0, str, 0)
+   else
+      GenNative(m_sta_long, longAbs, 0, str, 0);
+      
+   {save the returned value}
+   if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then
+      GenImplied(m_pla)
+   else if op^.optype in [cgLong,cgULong] then
+      gLong.where := onStack;
+   end; {GenVct}
+
+
+   procedure GenXjp (op: icptr);
+
+   { Generate code for a pc_xjp					}
+
+   var
+      lab1,lab2: integer;
+      q: integer;
+
+   begin {GenXjp}
+   q := op^.q;
+   lab1 := GenLabel;
+   GenTree(op^.left);
+   GenNative(m_cmp_imm, immediate, q, nil, 0);
+   GenNative(m_bcc, relative, lab1, nil, 0);
+   GenNative(m_lda_imm, immediate, q, nil, 0);
+   GenLab(lab1);
+   GenImplied(m_asl_a);
+   GenImplied(m_tax);
+   lab1 := GenLabel;
+   lab2 := GenLabel;
+   GenNative(m_lda_longx, longAbs, lab2, nil, 0);
+   GenNative(m_beq,relative,lab1,nil,0);
+   GenImplied(m_pha);
+   GenImplied(m_rts);
+   GenLab(lab1);
+   GenCall(12);
+   GenLab(lab2);
+   end; {GenXjp}
+
+
+   procedure DirLab (op: icptr);
+
+   { Generate code for a dc_lab					}
+
+   begin {DirLab}
+   if op^.lab = nil then
+      GenLab(op^.q)
+   else
+      GenNative(d_lab, gnrLabel, 0, op^.lab, isPrivate);
+   end; {DirLab}
+
+
+   procedure DirStr (op: icptr);
+
+   { Generate code for a dc_str					}
+
+   begin {DirStr}
+   skipLoad := false;
+   InitNative;
+   Header(op^.lab, op^.r, op^.q);
+   end; {DirStr}
+
+
+   procedure DirSym (op: icptr);
+
+   { Generate code for a dc_sym					}
+
+   begin {DirSym}
+   if debugFlag then
+      GenNative(d_sym, special, op^.q, pointer(op^.lab), 0);
+   end; {DirSym}
+
+
+begin {GenTree}
+{if printSymbols then begin write('GEN: '); WriteCode(op); end; {debug}
+Spin;
+case op^.opcode of
+   dc_dst: GenNative(d_lab, gnrSpace, op^.q, nil, 0);
+   dc_enp: DirEnp;
+   dc_glb: GenNative(d_lab, gnrLabel, op^.r, op^.lab, isPrivate*op^.q);
+   dc_lab: DirLab(op);
+   dc_fun,dc_loc,dc_prm: ;
+   dc_pin: GenNative(d_pin, special, 0, nil, 0);
+   dc_str: DirStr(op);
+   dc_sym: DirSym(op);
+
+   pc_abi,pc_bnt,pc_ngi,pc_not,pc_odd,pc_sqi: GenAbiBntNgiNotOddSqi(op);
+   pc_abl,pc_bnl,pc_ngl,pc_odl,pc_sql: GenAblBnlNglOdlSql(op);
+   pc_abr,pc_ngr: GenAbrNgr(op);
+   pc_add: GenNative(d_add, genaddress, op^.q, nil, sub1);
+   pc_adi: GenAdi(op);
+   pc_adl,pc_sbl: GenAdlSbl(op, nil);
+   pc_adr,pc_dvr,pc_mpr,pc_sbr: GenRealBinOp(op);
+   pc_and,pc_bnd,pc_bor,pc_bxr,pc_ior: GenLogic(op);
+   pc_atn,pc_cos,pc_exp,pc_log,pc_sin,pc_sqr,pc_sqt,pc_tan,pc_acs,pc_asn:
+      GenRealUnOp(op);
+   pc_at2: GenAt2(op);
+   pc_blr,pc_blx,pc_bal,pc_dvl,pc_mdl,pc_mpl,pc_sll,pc_slr,pc_udl,pc_ulm,
+      pc_uml,pc_vsr: GenBinLong(op);
+   pc_bno: GenBno(op);
+   pc_chk: GenChk(op);
+   pc_cnv: GenCnv(op);
+   pc_csp: GenCsp(op);
+   pc_cui: GenCui(op);
+   pc_cum: GenCum(op);
+   pc_cup: GenCup(op);
+   pc_dec,pc_inc: GenIncDec(op, nil);
+   pc_dif,pc_int,pc_uni: GenDifIntUni(op);
+   pc_dvi,pc_mod,pc_udi,pc_uim: GenDviMod(op);
+   pc_ent: GenEnt;
+   pc_equ,pc_neq: GenEquNeq(op, op^.opcode, 0);
+   pc_fix: GenFix(op);
+   pc_fjp,pc_tjp: GenFjpTjp(op);
+   pc_geq,pc_grt,pc_leq,pc_les: GenCmp(op, op^.opcode, 0);
+   pc_ind: GenInd(op);
+   pc_inn: GenInn(op);
+   pc_ixa: GenIxa(op);
+   pc_lao,pc_lad: GenLaoLad(op);
+   pc_lca: GenLca(op);
+   pc_lda: GenLda(op);  
+   pc_ldc: GenLdc(op);
+   pc_ldo: GenLdo(op);
+   pc_lod: GenLod(op);
+   pc_lla: GenLla(op);
+   pc_lnm: GenLnm(op);
+   pc_lsl: GenLsl(op);
+   pc_mov: GenMov(op, false);
+   pc_mpi,pc_umi: GenMpi(op);
+   pc_nam: GenNam(op);
+   pc_nop: ;     
+   pc_pds: GenPds(op);
+   pc_prs: GenPrs(op);
+   pc_pwr: GenPwr(op);
+   pc_ret: GenRet(op);
+   pc_rnd: GenRnd(op);
+   pc_rn4: GenRn4(op);
+   pc_sbi: GenSbi(op);
+   pc_shl,pc_shr,pc_usr: GenShlShrUsr(op);
+   pc_siz: GenSiz(op);
+   pc_sgs: GenSgs(op);
+   pc_sro,pc_cpo: GenSroCpo(op);
+   pc_stk: GenStk(op);
+   pc_sto: GenSto(op);
+   pc_str,pc_cop: GenStrCop(op);
+   pc_tl1,pc_tl2: GenTl1(op);
+   pc_ujp: GenUjp(op);
+   pc_vct: GenVct(op);
+   pc_xjp: GenXjp(op);
+
+   otherwise: begin
+      Error(cge1);
+      writeln('Undefined in GenTree: ', ord(op^.opcode):1);
+      end;
+   end; {case}
+end; {GenTree}
+
+{$optimize -1}
+
+{---------------------------------------------------------------}
+
+procedure Gen {blk: blockPtr};
+
+{ Generates native code for a list of blocks			}
+{								}
+{ parameters:							}
+{    blk - first of the list of blocks				}
+
+type
+   sfPtr = ^sfRecord;			{stack frame record}
+   sfRecord = record
+      next: sfPtr;			{next record}
+      bankLoc: integer;			{disp in dp where bank reg is stored}
+      dworkLoc: integer;		{disp in dp of 4 byte work spage for cg}
+      funLoc: integer;			{loc of fn ret value in stack frame}
+      localSize: integer;		{local space for current proc}
+      parameterSize: integer;		{# bytes of parameters for current proc}
+      staticLoc: integer;		{loc of static link}
+      end;
+
+var
+   gop: icptr;				{used to trace code lists}
+   sfList: sfPtr;			{stack frame list}
+   sfLast: sfPtr;			{stack frame temp variable}
+
+   
+   procedure StackFrame (blk: blockPtr; gop: icptr);
+
+   { Set up a stack frame for a new pc_ent			}
+   {								}
+   { parameters:						}
+   {    blk - starting block					}
+   {    gop - starting pc_ent					}
+
+   label 1, 2, 3;
+
+   const
+      locSize = 4;			{variables <= this size allocated first}
+
+   var
+      bk: blockPtr; 			{used to trace block lists}
+      minSize: integer;			{location for the next local label}
+      needScan2: boolean;		{do we need the 2nd dc_loc scan?}
+      op: icptr;			{used to trace code lists}
+      sf: sfPtr;			{new stack frame record}
+
+
+      procedure DirLoc1 (op: icptr);
+
+      { allocates stack frame locations for small dc_loc	}
+
+      begin {DirLoc1}
+      if op^.q <= locSize then begin
+	 if op^.r < maxLocalLabel then begin
+	    localLabel[op^.r] := minSize;
+	    minSize := minSize + op^.q;
+	    end {if}
+	 else
+	    Error(cge2);
+	 end {if}
+      else
+         needScan2 := true;
+      end; {DirLoc1}
+
+
+      procedure DirLoc2 (op: icptr);
+
+      { allocates stack frame locations for large dc_loc	}
+
+      begin {DirLoc2}
+      if op^.q > locSize then begin
+	 if op^.r < maxLocalLabel then begin
+	    localLabel[op^.r] := minSize;
+	    minSize := minSize + op^.q;
+	    end {if}
+	 else
+	    Error(cge2);
+	 end; {if}
+      end; {DirLoc2}
+
+
+      procedure DirPrm (op: icptr);
+
+      { allocates stack frame locations for parameters		}
+
+      begin {DirPrm}
+      if op^.s < maxLocalLabel then
+	 localLabel[op^.s] := localSize + returnSize + 1 + op^.r
+      else
+	 Error(cge2);
+      end; {DirPrm}
+
+
+      procedure Scan (op: icptr);
+
+      { scans the code stream for instructions that effect the	}
+      { size of the stack frame					}
+      {								}
+      { parameters: 						}
+      {	op - scan this opcode and its children			}
+
+      var
+	 opcode: pcodes;		{op^.opcode}
+	 size: integer;			{function return value size}
+
+      begin {Scan}
+      if op^.left <> nil then
+	 Scan(op^.left);
+      if op^.right <> nil then
+	 Scan(op^.right);
+      opcode := op^.opcode;
+      if ((opcode = pc_cup) and ((op^.lab = nil) or (not noGlobalLabels)))
+         or (opcode = pc_prs)
+         or (op^.p <> 0) then begin
+         if staticLoc = 0 then begin
+            staticLoc := 1;
+	    if dworkLoc <> 0 then
+	       dworkLoc := dworkLoc + 2;
+	    minSize := minSize + 2;
+	    localSize := localSize + 2;
+            end; {if}      
+         end; {if}
+      if opcode = dc_loc then
+	 localSize := localSize + op^.q
+      else if opcode = dc_fun then
+	 localSize := localSize + op^.q
+      else if opcode = dc_prm then
+	 parameterSize := parameterSize + op^.q
+      else if opcode in [pc_les,pc_leq,pc_grt,pc_geq] then begin
+         if op^.optype in [cgByte,cgWord,cgUByte,cgUWord] then
+            if Complex(op^.left) or Complex(op^.right) then
+	       if dworkLoc = 0 then begin
+		  dworkLoc := minSize;
+		  minSize := minSize + 4;
+		  localSize := localSize + 4;
+		  end; {if}                              
+	 end {else if}
+      else if opcode in [pc_sto,pc_ind,pc_lor,pc_lnd,pc_ixa,pc_cum]
+	 then begin
+	 if dworkLoc = 0 then begin
+	    dworkLoc := minSize;
+	    minSize := minSize + 4;
+	    localSize := localSize + 4;
+	    end; {if}                              
+	 end; {else if}
+      end; {Scan}
+
+
+   begin {StackFrame}
+   while blk <> nil do begin
+      new(sf);				{allocate a new stack frame}
+      if sfList = nil then
+	 sfList := sf
+      else
+	 sfLast^.next := sf;
+      sfLast := sf;
+      sf^.next := nil;
+      localSize := 0;			{determine the size of the stack frame}
+      parameterSize := 0;
+      staticLoc := 0;
+      funLoc := 0;
+      dworkLoc := 0;
+      minSize := 1;
+      bk := blk;
+      op := gop^.next;
+      repeat
+	 while op <> nil do begin
+            if op^.opcode = pc_ent then
+               goto 1;
+	    Scan(op);
+	    op := op^.next;
+	    end; {while}
+	 while (op = nil) and (bk <> nil) do begin
+	    bk := bk^.next;
+	    if bk <> nil then
+               op := bk^.code;
+            end; {while}
+      until op = nil;
+   1: if dataBank then begin
+	 bankLoc := minSize;
+	 minSize := minSize + 2;
+	 localSize := localSize + 2;
+	 end; {if}
+      needScan2 := false;			{allocate locations for the values}
+      bk := blk;
+      op := gop^.next;
+      repeat
+	 while op <> nil do begin
+            if op^.opcode = pc_ent then
+               goto 2
+	    else if op^.opcode = dc_loc then
+	       DirLoc1(op)
+	    else if op^.opcode = dc_fun then begin
+	       DirLoc1(op);
+               funLoc := localLabel[op^.r];
+               end {else if}
+	    else if op^.opcode = dc_prm then
+	       DirPrm(op);
+	    op := op^.next;
+	    end; {while}
+	 while (op = nil) and (bk <> nil) do begin
+	    bk := bk^.next;
+	    if bk <> nil then
+               op := bk^.code;
+            end; {while}
+      until op = nil;
+   2: if needScan2 then begin
+	 bk := blk;
+	 op := gop^.next;
+	 repeat
+	    while op <> nil do begin
+               if op^.opcode = pc_ent then
+        	  goto 3
+	       else if op^.opcode = dc_loc then
+		  DirLoc2(op)
+	       else if op^.opcode = dc_fun then begin
+		  DirLoc2(op);
+        	  funLoc := localLabel[op^.r];
+        	  end; {else if}
+	       op := op^.next;              
+	       end; {while}
+	    while (op = nil) and (bk <> nil) do begin
+	       bk := bk^.next;
+	       if bk <> nil then
+        	  op := bk^.code;
+               end; {while}
+	 until op = nil;
+	 end; {if}
+3:    blk := bk;			{get ready for next scan}
+      gop := op;
+      sf^.localSize := localSize;	{record the stack frame info}
+      sf^.parameterSize := parameterSize;
+      sf^.staticLoc := staticLoc;
+      sf^.funLoc := funLoc;
+      sf^.dworkLoc := dworkLoc;
+      sf^.bankLoc := bankLoc;
+      end; {while}
+   end; {StackFrame}
+
+
+begin {Gen}
+enpFound := false;			{dc_enp not found, yet}
+sfList := nil;				{no stack frame list}
+while blk <> nil do begin		{generate code for the block}
+   gop := blk^.code;
+   while gop <> nil do begin
+      if gop^.opcode = pc_ent then begin
+         if sfList = nil then
+            StackFrame(blk, gop);
+	 localSize := sfList^.localSize;
+	 parameterSize := sfList^.parameterSize;
+	 staticLoc := sfList^.staticLoc;
+	 funLoc := sfList^.funLoc;
+	 dworkLoc := sfList^.dworkLoc;
+	 bankLoc := sfList^.bankLoc;
+         sfLast := sfList;
+         sfList := sfList^.next;
+         dispose(sfLast);
+         end; {if}
+      GenTree(gop);
+      gop := gop^.next;
+      end; {while}
+   blk := blk^.next;
+   end; {while}
+if not enpFound then			{if dc_enp was optimized out, fake one}
+   DirEnp;
+end; {Gen}
+
+end.
diff --git a/linkit b/linkit
old mode 100755
new mode 100644
index 8b180ad..09ea260
--- a/linkit
+++ b/linkit
@@ -1 +1,7 @@
-set list        obj/pascal obj/call obj/parser obj/native obj/cgi obj/symbols
set list {list} obj/scanner obj/dag obj/cgc obj/gen obj/objout obj/pcommon

echo link {parameters} {list} keep=obj/pascal
link {parameters} {list} keep=obj/pascal
echo filetype obj/pascal exe $DB01
filetype obj/pascal exe $DB01
\ No newline at end of file
+set list        obj/pascal obj/call obj/parser obj/native obj/cgi obj/symbols
+set list {list} obj/scanner obj/dag obj/cgc obj/gen obj/objout obj/pcommon
+
+echo link {parameters} {list} keep=obj/pascal
+link {parameters} {list} keep=obj/pascal
+echo filetype obj/pascal exe $DB01
+filetype obj/pascal exe $DB01
diff --git a/make b/make
old mode 100755
new mode 100644
index 48f4a31..c6b2416
--- a/make
+++ b/make
@@ -1 +1,134 @@
-unset exit
set flags +t +e

Newer obj/pascal pascal.rez
if {status} != 0
   set exit on
   echo compile -e pascal.rez keep=obj/Pascal
   compile -e pascal.rez keep=obj/Pascal
   unset exit
end

if {#} == 0 then

   Newer obj/gen.a gen.pas
   if {Status} != 0
      set gen gen
      set dag dag
   end                   

   Newer obj/cgc.a cgc.pas cgc.asm cgc.macros
   if {Status} != 0
      set cgc cgc
      set dag dag
      set gen gen
      set objout objout
      set native native
      set symbols symbols
   end                   

   Newer obj/dag.a dag.pas dag.asm dag.macros
   if {Status} != 0
      set dag dag
   end                   

   Newer obj/pascal.a pascal.pas
   if {Status} != 0
      set pascal pascal
   end                   

   Newer obj/parser.a parser.pas
   if {Status} != 0
      set parser parser
      set pascal pascal
   end                   

   Newer obj/call.a call.pas
   if {Status} != 0
      set call call
      set parser parser
   end                   

   Newer obj/objout.a objout.pas objout.asm objout.macros
   if {Status} != 0
      set objout objout
      set symbols symbols
      set native native
      set gen gen
   end                   

   Newer obj/native.a native.pas native.asm native.pas
   if {Status} != 0
      set native native
      set symbols symbols
      set gen gen
   end                   

   Newer obj/cgi.a cgi.pas cgi.asm
   if {Status} != 0
      set cgi cgi
      set call call
      set native native
      set scanner scanner
      set symbols symbols
      set parser parser
      set pascal pascal
      set dag dag
      set cgc cgc
      set gen gen
      set objout objout
   end                   

   Newer obj/scanner.a scanner.pas scanner.asm scanner.macros
   if {Status} != 0
      set scanner scanner
      set symbols symbols
      set call call
      set parser parser
      set pascal pascal
   end                   

   Newer obj/symbols.a symbols.pas symbols.asm symbols.macros
   if {Status} != 0
      set symbols symbols
      set call call
      set parser parser
      set pascal pascal
   end                 

   Newer obj/pcommon.a pcommon.pas pcommon.asm pcommon.macros
   if {Status} != 0
      set pcommon pcommon
      set call call
      set symbols symbols
      set cgi cgi
      set native native
      set objout objout
      set parser parser
      set dag dag
      set cgc cgc
      set gen gen
   end                   

   set exit on
   set list {pcommon} {cgi} {cgc} {objout} {native} {gen} {dag} {scanner} {symbols} {call} {parser} {pascal}
   for i in {list}
      echo compile {flags} {i}.pas keep=obj/{i}
      compile {flags} {i}.pas keep=obj/{i}
   end

else

   set exit on
   for i in {parameters}
      echo compile {flags} {i}.pas keep=obj/{i}
      compile {flags} {i}.pas keep=obj/{i}
   end
end

* echo purge
* purge >.null
echo linkit
linkit
echo copy -c obj/pascal 16/Pascal
copy -c obj/pascal 16/Pascal
\ No newline at end of file
+unset exit
+set flags +t +e
+
+Newer obj/pascal pascal.rez
+if {status} != 0
+   set exit on
+   echo compile -e pascal.rez keep=obj/Pascal
+   compile -e pascal.rez keep=obj/Pascal
+   unset exit
+end
+
+if {#} == 0 then
+
+   Newer obj/gen.a gen.pas
+   if {Status} != 0
+      set gen gen
+      set dag dag
+   end                   
+
+   Newer obj/cgc.a cgc.pas cgc.asm cgc.macros
+   if {Status} != 0
+      set cgc cgc
+      set dag dag
+      set gen gen
+      set objout objout
+      set native native
+      set symbols symbols
+   end                   
+
+   Newer obj/dag.a dag.pas dag.asm dag.macros
+   if {Status} != 0
+      set dag dag
+   end                   
+
+   Newer obj/pascal.a pascal.pas
+   if {Status} != 0
+      set pascal pascal
+   end                   
+
+   Newer obj/parser.a parser.pas
+   if {Status} != 0
+      set parser parser
+      set pascal pascal
+   end                   
+
+   Newer obj/call.a call.pas
+   if {Status} != 0
+      set call call
+      set parser parser
+   end                   
+
+   Newer obj/objout.a objout.pas objout.asm objout.macros
+   if {Status} != 0
+      set objout objout
+      set symbols symbols
+      set native native
+      set gen gen
+   end                   
+
+   Newer obj/native.a native.pas native.asm native.pas
+   if {Status} != 0
+      set native native
+      set symbols symbols
+      set gen gen
+   end                   
+
+   Newer obj/cgi.a cgi.pas cgi.asm
+   if {Status} != 0
+      set cgi cgi
+      set call call
+      set native native
+      set scanner scanner
+      set symbols symbols
+      set parser parser
+      set pascal pascal
+      set dag dag
+      set cgc cgc
+      set gen gen
+      set objout objout
+   end                   
+
+   Newer obj/scanner.a scanner.pas scanner.asm scanner.macros
+   if {Status} != 0
+      set scanner scanner
+      set symbols symbols
+      set call call
+      set parser parser
+      set pascal pascal
+   end                   
+
+   Newer obj/symbols.a symbols.pas symbols.asm symbols.macros
+   if {Status} != 0
+      set symbols symbols
+      set call call
+      set parser parser
+      set pascal pascal
+   end                 
+
+   Newer obj/pcommon.a pcommon.pas pcommon.asm pcommon.macros
+   if {Status} != 0
+      set pcommon pcommon
+      set call call
+      set symbols symbols
+      set cgi cgi
+      set native native
+      set objout objout
+      set parser parser
+      set dag dag
+      set cgc cgc
+      set gen gen
+   end                   
+
+   set exit on
+   set list {pcommon} {cgi} {cgc} {objout} {native} {gen} {dag} {scanner} {symbols} {call} {parser} {pascal}
+   for i in {list}
+      echo compile {flags} {i}.pas keep=obj/{i}
+      compile {flags} {i}.pas keep=obj/{i}
+   end
+
+else
+
+   set exit on
+   for i in {parameters}
+      echo compile {flags} {i}.pas keep=obj/{i}
+      compile {flags} {i}.pas keep=obj/{i}
+   end
+end
+
+* echo purge
+* purge >.null
+echo linkit
+linkit
+echo copy -c obj/pascal 16/Pascal
+copy -c obj/pascal 16/Pascal
diff --git a/native.asm b/native.asm
old mode 100755
new mode 100644
index 46a01a5..9c8fd36
--- a/native.asm
+++ b/native.asm
@@ -1 +1,162 @@
-         mcopy native.macros
****************************************************************
*
*  Remove - remove an instruction from the peephole array
*
*  Inputs:
*        ns - index of element to remove
*
****************************************************************
*
Remove   start
elSize   equ   12                       size of an element
nPeepSize equ  128                      size of array
ns       equ   4                        array element

         lda   ns,S                     compute the source address
         cmp   #nPeepSize                (quit if nothing to move)
         bge   rtl
         asl   a
         adc   ns,S
         asl   a
         asl   a
         adc   #NPEEP
         tax
         sec                            compute the source address
         sbc   #elSize
         tay
         sec                            compute the move length
         sbc   #(nPeepSize-1)*elSize+NPEEP
         eor   #$FFFF
         mvn   NPEEP,NPEEP              move the array elements
rtl      dec   nNextSpot                nnextspot := nnextspot-1;
         lda   #1                       didone := true;
         sta   didOne
         lda   2,S                      fix stack and return
         sta   4,S
         pla
         sta   1,S
         rtl
         end

****************************************************************
*
*  Short - See if label lab is within short range of instruction n
*
*  Inputs:
*        n - instruction number
*        lab - label number
*
****************************************************************
*
Short    start
elSize   equ   12                       size of npeep array element
peep_opcode equ 0                       disp in nativeType of opcode
peep_mode equ  2                        disp in nativeType of mode
peep_operand equ 4                      disp in nativeType of operand
peep_name equ  6                        disp in nativeType of name
peep_flags equ 10                       disp in nativeType of flags

d_lab    equ   256                      label op code #

len      equ   0
i        equ   2

         subroutine (2:n,2:lab),4

         stz   len                      len := 0;
         lda   n                        i := n-1;
         dec   a                        while i > 0 do begin
         dec   a
         ldx   #elSize
         jsl   ~mul2
         tax
         bmi   lb3
lb1      lda   nPeep+peep_opcode,X        if npeep[i].opcode = d_lab then
         cmp   #d_lab
         bne   lb2
         lda   nPeep+peep_operand,X         if npeep[i].operand = lab then begin
         cmp   lab
         bne   lb2
         stz   fn                             Short := len <= 126;
         lda   len
         cmp   #127
         bge   lab1
         inc   fn
         bra   lab1                           goto 1;
lb2      anop                                 end;
         lda   nPeep+peep_opcode,X        len := len+size[npeep[i].mode];
         tay
         lda   size,Y
         and   #$00FF
         clc
         adc   len
         sta   len
         txa                              i := i-1;
         sec
         sbc   #elSize
         tax
         bpl   lb1                        end; {while}
lb3      stz   len                      len := 0;
         lda   n                        i := n+1;
         ldx   #elSize
         jsl   ~mul2
         tax
         lda   n
         inc   a
         sta   i
lb4      lda   i                        while i < nnextspot do begin
         cmp   nNextSpot
         bge   lb6
         lda   nPeep+peep_opcode,X        if npeep[i].opcode = d_lab then
         cmp   #d_lab
         bne   lb5
         lda   nPeep+peep_operand,X         if npeep[i].operand = lab then begin
         cmp   lab
         bne   lb5
         stz   fn                             Short := len < 128;
         lda   len
         cmp   #128
         bge   lab1
         inc   fn
         bra   lab1                           goto 1;
lb5      anop                                 end;
         lda   nPeep+peep_opcode,X        len := len+size[npeep[i].mode];
         tay
         lda   size,Y
         and   #$00FF
         clc
         adc   len
         sta   len
         inc   i                          i := i+1;
         txa
         clc
         adc   #elSize
         tax
         bra   lb4                        end; {while}
lb6      stz   fn                         Short := false;
lab1     anop                           1:end; {Short}
         return 2:fn

fn       ds    2                        function return value

size     dc    i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
         dc    i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
         dc    i1'3,2,4,2,2,2,2,2,1,3,1,1,3,3,3,4'
         dc    i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
         dc    i1'1,2,2,2,3,2,2,2,1,3,1,1,3,3,3,4'
         dc    i1'2,2,2,2,3,2,2,2,1,3,1,1,4,3,3,4'
         dc    i1'1,2,3,2,2,2,2,2,1,3,1,1,3,3,3,4'
         dc    i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'

         dc    i1'2,2,3,2,2,2,2,2,1,3,1,1,3,3,3,4'
         dc    i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
         dc    i1'3,2,3,2,2,2,2,2,1,3,1,1,3,3,3,4'
         dc    i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
         dc    i1'3,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
         dc    i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
         dc    i1'3,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
         dc    i1'2,2,2,2,3,2,2,2,1,3,1,1,3,3,3,4'

         dc    i1'0,0,1,2,0,2,0,255'
         end
\ No newline at end of file
+         mcopy native.macros
+****************************************************************
+*
+*  Remove - remove an instruction from the peephole array
+*
+*  Inputs:
+*        ns - index of element to remove
+*
+****************************************************************
+*
+Remove   start
+elSize   equ   12                       size of an element
+nPeepSize equ  128                      size of array
+ns       equ   4                        array element
+
+         lda   ns,S                     compute the source address
+         cmp   #nPeepSize                (quit if nothing to move)
+         bge   rtl
+         asl   a
+         adc   ns,S
+         asl   a
+         asl   a
+         adc   #NPEEP
+         tax
+         sec                            compute the source address
+         sbc   #elSize
+         tay
+         sec                            compute the move length
+         sbc   #(nPeepSize-1)*elSize+NPEEP
+         eor   #$FFFF
+         mvn   NPEEP,NPEEP              move the array elements
+rtl      dec   nNextSpot                nnextspot := nnextspot-1;
+         lda   #1                       didone := true;
+         sta   didOne
+         lda   2,S                      fix stack and return
+         sta   4,S
+         pla
+         sta   1,S
+         rtl
+         end
+
+****************************************************************
+*
+*  Short - See if label lab is within short range of instruction n
+*
+*  Inputs:
+*        n - instruction number
+*        lab - label number
+*
+****************************************************************
+*
+Short    start
+elSize   equ   12                       size of npeep array element
+peep_opcode equ 0                       disp in nativeType of opcode
+peep_mode equ  2                        disp in nativeType of mode
+peep_operand equ 4                      disp in nativeType of operand
+peep_name equ  6                        disp in nativeType of name
+peep_flags equ 10                       disp in nativeType of flags
+
+d_lab    equ   256                      label op code #
+
+len      equ   0
+i        equ   2
+
+         subroutine (2:n,2:lab),4
+
+         stz   len                      len := 0;
+         lda   n                        i := n-1;
+         dec   a                        while i > 0 do begin
+         dec   a
+         ldx   #elSize
+         jsl   ~mul2
+         tax
+         bmi   lb3
+lb1      lda   nPeep+peep_opcode,X        if npeep[i].opcode = d_lab then
+         cmp   #d_lab
+         bne   lb2
+         lda   nPeep+peep_operand,X         if npeep[i].operand = lab then begin
+         cmp   lab
+         bne   lb2
+         stz   fn                             Short := len <= 126;
+         lda   len
+         cmp   #127
+         bge   lab1
+         inc   fn
+         bra   lab1                           goto 1;
+lb2      anop                                 end;
+         lda   nPeep+peep_opcode,X        len := len+size[npeep[i].mode];
+         tay
+         lda   size,Y
+         and   #$00FF
+         clc
+         adc   len
+         sta   len
+         txa                              i := i-1;
+         sec
+         sbc   #elSize
+         tax
+         bpl   lb1                        end; {while}
+lb3      stz   len                      len := 0;
+         lda   n                        i := n+1;
+         ldx   #elSize
+         jsl   ~mul2
+         tax
+         lda   n
+         inc   a
+         sta   i
+lb4      lda   i                        while i < nnextspot do begin
+         cmp   nNextSpot
+         bge   lb6
+         lda   nPeep+peep_opcode,X        if npeep[i].opcode = d_lab then
+         cmp   #d_lab
+         bne   lb5
+         lda   nPeep+peep_operand,X         if npeep[i].operand = lab then begin
+         cmp   lab
+         bne   lb5
+         stz   fn                             Short := len < 128;
+         lda   len
+         cmp   #128
+         bge   lab1
+         inc   fn
+         bra   lab1                           goto 1;
+lb5      anop                                 end;
+         lda   nPeep+peep_opcode,X        len := len+size[npeep[i].mode];
+         tay
+         lda   size,Y
+         and   #$00FF
+         clc
+         adc   len
+         sta   len
+         inc   i                          i := i+1;
+         txa
+         clc
+         adc   #elSize
+         tax
+         bra   lb4                        end; {while}
+lb6      stz   fn                         Short := false;
+lab1     anop                           1:end; {Short}
+         return 2:fn
+
+fn       ds    2                        function return value
+
+size     dc    i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
+         dc    i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
+         dc    i1'3,2,4,2,2,2,2,2,1,3,1,1,3,3,3,4'
+         dc    i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
+         dc    i1'1,2,2,2,3,2,2,2,1,3,1,1,3,3,3,4'
+         dc    i1'2,2,2,2,3,2,2,2,1,3,1,1,4,3,3,4'
+         dc    i1'1,2,3,2,2,2,2,2,1,3,1,1,3,3,3,4'
+         dc    i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
+
+         dc    i1'2,2,3,2,2,2,2,2,1,3,1,1,3,3,3,4'
+         dc    i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
+         dc    i1'3,2,3,2,2,2,2,2,1,3,1,1,3,3,3,4'
+         dc    i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
+         dc    i1'3,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
+         dc    i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
+         dc    i1'3,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4'
+         dc    i1'2,2,2,2,3,2,2,2,1,3,1,1,3,3,3,4'
+
+         dc    i1'0,0,1,2,0,2,0,255'
+         end
diff --git a/native.macros b/native.macros
old mode 100755
new mode 100644
index 33a7632..1a00d44
--- a/native.macros
+++ b/native.macros
@@ -1 +1,118 @@
- MACRO
&lab subroutine &parms,&work
&lab anop
 aif c:&work,.a
 lclc &work
&work setc 0
.a
 gbla &totallen
 gbla &worklen
&worklen seta &work
&totallen seta 0
 aif c:&parms=0,.e
 lclc &len
 lclc &p
 lcla &i
&i seta c:&parms
.b
&p setc &parms(&i)
&len amid &p,2,1
 aif "&len"=":",.c
&len amid &p,1,2
&p amid &p,4,l:&p-3
 ago .d
.c
&len amid &p,1,1
&p amid &p,3,l:&p-2
.d
&p equ &totallen+3+&work
&totallen seta &totallen+&len
&i seta &i-1
 aif &i,^b
.e
 tsc
 sec
 sbc #&work
 tcs
 inc a
 phd
 tcd
 mend
 MACRO
&lab return &r
&lab anop
 lclc &len
 aif c:&r,.a
 lclc &r
&r setc 0
&len setc 0
 ago .h
.a
&len amid &r,2,1
 aif "&len"=":",.b
&len amid &r,1,2
&r amid &r,4,l:&r-3
 ago .c
.b
&len amid &r,1,1
&r amid &r,3,l:&r-2
.c
 aif &len<>2,.d
 ldy &r
 ago .h
.d
 aif &len<>4,.e
 ldx &r+2
 ldy &r
 ago .h
.e
 aif &len<>10,.g
 aif &totallen=0,.f
 lda &worklen+1
 sta &worklen+&totallen+1
 lda &worklen
 sta &worklen+&totallen
.f
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 phb
 plx
 ply
 lda &r+8
 pha
 lda &r+6
 pha
 lda &r+4
 pha
 lda &r+2
 pha
 lda &r
 pha
 phy
 phx
 plb
 rtl
 mexit
.g
 mnote 'Not a valid return length',16
 mexit
.h
 aif &totallen=0,.i
 lda &worklen+1
 sta &worklen+&totallen+1
 lda &worklen
 sta &worklen+&totallen
.i
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 aif &len=0,.j
 tya
.j
 rtl
 mend
\ No newline at end of file
+ MACRO
+&lab subroutine &parms,&work
+&lab anop
+ aif c:&work,.a
+ lclc &work
+&work setc 0
+.a
+ gbla &totallen
+ gbla &worklen
+&worklen seta &work
+&totallen seta 0
+ aif c:&parms=0,.e
+ lclc &len
+ lclc &p
+ lcla &i
+&i seta c:&parms
+.b
+&p setc &parms(&i)
+&len amid &p,2,1
+ aif "&len"=":",.c
+&len amid &p,1,2
+&p amid &p,4,l:&p-3
+ ago .d
+.c
+&len amid &p,1,1
+&p amid &p,3,l:&p-2
+.d
+&p equ &totallen+3+&work
+&totallen seta &totallen+&len
+&i seta &i-1
+ aif &i,^b
+.e
+ tsc
+ sec
+ sbc #&work
+ tcs
+ inc a
+ phd
+ tcd
+ mend
+ MACRO
+&lab return &r
+&lab anop
+ lclc &len
+ aif c:&r,.a
+ lclc &r
+&r setc 0
+&len setc 0
+ ago .h
+.a
+&len amid &r,2,1
+ aif "&len"=":",.b
+&len amid &r,1,2
+&r amid &r,4,l:&r-3
+ ago .c
+.b
+&len amid &r,1,1
+&r amid &r,3,l:&r-2
+.c
+ aif &len<>2,.d
+ ldy &r
+ ago .h
+.d
+ aif &len<>4,.e
+ ldx &r+2
+ ldy &r
+ ago .h
+.e
+ aif &len<>10,.g
+ aif &totallen=0,.f
+ lda &worklen+1
+ sta &worklen+&totallen+1
+ lda &worklen
+ sta &worklen+&totallen
+.f
+ pld
+ tsc
+ clc
+ adc #&worklen+&totallen
+ tcs
+ phb
+ plx
+ ply
+ lda &r+8
+ pha
+ lda &r+6
+ pha
+ lda &r+4
+ pha
+ lda &r+2
+ pha
+ lda &r
+ pha
+ phy
+ phx
+ plb
+ rtl
+ mexit
+.g
+ mnote 'Not a valid return length',16
+ mexit
+.h
+ aif &totallen=0,.i
+ lda &worklen+1
+ sta &worklen+&totallen+1
+ lda &worklen
+ sta &worklen+&totallen
+.i
+ pld
+ tsc
+ clc
+ adc #&worklen+&totallen
+ tcs
+ aif &len=0,.j
+ tya
+.j
+ rtl
+ mend
diff --git a/native.pas b/native.pas
old mode 100755
new mode 100644
index 2fdcb09..c41c619
--- a/native.pas
+++ b/native.pas
@@ -1 +1,2345 @@
-{$optimize -1}
{---------------------------------------------------------------}
{                                                               }
{  ORCA Native Code Generation                                  }
{                                                               }
{  This module of the code generator is called to generate      }
{  native code instructions.  The native code is optimized      }
{  and written to the object segment.                           }
{                                                               }
{  Externally available procedures:                             }
{                                                               }
{  EndSeg - close out the current segment                       }
{  GenNative - write a native code instruction to the output    }
{       file                                                    }
{  GenImplied - short form of GenNative - reduces code size     }
{  GenCall - short form of jsl to library subroutine - reduces  }
{       code size                                               }
{  GenLab - generate a label                                    }
{  InitFile - Set up the object file				}
{  InitNative - set up for a new segment			}
{  RefName - handle a reference to a named label                }
{                                                               }
{---------------------------------------------------------------}

unit Native;

interface

{$LibPrefix '0/obj/'}

uses PCommon, CGI, CGC, ObjOut;

{$segment 'CodeGen'}

{---------------------------------------------------------------}
   
procedure EndSeg;

{ close out the current segment                                 }


procedure GenNative (p_opcode: integer; p_mode: addressingMode;
                     p_operand: integer; p_name: pStringPtr; p_flags: integer);

{ write a native code instruction to the output file            }
{                                                               }
{ parameters:                                                   }
{       p_opcode - native op code                               }
{       p_mode - addressing mode                                }
{       p_operand - integer operand                             }
{       p_name - named operand                                  }
{       p_flags - operand modifier flags                        }


procedure GenImplied (p_opcode: integer);

{ short form of GenNative - reduces code size                   }
{                                                               }
{ parameters:                                                   }
{       p_code - operation code                                 }


procedure GenCall (callNum: integer);

{ short form of jsl to library subroutine - reduces code size   }
{                                                               }
{ parameters:                                                   }
{       callNum - subroutine # to generate a call for           }


procedure GenLab (lnum: integer);

{ generate a label                                              }
{                                                               }
{ parameters:                                                   }
{       lnum - label number                                     }


procedure InitFile (keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean);

{ Set up the object file					}
{                                                               }
{ parameters:							}
{    keepName - name of the output file				}
{    keepFlag - keep status:					}
{       0 - don't keep the output				}
{       1 - create a new object module				}
{       2 - a .root already exists				}
{       3 - at least on .letter file exists			}
{    partial - is this a partial compile?			}
{								}
{ Note: Declared as extern in CGI.pas				}


procedure InitNative;

{ set up for a new segment					}


procedure LabelSearch (lab: integer; len, shift, disp: integer);

{ resolve a label reference                                     }
{                                                               }
{ parameters:                                                   }
{       lab - label number                                      }
{       len - # bytes for the generated code                    }
{       shift - shift factor                                    }
{       disp - disp past the label                              }
{                                                               }
{ Note 1: maxlabel is reserved for use as the start of the      }
{       string space                                            }
{ Note 2: negative length indicates relative branch             }
{ Note 3: zero length indicates 2 byte addr -1                  }


procedure RefName (lab: pStringPtr; disp, len, shift: integer);

{ handle a reference to a named label                           }
{                                                               }
{ parameters:                                                   }
{       lab - label name                                        }
{       disp - displacement past the label                      }
{       len - number of bytes in the reference                  }
{       shift - shift factor                                    }

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

implementation

const
   npeepSize = 128;			{native peephole optimizer window size}
   nMaxPeep = 4;			{max # instructions needed to opt.}

type
                                        {65816 native code generation}
                                        {----------------------------}
   npeepRange = 1..npeepsize;           {subrange for native code peephole opt.}

   nativeType = record                  {native code instruction}
      opcode: integer;                  {op code}
      mode: addressingMode;             {addressing mode}
      operand: integer;                 {operand value}
      name: pStringPtr;                  {operand label}
      flags: integer;                   {modifier flags}
      end;

   registerConditions = (regUnknown,regImmediate,regAbsolute,regLocal);
   registerType = record                {used to track register contents}
      condition: registerConditions;
      value: integer;
      lab: pStringPtr;
      flags: integer;
      end;

var
                                        {65816 native code generation}
                                        {----------------------------}
   longA,longI: boolean;                {register sizes}

                                        {I/O files}
                                        {---------}
   fname1, fname2: gsosOutString;	{file names}
   nextSuffix: char;                    {next suffix character to use}

                                        {native peephole optimization}
                                        {----------------------------}
   aRegister,                           {current register contents}
      xRegister,
      yRegister: registerType;
   didOne: boolean;                     {has an optimization been done?}
   nleadOpcodes: set of 0..max_opcode;  {instructions that can start an opt.}
   nstopOpcodes: set of 0..max_opcode;  {instructions not involved in opt.}
   npeep: array[npeepRange] of nativeType; {native peephole array}
   nnextspot: npeepRange;               {next empty spot in npeep}
   

procedure GenSymbols (sym: ptr; doGlobals: integer); extern;

{ generate the symbol table                                     }

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

procedure UpDate (lab: integer; labelValue: longint);

{ define a label						}
{								}
{ parameters:							}
{    lab - label number						}
{    labelValue - displacement in seg where label is located	}

var
   next,temp: labelptr;			{work pointers}

begin {UpDate}
if labeltab[lab].defined then
   Error(cge1)
else begin

   {define the label for future references}
   with labeltab[lab] do begin
      defined := true;
      val := labelValue;
      next := chain;
      end; {with}

   {resolve any forward references}
   if next <> nil then begin
      Purge;
      while next <> nil do begin
         segdisp := next^.addr;
         Out2(long(labelvalue).lsw);
         Out2(long(labelvalue).msw);
         blkcnt := blkcnt-4;
         temp := next;
         next := next^.next;
         end; {while}
      segdisp := blkcnt;
      end; {if}
   end; {else}
end; {UpDate}


procedure WriteNative (opcode: integer; mode: addressingMode; operand: integer;
                      name: pStringPtr; flags: integer);

{ write a native code instruction to the output file            }
{                                                               }
{ parameters:                                                   }
{       opcode - native op code                                 }
{       mode - addressing mode                                  }
{       operand - integer operand                               }
{       name - named operand                                    }
{       flags - operand modifier flags                          }

label 1;

type
   rkind = (k1,k2,k3);                  {cnv record types}

var
   ch: char;                            {temp storage for string constants}
   cns: realRec;                        {for converting reals to bytes}
   cnv: record                          {for converting double, real to bytes}
      case rkind of
         k1: (rval: real;);
         k2: (dval: double;);
         k3: (ival1,ival2,ival3,ival4: integer;);
      end;
   count: integer;                      {number of constants to repeat}
   i,j,k: integer;                      {loop variables}
   lsegDisp: integer;                   {for backtracking while writting the   }
                                        { debugger's symbol table              }
   lval: longint;                       {temp storage for long constant}
   nptr: pStringPtr;                    {pointer to a name}
   sptr: pStringPtr;                    {pointer to a string constant}


   procedure GenImmediate1;

   { generate a one byte immediate operand                      }

   begin {GenImmediate1}
   if (flags & stringReference) <> 0 then begin
      Purge;
      Out(235); Out(1);                 {one byte expression}
      Out(128);                         {current location ctr}
      Out(129); Out2(-16); Out2(-1);    {-16}
      Out(7);                           {bit shift}
      Out(0);                           {end of expr}
      pc := pc+1;
      end {if}
   else if (flags & localLab) <> 0 then
      LabelSearch(long(name).lsw, 1, ord(odd(flags div shift16))*16, operand)
   else if (flags & shift16) <> 0 then
      RefName(name, operand, 1, -16)
   else
      CnOut(operand);
   end; {GenImmediate1}


   procedure GenImmediate2;

   { generate a two byte immediate operand                      }

   begin {GenImmediate2}
   if (flags & stringReference) <> 0 then begin
      Purge;
      Out(235); Out(2);
      LabelSearch(maxLabel, 2, 0, 0);
      if operand <> 0 then begin
         Out(129);
         Out2(operand); Out2(0);
         Out(1);
         end; {if}
      if (flags & shift16) <> 0 then begin
         Out(129);
         Out2(-16); Out2(-1);
         Out(7);
         end; {if}
      Out(0);
      end {if}
   else if (flags & shift8) <> 0 then
      RefName(name, operand, 2, -8)
   else if (flags & localLab) <> 0 then
      LabelSearch(long(name).lsw, 2, ord(odd(flags div shift16))*16, operand)
   else if (flags & shift16) <> 0 then
      RefName(name, operand, 2, -16)
   else if name = nil then
      CnOut2(operand)
   else
      RefName(name, operand, 2, 0);
   end; {GenImmediate2}


   procedure DefGlobal (private: integer);

   { define a global label                                      }
   {                                                            }
   { parameters:                                                }
   {    private - private flag                                  }

   var
      i: integer;                       {loop variable}

   begin {DefGlobal}
   Purge;
   Out(230);                            {global label definition}
   Out(ord(name^[0]));                  {write label name}
   for i := 1 to ord(name^[0]) do
      Out(ord(name^[i]));
   Out2(0);				{length attribute}
   Out(ord('N'));                       {type attribute: other directive}
   Out(private);                        {private or global?}
   end; {DefGlobal}


begin {WriteNative}
{ writeln('WriteNative: ',opcode:4, ', mode=', ord(mode):1,
   ' operand=', operand:1);      {debug}
case mode of

   implied:
      CnOut(opcode);

   immediate: begin
      if opcode = d_bmov then
         GenImmediate1
      else begin
         if opcode = m_and_imm then
            if not longA then
               if operand = 255 then
                  goto 1;
         CnOut(opcode);
         if opcode = m_pea then
            GenImmediate2
         else if opcode in
            [m_adc_imm,m_and_imm,m_cmp_imm,m_eor_imm,m_lda_imm,m_ora_imm,
             m_sbc_imm,m_bit_imm] then
               if longA then
                 GenImmediate2
              else
                 GenImmediate1
         else if opcode in [m_rep,m_sep,m_cop] then begin
            GenImmediate1;
            if opcode = m_rep then begin
               if odd(operand div 32) then longA := true;
               if odd(operand div 16) then longI := true;
               end {if}
            else if opcode = m_sep then begin
               if odd(operand div 32) then longA := false;
               if odd(operand div 16) then longI := false;
               end; {else}
            end {else}
         else
            if longI then
               GenImmediate2
            else
               GenImmediate1;
         end; {else}
      end;

   longabs: begin
      CnOut(opcode);
      isJSL := opcode = m_jsl;          {allow for dynamic segs}
      if name = nil then
         if odd(flags div toolCall) then begin
            CnOut2(0);
            CnOut($E1);
            end {if}
         else if odd(flags div userToolCall) then begin
            CnOut2(8);
            CnOut($E1);
            end {else if}
         else
            LabelSearch(operand, 3, 0, 0)
      else
         RefName(name, operand, 3, 0);
      isJSL := false;
      end;

   longabsolute: begin
      if opcode <> d_add then begin
         CnOut(opcode);
         i := 3;
         end {if}
      else
         i := 4;
      if (flags & localLab) <> 0 then
         LabelSearch(long(name).lsw, i, 0, operand)
      else if (flags & constantOpnd) <> 0 then begin
         lval := ord4(name);
         CnOut2(long(lval).lsw);
         if opcode = d_add then
            CnOut2(long(lval).msw)
         else
            CnOut(long(lval).msw);
         end {else if}
      else if name <> nil then
         RefName(name, operand, i, 0)
      else begin
         CnOut2(operand);
         CnOut(0);
         if opcode = d_add then
            CnOut(0);
         end; {else}
      end;

   absolute: begin
      if opcode <> d_add then
         CnOut(opcode);
      if (flags & localLab) <> 0 then
         LabelSearch(long(name).lsw, 2, 0, operand)
      else if name <> nil then
         RefName(name, operand, 2, 0)
      else if (flags & constantOpnd) <> 0 then
         CnOut2(operand)
      else
         LabelSearch(operand, 2, 0, 0);
      end;

   direct: begin
      if opcode <> d_add then
         CnOut(opcode);
      if (flags & localLab) <> 0 then
         LabelSearch(long(name).lsw, 1, 0, operand)
      else if name <> nil then
         RefName(name, operand, 1, 0)
      else
         CnOut(operand);
      end;

   longrelative: begin
      CnOut(opcode);
      LabelSearch(operand, -2, 0, 0);
      end;

   relative: begin
      CnOut(opcode);
      LabelSearch(operand, -1, 0, 0);
      end;

   gnrLabel:
      if name = nil then
         UpDate(operand, pc+cbufflen)
      else begin
         DefGlobal((flags >> 5) & 1);
         if operand <> 0 then begin
            Out(241);
            Out2(operand);
            Out2(0);
            pc := pc+operand;
            end; {if}
        end; {else}

   gnrSpace:
      if operand <> 0 then begin
         Out(241);
         Out2(operand);
         Out2(0);
         pc := pc+operand;
         end; {if}

   gnrConstant: begin
      if icptr(name)^.optype = cgString then
         count := 1
      else
         count := icptr(name)^.q;
      for i := 1 to count do
         case icptr(name)^.optype of
            cgByte,cgUByte      : CnOut(icptr(name)^.r);
            cgWord,cgUWord      : CnOut2(icptr(name)^.r);
            cgLong,cgULong      : begin
                                  lval := icptr(name)^.lval;
                                  CnOut2(long(lval).lsw);
                                  CnOut2(long(lval).msw);
                                  end;
            cgReal              : begin
                                  cnv.rval := icptr(name)^.rval;
                                  CnOut2(cnv.ival1);
                                  CnOut2(cnv.ival2);
                                  end;
            cgDouble            : begin
                                  cnv.dval := icptr(name)^.rval;
                                  CnOut2(cnv.ival1);
                                  CnOut2(cnv.ival2);
                                  CnOut2(cnv.ival3);
                                  CnOut2(cnv.ival4);
                                  end;
            cgString            : begin
                                  sptr := icptr(name)^.str;
                                  for j := 1 to length(sptr^) do
                                     CnOut(ord(sPtr^[j]));
                                  end;
            otherwise           : Error(cge1);
            end; {case}
      end;

   genAddress: begin
      if opcode < 256 then
         CnOut(opcode);
      if (flags & stringReference) <> 0 then begin
         Purge;
         Out(235);
         Out(2);
         LabelSearch(maxLabel,2,0,0);
         if operand <> 0 then begin
            Out(129);
            Out2(operand);
            Out2(0);
            Out(1);
            end; {if}
         if (flags & shift16) <> 0 then begin
            Out(129);
            Out2(-16);
            Out2(-1);
            Out(7);
            end; {if}
         Out(0);
         end {if}
      else if operand = 0 then begin
         CnOut(0);
         CnOut(0);
         end {else if}
      else if (flags & shift16) <> 0 then
         if longA then
            LabelSearch(operand, 2, 16, 0)
         else
            LabelSearch(operand, 1, 16, 0)
      else if (flags & sub1) <> 0 then
         LabelSearch(operand, 0, 0, 0)
      else  
         LabelSearch(operand, 2, 0, 0);
      end;

   special:
      if opcode = d_pin then begin
         segDisp := 36;
         out2(long(pc).lsw+cBuffLen);
         blkCnt := blkCnt-2;
         segDisp := blkCnt;
         end {if}
      else if opcode = d_sym then begin
         CnOut(m_cop);
         CnOut(5);
         Purge;
         lsegDisp := segDisp+1;
         CnOut2(0);
         symLength := 0;
         GenSymbols(pointer(name), operand);
         segDisp := lSegDisp;
         out2(symLength);
         blkCnt := blkCnt-2;
         segDisp := blkCnt;
         end {else if}
      else {d_wrd}
         CnOut2(operand);

   otherwise: Error(cge1);

   end; {case}
1:
end; {WriteNative}


procedure CheckRegisters(p_opcode: integer; p_mode: addressingMode;
                    p_operand: integer; p_name: pStringPtr; p_flags: integer);

{ write a native code instruction to the output file            }
{                                                               }
{ parameters:                                                   }
{       p_opcode - native op code                               }
{       p_mode - addressing mode                                }
{       p_operand - integer operand                             }
{       p_name - named operand                                  }
{       p_flags - operand modifier flags                        }

label 1,2;

begin {CheckRegisters}
case p_opcode of
   m_adc_abs,m_adc_dir,m_adc_imm,m_adc_s,m_and_abs,m_and_dir,m_and_imm,
   m_and_s,m_asl_a,m_dea,m_eor_abs,m_eor_dir,m_eor_imm,m_eor_s,m_lda_absx,
   m_lda_dirx,m_lda_indl,m_lda_indly,m_lda_longx,m_lda_s,m_lsr_a,m_ora_abs,
   m_ora_dir,m_ora_dirX,m_ora_imm,m_ora_longX,m_ora_s,m_pla,m_sbc_abs,
   m_sbc_dir,m_sbc_imm,m_sbc_s,m_tdc,m_tsc,m_tsb_dir,m_tsb_abs:
      aRegister.condition := regUnknown;

   m_ldy_absX,m_ldy_dirX,m_ply:
      yRegister.condition := regUnknown;

   m_plx:
      xRegister.condition := regUnknown;

   m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bra,m_brl,m_bvs,m_clc,m_cmp_abs,
   m_cmp_dir,m_cmp_imm,m_cmp_s,m_cpx_imm,m_jml,m_pha,m_phb,m_phd,
   m_phx,m_phy,m_plb,m_pld,m_rtl,m_rts,m_sec,m_sta_absX,
   m_sta_dir,m_sta_dirX,m_sta_indl,m_sta_indlY,m_sta_longX,
   m_sta_s,m_stx_dir,m_sty_dir,m_sty_dirX,m_stz_abs,m_stz_absX,
   m_stz_dir,m_stz_dirX,m_tcs,m_tcd,d_add,d_pin,m_pei_dir,m_cpx_abs,
   m_cpx_dir,m_cmp_dirx,m_php,m_plp,m_cop,d_wrd:   ;

   m_pea: begin
      if aRegister.condition = regImmediate then
         if aRegister.value = p_operand then
            if aRegister.lab = p_name then
               if aRegister.flags = p_flags then
        	  if longA then begin
        	     p_opcode := m_pha;
        	     p_mode := implied;
        	     goto 2;
        	     end; {if}
      if longI then begin
	 if xRegister.condition = regImmediate then
            if xRegister.value = p_operand then
               if xRegister.lab = p_name then
        	  if xRegister.flags = p_flags then begin
        	     p_opcode := m_phx;
        	     p_mode := implied;
        	     goto 2;
        	     end; {if}
	 if yRegister.condition = regImmediate then
            if yRegister.value = p_operand then
               if yRegister.lab = p_name then
        	  if yRegister.flags = p_flags then begin
        	     p_opcode := m_phy;
        	     p_mode := implied;
        	     goto 2;
        	     end; {if}
         end; {if}
      end;

   m_dec_abs,m_inc_abs,m_sta_abs,m_stx_abs,m_sty_abs,m_sta_long: begin
      if aRegister.condition = regAbsolute then
         if aRegister.lab = p_name then
            if aRegister.value = p_operand then
               if not (p_opcode in [m_sta_abs,m_sta_long]) then
                  aRegister.condition := regUnknown;
      if xRegister.condition = regAbsolute then
         if xRegister.lab = p_name then
            if xRegister.value = p_operand then
               if p_opcode <> m_stx_abs then
                  xRegister.condition := regUnknown;
      if yRegister.condition = regAbsolute then
         if yRegister.lab = p_name then
            if yRegister.value = p_operand then
               if p_opcode <> m_sty_abs then
                  yRegister.condition := regUnknown;
      end;

   m_dec_dir,m_dec_dirX,m_inc_dir,m_inc_dirX: begin
      if aRegister.condition = regLocal then
         if aRegister.value = p_operand then
            aRegister.condition := regUnknown;
      if xRegister.condition = regLocal then
         if xRegister.value = p_operand then
            xRegister.condition := regUnknown;
      if yRegister.condition = regLocal then
         if yRegister.value = p_operand then
            yRegister.condition := regUnknown;
      end;

   m_dex:
      if xRegister.condition = regImmediate then
         xRegister.value := xRegister.value-1
      else
         xRegister.condition := regUnknown;

   m_dey:
      if yRegister.condition = regImmediate then
         yRegister.value := yRegister.value-1
      else
         yRegister.condition := regUnknown;

   m_ina:
      if aRegister.condition = regImmediate then
         aRegister.value := aRegister.value+1
      else
         aRegister.condition := regUnknown;

   m_inx:
      if xRegister.condition = regImmediate then
         xRegister.value := xRegister.value+1
      else
         xRegister.condition := regUnknown;

   m_iny:
      if yRegister.condition = regImmediate then
         yRegister.value := yRegister.value+1
      else
         yRegister.condition := regUnknown;

   otherwise,
   m_jsl,m_mvn,m_rep,m_sep,d_lab,d_end,d_bmov,d_cns: begin
      aRegister.condition := regUnknown;
      xRegister.condition := regUnknown;
      yRegister.condition := regUnknown;
      end;

   m_lda_abs,m_lda_long: begin
      if (aRegister.condition = regAbsolute) and
         (aRegister.value = p_operand) and
         (aRegister.lab = p_name) then
         goto 1
      else if longA = longI then begin
         if (xRegister.condition = regAbsolute) and
            (xRegister.value = p_operand) and
            (xRegister.lab = p_name) then begin
            p_opcode := m_txa;
            p_mode := implied;
            aRegister := xRegister;
            goto 2;
            end {if}
         else if (yRegister.condition = regAbsolute) and
            (yRegister.value = p_operand) and
            (yRegister.lab = p_name) then begin
            p_opcode := m_tya;
            p_mode := implied;
            aRegister := yRegister;
            goto 2;
            end; {else if}
         end;
      aRegister.condition := regAbsolute;
      aRegister.value := p_operand;
      aRegister.lab := p_name;
      aRegister.flags := p_flags;
      end;

   m_lda_dir: begin
      if (aRegister.condition = regLocal) and
         (aRegister.value = p_operand) then
         goto 1
      else if longA = longI then begin
         if (xRegister.condition = regLocal) and
            (xRegister.value = p_operand) then begin
            p_opcode := m_txa;
            p_mode := implied;
            aRegister := xRegister;
            goto 2;
            end {if}
         else if (yRegister.condition = regLocal) and
            (yRegister.value = p_operand) then begin
            p_opcode := m_tya;
            p_mode := implied;
            aRegister := yRegister;
            goto 2;
            end; {else if}
         end; {else if}
      aRegister.condition := regLocal;
      aRegister.value := p_operand;
      aRegister.flags := p_flags;
      end;

   m_lda_imm: begin
      if (aRegister.condition = regImmediate) and
         (aRegister.value = p_operand) and
         (aRegister.lab = p_name) and
         (aRegister.flags = p_flags) then
         goto 1
      else if longA = longI then begin
         if (xRegister.condition = regImmediate) and
            (xRegister.value = p_operand) and
            (xRegister.lab = p_name) and
            (xRegister.flags = p_flags) then begin
            p_opcode := m_txa;
            p_mode := implied;
            aRegister := xRegister;
            goto 2;
            end {if}
         else if (yRegister.condition = regImmediate) and
            (yRegister.value = p_operand) and
            (yRegister.lab = p_name) and
            (yRegister.flags = p_flags) then begin
            p_opcode := m_tya;
            p_mode := implied;
            aRegister := yRegister;
            goto 2;
            end; {else if}
         end; {else if}
      if (aRegister.condition = regImmediate) and
         (aRegister.lab = p_name) and
         (aRegister.flags = p_flags) then
         if aRegister.value = (p_operand + 1) then begin
            p_opcode := m_dea;
            p_mode := implied;
            aRegister.value := p_operand;
            goto 2;
            end {if}   
         else if aRegister.value = (p_operand - 1) then begin
            p_opcode := m_ina;
            p_mode := implied;
            aRegister.value := p_operand;
            goto 2;
            end; {else if}
      aRegister.condition := regImmediate;
      aRegister.value := p_operand;
      aRegister.flags := p_flags;
      aRegister.lab := p_name;
      end;

   m_ldx_abs: begin
      if (xRegister.condition = regAbsolute) and
         (xRegister.value = p_operand) and
         (xRegister.lab = p_name) then
         goto 1
      else if (aRegister.condition = regAbsolute) and
         (aRegister.value = p_operand) and
         (aRegister.lab = p_name) and
         (longA = longI) then begin
         p_opcode := m_tax;
         p_mode := implied;
         xRegister := aRegister;
         end {else if}
      else if (yRegister.condition = regAbsolute) and
         (yRegister.value = p_operand) and
         (yRegister.lab = p_name) then begin
         p_opcode := m_tyx;
         p_mode := implied;
         xRegister := yRegister;
         end {else if}
      else begin
         xRegister.condition := regAbsolute;
         xRegister.value := p_operand;
         xRegister.lab := p_name;
         xRegister.flags := p_flags;
         end; {else}
      end;

   m_ldx_dir: begin
      if (xRegister.condition = regLocal) and
         (xRegister.value = p_operand) then
         goto 1
      else if (aRegister.condition = regLocal) and
         (aRegister.value = p_operand) and
         (longA = longI) then begin
         p_opcode := m_tax;
         p_mode := implied;
         xRegister := aRegister;
         end {else if}
      else if (yRegister.condition = regLocal) and
         (yRegister.value = p_operand) then begin
         p_opcode := m_tyx;
         p_mode := implied;
         xRegister := yRegister;
         end {else if}
      else begin
         xRegister.condition := regLocal;
         xRegister.value := p_operand;
         xRegister.flags := p_flags;
         end; {else}
      end;

   m_ldx_imm: begin
      if (xRegister.condition = regImmediate) and
         (xRegister.value = p_operand) and
         (xRegister.lab = p_name) and
         (xRegister.flags = p_flags) then
         goto 1
      else if (aRegister.condition = regImmediate) and
         (aRegister.value = p_operand) and
         (longA = longI) and
         (aRegister.lab = p_name) and
         (aRegister.flags = p_flags) then begin
         p_opcode := m_tax;
         p_mode := implied;
         xRegister := aRegister;
         end {else}
      else if (yRegister.condition = regImmediate) and
         (yRegister.value = p_operand) and
         (yRegister.lab = p_name) and
         (yRegister.flags = p_flags) then begin
         p_opcode := m_tyx;
         p_mode := implied;
         xRegister := yRegister;
         end {else if}
      else begin
	 if (xRegister.condition = regImmediate) and
            (xRegister.lab = p_name) and
            (xRegister.flags = p_flags) then
            if xRegister.value = (p_operand + 1) then begin
               p_opcode := m_dex;
               p_mode := implied;
               xRegister.value := p_operand;
               goto 2;
               end {if}   
            else if xRegister.value = (p_operand - 1) then begin
               p_opcode := m_inx;
               p_mode := implied;
               xRegister.value := p_operand;
               goto 2;
               end; {else if}
         xRegister.condition := regImmediate;
         xRegister.value := p_operand;
         xRegister.flags := p_flags;
         xRegister.lab := p_name;
         end; {else}
      end;

   m_ldy_abs: begin
      if (yRegister.condition = regAbsolute) and
         (yRegister.value = p_operand) and
         (yRegister.lab = p_name) then
         goto 1
      else if (aRegister.condition = regAbsolute) and
         (aRegister.value = p_operand) and
         (aRegister.lab = p_name) and
         (longA = longI) then begin
         p_opcode := m_tay;
         p_mode := implied;
         yRegister := aRegister;
         end {else if}
      else if (xRegister.condition = regAbsolute) and
         (xRegister.value = p_operand) and
         (xRegister.lab = p_name) then begin
         p_opcode := m_txy;
         p_mode := implied;
         yRegister := xRegister;
         end {else if}
      else begin
         yRegister.condition := regAbsolute;
         yRegister.value := p_operand;
         yRegister.lab := p_name;
         yRegister.flags := p_flags;
         end; {else}
      end;

   m_ldy_dir: begin
      if (yRegister.condition = regLocal) and
         (yRegister.value = p_operand) then
         goto 1
      else if (aRegister.condition = regLocal) and
         (aRegister.value = p_operand) and
         (longA = longI) then begin
         p_opcode := m_tay;
         p_mode := implied;
         yRegister := aRegister;
         end {else if}
      else if (xRegister.condition = regLocal) and
         (xRegister.value = p_operand) then begin
         p_opcode := m_txy;
         p_mode := implied;
         yRegister := xRegister;
         end {else if}
      else begin
         yRegister.condition := regLocal;
         yRegister.value := p_operand;
         yRegister.flags := p_flags;
         end; {else}
      end;

   m_ldy_imm: begin
      if (yRegister.condition = regImmediate) and
         (yRegister.value = p_operand) and
         (yRegister.lab = p_name) and
         (yRegister.flags = p_flags) then
         goto 1
      else if (aRegister.condition = regImmediate) and
         (aRegister.value = p_operand) and
         (aRegister.flags = p_flags) and
         (aRegister.lab = p_name) and
         (longA = longI) then begin
         p_opcode := m_tay;
         p_mode := implied;
         yRegister := aRegister;
         end {else if}
      else if (xRegister.condition = regImmediate) and
         (xRegister.value = p_operand) and
         (xRegister.lab = p_name) and
         (xRegister.flags = p_flags) then begin
         p_opcode := m_txy;
         p_mode := implied;
         yRegister := xRegister;
         end {else if}
      else begin
	 if (yRegister.condition = regImmediate) and
            (yRegister.lab = p_name) and
            (yRegister.flags = p_flags) then
            if yRegister.value = (p_operand + 1) then begin
               p_opcode := m_dey;
               p_mode := implied;
               yRegister.value := p_operand;
               goto 2;
               end {if}   
            else if yRegister.value = (p_operand - 1) then begin
               p_opcode := m_iny;
               p_mode := implied;
               yRegister.value := p_operand;
               goto 2;
               end; {else if}
         yRegister.condition := regImmediate;                   
         yRegister.value := p_operand;
         yRegister.flags := p_flags;
         yRegister.lab := p_name;
         end; {else}
      end;

   m_tax: begin
      if aRegister.condition <> regUnknown then
         if aRegister.condition = xRegister.condition then
            if aRegister.value = xRegister.value then
               if aRegister.flags = xRegister.flags then
                  if aRegister.condition <> regAbsolute then
                     goto 1
                  else if aRegister.lab = xRegister.lab then
                     goto 1;
      xRegister := aRegister;
      end;

   m_tay: begin
      if aRegister.condition <> regUnknown then
         if aRegister.condition = yRegister.condition then
            if aRegister.value = yRegister.value then
               if aRegister.flags = yRegister.flags then
                  if aRegister.condition <> regAbsolute then
                     goto 1
                  else if aRegister.lab = yRegister.lab then
                     goto 1;
      yRegister := aRegister;
      end;

   m_txa: begin
      if xRegister.condition <> regUnknown then
         if xRegister.condition = aRegister.condition then
            if xRegister.value = aRegister.value then
               if xRegister.flags = aRegister.flags then
                  if xRegister.condition <> regAbsolute then
                     goto 1
                  else if xRegister.lab = aRegister.lab then
                     goto 1;
      aRegister := xRegister;
      end;

   m_txy: begin
      if xRegister.condition <> regUnknown then
         if xRegister.condition = yRegister.condition then
            if xRegister.value = yRegister.value then
               if xRegister.flags = yRegister.flags then
                  if xRegister.condition <> regAbsolute then
                     goto 1
                  else if xRegister.lab = yRegister.lab then
                     goto 1;
      yRegister := xRegister;
      end;

   m_tya: begin
      if yRegister.condition <> regUnknown then
         if yRegister.condition = aRegister.condition then
            if yRegister.value = aRegister.value then
               if yRegister.flags = aRegister.flags then
                  if yRegister.condition <> regAbsolute then
                     goto 1
                  else if yRegister.lab = aRegister.lab then
                     goto 1;
      aRegister := yRegister;
      end;

   m_tyx: begin
      if yRegister.condition <> regUnknown then
         if yRegister.condition = xRegister.condition then
            if yRegister.value = xRegister.value then
               if yRegister.flags = xRegister.flags then
                  if yRegister.condition <> regAbsolute then
                     goto 1
                  else if yRegister.lab = xRegister.lab then
                     goto 1;
      xRegister := yRegister;
      end;
   end; {case}
2:
WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
1:
end; {CheckRegisters}


procedure Remove (ns: integer); extern;

{ Remove the instruction ns from the peephole array             }
{                                                               }
{ parameters:                                                   }
{       ns - index of the instruction to remove                 }


function Short (n, lab: integer): boolean; extern;

{ see if a label is within range of a one-byte relative branch  }
{                                                               }
{ parameters:                                                   }
{       n - index to branch instruction                         }
{       lab - label number                                      }

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

procedure EndSeg;

{ close out the current segment                                 }

var
   i: integer;

begin {EndSeg}
Purge;                                  {dump constant buffer}
if stringsize <> 0 then begin           {define string space}
   UpDate(maxLabel, pc);                {define the local label for the string space}
   for i := 1 to stringsize do
      CnOut(ord(stringspace[i]));
   Purge;
   end; {if}
Out(0);                                 {end the segment}
segDisp := 8;                           {update header}
Out2(long(pc).lsw);
Out2(long(pc).msw);
blkcnt := blkcnt-4;                     {purge the segment to disk}
segDisp := blkcnt;
CloseSeg;
end; {EndSeg}


procedure GenNative {p_opcode: integer; p_mode: addressingMode;
                     p_operand: integer; p_name: pStringPtr; p_flags: integer};

{ write a native code instruction to the output file            }
{                                                               }
{ parameters:                                                   }
{       p_opcode - native op code                               }
{       p_mode - addressing mode                                }
{       p_operand - integer operand                             }
{       p_name - named operand                                  }
{       p_flags - operand modifier flags                        }

var
   done: boolean;                       {loop termination}
   llongA: boolean;                     {for tracking A size during opt.}
   i: integer;                          {index}
   op: integer;                         {temp storage for opcode}


   procedure Purge;

   { Empty the peephole array                                   }

   begin {Purge}
   while nnextSpot > 1 do begin
      if registers then
         CheckRegisters(npeep[1].opcode, npeep[1].mode, npeep[1].operand,
            npeep[1].name, npeep[1].flags)
      else
         WriteNative(npeep[1].opcode, npeep[1].mode, npeep[1].operand,
            npeep[1].name, npeep[1].flags);
      Remove(1);
      end; {while}
   end; {Purge}


   procedure Optimize(ns: integer; longA: boolean);

   { Optimize the instruction starting at ns                    }
   {                                                            }
   { parameters:                                                }
   {    ns - index of instruction  to check for optimization    }
   {    longA - is the accumulator long?                        }

   label 1;

   var
      tn: nativeType;			{temp operation}


      function ASafe (ns: integer): boolean;

      { See if it is safe to skip loading the A register        }
      {                                                         }
      { parameters:                                             }
      {    ns - starting index                                  }

      label 1;

      var
         i: integer;                    {loop variable}
         opcode: integer;               {copy of current op code}

      begin {ASafe}
      ASafe := false;
      for i := ns to nnextSpot-1 do begin
         opcode := npeep[i].opcode;
         if opcode in
            [m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bra,m_brl,m_bvs,m_jml,m_jsl,
             m_lda_abs,m_lda_absx,m_lda_dir,m_lda_dirx,m_lda_imm,m_lda_indl,
             m_lda_indly,m_lda_long,m_lda_longx,m_lda_s,m_mvn,m_pla,m_rtl,
             m_rts,m_tdc,m_txa,m_tya,m_tsc,d_end,d_bmov,d_add,d_pin,d_wrd,
             d_sym,d_cns] then begin
            ASafe := true;
            goto 1;
            end {if}
         else if opcode in
            [m_adc_abs,m_adc_dir,m_adc_imm,m_adc_s,m_and_abs,m_and_dir,
             m_and_imm,m_and_s,m_asl_a,m_cmp_abs,m_cmp_dir,m_cmp_dirX,m_cmp_imm,
             m_cmp_long,m_cmp_s,m_dea,m_eor_abs,m_eor_dir,m_eor_imm,m_eor_s,
             m_ina,m_lda_abs,m_lda_absx,m_lda_dir,m_lda_dirx,m_lda_imm,
             m_lda_indl,m_lda_indly,m_lda_long,m_lda_longx,m_lda_s,m_lsr_a,
             m_ora_abs,m_ora_dir,m_ora_dirX,m_ora_imm,m_ora_longX,m_ora_s,
             m_pha,m_sbc_abs,m_sbc_dir,m_sbc_imm,m_sbc_s,m_sta_abs,m_sta_absX,
             m_sta_dir,m_sta_dirX,m_sta_indl,m_sta_indlY,m_sta_long,m_sta_longX,
             m_sta_s,m_tax,m_tay,m_tcd,m_tcs,m_xba,m_tsb_dir,m_tsb_abs] then
            goto 1;
         end; {for}
1:
      end; {ASafe}


      function SignExtension (ns: integer): boolean;

      { See if the pattern is a sugn extension			}
      {								}
      { Parameters:						}
      {    ns - start of suspected pattern			}
      {								}
      { Returns: true for a sign extension, else false		}

      begin {SignExtension}
      SignExtension := false;
      if npeep[ns].opcode = m_ldx_imm then
         if npeep[ns].operand = 0 then
            if npeep[ns+1].opcode = m_tay then
               if npeep[ns+2].opcode = m_bpl then
                  if npeep[ns+3].opcode = m_dex then
                     SignExtension := true;
      end; {SignExtension}


   begin {Optimize}
   with npeep[ns] do
      case opcode of

         m_and_imm:
            if npeep[ns+1].opcode = m_and_imm then begin
               operand := operand & npeep[ns+1].operand;
               Remove(ns+1);
               end; {if}

         m_asl_a:
            if npeep[ns+1].opcode = m_tay then
               if npeep[ns+2].opcode = m_iny then
                  if npeep[ns+3].opcode = m_iny then begin
                     opcode := m_ina;
                     npeep[ns+1].opcode := m_asl_a;
                     npeep[ns+2].opcode := m_tay;
                     Remove(ns+3);
                     end; {if}

         m_bcs,m_beq,m_bne,m_bmi,m_bpl,m_bcc:
            if npeep[ns+2].opcode = d_lab then
               if npeep[ns+2].operand = operand then
                  if npeep[ns+1].opcode = m_brl then begin
                     if Short(ns,npeep[ns+1].operand) then begin
                        operand := npeep[ns+1].operand;
                        Remove(ns+1);
                        if opcode = m_bcs then
                           opcode := m_bcc
                        else if opcode = m_beq then
                           opcode := m_bne
                        else if opcode = m_bne then
                           opcode := m_beq
                        else if opcode = m_bmi then
                           opcode := m_bpl
                        else if opcode = m_bcc then
                           opcode := m_bcs
                        else
                           opcode := m_bmi;
                        end; {if}
                     end {if m_brl}
                  else if npeep[ns+1].opcode = m_bra then begin
                     operand := npeep[ns+1].operand;
                     Remove(ns+1); Remove(ns+1);
                     if opcode = m_bcs then
                        opcode := m_bcc
                     else if opcode = m_beq then
                        opcode := m_bne
                     else if opcode = m_bne then
                        opcode := m_beq
                     else if opcode = m_bmi then
                        opcode := m_bpl
                     else if opcode = m_bcc then
                        opcode := m_bcs
                     else
                        opcode := m_bmi;
                     end; {else if m_bra}

         m_brl:
            if Short(ns,operand) then begin
               opcode := m_bra;
               mode := relative;
               didOne := true;
               end; {if}

         m_bvs:
            if npeep[ns+2].opcode = d_lab then
               if npeep[ns+2].operand = operand then
                  if npeep[ns+1].opcode = m_bmi then
                     if npeep[ns+4].opcode = d_lab then
                        if npeep[ns+1].operand = npeep[ns+4].operand then
                           if npeep[ns+3].opcode = m_brl then
                              if Short(ns,npeep[ns+3].operand) then
                                 if Short(ns+1,npeep[ns+3].operand) then begin
                                    operand := npeep[ns+3].operand;
                                    npeep[ns+1].operand := npeep[ns+3].operand;
                                    npeep[ns+1].opcode := m_bpl;
                                    Remove(ns+3);
                                    end; {if}

         m_dec_abs:
            if npeep[ns+1].opcode = m_lda_abs then
               if name^ = npeep[ns+1].name^ then
                  if npeep[ns+2].opcode = m_beq then
                     Remove(ns+1);

         m_lda_abs:
            if npeep[ns+1].opcode = m_clc then begin
               if npeep[ns+2].opcode = m_adc_abs then
                  if operand = npeep[ns+2].operand then
                     if name = npeep[ns+2].name then
                        if not rangeCheck then begin
                           npeep[ns+1].opcode := m_asl_a;
                           Remove(ns+2);
                           end; {if}
               end {if}
            else if npeep[ns+1].opcode = m_dea then begin
               if npeep[ns+2].opcode = m_tax then begin
                  opcode := m_ldx_abs;
                  npeep[ns+1].opcode := m_dex;
                  Remove(ns+2);
                  end; {if}
               end {else if}
            else if npeep[ns+2].opcode = m_sta_abs then begin
               if npeep[ns+1].opcode in [m_ora_dir,m_ora_abs,m_ora_dirX,
                  m_ora_imm,m_ora_longX,m_ora_s] then
                  if operand = npeep[ns+2].operand then
                     if name = npeep[ns+2].name then begin
                        npeep[ns+1].opcode := npeep[ns+1].opcode + $00A0;
                        npeep[ns+2].opcode := m_tsb_abs;
                        Remove(ns);
                        end; {if}
               end {else if}
            else if SignExtension(ns+1) then begin
               npeep[ns+2] := npeep[ns];
               Remove(ns);
               end {else if}
            else if npeep[ns+1].opcode = m_xba then
               if npeep[ns+2].opcode = m_and_imm then
                  if npeep[ns+2].operand = $00FF then begin
                     operand := operand+1;
                     Remove(ns+1);
                     end; {if}
                
         m_lda_dir:
            if npeep[ns+1].opcode = m_clc then begin
               if npeep[ns+2].opcode = m_adc_dir then
                  if operand = npeep[ns+2].operand then
                     if not rangeCheck then begin
                        npeep[ns+1].opcode := m_asl_a;
                        Remove(ns+2);
                        end; {if}
               end
            else if npeep[ns+1].opcode = m_dea then begin
               if npeep[ns+2].opcode = m_tax then begin
                  opcode := m_ldx_dir;
                  npeep[ns+1].opcode := m_dex;
                  Remove(ns+2);
                  end; {if}
               end {else if}
            else if npeep[ns+1].opcode = m_pha then begin
               if longA then begin
                  opcode := m_pei_dir;
                  Remove(ns+1);
                  end {if}
               end {else if}
            else if npeep[ns+2].opcode = m_sta_dir then begin
               if npeep[ns+1].opcode in [m_ora_dir,m_ora_abs,m_ora_dirX,
                  m_ora_imm,m_ora_longX,m_ora_s] then
                  if operand = npeep[ns+2].operand then begin
                     npeep[ns+1].opcode := npeep[ns+1].opcode + $00A0;
                     npeep[ns+2].opcode := m_tsb_dir;
                     Remove(ns);
                     end {if}
               end {else if}
            else if SignExtension(ns+1) then begin
               npeep[ns+2] := npeep[ns];
               Remove(ns);
               end {else if}
            else if npeep[ns+1].opcode = m_xba then
               if npeep[ns+2].opcode = m_and_imm then
                  if npeep[ns+2].operand = $00FF then begin
                     operand := operand+1;
                     Remove(ns+1);
                     end; {if}
                              
         m_pei_dir:
            if npeep[ns+1].opcode = m_pla then begin
               opcode := m_lda_dir;
               Remove(ns+1);
               end; {if}

         m_lda_imm:
            if npeep[ns+1].opcode = m_pha then
               if ASafe(ns+2) then
                  if longA then begin
                     opcode := m_pea;
                     Remove(ns+1);
                     end; {if}

         m_ldx_imm:
            if npeep[ns+1].opcode = m_lda_imm then
               if npeep[ns+2].opcode = m_phx then
                  if npeep[ns+3].opcode = m_pha then begin
                     opcode := m_pea;
                     npeep[ns+1].opcode := m_pea;
                     Remove(ns+2);
                     Remove(ns+2);
                     end; {if}

         m_ldy_imm:
            if npeep[ns+1].opcode = m_sep then
               if npeep[ns+1].operand = 32 then begin
                  didOne := true;
                  tn := npeep[ns];
                  npeep[ns] := npeep[ns+1];
                  npeep[ns+1] := tn;
                  end; {if}

         m_ora_abs:     
            if npeep[ns+1].opcode = m_sta_abs then
               if operand = npeep[ns+1].operand then
                  if name = npeep[ns+1].name then begin
                     opcode := m_tsb_abs;
                     Remove(ns+1);
                     end; {if}

         m_ora_dir:     
            if npeep[ns+1].opcode = m_sta_dir then
               if operand = npeep[ns+1].operand then begin
                  opcode := m_tsb_dir;
                  Remove(ns+1);
                  end; {if}

         m_pea:     
            if npeep[ns+1].opcode = m_pla then begin
               opcode := m_lda_imm;
               Remove(ns+1);
               end; {if}

         m_sta_abs:     
            if npeep[ns+1].opcode = m_lda_abs then
               if operand = npeep[ns+1].operand then
                  if name = npeep[ns+1].name then
                     if not (npeep[ns+2].opcode in
                        [m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then
                        Remove(ns+1);

         m_sta_dir:
            if npeep[ns+1].opcode = m_lda_dir then
               if operand = npeep[ns+1].operand then
                  if not (npeep[ns+2].opcode in
                     [m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then
                     Remove(ns+1);

         m_plb:
            if npeep[ns+1].opcode = m_phb then begin
               Remove(ns);
               Remove(ns);
               end; {if}

         m_plx:
            if npeep[ns+1].opcode = m_pha then begin
               opcode := m_sta_s;
               mode := direct;
               operand := 1;
               Remove(ns+1);
               end; {if}

         m_tax:
            if npeep[ns+1].opcode = m_phx then begin
               Remove(ns+1);
               opcode := m_pha;
               end {if}
            else if npeep[ns+1].opcode = m_txa then begin
               if not (npeep[ns+2].opcode in
                  [m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then begin
                  Remove(ns);
                  Remove(ns);
                  end; {if}
               end {else if}
            else if npeep[ns+1].opcode = m_dey then
               if npeep[ns+2].opcode = m_dey then
                  if npeep[ns+3].opcode = m_lda_indly then
                     if npeep[ns+4].opcode = m_stx_dir then begin
                        npeep[ns] := npeep[ns+4];
                        opcode := m_sta_dir;
                        Remove(ns+4);
                        end; {if}

         m_tya:
            if npeep[ns+1].opcode = m_sta_dir then begin
               npeep[ns+1].opcode := m_sty_dir;
               Remove(ns);
               end {if}
            else if npeep[ns+1].opcode = m_sta_abs then begin
               npeep[ns+1].opcode := m_sty_abs;
               Remove(ns);
               end; {else if}

         m_tyx:
            if npeep[ns+1].opcode = m_phx then begin
               Remove(ns+1);
               opcode := m_phy;
               end; {if}

         m_pha:
            if npeep[ns+1].opcode = m_pla then begin
               Remove(ns);
               Remove(ns);
               end {if}
            else if npeep[ns+1].opcode in [m_ldx_abs,m_ldx_dir] then
               if npeep[ns+2].opcode = m_pla then begin
                  Remove(ns+2);
                  Remove(ns);
                  end; {if}

         m_phy:
            if npeep[ns+1].opcode = m_ply then begin
               Remove(ns);
               Remove(ns);
               end; {if}

         m_rep:
            if npeep[ns+1].opcode = m_sep then
               if npeep[ns].operand = npeep[ns+1].operand then begin
        	  Remove(ns);
        	  Remove(ns);
        	  end; {if}

         otherwise: ;

         end; {case}
1:
  end; {Optimize}

begin {GenNative}
{ writeln('GenNative: ',p_opcode:4, ', mode=', ord(p_mode):1,
   ' operand=', p_operand:1);      {debug}
if npeephole then begin
   if (nnextspot = 1) and not (p_opcode in nleadOpcodes) then begin
      if p_opcode <> d_end then
         if registers then
            CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags)
         else
            WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
      end {if}
   else if p_opcode in nstopOpcodes then begin
      repeat
         didOne := false;
         i := 1;
         llongA := longA;
         while i < nnextSpot-nMaxPeep do begin
            op := npeep[i].opcode;
            if op = m_sep then begin
               if npeep[i].operand & $20 <> 0 then
                  llongA := false;
               end {if}
            else if op = m_rep then begin
               if npeep[i].operand & $20 <> 0 then
                  llongA := true;
               end; {else}
            Optimize(i,llongA);
            i := i+1;
            end; {while}
      until not didone;
      Purge;
      if p_opcode <> d_end then
         if registers then
            CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags)
         else
            WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
      end {else if}
   else if nnextSpot = npeepSize then begin
      repeat
         didOne := false;
         i := 1;
         llongA := longA;
         while i < nnextSpot-nMaxPeep do begin
            op := npeep[i].opcode;
            if op = m_sep then begin
               if npeep[i].operand & $20 <> 0 then
               llongA := false;
               end {if}
            else if op = m_rep then begin
               if npeep[i].operand & $20 <> 0 then
               llongA := true;
               end; {else}
            Optimize(i,llongA);
            i := i+1;
            end; {while}
      until not didone;
      done := false;
      repeat
         if nnextSpot = 1 then
            done := true
         else begin
            if npeep[1].opcode in nleadOpcodes then
               done := true
            else begin
               if registers then
                  CheckRegisters(nPeep[1].opcode, nPeep[1].mode,
                     nPeep[1].operand, nPeep[1].name, nPeep[1].flags)
               else
                  WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
                     nPeep[1].name,nPeep[1].flags);
               Remove(1);
               end; {else}
            end; {else}
      until done;
      if nnextSpot = nPeepSize then begin
         if registers then
            CheckRegisters(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
               nPeep[1].name, nPeep[1].flags)
         else
            WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
               nPeep[1].name, nPeep[1].flags);
         Remove(1);
         end; {if}
      with npeep[nnextSpot] do begin
         opcode := p_opcode;
         mode := p_mode;
         operand := p_operand;
         name := p_name;
         flags := p_flags;
         end; {with}
      nnextSpot := nnextSpot+1;
      if not (npeep[1].opcode in nleadOpcodes) then begin
         if registers then
            CheckRegisters(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
               nPeep[1].name, nPeep[1].flags)
         else
            WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
               nPeep[1].name, nPeep[1].flags);
         Remove(1);
         end; {if}
      end {else if}
   else begin
      with npeep[nnextSpot] do begin
         opcode := p_opcode;
         mode := p_mode;
         operand := p_operand;
         name := p_name;
         flags := p_flags;
         end; {with}
      nnextSpot := nnextSpot+1;
      end; {else}
   end {if}
else if p_opcode <> d_end then
   if registers then
      CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags)
   else
      WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
end; {GenNative}


procedure GenImplied {p_opcode: integer};

{ short form of GenNative - reduces code size                   }
{                                                               }
{ parameters:                                                   }
{       p_code - operation code                                 }

begin {GenImplied}
GenNative(p_opcode, implied, 0, nil, 0);
end; {GenImplied}


procedure GenCall {callNum: integer};

{ short form of jsl to library subroutine - reduces code size   }
{                                                               }
{ parameters:                                                   }
{       callNum - subroutine # to generate a call for           }

var
   sp: pStringPtr;                       {work string}

begin {GenCall}
case callNum of
      1: sp := @'~GET';
      2: sp := @'~PUT';
      3: sp := @'~OPEN';
      4: sp := @'~CLOSE';
      5: sp := @'~READINT';
      6: sp := @'~READREAL';
      7: sp := @'~READCHAR';
      8: sp := @'~WRITECHAR';
      9: sp := @'~WRITEINTEGER';
     10: sp := @'~WRITEREAL';
     11: sp := @'~PNEW';
     12: sp := @'~XJPERROR';
     13: sp := @'~READLN';
     14: sp := @'~WRITELINE';
     15: sp := @'~PAGE';
     16: sp := @'~INTTOSET';
     17: sp := @'~DISPOSE';
     18: sp := @'~LOADDOUBLE';
     19: sp := @'~PUTSP';
     20: sp := @'~PUTB';
     21: sp := @'~PUT2';
     22: sp := @'~PUTC';
     23: sp := @'~SAVEREAL';
     24: sp := @'~SAVESET';
     25: sp := @'~LOADREAL';
     26: sp := @'~WRITELINESO';
     27: sp := @'~WRITELINEEO';
     28: sp := @'~LOADSET';
     29: sp := @'~CNN';
     30: sp := @'~SETEQU';
     31: sp := @'~EQUE';
     32: sp := @'~MUL2';
     33: sp := @'~CHECK';
     34: sp := @'~CHECKPTR';
     35: sp := @'~CLEARMEM';
     36: sp := @'~CNVINTREAL';
     37: sp := @'~CNVREALINT';
     38: sp := @'~SETDIFFERENCE';
     39: sp := @'~SETINTERSECTION';
     40: sp := @'~SETUNION';
     41: sp := @'~DIV2';
     42: sp := @'~SETIN';
     43: sp := @'~MUL2';
     44: sp := @'~SEEK';
     45: sp := @'~WRITESTRING';
     46: sp := @'~PUTBOOLEAN';
     47: sp := @'~PRODOS';
     48: sp := @'~EOF';
     49: sp := @'~EOLN';
     50: sp := @'~ADDE';
     51: sp := @'~DIVE';
     52: sp := @'~MULE';
     53: sp := @'~SUBE';
     54: sp := @'~SQRE';
     55: sp := @'~SQTE';
     58: sp := @'~READCHARINPUT';
     59: sp := @'~READINTINPUT';
     60: sp := @'~READLNINPUT';
     61: sp := @'~READREALINPUT';
     62: sp := @'~WRITEREALOUTPUT';
     63: sp := @'~SINE';
     64: sp := @'~COSE';
     65: sp := @'~ATNE';
     66: sp := @'~LOGE';
     67: sp := @'~EXPE';
     68: sp := @'~ROUND';
     69: sp := @'~EQUSTRING';
     70: sp := @'~GRTE';
     71: sp := @'~GEQE';
     72: sp := @'~GRTSTRING';
     73: sp := @'~GEQSTRING';
     74: sp := @'~SETINCLUSION';
     75: sp := @'~SETLINENUMBER';
     76: sp := @'~SETNAME';
     77: sp := @'~RESETNAME';
     78: sp := @'~SETSIZE';
     79: sp := @'~READSTRINGINPUT';
     80: sp := @'~MOVE';
     81: sp := @'~REALRET2';
     82: sp := @'~REALFN';
     83: sp := @'~REALFIX';
     84: sp := @'~DOUBLERET2';
     85: sp := @'~DOUBLEFN';
     86: sp := @'~DOUBLEFIX';
     87: sp := @'~SAVEDOUBLE';
     88: sp := @'~SHIFTLEFT';
     89: sp := @'~SSHIFTRIGHT';
     90: sp := @'~POWER';
     91: sp := @'~HALT';
     92: sp := @'~PSEED';
     93: sp := @'~DELETE';
     94: sp := @'~INSERT';
     95: sp := @'~SHELLID';
     96: sp := @'~READCMDLINE';
     97: sp := @'~STARTGRAPH';
     98: sp := @'~STARTDESK';
     99: sp := @'~ENDGRAPH';
    100: sp := @'~ENDDESK';
    101: sp := @'~ORD4';
    102: sp := @'~CNVES';
    103: sp := @'~CNVIS';
    104: sp := @'~CNVSE';
    105: sp := @'~CNVSI';
    106: sp := @'~CNVSL';
    107: sp := @'~RANDOME';
    108: sp := @'~RANDOMI';
    109: sp := @'~READSTRING';
    110: sp := @'~CONCAT';
    111: sp := @'~COPY';
    112: sp := @'~LENGTH';
    113: sp := @'~POS';
{   114: sp := @'~USER_ID';  }
    115: sp := @'~CNV42';
    116: sp := @'~MOVESTRING';
    117: sp := @'~DISPOSESTRHEAP';
    118: sp := @'~CNVLS';
    120: sp := @'~TANE';
    121: sp := @'~ARCCOSE';
    122: sp := @'~ARCSINE';
    123: sp := @'~ARCTAN2E';
    124: sp := @'~MOD2';
    125: sp := @'~PACK2';
    126: sp := @'~UNPACK2';
    127: sp := @'~MAKESET';
    128: sp := @'~WRITEREALEO';
    129: sp := @'~CHECKSTACK';
    130: sp := @'~SETINA';
    131: sp := @'~NEWOPENREC';
    132: sp := @'~DISPOSEOPENREC';
    133: sp := @'~MUL4';
    134: sp := @'~PDIV4';
    135: sp := @'~PMOD4';
    136: sp := @'~SHL4';
    137: sp := @'~SHR4';
    138: sp := @'~GRTL';
    139: sp := @'~GEQL';
    140: sp := @'~READLONGINPUT';
    141: sp := @'~READLONG';
    142: sp := @'~UMUL2';
    143: sp := @'~PUT4';
    144: sp := @'~WRITELONG';
    145: sp := @'~CNVLE';
    146: sp := @'~CNVL2';
    147: sp := @'~INTCHK';
    148: sp := @'~REDIRECT';
    149: sp := @'~ROUND4';
    150: sp := @'~CNVREALLONG';
    151: sp := @'SYSCHAROUT';
    152: sp := @'SYSCHARERROUT';
    153: sp := @'~WRITESTRINGSO';
    154: sp := @'~WRITESTRINGEO';
    155: sp := @'~WRITELNSTRINGSO';
    156: sp := @'~WRITELNSTRINGEO';
    157: sp := @'~SAVECOMP';
    158: sp := @'~SAVEEXTENDED';
    159: sp := @'~COPYREAL';
    160: sp := @'~COPYDOUBLE';
    161: sp := @'~COPYCOMP';
    162: sp := @'~COPYEXTENDED';
    163: sp := @'~LOADCOMP';
    164: sp := @'~LOADEXTENDED';
    165: sp := @'~UDIV2';
    166: sp := @'~CNVLONGREAL';
    167: sp := @'~MOVE2';
    168: sp := @'~LONGMOVE';
    169: sp := @'~LONGMOVE2';
    170: sp := @'~LSHR4';
    171: sp := @'~ASHR4';
    172: sp := @'~UMUL4';
    173: sp := @'~UDIV4';
    174: sp := @'~UMOD4';
    175: sp := @'~USHIFTRIGHT';
    176: sp := @'~EXTENDEDRET2';
    177: sp := @'~COMPRET2';
    178: sp := @'~COMPFIX';
    179: sp := @'~CHECKLONG';
    180: sp := @'~PNEW4';
    181: sp := @'~MEMBER';
    182: sp := @'~NEWOBJECT';
    183: sp := @'~STRINGPSIZE';
    184: sp := @'~STRINGCSIZE';
    185: sp := @'~EOFSTDIN';
    186: sp := @'~EOLNSTDIN';
   otherwise:      
      Error(cge1);
   end; {case}
GenNative(m_jsl, longabs, 0, sp, 0);
end; {GenCall}


procedure InitFile {keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean};

{ Set up the object file					}
{                                                               }
{ parameters:							}
{    keepName - name of the output file				}
{    keepFlag - keep status:					}
{       0 - don't keep the output				}
{       1 - create a new object module				}
{       2 - a .root already exists				}
{       3 - at least on .letter file exists			}
{    partial - is this a partial compile?			}
{								}
{ Note: Declared as extern in CGI.pas				}


   procedure RootFile;

   { Create and write the initial entry segment                 }

   const
      dispToOpen     =     21;          {disps to glue routines for NDAs}
      dispToClose    =     38;
      dispToAction   =     50;
      dispToInit     =     65;
      dispToCDAOpen  =     9;           {disps to glue routines for CDAs}
      dispToCDAClose =     36;

   var
      i: integer;                       {loop index}
      lab: pStringPtr;			{for holdling names var pointers}
      menuLen: integer;                 {length of the menu name string}


      procedure SetDataBank;

      { set up the data bank register                           }

      begin {SetDataBank}
      CnOut(m_pea);
      RefName(@'~GLOBALS', 0, 2, -8);
      CnOut(m_plb);
      CnOut(m_plb);
      end; {SetDataBank}


   begin {RootFile}
   {open the initial object module}
   fname2.theString.theString := concat(fname1.theString.theString, '.root');
   fname2.theString.size := length(fname2.theString.theString);
   OpenObj(fname2);
   
   {write the header}
   Header(@'~_ROOT', $4000, 0);
   
   {new desk accessory initialization}
   if isNewDeskAcc then begin

      {set up the initial jump table}
      lab := @'~_ROOT';
      menuLen := length(menuLine);
      RefName(lab, menuLen + dispToOpen, 4, 0);
      RefName(lab, menuLen + dispToClose, 4, 0);
      RefName(lab, menuLen + dispToAction, 4, 0);
      RefName(lab, menuLen + dispToInit, 4, 0);
      CnOut2(refreshPeriod);
      CnOut2(eventMask);
      for i := 1 to menuLen do
         CnOut(ord(menuLine[i]));
      CnOut(0);

      {glue code for calling open routine}
      CnOut(m_phb);
      SetDataBank;
      CnOut(m_jsl);
      RefName(openName, 0, 3, 0);
      CnOut(m_plb);
      CnOut(m_sta_s); CnOut(4);
      CnOut(m_txa);
      CnOut(m_sta_s); CnOut(6);
      CnOut(m_rtl);

      {glue code for calling close routine}
      CnOut(m_phb);
      SetDataBank;
      CnOut(m_jsl);
      RefName(closeName, 0, 3, 0);
      CnOut(m_plb);
      CnOut(m_rtl);

      {glue code for calling action routine}
      CnOut(m_phb);
      SetDataBank;
      CnOut(m_pha);
      CnOut(m_phy);
      CnOut(m_phx);
      CnOut(m_jsl);
      RefName(actionName, 0, 3, 0);
      CnOut(m_plb);
      CnOut(m_rtl);

      {glue code for calling init routine}
      CnOut(m_pha);
      CnOut(m_jsl);
      RefName(@'~DAID', 0, 3, 0);
      CnOut(m_phb);
      SetDataBank;
      CnOut(m_pha);
      CnOut(m_jsl);
      RefName(initName, 0, 3, 0);
      CnOut(m_plb);
      CnOut(m_rtl);
      end

   {classic desk accessory initialization}
   else if isClassicDeskAcc then begin

      {write the name}
      menuLen := length(menuLine);
      CnOut(menuLen);
      for i := 1 to menuLen do
         CnOut(ord(menuLine[i]));

      {set up the initial jump table}
      lab := @'~_ROOT';
      RefName(lab, menuLen + dispToCDAOpen, 4, 0);
      RefName(lab, menuLen + dispToCDAClose, 4, 0);

      {glue code for calling open routine}
      CnOut(m_pea);
      CnOut2(1);
      CnOut(m_jsl);
      RefName(@'~DAID', 0, 3, 0);
      CnOut(m_phb);
      SetDataBank;
      CnOut(m_jsl);
      RefName(@'~CDASTART', 0, 3, 0);
      CnOut(m_jsl);
      RefName(openName,0,3,0);
      CnOut(m_jsl);
      RefName(@'~CDASHUTDOWN', 0, 3, 0);
      CnOut(m_plb);
      CnOut(m_rtl);

      {glue code for calling close routine}
      CnOut(m_phb);
      SetDataBank;
      CnOut(m_jsl);
      RefName(closeName, 0, 3, 0);
      CnOut(m_pea);
      CnOut2(0);
      CnOut(m_jsl);
      RefName(@'~DAID', 0, 3, 0);
      CnOut(m_plb);
      CnOut(m_rtl);
      end

   {control panel device initialization}
   else if isCDev then begin
      CnOut(m_pea);
      CnOut2(1);
      CnOut(m_jsl);
      RefName(@'~DAID', 0, 3, 0);
      CnOut(m_phb);
      SetDataBank;
      CnOut(m_pla);
      CnOut(m_sta_s); CnOut(13);
      CnOut(m_pla);
      CnOut(m_sta_s); CnOut(13);
      CnOut(m_jsl);
      RefName(openName,0,3,0);
      CnOut(m_tay);
      CnOut(m_lda_s); CnOut(3);
      CnOut(m_pha);
      CnOut(m_lda_s); CnOut(3);
      CnOut(m_pha);
      CnOut(m_txa);
      CnOut(m_sta_s); CnOut(7);
      CnOut(m_tya);
      CnOut(m_sta_s); CnOut(5);
      CnOut(m_plb);
      CnOut(m_rtl);
      end

   {NBA initialization}
   else if isNBA then begin
      CnOut(m_jsl);
      RefName(@'~NBASTARTUP', 0, 3, 0);
      CnOut(m_phx);
      CnOut(m_phy);
      CnOut(m_jsl);
      RefName(openName,0,3,0);
      CnOut(m_jsl);
      RefName(@'~NBASHUTDOWN', 0, 3, 0);
      CnOut(m_rtl);
      end

   {XCMD initialization}
   else if isXCMD then begin
      CnOut(m_jsl);
      RefName(@'~XCMDSTARTUP', 0, 3, 0);
      CnOut(m_jsl);
      RefName(openName,0,3,0);
      CnOut(m_jsl);
      RefName(@'~XCMDSHUTDOWN', 0, 3, 0);
      CnOut(m_rtl);
      end

   {normal program initialization}
   else begin

      {write the initial JSL}
      CnOut(m_jsl);
      if rtl then
         RefName(@'~_BWSTARTUP4', 0, 3, 0)
      else
         RefName(@'~_BWSTARTUP3', 0, 3, 0);

      {set the data bank register}
      SetDataBank;

      {write JSL to main entry point}
      CnOut(m_jsl);
      RefName(@'~_PASMAIN', 0, 3, 0);

      {return to the shell}
      CnOut(m_lda_imm); CnOut2(0);
      CnOut(m_jml);
      if rtl then 
	 RefName(@'~RTL', 0, 3, 0)
      else
	 RefName(@'~QUIT', 0, 3, 0);
      end;

   {finish the current segment}
   EndSeg;
   end; {RootFile}


   procedure SetStack;

   { Set up a stack frame					}

   begin {SetStack}
   if stackSize <> 0 then begin
      currentSegment := '~_STACK   ';	{write the header}
      Header(@'~_STACK', $4012, 0);
      currentSegment := defaultSegment;
      Out($F1);				{write the DS record to reserve space}
      Out2(stackSize);
      Out2(0);
      EndSeg;				{finish the current segment}
      end; {if}
   end; {SetStack}


begin {InitFile}
fname1 := keepname^;
if partial or (keepFlag = 3) then
   FindSuffix(fname1, nextSuffix)
else begin
   if (keepFlag = 1) and (not doingunit) then begin
       RootFile;
       SetStack;
       CloseObj;
       end; {if}
   DestroySuffixes(fname1);
   nextSuffix := 'a';
   end; {else}
fname2.theString.theString := concat(fname1.theString.theString, '.', nextSuffix);
fname2.theString.size := length(fname2.theString.theString);
OpenObj(fname2);
end; {InitFile}  


procedure InitNative; 

{ set up for a new segment					}

begin {InitNative}
aRegister.condition := regUnknown;	{set up the peephole optimizer}
xRegister.condition := regUnknown;
yRegister.condition := regUnknown;
nnextspot := 1;
nleadOpcodes := [m_asl_a,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_brl,m_bvs,m_bcc,
   m_dec_abs,m_lda_abs,m_lda_dir,m_lda_imm,m_ldx_imm,m_sta_abs,m_sta_dir,
   m_pha,m_plb,m_plx,m_tax,m_tya,m_tyx,m_phy,m_pei_dir,m_ldy_imm,m_rep,
   m_ora_dir,m_ora_abs,m_and_imm,m_pea];
nstopOpcodes := [d_end,d_pin];

stringSize := 0;			{initialize scalars for a new segment}
pc := 0;
cbufflen := 0;
longA := true;
longI := true;
end; {InitNative}


procedure GenLab {lnum: integer};

{ generate a label                                              }
{                                                               }
{ parameters:                                                   }
{       lnum - label number                                     }

begin {GenLab}
GenNative(d_lab, gnrlabel, lnum, nil, 0);
end; {GenLab}


procedure LabelSearch {lab: integer; len, shift, disp: integer};

{ resolve a label reference                                     }
{                                                               }
{ parameters:                                                   }
{       lab - label number                                      }
{       len - # bytes for the generated code                    }
{       shift - shift factor                                    }
{       disp - disp past the label                              }
{                                                               }
{ Note 1: maxlabel is reserved for use as the start of the      }
{       string space                                            }
{ Note 2: negative length indicates relative branch             }
{ Note 3: zero length indicates 2 byte addr -1                  }

var
   next: labelptr;                      {work pointer}

begin {LabelSearch}
if labeltab[lab].defined and (len < 0) and (shift = 0) and (disp = 0) then begin

   {handle a relative branch to a known disp}
   if len = -1 then
      CnOut(labeltab[lab].ival - long(pc).lsw - cbufflen + len)
   else
      CnOut2(labeltab[lab].ival - long(pc).lsw - cbufflen + len);
   end {if}
else begin
   if lab <> maxlabel then begin

      {handle a normal label reference}
      Purge;                            {empty the constant buffer}
      if len < 0 then begin
         len := -len;                   {generate a RELEXPR}
         Out(238);
         Out(len);
         Out2(len); Out2(0);
         end {if}
      else begin
         if isJSL then                  {generate a standard EXPR}
            Out(243)
         else
            Out(235);
         if len = 0 then
            Out(2)
         else
            Out(len);
         end; {else}
      end; {if}
   Out(135);                            {generate a relative offset from the seg. start}
   if not labeltab[lab].defined then begin
      next := pointer(Malloc(sizeof(labelEntry))); {value unknown: create a reference}
      next^.next := labeltab[lab].chain;
      labeltab[lab].chain := next;
      next^.addr := blkcnt;
      Out2(0);
      Out2(0);
      end {if}
   else {labeltab[lab].defined} begin
      Out2(labeltab[lab].ival);         {value known: write it}
      Out2(labeltab[lab].hval);
      end; {else}
   if len = 0 then begin
      Out(129);                         {subtract 1 from addr}
      Out2(1); Out2(0);
      Out(2);
      len := 2;
      end; {if}
   if disp <> 0 then begin
      Out(129);                         {add in the displacement}
      Out2(disp);
      if disp < 0 then
         Out2(-1)
      else
         Out2(0);
      Out(1);
      end; {if}
   if shift <> 0 then begin
      Out(129);                         {shift the address}
      Out2(-shift); Out2(-1);
      Out(7);
      end; {if}
   if lab <> maxlabel then              {if not a string, end the expression}
      Out(0);
   pc := pc+len;                        {update the pc}
   end; {else}
end; {LabelSearch}


procedure RefName {lab: pStringPtr; disp, len, shift: integer};

{ handle a reference to a named label                           }
{                                                               }
{ parameters:                                                   }
{       lab - label name                                        }
{       disp - displacement past the label                      }
{       len - number of bytes in the reference                  }
{       shift - shift factor                                    }

var
   i: integer;                          {loop var}
   slen: integer;                       {length of string}

begin {RefName}
Purge;                                  {clear any constant bytes}
if isJSL then                           {expression header}
   Out(243)
else
   Out(235);
Out(len);
Out(131);
pc := pc+len;
slen := length(lab^);
Out(slen);
for i := 1 to slen do
   Out(ord(lab^[i]));
if disp <> 0 then begin                 {if there is a disp, add it in}
   Out(129);
   Out2(disp);
   Out2(0);
   Out(1);
   end; {end}
if shift <> 0 then begin                {if there is a shift, add it in}
   Out(129);
   Out2(shift);
   if shift < 0 then
      Out2(-1)
   else
      Out2(0);
   Out(7);
   end; {if}
Out(0);                                 {end of expression}
end; {RefName}

end.

{$append 'Native.asm'}
\ No newline at end of file
+{$optimize -1}
+{---------------------------------------------------------------}
+{                                                               }
+{  ORCA Native Code Generation                                  }
+{                                                               }
+{  This module of the code generator is called to generate      }
+{  native code instructions.  The native code is optimized      }
+{  and written to the object segment.                           }
+{                                                               }
+{  Externally available procedures:                             }
+{                                                               }
+{  EndSeg - close out the current segment                       }
+{  GenNative - write a native code instruction to the output    }
+{       file                                                    }
+{  GenImplied - short form of GenNative - reduces code size     }
+{  GenCall - short form of jsl to library subroutine - reduces  }
+{       code size                                               }
+{  GenLab - generate a label                                    }
+{  InitFile - Set up the object file				}
+{  InitNative - set up for a new segment			}
+{  RefName - handle a reference to a named label                }
+{                                                               }
+{---------------------------------------------------------------}
+
+unit Native;
+
+interface
+
+{$LibPrefix '0/obj/'}
+
+uses PCommon, CGI, CGC, ObjOut;
+
+{$segment 'CodeGen'}
+
+{---------------------------------------------------------------}
+   
+procedure EndSeg;
+
+{ close out the current segment                                 }
+
+
+procedure GenNative (p_opcode: integer; p_mode: addressingMode;
+                     p_operand: integer; p_name: pStringPtr; p_flags: integer);
+
+{ write a native code instruction to the output file            }
+{                                                               }
+{ parameters:                                                   }
+{       p_opcode - native op code                               }
+{       p_mode - addressing mode                                }
+{       p_operand - integer operand                             }
+{       p_name - named operand                                  }
+{       p_flags - operand modifier flags                        }
+
+
+procedure GenImplied (p_opcode: integer);
+
+{ short form of GenNative - reduces code size                   }
+{                                                               }
+{ parameters:                                                   }
+{       p_code - operation code                                 }
+
+
+procedure GenCall (callNum: integer);
+
+{ short form of jsl to library subroutine - reduces code size   }
+{                                                               }
+{ parameters:                                                   }
+{       callNum - subroutine # to generate a call for           }
+
+
+procedure GenLab (lnum: integer);
+
+{ generate a label                                              }
+{                                                               }
+{ parameters:                                                   }
+{       lnum - label number                                     }
+
+
+procedure InitFile (keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean);
+
+{ Set up the object file					}
+{                                                               }
+{ parameters:							}
+{    keepName - name of the output file				}
+{    keepFlag - keep status:					}
+{       0 - don't keep the output				}
+{       1 - create a new object module				}
+{       2 - a .root already exists				}
+{       3 - at least on .letter file exists			}
+{    partial - is this a partial compile?			}
+{								}
+{ Note: Declared as extern in CGI.pas				}
+
+
+procedure InitNative;
+
+{ set up for a new segment					}
+
+
+procedure LabelSearch (lab: integer; len, shift, disp: integer);
+
+{ resolve a label reference                                     }
+{                                                               }
+{ parameters:                                                   }
+{       lab - label number                                      }
+{       len - # bytes for the generated code                    }
+{       shift - shift factor                                    }
+{       disp - disp past the label                              }
+{                                                               }
+{ Note 1: maxlabel is reserved for use as the start of the      }
+{       string space                                            }
+{ Note 2: negative length indicates relative branch             }
+{ Note 3: zero length indicates 2 byte addr -1                  }
+
+
+procedure RefName (lab: pStringPtr; disp, len, shift: integer);
+
+{ handle a reference to a named label                           }
+{                                                               }
+{ parameters:                                                   }
+{       lab - label name                                        }
+{       disp - displacement past the label                      }
+{       len - number of bytes in the reference                  }
+{       shift - shift factor                                    }
+
+{---------------------------------------------------------------}
+
+implementation
+
+const
+   npeepSize = 128;			{native peephole optimizer window size}
+   nMaxPeep = 4;			{max # instructions needed to opt.}
+
+type
+                                        {65816 native code generation}
+                                        {----------------------------}
+   npeepRange = 1..npeepsize;           {subrange for native code peephole opt.}
+
+   nativeType = record                  {native code instruction}
+      opcode: integer;                  {op code}
+      mode: addressingMode;             {addressing mode}
+      operand: integer;                 {operand value}
+      name: pStringPtr;                  {operand label}
+      flags: integer;                   {modifier flags}
+      end;
+
+   registerConditions = (regUnknown,regImmediate,regAbsolute,regLocal);
+   registerType = record                {used to track register contents}
+      condition: registerConditions;
+      value: integer;
+      lab: pStringPtr;
+      flags: integer;
+      end;
+
+var
+                                        {65816 native code generation}
+                                        {----------------------------}
+   longA,longI: boolean;                {register sizes}
+
+                                        {I/O files}
+                                        {---------}
+   fname1, fname2: gsosOutString;	{file names}
+   nextSuffix: char;                    {next suffix character to use}
+
+                                        {native peephole optimization}
+                                        {----------------------------}
+   aRegister,                           {current register contents}
+      xRegister,
+      yRegister: registerType;
+   didOne: boolean;                     {has an optimization been done?}
+   nleadOpcodes: set of 0..max_opcode;  {instructions that can start an opt.}
+   nstopOpcodes: set of 0..max_opcode;  {instructions not involved in opt.}
+   npeep: array[npeepRange] of nativeType; {native peephole array}
+   nnextspot: npeepRange;               {next empty spot in npeep}
+   
+
+procedure GenSymbols (sym: ptr; doGlobals: integer); extern;
+
+{ generate the symbol table                                     }
+
+{---------------------------------------------------------------}
+
+procedure UpDate (lab: integer; labelValue: longint);
+
+{ define a label						}
+{								}
+{ parameters:							}
+{    lab - label number						}
+{    labelValue - displacement in seg where label is located	}
+
+var
+   next,temp: labelptr;			{work pointers}
+
+begin {UpDate}
+if labeltab[lab].defined then
+   Error(cge1)
+else begin
+
+   {define the label for future references}
+   with labeltab[lab] do begin
+      defined := true;
+      val := labelValue;
+      next := chain;
+      end; {with}
+
+   {resolve any forward references}
+   if next <> nil then begin
+      Purge;
+      while next <> nil do begin
+         segdisp := next^.addr;
+         Out2(long(labelvalue).lsw);
+         Out2(long(labelvalue).msw);
+         blkcnt := blkcnt-4;
+         temp := next;
+         next := next^.next;
+         end; {while}
+      segdisp := blkcnt;
+      end; {if}
+   end; {else}
+end; {UpDate}
+
+
+procedure WriteNative (opcode: integer; mode: addressingMode; operand: integer;
+                      name: pStringPtr; flags: integer);
+
+{ write a native code instruction to the output file            }
+{                                                               }
+{ parameters:                                                   }
+{       opcode - native op code                                 }
+{       mode - addressing mode                                  }
+{       operand - integer operand                               }
+{       name - named operand                                    }
+{       flags - operand modifier flags                          }
+
+label 1;
+
+type
+   rkind = (k1,k2,k3);                  {cnv record types}
+
+var
+   ch: char;                            {temp storage for string constants}
+   cns: realRec;                        {for converting reals to bytes}
+   cnv: record                          {for converting double, real to bytes}
+      case rkind of
+         k1: (rval: real;);
+         k2: (dval: double;);
+         k3: (ival1,ival2,ival3,ival4: integer;);
+      end;
+   count: integer;                      {number of constants to repeat}
+   i,j,k: integer;                      {loop variables}
+   lsegDisp: integer;                   {for backtracking while writting the   }
+                                        { debugger's symbol table              }
+   lval: longint;                       {temp storage for long constant}
+   nptr: pStringPtr;                    {pointer to a name}
+   sptr: pStringPtr;                    {pointer to a string constant}
+
+
+   procedure GenImmediate1;
+
+   { generate a one byte immediate operand                      }
+
+   begin {GenImmediate1}
+   if (flags & stringReference) <> 0 then begin
+      Purge;
+      Out(235); Out(1);                 {one byte expression}
+      Out(128);                         {current location ctr}
+      Out(129); Out2(-16); Out2(-1);    {-16}
+      Out(7);                           {bit shift}
+      Out(0);                           {end of expr}
+      pc := pc+1;
+      end {if}
+   else if (flags & localLab) <> 0 then
+      LabelSearch(long(name).lsw, 1, ord(odd(flags div shift16))*16, operand)
+   else if (flags & shift16) <> 0 then
+      RefName(name, operand, 1, -16)
+   else
+      CnOut(operand);
+   end; {GenImmediate1}
+
+
+   procedure GenImmediate2;
+
+   { generate a two byte immediate operand                      }
+
+   begin {GenImmediate2}
+   if (flags & stringReference) <> 0 then begin
+      Purge;
+      Out(235); Out(2);
+      LabelSearch(maxLabel, 2, 0, 0);
+      if operand <> 0 then begin
+         Out(129);
+         Out2(operand); Out2(0);
+         Out(1);
+         end; {if}
+      if (flags & shift16) <> 0 then begin
+         Out(129);
+         Out2(-16); Out2(-1);
+         Out(7);
+         end; {if}
+      Out(0);
+      end {if}
+   else if (flags & shift8) <> 0 then
+      RefName(name, operand, 2, -8)
+   else if (flags & localLab) <> 0 then
+      LabelSearch(long(name).lsw, 2, ord(odd(flags div shift16))*16, operand)
+   else if (flags & shift16) <> 0 then
+      RefName(name, operand, 2, -16)
+   else if name = nil then
+      CnOut2(operand)
+   else
+      RefName(name, operand, 2, 0);
+   end; {GenImmediate2}
+
+
+   procedure DefGlobal (private: integer);
+
+   { define a global label                                      }
+   {                                                            }
+   { parameters:                                                }
+   {    private - private flag                                  }
+
+   var
+      i: integer;                       {loop variable}
+
+   begin {DefGlobal}
+   Purge;
+   Out(230);                            {global label definition}
+   Out(ord(name^[0]));                  {write label name}
+   for i := 1 to ord(name^[0]) do
+      Out(ord(name^[i]));
+   Out2(0);				{length attribute}
+   Out(ord('N'));                       {type attribute: other directive}
+   Out(private);                        {private or global?}
+   end; {DefGlobal}
+
+
+begin {WriteNative}
+{ writeln('WriteNative: ',opcode:4, ', mode=', ord(mode):1,
+   ' operand=', operand:1);      {debug}
+case mode of
+
+   implied:
+      CnOut(opcode);
+
+   immediate: begin
+      if opcode = d_bmov then
+         GenImmediate1
+      else begin
+         if opcode = m_and_imm then
+            if not longA then
+               if operand = 255 then
+                  goto 1;
+         CnOut(opcode);
+         if opcode = m_pea then
+            GenImmediate2
+         else if opcode in
+            [m_adc_imm,m_and_imm,m_cmp_imm,m_eor_imm,m_lda_imm,m_ora_imm,
+             m_sbc_imm,m_bit_imm] then
+               if longA then
+                 GenImmediate2
+              else
+                 GenImmediate1
+         else if opcode in [m_rep,m_sep,m_cop] then begin
+            GenImmediate1;
+            if opcode = m_rep then begin
+               if odd(operand div 32) then longA := true;
+               if odd(operand div 16) then longI := true;
+               end {if}
+            else if opcode = m_sep then begin
+               if odd(operand div 32) then longA := false;
+               if odd(operand div 16) then longI := false;
+               end; {else}
+            end {else}
+         else
+            if longI then
+               GenImmediate2
+            else
+               GenImmediate1;
+         end; {else}
+      end;
+
+   longabs: begin
+      CnOut(opcode);
+      isJSL := opcode = m_jsl;          {allow for dynamic segs}
+      if name = nil then
+         if odd(flags div toolCall) then begin
+            CnOut2(0);
+            CnOut($E1);
+            end {if}
+         else if odd(flags div userToolCall) then begin
+            CnOut2(8);
+            CnOut($E1);
+            end {else if}
+         else
+            LabelSearch(operand, 3, 0, 0)
+      else
+         RefName(name, operand, 3, 0);
+      isJSL := false;
+      end;
+
+   longabsolute: begin
+      if opcode <> d_add then begin
+         CnOut(opcode);
+         i := 3;
+         end {if}
+      else
+         i := 4;
+      if (flags & localLab) <> 0 then
+         LabelSearch(long(name).lsw, i, 0, operand)
+      else if (flags & constantOpnd) <> 0 then begin
+         lval := ord4(name);
+         CnOut2(long(lval).lsw);
+         if opcode = d_add then
+            CnOut2(long(lval).msw)
+         else
+            CnOut(long(lval).msw);
+         end {else if}
+      else if name <> nil then
+         RefName(name, operand, i, 0)
+      else begin
+         CnOut2(operand);
+         CnOut(0);
+         if opcode = d_add then
+            CnOut(0);
+         end; {else}
+      end;
+
+   absolute: begin
+      if opcode <> d_add then
+         CnOut(opcode);
+      if (flags & localLab) <> 0 then
+         LabelSearch(long(name).lsw, 2, 0, operand)
+      else if name <> nil then
+         RefName(name, operand, 2, 0)
+      else if (flags & constantOpnd) <> 0 then
+         CnOut2(operand)
+      else
+         LabelSearch(operand, 2, 0, 0);
+      end;
+
+   direct: begin
+      if opcode <> d_add then
+         CnOut(opcode);
+      if (flags & localLab) <> 0 then
+         LabelSearch(long(name).lsw, 1, 0, operand)
+      else if name <> nil then
+         RefName(name, operand, 1, 0)
+      else
+         CnOut(operand);
+      end;
+
+   longrelative: begin
+      CnOut(opcode);
+      LabelSearch(operand, -2, 0, 0);
+      end;
+
+   relative: begin
+      CnOut(opcode);
+      LabelSearch(operand, -1, 0, 0);
+      end;
+
+   gnrLabel:
+      if name = nil then
+         UpDate(operand, pc+cbufflen)
+      else begin
+         DefGlobal((flags >> 5) & 1);
+         if operand <> 0 then begin
+            Out(241);
+            Out2(operand);
+            Out2(0);
+            pc := pc+operand;
+            end; {if}
+        end; {else}
+
+   gnrSpace:
+      if operand <> 0 then begin
+         Out(241);
+         Out2(operand);
+         Out2(0);
+         pc := pc+operand;
+         end; {if}
+
+   gnrConstant: begin
+      if icptr(name)^.optype = cgString then
+         count := 1
+      else
+         count := icptr(name)^.q;
+      for i := 1 to count do
+         case icptr(name)^.optype of
+            cgByte,cgUByte      : CnOut(icptr(name)^.r);
+            cgWord,cgUWord      : CnOut2(icptr(name)^.r);
+            cgLong,cgULong      : begin
+                                  lval := icptr(name)^.lval;
+                                  CnOut2(long(lval).lsw);
+                                  CnOut2(long(lval).msw);
+                                  end;
+            cgReal              : begin
+                                  cnv.rval := icptr(name)^.rval;
+                                  CnOut2(cnv.ival1);
+                                  CnOut2(cnv.ival2);
+                                  end;
+            cgDouble            : begin
+                                  cnv.dval := icptr(name)^.rval;
+                                  CnOut2(cnv.ival1);
+                                  CnOut2(cnv.ival2);
+                                  CnOut2(cnv.ival3);
+                                  CnOut2(cnv.ival4);
+                                  end;
+            cgString            : begin
+                                  sptr := icptr(name)^.str;
+                                  for j := 1 to length(sptr^) do
+                                     CnOut(ord(sPtr^[j]));
+                                  end;
+            otherwise           : Error(cge1);
+            end; {case}
+      end;
+
+   genAddress: begin
+      if opcode < 256 then
+         CnOut(opcode);
+      if (flags & stringReference) <> 0 then begin
+         Purge;
+         Out(235);
+         Out(2);
+         LabelSearch(maxLabel,2,0,0);
+         if operand <> 0 then begin
+            Out(129);
+            Out2(operand);
+            Out2(0);
+            Out(1);
+            end; {if}
+         if (flags & shift16) <> 0 then begin
+            Out(129);
+            Out2(-16);
+            Out2(-1);
+            Out(7);
+            end; {if}
+         Out(0);
+         end {if}
+      else if operand = 0 then begin
+         CnOut(0);
+         CnOut(0);
+         end {else if}
+      else if (flags & shift16) <> 0 then
+         if longA then
+            LabelSearch(operand, 2, 16, 0)
+         else
+            LabelSearch(operand, 1, 16, 0)
+      else if (flags & sub1) <> 0 then
+         LabelSearch(operand, 0, 0, 0)
+      else  
+         LabelSearch(operand, 2, 0, 0);
+      end;
+
+   special:
+      if opcode = d_pin then begin
+         segDisp := 36;
+         out2(long(pc).lsw+cBuffLen);
+         blkCnt := blkCnt-2;
+         segDisp := blkCnt;
+         end {if}
+      else if opcode = d_sym then begin
+         CnOut(m_cop);
+         CnOut(5);
+         Purge;
+         lsegDisp := segDisp+1;
+         CnOut2(0);
+         symLength := 0;
+         GenSymbols(pointer(name), operand);
+         segDisp := lSegDisp;
+         out2(symLength);
+         blkCnt := blkCnt-2;
+         segDisp := blkCnt;
+         end {else if}
+      else {d_wrd}
+         CnOut2(operand);
+
+   otherwise: Error(cge1);
+
+   end; {case}
+1:
+end; {WriteNative}
+
+
+procedure CheckRegisters(p_opcode: integer; p_mode: addressingMode;
+                    p_operand: integer; p_name: pStringPtr; p_flags: integer);
+
+{ write a native code instruction to the output file            }
+{                                                               }
+{ parameters:                                                   }
+{       p_opcode - native op code                               }
+{       p_mode - addressing mode                                }
+{       p_operand - integer operand                             }
+{       p_name - named operand                                  }
+{       p_flags - operand modifier flags                        }
+
+label 1,2;
+
+begin {CheckRegisters}
+case p_opcode of
+   m_adc_abs,m_adc_dir,m_adc_imm,m_adc_s,m_and_abs,m_and_dir,m_and_imm,
+   m_and_s,m_asl_a,m_dea,m_eor_abs,m_eor_dir,m_eor_imm,m_eor_s,m_lda_absx,
+   m_lda_dirx,m_lda_indl,m_lda_indly,m_lda_longx,m_lda_s,m_lsr_a,m_ora_abs,
+   m_ora_dir,m_ora_dirX,m_ora_imm,m_ora_longX,m_ora_s,m_pla,m_sbc_abs,
+   m_sbc_dir,m_sbc_imm,m_sbc_s,m_tdc,m_tsc,m_tsb_dir,m_tsb_abs:
+      aRegister.condition := regUnknown;
+
+   m_ldy_absX,m_ldy_dirX,m_ply:
+      yRegister.condition := regUnknown;
+
+   m_plx:
+      xRegister.condition := regUnknown;
+
+   m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bra,m_brl,m_bvs,m_clc,m_cmp_abs,
+   m_cmp_dir,m_cmp_imm,m_cmp_s,m_cpx_imm,m_jml,m_pha,m_phb,m_phd,
+   m_phx,m_phy,m_plb,m_pld,m_rtl,m_rts,m_sec,m_sta_absX,
+   m_sta_dir,m_sta_dirX,m_sta_indl,m_sta_indlY,m_sta_longX,
+   m_sta_s,m_stx_dir,m_sty_dir,m_sty_dirX,m_stz_abs,m_stz_absX,
+   m_stz_dir,m_stz_dirX,m_tcs,m_tcd,d_add,d_pin,m_pei_dir,m_cpx_abs,
+   m_cpx_dir,m_cmp_dirx,m_php,m_plp,m_cop,d_wrd:   ;
+
+   m_pea: begin
+      if aRegister.condition = regImmediate then
+         if aRegister.value = p_operand then
+            if aRegister.lab = p_name then
+               if aRegister.flags = p_flags then
+        	  if longA then begin
+        	     p_opcode := m_pha;
+        	     p_mode := implied;
+        	     goto 2;
+        	     end; {if}
+      if longI then begin
+	 if xRegister.condition = regImmediate then
+            if xRegister.value = p_operand then
+               if xRegister.lab = p_name then
+        	  if xRegister.flags = p_flags then begin
+        	     p_opcode := m_phx;
+        	     p_mode := implied;
+        	     goto 2;
+        	     end; {if}
+	 if yRegister.condition = regImmediate then
+            if yRegister.value = p_operand then
+               if yRegister.lab = p_name then
+        	  if yRegister.flags = p_flags then begin
+        	     p_opcode := m_phy;
+        	     p_mode := implied;
+        	     goto 2;
+        	     end; {if}
+         end; {if}
+      end;
+
+   m_dec_abs,m_inc_abs,m_sta_abs,m_stx_abs,m_sty_abs,m_sta_long: begin
+      if aRegister.condition = regAbsolute then
+         if aRegister.lab = p_name then
+            if aRegister.value = p_operand then
+               if not (p_opcode in [m_sta_abs,m_sta_long]) then
+                  aRegister.condition := regUnknown;
+      if xRegister.condition = regAbsolute then
+         if xRegister.lab = p_name then
+            if xRegister.value = p_operand then
+               if p_opcode <> m_stx_abs then
+                  xRegister.condition := regUnknown;
+      if yRegister.condition = regAbsolute then
+         if yRegister.lab = p_name then
+            if yRegister.value = p_operand then
+               if p_opcode <> m_sty_abs then
+                  yRegister.condition := regUnknown;
+      end;
+
+   m_dec_dir,m_dec_dirX,m_inc_dir,m_inc_dirX: begin
+      if aRegister.condition = regLocal then
+         if aRegister.value = p_operand then
+            aRegister.condition := regUnknown;
+      if xRegister.condition = regLocal then
+         if xRegister.value = p_operand then
+            xRegister.condition := regUnknown;
+      if yRegister.condition = regLocal then
+         if yRegister.value = p_operand then
+            yRegister.condition := regUnknown;
+      end;
+
+   m_dex:
+      if xRegister.condition = regImmediate then
+         xRegister.value := xRegister.value-1
+      else
+         xRegister.condition := regUnknown;
+
+   m_dey:
+      if yRegister.condition = regImmediate then
+         yRegister.value := yRegister.value-1
+      else
+         yRegister.condition := regUnknown;
+
+   m_ina:
+      if aRegister.condition = regImmediate then
+         aRegister.value := aRegister.value+1
+      else
+         aRegister.condition := regUnknown;
+
+   m_inx:
+      if xRegister.condition = regImmediate then
+         xRegister.value := xRegister.value+1
+      else
+         xRegister.condition := regUnknown;
+
+   m_iny:
+      if yRegister.condition = regImmediate then
+         yRegister.value := yRegister.value+1
+      else
+         yRegister.condition := regUnknown;
+
+   otherwise,
+   m_jsl,m_mvn,m_rep,m_sep,d_lab,d_end,d_bmov,d_cns: begin
+      aRegister.condition := regUnknown;
+      xRegister.condition := regUnknown;
+      yRegister.condition := regUnknown;
+      end;
+
+   m_lda_abs,m_lda_long: begin
+      if (aRegister.condition = regAbsolute) and
+         (aRegister.value = p_operand) and
+         (aRegister.lab = p_name) then
+         goto 1
+      else if longA = longI then begin
+         if (xRegister.condition = regAbsolute) and
+            (xRegister.value = p_operand) and
+            (xRegister.lab = p_name) then begin
+            p_opcode := m_txa;
+            p_mode := implied;
+            aRegister := xRegister;
+            goto 2;
+            end {if}
+         else if (yRegister.condition = regAbsolute) and
+            (yRegister.value = p_operand) and
+            (yRegister.lab = p_name) then begin
+            p_opcode := m_tya;
+            p_mode := implied;
+            aRegister := yRegister;
+            goto 2;
+            end; {else if}
+         end;
+      aRegister.condition := regAbsolute;
+      aRegister.value := p_operand;
+      aRegister.lab := p_name;
+      aRegister.flags := p_flags;
+      end;
+
+   m_lda_dir: begin
+      if (aRegister.condition = regLocal) and
+         (aRegister.value = p_operand) then
+         goto 1
+      else if longA = longI then begin
+         if (xRegister.condition = regLocal) and
+            (xRegister.value = p_operand) then begin
+            p_opcode := m_txa;
+            p_mode := implied;
+            aRegister := xRegister;
+            goto 2;
+            end {if}
+         else if (yRegister.condition = regLocal) and
+            (yRegister.value = p_operand) then begin
+            p_opcode := m_tya;
+            p_mode := implied;
+            aRegister := yRegister;
+            goto 2;
+            end; {else if}
+         end; {else if}
+      aRegister.condition := regLocal;
+      aRegister.value := p_operand;
+      aRegister.flags := p_flags;
+      end;
+
+   m_lda_imm: begin
+      if (aRegister.condition = regImmediate) and
+         (aRegister.value = p_operand) and
+         (aRegister.lab = p_name) and
+         (aRegister.flags = p_flags) then
+         goto 1
+      else if longA = longI then begin
+         if (xRegister.condition = regImmediate) and
+            (xRegister.value = p_operand) and
+            (xRegister.lab = p_name) and
+            (xRegister.flags = p_flags) then begin
+            p_opcode := m_txa;
+            p_mode := implied;
+            aRegister := xRegister;
+            goto 2;
+            end {if}
+         else if (yRegister.condition = regImmediate) and
+            (yRegister.value = p_operand) and
+            (yRegister.lab = p_name) and
+            (yRegister.flags = p_flags) then begin
+            p_opcode := m_tya;
+            p_mode := implied;
+            aRegister := yRegister;
+            goto 2;
+            end; {else if}
+         end; {else if}
+      if (aRegister.condition = regImmediate) and
+         (aRegister.lab = p_name) and
+         (aRegister.flags = p_flags) then
+         if aRegister.value = (p_operand + 1) then begin
+            p_opcode := m_dea;
+            p_mode := implied;
+            aRegister.value := p_operand;
+            goto 2;
+            end {if}   
+         else if aRegister.value = (p_operand - 1) then begin
+            p_opcode := m_ina;
+            p_mode := implied;
+            aRegister.value := p_operand;
+            goto 2;
+            end; {else if}
+      aRegister.condition := regImmediate;
+      aRegister.value := p_operand;
+      aRegister.flags := p_flags;
+      aRegister.lab := p_name;
+      end;
+
+   m_ldx_abs: begin
+      if (xRegister.condition = regAbsolute) and
+         (xRegister.value = p_operand) and
+         (xRegister.lab = p_name) then
+         goto 1
+      else if (aRegister.condition = regAbsolute) and
+         (aRegister.value = p_operand) and
+         (aRegister.lab = p_name) and
+         (longA = longI) then begin
+         p_opcode := m_tax;
+         p_mode := implied;
+         xRegister := aRegister;
+         end {else if}
+      else if (yRegister.condition = regAbsolute) and
+         (yRegister.value = p_operand) and
+         (yRegister.lab = p_name) then begin
+         p_opcode := m_tyx;
+         p_mode := implied;
+         xRegister := yRegister;
+         end {else if}
+      else begin
+         xRegister.condition := regAbsolute;
+         xRegister.value := p_operand;
+         xRegister.lab := p_name;
+         xRegister.flags := p_flags;
+         end; {else}
+      end;
+
+   m_ldx_dir: begin
+      if (xRegister.condition = regLocal) and
+         (xRegister.value = p_operand) then
+         goto 1
+      else if (aRegister.condition = regLocal) and
+         (aRegister.value = p_operand) and
+         (longA = longI) then begin
+         p_opcode := m_tax;
+         p_mode := implied;
+         xRegister := aRegister;
+         end {else if}
+      else if (yRegister.condition = regLocal) and
+         (yRegister.value = p_operand) then begin
+         p_opcode := m_tyx;
+         p_mode := implied;
+         xRegister := yRegister;
+         end {else if}
+      else begin
+         xRegister.condition := regLocal;
+         xRegister.value := p_operand;
+         xRegister.flags := p_flags;
+         end; {else}
+      end;
+
+   m_ldx_imm: begin
+      if (xRegister.condition = regImmediate) and
+         (xRegister.value = p_operand) and
+         (xRegister.lab = p_name) and
+         (xRegister.flags = p_flags) then
+         goto 1
+      else if (aRegister.condition = regImmediate) and
+         (aRegister.value = p_operand) and
+         (longA = longI) and
+         (aRegister.lab = p_name) and
+         (aRegister.flags = p_flags) then begin
+         p_opcode := m_tax;
+         p_mode := implied;
+         xRegister := aRegister;
+         end {else}
+      else if (yRegister.condition = regImmediate) and
+         (yRegister.value = p_operand) and
+         (yRegister.lab = p_name) and
+         (yRegister.flags = p_flags) then begin
+         p_opcode := m_tyx;
+         p_mode := implied;
+         xRegister := yRegister;
+         end {else if}
+      else begin
+	 if (xRegister.condition = regImmediate) and
+            (xRegister.lab = p_name) and
+            (xRegister.flags = p_flags) then
+            if xRegister.value = (p_operand + 1) then begin
+               p_opcode := m_dex;
+               p_mode := implied;
+               xRegister.value := p_operand;
+               goto 2;
+               end {if}   
+            else if xRegister.value = (p_operand - 1) then begin
+               p_opcode := m_inx;
+               p_mode := implied;
+               xRegister.value := p_operand;
+               goto 2;
+               end; {else if}
+         xRegister.condition := regImmediate;
+         xRegister.value := p_operand;
+         xRegister.flags := p_flags;
+         xRegister.lab := p_name;
+         end; {else}
+      end;
+
+   m_ldy_abs: begin
+      if (yRegister.condition = regAbsolute) and
+         (yRegister.value = p_operand) and
+         (yRegister.lab = p_name) then
+         goto 1
+      else if (aRegister.condition = regAbsolute) and
+         (aRegister.value = p_operand) and
+         (aRegister.lab = p_name) and
+         (longA = longI) then begin
+         p_opcode := m_tay;
+         p_mode := implied;
+         yRegister := aRegister;
+         end {else if}
+      else if (xRegister.condition = regAbsolute) and
+         (xRegister.value = p_operand) and
+         (xRegister.lab = p_name) then begin
+         p_opcode := m_txy;
+         p_mode := implied;
+         yRegister := xRegister;
+         end {else if}
+      else begin
+         yRegister.condition := regAbsolute;
+         yRegister.value := p_operand;
+         yRegister.lab := p_name;
+         yRegister.flags := p_flags;
+         end; {else}
+      end;
+
+   m_ldy_dir: begin
+      if (yRegister.condition = regLocal) and
+         (yRegister.value = p_operand) then
+         goto 1
+      else if (aRegister.condition = regLocal) and
+         (aRegister.value = p_operand) and
+         (longA = longI) then begin
+         p_opcode := m_tay;
+         p_mode := implied;
+         yRegister := aRegister;
+         end {else if}
+      else if (xRegister.condition = regLocal) and
+         (xRegister.value = p_operand) then begin
+         p_opcode := m_txy;
+         p_mode := implied;
+         yRegister := xRegister;
+         end {else if}
+      else begin
+         yRegister.condition := regLocal;
+         yRegister.value := p_operand;
+         yRegister.flags := p_flags;
+         end; {else}
+      end;
+
+   m_ldy_imm: begin
+      if (yRegister.condition = regImmediate) and
+         (yRegister.value = p_operand) and
+         (yRegister.lab = p_name) and
+         (yRegister.flags = p_flags) then
+         goto 1
+      else if (aRegister.condition = regImmediate) and
+         (aRegister.value = p_operand) and
+         (aRegister.flags = p_flags) and
+         (aRegister.lab = p_name) and
+         (longA = longI) then begin
+         p_opcode := m_tay;
+         p_mode := implied;
+         yRegister := aRegister;
+         end {else if}
+      else if (xRegister.condition = regImmediate) and
+         (xRegister.value = p_operand) and
+         (xRegister.lab = p_name) and
+         (xRegister.flags = p_flags) then begin
+         p_opcode := m_txy;
+         p_mode := implied;
+         yRegister := xRegister;
+         end {else if}
+      else begin
+	 if (yRegister.condition = regImmediate) and
+            (yRegister.lab = p_name) and
+            (yRegister.flags = p_flags) then
+            if yRegister.value = (p_operand + 1) then begin
+               p_opcode := m_dey;
+               p_mode := implied;
+               yRegister.value := p_operand;
+               goto 2;
+               end {if}   
+            else if yRegister.value = (p_operand - 1) then begin
+               p_opcode := m_iny;
+               p_mode := implied;
+               yRegister.value := p_operand;
+               goto 2;
+               end; {else if}
+         yRegister.condition := regImmediate;                   
+         yRegister.value := p_operand;
+         yRegister.flags := p_flags;
+         yRegister.lab := p_name;
+         end; {else}
+      end;
+
+   m_tax: begin
+      if aRegister.condition <> regUnknown then
+         if aRegister.condition = xRegister.condition then
+            if aRegister.value = xRegister.value then
+               if aRegister.flags = xRegister.flags then
+                  if aRegister.condition <> regAbsolute then
+                     goto 1
+                  else if aRegister.lab = xRegister.lab then
+                     goto 1;
+      xRegister := aRegister;
+      end;
+
+   m_tay: begin
+      if aRegister.condition <> regUnknown then
+         if aRegister.condition = yRegister.condition then
+            if aRegister.value = yRegister.value then
+               if aRegister.flags = yRegister.flags then
+                  if aRegister.condition <> regAbsolute then
+                     goto 1
+                  else if aRegister.lab = yRegister.lab then
+                     goto 1;
+      yRegister := aRegister;
+      end;
+
+   m_txa: begin
+      if xRegister.condition <> regUnknown then
+         if xRegister.condition = aRegister.condition then
+            if xRegister.value = aRegister.value then
+               if xRegister.flags = aRegister.flags then
+                  if xRegister.condition <> regAbsolute then
+                     goto 1
+                  else if xRegister.lab = aRegister.lab then
+                     goto 1;
+      aRegister := xRegister;
+      end;
+
+   m_txy: begin
+      if xRegister.condition <> regUnknown then
+         if xRegister.condition = yRegister.condition then
+            if xRegister.value = yRegister.value then
+               if xRegister.flags = yRegister.flags then
+                  if xRegister.condition <> regAbsolute then
+                     goto 1
+                  else if xRegister.lab = yRegister.lab then
+                     goto 1;
+      yRegister := xRegister;
+      end;
+
+   m_tya: begin
+      if yRegister.condition <> regUnknown then
+         if yRegister.condition = aRegister.condition then
+            if yRegister.value = aRegister.value then
+               if yRegister.flags = aRegister.flags then
+                  if yRegister.condition <> regAbsolute then
+                     goto 1
+                  else if yRegister.lab = aRegister.lab then
+                     goto 1;
+      aRegister := yRegister;
+      end;
+
+   m_tyx: begin
+      if yRegister.condition <> regUnknown then
+         if yRegister.condition = xRegister.condition then
+            if yRegister.value = xRegister.value then
+               if yRegister.flags = xRegister.flags then
+                  if yRegister.condition <> regAbsolute then
+                     goto 1
+                  else if yRegister.lab = xRegister.lab then
+                     goto 1;
+      xRegister := yRegister;
+      end;
+   end; {case}
+2:
+WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
+1:
+end; {CheckRegisters}
+
+
+procedure Remove (ns: integer); extern;
+
+{ Remove the instruction ns from the peephole array             }
+{                                                               }
+{ parameters:                                                   }
+{       ns - index of the instruction to remove                 }
+
+
+function Short (n, lab: integer): boolean; extern;
+
+{ see if a label is within range of a one-byte relative branch  }
+{                                                               }
+{ parameters:                                                   }
+{       n - index to branch instruction                         }
+{       lab - label number                                      }
+
+{---------------------------------------------------------------}
+
+procedure EndSeg;
+
+{ close out the current segment                                 }
+
+var
+   i: integer;
+
+begin {EndSeg}
+Purge;                                  {dump constant buffer}
+if stringsize <> 0 then begin           {define string space}
+   UpDate(maxLabel, pc);                {define the local label for the string space}
+   for i := 1 to stringsize do
+      CnOut(ord(stringspace[i]));
+   Purge;
+   end; {if}
+Out(0);                                 {end the segment}
+segDisp := 8;                           {update header}
+Out2(long(pc).lsw);
+Out2(long(pc).msw);
+blkcnt := blkcnt-4;                     {purge the segment to disk}
+segDisp := blkcnt;
+CloseSeg;
+end; {EndSeg}
+
+
+procedure GenNative {p_opcode: integer; p_mode: addressingMode;
+                     p_operand: integer; p_name: pStringPtr; p_flags: integer};
+
+{ write a native code instruction to the output file            }
+{                                                               }
+{ parameters:                                                   }
+{       p_opcode - native op code                               }
+{       p_mode - addressing mode                                }
+{       p_operand - integer operand                             }
+{       p_name - named operand                                  }
+{       p_flags - operand modifier flags                        }
+
+var
+   done: boolean;                       {loop termination}
+   llongA: boolean;                     {for tracking A size during opt.}
+   i: integer;                          {index}
+   op: integer;                         {temp storage for opcode}
+
+
+   procedure Purge;
+
+   { Empty the peephole array                                   }
+
+   begin {Purge}
+   while nnextSpot > 1 do begin
+      if registers then
+         CheckRegisters(npeep[1].opcode, npeep[1].mode, npeep[1].operand,
+            npeep[1].name, npeep[1].flags)
+      else
+         WriteNative(npeep[1].opcode, npeep[1].mode, npeep[1].operand,
+            npeep[1].name, npeep[1].flags);
+      Remove(1);
+      end; {while}
+   end; {Purge}
+
+
+   procedure Optimize(ns: integer; longA: boolean);
+
+   { Optimize the instruction starting at ns                    }
+   {                                                            }
+   { parameters:                                                }
+   {    ns - index of instruction  to check for optimization    }
+   {    longA - is the accumulator long?                        }
+
+   label 1;
+
+   var
+      tn: nativeType;			{temp operation}
+
+
+      function ASafe (ns: integer): boolean;
+
+      { See if it is safe to skip loading the A register        }
+      {                                                         }
+      { parameters:                                             }
+      {    ns - starting index                                  }
+
+      label 1;
+
+      var
+         i: integer;                    {loop variable}
+         opcode: integer;               {copy of current op code}
+
+      begin {ASafe}
+      ASafe := false;
+      for i := ns to nnextSpot-1 do begin
+         opcode := npeep[i].opcode;
+         if opcode in
+            [m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bra,m_brl,m_bvs,m_jml,m_jsl,
+             m_lda_abs,m_lda_absx,m_lda_dir,m_lda_dirx,m_lda_imm,m_lda_indl,
+             m_lda_indly,m_lda_long,m_lda_longx,m_lda_s,m_mvn,m_pla,m_rtl,
+             m_rts,m_tdc,m_txa,m_tya,m_tsc,d_end,d_bmov,d_add,d_pin,d_wrd,
+             d_sym,d_cns] then begin
+            ASafe := true;
+            goto 1;
+            end {if}
+         else if opcode in
+            [m_adc_abs,m_adc_dir,m_adc_imm,m_adc_s,m_and_abs,m_and_dir,
+             m_and_imm,m_and_s,m_asl_a,m_cmp_abs,m_cmp_dir,m_cmp_dirX,m_cmp_imm,
+             m_cmp_long,m_cmp_s,m_dea,m_eor_abs,m_eor_dir,m_eor_imm,m_eor_s,
+             m_ina,m_lda_abs,m_lda_absx,m_lda_dir,m_lda_dirx,m_lda_imm,
+             m_lda_indl,m_lda_indly,m_lda_long,m_lda_longx,m_lda_s,m_lsr_a,
+             m_ora_abs,m_ora_dir,m_ora_dirX,m_ora_imm,m_ora_longX,m_ora_s,
+             m_pha,m_sbc_abs,m_sbc_dir,m_sbc_imm,m_sbc_s,m_sta_abs,m_sta_absX,
+             m_sta_dir,m_sta_dirX,m_sta_indl,m_sta_indlY,m_sta_long,m_sta_longX,
+             m_sta_s,m_tax,m_tay,m_tcd,m_tcs,m_xba,m_tsb_dir,m_tsb_abs] then
+            goto 1;
+         end; {for}
+1:
+      end; {ASafe}
+
+
+      function SignExtension (ns: integer): boolean;
+
+      { See if the pattern is a sugn extension			}
+      {								}
+      { Parameters:						}
+      {    ns - start of suspected pattern			}
+      {								}
+      { Returns: true for a sign extension, else false		}
+
+      begin {SignExtension}
+      SignExtension := false;
+      if npeep[ns].opcode = m_ldx_imm then
+         if npeep[ns].operand = 0 then
+            if npeep[ns+1].opcode = m_tay then
+               if npeep[ns+2].opcode = m_bpl then
+                  if npeep[ns+3].opcode = m_dex then
+                     SignExtension := true;
+      end; {SignExtension}
+
+
+   begin {Optimize}
+   with npeep[ns] do
+      case opcode of
+
+         m_and_imm:
+            if npeep[ns+1].opcode = m_and_imm then begin
+               operand := operand & npeep[ns+1].operand;
+               Remove(ns+1);
+               end; {if}
+
+         m_asl_a:
+            if npeep[ns+1].opcode = m_tay then
+               if npeep[ns+2].opcode = m_iny then
+                  if npeep[ns+3].opcode = m_iny then begin
+                     opcode := m_ina;
+                     npeep[ns+1].opcode := m_asl_a;
+                     npeep[ns+2].opcode := m_tay;
+                     Remove(ns+3);
+                     end; {if}
+
+         m_bcs,m_beq,m_bne,m_bmi,m_bpl,m_bcc:
+            if npeep[ns+2].opcode = d_lab then
+               if npeep[ns+2].operand = operand then
+                  if npeep[ns+1].opcode = m_brl then begin
+                     if Short(ns,npeep[ns+1].operand) then begin
+                        operand := npeep[ns+1].operand;
+                        Remove(ns+1);
+                        if opcode = m_bcs then
+                           opcode := m_bcc
+                        else if opcode = m_beq then
+                           opcode := m_bne
+                        else if opcode = m_bne then
+                           opcode := m_beq
+                        else if opcode = m_bmi then
+                           opcode := m_bpl
+                        else if opcode = m_bcc then
+                           opcode := m_bcs
+                        else
+                           opcode := m_bmi;
+                        end; {if}
+                     end {if m_brl}
+                  else if npeep[ns+1].opcode = m_bra then begin
+                     operand := npeep[ns+1].operand;
+                     Remove(ns+1); Remove(ns+1);
+                     if opcode = m_bcs then
+                        opcode := m_bcc
+                     else if opcode = m_beq then
+                        opcode := m_bne
+                     else if opcode = m_bne then
+                        opcode := m_beq
+                     else if opcode = m_bmi then
+                        opcode := m_bpl
+                     else if opcode = m_bcc then
+                        opcode := m_bcs
+                     else
+                        opcode := m_bmi;
+                     end; {else if m_bra}
+
+         m_brl:
+            if Short(ns,operand) then begin
+               opcode := m_bra;
+               mode := relative;
+               didOne := true;
+               end; {if}
+
+         m_bvs:
+            if npeep[ns+2].opcode = d_lab then
+               if npeep[ns+2].operand = operand then
+                  if npeep[ns+1].opcode = m_bmi then
+                     if npeep[ns+4].opcode = d_lab then
+                        if npeep[ns+1].operand = npeep[ns+4].operand then
+                           if npeep[ns+3].opcode = m_brl then
+                              if Short(ns,npeep[ns+3].operand) then
+                                 if Short(ns+1,npeep[ns+3].operand) then begin
+                                    operand := npeep[ns+3].operand;
+                                    npeep[ns+1].operand := npeep[ns+3].operand;
+                                    npeep[ns+1].opcode := m_bpl;
+                                    Remove(ns+3);
+                                    end; {if}
+
+         m_dec_abs:
+            if npeep[ns+1].opcode = m_lda_abs then
+               if name^ = npeep[ns+1].name^ then
+                  if npeep[ns+2].opcode = m_beq then
+                     Remove(ns+1);
+
+         m_lda_abs:
+            if npeep[ns+1].opcode = m_clc then begin
+               if npeep[ns+2].opcode = m_adc_abs then
+                  if operand = npeep[ns+2].operand then
+                     if name = npeep[ns+2].name then
+                        if not rangeCheck then begin
+                           npeep[ns+1].opcode := m_asl_a;
+                           Remove(ns+2);
+                           end; {if}
+               end {if}
+            else if npeep[ns+1].opcode = m_dea then begin
+               if npeep[ns+2].opcode = m_tax then begin
+                  opcode := m_ldx_abs;
+                  npeep[ns+1].opcode := m_dex;
+                  Remove(ns+2);
+                  end; {if}
+               end {else if}
+            else if npeep[ns+2].opcode = m_sta_abs then begin
+               if npeep[ns+1].opcode in [m_ora_dir,m_ora_abs,m_ora_dirX,
+                  m_ora_imm,m_ora_longX,m_ora_s] then
+                  if operand = npeep[ns+2].operand then
+                     if name = npeep[ns+2].name then begin
+                        npeep[ns+1].opcode := npeep[ns+1].opcode + $00A0;
+                        npeep[ns+2].opcode := m_tsb_abs;
+                        Remove(ns);
+                        end; {if}
+               end {else if}
+            else if SignExtension(ns+1) then begin
+               npeep[ns+2] := npeep[ns];
+               Remove(ns);
+               end {else if}
+            else if npeep[ns+1].opcode = m_xba then
+               if npeep[ns+2].opcode = m_and_imm then
+                  if npeep[ns+2].operand = $00FF then begin
+                     operand := operand+1;
+                     Remove(ns+1);
+                     end; {if}
+                
+         m_lda_dir:
+            if npeep[ns+1].opcode = m_clc then begin
+               if npeep[ns+2].opcode = m_adc_dir then
+                  if operand = npeep[ns+2].operand then
+                     if not rangeCheck then begin
+                        npeep[ns+1].opcode := m_asl_a;
+                        Remove(ns+2);
+                        end; {if}
+               end
+            else if npeep[ns+1].opcode = m_dea then begin
+               if npeep[ns+2].opcode = m_tax then begin
+                  opcode := m_ldx_dir;
+                  npeep[ns+1].opcode := m_dex;
+                  Remove(ns+2);
+                  end; {if}
+               end {else if}
+            else if npeep[ns+1].opcode = m_pha then begin
+               if longA then begin
+                  opcode := m_pei_dir;
+                  Remove(ns+1);
+                  end {if}
+               end {else if}
+            else if npeep[ns+2].opcode = m_sta_dir then begin
+               if npeep[ns+1].opcode in [m_ora_dir,m_ora_abs,m_ora_dirX,
+                  m_ora_imm,m_ora_longX,m_ora_s] then
+                  if operand = npeep[ns+2].operand then begin
+                     npeep[ns+1].opcode := npeep[ns+1].opcode + $00A0;
+                     npeep[ns+2].opcode := m_tsb_dir;
+                     Remove(ns);
+                     end {if}
+               end {else if}
+            else if SignExtension(ns+1) then begin
+               npeep[ns+2] := npeep[ns];
+               Remove(ns);
+               end {else if}
+            else if npeep[ns+1].opcode = m_xba then
+               if npeep[ns+2].opcode = m_and_imm then
+                  if npeep[ns+2].operand = $00FF then begin
+                     operand := operand+1;
+                     Remove(ns+1);
+                     end; {if}
+                              
+         m_pei_dir:
+            if npeep[ns+1].opcode = m_pla then begin
+               opcode := m_lda_dir;
+               Remove(ns+1);
+               end; {if}
+
+         m_lda_imm:
+            if npeep[ns+1].opcode = m_pha then
+               if ASafe(ns+2) then
+                  if longA then begin
+                     opcode := m_pea;
+                     Remove(ns+1);
+                     end; {if}
+
+         m_ldx_imm:
+            if npeep[ns+1].opcode = m_lda_imm then
+               if npeep[ns+2].opcode = m_phx then
+                  if npeep[ns+3].opcode = m_pha then begin
+                     opcode := m_pea;
+                     npeep[ns+1].opcode := m_pea;
+                     Remove(ns+2);
+                     Remove(ns+2);
+                     end; {if}
+
+         m_ldy_imm:
+            if npeep[ns+1].opcode = m_sep then
+               if npeep[ns+1].operand = 32 then begin
+                  didOne := true;
+                  tn := npeep[ns];
+                  npeep[ns] := npeep[ns+1];
+                  npeep[ns+1] := tn;
+                  end; {if}
+
+         m_ora_abs:     
+            if npeep[ns+1].opcode = m_sta_abs then
+               if operand = npeep[ns+1].operand then
+                  if name = npeep[ns+1].name then begin
+                     opcode := m_tsb_abs;
+                     Remove(ns+1);
+                     end; {if}
+
+         m_ora_dir:     
+            if npeep[ns+1].opcode = m_sta_dir then
+               if operand = npeep[ns+1].operand then begin
+                  opcode := m_tsb_dir;
+                  Remove(ns+1);
+                  end; {if}
+
+         m_pea:     
+            if npeep[ns+1].opcode = m_pla then begin
+               opcode := m_lda_imm;
+               Remove(ns+1);
+               end; {if}
+
+         m_sta_abs:     
+            if npeep[ns+1].opcode = m_lda_abs then
+               if operand = npeep[ns+1].operand then
+                  if name = npeep[ns+1].name then
+                     if not (npeep[ns+2].opcode in
+                        [m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then
+                        Remove(ns+1);
+
+         m_sta_dir:
+            if npeep[ns+1].opcode = m_lda_dir then
+               if operand = npeep[ns+1].operand then
+                  if not (npeep[ns+2].opcode in
+                     [m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then
+                     Remove(ns+1);
+
+         m_plb:
+            if npeep[ns+1].opcode = m_phb then begin
+               Remove(ns);
+               Remove(ns);
+               end; {if}
+
+         m_plx:
+            if npeep[ns+1].opcode = m_pha then begin
+               opcode := m_sta_s;
+               mode := direct;
+               operand := 1;
+               Remove(ns+1);
+               end; {if}
+
+         m_tax:
+            if npeep[ns+1].opcode = m_phx then begin
+               Remove(ns+1);
+               opcode := m_pha;
+               end {if}
+            else if npeep[ns+1].opcode = m_txa then begin
+               if not (npeep[ns+2].opcode in
+                  [m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then begin
+                  Remove(ns);
+                  Remove(ns);
+                  end; {if}
+               end {else if}
+            else if npeep[ns+1].opcode = m_dey then
+               if npeep[ns+2].opcode = m_dey then
+                  if npeep[ns+3].opcode = m_lda_indly then
+                     if npeep[ns+4].opcode = m_stx_dir then begin
+                        npeep[ns] := npeep[ns+4];
+                        opcode := m_sta_dir;
+                        Remove(ns+4);
+                        end; {if}
+
+         m_tya:
+            if npeep[ns+1].opcode = m_sta_dir then begin
+               npeep[ns+1].opcode := m_sty_dir;
+               Remove(ns);
+               end {if}
+            else if npeep[ns+1].opcode = m_sta_abs then begin
+               npeep[ns+1].opcode := m_sty_abs;
+               Remove(ns);
+               end; {else if}
+
+         m_tyx:
+            if npeep[ns+1].opcode = m_phx then begin
+               Remove(ns+1);
+               opcode := m_phy;
+               end; {if}
+
+         m_pha:
+            if npeep[ns+1].opcode = m_pla then begin
+               Remove(ns);
+               Remove(ns);
+               end {if}
+            else if npeep[ns+1].opcode in [m_ldx_abs,m_ldx_dir] then
+               if npeep[ns+2].opcode = m_pla then begin
+                  Remove(ns+2);
+                  Remove(ns);
+                  end; {if}
+
+         m_phy:
+            if npeep[ns+1].opcode = m_ply then begin
+               Remove(ns);
+               Remove(ns);
+               end; {if}
+
+         m_rep:
+            if npeep[ns+1].opcode = m_sep then
+               if npeep[ns].operand = npeep[ns+1].operand then begin
+        	  Remove(ns);
+        	  Remove(ns);
+        	  end; {if}
+
+         otherwise: ;
+
+         end; {case}
+1:
+  end; {Optimize}
+
+begin {GenNative}
+{ writeln('GenNative: ',p_opcode:4, ', mode=', ord(p_mode):1,
+   ' operand=', p_operand:1);      {debug}
+if npeephole then begin
+   if (nnextspot = 1) and not (p_opcode in nleadOpcodes) then begin
+      if p_opcode <> d_end then
+         if registers then
+            CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags)
+         else
+            WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
+      end {if}
+   else if p_opcode in nstopOpcodes then begin
+      repeat
+         didOne := false;
+         i := 1;
+         llongA := longA;
+         while i < nnextSpot-nMaxPeep do begin
+            op := npeep[i].opcode;
+            if op = m_sep then begin
+               if npeep[i].operand & $20 <> 0 then
+                  llongA := false;
+               end {if}
+            else if op = m_rep then begin
+               if npeep[i].operand & $20 <> 0 then
+                  llongA := true;
+               end; {else}
+            Optimize(i,llongA);
+            i := i+1;
+            end; {while}
+      until not didone;
+      Purge;
+      if p_opcode <> d_end then
+         if registers then
+            CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags)
+         else
+            WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
+      end {else if}
+   else if nnextSpot = npeepSize then begin
+      repeat
+         didOne := false;
+         i := 1;
+         llongA := longA;
+         while i < nnextSpot-nMaxPeep do begin
+            op := npeep[i].opcode;
+            if op = m_sep then begin
+               if npeep[i].operand & $20 <> 0 then
+               llongA := false;
+               end {if}
+            else if op = m_rep then begin
+               if npeep[i].operand & $20 <> 0 then
+               llongA := true;
+               end; {else}
+            Optimize(i,llongA);
+            i := i+1;
+            end; {while}
+      until not didone;
+      done := false;
+      repeat
+         if nnextSpot = 1 then
+            done := true
+         else begin
+            if npeep[1].opcode in nleadOpcodes then
+               done := true
+            else begin
+               if registers then
+                  CheckRegisters(nPeep[1].opcode, nPeep[1].mode,
+                     nPeep[1].operand, nPeep[1].name, nPeep[1].flags)
+               else
+                  WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
+                     nPeep[1].name,nPeep[1].flags);
+               Remove(1);
+               end; {else}
+            end; {else}
+      until done;
+      if nnextSpot = nPeepSize then begin
+         if registers then
+            CheckRegisters(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
+               nPeep[1].name, nPeep[1].flags)
+         else
+            WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
+               nPeep[1].name, nPeep[1].flags);
+         Remove(1);
+         end; {if}
+      with npeep[nnextSpot] do begin
+         opcode := p_opcode;
+         mode := p_mode;
+         operand := p_operand;
+         name := p_name;
+         flags := p_flags;
+         end; {with}
+      nnextSpot := nnextSpot+1;
+      if not (npeep[1].opcode in nleadOpcodes) then begin
+         if registers then
+            CheckRegisters(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
+               nPeep[1].name, nPeep[1].flags)
+         else
+            WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
+               nPeep[1].name, nPeep[1].flags);
+         Remove(1);
+         end; {if}
+      end {else if}
+   else begin
+      with npeep[nnextSpot] do begin
+         opcode := p_opcode;
+         mode := p_mode;
+         operand := p_operand;
+         name := p_name;
+         flags := p_flags;
+         end; {with}
+      nnextSpot := nnextSpot+1;
+      end; {else}
+   end {if}
+else if p_opcode <> d_end then
+   if registers then
+      CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags)
+   else
+      WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
+end; {GenNative}
+
+
+procedure GenImplied {p_opcode: integer};
+
+{ short form of GenNative - reduces code size                   }
+{                                                               }
+{ parameters:                                                   }
+{       p_code - operation code                                 }
+
+begin {GenImplied}
+GenNative(p_opcode, implied, 0, nil, 0);
+end; {GenImplied}
+
+
+procedure GenCall {callNum: integer};
+
+{ short form of jsl to library subroutine - reduces code size   }
+{                                                               }
+{ parameters:                                                   }
+{       callNum - subroutine # to generate a call for           }
+
+var
+   sp: pStringPtr;                       {work string}
+
+begin {GenCall}
+case callNum of
+      1: sp := @'~GET';
+      2: sp := @'~PUT';
+      3: sp := @'~OPEN';
+      4: sp := @'~CLOSE';
+      5: sp := @'~READINT';
+      6: sp := @'~READREAL';
+      7: sp := @'~READCHAR';
+      8: sp := @'~WRITECHAR';
+      9: sp := @'~WRITEINTEGER';
+     10: sp := @'~WRITEREAL';
+     11: sp := @'~PNEW';
+     12: sp := @'~XJPERROR';
+     13: sp := @'~READLN';
+     14: sp := @'~WRITELINE';
+     15: sp := @'~PAGE';
+     16: sp := @'~INTTOSET';
+     17: sp := @'~DISPOSE';
+     18: sp := @'~LOADDOUBLE';
+     19: sp := @'~PUTSP';
+     20: sp := @'~PUTB';
+     21: sp := @'~PUT2';
+     22: sp := @'~PUTC';
+     23: sp := @'~SAVEREAL';
+     24: sp := @'~SAVESET';
+     25: sp := @'~LOADREAL';
+     26: sp := @'~WRITELINESO';
+     27: sp := @'~WRITELINEEO';
+     28: sp := @'~LOADSET';
+     29: sp := @'~CNN';
+     30: sp := @'~SETEQU';
+     31: sp := @'~EQUE';
+     32: sp := @'~MUL2';
+     33: sp := @'~CHECK';
+     34: sp := @'~CHECKPTR';
+     35: sp := @'~CLEARMEM';
+     36: sp := @'~CNVINTREAL';
+     37: sp := @'~CNVREALINT';
+     38: sp := @'~SETDIFFERENCE';
+     39: sp := @'~SETINTERSECTION';
+     40: sp := @'~SETUNION';
+     41: sp := @'~DIV2';
+     42: sp := @'~SETIN';
+     43: sp := @'~MUL2';
+     44: sp := @'~SEEK';
+     45: sp := @'~WRITESTRING';
+     46: sp := @'~PUTBOOLEAN';
+     47: sp := @'~PRODOS';
+     48: sp := @'~EOF';
+     49: sp := @'~EOLN';
+     50: sp := @'~ADDE';
+     51: sp := @'~DIVE';
+     52: sp := @'~MULE';
+     53: sp := @'~SUBE';
+     54: sp := @'~SQRE';
+     55: sp := @'~SQTE';
+     58: sp := @'~READCHARINPUT';
+     59: sp := @'~READINTINPUT';
+     60: sp := @'~READLNINPUT';
+     61: sp := @'~READREALINPUT';
+     62: sp := @'~WRITEREALOUTPUT';
+     63: sp := @'~SINE';
+     64: sp := @'~COSE';
+     65: sp := @'~ATNE';
+     66: sp := @'~LOGE';
+     67: sp := @'~EXPE';
+     68: sp := @'~ROUND';
+     69: sp := @'~EQUSTRING';
+     70: sp := @'~GRTE';
+     71: sp := @'~GEQE';
+     72: sp := @'~GRTSTRING';
+     73: sp := @'~GEQSTRING';
+     74: sp := @'~SETINCLUSION';
+     75: sp := @'~SETLINENUMBER';
+     76: sp := @'~SETNAME';
+     77: sp := @'~RESETNAME';
+     78: sp := @'~SETSIZE';
+     79: sp := @'~READSTRINGINPUT';
+     80: sp := @'~MOVE';
+     81: sp := @'~REALRET2';
+     82: sp := @'~REALFN';
+     83: sp := @'~REALFIX';
+     84: sp := @'~DOUBLERET2';
+     85: sp := @'~DOUBLEFN';
+     86: sp := @'~DOUBLEFIX';
+     87: sp := @'~SAVEDOUBLE';
+     88: sp := @'~SHIFTLEFT';
+     89: sp := @'~SSHIFTRIGHT';
+     90: sp := @'~POWER';
+     91: sp := @'~HALT';
+     92: sp := @'~PSEED';
+     93: sp := @'~DELETE';
+     94: sp := @'~INSERT';
+     95: sp := @'~SHELLID';
+     96: sp := @'~READCMDLINE';
+     97: sp := @'~STARTGRAPH';
+     98: sp := @'~STARTDESK';
+     99: sp := @'~ENDGRAPH';
+    100: sp := @'~ENDDESK';
+    101: sp := @'~ORD4';
+    102: sp := @'~CNVES';
+    103: sp := @'~CNVIS';
+    104: sp := @'~CNVSE';
+    105: sp := @'~CNVSI';
+    106: sp := @'~CNVSL';
+    107: sp := @'~RANDOME';
+    108: sp := @'~RANDOMI';
+    109: sp := @'~READSTRING';
+    110: sp := @'~CONCAT';
+    111: sp := @'~COPY';
+    112: sp := @'~LENGTH';
+    113: sp := @'~POS';
+{   114: sp := @'~USER_ID';  }
+    115: sp := @'~CNV42';
+    116: sp := @'~MOVESTRING';
+    117: sp := @'~DISPOSESTRHEAP';
+    118: sp := @'~CNVLS';
+    120: sp := @'~TANE';
+    121: sp := @'~ARCCOSE';
+    122: sp := @'~ARCSINE';
+    123: sp := @'~ARCTAN2E';
+    124: sp := @'~MOD2';
+    125: sp := @'~PACK2';
+    126: sp := @'~UNPACK2';
+    127: sp := @'~MAKESET';
+    128: sp := @'~WRITEREALEO';
+    129: sp := @'~CHECKSTACK';
+    130: sp := @'~SETINA';
+    131: sp := @'~NEWOPENREC';
+    132: sp := @'~DISPOSEOPENREC';
+    133: sp := @'~MUL4';
+    134: sp := @'~PDIV4';
+    135: sp := @'~PMOD4';
+    136: sp := @'~SHL4';
+    137: sp := @'~SHR4';
+    138: sp := @'~GRTL';
+    139: sp := @'~GEQL';
+    140: sp := @'~READLONGINPUT';
+    141: sp := @'~READLONG';
+    142: sp := @'~UMUL2';
+    143: sp := @'~PUT4';
+    144: sp := @'~WRITELONG';
+    145: sp := @'~CNVLE';
+    146: sp := @'~CNVL2';
+    147: sp := @'~INTCHK';
+    148: sp := @'~REDIRECT';
+    149: sp := @'~ROUND4';
+    150: sp := @'~CNVREALLONG';
+    151: sp := @'SYSCHAROUT';
+    152: sp := @'SYSCHARERROUT';
+    153: sp := @'~WRITESTRINGSO';
+    154: sp := @'~WRITESTRINGEO';
+    155: sp := @'~WRITELNSTRINGSO';
+    156: sp := @'~WRITELNSTRINGEO';
+    157: sp := @'~SAVECOMP';
+    158: sp := @'~SAVEEXTENDED';
+    159: sp := @'~COPYREAL';
+    160: sp := @'~COPYDOUBLE';
+    161: sp := @'~COPYCOMP';
+    162: sp := @'~COPYEXTENDED';
+    163: sp := @'~LOADCOMP';
+    164: sp := @'~LOADEXTENDED';
+    165: sp := @'~UDIV2';
+    166: sp := @'~CNVLONGREAL';
+    167: sp := @'~MOVE2';
+    168: sp := @'~LONGMOVE';
+    169: sp := @'~LONGMOVE2';
+    170: sp := @'~LSHR4';
+    171: sp := @'~ASHR4';
+    172: sp := @'~UMUL4';
+    173: sp := @'~UDIV4';
+    174: sp := @'~UMOD4';
+    175: sp := @'~USHIFTRIGHT';
+    176: sp := @'~EXTENDEDRET2';
+    177: sp := @'~COMPRET2';
+    178: sp := @'~COMPFIX';
+    179: sp := @'~CHECKLONG';
+    180: sp := @'~PNEW4';
+    181: sp := @'~MEMBER';
+    182: sp := @'~NEWOBJECT';
+    183: sp := @'~STRINGPSIZE';
+    184: sp := @'~STRINGCSIZE';
+    185: sp := @'~EOFSTDIN';
+    186: sp := @'~EOLNSTDIN';
+   otherwise:      
+      Error(cge1);
+   end; {case}
+GenNative(m_jsl, longabs, 0, sp, 0);
+end; {GenCall}
+
+
+procedure InitFile {keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean};
+
+{ Set up the object file					}
+{                                                               }
+{ parameters:							}
+{    keepName - name of the output file				}
+{    keepFlag - keep status:					}
+{       0 - don't keep the output				}
+{       1 - create a new object module				}
+{       2 - a .root already exists				}
+{       3 - at least on .letter file exists			}
+{    partial - is this a partial compile?			}
+{								}
+{ Note: Declared as extern in CGI.pas				}
+
+
+   procedure RootFile;
+
+   { Create and write the initial entry segment                 }
+
+   const
+      dispToOpen     =     21;          {disps to glue routines for NDAs}
+      dispToClose    =     38;
+      dispToAction   =     50;
+      dispToInit     =     65;
+      dispToCDAOpen  =     9;           {disps to glue routines for CDAs}
+      dispToCDAClose =     36;
+
+   var
+      i: integer;                       {loop index}
+      lab: pStringPtr;			{for holdling names var pointers}
+      menuLen: integer;                 {length of the menu name string}
+
+
+      procedure SetDataBank;
+
+      { set up the data bank register                           }
+
+      begin {SetDataBank}
+      CnOut(m_pea);
+      RefName(@'~GLOBALS', 0, 2, -8);
+      CnOut(m_plb);
+      CnOut(m_plb);
+      end; {SetDataBank}
+
+
+   begin {RootFile}
+   {open the initial object module}
+   fname2.theString.theString := concat(fname1.theString.theString, '.root');
+   fname2.theString.size := length(fname2.theString.theString);
+   OpenObj(fname2);
+   
+   {write the header}
+   Header(@'~_ROOT', $4000, 0);
+   
+   {new desk accessory initialization}
+   if isNewDeskAcc then begin
+
+      {set up the initial jump table}
+      lab := @'~_ROOT';
+      menuLen := length(menuLine);
+      RefName(lab, menuLen + dispToOpen, 4, 0);
+      RefName(lab, menuLen + dispToClose, 4, 0);
+      RefName(lab, menuLen + dispToAction, 4, 0);
+      RefName(lab, menuLen + dispToInit, 4, 0);
+      CnOut2(refreshPeriod);
+      CnOut2(eventMask);
+      for i := 1 to menuLen do
+         CnOut(ord(menuLine[i]));
+      CnOut(0);
+
+      {glue code for calling open routine}
+      CnOut(m_phb);
+      SetDataBank;
+      CnOut(m_jsl);
+      RefName(openName, 0, 3, 0);
+      CnOut(m_plb);
+      CnOut(m_sta_s); CnOut(4);
+      CnOut(m_txa);
+      CnOut(m_sta_s); CnOut(6);
+      CnOut(m_rtl);
+
+      {glue code for calling close routine}
+      CnOut(m_phb);
+      SetDataBank;
+      CnOut(m_jsl);
+      RefName(closeName, 0, 3, 0);
+      CnOut(m_plb);
+      CnOut(m_rtl);
+
+      {glue code for calling action routine}
+      CnOut(m_phb);
+      SetDataBank;
+      CnOut(m_pha);
+      CnOut(m_phy);
+      CnOut(m_phx);
+      CnOut(m_jsl);
+      RefName(actionName, 0, 3, 0);
+      CnOut(m_plb);
+      CnOut(m_rtl);
+
+      {glue code for calling init routine}
+      CnOut(m_pha);
+      CnOut(m_jsl);
+      RefName(@'~DAID', 0, 3, 0);
+      CnOut(m_phb);
+      SetDataBank;
+      CnOut(m_pha);
+      CnOut(m_jsl);
+      RefName(initName, 0, 3, 0);
+      CnOut(m_plb);
+      CnOut(m_rtl);
+      end
+
+   {classic desk accessory initialization}
+   else if isClassicDeskAcc then begin
+
+      {write the name}
+      menuLen := length(menuLine);
+      CnOut(menuLen);
+      for i := 1 to menuLen do
+         CnOut(ord(menuLine[i]));
+
+      {set up the initial jump table}
+      lab := @'~_ROOT';
+      RefName(lab, menuLen + dispToCDAOpen, 4, 0);
+      RefName(lab, menuLen + dispToCDAClose, 4, 0);
+
+      {glue code for calling open routine}
+      CnOut(m_pea);
+      CnOut2(1);
+      CnOut(m_jsl);
+      RefName(@'~DAID', 0, 3, 0);
+      CnOut(m_phb);
+      SetDataBank;
+      CnOut(m_jsl);
+      RefName(@'~CDASTART', 0, 3, 0);
+      CnOut(m_jsl);
+      RefName(openName,0,3,0);
+      CnOut(m_jsl);
+      RefName(@'~CDASHUTDOWN', 0, 3, 0);
+      CnOut(m_plb);
+      CnOut(m_rtl);
+
+      {glue code for calling close routine}
+      CnOut(m_phb);
+      SetDataBank;
+      CnOut(m_jsl);
+      RefName(closeName, 0, 3, 0);
+      CnOut(m_pea);
+      CnOut2(0);
+      CnOut(m_jsl);
+      RefName(@'~DAID', 0, 3, 0);
+      CnOut(m_plb);
+      CnOut(m_rtl);
+      end
+
+   {control panel device initialization}
+   else if isCDev then begin
+      CnOut(m_pea);
+      CnOut2(1);
+      CnOut(m_jsl);
+      RefName(@'~DAID', 0, 3, 0);
+      CnOut(m_phb);
+      SetDataBank;
+      CnOut(m_pla);
+      CnOut(m_sta_s); CnOut(13);
+      CnOut(m_pla);
+      CnOut(m_sta_s); CnOut(13);
+      CnOut(m_jsl);
+      RefName(openName,0,3,0);
+      CnOut(m_tay);
+      CnOut(m_lda_s); CnOut(3);
+      CnOut(m_pha);
+      CnOut(m_lda_s); CnOut(3);
+      CnOut(m_pha);
+      CnOut(m_txa);
+      CnOut(m_sta_s); CnOut(7);
+      CnOut(m_tya);
+      CnOut(m_sta_s); CnOut(5);
+      CnOut(m_plb);
+      CnOut(m_rtl);
+      end
+
+   {NBA initialization}
+   else if isNBA then begin
+      CnOut(m_jsl);
+      RefName(@'~NBASTARTUP', 0, 3, 0);
+      CnOut(m_phx);
+      CnOut(m_phy);
+      CnOut(m_jsl);
+      RefName(openName,0,3,0);
+      CnOut(m_jsl);
+      RefName(@'~NBASHUTDOWN', 0, 3, 0);
+      CnOut(m_rtl);
+      end
+
+   {XCMD initialization}
+   else if isXCMD then begin
+      CnOut(m_jsl);
+      RefName(@'~XCMDSTARTUP', 0, 3, 0);
+      CnOut(m_jsl);
+      RefName(openName,0,3,0);
+      CnOut(m_jsl);
+      RefName(@'~XCMDSHUTDOWN', 0, 3, 0);
+      CnOut(m_rtl);
+      end
+
+   {normal program initialization}
+   else begin
+
+      {write the initial JSL}
+      CnOut(m_jsl);
+      if rtl then
+         RefName(@'~_BWSTARTUP4', 0, 3, 0)
+      else
+         RefName(@'~_BWSTARTUP3', 0, 3, 0);
+
+      {set the data bank register}
+      SetDataBank;
+
+      {write JSL to main entry point}
+      CnOut(m_jsl);
+      RefName(@'~_PASMAIN', 0, 3, 0);
+
+      {return to the shell}
+      CnOut(m_lda_imm); CnOut2(0);
+      CnOut(m_jml);
+      if rtl then 
+	 RefName(@'~RTL', 0, 3, 0)
+      else
+	 RefName(@'~QUIT', 0, 3, 0);
+      end;
+
+   {finish the current segment}
+   EndSeg;
+   end; {RootFile}
+
+
+   procedure SetStack;
+
+   { Set up a stack frame					}
+
+   begin {SetStack}
+   if stackSize <> 0 then begin
+      currentSegment := '~_STACK   ';	{write the header}
+      Header(@'~_STACK', $4012, 0);
+      currentSegment := defaultSegment;
+      Out($F1);				{write the DS record to reserve space}
+      Out2(stackSize);
+      Out2(0);
+      EndSeg;				{finish the current segment}
+      end; {if}
+   end; {SetStack}
+
+
+begin {InitFile}
+fname1 := keepname^;
+if partial or (keepFlag = 3) then
+   FindSuffix(fname1, nextSuffix)
+else begin
+   if (keepFlag = 1) and (not doingunit) then begin
+       RootFile;
+       SetStack;
+       CloseObj;
+       end; {if}
+   DestroySuffixes(fname1);
+   nextSuffix := 'a';
+   end; {else}
+fname2.theString.theString := concat(fname1.theString.theString, '.', nextSuffix);
+fname2.theString.size := length(fname2.theString.theString);
+OpenObj(fname2);
+end; {InitFile}  
+
+
+procedure InitNative; 
+
+{ set up for a new segment					}
+
+begin {InitNative}
+aRegister.condition := regUnknown;	{set up the peephole optimizer}
+xRegister.condition := regUnknown;
+yRegister.condition := regUnknown;
+nnextspot := 1;
+nleadOpcodes := [m_asl_a,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_brl,m_bvs,m_bcc,
+   m_dec_abs,m_lda_abs,m_lda_dir,m_lda_imm,m_ldx_imm,m_sta_abs,m_sta_dir,
+   m_pha,m_plb,m_plx,m_tax,m_tya,m_tyx,m_phy,m_pei_dir,m_ldy_imm,m_rep,
+   m_ora_dir,m_ora_abs,m_and_imm,m_pea];
+nstopOpcodes := [d_end,d_pin];
+
+stringSize := 0;			{initialize scalars for a new segment}
+pc := 0;
+cbufflen := 0;
+longA := true;
+longI := true;
+end; {InitNative}
+
+
+procedure GenLab {lnum: integer};
+
+{ generate a label                                              }
+{                                                               }
+{ parameters:                                                   }
+{       lnum - label number                                     }
+
+begin {GenLab}
+GenNative(d_lab, gnrlabel, lnum, nil, 0);
+end; {GenLab}
+
+
+procedure LabelSearch {lab: integer; len, shift, disp: integer};
+
+{ resolve a label reference                                     }
+{                                                               }
+{ parameters:                                                   }
+{       lab - label number                                      }
+{       len - # bytes for the generated code                    }
+{       shift - shift factor                                    }
+{       disp - disp past the label                              }
+{                                                               }
+{ Note 1: maxlabel is reserved for use as the start of the      }
+{       string space                                            }
+{ Note 2: negative length indicates relative branch             }
+{ Note 3: zero length indicates 2 byte addr -1                  }
+
+var
+   next: labelptr;                      {work pointer}
+
+begin {LabelSearch}
+if labeltab[lab].defined and (len < 0) and (shift = 0) and (disp = 0) then begin
+
+   {handle a relative branch to a known disp}
+   if len = -1 then
+      CnOut(labeltab[lab].ival - long(pc).lsw - cbufflen + len)
+   else
+      CnOut2(labeltab[lab].ival - long(pc).lsw - cbufflen + len);
+   end {if}
+else begin
+   if lab <> maxlabel then begin
+
+      {handle a normal label reference}
+      Purge;                            {empty the constant buffer}
+      if len < 0 then begin
+         len := -len;                   {generate a RELEXPR}
+         Out(238);
+         Out(len);
+         Out2(len); Out2(0);
+         end {if}
+      else begin
+         if isJSL then                  {generate a standard EXPR}
+            Out(243)
+         else
+            Out(235);
+         if len = 0 then
+            Out(2)
+         else
+            Out(len);
+         end; {else}
+      end; {if}
+   Out(135);                            {generate a relative offset from the seg. start}
+   if not labeltab[lab].defined then begin
+      next := pointer(Malloc(sizeof(labelEntry))); {value unknown: create a reference}
+      next^.next := labeltab[lab].chain;
+      labeltab[lab].chain := next;
+      next^.addr := blkcnt;
+      Out2(0);
+      Out2(0);
+      end {if}
+   else {labeltab[lab].defined} begin
+      Out2(labeltab[lab].ival);         {value known: write it}
+      Out2(labeltab[lab].hval);
+      end; {else}
+   if len = 0 then begin
+      Out(129);                         {subtract 1 from addr}
+      Out2(1); Out2(0);
+      Out(2);
+      len := 2;
+      end; {if}
+   if disp <> 0 then begin
+      Out(129);                         {add in the displacement}
+      Out2(disp);
+      if disp < 0 then
+         Out2(-1)
+      else
+         Out2(0);
+      Out(1);
+      end; {if}
+   if shift <> 0 then begin
+      Out(129);                         {shift the address}
+      Out2(-shift); Out2(-1);
+      Out(7);
+      end; {if}
+   if lab <> maxlabel then              {if not a string, end the expression}
+      Out(0);
+   pc := pc+len;                        {update the pc}
+   end; {else}
+end; {LabelSearch}
+
+
+procedure RefName {lab: pStringPtr; disp, len, shift: integer};
+
+{ handle a reference to a named label                           }
+{                                                               }
+{ parameters:                                                   }
+{       lab - label name                                        }
+{       disp - displacement past the label                      }
+{       len - number of bytes in the reference                  }
+{       shift - shift factor                                    }
+
+var
+   i: integer;                          {loop var}
+   slen: integer;                       {length of string}
+
+begin {RefName}
+Purge;                                  {clear any constant bytes}
+if isJSL then                           {expression header}
+   Out(243)
+else
+   Out(235);
+Out(len);
+Out(131);
+pc := pc+len;
+slen := length(lab^);
+Out(slen);
+for i := 1 to slen do
+   Out(ord(lab^[i]));
+if disp <> 0 then begin                 {if there is a disp, add it in}
+   Out(129);
+   Out2(disp);
+   Out2(0);
+   Out(1);
+   end; {end}
+if shift <> 0 then begin                {if there is a shift, add it in}
+   Out(129);
+   Out2(shift);
+   if shift < 0 then
+      Out2(-1)
+   else
+      Out2(0);
+   Out(7);
+   end; {if}
+Out(0);                                 {end of expression}
+end; {RefName}
+
+end.
+
+{$append 'Native.asm'}
diff --git a/objout.asm b/objout.asm
old mode 100755
new mode 100644
index a757805..6999adf
--- a/objout.asm
+++ b/objout.asm
@@ -1 +1,403 @@
-	mcopy	objout.macros
****************************************************************
*
*  Code Generator Output Routines
*
*  This module provides fast object module output for the code
*  generator.  Currently, the maximum size for a single object
*  segment is 64K.
*
*  By Mike Westerfield
*
*  Copyright July 1987
*  Byte Works, Inc.
*
****************************************************************
*
ObjData  privdata                       place with ~globals
;
;  Constants
;
!			NOTE: tokenBuffSize also defined in cgi.pas
tokenBuffSize equ 4095                  size of the token buffer
         end

****************************************************************
*
*  COut - write a code byte to the object file
*
*  Inputs:
*        b - byte to write (on stack)
*
****************************************************************
*
COut     start

         phb                            OutByte(b);
         pla
         ply
         plx
         phy
         pha
         plb
         jsr   OutByte
         inc   blkcnt                   blkcnt := blkcnt+1;
         inc4  pc                       pc := pc+1;
         rtl
         end

****************************************************************
*
*  CnOut - write a byte to the constant buffer
*
*  Inputs:
*        i - byte to write
*
****************************************************************
*
CnOut    start
maxCBuffLen equ 191                     max index into the constant buffer

         lda   cBuffLen                 if cBuffLen = maxCBuffLen then
         cmp   #maxCBuffLen
         bne   lb1
         jsl   Purge                       Purge;
lb1      phb                            cBuff[cBuffLen] := i;
         plx
         ply
         pla
         phy
         phx
         plb
         ldx   cBuffLen
         short M
         sta   cBuff,X
         long  M
         inc   cBuffLen                 cBuffLen := cBuffLen+1;
         rtl
         end

****************************************************************
*
*  CnOut2 - write a word to the constant buffer
*
*  Inputs:
*        i - word to write
*
****************************************************************
*
CnOut2   start
maxCBuffLen equ 191                     max index into the constant buffer

         lda   cBuffLen                 if cBuffLen+1 >= maxCBuffLen then
         inc   A
         cmp   #maxCBuffLen
         blt   lb1
         jsl   Purge                       Purge;
lb1      phb                            cBuff[cBuffLen] := i;
         plx
         ply
         pla
         phy
         phx
         plb
         ldx   cBuffLen
         sta   cBuff,X
         inx                            cBuffLen := cBuffLen+2;
         inx
         stx   cBuffLen
         rtl
         end

****************************************************************
*
*  GrowHandle - Grow the area occupied by a handle
*
*  Inputs:
*        size - new size for the buffer
*        haddr - address of the handle
*
*  Notes:
*        This subroutine must only be used if the handle is
*        grown.  It will fail if you try to shrink the handle.
*
****************************************************************
*
GrowHandle start
shandle  equ   1                        source handle
dhandle  equ   5                        destination handle
sptr     equ   9                        source pointer
dptr     equ   13                       destination pointer

         sub	(4:size,4:haddr),16

         ldy   #2                       recover the source handle
         lda   [haddr]
         sta   shandle
         lda   [haddr],Y
         sta   shandle+2
         ph4   shandle                  unlock the handle
         _HUnlock
         pha                            allocate a new area
         pha
         ph4   size
         ph2   >~User_ID
         ph2   #$8000
         ph4   #0
         _NewHandle
         bcc   lb0
         ph2   #3
	ph4	#0
         jsl   TermError
	
lb0      pl4   dhandle
         ph4   shandle                  lock the source handle
         _HLock
         ldy   #2                       dereference the dest handle
         lda   [dhandle]
         sta   dptr
         lda   [dhandle],Y
         sta   dptr+2
         lda   [shandle]                dereference the source handle
         sta   sptr
         lda   [shandle],Y
         sta   sptr+2
         pha                            get the size of the source handle
         pha
         ph4   shandle
         _GetHandleSize
         pl2   size
         plx                            move 64K chunks
         beq   lb2
         ldy   #0
lb1      lda   [sptr],Y
         sta   [dptr],Y
         dey
         dey
         bne   lb1
         inc   sptr+2
         inc   dptr+2
         dex
         bne   lb1
lb2      lda   size                     move the remaining bytes
         beq   lb5
         lsr   a
         bcc   lb2a
         short M
         lda   [sptr]
         sta   [dptr]
         long  M
         inc4  sptr
         inc4  dptr
         dec   size
         beq   lb5
lb2a     ldy   size
         bra   lb4
lb3      lda   [sptr],Y
         sta   [dptr],Y
lb4      dey
         dey
         bne   lb3
         lda   [sptr]
         sta   [dptr]
lb5      ph4   shandle                  dispose of the source handle
         _DisposeHandle
         ldy   #2                       save the new handle
         lda   dhandle
         sta   [haddr]
         lda   dhandle+2
         sta   [haddr],Y

         ret
         end

****************************************************************
*
*  Out - write a byte to the output file
*
*  Inputs:
*        b - byte to write (on stack)
*
****************************************************************
*
Out      start

         phb                            OutByte(b);
         pla
         ply
         plx
         phy
         pha
         plb
         jsr   OutByte
         inc   blkcnt                   blkcnt := blkcnt+1;
         rtl
         end

****************************************************************
*
*  Out2 - write a word to the output file
*
*  Inputs:
*        w - word to write (on stack)
*
****************************************************************
*
Out2     start

         phb                            OutWord(w);
         pla
         ply
         plx
         phy
         pha
         plb
         jsr   OutWord
         inc   blkcnt                   blkcnt := blkcnt+2;
         inc   blkcnt
         rtl
         end

****************************************************************
*
*  OutByte - write a byte to the object file
*
*  Inputs:
*        X - byte to write
*
****************************************************************
*
OutByte  private

         lda   objLen                   if objLen+segDisp = buffSize then
         clc
         adc   segDisp
         bcc   lb2
	phx		   PurgeObjBuffer;
	jsl	PurgeObjBuffer
	plx
	lda	objLen	   check for segment overflow
	clc
	adc	segDisp
	bcs	lb2a
lb2      ph4   objPtr                   p := pointer(ord4(objPtr)+segDisp);
         tsc                            p^ := b;
         phd
         tcd
         ldy   segDisp
         short M
         txa
         sta   [1],Y
         long  M
         inc   segDisp                  segDisp := segDisp+1;

	pld
         tsc
         clc
         adc   #4
         tcs
         rts

lb2a     lda   #$8000	handle a segment overflow
         sta   segDisp
         ph2   #112
         jsl   Error
	rts
         end

****************************************************************
*
*  OutWord - write a word to the object file
*
*  Inputs:
*        X - word to write
*
****************************************************************
*
OutWord  private

         lda   objLen                   if objLen+segDisp+1 = buffSize then
         sec
         adc   segDisp
         bcc   lb2
	phx		   PurgeObjBuffer;
	jsl	PurgeObjBuffer
	plx
	lda	objLen	   check for segment overflow
	sec
	adc	segDisp
	bcs	lb3
lb2      ph4   objPtr                   p := pointer(ord4(objPtr)+segDisp);
         tsc                            p^ := b;
         phd
         tcd
         ldy   segDisp
         txa
         sta   [1],Y
         iny                            segDisp := segDisp+2;
         iny
	sty   segDisp                  save new segDisp

         pld
         tsc
         clc
         adc   #4
         tcs
         rts

lb3      ph2   #112                     flag segment overflow error
         jsl   Error
         lda   #$8000
	sta	segDisp
	rts
         end

****************************************************************
*
*  TokenOut - write a byte to the interface file
*
*  Inputs:
*        4,s - byte to write (in a word)
*
****************************************************************
*
TokenOut start
         using ObjData
ptr      equ   1                        pointer to token buffer

         sub	(2:byte),4

         lda   codeGeneration           quit if no keep
         jeq   lb2
         ldy   tokenDisp                if at end of buffer then
         cpy   #tokenBuffSize
         bne   lb1
         add4  tokenLen,#tokenBuffSize    update tokenLen
         clc                              expand the token buffer
         lda   tokenLen
         adc   #tokenBuffSize+1
         tax
         lda   tokenLen+2
         adc   #0
         pha
         phx
         ph4   #tokenHandle
         jsl   GrowHandle
         move4 tokenHandle,ptr            dereference the pointer
         clc
         lda   [ptr]
         adc   tokenLen
         sta   tokenPtr
         ldy   #2
         lda   [ptr],Y
         adc   tokenLen+2
         sta   tokenPtr+2
         stz   tokenDisp                  set the disp back to 0
lb1      anop                           endif
         move4 tokenPtr,ptr             set the buffer pointer
         ldy   tokenDisp
         lda   byte                     save the byte
         sta   [ptr],Y
         inc   tokenDisp                inc disp in buffer
lb2      ret
         end
\ No newline at end of file
+	mcopy	objout.macros
+****************************************************************
+*
+*  Code Generator Output Routines
+*
+*  This module provides fast object module output for the code
+*  generator.  Currently, the maximum size for a single object
+*  segment is 64K.
+*
+*  By Mike Westerfield
+*
+*  Copyright July 1987
+*  Byte Works, Inc.
+*
+****************************************************************
+*
+ObjData  privdata                       place with ~globals
+;
+;  Constants
+;
+!			NOTE: tokenBuffSize also defined in cgi.pas
+tokenBuffSize equ 4095                  size of the token buffer
+         end
+
+****************************************************************
+*
+*  COut - write a code byte to the object file
+*
+*  Inputs:
+*        b - byte to write (on stack)
+*
+****************************************************************
+*
+COut     start
+
+         phb                            OutByte(b);
+         pla
+         ply
+         plx
+         phy
+         pha
+         plb
+         jsr   OutByte
+         inc   blkcnt                   blkcnt := blkcnt+1;
+         inc4  pc                       pc := pc+1;
+         rtl
+         end
+
+****************************************************************
+*
+*  CnOut - write a byte to the constant buffer
+*
+*  Inputs:
+*        i - byte to write
+*
+****************************************************************
+*
+CnOut    start
+maxCBuffLen equ 191                     max index into the constant buffer
+
+         lda   cBuffLen                 if cBuffLen = maxCBuffLen then
+         cmp   #maxCBuffLen
+         bne   lb1
+         jsl   Purge                       Purge;
+lb1      phb                            cBuff[cBuffLen] := i;
+         plx
+         ply
+         pla
+         phy
+         phx
+         plb
+         ldx   cBuffLen
+         short M
+         sta   cBuff,X
+         long  M
+         inc   cBuffLen                 cBuffLen := cBuffLen+1;
+         rtl
+         end
+
+****************************************************************
+*
+*  CnOut2 - write a word to the constant buffer
+*
+*  Inputs:
+*        i - word to write
+*
+****************************************************************
+*
+CnOut2   start
+maxCBuffLen equ 191                     max index into the constant buffer
+
+         lda   cBuffLen                 if cBuffLen+1 >= maxCBuffLen then
+         inc   A
+         cmp   #maxCBuffLen
+         blt   lb1
+         jsl   Purge                       Purge;
+lb1      phb                            cBuff[cBuffLen] := i;
+         plx
+         ply
+         pla
+         phy
+         phx
+         plb
+         ldx   cBuffLen
+         sta   cBuff,X
+         inx                            cBuffLen := cBuffLen+2;
+         inx
+         stx   cBuffLen
+         rtl
+         end
+
+****************************************************************
+*
+*  GrowHandle - Grow the area occupied by a handle
+*
+*  Inputs:
+*        size - new size for the buffer
+*        haddr - address of the handle
+*
+*  Notes:
+*        This subroutine must only be used if the handle is
+*        grown.  It will fail if you try to shrink the handle.
+*
+****************************************************************
+*
+GrowHandle start
+shandle  equ   1                        source handle
+dhandle  equ   5                        destination handle
+sptr     equ   9                        source pointer
+dptr     equ   13                       destination pointer
+
+         sub	(4:size,4:haddr),16
+
+         ldy   #2                       recover the source handle
+         lda   [haddr]
+         sta   shandle
+         lda   [haddr],Y
+         sta   shandle+2
+         ph4   shandle                  unlock the handle
+         _HUnlock
+         pha                            allocate a new area
+         pha
+         ph4   size
+         ph2   >~User_ID
+         ph2   #$8000
+         ph4   #0
+         _NewHandle
+         bcc   lb0
+         ph2   #3
+	ph4	#0
+         jsl   TermError
+	
+lb0      pl4   dhandle
+         ph4   shandle                  lock the source handle
+         _HLock
+         ldy   #2                       dereference the dest handle
+         lda   [dhandle]
+         sta   dptr
+         lda   [dhandle],Y
+         sta   dptr+2
+         lda   [shandle]                dereference the source handle
+         sta   sptr
+         lda   [shandle],Y
+         sta   sptr+2
+         pha                            get the size of the source handle
+         pha
+         ph4   shandle
+         _GetHandleSize
+         pl2   size
+         plx                            move 64K chunks
+         beq   lb2
+         ldy   #0
+lb1      lda   [sptr],Y
+         sta   [dptr],Y
+         dey
+         dey
+         bne   lb1
+         inc   sptr+2
+         inc   dptr+2
+         dex
+         bne   lb1
+lb2      lda   size                     move the remaining bytes
+         beq   lb5
+         lsr   a
+         bcc   lb2a
+         short M
+         lda   [sptr]
+         sta   [dptr]
+         long  M
+         inc4  sptr
+         inc4  dptr
+         dec   size
+         beq   lb5
+lb2a     ldy   size
+         bra   lb4
+lb3      lda   [sptr],Y
+         sta   [dptr],Y
+lb4      dey
+         dey
+         bne   lb3
+         lda   [sptr]
+         sta   [dptr]
+lb5      ph4   shandle                  dispose of the source handle
+         _DisposeHandle
+         ldy   #2                       save the new handle
+         lda   dhandle
+         sta   [haddr]
+         lda   dhandle+2
+         sta   [haddr],Y
+
+         ret
+         end
+
+****************************************************************
+*
+*  Out - write a byte to the output file
+*
+*  Inputs:
+*        b - byte to write (on stack)
+*
+****************************************************************
+*
+Out      start
+
+         phb                            OutByte(b);
+         pla
+         ply
+         plx
+         phy
+         pha
+         plb
+         jsr   OutByte
+         inc   blkcnt                   blkcnt := blkcnt+1;
+         rtl
+         end
+
+****************************************************************
+*
+*  Out2 - write a word to the output file
+*
+*  Inputs:
+*        w - word to write (on stack)
+*
+****************************************************************
+*
+Out2     start
+
+         phb                            OutWord(w);
+         pla
+         ply
+         plx
+         phy
+         pha
+         plb
+         jsr   OutWord
+         inc   blkcnt                   blkcnt := blkcnt+2;
+         inc   blkcnt
+         rtl
+         end
+
+****************************************************************
+*
+*  OutByte - write a byte to the object file
+*
+*  Inputs:
+*        X - byte to write
+*
+****************************************************************
+*
+OutByte  private
+
+         lda   objLen                   if objLen+segDisp = buffSize then
+         clc
+         adc   segDisp
+         bcc   lb2
+	phx		   PurgeObjBuffer;
+	jsl	PurgeObjBuffer
+	plx
+	lda	objLen	   check for segment overflow
+	clc
+	adc	segDisp
+	bcs	lb2a
+lb2      ph4   objPtr                   p := pointer(ord4(objPtr)+segDisp);
+         tsc                            p^ := b;
+         phd
+         tcd
+         ldy   segDisp
+         short M
+         txa
+         sta   [1],Y
+         long  M
+         inc   segDisp                  segDisp := segDisp+1;
+
+	pld
+         tsc
+         clc
+         adc   #4
+         tcs
+         rts
+
+lb2a     lda   #$8000	handle a segment overflow
+         sta   segDisp
+         ph2   #112
+         jsl   Error
+	rts
+         end
+
+****************************************************************
+*
+*  OutWord - write a word to the object file
+*
+*  Inputs:
+*        X - word to write
+*
+****************************************************************
+*
+OutWord  private
+
+         lda   objLen                   if objLen+segDisp+1 = buffSize then
+         sec
+         adc   segDisp
+         bcc   lb2
+	phx		   PurgeObjBuffer;
+	jsl	PurgeObjBuffer
+	plx
+	lda	objLen	   check for segment overflow
+	sec
+	adc	segDisp
+	bcs	lb3
+lb2      ph4   objPtr                   p := pointer(ord4(objPtr)+segDisp);
+         tsc                            p^ := b;
+         phd
+         tcd
+         ldy   segDisp
+         txa
+         sta   [1],Y
+         iny                            segDisp := segDisp+2;
+         iny
+	sty   segDisp                  save new segDisp
+
+         pld
+         tsc
+         clc
+         adc   #4
+         tcs
+         rts
+
+lb3      ph2   #112                     flag segment overflow error
+         jsl   Error
+         lda   #$8000
+	sta	segDisp
+	rts
+         end
+
+****************************************************************
+*
+*  TokenOut - write a byte to the interface file
+*
+*  Inputs:
+*        4,s - byte to write (in a word)
+*
+****************************************************************
+*
+TokenOut start
+         using ObjData
+ptr      equ   1                        pointer to token buffer
+
+         sub	(2:byte),4
+
+         lda   codeGeneration           quit if no keep
+         jeq   lb2
+         ldy   tokenDisp                if at end of buffer then
+         cpy   #tokenBuffSize
+         bne   lb1
+         add4  tokenLen,#tokenBuffSize    update tokenLen
+         clc                              expand the token buffer
+         lda   tokenLen
+         adc   #tokenBuffSize+1
+         tax
+         lda   tokenLen+2
+         adc   #0
+         pha
+         phx
+         ph4   #tokenHandle
+         jsl   GrowHandle
+         move4 tokenHandle,ptr            dereference the pointer
+         clc
+         lda   [ptr]
+         adc   tokenLen
+         sta   tokenPtr
+         ldy   #2
+         lda   [ptr],Y
+         adc   tokenLen+2
+         sta   tokenPtr+2
+         stz   tokenDisp                  set the disp back to 0
+lb1      anop                           endif
+         move4 tokenPtr,ptr             set the buffer pointer
+         ldy   tokenDisp
+         lda   byte                     save the byte
+         sta   [ptr],Y
+         inc   tokenDisp                inc disp in buffer
+lb2      ret
+         end
diff --git a/objout.macros b/objout.macros
old mode 100755
new mode 100644
index 7e78a6e..0afb808
--- a/objout.macros
+++ b/objout.macros
@@ -1 +1,516 @@
- MACRO
&LAB LONG &A,&B
 LCLB &I
 LCLB &M
&A AMID &A,1,1
&M SETB ("&A"="M").OR.("&A"="m")
&I SETB ("&A"="I").OR.("&A"="i")
 AIF C:&B=0,.A
&B AMID &B,1,1
&M SETB ("&B"="M").OR.("&B"="m").OR.&M
&I SETB ("&B"="I").OR.("&B"="i").OR.&I
.A
&LAB REP #&M*32+&I*16
 AIF .NOT.&M,.B
 LONGA ON
.B
 AIF .NOT.&I,.C
 LONGI ON
.C
 MEND
 MACRO
&LAB PH4 &N1
 LCLC &C
&LAB ANOP
&C AMID &N1,1,1
 AIF "&C"="#",.D
 AIF S:LONGA=1,.A
 REP #%00100000
.A
 AIF "&C"<>"{",.B
&C AMID &N1,L:&N1,1
 AIF "&C"<>"}",.G
&N1 AMID &N1,2,L:&N1-2
 LDY #2
 LDA (&N1),Y
 PHA
 LDA (&N1)
 PHA
 AGO .E
.B
 AIF "&C"<>"[",.C
 LDY #2
 LDA &N1,Y
 PHA
 LDA &N1
 PHA
 AGO .E
.C
 LDA &N1+2
 PHA
 LDA &N1
 PHA
 AGO .E
.D
&N1 AMID &N1,2,L:&N1-1
 PEA +(&N1)|-16
 PEA &N1
 AGO .F
.E
 AIF S:LONGA=1,.F
 SEP #%00100000
.F
 MEXIT
.G
 MNOTE "Missing closing '}'",16
 MEND
 MACRO
&LAB SHORT &A,&B
 LCLB &I
 LCLB &M
&A AMID &A,1,1
&M SETB ("&A"="M").OR.("&A"="m")
&I SETB ("&A"="I").OR.("&A"="i")
 AIF C:&B=0,.A
&B AMID &B,1,1
&M SETB ("&B"="M").OR.("&B"="m").OR.&M
&I SETB ("&B"="I").OR.("&B"="i").OR.&I
.A
&LAB SEP #&M*32+&I*16
 AIF .NOT.&M,.B
 LONGA OFF
.B
 AIF .NOT.&I,.C
 LONGI OFF
.C
 MEND
 MACRO
&LAB INC4 &A
&LAB ~SETM
 INC &A
 BNE ~&SYSCNT
 INC 2+&A
~&SYSCNT ~RESTM
 MEND
 MACRO
&LAB ~SETM
&LAB ANOP
 AIF C:&~LA,.B
 GBLB &~LA
 GBLB &~LI
.B
&~LA SETB S:LONGA
&~LI SETB S:LONGI
 AIF S:LONGA.AND.S:LONGI,.A
 REP #32*(.NOT.&~LA)+16*(.NOT.&~LI)
 LONGA ON
 LONGI ON
.A
 MEND
 MACRO
&LAB ~RESTM
&LAB ANOP
 AIF (&~LA+&~LI)=2,.I
 SEP #32*(.NOT.&~LA)+16*(.NOT.&~LI)
 AIF &~LA,.H
 LONGA OFF
.H
 AIF &~LI,.I
 LONGI OFF
.I
 MEND
 MACRO
&LAB PH2 &N1
 LCLC &C
&LAB ANOP
&C AMID &N1,1,1
 AIF "&C"="#",.D
 AIF S:LONGA=1,.A
 REP #%00100000
.A
 AIF "&C"<>"{",.B
&C AMID &N1,L:&N1,1
 AIF "&C"<>"}",.G
&N1 AMID &N1,2,L:&N1-2
 LDA (&N1)
 PHA
 AGO .E
.B
 LDA &N1
 PHA
 AGO .E
.D
&N1 AMID &N1,2,L:&N1-1
 PEA &N1
 AGO .F
.E
 AIF S:LONGA=1,.F
 SEP #%00100000
.F
 MEXIT
.G
 MNOTE "Missing closing '}'",16
 MEND
 macro
&l sub &parms,&work
&l anop
 aif c:&work,.a
 lclc &work
&work setc 0
.a
 gbla &totallen
 gbla &worklen
&worklen seta &work
&totallen seta 0
 aif c:&parms=0,.e
 lclc &len
 lclc &p
 lcla &i
&i seta c:&parms
.b
&p setc &parms(&i)
&len amid &p,2,1
 aif "&len"=":",.c
&len amid &p,1,2
&p amid &p,4,l:&p-3
 ago .d
.c
&len amid &p,1,1
&p amid &p,3,l:&p-2
.d
&p equ &totallen+4+&work
&totallen seta &totallen+&len
&i seta &i-1
 aif &i,^b
.e
 tsc
 aif &work=0,.f
 sec
 sbc #&work
 tcs
.f
 phd
 tcd
 mend
 MACRO
&LAB MOVE4 &A,&B
&LAB LDA &A
 STA &B
 LDA 2+&A
 STA 2+&B
 MEND
 MACRO
&LAB JEQ &BP
&LAB BNE *+5
 BRL &BP
 MEND
 macro
&l ret &r
&l anop
 lclc &len
 aif c:&r,.a
 lclc &r
&r setc 0
&len setc 0
 ago .h
.a
&len amid &r,2,1
 aif "&len"=":",.b
&len amid &r,1,2
&r amid &r,4,l:&r-3
 ago .c
.b
&len amid &r,1,1
&r amid &r,3,l:&r-2
.c
 aif &len<>2,.d
 ldy &r
 ago .h
.d
 aif &len<>4,.e
 ldx &r+2
 ldy &r
 ago .h
.e
 aif &len<>10,.g
 ldy #&r
 ldx #^&r
 ago .h
.g
 mnote 'Not a valid return length',16
 mexit
.h
 aif &totallen=0,.i
 lda &worklen+2
 sta &worklen+&totallen+2
 lda &worklen+1
 sta &worklen+&totallen+1
.i
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 aif &len=0,.j
 tya
.j
 rtl
 mend
 MACRO
&LAB ADD4 &M1,&M2,&M3
 LCLB &YISTWO
 LCLC &C
&LAB ~SETM
 AIF C:&M3,.A
&C AMID "&M2",1,1
 AIF "&C"<>"#",.A
&C AMID "&M1",1,1
 AIF "&C"="{",.A
 AIF "&C"="[",.A
&C AMID "&M2",2,L:&M2-1
 AIF &C>=65536,.A
 CLC
 ~LDA &M1
 ~OP ADC,&M2
 ~STA &M1
 BCC ~&SYSCNT
 ~OP.H INC,&M1
~&SYSCNT ANOP
 AGO .C
.A
 AIF C:&M3,.B
 LCLC &M3
&M3 SETC &M1
.B
 CLC
 ~LDA &M1
 ~OP ADC,&M2
 ~STA &M3
 ~LDA.H &M1
 ~OP.H ADC,&M2
 ~STA.H &M3
.C
 ~RESTM
 MEND
 MACRO
&LAB ~OP.H &OPC,&OP
&LAB ANOP
 LCLC &C
&C AMID "&OP",1,1
 AIF "&C"="[",.B
 AIF "&C"<>"{",.D
&C AMID "&OP",L:&OP,1
 AIF "&C"="}",.A
 MNOTE "Missing closing '}'",2
&OP SETC &OP}
.A
&OP AMID "&OP",2,L:&OP-2
&OP SETC (&OP)
.B
 AIF &YISTWO,.C
&YISTWO SETB 1
 LDY #2
&OP SETC "&OP,Y"
.C
 &OPC &OP
 MEXIT
.D
 AIF "&C"<>"#",.E
&OP AMID "&OP",2,L:&OP-1
&OP SETC "#^&OP"
 &OPC &OP
 MEXIT
.E
 &OPC 2+&OP
 MEND
 MACRO
&LAB ~LDA.H &OP
&LAB ANOP
 LCLC &C
&C AMID "&OP",1,1
 AIF "&C"="[",.B
 AIF "&C"<>"{",.D
&C AMID "&OP",L:&OP,1
 AIF "&C"="}",.A
 MNOTE "Missing closing '}'",2
&OP SETC &OP}
.A
&OP AMID "&OP",2,L:&OP-2
&OP SETC (&OP)
.B
 AIF &YISTWO,.C
&YISTWO SETB 1
 LDY #2
&OP SETC "&OP,Y"
.C
 LDA &OP
 MEXIT
.D
 AIF "&C"<>"#",.E
&OP AMID "&OP",2,L:&OP-1
&OP SETC "#^&OP"
 LDA &OP
 MEXIT
.E
 LDA 2+&OP
 MEND
 MACRO
&LAB ~STA.H &OP
&LAB ANOP
 LCLC &C
&C AMID "&OP",1,1
 AIF "&C"="[",.B
 AIF "&C"<>"{",.D
&C AMID "&OP",L:&OP,1
 AIF "&C"="}",.A
 MNOTE "Missing closing '}'",2
&OP SETC &OP}
.A
&OP AMID "&OP",2,L:&OP-2
&OP SETC (&OP)
.B
 AIF &YISTWO,.C
&YISTWO SETB 1
 LDY #2
&OP SETC "&OP,Y"
.C
 STA &OP
 MEXIT
.D
 STA 2+&OP
 MEND
 MACRO
&LAB ~LDA &OP
 LCLC &C
&C AMID "&OP",1,1
 AIF "&C"<>"{",.B
&C AMID "&OP",L:&OP,1
 AIF "&C"="}",.A
 MNOTE "Missing closing '}'",2
&OP SETC &OP}
.A
&OP AMID "&OP",2,L:&OP-2
&OP SETC (&OP)
.B
&LAB LDA &OP
 MEND
 MACRO
&LAB ~STA &OP
 LCLC &C
&C AMID "&OP",1,1
 AIF "&C"<>"{",.B
&C AMID "&OP",L:&OP,1
 AIF "&C"="}",.A
 MNOTE "Missing closing '}'",2
&OP SETC &OP}
.A
&OP AMID "&OP",2,L:&OP-2
&OP SETC (&OP)
.B
&LAB STA &OP
 MEND
 MACRO
&LAB ~OP &OPC,&OP
 LCLC &C
&C AMID "&OP",1,1
 AIF "&C"<>"{",.B
&C AMID "&OP",L:&OP,1
 AIF "&C"="}",.A
 MNOTE "Missing closing '}'",2
&OP SETC &OP}
.A
&OP AMID "&OP",2,L:&OP-2
&OP SETC (&OP)
.B
&LAB &OPC &OP
 MEND
 MACRO
&LAB _NEWHANDLE
&LAB LDX #$0902
 JSL $E10000
 MEND
 MACRO
&LAB PL4 &N1
 LCLC &C
&LAB ANOP
 AIF S:LONGA=1,.A
 REP #%00100000
.A
&C AMID &N1,1,1
 AIF "&C"<>"{",.B
&C AMID &N1,L:&N1,1
 AIF "&C"<>"}",.F
&N1 AMID &N1,2,L:&N1-2
 PLA
 STA (&N1)
 LDY #2
 PLA
 STA (&N1),Y
 AGO .D
.B
 AIF "&C"<>"[",.C
 PLA
 STA &N1
 LDY #2
 PLA
 STA &N1,Y
 AGO .D
.C
 PLA
 STA &N1
 PLA
 STA &N1+2
.D
 AIF S:LONGA=1,.E
 SEP #%00100000
.E
 MEXIT
.F
 MNOTE "Missing closing '}'",16
 MEND
 MACRO
&LAB _DISPOSEHANDLE
&LAB LDX #$1002
 JSL $E10000
 MEND
 MACRO
&LAB _HLOCK
&LAB LDX #$2002
 JSL $E10000
 MEND
 MACRO
&LAB _HUNLOCK
&LAB LDX #$2202
 JSL $E10000
 MEND
 MACRO
&LAB _GETHANDLESIZE
&LAB LDX #$1802
 JSL $E10000
 MEND
 MACRO
&LAB PL2 &N1
 LCLC &C
&LAB ANOP
 AIF S:LONGA=1,.A
 REP #%00100000
.A
&C AMID &N1,1,1
 AIF "&C"<>"{",.B
&C AMID &N1,L:&N1,1
 AIF "&C"<>"}",.F
&N1 AMID &N1,2,L:&N1-2
 PLA
 STA (&N1)
 AGO .D
.B
 PLA
 STA &N1
.D
 AIF S:LONGA=1,.E
 SEP #%00100000
.E
 MEXIT
.F
 MNOTE "Missing closing '}'",16
 MEND
\ No newline at end of file
+ MACRO
+&LAB LONG &A,&B
+ LCLB &I
+ LCLB &M
+&A AMID &A,1,1
+&M SETB ("&A"="M").OR.("&A"="m")
+&I SETB ("&A"="I").OR.("&A"="i")
+ AIF C:&B=0,.A
+&B AMID &B,1,1
+&M SETB ("&B"="M").OR.("&B"="m").OR.&M
+&I SETB ("&B"="I").OR.("&B"="i").OR.&I
+.A
+&LAB REP #&M*32+&I*16
+ AIF .NOT.&M,.B
+ LONGA ON
+.B
+ AIF .NOT.&I,.C
+ LONGI ON
+.C
+ MEND
+ MACRO
+&LAB PH4 &N1
+ LCLC &C
+&LAB ANOP
+&C AMID &N1,1,1
+ AIF "&C"="#",.D
+ AIF S:LONGA=1,.A
+ REP #%00100000
+.A
+ AIF "&C"<>"{",.B
+&C AMID &N1,L:&N1,1
+ AIF "&C"<>"}",.G
+&N1 AMID &N1,2,L:&N1-2
+ LDY #2
+ LDA (&N1),Y
+ PHA
+ LDA (&N1)
+ PHA
+ AGO .E
+.B
+ AIF "&C"<>"[",.C
+ LDY #2
+ LDA &N1,Y
+ PHA
+ LDA &N1
+ PHA
+ AGO .E
+.C
+ LDA &N1+2
+ PHA
+ LDA &N1
+ PHA
+ AGO .E
+.D
+&N1 AMID &N1,2,L:&N1-1
+ PEA +(&N1)|-16
+ PEA &N1
+ AGO .F
+.E
+ AIF S:LONGA=1,.F
+ SEP #%00100000
+.F
+ MEXIT
+.G
+ MNOTE "Missing closing '}'",16
+ MEND
+ MACRO
+&LAB SHORT &A,&B
+ LCLB &I
+ LCLB &M
+&A AMID &A,1,1
+&M SETB ("&A"="M").OR.("&A"="m")
+&I SETB ("&A"="I").OR.("&A"="i")
+ AIF C:&B=0,.A
+&B AMID &B,1,1
+&M SETB ("&B"="M").OR.("&B"="m").OR.&M
+&I SETB ("&B"="I").OR.("&B"="i").OR.&I
+.A
+&LAB SEP #&M*32+&I*16
+ AIF .NOT.&M,.B
+ LONGA OFF
+.B
+ AIF .NOT.&I,.C
+ LONGI OFF
+.C
+ MEND
+ MACRO
+&LAB INC4 &A
+&LAB ~SETM
+ INC &A
+ BNE ~&SYSCNT
+ INC 2+&A
+~&SYSCNT ~RESTM
+ MEND
+ MACRO
+&LAB ~SETM
+&LAB ANOP
+ AIF C:&~LA,.B
+ GBLB &~LA
+ GBLB &~LI
+.B
+&~LA SETB S:LONGA
+&~LI SETB S:LONGI
+ AIF S:LONGA.AND.S:LONGI,.A
+ REP #32*(.NOT.&~LA)+16*(.NOT.&~LI)
+ LONGA ON
+ LONGI ON
+.A
+ MEND
+ MACRO
+&LAB ~RESTM
+&LAB ANOP
+ AIF (&~LA+&~LI)=2,.I
+ SEP #32*(.NOT.&~LA)+16*(.NOT.&~LI)
+ AIF &~LA,.H
+ LONGA OFF
+.H
+ AIF &~LI,.I
+ LONGI OFF
+.I
+ MEND
+ MACRO
+&LAB PH2 &N1
+ LCLC &C
+&LAB ANOP
+&C AMID &N1,1,1
+ AIF "&C"="#",.D
+ AIF S:LONGA=1,.A
+ REP #%00100000
+.A
+ AIF "&C"<>"{",.B
+&C AMID &N1,L:&N1,1
+ AIF "&C"<>"}",.G
+&N1 AMID &N1,2,L:&N1-2
+ LDA (&N1)
+ PHA
+ AGO .E
+.B
+ LDA &N1
+ PHA
+ AGO .E
+.D
+&N1 AMID &N1,2,L:&N1-1
+ PEA &N1
+ AGO .F
+.E
+ AIF S:LONGA=1,.F
+ SEP #%00100000
+.F
+ MEXIT
+.G
+ MNOTE "Missing closing '}'",16
+ MEND
+ macro
+&l sub &parms,&work
+&l anop
+ aif c:&work,.a
+ lclc &work
+&work setc 0
+.a
+ gbla &totallen
+ gbla &worklen
+&worklen seta &work
+&totallen seta 0
+ aif c:&parms=0,.e
+ lclc &len
+ lclc &p
+ lcla &i
+&i seta c:&parms
+.b
+&p setc &parms(&i)
+&len amid &p,2,1
+ aif "&len"=":",.c
+&len amid &p,1,2
+&p amid &p,4,l:&p-3
+ ago .d
+.c
+&len amid &p,1,1
+&p amid &p,3,l:&p-2
+.d
+&p equ &totallen+4+&work
+&totallen seta &totallen+&len
+&i seta &i-1
+ aif &i,^b
+.e
+ tsc
+ aif &work=0,.f
+ sec
+ sbc #&work
+ tcs
+.f
+ phd
+ tcd
+ mend
+ MACRO
+&LAB MOVE4 &A,&B
+&LAB LDA &A
+ STA &B
+ LDA 2+&A
+ STA 2+&B
+ MEND
+ MACRO
+&LAB JEQ &BP
+&LAB BNE *+5
+ BRL &BP
+ MEND
+ macro
+&l ret &r
+&l anop
+ lclc &len
+ aif c:&r,.a
+ lclc &r
+&r setc 0
+&len setc 0
+ ago .h
+.a
+&len amid &r,2,1
+ aif "&len"=":",.b
+&len amid &r,1,2
+&r amid &r,4,l:&r-3
+ ago .c
+.b
+&len amid &r,1,1
+&r amid &r,3,l:&r-2
+.c
+ aif &len<>2,.d
+ ldy &r
+ ago .h
+.d
+ aif &len<>4,.e
+ ldx &r+2
+ ldy &r
+ ago .h
+.e
+ aif &len<>10,.g
+ ldy #&r
+ ldx #^&r
+ ago .h
+.g
+ mnote 'Not a valid return length',16
+ mexit
+.h
+ aif &totallen=0,.i
+ lda &worklen+2
+ sta &worklen+&totallen+2
+ lda &worklen+1
+ sta &worklen+&totallen+1
+.i
+ pld
+ tsc
+ clc
+ adc #&worklen+&totallen
+ tcs
+ aif &len=0,.j
+ tya
+.j
+ rtl
+ mend
+ MACRO
+&LAB ADD4 &M1,&M2,&M3
+ LCLB &YISTWO
+ LCLC &C
+&LAB ~SETM
+ AIF C:&M3,.A
+&C AMID "&M2",1,1
+ AIF "&C"<>"#",.A
+&C AMID "&M1",1,1
+ AIF "&C"="{",.A
+ AIF "&C"="[",.A
+&C AMID "&M2",2,L:&M2-1
+ AIF &C>=65536,.A
+ CLC
+ ~LDA &M1
+ ~OP ADC,&M2
+ ~STA &M1
+ BCC ~&SYSCNT
+ ~OP.H INC,&M1
+~&SYSCNT ANOP
+ AGO .C
+.A
+ AIF C:&M3,.B
+ LCLC &M3
+&M3 SETC &M1
+.B
+ CLC
+ ~LDA &M1
+ ~OP ADC,&M2
+ ~STA &M3
+ ~LDA.H &M1
+ ~OP.H ADC,&M2
+ ~STA.H &M3
+.C
+ ~RESTM
+ MEND
+ MACRO
+&LAB ~OP.H &OPC,&OP
+&LAB ANOP
+ LCLC &C
+&C AMID "&OP",1,1
+ AIF "&C"="[",.B
+ AIF "&C"<>"{",.D
+&C AMID "&OP",L:&OP,1
+ AIF "&C"="}",.A
+ MNOTE "Missing closing '}'",2
+&OP SETC &OP}
+.A
+&OP AMID "&OP",2,L:&OP-2
+&OP SETC (&OP)
+.B
+ AIF &YISTWO,.C
+&YISTWO SETB 1
+ LDY #2
+&OP SETC "&OP,Y"
+.C
+ &OPC &OP
+ MEXIT
+.D
+ AIF "&C"<>"#",.E
+&OP AMID "&OP",2,L:&OP-1
+&OP SETC "#^&OP"
+ &OPC &OP
+ MEXIT
+.E
+ &OPC 2+&OP
+ MEND
+ MACRO
+&LAB ~LDA.H &OP
+&LAB ANOP
+ LCLC &C
+&C AMID "&OP",1,1
+ AIF "&C"="[",.B
+ AIF "&C"<>"{",.D
+&C AMID "&OP",L:&OP,1
+ AIF "&C"="}",.A
+ MNOTE "Missing closing '}'",2
+&OP SETC &OP}
+.A
+&OP AMID "&OP",2,L:&OP-2
+&OP SETC (&OP)
+.B
+ AIF &YISTWO,.C
+&YISTWO SETB 1
+ LDY #2
+&OP SETC "&OP,Y"
+.C
+ LDA &OP
+ MEXIT
+.D
+ AIF "&C"<>"#",.E
+&OP AMID "&OP",2,L:&OP-1
+&OP SETC "#^&OP"
+ LDA &OP
+ MEXIT
+.E
+ LDA 2+&OP
+ MEND
+ MACRO
+&LAB ~STA.H &OP
+&LAB ANOP
+ LCLC &C
+&C AMID "&OP",1,1
+ AIF "&C"="[",.B
+ AIF "&C"<>"{",.D
+&C AMID "&OP",L:&OP,1
+ AIF "&C"="}",.A
+ MNOTE "Missing closing '}'",2
+&OP SETC &OP}
+.A
+&OP AMID "&OP",2,L:&OP-2
+&OP SETC (&OP)
+.B
+ AIF &YISTWO,.C
+&YISTWO SETB 1
+ LDY #2
+&OP SETC "&OP,Y"
+.C
+ STA &OP
+ MEXIT
+.D
+ STA 2+&OP
+ MEND
+ MACRO
+&LAB ~LDA &OP
+ LCLC &C
+&C AMID "&OP",1,1
+ AIF "&C"<>"{",.B
+&C AMID "&OP",L:&OP,1
+ AIF "&C"="}",.A
+ MNOTE "Missing closing '}'",2
+&OP SETC &OP}
+.A
+&OP AMID "&OP",2,L:&OP-2
+&OP SETC (&OP)
+.B
+&LAB LDA &OP
+ MEND
+ MACRO
+&LAB ~STA &OP
+ LCLC &C
+&C AMID "&OP",1,1
+ AIF "&C"<>"{",.B
+&C AMID "&OP",L:&OP,1
+ AIF "&C"="}",.A
+ MNOTE "Missing closing '}'",2
+&OP SETC &OP}
+.A
+&OP AMID "&OP",2,L:&OP-2
+&OP SETC (&OP)
+.B
+&LAB STA &OP
+ MEND
+ MACRO
+&LAB ~OP &OPC,&OP
+ LCLC &C
+&C AMID "&OP",1,1
+ AIF "&C"<>"{",.B
+&C AMID "&OP",L:&OP,1
+ AIF "&C"="}",.A
+ MNOTE "Missing closing '}'",2
+&OP SETC &OP}
+.A
+&OP AMID "&OP",2,L:&OP-2
+&OP SETC (&OP)
+.B
+&LAB &OPC &OP
+ MEND
+ MACRO
+&LAB _NEWHANDLE
+&LAB LDX #$0902
+ JSL $E10000
+ MEND
+ MACRO
+&LAB PL4 &N1
+ LCLC &C
+&LAB ANOP
+ AIF S:LONGA=1,.A
+ REP #%00100000
+.A
+&C AMID &N1,1,1
+ AIF "&C"<>"{",.B
+&C AMID &N1,L:&N1,1
+ AIF "&C"<>"}",.F
+&N1 AMID &N1,2,L:&N1-2
+ PLA
+ STA (&N1)
+ LDY #2
+ PLA
+ STA (&N1),Y
+ AGO .D
+.B
+ AIF "&C"<>"[",.C
+ PLA
+ STA &N1
+ LDY #2
+ PLA
+ STA &N1,Y
+ AGO .D
+.C
+ PLA
+ STA &N1
+ PLA
+ STA &N1+2
+.D
+ AIF S:LONGA=1,.E
+ SEP #%00100000
+.E
+ MEXIT
+.F
+ MNOTE "Missing closing '}'",16
+ MEND
+ MACRO
+&LAB _DISPOSEHANDLE
+&LAB LDX #$1002
+ JSL $E10000
+ MEND
+ MACRO
+&LAB _HLOCK
+&LAB LDX #$2002
+ JSL $E10000
+ MEND
+ MACRO
+&LAB _HUNLOCK
+&LAB LDX #$2202
+ JSL $E10000
+ MEND
+ MACRO
+&LAB _GETHANDLESIZE
+&LAB LDX #$1802
+ JSL $E10000
+ MEND
+ MACRO
+&LAB PL2 &N1
+ LCLC &C
+&LAB ANOP
+ AIF S:LONGA=1,.A
+ REP #%00100000
+.A
+&C AMID &N1,1,1
+ AIF "&C"<>"{",.B
+&C AMID &N1,L:&N1,1
+ AIF "&C"<>"}",.F
+&N1 AMID &N1,2,L:&N1-2
+ PLA
+ STA (&N1)
+ AGO .D
+.B
+ PLA
+ STA &N1
+.D
+ AIF S:LONGA=1,.E
+ SEP #%00100000
+.E
+ MEXIT
+.F
+ MNOTE "Missing closing '}'",16
+ MEND
diff --git a/objout.pas b/objout.pas
old mode 100755
new mode 100644
index 9ae7c9e..e506ee5
--- a/objout.pas
+++ b/objout.pas
@@ -1 +1,561 @@
-{$optimize -1}
{---------------------------------------------------------------}
{                                                               }
{  ObjOut                                                       }
{                                                               }
{  This unit has the primitive routines used to actually        }
{  create and write to object modules.  A few low-level         }
{  subroutines that need to be in assembly language for speed   }
{  are also included here.                                      }
{                                                               }
{---------------------------------------------------------------}

unit ObjOut;

interface

{$LibPrefix '0/obj/'}

uses PCommon, CGI, CGC;

{$segment 'CodeGen'}

procedure CloseObj;

{ close the current obj file                                    }
{								}
{ Note: Declared as extern in CGI.pas				}


procedure CloseSeg;

{ close out the current segment                                 }


procedure COut (b: integer); extern;

{ write a code byte to the object file                          }
{                                                               }
{ parameters:                                                   }
{       b - byte to write                                       }


procedure CnOut (i: integer); extern;

{ write a byte to the constant buffer                           }
{                                                               }
{ parameters:                                                   }
{       i - byte to write                                       }


procedure CnOut2 (i: integer); extern;

{ write a word to the constant buffer                           }
{                                                               }
{ parameters:                                                   }
{       i - word to write                                       }


procedure DestroySuffixes (var name: gsosOutString);

{ destroy the .a, .b, etc suffixes                              }
{                                                               }
{ parameters:                                                   }
{       name - root name of file sequence to destroy            }


procedure FindSuffix (var name: gsosOutString; var ch: char);

{ find the next available alphabetic suffix                     }
{                                                               }
{ parameters:                                                   }
{       ch - addr to place suffix character                     }
{       name - root name of suffix to find                      }


procedure Header (name: pStringPtr; kind: integer; lengthCode: integer);

{ write a segment header to the output file                     }
{                                                               }
{ parameters:                                                   }
{       name - name of the segment                              }
{       kind - segment kind                                     }
{       lengthCode - code bank size code; bank size div $10000  }


procedure OpenObj (var name: gsosOutString);

{ open a new obj file with the indicated file name              }
{                                                               }
{ parameters:                                                   }
{       name - object file name                                 }


procedure OpenSeg;

{ create a new segment and mark its beginning                   }


procedure Out (b: integer); extern;

{ write a byte to the output file                               }
{                                                               }
{ parameters:                                                   }
{       b - byte to write                                       }


procedure Out2 (w: integer); extern;

{ write a word to the output file                               }
{                                                               }
{ parameters:                                                   }
{       w - word to write                                       }


procedure TokenOut (b: byte); extern;

{ Write a byte to the interface file				}
{								}
{ parameters:							}
{    b - byte to write						}
{								}
{ Notes: Also declared as extern in cgi.pas			}


procedure Purge;

{ write any constant bytes to the output buffer                 }

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

implementation

const
					{NOTE: OutByte and Outword assume }
                                        { buffSize is 64K		  }
   buffSize = 65536;			{size of the obj buffer}
   maxCBuffLen  = 191;                  {length of the constant buffer}
   OBJ = $B1;                           {object file type}

type
   closeOSDCB = record			{Close DCB}
      pcount: integer;
      refNum: integer;
      end;

   createOSDCB = record			{Create DCB}
      pcount: integer;
      pathName: gsosInStringPtr;
      access: integer;
      fileType: integer;
      auxType: longint;
      storageType: integer;
      dataEOF: longint;
      resourceEOF: longint;
      end;

   openOSDCB = record			{Open DCB}
      pcount: integer;
      refNum: integer;
      pathName: gsosInStringPtr;
      requestAccess: integer;
      resourceNumber: integer;
      access: integer;
      fileType: integer;
      auxType: longint;
      storageType: integer;
      createDateTime: timeField;
      modDateTime: timeField;
      optionList: optionListPtr;
      dataEOF: longint;
      blocksUsed: longint;
      resourceEOF: longint;
      resourceBlocks: longint;
      end;
      
   readWriteOSDCB = record		{WriteGS DCB}
      pcount: integer;
      refNum: integer;
      dataBuffer: ptr;
      requestCount: longint;
      transferCount: longint;
      cachePriority: integer;
      end;

var
   cBuff: array[0..maxCBuffLen] of byte; {constant buffer}

   objFile: gsosOutString;              {object file name}
   objLen: longint;                     {# bytes used in obj buffer}
   objHandle: handle;                   {handle of the obj buffer}
   objPtr: ptr;                         {pointer to the next spot in the obj buffer}

   segStart: ptr;			{points to first byte in current segment}
   spoolRefnum: integer;		{reference number for open file}

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

                                        {ProDOS calls}
                                        {------------}

procedure CloseGS (var parms: closeOSDCB); prodos ($2014);
           
procedure CreateGS (var parms: createOSDCB); prodos ($2001);
   
procedure OpenGS (var parms: openOSDCB); prodos ($2010);

procedure WriteGS (var parms: readWriteOSDCB); prodos ($2013);
                                                        
                                        {memory manager calls}
                                        {--------------------}

procedure BlockMove (sourcPtr, destPtr: ptr; count: longint); tool ($02, $2B);

procedure HUnLock (theHandle: handle); tool ($02, $22);

procedure HLock (theHandle: handle); tool ($02, $20);

function NewHandle (blockSize: longint; userID, memAttributes: integer;
                    memLocation: ptr): handle; tool($02, $09);

procedure SetHandleSize (newSize: longint; theHandle: handle); tool ($02, $19);

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

procedure PurgeObjBuffer;

{ Spool any completed segments to the object file               }

var
   len: longint;			{# bytes to write}
   sPtr: ptr;				{start of object buffer}
   wrRec: readWriteOSDCB;		{WriteGS record}


   procedure InitSpoolFile;

   { Set up the spool file					}

   var
      dsRec: destroyOSDCB;		{DestroyGS record}
      crRec: createOSDCB;		{CreateGS record}
      opRec: openOSDCB;			{OpenGS record}
      
   begin {InitSpoolFile}
   if memoryFlag then			{make sure this is a disk-based compile}
      TermError(5, nil);
   dsRec.pCount := 1;			{destroy any old file}
   dsRec.pathname := @objFile.theString;
   DestroyGS(dsRec);
   crRec.pCount := 5;			{create a new file}
   crRec.pathName := @objFile.theString;
   crRec.access := $C3;
   crRec.fileType := OBJ;
   crRec.auxType := $0000;
   crRec.storageType := 1;
   CreateGS(crRec);
   if ToolError <> 0 then                    
      TermError(8, nil);
   opRec.pCount := 3;			{open the file}
   opRec.pathname := @objFile.theString;
   opRec.requestAccess := 3;
   OpenGS(opRec);
   if ToolError <> 0 then
      TermError(8, nil);
   spoolRefnum := opRec.refnum;
   end; {InitSpoolFile}


begin {PurgeObjBuffer}
if spoolRefnum = 0 then			{make sure the spool file exists}
   InitSpoolFile;
sPtr := objHandle^;			{determine size of completed segments}
len := ord4(segStart) - ord4(sPtr);
if len <> 0 then begin
   wrRec.pcount := 4;			{write completed segments}
   wrRec.refnum := spoolRefnum;
   wrRec.dataBuffer := pointer(sPtr);
   wrRec.requestCount := len;
   WriteGS(wrRec);
   if ToolError <> 0 then		{check for write errors}
      TermError(13, nil);
   objLen := 0;				{adjust file pointers}
   BlockMove(segStart, sPtr, ord4(segDisp) & $00FFFF);
   objPtr := sPtr;
   segStart := sPtr;
   end; {if}                      
end; {PurgeObjBuffer}


procedure CloseObj;

{ close the current obj file                                    }
{								}
{ Note: Declared as extern in CGI.pas				}

var
   clRec: closeOSDCB;			{CloseGS record}
   ffDCBGS: fastFileDCBGS;		{dcb for fastfile call}
   i: integer;				{loop/index variable}

begin {CloseObj}
if spoolRefnum <> 0 then begin
   PurgeObjBuffer;
   clRec.pCount := 1;
   clRec.refnum := spoolRefnum;
   CloseGS(clRec);
   end {if}
else if objLen <> 0 then begin
   {resize the buffer}
   HUnLock(objHandle);
   SetHandleSize(objLen, objHandle);
   HLock(objHandle);

   {save the file}
   ffDCBGS.pCount := 14;
   ffDCBGS.fileHandle := objHandle;
   ffDCBGS.pathName := @objFile.theString;
   ffDCBGS.access := $C3;
   ffDCBGS.fileType := OBJ;
   ffDCBGS.auxType := 0;
   ffDCBGS.storageType := 1;
   for i := 1 to 8 do
      ffDCBGS.createDate[i] := 0;
   ffDCBGS.modDate := ffDCBGS.createDate;
   ffDCBGS.option := nil;
   ffDCBGS.fileLength := objLen;
   if memoryFlag then begin
      ffDCBGS.flags := 0;
      ffDCBGS.action := 4;
      end {if}
   else begin
      ffDCBGS.flags := $C000;
      ffDCBGS.action := 3;
      end; {else}
   FastFileGS(ffDCBGS);
   if ToolError <> 0 then
      TermError(13, nil)
   else begin
      ffDCBGS.PATHName := @objFile.theString;
      ffDCBGS.action := 7;
      FastFileGS(ffDCBGS);
      end; {else}
   end; {if}
end; {CloseObj}


procedure CloseSeg;

{ close out the current segment                                 }
{                                                               }
{ variables:                                                    }
{       objHandle - segment handle                              }
{       objLen - used bytes in the segment                      }
{       objPtr - set to point to a fresh segment                }

var
   longPtr: ^longint;                   {used to set the block count}

begin {CloseSeg}
longPtr := pointer(objPtr);             {set the block count}
longPtr^ := ord4(segDisp) & $00FFFF;
objLen := objLen + (ord4(segDisp) & $00FFFF); {update the length of the obj file}
objPtr := pointer(ord4(objHandle^)+objLen); {set objPtr}
segStart := objPtr;
if objLen = buffSize then
   PurgeObjBuffer;
end; {CloseSeg}


procedure DestroySuffixes {var name: gsosOutString};

{ destroy the .a, .b, etc suffixes                              }
{                                                               }
{ parameters:                                                   }
{       name - root name of file sequence to destroy            }

var
   done: boolean;                       {loop termination flag}
   dsDCBGS: destroyOSDCB;		{dcb for destroy call}
   ffDCBGS: fastFileDCBGS;		{dcb for fastfile calls}
   giDCBGS: getFileInfoOSDCB;		{dcb for Get_File_Info call}
   suffix: char;                        {current suffix character}

   fName: gsosInString;                 {work file name}

begin {DestroySuffixes}
suffix := 'a';
done := false;
repeat
   fName := name.theString;
   if fName.size > maxPath-2 then
      fName.size := maxPath-2;
   fName.theString[fName.size+1] := '.';
   fName.theString[fName.size+2] := suffix;
   fName.size := fName.size + 2;
   giDCBGS.pCount := 12;
   giDCBGS.optionList := nil;
   giDCBGS.pathName := @fName;
   GetFileInfoGS(giDCBGS);
   if ToolError = 0 then begin
      if giDCBGS.fileType = OBJ then begin
         dsDCBGS.pCount := 1;
         dsDCBGS.pathName := @fName;
         DestroyGS(dsDCBGS);
         end; {if}
      end {if}
   else
      done := true;
   suffix := succ(suffix);
until done;
end; {DestroySuffixes}


procedure FindSuffix {var name: gsosOutString; var ch: char};
          
{ find the next available alphabetic suffix                     }
{                                                               }
{ parameters:                                                   }
{       ch - addr to place suffix character                     }
{       name - root name of suffix to find                      }

var
   done: boolean;                       {loop termination test}
   giDCBGS: getFileInfoOSDCB;		{dcb for Get_File_Info call}

   fName: gsosInString;			{work file name}

begin {FindSuffix}
ch := 'a';
done := false;
repeat
   fName := name.theString;
   if fName.size > maxPath-2 then
      fName.size := maxPath-2;
   fName.theString[fName.size+1] := '.';
   fName.theString[fName.size+2] := ch;
   fName.size := fName.size + 2;
   giDCBGS.pCount := 12;
   giDCBGS.optionList := nil;
   giDCBGS.pathName := @fName;
   GetFileInfoGS(giDCBGS);
   if ToolError = 0 then
      ch := succ(ch)
   else
      done := true;
until done;
end; {FindSuffix}


procedure Header {name: pStringPtr; kind: integer; lengthCode: integer};

{ write a segment header to the output file                     }
{                                                               }
{ parameters:                                                   }
{       name - name of the segment                              }
{       kind - segment kind                                     }
{       lengthCode - code bank size code; bank size div $10000  }


var
   i: integer;                          {loop var}
   len: integer;                        {length of string}

begin {Header}
OpenSeg;                                {start the new segment}
blkcnt := 0; segdisp := 0;
for i := 1 to 12 do                     {blkcnt,resspc,length}
   Out(0);
Out(0);					{unused}
Out(0);                                 {lablen}
Out(4);                                 {numlen}
Out(2);                                 {version}
Out2(0); Out2(ord(lengthcode=0));       {cbanksize}
Out2(kind|segmentKind);			{kind}
for i := 1 to 9 do                 {unused,org,align,numsex,unused,segnum,entry}
   Out2(0);
len := length(name^);                   {dispname,dispdata}
Out2($30); Out2($3B+len);
Out2(0); Out2(0);			{temporg}
for i := 1 to 10 do                     {write the segment name}
   Out(ord(currentSegment[i]));
currentSegment := defaultSegment;       {revert to default segment name}
Out(len);                               {segname}
for i := 1 to len do
   Out(ord(name^[i]));
end; {Header}


procedure OpenObj {var name: gsosOutString};

{ open a new obj file with the indicated file name              }
{                                                               }
{ parameters:                                                   }
{       name - object file name                                 }

var
   dsDCBGS: destroyOSDCB;		{dcb for Destroy call}
   giDCBGS: getFileInfoOSDCB;		{dcb for Get_File_Info call}

begin {OpenObj}
{the file is not spooled (yet)}
spoolRefnum := 0;

{if there is an existing file, delete it}
if memoryFlag then begin
   giDCBGS.pCount := 3;
   giDCBGS.pathName := @name.theString;
   GetFileInfoGS(giDCBGS);
   if ToolError = 0 then
      if giDCBGS.fileType = OBJ then begin
         dsDCBGS.pCount := 1;
         dsDCBGS.pathName := @name.theString;
         DestroyGS(dsDCBGS);
         end; {if}
   end; {if}

{allocate memory for an initial buffer}
objHandle := pointer(NewHandle(buffSize, userID, $8000, nil));

{set up the buffer variables}
if ToolError = 0 then begin
   objLen := 0;
   objPtr := objHandle^;
   end {if}
else begin
   TermError(3, nil);
   end;       
{save the object file name}
objFile := name;
end; {OpenObj}


procedure OpenSeg;

{ create a new segment and mark its beginning                   }

begin {OpenSeg}
segDisp := 0;
segStart := objPtr;
end; {OpenSeg}


procedure Purge;

{ write any constant bytes to the output buffer                 }

var
   i: integer;                          {loop variable}

begin {Purge}
if cBuffLen <> 0 then begin
   Out(cBuffLen);
   for i := 0 to cBuffLen-1 do
      COut(cBuff[i]);
   cBuffLen := 0;
   end; {if}
end; {Purge}

end.                  

{$append 'objout.asm'}
\ No newline at end of file
+{$optimize -1}
+{---------------------------------------------------------------}
+{                                                               }
+{  ObjOut                                                       }
+{                                                               }
+{  This unit has the primitive routines used to actually        }
+{  create and write to object modules.  A few low-level         }
+{  subroutines that need to be in assembly language for speed   }
+{  are also included here.                                      }
+{                                                               }
+{---------------------------------------------------------------}
+
+unit ObjOut;
+
+interface
+
+{$LibPrefix '0/obj/'}
+
+uses PCommon, CGI, CGC;
+
+{$segment 'CodeGen'}
+
+procedure CloseObj;
+
+{ close the current obj file                                    }
+{								}
+{ Note: Declared as extern in CGI.pas				}
+
+
+procedure CloseSeg;
+
+{ close out the current segment                                 }
+
+
+procedure COut (b: integer); extern;
+
+{ write a code byte to the object file                          }
+{                                                               }
+{ parameters:                                                   }
+{       b - byte to write                                       }
+
+
+procedure CnOut (i: integer); extern;
+
+{ write a byte to the constant buffer                           }
+{                                                               }
+{ parameters:                                                   }
+{       i - byte to write                                       }
+
+
+procedure CnOut2 (i: integer); extern;
+
+{ write a word to the constant buffer                           }
+{                                                               }
+{ parameters:                                                   }
+{       i - word to write                                       }
+
+
+procedure DestroySuffixes (var name: gsosOutString);
+
+{ destroy the .a, .b, etc suffixes                              }
+{                                                               }
+{ parameters:                                                   }
+{       name - root name of file sequence to destroy            }
+
+
+procedure FindSuffix (var name: gsosOutString; var ch: char);
+
+{ find the next available alphabetic suffix                     }
+{                                                               }
+{ parameters:                                                   }
+{       ch - addr to place suffix character                     }
+{       name - root name of suffix to find                      }
+
+
+procedure Header (name: pStringPtr; kind: integer; lengthCode: integer);
+
+{ write a segment header to the output file                     }
+{                                                               }
+{ parameters:                                                   }
+{       name - name of the segment                              }
+{       kind - segment kind                                     }
+{       lengthCode - code bank size code; bank size div $10000  }
+
+
+procedure OpenObj (var name: gsosOutString);
+
+{ open a new obj file with the indicated file name              }
+{                                                               }
+{ parameters:                                                   }
+{       name - object file name                                 }
+
+
+procedure OpenSeg;
+
+{ create a new segment and mark its beginning                   }
+
+
+procedure Out (b: integer); extern;
+
+{ write a byte to the output file                               }
+{                                                               }
+{ parameters:                                                   }
+{       b - byte to write                                       }
+
+
+procedure Out2 (w: integer); extern;
+
+{ write a word to the output file                               }
+{                                                               }
+{ parameters:                                                   }
+{       w - word to write                                       }
+
+
+procedure TokenOut (b: byte); extern;
+
+{ Write a byte to the interface file				}
+{								}
+{ parameters:							}
+{    b - byte to write						}
+{								}
+{ Notes: Also declared as extern in cgi.pas			}
+
+
+procedure Purge;
+
+{ write any constant bytes to the output buffer                 }
+
+{---------------------------------------------------------------}
+
+implementation
+
+const
+					{NOTE: OutByte and Outword assume }
+                                        { buffSize is 64K		  }
+   buffSize = 65536;			{size of the obj buffer}
+   maxCBuffLen  = 191;                  {length of the constant buffer}
+   OBJ = $B1;                           {object file type}
+
+type
+   closeOSDCB = record			{Close DCB}
+      pcount: integer;
+      refNum: integer;
+      end;
+
+   createOSDCB = record			{Create DCB}
+      pcount: integer;
+      pathName: gsosInStringPtr;
+      access: integer;
+      fileType: integer;
+      auxType: longint;
+      storageType: integer;
+      dataEOF: longint;
+      resourceEOF: longint;
+      end;
+
+   openOSDCB = record			{Open DCB}
+      pcount: integer;
+      refNum: integer;
+      pathName: gsosInStringPtr;
+      requestAccess: integer;
+      resourceNumber: integer;
+      access: integer;
+      fileType: integer;
+      auxType: longint;
+      storageType: integer;
+      createDateTime: timeField;
+      modDateTime: timeField;
+      optionList: optionListPtr;
+      dataEOF: longint;
+      blocksUsed: longint;
+      resourceEOF: longint;
+      resourceBlocks: longint;
+      end;
+      
+   readWriteOSDCB = record		{WriteGS DCB}
+      pcount: integer;
+      refNum: integer;
+      dataBuffer: ptr;
+      requestCount: longint;
+      transferCount: longint;
+      cachePriority: integer;
+      end;
+
+var
+   cBuff: array[0..maxCBuffLen] of byte; {constant buffer}
+
+   objFile: gsosOutString;              {object file name}
+   objLen: longint;                     {# bytes used in obj buffer}
+   objHandle: handle;                   {handle of the obj buffer}
+   objPtr: ptr;                         {pointer to the next spot in the obj buffer}
+
+   segStart: ptr;			{points to first byte in current segment}
+   spoolRefnum: integer;		{reference number for open file}
+
+{---------------------------------------------------------------}
+
+                                        {ProDOS calls}
+                                        {------------}
+
+procedure CloseGS (var parms: closeOSDCB); prodos ($2014);
+           
+procedure CreateGS (var parms: createOSDCB); prodos ($2001);
+   
+procedure OpenGS (var parms: openOSDCB); prodos ($2010);
+
+procedure WriteGS (var parms: readWriteOSDCB); prodos ($2013);
+                                                        
+                                        {memory manager calls}
+                                        {--------------------}
+
+procedure BlockMove (sourcPtr, destPtr: ptr; count: longint); tool ($02, $2B);
+
+procedure HUnLock (theHandle: handle); tool ($02, $22);
+
+procedure HLock (theHandle: handle); tool ($02, $20);
+
+function NewHandle (blockSize: longint; userID, memAttributes: integer;
+                    memLocation: ptr): handle; tool($02, $09);
+
+procedure SetHandleSize (newSize: longint; theHandle: handle); tool ($02, $19);
+
+{---------------------------------------------------------------}
+
+procedure PurgeObjBuffer;
+
+{ Spool any completed segments to the object file               }
+
+var
+   len: longint;			{# bytes to write}
+   sPtr: ptr;				{start of object buffer}
+   wrRec: readWriteOSDCB;		{WriteGS record}
+
+
+   procedure InitSpoolFile;
+
+   { Set up the spool file					}
+
+   var
+      dsRec: destroyOSDCB;		{DestroyGS record}
+      crRec: createOSDCB;		{CreateGS record}
+      opRec: openOSDCB;			{OpenGS record}
+      
+   begin {InitSpoolFile}
+   if memoryFlag then			{make sure this is a disk-based compile}
+      TermError(5, nil);
+   dsRec.pCount := 1;			{destroy any old file}
+   dsRec.pathname := @objFile.theString;
+   DestroyGS(dsRec);
+   crRec.pCount := 5;			{create a new file}
+   crRec.pathName := @objFile.theString;
+   crRec.access := $C3;
+   crRec.fileType := OBJ;
+   crRec.auxType := $0000;
+   crRec.storageType := 1;
+   CreateGS(crRec);
+   if ToolError <> 0 then                    
+      TermError(8, nil);
+   opRec.pCount := 3;			{open the file}
+   opRec.pathname := @objFile.theString;
+   opRec.requestAccess := 3;
+   OpenGS(opRec);
+   if ToolError <> 0 then
+      TermError(8, nil);
+   spoolRefnum := opRec.refnum;
+   end; {InitSpoolFile}
+
+
+begin {PurgeObjBuffer}
+if spoolRefnum = 0 then			{make sure the spool file exists}
+   InitSpoolFile;
+sPtr := objHandle^;			{determine size of completed segments}
+len := ord4(segStart) - ord4(sPtr);
+if len <> 0 then begin
+   wrRec.pcount := 4;			{write completed segments}
+   wrRec.refnum := spoolRefnum;
+   wrRec.dataBuffer := pointer(sPtr);
+   wrRec.requestCount := len;
+   WriteGS(wrRec);
+   if ToolError <> 0 then		{check for write errors}
+      TermError(13, nil);
+   objLen := 0;				{adjust file pointers}
+   BlockMove(segStart, sPtr, ord4(segDisp) & $00FFFF);
+   objPtr := sPtr;
+   segStart := sPtr;
+   end; {if}                      
+end; {PurgeObjBuffer}
+
+
+procedure CloseObj;
+
+{ close the current obj file                                    }
+{								}
+{ Note: Declared as extern in CGI.pas				}
+
+var
+   clRec: closeOSDCB;			{CloseGS record}
+   ffDCBGS: fastFileDCBGS;		{dcb for fastfile call}
+   i: integer;				{loop/index variable}
+
+begin {CloseObj}
+if spoolRefnum <> 0 then begin
+   PurgeObjBuffer;
+   clRec.pCount := 1;
+   clRec.refnum := spoolRefnum;
+   CloseGS(clRec);
+   end {if}
+else if objLen <> 0 then begin
+   {resize the buffer}
+   HUnLock(objHandle);
+   SetHandleSize(objLen, objHandle);
+   HLock(objHandle);
+
+   {save the file}
+   ffDCBGS.pCount := 14;
+   ffDCBGS.fileHandle := objHandle;
+   ffDCBGS.pathName := @objFile.theString;
+   ffDCBGS.access := $C3;
+   ffDCBGS.fileType := OBJ;
+   ffDCBGS.auxType := 0;
+   ffDCBGS.storageType := 1;
+   for i := 1 to 8 do
+      ffDCBGS.createDate[i] := 0;
+   ffDCBGS.modDate := ffDCBGS.createDate;
+   ffDCBGS.option := nil;
+   ffDCBGS.fileLength := objLen;
+   if memoryFlag then begin
+      ffDCBGS.flags := 0;
+      ffDCBGS.action := 4;
+      end {if}
+   else begin
+      ffDCBGS.flags := $C000;
+      ffDCBGS.action := 3;
+      end; {else}
+   FastFileGS(ffDCBGS);
+   if ToolError <> 0 then
+      TermError(13, nil)
+   else begin
+      ffDCBGS.PATHName := @objFile.theString;
+      ffDCBGS.action := 7;
+      FastFileGS(ffDCBGS);
+      end; {else}
+   end; {if}
+end; {CloseObj}
+
+
+procedure CloseSeg;
+
+{ close out the current segment                                 }
+{                                                               }
+{ variables:                                                    }
+{       objHandle - segment handle                              }
+{       objLen - used bytes in the segment                      }
+{       objPtr - set to point to a fresh segment                }
+
+var
+   longPtr: ^longint;                   {used to set the block count}
+
+begin {CloseSeg}
+longPtr := pointer(objPtr);             {set the block count}
+longPtr^ := ord4(segDisp) & $00FFFF;
+objLen := objLen + (ord4(segDisp) & $00FFFF); {update the length of the obj file}
+objPtr := pointer(ord4(objHandle^)+objLen); {set objPtr}
+segStart := objPtr;
+if objLen = buffSize then
+   PurgeObjBuffer;
+end; {CloseSeg}
+
+
+procedure DestroySuffixes {var name: gsosOutString};
+
+{ destroy the .a, .b, etc suffixes                              }
+{                                                               }
+{ parameters:                                                   }
+{       name - root name of file sequence to destroy            }
+
+var
+   done: boolean;                       {loop termination flag}
+   dsDCBGS: destroyOSDCB;		{dcb for destroy call}
+   ffDCBGS: fastFileDCBGS;		{dcb for fastfile calls}
+   giDCBGS: getFileInfoOSDCB;		{dcb for Get_File_Info call}
+   suffix: char;                        {current suffix character}
+
+   fName: gsosInString;                 {work file name}
+
+begin {DestroySuffixes}
+suffix := 'a';
+done := false;
+repeat
+   fName := name.theString;
+   if fName.size > maxPath-2 then
+      fName.size := maxPath-2;
+   fName.theString[fName.size+1] := '.';
+   fName.theString[fName.size+2] := suffix;
+   fName.size := fName.size + 2;
+   giDCBGS.pCount := 12;
+   giDCBGS.optionList := nil;
+   giDCBGS.pathName := @fName;
+   GetFileInfoGS(giDCBGS);
+   if ToolError = 0 then begin
+      if giDCBGS.fileType = OBJ then begin
+         dsDCBGS.pCount := 1;
+         dsDCBGS.pathName := @fName;
+         DestroyGS(dsDCBGS);
+         end; {if}
+      end {if}
+   else
+      done := true;
+   suffix := succ(suffix);
+until done;
+end; {DestroySuffixes}
+
+
+procedure FindSuffix {var name: gsosOutString; var ch: char};
+          
+{ find the next available alphabetic suffix                     }
+{                                                               }
+{ parameters:                                                   }
+{       ch - addr to place suffix character                     }
+{       name - root name of suffix to find                      }
+
+var
+   done: boolean;                       {loop termination test}
+   giDCBGS: getFileInfoOSDCB;		{dcb for Get_File_Info call}
+
+   fName: gsosInString;			{work file name}
+
+begin {FindSuffix}
+ch := 'a';
+done := false;
+repeat
+   fName := name.theString;
+   if fName.size > maxPath-2 then
+      fName.size := maxPath-2;
+   fName.theString[fName.size+1] := '.';
+   fName.theString[fName.size+2] := ch;
+   fName.size := fName.size + 2;
+   giDCBGS.pCount := 12;
+   giDCBGS.optionList := nil;
+   giDCBGS.pathName := @fName;
+   GetFileInfoGS(giDCBGS);
+   if ToolError = 0 then
+      ch := succ(ch)
+   else
+      done := true;
+until done;
+end; {FindSuffix}
+
+
+procedure Header {name: pStringPtr; kind: integer; lengthCode: integer};
+
+{ write a segment header to the output file                     }
+{                                                               }
+{ parameters:                                                   }
+{       name - name of the segment                              }
+{       kind - segment kind                                     }
+{       lengthCode - code bank size code; bank size div $10000  }
+
+
+var
+   i: integer;                          {loop var}
+   len: integer;                        {length of string}
+
+begin {Header}
+OpenSeg;                                {start the new segment}
+blkcnt := 0; segdisp := 0;
+for i := 1 to 12 do                     {blkcnt,resspc,length}
+   Out(0);
+Out(0);					{unused}
+Out(0);                                 {lablen}
+Out(4);                                 {numlen}
+Out(2);                                 {version}
+Out2(0); Out2(ord(lengthcode=0));       {cbanksize}
+Out2(kind|segmentKind);			{kind}
+for i := 1 to 9 do                 {unused,org,align,numsex,unused,segnum,entry}
+   Out2(0);
+len := length(name^);                   {dispname,dispdata}
+Out2($30); Out2($3B+len);
+Out2(0); Out2(0);			{temporg}
+for i := 1 to 10 do                     {write the segment name}
+   Out(ord(currentSegment[i]));
+currentSegment := defaultSegment;       {revert to default segment name}
+Out(len);                               {segname}
+for i := 1 to len do
+   Out(ord(name^[i]));
+end; {Header}
+
+
+procedure OpenObj {var name: gsosOutString};
+
+{ open a new obj file with the indicated file name              }
+{                                                               }
+{ parameters:                                                   }
+{       name - object file name                                 }
+
+var
+   dsDCBGS: destroyOSDCB;		{dcb for Destroy call}
+   giDCBGS: getFileInfoOSDCB;		{dcb for Get_File_Info call}
+
+begin {OpenObj}
+{the file is not spooled (yet)}
+spoolRefnum := 0;
+
+{if there is an existing file, delete it}
+if memoryFlag then begin
+   giDCBGS.pCount := 3;
+   giDCBGS.pathName := @name.theString;
+   GetFileInfoGS(giDCBGS);
+   if ToolError = 0 then
+      if giDCBGS.fileType = OBJ then begin
+         dsDCBGS.pCount := 1;
+         dsDCBGS.pathName := @name.theString;
+         DestroyGS(dsDCBGS);
+         end; {if}
+   end; {if}
+
+{allocate memory for an initial buffer}
+objHandle := pointer(NewHandle(buffSize, userID, $8000, nil));
+
+{set up the buffer variables}
+if ToolError = 0 then begin
+   objLen := 0;
+   objPtr := objHandle^;
+   end {if}
+else begin
+   TermError(3, nil);
+   end;       
+{save the object file name}
+objFile := name;
+end; {OpenObj}
+
+
+procedure OpenSeg;
+
+{ create a new segment and mark its beginning                   }
+
+begin {OpenSeg}
+segDisp := 0;
+segStart := objPtr;
+end; {OpenSeg}
+
+
+procedure Purge;
+
+{ write any constant bytes to the output buffer                 }
+
+var
+   i: integer;                          {loop variable}
+
+begin {Purge}
+if cBuffLen <> 0 then begin
+   Out(cBuffLen);
+   for i := 0 to cBuffLen-1 do
+      COut(cBuff[i]);
+   cBuffLen := 0;
+   end; {if}
+end; {Purge}
+
+end.                  
+
+{$append 'objout.asm'}
diff --git a/parser.pas b/parser.pas
old mode 100755
new mode 100644
index 8fd63f7..c395057
--- a/parser.pas
+++ b/parser.pas
@@ -1 +1,5078 @@
-{$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(sizeof(structure)));
      with lsp^ do begin
	aeltype := charptr;
	inxtype := nil;
	ispacked := pkpacked;
	hasSFile := false;
	size := lgth*packedcharsize;
	form := arrays;
	end; {with}
      end; {else}
    fvalu := val;
    InSymbol;
    end
  else begin
    sign := none;
    if (sy = addop) and (op in [plus,minus]) then begin
      if op = plus then sign := pos else sign := neg;
      InSymbol;
      end; {if}
    if sy = ident then begin
      searchid([konst],lcp);
      if lcp <> nil then
	with lcp^ do begin
	  lsp := idtype;
	  fvalu := values;
	  end {with}
      else begin
	fvalu.ival := 0;
	lsp := intptr;
	end; {else}
      if sign = neg then
	if (lsp = intptr) or (lsp = byteptr) then
	  fvalu.ival := -fvalu.ival
	else if lsp = longptr then begin
          lvp := pointer(Malloc(constantRec_longC));
          lvp^.cclass := longC;
	  lvp^.lval := -fvalu.valp^.lval;
	  fvalu.valp := lvp;
	  end {else if}
	else if IsReal(lsp) then begin
          lvp := pointer(Malloc(constantRec_reel));
          lvp^.cclass := reel;
	  lvp^.rval := -fvalu.valp^.rval;
	  fvalu.valp := lvp;
	  end; {else if}
      if sign <> none then
	if (lsp <> intptr) and (not IsReal(lsp)) and
	  (lsp <> byteptr) and (lsp <> longptr) then
	  Error(34);
      InSymbol;
      end {if}
    else if sy = intconst then begin
      if sign = neg then
        val.ival := -val.ival;
      lsp := intptr;
      fvalu := val;
      InSymbol;
      end {else if}
    else if sy = realconst then begin
      if sign = neg then
        val.valp^.rval := -val.valp^.rval;
      lsp := realptr;
      fvalu := val;
      InSymbol;
      end {else if}
    else if sy = longintconst then begin
      if sign = neg then
        val.valp^.lval := -val.valp^.lval;
      lsp := longptr;
      fvalu := val;
      InSymbol;
      end {else if}
    else begin
      Error(35);
      Skip(fsys);
      end {else if}
    end; {else}
  if not (sy in fsys) then begin
    Error(6);
    Skip(fsys);
    end; {if}
  end; {if}
fsp := lsp;
end; {DoConstant}


  procedure CheckUses(var id: pString; sym: symbol);
  {make sure this name has not been used from another level}

  label 1;

  var
    p: lptr;				{work pointer for traversing list}
    lcp: ctp;				{work pointer for checking fwd ptrs}

  begin {CheckUses}
  p := display[top].labsused;
  while p <> nil do begin
    if CompNames(p^.name^,id) = 0 then begin
      Error(18);
      goto 1;
      end;
    p := p^.next;
    end;
  if sym <> typesy then begin
    lcp := fwptr;
    while lcp <> nil do begin
      if CompNames(lcp^.name^,id) = 0 then begin
	Error(18);
	goto 1;
	end;
      lcp := lcp^.next;
      end;
    end;
  1:
  end; {CheckUses}

  procedure ExportUses;
  {uses from more than one level back are exported to the previous level}

  label 1;

  var
    p,q,r: lPtr; 			{for moveing used id list up}

  begin {ExportUses}
  p := display[top].labsused;		{check all labels in curent list}
  while p <> nil do begin
    if p^.disx < top-1 then begin	{if they are from more than one level  }
      q := display[top-1].labsused;	{ back, they must be in the last list  }
      while q <> nil do begin		{skip if the label is already in the   }
	if q^.name = p^.name then	{ last list			       }
	  goto 1;
	q := q^.next;
	end; {while}
      new(r);				{insert in the last list}
      r^.next := display[top-1].labsused;
      display[top-1].labsused := r;
      r^.name := p^.name;
      r^.disx := p^.disx;
      end; {if}
    p := p^.next;
    end; {while}
  1:
  end; {ExportUses}


  procedure ProcDeclaration (fsy: symbol; fsys: setofsys;
    isObject, compilebody: boolean; var foundbody: boolean); forward;

  { Procedure/function declaration				}


  procedure Typ (fsys: setofsys; var fsp: stp; var fsize: addrrange;
    isType: boolean);

  { compile a type definition					}
  {								}
  { parameters:							}
  {    fsys - follow symbols					}
  {    fsp -							}
  {    fsize -							}
  {    isType - is this the root level of a type declaration?	}

  var
    lsp,lsp1,lsp2: stp;
    oldtop: disprange;			{display level on entry}
    ttop: disprange;			{temp display level}
    lcp, lcp2: ctp;
    lsize,disp1: addrrange;
    lmin,lmax: longint;
    ispacked: packedkinds;
    test: boolean;
    lvalu: valu;
    len: integer;			{string length}
    l1,l2,l3: longint;			{used to compute array size}
    lval: record 			{used to convert between types}
      case boolean of
	true : (long: longint);
	false: (lsw: integer; msw: integer);
      end;


    procedure Duplicate (var ncp: ctp; ocp: ctp);

    { Duplicate a field list					}
    {								}
    { parameters:						}
    {    ncp - (output) new (copied) identifier			}
    {    ocp - identifier to copy				}

    begin {Duplicate}
    if ocp <> nil then begin
      ncp := pointer(Malloc(sizeof(identifier)));
      ncp^ := ocp^;
      Duplicate(ncp^.llink, ocp^.llink);
      Duplicate(ncp^.rlink, ocp^.rlink);
      end; {if}
    end; {Dulpicate}


    procedure SimpleType (fsys:setofsys; var fsp:stp; var fsize:addrrange);

    { Compile a simple type					}
    {								}
    { parameters:						}
    {    fsys -							}
    {    fsp -							}
    {    fsize -						}

    var
      lsp,lsp1: stp;
      lcp,lcp1: ctp;
      ttop: disprange;
      lcnt: integer;
      lvalu: valu;
      len: integer;			{string length}

    begin {SimpleType}
    fsize := 1;
    if not (sy in simptypebegsys) then begin
      Error(1);
      Skip(fsys + simptypebegsys);
      end; {if}
    if sy in simptypebegsys then begin

      {enumerations}
      if sy = lparent then begin
	ttop := top;   {decl. consts local to innermost block}
	while display[top].occur <> blck do
          top := top - 1;
        lsp := pointer(Malloc(sizeof(structure)));
	with lsp^ do begin
	  size := intsize;
	  form := scalar;
	  hasSFile := false;
	  scalkind := declared;
	  end; {with}
	lcp1 := nil;
	lcnt := 0;
	repeat
	  InSymbol;
	  if sy = ident then begin
            lcp := pointer(Malloc(sizeof(identifier)));
	    with lcp^ do begin
	      len := ord(id[0])+2;
              name := pointer(Malloc(len));
	      CopyString(name^,id,len);
	      idtype := lsp;
	      next := lcp1;
	      values.ival := lcnt;
	      klass := konst;
	      hasIFile := idtype^.hasSFile;
	      end;
	    CheckUses(lcp^.name^,constsy);
	    EnterId(lcp);
	    lcnt := lcnt + 1;
	    lcp1 := lcp; InSymbol
	    end
	  else Error(2);
	  if not (sy in fsys + [comma,rparent]) then begin
	    Error(6);
	    Skip(fsys + [comma,rparent]);
	    end;
	until sy <> comma;
	lsp^.fconst := lcp1;
	top := ttop;
	Match(rparent,4);
	end

      {named types, subranges}
      else begin
	if sy = ident then begin
	  SearchID([types,konst],lcp);
	  if lcp^.name = thisType then
            Error(10);
	  InSymbol;
	  if lcp^.klass = konst then begin
            lsp := pointer(Malloc(sizeof(structure)));
	    with lsp^, lcp^ do begin
	      rangetype := idtype;
	      form := subrange;
	      hasSFile := false;
              if rangetype = longptr then begin
	        min := values.valp^.lval;
	        size := longsize;
                end {if}
              else begin
	        min := values.ival;
	        size := intsize;
                end; {else}
	      end;
	    Match(dotdot,83);
	    DoConstant(fsys,lsp1,lvalu);
            if lsp1 = longptr then
	      lsp^.max := lvalu.valp^.lval
            else
	      lsp^.max := lvalu.ival;
	    if lsp^.rangetype <> lsp1 then
              if (lsp^.rangetype = intptr) and (lsp1 = longptr) then begin
        	lsp^.rangetype := longptr;
                lsp^.size := longsize;
                end {if}
              else if (lsp^.rangetype <> longptr) or (lsp1 <> intptr) then
        	Error(36);
	    end
	  else begin
	    lsp := lcp^.idtype;
	    if lsp <> nil then fsize := lsp^.size;
	    if iso then
	      if (lsp = longptr) or (lsp = byteptr) then Error(112);
	    end
	  end {sy = ident}
	else begin
          lsp := pointer(Malloc(sizeof(structure)));
	  DoConstant(fsys + [dotdot],lsp1,lvalu);
	  with lsp^ do begin
	    form := subrange;
	    hasSFile := false;
	    rangetype:=lsp1;
            if rangetype = longptr then begin
	      min := lvalu.valp^.lval;
	      size := longsize;
              end {if}
            else begin
	      min := lvalu.ival;
	      size := intsize;
              end; {else}
	    end;
	  Match(dotdot,83);
	  DoConstant(fsys,lsp1,lvalu);
          if lsp1 = longptr then
	    lsp^.max := lvalu.valp^.lval
          else
	    lsp^.max := lvalu.ival;
	  if lsp^.rangetype <> lsp1 then
            if (lsp^.rangetype = intptr) and (lsp1 = longptr) then begin
              lsp^.rangetype := longptr;
              lsp^.size := longsize;
              end {if}
            else if (lsp^.rangetype <> longptr) or (lsp1 <> intptr) then
              Error(36);
	  end;
	if lsp <> nil then
	  with lsp^ do
	    if form = subrange then
	      if rangetype <> nil then
		if IsReal(rangetype) or IsString(rangetype) then
                  Error(73)
		else if min > max then
                  Error(31)
	end;
      fsp := lsp;
      if not (sy in fsys) then begin
        Error(6);
        Skip(fsys)
        end; {if}
      end
    else fsp := nil
    end; {SimpleType}


    procedure FieldList (fsys: setofsys; var frecvar: stp; var hasFile: boolean;
      isObject: boolean);

    { compile a field list					}
    {								}
    { parameters:						}
    {    fsys - following symbols				}
    {    frecvar -						}
    {    hasFile -						}
    {    isObject - is this an object? (or a record)		}

    label 1;

    var
      lcp,lcp1,nxt,nxt1,inst: ctp;
      lsp,lsp1,lsp2,lsp3,lsp4: stp;
      minsize,maxsize,lsize: addrrange;
      lvalu: valu;
      numcase: longint;
      max,min: longint;
      tHasFile: boolean; 		{tracks files in the field list}
      len: integer;			{length of a string}
      hasId: boolean;			{does the case have an attached id?}

    begin {FieldList}
    lsp := nil;
    hasFile := false;
    if not (sy in fsys+[ident,casesy]) then begin
      Error(19);
      Skip(fsys + [ident,casesy]);
      end;
    while sy = ident do begin
      nxt := nil;
      nxt1 := nil;
      repeat
	if sy = ident then begin
          lcp := pointer(Malloc(sizeof(identifier)));
	  with lcp^ do begin
	    len := ord(id[0])+2;
            name := pointer(Malloc(len));
	    CopyString(name^,id,len);
	    idtype := nil;
	    next := nil;
	    klass := field;
	    fldvar := false;
	    hasIFile := false;
	    end;
	  if nxt1 <> nil then
            nxt1^.next := lcp;
	  nxt1 := lcp;
	  if nxt = nil then
            nxt := lcp;
	  EnterId(lcp);
	  InSymbol;
	  end
	else Error(2);
	if not (sy in [comma,colon]) then begin
          Error(6);
          Skip(fsys + [comma,colon,semicolon,casesy])
	  end; {if}
	test := sy <> comma;
	if not test then InSymbol;
      until test;
      Match(colon,5);
      Typ(fsys + [casesy,semicolon], lsp, lsize, false);
      hasFile := hasFile or lsp^.hasSFile;
      while nxt <> nil do
	with nxt^ do begin
	  idtype := lsp;
	  fldaddr := disp1;
	  nxt := next;
	  disp1 := disp1 + lsize;
	  end;
      while sy = semicolon do begin
	InSymbol;
	if not (sy in fsys + [ident,casesy,semicolon]) then begin
	  Error(19);
	  Skip(fsys + [ident,casesy]);
	  end;
	end;
      end; {while sy = ident}
    if sy = casesy then begin
      if isObject then
        Error(123);
      hasId := false;
      lsp := pointer(Malloc(sizeof(structure)));
      with lsp^ do begin
	tagfieldp := nil;
	fstvar := nil;
	form := tagfld;
	hasSFile := false;
	end;
      frecvar := lsp;
      InSymbol;
      if sy = ident then begin
        lcp := pointer(Malloc(sizeof(identifier)));
	with lcp^ do begin
	  len := ord(id[0])+2;
          name := pointer(Malloc(len));
	  CopyString(name^,id,len);
	  idtype := nil;
	  klass:=field;
	  next := nil;
	  fldaddr := disp1;
	  fldvar := true;
	  hasIFile := false;
	  end;
	InSymbol;
	if sy = colon then begin
	  InSymbol;
	  hasId := true;
	  if sy <> ident then begin
	    Error(2);
	    Skip(fsys + [ofsy,lparent]);
	    goto 1;
	    end; {if sy <> ident}
	  EnterId(lcp);
	  end
	else begin
	  id := lcp^.name^;
	  if sy <> ofsy then Error(8);
	  end;
	SearchID([types], lcp1);
	lsp1 := lcp1^.idtype;
	if lsp1 <> nil then begin
	  lcp^.fldaddr := disp1;
	  if hasId then
	    disp1 := disp1+lsp1^.size;
	  if lsp1^.form <= subrange then begin
	    if IsReal(lsp1) then
              Error(39)
	    else if (lsp1 = intptr) or (lsp1 = longptr) then begin
	      Error(111);
	      numcase := maxint;
	      end
	    else begin
	      GetBounds(lsp1,min,max);
	      if (max >= 0) and (min <= 0) then
		if max < (maxint+min) then
		  numcase := max-min+1
		else begin
		  Error(111);
		  numcase := maxint;
		  end
	      else
		numcase := max-min+1
	      end;
	    lcp^.idtype := lsp1;
	    lsp^.tagfieldp := lcp;
	    end
	  else
            Error(39);
	  end;
	if sy = ident then InSymbol;
	end
      else begin
	Error(2);
	Skip(fsys + [ofsy,lparent]);
	end;
1:    lsp^.size := disp1;
      Match(ofsy,8);
      lsp1 := nil;
      minsize := disp1;
      maxsize := disp1;
      repeat
	lsp2 := nil;
	if not (sy in fsys + [semicolon]) then begin
	  repeat
	    DoConstant(fsys + [comma,colon,lparent],lsp3,lvalu);
	    if lsp^.tagfieldp <> nil then
	      if not CompTypes(lsp^.tagfieldp^.idtype,lsp3) then
		Error(40);
            lsp3 := pointer(Malloc(sizeof(structure)));
	    numcase := numcase-1;
	    with lsp3^ do begin
	      nxtvar := lsp1;
	      subvar := lsp2;
	      varval := lvalu.ival;
	      form := variant;
	      hasSFile := false;
	      end;
	    lsp4 := lsp1;
	    while lsp4 <> nil do
	      with lsp4^ do begin
		if varval = lvalu.ival then Error(94);
		lsp4 := nxtvar;
		end;
	    lsp1 := lsp3;
	    lsp2 := lsp3;
	    test := sy <> comma;
	    if not test then InSymbol;
	  until test;
	  Match(colon,5);
	  Match(lparent,9);
	  FieldList(fsys + [rparent, semicolon], lsp2, tHasFile, false);
	  hasFile := hasFile or tHasFile;
	  if disp1 > maxsize then maxsize := disp1;
	  while lsp3 <> nil do begin
	    lsp4 := lsp3^.subvar;
	    lsp3^.subvar := lsp2;
	    lsp3^.size := disp1;
	    lsp3 := lsp4;
	    end;
	  Match(rparent,4);
	  if not (sy in fsys + [semicolon]) then begin
	    Error(6);
	    Skip(fsys + [semicolon]);
	    end;
	  end;
	test := sy <> semicolon;
	if not test then begin
	  disp1 := minsize;
	  InSymbol;
	  end;
      until test;
      if numcase <> 0 then Error(98);
      disp1 := maxsize;
      lsp^.fstvar := lsp1;
      frecVar^.hasSFile := hasFile;
      end
    else
      frecvar := nil;
    end; {FieldList}


    procedure ProcList (fsys: setofsys);

    { compile a field list					}
    {								}
    { parameters:						}
    {    fsys - following symbols				}

    var
      foundBody: boolean;		{dummy var for ProcDeclaration}
      lsy: symbol; 			{for recording type of subroutine}

    begin {ProcList}
    {make sure the initial symbol is valid}
    if not (sy in fsys+[procsy,funcsy]) then begin
      Error(19);
      Skip(fsys + [procsy,funcsy]);
      end; {if}

    {process all procedures and functions}
    while sy in [procsy,funcsy] do begin
      nextLocalLabel := 1;
      lsy := sy;
      InSymbol;
      nextLocalLabel := 1;
      ProcDeclaration(lsy, fsys+[procsy,funcsy], true, true, foundbody);
      if objectcp^.pfdirective = droverride then
        objectcp^.pfdirective := drforw
      else begin
        objectcp^.pfaddr := disp1;
        disp1 := disp1 + ptrsize;
        end; {else}
      while sy = semicolon do begin
	InSymbol;
	if not (sy in fsys + [procsy,funcsy,semicolon]) then begin
	  Error(19);
	  Skip(fsys + [procsy,funcsy]);
	  end; {if}
	end; {while}
      end; {while}
    end; {ProcList}


  begin {Typ}
  if not (sy in typebegsys) then begin
    Error(10);
    Skip(fsys+typebegsys);
    end;
  if sy in typebegsys then begin
    if sy in simptypebegsys then
      SimpleType(fsys,fsp,fsize)
{^} else if sy = arrow then begin
      lsp := pointer(Malloc(sizeof(structure)));
      fsp := lsp;
      with lsp^ do begin
	eltype := nil;
	size := ptrsize;
	form := pointerStruct;
	hasSFile := false;
	end; {with}
      InSymbol;
      if sy = ident then begin
	SearchSection(display[top].fname,lcp);
	if lcp <> nil then
          if lcp^.klass <> types then
            lcp := nil;
	if lcp = nil then begin
          {forward reference type id}
          lcp := pointer(Malloc(sizeof(identifier)));
	  with lcp^ do begin
	    len := ord(id[0])+2;
            name := pointer(Malloc(len));
	    CopyString(name^,id,len);
	    idtype := lsp;
	    next := fwptr;
	    klass := types;
	    hasIFile := lsp^.hasSFile;
	    end; {with}
	  fwptr := lcp;
	  end {if}
	else
	  with lcp^,lsp^ do begin
	    if {lcp^.}idtype <> nil then begin
	      {lsp^.}eltype := {lcp^.}idtype;
	      {lsp^.}hasSFile := {lcp^.}hasIFile;
	      end; {if}
	    if {lcp^.}name = thisType then
              Error(10);
	    end; {with}
	InSymbol;
	end {if}
      else Error(2);
      end {else if}
    else begin
      if sy = packedsy then begin
	InSymbol;
	ispacked := pkpacked;
	if not (sy in (typedels + [objectsy])) then begin
	  Error(10);
	  Skip(fsys + (typedels + [objectsy]));
	  end {if}
	end {if}
      else ispacked := pkunpacked;
{array}
      if sy = arraysy then begin
	InSymbol;
	Match(lbrack,11);
	lsp1 := nil;
	repeat
          lsp := pointer(Malloc(sizeof(structure)));
	  with lsp^ do begin
	    aeltype := lsp1;
	    inxtype := nil;
	    form := arrays;
	    hasSFile := lsp1^.hasSFile;
	    end;
	  lsp^.ispacked := ispacked;
	  lsp1 := lsp;
	  SimpleType(fsys + [comma,rbrack,ofsy],lsp2,lsize);
	  lsp1^.size := lsize;
	  if lsp2 <> nil then
	    if lsp2^.form <= subrange then begin
	      if IsReal(lsp2) then begin
		Error(38);
		lsp2 := nil;
		end
	      else if lsp2 = longptr then begin
		Error(74);
		lsp2 := nil;
		end; {else if}
	      lsp^.inxtype := lsp2
	      end {if}
	    else begin
	      Error(41);
	      lsp2 := nil;
	      end; {else}
	  test := sy <> comma;
	  if test then Match(rbrack,12) else InSymbol;
	until test;
	Match(ofsy,8);
	Typ(fsys, lsp, lsize, false);
	if lsp1^.ispacked = pkpacked then
	  if CompTypes(lsp,charptr) or CompTypes(lsp,boolptr) then
	    lsize := packedcharsize;
	repeat
	  with lsp1^ do begin
	    lsp2 := aeltype;
	    aeltype := lsp;
	    hasSFile := lsp^.hasSFile;
	    if inxtype <> nil then begin
	      GetBounds(inxtype,lmin,lmax);
              lsize := (lmax-lmin+1)*lsize;
	      size := lsize;
	      end; {if}
	    end; {with}
	  lsp := lsp1; lsp1 := lsp2;
	until lsp1 = nil;
        if lsize > $010000 then
          if SmallMemoryModel then
            Error(122);
	end
{stringsy}
      else if sy = stringsy then begin
	InSymbol;
	lmin := 80; {default string length is 80}
	if sy = lbrack then begin
	  InSymbol;
	  DoConstant(fsys+[rbrack],lsp1,lvalu);
	  if lsp1 = intptr then
	    lmin := lvalu.ival
	  else
	    Error(15);
	  Match(rbrack,12);
	  end;
        lsp1 := pointer(Malloc(sizeof(structure)));
	with lsp1^ do begin
	  size := 2;
	  form := subrange;
	  hasSFile := false;
	  rangetype := intptr;
	  min := 0;
	  if lmin > 255 then
	    min := 1;
	  max := lmin;
	  end;
        lsp := pointer(Malloc(sizeof(structure)));
	with lsp^ do begin
	  aeltype := charptr;
	  inxtype := lsp1;
	  form := arrays;
	  hasSFile := false;
	  size := (lmin-lsp1^.min+1)*packedcharsize;
	  ispacked := pkpacked;
	  end;
	end
{record}
      else if sy = recordsy then begin
	InSymbol;
	oldtop := top;
	if top < displimit then begin
	  top := top+1;
	  with display[top] do begin
	    fname := nil;
	    flabel := nil;
	    labsused := nil;
	    occur := rec;
	    end
	  end
	else
          Error(107);
	disp1 := 0;
        lsp := pointer(Malloc(sizeof(structure)));
	FieldList(fsys-[semicolon]+[endsy], lsp1, lsp^.hasSFile, false);
        if disp1 > $010000 then
          if SmallMemoryModel then
            Error(122);
	with lsp^ do begin
	  fstfld := display[top].fname;
	  recvar := lsp1;
	  size := disp1;
	  form := records;
	  end; {with}
	lsp^.ispacked := ispacked;
	ExportUses;
	top := oldtop;
	Match(endsy,13);
	end
{object}
      else if sy = objectsy then begin
	InSymbol;

        {make sure we are declaring a type}
        if not isType then
          Error(127);

        {set up a new display}
	oldtop := top;
	if top < displimit then begin
	  top := top+1;
	  with display[top] do begin
	    fname := nil;
	    flabel := nil;
	    labsused := nil;
	    occur := rec;
	    end
	  end
	else
          Error(107);
	disp1 := 6;

        {set up the type}
        lsp := pointer(Malloc(sizeof(structure)));
	with lsp^ do begin
	  form := objects;
          objname := nil;
          objsize := 6;
          objlevel := 1;
          objparent := nil;
	  size := ptrsize;
	  end; {with}

        {handle inheritance}
        if sy = lparent then begin
          InSymbol;
          if sy = ident then begin
            SearchId([types], lcp2);
            if lcp2 <> nil then begin
              if lcp2^.idtype <> nil then
                if lcp2^.idtype^.form = objects then begin
                  Duplicate(display[top].fname, lcp2^.idtype^.objfld);
                  disp1 := lcp2^.idtype^.objsize;
                  lsp^.objparent := lcp2^.idtype;
                  lsp^.objlevel := lcp2^.idtype^.objlevel + 1;
                  end {if}
                else
                  Error(129);
              end {if}
            else
              Error(33);
            InSymbol;
            end {if}
          else
            Error(128);
          Match(rparent,4);
          end; {if}

        {compile the fields and methods}
        if sy in typebegsys then
	  FieldList(fsys-[semicolon]+[endsy,procsy,funcsy], lsp1,
            lsp^.hasSFile, true);
        objectType := lsp;
        ttop := top;
        top := oldtop;
        EnterId(objectcp);
        top := ttop;
        objectcp^.idtype := lsp;
        ProcList(fsys-[semicolon]+[endsy]);
        if disp1 > $010000 then
          if SmallMemoryModel then
            Error(122);
	lsp^.objfld := display[top].fname;
        lsp^.objsize := disp1;

	lsp^.ispacked := ispacked;
	ExportUses;
	top := oldtop;
	Match(endsy,13);
	end {else if}
{set} else if sy = setsy then begin
	InSymbol;
	Match(ofsy,8);
	SimpleType(fsys,lsp1,lsize);
	if lsp1 <> nil then
	  if lsp1^.form > subrange then begin
	    Error(43);
	    lsp1 := nil;
	    end
	  else if IsReal(lsp1) then begin
	    Error(42);
	    lsp1 := nil;
	    end
	  else if (lsp1 = intptr) or (lsp1 = longptr) then begin
	    Error(90);
	    lsp1 := nil;
	    end
	  else begin
	    GetBounds(lsp1,lmin,lmax);
	    if (lmin < setlow) or (lmax > sethigh) then
              Error(90);
	    lmax := lmax div 8 + 1;
            if lmax = 1 then
               lmax := 2
            else if lmax = 3 then
               lmax := 4;
	    end;
        lsp := pointer(Malloc(sizeof(structure)));
	with lsp^ do begin
	  elset := lsp1;
	  size := lmax;
	  form := power;
	  hasSFile := false;
	  end;
	lsp^.ispacked := ispacked;
	end
{file} else if sy = filesy then begin
	InSymbol;
	Match(ofsy,8);
	Typ(fsys, lsp1, lsize, false);
	if lsp1^.hasSFile then Error(117);
	fsize := lsize;
	if (lsp1 = charptr) or (lsp1 = boolptr) then
	  fsize := packedcharsize;
        lsp := pointer(Malloc(sizeof(structure)));
	with lsp^ do begin
	  size := ptrsize;
	  form := files;
	  hasSFile := true;
	  filtype := lsp1;
	  filsize := lsize;
	  end;
	lsp^.ispacked := ispacked;
	end;
      fsp := lsp
      end;
    if not (sy in fsys) then begin
      Error(6);
      Skip(fsys)
      end; {if}
    end
  else
    fsp := nil;
  if fsp = nil then
    fsize := 1
  else
    fsize := fsp^.size;
  end {Typ} ;

  procedure labeldeclaration(fsys: setofsys);
  {Declare a user-defined label}

  var
    llp: lbp;
    redef: boolean;
    i: integer;
    test: boolean;

  begin {labeldeclaration}
  repeat
    if sy = intconst then
      with display[top] do begin
	llp := flabel; redef := false;
	while (llp <> nil) and not redef do
	  if llp^.labval <> val.ival then llp := llp^.nextlab
	  else begin redef := true; Error(88); end;
	if not redef then begin
          llp := pointer(Malloc(sizeof(labl)));
	  with llp^ do begin
	    labval := val.ival; labname := GenLabel;
	    if top = 1 then firstlab := labname+1;
	    defined := false; nextlab := flabel;
	    lstlevel := 0;
	    end;
	  if (val.ival < 0) or (val.ival > 9999) then Error(105);
	  flabel := llp
	  end;
	InSymbol;
	end
    else Error(15);
    if not ( sy in fsys + [comma, semicolon] ) then begin
      Error(6);
      Skip(fsys+[comma,semicolon])
      end;
    test := sy <> comma;
    if not test then InSymbol
  until test;
  Match(semicolon,14);
  end; {labeldeclaration}

  procedure ConstDeclaration(fsys: setofsys);
  {compile a constant}

  var
    lcp: ctp;
    lsp: stp;
    lvalu: valu;
    len: integer;			{string length}

  begin {ConstDeclaration}
  if sy <> ident then begin
    Error(2);
    Skip(fsys + [ident]);
    end;
  while sy = ident do begin
    lcp := pointer(Malloc(sizeof(identifier)));
    with lcp^ do begin
      len := ord(id[0])+2;
      name := pointer(Malloc(len));
      CopyString(name^,id,len);
      idtype := nil;
      next := nil;
      klass:=konst;
      hasIFile := false;
      end;
    InSymbol;
    if (sy = relop) and (op = eqop) then
      InSymbol
    else
      Error(16);
    DoConstant(fsys + [semicolon],lsp,lvalu);
    EnterId(lcp);
    with lcp^ do begin
      CheckUses({lcp^.}name^,constsy);
      {lcp^.}idtype := lsp;
      {lcp^.}values := lvalu;
      end;
    Match(semicolon,14);
    if not (sy in fsys+[ident,implementationsy]) then begin
      Error(6);
      Skip(fsys + [ident,implementationsy]);
      end;
    end;
  end; {ConstDeclaration}

  procedure FwPtrCheck;
  {Check all forward declared pointers to be sure they are resolved}

  var
    lcp: ctp;

  begin {FwPtrCheck}
  while fwptr <> nil do begin
    id := fwptr^.name^;
    prterr := false;
    SearchId([types],lcp);
    prterr := true;
    if lcp = nil then begin
      write('**** The pointer ',id,' cannot be resolved');
      FlagError;
      end
    else if lcp^.idtype <> nil then
      with fwptr^.idtype^, lcp^ do begin
	eltype := idtype;
	hasSFile := hasIFile;
	end;
    fwptr := fwptr^.next;
    end;
  end; {FwPtrCheck}

  procedure TypeDeclaration (fsys: setofsys);

  { compile a type declaration					}
  {								}
  { parameters:							}
  {   fsys -							}

  var
    lcp: ctp;
    lsp: stp;
    lsize: addrrange;
    len: integer;			{string length}

  begin {TypeDeclaration}
  if sy <> ident then begin		{check for a bogus start}
    Error(2);
    Skip(fsys + [ident]);
    end; {if}
  while sy = ident do begin		{scan all declarations}
					{process the identifier}
    lcp := pointer(Malloc(sizeof(identifier)));
    with lcp^ do begin
      len := ord(id[0])+2;
      name := pointer(Malloc(len));
      CopyString(name^,id,len);
      thisType := name;
      klass := types;
      end; {with}
    InSymbol;
					{check for '='}
    if (sy = relop) and (op = eqop) then
      InSymbol
    else
      Error(16);
    objectName := lcp^.name^;
    objectCp := lcp;
    Typ(fsys+[semicolon], lsp, lsize, true); {get the type}
    if lsp^.form = objects then
      lsp^.objname := lcp^.name;
    thisType := nil;
    if lsp^.form <> objects then	{enter in symbol table}
      EnterId(lcp);
    with lcp^ do begin
      {lcp^.}idtype := lsp;
      {lcp^.}hasIFile := lsp^.hasSFile;
      CheckUses({lcp^.}name^,typesy);
      end; {with}
    Match(semicolon,14);		{get ready for another one}
    if not (sy in fsys + [ident,implementationsy]) then begin
      Error(6);
      Skip(fsys + [ident,implementationsy]);
      end; {if}
    end; {while}
  FwPtrCheck;				{make sure forward declarations were resolved}
  end; {TypeDeclaration}

  procedure VarDeclaration(fsys: setofsys);
  {declare variables}

  var
    isExtern: boolean;			{is this an external variable declaration?}
    lcp,nxt: ctp;
    lsp: stp;
    lsize: addrrange;
    test: boolean;
    len: integer;			{string length}

  begin {VarDeclaration}
  nxt := nil;
  repeat {loops over type part}
    repeat {loops over all variable names}
      if sy = ident then begin
	{declare a new variable}
        lcp := pointer(Malloc(sizeof(identifier)));
	with lcp^ do begin
          len := ord(id[0])+2;
          name := pointer(Malloc(len));
	  CopyString(name^,id,len);
	  next := nxt;
	  klass := varsm;
	  vcontvar := false;
	  vrestrict := false;
	  idtype := nil;
	  vkind := actual;
	  vlev := level;
	  fromUses := inUses;
	  vPrivate := doingUnit and (not doingInterface);
	  end;
	EnterId(lcp);
	nxt := lcp;
	InSymbol;
	end
      else Error(2);
      if not (sy in fsys + [comma,colon] + typedels) then begin
	Error(6); Skip(fsys+[comma,colon,semicolon]+typedels)
	end;
      test := sy <> comma;
      if not test then InSymbol;
    until test;
    Match(colon,5);

    {see if the variable is extern}
    isExtern := false;
    if not iso then
      if sy = ident then
        if (id = 'EXTERN') or (id = 'EXTERNAL') then begin
          InSymbol;
          isExtern := true;
          end; {if}
    {get the type for the variable list}
    Typ(fsys + [semicolon] + typedels, lsp, lsize, false);
    FwPtrCheck;
    {loop over the variable list, filling in type based info}
    while nxt <> nil do
      with nxt^ do begin
	CheckUses(name^,varsy);
	idtype := lsp;
	fromUses := fromUses or isExtern;
	hasIFile := lsp^.hasSFile;
	if level <> 1 then
	  vlabel := GetLocalLabel;
	nxt := next;
	end;
    Match(semicolon,14);
    if not (sy in fsys + [ident,implementationsy]) then begin
      Error(6);
      Skip(fsys + [ident,implementationsy]);
      end;
  until (sy <> ident) and not (sy in typedels);
  end; {VarDeclaration}
 

  procedure DoBlock (fsys: setofsys; fsy: symbol; fprocp: ctp;
     isProgram: boolean); forward;
  {compile a block}


  procedure ProcDeclaration {fsy: symbol; fsys: setofsys;
    isObject, compilebody: boolean; var foundbody: boolean};

  { Procedure/function declaration				}
  {								}
  { parameters:							}
  {   fsy - procedure or function symbol			}
  {   fsys - follow symbols					}
  {   isObject - is this declaration in an object?		}
  {   compilebody - Compile the body? (used for partial compile)}
  {   foundbody - Was the body found (used for partial compile)	}

  var
    forw: boolean;
    i: integer;
    lcp,lcp1,lcp2: ctp;
    len: integer;			{string length}
    lisMethod: boolean;			{copy of isMethod}
    lpsize: integer;			{for saving psize (nested declarations)}
    lsp, lsp1: stp;
    lvalu: valu;			{constant from a directive}
    needSemicolon: boolean;		{for parsing interface files}
    oldlev: 0..maxlevel;
    oldtop: disprange;
    override: boolean;			{true if override is the only legal possibility}


    procedure ParameterList (ssy: setofsys; var fpar: ctp;
      forw,dummy: boolean);

    { Compile the parameter list				}
    {								}
    { parameters:						}
    {    ssy -							}
    {    fpar - list of parameter symbols			}
    {    forw -							}
    {    dummy -						}

    var
      list,lcp,lcp1: ctp;
      lsp: stp; lkind: idkind;
      lsize: unsigned;
      item: integer;
      test: boolean;
      len: integer;			{string length}
      universal: boolean;		{is the parm universal?}


      procedure FunProcParm (forp: idclass; var lcp: ctp; fsys: setofsys);

      { Compile a procedure or function parameter		}
      {								}
      { parameters:						}
      {    forp - function or procedure symbol			}
      {    lcp -						}
      {    fsys -						}

      var
	lpsize: integer;		{for saving psize}
	len: integer;			{string length}

      begin {FunProcParm}
      InSymbol;
      if sy = ident then begin

        {create a symbol table entry}
        lcp := pointer(Malloc(sizeof(identifier)));
	with lcp^ do begin
          len := ord(id[0])+2;
          name := pointer(Malloc(len));
	  CopyString(name^,id,len);
	  hasIFile := false;
	  idtype := nil;
	  pflev := level;
	  klass := forp;
	  pfdeckind := declared;
	  psize := psize+procsize;
	  pflabel := GetLocalLabel;
          pfparms := nil;
	  pfkind := formal;
	  pfnext := nil;
	  next := nil;
	  end; {with}
	if not dummy then
          EnterId(lcp);
	InSymbol;

	item := item+1;
	if list <> nil then
          list^.next := lcp;
	list := lcp;
	if fpar = nil then
          fpar := list;
	lpsize := psize;
	with lcp^ do
	  if forp = proc then begin
	    if not (sy in [semicolon,rparent]) then
	      ParameterList([semicolon,rparent], pfnext, false, true);
	    end
	  else if sy <> colon then
	    ParameterList([colon], pfnext, false, true);
	psize := lpsize;
	end {if}
      else
	Error(2);
      end; {FunProcParm}


    begin {ParameterList}
    list := nil;
    fpar := nil;
    item := 1;
    if isObject or (sy = lparent) then
      psize := 0; {define parameters as offsets from 0}

    {declare the 'self' parameter for methods}
    if isObject then begin
      lcp := pointer(Malloc(sizeof(identifier)));
      with lcp^ do begin
	name := @'SELF';
	idtype := objectType;
	next := nil;
	hasIFile := false;
	klass := varsm;
	vkind := actual;
	vlev := level;
	vitem := item;
	vlabel := GetLocalLabel;
	vcontvar := false;
	fromUses := false;
	vrestrict := false;
	vUniv := false;
	vPrivate := true;
	end; {with}
      EnterId(lcp);
      list := lcp;
      fpar := list;
      psize := {psize +} ptrsize;
      item := 2 {item+1};
      end; {if}

    {handle standard parameters}
    if not (sy in ssy+[lparent]) then begin
      Error(7);
      Skip(fsys+ssy+[lparent])
      end; {if}
    if sy = lparent then begin
      if forw or override then
        Error(45);
      InSymbol;
      if not (sy in [ident,varsy,funcsy,procsy]) then begin
	Error(7);
	Skip(fsys+[ident,rparent]);
	end; {if}
      while sy in [ident,varsy,funcsy,procsy] do begin
	if sy = procsy then begin
	  FunProcParm(proc, lcp, fsys+[comma,semicolon,rparent]);
	  lcp^.idtype := nilptr;
	  end {if}
	else if sy = funcsy then begin
	  FunProcParm(func, lcp, fsys+[comma,semicolon,rparent,colon]);
	  Match(colon,5);
	  if sy = ident then begin
	    SearchId([types],lcp1);
	    lsp := lcp1^.idtype;
	    if lsp <> nil then
	      if not (lsp^.form in [scalar,subrange,pointerStruct,objects])
                then begin
		Error(46);
		lsp := nil;
		end; {if}
	    lcp^.idtype := lsp;
	    InSymbol;
	    end
	  else Error(2);
	  end {else if}

        {'normal' parameter}
	else begin			

          {handle var declarations}
	  if sy = varsy then begin
	    lkind := formal;
	    InSymbol;
	    end
	  else
	    lkind := actual;

	  {process the list of names}
	  lcp1 := nil;
	  repeat
	    if sy = ident then begin
              lcp := pointer(Malloc(sizeof(identifier)));
	      with lcp^ do begin
                len := ord(id[0])+2;
                name := pointer(Malloc(len));
		CopyString(name^,id,len);
		idtype := nil;
		klass := varsm;
		vkind := lkind;
		next := nil;
		vlev := level;
		vcontvar := false;
		vrestrict := false;
		vitem := item;
		fromUses := inUses;
		end; {with}
	      if not dummy then
                EnterId(lcp);
	      if list <> nil then
                list^.next := lcp;
	      list := lcp;
	      if fpar = nil then
                fpar := list;
	      if lcp1 = nil then
                lcp1 := list;
	      InSymbol;
	      end {if}
	    else
              Error(2);
	    if not (sy in [comma,colon]+fsys) then begin
	      Error(7);
	      Skip(fsys+[comma,semicolon,rparent]);
	      end;
	    test := sy <> comma;
	    if not test then InSymbol;
	  until test;
	  Match(colon,5);

	  {see if the symbol is universal}
	  if sy = univsy then begin
	    if iso then
              Error(112);
	    universal := true;
	    InSymbol;
	    end {if}
	  else
	    universal := false;

	  {process the parameter type}
	  if sy = ident then begin

	    {find and check the type}
	    SearchId([types],lcp);
	    lsp := lcp^.idtype;
	    if lsp <> nil then
	      if lkind = actual then
		if lsp^.form = files then
                  Error(47);

	    {record the type size}
	    lsize := ParmSize(lsp,lkind);

	    {scan the variables, adding type info}
	    while lcp1 <> nil do begin
	      with lcp1^ do begin
		idtype := lsp;
                psize := psize+lsize;
		vlabel := GetLocalLabel;
		vuniv := universal;
		hasIFile := false;
		end; {with}

	      {allocate local space for value parms passed as pointers}
	      if lsp <> nil then
		if (lkind = actual) and (lsp^.form > power) then
		  if (lsp^.form <> records) or (lsp^.size > 4) then
		    lcp1^.vlabel := GetLocalLabel;
	      lcp1 := lcp1^.next;
	      end; {while}
	    InSymbol;
	    end {if}
	  else
            Error(2);
	  item := item+1;
	  end; {else}

	if not (sy in fsys+[semicolon,rparent]) then begin
	  Error(7);
	  Skip(fsys+[ident,rparent]);
	  end; {if}
	if sy = semicolon then begin
	  InSymbol;
	  if not (sy in fsys+[ident,varsy,procsy,funcsy]) then begin
	    Error(7);
	    Skip(fsys+[ident,rparent]);
	    end; {if}
	  end; {if}
	end; {while}
      Match(rparent,4);
      if not (sy in ssy+fsys) then begin
	Error(6);
	Skip(ssy+fsys);
	end; {if}
      end; {if}
    display[top].labsused := nil;
    end; {ParameterList}                


  begin {ProcDeclaration}
  lpsize := psize;
  psize := 0;
  forw := false;

  {see if this is the object name for a method}
  override := false;
  isMethod := false;
  if sy = ident then begin
    prterr := false;
    SearchID([types], lcp);
    prterr := true;
    if lcp <> nil then
      if lcp^.idtype <> nil then
	if lcp^.idtype^.form = objects then begin
          isMethod := true;
          lisMethod := true;
          objectName := id;
          InSymbol;
	  Match(period, 21);
          end; {if}
    end; {if}

  if sy = ident then begin
    {check for forward declarations}
    if isMethod then begin
      if level <> 1 then
        Error(126);
      if lcp^.idtype = nil then
        lcp := nil
      else
        SearchSection(lcp^.idtype^.objfld, lcp);
      if lcp = nil then
        Error(124)
      else
        if lcp^.pfdirective = drnone then
          Error(30);
      end {if}
    else
      SearchSection(display[top].fname, lcp);
    if lcp <> nil then
      with lcp^ do begin
        if isObject then
          override := true
	else if klass = proc then
	  forw := ((pfdirective=drforw) or isMethod)
            and (fsy=procsy) and (pfkind=actual)
	else if klass = func then
	  forw:= ((pfdirective=drforw) or isMethod)
            and (fsy=funcsy) and (pfkind=actual)
	else
          forw := false;
	if not (forw or override) then
          Error(84);
	end; {with}

    {if not forward, create a new identifier}
    if override then begin

      {override an ancestor method}
      lcp^.pfoname := pointer(Malloc(length(objectName)+length(lcp^.name^)+2));
      lcp^.pfoname^ := concat(objectName, '~', lcp^.name^);
      objectcp := lcp;

      {change the 'SELF' parameter type}
      lcp2 := pointer(Malloc(sizeof(identifier)));
      lcp2^ := lcp^.pfparms^;
      lcp^.pfparms := lcp2;
      lcp2^.idtype := objectType;
      end {if}
    else if not forw then begin
      lcp := pointer(Malloc(sizeof(identifier)));
      with lcp^ do begin
        len := ord(id[0])+2;
        name := pointer(Malloc(len));
	CopyString(name^,id,len);
	idtype := nilptr;
	pflev := level;
	pfname := GenLabel;
        if isObject then begin
          pfoname := pointer(Malloc(length(objectName)+length(name^)+2));
          pfoname^ := concat(objectName, '~', name^);
          end {if}
        else
          pfoname := name;
	pfparms := nil;
	pfdeckind := declared;
	pfkind := actual;
	pfPrivate := doingUnit and (not doingInterface);
	if fsy = procsy then
          klass := proc
        else
          klass := func;
	hasIFile := false;
	end; {if}
      CheckUses(lcp^.name^, procsy);
      EnterId(lcp);
      objectcp := lcp;
      end {if}
    else begin
      {forward - reset location counter}
      psize := lcp^.pfactualsize;

      {reset label counter}
      lcp1 := lcp^.pfparms;
      while lcp1 <> nil do begin
        if lcp1^.klass = varsm then begin
          if lcp1^.vlabel >= nextLocalLabel then
            nextLocalLabel := lcp1^.vlabel + 1;
          end {if}
        else if lcp1^.klass in [proc,func] then
          if lcp1^.pflabel >= nextLocalLabel then
            nextLocalLabel := lcp1^.pflabel + 1;
        lcp1 := lcp1^.next;
        end; {while}
      end; {else}
    InSymbol;

    {check for unexpected method}
    if sy = period then begin
      Error(125);
      InSymbol;
      if sy = ident then
        InSymbol;
      end; {if}
    end {if}
  else begin

    {missing function identifier}
    Error(2);
    lcp := ufctptr;
    end; {else}

  {create a new stack frame level}
  oldlev := level;
  oldtop := top;
  if level < maxlevel then
    level := level + 1
  else
    Error(108);
  if top < displimit then begin
    top := top+1;
    with display[top] do begin
      if forw then
        fname := lcp^.pfparms
      else
        fname := nil;
      flabel := nil;
      labsused := nil;
      occur := blck;
      ispacked := false;
      end; {with}
    end {if}
  else
    Error(107);

  {assign function labels}
  with lcp^ do
    if klass = func then
      pflabel := GetLocalLabel
    else
      pflabel := 0;

  {compile the parameters}
  if fsy = procsy then begin
    ParameterList([semicolon], lcp1, forw, false);
    if not (forw or override) then
      with lcp^ do begin
	pfparms := lcp1;
	pfactualsize := psize;
	end; {with}
    end {if}
  else begin
    ParameterList([semicolon,colon], lcp1, forw, false);
    if not (forw or override) then
      with lcp^ do begin
	pfparms := lcp1;
	pfactualsize := psize;
	end; {with}
    if sy = colon then begin
      InSymbol;
      if sy = ident then begin
	if forw or override then
          Error(48);
	SearchId([types], lcp1);
	lsp := lcp1^.idtype;
	lcp^.idtype := lsp;
	if lsp <> nil then
	  if not (lsp^.form in [scalar,subrange,pointerStruct,objects]) then
            begin
	    Error(46);
            lcp^.idtype := nil;
	    end; {if}
	InSymbol;
	end {if}
      else begin
        Error(2);
        Skip(fsys + [semicolon])
        end; {else}
      end {if}
    else if not (forw or override) then
      Error(49)
    end; {else}
  Match(semicolon,14);

  {handle directives}
  if (sy = ident) or doingInterface or inUses or isObject then begin
    foundBody := false;
    if sy <> ident then begin		{special assumptions for uses,	}
      if inUses and (not isObject) then	{ interface files, methods	}
	lcp2 := externIdentifier
      else
	lcp2 := forwardIdentifier;
      if override then
        Error(30);
      needSemicolon := false;
      end {if}
    else begin				{normal identifier section}
      SearchId([directive],lcp2);	{find the identifier type}
      InSymbol;
      needSemicolon := true;
      end; {else}
    lcp^.pfdirective := lcp2^.drkind;
    if override then begin
      if lcp2^.drkind <> droverride then
        Error(30);
      end {if}
    else if lcp2^.drkind = droverride then
      Error(124);
    with lcp^ do
      case pfdirective of
	drforw,droverride:
	  if forw then
	    Error(85);
	drextern:
	  if level <> 2 then
	    Error(101);
	drprodos: begin
	  if sy = lparent then
            InSymbol;
	  if (sy = intconst) then begin
	    pfcallnum := val.ival;
	    InSymbol;
	    end {if}
	  else
            Error(15);
	  if sy = rparent then
            InSymbol;
	  end;
	drtool1,drtool2: begin
	  if sy = lparent then
            InSymbol;
	  DoConstant(fsys+[comma], lsp1, lvalu);
          if lsp1 = intptr then
	    pftoolnum := lvalu.ival
	  else
            Error(15);
	  Match(comma,20);
	  DoConstant(fsys+[rparent], lsp1, lvalu);
          if lsp1 = intptr then
	    pfcallnum := lvalu.ival
	  else
            Error(15);
	  if sy = rparent then
	    InSymbol;
	  end;
	drvector: begin
	  if sy = lparent then
            InSymbol;
	  DoConstant(fsys+[comma], lsp1, lvalu);
          if lsp1 = longptr then
            pfaddr := lvalu.valp^.lval
          else if lsp1 = intptr then
	    pftoolnum := lvalu.ival
	  else
            Error(15);
	  Match(comma,20);
	  DoConstant(fsys+[rparent], lsp1, lvalu);
          if lsp1 = intptr then
	    pfcallnum := lvalu.ival
	  else
            Error(15);
	  if sy = rparent then
	    InSymbol;
	  end;
	otherwise: Error(6);
	end; {case}
    if needSemicolon then
      Match(semicolon,14);
    if not (sy in fsys) then begin
      Error(6);
      Skip(fsys);
      end; {if}
    end {if}
  else
    with lcp^ do begin

      {if list is off, write the proc name}
      foundBody := true;
      if (not list) and progress and compilebody then
	writeln(' ':level, {lcp^.}pfoname^);

      {lcp^.}pfdirective := drnone;
      {lcp^.}pfset := false;
      if compilebody then begin
	if level <= 2 then begin
	  mark({lcp^.}pfmark);
	  Gen2Name(dc_str, $4000*ord({lcp^.}pfPrivate)+$8000*ord(isDynamic), 0,
	    {lcp^.}pfoname);
	  inseg := true;
	  end; {if}
	DoBlock(fsys,semicolon,lcp,false);
	Match(semicolon,14);
	if not (sy in [endsy,beginsy,procsy,funcsy]) then begin
	  Error(6);
	  Skip([beginsy,procsy,funcsy]);
	  end; {if}
	if ({lcp^.}klass = func) and (not {lcp^.}pfset) then Error(96);
	end; {if}
      end; {with}
  ExportUses;
  level := oldlev;
  top := oldtop;
  psize := lpsize;
  end; {ProcDeclaration}


  procedure UsesDeclaration(fsys: setofsys);
  {compile a uses statement}

  var
    done: boolean;			{for detecting end of loop}
    foundBody: boolean;			{dummy var for ProcDeclaration}
    lfsys: setofsys;			{temp fsys}
    lsy: symbol; 			{for recording type of subroutine}

  begin {UsesDeclaration}
  if level <> 1 then Error(115); 	{must be at program level}
  repeat
    if sy = ident then begin
      inUses := true;			{mark as in a uses file}
      OpenUses;				{open the uses file}
      InSymbol;				{get the first symbol in the uses file}
      fsys := fsys+[implementationsy];	{allow implementation}
					{compile the file}
      while sy = usessy do begin 	{skip uses - assumes correct syntax,}
	repeat				{ but will not hang if fooled	    }
	  InSymbol;
	until (sy = semicolon) or eofl;
	InSymbol;
	end;
      if sy = constsy then begin InSymbol; ConstDeclaration(fsys); end;
      if sy = typesy then begin InSymbol; TypeDeclaration(fsys); end;
      if sy = varsy then begin InSymbol; VarDeclaration(fsys); end;
      {handle procedure, function declarations}
      while sy in [procsy,funcsy] do begin
	lsy := sy;
	InSymbol;
        nextLocalLabel := 1;
	ProcDeclaration(lsy, fsys, false, true, foundbody);
	if foundBody then Error(81);
	end;
      if sy <> implementationsy then begin
	Error(116);
	Skip([implementationsy]);
	end
      else
	InSymbol;
      inUses := false;			{mark as out of uses file}
      end
    else
      Error(2);
    done := sy <> comma;
    if not done then
      InSymbol;
  until done or eofl;
  Match(semicolon,14);
  end; {UsesDeclaration}


  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.		}

  var
    isFunction: boolean; 		{are we dereferencing a function?}
    lattr: attr;			{copy of an attribute}
    lcp,lcp1: ctp;
    lmin,lmax: longint;
    lsize: addrrange;
    lispacked: boolean;


    procedure ArrayIndex;

    { Handles subscripting an array				}

    var
      bt: baseTypeEnum;			{index base type}

    begin {ArrayIndex}
    {track array packing}
    gispacked := gispacked or lispacked;
    
    {loop over subscripts, possibly separated by commas}
    repeat

      {get the type, and make sure it's an array}
      lattr := gattr;
      lcp1 := glcp;
      with lattr do 
	if typtr <> nil then
	  if typtr^.form <> arrays then begin
	    Error(63);
            typtr := nil;
	    end; {if}
      LoadAddress;
      InSymbol;

      {get the array subscript value}
      Expression(fsys + [comma,rbrack],fprocp);
      Load;
      glcp := lcp1;
      if gattr.typtr <> nil then
	if gattr.typtr^.form <> scalar then
          Error(41);
      if lattr.typtr <> nil then
	with lattr.typtr^ do begin

          {if needed, promote the index to long}
          if CompTypes(inxtype, longptr) then
            if CompTypes(gattr.typtr, intptr) then begin
              Gen2(pc_cnv, ord(cgWord), ord(cgLong));
              gattr.typtr := longptr;
              end; {if}

          {check the type of the subscript}
	  if CompTypes(inxtype,gattr.typtr) then begin
	    if inxtype <> nil then begin

              {check the range of the subscript}
	      GetBounds(inxtype,lmin,lmax);
	      if debug then
                if GetType(inxtype, false) in [cgLong,cgULong] then
                  GenL2t(pc_chk, lmin, lmax, cgULong)
                else
                  Gen2t(pc_chk, ord(lmin), ord(lmax), cgWord);

              {handle non-zero stating indexes for the array}
              if lmin <> 0 then
                if lmin > maxint then begin
                  GenLdcLong(lmin);
                  Gen0(pc_sbl);
                  end {if}
                else
		  Gen1t(pc_dec, ord(lmin), GetType(inxtype, false));
	      end;
	    end
	  else
            Error(64);

          {set up the result type, after indexing}
          bt := GetType(gattr.typtr, false);
	  with gattr do begin
	    typtr := aeltype;
            isPacked := false;
	    kind := varbl;
	    access := indrct;
	    idplmt := 0;
	    end;

          {index into the array}
	  if gattr.typtr <> nil then begin
	    lsize := gattr.typtr^.size;
	    if ((gattr.typtr = charptr) or (gattr.typtr = boolptr))
	      and (ispacked = pkpacked) then begin
	      lsize := packedcharsize;
              gattr.isPacked := true;
              end; {if}
            if (size < $010000) and (inxtype^.size <= intsize) then begin
	      Gen1t(pc_ldc, long(lsize).lsw, cgUWord);
              Gen0(pc_umi);
	      Gen0t(pc_ixa, cgUWord);
              end {if}
            else begin
              if not (bt in [cgLong,cgULong]) then
                Gen2(pc_cnv,ord(bt),ord(cgULong));
	      GenLdcLong(lsize);
              Gen0(pc_uml);
              Gen0(pc_adl);
              end; {else}
      	    end; {if}
	  end; {with}
    until sy <> comma;

    {make sure there is a matching ']'}
    Match(rbrack,12);
    end; {ArrayIndex}


    procedure FieldSelection;

    { Compile a field selection					}

    var
      form: structform;			{records or objects (kind of variable)}
      disp: addrrange;			{disp in object for method}

    begin {FieldSelection}
    gispacked := gispacked or lispacked;
    with gattr do begin

      {get the variable kind}
      if typtr <> nil then begin
        form := typtr^.form;
	if not (form in [records,objects]) then begin
	  Error(65);
          typtr := nil;
	  end; {if}
        end {if}
      else
        form := records;

      {get the field id}
      if sy = ident then begin
	if typtr <> nil then begin

          {find the field}
          if form = records then
	    SearchSection(typtr^.fstfld, lcp)
          else
	    SearchSection(typtr^.objfld, lcp);
	  if lcp = nil then begin
	    Error(77);
            typtr := nil;
	    end {if}
	  else begin

            {dereference the field}
	    glcp := lcp;
	    with lcp^ do begin
	      typtr := idtype;
	      lispacked := typtr^.ispacked = pkpacked;
	      case access of
		drct:	  begin
                          if form = objects then begin
                            typtr := longptr;
                            Load;
			    if debug then
			      GenL2t(pc_chk, 1, maxaddr, cgULong);
			    typtr := idtype;
                            isPacked := lispacked;
			    kind := varbl;
			    access := indrct;
                            if klass = field then
			      idplmt := fldaddr
                            else
			      idplmt := pfaddr;
                            end {if}
                          else begin
                            dpdisp := dpdisp + fldaddr;
                            if dpdisp > maxint then
                              {use indirect access}
                              LoadAddress;
                            end; {else}
                          end;     
		indrct:   if form = objects then begin
                            typtr := longptr;
                            Load;
			    if debug then
			      GenL2t(pc_chk, 1, maxaddr, cgULong);
                            typtr := idtype;
                            isPacked := lispacked;
			    kind := varbl;                                
			    access := indrct;
                            if klass = field then
			      idplmt := fldaddr
                            else
			      idplmt := pfaddr;
	                    end {if}
                          else
			    idplmt := idplmt + fldaddr;
		inxd:	  Error(113)
		end; {case}
	      end; {with}

            {skip the field name}
	    InSymbol;

            {check for method calls}
            if glcp^.klass = proc then begin
              disp := gattr.idplmt;
              gattr.idplmt := 0;
              LoadAddress;
              Gen0t(pc_stk, cgULong);
	      CallNonStandard(fsys, glcp, fprocp, disp, cMethod);
              isMethod := true;
              end {if}
            else if glcp^.klass = func then begin
              disp := gattr.idplmt;
              gattr.idplmt := 0;
              LoadAddress;
              Gen0t(pc_stk, cgULong);
	      isFunction := true;
	      CallNonStandard(fsys, glcp, fprocp, disp, cMethod);
              isMethod := true;
	      if sy <> arrow then
		gattr.kind := expr;
	      if sy in [period,lbrack] then
        	Error(23);
              end; {else if}
	    end; {else}
	  end {if}
        else

          {skip the field name}
	  InSymbol;
	end {sy = ident}
      else
        Error(2)
      end; {with gattr}
    end; {FieldSelection}


  begin {Selector}
  isFunction := false;
  isMethod := false;
  if not doingCast then begin

    {access the identifier}
    with fcp^, gattr do begin
      typtr := idtype;
      isPacked := false;
      kind := varbl;
      case klass of
	varsm:
	  if vkind = actual then begin
	    {for actual variables, pass back the info}
	    access := drct;
	    vlevel := vlev;
	    dpdisp := 0;
	    if vlevel = 1 then
	      aname := name
	    else
	      dplab := vlabel;
	    end
	  else begin
	    {for formal variables, load their addr and indicate indirection}
	    Gen3t(pc_lod, vlabel, 0, level-vlev, cgULong);
	    access := indrct;
	    idplmt := 0
	    end;
	field:
	  with display[disx] do
	    if occur = crec {field is directly accessable} then begin
	      access := drct;
	      vlevel := clev;
	      if vlevel = 1 then
                aname := cname;
	      dpdisp := cdspl+fldaddr;
              dplab := clab;
	      end {if}
	    else {field must be accessed indirectly} begin
	      {for with only - access temp global variable from stack frame}
	      Gen3t(pc_lod, vdsplab, 0, 0, cgULong);
	      access := indrct;
	      idplmt := fldaddr
	      end;
	func: begin
	  isFunction := true;
	  Call(fsys, fcp, fprocp);
	  if sy <> arrow then
	    gattr.kind := expr;
	  if sy in [period,lbrack] then
            Error(23);
	  end;
	otherwise:;
	end; {case}
      end; {with}
    if not (sy in selectsys + fsys) then begin
      Error(29);
      Skip(selectsys + fsys);
      end;
    lispacked := false;
    if glcp <> nil then
      with glcp^ do
	if {glcp^.}idtype <> nil then
	  lispacked := {glcp^.}idtype^.ispacked = pkpacked;
    {handle selections}
    end; {with}

  {do selections}
  while sy in selectsys do begin
{[} if sy = lbrack then			{indexes}
      ArrayIndex
{.} else if sy = period then begin	{record or object fields}
      InSymbol;
      FieldSelection;
      end {else if}
{^} else begin
      gispacked := false;
      if gattr.typtr <> nil then
	with gattr,typtr^ do
	  if form in [pointerStruct,files] then begin
	    if not isFunction then
	      Load;
	    if form = pointerStruct then
	      typtr := eltype
	    else
	      typtr := filtype;
	    lispacked := typtr^.ispacked = pkpacked;
	    if debug then
	      GenL2t(pc_chk, 1, maxaddr, cgULong);
	    with gattr do begin
              isPacked := false;
	      kind := varbl;
	      access := indrct;
	      idplmt := 0;
	      end;
	    end
	  else
	    Error(66);
      InSymbol;
      end;
    if not (sy in fsys + selectsys) then begin
      Error(6);
      Skip(fsys + selectsys);
      end; {if}
    end {while}
  end; {Selector}

  
  procedure InheritedCall (fsys: setofsys; fprocp: ctp);

  { Compile an inherited call					}
  {								}
  { parameters:							}
  {    fsys - follow symbols					}
  {    fprocp - identifier for program or program-level		}
  {       subroutine contining this statement			}
  
  var
    lcp, lcp2, lcp3: ctp;		{work identifiers}
    loc: unsigned;			{position of '~' in object.method name}
    lsp: stp;				{superclass object type}

  begin {InheritedCall}
  if sy = ident then begin

    {find the current method's object}
    SearchId([proc,func], lcp);
    if lcp <> nil then begin
      id := lcp^.pfoname^;
      loc := Pos('~', id);
      if loc <> 0 then
        id[0] := chr(loc-1);
      SearchId([types], lcp2);
      
      {find the parent object}
      if lcp2 <> nil then
        if lcp2^.idtype <> nil then
          if lcp2^.idtype^.objparent <> nil then begin
            lsp := lcp2^.idtype^.objparent;

            {find the method to be inherited}
            id := lcp^.name^;
	    SearchSection(lsp^.objfld, lcp2);
            if lcp2 = nil then
              Error(130)
            else begin
	      {set up the 'SELF' parameter}
	      id := 'SELF';
	      SearchId([varsm,field], lcp3);
	      if lcp3 <> nil then
		if (lcp3^.idtype <> nil) and (lcp3^.klass = varsm) then begin
		  gattr.typtr := lcp3^.idtype;
        	  gattr.isPacked := false;
        	  gattr.kind := varbl;
        	  gattr.access := drct;
        	  gattr.vlevel := lcp3^.vlev;
        	  gattr.dplab := lcp3^.vlabel;
        	  gattr.dpdisp := 0;
        	  gattr.aname := lcp3^.name;
                  Load;
                  Gen0t(pc_stk, cgULong);
        	  end; {if}

              {call the inherited method}
	      InSymbol;
	      CallNonStandard(fsys, lcp2, fprocp, 0, cInherited);
              end; {else}
            end; {if}
      end; {if}
    end {if}
  else begin
    Error(2);
    Skip(fsys);
    end; {else}
  end; {InheritedCall}


  procedure Expression {fsys: setofsys; fprocp: ctp};

  { compile an expression					}
  {								}
  { parameters:							}
  {    fsys - follow symbols					}
  {    fprocp - identifier for program or program-level		}
  {       subroutine contining this statement			}
  
  var
    lattr: attr;
    lop: operator;
    typind: basetypeenum;
    lsize,rsize: integer;		{size of string operands}
 
    procedure FloatCheck(var first, second: stp);
    {insure that both operands are real}

    begin {FloatCheck}
    if (second = intptr) or (second = byteptr) then begin
      Gen2(pc_cnv,ord(cgWord),ord(cgReal));
      second := realptr;
      end
    else if second = longptr then begin
      Gen2(pc_cnv,ord(cgLong),ord(cgReal));
      second := realptr;
      end
    else if IsReal(second) then
      second := realptr;
    if (first = intptr) or (first = byteptr) then begin
      Gen2(pc_cnn,ord(cgWord),ord(cgReal));
      first := realptr;
      end
    else if first = longptr then begin
      Gen2(pc_cnn,ord(cgLong),ord(cgReal));
      first := realptr;
      end
    else if IsReal(first) then
      first := realptr;
    end; {FloatCheck}

    procedure MatchOpnd(var first, second: stp);
    {insure that the operand types match}

    begin {MatchOpnd}
    {eliminate need for redundant checking}
    if second = byteptr then
      second := intptr
    else if IsReal(second) then
      second := realptr;
    if first = byteptr then
      first := intptr
    else if IsReal(first) then
      first := realptr;
    {match second operand to first if first is of higher type}
    if second = intptr then begin
      if first = longptr then begin
	Gen2(pc_cnv,ord(cgWord),ord(cgLong));
	second := longptr;
	end
      else if first = realptr then begin
	Gen2(pc_cnv,ord(cgWord),ord(cgReal));
	second := realptr;
	end;
      end
    else if second = longptr then
      if first = realptr then begin
	Gen2(pc_cnv,ord(cgLong),ord(cgReal));
	second := realptr;
	end;
    {match first operand to second if second is of higher type}
    if first = intptr then begin
      if second = longptr then begin
	Gen2(pc_cnn,ord(cgWord),ord(cgLong));
	first := longptr;
	end
      else if second = realptr then begin
	Gen2(pc_cnn,ord(cgWord),ord(cgReal));
	first := realptr;
	end;
      end
    else if first = longptr then
      if second = realptr then begin
	Gen2(pc_cnn,ord(cgLong),ord(cgReal));
	first := realptr;
	end;
    end; {MatchOpnd}

    procedure SimpleExpression(fsys: setofsys);
    {compile a simple expression}

    var
      lattr: attr;
      lop: operator;
      signed,foundSign: boolean;
 
      procedure Term (fsys: setofsys);

      { compile a term						}
      {								}
      { parameters:						}
      {    fsys - follow symbols				}

      var
	lattr: attr;
	lop: operator;


	procedure Factor (fsys: setofsys);

	{ compile a factor						}
        {								}
        { parameters:							}
        {    fsys - follow symbols					}

	var
          isMethod: boolean;		{dummy for selector call}
	  lvp: csp;
	  varpart: boolean;
	  cstmax: setlow..sethigh;
	  lsp: stp;
	  lowrange,i: integer;
	  test: boolean;
	  lcp: ctp;			{used to form addresses via atsy}
	  cstpart: ^settype;
	  castType: stp; 		{type to cast to (for type casting)}
	  castSize: addrrange;		{sizes (for type casting)}

	begin {Factor}
	if not (sy in facbegsys) then begin
	  Error(28);
	  Skip(fsys + facbegsys);
	  gattr.typtr := nil;
	  end; {if}
	while sy in facbegsys do begin
	  case sy of
  {id}	    ident: begin
	      SearchId([types,konst,varsm,field,func],glcp);
	      with glcp^ do begin
		InSymbol;
		if klass = types then begin
		  {handle a type cast}
		  if iso then Error(112);
		  castType := {glcp^.}idtype;
		  castSize := castType^.size;
		  Match(lparent,9);
		  Expression(fsys + [rparent],fprocp);
		  if (gattr.typtr^.form in
                    [power,arrays,records,files,tagfld,variant])
                    or (castType^.form in [power,files,tagfld,variant]) then
		    Error(121);
		  if castSize <> gattr.typtr^.size then begin
		    {type conversion}
		    Load;
		    gattr.typtr := castType;
		    if castSize = 2 then
		      Gen2(pc_cnv,ord(cgLong),ord(cgWord))
		    else
		      Gen2(pc_cnv,ord(cgWord),ord(cgLong));
		    Match(rparent,4);
		    end
		  else begin
		    {treat space as another type}
		    gattr.typtr := castType;
		    Match(rparent,4);
		    doingCast := true;
		    Selector(fsys, glcp, fprocp, isMethod);
		    doingCast := false;
		    end;
		  end
		else if klass = konst then
		  with gattr do begin
		    typtr := {glcp^.}idtype;
                    isPacked := false;
		    kind := cst;
		    cval := {glcp^.}values;
		    end
		else
		  Selector(fsys, glcp, fprocp, isMethod);
		end;
	      end;
{inherited} inheritedsy: begin
              InSymbol;
	      InheritedCall(fsys, fprocp);
	      if sy <> arrow then
		gattr.kind := expr;
	      if sy in [period,lbrack] then
        	Error(23);
              end;
  {nil}	    nilsy: begin
	      with gattr do begin
		typtr := nilptr;
                isPacked := false;
		kind := cst;
		cval.ival := 0;
		InSymbol;
		end;
	      end;
  {atsy}    atsy: begin
	      InSymbol;
	      if sy = ident then begin
		SearchId([konst,varsm,field,func,proc],lcp);
		InSymbol;
		if lcp^.klass in [func,proc] then
		  Gen0Name(pc_lad,lcp^.name)
                else if lcp^.klass = konst then begin
                  if IsString(lcp^.idtype) then begin
                    val := lcp^.values;
                    lgth := length(val.valp^.sval);
                    LoadString(lengthString);
		    LoadAddress;
                    end {if}
                  else
                    Error(32);
                  end {else if}
		else begin
		  if lcp^.klass = varsm then begin
		    if lcp^.vcontvar then Error(97);
		    if lcp^.vlev <> level then lcp^.vrestrict := true;
		    end;
		  Selector(fsys, lcp, fprocp, isMethod);
		  LoadAddress;
		  end;
		end
	      else if sy = stringconst then begin
		LoadString(lengthString);
		InSymbol;
		LoadAddress;
		end
	      else Error(2);
	      gattr.kind := expr;
	      gattr.typtr := nilptr;
	      end;
  {cst}	    intconst: begin
	      with gattr do begin
		typtr := intptr;
                isPacked := false;
		kind := cst;
		cval := val;
		end;
	      InSymbol;
	      end;
	    longintconst: begin
	      with gattr do begin
		typtr := longptr;
                isPacked := false;
		kind := cst;
		cval := val;
		end;
	      InSymbol;
	      end;
	    realconst: begin
	      with gattr do begin
		typtr := realptr;
                isPacked := false;
		kind := cst;
		cval := val;
		end;
	      InSymbol;
	      end;
	    stringconst: begin
	      with gattr do begin
		if lgth = 1 then
                  typtr := charptr
		else begin
                  lsp := pointer(Malloc(sizeof(structure)));
		  with lsp^ do begin
		    aeltype := charptr;
		    form := arrays;
		    hasSFile := false;
		    ispacked := pkpacked;
		    inxtype := dummystring;
		    size := lgth*packedcharsize;
		    end; {with}
		  typtr := lsp
		  end; {else}
                isPacked := false;
		kind := cst;
		cval := val;
		end; {with}
	      InSymbol;
	      end;
    {(}	    lparent: begin
	      InSymbol;
	      Expression(fsys + [rparent],fprocp);
	      Load;
	      Match(rparent,4);
	      end;
   {not}    notsy: begin
	      InSymbol;
	      Factor(fsys);
	      Load;
	      Gen0(pc_not);
	      if gattr.typtr <> nil then
		if gattr.typtr <> boolptr then begin
		  Error(60); gattr.typtr := nil;
		  end;
	      end;
   {~}	    bitnot: begin
	      InSymbol;
	      Factor(fsys);
	      Load;
	      if gattr.typtr <> nil then
		if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
		  Gen0(pc_bnt)
		else if gattr.typtr = longptr then
		  Gen0(pc_bnl)
		else begin
		  Error(59);
		  gattr.typtr := nil;
		  end;
	      end;
   {[}	    lbrack: begin
	      new(cstPart);
	      InSymbol;
	      cstpart^ := [ ];
	      varpart := false;
              lsp := pointer(Malloc(sizeof(structure)));
	      cstmax := setlow;
	      with lsp^ do begin
		ispacked := pkeither;
		hasSFile := false;
		form := power;
		elset := nil;
		end;
	      if sy = rbrack then begin
		lsp^.size := cstmax div 8 + 1;
		with gattr do begin
		  typtr := lsp;
                  isPacked := false;
                  kind := cst
                  end;
		InSymbol;
		end
	      else begin
		repeat
		  Expression(fsys + [comma,rbrack,dotdot],fprocp);
		  if gattr.typtr <> nil then
		    if not (gattr.typtr^.form in [scalar,subrange]) then begin
		      Error(61);
                      gattr.typtr := nil;
		      end
		    else if CompTypes(lsp^.elset,gattr.typtr) then begin
		      if gattr.kind = cst then begin
			if (gattr.cval.ival < setlow) or
			  (gattr.cval.ival > sethigh) then Error(110);
			if sy = dotdot then begin
			  InSymbol;
			  lowrange := gattr.cval.ival;
			  Expression(fsys+[comma,rbrack],fprocp);
			  if gattr.typtr <> nil then
			    if not (gattr.typtr^.form in [scalar,subrange]) then
			      begin
			      Error(61);
			      gattr.typtr := nil;
			      end
			    else if CompTypes(lsp^.elset,gattr.typtr) then begin
			      if gattr.kind = cst then begin
				if gattr.cval.ival>sethigh then Error(110);
				for i := lowrange to gattr.cval.ival do
				  cstpart^ := cstpart^+[i];
				if gattr.cval.ival > cstmax then
				  cstmax := gattr.cval.ival;
				end
			      else begin
                                Gen1t(pc_ldc, lowRange, cgWord);
				Load;
				if debug then
				  Gen2t(pc_chk, setlow, sethigh, cgUWord);
				Gen0(pc_sgs);
				if varpart then Gen0(pc_uni)
				else varpart := true
				end;
			      end
			    else Error(62);
			  end
			else begin
			  cstpart^ := cstpart^+[gattr.cval.ival];
			  if gattr.cval.ival > cstmax then
			    cstmax := gattr.cval.ival;
			  end
			end
		      else begin
			Load;
			if debug then
			  Gen2t(pc_chk, setlow, sethigh, cgUWord);
			if sy = dotdot then begin
			  InSymbol;
			  Expression(fsys+[comma,rbrack],fprocp);
			  if gattr.typtr <> nil then
			    if not (gattr.typtr^.form in [scalar,subrange]) then
			      begin
			      Error(61);
			      gattr.typtr := nil;
			      end
			    else if CompTypes(lsp^.elset,gattr.typtr) then begin
			      Load;
			      if debug then
				Gen2t(pc_chk, setlow, sethigh, cgUWord);
			      end
			    else Error(62);
			  end
			else
			  Gen1t(pc_ldc, $8000, cgUWord);
			Gen0(pc_sgs);
			if varpart then Gen0(pc_uni)
			else varpart := true
			end;
		      lsp^.elset := gattr.typtr;
		      gattr.typtr := lsp
		      end
		    else Error(62);
		  test := sy <> comma;
		  if not test then InSymbol
		until test;
		Match(rbrack,12);
		end;
	      if varpart then begin
		if cstpart^ <> [ ] then begin
                  lvp := pointer(Malloc(sizeof(constantRec)));
		  with lvp^ do begin
		    cclass := pset;
		    pval := cstpart^;
		    pmax := cstmax;
		    end;
		  GenLdcSet(lvp^);
		  Gen0(pc_uni);
		  gattr.kind := expr;
		  end
		end
	      else begin
                lvp := pointer(Malloc(sizeof(constantRec)));
		with lvp^ do begin
		  cclass := pset;
		  pval := cstpart^;
		  pmax := cstmax;
		  end;
		gattr.cval.valp := lvp;
                gattr.isPacked := false;
		gattr.kind := cst;
		end;
	      dispose(cstPart);
	      end
	    end; {case}
	  if not (sy in (fsys+[powersy])) then begin
	    Error(6);
            Skip(fsys + facbegsys);
	    end; {if}
	  end; {while}
	if sy = powersy then begin
	  Load;
	  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
	    Gen2(pc_cnv,ord(cgWord),ord(cgReal))
	  else if gattr.typtr = longptr then
	    Gen2(pc_cnv,ord(cgLong),ord(cgReal))
	  else if not IsReal(gattr.typtr) then
	    Error(59);
	  InSymbol;
	  Factor(fsys);
	  Load;
	  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
	    Gen2(pc_cnv,ord(cgWord),ord(cgReal))
	  else if gattr.typtr = longptr then
	    Gen2(pc_cnv,ord(cgLong),ord(cgReal))
	  else if not IsReal(gattr.typtr) then
	    Error(59);
	  Gen0(pc_pwr);
	  gattr.typtr := realptr;
	  end;
	end; {Factor}

      begin {Term}
      Factor(fsys + [mulop,powersy]);
      while sy = mulop do begin
	Load;
	lattr := gattr;
	lop := op;
	InSymbol;
	Factor(fsys + [mulop]);
	Load;
	if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
	  case lop of
   {*}	    mul: begin
	      MatchOpnd(lattr.typtr,gattr.typtr);
	      if lattr.typtr = intptr then
		Gen0(pc_mpi)
	      else if lattr.typtr = longptr then
		Gen0(pc_mpl)
	      else if lattr.typtr = realptr then
		Gen0(pc_mpr)
	      else if(lattr.typtr^.form=power)
		and CompTypes(lattr.typtr,gattr.typtr)then
		Gen0(pc_int)
	      else begin
		Error(59);
		gattr.typtr:=nil;
		end;
	      end;
   {/}	    rdiv: begin
	      FloatCheck(lattr.typtr,gattr.typtr);
	      if lattr.typtr = realptr then
		Gen0(pc_dvr)
	      else begin
		Error(59);
		gattr.typtr := nil;
		end;
	      end;
   {div}    idiv: begin
	      MatchOpnd(lattr.typtr,gattr.typtr);
	      if lattr.typtr = intptr then
		Gen0(pc_dvi)
	      else if lattr.typtr = longptr then
		Gen0(pc_dvl)
	      else begin
		Error(59);
		gattr.typtr := nil;
		end;
	      end;
   {mod}    imod: begin
	      MatchOpnd(lattr.typtr,gattr.typtr);
	      if lattr.typtr = intptr then
		Gen0(pc_mod)
	      else if lattr.typtr = longptr then
		Gen0(pc_mdl)
	      else begin
		Error(59);
		gattr.typtr := nil;
		end;
	      end;
   {and}    andop:
	      if (lattr.typtr = boolptr) and (gattr.typtr = boolptr) then
		Gen0(pc_and)
	      else begin
		Error(59);
		gattr.typtr := nil;
		end;
   {<<}	    lshift: begin
	      MatchOpnd(lattr.typtr,gattr.typtr);
	      if lattr.typtr=intptr then
		Gen0(pc_shl)
	      else if lattr.typtr = longptr then
		Gen0(pc_sll)
	      else begin
		Error(59);
		gattr.typtr:=nil;
		end;
	      end;
   {>>}	    rshift: begin
	      MatchOpnd(lattr.typtr,gattr.typtr);
	      if lattr.typtr=intptr then
		Gen0(pc_shr)
	      else if lattr.typtr = longptr then
		Gen0(pc_slr)
	      else begin
		Error(59);
		gattr.typtr:=nil;
		end;
	      end;
   {&}	    band: begin
	      MatchOpnd(lattr.typtr,gattr.typtr);
	      if lattr.typtr=intptr then
		Gen0(pc_bnd)
	      else if lattr.typtr = longptr then
		Gen0(pc_bal)
	      else begin
		Error(59);
		gattr.typtr:=nil;
		end;
	      end;
	    end {case}
	else
	  gattr.typtr := nil;
	end; {while}
      end; {Term}

    begin {SimpleExpression}
    signed := false;
    foundSign := false;
    if (sy = addop) and (op in [plus,minus]) then begin
      signed := op = minus;
      InSymbol;
      foundSign := true;
      end;
    Term(fsys + [addop]);
    if signed then begin
      Load;
      if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
	Gen0(pc_ngi)
      else if gattr.typtr = longptr then
	Gen0(pc_ngl)
      else if IsReal(gattr.typtr) then
	Gen0(pc_ngr)
      else begin
	Error(59);
	gattr.typtr := nil;
	end;
      end
    else if foundSign then
      if (gattr.typtr <> intptr) and (not IsReal(gattr.typtr))
	and (gattr.typtr <> byteptr) and (gattr.typtr <> longptr) then
	Error(34);
    while sy = addop do begin
      Load;
      lattr := gattr;
      lop := op;
      InSymbol;
      Term(fsys + [addop]);
      Load;
      if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
	case lop of
{+}	  plus: begin
	    MatchOpnd(lattr.typtr,gattr.typtr);
	    if lattr.typtr = intptr then
	      Gen0(pc_adi)
	    else if lattr.typtr = longptr then
	      Gen0(pc_adl)
	    else if lattr.typtr = realptr then
	      Gen0(pc_adr)
	    else if (lattr.typtr^.form=power)
	      and CompTypes(lattr.typtr,gattr.typtr) then
	      Gen0(pc_uni)
	    else begin
	      Error(59);
	      gattr.typtr:=nil;
	      end;
	    end;
{-}	  minus: begin
	    MatchOpnd(lattr.typtr,gattr.typtr);
	    if lattr.typtr = intptr then
	      Gen0(pc_sbi)
	    else if lattr.typtr = longptr then
	      Gen0(pc_sbl)
	    else if lattr.typtr = realptr then
	      Gen0(pc_sbr)
	    else if (lattr.typtr^.form = power)
	      and CompTypes(lattr.typtr,gattr.typtr) then
	      Gen0(pc_dif)
	    else begin
	      Error(59);
	      gattr.typtr := nil;
	      end;
	    end;
{or}	  orop:
	    if (lattr.typtr = boolptr) and (gattr.typtr = boolptr) then
	      Gen0(pc_ior)
	    else begin
	      Error(59);
	      gattr.typtr := nil;
	      end;
{|}	  bor: begin
	    MatchOpnd(lattr.typtr,gattr.typtr);
	    if lattr.typtr = intptr then
	      Gen0(pc_bor)
	    else if lattr.typtr = longptr then
	      Gen0(pc_blr)
	    else begin
	      Error(59);
	      gattr.typtr:=nil;
	      end;
	    end;
{!}	  xor: begin
	    MatchOpnd(lattr.typtr,gattr.typtr);
	    if lattr.typtr = intptr then
	      Gen0(pc_bxr)
	    else if lattr.typtr = longptr then
	      Gen0(pc_blx)
	    else begin
	      Error(59);
	      gattr.typtr:=nil;
	      end;
	    end;
	  end {case}
      else gattr.typtr := nil
      end; {while}
    end; {SimpleExpression}

  begin {Expression}
  SimpleExpression(fsys + [relop]);
  if sy = relop then begin
    if gattr.typtr <> nil then
      if gattr.typtr^.form in [scalar..power,objects] then
	Load
      else
	LoadAddress;
    lattr := gattr;
    lop := op;
    InSymbol;
    SimpleExpression(fsys);
    {set the size of the left operand}
    if lattr.typtr <> nil then
      if IsString(lattr.typtr) then
	lsize := StrLen(lattr.typtr);
    if gattr.typtr <> nil then begin
      if IsString(gattr.typtr) then
	if lattr.typtr = charptr then begin
	  lattr.typtr := stringptr;
	  lsize := -1;
	  end;
      if gattr.typtr^.form in [scalar..power,objects] then
	Load
      else
	LoadAddress;
      end;
    {set the size of the right operand}
    if IsString(gattr.typtr) then
      rsize := StrLen(gattr.typtr)
    else begin
      if lattr.typtr <> nil then
	if IsString(lattr.typtr) then
	  if gattr.typtr = charptr then begin
	    gattr.typtr := stringptr;
	    rsize := -1;
	    end; {if}
      end; {else}

    if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
      if lop = inop then
	if lattr.typtr^.form<power then
	  if gattr.typtr^.form = power then
	    if CompTypes(lattr.typtr,gattr.typtr^.elset) then
	      Gen0(pc_inn)
	    else begin Error(54); gattr.typtr := nil; end
	  else begin Error(55); gattr.typtr := nil; end
	else begin Error(54); gattr.typtr := nil; end
      else begin
	MatchOpnd(lattr.typtr,gattr.typtr);
	if CompTypes(lattr.typtr,gattr.typtr) then begin
	  case lattr.typtr^.form of
	    scalar:
	      if lattr.typtr = realptr then typind := cgReal
	      else if lattr.typtr = boolptr then typind := cgUWord
	      else if lattr.typtr = charptr then typind := cgUWord
	      else if lattr.typtr = doubleptr then typind := cgDouble
	      else if lattr.typtr = compptr then typind := cgComp
	      else if lattr.typtr = extendedptr then typind := cgExtended
	      else if lattr.typtr = longptr then typind := cgLong
	      else typind := cgWord;
	    pointerStruct,objects: begin
	      if lop in [ltop,leop,gtop,geop] then Error(56);
	      typind := cgULong;
	      end;
	    power: begin
	      if lop in [ltop,gtop] then Error(57);
	      typind := cgSet;
	      end;
	    arrays: begin
	      if not IsString(lattr.typtr) then Error(59);
	      typind := cgString;
	      end;
	    records: begin
	      Error(59);
	      typind := cgString;
	      end;
	    files: begin
	      Error(58);
	      typind := cgULong;
	      end
	    end;
          if typind = cgString then begin
	    case lop of
	      ltop: Gen2t(pc_les, lsize, rsize, typind);
	      leop: Gen2t(pc_leq, lsize, rsize, typind);
	      gtop: Gen2t(pc_grt, lsize, rsize, typind);
	      geop: Gen2t(pc_geq, lsize, rsize, typind);
	      neop: Gen2t(pc_neq, lsize, rsize, typind);
	      eqop: Gen2t(pc_equ, lsize, rsize, typind);
	      end {case}
            end
          else
	    case lop of
	      ltop: Gen0t(pc_les, typind);
	      leop: Gen0t(pc_leq, typind);
	      gtop: Gen0t(pc_grt, typind);
	      geop: Gen0t(pc_geq, typind);
	      neop: Gen0t(pc_neq, typind);
	      eqop: Gen0t(pc_equ, typind);
	      end; {case}
	  end
	else Error(54);
	end;
    gattr.typtr := boolptr;
    gattr.kind := expr;
    end; {sy = relop}
  end; {Expression}

 
  procedure Statement (fsys: setofsys; fprocp: ctp; var stlevel: integer;
    var starray: starrtype);

  { Compile a statement						}
  {								}
  { parameters:							}
  {    fsys -							}
  {    fprocp - identifier for program or program-level		}
  {       subroutine contining this statement			}
  {    stlevel -						}
  {    starray -						}

  label 1;

  var
    lcp, fcp: ctp;			{work identifier pointers}
    llp: lbp; i: integer;


    procedure MakeLab(var ml: ctp; n: integer);
    {Change a numbered label into a named label}

    var i: integer;

    begin {MakeLab}
    ml := pointer(Malloc(sizeof(identifier)));
    with ml^ do begin
      name := pointer(Malloc(6));
      name^[0] := chr(5);
      name^[1] := '~';
      for i := 5 downto 2 do begin
	name^[i] := chr(ord('0')+n mod 10);
	n := n div 10;
	end;
      end;
    end; {MakeLab}


    procedure Assignment (fcp: ctp);

    { compile an assignment statement				}
    {								}
    { parameters:						}
    {    fcp - leading identifier in assignment statement	}

    label 1;

    var
      isMethod: boolean;		{is this a method call?}
      lattr: attr;			{attr for left hand side}
      tattr: attr;			{for checking string types}
      stringAssignment: boolean; 	{are we assigning a string?}

    begin {Assignment}
    isMethod := false;
    stringAssignment := false;
    if fcp <> nil then
      with fcp^ do begin
	if klass = func then begin

          {function assignment}
	  pfset := true;
	  if pfdeckind = standard then begin
	    Error(75);
	    gattr.typtr := nil;
	    end
	  else begin
	    if pfkind = formal then
	      Error(76)
	    else if pflev+1 > level then
	      Error(93);
	    with gattr do begin
	      typtr := idtype;
              isPacked := false;
	      kind := varbl;
	      access := drct;
	      vlevel := pflev+1;
	      dplab := pflabel;
              dpdisp := 0;
	      end; {with}
	    end;
	  goto 1;
	  end {if}
	else if klass = varsm then begin

          {variable (non-function) assignment}
	  if vcontvar then
            Error(97);
	  if vlev <> level then
            vrestrict := true;
	  end; {else if}
	end; {with}
    Selector(fsys + [becomes], fcp, fprocp, isMethod);

    {handle the right-hand side}
1:  if not isMethod then
      if sy = becomes then begin
	if gattr.typtr <> nil then begin
	  stringAssignment := IsString(gattr.typtr);
	  if (gattr.access<>drct) or 
	    (gattr.typtr^.form in [arrays,records,files]) then begin
	    LoadAddress;
	    if stringAssignment then
              Gen0t(pc_stk, cgULong);
            end; {if}
	  if stringAssignment then begin
	    Gen1t(pc_ldc, StrLen(gattr.typtr), cgWord);
            Gen0t(pc_stk, cgWord);
            Gen0t(pc_bno, cgWord);
            end; {if}
	  end; {if}
	lattr := gattr;
	InSymbol;
	Expression(fsys,fprocp);
	tattr := gattr;
	if gattr.typtr <> nil then
	  if gattr.typtr^.form = objects then begin
	    Load;
	    if debug then
	      GenL2t(pc_chk, 1, maxaddr, cgULong);
            end {if}
	  else if gattr.typtr^.form in [scalar,subrange,pointerStruct,power] then
	    Load
	  else
	    LoadAddress;

	if (lattr.typtr <> nil) and (gattr.typtr <> nil) then begin
	  if CompTypes(realptr, lattr.typtr) then begin

            {convert a non-real rhs to a real before storing}
	    if (gattr.typtr = intptr) or (gattr.typtr = bytePtr) then begin
	      Gen2(pc_cnv, ord(cgWord), ord(cgReal));
	      gattr.typtr := realptr;
	      end
	    else if gattr.typtr = longptr then begin
	      Gen2(pc_cnv, ord(cgLong), ord(cgReal));
	      gattr.typtr := realptr;
	      end;
	    end
	  else if CompTypes(longptr, lattr.typtr) then

            {convert a non-long rhs to a long before storing}
	    if (gattr.typtr = intptr) or (gattr.typtr = bytePtr) then begin
	      Gen2(pc_cnv, ord(cgWord), ord(cgLong));
	      gattr.typtr := longptr;
	      end; {if}

          {convert a char rhs to a string before storing}
	  if gattr.typtr = charptr then begin
	    if IsString(lattr.typtr) then begin
	      stringAssignment := true;
	      gattr.typtr := stringptr;
              Gen0t(pc_stk, cgUWord);
              GenLdcLong(-1);
              Gen0t(pc_stk, cgULong);
              Gen0t(pc_bno, cgULong);
              Gen0t(pc_bno, cgULong);
	      end;
	    end
	  else if IsString(tattr.typtr) then begin
	    if tattr.kind <> expr then begin
              Gen0t(pc_stk, cgULong);
	      Gen1t(pc_ldc, StrLen(tattr.typtr), cgWord);
              Gen0t(pc_stk, cgWord);
              Gen0t(pc_bno, cgWord);
              end; {if}
            Gen0t(pc_bno, cgULong);
            end;

          {do the assignment}
	  if CompTypes(lattr.typtr, gattr.typtr) then begin
	    case lattr.typtr^.form of
	      scalar,subrange: begin
		CheckBnds(lattr.typtr);
		Store(lattr);
		end;
	      pointerStruct, power, objects:
        	Store(lattr);
	      arrays,records:
		if stringAssignment then
		  Gen1(pc_csp,91{mvs})
		else
	          Gen2(pc_mov, long(lattr.typtr^.size).msw,
                    long(lattr.typtr^.size).lsw);
	      files: ;
	      end; {case}
	    if gattr.typtr^.hasSFile then
	      if lattr.typtr^.form <> pointerStruct then
		Error(71);
	    end {if}
	  else if CompObjects(lattr.typtr, gattr.typtr) then
            Store(lattr)
	  else
            Error(54);
	  end {if}
	end {sy = becomes}
      else
	Error(23);
    end; {Assignment}


    procedure GotoStatement;
    {Compile a goto statement}

    label 1;

    var
      llp: lbp;
      ttop: disprange;
      i: integer;
      fcp: ctp;

    begin {GotoStatement}
    if sy = intconst then begin
      ttop := level;
      repeat
	llp := display[ttop].flabel;
	while llp <> nil do
	  with llp^ do
	    if labval = val.ival then begin
	      for i := ttop to level-1 do
                Gen0(pc_prs);
	      if labname >= firstlab then
                Gen1(pc_ujp, labname)
	      else begin
		MakeLab(fcp,labname);
		Gen0Name(pc_ujp, fcp^.name);
		end;
	      if defined then begin
		if lstlevel > stlevel then Error(99)
		else begin
		  for i := 1 to lstlevel-1 do
		    if starray[i] <> lstarray[i] then begin
		      Error(99); goto 1;
		      end;
		  end;
		end
	      else begin
		if ttop<>level then lstlevel := 1
		else if lstlevel = 0 then begin
		  lstlevel := stlevel; lstarray := starray;
		  end
		else begin
		  if lstlevel > stlevel then lstlevel := stlevel;
		  for i := 1 to lstlevel do
		    if lstarray[i] <> starray[i] then begin
		      lstlevel := i; goto 1;
		      end;
		  end;
		end;
	      goto 1;
	      end
	    else llp := nextlab;
	ttop := ttop-1;
      until ttop = 0;
      Error(89);
1:    InSymbol
      end
    else Error(15)
    end; {GotoStatement}
 
    procedure StartStruct;

    begin {StartStruct}
    if stlevel < maxgoto then starray[stlevel] := starray[stlevel]+1;
    stlevel := stlevel+1;
    end; {StartStruct}

    procedure EndStruct;

    begin {EndStruct}
    if stlevel < maxgoto then starray[stlevel] := 0;
    stlevel := stlevel-1;
    end; {EndStruct}

    procedure CompoundStatement;
    {compile a compound statement}

    var
      test: boolean;

    begin {CompoundStatement}
    StartStruct;
    repeat
      repeat
	Statement(fsys + [semicolon,endsy],fprocp,stlevel,starray);
      until not (sy in statbegsys);
      test := sy <> semicolon;
      if not test then InSymbol
    until test;
    Match(endsy,13); EndStruct;
    end; {CompoundStatement}
 
    procedure IfStatement;

    var
      lcix1,lcix2: integer;

    begin {IfStatement}
    Expression(fsys + [thensy],fprocp);
    lcix1 := GenLabel;
    checkbool;
    Gen1(pc_fjp, lcix1);
    Match(thensy,24);
    StartStruct;
    Statement(fsys + [elsesy],fprocp,stlevel,starray);
    EndStruct;
    if sy = elsesy then begin
      lcix2 := GenLabel;
      Gen1(pc_ujp, lcix2);
      Gen1(dc_lab, lcix1);
      InSymbol; StartStruct;
      Statement(fsys,fprocp,stlevel,starray);
      EndStruct;
      Gen1(dc_lab, lcix2)
      end
    else
      Gen1(dc_lab, lcix1)
    end {IfStatement} ;
 
    procedure CaseStatement;
    {compile a case statement}

    label 1;

    const
      sparse = 5;			{label to tableSize ratio for sparse table}

    var
      foundlab: boolean; 		{was a label found?}
      fstptr,lpt1,lpt2,lpt3: cip;
      isotherwise: boolean;		{was the last label 'otherwise'?}
      laddr, lcix, lcix1: integer;
      lcount: unsigned;			{number of case labels}
      lmin, lmax: integer;		{low, high case label}
      llb: unsigned;			{used to allocate temporary space}
      lsp,lsp1: stp;
      lval: valu;
      otherlab: unsigned;		{otherwise label number}
      test: boolean;

    begin {CaseStatement}
    {evaluate the case expression}
    otherlab := 0;
    Expression(fsys + [ofsy,comma,colon],fprocp);
    Load;
    llb := GetTemp(intsize);
    Gen3t(pc_str, llb, 0, 0, cgWord);
    lcix := GenLabel;
    lsp := gattr.typtr;
    if lsp <> nil then
      if (lsp^.form <> scalar) or IsReal(lsp) then begin
	Error(69);
	lsp := nil;
	end; {if}
    Gen1(pc_ujp, lcix);
    Match(ofsy,8);
    fstptr := nil;
    laddr := GenLabel;

    {collect the labeled statements}
    lmax := -maxint;
    lcount := 0;
    repeat
      StartStruct;
      lpt3 := nil;
      lcix1 := GenLabel;
      foundlab := false;
      if not(sy in [semicolon,endsy]) then begin
	repeat
	  if sy = otherwisesy then begin
	    if otherlab <> 0 then
	      Error(80)
	    else begin
	      foundlab := true;
	      otherlab := lcix1;
	      end;
	    InSymbol;
	    isotherwise := true;
	    end {if}
	  else begin
	    isotherwise := false;
	    DoConstant(fsys + [comma,colon],lsp1,lval);
	    if lval.ival > lmax then
              lmax := lval.ival;
	    if lsp <> nil then
	      if CompTypes(lsp,lsp1) then begin
		lpt1 := fstptr;
		lpt2 := nil;
		while lpt1 <> nil do
		  with lpt1^ do begin
		    if cslab >= lval.ival then begin
		      if cslab = lval.ival then
                        Error(80);
		      goto 1;
		      end; {if}
		    lpt2 := lpt1;
		    lpt1 := next;
		    end; {with}
1:		lpt3 := pointer(Malloc(sizeof(caseInfo)));
		foundlab := true;
		with lpt3^ do begin
		  next := lpt1;
		  cslab := lval.ival;
		  csstart := lcix1;
		  end; {with}
                lcount := lcount+1;
		if lpt2 = nil then
                  fstptr := lpt3
		else
                  lpt2^.next := lpt3
		end {if}
	      else
		Error(72);
	    end;
	  test := sy <> comma;
	  if not test then InSymbol;
	until test;
	if sy = colon then
	  InSymbol
	else if not isotherwise then
	  Error(5);
	Gen1(dc_lab, lcix1);
	repeat
	  Statement(fsys + [semicolon],fprocp,stlevel,starray);
	until not (sy in statbegsys);
	if foundlab then
          Gen1(pc_ujp, laddr);
	end;
      test := sy <> semicolon;
      if not test then InSymbol;
      EndStruct;
    until test;

    {generate the branch code}
    Gen1(dc_lab, lcix);
    if fstptr <> nil then begin		{if there are labels...}
      lmin := fstptr^.cslab;
      if (lmax - lmin) div lcount > sparse then begin

        {use if-else for sparse case statements}
        while fstptr <> nil do begin
          Gen1t(pc_ldc, fstptr^.cslab, cgWord);
          Gen3t(pc_lod, llb, 0, 0, cgWord);
          Gen0t(pc_equ, cgWord);
          Gen1(pc_tjp, fstptr^.csstart);
          fstptr := fstptr^.next;
          end; {while}
        {handle untrapped values}
        if otherlab <> 0 then
          Gen1(pc_ujp, otherlab)
        else begin
          Gen0(pc_nop);
	  Gen1tName(pc_cup, 0, cgVoid, @'~XJPERROR');
          end; {if}
        end {if}
      else begin

        {use a jump table for compact case statements}
	Gen3t(pc_lod, llb, 0, 0, cgWord); {do the indexed jump}
	Gen1t(pc_dec, lmin, cgWord);
	Gen1(pc_xjp, lmax-lmin+1);
	repeat				{generate the jump table}
	  with fstptr^ do begin
	    while cslab > lmin do begin	{generate default labels for gaps in   }
	      Gen1(pc_add, otherlab);	{ the table			       }
	      lmin := lmin+1;
	      end; {while}
	    Gen1(pc_add, csstart);	{generate an entry for a label that    }
	    fstptr := next;		{was specified			       }
	    lmin := lmin+1;
	    end; {with}
	until fstptr = nil;
	Gen1(pc_add, otherlab);		{generate a label for overflows}
        end; {else}

      Gen1(dc_lab, laddr);		{for branching around the table}
      end; {if}
    Match(endsy,13);
    FreeTemp(llb, intsize);		{free the temp label}
    end; {CaseStatement}
 
    procedure RepeatStatement;

    var
      laddr: integer;

    begin {RepeatStatement}
    laddr := GenLabel;
    Gen1(dc_lab, laddr);
    StartStruct;
    repeat
      Statement(fsys + [semicolon,untilsy],fprocp,stlevel,starray);
      if sy in statbegsys then Error(14)
    until not(sy in statbegsys);
    while sy = semicolon do
      begin InSymbol;
      repeat
	Statement(fsys + [semicolon,untilsy],fprocp,stlevel,starray);
	if sy in statbegsys then Error(14)
      until not (sy in statbegsys);
      end;
    Match(untilsy,25);
    Expression(fsys,fprocp);
    checkbool;
    Gen1(pc_fjp, laddr);
    EndStruct;
    end {RepeatStatement} ;
 
    procedure WhileStatement;

    var
      laddr, lcix: integer;

    begin {WhileStatement}
    laddr := GenLabel;
    Gen1(dc_lab, laddr);
    StartStruct;
    Expression(fsys + [dosy],fprocp);
    lcix := GenLabel;
    checkbool;
    Gen1(pc_fjp, lcix);
    Match(dosy,26);
    Statement(fsys,fprocp,stlevel,starray);
    Gen1(pc_ujp, laddr);
    Gen1(dc_lab, lcix);
    EndStruct;
    end; {WhileStatement}
 
    procedure ForStatement;
    {compile a for loop}

    var
      firstExpr: boolean;		{was the first thing an expression?}
      lattr,lattr2: attr;		{local attributes for start, stop}
      ldattr: attr;			{lattr without subranges removed}
      lsy: symbol;			{preserve symbol past InSymbol call}
      lab1, lab2: integer;		{top, bottom labels}
      llb,llb2: unsigned;		{used to allocate temporary space}
      llb1Used,llb2Used: boolean;	{was work space used?}
      lcp,cvlcp: ctp;			{temp ptr to identifier}
      sattr: attr;			{attr for start expr}
      isunsigned: boolean;		{is the loop variable unsigned?}

      startConst,endConst: boolean;	{are start,stop points constant?}
      startVal,endVal: integer;		{ if so, these are the values}


    begin {ForStatement}
    {no work space reserved yet}
    llb1Used := false;
    llb2Used := false;
    firstExpr := false;

    {set up the top and bottom loop points}
    lab1 := GenLabel;
    lab2 := GenLabel;

    {set up a default control variable}
    with lattr do begin
      typtr := nil;
      isPacked := false;
      kind := varbl;
      aName := pointer(ord4(@'  ')+1);
      access := drct;
      vlevel := level;
      dpdisp := 0;
      end;

    {find and check the control variable}
    isunsigned := false;
    if sy = ident then begin
      SearchId([varsm],lcp);
      if lcp <> nil then
         if lcp^.idtype <> nil then
            if lcp^.idtype^.form = subrange then
               isunsigned := lcp^.idtype^.min >= 0;
      with lattr do begin
        isPacked := false;
	kind := varbl;
	with lcp^ do begin
	  typtr := idtype;
	  if vcontvar or vrestrict then
            Error(97);
	  {prohibit use of this var as a control var}
	  vcontvar := true;
	  if vkind = actual then
	    if vlev = level then begin
	      access := drct;
	      aname := name;
	      vlevel := level;
              dpdisp := 0;
	      if level <> 1 then
                dplab := vlabel;
	      end
	    else begin
	      Error(79);
	      typtr := nil;
	      end
	  else begin
	    Error(95);
	    typtr := nil;
	    end;{else}
	  end; {with}
	end; {with}
      cvlcp := lcp;
      ldattr := lattr;
      if lattr.typtr <> nil then
	if (lattr.typtr^.form > subrange)
	  or CompTypes(realptr,lattr.typtr)
	  or CompTypes(longptr,lattr.typtr) then begin
	  Error(68);
	  lattr.typtr := nil;
	  end;
      InSymbol;
      end
    else begin
      Error(2);
      Skip(fsys + [becomes,tosy,downtosy,dosy]);
      end;
    {evaluate the start value for the loop}
    if sy = becomes then begin
      InSymbol;
      Expression(fsys + [tosy,downtosy,dosy],fprocp);
      if gattr.typtr <> nil then begin
	if gattr.typtr^.form = subrange then
	  gattr.typtr := gattr.typtr^.rangetype;
	if gattr.typtr^.form <> scalar then
          Error(69)
	else if CompTypes(lattr.typtr,gattr.typtr) then begin
	  lattr2 := lattr;
	  if gattr.kind = cst then begin
	    startConst := true;
	    startVal := gattr.cval.ival;
	    end {if}
	  else begin
	    startConst := false;
	    with gattr do
	      if (kind = expr) or ((kind = varbl) and (access <> drct)) then
		begin
		Load;
		llb := GetTemp(intsize);
		llb1Used := true;
		Gen3t(pc_str, llb, 0, 0, cgWord);
                isPacked := false;
		kind := varbl;
		access := drct;
		vlevel := level;
		dplab := llb;
		firstExpr := true;
		end; {with}
	    end; {else}
	  sattr := gattr;
	  end {else if}
	else
          Error(70);
	end; {if}
      {evaluate the loop condition and stop point}
      if sy in [tosy,downtosy] then begin
	lsy := sy;
	InSymbol;
	Expression(fsys + [dosy],fprocp);
	if gattr.typtr <> nil then begin
	  if gattr.typtr^.form = subrange then
	    gattr.typtr := gattr.typtr^.rangetype;
	  if gattr.typtr^.form <> scalar then
            Error(69)
	  else if CompTypes(lattr.typtr,gattr.typtr) then begin
	    if gattr.kind = cst then begin
	      endConst := true;
	      endVal := gattr.cval.ival;
	      end
	    else begin
	      endConst := false;
	      Load;
	      {make room for the end value on the stack frame}
	      llb2 := GetTemp(intsize);
	      llb2Used := true;
	      Gen3t(pc_str, llb2, 0, 0, cgWord);
	      end;
	    {initialize the loop variable}
	    gattr := sattr;
	    if firstExpr then
	      Gen3t(pc_lod, gattr.dplab, 0, 0, cgWord)
	    else
	      Load;
	    Store(lattr);
	    if (not startConst) or (not endConst) then begin
	      {check for a skip of the entire body}
	      gattr := ldattr;
	      Load;
	      if endConst then
		Gen1t(pc_ldc, endVal, cgWord)
	      else
	        Gen3t(pc_lod, llb2, 0, 0, cgWord);
	      if lsy = downtosy then
                if isunsigned then
                   Gen0t(pc_geq, cgUWord)
                else
                   Gen0t(pc_geq, cgWord)
              else
                if isunsigned then
                  Gen0t(pc_leq, cgUWord)
		else
                  Gen0t(pc_leq, cgWord);
	      Gen1(pc_fjp, lab2);
	      end {if}
	    else if lsy = tosy then begin
	      if endVal < startVal then
		Gen1(pc_ujp, lab2);
	      end {else if}
	    else
	      if endVal > startVal then
		Gen1(pc_ujp, lab2);
	    Gen1(dc_lab, lab1);
	    end {else if}
	  else
            Error(70);
	  end {if}
	end
      else begin
	Error(27);
	Skip(fsys + [dosy]);
	end; {else}
      {must find the closing do}
      Match(dosy,26);
      {compile the body of the loop}
      StartStruct;
      Statement(fsys,fprocp,stlevel,starray);
      EndStruct;
      if endConst then begin
	{handle a constant stop condition}
	{update the control var}
	gattr := lattr;
	Load;
	if lsy = tosy then
          Gen1t(pc_inc, 1, cgWord)
	else
          Gen1t(pc_dec, 1, cgWord);
	Store(lattr);
	{branch if not done}
	gattr := lattr;
	Load;
	if lsy = tosy then
	  Gen1t(pc_ldc, endVal+1, cgWord)
	else
	  Gen1t(pc_ldc, endVal-1, cgWord);
	Gen0t(pc_equ, cgWord);
	Gen1(pc_fjp, lab1);
	end
      else begin
	{handle a constant end condition}
	{branch if done}
	gattr := lattr;
	Load;
	Gen3t(pc_lod, llb2, 0, 0, cgWord);
	Gen0t(pc_neq, cgWord);
	Gen1(pc_fjp, lab2);
	{update the control var}
	gattr := lattr;
	Load;
	if lsy = tosy then
          Gen1t(pc_inc, 1, cgWord)
	else
          Gen1t(pc_dec, 1, cgWord);
	Store(lattr);
	{back to the top}
	Gen1(pc_ujp, lab1);
	end;
      Gen1(dc_lab, lab2);
      {remove the end value's space from the used part of the stack frame}
      if llb1Used then
        FreeTemp(llb, intsize);
      if llb2Used then
        FreeTemp(llb2, intsize);
      {allow reuse of this var as a control var}
      cvlcp^.vcontvar := false;
      end
    else begin
      Error(23);
      Skip(fsys + [semicolon]);
      end;
    end; {ForStatement}
 
    procedure WithStatement;
    {compile the with statement}

    var
      form: structform;			{kind of with (records or objects)}
      isMethod: boolean;		{dummy for selector call}
      lcp: ctp;
      llb: unsigned;			{for reserving work space}
      llbUsed: boolean;			{was llc used?}
      name: pStringPtr;			{name of the record being with-ed}
      test: boolean;			{test for loop termination}
      len: integer;			{string length}
      oldtop: integer;			{old top value}

    begin {WithStatement}
    llbUsed := false;
    oldtop := top;
    repeat
      if sy = ident then begin
        len := ord(id[0])+2;
        name := pointer(Malloc(len));
	CopyString(name^,id,len);
	SearchId([varsm,field],lcp);
	InSymbol;
	end
      else begin
	Error(2);
	lcp := uvarptr;
	name := nil;
	end;
      Selector(fsys + [comma,dosy], lcp, fprocp, isMethod);
      if gattr.typtr <> nil then begin
        form := gattr.typtr^.form;
	if form in [records,objects] then
	  if top < displimit then begin
	    top := top+1;
	    with display[top] do begin
	      cname := pointer(ord4(@'  ')+1);
              if form = records then
		fname := gattr.typtr^.fstfld
              else
		fname := gattr.typtr^.objfld;
	      flabel := nil;
	      ispacked := gattr.typtr^.ispacked = pkpacked;
	      end; {with}
	    if (gattr.access = drct) and (form = records) then
	      with display[top] do begin
		occur := crec;
		labsused := nil;
		clev := gattr.vlevel;
		if display[disx].occur = crec then
		  cname := display[disx].cname
		else
		  cname := name;
		name := nil;
		cdspl := gattr.dpdisp;
		clab := gattr.dplab;
		end
	    else begin
              if gattr.access = drct {and (form = objects)} then
                Load
              else
	        LoadAddress;
	      llb := GetTemp(ptrsize);
	      llbUsed := true;
	      if level <= 1 then
		Gen3t(pc_str, llb, 0, level-1, cgULong)
	      else
		Gen3t(pc_str, llb, 0, 0, cgULong);
	      with display[top] do begin
		labsused := nil;
		occur := vrec;
		vdsplab := llb;
		end; {with}
	      end; {else}
	    end {if}
	  else
            Error(107)
	else
          Error(65);
        end; {if}
      test := sy <> comma;
      if not test then
        InSymbol;
    until test;
    Match(dosy,26);
    StartStruct;
    Statement(fsys,fprocp,stlevel,starray);
    EndStruct;
    if llbUsed then
      FreeTemp(llb, ptrsize);
    top := oldtop;
    end; {WithStatement}


  begin {Statement}
  if sy = intconst then begin
    {define a label for gotos}
    llp := display[level].flabel;
    while llp <> nil do
      with llp^ do
	if labval = val.ival then begin
	  if defined then Error(87);
	  if labname > firstlab then
            Gen1(dc_lab, labname)
	  else begin
	    MakeLab(fcp,labname);
	    Gen0name(dc_lab, fcp^.name);
	    end;
	  defined := true;
	  if lstlevel <> 0 then
	    if stlevel > lstlevel then Error(99)
	    else
	      for i := 1 to stlevel-1 do
		if starray[i] <> lstarray[i] then begin
		  Error(99);
		  goto 1;
		  end;
	  lstlevel := stlevel;
	  lstarray := starray;
	  goto 1;
	  end
	else llp := nextlab;
    Error(89);
1:  InSymbol; Match(colon,5);
    end;
  if not (sy in fsys + [ident]) then begin
    Error(6);
    Skip(fsys);
    end;

  {if trace names are enabled and a line # is due, generate it}
  if debugFlag or traceBack then
    if lastline<>linecount then
      if namFound then begin
	lastline := linecount;
	Gen2(pc_lnm, linecount, ord(debugType));
	end;
  if sy in statbegsys + [ident] then begin
    case sy of
      beginsy:	   begin InSymbol; CompoundStatement; end;
      gotosy:	   begin InSymbol; GotoStatement; end;
      ifsy:	   begin InSymbol; IfStatement; end;
      casesy:	   begin InSymbol; CaseStatement; end;
      whilesy:	   begin InSymbol; WhileStatement; end;
      repeatsy:    begin InSymbol; RepeatStatement; end;
      forsy:	   begin InSymbol; ForStatement; end;
      withsy:	   begin InSymbol; WithStatement; end;
      inheritedsy: begin InSymbol; InheritedCall(fsys, fprocp); end;
      ident:	   begin
		   SearchId([varsm,field,func,proc], lcp);
		   InSymbol;
		   if lcp^.klass = proc then
                     Call(fsys, lcp, fprocp)
		   else
                     Assignment(lcp);
		   end;
      end;
    {if the string heap was used, purge it}
    if stringHeap then begin
      stringHeap := false;
      Gen0(pc_nop);
      Gen1(pc_csp,92{dsh});
      end;
    {make sure the next token is legal}
    if not (sy in [semicolon,endsy,elsesy,untilsy]) then begin
      Error(6);
      Skip(fsys);
      end;
    end;        
  end; {Statement}
 
  procedure Body (fsys: setofsys; fprocp: ctp);

  { Compile the body of a procedure, function or program	}
  {								}
  { parameters:							}
  {    fsys - follow symbols					}
  {    fprocp - identifier for program or program-level		}
  {       subroutine contining this statement			}
  
  var
    llcp: ctp;
    saveId: pStringPtr;			{program identifier name}
    i: integer;
    llbl: unsigned;
    lcp: ctp;
    llp: lbp;
    fcp: csp;
    fsp: stp;
    plabel: unsigned;			{largest parameter label number}
    size: unsigned;			{temp size}
    stlevel: integer;
    starray: starrtype;
    test: boolean;
    hasFiles: boolean;			{are there any files in the block?}

    procedure GenLocals (lcp: ctp; pLab: unsigned);

    { define non-array global variables				}
    {								}
    { parameters:						}
    {   lcp - symbol table node					}
    {   pLab - largest parameter label				}

    begin {GenLocals}
    if lcp <> nil then
      with lcp^ do begin
	GenLocals(rlink, pLab);
	GenLocals(llink, pLab);
	if klass = varsm then
          if vlabel > pLab then 
            Gen2(dc_loc, vlabel, long(idtype^.size).lsw);
	end; {with}
    end; {GenLocals}


    procedure OpenFiles (lcp: ctp);

    { open all files in the block				}
    {								}
    { parameters:						}
    {   lcp - symbol table node					}
    
    begin {OpenFiles}
    if lcp <> nil then
      with lcp^ do begin
	OpenFiles(rlink);
	OpenFiles(llink);
	if hasIFile then
	  if klass = varsm then begin
	    hasFiles := true;
	    Gen1t(pc_ldc, ord(idtype^.size), cgUWord);
            Gen0t(pc_stk, cgWord);
	    with gattr do begin
	      typtr := idtype;
	      access := drct;
              isPacked := false;
	      kind := varbl;
	      vlevel := vlev;
              dpdisp := 0;
	      if vlev <> 1 then
                dplab := vlabel;
	      aname := name;
	      end; {with}
	    LoadAddress;
            Gen0t(pc_stk, cgULong);
            Gen0t(pc_bno, cgULong);
	    Gen1(pc_csp,35{clr});
	    end; {if}
      end; {with}
    end; {OpenFiles}


    procedure WithSelf;

    { Fake a "with self do begin" for methods			}

    var
      form: structform;			{kind of with (records or objects)}
      lid: pString;			{copy of id}
      lcp: ctp;				{object type}

    begin {WithSelf}
    lid := id;
    id := 'SELF';
    SearchId([varsm,field],lcp);
    if lcp <> nil then
      if lcp^.idtype <> nil then begin
	form := lcp^.idtype^.form;
	if form in [records,objects] then
	  if top < displimit then begin
	    top := top+1;
	    with display[top] do begin
	      isPacked := lcp^.idtype^.ispacked = pkpacked;
	      labsused := nil;
              if form = records then
		fname := lcp^.idtype^.fstfld
              else
		fname := lcp^.idtype^.objfld;
	      flabel := nil;
              occur := vrec;
              vdsplab := lcp^.vlabel;
	      end; {with}
	    end {if}
	  else
            Error(107)
	else
          Error(65);
	end; {if}
    id := lid;
    end; {WithSelf}


  begin {Body}
  namFound := false;			{turn line #s off}
  for stlevel := 1 to maxgoto do
    starray[stlevel] := 0;
  stlevel := 1;
  if level = 1 {program block} then begin
    Gen2Name(dc_str, $4000+$8000*ord(isDynamic), 0, fprocp^.name);
    inseg := true;
    end
  else if level = 2 {entry of level 1 procedure} then
    Gen0(dc_pin)
  else {imbeded procedure}
    Gen1(dc_lab, fprocp^.pfname);
  Gen0(pc_ent);				{create a stack frame}
  ResetTemp;				{forget old temporary variables}

  lcp := fprocp^.pfparms;		{generate code for passed parameters}
  plabel := 0;
  while lcp <> nil do
    with lcp^ do begin
      if klass = varsm then begin
	if idtype <> nil then
	  if idtype^.form > power then begin
            {handle variables always passed as pointers}
	    if vkind = actual then begin
	      if (idtype^.form = records) and (idtype^.size <= 4) then begin
                {short records are passed by value}
		if idtype^.size <= 2 then
		  size := 2
		else
                  size := 4;
		psize := psize-size;
                Gen3(dc_prm, vlabel, size, psize);
		end {if}
              else if idtype^.form = objects then begin
	        psize := psize-ptrsize;
                Gen3(dc_prm, vlabel, ptrsize, psize);
                end {else if}
              else begin
	        psize := psize-ptrsize;
                size := long(idtype^.size).lsw;
                Gen3(dc_prm, vlabel-1, ptrsize, psize);
                Gen2(dc_loc, vlabel, size);
		Gen3(pc_lda, vlabel, 0, 0);
		Gen3t(pc_lod, vlabel-1, 0, 0, cgULong);
		Gen2(pc_mov, 0, size);
                end; {else}
	      end {if}
            else begin
	      psize := psize-ptrsize;
              Gen3(dc_prm, vlabel, ptrsize, psize);
              end; {else}
	    end {else if}
	  else if vkind = actual then begin
	    if IsReal(idtype) then begin
	      psize := psize-extSize;
              Gen3(dc_prm, vlabel, extSize, psize);
              if GetType(idtype, false) <> cgExtended then
	        Gen1t(pc_fix, vlabel, GetType(idtype, false));
	      end
	    else if idtype = byteptr then begin
	      psize := psize-intSize;
              Gen3(dc_prm, vlabel, intSize, psize);
              end {else if}
	    else begin
              size := long(idtype^.size).lsw;
	      psize := psize-size;
              Gen3(dc_prm, vlabel, size, psize);
              end; {else}
	    end
	  else begin
	    psize := psize-ptrsize;
            Gen3(dc_prm, vlabel, ptrsize, psize);
            end; {else}
	if vlabel > plabel then
          plabel := vlabel;
	end {if}
      else if klass in [proc,func] then begin
	psize := psize-procsize;
        Gen3(dc_prm, pflabel, procsize, psize);
	if pflabel > plabel then
          plabel := pflabel;
        end; {else if}
      lcp := lcp^.next;                      
      end; {with}
  if fprocp^.klass = func then begin	{generate the function label}
    case GetType(fprocp^.idtype, false) of
      cgByte,cgUByte,
      cgWord,cgUWord:   size := cgWordSize;
      cgLong,cgULong:   size := cgLongSize;
      cgReal:           size := cgRealSize;
      cgDouble:         size := cgDoubleSize;
      cgComp:           size := cgCompSize;
      cgExtended:       size := cgExtendedSize;
      otherwise:	size := 0;
      end; {case}     
    Gen2(dc_fun, fprocp^.pflabel, size);
    if fprocp^.pflabel > plabel then
      plabel := fprocp^.pflabel;
    end; {if}
  if level <> 1 then			{generate space for local variables}
     GenLocals(display[top].fname, plabel);

					{record the current procedure name}
  if debugFlag or profileFlag or traceBack then begin
    fcp := pointer(Malloc(sizeof(constantRec)));
    with fcp^ do begin
      cclass := strg;
      sval := fprocp^.name^;
      end; {with}
    GenPS(pc_nam, fprocp^.pfoname);
    namFound := true; {turn line #s on}
    end; {if}
					{give the symbol table to the code }
					{ generator.			   }
  if debugFlag then
    Gen1Name(dc_sym, 0, pointer(display[top].fname));
  if fprocp^.klass = prog then begin
    new(saveId);
    saveId^ := id;
    while fextfilep <> nil do begin
      with fextfilep^ do
	if not ((CompNames(filename^,inputid) = 0) or
	  (CompNames(filename^,outputid) = 0) or
	  (CompNames(filename^,erroroutputid) = 0)) then begin
	  id := filename^;
	  SearchSection(display[1].fname,llcp);
	  if llcp = nil then begin
	    write('**** Undeclared external variable: ', filename^);
	    FlagError;
	    end
	  else if llcp^.klass in [proc,func] then begin
	    write('**** External variable cannot be procedure or function: ',
               filename^);
	    FlagError;
	    end;
	  end;
      fextfilep := fextfilep^.nextfile;
      end;
    id := saveId^;
    dispose(saveId);
    end;
  if isMethod then			{do "with self do begin"}
    WithSelf;
  hasFiles := false;			{initialize all file variables}
  OpenFiles(display[top].fname);
  if hasFiles then begin
    {create a new file record level}
    Gen0(pc_nop);
    Gen1(pc_csp,96{orc});
    end;
  repeat				{compile the statements in the body}
    repeat
      Statement(fsys+[semicolon,endsy],fprocp,stlevel,starray);
    until not (sy in statbegsys);
    test := sy <> semicolon;
    if not test then
      InSymbol;
  until test;
  Match(endsy,13);
  llp := display[top].flabel;		{test for undefined labels}
  while llp <> nil do
    with llp^ do begin
      if not defined then begin
	write('**** undefined label: ',labval:1);
	FlagError;
	end;
      llp := nextlab;
      end;
  if hasFiles then begin		{close all files opened in this block}
    Gen0(pc_nop);
    Gen1(pc_csp,97{crc});
    end;
  if fprocp^.klass <> func then		{return to caller}
    Gen0t(pc_ret, cgVoid)
  else
    Gen0t(pc_ret, GetType(fprocp^.idtype, false));
  if level <= 2 then begin		{finish the segment}
    Gen0(dc_enp);
    intlabel := firstlab;
    inseg := false;
    if fprocp^.klass in [proc,func] then begin
      release(fprocp^.pfmark);
      code := pointer(Calloc(sizeof(intermediate_code)));
      end;
    end;
  if isMethod then			{do "end" for "with self do begin"}
    top := top-1;
  end; {Body}
 
  procedure DoBlock {fsys: setofsys; fsy: symbol; fprocp: ctp;
     isProgram: boolean};
  {compile a block}

  label 1;

  const
    returnSize = 3;			{size of a return address}

  var
    actuallc: addrrange; 		{used when updating actual parm locs}
    lsy: symbol; 			{temp symbol}
    foundBody: boolean;			{dummy var for ProcDeclaration}
    lisMethod: boolean;			{copy of isMethod}
    lcp: ctp;				{work pointer}
    procName: pStringPtr;		{name of proc being compiled}


    procedure CheckForw(lcp: ctp);

    begin {CheckForw}
    if lcp<>nil then with lcp^ do begin
      CheckForw(rlink);
      CheckForw(llink);
      if (klass in [proc,func]) and (pfkind = actual) then
	if pfdirective = drforw then begin
	  write('**** forward ref not resolved: ', name^);
	  FlagError;
	  end;
      end;
    end; {CheckForw}


    function ShouldBeCompiled(fsy: symbol): boolean;
    {check to see if a level 1 proc should be compiled; skip if not}

    var
      foundBody: boolean;		{did the proc have a body}
      llist: boolean;			{local list flag}


      function InPartialList(var name: pString): boolean;

      { see if a name is in the partial compile list		}
      {								}
      { parameters:						}
      {    name - name to check					}
      {								}
      { returns: True if the name is in the list, else false	}
      {								}
      { Note: name is var to save space - it is not changed	}

      label 1;

      var
	ptr,lptr: partialptr;

      begin {InPartialList}
      InPartialList := true;
      ptr := partialList;
      lptr := nil;
      while ptr <> nil do begin
	with ptr^ do
	  if CompNames(name, pname^) = 0 then goto 1;
	lptr := ptr;
	ptr := ptr^.next;
	end; {while}
      InPartialList := false;
      1:
      end; {InPartialList}


      procedure SkipProc;
      {skip a procedure or function}

      var
	cnt: integer;			{# ends needed}
	lcp: ctp;			{work pointer for skipping forwards}

      begin {SkipProc}
      {skip to the first function or procedure, or the body}
      while (not eofl) and (not(sy in [beginsy,procsy,funcsy])) do
	InSymbol;
      {skip all of the procedure and function declarations}
      while sy in [procsy,funcsy] do begin
	{skip to the parameter list or the end of the header}
	while (not eofl) and (not (sy in [lparent,semicolon])) do InSymbol;
	{if there is a header, skip it}
	if sy = lparent then begin
	  InSymbol;
	  cnt := 1;
	  while (cnt > 0) and (not eofl) do begin
	    if sy = lparent then cnt := cnt+1
	    else if sy = rparent then cnt := cnt-1;
	    InSymbol;
	    end;
	  end;
	{skip the function return type, if any}
	while (sy <> semicolon) and (not eofl) do InSymbol;
	InSymbol;
	{if the declaration has no block, skip the identifiers (forward, etc)}
	if sy = ident then begin
	  SearchId([directive],lcp);
	  InSymbol;
	  if sy = lparent then begin
	    while (sy <> rparent) and (not eofl) do InSymbol;
	    InSymbol;
	    end;
	  Match(semicolon,14);
	  end
	{for procedures with a block, skip it here}
	else
	  SkipProc;
	end;
      {skip the body}
      Match(beginsy,17);
      cnt := 1;
      while (cnt > 0) and (not eofl) do begin
	if sy in [beginsy,casesy] then
	  cnt := cnt+1
	else if sy = endsy then
	  cnt := cnt-1;
	InSymbol;
	end;
      Match(semicolon,14);
      end; {SkipProc}

    begin {ShouldBeCompiled}
    if InPartialList(id) then
      ShouldBeCompiled := true
    else begin
      ShouldBeCompiled := false;
      {compile the header}
      ProcDeclaration(fsy, fsys, false, false, foundBody);
      {if there is a body, skip it}
      if foundBody then begin
	llist := list;
	list := false;
	SkipProc;
	list := llist;
	end;
      end;
    end; {ShouldBeCompiled}


    procedure Remove(var name: pString);

    { remove a name from the partial compile list		}
    {								}
    { parameters:						}
    {    name - name to remove					}
    {								}
    { Note: name is var to save space - it is not changed	}

    label 1;

    var
      ptr,lptr: partialptr;

    begin {Remove}
    ptr := partialList;
    lptr := nil;
    while ptr <> nil do begin
      with ptr^ do
	if CompNames(name,pname^) = 0 then begin
	  if lptr = nil then
	    partialList := next
	  else
	    lptr^.next := next;
	  goto 1;
	  end; {if}
      lptr := ptr;
      ptr := ptr^.next;
      end; {while}
    1:
    end; {Remove}


  begin {DoBlock}
  {save the methods object, if any}
  lisMethod := isMethod;

  {handle declarations}
  repeat
    while sy = usessy do begin
      InSymbol;
      UsesDeclaration(fsys);
      end; {while}
    if sy = labelsy then begin
      InSymbol;
      LabelDeclaration(fsys);
      if isProgram then
	noGlobalLabels := false;
      end; {if}
    if sy = constsy then begin
      InSymbol;
      ConstDeclaration(fsys);
      end; {if}
    if sy = typesy then begin
      InSymbol;
      TypeDeclaration(fsys);
      end; {if}
    if sy = varsy then begin
      InSymbol;
      VarDeclaration(fsys);
      end; {if}
    {handle procedure, function declarations}
    while sy in [procsy,funcsy] do begin
      if level = 1 then
	nextLocalLabel := 1;
      lsy := sy;
      InSymbol;
      new(procName);
      procName^ := id;
      if (level > 1) or (not partial) then
	ProcDeclaration(lsy, fsys, false, true, foundBody)
      else if ShouldBeCompiled(lsy) then begin
	{compile the header}
	ProcDeclaration(lsy, fsys, false, true, foundBody);
	{remove the name from the list of names to compile}
	if foundBody and (not isMethod) then
	  Remove(procName^);
	if partialList = nil then begin
	  eofl := true;
	  sy := period;
	  goto 1;
	  end;
	end;
      dispose(procName);
      end;
    CheckForw(display[top].fname);
    if not ((sy = beginsy) or (doingUnit and (sy = endsy))) then begin
      Error(18);
      Skip(fsys);
      end;
  until (sy in statbegsys) or (doingUnit and (sy = endsy)) or eofl;

  {compile the body of the block}
  if (not doingUnit) or (level > 1) then begin
    if level = 1 then
      nextLocalLabel := 1;
    Match(beginsy,17);                            
    repeat
      isMethod := lisMethod;
      Body(fsys + [casesy],fprocp);
      if sy <> fsy then begin
	Error(6);
	Skip(fsys);
	end;
    until (sy = fsy) or (sy in blockbegsys) or eofl;
    end; {if}
1:
  end; {DoBlock}
 
  procedure Programme{fsys:setofsys};
  {Compile a program}

  var
    fp,extfp,nextfp: extfilep;
    lcp: ctp;
    idname: pStringPtr;			{segment name}
    noStart: boolean;			{has a start been generated?}
    len: integer;			{string length}

    procedure DoGlobals;
    {declare the ~globals and ~arrays segments}

    var
      didone: boolean;			{did we generate at least one label?}

      procedure GenArrays(lcp: ctp);

      { define global arrays					}
      {								}
      { parameters:						}
      {   lcp - stack frame to check for arrays			}

      var
        size: addrrange;		{size of the array}

      begin {GenArrays}
      if lcp <> nil then with lcp^ do begin
	GenArrays(rlink);
	GenArrays(llink);
	if klass = varsm then
	  if idtype^.form in [arrays,records] then
	    if not fromUses then begin
	      if noStart then begin
		idName := @'~ARRAYS';
		if smallMemoryModel then
		  NextSegName('          ')
		else
		  NextSegName('~ARRAYS   ');
		Gen2Name(dc_str, $4000, 1, idname);
		noStart := false;
		end;
	      Gen2Name(dc_glb, 0, ord(vPrivate), name);
              size := idtype^.size;
              while size > maxint do begin
                Gen1(dc_dst, $4000);
                size := size-$4000;
                end; {while}
              Gen1(dc_dst, long(size).lsw);
	      end;
	end;
      end; {GenArrays}

      procedure GenGlobals(lcp: ctp);
      {define non-array global variables}

      begin {GenGlobals}
      if lcp <> nil then with lcp^ do begin
	GenGlobals(rlink);
	GenGlobals(llink);
	if klass = varsm then
	  if not (idtype^.form in [arrays,records]) then
	    if not fromUses then begin
	      Gen2Name(dc_glb, long(idtype^.size).lsw, ord(vPrivate), name);
	      didone := true;
	      end; {if}
	end;
      end; {GenGlobals}

    begin {DoGlobals}
    {declare the ~globals segment, which holds non-array data types}
    idName := @'~GLOBALS';
    if smallMemoryModel then
      NextSegName('          ')
    else
      NextSegName('~GLOBALS  ');
    Gen2Name(dc_str, $4000, 0, idname);
    didone := false;
    GenGlobals(display[1].fname);
    if not didone then
      if not smallMemoryModel then
	Gen2Name(dc_glb, 1{byte}, 1{private}, @'~');
    Gen0(dc_enp);
    {declare the ~arrays segment, which holds global arrays}
    noStart := true;
    GenArrays(display[1].fname);
    if not noStart then
      Gen0(dc_enp);
    end; {DoGlobals}

    procedure InterfacePart;
    {compile the interface part of a unit}

    var
      lsy: symbol;			{temp symbol}
      foundBody: boolean;		{dummy var for ProcDeclaration}
 
    begin {InterfacePart}
    repeat
      {handle declarations}
      while sy = usessy do begin InSymbol; UsesDeclaration(fsys); end;
      if sy = constsy then begin InSymbol; ConstDeclaration(fsys); end;
      if sy = typesy then begin InSymbol; TypeDeclaration(fsys); end;
      if sy = varsy then begin InSymbol; VarDeclaration(fsys); end;
      {handle procedure, function declarations}
      while sy in [procsy,funcsy] do begin
	lsy := sy;
	InSymbol;
	{compile the header}
        nextLocalLabel := 1;
	ProcDeclaration(lsy, fsys+[implementationsy], false, true, foundBody);
	if foundBody then
	  Error(120);
	end;
      if sy <> implementationsy then begin
	Skip([period]);
	InSymbol;
	end;
    until (sy = implementationsy) or eofl;
    end; {InterfacePart}

  begin {Programme}
  progfound := true;
					{create the main program name}
  lcp := pointer(Malloc(sizeof(identifier)));
  with lcp^ do begin
    name := @'~_PASMAIN';
    idtype := nil;
    next := nil;
    klass := prog;
    pfname := 0;
    pfoname := name;
    pfactualsize := 0;
    pfparms := nil;
    hasIFile := false;
    end;
  EnterId(lcp);
  if sy = progsy then begin {compilation of a program}
    if kNameGS.theString.size <> 0 then {start output files}
      CodeGenInit(kNameGS, keepflag, partial);
    InSymbol;
    Match(ident,2);
    {compile the program's parameter list}
    if sy = lparent then begin
      nextfp := nil;
      repeat
	InSymbol;
	if sy = ident then begin
          extfp := pointer(Malloc(sizeof(filerec)));
	  with extfp^ do begin
            len := ord(id[0])+2;
            filename := pointer(Malloc(len));
	    CopyString(filename^,id,len);
	    nextfile := nil;
	    end;
	  fp := fextfilep;
	  while fp <> nil do begin
	    if CompNames(fp^.filename^,id) = 0 then
              Error(30);
	    fp := fp^.nextfile;
	    end;
	  if nextfp <> nil then nextfp^.nextfile := extfp;
	  nextfp := extfp;
	  if fextfilep = nil then fextfilep := extfp;
	  if CompNames(id,inputid) = 0 then noinput := false;
	  if CompNames(id,outputid) = 0 then nooutput := false;
	  if CompNames(id,erroroutputid) = 0 then noerroroutput := false;
	  InSymbol;
	  if not (sy in [comma,rparent]) then Error(20);
	  end
	else Error(2);
      until sy <> comma;
      if sy <> rparent then Error(4);
      InSymbol;
      end;
    Match(semicolon,14);
    {compile the block}
    repeat DoBlock(fsys,period,lcp,true);
      if sy <> period then Error(21);
    until (sy = period) or eofl;
    end
  else begin {compilation of a unit}
    noInput := false;			{allow all I/O}
    noOutput := false;
    noErrorOutput := false;
    doingUnit := true;			{note that this is a unit}
    if kNameGS.theString.size <> 0 then {start output files}
      CodeGenInit(kNameGS, keepflag, partial);
    Match(unitsy,3);			{compile the header}
    Match(ident,2);
    Match(semicolon,14);
    doingInterface := true;		{compile the interface part}
    Match(interfacesy,119);
    InterfacePart;
    doingInterface := false;
    CloseToken;
    Match(implementationsy,118); 	{compile the implementation part}
    DoBlock(fsys,period,lcp,true);
    if not ((sy = period) and eofl) then begin
      Match(endsy,13);
      if sy <> period then begin
        Error(21);
        if allTerm then
          while (errinx <> 0) and (not eofl) do
            InSymbol;
        end; {if}
      end;
    end;
  DoGlobals;				{declare the global variables}
  end; {Programme}
 
{----Initialization-------------------------------------------------------}

  procedure InitScalars;
  {Initialize global scalars}

  var
    i: integer;

  begin {InitScalars}
  level := 0; top := 0;			{set up level 0 frame}
  with display[0] do begin
     fname := nil;
     flabel := nil;
     labsused := nil;
     occur := blck;
     ispacked := false;
     end; {with}
  display[1] := display[0];

  code := pointer(Calloc(sizeof(intermediate_code)));
  {code^.lab := nil;}
  fwptr := nil;
  fextfilep := nil;
  thisType := nil;			{not declaring a type}
  tempList := nil; 			{no temp variables}
  nextLocalLabel := 1;			{reset local label count}
  numerr := 0;				{no errors found}
  errinx := 0;
  intlabel := 0;
  linecount := 0;			{no lines processed}
  lastline := 0;
  firstlab := 0;
  eofl := false; 			{not at end of file}
  iso := false;				{don't enforce iso}
  progfound := false;			{program symbol not found}
  inseg := false;
  debug := false;			{don't generate check code}
  inUses := false;
  stringHeap := false;
  namFound := false;
  isDynamic := false;			{segments are not dynamic}
  isMethod := false;			{not doing a method}
  doingInterface := false;		{not doing interface part}
  doingUnit := false;			{not doing a unit}
  doingCast := false;			{not casting an expression}
  noGlobalLabels := true;		{no program level labels found so far}
  prterr := true;
  noinput := true;
  nooutput := true;
  noerroroutput := true;
  psize := 0;				{no parameters at the program level}
  ch := ' ';
  code^.optype := cgWord;
  gattr.aname := pointer(Malloc(maxCnt+1));

  inputid := 'INPUT';
  outputid := 'OUTPUT';
  erroroutputid := 'ERROROUTPUT';
  end; {InitScalars}
 
  procedure InitSets;
  {initialize structured set constants}

  begin {InitSets}
  constbegsys := [addop,intconst,realconst,stringconst,ident,nilsy,
    longintconst];
  simptypebegsys := [lparent] + constbegsys;
  typebegsys:=[stringsy,arrow,packedsy,arraysy,recordsy,setsy,filesy,objectsy]
    +simptypebegsys;
  typedels := [arraysy,recordsy,setsy,filesy];
  blockbegsys := [labelsy,constsy,typesy,varsy,procsy,funcsy,beginsy];
  selectsys := [arrow,period,lbrack];
  facbegsys := [intconst,realconst,stringconst,ident,lparent,bitnot,
    nilsy,lbrack,notsy,atsy,longintconst,inheritedsy];
  statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,withsy,casesy,
    inheritedsy];
  end {InitSets};
 
end.
\ No newline at end of file
+{$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(sizeof(structure)));
+      with lsp^ do begin
+	aeltype := charptr;
+	inxtype := nil;
+	ispacked := pkpacked;
+	hasSFile := false;
+	size := lgth*packedcharsize;
+	form := arrays;
+	end; {with}
+      end; {else}
+    fvalu := val;
+    InSymbol;
+    end
+  else begin
+    sign := none;
+    if (sy = addop) and (op in [plus,minus]) then begin
+      if op = plus then sign := pos else sign := neg;
+      InSymbol;
+      end; {if}
+    if sy = ident then begin
+      searchid([konst],lcp);
+      if lcp <> nil then
+	with lcp^ do begin
+	  lsp := idtype;
+	  fvalu := values;
+	  end {with}
+      else begin
+	fvalu.ival := 0;
+	lsp := intptr;
+	end; {else}
+      if sign = neg then
+	if (lsp = intptr) or (lsp = byteptr) then
+	  fvalu.ival := -fvalu.ival
+	else if lsp = longptr then begin
+          lvp := pointer(Malloc(constantRec_longC));
+          lvp^.cclass := longC;
+	  lvp^.lval := -fvalu.valp^.lval;
+	  fvalu.valp := lvp;
+	  end {else if}
+	else if IsReal(lsp) then begin
+          lvp := pointer(Malloc(constantRec_reel));
+          lvp^.cclass := reel;
+	  lvp^.rval := -fvalu.valp^.rval;
+	  fvalu.valp := lvp;
+	  end; {else if}
+      if sign <> none then
+	if (lsp <> intptr) and (not IsReal(lsp)) and
+	  (lsp <> byteptr) and (lsp <> longptr) then
+	  Error(34);
+      InSymbol;
+      end {if}
+    else if sy = intconst then begin
+      if sign = neg then
+        val.ival := -val.ival;
+      lsp := intptr;
+      fvalu := val;
+      InSymbol;
+      end {else if}
+    else if sy = realconst then begin
+      if sign = neg then
+        val.valp^.rval := -val.valp^.rval;
+      lsp := realptr;
+      fvalu := val;
+      InSymbol;
+      end {else if}
+    else if sy = longintconst then begin
+      if sign = neg then
+        val.valp^.lval := -val.valp^.lval;
+      lsp := longptr;
+      fvalu := val;
+      InSymbol;
+      end {else if}
+    else begin
+      Error(35);
+      Skip(fsys);
+      end {else if}
+    end; {else}
+  if not (sy in fsys) then begin
+    Error(6);
+    Skip(fsys);
+    end; {if}
+  end; {if}
+fsp := lsp;
+end; {DoConstant}
+
+
+  procedure CheckUses(var id: pString; sym: symbol);
+  {make sure this name has not been used from another level}
+
+  label 1;
+
+  var
+    p: lptr;				{work pointer for traversing list}
+    lcp: ctp;				{work pointer for checking fwd ptrs}
+
+  begin {CheckUses}
+  p := display[top].labsused;
+  while p <> nil do begin
+    if CompNames(p^.name^,id) = 0 then begin
+      Error(18);
+      goto 1;
+      end;
+    p := p^.next;
+    end;
+  if sym <> typesy then begin
+    lcp := fwptr;
+    while lcp <> nil do begin
+      if CompNames(lcp^.name^,id) = 0 then begin
+	Error(18);
+	goto 1;
+	end;
+      lcp := lcp^.next;
+      end;
+    end;
+  1:
+  end; {CheckUses}
+
+  procedure ExportUses;
+  {uses from more than one level back are exported to the previous level}
+
+  label 1;
+
+  var
+    p,q,r: lPtr; 			{for moveing used id list up}
+
+  begin {ExportUses}
+  p := display[top].labsused;		{check all labels in curent list}
+  while p <> nil do begin
+    if p^.disx < top-1 then begin	{if they are from more than one level  }
+      q := display[top-1].labsused;	{ back, they must be in the last list  }
+      while q <> nil do begin		{skip if the label is already in the   }
+	if q^.name = p^.name then	{ last list			       }
+	  goto 1;
+	q := q^.next;
+	end; {while}
+      new(r);				{insert in the last list}
+      r^.next := display[top-1].labsused;
+      display[top-1].labsused := r;
+      r^.name := p^.name;
+      r^.disx := p^.disx;
+      end; {if}
+    p := p^.next;
+    end; {while}
+  1:
+  end; {ExportUses}
+
+
+  procedure ProcDeclaration (fsy: symbol; fsys: setofsys;
+    isObject, compilebody: boolean; var foundbody: boolean); forward;
+
+  { Procedure/function declaration				}
+
+
+  procedure Typ (fsys: setofsys; var fsp: stp; var fsize: addrrange;
+    isType: boolean);
+
+  { compile a type definition					}
+  {								}
+  { parameters:							}
+  {    fsys - follow symbols					}
+  {    fsp -							}
+  {    fsize -							}
+  {    isType - is this the root level of a type declaration?	}
+
+  var
+    lsp,lsp1,lsp2: stp;
+    oldtop: disprange;			{display level on entry}
+    ttop: disprange;			{temp display level}
+    lcp, lcp2: ctp;
+    lsize,disp1: addrrange;
+    lmin,lmax: longint;
+    ispacked: packedkinds;
+    test: boolean;
+    lvalu: valu;
+    len: integer;			{string length}
+    l1,l2,l3: longint;			{used to compute array size}
+    lval: record 			{used to convert between types}
+      case boolean of
+	true : (long: longint);
+	false: (lsw: integer; msw: integer);
+      end;
+
+
+    procedure Duplicate (var ncp: ctp; ocp: ctp);
+
+    { Duplicate a field list					}
+    {								}
+    { parameters:						}
+    {    ncp - (output) new (copied) identifier			}
+    {    ocp - identifier to copy				}
+
+    begin {Duplicate}
+    if ocp <> nil then begin
+      ncp := pointer(Malloc(sizeof(identifier)));
+      ncp^ := ocp^;
+      Duplicate(ncp^.llink, ocp^.llink);
+      Duplicate(ncp^.rlink, ocp^.rlink);
+      end; {if}
+    end; {Dulpicate}
+
+
+    procedure SimpleType (fsys:setofsys; var fsp:stp; var fsize:addrrange);
+
+    { Compile a simple type					}
+    {								}
+    { parameters:						}
+    {    fsys -							}
+    {    fsp -							}
+    {    fsize -						}
+
+    var
+      lsp,lsp1: stp;
+      lcp,lcp1: ctp;
+      ttop: disprange;
+      lcnt: integer;
+      lvalu: valu;
+      len: integer;			{string length}
+
+    begin {SimpleType}
+    fsize := 1;
+    if not (sy in simptypebegsys) then begin
+      Error(1);
+      Skip(fsys + simptypebegsys);
+      end; {if}
+    if sy in simptypebegsys then begin
+
+      {enumerations}
+      if sy = lparent then begin
+	ttop := top;   {decl. consts local to innermost block}
+	while display[top].occur <> blck do
+          top := top - 1;
+        lsp := pointer(Malloc(sizeof(structure)));
+	with lsp^ do begin
+	  size := intsize;
+	  form := scalar;
+	  hasSFile := false;
+	  scalkind := declared;
+	  end; {with}
+	lcp1 := nil;
+	lcnt := 0;
+	repeat
+	  InSymbol;
+	  if sy = ident then begin
+            lcp := pointer(Malloc(sizeof(identifier)));
+	    with lcp^ do begin
+	      len := ord(id[0])+2;
+              name := pointer(Malloc(len));
+	      CopyString(name^,id,len);
+	      idtype := lsp;
+	      next := lcp1;
+	      values.ival := lcnt;
+	      klass := konst;
+	      hasIFile := idtype^.hasSFile;
+	      end;
+	    CheckUses(lcp^.name^,constsy);
+	    EnterId(lcp);
+	    lcnt := lcnt + 1;
+	    lcp1 := lcp; InSymbol
+	    end
+	  else Error(2);
+	  if not (sy in fsys + [comma,rparent]) then begin
+	    Error(6);
+	    Skip(fsys + [comma,rparent]);
+	    end;
+	until sy <> comma;
+	lsp^.fconst := lcp1;
+	top := ttop;
+	Match(rparent,4);
+	end
+
+      {named types, subranges}
+      else begin
+	if sy = ident then begin
+	  SearchID([types,konst],lcp);
+	  if lcp^.name = thisType then
+            Error(10);
+	  InSymbol;
+	  if lcp^.klass = konst then begin
+            lsp := pointer(Malloc(sizeof(structure)));
+	    with lsp^, lcp^ do begin
+	      rangetype := idtype;
+	      form := subrange;
+	      hasSFile := false;
+              if rangetype = longptr then begin
+	        min := values.valp^.lval;
+	        size := longsize;
+                end {if}
+              else begin
+	        min := values.ival;
+	        size := intsize;
+                end; {else}
+	      end;
+	    Match(dotdot,83);
+	    DoConstant(fsys,lsp1,lvalu);
+            if lsp1 = longptr then
+	      lsp^.max := lvalu.valp^.lval
+            else
+	      lsp^.max := lvalu.ival;
+	    if lsp^.rangetype <> lsp1 then
+              if (lsp^.rangetype = intptr) and (lsp1 = longptr) then begin
+        	lsp^.rangetype := longptr;
+                lsp^.size := longsize;
+                end {if}
+              else if (lsp^.rangetype <> longptr) or (lsp1 <> intptr) then
+        	Error(36);
+	    end
+	  else begin
+	    lsp := lcp^.idtype;
+	    if lsp <> nil then fsize := lsp^.size;
+	    if iso then
+	      if (lsp = longptr) or (lsp = byteptr) then Error(112);
+	    end
+	  end {sy = ident}
+	else begin
+          lsp := pointer(Malloc(sizeof(structure)));
+	  DoConstant(fsys + [dotdot],lsp1,lvalu);
+	  with lsp^ do begin
+	    form := subrange;
+	    hasSFile := false;
+	    rangetype:=lsp1;
+            if rangetype = longptr then begin
+	      min := lvalu.valp^.lval;
+	      size := longsize;
+              end {if}
+            else begin
+	      min := lvalu.ival;
+	      size := intsize;
+              end; {else}
+	    end;
+	  Match(dotdot,83);
+	  DoConstant(fsys,lsp1,lvalu);
+          if lsp1 = longptr then
+	    lsp^.max := lvalu.valp^.lval
+          else
+	    lsp^.max := lvalu.ival;
+	  if lsp^.rangetype <> lsp1 then
+            if (lsp^.rangetype = intptr) and (lsp1 = longptr) then begin
+              lsp^.rangetype := longptr;
+              lsp^.size := longsize;
+              end {if}
+            else if (lsp^.rangetype <> longptr) or (lsp1 <> intptr) then
+              Error(36);
+	  end;
+	if lsp <> nil then
+	  with lsp^ do
+	    if form = subrange then
+	      if rangetype <> nil then
+		if IsReal(rangetype) or IsString(rangetype) then
+                  Error(73)
+		else if min > max then
+                  Error(31)
+	end;
+      fsp := lsp;
+      if not (sy in fsys) then begin
+        Error(6);
+        Skip(fsys)
+        end; {if}
+      end
+    else fsp := nil
+    end; {SimpleType}
+
+
+    procedure FieldList (fsys: setofsys; var frecvar: stp; var hasFile: boolean;
+      isObject: boolean);
+
+    { compile a field list					}
+    {								}
+    { parameters:						}
+    {    fsys - following symbols				}
+    {    frecvar -						}
+    {    hasFile -						}
+    {    isObject - is this an object? (or a record)		}
+
+    label 1;
+
+    var
+      lcp,lcp1,nxt,nxt1,inst: ctp;
+      lsp,lsp1,lsp2,lsp3,lsp4: stp;
+      minsize,maxsize,lsize: addrrange;
+      lvalu: valu;
+      numcase: longint;
+      max,min: longint;
+      tHasFile: boolean; 		{tracks files in the field list}
+      len: integer;			{length of a string}
+      hasId: boolean;			{does the case have an attached id?}
+
+    begin {FieldList}
+    lsp := nil;
+    hasFile := false;
+    if not (sy in fsys+[ident,casesy]) then begin
+      Error(19);
+      Skip(fsys + [ident,casesy]);
+      end;
+    while sy = ident do begin
+      nxt := nil;
+      nxt1 := nil;
+      repeat
+	if sy = ident then begin
+          lcp := pointer(Malloc(sizeof(identifier)));
+	  with lcp^ do begin
+	    len := ord(id[0])+2;
+            name := pointer(Malloc(len));
+	    CopyString(name^,id,len);
+	    idtype := nil;
+	    next := nil;
+	    klass := field;
+	    fldvar := false;
+	    hasIFile := false;
+	    end;
+	  if nxt1 <> nil then
+            nxt1^.next := lcp;
+	  nxt1 := lcp;
+	  if nxt = nil then
+            nxt := lcp;
+	  EnterId(lcp);
+	  InSymbol;
+	  end
+	else Error(2);
+	if not (sy in [comma,colon]) then begin
+          Error(6);
+          Skip(fsys + [comma,colon,semicolon,casesy])
+	  end; {if}
+	test := sy <> comma;
+	if not test then InSymbol;
+      until test;
+      Match(colon,5);
+      Typ(fsys + [casesy,semicolon], lsp, lsize, false);
+      hasFile := hasFile or lsp^.hasSFile;
+      while nxt <> nil do
+	with nxt^ do begin
+	  idtype := lsp;
+	  fldaddr := disp1;
+	  nxt := next;
+	  disp1 := disp1 + lsize;
+	  end;
+      while sy = semicolon do begin
+	InSymbol;
+	if not (sy in fsys + [ident,casesy,semicolon]) then begin
+	  Error(19);
+	  Skip(fsys + [ident,casesy]);
+	  end;
+	end;
+      end; {while sy = ident}
+    if sy = casesy then begin
+      if isObject then
+        Error(123);
+      hasId := false;
+      lsp := pointer(Malloc(sizeof(structure)));
+      with lsp^ do begin
+	tagfieldp := nil;
+	fstvar := nil;
+	form := tagfld;
+	hasSFile := false;
+	end;
+      frecvar := lsp;
+      InSymbol;
+      if sy = ident then begin
+        lcp := pointer(Malloc(sizeof(identifier)));
+	with lcp^ do begin
+	  len := ord(id[0])+2;
+          name := pointer(Malloc(len));
+	  CopyString(name^,id,len);
+	  idtype := nil;
+	  klass:=field;
+	  next := nil;
+	  fldaddr := disp1;
+	  fldvar := true;
+	  hasIFile := false;
+	  end;
+	InSymbol;
+	if sy = colon then begin
+	  InSymbol;
+	  hasId := true;
+	  if sy <> ident then begin
+	    Error(2);
+	    Skip(fsys + [ofsy,lparent]);
+	    goto 1;
+	    end; {if sy <> ident}
+	  EnterId(lcp);
+	  end
+	else begin
+	  id := lcp^.name^;
+	  if sy <> ofsy then Error(8);
+	  end;
+	SearchID([types], lcp1);
+	lsp1 := lcp1^.idtype;
+	if lsp1 <> nil then begin
+	  lcp^.fldaddr := disp1;
+	  if hasId then
+	    disp1 := disp1+lsp1^.size;
+	  if lsp1^.form <= subrange then begin
+	    if IsReal(lsp1) then
+              Error(39)
+	    else if (lsp1 = intptr) or (lsp1 = longptr) then begin
+	      Error(111);
+	      numcase := maxint;
+	      end
+	    else begin
+	      GetBounds(lsp1,min,max);
+	      if (max >= 0) and (min <= 0) then
+		if max < (maxint+min) then
+		  numcase := max-min+1
+		else begin
+		  Error(111);
+		  numcase := maxint;
+		  end
+	      else
+		numcase := max-min+1
+	      end;
+	    lcp^.idtype := lsp1;
+	    lsp^.tagfieldp := lcp;
+	    end
+	  else
+            Error(39);
+	  end;
+	if sy = ident then InSymbol;
+	end
+      else begin
+	Error(2);
+	Skip(fsys + [ofsy,lparent]);
+	end;
+1:    lsp^.size := disp1;
+      Match(ofsy,8);
+      lsp1 := nil;
+      minsize := disp1;
+      maxsize := disp1;
+      repeat
+	lsp2 := nil;
+	if not (sy in fsys + [semicolon]) then begin
+	  repeat
+	    DoConstant(fsys + [comma,colon,lparent],lsp3,lvalu);
+	    if lsp^.tagfieldp <> nil then
+	      if not CompTypes(lsp^.tagfieldp^.idtype,lsp3) then
+		Error(40);
+            lsp3 := pointer(Malloc(sizeof(structure)));
+	    numcase := numcase-1;
+	    with lsp3^ do begin
+	      nxtvar := lsp1;
+	      subvar := lsp2;
+	      varval := lvalu.ival;
+	      form := variant;
+	      hasSFile := false;
+	      end;
+	    lsp4 := lsp1;
+	    while lsp4 <> nil do
+	      with lsp4^ do begin
+		if varval = lvalu.ival then Error(94);
+		lsp4 := nxtvar;
+		end;
+	    lsp1 := lsp3;
+	    lsp2 := lsp3;
+	    test := sy <> comma;
+	    if not test then InSymbol;
+	  until test;
+	  Match(colon,5);
+	  Match(lparent,9);
+	  FieldList(fsys + [rparent, semicolon], lsp2, tHasFile, false);
+	  hasFile := hasFile or tHasFile;
+	  if disp1 > maxsize then maxsize := disp1;
+	  while lsp3 <> nil do begin
+	    lsp4 := lsp3^.subvar;
+	    lsp3^.subvar := lsp2;
+	    lsp3^.size := disp1;
+	    lsp3 := lsp4;
+	    end;
+	  Match(rparent,4);
+	  if not (sy in fsys + [semicolon]) then begin
+	    Error(6);
+	    Skip(fsys + [semicolon]);
+	    end;
+	  end;
+	test := sy <> semicolon;
+	if not test then begin
+	  disp1 := minsize;
+	  InSymbol;
+	  end;
+      until test;
+      if numcase <> 0 then Error(98);
+      disp1 := maxsize;
+      lsp^.fstvar := lsp1;
+      frecVar^.hasSFile := hasFile;
+      end
+    else
+      frecvar := nil;
+    end; {FieldList}
+
+
+    procedure ProcList (fsys: setofsys);
+
+    { compile a field list					}
+    {								}
+    { parameters:						}
+    {    fsys - following symbols				}
+
+    var
+      foundBody: boolean;		{dummy var for ProcDeclaration}
+      lsy: symbol; 			{for recording type of subroutine}
+
+    begin {ProcList}
+    {make sure the initial symbol is valid}
+    if not (sy in fsys+[procsy,funcsy]) then begin
+      Error(19);
+      Skip(fsys + [procsy,funcsy]);
+      end; {if}
+
+    {process all procedures and functions}
+    while sy in [procsy,funcsy] do begin
+      nextLocalLabel := 1;
+      lsy := sy;
+      InSymbol;
+      nextLocalLabel := 1;
+      ProcDeclaration(lsy, fsys+[procsy,funcsy], true, true, foundbody);
+      if objectcp^.pfdirective = droverride then
+        objectcp^.pfdirective := drforw
+      else begin
+        objectcp^.pfaddr := disp1;
+        disp1 := disp1 + ptrsize;
+        end; {else}
+      while sy = semicolon do begin
+	InSymbol;
+	if not (sy in fsys + [procsy,funcsy,semicolon]) then begin
+	  Error(19);
+	  Skip(fsys + [procsy,funcsy]);
+	  end; {if}
+	end; {while}
+      end; {while}
+    end; {ProcList}
+
+
+  begin {Typ}
+  if not (sy in typebegsys) then begin
+    Error(10);
+    Skip(fsys+typebegsys);
+    end;
+  if sy in typebegsys then begin
+    if sy in simptypebegsys then
+      SimpleType(fsys,fsp,fsize)
+{^} else if sy = arrow then begin
+      lsp := pointer(Malloc(sizeof(structure)));
+      fsp := lsp;
+      with lsp^ do begin
+	eltype := nil;
+	size := ptrsize;
+	form := pointerStruct;
+	hasSFile := false;
+	end; {with}
+      InSymbol;
+      if sy = ident then begin
+	SearchSection(display[top].fname,lcp);
+	if lcp <> nil then
+          if lcp^.klass <> types then
+            lcp := nil;
+	if lcp = nil then begin
+          {forward reference type id}
+          lcp := pointer(Malloc(sizeof(identifier)));
+	  with lcp^ do begin
+	    len := ord(id[0])+2;
+            name := pointer(Malloc(len));
+	    CopyString(name^,id,len);
+	    idtype := lsp;
+	    next := fwptr;
+	    klass := types;
+	    hasIFile := lsp^.hasSFile;
+	    end; {with}
+	  fwptr := lcp;
+	  end {if}
+	else
+	  with lcp^,lsp^ do begin
+	    if {lcp^.}idtype <> nil then begin
+	      {lsp^.}eltype := {lcp^.}idtype;
+	      {lsp^.}hasSFile := {lcp^.}hasIFile;
+	      end; {if}
+	    if {lcp^.}name = thisType then
+              Error(10);
+	    end; {with}
+	InSymbol;
+	end {if}
+      else Error(2);
+      end {else if}
+    else begin
+      if sy = packedsy then begin
+	InSymbol;
+	ispacked := pkpacked;
+	if not (sy in (typedels + [objectsy])) then begin
+	  Error(10);
+	  Skip(fsys + (typedels + [objectsy]));
+	  end {if}
+	end {if}
+      else ispacked := pkunpacked;
+{array}
+      if sy = arraysy then begin
+	InSymbol;
+	Match(lbrack,11);
+	lsp1 := nil;
+	repeat
+          lsp := pointer(Malloc(sizeof(structure)));
+	  with lsp^ do begin
+	    aeltype := lsp1;
+	    inxtype := nil;
+	    form := arrays;
+	    hasSFile := lsp1^.hasSFile;
+	    end;
+	  lsp^.ispacked := ispacked;
+	  lsp1 := lsp;
+	  SimpleType(fsys + [comma,rbrack,ofsy],lsp2,lsize);
+	  lsp1^.size := lsize;
+	  if lsp2 <> nil then
+	    if lsp2^.form <= subrange then begin
+	      if IsReal(lsp2) then begin
+		Error(38);
+		lsp2 := nil;
+		end
+	      else if lsp2 = longptr then begin
+		Error(74);
+		lsp2 := nil;
+		end; {else if}
+	      lsp^.inxtype := lsp2
+	      end {if}
+	    else begin
+	      Error(41);
+	      lsp2 := nil;
+	      end; {else}
+	  test := sy <> comma;
+	  if test then Match(rbrack,12) else InSymbol;
+	until test;
+	Match(ofsy,8);
+	Typ(fsys, lsp, lsize, false);
+	if lsp1^.ispacked = pkpacked then
+	  if CompTypes(lsp,charptr) or CompTypes(lsp,boolptr) then
+	    lsize := packedcharsize;
+	repeat
+	  with lsp1^ do begin
+	    lsp2 := aeltype;
+	    aeltype := lsp;
+	    hasSFile := lsp^.hasSFile;
+	    if inxtype <> nil then begin
+	      GetBounds(inxtype,lmin,lmax);
+              lsize := (lmax-lmin+1)*lsize;
+	      size := lsize;
+	      end; {if}
+	    end; {with}
+	  lsp := lsp1; lsp1 := lsp2;
+	until lsp1 = nil;
+        if lsize > $010000 then
+          if SmallMemoryModel then
+            Error(122);
+	end
+{stringsy}
+      else if sy = stringsy then begin
+	InSymbol;
+	lmin := 80; {default string length is 80}
+	if sy = lbrack then begin
+	  InSymbol;
+	  DoConstant(fsys+[rbrack],lsp1,lvalu);
+	  if lsp1 = intptr then
+	    lmin := lvalu.ival
+	  else
+	    Error(15);
+	  Match(rbrack,12);
+	  end;
+        lsp1 := pointer(Malloc(sizeof(structure)));
+	with lsp1^ do begin
+	  size := 2;
+	  form := subrange;
+	  hasSFile := false;
+	  rangetype := intptr;
+	  min := 0;
+	  if lmin > 255 then
+	    min := 1;
+	  max := lmin;
+	  end;
+        lsp := pointer(Malloc(sizeof(structure)));
+	with lsp^ do begin
+	  aeltype := charptr;
+	  inxtype := lsp1;
+	  form := arrays;
+	  hasSFile := false;
+	  size := (lmin-lsp1^.min+1)*packedcharsize;
+	  ispacked := pkpacked;
+	  end;
+	end
+{record}
+      else if sy = recordsy then begin
+	InSymbol;
+	oldtop := top;
+	if top < displimit then begin
+	  top := top+1;
+	  with display[top] do begin
+	    fname := nil;
+	    flabel := nil;
+	    labsused := nil;
+	    occur := rec;
+	    end
+	  end
+	else
+          Error(107);
+	disp1 := 0;
+        lsp := pointer(Malloc(sizeof(structure)));
+	FieldList(fsys-[semicolon]+[endsy], lsp1, lsp^.hasSFile, false);
+        if disp1 > $010000 then
+          if SmallMemoryModel then
+            Error(122);
+	with lsp^ do begin
+	  fstfld := display[top].fname;
+	  recvar := lsp1;
+	  size := disp1;
+	  form := records;
+	  end; {with}
+	lsp^.ispacked := ispacked;
+	ExportUses;
+	top := oldtop;
+	Match(endsy,13);
+	end
+{object}
+      else if sy = objectsy then begin
+	InSymbol;
+
+        {make sure we are declaring a type}
+        if not isType then
+          Error(127);
+
+        {set up a new display}
+	oldtop := top;
+	if top < displimit then begin
+	  top := top+1;
+	  with display[top] do begin
+	    fname := nil;
+	    flabel := nil;
+	    labsused := nil;
+	    occur := rec;
+	    end
+	  end
+	else
+          Error(107);
+	disp1 := 6;
+
+        {set up the type}
+        lsp := pointer(Malloc(sizeof(structure)));
+	with lsp^ do begin
+	  form := objects;
+          objname := nil;
+          objsize := 6;
+          objlevel := 1;
+          objparent := nil;
+	  size := ptrsize;
+	  end; {with}
+
+        {handle inheritance}
+        if sy = lparent then begin
+          InSymbol;
+          if sy = ident then begin
+            SearchId([types], lcp2);
+            if lcp2 <> nil then begin
+              if lcp2^.idtype <> nil then
+                if lcp2^.idtype^.form = objects then begin
+                  Duplicate(display[top].fname, lcp2^.idtype^.objfld);
+                  disp1 := lcp2^.idtype^.objsize;
+                  lsp^.objparent := lcp2^.idtype;
+                  lsp^.objlevel := lcp2^.idtype^.objlevel + 1;
+                  end {if}
+                else
+                  Error(129);
+              end {if}
+            else
+              Error(33);
+            InSymbol;
+            end {if}
+          else
+            Error(128);
+          Match(rparent,4);
+          end; {if}
+
+        {compile the fields and methods}
+        if sy in typebegsys then
+	  FieldList(fsys-[semicolon]+[endsy,procsy,funcsy], lsp1,
+            lsp^.hasSFile, true);
+        objectType := lsp;
+        ttop := top;
+        top := oldtop;
+        EnterId(objectcp);
+        top := ttop;
+        objectcp^.idtype := lsp;
+        ProcList(fsys-[semicolon]+[endsy]);
+        if disp1 > $010000 then
+          if SmallMemoryModel then
+            Error(122);
+	lsp^.objfld := display[top].fname;
+        lsp^.objsize := disp1;
+
+	lsp^.ispacked := ispacked;
+	ExportUses;
+	top := oldtop;
+	Match(endsy,13);
+	end {else if}
+{set} else if sy = setsy then begin
+	InSymbol;
+	Match(ofsy,8);
+	SimpleType(fsys,lsp1,lsize);
+	if lsp1 <> nil then
+	  if lsp1^.form > subrange then begin
+	    Error(43);
+	    lsp1 := nil;
+	    end
+	  else if IsReal(lsp1) then begin
+	    Error(42);
+	    lsp1 := nil;
+	    end
+	  else if (lsp1 = intptr) or (lsp1 = longptr) then begin
+	    Error(90);
+	    lsp1 := nil;
+	    end
+	  else begin
+	    GetBounds(lsp1,lmin,lmax);
+	    if (lmin < setlow) or (lmax > sethigh) then
+              Error(90);
+	    lmax := lmax div 8 + 1;
+            if lmax = 1 then
+               lmax := 2
+            else if lmax = 3 then
+               lmax := 4;
+	    end;
+        lsp := pointer(Malloc(sizeof(structure)));
+	with lsp^ do begin
+	  elset := lsp1;
+	  size := lmax;
+	  form := power;
+	  hasSFile := false;
+	  end;
+	lsp^.ispacked := ispacked;
+	end
+{file} else if sy = filesy then begin
+	InSymbol;
+	Match(ofsy,8);
+	Typ(fsys, lsp1, lsize, false);
+	if lsp1^.hasSFile then Error(117);
+	fsize := lsize;
+	if (lsp1 = charptr) or (lsp1 = boolptr) then
+	  fsize := packedcharsize;
+        lsp := pointer(Malloc(sizeof(structure)));
+	with lsp^ do begin
+	  size := ptrsize;
+	  form := files;
+	  hasSFile := true;
+	  filtype := lsp1;
+	  filsize := lsize;
+	  end;
+	lsp^.ispacked := ispacked;
+	end;
+      fsp := lsp
+      end;
+    if not (sy in fsys) then begin
+      Error(6);
+      Skip(fsys)
+      end; {if}
+    end
+  else
+    fsp := nil;
+  if fsp = nil then
+    fsize := 1
+  else
+    fsize := fsp^.size;
+  end {Typ} ;
+
+  procedure labeldeclaration(fsys: setofsys);
+  {Declare a user-defined label}
+
+  var
+    llp: lbp;
+    redef: boolean;
+    i: integer;
+    test: boolean;
+
+  begin {labeldeclaration}
+  repeat
+    if sy = intconst then
+      with display[top] do begin
+	llp := flabel; redef := false;
+	while (llp <> nil) and not redef do
+	  if llp^.labval <> val.ival then llp := llp^.nextlab
+	  else begin redef := true; Error(88); end;
+	if not redef then begin
+          llp := pointer(Malloc(sizeof(labl)));
+	  with llp^ do begin
+	    labval := val.ival; labname := GenLabel;
+	    if top = 1 then firstlab := labname+1;
+	    defined := false; nextlab := flabel;
+	    lstlevel := 0;
+	    end;
+	  if (val.ival < 0) or (val.ival > 9999) then Error(105);
+	  flabel := llp
+	  end;
+	InSymbol;
+	end
+    else Error(15);
+    if not ( sy in fsys + [comma, semicolon] ) then begin
+      Error(6);
+      Skip(fsys+[comma,semicolon])
+      end;
+    test := sy <> comma;
+    if not test then InSymbol
+  until test;
+  Match(semicolon,14);
+  end; {labeldeclaration}
+
+  procedure ConstDeclaration(fsys: setofsys);
+  {compile a constant}
+
+  var
+    lcp: ctp;
+    lsp: stp;
+    lvalu: valu;
+    len: integer;			{string length}
+
+  begin {ConstDeclaration}
+  if sy <> ident then begin
+    Error(2);
+    Skip(fsys + [ident]);
+    end;
+  while sy = ident do begin
+    lcp := pointer(Malloc(sizeof(identifier)));
+    with lcp^ do begin
+      len := ord(id[0])+2;
+      name := pointer(Malloc(len));
+      CopyString(name^,id,len);
+      idtype := nil;
+      next := nil;
+      klass:=konst;
+      hasIFile := false;
+      end;
+    InSymbol;
+    if (sy = relop) and (op = eqop) then
+      InSymbol
+    else
+      Error(16);
+    DoConstant(fsys + [semicolon],lsp,lvalu);
+    EnterId(lcp);
+    with lcp^ do begin
+      CheckUses({lcp^.}name^,constsy);
+      {lcp^.}idtype := lsp;
+      {lcp^.}values := lvalu;
+      end;
+    Match(semicolon,14);
+    if not (sy in fsys+[ident,implementationsy]) then begin
+      Error(6);
+      Skip(fsys + [ident,implementationsy]);
+      end;
+    end;
+  end; {ConstDeclaration}
+
+  procedure FwPtrCheck;
+  {Check all forward declared pointers to be sure they are resolved}
+
+  var
+    lcp: ctp;
+
+  begin {FwPtrCheck}
+  while fwptr <> nil do begin
+    id := fwptr^.name^;
+    prterr := false;
+    SearchId([types],lcp);
+    prterr := true;
+    if lcp = nil then begin
+      write('**** The pointer ',id,' cannot be resolved');
+      FlagError;
+      end
+    else if lcp^.idtype <> nil then
+      with fwptr^.idtype^, lcp^ do begin
+	eltype := idtype;
+	hasSFile := hasIFile;
+	end;
+    fwptr := fwptr^.next;
+    end;
+  end; {FwPtrCheck}
+
+  procedure TypeDeclaration (fsys: setofsys);
+
+  { compile a type declaration					}
+  {								}
+  { parameters:							}
+  {   fsys -							}
+
+  var
+    lcp: ctp;
+    lsp: stp;
+    lsize: addrrange;
+    len: integer;			{string length}
+
+  begin {TypeDeclaration}
+  if sy <> ident then begin		{check for a bogus start}
+    Error(2);
+    Skip(fsys + [ident]);
+    end; {if}
+  while sy = ident do begin		{scan all declarations}
+					{process the identifier}
+    lcp := pointer(Malloc(sizeof(identifier)));
+    with lcp^ do begin
+      len := ord(id[0])+2;
+      name := pointer(Malloc(len));
+      CopyString(name^,id,len);
+      thisType := name;
+      klass := types;
+      end; {with}
+    InSymbol;
+					{check for '='}
+    if (sy = relop) and (op = eqop) then
+      InSymbol
+    else
+      Error(16);
+    objectName := lcp^.name^;
+    objectCp := lcp;
+    Typ(fsys+[semicolon], lsp, lsize, true); {get the type}
+    if lsp^.form = objects then
+      lsp^.objname := lcp^.name;
+    thisType := nil;
+    if lsp^.form <> objects then	{enter in symbol table}
+      EnterId(lcp);
+    with lcp^ do begin
+      {lcp^.}idtype := lsp;
+      {lcp^.}hasIFile := lsp^.hasSFile;
+      CheckUses({lcp^.}name^,typesy);
+      end; {with}
+    Match(semicolon,14);		{get ready for another one}
+    if not (sy in fsys + [ident,implementationsy]) then begin
+      Error(6);
+      Skip(fsys + [ident,implementationsy]);
+      end; {if}
+    end; {while}
+  FwPtrCheck;				{make sure forward declarations were resolved}
+  end; {TypeDeclaration}
+
+  procedure VarDeclaration(fsys: setofsys);
+  {declare variables}
+
+  var
+    isExtern: boolean;			{is this an external variable declaration?}
+    lcp,nxt: ctp;
+    lsp: stp;
+    lsize: addrrange;
+    test: boolean;
+    len: integer;			{string length}
+
+  begin {VarDeclaration}
+  nxt := nil;
+  repeat {loops over type part}
+    repeat {loops over all variable names}
+      if sy = ident then begin
+	{declare a new variable}
+        lcp := pointer(Malloc(sizeof(identifier)));
+	with lcp^ do begin
+          len := ord(id[0])+2;
+          name := pointer(Malloc(len));
+	  CopyString(name^,id,len);
+	  next := nxt;
+	  klass := varsm;
+	  vcontvar := false;
+	  vrestrict := false;
+	  idtype := nil;
+	  vkind := actual;
+	  vlev := level;
+	  fromUses := inUses;
+	  vPrivate := doingUnit and (not doingInterface);
+	  end;
+	EnterId(lcp);
+	nxt := lcp;
+	InSymbol;
+	end
+      else Error(2);
+      if not (sy in fsys + [comma,colon] + typedels) then begin
+	Error(6); Skip(fsys+[comma,colon,semicolon]+typedels)
+	end;
+      test := sy <> comma;
+      if not test then InSymbol;
+    until test;
+    Match(colon,5);
+
+    {see if the variable is extern}
+    isExtern := false;
+    if not iso then
+      if sy = ident then
+        if (id = 'EXTERN') or (id = 'EXTERNAL') then begin
+          InSymbol;
+          isExtern := true;
+          end; {if}
+    {get the type for the variable list}
+    Typ(fsys + [semicolon] + typedels, lsp, lsize, false);
+    FwPtrCheck;
+    {loop over the variable list, filling in type based info}
+    while nxt <> nil do
+      with nxt^ do begin
+	CheckUses(name^,varsy);
+	idtype := lsp;
+	fromUses := fromUses or isExtern;
+	hasIFile := lsp^.hasSFile;
+	if level <> 1 then
+	  vlabel := GetLocalLabel;
+	nxt := next;
+	end;
+    Match(semicolon,14);
+    if not (sy in fsys + [ident,implementationsy]) then begin
+      Error(6);
+      Skip(fsys + [ident,implementationsy]);
+      end;
+  until (sy <> ident) and not (sy in typedels);
+  end; {VarDeclaration}
+ 
+
+  procedure DoBlock (fsys: setofsys; fsy: symbol; fprocp: ctp;
+     isProgram: boolean); forward;
+  {compile a block}
+
+
+  procedure ProcDeclaration {fsy: symbol; fsys: setofsys;
+    isObject, compilebody: boolean; var foundbody: boolean};
+
+  { Procedure/function declaration				}
+  {								}
+  { parameters:							}
+  {   fsy - procedure or function symbol			}
+  {   fsys - follow symbols					}
+  {   isObject - is this declaration in an object?		}
+  {   compilebody - Compile the body? (used for partial compile)}
+  {   foundbody - Was the body found (used for partial compile)	}
+
+  var
+    forw: boolean;
+    i: integer;
+    lcp,lcp1,lcp2: ctp;
+    len: integer;			{string length}
+    lisMethod: boolean;			{copy of isMethod}
+    lpsize: integer;			{for saving psize (nested declarations)}
+    lsp, lsp1: stp;
+    lvalu: valu;			{constant from a directive}
+    needSemicolon: boolean;		{for parsing interface files}
+    oldlev: 0..maxlevel;
+    oldtop: disprange;
+    override: boolean;			{true if override is the only legal possibility}
+
+
+    procedure ParameterList (ssy: setofsys; var fpar: ctp;
+      forw,dummy: boolean);
+
+    { Compile the parameter list				}
+    {								}
+    { parameters:						}
+    {    ssy -							}
+    {    fpar - list of parameter symbols			}
+    {    forw -							}
+    {    dummy -						}
+
+    var
+      list,lcp,lcp1: ctp;
+      lsp: stp; lkind: idkind;
+      lsize: unsigned;
+      item: integer;
+      test: boolean;
+      len: integer;			{string length}
+      universal: boolean;		{is the parm universal?}
+
+
+      procedure FunProcParm (forp: idclass; var lcp: ctp; fsys: setofsys);
+
+      { Compile a procedure or function parameter		}
+      {								}
+      { parameters:						}
+      {    forp - function or procedure symbol			}
+      {    lcp -						}
+      {    fsys -						}
+
+      var
+	lpsize: integer;		{for saving psize}
+	len: integer;			{string length}
+
+      begin {FunProcParm}
+      InSymbol;
+      if sy = ident then begin
+
+        {create a symbol table entry}
+        lcp := pointer(Malloc(sizeof(identifier)));
+	with lcp^ do begin
+          len := ord(id[0])+2;
+          name := pointer(Malloc(len));
+	  CopyString(name^,id,len);
+	  hasIFile := false;
+	  idtype := nil;
+	  pflev := level;
+	  klass := forp;
+	  pfdeckind := declared;
+	  psize := psize+procsize;
+	  pflabel := GetLocalLabel;
+          pfparms := nil;
+	  pfkind := formal;
+	  pfnext := nil;
+	  next := nil;
+	  end; {with}
+	if not dummy then
+          EnterId(lcp);
+	InSymbol;
+
+	item := item+1;
+	if list <> nil then
+          list^.next := lcp;
+	list := lcp;
+	if fpar = nil then
+          fpar := list;
+	lpsize := psize;
+	with lcp^ do
+	  if forp = proc then begin
+	    if not (sy in [semicolon,rparent]) then
+	      ParameterList([semicolon,rparent], pfnext, false, true);
+	    end
+	  else if sy <> colon then
+	    ParameterList([colon], pfnext, false, true);
+	psize := lpsize;
+	end {if}
+      else
+	Error(2);
+      end; {FunProcParm}
+
+
+    begin {ParameterList}
+    list := nil;
+    fpar := nil;
+    item := 1;
+    if isObject or (sy = lparent) then
+      psize := 0; {define parameters as offsets from 0}
+
+    {declare the 'self' parameter for methods}
+    if isObject then begin
+      lcp := pointer(Malloc(sizeof(identifier)));
+      with lcp^ do begin
+	name := @'SELF';
+	idtype := objectType;
+	next := nil;
+	hasIFile := false;
+	klass := varsm;
+	vkind := actual;
+	vlev := level;
+	vitem := item;
+	vlabel := GetLocalLabel;
+	vcontvar := false;
+	fromUses := false;
+	vrestrict := false;
+	vUniv := false;
+	vPrivate := true;
+	end; {with}
+      EnterId(lcp);
+      list := lcp;
+      fpar := list;
+      psize := {psize +} ptrsize;
+      item := 2 {item+1};
+      end; {if}
+
+    {handle standard parameters}
+    if not (sy in ssy+[lparent]) then begin
+      Error(7);
+      Skip(fsys+ssy+[lparent])
+      end; {if}
+    if sy = lparent then begin
+      if forw or override then
+        Error(45);
+      InSymbol;
+      if not (sy in [ident,varsy,funcsy,procsy]) then begin
+	Error(7);
+	Skip(fsys+[ident,rparent]);
+	end; {if}
+      while sy in [ident,varsy,funcsy,procsy] do begin
+	if sy = procsy then begin
+	  FunProcParm(proc, lcp, fsys+[comma,semicolon,rparent]);
+	  lcp^.idtype := nilptr;
+	  end {if}
+	else if sy = funcsy then begin
+	  FunProcParm(func, lcp, fsys+[comma,semicolon,rparent,colon]);
+	  Match(colon,5);
+	  if sy = ident then begin
+	    SearchId([types],lcp1);
+	    lsp := lcp1^.idtype;
+	    if lsp <> nil then
+	      if not (lsp^.form in [scalar,subrange,pointerStruct,objects])
+                then begin
+		Error(46);
+		lsp := nil;
+		end; {if}
+	    lcp^.idtype := lsp;
+	    InSymbol;
+	    end
+	  else Error(2);
+	  end {else if}
+
+        {'normal' parameter}
+	else begin			
+
+          {handle var declarations}
+	  if sy = varsy then begin
+	    lkind := formal;
+	    InSymbol;
+	    end
+	  else
+	    lkind := actual;
+
+	  {process the list of names}
+	  lcp1 := nil;
+	  repeat
+	    if sy = ident then begin
+              lcp := pointer(Malloc(sizeof(identifier)));
+	      with lcp^ do begin
+                len := ord(id[0])+2;
+                name := pointer(Malloc(len));
+		CopyString(name^,id,len);
+		idtype := nil;
+		klass := varsm;
+		vkind := lkind;
+		next := nil;
+		vlev := level;
+		vcontvar := false;
+		vrestrict := false;
+		vitem := item;
+		fromUses := inUses;
+		end; {with}
+	      if not dummy then
+                EnterId(lcp);
+	      if list <> nil then
+                list^.next := lcp;
+	      list := lcp;
+	      if fpar = nil then
+                fpar := list;
+	      if lcp1 = nil then
+                lcp1 := list;
+	      InSymbol;
+	      end {if}
+	    else
+              Error(2);
+	    if not (sy in [comma,colon]+fsys) then begin
+	      Error(7);
+	      Skip(fsys+[comma,semicolon,rparent]);
+	      end;
+	    test := sy <> comma;
+	    if not test then InSymbol;
+	  until test;
+	  Match(colon,5);
+
+	  {see if the symbol is universal}
+	  if sy = univsy then begin
+	    if iso then
+              Error(112);
+	    universal := true;
+	    InSymbol;
+	    end {if}
+	  else
+	    universal := false;
+
+	  {process the parameter type}
+	  if sy = ident then begin
+
+	    {find and check the type}
+	    SearchId([types],lcp);
+	    lsp := lcp^.idtype;
+	    if lsp <> nil then
+	      if lkind = actual then
+		if lsp^.form = files then
+                  Error(47);
+
+	    {record the type size}
+	    lsize := ParmSize(lsp,lkind);
+
+	    {scan the variables, adding type info}
+	    while lcp1 <> nil do begin
+	      with lcp1^ do begin
+		idtype := lsp;
+                psize := psize+lsize;
+		vlabel := GetLocalLabel;
+		vuniv := universal;
+		hasIFile := false;
+		end; {with}
+
+	      {allocate local space for value parms passed as pointers}
+	      if lsp <> nil then
+		if (lkind = actual) and (lsp^.form > power) then
+		  if (lsp^.form <> records) or (lsp^.size > 4) then
+		    lcp1^.vlabel := GetLocalLabel;
+	      lcp1 := lcp1^.next;
+	      end; {while}
+	    InSymbol;
+	    end {if}
+	  else
+            Error(2);
+	  item := item+1;
+	  end; {else}
+
+	if not (sy in fsys+[semicolon,rparent]) then begin
+	  Error(7);
+	  Skip(fsys+[ident,rparent]);
+	  end; {if}
+	if sy = semicolon then begin
+	  InSymbol;
+	  if not (sy in fsys+[ident,varsy,procsy,funcsy]) then begin
+	    Error(7);
+	    Skip(fsys+[ident,rparent]);
+	    end; {if}
+	  end; {if}
+	end; {while}
+      Match(rparent,4);
+      if not (sy in ssy+fsys) then begin
+	Error(6);
+	Skip(ssy+fsys);
+	end; {if}
+      end; {if}
+    display[top].labsused := nil;
+    end; {ParameterList}                
+
+
+  begin {ProcDeclaration}
+  lpsize := psize;
+  psize := 0;
+  forw := false;
+
+  {see if this is the object name for a method}
+  override := false;
+  isMethod := false;
+  if sy = ident then begin
+    prterr := false;
+    SearchID([types], lcp);
+    prterr := true;
+    if lcp <> nil then
+      if lcp^.idtype <> nil then
+	if lcp^.idtype^.form = objects then begin
+          isMethod := true;
+          lisMethod := true;
+          objectName := id;
+          InSymbol;
+	  Match(period, 21);
+          end; {if}
+    end; {if}
+
+  if sy = ident then begin
+    {check for forward declarations}
+    if isMethod then begin
+      if level <> 1 then
+        Error(126);
+      if lcp^.idtype = nil then
+        lcp := nil
+      else
+        SearchSection(lcp^.idtype^.objfld, lcp);
+      if lcp = nil then
+        Error(124)
+      else
+        if lcp^.pfdirective = drnone then
+          Error(30);
+      end {if}
+    else
+      SearchSection(display[top].fname, lcp);
+    if lcp <> nil then
+      with lcp^ do begin
+        if isObject then
+          override := true
+	else if klass = proc then
+	  forw := ((pfdirective=drforw) or isMethod)
+            and (fsy=procsy) and (pfkind=actual)
+	else if klass = func then
+	  forw:= ((pfdirective=drforw) or isMethod)
+            and (fsy=funcsy) and (pfkind=actual)
+	else
+          forw := false;
+	if not (forw or override) then
+          Error(84);
+	end; {with}
+
+    {if not forward, create a new identifier}
+    if override then begin
+
+      {override an ancestor method}
+      lcp^.pfoname := pointer(Malloc(length(objectName)+length(lcp^.name^)+2));
+      lcp^.pfoname^ := concat(objectName, '~', lcp^.name^);
+      objectcp := lcp;
+
+      {change the 'SELF' parameter type}
+      lcp2 := pointer(Malloc(sizeof(identifier)));
+      lcp2^ := lcp^.pfparms^;
+      lcp^.pfparms := lcp2;
+      lcp2^.idtype := objectType;
+      end {if}
+    else if not forw then begin
+      lcp := pointer(Malloc(sizeof(identifier)));
+      with lcp^ do begin
+        len := ord(id[0])+2;
+        name := pointer(Malloc(len));
+	CopyString(name^,id,len);
+	idtype := nilptr;
+	pflev := level;
+	pfname := GenLabel;
+        if isObject then begin
+          pfoname := pointer(Malloc(length(objectName)+length(name^)+2));
+          pfoname^ := concat(objectName, '~', name^);
+          end {if}
+        else
+          pfoname := name;
+	pfparms := nil;
+	pfdeckind := declared;
+	pfkind := actual;
+	pfPrivate := doingUnit and (not doingInterface);
+	if fsy = procsy then
+          klass := proc
+        else
+          klass := func;
+	hasIFile := false;
+	end; {if}
+      CheckUses(lcp^.name^, procsy);
+      EnterId(lcp);
+      objectcp := lcp;
+      end {if}
+    else begin
+      {forward - reset location counter}
+      psize := lcp^.pfactualsize;
+
+      {reset label counter}
+      lcp1 := lcp^.pfparms;
+      while lcp1 <> nil do begin
+        if lcp1^.klass = varsm then begin
+          if lcp1^.vlabel >= nextLocalLabel then
+            nextLocalLabel := lcp1^.vlabel + 1;
+          end {if}
+        else if lcp1^.klass in [proc,func] then
+          if lcp1^.pflabel >= nextLocalLabel then
+            nextLocalLabel := lcp1^.pflabel + 1;
+        lcp1 := lcp1^.next;
+        end; {while}
+      end; {else}
+    InSymbol;
+
+    {check for unexpected method}
+    if sy = period then begin
+      Error(125);
+      InSymbol;
+      if sy = ident then
+        InSymbol;
+      end; {if}
+    end {if}
+  else begin
+
+    {missing function identifier}
+    Error(2);
+    lcp := ufctptr;
+    end; {else}
+
+  {create a new stack frame level}
+  oldlev := level;
+  oldtop := top;
+  if level < maxlevel then
+    level := level + 1
+  else
+    Error(108);
+  if top < displimit then begin
+    top := top+1;
+    with display[top] do begin
+      if forw then
+        fname := lcp^.pfparms
+      else
+        fname := nil;
+      flabel := nil;
+      labsused := nil;
+      occur := blck;
+      ispacked := false;
+      end; {with}
+    end {if}
+  else
+    Error(107);
+
+  {assign function labels}
+  with lcp^ do
+    if klass = func then
+      pflabel := GetLocalLabel
+    else
+      pflabel := 0;
+
+  {compile the parameters}
+  if fsy = procsy then begin
+    ParameterList([semicolon], lcp1, forw, false);
+    if not (forw or override) then
+      with lcp^ do begin
+	pfparms := lcp1;
+	pfactualsize := psize;
+	end; {with}
+    end {if}
+  else begin
+    ParameterList([semicolon,colon], lcp1, forw, false);
+    if not (forw or override) then
+      with lcp^ do begin
+	pfparms := lcp1;
+	pfactualsize := psize;
+	end; {with}
+    if sy = colon then begin
+      InSymbol;
+      if sy = ident then begin
+	if forw or override then
+          Error(48);
+	SearchId([types], lcp1);
+	lsp := lcp1^.idtype;
+	lcp^.idtype := lsp;
+	if lsp <> nil then
+	  if not (lsp^.form in [scalar,subrange,pointerStruct,objects]) then
+            begin
+	    Error(46);
+            lcp^.idtype := nil;
+	    end; {if}
+	InSymbol;
+	end {if}
+      else begin
+        Error(2);
+        Skip(fsys + [semicolon])
+        end; {else}
+      end {if}
+    else if not (forw or override) then
+      Error(49)
+    end; {else}
+  Match(semicolon,14);
+
+  {handle directives}
+  if (sy = ident) or doingInterface or inUses or isObject then begin
+    foundBody := false;
+    if sy <> ident then begin		{special assumptions for uses,	}
+      if inUses and (not isObject) then	{ interface files, methods	}
+	lcp2 := externIdentifier
+      else
+	lcp2 := forwardIdentifier;
+      if override then
+        Error(30);
+      needSemicolon := false;
+      end {if}
+    else begin				{normal identifier section}
+      SearchId([directive],lcp2);	{find the identifier type}
+      InSymbol;
+      needSemicolon := true;
+      end; {else}
+    lcp^.pfdirective := lcp2^.drkind;
+    if override then begin
+      if lcp2^.drkind <> droverride then
+        Error(30);
+      end {if}
+    else if lcp2^.drkind = droverride then
+      Error(124);
+    with lcp^ do
+      case pfdirective of
+	drforw,droverride:
+	  if forw then
+	    Error(85);
+	drextern:
+	  if level <> 2 then
+	    Error(101);
+	drprodos: begin
+	  if sy = lparent then
+            InSymbol;
+	  if (sy = intconst) then begin
+	    pfcallnum := val.ival;
+	    InSymbol;
+	    end {if}
+	  else
+            Error(15);
+	  if sy = rparent then
+            InSymbol;
+	  end;
+	drtool1,drtool2: begin
+	  if sy = lparent then
+            InSymbol;
+	  DoConstant(fsys+[comma], lsp1, lvalu);
+          if lsp1 = intptr then
+	    pftoolnum := lvalu.ival
+	  else
+            Error(15);
+	  Match(comma,20);
+	  DoConstant(fsys+[rparent], lsp1, lvalu);
+          if lsp1 = intptr then
+	    pfcallnum := lvalu.ival
+	  else
+            Error(15);
+	  if sy = rparent then
+	    InSymbol;
+	  end;
+	drvector: begin
+	  if sy = lparent then
+            InSymbol;
+	  DoConstant(fsys+[comma], lsp1, lvalu);
+          if lsp1 = longptr then
+            pfaddr := lvalu.valp^.lval
+          else if lsp1 = intptr then
+	    pftoolnum := lvalu.ival
+	  else
+            Error(15);
+	  Match(comma,20);
+	  DoConstant(fsys+[rparent], lsp1, lvalu);
+          if lsp1 = intptr then
+	    pfcallnum := lvalu.ival
+	  else
+            Error(15);
+	  if sy = rparent then
+	    InSymbol;
+	  end;
+	otherwise: Error(6);
+	end; {case}
+    if needSemicolon then
+      Match(semicolon,14);
+    if not (sy in fsys) then begin
+      Error(6);
+      Skip(fsys);
+      end; {if}
+    end {if}
+  else
+    with lcp^ do begin
+
+      {if list is off, write the proc name}
+      foundBody := true;
+      if (not list) and progress and compilebody then
+	writeln(' ':level, {lcp^.}pfoname^);
+
+      {lcp^.}pfdirective := drnone;
+      {lcp^.}pfset := false;
+      if compilebody then begin
+	if level <= 2 then begin
+	  mark({lcp^.}pfmark);
+	  Gen2Name(dc_str, $4000*ord({lcp^.}pfPrivate)+$8000*ord(isDynamic), 0,
+	    {lcp^.}pfoname);
+	  inseg := true;
+	  end; {if}
+	DoBlock(fsys,semicolon,lcp,false);
+	Match(semicolon,14);
+	if not (sy in [endsy,beginsy,procsy,funcsy]) then begin
+	  Error(6);
+	  Skip([beginsy,procsy,funcsy]);
+	  end; {if}
+	if ({lcp^.}klass = func) and (not {lcp^.}pfset) then Error(96);
+	end; {if}
+      end; {with}
+  ExportUses;
+  level := oldlev;
+  top := oldtop;
+  psize := lpsize;
+  end; {ProcDeclaration}
+
+
+  procedure UsesDeclaration(fsys: setofsys);
+  {compile a uses statement}
+
+  var
+    done: boolean;			{for detecting end of loop}
+    foundBody: boolean;			{dummy var for ProcDeclaration}
+    lfsys: setofsys;			{temp fsys}
+    lsy: symbol; 			{for recording type of subroutine}
+
+  begin {UsesDeclaration}
+  if level <> 1 then Error(115); 	{must be at program level}
+  repeat
+    if sy = ident then begin
+      inUses := true;			{mark as in a uses file}
+      OpenUses;				{open the uses file}
+      InSymbol;				{get the first symbol in the uses file}
+      fsys := fsys+[implementationsy];	{allow implementation}
+					{compile the file}
+      while sy = usessy do begin 	{skip uses - assumes correct syntax,}
+	repeat				{ but will not hang if fooled	    }
+	  InSymbol;
+	until (sy = semicolon) or eofl;
+	InSymbol;
+	end;
+      if sy = constsy then begin InSymbol; ConstDeclaration(fsys); end;
+      if sy = typesy then begin InSymbol; TypeDeclaration(fsys); end;
+      if sy = varsy then begin InSymbol; VarDeclaration(fsys); end;
+      {handle procedure, function declarations}
+      while sy in [procsy,funcsy] do begin
+	lsy := sy;
+	InSymbol;
+        nextLocalLabel := 1;
+	ProcDeclaration(lsy, fsys, false, true, foundbody);
+	if foundBody then Error(81);
+	end;
+      if sy <> implementationsy then begin
+	Error(116);
+	Skip([implementationsy]);
+	end
+      else
+	InSymbol;
+      inUses := false;			{mark as out of uses file}
+      end
+    else
+      Error(2);
+    done := sy <> comma;
+    if not done then
+      InSymbol;
+  until done or eofl;
+  Match(semicolon,14);
+  end; {UsesDeclaration}
+
+
+  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.		}
+
+  var
+    isFunction: boolean; 		{are we dereferencing a function?}
+    lattr: attr;			{copy of an attribute}
+    lcp,lcp1: ctp;
+    lmin,lmax: longint;
+    lsize: addrrange;
+    lispacked: boolean;
+
+
+    procedure ArrayIndex;
+
+    { Handles subscripting an array				}
+
+    var
+      bt: baseTypeEnum;			{index base type}
+
+    begin {ArrayIndex}
+    {track array packing}
+    gispacked := gispacked or lispacked;
+    
+    {loop over subscripts, possibly separated by commas}
+    repeat
+
+      {get the type, and make sure it's an array}
+      lattr := gattr;
+      lcp1 := glcp;
+      with lattr do 
+	if typtr <> nil then
+	  if typtr^.form <> arrays then begin
+	    Error(63);
+            typtr := nil;
+	    end; {if}
+      LoadAddress;
+      InSymbol;
+
+      {get the array subscript value}
+      Expression(fsys + [comma,rbrack],fprocp);
+      Load;
+      glcp := lcp1;
+      if gattr.typtr <> nil then
+	if gattr.typtr^.form <> scalar then
+          Error(41);
+      if lattr.typtr <> nil then
+	with lattr.typtr^ do begin
+
+          {if needed, promote the index to long}
+          if CompTypes(inxtype, longptr) then
+            if CompTypes(gattr.typtr, intptr) then begin
+              Gen2(pc_cnv, ord(cgWord), ord(cgLong));
+              gattr.typtr := longptr;
+              end; {if}
+
+          {check the type of the subscript}
+	  if CompTypes(inxtype,gattr.typtr) then begin
+	    if inxtype <> nil then begin
+
+              {check the range of the subscript}
+	      GetBounds(inxtype,lmin,lmax);
+	      if debug then
+                if GetType(inxtype, false) in [cgLong,cgULong] then
+                  GenL2t(pc_chk, lmin, lmax, cgULong)
+                else
+                  Gen2t(pc_chk, ord(lmin), ord(lmax), cgWord);
+
+              {handle non-zero stating indexes for the array}
+              if lmin <> 0 then
+                if lmin > maxint then begin
+                  GenLdcLong(lmin);
+                  Gen0(pc_sbl);
+                  end {if}
+                else
+		  Gen1t(pc_dec, ord(lmin), GetType(inxtype, false));
+	      end;
+	    end
+	  else
+            Error(64);
+
+          {set up the result type, after indexing}
+          bt := GetType(gattr.typtr, false);
+	  with gattr do begin
+	    typtr := aeltype;
+            isPacked := false;
+	    kind := varbl;
+	    access := indrct;
+	    idplmt := 0;
+	    end;
+
+          {index into the array}
+	  if gattr.typtr <> nil then begin
+	    lsize := gattr.typtr^.size;
+	    if ((gattr.typtr = charptr) or (gattr.typtr = boolptr))
+	      and (ispacked = pkpacked) then begin
+	      lsize := packedcharsize;
+              gattr.isPacked := true;
+              end; {if}
+            if (size < $010000) and (inxtype^.size <= intsize) then begin
+	      Gen1t(pc_ldc, long(lsize).lsw, cgUWord);
+              Gen0(pc_umi);
+	      Gen0t(pc_ixa, cgUWord);
+              end {if}
+            else begin
+              if not (bt in [cgLong,cgULong]) then
+                Gen2(pc_cnv,ord(bt),ord(cgULong));
+	      GenLdcLong(lsize);
+              Gen0(pc_uml);
+              Gen0(pc_adl);
+              end; {else}
+      	    end; {if}
+	  end; {with}
+    until sy <> comma;
+
+    {make sure there is a matching ']'}
+    Match(rbrack,12);
+    end; {ArrayIndex}
+
+
+    procedure FieldSelection;
+
+    { Compile a field selection					}
+
+    var
+      form: structform;			{records or objects (kind of variable)}
+      disp: addrrange;			{disp in object for method}
+
+    begin {FieldSelection}
+    gispacked := gispacked or lispacked;
+    with gattr do begin
+
+      {get the variable kind}
+      if typtr <> nil then begin
+        form := typtr^.form;
+	if not (form in [records,objects]) then begin
+	  Error(65);
+          typtr := nil;
+	  end; {if}
+        end {if}
+      else
+        form := records;
+
+      {get the field id}
+      if sy = ident then begin
+	if typtr <> nil then begin
+
+          {find the field}
+          if form = records then
+	    SearchSection(typtr^.fstfld, lcp)
+          else
+	    SearchSection(typtr^.objfld, lcp);
+	  if lcp = nil then begin
+	    Error(77);
+            typtr := nil;
+	    end {if}
+	  else begin
+
+            {dereference the field}
+	    glcp := lcp;
+	    with lcp^ do begin
+	      typtr := idtype;
+	      lispacked := typtr^.ispacked = pkpacked;
+	      case access of
+		drct:	  begin
+                          if form = objects then begin
+                            typtr := longptr;
+                            Load;
+			    if debug then
+			      GenL2t(pc_chk, 1, maxaddr, cgULong);
+			    typtr := idtype;
+                            isPacked := lispacked;
+			    kind := varbl;
+			    access := indrct;
+                            if klass = field then
+			      idplmt := fldaddr
+                            else
+			      idplmt := pfaddr;
+                            end {if}
+                          else begin
+                            dpdisp := dpdisp + fldaddr;
+                            if dpdisp > maxint then
+                              {use indirect access}
+                              LoadAddress;
+                            end; {else}
+                          end;     
+		indrct:   if form = objects then begin
+                            typtr := longptr;
+                            Load;
+			    if debug then
+			      GenL2t(pc_chk, 1, maxaddr, cgULong);
+                            typtr := idtype;
+                            isPacked := lispacked;
+			    kind := varbl;                                
+			    access := indrct;
+                            if klass = field then
+			      idplmt := fldaddr
+                            else
+			      idplmt := pfaddr;
+	                    end {if}
+                          else
+			    idplmt := idplmt + fldaddr;
+		inxd:	  Error(113)
+		end; {case}
+	      end; {with}
+
+            {skip the field name}
+	    InSymbol;
+
+            {check for method calls}
+            if glcp^.klass = proc then begin
+              disp := gattr.idplmt;
+              gattr.idplmt := 0;
+              LoadAddress;
+              Gen0t(pc_stk, cgULong);
+	      CallNonStandard(fsys, glcp, fprocp, disp, cMethod);
+              isMethod := true;
+              end {if}
+            else if glcp^.klass = func then begin
+              disp := gattr.idplmt;
+              gattr.idplmt := 0;
+              LoadAddress;
+              Gen0t(pc_stk, cgULong);
+	      isFunction := true;
+	      CallNonStandard(fsys, glcp, fprocp, disp, cMethod);
+              isMethod := true;
+	      if sy <> arrow then
+		gattr.kind := expr;
+	      if sy in [period,lbrack] then
+        	Error(23);
+              end; {else if}
+	    end; {else}
+	  end {if}
+        else
+
+          {skip the field name}
+	  InSymbol;
+	end {sy = ident}
+      else
+        Error(2)
+      end; {with gattr}
+    end; {FieldSelection}
+
+
+  begin {Selector}
+  isFunction := false;
+  isMethod := false;
+  if not doingCast then begin
+
+    {access the identifier}
+    with fcp^, gattr do begin
+      typtr := idtype;
+      isPacked := false;
+      kind := varbl;
+      case klass of
+	varsm:
+	  if vkind = actual then begin
+	    {for actual variables, pass back the info}
+	    access := drct;
+	    vlevel := vlev;
+	    dpdisp := 0;
+	    if vlevel = 1 then
+	      aname := name
+	    else
+	      dplab := vlabel;
+	    end
+	  else begin
+	    {for formal variables, load their addr and indicate indirection}
+	    Gen3t(pc_lod, vlabel, 0, level-vlev, cgULong);
+	    access := indrct;
+	    idplmt := 0
+	    end;
+	field:
+	  with display[disx] do
+	    if occur = crec {field is directly accessable} then begin
+	      access := drct;
+	      vlevel := clev;
+	      if vlevel = 1 then
+                aname := cname;
+	      dpdisp := cdspl+fldaddr;
+              dplab := clab;
+	      end {if}
+	    else {field must be accessed indirectly} begin
+	      {for with only - access temp global variable from stack frame}
+	      Gen3t(pc_lod, vdsplab, 0, 0, cgULong);
+	      access := indrct;
+	      idplmt := fldaddr
+	      end;
+	func: begin
+	  isFunction := true;
+	  Call(fsys, fcp, fprocp);
+	  if sy <> arrow then
+	    gattr.kind := expr;
+	  if sy in [period,lbrack] then
+            Error(23);
+	  end;
+	otherwise:;
+	end; {case}
+      end; {with}
+    if not (sy in selectsys + fsys) then begin
+      Error(29);
+      Skip(selectsys + fsys);
+      end;
+    lispacked := false;
+    if glcp <> nil then
+      with glcp^ do
+	if {glcp^.}idtype <> nil then
+	  lispacked := {glcp^.}idtype^.ispacked = pkpacked;
+    {handle selections}
+    end; {with}
+
+  {do selections}
+  while sy in selectsys do begin
+{[} if sy = lbrack then			{indexes}
+      ArrayIndex
+{.} else if sy = period then begin	{record or object fields}
+      InSymbol;
+      FieldSelection;
+      end {else if}
+{^} else begin
+      gispacked := false;
+      if gattr.typtr <> nil then
+	with gattr,typtr^ do
+	  if form in [pointerStruct,files] then begin
+	    if not isFunction then
+	      Load;
+	    if form = pointerStruct then
+	      typtr := eltype
+	    else
+	      typtr := filtype;
+	    lispacked := typtr^.ispacked = pkpacked;
+	    if debug then
+	      GenL2t(pc_chk, 1, maxaddr, cgULong);
+	    with gattr do begin
+              isPacked := false;
+	      kind := varbl;
+	      access := indrct;
+	      idplmt := 0;
+	      end;
+	    end
+	  else
+	    Error(66);
+      InSymbol;
+      end;
+    if not (sy in fsys + selectsys) then begin
+      Error(6);
+      Skip(fsys + selectsys);
+      end; {if}
+    end {while}
+  end; {Selector}
+
+  
+  procedure InheritedCall (fsys: setofsys; fprocp: ctp);
+
+  { Compile an inherited call					}
+  {								}
+  { parameters:							}
+  {    fsys - follow symbols					}
+  {    fprocp - identifier for program or program-level		}
+  {       subroutine contining this statement			}
+  
+  var
+    lcp, lcp2, lcp3: ctp;		{work identifiers}
+    loc: unsigned;			{position of '~' in object.method name}
+    lsp: stp;				{superclass object type}
+
+  begin {InheritedCall}
+  if sy = ident then begin
+
+    {find the current method's object}
+    SearchId([proc,func], lcp);
+    if lcp <> nil then begin
+      id := lcp^.pfoname^;
+      loc := Pos('~', id);
+      if loc <> 0 then
+        id[0] := chr(loc-1);
+      SearchId([types], lcp2);
+      
+      {find the parent object}
+      if lcp2 <> nil then
+        if lcp2^.idtype <> nil then
+          if lcp2^.idtype^.objparent <> nil then begin
+            lsp := lcp2^.idtype^.objparent;
+
+            {find the method to be inherited}
+            id := lcp^.name^;
+	    SearchSection(lsp^.objfld, lcp2);
+            if lcp2 = nil then
+              Error(130)
+            else begin
+	      {set up the 'SELF' parameter}
+	      id := 'SELF';
+	      SearchId([varsm,field], lcp3);
+	      if lcp3 <> nil then
+		if (lcp3^.idtype <> nil) and (lcp3^.klass = varsm) then begin
+		  gattr.typtr := lcp3^.idtype;
+        	  gattr.isPacked := false;
+        	  gattr.kind := varbl;
+        	  gattr.access := drct;
+        	  gattr.vlevel := lcp3^.vlev;
+        	  gattr.dplab := lcp3^.vlabel;
+        	  gattr.dpdisp := 0;
+        	  gattr.aname := lcp3^.name;
+                  Load;
+                  Gen0t(pc_stk, cgULong);
+        	  end; {if}
+
+              {call the inherited method}
+	      InSymbol;
+	      CallNonStandard(fsys, lcp2, fprocp, 0, cInherited);
+              end; {else}
+            end; {if}
+      end; {if}
+    end {if}
+  else begin
+    Error(2);
+    Skip(fsys);
+    end; {else}
+  end; {InheritedCall}
+
+
+  procedure Expression {fsys: setofsys; fprocp: ctp};
+
+  { compile an expression					}
+  {								}
+  { parameters:							}
+  {    fsys - follow symbols					}
+  {    fprocp - identifier for program or program-level		}
+  {       subroutine contining this statement			}
+  
+  var
+    lattr: attr;
+    lop: operator;
+    typind: basetypeenum;
+    lsize,rsize: integer;		{size of string operands}
+ 
+    procedure FloatCheck(var first, second: stp);
+    {insure that both operands are real}
+
+    begin {FloatCheck}
+    if (second = intptr) or (second = byteptr) then begin
+      Gen2(pc_cnv,ord(cgWord),ord(cgReal));
+      second := realptr;
+      end
+    else if second = longptr then begin
+      Gen2(pc_cnv,ord(cgLong),ord(cgReal));
+      second := realptr;
+      end
+    else if IsReal(second) then
+      second := realptr;
+    if (first = intptr) or (first = byteptr) then begin
+      Gen2(pc_cnn,ord(cgWord),ord(cgReal));
+      first := realptr;
+      end
+    else if first = longptr then begin
+      Gen2(pc_cnn,ord(cgLong),ord(cgReal));
+      first := realptr;
+      end
+    else if IsReal(first) then
+      first := realptr;
+    end; {FloatCheck}
+
+    procedure MatchOpnd(var first, second: stp);
+    {insure that the operand types match}
+
+    begin {MatchOpnd}
+    {eliminate need for redundant checking}
+    if second = byteptr then
+      second := intptr
+    else if IsReal(second) then
+      second := realptr;
+    if first = byteptr then
+      first := intptr
+    else if IsReal(first) then
+      first := realptr;
+    {match second operand to first if first is of higher type}
+    if second = intptr then begin
+      if first = longptr then begin
+	Gen2(pc_cnv,ord(cgWord),ord(cgLong));
+	second := longptr;
+	end
+      else if first = realptr then begin
+	Gen2(pc_cnv,ord(cgWord),ord(cgReal));
+	second := realptr;
+	end;
+      end
+    else if second = longptr then
+      if first = realptr then begin
+	Gen2(pc_cnv,ord(cgLong),ord(cgReal));
+	second := realptr;
+	end;
+    {match first operand to second if second is of higher type}
+    if first = intptr then begin
+      if second = longptr then begin
+	Gen2(pc_cnn,ord(cgWord),ord(cgLong));
+	first := longptr;
+	end
+      else if second = realptr then begin
+	Gen2(pc_cnn,ord(cgWord),ord(cgReal));
+	first := realptr;
+	end;
+      end
+    else if first = longptr then
+      if second = realptr then begin
+	Gen2(pc_cnn,ord(cgLong),ord(cgReal));
+	first := realptr;
+	end;
+    end; {MatchOpnd}
+
+    procedure SimpleExpression(fsys: setofsys);
+    {compile a simple expression}
+
+    var
+      lattr: attr;
+      lop: operator;
+      signed,foundSign: boolean;
+ 
+      procedure Term (fsys: setofsys);
+
+      { compile a term						}
+      {								}
+      { parameters:						}
+      {    fsys - follow symbols				}
+
+      var
+	lattr: attr;
+	lop: operator;
+
+
+	procedure Factor (fsys: setofsys);
+
+	{ compile a factor						}
+        {								}
+        { parameters:							}
+        {    fsys - follow symbols					}
+
+	var
+          isMethod: boolean;		{dummy for selector call}
+	  lvp: csp;
+	  varpart: boolean;
+	  cstmax: setlow..sethigh;
+	  lsp: stp;
+	  lowrange,i: integer;
+	  test: boolean;
+	  lcp: ctp;			{used to form addresses via atsy}
+	  cstpart: ^settype;
+	  castType: stp; 		{type to cast to (for type casting)}
+	  castSize: addrrange;		{sizes (for type casting)}
+
+	begin {Factor}
+	if not (sy in facbegsys) then begin
+	  Error(28);
+	  Skip(fsys + facbegsys);
+	  gattr.typtr := nil;
+	  end; {if}
+	while sy in facbegsys do begin
+	  case sy of
+  {id}	    ident: begin
+	      SearchId([types,konst,varsm,field,func],glcp);
+	      with glcp^ do begin
+		InSymbol;
+		if klass = types then begin
+		  {handle a type cast}
+		  if iso then Error(112);
+		  castType := {glcp^.}idtype;
+		  castSize := castType^.size;
+		  Match(lparent,9);
+		  Expression(fsys + [rparent],fprocp);
+		  if (gattr.typtr^.form in
+                    [power,arrays,records,files,tagfld,variant])
+                    or (castType^.form in [power,files,tagfld,variant]) then
+		    Error(121);
+		  if castSize <> gattr.typtr^.size then begin
+		    {type conversion}
+		    Load;
+		    gattr.typtr := castType;
+		    if castSize = 2 then
+		      Gen2(pc_cnv,ord(cgLong),ord(cgWord))
+		    else
+		      Gen2(pc_cnv,ord(cgWord),ord(cgLong));
+		    Match(rparent,4);
+		    end
+		  else begin
+		    {treat space as another type}
+		    gattr.typtr := castType;
+		    Match(rparent,4);
+		    doingCast := true;
+		    Selector(fsys, glcp, fprocp, isMethod);
+		    doingCast := false;
+		    end;
+		  end
+		else if klass = konst then
+		  with gattr do begin
+		    typtr := {glcp^.}idtype;
+                    isPacked := false;
+		    kind := cst;
+		    cval := {glcp^.}values;
+		    end
+		else
+		  Selector(fsys, glcp, fprocp, isMethod);
+		end;
+	      end;
+{inherited} inheritedsy: begin
+              InSymbol;
+	      InheritedCall(fsys, fprocp);
+	      if sy <> arrow then
+		gattr.kind := expr;
+	      if sy in [period,lbrack] then
+        	Error(23);
+              end;
+  {nil}	    nilsy: begin
+	      with gattr do begin
+		typtr := nilptr;
+                isPacked := false;
+		kind := cst;
+		cval.ival := 0;
+		InSymbol;
+		end;
+	      end;
+  {atsy}    atsy: begin
+	      InSymbol;
+	      if sy = ident then begin
+		SearchId([konst,varsm,field,func,proc],lcp);
+		InSymbol;
+		if lcp^.klass in [func,proc] then
+		  Gen0Name(pc_lad,lcp^.name)
+                else if lcp^.klass = konst then begin
+                  if IsString(lcp^.idtype) then begin
+                    val := lcp^.values;
+                    lgth := length(val.valp^.sval);
+                    LoadString(lengthString);
+		    LoadAddress;
+                    end {if}
+                  else
+                    Error(32);
+                  end {else if}
+		else begin
+		  if lcp^.klass = varsm then begin
+		    if lcp^.vcontvar then Error(97);
+		    if lcp^.vlev <> level then lcp^.vrestrict := true;
+		    end;
+		  Selector(fsys, lcp, fprocp, isMethod);
+		  LoadAddress;
+		  end;
+		end
+	      else if sy = stringconst then begin
+		LoadString(lengthString);
+		InSymbol;
+		LoadAddress;
+		end
+	      else Error(2);
+	      gattr.kind := expr;
+	      gattr.typtr := nilptr;
+	      end;
+  {cst}	    intconst: begin
+	      with gattr do begin
+		typtr := intptr;
+                isPacked := false;
+		kind := cst;
+		cval := val;
+		end;
+	      InSymbol;
+	      end;
+	    longintconst: begin
+	      with gattr do begin
+		typtr := longptr;
+                isPacked := false;
+		kind := cst;
+		cval := val;
+		end;
+	      InSymbol;
+	      end;
+	    realconst: begin
+	      with gattr do begin
+		typtr := realptr;
+                isPacked := false;
+		kind := cst;
+		cval := val;
+		end;
+	      InSymbol;
+	      end;
+	    stringconst: begin
+	      with gattr do begin
+		if lgth = 1 then
+                  typtr := charptr
+		else begin
+                  lsp := pointer(Malloc(sizeof(structure)));
+		  with lsp^ do begin
+		    aeltype := charptr;
+		    form := arrays;
+		    hasSFile := false;
+		    ispacked := pkpacked;
+		    inxtype := dummystring;
+		    size := lgth*packedcharsize;
+		    end; {with}
+		  typtr := lsp
+		  end; {else}
+                isPacked := false;
+		kind := cst;
+		cval := val;
+		end; {with}
+	      InSymbol;
+	      end;
+    {(}	    lparent: begin
+	      InSymbol;
+	      Expression(fsys + [rparent],fprocp);
+	      Load;
+	      Match(rparent,4);
+	      end;
+   {not}    notsy: begin
+	      InSymbol;
+	      Factor(fsys);
+	      Load;
+	      Gen0(pc_not);
+	      if gattr.typtr <> nil then
+		if gattr.typtr <> boolptr then begin
+		  Error(60); gattr.typtr := nil;
+		  end;
+	      end;
+   {~}	    bitnot: begin
+	      InSymbol;
+	      Factor(fsys);
+	      Load;
+	      if gattr.typtr <> nil then
+		if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
+		  Gen0(pc_bnt)
+		else if gattr.typtr = longptr then
+		  Gen0(pc_bnl)
+		else begin
+		  Error(59);
+		  gattr.typtr := nil;
+		  end;
+	      end;
+   {[}	    lbrack: begin
+	      new(cstPart);
+	      InSymbol;
+	      cstpart^ := [ ];
+	      varpart := false;
+              lsp := pointer(Malloc(sizeof(structure)));
+	      cstmax := setlow;
+	      with lsp^ do begin
+		ispacked := pkeither;
+		hasSFile := false;
+		form := power;
+		elset := nil;
+		end;
+	      if sy = rbrack then begin
+		lsp^.size := cstmax div 8 + 1;
+		with gattr do begin
+		  typtr := lsp;
+                  isPacked := false;
+                  kind := cst
+                  end;
+		InSymbol;
+		end
+	      else begin
+		repeat
+		  Expression(fsys + [comma,rbrack,dotdot],fprocp);
+		  if gattr.typtr <> nil then
+		    if not (gattr.typtr^.form in [scalar,subrange]) then begin
+		      Error(61);
+                      gattr.typtr := nil;
+		      end
+		    else if CompTypes(lsp^.elset,gattr.typtr) then begin
+		      if gattr.kind = cst then begin
+			if (gattr.cval.ival < setlow) or
+			  (gattr.cval.ival > sethigh) then Error(110);
+			if sy = dotdot then begin
+			  InSymbol;
+			  lowrange := gattr.cval.ival;
+			  Expression(fsys+[comma,rbrack],fprocp);
+			  if gattr.typtr <> nil then
+			    if not (gattr.typtr^.form in [scalar,subrange]) then
+			      begin
+			      Error(61);
+			      gattr.typtr := nil;
+			      end
+			    else if CompTypes(lsp^.elset,gattr.typtr) then begin
+			      if gattr.kind = cst then begin
+				if gattr.cval.ival>sethigh then Error(110);
+				for i := lowrange to gattr.cval.ival do
+				  cstpart^ := cstpart^+[i];
+				if gattr.cval.ival > cstmax then
+				  cstmax := gattr.cval.ival;
+				end
+			      else begin
+                                Gen1t(pc_ldc, lowRange, cgWord);
+				Load;
+				if debug then
+				  Gen2t(pc_chk, setlow, sethigh, cgUWord);
+				Gen0(pc_sgs);
+				if varpart then Gen0(pc_uni)
+				else varpart := true
+				end;
+			      end
+			    else Error(62);
+			  end
+			else begin
+			  cstpart^ := cstpart^+[gattr.cval.ival];
+			  if gattr.cval.ival > cstmax then
+			    cstmax := gattr.cval.ival;
+			  end
+			end
+		      else begin
+			Load;
+			if debug then
+			  Gen2t(pc_chk, setlow, sethigh, cgUWord);
+			if sy = dotdot then begin
+			  InSymbol;
+			  Expression(fsys+[comma,rbrack],fprocp);
+			  if gattr.typtr <> nil then
+			    if not (gattr.typtr^.form in [scalar,subrange]) then
+			      begin
+			      Error(61);
+			      gattr.typtr := nil;
+			      end
+			    else if CompTypes(lsp^.elset,gattr.typtr) then begin
+			      Load;
+			      if debug then
+				Gen2t(pc_chk, setlow, sethigh, cgUWord);
+			      end
+			    else Error(62);
+			  end
+			else
+			  Gen1t(pc_ldc, $8000, cgUWord);
+			Gen0(pc_sgs);
+			if varpart then Gen0(pc_uni)
+			else varpart := true
+			end;
+		      lsp^.elset := gattr.typtr;
+		      gattr.typtr := lsp
+		      end
+		    else Error(62);
+		  test := sy <> comma;
+		  if not test then InSymbol
+		until test;
+		Match(rbrack,12);
+		end;
+	      if varpart then begin
+		if cstpart^ <> [ ] then begin
+                  lvp := pointer(Malloc(sizeof(constantRec)));
+		  with lvp^ do begin
+		    cclass := pset;
+		    pval := cstpart^;
+		    pmax := cstmax;
+		    end;
+		  GenLdcSet(lvp^);
+		  Gen0(pc_uni);
+		  gattr.kind := expr;
+		  end
+		end
+	      else begin
+                lvp := pointer(Malloc(sizeof(constantRec)));
+		with lvp^ do begin
+		  cclass := pset;
+		  pval := cstpart^;
+		  pmax := cstmax;
+		  end;
+		gattr.cval.valp := lvp;
+                gattr.isPacked := false;
+		gattr.kind := cst;
+		end;
+	      dispose(cstPart);
+	      end
+	    end; {case}
+	  if not (sy in (fsys+[powersy])) then begin
+	    Error(6);
+            Skip(fsys + facbegsys);
+	    end; {if}
+	  end; {while}
+	if sy = powersy then begin
+	  Load;
+	  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
+	    Gen2(pc_cnv,ord(cgWord),ord(cgReal))
+	  else if gattr.typtr = longptr then
+	    Gen2(pc_cnv,ord(cgLong),ord(cgReal))
+	  else if not IsReal(gattr.typtr) then
+	    Error(59);
+	  InSymbol;
+	  Factor(fsys);
+	  Load;
+	  if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
+	    Gen2(pc_cnv,ord(cgWord),ord(cgReal))
+	  else if gattr.typtr = longptr then
+	    Gen2(pc_cnv,ord(cgLong),ord(cgReal))
+	  else if not IsReal(gattr.typtr) then
+	    Error(59);
+	  Gen0(pc_pwr);
+	  gattr.typtr := realptr;
+	  end;
+	end; {Factor}
+
+      begin {Term}
+      Factor(fsys + [mulop,powersy]);
+      while sy = mulop do begin
+	Load;
+	lattr := gattr;
+	lop := op;
+	InSymbol;
+	Factor(fsys + [mulop]);
+	Load;
+	if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
+	  case lop of
+   {*}	    mul: begin
+	      MatchOpnd(lattr.typtr,gattr.typtr);
+	      if lattr.typtr = intptr then
+		Gen0(pc_mpi)
+	      else if lattr.typtr = longptr then
+		Gen0(pc_mpl)
+	      else if lattr.typtr = realptr then
+		Gen0(pc_mpr)
+	      else if(lattr.typtr^.form=power)
+		and CompTypes(lattr.typtr,gattr.typtr)then
+		Gen0(pc_int)
+	      else begin
+		Error(59);
+		gattr.typtr:=nil;
+		end;
+	      end;
+   {/}	    rdiv: begin
+	      FloatCheck(lattr.typtr,gattr.typtr);
+	      if lattr.typtr = realptr then
+		Gen0(pc_dvr)
+	      else begin
+		Error(59);
+		gattr.typtr := nil;
+		end;
+	      end;
+   {div}    idiv: begin
+	      MatchOpnd(lattr.typtr,gattr.typtr);
+	      if lattr.typtr = intptr then
+		Gen0(pc_dvi)
+	      else if lattr.typtr = longptr then
+		Gen0(pc_dvl)
+	      else begin
+		Error(59);
+		gattr.typtr := nil;
+		end;
+	      end;
+   {mod}    imod: begin
+	      MatchOpnd(lattr.typtr,gattr.typtr);
+	      if lattr.typtr = intptr then
+		Gen0(pc_mod)
+	      else if lattr.typtr = longptr then
+		Gen0(pc_mdl)
+	      else begin
+		Error(59);
+		gattr.typtr := nil;
+		end;
+	      end;
+   {and}    andop:
+	      if (lattr.typtr = boolptr) and (gattr.typtr = boolptr) then
+		Gen0(pc_and)
+	      else begin
+		Error(59);
+		gattr.typtr := nil;
+		end;
+   {<<}	    lshift: begin
+	      MatchOpnd(lattr.typtr,gattr.typtr);
+	      if lattr.typtr=intptr then
+		Gen0(pc_shl)
+	      else if lattr.typtr = longptr then
+		Gen0(pc_sll)
+	      else begin
+		Error(59);
+		gattr.typtr:=nil;
+		end;
+	      end;
+   {>>}	    rshift: begin
+	      MatchOpnd(lattr.typtr,gattr.typtr);
+	      if lattr.typtr=intptr then
+		Gen0(pc_shr)
+	      else if lattr.typtr = longptr then
+		Gen0(pc_slr)
+	      else begin
+		Error(59);
+		gattr.typtr:=nil;
+		end;
+	      end;
+   {&}	    band: begin
+	      MatchOpnd(lattr.typtr,gattr.typtr);
+	      if lattr.typtr=intptr then
+		Gen0(pc_bnd)
+	      else if lattr.typtr = longptr then
+		Gen0(pc_bal)
+	      else begin
+		Error(59);
+		gattr.typtr:=nil;
+		end;
+	      end;
+	    end {case}
+	else
+	  gattr.typtr := nil;
+	end; {while}
+      end; {Term}
+
+    begin {SimpleExpression}
+    signed := false;
+    foundSign := false;
+    if (sy = addop) and (op in [plus,minus]) then begin
+      signed := op = minus;
+      InSymbol;
+      foundSign := true;
+      end;
+    Term(fsys + [addop]);
+    if signed then begin
+      Load;
+      if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
+	Gen0(pc_ngi)
+      else if gattr.typtr = longptr then
+	Gen0(pc_ngl)
+      else if IsReal(gattr.typtr) then
+	Gen0(pc_ngr)
+      else begin
+	Error(59);
+	gattr.typtr := nil;
+	end;
+      end
+    else if foundSign then
+      if (gattr.typtr <> intptr) and (not IsReal(gattr.typtr))
+	and (gattr.typtr <> byteptr) and (gattr.typtr <> longptr) then
+	Error(34);
+    while sy = addop do begin
+      Load;
+      lattr := gattr;
+      lop := op;
+      InSymbol;
+      Term(fsys + [addop]);
+      Load;
+      if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
+	case lop of
+{+}	  plus: begin
+	    MatchOpnd(lattr.typtr,gattr.typtr);
+	    if lattr.typtr = intptr then
+	      Gen0(pc_adi)
+	    else if lattr.typtr = longptr then
+	      Gen0(pc_adl)
+	    else if lattr.typtr = realptr then
+	      Gen0(pc_adr)
+	    else if (lattr.typtr^.form=power)
+	      and CompTypes(lattr.typtr,gattr.typtr) then
+	      Gen0(pc_uni)
+	    else begin
+	      Error(59);
+	      gattr.typtr:=nil;
+	      end;
+	    end;
+{-}	  minus: begin
+	    MatchOpnd(lattr.typtr,gattr.typtr);
+	    if lattr.typtr = intptr then
+	      Gen0(pc_sbi)
+	    else if lattr.typtr = longptr then
+	      Gen0(pc_sbl)
+	    else if lattr.typtr = realptr then
+	      Gen0(pc_sbr)
+	    else if (lattr.typtr^.form = power)
+	      and CompTypes(lattr.typtr,gattr.typtr) then
+	      Gen0(pc_dif)
+	    else begin
+	      Error(59);
+	      gattr.typtr := nil;
+	      end;
+	    end;
+{or}	  orop:
+	    if (lattr.typtr = boolptr) and (gattr.typtr = boolptr) then
+	      Gen0(pc_ior)
+	    else begin
+	      Error(59);
+	      gattr.typtr := nil;
+	      end;
+{|}	  bor: begin
+	    MatchOpnd(lattr.typtr,gattr.typtr);
+	    if lattr.typtr = intptr then
+	      Gen0(pc_bor)
+	    else if lattr.typtr = longptr then
+	      Gen0(pc_blr)
+	    else begin
+	      Error(59);
+	      gattr.typtr:=nil;
+	      end;
+	    end;
+{!}	  xor: begin
+	    MatchOpnd(lattr.typtr,gattr.typtr);
+	    if lattr.typtr = intptr then
+	      Gen0(pc_bxr)
+	    else if lattr.typtr = longptr then
+	      Gen0(pc_blx)
+	    else begin
+	      Error(59);
+	      gattr.typtr:=nil;
+	      end;
+	    end;
+	  end {case}
+      else gattr.typtr := nil
+      end; {while}
+    end; {SimpleExpression}
+
+  begin {Expression}
+  SimpleExpression(fsys + [relop]);
+  if sy = relop then begin
+    if gattr.typtr <> nil then
+      if gattr.typtr^.form in [scalar..power,objects] then
+	Load
+      else
+	LoadAddress;
+    lattr := gattr;
+    lop := op;
+    InSymbol;
+    SimpleExpression(fsys);
+    {set the size of the left operand}
+    if lattr.typtr <> nil then
+      if IsString(lattr.typtr) then
+	lsize := StrLen(lattr.typtr);
+    if gattr.typtr <> nil then begin
+      if IsString(gattr.typtr) then
+	if lattr.typtr = charptr then begin
+	  lattr.typtr := stringptr;
+	  lsize := -1;
+	  end;
+      if gattr.typtr^.form in [scalar..power,objects] then
+	Load
+      else
+	LoadAddress;
+      end;
+    {set the size of the right operand}
+    if IsString(gattr.typtr) then
+      rsize := StrLen(gattr.typtr)
+    else begin
+      if lattr.typtr <> nil then
+	if IsString(lattr.typtr) then
+	  if gattr.typtr = charptr then begin
+	    gattr.typtr := stringptr;
+	    rsize := -1;
+	    end; {if}
+      end; {else}
+
+    if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
+      if lop = inop then
+	if lattr.typtr^.form<power then
+	  if gattr.typtr^.form = power then
+	    if CompTypes(lattr.typtr,gattr.typtr^.elset) then
+	      Gen0(pc_inn)
+	    else begin Error(54); gattr.typtr := nil; end
+	  else begin Error(55); gattr.typtr := nil; end
+	else begin Error(54); gattr.typtr := nil; end
+      else begin
+	MatchOpnd(lattr.typtr,gattr.typtr);
+	if CompTypes(lattr.typtr,gattr.typtr) then begin
+	  case lattr.typtr^.form of
+	    scalar:
+	      if lattr.typtr = realptr then typind := cgReal
+	      else if lattr.typtr = boolptr then typind := cgUWord
+	      else if lattr.typtr = charptr then typind := cgUWord
+	      else if lattr.typtr = doubleptr then typind := cgDouble
+	      else if lattr.typtr = compptr then typind := cgComp
+	      else if lattr.typtr = extendedptr then typind := cgExtended
+	      else if lattr.typtr = longptr then typind := cgLong
+	      else typind := cgWord;
+	    pointerStruct,objects: begin
+	      if lop in [ltop,leop,gtop,geop] then Error(56);
+	      typind := cgULong;
+	      end;
+	    power: begin
+	      if lop in [ltop,gtop] then Error(57);
+	      typind := cgSet;
+	      end;
+	    arrays: begin
+	      if not IsString(lattr.typtr) then Error(59);
+	      typind := cgString;
+	      end;
+	    records: begin
+	      Error(59);
+	      typind := cgString;
+	      end;
+	    files: begin
+	      Error(58);
+	      typind := cgULong;
+	      end
+	    end;
+          if typind = cgString then begin
+	    case lop of
+	      ltop: Gen2t(pc_les, lsize, rsize, typind);
+	      leop: Gen2t(pc_leq, lsize, rsize, typind);
+	      gtop: Gen2t(pc_grt, lsize, rsize, typind);
+	      geop: Gen2t(pc_geq, lsize, rsize, typind);
+	      neop: Gen2t(pc_neq, lsize, rsize, typind);
+	      eqop: Gen2t(pc_equ, lsize, rsize, typind);
+	      end {case}
+            end
+          else
+	    case lop of
+	      ltop: Gen0t(pc_les, typind);
+	      leop: Gen0t(pc_leq, typind);
+	      gtop: Gen0t(pc_grt, typind);
+	      geop: Gen0t(pc_geq, typind);
+	      neop: Gen0t(pc_neq, typind);
+	      eqop: Gen0t(pc_equ, typind);
+	      end; {case}
+	  end
+	else Error(54);
+	end;
+    gattr.typtr := boolptr;
+    gattr.kind := expr;
+    end; {sy = relop}
+  end; {Expression}
+
+ 
+  procedure Statement (fsys: setofsys; fprocp: ctp; var stlevel: integer;
+    var starray: starrtype);
+
+  { Compile a statement						}
+  {								}
+  { parameters:							}
+  {    fsys -							}
+  {    fprocp - identifier for program or program-level		}
+  {       subroutine contining this statement			}
+  {    stlevel -						}
+  {    starray -						}
+
+  label 1;
+
+  var
+    lcp, fcp: ctp;			{work identifier pointers}
+    llp: lbp; i: integer;
+
+
+    procedure MakeLab(var ml: ctp; n: integer);
+    {Change a numbered label into a named label}
+
+    var i: integer;
+
+    begin {MakeLab}
+    ml := pointer(Malloc(sizeof(identifier)));
+    with ml^ do begin
+      name := pointer(Malloc(6));
+      name^[0] := chr(5);
+      name^[1] := '~';
+      for i := 5 downto 2 do begin
+	name^[i] := chr(ord('0')+n mod 10);
+	n := n div 10;
+	end;
+      end;
+    end; {MakeLab}
+
+
+    procedure Assignment (fcp: ctp);
+
+    { compile an assignment statement				}
+    {								}
+    { parameters:						}
+    {    fcp - leading identifier in assignment statement	}
+
+    label 1;
+
+    var
+      isMethod: boolean;		{is this a method call?}
+      lattr: attr;			{attr for left hand side}
+      tattr: attr;			{for checking string types}
+      stringAssignment: boolean; 	{are we assigning a string?}
+
+    begin {Assignment}
+    isMethod := false;
+    stringAssignment := false;
+    if fcp <> nil then
+      with fcp^ do begin
+	if klass = func then begin
+
+          {function assignment}
+	  pfset := true;
+	  if pfdeckind = standard then begin
+	    Error(75);
+	    gattr.typtr := nil;
+	    end
+	  else begin
+	    if pfkind = formal then
+	      Error(76)
+	    else if pflev+1 > level then
+	      Error(93);
+	    with gattr do begin
+	      typtr := idtype;
+              isPacked := false;
+	      kind := varbl;
+	      access := drct;
+	      vlevel := pflev+1;
+	      dplab := pflabel;
+              dpdisp := 0;
+	      end; {with}
+	    end;
+	  goto 1;
+	  end {if}
+	else if klass = varsm then begin
+
+          {variable (non-function) assignment}
+	  if vcontvar then
+            Error(97);
+	  if vlev <> level then
+            vrestrict := true;
+	  end; {else if}
+	end; {with}
+    Selector(fsys + [becomes], fcp, fprocp, isMethod);
+
+    {handle the right-hand side}
+1:  if not isMethod then
+      if sy = becomes then begin
+	if gattr.typtr <> nil then begin
+	  stringAssignment := IsString(gattr.typtr);
+	  if (gattr.access<>drct) or 
+	    (gattr.typtr^.form in [arrays,records,files]) then begin
+	    LoadAddress;
+	    if stringAssignment then
+              Gen0t(pc_stk, cgULong);
+            end; {if}
+	  if stringAssignment then begin
+	    Gen1t(pc_ldc, StrLen(gattr.typtr), cgWord);
+            Gen0t(pc_stk, cgWord);
+            Gen0t(pc_bno, cgWord);
+            end; {if}
+	  end; {if}
+	lattr := gattr;
+	InSymbol;
+	Expression(fsys,fprocp);
+	tattr := gattr;
+	if gattr.typtr <> nil then
+	  if gattr.typtr^.form = objects then begin
+	    Load;
+	    if debug then
+	      GenL2t(pc_chk, 1, maxaddr, cgULong);
+            end {if}
+	  else if gattr.typtr^.form in [scalar,subrange,pointerStruct,power] then
+	    Load
+	  else
+	    LoadAddress;
+
+	if (lattr.typtr <> nil) and (gattr.typtr <> nil) then begin
+	  if CompTypes(realptr, lattr.typtr) then begin
+
+            {convert a non-real rhs to a real before storing}
+	    if (gattr.typtr = intptr) or (gattr.typtr = bytePtr) then begin
+	      Gen2(pc_cnv, ord(cgWord), ord(cgReal));
+	      gattr.typtr := realptr;
+	      end
+	    else if gattr.typtr = longptr then begin
+	      Gen2(pc_cnv, ord(cgLong), ord(cgReal));
+	      gattr.typtr := realptr;
+	      end;
+	    end
+	  else if CompTypes(longptr, lattr.typtr) then
+
+            {convert a non-long rhs to a long before storing}
+	    if (gattr.typtr = intptr) or (gattr.typtr = bytePtr) then begin
+	      Gen2(pc_cnv, ord(cgWord), ord(cgLong));
+	      gattr.typtr := longptr;
+	      end; {if}
+
+          {convert a char rhs to a string before storing}
+	  if gattr.typtr = charptr then begin
+	    if IsString(lattr.typtr) then begin
+	      stringAssignment := true;
+	      gattr.typtr := stringptr;
+              Gen0t(pc_stk, cgUWord);
+              GenLdcLong(-1);
+              Gen0t(pc_stk, cgULong);
+              Gen0t(pc_bno, cgULong);
+              Gen0t(pc_bno, cgULong);
+	      end;
+	    end
+	  else if IsString(tattr.typtr) then begin
+	    if tattr.kind <> expr then begin
+              Gen0t(pc_stk, cgULong);
+	      Gen1t(pc_ldc, StrLen(tattr.typtr), cgWord);
+              Gen0t(pc_stk, cgWord);
+              Gen0t(pc_bno, cgWord);
+              end; {if}
+            Gen0t(pc_bno, cgULong);
+            end;
+
+          {do the assignment}
+	  if CompTypes(lattr.typtr, gattr.typtr) then begin
+	    case lattr.typtr^.form of
+	      scalar,subrange: begin
+		CheckBnds(lattr.typtr);
+		Store(lattr);
+		end;
+	      pointerStruct, power, objects:
+        	Store(lattr);
+	      arrays,records:
+		if stringAssignment then
+		  Gen1(pc_csp,91{mvs})
+		else
+	          Gen2(pc_mov, long(lattr.typtr^.size).msw,
+                    long(lattr.typtr^.size).lsw);
+	      files: ;
+	      end; {case}
+	    if gattr.typtr^.hasSFile then
+	      if lattr.typtr^.form <> pointerStruct then
+		Error(71);
+	    end {if}
+	  else if CompObjects(lattr.typtr, gattr.typtr) then
+            Store(lattr)
+	  else
+            Error(54);
+	  end {if}
+	end {sy = becomes}
+      else
+	Error(23);
+    end; {Assignment}
+
+
+    procedure GotoStatement;
+    {Compile a goto statement}
+
+    label 1;
+
+    var
+      llp: lbp;
+      ttop: disprange;
+      i: integer;
+      fcp: ctp;
+
+    begin {GotoStatement}
+    if sy = intconst then begin
+      ttop := level;
+      repeat
+	llp := display[ttop].flabel;
+	while llp <> nil do
+	  with llp^ do
+	    if labval = val.ival then begin
+	      for i := ttop to level-1 do
+                Gen0(pc_prs);
+	      if labname >= firstlab then
+                Gen1(pc_ujp, labname)
+	      else begin
+		MakeLab(fcp,labname);
+		Gen0Name(pc_ujp, fcp^.name);
+		end;
+	      if defined then begin
+		if lstlevel > stlevel then Error(99)
+		else begin
+		  for i := 1 to lstlevel-1 do
+		    if starray[i] <> lstarray[i] then begin
+		      Error(99); goto 1;
+		      end;
+		  end;
+		end
+	      else begin
+		if ttop<>level then lstlevel := 1
+		else if lstlevel = 0 then begin
+		  lstlevel := stlevel; lstarray := starray;
+		  end
+		else begin
+		  if lstlevel > stlevel then lstlevel := stlevel;
+		  for i := 1 to lstlevel do
+		    if lstarray[i] <> starray[i] then begin
+		      lstlevel := i; goto 1;
+		      end;
+		  end;
+		end;
+	      goto 1;
+	      end
+	    else llp := nextlab;
+	ttop := ttop-1;
+      until ttop = 0;
+      Error(89);
+1:    InSymbol
+      end
+    else Error(15)
+    end; {GotoStatement}
+ 
+    procedure StartStruct;
+
+    begin {StartStruct}
+    if stlevel < maxgoto then starray[stlevel] := starray[stlevel]+1;
+    stlevel := stlevel+1;
+    end; {StartStruct}
+
+    procedure EndStruct;
+
+    begin {EndStruct}
+    if stlevel < maxgoto then starray[stlevel] := 0;
+    stlevel := stlevel-1;
+    end; {EndStruct}
+
+    procedure CompoundStatement;
+    {compile a compound statement}
+
+    var
+      test: boolean;
+
+    begin {CompoundStatement}
+    StartStruct;
+    repeat
+      repeat
+	Statement(fsys + [semicolon,endsy],fprocp,stlevel,starray);
+      until not (sy in statbegsys);
+      test := sy <> semicolon;
+      if not test then InSymbol
+    until test;
+    Match(endsy,13); EndStruct;
+    end; {CompoundStatement}
+ 
+    procedure IfStatement;
+
+    var
+      lcix1,lcix2: integer;
+
+    begin {IfStatement}
+    Expression(fsys + [thensy],fprocp);
+    lcix1 := GenLabel;
+    checkbool;
+    Gen1(pc_fjp, lcix1);
+    Match(thensy,24);
+    StartStruct;
+    Statement(fsys + [elsesy],fprocp,stlevel,starray);
+    EndStruct;
+    if sy = elsesy then begin
+      lcix2 := GenLabel;
+      Gen1(pc_ujp, lcix2);
+      Gen1(dc_lab, lcix1);
+      InSymbol; StartStruct;
+      Statement(fsys,fprocp,stlevel,starray);
+      EndStruct;
+      Gen1(dc_lab, lcix2)
+      end
+    else
+      Gen1(dc_lab, lcix1)
+    end {IfStatement} ;
+ 
+    procedure CaseStatement;
+    {compile a case statement}
+
+    label 1;
+
+    const
+      sparse = 5;			{label to tableSize ratio for sparse table}
+
+    var
+      foundlab: boolean; 		{was a label found?}
+      fstptr,lpt1,lpt2,lpt3: cip;
+      isotherwise: boolean;		{was the last label 'otherwise'?}
+      laddr, lcix, lcix1: integer;
+      lcount: unsigned;			{number of case labels}
+      lmin, lmax: integer;		{low, high case label}
+      llb: unsigned;			{used to allocate temporary space}
+      lsp,lsp1: stp;
+      lval: valu;
+      otherlab: unsigned;		{otherwise label number}
+      test: boolean;
+
+    begin {CaseStatement}
+    {evaluate the case expression}
+    otherlab := 0;
+    Expression(fsys + [ofsy,comma,colon],fprocp);
+    Load;
+    llb := GetTemp(intsize);
+    Gen3t(pc_str, llb, 0, 0, cgWord);
+    lcix := GenLabel;
+    lsp := gattr.typtr;
+    if lsp <> nil then
+      if (lsp^.form <> scalar) or IsReal(lsp) then begin
+	Error(69);
+	lsp := nil;
+	end; {if}
+    Gen1(pc_ujp, lcix);
+    Match(ofsy,8);
+    fstptr := nil;
+    laddr := GenLabel;
+
+    {collect the labeled statements}
+    lmax := -maxint;
+    lcount := 0;
+    repeat
+      StartStruct;
+      lpt3 := nil;
+      lcix1 := GenLabel;
+      foundlab := false;
+      if not(sy in [semicolon,endsy]) then begin
+	repeat
+	  if sy = otherwisesy then begin
+	    if otherlab <> 0 then
+	      Error(80)
+	    else begin
+	      foundlab := true;
+	      otherlab := lcix1;
+	      end;
+	    InSymbol;
+	    isotherwise := true;
+	    end {if}
+	  else begin
+	    isotherwise := false;
+	    DoConstant(fsys + [comma,colon],lsp1,lval);
+	    if lval.ival > lmax then
+              lmax := lval.ival;
+	    if lsp <> nil then
+	      if CompTypes(lsp,lsp1) then begin
+		lpt1 := fstptr;
+		lpt2 := nil;
+		while lpt1 <> nil do
+		  with lpt1^ do begin
+		    if cslab >= lval.ival then begin
+		      if cslab = lval.ival then
+                        Error(80);
+		      goto 1;
+		      end; {if}
+		    lpt2 := lpt1;
+		    lpt1 := next;
+		    end; {with}
+1:		lpt3 := pointer(Malloc(sizeof(caseInfo)));
+		foundlab := true;
+		with lpt3^ do begin
+		  next := lpt1;
+		  cslab := lval.ival;
+		  csstart := lcix1;
+		  end; {with}
+                lcount := lcount+1;
+		if lpt2 = nil then
+                  fstptr := lpt3
+		else
+                  lpt2^.next := lpt3
+		end {if}
+	      else
+		Error(72);
+	    end;
+	  test := sy <> comma;
+	  if not test then InSymbol;
+	until test;
+	if sy = colon then
+	  InSymbol
+	else if not isotherwise then
+	  Error(5);
+	Gen1(dc_lab, lcix1);
+	repeat
+	  Statement(fsys + [semicolon],fprocp,stlevel,starray);
+	until not (sy in statbegsys);
+	if foundlab then
+          Gen1(pc_ujp, laddr);
+	end;
+      test := sy <> semicolon;
+      if not test then InSymbol;
+      EndStruct;
+    until test;
+
+    {generate the branch code}
+    Gen1(dc_lab, lcix);
+    if fstptr <> nil then begin		{if there are labels...}
+      lmin := fstptr^.cslab;
+      if (lmax - lmin) div lcount > sparse then begin
+
+        {use if-else for sparse case statements}
+        while fstptr <> nil do begin
+          Gen1t(pc_ldc, fstptr^.cslab, cgWord);
+          Gen3t(pc_lod, llb, 0, 0, cgWord);
+          Gen0t(pc_equ, cgWord);
+          Gen1(pc_tjp, fstptr^.csstart);
+          fstptr := fstptr^.next;
+          end; {while}
+        {handle untrapped values}
+        if otherlab <> 0 then
+          Gen1(pc_ujp, otherlab)
+        else begin
+          Gen0(pc_nop);
+	  Gen1tName(pc_cup, 0, cgVoid, @'~XJPERROR');
+          end; {if}
+        end {if}
+      else begin
+
+        {use a jump table for compact case statements}
+	Gen3t(pc_lod, llb, 0, 0, cgWord); {do the indexed jump}
+	Gen1t(pc_dec, lmin, cgWord);
+	Gen1(pc_xjp, lmax-lmin+1);
+	repeat				{generate the jump table}
+	  with fstptr^ do begin
+	    while cslab > lmin do begin	{generate default labels for gaps in   }
+	      Gen1(pc_add, otherlab);	{ the table			       }
+	      lmin := lmin+1;
+	      end; {while}
+	    Gen1(pc_add, csstart);	{generate an entry for a label that    }
+	    fstptr := next;		{was specified			       }
+	    lmin := lmin+1;
+	    end; {with}
+	until fstptr = nil;
+	Gen1(pc_add, otherlab);		{generate a label for overflows}
+        end; {else}
+
+      Gen1(dc_lab, laddr);		{for branching around the table}
+      end; {if}
+    Match(endsy,13);
+    FreeTemp(llb, intsize);		{free the temp label}
+    end; {CaseStatement}
+ 
+    procedure RepeatStatement;
+
+    var
+      laddr: integer;
+
+    begin {RepeatStatement}
+    laddr := GenLabel;
+    Gen1(dc_lab, laddr);
+    StartStruct;
+    repeat
+      Statement(fsys + [semicolon,untilsy],fprocp,stlevel,starray);
+      if sy in statbegsys then Error(14)
+    until not(sy in statbegsys);
+    while sy = semicolon do
+      begin InSymbol;
+      repeat
+	Statement(fsys + [semicolon,untilsy],fprocp,stlevel,starray);
+	if sy in statbegsys then Error(14)
+      until not (sy in statbegsys);
+      end;
+    Match(untilsy,25);
+    Expression(fsys,fprocp);
+    checkbool;
+    Gen1(pc_fjp, laddr);
+    EndStruct;
+    end {RepeatStatement} ;
+ 
+    procedure WhileStatement;
+
+    var
+      laddr, lcix: integer;
+
+    begin {WhileStatement}
+    laddr := GenLabel;
+    Gen1(dc_lab, laddr);
+    StartStruct;
+    Expression(fsys + [dosy],fprocp);
+    lcix := GenLabel;
+    checkbool;
+    Gen1(pc_fjp, lcix);
+    Match(dosy,26);
+    Statement(fsys,fprocp,stlevel,starray);
+    Gen1(pc_ujp, laddr);
+    Gen1(dc_lab, lcix);
+    EndStruct;
+    end; {WhileStatement}
+ 
+    procedure ForStatement;
+    {compile a for loop}
+
+    var
+      firstExpr: boolean;		{was the first thing an expression?}
+      lattr,lattr2: attr;		{local attributes for start, stop}
+      ldattr: attr;			{lattr without subranges removed}
+      lsy: symbol;			{preserve symbol past InSymbol call}
+      lab1, lab2: integer;		{top, bottom labels}
+      llb,llb2: unsigned;		{used to allocate temporary space}
+      llb1Used,llb2Used: boolean;	{was work space used?}
+      lcp,cvlcp: ctp;			{temp ptr to identifier}
+      sattr: attr;			{attr for start expr}
+      isunsigned: boolean;		{is the loop variable unsigned?}
+
+      startConst,endConst: boolean;	{are start,stop points constant?}
+      startVal,endVal: integer;		{ if so, these are the values}
+
+
+    begin {ForStatement}
+    {no work space reserved yet}
+    llb1Used := false;
+    llb2Used := false;
+    firstExpr := false;
+
+    {set up the top and bottom loop points}
+    lab1 := GenLabel;
+    lab2 := GenLabel;
+
+    {set up a default control variable}
+    with lattr do begin
+      typtr := nil;
+      isPacked := false;
+      kind := varbl;
+      aName := pointer(ord4(@'  ')+1);
+      access := drct;
+      vlevel := level;
+      dpdisp := 0;
+      end;
+
+    {find and check the control variable}
+    isunsigned := false;
+    if sy = ident then begin
+      SearchId([varsm],lcp);
+      if lcp <> nil then
+         if lcp^.idtype <> nil then
+            if lcp^.idtype^.form = subrange then
+               isunsigned := lcp^.idtype^.min >= 0;
+      with lattr do begin
+        isPacked := false;
+	kind := varbl;
+	with lcp^ do begin
+	  typtr := idtype;
+	  if vcontvar or vrestrict then
+            Error(97);
+	  {prohibit use of this var as a control var}
+	  vcontvar := true;
+	  if vkind = actual then
+	    if vlev = level then begin
+	      access := drct;
+	      aname := name;
+	      vlevel := level;
+              dpdisp := 0;
+	      if level <> 1 then
+                dplab := vlabel;
+	      end
+	    else begin
+	      Error(79);
+	      typtr := nil;
+	      end
+	  else begin
+	    Error(95);
+	    typtr := nil;
+	    end;{else}
+	  end; {with}
+	end; {with}
+      cvlcp := lcp;
+      ldattr := lattr;
+      if lattr.typtr <> nil then
+	if (lattr.typtr^.form > subrange)
+	  or CompTypes(realptr,lattr.typtr)
+	  or CompTypes(longptr,lattr.typtr) then begin
+	  Error(68);
+	  lattr.typtr := nil;
+	  end;
+      InSymbol;
+      end
+    else begin
+      Error(2);
+      Skip(fsys + [becomes,tosy,downtosy,dosy]);
+      end;
+    {evaluate the start value for the loop}
+    if sy = becomes then begin
+      InSymbol;
+      Expression(fsys + [tosy,downtosy,dosy],fprocp);
+      if gattr.typtr <> nil then begin
+	if gattr.typtr^.form = subrange then
+	  gattr.typtr := gattr.typtr^.rangetype;
+	if gattr.typtr^.form <> scalar then
+          Error(69)
+	else if CompTypes(lattr.typtr,gattr.typtr) then begin
+	  lattr2 := lattr;
+	  if gattr.kind = cst then begin
+	    startConst := true;
+	    startVal := gattr.cval.ival;
+	    end {if}
+	  else begin
+	    startConst := false;
+	    with gattr do
+	      if (kind = expr) or ((kind = varbl) and (access <> drct)) then
+		begin
+		Load;
+		llb := GetTemp(intsize);
+		llb1Used := true;
+		Gen3t(pc_str, llb, 0, 0, cgWord);
+                isPacked := false;
+		kind := varbl;
+		access := drct;
+		vlevel := level;
+		dplab := llb;
+		firstExpr := true;
+		end; {with}
+	    end; {else}
+	  sattr := gattr;
+	  end {else if}
+	else
+          Error(70);
+	end; {if}
+      {evaluate the loop condition and stop point}
+      if sy in [tosy,downtosy] then begin
+	lsy := sy;
+	InSymbol;
+	Expression(fsys + [dosy],fprocp);
+	if gattr.typtr <> nil then begin
+	  if gattr.typtr^.form = subrange then
+	    gattr.typtr := gattr.typtr^.rangetype;
+	  if gattr.typtr^.form <> scalar then
+            Error(69)
+	  else if CompTypes(lattr.typtr,gattr.typtr) then begin
+	    if gattr.kind = cst then begin
+	      endConst := true;
+	      endVal := gattr.cval.ival;
+	      end
+	    else begin
+	      endConst := false;
+	      Load;
+	      {make room for the end value on the stack frame}
+	      llb2 := GetTemp(intsize);
+	      llb2Used := true;
+	      Gen3t(pc_str, llb2, 0, 0, cgWord);
+	      end;
+	    {initialize the loop variable}
+	    gattr := sattr;
+	    if firstExpr then
+	      Gen3t(pc_lod, gattr.dplab, 0, 0, cgWord)
+	    else
+	      Load;
+	    Store(lattr);
+	    if (not startConst) or (not endConst) then begin
+	      {check for a skip of the entire body}
+	      gattr := ldattr;
+	      Load;
+	      if endConst then
+		Gen1t(pc_ldc, endVal, cgWord)
+	      else
+	        Gen3t(pc_lod, llb2, 0, 0, cgWord);
+	      if lsy = downtosy then
+                if isunsigned then
+                   Gen0t(pc_geq, cgUWord)
+                else
+                   Gen0t(pc_geq, cgWord)
+              else
+                if isunsigned then
+                  Gen0t(pc_leq, cgUWord)
+		else
+                  Gen0t(pc_leq, cgWord);
+	      Gen1(pc_fjp, lab2);
+	      end {if}
+	    else if lsy = tosy then begin
+	      if endVal < startVal then
+		Gen1(pc_ujp, lab2);
+	      end {else if}
+	    else
+	      if endVal > startVal then
+		Gen1(pc_ujp, lab2);
+	    Gen1(dc_lab, lab1);
+	    end {else if}
+	  else
+            Error(70);
+	  end {if}
+	end
+      else begin
+	Error(27);
+	Skip(fsys + [dosy]);
+	end; {else}
+      {must find the closing do}
+      Match(dosy,26);
+      {compile the body of the loop}
+      StartStruct;
+      Statement(fsys,fprocp,stlevel,starray);
+      EndStruct;
+      if endConst then begin
+	{handle a constant stop condition}
+	{update the control var}
+	gattr := lattr;
+	Load;
+	if lsy = tosy then
+          Gen1t(pc_inc, 1, cgWord)
+	else
+          Gen1t(pc_dec, 1, cgWord);
+	Store(lattr);
+	{branch if not done}
+	gattr := lattr;
+	Load;
+	if lsy = tosy then
+	  Gen1t(pc_ldc, endVal+1, cgWord)
+	else
+	  Gen1t(pc_ldc, endVal-1, cgWord);
+	Gen0t(pc_equ, cgWord);
+	Gen1(pc_fjp, lab1);
+	end
+      else begin
+	{handle a constant end condition}
+	{branch if done}
+	gattr := lattr;
+	Load;
+	Gen3t(pc_lod, llb2, 0, 0, cgWord);
+	Gen0t(pc_neq, cgWord);
+	Gen1(pc_fjp, lab2);
+	{update the control var}
+	gattr := lattr;
+	Load;
+	if lsy = tosy then
+          Gen1t(pc_inc, 1, cgWord)
+	else
+          Gen1t(pc_dec, 1, cgWord);
+	Store(lattr);
+	{back to the top}
+	Gen1(pc_ujp, lab1);
+	end;
+      Gen1(dc_lab, lab2);
+      {remove the end value's space from the used part of the stack frame}
+      if llb1Used then
+        FreeTemp(llb, intsize);
+      if llb2Used then
+        FreeTemp(llb2, intsize);
+      {allow reuse of this var as a control var}
+      cvlcp^.vcontvar := false;
+      end
+    else begin
+      Error(23);
+      Skip(fsys + [semicolon]);
+      end;
+    end; {ForStatement}
+ 
+    procedure WithStatement;
+    {compile the with statement}
+
+    var
+      form: structform;			{kind of with (records or objects)}
+      isMethod: boolean;		{dummy for selector call}
+      lcp: ctp;
+      llb: unsigned;			{for reserving work space}
+      llbUsed: boolean;			{was llc used?}
+      name: pStringPtr;			{name of the record being with-ed}
+      test: boolean;			{test for loop termination}
+      len: integer;			{string length}
+      oldtop: integer;			{old top value}
+
+    begin {WithStatement}
+    llbUsed := false;
+    oldtop := top;
+    repeat
+      if sy = ident then begin
+        len := ord(id[0])+2;
+        name := pointer(Malloc(len));
+	CopyString(name^,id,len);
+	SearchId([varsm,field],lcp);
+	InSymbol;
+	end
+      else begin
+	Error(2);
+	lcp := uvarptr;
+	name := nil;
+	end;
+      Selector(fsys + [comma,dosy], lcp, fprocp, isMethod);
+      if gattr.typtr <> nil then begin
+        form := gattr.typtr^.form;
+	if form in [records,objects] then
+	  if top < displimit then begin
+	    top := top+1;
+	    with display[top] do begin
+	      cname := pointer(ord4(@'  ')+1);
+              if form = records then
+		fname := gattr.typtr^.fstfld
+              else
+		fname := gattr.typtr^.objfld;
+	      flabel := nil;
+	      ispacked := gattr.typtr^.ispacked = pkpacked;
+	      end; {with}
+	    if (gattr.access = drct) and (form = records) then
+	      with display[top] do begin
+		occur := crec;
+		labsused := nil;
+		clev := gattr.vlevel;
+		if display[disx].occur = crec then
+		  cname := display[disx].cname
+		else
+		  cname := name;
+		name := nil;
+		cdspl := gattr.dpdisp;
+		clab := gattr.dplab;
+		end
+	    else begin
+              if gattr.access = drct {and (form = objects)} then
+                Load
+              else
+	        LoadAddress;
+	      llb := GetTemp(ptrsize);
+	      llbUsed := true;
+	      if level <= 1 then
+		Gen3t(pc_str, llb, 0, level-1, cgULong)
+	      else
+		Gen3t(pc_str, llb, 0, 0, cgULong);
+	      with display[top] do begin
+		labsused := nil;
+		occur := vrec;
+		vdsplab := llb;
+		end; {with}
+	      end; {else}
+	    end {if}
+	  else
+            Error(107)
+	else
+          Error(65);
+        end; {if}
+      test := sy <> comma;
+      if not test then
+        InSymbol;
+    until test;
+    Match(dosy,26);
+    StartStruct;
+    Statement(fsys,fprocp,stlevel,starray);
+    EndStruct;
+    if llbUsed then
+      FreeTemp(llb, ptrsize);
+    top := oldtop;
+    end; {WithStatement}
+
+
+  begin {Statement}
+  if sy = intconst then begin
+    {define a label for gotos}
+    llp := display[level].flabel;
+    while llp <> nil do
+      with llp^ do
+	if labval = val.ival then begin
+	  if defined then Error(87);
+	  if labname > firstlab then
+            Gen1(dc_lab, labname)
+	  else begin
+	    MakeLab(fcp,labname);
+	    Gen0name(dc_lab, fcp^.name);
+	    end;
+	  defined := true;
+	  if lstlevel <> 0 then
+	    if stlevel > lstlevel then Error(99)
+	    else
+	      for i := 1 to stlevel-1 do
+		if starray[i] <> lstarray[i] then begin
+		  Error(99);
+		  goto 1;
+		  end;
+	  lstlevel := stlevel;
+	  lstarray := starray;
+	  goto 1;
+	  end
+	else llp := nextlab;
+    Error(89);
+1:  InSymbol; Match(colon,5);
+    end;
+  if not (sy in fsys + [ident]) then begin
+    Error(6);
+    Skip(fsys);
+    end;
+
+  {if trace names are enabled and a line # is due, generate it}
+  if debugFlag or traceBack then
+    if lastline<>linecount then
+      if namFound then begin
+	lastline := linecount;
+	Gen2(pc_lnm, linecount, ord(debugType));
+	end;
+  if sy in statbegsys + [ident] then begin
+    case sy of
+      beginsy:	   begin InSymbol; CompoundStatement; end;
+      gotosy:	   begin InSymbol; GotoStatement; end;
+      ifsy:	   begin InSymbol; IfStatement; end;
+      casesy:	   begin InSymbol; CaseStatement; end;
+      whilesy:	   begin InSymbol; WhileStatement; end;
+      repeatsy:    begin InSymbol; RepeatStatement; end;
+      forsy:	   begin InSymbol; ForStatement; end;
+      withsy:	   begin InSymbol; WithStatement; end;
+      inheritedsy: begin InSymbol; InheritedCall(fsys, fprocp); end;
+      ident:	   begin
+		   SearchId([varsm,field,func,proc], lcp);
+		   InSymbol;
+		   if lcp^.klass = proc then
+                     Call(fsys, lcp, fprocp)
+		   else
+                     Assignment(lcp);
+		   end;
+      end;
+    {if the string heap was used, purge it}
+    if stringHeap then begin
+      stringHeap := false;
+      Gen0(pc_nop);
+      Gen1(pc_csp,92{dsh});
+      end;
+    {make sure the next token is legal}
+    if not (sy in [semicolon,endsy,elsesy,untilsy]) then begin
+      Error(6);
+      Skip(fsys);
+      end;
+    end;        
+  end; {Statement}
+ 
+  procedure Body (fsys: setofsys; fprocp: ctp);
+
+  { Compile the body of a procedure, function or program	}
+  {								}
+  { parameters:							}
+  {    fsys - follow symbols					}
+  {    fprocp - identifier for program or program-level		}
+  {       subroutine contining this statement			}
+  
+  var
+    llcp: ctp;
+    saveId: pStringPtr;			{program identifier name}
+    i: integer;
+    llbl: unsigned;
+    lcp: ctp;
+    llp: lbp;
+    fcp: csp;
+    fsp: stp;
+    plabel: unsigned;			{largest parameter label number}
+    size: unsigned;			{temp size}
+    stlevel: integer;
+    starray: starrtype;
+    test: boolean;
+    hasFiles: boolean;			{are there any files in the block?}
+
+    procedure GenLocals (lcp: ctp; pLab: unsigned);
+
+    { define non-array global variables				}
+    {								}
+    { parameters:						}
+    {   lcp - symbol table node					}
+    {   pLab - largest parameter label				}
+
+    begin {GenLocals}
+    if lcp <> nil then
+      with lcp^ do begin
+	GenLocals(rlink, pLab);
+	GenLocals(llink, pLab);
+	if klass = varsm then
+          if vlabel > pLab then 
+            Gen2(dc_loc, vlabel, long(idtype^.size).lsw);
+	end; {with}
+    end; {GenLocals}
+
+
+    procedure OpenFiles (lcp: ctp);
+
+    { open all files in the block				}
+    {								}
+    { parameters:						}
+    {   lcp - symbol table node					}
+    
+    begin {OpenFiles}
+    if lcp <> nil then
+      with lcp^ do begin
+	OpenFiles(rlink);
+	OpenFiles(llink);
+	if hasIFile then
+	  if klass = varsm then begin
+	    hasFiles := true;
+	    Gen1t(pc_ldc, ord(idtype^.size), cgUWord);
+            Gen0t(pc_stk, cgWord);
+	    with gattr do begin
+	      typtr := idtype;
+	      access := drct;
+              isPacked := false;
+	      kind := varbl;
+	      vlevel := vlev;
+              dpdisp := 0;
+	      if vlev <> 1 then
+                dplab := vlabel;
+	      aname := name;
+	      end; {with}
+	    LoadAddress;
+            Gen0t(pc_stk, cgULong);
+            Gen0t(pc_bno, cgULong);
+	    Gen1(pc_csp,35{clr});
+	    end; {if}
+      end; {with}
+    end; {OpenFiles}
+
+
+    procedure WithSelf;
+
+    { Fake a "with self do begin" for methods			}
+
+    var
+      form: structform;			{kind of with (records or objects)}
+      lid: pString;			{copy of id}
+      lcp: ctp;				{object type}
+
+    begin {WithSelf}
+    lid := id;
+    id := 'SELF';
+    SearchId([varsm,field],lcp);
+    if lcp <> nil then
+      if lcp^.idtype <> nil then begin
+	form := lcp^.idtype^.form;
+	if form in [records,objects] then
+	  if top < displimit then begin
+	    top := top+1;
+	    with display[top] do begin
+	      isPacked := lcp^.idtype^.ispacked = pkpacked;
+	      labsused := nil;
+              if form = records then
+		fname := lcp^.idtype^.fstfld
+              else
+		fname := lcp^.idtype^.objfld;
+	      flabel := nil;
+              occur := vrec;
+              vdsplab := lcp^.vlabel;
+	      end; {with}
+	    end {if}
+	  else
+            Error(107)
+	else
+          Error(65);
+	end; {if}
+    id := lid;
+    end; {WithSelf}
+
+
+  begin {Body}
+  namFound := false;			{turn line #s off}
+  for stlevel := 1 to maxgoto do
+    starray[stlevel] := 0;
+  stlevel := 1;
+  if level = 1 {program block} then begin
+    Gen2Name(dc_str, $4000+$8000*ord(isDynamic), 0, fprocp^.name);
+    inseg := true;
+    end
+  else if level = 2 {entry of level 1 procedure} then
+    Gen0(dc_pin)
+  else {imbeded procedure}
+    Gen1(dc_lab, fprocp^.pfname);
+  Gen0(pc_ent);				{create a stack frame}
+  ResetTemp;				{forget old temporary variables}
+
+  lcp := fprocp^.pfparms;		{generate code for passed parameters}
+  plabel := 0;
+  while lcp <> nil do
+    with lcp^ do begin
+      if klass = varsm then begin
+	if idtype <> nil then
+	  if idtype^.form > power then begin
+            {handle variables always passed as pointers}
+	    if vkind = actual then begin
+	      if (idtype^.form = records) and (idtype^.size <= 4) then begin
+                {short records are passed by value}
+		if idtype^.size <= 2 then
+		  size := 2
+		else
+                  size := 4;
+		psize := psize-size;
+                Gen3(dc_prm, vlabel, size, psize);
+		end {if}
+              else if idtype^.form = objects then begin
+	        psize := psize-ptrsize;
+                Gen3(dc_prm, vlabel, ptrsize, psize);
+                end {else if}
+              else begin
+	        psize := psize-ptrsize;
+                size := long(idtype^.size).lsw;
+                Gen3(dc_prm, vlabel-1, ptrsize, psize);
+                Gen2(dc_loc, vlabel, size);
+		Gen3(pc_lda, vlabel, 0, 0);
+		Gen3t(pc_lod, vlabel-1, 0, 0, cgULong);
+		Gen2(pc_mov, 0, size);
+                end; {else}
+	      end {if}
+            else begin
+	      psize := psize-ptrsize;
+              Gen3(dc_prm, vlabel, ptrsize, psize);
+              end; {else}
+	    end {else if}
+	  else if vkind = actual then begin
+	    if IsReal(idtype) then begin
+	      psize := psize-extSize;
+              Gen3(dc_prm, vlabel, extSize, psize);
+              if GetType(idtype, false) <> cgExtended then
+	        Gen1t(pc_fix, vlabel, GetType(idtype, false));
+	      end
+	    else if idtype = byteptr then begin
+	      psize := psize-intSize;
+              Gen3(dc_prm, vlabel, intSize, psize);
+              end {else if}
+	    else begin
+              size := long(idtype^.size).lsw;
+	      psize := psize-size;
+              Gen3(dc_prm, vlabel, size, psize);
+              end; {else}
+	    end
+	  else begin
+	    psize := psize-ptrsize;
+            Gen3(dc_prm, vlabel, ptrsize, psize);
+            end; {else}
+	if vlabel > plabel then
+          plabel := vlabel;
+	end {if}
+      else if klass in [proc,func] then begin
+	psize := psize-procsize;
+        Gen3(dc_prm, pflabel, procsize, psize);
+	if pflabel > plabel then
+          plabel := pflabel;
+        end; {else if}
+      lcp := lcp^.next;                      
+      end; {with}
+  if fprocp^.klass = func then begin	{generate the function label}
+    case GetType(fprocp^.idtype, false) of
+      cgByte,cgUByte,
+      cgWord,cgUWord:   size := cgWordSize;
+      cgLong,cgULong:   size := cgLongSize;
+      cgReal:           size := cgRealSize;
+      cgDouble:         size := cgDoubleSize;
+      cgComp:           size := cgCompSize;
+      cgExtended:       size := cgExtendedSize;
+      otherwise:	size := 0;
+      end; {case}     
+    Gen2(dc_fun, fprocp^.pflabel, size);
+    if fprocp^.pflabel > plabel then
+      plabel := fprocp^.pflabel;
+    end; {if}
+  if level <> 1 then			{generate space for local variables}
+     GenLocals(display[top].fname, plabel);
+
+					{record the current procedure name}
+  if debugFlag or profileFlag or traceBack then begin
+    fcp := pointer(Malloc(sizeof(constantRec)));
+    with fcp^ do begin
+      cclass := strg;
+      sval := fprocp^.name^;
+      end; {with}
+    GenPS(pc_nam, fprocp^.pfoname);
+    namFound := true; {turn line #s on}
+    end; {if}
+					{give the symbol table to the code }
+					{ generator.			   }
+  if debugFlag then
+    Gen1Name(dc_sym, 0, pointer(display[top].fname));
+  if fprocp^.klass = prog then begin
+    new(saveId);
+    saveId^ := id;
+    while fextfilep <> nil do begin
+      with fextfilep^ do
+	if not ((CompNames(filename^,inputid) = 0) or
+	  (CompNames(filename^,outputid) = 0) or
+	  (CompNames(filename^,erroroutputid) = 0)) then begin
+	  id := filename^;
+	  SearchSection(display[1].fname,llcp);
+	  if llcp = nil then begin
+	    write('**** Undeclared external variable: ', filename^);
+	    FlagError;
+	    end
+	  else if llcp^.klass in [proc,func] then begin
+	    write('**** External variable cannot be procedure or function: ',
+               filename^);
+	    FlagError;
+	    end;
+	  end;
+      fextfilep := fextfilep^.nextfile;
+      end;
+    id := saveId^;
+    dispose(saveId);
+    end;
+  if isMethod then			{do "with self do begin"}
+    WithSelf;
+  hasFiles := false;			{initialize all file variables}
+  OpenFiles(display[top].fname);
+  if hasFiles then begin
+    {create a new file record level}
+    Gen0(pc_nop);
+    Gen1(pc_csp,96{orc});
+    end;
+  repeat				{compile the statements in the body}
+    repeat
+      Statement(fsys+[semicolon,endsy],fprocp,stlevel,starray);
+    until not (sy in statbegsys);
+    test := sy <> semicolon;
+    if not test then
+      InSymbol;
+  until test;
+  Match(endsy,13);
+  llp := display[top].flabel;		{test for undefined labels}
+  while llp <> nil do
+    with llp^ do begin
+      if not defined then begin
+	write('**** undefined label: ',labval:1);
+	FlagError;
+	end;
+      llp := nextlab;
+      end;
+  if hasFiles then begin		{close all files opened in this block}
+    Gen0(pc_nop);
+    Gen1(pc_csp,97{crc});
+    end;
+  if fprocp^.klass <> func then		{return to caller}
+    Gen0t(pc_ret, cgVoid)
+  else
+    Gen0t(pc_ret, GetType(fprocp^.idtype, false));
+  if level <= 2 then begin		{finish the segment}
+    Gen0(dc_enp);
+    intlabel := firstlab;
+    inseg := false;
+    if fprocp^.klass in [proc,func] then begin
+      release(fprocp^.pfmark);
+      code := pointer(Calloc(sizeof(intermediate_code)));
+      end;
+    end;
+  if isMethod then			{do "end" for "with self do begin"}
+    top := top-1;
+  end; {Body}
+ 
+  procedure DoBlock {fsys: setofsys; fsy: symbol; fprocp: ctp;
+     isProgram: boolean};
+  {compile a block}
+
+  label 1;
+
+  const
+    returnSize = 3;			{size of a return address}
+
+  var
+    actuallc: addrrange; 		{used when updating actual parm locs}
+    lsy: symbol; 			{temp symbol}
+    foundBody: boolean;			{dummy var for ProcDeclaration}
+    lisMethod: boolean;			{copy of isMethod}
+    lcp: ctp;				{work pointer}
+    procName: pStringPtr;		{name of proc being compiled}
+
+
+    procedure CheckForw(lcp: ctp);
+
+    begin {CheckForw}
+    if lcp<>nil then with lcp^ do begin
+      CheckForw(rlink);
+      CheckForw(llink);
+      if (klass in [proc,func]) and (pfkind = actual) then
+	if pfdirective = drforw then begin
+	  write('**** forward ref not resolved: ', name^);
+	  FlagError;
+	  end;
+      end;
+    end; {CheckForw}
+
+
+    function ShouldBeCompiled(fsy: symbol): boolean;
+    {check to see if a level 1 proc should be compiled; skip if not}
+
+    var
+      foundBody: boolean;		{did the proc have a body}
+      llist: boolean;			{local list flag}
+
+
+      function InPartialList(var name: pString): boolean;
+
+      { see if a name is in the partial compile list		}
+      {								}
+      { parameters:						}
+      {    name - name to check					}
+      {								}
+      { returns: True if the name is in the list, else false	}
+      {								}
+      { Note: name is var to save space - it is not changed	}
+
+      label 1;
+
+      var
+	ptr,lptr: partialptr;
+
+      begin {InPartialList}
+      InPartialList := true;
+      ptr := partialList;
+      lptr := nil;
+      while ptr <> nil do begin
+	with ptr^ do
+	  if CompNames(name, pname^) = 0 then goto 1;
+	lptr := ptr;
+	ptr := ptr^.next;
+	end; {while}
+      InPartialList := false;
+      1:
+      end; {InPartialList}
+
+
+      procedure SkipProc;
+      {skip a procedure or function}
+
+      var
+	cnt: integer;			{# ends needed}
+	lcp: ctp;			{work pointer for skipping forwards}
+
+      begin {SkipProc}
+      {skip to the first function or procedure, or the body}
+      while (not eofl) and (not(sy in [beginsy,procsy,funcsy])) do
+	InSymbol;
+      {skip all of the procedure and function declarations}
+      while sy in [procsy,funcsy] do begin
+	{skip to the parameter list or the end of the header}
+	while (not eofl) and (not (sy in [lparent,semicolon])) do InSymbol;
+	{if there is a header, skip it}
+	if sy = lparent then begin
+	  InSymbol;
+	  cnt := 1;
+	  while (cnt > 0) and (not eofl) do begin
+	    if sy = lparent then cnt := cnt+1
+	    else if sy = rparent then cnt := cnt-1;
+	    InSymbol;
+	    end;
+	  end;
+	{skip the function return type, if any}
+	while (sy <> semicolon) and (not eofl) do InSymbol;
+	InSymbol;
+	{if the declaration has no block, skip the identifiers (forward, etc)}
+	if sy = ident then begin
+	  SearchId([directive],lcp);
+	  InSymbol;
+	  if sy = lparent then begin
+	    while (sy <> rparent) and (not eofl) do InSymbol;
+	    InSymbol;
+	    end;
+	  Match(semicolon,14);
+	  end
+	{for procedures with a block, skip it here}
+	else
+	  SkipProc;
+	end;
+      {skip the body}
+      Match(beginsy,17);
+      cnt := 1;
+      while (cnt > 0) and (not eofl) do begin
+	if sy in [beginsy,casesy] then
+	  cnt := cnt+1
+	else if sy = endsy then
+	  cnt := cnt-1;
+	InSymbol;
+	end;
+      Match(semicolon,14);
+      end; {SkipProc}
+
+    begin {ShouldBeCompiled}
+    if InPartialList(id) then
+      ShouldBeCompiled := true
+    else begin
+      ShouldBeCompiled := false;
+      {compile the header}
+      ProcDeclaration(fsy, fsys, false, false, foundBody);
+      {if there is a body, skip it}
+      if foundBody then begin
+	llist := list;
+	list := false;
+	SkipProc;
+	list := llist;
+	end;
+      end;
+    end; {ShouldBeCompiled}
+
+
+    procedure Remove(var name: pString);
+
+    { remove a name from the partial compile list		}
+    {								}
+    { parameters:						}
+    {    name - name to remove					}
+    {								}
+    { Note: name is var to save space - it is not changed	}
+
+    label 1;
+
+    var
+      ptr,lptr: partialptr;
+
+    begin {Remove}
+    ptr := partialList;
+    lptr := nil;
+    while ptr <> nil do begin
+      with ptr^ do
+	if CompNames(name,pname^) = 0 then begin
+	  if lptr = nil then
+	    partialList := next
+	  else
+	    lptr^.next := next;
+	  goto 1;
+	  end; {if}
+      lptr := ptr;
+      ptr := ptr^.next;
+      end; {while}
+    1:
+    end; {Remove}
+
+
+  begin {DoBlock}
+  {save the methods object, if any}
+  lisMethod := isMethod;
+
+  {handle declarations}
+  repeat
+    while sy = usessy do begin
+      InSymbol;
+      UsesDeclaration(fsys);
+      end; {while}
+    if sy = labelsy then begin
+      InSymbol;
+      LabelDeclaration(fsys);
+      if isProgram then
+	noGlobalLabels := false;
+      end; {if}
+    if sy = constsy then begin
+      InSymbol;
+      ConstDeclaration(fsys);
+      end; {if}
+    if sy = typesy then begin
+      InSymbol;
+      TypeDeclaration(fsys);
+      end; {if}
+    if sy = varsy then begin
+      InSymbol;
+      VarDeclaration(fsys);
+      end; {if}
+    {handle procedure, function declarations}
+    while sy in [procsy,funcsy] do begin
+      if level = 1 then
+	nextLocalLabel := 1;
+      lsy := sy;
+      InSymbol;
+      new(procName);
+      procName^ := id;
+      if (level > 1) or (not partial) then
+	ProcDeclaration(lsy, fsys, false, true, foundBody)
+      else if ShouldBeCompiled(lsy) then begin
+	{compile the header}
+	ProcDeclaration(lsy, fsys, false, true, foundBody);
+	{remove the name from the list of names to compile}
+	if foundBody and (not isMethod) then
+	  Remove(procName^);
+	if partialList = nil then begin
+	  eofl := true;
+	  sy := period;
+	  goto 1;
+	  end;
+	end;
+      dispose(procName);
+      end;
+    CheckForw(display[top].fname);
+    if not ((sy = beginsy) or (doingUnit and (sy = endsy))) then begin
+      Error(18);
+      Skip(fsys);
+      end;
+  until (sy in statbegsys) or (doingUnit and (sy = endsy)) or eofl;
+
+  {compile the body of the block}
+  if (not doingUnit) or (level > 1) then begin
+    if level = 1 then
+      nextLocalLabel := 1;
+    Match(beginsy,17);                            
+    repeat
+      isMethod := lisMethod;
+      Body(fsys + [casesy],fprocp);
+      if sy <> fsy then begin
+	Error(6);
+	Skip(fsys);
+	end;
+    until (sy = fsy) or (sy in blockbegsys) or eofl;
+    end; {if}
+1:
+  end; {DoBlock}
+ 
+  procedure Programme{fsys:setofsys};
+  {Compile a program}
+
+  var
+    fp,extfp,nextfp: extfilep;
+    lcp: ctp;
+    idname: pStringPtr;			{segment name}
+    noStart: boolean;			{has a start been generated?}
+    len: integer;			{string length}
+
+    procedure DoGlobals;
+    {declare the ~globals and ~arrays segments}
+
+    var
+      didone: boolean;			{did we generate at least one label?}
+
+      procedure GenArrays(lcp: ctp);
+
+      { define global arrays					}
+      {								}
+      { parameters:						}
+      {   lcp - stack frame to check for arrays			}
+
+      var
+        size: addrrange;		{size of the array}
+
+      begin {GenArrays}
+      if lcp <> nil then with lcp^ do begin
+	GenArrays(rlink);
+	GenArrays(llink);
+	if klass = varsm then
+	  if idtype^.form in [arrays,records] then
+	    if not fromUses then begin
+	      if noStart then begin
+		idName := @'~ARRAYS';
+		if smallMemoryModel then
+		  NextSegName('          ')
+		else
+		  NextSegName('~ARRAYS   ');
+		Gen2Name(dc_str, $4000, 1, idname);
+		noStart := false;
+		end;
+	      Gen2Name(dc_glb, 0, ord(vPrivate), name);
+              size := idtype^.size;
+              while size > maxint do begin
+                Gen1(dc_dst, $4000);
+                size := size-$4000;
+                end; {while}
+              Gen1(dc_dst, long(size).lsw);
+	      end;
+	end;
+      end; {GenArrays}
+
+      procedure GenGlobals(lcp: ctp);
+      {define non-array global variables}
+
+      begin {GenGlobals}
+      if lcp <> nil then with lcp^ do begin
+	GenGlobals(rlink);
+	GenGlobals(llink);
+	if klass = varsm then
+	  if not (idtype^.form in [arrays,records]) then
+	    if not fromUses then begin
+	      Gen2Name(dc_glb, long(idtype^.size).lsw, ord(vPrivate), name);
+	      didone := true;
+	      end; {if}
+	end;
+      end; {GenGlobals}
+
+    begin {DoGlobals}
+    {declare the ~globals segment, which holds non-array data types}
+    idName := @'~GLOBALS';
+    if smallMemoryModel then
+      NextSegName('          ')
+    else
+      NextSegName('~GLOBALS  ');
+    Gen2Name(dc_str, $4000, 0, idname);
+    didone := false;
+    GenGlobals(display[1].fname);
+    if not didone then
+      if not smallMemoryModel then
+	Gen2Name(dc_glb, 1{byte}, 1{private}, @'~');
+    Gen0(dc_enp);
+    {declare the ~arrays segment, which holds global arrays}
+    noStart := true;
+    GenArrays(display[1].fname);
+    if not noStart then
+      Gen0(dc_enp);
+    end; {DoGlobals}
+
+    procedure InterfacePart;
+    {compile the interface part of a unit}
+
+    var
+      lsy: symbol;			{temp symbol}
+      foundBody: boolean;		{dummy var for ProcDeclaration}
+ 
+    begin {InterfacePart}
+    repeat
+      {handle declarations}
+      while sy = usessy do begin InSymbol; UsesDeclaration(fsys); end;
+      if sy = constsy then begin InSymbol; ConstDeclaration(fsys); end;
+      if sy = typesy then begin InSymbol; TypeDeclaration(fsys); end;
+      if sy = varsy then begin InSymbol; VarDeclaration(fsys); end;
+      {handle procedure, function declarations}
+      while sy in [procsy,funcsy] do begin
+	lsy := sy;
+	InSymbol;
+	{compile the header}
+        nextLocalLabel := 1;
+	ProcDeclaration(lsy, fsys+[implementationsy], false, true, foundBody);
+	if foundBody then
+	  Error(120);
+	end;
+      if sy <> implementationsy then begin
+	Skip([period]);
+	InSymbol;
+	end;
+    until (sy = implementationsy) or eofl;
+    end; {InterfacePart}
+
+  begin {Programme}
+  progfound := true;
+					{create the main program name}
+  lcp := pointer(Malloc(sizeof(identifier)));
+  with lcp^ do begin
+    name := @'~_PASMAIN';
+    idtype := nil;
+    next := nil;
+    klass := prog;
+    pfname := 0;
+    pfoname := name;
+    pfactualsize := 0;
+    pfparms := nil;
+    hasIFile := false;
+    end;
+  EnterId(lcp);
+  if sy = progsy then begin {compilation of a program}
+    if kNameGS.theString.size <> 0 then {start output files}
+      CodeGenInit(kNameGS, keepflag, partial);
+    InSymbol;
+    Match(ident,2);
+    {compile the program's parameter list}
+    if sy = lparent then begin
+      nextfp := nil;
+      repeat
+	InSymbol;
+	if sy = ident then begin
+          extfp := pointer(Malloc(sizeof(filerec)));
+	  with extfp^ do begin
+            len := ord(id[0])+2;
+            filename := pointer(Malloc(len));
+	    CopyString(filename^,id,len);
+	    nextfile := nil;
+	    end;
+	  fp := fextfilep;
+	  while fp <> nil do begin
+	    if CompNames(fp^.filename^,id) = 0 then
+              Error(30);
+	    fp := fp^.nextfile;
+	    end;
+	  if nextfp <> nil then nextfp^.nextfile := extfp;
+	  nextfp := extfp;
+	  if fextfilep = nil then fextfilep := extfp;
+	  if CompNames(id,inputid) = 0 then noinput := false;
+	  if CompNames(id,outputid) = 0 then nooutput := false;
+	  if CompNames(id,erroroutputid) = 0 then noerroroutput := false;
+	  InSymbol;
+	  if not (sy in [comma,rparent]) then Error(20);
+	  end
+	else Error(2);
+      until sy <> comma;
+      if sy <> rparent then Error(4);
+      InSymbol;
+      end;
+    Match(semicolon,14);
+    {compile the block}
+    repeat DoBlock(fsys,period,lcp,true);
+      if sy <> period then Error(21);
+    until (sy = period) or eofl;
+    end
+  else begin {compilation of a unit}
+    noInput := false;			{allow all I/O}
+    noOutput := false;
+    noErrorOutput := false;
+    doingUnit := true;			{note that this is a unit}
+    if kNameGS.theString.size <> 0 then {start output files}
+      CodeGenInit(kNameGS, keepflag, partial);
+    Match(unitsy,3);			{compile the header}
+    Match(ident,2);
+    Match(semicolon,14);
+    doingInterface := true;		{compile the interface part}
+    Match(interfacesy,119);
+    InterfacePart;
+    doingInterface := false;
+    CloseToken;
+    Match(implementationsy,118); 	{compile the implementation part}
+    DoBlock(fsys,period,lcp,true);
+    if not ((sy = period) and eofl) then begin
+      Match(endsy,13);
+      if sy <> period then begin
+        Error(21);
+        if allTerm then
+          while (errinx <> 0) and (not eofl) do
+            InSymbol;
+        end; {if}
+      end;
+    end;
+  DoGlobals;				{declare the global variables}
+  end; {Programme}
+ 
+{----Initialization-------------------------------------------------------}
+
+  procedure InitScalars;
+  {Initialize global scalars}
+
+  var
+    i: integer;
+
+  begin {InitScalars}
+  level := 0; top := 0;			{set up level 0 frame}
+  with display[0] do begin
+     fname := nil;
+     flabel := nil;
+     labsused := nil;
+     occur := blck;
+     ispacked := false;
+     end; {with}
+  display[1] := display[0];
+
+  code := pointer(Calloc(sizeof(intermediate_code)));
+  {code^.lab := nil;}
+  fwptr := nil;
+  fextfilep := nil;
+  thisType := nil;			{not declaring a type}
+  tempList := nil; 			{no temp variables}
+  nextLocalLabel := 1;			{reset local label count}
+  numerr := 0;				{no errors found}
+  errinx := 0;
+  intlabel := 0;
+  linecount := 0;			{no lines processed}
+  lastline := 0;
+  firstlab := 0;
+  eofl := false; 			{not at end of file}
+  iso := false;				{don't enforce iso}
+  progfound := false;			{program symbol not found}
+  inseg := false;
+  debug := false;			{don't generate check code}
+  inUses := false;
+  stringHeap := false;
+  namFound := false;
+  isDynamic := false;			{segments are not dynamic}
+  isMethod := false;			{not doing a method}
+  doingInterface := false;		{not doing interface part}
+  doingUnit := false;			{not doing a unit}
+  doingCast := false;			{not casting an expression}
+  noGlobalLabels := true;		{no program level labels found so far}
+  prterr := true;
+  noinput := true;
+  nooutput := true;
+  noerroroutput := true;
+  psize := 0;				{no parameters at the program level}
+  ch := ' ';
+  code^.optype := cgWord;
+  gattr.aname := pointer(Malloc(maxCnt+1));
+
+  inputid := 'INPUT';
+  outputid := 'OUTPUT';
+  erroroutputid := 'ERROROUTPUT';
+  end; {InitScalars}
+ 
+  procedure InitSets;
+  {initialize structured set constants}
+
+  begin {InitSets}
+  constbegsys := [addop,intconst,realconst,stringconst,ident,nilsy,
+    longintconst];
+  simptypebegsys := [lparent] + constbegsys;
+  typebegsys:=[stringsy,arrow,packedsy,arraysy,recordsy,setsy,filesy,objectsy]
+    +simptypebegsys;
+  typedels := [arraysy,recordsy,setsy,filesy];
+  blockbegsys := [labelsy,constsy,typesy,varsy,procsy,funcsy,beginsy];
+  selectsys := [arrow,period,lbrack];
+  facbegsys := [intconst,realconst,stringconst,ident,lparent,bitnot,
+    nilsy,lbrack,notsy,atsy,longintconst,inheritedsy];
+  statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,withsy,casesy,
+    inheritedsy];
+  end {InitSets};
+ 
+end.
diff --git a/pascal.notes b/pascal.notes
old mode 100755
new mode 100644
index cbea926..ee47350
--- a/pascal.notes
+++ b/pascal.notes
@@ -1 +1,217 @@
-ORCA/Pascal 2.2
Copyright 1996, Byte Works Inc.

-- Change List --------------------------------------------------------------

2.2	    1.	Bugs fixed; see notes, below.

	    2.	Pascal supports the extended character set.  See "Extended
		Characters."

2.1	    1.	Bugs fixed; see notes, below.

	    2.  New optimization added for method calls.  See "New
		Optimization."

2.0.1	    1.	Bugs fixed; see notes, below.

-- Manual Errata ------------------------------------------------------------

p. 340

trunc4 returns a longint, so the definition line should read:

function trunc4 (x: real): longint;

p. 361

The ISO and ANSI compliance statements say that ORCA/Pascal 1.2 complies with the standards.  So do the other versions, including the current one.

p. 364

Add the following:

ORCA/Pascal supports Apple's extended ASCII character set, allowing use of non-ASCII characters in identifiers and supporting some special characters as substitutes for traditional mathematical operations.  See "Extended Characters" for implementation details.

p. 378

Under "Implementation Restrictions," delete these:

"2.  Arrays cannot be larger than 64K bytes long."

"3.  Records cannot be larger than 64K bytes long."

ORCA/Pascal supports both using the large memory model.  If you try to use a structure larger than 64K with the small memory model, you get a more specific error message telling you to switch memory models.

-- New Features -------------------------------------------------------------

New Optimization
----------------

There is a new optimization bit for the Optimize directive.  When bit 5 (value of 32, or $0020) is set, the compiler is allowed to perform optimizations that will generate code that is not ROMable.  Currently, the only optimization it performs is to use self-modifying code for method calls, resulting in code for the call that is about 1/3 faster and shorter than without this optimization.

WARNING:  Object Pascal code compiled with Pascal 2.1 and later is not compatible with Object Pascal code compiled with Pascal 2.0.  You must recompile the entire program and all libraries if the program or libraries involve objects.

Extended Characters
-------------------

Bear with me.  This is an ASCII file, and it describes non-ASCII material.

Beginning with version 2.1, the PRIZM desktop editor supports the full Apple extended character set.  A file called FontTest on the samples disk shows the complete character set, and also contains a table that shows how to type each character from a U.S. English keyboard.

Pascal supports the use of extended characters in strings, comments, identifiers, and for a few mathematical operations.

Any character you can type from PRIZM (or for that matter, any character with an ordinal value in [1..12, 14..255]) can appear in a string or comment.  The ordinal value of the character matches the values shown in FontTest, as well as several official Apple publications.  Keep in mind that many output devices, including Apple's text console driver, do not support all of these characters.  ORCA/Pascal will properly send extended characters to whatever output device you choose, but what happens when the output device tries to handle the character varies from device to device.

Many of the characters in the extended character set are used in languages oter than English, and are now allowed in identifiers.  There are two ways to think about which characters will work in an identifier.

The simple way is to remember that all characters that look like a graphically modified ASCII alphabetic character or a Greek alphabetic character are allowed in identifiers.  For example, an a with two dots above it is now legal in an identifier.

The more exact, and naturally more complicated way to think about which characters are allowed in an identifier is to list all of them.  Since this is an ASCII file, I'll list the ordinal values--you can cross reference the values in FontTest.  The ordinal values of the extended characters that are allowed in identifiers are [$80..$9F, $A7, $AE, $AF, $B4..$B9, $BB..$BF, $C4, $C6, $CB..$CF, $D8, $DE, $DF].

In addition, ORCA/Pascal supports several extended characters as shortcuts for multi-character mathematical operations.  These are:

	ordinal value	description		substitutes for
	-------------	-----------		---------------
	$C7		two <			<<
	$C8		two >			>>
	$AD		not equal		<>
	$B2		less than or equal	<=
	$B3		greater than or equal	>=
	$D6		division (- with dots)	div

Finally, the non-breaking space, sometimes called the sticky space (ordinal value $CA), is treated exactly like a standard space character.

-- Bugs from Pascal 2.1 that are fixed in Pascal 2.2 ------------------------

1. Incorrect code was generated for compares of objects.  For example, if obj1 and obj2 are object variables,

	if obj1 = nil then ...

and

	if obj1 <> obj2 then ...

both generated incorrect code.

2. A bug in error reporting has been corrected.  For some rare errors, the compiler incremented the error count but did not print the error message.

3. Eof and eoln have not worked for the standard input file since the switch to the .CONSOLE driver.  They do, now.

(Jason)

4. When a Read of a real value encounters a character sequence that starts with a character that can't be a part of a real number, as in

   var
      r: real;

   begin
   read(r);

with input of

   a

should generate a run-time error.  In ORCA/Pascal 2.1, this error was not detected.

(Rick Prest)

5. Reading a value into an array element or a pointer, as in

   read(readValue[4])

did not always work correctly.

(Rick Prest)

6. Ord4 did not report an error when used on a nonscalar value, as in ord4(3.4).

7. When the +t +e flags were used and too many END statements caused the compiler to flag a "'.' expected" error, the error was not reported properly.  The file name and error message were garbage when the editor was called, resulting in a blank file with an error message containing random characters.

8.  Code generation has been improved for optimized code when a value is stored through a global pointer.

9.  Loads of double values were not performed correctly by the FPE version of the SysFloat library, resulting in a large loss of precision.

(Soenke Behrens, Dirk Froehling, Frank Gizinski)

10.  With output redirected to a file and input comming from the keyboard, pressing the return key echoed the return that should have shown up on the screen to the output file.

(Soenke Behrens, David Empson)

-- Bugs Fixed from Pascal 2.0.1 ---------------------------------------------

1. The compiler flagged a compile error when debug code was generated for a variable that was declared as a type where the type was a pointer to a record, as in

	type
	   r = record
	      i: integer;
	      end;
	   rp = ^r;

	var
	   p: rp;

2. Objects could not be packed; now they can.

3. It is now possible to compare an object to nil using the equality and inequality comparisons (= and <>).

4. Stores to boolean and character fields within an object intermitantly saved only one byte, when they should have saved two bytes.

5. String constants in the interface part of a unit did not resolve properly when used from another unit or the main program.

(Ken Kazinski)

-- Bugs Fixed from Pascal 2.0.0 ---------------------------------------------

1. With optimizations on, assigning the same constant to both a byte and word
could generate code that did not correctly set the most significant byte of
the word.

(GNOTim2)

2. In some cases, successive stores of the same long constant to two different
locations with common subexpression elimination turned on would damage the
stack.

(GNOTim2)

3. In some conditional branches involcing comples integer expressions, the
condition code was not properly evaluated.

(GNOTim2)

4. Optimization of arithmetic shifts by a constant in the range 9..15 has been
improved.

(GNOTim2)

5. Text programs didn't work when launched from the Finder.

(JamesG7858)

6. On page 250, the manual shows parameter lists for overridden methods,
like this:

   cube = object (box)
      front, back: integer;
      function Volume: integer;
      procedure Fill (ptop, pleft, pbottom, pright,
                      pfront, pback: integer); override;
      procedure Grow (size: integer); override;
      end;

This is incorrect.  When you override a method, the parameter lists must
match.  As with forward procedures in Standard Pascal, ORCA/Pascal flags an
error when you redefine the method list.  The correct way to declare this class
is:

   cube = object (box)
      front, back: integer;
      function Volume: integer;
      procedure Fill; override;
      procedure Grow; override;
      end;
   
(Daniel B. Johnson)

7.  The {$rtl} pragma was not exiting with an RTL.
\ No newline at end of file
+ORCA/Pascal 2.2
+Copyright 1996, Byte Works Inc.
+
+-- Change List --------------------------------------------------------------
+
+2.2	    1.	Bugs fixed; see notes, below.
+
+	    2.	Pascal supports the extended character set.  See "Extended
+		Characters."
+
+2.1	    1.	Bugs fixed; see notes, below.
+
+	    2.  New optimization added for method calls.  See "New
+		Optimization."
+
+2.0.1	    1.	Bugs fixed; see notes, below.
+
+-- Manual Errata ------------------------------------------------------------
+
+p. 340
+
+trunc4 returns a longint, so the definition line should read:
+
+function trunc4 (x: real): longint;
+
+p. 361
+
+The ISO and ANSI compliance statements say that ORCA/Pascal 1.2 complies with the standards.  So do the other versions, including the current one.
+
+p. 364
+
+Add the following:
+
+ORCA/Pascal supports Apple's extended ASCII character set, allowing use of non-ASCII characters in identifiers and supporting some special characters as substitutes for traditional mathematical operations.  See "Extended Characters" for implementation details.
+
+p. 378
+
+Under "Implementation Restrictions," delete these:
+
+"2.  Arrays cannot be larger than 64K bytes long."
+
+"3.  Records cannot be larger than 64K bytes long."
+
+ORCA/Pascal supports both using the large memory model.  If you try to use a structure larger than 64K with the small memory model, you get a more specific error message telling you to switch memory models.
+
+-- New Features -------------------------------------------------------------
+
+New Optimization
+----------------
+
+There is a new optimization bit for the Optimize directive.  When bit 5 (value of 32, or $0020) is set, the compiler is allowed to perform optimizations that will generate code that is not ROMable.  Currently, the only optimization it performs is to use self-modifying code for method calls, resulting in code for the call that is about 1/3 faster and shorter than without this optimization.
+
+WARNING:  Object Pascal code compiled with Pascal 2.1 and later is not compatible with Object Pascal code compiled with Pascal 2.0.  You must recompile the entire program and all libraries if the program or libraries involve objects.
+
+Extended Characters
+-------------------
+
+Bear with me.  This is an ASCII file, and it describes non-ASCII material.
+
+Beginning with version 2.1, the PRIZM desktop editor supports the full Apple extended character set.  A file called FontTest on the samples disk shows the complete character set, and also contains a table that shows how to type each character from a U.S. English keyboard.
+
+Pascal supports the use of extended characters in strings, comments, identifiers, and for a few mathematical operations.
+
+Any character you can type from PRIZM (or for that matter, any character with an ordinal value in [1..12, 14..255]) can appear in a string or comment.  The ordinal value of the character matches the values shown in FontTest, as well as several official Apple publications.  Keep in mind that many output devices, including Apple's text console driver, do not support all of these characters.  ORCA/Pascal will properly send extended characters to whatever output device you choose, but what happens when the output device tries to handle the character varies from device to device.
+
+Many of the characters in the extended character set are used in languages oter than English, and are now allowed in identifiers.  There are two ways to think about which characters will work in an identifier.
+
+The simple way is to remember that all characters that look like a graphically modified ASCII alphabetic character or a Greek alphabetic character are allowed in identifiers.  For example, an a with two dots above it is now legal in an identifier.
+
+The more exact, and naturally more complicated way to think about which characters are allowed in an identifier is to list all of them.  Since this is an ASCII file, I'll list the ordinal values--you can cross reference the values in FontTest.  The ordinal values of the extended characters that are allowed in identifiers are [$80..$9F, $A7, $AE, $AF, $B4..$B9, $BB..$BF, $C4, $C6, $CB..$CF, $D8, $DE, $DF].
+
+In addition, ORCA/Pascal supports several extended characters as shortcuts for multi-character mathematical operations.  These are:
+
+	ordinal value	description		substitutes for
+	-------------	-----------		---------------
+	$C7		two <			<<
+	$C8		two >			>>
+	$AD		not equal		<>
+	$B2		less than or equal	<=
+	$B3		greater than or equal	>=
+	$D6		division (- with dots)	div
+
+Finally, the non-breaking space, sometimes called the sticky space (ordinal value $CA), is treated exactly like a standard space character.
+
+-- Bugs from Pascal 2.1 that are fixed in Pascal 2.2 ------------------------
+
+1. Incorrect code was generated for compares of objects.  For example, if obj1 and obj2 are object variables,
+
+	if obj1 = nil then ...
+
+and
+
+	if obj1 <> obj2 then ...
+
+both generated incorrect code.
+
+2. A bug in error reporting has been corrected.  For some rare errors, the compiler incremented the error count but did not print the error message.
+
+3. Eof and eoln have not worked for the standard input file since the switch to the .CONSOLE driver.  They do, now.
+
+(Jason)
+
+4. When a Read of a real value encounters a character sequence that starts with a character that can't be a part of a real number, as in
+
+   var
+      r: real;
+
+   begin
+   read(r);
+
+with input of
+
+   a
+
+should generate a run-time error.  In ORCA/Pascal 2.1, this error was not detected.
+
+(Rick Prest)
+
+5. Reading a value into an array element or a pointer, as in
+
+   read(readValue[4])
+
+did not always work correctly.
+
+(Rick Prest)
+
+6. Ord4 did not report an error when used on a nonscalar value, as in ord4(3.4).
+
+7. When the +t +e flags were used and too many END statements caused the compiler to flag a "'.' expected" error, the error was not reported properly.  The file name and error message were garbage when the editor was called, resulting in a blank file with an error message containing random characters.
+
+8.  Code generation has been improved for optimized code when a value is stored through a global pointer.
+
+9.  Loads of double values were not performed correctly by the FPE version of the SysFloat library, resulting in a large loss of precision.
+
+(Soenke Behrens, Dirk Froehling, Frank Gizinski)
+
+10.  With output redirected to a file and input comming from the keyboard, pressing the return key echoed the return that should have shown up on the screen to the output file.
+
+(Soenke Behrens, David Empson)
+
+-- Bugs Fixed from Pascal 2.0.1 ---------------------------------------------
+
+1. The compiler flagged a compile error when debug code was generated for a variable that was declared as a type where the type was a pointer to a record, as in
+
+	type
+	   r = record
+	      i: integer;
+	      end;
+	   rp = ^r;
+
+	var
+	   p: rp;
+
+2. Objects could not be packed; now they can.
+
+3. It is now possible to compare an object to nil using the equality and inequality comparisons (= and <>).
+
+4. Stores to boolean and character fields within an object intermitantly saved only one byte, when they should have saved two bytes.
+
+5. String constants in the interface part of a unit did not resolve properly when used from another unit or the main program.
+
+(Ken Kazinski)
+
+-- Bugs Fixed from Pascal 2.0.0 ---------------------------------------------
+
+1. With optimizations on, assigning the same constant to both a byte and word
+could generate code that did not correctly set the most significant byte of
+the word.
+
+(GNOTim2)
+
+2. In some cases, successive stores of the same long constant to two different
+locations with common subexpression elimination turned on would damage the
+stack.
+
+(GNOTim2)
+
+3. In some conditional branches involcing comples integer expressions, the
+condition code was not properly evaluated.
+
+(GNOTim2)
+
+4. Optimization of arithmetic shifts by a constant in the range 9..15 has been
+improved.
+
+(GNOTim2)
+
+5. Text programs didn't work when launched from the Finder.
+
+(JamesG7858)
+
+6. On page 250, the manual shows parameter lists for overridden methods,
+like this:
+
+   cube = object (box)
+      front, back: integer;
+      function Volume: integer;
+      procedure Fill (ptop, pleft, pbottom, pright,
+                      pfront, pback: integer); override;
+      procedure Grow (size: integer); override;
+      end;
+
+This is incorrect.  When you override a method, the parameter lists must
+match.  As with forward procedures in Standard Pascal, ORCA/Pascal flags an
+error when you redefine the method list.  The correct way to declare this class
+is:
+
+   cube = object (box)
+      front, back: integer;
+      function Volume: integer;
+      procedure Fill; override;
+      procedure Grow; override;
+      end;
+   
+(Daniel B. Johnson)
+
+7.  The {$rtl} pragma was not exiting with an RTL.
diff --git a/pascal.pas b/pascal.pas
old mode 100755
new mode 100644
index 3bffe9e..084cca8
--- a/pascal.pas
+++ b/pascal.pas
@@ -1 +1,63 @@
-{$optimize -1}
{$stacksize $4000}
{------------------------------------------------------------}
{							     }
{  ORCA/Pascal 2.2					     }
{							     }
{  A native code compiler for the Apple IIGS.		     }
{							     }
{  By Mike Westerfield					     }
{							     }
{  Copyright March 1988					     }
{  By the Byte Works, Inc.				     }
{							     }
{------------------------------------------------------------}
{							     }
{  Version 2.2 prepared in March, 1996		     	     }
{  Version 2.1 prepared in July, 1994		     	     }
{  Version 2.0.1 prepared in June, 1993		     	     }
{  Version 2.0.0 prepared in March, 1993		     }
{  Version 1.4.2 prepared in October, 1992		     }
{  Version 1.4.1 prepared in October, 1991		     }
{  Version 1.4 prepared in September, 1991		     }
{  Version 1.3 prepared in September, 1990		     }
{							     }
{------------------------------------------------------------}
 
program pascal (output);

{$segment 'pascal'}

{$LibPrefix '0/obj/'}

uses PCommon, CGI, Scanner, Symbols, Parser;

begin
{initialization:}
MMInit;					{memory manager}
InitPCommon;				{common module}
InitScalars;				{global variables}
InitSets;     
CodeGenScalarInit;
scanner_init; 
enterstdtypes;
stdnames;     
entstdnames;  
EnterUndecl;  
if progress or list then begin
   writeln('ORCA/Pascal 2.2.0'); 	{write banner}
   writeln('Copyright 1987,1988,1991,1993,1994,1996, Byte Works, Inc.');
   writeln;
   end; {if}
level := 1;				{set the top symbol level}
top := 1;

{compile:}
InSymbol;				{get the first symbol}
programme(blockbegsys+statbegsys-[casesy]); {compile the program}
               
{termination:}
if codeGeneration then CodeGenFini;	{shut down code generator}
scanner_fini;				{shut down scanner}
StopSpin;
end.
\ No newline at end of file
+{$optimize -1}
+{$stacksize $4000}
+{------------------------------------------------------------}
+{							     }
+{  ORCA/Pascal 2.2					     }
+{							     }
+{  A native code compiler for the Apple IIGS.		     }
+{							     }
+{  By Mike Westerfield					     }
+{							     }
+{  Copyright March 1988					     }
+{  By the Byte Works, Inc.				     }
+{							     }
+{------------------------------------------------------------}
+{							     }
+{  Version 2.2 prepared in March, 1996		     	     }
+{  Version 2.1 prepared in July, 1994		     	     }
+{  Version 2.0.1 prepared in June, 1993		     	     }
+{  Version 2.0.0 prepared in March, 1993		     }
+{  Version 1.4.2 prepared in October, 1992		     }
+{  Version 1.4.1 prepared in October, 1991		     }
+{  Version 1.4 prepared in September, 1991		     }
+{  Version 1.3 prepared in September, 1990		     }
+{							     }
+{------------------------------------------------------------}
+ 
+program pascal (output);
+
+{$segment 'pascal'}
+
+{$LibPrefix '0/obj/'}
+
+uses PCommon, CGI, Scanner, Symbols, Parser;
+
+begin
+{initialization:}
+MMInit;					{memory manager}
+InitPCommon;				{common module}
+InitScalars;				{global variables}
+InitSets;     
+CodeGenScalarInit;
+scanner_init; 
+enterstdtypes;
+stdnames;     
+entstdnames;  
+EnterUndecl;  
+if progress or list then begin
+   writeln('ORCA/Pascal 2.2.0'); 	{write banner}
+   writeln('Copyright 1987,1988,1991,1993,1994,1996, Byte Works, Inc.');
+   writeln;
+   end; {if}
+level := 1;				{set the top symbol level}
+top := 1;
+
+{compile:}
+InSymbol;				{get the first symbol}
+programme(blockbegsys+statbegsys-[casesy]); {compile the program}
+               
+{termination:}
+if codeGeneration then CodeGenFini;	{shut down code generator}
+scanner_fini;				{shut down scanner}
+StopSpin;
+end.
diff --git a/pascal.rez b/pascal.rez
old mode 100755
new mode 100644
index fcb3874..5e3783d
--- a/pascal.rez
+++ b/pascal.rez
@@ -1 +1,14 @@
-#include "types.rez"

resource rVersion(1) {
   {
      2,				/* Major revision */
      2,				/* Minor revision */
      0,				/* Bug version */
      release,				/* Release stage */
      0,				/* Non-final release # */
      },
   verUS,				/* Region code */
   "ORCA/Pascal",			/* Short version number */
   "Copyright 1996, Byte Works, Inc."	/* Long version number */
   };
\ No newline at end of file
+#include "types.rez"
+
+resource rVersion(1) {
+   {
+      2,				/* Major revision */
+      2,				/* Minor revision */
+      0,				/* Bug version */
+      release,				/* Release stage */
+      0,				/* Non-final release # */
+      },
+   verUS,				/* Region code */
+   "ORCA/Pascal",			/* Short version number */
+   "Copyright 1996, Byte Works, Inc."	/* Long version number */
+   };
diff --git a/pcommon.asm b/pcommon.asm
old mode 100755
new mode 100644
index d285348..fd79f57
--- a/pcommon.asm
+++ b/pcommon.asm
@@ -1 +1,521 @@
-	mcopy pcommon.macros
****************************************************************
*
*  MMCom - common data area for the memory manager
*
****************************************************************
*
MMCom	privdata
;
;  constants
;
maxBuffSize equ 16*1024	size of a buffer
;
;  data
;
buffSize ds	2	remaining bytes in the current buffer
currBuffHand ds 4	handle of current buffer
currBuffStart ds 4	pointer to start of current buffer
nextPtr	ds	4	pointer to next byte in current buffer
	end

****************************************************************
*
*  BRK - break into the debugger
*
*  Inputs:
*	4,S - break code
*
****************************************************************
*
BRK	start

	phb
	plx
	ply
	pla
	and	#$00FF
	xba
	sta	lb1
	phy
	phx
	plb
lb1	brk	$00
	rtl
	end

****************************************************************
*
*  Calloc - allocate and clear a new memory area
*
*  Inputs:
*	size - # bytes to allocate
*
*  Outputs:
*	X-A - pointer to memory
*
*  Notes:  Assumes size > 2
*
****************************************************************
*
Calloc	start
ptr	equ	1	pointer to memory

	sub	(2:size),4

	ph2	size	allocate the memory
	jsl	Malloc
	sta	ptr
	stx	ptr+2

	ldy	size	if there are an odd number of bytes then
	tya
	lsr	A
	bcc	lb1
	dey		  clear the last byte
	short	M
	lda	#0
	sta	[ptr],Y
	long	M
lb1	lda	#0	clear the memory, one word at a time
lb2	dey
	dey
	sta	[ptr],Y
	bne	lb2

	ret	4:ptr
	end

****************************************************************
*
*  CompNames - Compare two names
*
*  Inputs:
*	name1, name2 - addresses of the two strings to compare
*
*  Outputs:
*	int - 0 if equal, -1 if name1<name2, 1 if name1>name2
*
****************************************************************
*
CompNames start
result	equ	1

	sub	(4:name1,4:name2),2

	short	I,M  
	lda	[name1]	get the length of the shorter string
	cmp	[name2]
	blt	lb1
	lda	[name2]
lb1	tax
	beq	lb2a
	ldy	#1	compare the existing characters
lb2	lda	[name1],Y
	cmp	[name2],Y
	bne	lb4
	iny
	dex
	bne	lb2
lb2a	lda	[name1]	characters match -- compare the lengths
	cmp	[name2]
	bne	lb4

lb3	long	I,M
	lda	#0	strings match
	bra	lb6

lb4	long	I,M	strings don't match -- set condition code
	bge	lb5
	lda	#-1
	bra	lb6
lb5	lda	#1
lb6	sta	result

	ret	2:result
	end

****************************************************************
*
*  KeyPress - Has a key been presed?
*
*  If a key has not been pressed, this function returns
*  false.  If a key has been pressed, it clears the key
*  strobe.  If the key was an open-apple ., a terminal exit
*  is performed; otherwise, the function returns true.
*
****************************************************************
*
KeyPress start

	KeyPressGS kpRec
	lda	kpAvailable
	beq	rts
	ReadKeyGS rkRec
	lda	rkKey
	cmp	#'.'
	bne	lb1
	lda	rkModifiers
	and	#$0100
	beq	lb1
         ph2   #0
         ph4   #0
         jsl   TermError

lb1	lda	#1
rts	rtl

kpRec	dc	i'3'
kpKey	ds	2
kpModifiers ds	2
kpAvailable ds	2
                  
rkRec	dc	i'2'
rkKey	ds	2
rkModifiers ds	2
         end

****************************************************************
*
*  Mark - mark the stack
*
*  Inputs:
*	ptr - location to place mark
*
****************************************************************
*
Mark	start
	using MMCom

	sub	(4:ptr),0

	ldy	#2	ptr^ := nextPtr
	lda	nextPtr
	sta	[ptr]
	lda	nextPtr+2
	sta	[ptr],Y

	ret
	end

****************************************************************
*
*  MMInit - initialize the memory manager
*
****************************************************************
*
MMInit	start
	using MMCom

	stz	buffSize	no bytes in current buffer
	stz	currBuffHand	nil handle
	stz	currBuffHand+2
	rtl
	end

****************************************************************
*
*  Malloc - allocate a new memory area
*
*  Inputs:
*	size - # bytes to allocate
*
*  Outputs:
*	X-A - pointer to memory
*
****************************************************************
*
Malloc	start
	using MMCom
ptr	equ	1	pointer to memory
handle	equ	5	new memory handle
lptr	equ	9	work pointer

	sub	(2:size),12

	lda	buffSize	if buffSize < size then begin
	cmp	size
	bge	lb2
	ph4	#0	  handle := AppleNew(maxBuffSize);
	ph4	#maxBuffSize
	ph2	>~User_ID
	ph2	#$C010
	ph4	#0
	_NewHandle
	bcc	lb1
	ph2	#3
	ph4	#0
	jsl	TermError

lb1	pl4	handle
	ldy	#2	  lptr := handle^;
	lda	[handle],Y	  currBuffStart := handle^;
	sta	lptr+2
	sta	currBuffStart+2
	lda	[handle]
	sta	lptr
	sta	currBuffStart
	lda	currBuffHand+2	  lptr[0] := currBuffHand;
	sta	[lptr],Y
	lda	currBuffHand
	sta	[lptr]
	move4 handle,currBuffHand	  currBuffHand := handle;
	add4	lptr,#4,nextPtr	  nextPtr := lptr+4;
	lda	#maxBuffSize-4	  buffSize := maxBuffSize-4;
	sta	buffSize
lb2	anop		  end;
	clc		ptr := nextPtr;
	lda	nextPtr	nextPtr := nextPtr+size;
	sta	ptr
	adc	size
	sta	nextPtr
	lda	nextPtr+2
	sta	ptr+2
	adc	#0
	sta	nextPtr+2
	sub2	buffSize,size	buffSize := buffSize-size;

	ret	4:ptr
	end

****************************************************************
*
*  ~Move - move some bytes
*
*  Inputs:
*        source - pointer to source bytes
*        dest - pointer to destination bytes
*        len - number of bytes to move
*
*  Notes:
*        Also used to copy strings via CopyString entry point
*
****************************************************************
*
~Move    start
CopyString entry

         sub	(4:dest,4:source,2:len),0
	
         lda   len                      move one byte if the move length is odd
         lsr   a
         bcc   lb1
         short M
         lda   [source]
         sta   [dest]
         long  M
         inc4  source
         inc4  dest
         dec   len
lb1      ldy   len                      move the bytes
         beq   lb4
         dey
         dey
         beq   lb3
lb2      lda   [source],Y
         sta   [dest],Y
         dey
         dey
         bne   lb2
lb3      lda   [source]
         sta   [dest]

lb4      ret
         end

****************************************************************
*
*  Release - release previously marked memory
*
*  Inputs:
*	ptr - pointer supplied by Mark
*
****************************************************************
*
Release	start
	using MMCom
lptr	equ	1	local work pointer
handle	equ	5	work handle

	sub	(4:ptr),8

lb1	lda	ptr+2	while not ((ptr >= currBuffStart)
	cmp	currBuffStart+2	  and (ptr <= nextPtr)) do begin
	bne	lb2
	lda	ptr
	cmp	currBuffStart
lb2	blt	lb4
	lda	ptr+2
	cmp	nextPtr+2
	bne	lb3
	lda	ptr
	cmp	nextPtr
lb3	ble	lb5
lb4	move4 currBuffStart,lptr	  handle := currBuffStart[0];
	ldy	#2
	lda	[lptr]
	sta	handle
	lda	[lptr],Y
	sta	handle+2
	ph4	currBuffHand	  AppleDispose(currBuffHand);
	_DisposeHandle
	move4 handle,currBuffHand	  currBuffHand := handle;
	ldy	#2	  currBuffStart := handle^;
	lda	[handle]
	sta	currBuffStart
	lda	[handle],Y
	sta	currBuffStart+2
!			  nextPtr := currBuffStart+maxBuffSize;
	add4	currBuffStart,#maxBuffSize,nextPtr
	stz	buffSize	  buffSize := 0;
	bra	lb1	  end;
lb5	sec		buffSize := buffSize-ptr+nextPtr;
	lda	nextPtr
	sbc	ptr
	clc
	adc	buffSize
	sta	buffSize
	move4 ptr,nextPtr	nextPtr := ptr;

	ret
	end

****************************************************************
*
*  StdNames - Initialize the standard names array
*
*  Outputs:
*	NA - set to addresses of appropriate strings
*
****************************************************************
*
StdNames start
ptrSize	equ	4	size of a pointer
maxNA	equ	77	# elements in NA array

	move	lNA,NA,#ptrSize*maxNA
	rtl


lNA	dc	a4'l01,l02,l03,l04,l05,l06,l07,l08,l09,l10'
	dc	a4'l11,l12,l13,l14,l15,l16,l17,l18,l19,l20'
	dc	a4'l21,l22,l23,l24,l25,l26,l27,l28,l29,l30'
	dc	a4'l31,l32,l33,l34,l35,l36,l37,l38,l39,l40'
	dc	a4'l41,l42,l43,l44,l45,l46,l47,l48,l49,l50'
	dc	a4'l51,l52,l53,l54,l55,l56,l57,l58,l59,l60'
	dc	a4'l61,l62,l63,l64,l65,l66,l67,l68,l69,l70'
	dc	a4'l71,l72,l73,l74,l75,l76,l77'

l01	dw	'FALSE'
l02	dw	'TRUE'
l03	dw	'INPUT'
l04	dw	'OUTPUT'
l05	dw	'GET'
l06	dw	'PUT'
l07	dw	'OPEN'
l08	dw	'CLOSE'
l09	dw	'RESET'
l10	dw	'REWRITE'
l11	dw	'READ'
l12	dw	'WRITE'
l13	dw	'PACK'
l14	dw	'UNPACK'
l15	dw	'NEW'
l16	dw	'@B1'
l17	dw	'READLN'
l18	dw	'WRITELN'
l19	dw	'PAGE'
l20	dw	'@B2'
l21	dw	'DISPOSE'
l22	dw	'@B3'
l23	dw	'SEEK'
l24	dw	'ABS'
l25	dw	'SQR'
l26	dw	'TRUNC'
l27	dw	'ROUND'
l28	dw	'ODD'
l29	dw	'ORD'
l30	dw	'CHR'
l31	dw	'PRED'
l32	dw	'SUCC'
l33	dw	'EOF'
l34	dw	'EOLN'
l35	dw	'SIN'
l36	dw	'COS'
l37	dw	'EXP'
l38	dw	'SQRT'
l39	dw	'LN'
l40	dw	'ARCTAN'
l41	dw	'HALT'
l42	dw	'SEED'
l43	dw	'DELETE'
l44	dw	'INSERT'
l45	dw	'SHELLID'
l46	dw	'COMMANDLINE'
l47	dw	'STARTGRAPH'
l48	dw	'STARTDESK'
l49	dw	'ENDGRAPH'
l50	dw	'ENDDESK'
l51	dw	'ORD4'
l52	dw	'CNVDS'
l53	dw	'CNVIS'
l54	dw	'CNVSR'
l55	dw	'CNVSI'
l56	dw	'CNVSL'
l57	dw	'RANDOM'
l58	dw	'RANDOMINTEGER'
l59	dw	'RANDOMLONGINT'
l60	dw	'CONCAT'
l61	dw	'COPY'
l62	dw	'LENGTH'
l63	dw	'POS'
l64	dw	'RANDOMDOUBLE'
l65	dw	'CNVRS'
l66	dw	'CNVSD'
l67	dw	'USERID'
l68	dw	'POINTER'
l69	dw	'TAN'
l70	dw	'ARCCOS'
l71	dw	'ARCSIN'
l72	dw	'ARCTAN2'
l73	dw	'TOOLERROR'
l74	dw	'SIZEOF'
l75	dw	'TRUNC4'
l76	dw	'ROUND4'
l77	dw	'MEMBER'
	end

****************************************************************
*
*  WaitForKeyPress - If necessary, wait for a keypress
*
*  This routine is called after reporting non-terminal errors.
*  If the user has flagged all errors as terminal (+T), a
*  terminal exit is made.  If the user has not, but has requested
*  that the compiler wait for a keypress after printeing an error
*  (+W), it waits for a keypress.
*
*  Inputs:
*	r0 - long address of the error message
*	wait - wait for a keypress?
*	allTerm - are all errors terminal?
*
****************************************************************
*
WaitForKeyPress start
	using GetCom

	lda	allTerm	if allTerm then
	beq	lb1
	ph2	#0	  do a terminal error exit;
	ph4	#0
	jsl	TermError
lb1	lda	wait	if wait then begin
	beq	lb3
	jsl	DrawHourglass	  draw the wait symbol
lb1a	jsl	KeyPress	  get a keypress
	tay
	beq	lb1a
	jsl	ClearHourglass	  clear the wait symbol
lb3	rtl
	end
\ No newline at end of file
+	mcopy pcommon.macros
+****************************************************************
+*
+*  MMCom - common data area for the memory manager
+*
+****************************************************************
+*
+MMCom	privdata
+;
+;  constants
+;
+maxBuffSize equ 16*1024	size of a buffer
+;
+;  data
+;
+buffSize ds	2	remaining bytes in the current buffer
+currBuffHand ds 4	handle of current buffer
+currBuffStart ds 4	pointer to start of current buffer
+nextPtr	ds	4	pointer to next byte in current buffer
+	end
+
+****************************************************************
+*
+*  BRK - break into the debugger
+*
+*  Inputs:
+*	4,S - break code
+*
+****************************************************************
+*
+BRK	start
+
+	phb
+	plx
+	ply
+	pla
+	and	#$00FF
+	xba
+	sta	lb1
+	phy
+	phx
+	plb
+lb1	brk	$00
+	rtl
+	end
+
+****************************************************************
+*
+*  Calloc - allocate and clear a new memory area
+*
+*  Inputs:
+*	size - # bytes to allocate
+*
+*  Outputs:
+*	X-A - pointer to memory
+*
+*  Notes:  Assumes size > 2
+*
+****************************************************************
+*
+Calloc	start
+ptr	equ	1	pointer to memory
+
+	sub	(2:size),4
+
+	ph2	size	allocate the memory
+	jsl	Malloc
+	sta	ptr
+	stx	ptr+2
+
+	ldy	size	if there are an odd number of bytes then
+	tya
+	lsr	A
+	bcc	lb1
+	dey		  clear the last byte
+	short	M
+	lda	#0
+	sta	[ptr],Y
+	long	M
+lb1	lda	#0	clear the memory, one word at a time
+lb2	dey
+	dey
+	sta	[ptr],Y
+	bne	lb2
+
+	ret	4:ptr
+	end
+
+****************************************************************
+*
+*  CompNames - Compare two names
+*
+*  Inputs:
+*	name1, name2 - addresses of the two strings to compare
+*
+*  Outputs:
+*	int - 0 if equal, -1 if name1<name2, 1 if name1>name2
+*
+****************************************************************
+*
+CompNames start
+result	equ	1
+
+	sub	(4:name1,4:name2),2
+
+	short	I,M  
+	lda	[name1]	get the length of the shorter string
+	cmp	[name2]
+	blt	lb1
+	lda	[name2]
+lb1	tax
+	beq	lb2a
+	ldy	#1	compare the existing characters
+lb2	lda	[name1],Y
+	cmp	[name2],Y
+	bne	lb4
+	iny
+	dex
+	bne	lb2
+lb2a	lda	[name1]	characters match -- compare the lengths
+	cmp	[name2]
+	bne	lb4
+
+lb3	long	I,M
+	lda	#0	strings match
+	bra	lb6
+
+lb4	long	I,M	strings don't match -- set condition code
+	bge	lb5
+	lda	#-1
+	bra	lb6
+lb5	lda	#1
+lb6	sta	result
+
+	ret	2:result
+	end
+
+****************************************************************
+*
+*  KeyPress - Has a key been presed?
+*
+*  If a key has not been pressed, this function returns
+*  false.  If a key has been pressed, it clears the key
+*  strobe.  If the key was an open-apple ., a terminal exit
+*  is performed; otherwise, the function returns true.
+*
+****************************************************************
+*
+KeyPress start
+
+	KeyPressGS kpRec
+	lda	kpAvailable
+	beq	rts
+	ReadKeyGS rkRec
+	lda	rkKey
+	cmp	#'.'
+	bne	lb1
+	lda	rkModifiers
+	and	#$0100
+	beq	lb1
+         ph2   #0
+         ph4   #0
+         jsl   TermError
+
+lb1	lda	#1
+rts	rtl
+
+kpRec	dc	i'3'
+kpKey	ds	2
+kpModifiers ds	2
+kpAvailable ds	2
+                  
+rkRec	dc	i'2'
+rkKey	ds	2
+rkModifiers ds	2
+         end
+
+****************************************************************
+*
+*  Mark - mark the stack
+*
+*  Inputs:
+*	ptr - location to place mark
+*
+****************************************************************
+*
+Mark	start
+	using MMCom
+
+	sub	(4:ptr),0
+
+	ldy	#2	ptr^ := nextPtr
+	lda	nextPtr
+	sta	[ptr]
+	lda	nextPtr+2
+	sta	[ptr],Y
+
+	ret
+	end
+
+****************************************************************
+*
+*  MMInit - initialize the memory manager
+*
+****************************************************************
+*
+MMInit	start
+	using MMCom
+
+	stz	buffSize	no bytes in current buffer
+	stz	currBuffHand	nil handle
+	stz	currBuffHand+2
+	rtl
+	end
+
+****************************************************************
+*
+*  Malloc - allocate a new memory area
+*
+*  Inputs:
+*	size - # bytes to allocate
+*
+*  Outputs:
+*	X-A - pointer to memory
+*
+****************************************************************
+*
+Malloc	start
+	using MMCom
+ptr	equ	1	pointer to memory
+handle	equ	5	new memory handle
+lptr	equ	9	work pointer
+
+	sub	(2:size),12
+
+	lda	buffSize	if buffSize < size then begin
+	cmp	size
+	bge	lb2
+	ph4	#0	  handle := AppleNew(maxBuffSize);
+	ph4	#maxBuffSize
+	ph2	>~User_ID
+	ph2	#$C010
+	ph4	#0
+	_NewHandle
+	bcc	lb1
+	ph2	#3
+	ph4	#0
+	jsl	TermError
+
+lb1	pl4	handle
+	ldy	#2	  lptr := handle^;
+	lda	[handle],Y	  currBuffStart := handle^;
+	sta	lptr+2
+	sta	currBuffStart+2
+	lda	[handle]
+	sta	lptr
+	sta	currBuffStart
+	lda	currBuffHand+2	  lptr[0] := currBuffHand;
+	sta	[lptr],Y
+	lda	currBuffHand
+	sta	[lptr]
+	move4 handle,currBuffHand	  currBuffHand := handle;
+	add4	lptr,#4,nextPtr	  nextPtr := lptr+4;
+	lda	#maxBuffSize-4	  buffSize := maxBuffSize-4;
+	sta	buffSize
+lb2	anop		  end;
+	clc		ptr := nextPtr;
+	lda	nextPtr	nextPtr := nextPtr+size;
+	sta	ptr
+	adc	size
+	sta	nextPtr
+	lda	nextPtr+2
+	sta	ptr+2
+	adc	#0
+	sta	nextPtr+2
+	sub2	buffSize,size	buffSize := buffSize-size;
+
+	ret	4:ptr
+	end
+
+****************************************************************
+*
+*  ~Move - move some bytes
+*
+*  Inputs:
+*        source - pointer to source bytes
+*        dest - pointer to destination bytes
+*        len - number of bytes to move
+*
+*  Notes:
+*        Also used to copy strings via CopyString entry point
+*
+****************************************************************
+*
+~Move    start
+CopyString entry
+
+         sub	(4:dest,4:source,2:len),0
+	
+         lda   len                      move one byte if the move length is odd
+         lsr   a
+         bcc   lb1
+         short M
+         lda   [source]
+         sta   [dest]
+         long  M
+         inc4  source
+         inc4  dest
+         dec   len
+lb1      ldy   len                      move the bytes
+         beq   lb4
+         dey
+         dey
+         beq   lb3
+lb2      lda   [source],Y
+         sta   [dest],Y
+         dey
+         dey
+         bne   lb2
+lb3      lda   [source]
+         sta   [dest]
+
+lb4      ret
+         end
+
+****************************************************************
+*
+*  Release - release previously marked memory
+*
+*  Inputs:
+*	ptr - pointer supplied by Mark
+*
+****************************************************************
+*
+Release	start
+	using MMCom
+lptr	equ	1	local work pointer
+handle	equ	5	work handle
+
+	sub	(4:ptr),8
+
+lb1	lda	ptr+2	while not ((ptr >= currBuffStart)
+	cmp	currBuffStart+2	  and (ptr <= nextPtr)) do begin
+	bne	lb2
+	lda	ptr
+	cmp	currBuffStart
+lb2	blt	lb4
+	lda	ptr+2
+	cmp	nextPtr+2
+	bne	lb3
+	lda	ptr
+	cmp	nextPtr
+lb3	ble	lb5
+lb4	move4 currBuffStart,lptr	  handle := currBuffStart[0];
+	ldy	#2
+	lda	[lptr]
+	sta	handle
+	lda	[lptr],Y
+	sta	handle+2
+	ph4	currBuffHand	  AppleDispose(currBuffHand);
+	_DisposeHandle
+	move4 handle,currBuffHand	  currBuffHand := handle;
+	ldy	#2	  currBuffStart := handle^;
+	lda	[handle]
+	sta	currBuffStart
+	lda	[handle],Y
+	sta	currBuffStart+2
+!			  nextPtr := currBuffStart+maxBuffSize;
+	add4	currBuffStart,#maxBuffSize,nextPtr
+	stz	buffSize	  buffSize := 0;
+	bra	lb1	  end;
+lb5	sec		buffSize := buffSize-ptr+nextPtr;
+	lda	nextPtr
+	sbc	ptr
+	clc
+	adc	buffSize
+	sta	buffSize
+	move4 ptr,nextPtr	nextPtr := ptr;
+
+	ret
+	end
+
+****************************************************************
+*
+*  StdNames - Initialize the standard names array
+*
+*  Outputs:
+*	NA - set to addresses of appropriate strings
+*
+****************************************************************
+*
+StdNames start
+ptrSize	equ	4	size of a pointer
+maxNA	equ	77	# elements in NA array
+
+	move	lNA,NA,#ptrSize*maxNA
+	rtl
+
+
+lNA	dc	a4'l01,l02,l03,l04,l05,l06,l07,l08,l09,l10'
+	dc	a4'l11,l12,l13,l14,l15,l16,l17,l18,l19,l20'
+	dc	a4'l21,l22,l23,l24,l25,l26,l27,l28,l29,l30'
+	dc	a4'l31,l32,l33,l34,l35,l36,l37,l38,l39,l40'
+	dc	a4'l41,l42,l43,l44,l45,l46,l47,l48,l49,l50'
+	dc	a4'l51,l52,l53,l54,l55,l56,l57,l58,l59,l60'
+	dc	a4'l61,l62,l63,l64,l65,l66,l67,l68,l69,l70'
+	dc	a4'l71,l72,l73,l74,l75,l76,l77'
+
+l01	dw	'FALSE'
+l02	dw	'TRUE'
+l03	dw	'INPUT'
+l04	dw	'OUTPUT'
+l05	dw	'GET'
+l06	dw	'PUT'
+l07	dw	'OPEN'
+l08	dw	'CLOSE'
+l09	dw	'RESET'
+l10	dw	'REWRITE'
+l11	dw	'READ'
+l12	dw	'WRITE'
+l13	dw	'PACK'
+l14	dw	'UNPACK'
+l15	dw	'NEW'
+l16	dw	'@B1'
+l17	dw	'READLN'
+l18	dw	'WRITELN'
+l19	dw	'PAGE'
+l20	dw	'@B2'
+l21	dw	'DISPOSE'
+l22	dw	'@B3'
+l23	dw	'SEEK'
+l24	dw	'ABS'
+l25	dw	'SQR'
+l26	dw	'TRUNC'
+l27	dw	'ROUND'
+l28	dw	'ODD'
+l29	dw	'ORD'
+l30	dw	'CHR'
+l31	dw	'PRED'
+l32	dw	'SUCC'
+l33	dw	'EOF'
+l34	dw	'EOLN'
+l35	dw	'SIN'
+l36	dw	'COS'
+l37	dw	'EXP'
+l38	dw	'SQRT'
+l39	dw	'LN'
+l40	dw	'ARCTAN'
+l41	dw	'HALT'
+l42	dw	'SEED'
+l43	dw	'DELETE'
+l44	dw	'INSERT'
+l45	dw	'SHELLID'
+l46	dw	'COMMANDLINE'
+l47	dw	'STARTGRAPH'
+l48	dw	'STARTDESK'
+l49	dw	'ENDGRAPH'
+l50	dw	'ENDDESK'
+l51	dw	'ORD4'
+l52	dw	'CNVDS'
+l53	dw	'CNVIS'
+l54	dw	'CNVSR'
+l55	dw	'CNVSI'
+l56	dw	'CNVSL'
+l57	dw	'RANDOM'
+l58	dw	'RANDOMINTEGER'
+l59	dw	'RANDOMLONGINT'
+l60	dw	'CONCAT'
+l61	dw	'COPY'
+l62	dw	'LENGTH'
+l63	dw	'POS'
+l64	dw	'RANDOMDOUBLE'
+l65	dw	'CNVRS'
+l66	dw	'CNVSD'
+l67	dw	'USERID'
+l68	dw	'POINTER'
+l69	dw	'TAN'
+l70	dw	'ARCCOS'
+l71	dw	'ARCSIN'
+l72	dw	'ARCTAN2'
+l73	dw	'TOOLERROR'
+l74	dw	'SIZEOF'
+l75	dw	'TRUNC4'
+l76	dw	'ROUND4'
+l77	dw	'MEMBER'
+	end
+
+****************************************************************
+*
+*  WaitForKeyPress - If necessary, wait for a keypress
+*
+*  This routine is called after reporting non-terminal errors.
+*  If the user has flagged all errors as terminal (+T), a
+*  terminal exit is made.  If the user has not, but has requested
+*  that the compiler wait for a keypress after printeing an error
+*  (+W), it waits for a keypress.
+*
+*  Inputs:
+*	r0 - long address of the error message
+*	wait - wait for a keypress?
+*	allTerm - are all errors terminal?
+*
+****************************************************************
+*
+WaitForKeyPress start
+	using GetCom
+
+	lda	allTerm	if allTerm then
+	beq	lb1
+	ph2	#0	  do a terminal error exit;
+	ph4	#0
+	jsl	TermError
+lb1	lda	wait	if wait then begin
+	beq	lb3
+	jsl	DrawHourglass	  draw the wait symbol
+lb1a	jsl	KeyPress	  get a keypress
+	tay
+	beq	lb1a
+	jsl	ClearHourglass	  clear the wait symbol
+lb3	rtl
+	end
diff --git a/pcommon.macros b/pcommon.macros
old mode 100755
new mode 100644
index 48d0b2f..9f1302a
--- a/pcommon.macros
+++ b/pcommon.macros
@@ -1 +1,694 @@
- macro
&l ret &r
&l anop
 lclc &len
 aif c:&r,.a
 lclc &r
&r setc 0
&len setc 0
 ago .h
.a
&len amid &r,2,1
 aif "&len"=":",.b
&len amid &r,1,2
&r amid &r,4,l:&r-3
 ago .c
.b
&len amid &r,1,1
&r amid &r,3,l:&r-2
.c
 aif &len<>2,.d
 ldy &r
 ago .h
.d
 aif &len<>4,.e
 ldx &r+2
 ldy &r
 ago .h
.e
 aif &len<>10,.g
 ldy #&r
 ldx #^&r
 ago .h
.g
 mnote 'Not a valid return length',16
 mexit
.h
 aif &totallen=0,.i
 lda &worklen+2
 sta &worklen+&totallen+2
 lda &worklen+1
 sta &worklen+&totallen+1
.i
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 aif &len=0,.j
 tya
.j
 rtl
 mend
 macro
&l sub &parms,&work
&l anop
 aif c:&work,.a
 lclc &work
&work setc 0
.a
 gbla &totallen
 gbla &worklen
&worklen seta &work
&totallen seta 0
 aif c:&parms=0,.e
 lclc &len
 lclc &p
 lcla &i
&i seta c:&parms
.b
&p setc &parms(&i)
&len amid &p,2,1
 aif "&len"=":",.c
&len amid &p,1,2
&p amid &p,4,l:&p-3
 ago .d
.c
&len amid &p,1,1
&p amid &p,3,l:&p-2
.d
&p equ &totallen+4+&work
&totallen seta &totallen+&len
&i seta &i-1
 aif &i,^b
.e
 tsc
 aif &work=0,.f
 sec
 sbc #&work
 tcs
.f
 phd
 tcd
 mend
 macro
&l sub2 &n1,&n2,&n3
 aif c:&n3,.a
 lclc &n3
&n3 setc &n1
.a
&l ~setm
 sec
 ~lda &n1
 ~op sbc,&n2
 ~sta &n3
 ~restm
 mend
 macro
&l add4 &m1,&m2,&m3
 lclb &yistwo
 lclc &c
&l ~setm
 aif c:&m3,.a
&c amid "&m2",1,1
 aif "&c"<>"#",.a
&c amid "&m1",1,1
 aif "&c"="{",.a
 aif "&c"="[",.a
&c amid "&m2",2,l:&m2-1
 aif &c>=65536,.a
 clc
 ~lda &m1
 ~op adc,&m2
 ~sta &m1
 bcc ~&syscnt
 ~op.h inc,&m1
~&syscnt anop
 ago .c
.a
 aif c:&m3,.b
 lclc &m3
&m3 setc &m1
.b
 clc
 ~lda &m1
 ~op adc,&m2
 ~sta &m3
 ~lda.h &m1
 ~op.h adc,&m2
 ~sta.h &m3
.c
 ~restm
 mend
 macro
&l ble &bp
&l blt &bp
 beq &bp
 mend
 macro
&l dw &adr
&l dc i1"l:~&sysname&syscnt"
~&sysname&syscnt dc c"&adr"
 mend
 macro
&l inc4 &a
&l ~setm
 inc &a
 bne ~&syscnt
 inc 2+&a
~&syscnt ~restm
 mend
 macro
&l long &a,&b
 lclb &i
 lclb &m
&a amid &a,1,1
&m setb ("&a"="M").or.("&a"="m")
&i setb ("&a"="I").or.("&a"="i")
 aif c:&b=0,.a
&b amid &b,1,1
&m setb ("&b"="M").or.("&b"="m").or.&m
&i setb ("&b"="I").or.("&b"="i").or.&i
.a
&l rep #&m*32+&i*16
 aif .not.&m,.b
 longa on
.b
 aif .not.&i,.c
 longi on
.c
 mend
 macro
&l move &ad1,&ad2,&len
&l anop
 lclb &la
 lclb &li
 lclc &c
 aif c:&len,.a1
 lclc &len
&len setc #2
.a1
&la setb s:longa
&li setb s:longi
 aif s:longa.and.s:longi,.a
 rep #32*(.not.&la)+16*(.not.&li)
 longa on
 longi on
.a
&c amid &len,1,1
 aif "&c"<>"#",.d
&c amid &len,2,l:&len-1
 aif &c<>2,.d
&c amid &ad1,1,1
 aif "&c"<>"{",.b
&ad1 amid &ad1,2,l:&ad1-2
&ad1 setc (&ad1)
.b
 lda &ad1
&c amid &ad2,1,1
 aif "&c"<>"{",.c
&ad2 amid &ad2,2,l:&ad2-2
&ad2 setc (&ad2)
.c
 sta &ad2
 ago .g
.d
&c amid &ad1,1,1
 aif "&c"="#",.f
&c amid &len,1,1
 aif "&c"<>"{",.e
&len amid &len,2,l:&len-2
&len setc (&len)
.e
&c amid &len,1,1
 aif "&c"="#",.e1
 lda &len
 dec a
 ago .e2
.e1
 lda &len-1
.e2
 ldx #&ad1
 ldy #&ad2
 mvn &ad1,&ad2
 ago .g
.f
 lda &ad1
 sta &ad2
 lda &len-1
 ldx #&ad2
 ldy #&ad2+1
 mvn &ad2,&ad2
.g
 aif (&la+&li)=2,.i
 sep #32*(.not.&la)+16*(.not.&li)
 aif &la,.h
 longa off
.h
 aif &li,.i
 longi off
.i
 mend
 macro
&l move4 &m1,&m2
 lclb &yistwo
&l ~setm
 ~lda &m1
 ~sta &m2
 ~lda.h &m1
 ~sta.h &m2
 ~restm
 mend
 macro
&l ph2 &n1
 aif "&n1"="*",.f
 lclc &c
&l anop
&c amid &n1,1,1
 aif "&c"="#",.d
 aif s:longa=1,.a
 rep #%00100000
.a
 aif "&c"<>"{",.b
&c amid &n1,l:&n1,1
 aif "&c"<>"}",.g
&n1 amid &n1,2,l:&n1-2
 lda (&n1)
 pha
 ago .e
.b
 aif "&c"="<",.c
 lda &n1
 pha
 ago .e
.c
&n1 amid &n1,2,l:&n1-1
 pei &n1
 ago .e
.d
&n1 amid &n1,2,l:&n1-1
 pea &n1
 ago .f
.e
 aif s:longa=1,.f
 sep #%00100000
.f
 mexit
.g
 mnote "Missing closing '}'",16
 mend
 macro
&l ph4 &n1
 aif "&n1"="*",.f
 lclc &c
&l anop
&c amid &n1,1,1
 aif "&c"="#",.d
 aif s:longa=1,.a
 rep #%00100000
.a
 aif "&c"<>"{",.b
&c amid &n1,l:&n1,1
 aif "&c"<>"}",.g
&n1 amid &n1,2,l:&n1-2
 ldy #2
 lda (&n1),y
 pha
 lda (&n1)
 pha
 ago .e
.b
 aif "&c"<>"[",.c
 ldy #2
 lda &n1,y
 pha
 lda &n1
 pha
 ago .e
.c
 aif "&c"<>"<",.c1
&n1 amid &n1,2,l:&n1-1
 pei &n1+2
 pei &n1
 ago .e
.c1
 lda &n1+2
 pha
 lda &n1
 pha
 ago .e
.d
&n1 amid &n1,2,l:&n1-1
 pea +(&n1)|-16
 pea &n1
 ago .f
.e
 aif s:longa=1,.f
 sep #%00100000
.f
 mexit
.g
 mnote "Missing closing '}'",16
 mend
 macro
&l pl4 &n1
 lclc &c
&l anop
 aif s:longa=1,.a
 rep #%00100000
.a
&c amid &n1,1,1
 aif "&c"<>"{",.b
&c amid &n1,l:&n1,1
 aif "&c"<>"}",.f
&n1 amid &n1,2,l:&n1-2
 pla
 sta (&n1)
 ldy #2
 pla
 sta (&n1),y
 ago .d
.b
 aif "&c"<>"[",.c
 pla
 sta &n1
 ldy #2
 pla
 sta &n1,y
 ago .d
.c
 pla
 sta &n1
 pla
 sta &n1+2
.d
 aif s:longa=1,.e
 sep #%00100000
.e
 mexit
.f
 mnote "Missing closing '}'",16
 mend
 macro
&l short &a,&b
 lclb &i
 lclb &m
&a amid &a,1,1
&m setb ("&a"="M").or.("&a"="m")
&i setb ("&a"="I").or.("&a"="i")
 aif c:&b=0,.a
&b amid &b,1,1
&m setb ("&b"="M").or.("&b"="m").or.&m
&i setb ("&b"="I").or.("&b"="i").or.&i
.a
&l sep #&m*32+&i*16
 aif .not.&m,.b
 longa off
.b
 aif .not.&i,.c
 longi off
.c
 mend
 macro
&l ~lda &op
 lclc &c
&c amid "&op",1,1
 aif "&c"<>"{",.b
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
&l lda &op
 mend
 macro
&l ~lda.h &op
&l anop
 lclc &c
&c amid "&op",1,1
 aif "&c"="[",.b
 aif "&c"<>"{",.d
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
 aif &yistwo,.c
&yistwo setb 1
 ldy #2
.c
&op setc "&op,y"
 lda &op
 mexit
.d
 aif "&c"<>"#",.e
&op amid "&op",2,l:&op-1
&op setc "#^&op"
 lda &op
 mexit
.e
 lda 2+&op
 mend
 macro
&l ~op &opc,&op
 lclc &c
&c amid "&op",1,1
 aif "&c"<>"{",.b
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
&l &opc &op
 mend
 macro
&l ~op.h &opc,&op
&l anop
 lclc &c
&c amid "&op",1,1
 aif "&c"="[",.b
 aif "&c"<>"{",.d
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
 aif &yistwo,.c
&yistwo setb 1
 ldy #2
.c
&op setc "&op,y"
 &opc &op
 mexit
.d
 aif "&c"<>"#",.e
&op amid "&op",2,l:&op-1
&op setc "#^&op"
 &opc &op
 mexit
.e
 &opc 2+&op
 mend
 macro
&l ~restm
&l anop
 aif (&~la+&~li)=2,.i
 sep #32*(.not.&~la)+16*(.not.&~li)
 aif &~la,.h
 longa off
.h
 aif &~li,.i
 longi off
.i
 mend
 macro
&l ~setm
&l anop
 aif c:&~la,.b
 gblb &~la
 gblb &~li
.b
&~la setb s:longa
&~li setb s:longi
 aif s:longa.and.s:longi,.a
 rep #32*(.not.&~la)+16*(.not.&~li)
 longa on
 longi on
.a
 mend
 macro
&l ~sta &op
 lclc &c
&c amid "&op",1,1
 aif "&c"<>"{",.b
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
&l sta &op
 mend
 macro
&l ~sta.h &op
&l anop
 lclc &c
&c amid "&op",1,1
 aif "&c"="[",.b
 aif "&c"<>"{",.d
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
 aif &yistwo,.c
&yistwo setb 1
 ldy #2
.c
&op setc "&op,y"
 sta &op
 mexit
.d
 sta 2+&op
 mend
 MACRO
&lab _DisposeHandle
&lab ldx #$1002
 jsl $E10000
 MEND
 MACRO
&lab _NewHandle
&lab ldx #$0902
 jsl $E10000
 MEND
 macro
&l puts &n1,&f1,&cr,&errout
&l ~setm
 lclc &c
&c amid "&n1",1,1
 aif "&c"<>"#",.c
 aif l:&n1>127,.a
 bra ~&syscnt
 ago .b
.a
 brl ~&syscnt
.b
&n1 amid "&n1",2,l:&n1-1
~l&syscnt dc i1"l:~s&syscnt"
~s&syscnt dc c&n1
~&syscnt anop
&n1 setc ~l&syscnt-1
.c
 ~pusha &n1
 aif c:&f1,.c1
 pea 0
 ago .c2
.c1
 ph2 &f1
.c2
 ph2 #c:&cr
 ph2 #c:&errout
 jsl ~puts
 ~restm
 mend
 macro
&l ~pusha &n1
 lclc &c
&l anop
&c amid &n1,1,1
 aif "&c"<>"{",.b
&c amid &n1,l:&n1,1
 aif "&c"<>"}",.g
&n1 amid &n1,2,l:&n1-2
 sep #$20
 longa off
 lda #0
 pha
 rep #$20
 longa on
 phk
 lda &n1
 pha
 mexit
.b
 aif "&c"<>"[",.c
&n1 amid &n1,2,l:&n1-2
 lda &n1+2
 pha
 lda &n1
 pha
 mexit
.c
 pea +(&n1)|-16
 pea &n1
 mexit
.g
 mnote "Missing closing '}'",16
 mend
 macro
&l dbne &r,&bp
 aif "&r"="X",.l1
 aif "&r"="Y",.l1
 aif "&r"="x",.l1
 aif "&r"="y",.l1
&l dec &r
 bne &bp
 mexit
.l1
&l de&r
 bne &bp
 mend
 macro
&l la &ad1,&ad2
&l anop
 lcla &lb
 lclb &la
 aif s:longa,.a
 rep #%00100000
 longa on
&la setb 1
.a
 lda #&ad2
&lb seta c:&ad1
.b
 sta &ad1(&lb)
&lb seta &lb-1
 aif &lb,^b
 aif &la=0,.d
 sep #%00100000
 longa off
.d
 mend
 macro
&l keypressgs &p
&l ~setm
 jsl $E100A8
 dc i2'$015E'
 dc i4'&p'
 ~restm
 mend
 macro
&l readkeygs &p
&l ~setm
 jsl $E100A8
 dc i2'$015F'
 dc i4'&p'
 ~restm
 mend
\ No newline at end of file
+ macro
+&l ret &r
+&l anop
+ lclc &len
+ aif c:&r,.a
+ lclc &r
+&r setc 0
+&len setc 0
+ ago .h
+.a
+&len amid &r,2,1
+ aif "&len"=":",.b
+&len amid &r,1,2
+&r amid &r,4,l:&r-3
+ ago .c
+.b
+&len amid &r,1,1
+&r amid &r,3,l:&r-2
+.c
+ aif &len<>2,.d
+ ldy &r
+ ago .h
+.d
+ aif &len<>4,.e
+ ldx &r+2
+ ldy &r
+ ago .h
+.e
+ aif &len<>10,.g
+ ldy #&r
+ ldx #^&r
+ ago .h
+.g
+ mnote 'Not a valid return length',16
+ mexit
+.h
+ aif &totallen=0,.i
+ lda &worklen+2
+ sta &worklen+&totallen+2
+ lda &worklen+1
+ sta &worklen+&totallen+1
+.i
+ pld
+ tsc
+ clc
+ adc #&worklen+&totallen
+ tcs
+ aif &len=0,.j
+ tya
+.j
+ rtl
+ mend
+ macro
+&l sub &parms,&work
+&l anop
+ aif c:&work,.a
+ lclc &work
+&work setc 0
+.a
+ gbla &totallen
+ gbla &worklen
+&worklen seta &work
+&totallen seta 0
+ aif c:&parms=0,.e
+ lclc &len
+ lclc &p
+ lcla &i
+&i seta c:&parms
+.b
+&p setc &parms(&i)
+&len amid &p,2,1
+ aif "&len"=":",.c
+&len amid &p,1,2
+&p amid &p,4,l:&p-3
+ ago .d
+.c
+&len amid &p,1,1
+&p amid &p,3,l:&p-2
+.d
+&p equ &totallen+4+&work
+&totallen seta &totallen+&len
+&i seta &i-1
+ aif &i,^b
+.e
+ tsc
+ aif &work=0,.f
+ sec
+ sbc #&work
+ tcs
+.f
+ phd
+ tcd
+ mend
+ macro
+&l sub2 &n1,&n2,&n3
+ aif c:&n3,.a
+ lclc &n3
+&n3 setc &n1
+.a
+&l ~setm
+ sec
+ ~lda &n1
+ ~op sbc,&n2
+ ~sta &n3
+ ~restm
+ mend
+ macro
+&l add4 &m1,&m2,&m3
+ lclb &yistwo
+ lclc &c
+&l ~setm
+ aif c:&m3,.a
+&c amid "&m2",1,1
+ aif "&c"<>"#",.a
+&c amid "&m1",1,1
+ aif "&c"="{",.a
+ aif "&c"="[",.a
+&c amid "&m2",2,l:&m2-1
+ aif &c>=65536,.a
+ clc
+ ~lda &m1
+ ~op adc,&m2
+ ~sta &m1
+ bcc ~&syscnt
+ ~op.h inc,&m1
+~&syscnt anop
+ ago .c
+.a
+ aif c:&m3,.b
+ lclc &m3
+&m3 setc &m1
+.b
+ clc
+ ~lda &m1
+ ~op adc,&m2
+ ~sta &m3
+ ~lda.h &m1
+ ~op.h adc,&m2
+ ~sta.h &m3
+.c
+ ~restm
+ mend
+ macro
+&l ble &bp
+&l blt &bp
+ beq &bp
+ mend
+ macro
+&l dw &adr
+&l dc i1"l:~&sysname&syscnt"
+~&sysname&syscnt dc c"&adr"
+ mend
+ macro
+&l inc4 &a
+&l ~setm
+ inc &a
+ bne ~&syscnt
+ inc 2+&a
+~&syscnt ~restm
+ mend
+ macro
+&l long &a,&b
+ lclb &i
+ lclb &m
+&a amid &a,1,1
+&m setb ("&a"="M").or.("&a"="m")
+&i setb ("&a"="I").or.("&a"="i")
+ aif c:&b=0,.a
+&b amid &b,1,1
+&m setb ("&b"="M").or.("&b"="m").or.&m
+&i setb ("&b"="I").or.("&b"="i").or.&i
+.a
+&l rep #&m*32+&i*16
+ aif .not.&m,.b
+ longa on
+.b
+ aif .not.&i,.c
+ longi on
+.c
+ mend
+ macro
+&l move &ad1,&ad2,&len
+&l anop
+ lclb &la
+ lclb &li
+ lclc &c
+ aif c:&len,.a1
+ lclc &len
+&len setc #2
+.a1
+&la setb s:longa
+&li setb s:longi
+ aif s:longa.and.s:longi,.a
+ rep #32*(.not.&la)+16*(.not.&li)
+ longa on
+ longi on
+.a
+&c amid &len,1,1
+ aif "&c"<>"#",.d
+&c amid &len,2,l:&len-1
+ aif &c<>2,.d
+&c amid &ad1,1,1
+ aif "&c"<>"{",.b
+&ad1 amid &ad1,2,l:&ad1-2
+&ad1 setc (&ad1)
+.b
+ lda &ad1
+&c amid &ad2,1,1
+ aif "&c"<>"{",.c
+&ad2 amid &ad2,2,l:&ad2-2
+&ad2 setc (&ad2)
+.c
+ sta &ad2
+ ago .g
+.d
+&c amid &ad1,1,1
+ aif "&c"="#",.f
+&c amid &len,1,1
+ aif "&c"<>"{",.e
+&len amid &len,2,l:&len-2
+&len setc (&len)
+.e
+&c amid &len,1,1
+ aif "&c"="#",.e1
+ lda &len
+ dec a
+ ago .e2
+.e1
+ lda &len-1
+.e2
+ ldx #&ad1
+ ldy #&ad2
+ mvn &ad1,&ad2
+ ago .g
+.f
+ lda &ad1
+ sta &ad2
+ lda &len-1
+ ldx #&ad2
+ ldy #&ad2+1
+ mvn &ad2,&ad2
+.g
+ aif (&la+&li)=2,.i
+ sep #32*(.not.&la)+16*(.not.&li)
+ aif &la,.h
+ longa off
+.h
+ aif &li,.i
+ longi off
+.i
+ mend
+ macro
+&l move4 &m1,&m2
+ lclb &yistwo
+&l ~setm
+ ~lda &m1
+ ~sta &m2
+ ~lda.h &m1
+ ~sta.h &m2
+ ~restm
+ mend
+ macro
+&l ph2 &n1
+ aif "&n1"="*",.f
+ lclc &c
+&l anop
+&c amid &n1,1,1
+ aif "&c"="#",.d
+ aif s:longa=1,.a
+ rep #%00100000
+.a
+ aif "&c"<>"{",.b
+&c amid &n1,l:&n1,1
+ aif "&c"<>"}",.g
+&n1 amid &n1,2,l:&n1-2
+ lda (&n1)
+ pha
+ ago .e
+.b
+ aif "&c"="<",.c
+ lda &n1
+ pha
+ ago .e
+.c
+&n1 amid &n1,2,l:&n1-1
+ pei &n1
+ ago .e
+.d
+&n1 amid &n1,2,l:&n1-1
+ pea &n1
+ ago .f
+.e
+ aif s:longa=1,.f
+ sep #%00100000
+.f
+ mexit
+.g
+ mnote "Missing closing '}'",16
+ mend
+ macro
+&l ph4 &n1
+ aif "&n1"="*",.f
+ lclc &c
+&l anop
+&c amid &n1,1,1
+ aif "&c"="#",.d
+ aif s:longa=1,.a
+ rep #%00100000
+.a
+ aif "&c"<>"{",.b
+&c amid &n1,l:&n1,1
+ aif "&c"<>"}",.g
+&n1 amid &n1,2,l:&n1-2
+ ldy #2
+ lda (&n1),y
+ pha
+ lda (&n1)
+ pha
+ ago .e
+.b
+ aif "&c"<>"[",.c
+ ldy #2
+ lda &n1,y
+ pha
+ lda &n1
+ pha
+ ago .e
+.c
+ aif "&c"<>"<",.c1
+&n1 amid &n1,2,l:&n1-1
+ pei &n1+2
+ pei &n1
+ ago .e
+.c1
+ lda &n1+2
+ pha
+ lda &n1
+ pha
+ ago .e
+.d
+&n1 amid &n1,2,l:&n1-1
+ pea +(&n1)|-16
+ pea &n1
+ ago .f
+.e
+ aif s:longa=1,.f
+ sep #%00100000
+.f
+ mexit
+.g
+ mnote "Missing closing '}'",16
+ mend
+ macro
+&l pl4 &n1
+ lclc &c
+&l anop
+ aif s:longa=1,.a
+ rep #%00100000
+.a
+&c amid &n1,1,1
+ aif "&c"<>"{",.b
+&c amid &n1,l:&n1,1
+ aif "&c"<>"}",.f
+&n1 amid &n1,2,l:&n1-2
+ pla
+ sta (&n1)
+ ldy #2
+ pla
+ sta (&n1),y
+ ago .d
+.b
+ aif "&c"<>"[",.c
+ pla
+ sta &n1
+ ldy #2
+ pla
+ sta &n1,y
+ ago .d
+.c
+ pla
+ sta &n1
+ pla
+ sta &n1+2
+.d
+ aif s:longa=1,.e
+ sep #%00100000
+.e
+ mexit
+.f
+ mnote "Missing closing '}'",16
+ mend
+ macro
+&l short &a,&b
+ lclb &i
+ lclb &m
+&a amid &a,1,1
+&m setb ("&a"="M").or.("&a"="m")
+&i setb ("&a"="I").or.("&a"="i")
+ aif c:&b=0,.a
+&b amid &b,1,1
+&m setb ("&b"="M").or.("&b"="m").or.&m
+&i setb ("&b"="I").or.("&b"="i").or.&i
+.a
+&l sep #&m*32+&i*16
+ aif .not.&m,.b
+ longa off
+.b
+ aif .not.&i,.c
+ longi off
+.c
+ mend
+ macro
+&l ~lda &op
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"<>"{",.b
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+&l lda &op
+ mend
+ macro
+&l ~lda.h &op
+&l anop
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"="[",.b
+ aif "&c"<>"{",.d
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+ aif &yistwo,.c
+&yistwo setb 1
+ ldy #2
+.c
+&op setc "&op,y"
+ lda &op
+ mexit
+.d
+ aif "&c"<>"#",.e
+&op amid "&op",2,l:&op-1
+&op setc "#^&op"
+ lda &op
+ mexit
+.e
+ lda 2+&op
+ mend
+ macro
+&l ~op &opc,&op
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"<>"{",.b
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+&l &opc &op
+ mend
+ macro
+&l ~op.h &opc,&op
+&l anop
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"="[",.b
+ aif "&c"<>"{",.d
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+ aif &yistwo,.c
+&yistwo setb 1
+ ldy #2
+.c
+&op setc "&op,y"
+ &opc &op
+ mexit
+.d
+ aif "&c"<>"#",.e
+&op amid "&op",2,l:&op-1
+&op setc "#^&op"
+ &opc &op
+ mexit
+.e
+ &opc 2+&op
+ mend
+ macro
+&l ~restm
+&l anop
+ aif (&~la+&~li)=2,.i
+ sep #32*(.not.&~la)+16*(.not.&~li)
+ aif &~la,.h
+ longa off
+.h
+ aif &~li,.i
+ longi off
+.i
+ mend
+ macro
+&l ~setm
+&l anop
+ aif c:&~la,.b
+ gblb &~la
+ gblb &~li
+.b
+&~la setb s:longa
+&~li setb s:longi
+ aif s:longa.and.s:longi,.a
+ rep #32*(.not.&~la)+16*(.not.&~li)
+ longa on
+ longi on
+.a
+ mend
+ macro
+&l ~sta &op
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"<>"{",.b
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+&l sta &op
+ mend
+ macro
+&l ~sta.h &op
+&l anop
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"="[",.b
+ aif "&c"<>"{",.d
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+ aif &yistwo,.c
+&yistwo setb 1
+ ldy #2
+.c
+&op setc "&op,y"
+ sta &op
+ mexit
+.d
+ sta 2+&op
+ mend
+ MACRO
+&lab _DisposeHandle
+&lab ldx #$1002
+ jsl $E10000
+ MEND
+ MACRO
+&lab _NewHandle
+&lab ldx #$0902
+ jsl $E10000
+ MEND
+ macro
+&l puts &n1,&f1,&cr,&errout
+&l ~setm
+ lclc &c
+&c amid "&n1",1,1
+ aif "&c"<>"#",.c
+ aif l:&n1>127,.a
+ bra ~&syscnt
+ ago .b
+.a
+ brl ~&syscnt
+.b
+&n1 amid "&n1",2,l:&n1-1
+~l&syscnt dc i1"l:~s&syscnt"
+~s&syscnt dc c&n1
+~&syscnt anop
+&n1 setc ~l&syscnt-1
+.c
+ ~pusha &n1
+ aif c:&f1,.c1
+ pea 0
+ ago .c2
+.c1
+ ph2 &f1
+.c2
+ ph2 #c:&cr
+ ph2 #c:&errout
+ jsl ~puts
+ ~restm
+ mend
+ macro
+&l ~pusha &n1
+ lclc &c
+&l anop
+&c amid &n1,1,1
+ aif "&c"<>"{",.b
+&c amid &n1,l:&n1,1
+ aif "&c"<>"}",.g
+&n1 amid &n1,2,l:&n1-2
+ sep #$20
+ longa off
+ lda #0
+ pha
+ rep #$20
+ longa on
+ phk
+ lda &n1
+ pha
+ mexit
+.b
+ aif "&c"<>"[",.c
+&n1 amid &n1,2,l:&n1-2
+ lda &n1+2
+ pha
+ lda &n1
+ pha
+ mexit
+.c
+ pea +(&n1)|-16
+ pea &n1
+ mexit
+.g
+ mnote "Missing closing '}'",16
+ mend
+ macro
+&l dbne &r,&bp
+ aif "&r"="X",.l1
+ aif "&r"="Y",.l1
+ aif "&r"="x",.l1
+ aif "&r"="y",.l1
+&l dec &r
+ bne &bp
+ mexit
+.l1
+&l de&r
+ bne &bp
+ mend
+ macro
+&l la &ad1,&ad2
+&l anop
+ lcla &lb
+ lclb &la
+ aif s:longa,.a
+ rep #%00100000
+ longa on
+&la setb 1
+.a
+ lda #&ad2
+&lb seta c:&ad1
+.b
+ sta &ad1(&lb)
+&lb seta &lb-1
+ aif &lb,^b
+ aif &la=0,.d
+ sep #%00100000
+ longa off
+.d
+ mend
+ macro
+&l keypressgs &p
+&l ~setm
+ jsl $E100A8
+ dc i2'$015E'
+ dc i4'&p'
+ ~restm
+ mend
+ macro
+&l readkeygs &p
+&l ~setm
+ jsl $E100A8
+ dc i2'$015F'
+ dc i4'&p'
+ ~restm
+ mend
diff --git a/pcommon.pas b/pcommon.pas
old mode 100755
new mode 100644
index 5f389ca..65bd673
--- a/pcommon.pas
+++ b/pcommon.pas
@@ -1 +1,1053 @@
-{$optimize -1}
{---------------------------------------------------------------}
{								}
{  PCommon							}
{								}
{  Common variables and low-level utility subroutines used by	}
{  by the compiler.						}
{								}
{---------------------------------------------------------------}

unit PCommon;

interface

const
   displimit   = 20;			{max # proc levels, nested records,}
					{ with statements.}
   maxaddr     = maxint4;		{max legal value for a pointer}
   maxcnt      = 256;			{number of characters in a line+1}
   maxLine     = 255;			{number of characters in a line}
   maxLabel    = 2400;			{max # of compiler generated labels}
   maxlevel    = 10;			{max # proc levels}
   maxgoto     = 10;			{max nesting level for goto check}
					{NOTE: maxPath also defined in scanner.asm}
   maxPath     = 255;			{max length of a path name}
   ordmaxchar  = 127;			{ord of largest char}
   ordminchar  = 0;			{ord of smallest char}
   sethigh     = 2047;			{number of bits in set variable - 1}
   setlow      = 0;			{"ord" of lsb of set variable}
   setsize     = 256;			{set size in bytes; (sethigh+1) div 8}

   intsize     = 2;			{storage in bytes required for base}
   realsize    = 4;			{ types}
   doublesize  = 8;
   compsize    = 8;
   extendedsize  = 10;
   bytesize    = 1;
   longsize    = 4;
   packedcharsize = 1;
   charsize    = 2;
   boolsize    = 2;
   ptrsize     = 4;
   procsize    = 6;
   extSize     = 10;			{size of real when passed as parm}

   constantRec_longC = 6;		{partial sizes for constantRec}
   constantRec_reel  = 10;
   constantRec_pset  = 260;
   constantRec_chset = 258;
   constantRec_strg  = 258;

					{error reporting}
					{---------------}
   maxErr = 10;				{max errors on one line}

					{file types}
                                        {----------}
   BIN = $06;				{binary file}
   DVU = $5E;				{developer utility data file}
   AuxUnit = $008009;			{Pascal unit Aux Type}

type
					{misc}
					{----}
   disprange = 0..displimit;		{nesting level for procs + withs}
   markPtr = ^integer;			{pointer type for mark, release}
   ptr = ^byte;				{general pointer}
   handle = ^ptr;			{general handle}
   stringKind = (lengthString,nullString); {string formats}
   pString = packed array [0..maxLine] of char; {length string}
   pStringPtr = ^pString;
   unsigned = 0..maxint; 		{unsigned integer}
   where = (blck,crec,vrec,rec); 	{origin of a set of symbols}

   long = record 			{for extracting words}
      case boolean of
	 true: (lsw, msw: integer);
	 false: (l: longint);
      end;

					{error reporting}
					{---------------}
					{NOTE: disps defined in Scanner.asm}
   errtype = record
      nmr: unsigned;			{error number}
      pos: unsigned;			{position in line}
      end;
					{basic symbols}
					{-------------}
   packedkinds = (pkpacked,pkunpacked,pkeither);

   symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop,
	     lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow,
	     colon,dotdot,becomes,labelsy,constsy,typesy,varsy,funcsy,
	     progsy,procsy,setsy,packedsy,arraysy,recordsy,filesy,nilsy,
	     beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy,gotosy,
	     endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,thensy,
	     othersy,otherwisesy,powersy,bitnot,usessy,stringsy,atsy,
	     longintconst,unitsy,interfacesy,implementationsy,univsy,
             objectsy,inheritedsy);
   setofsys = set of symbol;

   operator = (noop,mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop,gtop,
	       neop,eqop,inop,band,bor,xor,rshift,lshift);


					{data structures}
					{---------------}
   ctp = ^identifier;

   addrrange = longint;			{valid range for pointers}
   declkind = (standard,declared);
   structform = (scalar,subrange,pointerStruct,power,arrays,records,objects,
		files,tagfld,variant);

   stp = ^structure;
   structure = record
      size: addrrange;
      ispacked: packedkinds;
      hasSFile: boolean;
      case form: structform of
	 scalar: 	(case scalkind: declkind of
			    declared: (fconst: ctp);
			    standard: ());
	 subrange:	(rangetype: stp; min,max: longint);
	 pointerStruct: (eltype: stp);
	 power:		(elset: stp);
	 arrays: 	(aeltype,inxtype: stp);
	 records:	(fstfld: ctp; recvar: stp);
	 objects:	(objfld: ctp;		{object fields}
			 objsize: addrrange;	{object size}
                         objname: pstringptr;	{object name}
                         objlevel: integer;	{generation level}
                         objparent: stp;	{parent or nil}
                         );
	 files:		(filtype: stp; filsize: addrrange);
	 tagfld: 	(tagfieldp: ctp; fstvar: stp);
	 variant:	(nxtvar,subvar: stp; varval: integer)
      end;

					{constants}
					{---------}
   cstclass = (reel,pset,strg,chset,longC);
   settype = set of setlow..sethigh;

   csp = ^ constantRec;
				{NOTE: Size in scanner.asm}
				{NOTE: Partial sizes here and in scanner.asm}
   constantRec = record
      case cclass: cstclass of
	 longC:(lval: longint);
	 reel: (rval: double);
	 pset: (pval: settype;
		pmax: setlow..sethigh);
	 chset:(ch: packed array[0..255] of char);
	 strg: (sval: pString);
	 end;

   valu = record case boolean of
      true  :(ival: integer);
      false: (valp: csp)
      end;
					{names}
					{-----}

   directive_type = (drnone,drforw,drextern,drprodos,drtool1,drtool2,drvector,
                     droverride);
   idclass = (types,konst,varsm,field,proc,func,directive,prog);
   setofids = set of idclass;
   idkind = (actual,formal);
   levrange = 0..maxlevel;
   keyrange = 1..53;			{range of std proc nums}

					{NOTE: Disps in scanner.asm}
   identifier = record
      name: pStringPtr;			{name of the identifier}
      llink, rlink: ctp; 		{links for symbol tree}
      idtype: stp;			{type of identifier}
      next: ctp;
      hasIFile: boolean;
      case klass: idclass of
	 konst: (values: valu);		{constant value}
	 varsm: (vkind: idkind;
		 vlev: levrange; 	{declaration level}
		 vitem: integer;
		 vlabel: unsigned;	{variable label}
		 vcontvar: boolean;
		 fromUses: boolean;
		 vrestrict: boolean;
		 vuniv: boolean; 	{for parameters, is it universal?}
		 vPrivate: boolean;
		 );
	 field: (fldaddr: addrrange;
		 fldvar: boolean;
		 );
	 prog,
	 proc,
	 func:	(case pfdeckind: declkind of
		  standard: (key: keyrange);
		  declared: (pflev: levrange;		{static level}
			     pfname: integer;		{subroutine name}
                             pfoname: pStringPtr;	{object.method name}
			     pfactualsize: integer;	{size of parameters}
			     pflabel: unsigned;
			     pfset: boolean;		{has func. return value been set?}
			     pfmark: markPtr;		{memory mark}
			     pfPrivate: boolean;
                             pfaddr: addrrange;		{method object disp}
                             pfparms: ctp;		{parameter list}
			     case pfkind: idkind of
			       actual: (pfdirective: directive_type;
					pfcallnum, pftoolnum: integer;
				       );
			       formal: (pflab: unsigned;
			                pfnext: ctp;
				       );
			    );                      
		);
	 directive: (drkind: directive_type);
	 types: ();
      end;

					{NOTE: Disps in scanner.asm}
					{NOTE: Size in scanner.asm}
   lptr = ^ltype;			{linked list of identifiers used from}
   ltype = record			{ other levels}
      next: lptr;			{next record}
      name: pStringPtr;			{identifier that was used}
      disx: disprange;			{level of the identifier}
      end;

   partialptr = ^partialname;		{partial compile ptr}
   partialname = record			{partial name}
      next: partialptr;
      pname: pStringPtr;
      end;

					{labels}
					{------}
  starrtype = array[1..maxgoto] of integer;
  lbp = ^ labl;
  labl = record
	   nextlab: lbp;
	   defined: boolean;
	   lstlevel: integer;
	   lstarray: starrtype;
	   labval, labname: integer;
	 end;

					{expression attributes}
					{---------------------}
   attrkind = (cst,varbl,expr);
   vaccess = (drct,indrct,inxd);

   attrptr = ^attr;
   attr = record
      typtr: stp;			{type of the expression}
      isPacked: boolean;		{is this value packed?}
      case kind: attrkind of		{form of the expression}
	 cst:	 (cval: valu);		{... a constant}
	 expr:	 ();
	 varbl:	 (case access: vaccess of {... a variable}
		  drct: (vlevel: levrange;
			 dplab: unsigned;
			 dpdisp: addrrange;
			 aname: pStringPtr;
			 );
		  indrct: (idplmt: addrrange);	{... a pointer to something}
		  inxd: ()
		  );
      end;

					{files}
					{-----}
   extfilep = ^filerec;
   filerec = record
      filename: pStringPtr;
      nextfile: extfilep
      end;

   gsosInString = record
       size: integer;
       theString: packed array [1..maxPath] of char;
       end;
   gsosInStringPtr = ^gsosInString;

   {GS/OS class 1 output string}
   gsosOutString = record
       maxSize: integer;
       theString: gsosInString;
       end;
   gsosOutStringPtr = ^gsosOutString;

					{ORCA Shell and ProDOS}
					{---------------------}
   consoleOutDCBGS = record
      pcount: integer;
      ch: char;
      end;

   destroyOSDCB = record		{Destroy DCB}
      pcount: integer;
      pathName: gsosInStringPtr;
      end;

   timeField = array[1..8] of byte;

   optionListRecord = record
      totalSize: integer;
      requiredSize: integer;
      fileSysID: integer;
      theData: packed array [1..100] of char;
      end;
   optionListPtr = ^optionListRecord;

   errorDCBGS = record
      pcount: integer;
      error: integer;
      end;

   expandDevicesDCBGS = record
      pcount: integer;
      inName: gsosInStringPtr;
      outName: gsosOutStringPtr;
      end;

   fastFileDCBGS = record
      pcount: integer;
      action: integer;
      index: integer;
      flags: integer;
      fileHandle: handle;
      pathName: gsosInStringPtr;
      access: integer;
      fileType: integer;
      auxType: longint;
      storageType: integer;
      createDate: timeField;
      modDate: timeField;
      option: optionListPtr;
      fileLength: longint;
      blocksUsed: longint;
      end;

   getFileInfoOSDCB = record
      pcount: integer;
      pathName: gsosInStringPtr;
      access: integer;
      fileType: integer;
      auxType: longint;
      storageType: integer;
      createDateTime: timeField;
      modDateTime: timeField;
      optionList: optionListPtr;
      dataEOF: longint;
      blocksUsed: longint;
      resourceEOF: longint;
      resourceBlocks: longint;
      end;

   getLInfoDCBGS = record
      pcount: integer;
      sFile: gsosOutStringPtr;
      dFile: gsosOutStringPtr;
      namesList: gsosOutStringPtr;
      iString: gsosOutStringPtr;
      merr: byte;
      merrf: byte;
      lops: byte;
      kFlag: byte;
      mFlags: longint;
      pFlags: longint;
      org: longint;
      end;

   versionDCBGS = record
      pcount: integer;
      version: packed array[1..4] of char;
      end;

var
					{misc}
					{----}
   chEndPtr: ptr;			{pointer to the end of the current file}
   chPtr: ptr;				{pointer to the next line of the current file}
   filePtr: ptr; 			{pointer to the start of the current file}

					{counters:}
					{---------}
   intLabel: integer;			{last label number used}
   linecount: integer;			{line number for current line}

					{flags & switches}
					{----------------}
   wait: boolean;			{wait for keypress on non-terminal error?}
   allTerm: boolean;			{treat all errors as terminal?}
   dataBank: boolean;			{save, restore data bank?}
   debug: boolean;			{generate range check code?}
   doingUnit: boolean;			{compiling a unit?}
   goToEditor: boolean;			{return to editor on a terminal error?}
   iso: boolean; 			{iso only?}
   liDCBGS: getLInfoDCBGS;		{get/set LInfo DCB}
   list: boolean;			{list source?}
   memoryFlag: boolean;			{+M flag from command line?}
   noGlobalLabels: boolean;		{have any global labels been detected?}
   noinput,nooutput,noerroroutput: boolean; {tells if stan. dev. are declared}
   printer: boolean;			{is the printer on?}
   printSymbols: boolean;		{print the symbol table?}
   progfound: boolean;			{tells if the code has started}
   progress: boolean;			{print progress information?}
   prterr: boolean;			{to allow forward references in pointer
					 type declaration by supressing error
					 messages}
   stringHeap: boolean;			{has the string heap been used?}

					{error reporting}
					{---------------}
   errinx: 0..maxErr;			{number of errors on this line}
   errlist: array[1..maxErr] of errtype; {list of errors}
   numerr: unsigned;			{number of errors in the program}

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

					{scanner}
					{-------}
   chCnt: unsigned;			{character counter}
   lCnt: unsigned;			{# lines written on this page}
   pageSize: unsigned;			{printing lines on a page}
   title: pString;			{title}

					{expression compilation:}
					{-----------------------}
   gattr: attr;				{describes the expr currently compiled}
   gispacked: boolean;			{was last identifier a component of
					 a packed structure?}
   glcp: ctp;				{last identifier in an expression}

					{structured constants:}
					{---------------------}
   na:	array [1..77] of pStringPtr;

					{file names}
					{----------}
   fNameGS: gsosOutString;		{current source file name}
   kNameGS: gsosOutString;		{Keep file name}
   subsGS: gsosOutString;		{List of subroutines for partial compile}
   ldInfoGS: gsosOutString;		{language dependent parameters (not used)}
   intPrefixGS: gsosOutString;		{prefix to search for interface files}
   usesFileNameGS: gsosOutString;	{active uses file name}

					{bookkeeping of declaration levels:}
					{----------------------------------}
   disx: disprange;			{level of last id searched by searchid}
   level: levrange;			{current static level}
   top: disprange;			{top of display}
   nextLocalLabel: unsigned;		{next available local data label number}

					{NOTE: Disps in scanner.asm}
					{NOTE: Size in scanner.asm}
   display:				{where:	  means:}
      array [disprange] of record
	 ispacked: boolean;
	 labsused: lptr; 		{list of labels used from other levels}
	 fname: ctp;
	 flabel: lbp;
	 case occur: where of		{=blck:	  id is variable id}
	    crec: (clev: levrange;	{=crec:	  id is field id in record with}
		  cdspl: addrrange;	{	  constant address}
                  clab: unsigned;
		  cname: pStringPtr);
	    vrec: (vdsplab: unsigned);	{=vrec:	  id is field id in record with}
                                      	{	  variable address}
	    rec,blck:();
	 end;				{ --> procedure withstatement}

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

					{ORCA Shell and ProDOS}
					{---------------------}

procedure DestroyGS (var parms: destroyOSDCB); prodos ($2002);

procedure ErrorGS (var parms: errorDCBGS); prodos ($0145);

procedure GetFileInfoGS (var parms: getFileInfoOSDCB); prodos ($2006);

procedure GetLInfoGS (var parms: getLInfoDCBGS); prodos ($0141);

procedure ExpandDevicesGS (var parms: expandDevicesDCBGS); prodos ($0154);

procedure FastFileGS (var parms: fastFileDCBGS); prodos ($014E);

procedure SetLInfoGS (var parms: getLInfoDCBGS); prodos ($0142);

procedure VersionGS (var parms: versionDCBGS); prodos ($0147);

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

procedure Brk (code: integer); extern;

{ Break into the debugger					}
{								}
{ parameters:							}
{    code - BRK code						}


function Calloc (size: integer): ptr; extern;

{ Allocate and clear memory					}
{								}
{ parameters:							}
{    size - number of bytes to reserve				}
{								}
{ Returns: pointer to the memory 				}


procedure ClearHourGlass;

{ Erase the hourglass from the screen				}


function CompNames (var name1,name2: pString): integer; extern;

{ Compare two identifiers					}
{								}
{ parameters:							}
{    name1, name2 - identifiers to compare			}
{								}
{ Returns:	-1 if name1 < name2				}
{		0 if name1 = name2				}
{		1 if name1 > name2				}


procedure CopyString (var s1,s2: pString; len: integer); extern;

{ copy a string from s2 to s1					}
{								}
{ parameters:							}
{    s1 - string buffer to copy to				}
{    s2 - string buffer to copy from				}
{    len - length of the s1 string buffer			}


procedure DrawHourGlass;

{ Draw the hourglass on the screen				}


procedure Error (err: integer);

{ flag an error in the current line				}
{								}
{ parameters:							}
{    err - error number						}


{procedure Error2 (loc, err: integer); {debug}

{ flag an error in the current line				}
{								}
{ parameters:							}
{    loc - error location					}
{    err - error number						}


procedure FlagError;

{ do all error processing except writing the message		}


function GenLabel: integer;

{ generate the next local label, checking for too many		}


function GetFileType (var name: gsosOutString): integer;

{ Checks to see if a file exists				}
{								}
{ parameters:							}
{    name - file name to check for				}
{								}
{ Returns: File type if the file exists, or -1 if the file does	}
{    not exist (or if GetFileInfo returns an error)		}


function GetLocalLabel: integer;

{ get the next local label number				}


procedure InitPCommon;

{ Initialize this module 					}


function KeyPress: boolean; extern;
 
{ Has a key been presed?                                        }
{                                                               }
{ If a key has not been pressed, this function returns          }
{ false.  If a key has been pressed, it clears the key          }
{ strobe.  If the key was an open-apple ., a terminal exit      }
{ is performed; otherwise, the function returns true.           }
 

procedure LineFeed;

{ generate a line feed						}


function Malloc (size: integer): ptr; extern;

{ Allocate memory						}
{								}
{ parameters:							}
{    size - number of bytes to reserve				}
{								}
{ Returns: pointer to the memory 				}


procedure MMInit; extern;

{ initialize the memory manager					}


procedure Mark (var p: markPtr); extern;

{ mark the heap							}
{								}
{ parameters:							}
{    p - location to save mark pointer				}


procedure PurgeSource;

{ Purge the current source file					}


procedure Release (p: markPtr); extern;

{ release previously marked heap area				}
{								}
{ parameters:							}
{    p - release all memory from this point on			}


procedure StdNames; extern;

{ initialize the na array					}


procedure Spin;

{ Spin the spinner						}
{								}
{ Notes: Starts the spinner if it is not already in use		}


procedure StopSpin;

{ Stop the spinner						}
{								}
{ Notes: The call is safe, and ignored, if the spinner is	}


procedure SystemError (errNo: integer);

{ intercept run time compiler errors				}


procedure TermError (err: unsigned; msg: pStringPtr);

{ Flag a terminal error						}
{								}
{ parameters:							}
{    err - terminal error number 				}
{    msg - error message, or nil for one of the standard errors	}
{								}
{ Notes: err is not used if msg <> nil				}


procedure WaitForKeyPress; extern;

{ If +w has been used, waits for a keypress			}

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

implementation

const
					{spinner}
					{-------}
   spinSpeed = 8;			{calls before one spinner move}

var
					{spinner}
					{-------}

   spinning: boolean;			{are we spinning now?}
   spinDisp: integer;			{disp to the spinner character}
   spinCount: integer;			{spin loop counter}

   spinner: array[0..3] of char; 	{spinner characters}

procedure ConsoleOutGS (var parms: consoleOutDCBGS); prodos ($015A);

procedure SystemQuitFlags (flags: integer); extern;

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

procedure ExitToEditor (msg: pStringPtr; disp: longint);

{  do an error exit to the editor				}
{								}
{  parameters:							}
{	msg - pointer to the error message			}
{	disp - displacement into the error file			}
{								}
{  variables:							}
{	includeFile - source file name				}

var
   msgGS: gsosInString;			{message}

begin {ExitToEditor}
msgGS.size := length(msg^);		{set up the error message}
msgGS.theString := msg^;
liDCBGS.org := disp;			{mark the error}
liDCBGS.namesList := @msgGS;
liDCBGS.lops := 0;			{prevent re-entry}
liDCBGS.merrf := 255;
with liDCBGS do begin
   sFile := pointer(ord4(sFile)+2);
   dFile := pointer(ord4(dFile)+2);
   iString := pointer(ord4(iString)+2);
   end; {with}
SetLInfoGS(liDCBGS);
StopSpin;				{stop the spinner}
halt(-1);				{return to the shell}
end; {ExitToEditor}

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

procedure ClearHourGlass;

{ Erase the hourglass from the screen				}

var
   coRec: consoleOutDCBGS;		{Console out record}

begin {ClearHourGlass}
coRec.pcount := 1;
coRec.ch := ' '; 	ConsoleOutGS(coRec);
coRec.ch := chr(8);	ConsoleOutGS(coRec);
end; {ClearHourGlass}


procedure DrawHourGlass;

{ Draw the hourglass on the screen				}

var
   coRec: consoleOutDCBGS;		{Console out record}

begin {DrawHourGlass}
coRec.pcount := 1;
coRec.ch := chr(27);	ConsoleOutGS(coRec);
coRec.ch := chr(15);	ConsoleOutGS(coRec);
coRec.ch := 'C'; 	ConsoleOutGS(coRec);
coRec.ch := chr(24);	ConsoleOutGS(coRec);
coRec.ch := chr(14);	ConsoleOutGS(coRec);
coRec.ch := chr(8);	ConsoleOutGS(coRec);
end; {DrawHourGlass}


procedure Error {err: integer};

{ flag an error in the current line				}
{								}
{ parameters:							}
{    err - error number						}

begin {Error}
if errinx >= maxErr - 1 then begin
   errlist[maxErr].nmr := 109;
   errinx := maxErr;
   end {if}
else begin
   errinx := errinx + 1;
   errlist[errinx].nmr := err;
   numerr := numerr + 1;
   end; {else}
errlist[errinx].pos := chCnt;
if liDCBGS.merrf < 16 then
   liDCBGS.merrf := 16;
end; {Error}


{procedure Error2 {loc, err: integer); {debug}

{ flag an error in the current line				}
{								}
{ parameters:							}
{    loc - error location					}
{    err - error number						}

{begin {Error2}
{writeln('Error ', err:1, ' flagged at ', loc:1);
Error(err);
end; {Error2}


procedure FlagError;

{ do all error processing except writing the message		}

begin {FlagError}
LineFeed;				{write the carriage return}
numerr := numerr+1;			{increment the number of errors}
WaitForKeyPress; 			{wait for a keypress}
if liDCBGS.merrf < 16 then		{set the error level}
   liDCBGS.merrf := 16;
end; {FlagError}


function GenLabel{: integer};

{ generate the next local label, checking for too many		}

begin {GenLabel}
if intLabel < maxLabel then
   intLabel := intLabel+1
else begin
   intLabel := 0;
   Error(102);
   end;
GenLabel := intLabel;
end; {GenLabel}


function GetFileType {var name: gsosOutString): integer};

{ Checks to see if a file exists				}
{								}
{ parameters:							}
{    name - file name to check for				}
{								}
{ Returns: File type if the file exists, or -1 if the file does	}
{    not exist (or if GetFileInfo returns an error)		}

var
   giRec: getFileInfoOSDCB;		{GetFileInfo record}

begin {GetFileType}
giRec.pcount := 3;
giRec.pathName := @name.theString;
GetFileInfoGS(giRec);
if ToolError = 0 then
   GetFileType := giRec.fileType
else
   GetFileType := -1;
end; {GetFileType}


function GetLocalLabel{: integer};

{ get the next local label number				}

begin {GetLocalLabel}
GetLocalLabel := nextLocalLabel;
nextLocalLabel := nextLocalLabel+1;
end; {GetLocalLabel}


procedure InitPCommon;

{ Initialize this module 					}

var
   vDCBGS: versionDCBGS;		{for checking the version number}

begin {InitPCommon}
SystemQuitFlags($4000);			{make sure we quit with restart set}

vDCBGS.pCount := 1;			{check the version number}
VersionGS(vDCBGS);
if vDCBGS.version[1] < '2' then
   TermError(14, nil);

spinning := false;			{not spinning the spinner}
spinDisp := 0;				{start spinning with the first character}
spinner[0] := '|';			{set up the spinner characters}
spinner[1] := '/';
spinner[2] := '-';
spinner[3] := '\';
end; {InitPCommon}


procedure LineFeed;

{ generate a line feed						}

begin {LineFeed}
writeln;
if printer then begin
   lcnt := lcnt+1;
   if lcnt = pageSize then begin
      if length(title) = 0 then
	 lcnt := 0
      else begin
	 lcnt := 2;
	 writeln(title);
	 writeln;
	 end; {else}
      end; {if}
   end; {if}
end; {LineFeed}


procedure PurgeSource;

{ Purge the current source file					}

var
   ffDCBGS: fastFileDCBGS;		{FastFile record}

begin {PurgeSource}
with ffDCBGS do begin
   pCount := 5;
   action := 7;
   pathName := @fNameGS.theString;
   end; {with}
FastFileGS(ffDCBGS);
end; {PurgeSource}


procedure Spin;

{ Spin the spinner						}
{								}
{ Notes: Starts the spinner if it is not already in use		}

var
   coRec: consoleOutDCBGS;		{Console out record}

begin {Spin}
if not spinning then begin
   spinning := true;
   spinCount := spinSpeed;
   end; {if}
spinCount := spinCount - 1;
if spinCount = 0 then begin
   spinCount := spinSpeed;
   spinDisp := spinDisp - 1;
   if spinDisp < 0 then
      spinDisp := 3;
   coRec.pcount := 1;
   coRec.ch := spinner[spinDisp];
   ConsoleOutGS(coRec);
   coRec.ch := chr(8);
   ConsoleOutGS(coRec);
   end; {if}
end; {Spin}


procedure StopSpin;

{ Stop the spinner						}
{								}
{ Notes: The call is safe, and ignored, if the spinner is	}
{	inactive.						}

var
   coRec: consoleOutDCBGS;		{Console out record}

begin {StopSpin}
if spinning then begin
   spinning := false;
   coRec.pcount := 1;
   coRec.ch := ' ';
   ConsoleOutGS(coRec);
   coRec.ch := chr(8);
   ConsoleOutGS(coRec);
   end; {if}
end; {StopSpin}


procedure SystemError {errNo: integer};

{ intercept run time compiler errors				}

begin {SystemError}
if errNo = 5 then
   TermError(3, nil)
else
   TermError(7, nil);
end; {SystemError}


procedure TermError {err: unsigned; msg: pStringPtr};

{ Flag a terminal error						}
{								}
{ parameters:							}
{    err - terminal error number 				}
{    msg - error message, or nil for one of the standard errors	}
{								}
{ Notes: err is not used if msg <> nil				}

begin {TermError}
PurgeSource;				{purge the source file}
if msg = nil then
   case err of
      0:msg := @'User termination';
      1:msg := @'Not enough bank zero memory';
      2:msg := @'Non-Pascal file opened at an inappropriate time';
      3:msg := @'Out of memory';
      4:msg := @'Tool or ProDOS error - see listing file';
      5:msg := @'Segment buffer overflow';
      6:msg := @'Error reading uses file';
     {7:msg := @'Compiler error';}
      8:msg := @'Could not open the object file';
      9:msg := @'Could not delete interface file';
     10:msg := @'Units cannot be compiled to memory';
     11:msg := @'Source files must end with a return';
     12:msg := @'Error writing uses file';
     13:msg := @'Error writing object file';
     14:msg := @'ORCA/Pascal requires version 2.0 or later of the shell';
     otherwise:
	msg := @'Compiler error';
     end; {case}
writeln('Terminal error: ', msg^);
if gotoEditor then			{error exit to editor}
   ExitToEditor(msg, ord4(chPtr) - ord4(filePtr) + chCnt)
else begin
   liDCBGS.lops := 0;			{prevent re-entry}
   liDCBGS.merrf := 127;
   with liDCBGS do begin
      sFile := pointer(ord4(sFile)+2);
      dFile := pointer(ord4(dFile)+2);
      namesList := pointer(ord4(namesList)+2);
      iString := pointer(ord4(iString)+2);
      end; {with}
   SetLInfoGS(liDCBGS);
   StopSpin;				{stop the spinner}
   halt(-1);				{return to the shell}
   end; {else}
end; {TermError}

end.

{$append 'pcommon.asm'}
\ No newline at end of file
+{$optimize -1}
+{---------------------------------------------------------------}
+{								}
+{  PCommon							}
+{								}
+{  Common variables and low-level utility subroutines used by	}
+{  by the compiler.						}
+{								}
+{---------------------------------------------------------------}
+
+unit PCommon;
+
+interface
+
+const
+   displimit   = 20;			{max # proc levels, nested records,}
+					{ with statements.}
+   maxaddr     = maxint4;		{max legal value for a pointer}
+   maxcnt      = 256;			{number of characters in a line+1}
+   maxLine     = 255;			{number of characters in a line}
+   maxLabel    = 2400;			{max # of compiler generated labels}
+   maxlevel    = 10;			{max # proc levels}
+   maxgoto     = 10;			{max nesting level for goto check}
+					{NOTE: maxPath also defined in scanner.asm}
+   maxPath     = 255;			{max length of a path name}
+   ordmaxchar  = 127;			{ord of largest char}
+   ordminchar  = 0;			{ord of smallest char}
+   sethigh     = 2047;			{number of bits in set variable - 1}
+   setlow      = 0;			{"ord" of lsb of set variable}
+   setsize     = 256;			{set size in bytes; (sethigh+1) div 8}
+
+   intsize     = 2;			{storage in bytes required for base}
+   realsize    = 4;			{ types}
+   doublesize  = 8;
+   compsize    = 8;
+   extendedsize  = 10;
+   bytesize    = 1;
+   longsize    = 4;
+   packedcharsize = 1;
+   charsize    = 2;
+   boolsize    = 2;
+   ptrsize     = 4;
+   procsize    = 6;
+   extSize     = 10;			{size of real when passed as parm}
+
+   constantRec_longC = 6;		{partial sizes for constantRec}
+   constantRec_reel  = 10;
+   constantRec_pset  = 260;
+   constantRec_chset = 258;
+   constantRec_strg  = 258;
+
+					{error reporting}
+					{---------------}
+   maxErr = 10;				{max errors on one line}
+
+					{file types}
+                                        {----------}
+   BIN = $06;				{binary file}
+   DVU = $5E;				{developer utility data file}
+   AuxUnit = $008009;			{Pascal unit Aux Type}
+
+type
+					{misc}
+					{----}
+   disprange = 0..displimit;		{nesting level for procs + withs}
+   markPtr = ^integer;			{pointer type for mark, release}
+   ptr = ^byte;				{general pointer}
+   handle = ^ptr;			{general handle}
+   stringKind = (lengthString,nullString); {string formats}
+   pString = packed array [0..maxLine] of char; {length string}
+   pStringPtr = ^pString;
+   unsigned = 0..maxint; 		{unsigned integer}
+   where = (blck,crec,vrec,rec); 	{origin of a set of symbols}
+
+   long = record 			{for extracting words}
+      case boolean of
+	 true: (lsw, msw: integer);
+	 false: (l: longint);
+      end;
+
+					{error reporting}
+					{---------------}
+					{NOTE: disps defined in Scanner.asm}
+   errtype = record
+      nmr: unsigned;			{error number}
+      pos: unsigned;			{position in line}
+      end;
+					{basic symbols}
+					{-------------}
+   packedkinds = (pkpacked,pkunpacked,pkeither);
+
+   symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop,
+	     lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow,
+	     colon,dotdot,becomes,labelsy,constsy,typesy,varsy,funcsy,
+	     progsy,procsy,setsy,packedsy,arraysy,recordsy,filesy,nilsy,
+	     beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy,gotosy,
+	     endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,thensy,
+	     othersy,otherwisesy,powersy,bitnot,usessy,stringsy,atsy,
+	     longintconst,unitsy,interfacesy,implementationsy,univsy,
+             objectsy,inheritedsy);
+   setofsys = set of symbol;
+
+   operator = (noop,mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop,gtop,
+	       neop,eqop,inop,band,bor,xor,rshift,lshift);
+
+
+					{data structures}
+					{---------------}
+   ctp = ^identifier;
+
+   addrrange = longint;			{valid range for pointers}
+   declkind = (standard,declared);
+   structform = (scalar,subrange,pointerStruct,power,arrays,records,objects,
+		files,tagfld,variant);
+
+   stp = ^structure;
+   structure = record
+      size: addrrange;
+      ispacked: packedkinds;
+      hasSFile: boolean;
+      case form: structform of
+	 scalar: 	(case scalkind: declkind of
+			    declared: (fconst: ctp);
+			    standard: ());
+	 subrange:	(rangetype: stp; min,max: longint);
+	 pointerStruct: (eltype: stp);
+	 power:		(elset: stp);
+	 arrays: 	(aeltype,inxtype: stp);
+	 records:	(fstfld: ctp; recvar: stp);
+	 objects:	(objfld: ctp;		{object fields}
+			 objsize: addrrange;	{object size}
+                         objname: pstringptr;	{object name}
+                         objlevel: integer;	{generation level}
+                         objparent: stp;	{parent or nil}
+                         );
+	 files:		(filtype: stp; filsize: addrrange);
+	 tagfld: 	(tagfieldp: ctp; fstvar: stp);
+	 variant:	(nxtvar,subvar: stp; varval: integer)
+      end;
+
+					{constants}
+					{---------}
+   cstclass = (reel,pset,strg,chset,longC);
+   settype = set of setlow..sethigh;
+
+   csp = ^ constantRec;
+				{NOTE: Size in scanner.asm}
+				{NOTE: Partial sizes here and in scanner.asm}
+   constantRec = record
+      case cclass: cstclass of
+	 longC:(lval: longint);
+	 reel: (rval: double);
+	 pset: (pval: settype;
+		pmax: setlow..sethigh);
+	 chset:(ch: packed array[0..255] of char);
+	 strg: (sval: pString);
+	 end;
+
+   valu = record case boolean of
+      true  :(ival: integer);
+      false: (valp: csp)
+      end;
+					{names}
+					{-----}
+
+   directive_type = (drnone,drforw,drextern,drprodos,drtool1,drtool2,drvector,
+                     droverride);
+   idclass = (types,konst,varsm,field,proc,func,directive,prog);
+   setofids = set of idclass;
+   idkind = (actual,formal);
+   levrange = 0..maxlevel;
+   keyrange = 1..53;			{range of std proc nums}
+
+					{NOTE: Disps in scanner.asm}
+   identifier = record
+      name: pStringPtr;			{name of the identifier}
+      llink, rlink: ctp; 		{links for symbol tree}
+      idtype: stp;			{type of identifier}
+      next: ctp;
+      hasIFile: boolean;
+      case klass: idclass of
+	 konst: (values: valu);		{constant value}
+	 varsm: (vkind: idkind;
+		 vlev: levrange; 	{declaration level}
+		 vitem: integer;
+		 vlabel: unsigned;	{variable label}
+		 vcontvar: boolean;
+		 fromUses: boolean;
+		 vrestrict: boolean;
+		 vuniv: boolean; 	{for parameters, is it universal?}
+		 vPrivate: boolean;
+		 );
+	 field: (fldaddr: addrrange;
+		 fldvar: boolean;
+		 );
+	 prog,
+	 proc,
+	 func:	(case pfdeckind: declkind of
+		  standard: (key: keyrange);
+		  declared: (pflev: levrange;		{static level}
+			     pfname: integer;		{subroutine name}
+                             pfoname: pStringPtr;	{object.method name}
+			     pfactualsize: integer;	{size of parameters}
+			     pflabel: unsigned;
+			     pfset: boolean;		{has func. return value been set?}
+			     pfmark: markPtr;		{memory mark}
+			     pfPrivate: boolean;
+                             pfaddr: addrrange;		{method object disp}
+                             pfparms: ctp;		{parameter list}
+			     case pfkind: idkind of
+			       actual: (pfdirective: directive_type;
+					pfcallnum, pftoolnum: integer;
+				       );
+			       formal: (pflab: unsigned;
+			                pfnext: ctp;
+				       );
+			    );                      
+		);
+	 directive: (drkind: directive_type);
+	 types: ();
+      end;
+
+					{NOTE: Disps in scanner.asm}
+					{NOTE: Size in scanner.asm}
+   lptr = ^ltype;			{linked list of identifiers used from}
+   ltype = record			{ other levels}
+      next: lptr;			{next record}
+      name: pStringPtr;			{identifier that was used}
+      disx: disprange;			{level of the identifier}
+      end;
+
+   partialptr = ^partialname;		{partial compile ptr}
+   partialname = record			{partial name}
+      next: partialptr;
+      pname: pStringPtr;
+      end;
+
+					{labels}
+					{------}
+  starrtype = array[1..maxgoto] of integer;
+  lbp = ^ labl;
+  labl = record
+	   nextlab: lbp;
+	   defined: boolean;
+	   lstlevel: integer;
+	   lstarray: starrtype;
+	   labval, labname: integer;
+	 end;
+
+					{expression attributes}
+					{---------------------}
+   attrkind = (cst,varbl,expr);
+   vaccess = (drct,indrct,inxd);
+
+   attrptr = ^attr;
+   attr = record
+      typtr: stp;			{type of the expression}
+      isPacked: boolean;		{is this value packed?}
+      case kind: attrkind of		{form of the expression}
+	 cst:	 (cval: valu);		{... a constant}
+	 expr:	 ();
+	 varbl:	 (case access: vaccess of {... a variable}
+		  drct: (vlevel: levrange;
+			 dplab: unsigned;
+			 dpdisp: addrrange;
+			 aname: pStringPtr;
+			 );
+		  indrct: (idplmt: addrrange);	{... a pointer to something}
+		  inxd: ()
+		  );
+      end;
+
+					{files}
+					{-----}
+   extfilep = ^filerec;
+   filerec = record
+      filename: pStringPtr;
+      nextfile: extfilep
+      end;
+
+   gsosInString = record
+       size: integer;
+       theString: packed array [1..maxPath] of char;
+       end;
+   gsosInStringPtr = ^gsosInString;
+
+   {GS/OS class 1 output string}
+   gsosOutString = record
+       maxSize: integer;
+       theString: gsosInString;
+       end;
+   gsosOutStringPtr = ^gsosOutString;
+
+					{ORCA Shell and ProDOS}
+					{---------------------}
+   consoleOutDCBGS = record
+      pcount: integer;
+      ch: char;
+      end;
+
+   destroyOSDCB = record		{Destroy DCB}
+      pcount: integer;
+      pathName: gsosInStringPtr;
+      end;
+
+   timeField = array[1..8] of byte;
+
+   optionListRecord = record
+      totalSize: integer;
+      requiredSize: integer;
+      fileSysID: integer;
+      theData: packed array [1..100] of char;
+      end;
+   optionListPtr = ^optionListRecord;
+
+   errorDCBGS = record
+      pcount: integer;
+      error: integer;
+      end;
+
+   expandDevicesDCBGS = record
+      pcount: integer;
+      inName: gsosInStringPtr;
+      outName: gsosOutStringPtr;
+      end;
+
+   fastFileDCBGS = record
+      pcount: integer;
+      action: integer;
+      index: integer;
+      flags: integer;
+      fileHandle: handle;
+      pathName: gsosInStringPtr;
+      access: integer;
+      fileType: integer;
+      auxType: longint;
+      storageType: integer;
+      createDate: timeField;
+      modDate: timeField;
+      option: optionListPtr;
+      fileLength: longint;
+      blocksUsed: longint;
+      end;
+
+   getFileInfoOSDCB = record
+      pcount: integer;
+      pathName: gsosInStringPtr;
+      access: integer;
+      fileType: integer;
+      auxType: longint;
+      storageType: integer;
+      createDateTime: timeField;
+      modDateTime: timeField;
+      optionList: optionListPtr;
+      dataEOF: longint;
+      blocksUsed: longint;
+      resourceEOF: longint;
+      resourceBlocks: longint;
+      end;
+
+   getLInfoDCBGS = record
+      pcount: integer;
+      sFile: gsosOutStringPtr;
+      dFile: gsosOutStringPtr;
+      namesList: gsosOutStringPtr;
+      iString: gsosOutStringPtr;
+      merr: byte;
+      merrf: byte;
+      lops: byte;
+      kFlag: byte;
+      mFlags: longint;
+      pFlags: longint;
+      org: longint;
+      end;
+
+   versionDCBGS = record
+      pcount: integer;
+      version: packed array[1..4] of char;
+      end;
+
+var
+					{misc}
+					{----}
+   chEndPtr: ptr;			{pointer to the end of the current file}
+   chPtr: ptr;				{pointer to the next line of the current file}
+   filePtr: ptr; 			{pointer to the start of the current file}
+
+					{counters:}
+					{---------}
+   intLabel: integer;			{last label number used}
+   linecount: integer;			{line number for current line}
+
+					{flags & switches}
+					{----------------}
+   wait: boolean;			{wait for keypress on non-terminal error?}
+   allTerm: boolean;			{treat all errors as terminal?}
+   dataBank: boolean;			{save, restore data bank?}
+   debug: boolean;			{generate range check code?}
+   doingUnit: boolean;			{compiling a unit?}
+   goToEditor: boolean;			{return to editor on a terminal error?}
+   iso: boolean; 			{iso only?}
+   liDCBGS: getLInfoDCBGS;		{get/set LInfo DCB}
+   list: boolean;			{list source?}
+   memoryFlag: boolean;			{+M flag from command line?}
+   noGlobalLabels: boolean;		{have any global labels been detected?}
+   noinput,nooutput,noerroroutput: boolean; {tells if stan. dev. are declared}
+   printer: boolean;			{is the printer on?}
+   printSymbols: boolean;		{print the symbol table?}
+   progfound: boolean;			{tells if the code has started}
+   progress: boolean;			{print progress information?}
+   prterr: boolean;			{to allow forward references in pointer
+					 type declaration by supressing error
+					 messages}
+   stringHeap: boolean;			{has the string heap been used?}
+
+					{error reporting}
+					{---------------}
+   errinx: 0..maxErr;			{number of errors on this line}
+   errlist: array[1..maxErr] of errtype; {list of errors}
+   numerr: unsigned;			{number of errors in the program}
+
+{---------------------------------------------------------------}
+
+					{scanner}
+					{-------}
+   chCnt: unsigned;			{character counter}
+   lCnt: unsigned;			{# lines written on this page}
+   pageSize: unsigned;			{printing lines on a page}
+   title: pString;			{title}
+
+					{expression compilation:}
+					{-----------------------}
+   gattr: attr;				{describes the expr currently compiled}
+   gispacked: boolean;			{was last identifier a component of
+					 a packed structure?}
+   glcp: ctp;				{last identifier in an expression}
+
+					{structured constants:}
+					{---------------------}
+   na:	array [1..77] of pStringPtr;
+
+					{file names}
+					{----------}
+   fNameGS: gsosOutString;		{current source file name}
+   kNameGS: gsosOutString;		{Keep file name}
+   subsGS: gsosOutString;		{List of subroutines for partial compile}
+   ldInfoGS: gsosOutString;		{language dependent parameters (not used)}
+   intPrefixGS: gsosOutString;		{prefix to search for interface files}
+   usesFileNameGS: gsosOutString;	{active uses file name}
+
+					{bookkeeping of declaration levels:}
+					{----------------------------------}
+   disx: disprange;			{level of last id searched by searchid}
+   level: levrange;			{current static level}
+   top: disprange;			{top of display}
+   nextLocalLabel: unsigned;		{next available local data label number}
+
+					{NOTE: Disps in scanner.asm}
+					{NOTE: Size in scanner.asm}
+   display:				{where:	  means:}
+      array [disprange] of record
+	 ispacked: boolean;
+	 labsused: lptr; 		{list of labels used from other levels}
+	 fname: ctp;
+	 flabel: lbp;
+	 case occur: where of		{=blck:	  id is variable id}
+	    crec: (clev: levrange;	{=crec:	  id is field id in record with}
+		  cdspl: addrrange;	{	  constant address}
+                  clab: unsigned;
+		  cname: pStringPtr);
+	    vrec: (vdsplab: unsigned);	{=vrec:	  id is field id in record with}
+                                      	{	  variable address}
+	    rec,blck:();
+	 end;				{ --> procedure withstatement}
+
+{---------------------------------------------------------------}
+
+					{ORCA Shell and ProDOS}
+					{---------------------}
+
+procedure DestroyGS (var parms: destroyOSDCB); prodos ($2002);
+
+procedure ErrorGS (var parms: errorDCBGS); prodos ($0145);
+
+procedure GetFileInfoGS (var parms: getFileInfoOSDCB); prodos ($2006);
+
+procedure GetLInfoGS (var parms: getLInfoDCBGS); prodos ($0141);
+
+procedure ExpandDevicesGS (var parms: expandDevicesDCBGS); prodos ($0154);
+
+procedure FastFileGS (var parms: fastFileDCBGS); prodos ($014E);
+
+procedure SetLInfoGS (var parms: getLInfoDCBGS); prodos ($0142);
+
+procedure VersionGS (var parms: versionDCBGS); prodos ($0147);
+
+{---------------------------------------------------------------}
+
+procedure Brk (code: integer); extern;
+
+{ Break into the debugger					}
+{								}
+{ parameters:							}
+{    code - BRK code						}
+
+
+function Calloc (size: integer): ptr; extern;
+
+{ Allocate and clear memory					}
+{								}
+{ parameters:							}
+{    size - number of bytes to reserve				}
+{								}
+{ Returns: pointer to the memory 				}
+
+
+procedure ClearHourGlass;
+
+{ Erase the hourglass from the screen				}
+
+
+function CompNames (var name1,name2: pString): integer; extern;
+
+{ Compare two identifiers					}
+{								}
+{ parameters:							}
+{    name1, name2 - identifiers to compare			}
+{								}
+{ Returns:	-1 if name1 < name2				}
+{		0 if name1 = name2				}
+{		1 if name1 > name2				}
+
+
+procedure CopyString (var s1,s2: pString; len: integer); extern;
+
+{ copy a string from s2 to s1					}
+{								}
+{ parameters:							}
+{    s1 - string buffer to copy to				}
+{    s2 - string buffer to copy from				}
+{    len - length of the s1 string buffer			}
+
+
+procedure DrawHourGlass;
+
+{ Draw the hourglass on the screen				}
+
+
+procedure Error (err: integer);
+
+{ flag an error in the current line				}
+{								}
+{ parameters:							}
+{    err - error number						}
+
+
+{procedure Error2 (loc, err: integer); {debug}
+
+{ flag an error in the current line				}
+{								}
+{ parameters:							}
+{    loc - error location					}
+{    err - error number						}
+
+
+procedure FlagError;
+
+{ do all error processing except writing the message		}
+
+
+function GenLabel: integer;
+
+{ generate the next local label, checking for too many		}
+
+
+function GetFileType (var name: gsosOutString): integer;
+
+{ Checks to see if a file exists				}
+{								}
+{ parameters:							}
+{    name - file name to check for				}
+{								}
+{ Returns: File type if the file exists, or -1 if the file does	}
+{    not exist (or if GetFileInfo returns an error)		}
+
+
+function GetLocalLabel: integer;
+
+{ get the next local label number				}
+
+
+procedure InitPCommon;
+
+{ Initialize this module 					}
+
+
+function KeyPress: boolean; extern;
+ 
+{ Has a key been presed?                                        }
+{                                                               }
+{ If a key has not been pressed, this function returns          }
+{ false.  If a key has been pressed, it clears the key          }
+{ strobe.  If the key was an open-apple ., a terminal exit      }
+{ is performed; otherwise, the function returns true.           }
+ 
+
+procedure LineFeed;
+
+{ generate a line feed						}
+
+
+function Malloc (size: integer): ptr; extern;
+
+{ Allocate memory						}
+{								}
+{ parameters:							}
+{    size - number of bytes to reserve				}
+{								}
+{ Returns: pointer to the memory 				}
+
+
+procedure MMInit; extern;
+
+{ initialize the memory manager					}
+
+
+procedure Mark (var p: markPtr); extern;
+
+{ mark the heap							}
+{								}
+{ parameters:							}
+{    p - location to save mark pointer				}
+
+
+procedure PurgeSource;
+
+{ Purge the current source file					}
+
+
+procedure Release (p: markPtr); extern;
+
+{ release previously marked heap area				}
+{								}
+{ parameters:							}
+{    p - release all memory from this point on			}
+
+
+procedure StdNames; extern;
+
+{ initialize the na array					}
+
+
+procedure Spin;
+
+{ Spin the spinner						}
+{								}
+{ Notes: Starts the spinner if it is not already in use		}
+
+
+procedure StopSpin;
+
+{ Stop the spinner						}
+{								}
+{ Notes: The call is safe, and ignored, if the spinner is	}
+
+
+procedure SystemError (errNo: integer);
+
+{ intercept run time compiler errors				}
+
+
+procedure TermError (err: unsigned; msg: pStringPtr);
+
+{ Flag a terminal error						}
+{								}
+{ parameters:							}
+{    err - terminal error number 				}
+{    msg - error message, or nil for one of the standard errors	}
+{								}
+{ Notes: err is not used if msg <> nil				}
+
+
+procedure WaitForKeyPress; extern;
+
+{ If +w has been used, waits for a keypress			}
+
+{---------------------------------------------------------------}
+
+implementation
+
+const
+					{spinner}
+					{-------}
+   spinSpeed = 8;			{calls before one spinner move}
+
+var
+					{spinner}
+					{-------}
+
+   spinning: boolean;			{are we spinning now?}
+   spinDisp: integer;			{disp to the spinner character}
+   spinCount: integer;			{spin loop counter}
+
+   spinner: array[0..3] of char; 	{spinner characters}
+
+procedure ConsoleOutGS (var parms: consoleOutDCBGS); prodos ($015A);
+
+procedure SystemQuitFlags (flags: integer); extern;
+
+{---------------------------------------------------------------}
+
+procedure ExitToEditor (msg: pStringPtr; disp: longint);
+
+{  do an error exit to the editor				}
+{								}
+{  parameters:							}
+{	msg - pointer to the error message			}
+{	disp - displacement into the error file			}
+{								}
+{  variables:							}
+{	includeFile - source file name				}
+
+var
+   msgGS: gsosInString;			{message}
+
+begin {ExitToEditor}
+msgGS.size := length(msg^);		{set up the error message}
+msgGS.theString := msg^;
+liDCBGS.org := disp;			{mark the error}
+liDCBGS.namesList := @msgGS;
+liDCBGS.lops := 0;			{prevent re-entry}
+liDCBGS.merrf := 255;
+with liDCBGS do begin
+   sFile := pointer(ord4(sFile)+2);
+   dFile := pointer(ord4(dFile)+2);
+   iString := pointer(ord4(iString)+2);
+   end; {with}
+SetLInfoGS(liDCBGS);
+StopSpin;				{stop the spinner}
+halt(-1);				{return to the shell}
+end; {ExitToEditor}
+
+{---------------------------------------------------------------}
+
+procedure ClearHourGlass;
+
+{ Erase the hourglass from the screen				}
+
+var
+   coRec: consoleOutDCBGS;		{Console out record}
+
+begin {ClearHourGlass}
+coRec.pcount := 1;
+coRec.ch := ' '; 	ConsoleOutGS(coRec);
+coRec.ch := chr(8);	ConsoleOutGS(coRec);
+end; {ClearHourGlass}
+
+
+procedure DrawHourGlass;
+
+{ Draw the hourglass on the screen				}
+
+var
+   coRec: consoleOutDCBGS;		{Console out record}
+
+begin {DrawHourGlass}
+coRec.pcount := 1;
+coRec.ch := chr(27);	ConsoleOutGS(coRec);
+coRec.ch := chr(15);	ConsoleOutGS(coRec);
+coRec.ch := 'C'; 	ConsoleOutGS(coRec);
+coRec.ch := chr(24);	ConsoleOutGS(coRec);
+coRec.ch := chr(14);	ConsoleOutGS(coRec);
+coRec.ch := chr(8);	ConsoleOutGS(coRec);
+end; {DrawHourGlass}
+
+
+procedure Error {err: integer};
+
+{ flag an error in the current line				}
+{								}
+{ parameters:							}
+{    err - error number						}
+
+begin {Error}
+if errinx >= maxErr - 1 then begin
+   errlist[maxErr].nmr := 109;
+   errinx := maxErr;
+   end {if}
+else begin
+   errinx := errinx + 1;
+   errlist[errinx].nmr := err;
+   numerr := numerr + 1;
+   end; {else}
+errlist[errinx].pos := chCnt;
+if liDCBGS.merrf < 16 then
+   liDCBGS.merrf := 16;
+end; {Error}
+
+
+{procedure Error2 {loc, err: integer); {debug}
+
+{ flag an error in the current line				}
+{								}
+{ parameters:							}
+{    loc - error location					}
+{    err - error number						}
+
+{begin {Error2}
+{writeln('Error ', err:1, ' flagged at ', loc:1);
+Error(err);
+end; {Error2}
+
+
+procedure FlagError;
+
+{ do all error processing except writing the message		}
+
+begin {FlagError}
+LineFeed;				{write the carriage return}
+numerr := numerr+1;			{increment the number of errors}
+WaitForKeyPress; 			{wait for a keypress}
+if liDCBGS.merrf < 16 then		{set the error level}
+   liDCBGS.merrf := 16;
+end; {FlagError}
+
+
+function GenLabel{: integer};
+
+{ generate the next local label, checking for too many		}
+
+begin {GenLabel}
+if intLabel < maxLabel then
+   intLabel := intLabel+1
+else begin
+   intLabel := 0;
+   Error(102);
+   end;
+GenLabel := intLabel;
+end; {GenLabel}
+
+
+function GetFileType {var name: gsosOutString): integer};
+
+{ Checks to see if a file exists				}
+{								}
+{ parameters:							}
+{    name - file name to check for				}
+{								}
+{ Returns: File type if the file exists, or -1 if the file does	}
+{    not exist (or if GetFileInfo returns an error)		}
+
+var
+   giRec: getFileInfoOSDCB;		{GetFileInfo record}
+
+begin {GetFileType}
+giRec.pcount := 3;
+giRec.pathName := @name.theString;
+GetFileInfoGS(giRec);
+if ToolError = 0 then
+   GetFileType := giRec.fileType
+else
+   GetFileType := -1;
+end; {GetFileType}
+
+
+function GetLocalLabel{: integer};
+
+{ get the next local label number				}
+
+begin {GetLocalLabel}
+GetLocalLabel := nextLocalLabel;
+nextLocalLabel := nextLocalLabel+1;
+end; {GetLocalLabel}
+
+
+procedure InitPCommon;
+
+{ Initialize this module 					}
+
+var
+   vDCBGS: versionDCBGS;		{for checking the version number}
+
+begin {InitPCommon}
+SystemQuitFlags($4000);			{make sure we quit with restart set}
+
+vDCBGS.pCount := 1;			{check the version number}
+VersionGS(vDCBGS);
+if vDCBGS.version[1] < '2' then
+   TermError(14, nil);
+
+spinning := false;			{not spinning the spinner}
+spinDisp := 0;				{start spinning with the first character}
+spinner[0] := '|';			{set up the spinner characters}
+spinner[1] := '/';
+spinner[2] := '-';
+spinner[3] := '\';
+end; {InitPCommon}
+
+
+procedure LineFeed;
+
+{ generate a line feed						}
+
+begin {LineFeed}
+writeln;
+if printer then begin
+   lcnt := lcnt+1;
+   if lcnt = pageSize then begin
+      if length(title) = 0 then
+	 lcnt := 0
+      else begin
+	 lcnt := 2;
+	 writeln(title);
+	 writeln;
+	 end; {else}
+      end; {if}
+   end; {if}
+end; {LineFeed}
+
+
+procedure PurgeSource;
+
+{ Purge the current source file					}
+
+var
+   ffDCBGS: fastFileDCBGS;		{FastFile record}
+
+begin {PurgeSource}
+with ffDCBGS do begin
+   pCount := 5;
+   action := 7;
+   pathName := @fNameGS.theString;
+   end; {with}
+FastFileGS(ffDCBGS);
+end; {PurgeSource}
+
+
+procedure Spin;
+
+{ Spin the spinner						}
+{								}
+{ Notes: Starts the spinner if it is not already in use		}
+
+var
+   coRec: consoleOutDCBGS;		{Console out record}
+
+begin {Spin}
+if not spinning then begin
+   spinning := true;
+   spinCount := spinSpeed;
+   end; {if}
+spinCount := spinCount - 1;
+if spinCount = 0 then begin
+   spinCount := spinSpeed;
+   spinDisp := spinDisp - 1;
+   if spinDisp < 0 then
+      spinDisp := 3;
+   coRec.pcount := 1;
+   coRec.ch := spinner[spinDisp];
+   ConsoleOutGS(coRec);
+   coRec.ch := chr(8);
+   ConsoleOutGS(coRec);
+   end; {if}
+end; {Spin}
+
+
+procedure StopSpin;
+
+{ Stop the spinner						}
+{								}
+{ Notes: The call is safe, and ignored, if the spinner is	}
+{	inactive.						}
+
+var
+   coRec: consoleOutDCBGS;		{Console out record}
+
+begin {StopSpin}
+if spinning then begin
+   spinning := false;
+   coRec.pcount := 1;
+   coRec.ch := ' ';
+   ConsoleOutGS(coRec);
+   coRec.ch := chr(8);
+   ConsoleOutGS(coRec);
+   end; {if}
+end; {StopSpin}
+
+
+procedure SystemError {errNo: integer};
+
+{ intercept run time compiler errors				}
+
+begin {SystemError}
+if errNo = 5 then
+   TermError(3, nil)
+else
+   TermError(7, nil);
+end; {SystemError}
+
+
+procedure TermError {err: unsigned; msg: pStringPtr};
+
+{ Flag a terminal error						}
+{								}
+{ parameters:							}
+{    err - terminal error number 				}
+{    msg - error message, or nil for one of the standard errors	}
+{								}
+{ Notes: err is not used if msg <> nil				}
+
+begin {TermError}
+PurgeSource;				{purge the source file}
+if msg = nil then
+   case err of
+      0:msg := @'User termination';
+      1:msg := @'Not enough bank zero memory';
+      2:msg := @'Non-Pascal file opened at an inappropriate time';
+      3:msg := @'Out of memory';
+      4:msg := @'Tool or ProDOS error - see listing file';
+      5:msg := @'Segment buffer overflow';
+      6:msg := @'Error reading uses file';
+     {7:msg := @'Compiler error';}
+      8:msg := @'Could not open the object file';
+      9:msg := @'Could not delete interface file';
+     10:msg := @'Units cannot be compiled to memory';
+     11:msg := @'Source files must end with a return';
+     12:msg := @'Error writing uses file';
+     13:msg := @'Error writing object file';
+     14:msg := @'ORCA/Pascal requires version 2.0 or later of the shell';
+     otherwise:
+	msg := @'Compiler error';
+     end; {case}
+writeln('Terminal error: ', msg^);
+if gotoEditor then			{error exit to editor}
+   ExitToEditor(msg, ord4(chPtr) - ord4(filePtr) + chCnt)
+else begin
+   liDCBGS.lops := 0;			{prevent re-entry}
+   liDCBGS.merrf := 127;
+   with liDCBGS do begin
+      sFile := pointer(ord4(sFile)+2);
+      dFile := pointer(ord4(dFile)+2);
+      namesList := pointer(ord4(namesList)+2);
+      iString := pointer(ord4(iString)+2);
+      end; {with}
+   SetLInfoGS(liDCBGS);
+   StopSpin;				{stop the spinner}
+   halt(-1);				{return to the shell}
+   end; {else}
+end; {TermError}
+
+end.
+
+{$append 'pcommon.asm'}
diff --git a/scanner.asm b/scanner.asm
old mode 100755
new mode 100644
index c6d87ec..3f85230
--- a/scanner.asm
+++ b/scanner.asm
@@ -1 +1,1929 @@
-	mcopy	scanner.macros
****************************************************************
*
*  GetCom - Common Data for Get Character Module
*
****************************************************************
*
GetCom	data
;
;  Constants
;
autoGo	gequ	$06	auto-Go key code
breakPoint gequ $07	breakpoint key code
maxCnt	gequ	256	# chars on a line + 1
maxPath	gequ	255	max length of a path name
return	equ	$0D	RETURN key code
tab	equ	$09	tab key code
;
;  Size of pascal structures
;
constantSize equ 258	size of a constantRec
constantSize_longC   equ 6
constantSize_reel    equ 10
constantSize_pset    equ 260
constantSize_chset   equ 258
constantSize_strg    equ 258

displaySize equ 28	size of an element of the display array
ltypeSize equ 10	size of an ltype record
;
;  Displacements into records, by record-name_field-name
;
constant_rval equ 2	disp in constant of real value
constant_lval equ 2	disp in constant of longint value
constant_sval gequ 2	disp in constant of string characters

identifier_llink equ 4	disp in identifier of left link
identifier_rlink equ 8	disp in identifier of right link
identifier_klass equ 22	disp in identifier of klass record

display_ispacked equ 0	disp in display of ispacked field
display_labsused equ 2	disp in display of labsused
display_fname equ 6	disp in display of fname

ltype_next equ 0	disp in ltype of next
ltype_name equ 4	disp in ltype of name
ltype_disx equ 8	disp in ltype of disx

valu_ival equ	0	disp in valu of integer value
valu_valp equ	0	disp in valu of value pointer
;
;  Variables
;
digit	ds	maxCnt	string for building numeric constants
endOfUses ds	2	at end of a uses file?
test	ds	2
tInSymbol ds	3	first 3 bytes of InSymbol
;
;  Enumerations
;
bools	enum	(false,true),0
symbol	enum	(ident,intconst,realconst,stringconst,notsy,mulop,addop,relop),0
	enum	(lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow)
	enum	(colon,dotdot,becomes,labelsy,constsy,typesy,varsy,funcsy,progsy)
	enum	(procsy,setsy,packedsy,arraysy,recordsy,filesy,nilsy)
	enum	(beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy)
	enum	(gotosy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy)
	enum	(thensy,othersy,otherwisesy,powersy,bitnot,usessy,stringsy)
	enum	(atsy,longintconst,unitsy,interfacesy,implementationsy)
	enum	(univsy,objectsy,inheritedsy)
operator enum	(noop,mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop),0
	enum	(gtop,neop,eqop,inop,band,bor,xor,rshift,lshift)
cstclass enum	(reel,pset,strg,chset,long),0
chtp	enum	(letter,number,special,illegal,underLine),0
	enum	(chLComt,chStrQuo,chColon,chPeriod,chlt,chgt)
	enum	(chLParen,chSpace,chAsterisk,chDollar,chAt)
;
;  Structured constants
;
charTp	entry		character types
	dc	8i1'illegal'
	dc	i1'illegal,chSpace',6I1'illegal'
	dc	8i1'illegal'
	dc	8i1'illegal'
	dc	i1'chSpace,special,illegal,illegal,chDollar,illegal,special,chStrQuo'
	dc	i1'chLParen,special,chAsterisk,special,special,special,chPeriod,special'
	dc	8i1'number'
	dc	i1'number,number,chColon,special,chlt,special,chgt,illegal'
	dc	i1'chAt',7I1'letter'
	dc	8i1'letter'
	dc	8i1'letter'
	dc	3i1'letter',I1'special,illegal,special,special,underLine'
	dc	8i1'illegal'
	dc	8i1'illegal'
	dc	8i1'illegal'
	dc	3i1'illegal',I1'chLComt,special,illegal,special,illegal'

	dc	8i1'letter'	$80
	dc	8i1'letter'
	dc	8i1'letter'	$90
	dc	8i1'letter'
	dc	7i1'illegal',i1'letter'	$A0
	dc	5i1'illegal',i1'special',2i1'letter'
	dc	2i1'illegal',2i1'special',4i1'letter'	$B0
	dc	i1'letter,letter,illegal,letter,letter,letter,letter,letter'
	dc	i1'illegal,illegal,illegal,illegal,letter,illegal,letter,special'
	dc	i1'special,illegal,chSpace',5i1'letter'
	dc	6i1'illegal',i1'special',i1'illegal'	$D0
	dc	i1'letter,illegal,illegal,illegal,illegal,illegal,letter,letter'
	dc	8i1'illegal'	$E0
	dc	8i1'illegal'
	dc	8i1'illegal'	$F0
	dc	8i1'illegal'

uppercase anop
 dc i1'$00,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0A,$0B,$0C,$0D,$0E,$0F'
 dc i1'$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$1A,$1B,$1C,$1D,$1E,$1F'
 dc i1'$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$2A,$2B,$2C,$2D,$2E,$2F'
 dc i1'$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$3A,$3B,$3C,$3D,$3E,$3F'
 dc c'@ABCDEFGHIJKLMNO'
 dc c'PQRSTUVWXYZ[\]^_'
 dc c'`ABCDEFGHIJKLMNO'
 dc c'PQRSTUVWXYZ{|}~',i1'$7F'
 dc i1'$80,$81,$82,$83,$84,$85,$86,$87,$CB,$89,$80,$CC,$81,$82,$83,$8F'
 dc i1'$90,$91,$92,$93,$94,$95,$84,$97,$98,$99,$85,$CD,$9C,$9D,$9E,$86'
 dc i1'$A0,$A1,$A2,$A3,$A4,$A5,$A6,$A7,$A8,$A9,$AA,$AB,$AC,$AD,$AE,$AF'
 dc i1'$B0,$B1,$B2,$B3,$B4,$B5,$C6,$B7,$B8,$B8,$BA,$BB,$BC,$BD,$AE,$AF'
 dc i1'$C0,$C1,$C2,$C3,$C4,$C5,$C6,$C7,$C8,$C9,$CA,$CB,$CC,$CD,$CE,$CE'
 dc i1'$D0,$D1,$D2,$D3,$D4,$D5,$D6,$D7,$D8,$D9,$DA,$DB,$DC,$DD,$DE,$DF'
 dc i1'$E0,$E1,$E2,$E3,$E4,$E5,$E6,$E7,$E8,$E9,$EA,$EB,$EC,$ED,$EE,$EF'
 dc i1'$F0,$F1,$F2,$F3,$F4,$F5,$F6,$F7,$F8,$F9,$FA,$FB,$FC,$FD,$FE,$FF'
;
;  DCB's
;
st_dcb	anop		stop dcb
st_flag	ds	2
	end

****************************************************************
*
*  EndDigit - Flag the end of a digit
*
*  Inputs:
*	Y - disp in line
*	X - disp in digit
*
****************************************************************
*
EndDigit private
	using GetCom

	stz	digit,X
	sty	chCnt
	jsl	NextCh
	rts
	end

****************************************************************
*
*  EndOfLine - Read in the next source line
*
*  Inputs:
*	chPtr - pointer to the next line to read
*
*  Outputs:
*	LINECOUNT - updated; # lines read
*	chPtr - updated
*	LINE - characters in this line
*	ERRINX - # errors in this line; set to 0
*	chCnt - # characters read from the line; set to 0
*
****************************************************************
*
EndOfLine private
	using GetCom
cPtr	equ	1	local copy of chPtr

         sub	,4

	move4	chPtr,cPtr	cPtr := chPtr
	stop	st_dcb	if user flagged an abort then
	lda	st_flag	  TermError(0, nil);
	beq	st1
	ph2	#0
	ph4	#0
	jsl	TermError
st1	jsl	ListLine	ListLine;
	inc	LINECOUNT	linecount := linecount+1;
	clc		<skip to end of old line>
	lda	cPtr
	adc	chCnt
	sta	cPtr
	bcc	lb1
	inc	cPtr+2
lb1	stz	chCnt	chCnt := 0;
	stz	ERRINX	ERRINX := 0;
	stz	debugType	DEBUGTYPE := 0;
	lda	[cPtr]	if cPtr^ in [autoGo,breakPoint] then
	and	#$00FF	  begin
	cmp	#breakPoint
	beq	lb2
	cmp	#autoGo
	bne	lb4	  if cPtr^ = autoGo then
	lda	#2	    debugType := 2
	bra	lb3	  else
lb2	lda	#1	    debugType := 1;
lb3	sta	debugType
	inc4	cPtr	  cPtr := pointer(ord4(cPtr)+1);
lb4	anop		  end; {if}

	move4	cPtr,chPtr	chPtr := cPtr
	ret
	end

****************************************************************
*
*  FakeInsymbol - install the uses file InSymbol patch
*
****************************************************************
*
FakeInsymbol private
	using GetCom

	lda	InSymbol	set up fake InSymbol
	sta	tInSymbol
	lda	InSymbol+1
	sta	tInSymbol+1
	lda	jmp
	sta	InSymbol
	lda	jmp+1
	sta	InSymbol+1
	rtl

jmp	jmp	UsesInSymbol
	end

****************************************************************
*
*  InSymbol - Read the next symbol from the source file
*
*  Outputs:
*	SY - kind of symbol found
*	OP - classification of symbol
*	VAL - value of last constant
*	LGTH - length of last string constant
*	ID - last identifier
*
****************************************************************
*
InSymbol start
	using GetCom
rwLen	equ	15	# bytes in a reserved word

cPtr	equ	1	local copy of chPtr
lvp	equ	5	constant record
count	equ	9	loop counter
aindex	equ	11	array index
k	equ	13	temp index variable

	sub	,14

lb1	lda	endOfUses	if endOfUses then
	beq	lab1
	lda	#othersy	  sy := othersy;
	sta	SY
	stz	endOfUses	  endOfUses := false;
	brl	end	  return;

lab1	anop		1:
	lda	CH	  while (charTp[ch] = chSpace) and
	cmp	#' '	    not eofl do
	beq	lb2	    nextch;
	cmp	#$CA
	beq	lb2
	cmp	#tab
	bne	lb4
lb2	lda	EOFL
	bne	lb3
	jsl	NextCh
	bra	lb1
lb3	lda	CH	  case charTp[ch] of
lb4	tax
	lda	charTp,X
	and	#$00FF
	asl	A
	tax
	jmp	(caseTable,X)

caseTable anop		jump table for the case statement
	dc	a'lr1'	letter
	dc	a'nm1'	number
	dc	a'sp1'	special
	dc	a'il1'	illegal
	dc	a'un1'	underLine
	dc	a'cm1'	clLComt
	dc	a'qt1'	chStrQuo
	dc	a'cl1'	colon
	dc	a'dt1'	period
	dc	a'lt1'	chlt
	dc	a'gt1'	chgt
	dc	a'lp1'	chLParen
	dc	a'bl1'	chSpace
	dc	a'as1'	chAsterisk
	dc	a'dl1'	chDollar
	dc	a'at1'	chAt
;
;  Flag and skip illegal characters
;
il1	anop		    illegal: begin
	listerror #6	      error(6);
	jsl	NextCh	      nextch;
	brl	lab1	      goto 1;
;			      end;
;
;  Skip leading white space
;
bl1	anop		    chSpace:
	lda	#otherSy	      sy := othersy;
	sta	SY
	brl	end
;
;  Handle identifiers and reserved words
;
un1	anop		    underline,
lr1	anop		    letter: begin
	move4	chPtr,cPtr
!			      k := 0;
!			      id[0] := chr(0);
	stz	id
	ldy	chCnt
	dey
	ldx	#0
	short M
lr2	anop		      repeat
	lda	[cPtr],Y		if iso then
	cmp	#'_'		  if (ch = '_')
	beq	lr2a
	cmp	#$80		    or (ord(ch) > $7F) then
	blt	lr4
lr2a	pha
	lda	ISO
	beq	lr3
	long	M		    error(112);
	phx
	phy
	listerror #112
	ply
	plx
	lda	#0
	short M
lr3	pla
!				k := k+1;
lr4	stx	k		if k <= maxcnt then
	tax			  id[k] := ch;
	lda	upperCase,X
	tax
	lda	charTp,X
	cmp	#letter
	beq	lr6
	cmp	#number
	beq	lr6
	cmp	#underLine
	bne	lr7
lr6	txa
	ldx	k
	sta	id+1,X
	iny			nextch;
	inx
	bra	lr2	      until not
!				(charTp[ch] in
!				[letter,number,underscore]);
lr7	sty	chCnt
	lda	k	      id[0] := chr(k);
	sta	id
	long	M
	jsr	LNextCh
	lda	k	      if k < rwLen then begin
	cmp	#rwLen
	jge	lr9a
	lda	id+1		index := ord(id[1])-ord('a');
	and	#$00FF
	asl	a
	tax
	lda	nrw-'A'*2,X		for i := frw[index] to
	jeq	lr9a		  frw[index+1] - 1 do
	sta	count
	lda	arw-'A'*2,X
	sta	aindex
	tax
lr8	lda	|0,X		  if rw[i] = id then begin
	cmp	id
	bne	lr9
	and	#$00FF
	dec	A
	tay
	phx
	clc
	adc	1,S
	plx
	tax
	short	M
cp1	lda	|1,X
	cmp	id+1,Y
	bne	lr9
	dex
	dey
	bne	cp1
	long	M
	ldx	aindex
	lda	|rwLen,X		    sy := rsy[i];
	sta	SY
	lda	|rwLen+2,X		    op := rop[i];
	sta	OP
	lda	ISO		    if not (iso and
	beq	lr8a
	lda	SY		      ((sy = otherwisesy)
	cmp	#otherwisesy
	beq	lr9a
	cmp	#stringsy		      or (sy = stringsy)
	beq	lr9a
	cmp	#unitsy		      or (sy = unitsy)
	beq	lr9a
	cmp	#interfacesy		      or (sy = interfacesy)
	beq	lr9a
	cmp	#implementationsy		      or (sy = implementationsy)
	beq	lr9a
	cmp	#univsy		      or (sy = univsy)
	beq	lr9a
	cmp	#usessy		      or (sy = usessy)))
	beq	lr9a
	cmp	#objectsy		      or (sy = objectsy)))
	beq	lr9a
	cmp	#inheritedsy		      or (sy = inheritedsy)))
	beq	lr9a		      then
lr8a	brl	end		      goto 2;
lr9	long	M		    end;
	clc
	lda	aindex
	adc	#rwLen+4
	sta	aindex
	tax
	dec	count
	jne	lr8
!				end;
lr9a	lda	#ident	      sy := ident;
	sta	SY
	lda	#noop	      op := noop;
	sta	OP
	brl	end	2:    end;
;
;  Handle numeric constants
;
nm1	anop		    number: begin
	move4	chPtr,cPtr
	lda	#noop	      op := noop;
	sta	OP
	ldy	chCnt	      k := 0;
	dey
	ldx	#0
	jsr	SaveDigits2	      repeat
!				savedigit;
!			      until charTp[ch] <> number;
	lda	#intconst	      sy := intconst;
	sta	SY
	lda	[cPtr],Y	      if ((ch = '.') and
	and	#$00FF		(line[chCnt+1] <> ')') and
	cmp	#'e'		(line[chCnt+1] <> '.')) or
	beq	nm2		(ch = 'e') then begin
	cmp	#'E'
	beq	nm2
	cmp	#'.'
	bne	nm12a
	lda	[cPtr],Y
	cmp	#').'
	beq	nm12a
	cmp	#'..'
	bne	nm2
nm12a	brl	nm12
nm2	lda	[cPtr],Y		if ch = '.' then begin
	and	#$00FF
	cmp	#'.'
	bne	nm5
	sta	digit,X		  savedigit;
	inx
	iny
	jsr	SaveDigits		  if charTp[ch] <> number then
!				    error(103)
!				  else
!				    repeat
!				      savedigit
!				    until charTp[ch] <> number;
nm5	anop			  end;
	lda	[cPtr],Y		if ch = 'e' then begin
	and	#$00FF
	cmp	#'e'
	beq	nm6
	cmp	#'E'
	bne	nm9
nm6	sta	digit,X		  savedigit;
	iny
	inx
	lda	[cPtr],Y		  if (ch = '+') or (ch ='-')
	and	#$00FF
	cmp	#'+'
	beq	nm7
	cmp	#'-'
	bne	nm8
nm7	sta	digit,X		    then savedigit;
	iny
	inx
nm8	jsr	SaveDigits		  if charTp[ch] <> number then
!				    error(103)
!				  else
!				    repeat
!				      savedigit
!				    until charTp[ch] <> number;
!				  end;
nm9	jsr	EndDigit		{finish reading number}
	ph2	#constantSize_reel		new(lvp,reel);
	jsl	Malloc
	sta	lvp
	stx	lvp+2
	lda	#realconst		sy:= realconst;
	sta	SY
	lda	#reel		lvp^.cclass := reel;
	sta	[lvp]
	ph4	#digit		lvp^.rval := cnvsr(digit);
	ph4	#index		{convert from ascii to decform}
	ph4	#decrec
	ph4	#valid
	stz	index
	stz	index+2
	fcstr2dec
	lda	valid		{flag an error if SANE said to}
	beq	nm10
	ldy	index
	lda	digit,Y
	and	#$00FF
	bne	nm10
	ph4	#decrec		{convert decform to real}
	ph4	#realvalue
	fdec2d
	bcs	nm10
	lda	realvalue		{save the result}
	ldy	#constant_rval
	sta	[lvp],Y
	lda	realvalue+2
	iny
	iny
	sta	[lvp],Y
	lda	realvalue+4
	iny
	iny
	sta	[lvp],Y
	lda	realvalue+6
	iny
	iny
	sta	[lvp],Y
	bra	nm11		if syserr then
nm10	listerror #105		  error(105);
nm11	move4 lvp,VAL+valu_valp		val.valp := lvp
	bra	nm15		end
nm12	anop		      else begin
	ph4	#0		lval := cnvs4(digit);
	ph4	#digit		if syserr then
	phx			  error(105);
	jsr	EndDigit		  {finish reading number}
	ph2	#1
	_dec2long
	bcc	nm13
	listerror #105
nm13	lda	3,S		if istwobyte(lval) then
	tax
	lda	1,S
	bpl	nm14
	inx
nm14	txa
	bne	nm14a
	pla			  ival := lval
	sta	VAL+valu_ival
	pla
	bra	nm15		else begin

nm14a	ph2	#constantSize_longC	          lvp := pointer(Malloc(sizeof(constantRec)));
	jsl	Malloc
	sta	lvp
	stx	lvp+2
	lda	#longintconst		  sy := longintconst;
	sta	SY
	lda	#long		  lvp^.cclass := long;
	sta	[lvp]
	pla
	ldy	#constant_lval
	sta	[lvp],Y
	pla
	iny
	iny
	sta	[lvp],Y
	move4 lvp,VAL+valu_valp		  val.valp := lvp
!				  end;
!				end;
nm15	lda	CH	      if charTp[ch] = letter then
	cmp	#'A'
	blt	nm16
	cmp	#'Z'+1
	bge	nm16
	listerror #103		error(103);
nm16	brl	end	      end;
;
;  Handle hex constants
;
dl1	anop		    number: begin
	lda	#noop	      op := noop;
	sta	OP
	lda	#intconst	      sy := intconst;
	sta	SY
	jsl	NextCh	      nextch;

	pea	0	      t := 0;
	pea	0
	ldy	#0	      chCnt := 0;
dl2	lda	CH	      while isHex(ch) do
	cmp	#'0'
	blt	dl7
	cmp	#'F'+1
	bge	dl7
	cmp	#'9'+1
	blt	dl3
	cmp	#'A'
	blt	dl7
dl3	iny			chCnt := chCnt+1;
	lda	3,S		if t > $FFFFFFF then begin
	cmp	#$1000
	blt	dl4
	phy
	listError #105		  error(105);
	ply
	brl	dl7		  goto 1;
dl4	anop			  end;
	ldx	#4		t := t<<4 | hexVal(ch);
dl5	pla
	asl	a
	pha
	lda	3,S
	rol	a
	sta	3,S
	dex
	bne	dl5
	lda	CH
	cmp	#'A'
	blt	dl6
	sbc	#7
dl6	and	#$000F
	ora	1,S
	sta	1,S
	phy			NextCh;
	jsl	NextCh
	ply
	bra	dl2		end;
dl7	cpy	#5	      if chCnt <= 4 then
	bge	dl8
	lda	1,S		if ord(t) < 0 then
	bpl	dl8
	lda	#$FFFF		  t := t | $FFFF0000;
	sta	3,S
dl8	brl	nm13
;
;  Handle string and character constants
;
qt1	anop		    chStrQuo: begin
	move4	chPtr,cPtr
	lda	#stringconst	      sy := stringconst;
	sta	SY
	lda	#noop	      op := noop;
	sta	OP
	ldx	#0	      lgth := 0;
	ldy	chCnt
	dey
	short M
qt2	anop		      repeat
qt3	anop			repeat
	iny			  nextch;
	lda	[cPtr],Y		  lgth := lgth + 1;
	sta	lString+1,X		  lString[lgth] := ch;
	inx
	cmp	#RETURN		until (eol) or (ch = '''');
	beq	qt4
	cmp	#''''
	bne	qt3
!				if not eol then
	iny			  nextch
	bra	qt5		else
qt4	long	M
	phy			  error(104)
	listerror #104
	ply
	ldx	#2
	bra	qt6
qt5	longa off
	lda	[cPtr],Y	      until ch <> '''';
	cmp	#''''
	beq	qt3
	long	M
qt6	dex
	stx	LGTH
	sty	chCnt
	jsr	LNextCh
!			      lgth := lgth - 1;
!			      {now lgth = nr of chars in string}
	lda	LGTH	      if (lgth = 0) and iso then begin
	bne	qt7
	lda	ISO
	beq	qt7
	listerror #106		error(106);
	lda	#1		lgth := 1;
	sta	LGTH
qt7	anop			end;
	short	M	      lString[0] := chr(lgth);
	lda	LGTH
	sta	lString
	long	M
	jsl	SaveString	      if lgth = 1 then
!				val.ival := ord(lString[1])
!			      else begin
!				new(lvp,strg);
!				lvp^.cclass:=strg;
!				lvp^.slgth := lgth;
!				for i := 1 to lgth do
!				  lvp^.sval[i] := lString[i];
!				val.valp := lvp;
!				end
	brl	end	      end;
;
;  Handle : and :=
;
cl1	anop		    chColon: begin
	lda	#noop	      op := noop;
	sta	OP
	jsl	NextCh	      nextch;
	lda	CH	      if ch = '=' then begin
	cmp	#'='
	bne	cl2
	lda	#becomes		sy := becomes;
	sta	SY
	jsl	NextCh		nextch;
	brl	end		end
cl2	anop		      else
	lda	#colon		sy := colon
	sta	SY
	brl	end	      end;
;
;  Handle * and **
;
as1	anop		    chAsterisk: begin
	jsl	NextCh	      nextch;
	lda	CH	      if ch = '*' then begin
	cmp	#'*'
	bne	as2
	lda	#powersy		sy := powersy;
	sta	SY
	lda	#noop		op := noop;
	sta	OP
	jsl	NextCh		nextch;
	brl	end		end
as2	anop		      else
	lda	#mulop		sy := mulop;
	sta	SY
	lda	#mul		op := mul;
	sta	OP
	brl	end	      end;
;
;  Handle ., .. and .) -- .) substitutes for ]
;
dt1	anop		    chPeriod: begin
	lda	#noop	      op := noop;
	sta	OP
	jsl	NextCh	      nextch;
	lda	CH	      if ch = '.' then begin
	cmp	#'.'
	bne	dt2
	lda	#dotdot		sy := dotdot;
	sta	SY
	jsl	NextCh		nextch;
	brl	end		end
dt2	cmp	#')'	      else if ch = ')' then begin
	bne	dt3
	lda	#rbrack		sy := rbrack;
	sta	SY
	jsl	NextCh		nextch;
	brl	end		end
dt3	anop		      else
	lda	#period		sy := period;
	sta	SY
	brl	end	      end;
;
;  Handle <, <<, <= and <>
;
lt1	anop		    chlt: begin
	jsl	NextCh	      nextch;
	lda	#relop	      sy := relop;
	sta	SY
	lda	CH	      if ch = '=' then begin
	cmp	#'='
	bne	lt2
	lda	#leop		op := leop;
	sta	OP
	jsl	NextCh		nextch;
	brl	end		end
lt2	cmp	#'>'	      else if ch = '>' then begin
	bne	lt3
	lda	#neop		op := neop;
	sta	OP
	jsl	NextCh		nextch;
	brl	end		end
lt3	cmp	#'<'	      else if ch = '<' then begin
	bne	lt4
	lda	#mulop		sy := mulop;
	sta	SY
	lda	#lshift		op := lshift;
	sta	OP
	jsl	NextCh		nextch;
	brl	end		end
lt4	anop		      else
	lda	#ltop		op := ltop;
	sta	OP
	brl	end	      end;
;
;  Handle >, >> and >=
;
gt1	anop		    chgt: begin
	jsl	NextCh	      nextch;
	lda	#relop	      sy := relop;
	sta	SY
	lda	CH	      if ch = '=' then begin
	cmp	#'='
	bne	gt2
	lda	#geop		op := geop;
	sta	OP
	jsl	NextCh		nextch;
	brl	end		end
gt2	cmp	#'>'	      else if ch = '>' then begin
	bne	gt3
	lda	#mulop		sy := mulop;
	sta	SY
	lda	#rshift		op := rshift;
	sta	OP
	jsl	NextCh		nextch;
	brl	end		end
gt3	anop		      else
	lda	#gtop		op := gtop;
	sta	OP
	brl	end	      end;
;
;  Handle comments and ( and (. tokens -- (. substitutes for [
;
lp1	anop		    chLComt,chLParen: begin
!			      if charTp[ch] = chLParen then
	jsl	NextCh		nextch
!			      else
!				ch := '*';
	lda	CH	      if ch = '*' then begin
	cmp	#'*'
	bne	cm6
cm1	jsl	NextCh		nextch;
	lda	CH		if ch = '$' then
	cmp	#'$'
	bne	cm2
	jsl	options		  options;
	lsr	A
	bcs	cm2
	lda	#' '		  {for append, copy, don't}
	sta	CH		  {scan for end of comment}
	brl	lab1
cm2	jsl	SkipComment		  skipcomment;
	brl	lab1		goto 1
cm6	anop			end;
	cmp	#'.'	      if ch = '.' then begin
	bne	cm7
	jsl	NextCh		nextch;
	lda	#lbrack		sy := lbrack;
	bra	cm8		end
cm7	anop		      else
	lda	#lparent		sy := lparent;
cm8	sta	SY
	lda	#noop	      op := noop;
	sta	OP
	brl	end	      end;
;
;  Handle the @ character.
;
at1	anop		    begin
	jsl	NextCh	      NextCh;
	lda	ISO	      if iso then
	beq	at2
	lda	#arrow		sy := arrow
	bra	at3	      else
at2	lda	#atsy		sy := atsy;
at3	sta	SY
	lda	#noop	      op := noop;
	sta	OP
	brl	end	      end;
;
;  Set the symbol and operation for special symbols from two arrays.
;
sp1	anop		    special: begin
	lda	ISO	      if iso then
	beq	sp2
	lda	CH	        if ord(ch) >= 128 then
	and	#$0080
	beq	sp2
	listerror #112	          error(112);

sp2	lda	CH	      sy := ssy[ch];
	tax
	lda	ssy-' ',X
	and	#$00FF
	sta	SY
	lda	sop-' ',X	      op := sop[ch];
	and	#$00FF
	sta	OP
	jsl	NextCh	      nextch;
!			      end;
end	anop		  end {case}
;
;  If in an interface file, write the token to it
;
	lda	DOINGINTERFACE	if doingInterface
	beq	if0	  and not doingOption then begin
	lda	doingOption
	beq	if0a
if0	brl	if7
if0a	ph2	SY	  TokenOut(sy);
	jsl	TokenOut
	lda	SY	  if sy in [mulop,addop,relop] then
	cmp	#mulop
	beq	if0b
	cmp	#addop
	beq	if0b
	cmp	#relop
	bne	if0c
if0b	ph2	OP	    TokenOut(op);
	jsl	TokenOut
	brl	if7
if0c	cmp	#ident	  else if sy = ident then begin
	bne	if2
	ldx	#0	    for i := 1 to length(id) do
	lda	id
	and	#$00FF
	tay
if1	lda	id+1,X	      TokenOut(ord(id[i]));
	and	#$00FF
	phx
	phy
	pha
	jsl	TokenOut
	ply
	plx
	inx
	dey
	bne	if1
	pea	' '	    TokenOut(' ');
	jsl	TokenOut
	brl	if7	    end
if2	cmp	#intconst	  else if sy = intconst then begin
	bne	if3
	ph2	VAL+valu_ival	    TokenOut(ival);
	jsl	TokenOut
	lda	VAL+valu_ival	    TokenOut(ival >> 8);
	xba
	pha
	jsl	TokenOut
	brl	if7	    end
if3	cmp	#longintconst	  else if sy = longintconst then begin
	bne	if4
	ldy	#constant_lval	    TokenOut(lvp^.lval);
	lda	[lvp],Y	    TokenOut(lvp^.lval >> 8);
	xba
	pha
	xba
	pha
	jsl	TokenOut
	jsl	TokenOut
	ldy	#constant_lval+2	    TokenOut(lvp^.lval >> 16);
	lda	[lvp],Y	    TokenOut(lvp^.lval >> 24);
	xba
	pha
	xba
	pha
	jsl	TokenOut
	jsl	TokenOut
	bra	if7	    end
if4	cmp	#realconst	  else if sy = realconst then begin
	bne	if5
	ph2	realvalue	    for i := 0 to 7 do begin
	jsl	TokenOut	      ptr := pointer(@realvalue+i);
	ph2	realvalue+1	      TokenOut(ptr^);
	jsl	TokenOut	      end;
	ph2	realvalue+2
	jsl	TokenOut
	ph2	realvalue+3
	jsl	TokenOut
	ph2	realvalue+4
	jsl	TokenOut
	ph2	realvalue+5
	jsl	TokenOut
	ph2	realvalue+6
	jsl	TokenOut
	ph2	realvalue+7
	jsl	TokenOut
	bra	if7	    end
if5	cmp	#stringconst	  else if sy = stringconst then begin
	bne	if7
	ph2	lgth	    TokenOut(lgth);
	jsl	TokenOut
	ldx	#0	    for i := 1 to lgth do
if6	lda	lString+1,X	      TokenOut(ord(lString[i]));
	phx
	pha
	jsl	TokenOut
	plx
	inx
	cpx	lgth
	bne	if6
!			    end;
if7	anop		  end;
	ret	 	end; {insymbol}
;
;  LNextCh - call NextCh, then reset cPtr
;
LNextCh	jsl	NextCh
	move4	chPtr,cPtr
	rts
;
;  Local data areas
;
ssy	anop		special character symbol definitions
	dc	i1'0,addop,0,0,0,0,mulop,0'
	dc	i1'lparent,rparent,0,addop,comma,addop,0,mulop'
	dc	8i1'0'
	dc	i1'0,0,0,semicolon,0,relop,0,0'
	dc	i1'0,0,0,0,0,0,0,0'
	dc	8i1'0'
	dc	8i1'0'
	dc	i1'0,0,0,lbrack,0,rbrack,arrow,0'
	dc	8i1'0'
	dc	8i1'0'
	dc	8i1'0'
	dc	i1'0,0,0,0,addop,0,bitnot,0'
	dc	8i1'0'				$80
	dc	8i1'0'
	dc	8i1'0'				$90
	dc	8i1'0'
	dc	8i1'0'				$A0
	dc	i1'0,0,0,0,0,relop,0,0'
	dc	i1'0,0,relop,relop,0,0,0,0'			$B0
	dc	8i1'0'
	dc	i1'0,0,0,0,0,0,0,mulop'				$C0
	dc	i1'mulop,0,0,0,0,0,0,0'
	dc	i1'0,0,0,0,0,0,mulop,0'				$D0
;	dc	8i1'0'
sop	dc	i1'0,xor,0,0,0,0,band,0'
	dc	i1'0,0,0,plus,0,minus,0,rdiv'
	dc	8i1'0'
	dc	i1'0,0,0,0,0,eqop,0,0'
	dc	8i1'0'
	dc	8i1'0'
	dc	8i1'0'
	dc	8i1'0'
	dc	8i1'0'
	dc	8i1'0'
	dc	8i1'0'
	dc	i1'0,0,0,0,bor,0,0,0'
	dc	8i1'0'				$80
	dc	8i1'0'
	dc	8i1'0'				$90
	dc	8i1'0'
	dc	8i1'0'				$A0
	dc	i1'0,0,0,0,0,neop,0,0'
	dc	i1'0,0,leop,geop,0,0,0,0'			$B0
	dc	8i1'0'
	dc	i1'0,0,0,0,0,0,0,lshift'				$C0
	dc	i1'rshift,0,0,0,0,0,0,0'
	dc	i1'0,0,0,0,0,0,idiv,0'				$D0
;	dc	8i1'0'
nrw	dc	i'2,1,2,3,2,3,1,0,5,0'	number of reserved words starting with
	dc	i'0,1,1,2,4,3,0,2,2,3'	 each letter of the alphabet
	dc	i'4,1,2,0,0,0'
arw	dc	a'rwa,rwb,rwc,rwd,rwe'	address of first reserved word for each
	dc	a'rwf,rwg,rwh,rwi,rwj'	 letter of the alphabet
	dc	a'rwk,rwl,rwm,rwn,rwo'
	dc	a'rwp,rwq,rwr,rws,rwt'
	dc	a'rwu,rwv,rww,rwx,rwy'
	dc	a'rwz'
!
rwa	dc	i1'3',c'AND           ',i'mulop,andop'    reserved words, old rsy &
	dc	i1'5',c'ARRAY         ',i'arraysy,0'	      rop arrays
rwb	dc	i1'5',c'BEGIN         ',i'beginsy,0'
rwc	dc	i1'4',c'CASE          ',i'casesy,0'
	dc	i1'5',c'CONST         ',i'constsy,0'
rwd	dc	i1'2',c'DO            ',i'dosy,0'
	dc	i1'3',c'DIV           ',i'mulop,idiv'
	dc	i1'6',c'DOWNTO        ',i'downtosy,0'
rwe	dc	i1'3',c'END           ',i'endsy,0'
	dc	i1'4',c'ELSE          ',i'elsesy,0'
rwf	dc	i1'3',c'FOR           ',i'forsy,0'
	dc	i1'8',c'FUNCTION      ',i'funcsy,0'
	dc	i1'4',c'FILE          ',i'filesy,0'
rwg	dc	i1'4',c'GOTO          ',i'gotosy,0'
rwh	anop
rwi	dc	i1'2',c'IF            ',i'ifsy,0'
	dc	i1'2',c'IN            ',i'relop,inop'
	dc	i1'9',c'INTERFACE     ',i'interfacesy,0'
	dc	i1'14',c'IMPLEMENTATION',i'implementationsy,0'
	dc	i1'9',c'INHERITED     ',i'inheritedsy,0'
rwj	anop
rwk	anop
rwl	dc	i1'5',c'LABEL         ',i'labelsy,0'
rwm	dc	i1'3',c'MOD           ',i'mulop,imod'
rwn	dc	i1'3',c'NIL           ',i'nilsy,0'
	dc	i1'3',c'NOT           ',i'notsy,0'
rwo	dc	i1'2',c'OF            ',i'ofsy,0'
	dc	i1'2',c'OR            ',i'addop,orop'
	dc	i1'9',c'OTHERWISE     ',i'otherwisesy,0'
	dc	i1'6',c'OBJECT        ',i'objectsy,0'
rwp	dc	i1'9',c'PROCEDURE     ',i'procsy,0'
	dc	i1'6',c'PACKED        ',i'packedsy,0'
	dc	i1'7',c'PROGRAM       ',i'progsy,0'
rwq	anop
rwr	dc	i1'6',c'REPEAT        ',i'repeatsy,0'
	dc	i1'6',c'RECORD        ',i'recordsy,0'
rws	dc	i1'3',c'SET           ',i'setsy,0'
	dc	i1'6',c'STRING        ',i'stringsy,0'
rwt	dc	i1'4',c'THEN          ',i'thensy,0'
	dc	i1'2',c'TO            ',i'tosy,0'
	dc	i1'4',c'TYPE          ',i'typesy,0'
rwu	dc	i1'5',c'UNTIL         ',i'untilsy,0'
	dc	i1'4',c'USES          ',i'usessy,0'
	dc	i1'4',c'UNIT          ',i'unitsy,0'
	dc	i1'4',c'UNIV          ',i'univsy,0'
rwv	dc	i1'3',c'VAR           ',i'varsy,0'
rww	dc	i1'4',c'WITH          ',i'withsy,0'
	dc	i1'5',c'WHILE         ',i'whilesy,0'
rwx	anop
rwy	anop
rwz	anop

index	ds	4	index into string
decrec	ds	33	decimal record for conversion
valid	ds	4	valid prefix flag
realvalue ds	8	binary format real number
	end

****************************************************************
*
*  ListLine - List the current line and any errors found
*
*  Inputs:
*	LIST - source listing on?
*	ERRINX - # errors in this line
*	LINE - source line to list
*	errList - array of error numbers
*
****************************************************************
*
ListLine private
	using GetCom
errtype_nmr equ 0	disps in errtype record
errtype_pos equ 2

i	equ	1
k	equ	3
cPtr	equ	5	local copy of chPtr
r0	equ	9	work register
lch	equ	11	temp character

	sub	,12

	jsl	KeyPress	if <a key has been pressed> then begin
	tay
	beq	kp1
	jsl	DrawHourglass	  DrawHourglass;
kp0	jsl	Keypress	  repeat
	tay
	beq	kp0	  until KeyPress;
	jsl	ClearHourglass	  ClearHourglass;
kp1	anop		  end;
	lda	LIST	if (list or (errinx > 0)) and
	ora	ERRINX	  linecount then begin
	jeq	lb9
	lda	LINECOUNT
	jeq	lb9
	put2	LINECOUNT,#4	  write(linecount:4,' ');
	putc	#' '
	move4	chPtr,cPtr	  while line[i] <> return do begin
	ldy	#0
lb1	lda	[cPtr],Y
	and	#$00FF
	cmp	#return
	beq	lb2
	phy		    write(line[i]);
	sta	lch
	putc	lch
	ply
	iny		    i := i+1;
	bra	lb1	    end;
lb2	jsl	LineFeed	  LineFeed;
	ldx	#1	  for i := 1 to errinx do begin
	stx	i
lb3	lda	i
	cmp	ERRINX
	jgt	lb8
	puts	#'****'	    write('****');
	lda	i	    for k := 1 to errlist[i].pos-1 do
	asl	A
	asl	A
	tax
	lda	errList-4+errtype_pos,X
	dec	a
	beq	lb5
	bmi	lb5
	cmp	#maxcnt
	bge	lb5
	sta	k
lb4	putc	#' '	      write(' ');
	dbne	k,lb4
lb5	puts	#'^ '	    write('^ ');
	lla	r0,msgs	    <find error message>
	lda	i
	asl	A
	asl	A
	tax
	lda	errList-4+errtype_nmr,X
	sta	k
lb6	dbeq	k,lb7
	lda	(r0)
	and	#$00FF
	sec
	adc	r0
	sta	r0
	bra	lb6
lb7	dec	r0	    <write the error message>
	puts	{r0}
	inc	r0
	jsl	LineFeed	    LineFeed;
	lda	allTerm	    if allTerm then
	beq	lb7a
	lda	i	      chCnt := errlist[i].pos-2;
	asl	A
	asl	A
	tax
	lda	errList-4+errtype_pos,X
	dec	a
	dec	a
	sta	chCnt
	ph2	#0	      TermError(0, r0);
	ph2	#msgs|(-16)
	ph2	r0
	jsl	TermError
lb7a	inc	i	    end;
	brl	lb3
lb8	lda	ERRINX	  if (errinx > 0) and 
	beq	lb9	    (not printer) then
	lda	printer
	bne	lb9
	jsl	WaitForKeyPress	    WaitForKeyPress;
lb9	anop		  end;
	jsl	Spin	  Spin;
	ret

msgs	dw	'error in simple type'	1
	dw	'identifier expected'
	dw	'''program'' expected'
	dw	''')'' expected'
	dw	''':'' expected'
	dw	'illegal symbol'
	dw	'error in parameter list'
	dw	'''of'' expected'
	dw	'''('' expected'
	dw	'error in type'	10
	dw	'''['' expected'
	dw	''']'' expected'
	dw	'''end'' expected'
	dw	''';'' expected'
	dw	'integer expected'
	dw	'''='' expected'
	dw	'''begin'' expected'
	dw	'error in declaration part'
	dw	'error in field-list'
	dw	''','' expected'	20
	dw	'''.'' expected'
	dw	'error in constant'
	dw	''':='' expected'
	dw	'''then'' expected'
	dw	'''until'' expected'
	dw	'''do'' expected'
	dw	'''to'' expected'
	dw	'error in factor'
	dw	'error in variable'
	dw	'identifier declared twice' 30
	dw	'low bound exceeds high bound'
	dw	'identifier is not of appropriate class'
	dw	'identifier not declared'
	dw	'sign not allowed'
	dw	'number expected'
	dw	'incompatible subrange types'
	dw	'quoted file name expected'
	dw	'type must not be real'
	dw	'tagfield type must be scalar or subrange'
	dw	'incompatible with tagfield type' 40
	dw	'index type must be scalar or subrange'
	dw	'base type must not be real'
	dw	'base type must be scalar or subrange'
	dw	'error in type of standard procedure parameter'
	dw	'forward declared; repitition of parameter list not allowed'
	dw	'function result type must be scalar, subrange or pointer'
	dw	'file value parameter not allowed'
	dw	'forward declared function; cannot repeat type'
	dw	'missing result type in function declaration'
	dw	'F-format for real only' 50
	dw	'error in type of standard function parameter'
	dw	'number of parameters does not agree with declaration'
	dw	'result type of function does not agree with declaration'
	dw	'type conflict of operands'
	dw	'expression is not of set type'
	dw	'only tests on equality allowed'
	dw	'strict inclusion not allowed'
	dw	'file comparison not allowed'
	dw	'illegal type of operand(s)'
	dw	'type of operand must be boolean' 60
	dw	'set element type must be scalar or subrange'
	dw	'set element types not compatible'
	dw	'type of variable is not array'
	dw	'index type is not compatible with declaration'
	dw	'type of variable is not record'
	dw	'type of variable must be file or pointer'
	dw	'illegal parameter substitution'
	dw	'illegal type of loop control variable'
	dw	'illegal type of expression'
	dw	'type conflict'	70
	dw	'assignment of files not allowed'
	dw	'label type incompatible with selecting expression'
	dw	'subrange bounds must be scalar'
	dw	'74'
	dw	'assignment to standard function is not allowed'
	dw	'assignment to formal function is not allowed'
	dw	'no such field in this record'
	dw	'actual parameter must be a variable'
	dw	'control var must be declared at this level'
	dw	'multidefined case label' 80
	dw	'only extern, forward, ProDOS or tool allowed in uses'
	dw	'missing corresponding variant declaration'
	dw	'''..'' expected'
	dw	'previous declaration was not forward'
	dw	'again forward declared'
	dw	'parameter size must be constant'
	dw	'multidefined label'
	dw	'multideclared label'
	dw	'undeclared label'
	dw	'error in base set'	90
	dw	'missing ''input'' in program heading'
	dw	'missing ''output'' in program heading'
	dw	'assignment to function identifier not allowed here'
	dw	'multidefined record variant'
	dw	'cannot use as formal parameter'
	dw	'no assignment to function found'
	dw	'cannot modify control variable'
	dw	'wrong number of selectors'
	dw	'illegal goto'
	dw	'misplaced directive'	100
	dw	'extern allowed at program level only'
	dw	'label space exhausted'
	dw	'digit expected'
	dw	'string constant must not exceed source line'
	dw	'integer constant exceeds range'
	dw	'zero string not allowed'
	dw	'too many nested scopes of identifiers'
	dw	'too many nested procedures and/or functions'
	dw	'further errors supressed'
	dw	'element expression out of range' 110
	dw	'implementation restriction'
	dw	'not iso standard'
	dw	'compiler error'
	dw	'114'
	dw	'uses allowed at program level only'
	dw	'error in uses'
	dw	'file cannot contain another file'
	dw	'''implementation'' expected'
	dw	'''interface'' expected'
	dw	'body must appear in implementation part' 120
	dw	'casted expression must be scalar or pointer'
	dw	'use memory model 1 for memory blocks larger than 64K'
	dw	'objects cannot have a variant part'
	dw	'undeclared method'
	dw	'not a known object'
	dw	'methods must be declared at the program level'
	dw	'objects must be declared as a named type'
	dw	'object expected'
	dw	'type of variable must be object'
	dw	'there is no method to inherit' 130
	dw	'string expected'
	dw	'implementation restriction: string space exhausted'
	dw	'Unexpected end of file'
	end    

****************************************************************
*
*  Match - Insure that the next symbol is the one requested
*
*  Inputs:
*	sym - symbol to match
*	ern - number of error of there is no match
*
****************************************************************
*
Match	start
	using GetCom

	sub	(2:sym,2:ern),0
	lda	sym	if sy = sym then
	cmp	SY
	bne	lb1
	jsl	InSymbol	  insymbol
	bra	lb2	else
lb1	lda	ern	  error(ern);
	pha
	jsl	Error
lb2	ret
	end

****************************************************************
*
*  NextCH - Get Next Character
*
*  Inputs:
*	EOFL - at end of file?
*	eol - at end of line?
*	fHeadGS - head of copied files list
*	chCnt - number of character read from the line so far
*
*  Outputs:
*	EOFL - set if at end of file
*	eol - set if at end of line
*	chCnt - updated
*	CH - next character to process
*
****************************************************************
*
NextCH	private
	using GetCom
cPtr	equ	1	local copy of chPtr
fPtr	equ	5	local copy of fHeadGS

	sub	,8

	move4	chPtr,cPtr	cPtr := chPtr;
	lda	EOFL	if not eofl then begin
	beq	ef1
	lda	#' '
	sta	CH
	brl	ret

ef1	lda	eol	  if eol then begin
	jeq	lb8
lab1	clc		1:  if eof(prd) then begin
	lda	chCnt
	adc	cPtr
	tax
	lda	cPtr+2
	adc	#0
	cmp	chEndPtr+2
	bne	ef2
	cpx	chEndPtr
ef2	jlt	lb5
lb0	jsl	PurgeSource	      <purge the file>;
	lda	fHeadGS	      if fHeadGS = nil then begin
	ora	fHeadGS+2
	bne	lb1
	lda	eofDisable		if not eofDisable then begin
	bne	lb0a
	ph2	#133		  <flag the error>;
	jsl	Error
	inc	NUMERR		  numerr := numerr+1
lb0a	anop			  end;
	la	EOFL,true		eofl := true;
	stz	TEST		test := false;
	lda	#' '		ch := ' ';
	sta	CH
	brl	ret	      else
lb1	add4	fHeadGS,#4,cPtr		with fHeadGS^ do begin
	short M		  fName := name;
	ldy	#maxPath+4-1
lb2	lda	[cPtr],Y
	sta	fNameGS,Y
	dbpl	Y,lb2
	long	M
	jsl	OpenGS		  <open the file>;
	move4	fHeadGS,fPtr
	ldy	#maxPath+4+4		  seek(prd,pos);
	clc
	lda	[fPtr],Y
	adc	filePtr
	sta	cPtr
	iny
	iny
	lda	[fPtr],Y
	adc	filePtr+2
	sta	cPtr+2
	stz	chCnt
	ldy	#maxPath+4+4+4		  <push uses flag>
	lda	[fPtr],Y
	pha
	ldy	#maxPath+4+4+4+2		  lineCount := fHeadGS^.lineCount;
	lda	[fPtr],Y
	sta	lineCount
	ldy	#2		  fHeadGS := fHeadGS^.next;
	lda	[fPtr],Y
	sta	fHeadGS+2
	lda	[fPtr]
	sta	fHeadGS
	dispose fPtr		  dispose(fPtr);
	pla			  {if this is a uses, mark it}
	beq	lb3
	lda	#' '
	sta	CH
	lda	#true
	sta	endOfUses
	stz	eol
	bra	ret
lb3	brl	lab1		  goto 1;
;				  end;
;			      end
lb5	anop		    else begin
	move4	cPtr,chPtr	      EndOfLine;
	jsl	EndOfLine
	move4	chPtr,cPtr
lb5a	ldy	#0	      while (line[chCnt+1]<>return) and
	short M		(charTp[line[chCnt+1]]=chSpace) do
lb6	lda	[cPtr],Y	      chCnt := chCnt+1;
	cmp	#' '
	beq	lb6A
	cmp	#tab
	beq	lb6A
	cmp	#$CA
	bne	lb6B
	lda	#' '
lb6A	iny
	bra	lb6
lb6B	long	M
	tya
	sta	chCnt
lb7	anop		    end;
lb8	anop		  end;
	lda	#0
	short M
	ldy	chCnt	eol := line[chCnt] = return;
	tax
	lda	[cPtr],Y
	cmp	#return
	bne	lb9
	inx
	lda	#' '
lb9	stx	eol
	tax		ch := line[chCnt];
	lda	upperCase,X	if (ch >= 'a') and (ch <= 'z') then
	sta	CH	  ch := chr(ord(ch)-ord('a')+ord('A');
	stz	CH+1
	long	M
	inc	chCnt	chCnt := chCnt+1;
lb11	anop
	anop		end;

ret	move4	cPtr,chPtr
	ret
	end

****************************************************************
*
*  SaveDigits - Save a sequence of digits
*
*  Inputs:
*	X - disp in digit
*	Y - disp in input line
*
*  Outputs:
*	digit - contains any digits read
*
*  Notes:
*	Entry at SaveDigits2 skips the check that insures
*	some digits exist.
*
*	Assumes cPtr has been set up in a valid DP area at 1
*
****************************************************************
*
SaveDigits private
	using GetCom
cPtr	equ	1	copy of chPtr

	lda	[cPtr],Y	if charTp[ch] <> number then
	and	#$00FF
	cmp	#'0'
	blt	lb1
	cmp	#'9'+1
	blt	SaveDigits2
lb1	phx		  error(103)
	phy
	listerror #103
	ply
	plx
	rts

SaveDigits2 entry	else
	short M
	anop		  repeat
	lda	[cPtr],Y	    savedigit
lb2	sta	digit,X
	iny
	inx
	lda	[cPtr],Y	  until charTp[ch] <> number;
	cmp	#'0'
	blt	lb3
	cmp	#'9'+1
	blt	lb2
lb3	long	M
	rts		  end;
	end

****************************************************************
*
*  SaveString - does the work for InSymbol and UsesInsymbol
*
*  Notes: Assumes that a constant record is a word followed by
*	a p-string.
*
****************************************************************
*
SaveString private
	using GetCom

	aif	constant_sval=2,.OK
	mnote	'constant_sval assumed to be 2',16
.OK

lvp	equ	1	new constant record pointer

	sub	,4

	lda	LGTH	if lgth = 1 then
	dec	a
	bne	qt8
	lda	lString+1	  val.ival := ord(lString[1])
	and	#$00FF
	sta	VAL+valu_ival
	bra	end	else begin

qt8	lda	lgth	  lvp := pointer(Malloc(lgth+5)));
	clc		  {extra 2 bytes leave room for
	adc	#5	   possible expansion in LoadString}
	pha
	jsl	Malloc
	sta	lvp
	stx	lvp+2
	lda	#strg	  lvp^.cclass:=strg;
	sta	[lvp]
	lda	lgth	  lvp^.sval := lString;
	and	#$00FF
	tax
	ldy	#constant_sval
	short	M
	sta	[lvp],Y
	cpx	#0
	beq	lb2
lb1	iny
	lda	lString-constant_sval,Y
	sta	[lvp],Y
	dex
	bne	lb1
lb2	long	M
	move4 lvp,VAL+valu_valp	  val.valp := lvp;
!			  end; {else}
end	ret
	end

****************************************************************
*
*  Scanner_Init - Initialize the scanner
*
****************************************************************
*
Scanner_Init start
	using GetCom
;
;  Initialize volitile variables
;
	stz	title+1	delete any old title
	stz	intPrefixGS+2	wipe out old interface prefix
	stz	chCnt	no characters read from current line
	lda	#true	at end of line
	sta	eol
	stz	LIST	listing defaults to off
	stz	doingOption	not compiling an option (directive)
	stz	fHeadGS	fHeadGS := nil
	stz	fHeadGS+2
	stz	lCnt	no lines on printed page
	stz	langNum	language number not yet determined
	stz	eofDisable	enable eofl error check
	stz	endOfUses	not at end of a uses
	stz	didKeep	no $keep found, yet
;
;  Find out how long a page is.
;
	la	pageSize,60	assume a size of 60
	ReadVariableGS rvRec	read the actual size, if any
	bcs	pl1
	lda	variable+2	if there is a variable then
	beq	pl1
	ph2	#0	  find its value
	ph4	#variable+2
	ph2	variable+2
	ph2	#0
	_dec2int
	pla
	sta	pageSize	  save the value
pl1	anop		endif
;
;  Set printer to true if output has been redirected.
;
	direction dr_dcb
	lda	direction
	sta	printer
;
;  Get the inputs and open the initial file.
;
	jsl	InitFile	get shell interface stuff
	jsl	OpenGS	open the file
;
;  Set up the partial compile name list.
;
	jsl	GetPartialNames
;
;  Read the first character.
;
	jsl	NextCh
	rtl
;
;  Local data
;
rvRec	dc	i'3'	ReadVariableGS record
	dc	a4'name,variable'
	ds	2

name	dosw	PrinterLines	name of the printer line variable
variable dc	i'9,0',c'     '	value of PrinterLines

dr_dcb	anop		direction dcb
	dc	i'1'	find direction of standard out
direction ds	2	direction of standard out
	end

****************************************************************
*
*  UsesInSymbol - returns a symbol from an interface file
*
*  Inputs:
*	tInSymbol - bytes to restore InSymbol with after the
*		file is processed
*	usesLength - bytes remaining in file
*	usesPtr - pointer to next byte in file
*
*  Outputs:
*	sy - symbol
*	op - operator
*	id - identifier name
*	val - constant value
*
****************************************************************
*
UsesInSymbol start
	using GetCom
uPtr	equ	1	local copy of usesPtr
lvp	equ	5	constant pointer

	sub	,8

	jsl	Spin	Spin;
	move4	usesPtr,uPtr	uPtr := usesPtr;
	lda	[uPtr]	SY := uPtr^;
	and	#$00FF
	sta	SY
	inc4	uPtr	++uPtr;
	dec4	usesLength	--usesLength;
	stz	OP	op := noop;
	lda	SY	if sy in [addop,mulop,relop] then begin
	cmp	#addop
	beq	la1
	cmp	#mulop
	beq	la1
	cmp	#relop
	bne	la2
la1	lda	[uPtr]	  OP := uPtr^;
	and	#$00FF
	sta	OP
	inc4	uPtr	  ++uPtr;
	dec4	usesLength	  --usesLength;
la2	anop		  end;
	lda	SY	if sy = ident then begin
	cmp	#ident
	bne	lb2
	ldy	#0	  y := 0;
lb1	anop		  while X >= 0 do begin
	lda	[uPtr]	    id[y+1] := uPtr^;
	and	#$00FF
	cmp	#' '
	beq	lb1a
	short	M
	sta	id+1,Y
	long	M
	iny		    y := y+1;
	inc4	uPtr	    uPtr++;
	dec4	usesLength	    usesLength--;
	bpl	lb1	    end
lb1a	short	I	  id[0] := chr(y);
	sty	id
	long	I
	inc4	uPtr	  uPtr++;
	dec4	usesLength	  usesLength--;
	brl	lb7	  end
lb2	cmp	#intconst	else if sy = intconst then begin
	bne	lb3
	lda	[uPtr]	  val.ival := uPtr^;
	sta	VAL+valu_ival
	add4	uPtr,#2	  uPtr += 2;
	sub4	usesLength,#2	  usesLength -= 2;
	brl	lb7	  end
lb3	cmp	#longintconst	else if sy = longintconst then begin
	bne	lb4
	ph2	#constantSize_longC	  lvp := pointer(Malloc(sizeof(constantRec)));
	jsl	Malloc
	sta	lvp
	stx	lvp+2
	lda	#long	  lvp^.cclass := long;
	sta	[lvp]
	ldy	#2	  lvp^.lval := uPtr^;
	lda	[uPtr],Y
	ldy	#constant_lval+2
	sta	[lvp],Y
	dey
	dey
	lda	[uPtr]
	sta	[lvp],Y
	move4 lvp,VAL+valu_valp	  val.valp := lvp;
	add4	uPtr,#4	  uPtr += 4;
	sub4	usesLength,#4	  usesLength -= 4;
	brl	lb7	  end
lb4	cmp	#realconst	else if sy = realconst then begin
	bne	lb5
	ph2	#constantSize_reel	  lvp := pointer(Malloc(sizeof(constantRec)));
	jsl	Malloc
	sta	lvp
	stx	lvp+2
	lda	#reel	  lcp^.cclass := reel;
	sta	[lvp]
	move4 lvp,VAL+valu_valp	  val.valp := lvp;
	add4	lvp,#valu_valp	  lvp^.rval := uPtr^;
	ldy	#2
	lda	[uPtr]
	sta	[lvp]
	lda	[uPtr],Y
	sta	[lvp],Y
	iny
	iny
	lda	[uPtr],Y
	sta	[lvp],Y
	iny
	iny
	lda	[uPtr],Y
	sta	[lvp],Y
	add4	uPtr,#8	  uPtr += 8;
	sub4	usesLength,#8	  usesLength -= 8;
	bra	lb7	  end
lb5	cmp	#stringconst	else if sy = stringconst then begin
	bne	lb7
	lda	[uPtr]	  lgth := uPtr^;
	and	#$00FF
	sta	lgth
	tay
	ldx	#0	  for x := 1 to lgth do begin
lb6	lda	[uPtr]	    lString[x] := uPtr^;
	and	#$00FF
	sta	lString,X
	inc4	uPtr	    uPtr++;
	dec4	usesLength	    usesLength--;
	inx		    end;
	dey
	bpl	lb6
	jsl	SaveString	  if lgth = 1 then
;			    val.ival := lString[1]
;			  else begin
;			    new(lvp,strg);
;			    lvp^.cclass := strg;
;			    lvp^.slgth := lgth;
;			    for i := 1 to lgth do
;			      lvp^.sval[i] := lString[i];
;			    val.valp := lvp;
;			    end;
;			  end;
lb7	lda	usesLength+2	if usesLength <= 0 then
	bmi	lb8
	ora	usesLength
	bne	lb9
lb8	lda	tInSymbol	  <fix InSymbol>
	sta	InSymbol
	lda	tInSymbol+1
	sta	InSymbol+1
	lla	ffPathname,usesFileNameGS  purge the uses file
	FastFileGS ffDCB
lb9	anop		  end;

	move4	uPtr,usesPtr	usesPtr := uPtr;
	ret

ffDCB	anop
	dc	i'5'	pCount
	dc	i'7'	action
	dc	i'0'	index
	dc	i'$C000'	flags
	dc	a4'0'	fileHandle
ffPathName ds	4	pathName
	end
\ No newline at end of file
+	mcopy	scanner.macros
+****************************************************************
+*
+*  GetCom - Common Data for Get Character Module
+*
+****************************************************************
+*
+GetCom	data
+;
+;  Constants
+;
+autoGo	gequ	$06	auto-Go key code
+breakPoint gequ $07	breakpoint key code
+maxCnt	gequ	256	# chars on a line + 1
+maxPath	gequ	255	max length of a path name
+return	equ	$0D	RETURN key code
+tab	equ	$09	tab key code
+;
+;  Size of pascal structures
+;
+constantSize equ 258	size of a constantRec
+constantSize_longC   equ 6
+constantSize_reel    equ 10
+constantSize_pset    equ 260
+constantSize_chset   equ 258
+constantSize_strg    equ 258
+
+displaySize equ 28	size of an element of the display array
+ltypeSize equ 10	size of an ltype record
+;
+;  Displacements into records, by record-name_field-name
+;
+constant_rval equ 2	disp in constant of real value
+constant_lval equ 2	disp in constant of longint value
+constant_sval gequ 2	disp in constant of string characters
+
+identifier_llink equ 4	disp in identifier of left link
+identifier_rlink equ 8	disp in identifier of right link
+identifier_klass equ 22	disp in identifier of klass record
+
+display_ispacked equ 0	disp in display of ispacked field
+display_labsused equ 2	disp in display of labsused
+display_fname equ 6	disp in display of fname
+
+ltype_next equ 0	disp in ltype of next
+ltype_name equ 4	disp in ltype of name
+ltype_disx equ 8	disp in ltype of disx
+
+valu_ival equ	0	disp in valu of integer value
+valu_valp equ	0	disp in valu of value pointer
+;
+;  Variables
+;
+digit	ds	maxCnt	string for building numeric constants
+endOfUses ds	2	at end of a uses file?
+test	ds	2
+tInSymbol ds	3	first 3 bytes of InSymbol
+;
+;  Enumerations
+;
+bools	enum	(false,true),0
+symbol	enum	(ident,intconst,realconst,stringconst,notsy,mulop,addop,relop),0
+	enum	(lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow)
+	enum	(colon,dotdot,becomes,labelsy,constsy,typesy,varsy,funcsy,progsy)
+	enum	(procsy,setsy,packedsy,arraysy,recordsy,filesy,nilsy)
+	enum	(beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy)
+	enum	(gotosy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy)
+	enum	(thensy,othersy,otherwisesy,powersy,bitnot,usessy,stringsy)
+	enum	(atsy,longintconst,unitsy,interfacesy,implementationsy)
+	enum	(univsy,objectsy,inheritedsy)
+operator enum	(noop,mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop),0
+	enum	(gtop,neop,eqop,inop,band,bor,xor,rshift,lshift)
+cstclass enum	(reel,pset,strg,chset,long),0
+chtp	enum	(letter,number,special,illegal,underLine),0
+	enum	(chLComt,chStrQuo,chColon,chPeriod,chlt,chgt)
+	enum	(chLParen,chSpace,chAsterisk,chDollar,chAt)
+;
+;  Structured constants
+;
+charTp	entry		character types
+	dc	8i1'illegal'
+	dc	i1'illegal,chSpace',6I1'illegal'
+	dc	8i1'illegal'
+	dc	8i1'illegal'
+	dc	i1'chSpace,special,illegal,illegal,chDollar,illegal,special,chStrQuo'
+	dc	i1'chLParen,special,chAsterisk,special,special,special,chPeriod,special'
+	dc	8i1'number'
+	dc	i1'number,number,chColon,special,chlt,special,chgt,illegal'
+	dc	i1'chAt',7I1'letter'
+	dc	8i1'letter'
+	dc	8i1'letter'
+	dc	3i1'letter',I1'special,illegal,special,special,underLine'
+	dc	8i1'illegal'
+	dc	8i1'illegal'
+	dc	8i1'illegal'
+	dc	3i1'illegal',I1'chLComt,special,illegal,special,illegal'
+
+	dc	8i1'letter'	$80
+	dc	8i1'letter'
+	dc	8i1'letter'	$90
+	dc	8i1'letter'
+	dc	7i1'illegal',i1'letter'	$A0
+	dc	5i1'illegal',i1'special',2i1'letter'
+	dc	2i1'illegal',2i1'special',4i1'letter'	$B0
+	dc	i1'letter,letter,illegal,letter,letter,letter,letter,letter'
+	dc	i1'illegal,illegal,illegal,illegal,letter,illegal,letter,special'
+	dc	i1'special,illegal,chSpace',5i1'letter'
+	dc	6i1'illegal',i1'special',i1'illegal'	$D0
+	dc	i1'letter,illegal,illegal,illegal,illegal,illegal,letter,letter'
+	dc	8i1'illegal'	$E0
+	dc	8i1'illegal'
+	dc	8i1'illegal'	$F0
+	dc	8i1'illegal'
+
+uppercase anop
+ dc i1'$00,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0A,$0B,$0C,$0D,$0E,$0F'
+ dc i1'$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$1A,$1B,$1C,$1D,$1E,$1F'
+ dc i1'$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$2A,$2B,$2C,$2D,$2E,$2F'
+ dc i1'$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$3A,$3B,$3C,$3D,$3E,$3F'
+ dc c'@ABCDEFGHIJKLMNO'
+ dc c'PQRSTUVWXYZ[\]^_'
+ dc c'`ABCDEFGHIJKLMNO'
+ dc c'PQRSTUVWXYZ{|}~',i1'$7F'
+ dc i1'$80,$81,$82,$83,$84,$85,$86,$87,$CB,$89,$80,$CC,$81,$82,$83,$8F'
+ dc i1'$90,$91,$92,$93,$94,$95,$84,$97,$98,$99,$85,$CD,$9C,$9D,$9E,$86'
+ dc i1'$A0,$A1,$A2,$A3,$A4,$A5,$A6,$A7,$A8,$A9,$AA,$AB,$AC,$AD,$AE,$AF'
+ dc i1'$B0,$B1,$B2,$B3,$B4,$B5,$C6,$B7,$B8,$B8,$BA,$BB,$BC,$BD,$AE,$AF'
+ dc i1'$C0,$C1,$C2,$C3,$C4,$C5,$C6,$C7,$C8,$C9,$CA,$CB,$CC,$CD,$CE,$CE'
+ dc i1'$D0,$D1,$D2,$D3,$D4,$D5,$D6,$D7,$D8,$D9,$DA,$DB,$DC,$DD,$DE,$DF'
+ dc i1'$E0,$E1,$E2,$E3,$E4,$E5,$E6,$E7,$E8,$E9,$EA,$EB,$EC,$ED,$EE,$EF'
+ dc i1'$F0,$F1,$F2,$F3,$F4,$F5,$F6,$F7,$F8,$F9,$FA,$FB,$FC,$FD,$FE,$FF'
+;
+;  DCB's
+;
+st_dcb	anop		stop dcb
+st_flag	ds	2
+	end
+
+****************************************************************
+*
+*  EndDigit - Flag the end of a digit
+*
+*  Inputs:
+*	Y - disp in line
+*	X - disp in digit
+*
+****************************************************************
+*
+EndDigit private
+	using GetCom
+
+	stz	digit,X
+	sty	chCnt
+	jsl	NextCh
+	rts
+	end
+
+****************************************************************
+*
+*  EndOfLine - Read in the next source line
+*
+*  Inputs:
+*	chPtr - pointer to the next line to read
+*
+*  Outputs:
+*	LINECOUNT - updated; # lines read
+*	chPtr - updated
+*	LINE - characters in this line
+*	ERRINX - # errors in this line; set to 0
+*	chCnt - # characters read from the line; set to 0
+*
+****************************************************************
+*
+EndOfLine private
+	using GetCom
+cPtr	equ	1	local copy of chPtr
+
+         sub	,4
+
+	move4	chPtr,cPtr	cPtr := chPtr
+	stop	st_dcb	if user flagged an abort then
+	lda	st_flag	  TermError(0, nil);
+	beq	st1
+	ph2	#0
+	ph4	#0
+	jsl	TermError
+st1	jsl	ListLine	ListLine;
+	inc	LINECOUNT	linecount := linecount+1;
+	clc		<skip to end of old line>
+	lda	cPtr
+	adc	chCnt
+	sta	cPtr
+	bcc	lb1
+	inc	cPtr+2
+lb1	stz	chCnt	chCnt := 0;
+	stz	ERRINX	ERRINX := 0;
+	stz	debugType	DEBUGTYPE := 0;
+	lda	[cPtr]	if cPtr^ in [autoGo,breakPoint] then
+	and	#$00FF	  begin
+	cmp	#breakPoint
+	beq	lb2
+	cmp	#autoGo
+	bne	lb4	  if cPtr^ = autoGo then
+	lda	#2	    debugType := 2
+	bra	lb3	  else
+lb2	lda	#1	    debugType := 1;
+lb3	sta	debugType
+	inc4	cPtr	  cPtr := pointer(ord4(cPtr)+1);
+lb4	anop		  end; {if}
+
+	move4	cPtr,chPtr	chPtr := cPtr
+	ret
+	end
+
+****************************************************************
+*
+*  FakeInsymbol - install the uses file InSymbol patch
+*
+****************************************************************
+*
+FakeInsymbol private
+	using GetCom
+
+	lda	InSymbol	set up fake InSymbol
+	sta	tInSymbol
+	lda	InSymbol+1
+	sta	tInSymbol+1
+	lda	jmp
+	sta	InSymbol
+	lda	jmp+1
+	sta	InSymbol+1
+	rtl
+
+jmp	jmp	UsesInSymbol
+	end
+
+****************************************************************
+*
+*  InSymbol - Read the next symbol from the source file
+*
+*  Outputs:
+*	SY - kind of symbol found
+*	OP - classification of symbol
+*	VAL - value of last constant
+*	LGTH - length of last string constant
+*	ID - last identifier
+*
+****************************************************************
+*
+InSymbol start
+	using GetCom
+rwLen	equ	15	# bytes in a reserved word
+
+cPtr	equ	1	local copy of chPtr
+lvp	equ	5	constant record
+count	equ	9	loop counter
+aindex	equ	11	array index
+k	equ	13	temp index variable
+
+	sub	,14
+
+lb1	lda	endOfUses	if endOfUses then
+	beq	lab1
+	lda	#othersy	  sy := othersy;
+	sta	SY
+	stz	endOfUses	  endOfUses := false;
+	brl	end	  return;
+
+lab1	anop		1:
+	lda	CH	  while (charTp[ch] = chSpace) and
+	cmp	#' '	    not eofl do
+	beq	lb2	    nextch;
+	cmp	#$CA
+	beq	lb2
+	cmp	#tab
+	bne	lb4
+lb2	lda	EOFL
+	bne	lb3
+	jsl	NextCh
+	bra	lb1
+lb3	lda	CH	  case charTp[ch] of
+lb4	tax
+	lda	charTp,X
+	and	#$00FF
+	asl	A
+	tax
+	jmp	(caseTable,X)
+
+caseTable anop		jump table for the case statement
+	dc	a'lr1'	letter
+	dc	a'nm1'	number
+	dc	a'sp1'	special
+	dc	a'il1'	illegal
+	dc	a'un1'	underLine
+	dc	a'cm1'	clLComt
+	dc	a'qt1'	chStrQuo
+	dc	a'cl1'	colon
+	dc	a'dt1'	period
+	dc	a'lt1'	chlt
+	dc	a'gt1'	chgt
+	dc	a'lp1'	chLParen
+	dc	a'bl1'	chSpace
+	dc	a'as1'	chAsterisk
+	dc	a'dl1'	chDollar
+	dc	a'at1'	chAt
+;
+;  Flag and skip illegal characters
+;
+il1	anop		    illegal: begin
+	listerror #6	      error(6);
+	jsl	NextCh	      nextch;
+	brl	lab1	      goto 1;
+;			      end;
+;
+;  Skip leading white space
+;
+bl1	anop		    chSpace:
+	lda	#otherSy	      sy := othersy;
+	sta	SY
+	brl	end
+;
+;  Handle identifiers and reserved words
+;
+un1	anop		    underline,
+lr1	anop		    letter: begin
+	move4	chPtr,cPtr
+!			      k := 0;
+!			      id[0] := chr(0);
+	stz	id
+	ldy	chCnt
+	dey
+	ldx	#0
+	short M
+lr2	anop		      repeat
+	lda	[cPtr],Y		if iso then
+	cmp	#'_'		  if (ch = '_')
+	beq	lr2a
+	cmp	#$80		    or (ord(ch) > $7F) then
+	blt	lr4
+lr2a	pha
+	lda	ISO
+	beq	lr3
+	long	M		    error(112);
+	phx
+	phy
+	listerror #112
+	ply
+	plx
+	lda	#0
+	short M
+lr3	pla
+!				k := k+1;
+lr4	stx	k		if k <= maxcnt then
+	tax			  id[k] := ch;
+	lda	upperCase,X
+	tax
+	lda	charTp,X
+	cmp	#letter
+	beq	lr6
+	cmp	#number
+	beq	lr6
+	cmp	#underLine
+	bne	lr7
+lr6	txa
+	ldx	k
+	sta	id+1,X
+	iny			nextch;
+	inx
+	bra	lr2	      until not
+!				(charTp[ch] in
+!				[letter,number,underscore]);
+lr7	sty	chCnt
+	lda	k	      id[0] := chr(k);
+	sta	id
+	long	M
+	jsr	LNextCh
+	lda	k	      if k < rwLen then begin
+	cmp	#rwLen
+	jge	lr9a
+	lda	id+1		index := ord(id[1])-ord('a');
+	and	#$00FF
+	asl	a
+	tax
+	lda	nrw-'A'*2,X		for i := frw[index] to
+	jeq	lr9a		  frw[index+1] - 1 do
+	sta	count
+	lda	arw-'A'*2,X
+	sta	aindex
+	tax
+lr8	lda	|0,X		  if rw[i] = id then begin
+	cmp	id
+	bne	lr9
+	and	#$00FF
+	dec	A
+	tay
+	phx
+	clc
+	adc	1,S
+	plx
+	tax
+	short	M
+cp1	lda	|1,X
+	cmp	id+1,Y
+	bne	lr9
+	dex
+	dey
+	bne	cp1
+	long	M
+	ldx	aindex
+	lda	|rwLen,X		    sy := rsy[i];
+	sta	SY
+	lda	|rwLen+2,X		    op := rop[i];
+	sta	OP
+	lda	ISO		    if not (iso and
+	beq	lr8a
+	lda	SY		      ((sy = otherwisesy)
+	cmp	#otherwisesy
+	beq	lr9a
+	cmp	#stringsy		      or (sy = stringsy)
+	beq	lr9a
+	cmp	#unitsy		      or (sy = unitsy)
+	beq	lr9a
+	cmp	#interfacesy		      or (sy = interfacesy)
+	beq	lr9a
+	cmp	#implementationsy		      or (sy = implementationsy)
+	beq	lr9a
+	cmp	#univsy		      or (sy = univsy)
+	beq	lr9a
+	cmp	#usessy		      or (sy = usessy)))
+	beq	lr9a
+	cmp	#objectsy		      or (sy = objectsy)))
+	beq	lr9a
+	cmp	#inheritedsy		      or (sy = inheritedsy)))
+	beq	lr9a		      then
+lr8a	brl	end		      goto 2;
+lr9	long	M		    end;
+	clc
+	lda	aindex
+	adc	#rwLen+4
+	sta	aindex
+	tax
+	dec	count
+	jne	lr8
+!				end;
+lr9a	lda	#ident	      sy := ident;
+	sta	SY
+	lda	#noop	      op := noop;
+	sta	OP
+	brl	end	2:    end;
+;
+;  Handle numeric constants
+;
+nm1	anop		    number: begin
+	move4	chPtr,cPtr
+	lda	#noop	      op := noop;
+	sta	OP
+	ldy	chCnt	      k := 0;
+	dey
+	ldx	#0
+	jsr	SaveDigits2	      repeat
+!				savedigit;
+!			      until charTp[ch] <> number;
+	lda	#intconst	      sy := intconst;
+	sta	SY
+	lda	[cPtr],Y	      if ((ch = '.') and
+	and	#$00FF		(line[chCnt+1] <> ')') and
+	cmp	#'e'		(line[chCnt+1] <> '.')) or
+	beq	nm2		(ch = 'e') then begin
+	cmp	#'E'
+	beq	nm2
+	cmp	#'.'
+	bne	nm12a
+	lda	[cPtr],Y
+	cmp	#').'
+	beq	nm12a
+	cmp	#'..'
+	bne	nm2
+nm12a	brl	nm12
+nm2	lda	[cPtr],Y		if ch = '.' then begin
+	and	#$00FF
+	cmp	#'.'
+	bne	nm5
+	sta	digit,X		  savedigit;
+	inx
+	iny
+	jsr	SaveDigits		  if charTp[ch] <> number then
+!				    error(103)
+!				  else
+!				    repeat
+!				      savedigit
+!				    until charTp[ch] <> number;
+nm5	anop			  end;
+	lda	[cPtr],Y		if ch = 'e' then begin
+	and	#$00FF
+	cmp	#'e'
+	beq	nm6
+	cmp	#'E'
+	bne	nm9
+nm6	sta	digit,X		  savedigit;
+	iny
+	inx
+	lda	[cPtr],Y		  if (ch = '+') or (ch ='-')
+	and	#$00FF
+	cmp	#'+'
+	beq	nm7
+	cmp	#'-'
+	bne	nm8
+nm7	sta	digit,X		    then savedigit;
+	iny
+	inx
+nm8	jsr	SaveDigits		  if charTp[ch] <> number then
+!				    error(103)
+!				  else
+!				    repeat
+!				      savedigit
+!				    until charTp[ch] <> number;
+!				  end;
+nm9	jsr	EndDigit		{finish reading number}
+	ph2	#constantSize_reel		new(lvp,reel);
+	jsl	Malloc
+	sta	lvp
+	stx	lvp+2
+	lda	#realconst		sy:= realconst;
+	sta	SY
+	lda	#reel		lvp^.cclass := reel;
+	sta	[lvp]
+	ph4	#digit		lvp^.rval := cnvsr(digit);
+	ph4	#index		{convert from ascii to decform}
+	ph4	#decrec
+	ph4	#valid
+	stz	index
+	stz	index+2
+	fcstr2dec
+	lda	valid		{flag an error if SANE said to}
+	beq	nm10
+	ldy	index
+	lda	digit,Y
+	and	#$00FF
+	bne	nm10
+	ph4	#decrec		{convert decform to real}
+	ph4	#realvalue
+	fdec2d
+	bcs	nm10
+	lda	realvalue		{save the result}
+	ldy	#constant_rval
+	sta	[lvp],Y
+	lda	realvalue+2
+	iny
+	iny
+	sta	[lvp],Y
+	lda	realvalue+4
+	iny
+	iny
+	sta	[lvp],Y
+	lda	realvalue+6
+	iny
+	iny
+	sta	[lvp],Y
+	bra	nm11		if syserr then
+nm10	listerror #105		  error(105);
+nm11	move4 lvp,VAL+valu_valp		val.valp := lvp
+	bra	nm15		end
+nm12	anop		      else begin
+	ph4	#0		lval := cnvs4(digit);
+	ph4	#digit		if syserr then
+	phx			  error(105);
+	jsr	EndDigit		  {finish reading number}
+	ph2	#1
+	_dec2long
+	bcc	nm13
+	listerror #105
+nm13	lda	3,S		if istwobyte(lval) then
+	tax
+	lda	1,S
+	bpl	nm14
+	inx
+nm14	txa
+	bne	nm14a
+	pla			  ival := lval
+	sta	VAL+valu_ival
+	pla
+	bra	nm15		else begin
+
+nm14a	ph2	#constantSize_longC	          lvp := pointer(Malloc(sizeof(constantRec)));
+	jsl	Malloc
+	sta	lvp
+	stx	lvp+2
+	lda	#longintconst		  sy := longintconst;
+	sta	SY
+	lda	#long		  lvp^.cclass := long;
+	sta	[lvp]
+	pla
+	ldy	#constant_lval
+	sta	[lvp],Y
+	pla
+	iny
+	iny
+	sta	[lvp],Y
+	move4 lvp,VAL+valu_valp		  val.valp := lvp
+!				  end;
+!				end;
+nm15	lda	CH	      if charTp[ch] = letter then
+	cmp	#'A'
+	blt	nm16
+	cmp	#'Z'+1
+	bge	nm16
+	listerror #103		error(103);
+nm16	brl	end	      end;
+;
+;  Handle hex constants
+;
+dl1	anop		    number: begin
+	lda	#noop	      op := noop;
+	sta	OP
+	lda	#intconst	      sy := intconst;
+	sta	SY
+	jsl	NextCh	      nextch;
+
+	pea	0	      t := 0;
+	pea	0
+	ldy	#0	      chCnt := 0;
+dl2	lda	CH	      while isHex(ch) do
+	cmp	#'0'
+	blt	dl7
+	cmp	#'F'+1
+	bge	dl7
+	cmp	#'9'+1
+	blt	dl3
+	cmp	#'A'
+	blt	dl7
+dl3	iny			chCnt := chCnt+1;
+	lda	3,S		if t > $FFFFFFF then begin
+	cmp	#$1000
+	blt	dl4
+	phy
+	listError #105		  error(105);
+	ply
+	brl	dl7		  goto 1;
+dl4	anop			  end;
+	ldx	#4		t := t<<4 | hexVal(ch);
+dl5	pla
+	asl	a
+	pha
+	lda	3,S
+	rol	a
+	sta	3,S
+	dex
+	bne	dl5
+	lda	CH
+	cmp	#'A'
+	blt	dl6
+	sbc	#7
+dl6	and	#$000F
+	ora	1,S
+	sta	1,S
+	phy			NextCh;
+	jsl	NextCh
+	ply
+	bra	dl2		end;
+dl7	cpy	#5	      if chCnt <= 4 then
+	bge	dl8
+	lda	1,S		if ord(t) < 0 then
+	bpl	dl8
+	lda	#$FFFF		  t := t | $FFFF0000;
+	sta	3,S
+dl8	brl	nm13
+;
+;  Handle string and character constants
+;
+qt1	anop		    chStrQuo: begin
+	move4	chPtr,cPtr
+	lda	#stringconst	      sy := stringconst;
+	sta	SY
+	lda	#noop	      op := noop;
+	sta	OP
+	ldx	#0	      lgth := 0;
+	ldy	chCnt
+	dey
+	short M
+qt2	anop		      repeat
+qt3	anop			repeat
+	iny			  nextch;
+	lda	[cPtr],Y		  lgth := lgth + 1;
+	sta	lString+1,X		  lString[lgth] := ch;
+	inx
+	cmp	#RETURN		until (eol) or (ch = '''');
+	beq	qt4
+	cmp	#''''
+	bne	qt3
+!				if not eol then
+	iny			  nextch
+	bra	qt5		else
+qt4	long	M
+	phy			  error(104)
+	listerror #104
+	ply
+	ldx	#2
+	bra	qt6
+qt5	longa off
+	lda	[cPtr],Y	      until ch <> '''';
+	cmp	#''''
+	beq	qt3
+	long	M
+qt6	dex
+	stx	LGTH
+	sty	chCnt
+	jsr	LNextCh
+!			      lgth := lgth - 1;
+!			      {now lgth = nr of chars in string}
+	lda	LGTH	      if (lgth = 0) and iso then begin
+	bne	qt7
+	lda	ISO
+	beq	qt7
+	listerror #106		error(106);
+	lda	#1		lgth := 1;
+	sta	LGTH
+qt7	anop			end;
+	short	M	      lString[0] := chr(lgth);
+	lda	LGTH
+	sta	lString
+	long	M
+	jsl	SaveString	      if lgth = 1 then
+!				val.ival := ord(lString[1])
+!			      else begin
+!				new(lvp,strg);
+!				lvp^.cclass:=strg;
+!				lvp^.slgth := lgth;
+!				for i := 1 to lgth do
+!				  lvp^.sval[i] := lString[i];
+!				val.valp := lvp;
+!				end
+	brl	end	      end;
+;
+;  Handle : and :=
+;
+cl1	anop		    chColon: begin
+	lda	#noop	      op := noop;
+	sta	OP
+	jsl	NextCh	      nextch;
+	lda	CH	      if ch = '=' then begin
+	cmp	#'='
+	bne	cl2
+	lda	#becomes		sy := becomes;
+	sta	SY
+	jsl	NextCh		nextch;
+	brl	end		end
+cl2	anop		      else
+	lda	#colon		sy := colon
+	sta	SY
+	brl	end	      end;
+;
+;  Handle * and **
+;
+as1	anop		    chAsterisk: begin
+	jsl	NextCh	      nextch;
+	lda	CH	      if ch = '*' then begin
+	cmp	#'*'
+	bne	as2
+	lda	#powersy		sy := powersy;
+	sta	SY
+	lda	#noop		op := noop;
+	sta	OP
+	jsl	NextCh		nextch;
+	brl	end		end
+as2	anop		      else
+	lda	#mulop		sy := mulop;
+	sta	SY
+	lda	#mul		op := mul;
+	sta	OP
+	brl	end	      end;
+;
+;  Handle ., .. and .) -- .) substitutes for ]
+;
+dt1	anop		    chPeriod: begin
+	lda	#noop	      op := noop;
+	sta	OP
+	jsl	NextCh	      nextch;
+	lda	CH	      if ch = '.' then begin
+	cmp	#'.'
+	bne	dt2
+	lda	#dotdot		sy := dotdot;
+	sta	SY
+	jsl	NextCh		nextch;
+	brl	end		end
+dt2	cmp	#')'	      else if ch = ')' then begin
+	bne	dt3
+	lda	#rbrack		sy := rbrack;
+	sta	SY
+	jsl	NextCh		nextch;
+	brl	end		end
+dt3	anop		      else
+	lda	#period		sy := period;
+	sta	SY
+	brl	end	      end;
+;
+;  Handle <, <<, <= and <>
+;
+lt1	anop		    chlt: begin
+	jsl	NextCh	      nextch;
+	lda	#relop	      sy := relop;
+	sta	SY
+	lda	CH	      if ch = '=' then begin
+	cmp	#'='
+	bne	lt2
+	lda	#leop		op := leop;
+	sta	OP
+	jsl	NextCh		nextch;
+	brl	end		end
+lt2	cmp	#'>'	      else if ch = '>' then begin
+	bne	lt3
+	lda	#neop		op := neop;
+	sta	OP
+	jsl	NextCh		nextch;
+	brl	end		end
+lt3	cmp	#'<'	      else if ch = '<' then begin
+	bne	lt4
+	lda	#mulop		sy := mulop;
+	sta	SY
+	lda	#lshift		op := lshift;
+	sta	OP
+	jsl	NextCh		nextch;
+	brl	end		end
+lt4	anop		      else
+	lda	#ltop		op := ltop;
+	sta	OP
+	brl	end	      end;
+;
+;  Handle >, >> and >=
+;
+gt1	anop		    chgt: begin
+	jsl	NextCh	      nextch;
+	lda	#relop	      sy := relop;
+	sta	SY
+	lda	CH	      if ch = '=' then begin
+	cmp	#'='
+	bne	gt2
+	lda	#geop		op := geop;
+	sta	OP
+	jsl	NextCh		nextch;
+	brl	end		end
+gt2	cmp	#'>'	      else if ch = '>' then begin
+	bne	gt3
+	lda	#mulop		sy := mulop;
+	sta	SY
+	lda	#rshift		op := rshift;
+	sta	OP
+	jsl	NextCh		nextch;
+	brl	end		end
+gt3	anop		      else
+	lda	#gtop		op := gtop;
+	sta	OP
+	brl	end	      end;
+;
+;  Handle comments and ( and (. tokens -- (. substitutes for [
+;
+lp1	anop		    chLComt,chLParen: begin
+!			      if charTp[ch] = chLParen then
+	jsl	NextCh		nextch
+!			      else
+!				ch := '*';
+	lda	CH	      if ch = '*' then begin
+	cmp	#'*'
+	bne	cm6
+cm1	jsl	NextCh		nextch;
+	lda	CH		if ch = '$' then
+	cmp	#'$'
+	bne	cm2
+	jsl	options		  options;
+	lsr	A
+	bcs	cm2
+	lda	#' '		  {for append, copy, don't}
+	sta	CH		  {scan for end of comment}
+	brl	lab1
+cm2	jsl	SkipComment		  skipcomment;
+	brl	lab1		goto 1
+cm6	anop			end;
+	cmp	#'.'	      if ch = '.' then begin
+	bne	cm7
+	jsl	NextCh		nextch;
+	lda	#lbrack		sy := lbrack;
+	bra	cm8		end
+cm7	anop		      else
+	lda	#lparent		sy := lparent;
+cm8	sta	SY
+	lda	#noop	      op := noop;
+	sta	OP
+	brl	end	      end;
+;
+;  Handle the @ character.
+;
+at1	anop		    begin
+	jsl	NextCh	      NextCh;
+	lda	ISO	      if iso then
+	beq	at2
+	lda	#arrow		sy := arrow
+	bra	at3	      else
+at2	lda	#atsy		sy := atsy;
+at3	sta	SY
+	lda	#noop	      op := noop;
+	sta	OP
+	brl	end	      end;
+;
+;  Set the symbol and operation for special symbols from two arrays.
+;
+sp1	anop		    special: begin
+	lda	ISO	      if iso then
+	beq	sp2
+	lda	CH	        if ord(ch) >= 128 then
+	and	#$0080
+	beq	sp2
+	listerror #112	          error(112);
+
+sp2	lda	CH	      sy := ssy[ch];
+	tax
+	lda	ssy-' ',X
+	and	#$00FF
+	sta	SY
+	lda	sop-' ',X	      op := sop[ch];
+	and	#$00FF
+	sta	OP
+	jsl	NextCh	      nextch;
+!			      end;
+end	anop		  end {case}
+;
+;  If in an interface file, write the token to it
+;
+	lda	DOINGINTERFACE	if doingInterface
+	beq	if0	  and not doingOption then begin
+	lda	doingOption
+	beq	if0a
+if0	brl	if7
+if0a	ph2	SY	  TokenOut(sy);
+	jsl	TokenOut
+	lda	SY	  if sy in [mulop,addop,relop] then
+	cmp	#mulop
+	beq	if0b
+	cmp	#addop
+	beq	if0b
+	cmp	#relop
+	bne	if0c
+if0b	ph2	OP	    TokenOut(op);
+	jsl	TokenOut
+	brl	if7
+if0c	cmp	#ident	  else if sy = ident then begin
+	bne	if2
+	ldx	#0	    for i := 1 to length(id) do
+	lda	id
+	and	#$00FF
+	tay
+if1	lda	id+1,X	      TokenOut(ord(id[i]));
+	and	#$00FF
+	phx
+	phy
+	pha
+	jsl	TokenOut
+	ply
+	plx
+	inx
+	dey
+	bne	if1
+	pea	' '	    TokenOut(' ');
+	jsl	TokenOut
+	brl	if7	    end
+if2	cmp	#intconst	  else if sy = intconst then begin
+	bne	if3
+	ph2	VAL+valu_ival	    TokenOut(ival);
+	jsl	TokenOut
+	lda	VAL+valu_ival	    TokenOut(ival >> 8);
+	xba
+	pha
+	jsl	TokenOut
+	brl	if7	    end
+if3	cmp	#longintconst	  else if sy = longintconst then begin
+	bne	if4
+	ldy	#constant_lval	    TokenOut(lvp^.lval);
+	lda	[lvp],Y	    TokenOut(lvp^.lval >> 8);
+	xba
+	pha
+	xba
+	pha
+	jsl	TokenOut
+	jsl	TokenOut
+	ldy	#constant_lval+2	    TokenOut(lvp^.lval >> 16);
+	lda	[lvp],Y	    TokenOut(lvp^.lval >> 24);
+	xba
+	pha
+	xba
+	pha
+	jsl	TokenOut
+	jsl	TokenOut
+	bra	if7	    end
+if4	cmp	#realconst	  else if sy = realconst then begin
+	bne	if5
+	ph2	realvalue	    for i := 0 to 7 do begin
+	jsl	TokenOut	      ptr := pointer(@realvalue+i);
+	ph2	realvalue+1	      TokenOut(ptr^);
+	jsl	TokenOut	      end;
+	ph2	realvalue+2
+	jsl	TokenOut
+	ph2	realvalue+3
+	jsl	TokenOut
+	ph2	realvalue+4
+	jsl	TokenOut
+	ph2	realvalue+5
+	jsl	TokenOut
+	ph2	realvalue+6
+	jsl	TokenOut
+	ph2	realvalue+7
+	jsl	TokenOut
+	bra	if7	    end
+if5	cmp	#stringconst	  else if sy = stringconst then begin
+	bne	if7
+	ph2	lgth	    TokenOut(lgth);
+	jsl	TokenOut
+	ldx	#0	    for i := 1 to lgth do
+if6	lda	lString+1,X	      TokenOut(ord(lString[i]));
+	phx
+	pha
+	jsl	TokenOut
+	plx
+	inx
+	cpx	lgth
+	bne	if6
+!			    end;
+if7	anop		  end;
+	ret	 	end; {insymbol}
+;
+;  LNextCh - call NextCh, then reset cPtr
+;
+LNextCh	jsl	NextCh
+	move4	chPtr,cPtr
+	rts
+;
+;  Local data areas
+;
+ssy	anop		special character symbol definitions
+	dc	i1'0,addop,0,0,0,0,mulop,0'
+	dc	i1'lparent,rparent,0,addop,comma,addop,0,mulop'
+	dc	8i1'0'
+	dc	i1'0,0,0,semicolon,0,relop,0,0'
+	dc	i1'0,0,0,0,0,0,0,0'
+	dc	8i1'0'
+	dc	8i1'0'
+	dc	i1'0,0,0,lbrack,0,rbrack,arrow,0'
+	dc	8i1'0'
+	dc	8i1'0'
+	dc	8i1'0'
+	dc	i1'0,0,0,0,addop,0,bitnot,0'
+	dc	8i1'0'				$80
+	dc	8i1'0'
+	dc	8i1'0'				$90
+	dc	8i1'0'
+	dc	8i1'0'				$A0
+	dc	i1'0,0,0,0,0,relop,0,0'
+	dc	i1'0,0,relop,relop,0,0,0,0'			$B0
+	dc	8i1'0'
+	dc	i1'0,0,0,0,0,0,0,mulop'				$C0
+	dc	i1'mulop,0,0,0,0,0,0,0'
+	dc	i1'0,0,0,0,0,0,mulop,0'				$D0
+;	dc	8i1'0'
+sop	dc	i1'0,xor,0,0,0,0,band,0'
+	dc	i1'0,0,0,plus,0,minus,0,rdiv'
+	dc	8i1'0'
+	dc	i1'0,0,0,0,0,eqop,0,0'
+	dc	8i1'0'
+	dc	8i1'0'
+	dc	8i1'0'
+	dc	8i1'0'
+	dc	8i1'0'
+	dc	8i1'0'
+	dc	8i1'0'
+	dc	i1'0,0,0,0,bor,0,0,0'
+	dc	8i1'0'				$80
+	dc	8i1'0'
+	dc	8i1'0'				$90
+	dc	8i1'0'
+	dc	8i1'0'				$A0
+	dc	i1'0,0,0,0,0,neop,0,0'
+	dc	i1'0,0,leop,geop,0,0,0,0'			$B0
+	dc	8i1'0'
+	dc	i1'0,0,0,0,0,0,0,lshift'				$C0
+	dc	i1'rshift,0,0,0,0,0,0,0'
+	dc	i1'0,0,0,0,0,0,idiv,0'				$D0
+;	dc	8i1'0'
+nrw	dc	i'2,1,2,3,2,3,1,0,5,0'	number of reserved words starting with
+	dc	i'0,1,1,2,4,3,0,2,2,3'	 each letter of the alphabet
+	dc	i'4,1,2,0,0,0'
+arw	dc	a'rwa,rwb,rwc,rwd,rwe'	address of first reserved word for each
+	dc	a'rwf,rwg,rwh,rwi,rwj'	 letter of the alphabet
+	dc	a'rwk,rwl,rwm,rwn,rwo'
+	dc	a'rwp,rwq,rwr,rws,rwt'
+	dc	a'rwu,rwv,rww,rwx,rwy'
+	dc	a'rwz'
+!
+rwa	dc	i1'3',c'AND           ',i'mulop,andop'    reserved words, old rsy &
+	dc	i1'5',c'ARRAY         ',i'arraysy,0'	      rop arrays
+rwb	dc	i1'5',c'BEGIN         ',i'beginsy,0'
+rwc	dc	i1'4',c'CASE          ',i'casesy,0'
+	dc	i1'5',c'CONST         ',i'constsy,0'
+rwd	dc	i1'2',c'DO            ',i'dosy,0'
+	dc	i1'3',c'DIV           ',i'mulop,idiv'
+	dc	i1'6',c'DOWNTO        ',i'downtosy,0'
+rwe	dc	i1'3',c'END           ',i'endsy,0'
+	dc	i1'4',c'ELSE          ',i'elsesy,0'
+rwf	dc	i1'3',c'FOR           ',i'forsy,0'
+	dc	i1'8',c'FUNCTION      ',i'funcsy,0'
+	dc	i1'4',c'FILE          ',i'filesy,0'
+rwg	dc	i1'4',c'GOTO          ',i'gotosy,0'
+rwh	anop
+rwi	dc	i1'2',c'IF            ',i'ifsy,0'
+	dc	i1'2',c'IN            ',i'relop,inop'
+	dc	i1'9',c'INTERFACE     ',i'interfacesy,0'
+	dc	i1'14',c'IMPLEMENTATION',i'implementationsy,0'
+	dc	i1'9',c'INHERITED     ',i'inheritedsy,0'
+rwj	anop
+rwk	anop
+rwl	dc	i1'5',c'LABEL         ',i'labelsy,0'
+rwm	dc	i1'3',c'MOD           ',i'mulop,imod'
+rwn	dc	i1'3',c'NIL           ',i'nilsy,0'
+	dc	i1'3',c'NOT           ',i'notsy,0'
+rwo	dc	i1'2',c'OF            ',i'ofsy,0'
+	dc	i1'2',c'OR            ',i'addop,orop'
+	dc	i1'9',c'OTHERWISE     ',i'otherwisesy,0'
+	dc	i1'6',c'OBJECT        ',i'objectsy,0'
+rwp	dc	i1'9',c'PROCEDURE     ',i'procsy,0'
+	dc	i1'6',c'PACKED        ',i'packedsy,0'
+	dc	i1'7',c'PROGRAM       ',i'progsy,0'
+rwq	anop
+rwr	dc	i1'6',c'REPEAT        ',i'repeatsy,0'
+	dc	i1'6',c'RECORD        ',i'recordsy,0'
+rws	dc	i1'3',c'SET           ',i'setsy,0'
+	dc	i1'6',c'STRING        ',i'stringsy,0'
+rwt	dc	i1'4',c'THEN          ',i'thensy,0'
+	dc	i1'2',c'TO            ',i'tosy,0'
+	dc	i1'4',c'TYPE          ',i'typesy,0'
+rwu	dc	i1'5',c'UNTIL         ',i'untilsy,0'
+	dc	i1'4',c'USES          ',i'usessy,0'
+	dc	i1'4',c'UNIT          ',i'unitsy,0'
+	dc	i1'4',c'UNIV          ',i'univsy,0'
+rwv	dc	i1'3',c'VAR           ',i'varsy,0'
+rww	dc	i1'4',c'WITH          ',i'withsy,0'
+	dc	i1'5',c'WHILE         ',i'whilesy,0'
+rwx	anop
+rwy	anop
+rwz	anop
+
+index	ds	4	index into string
+decrec	ds	33	decimal record for conversion
+valid	ds	4	valid prefix flag
+realvalue ds	8	binary format real number
+	end
+
+****************************************************************
+*
+*  ListLine - List the current line and any errors found
+*
+*  Inputs:
+*	LIST - source listing on?
+*	ERRINX - # errors in this line
+*	LINE - source line to list
+*	errList - array of error numbers
+*
+****************************************************************
+*
+ListLine private
+	using GetCom
+errtype_nmr equ 0	disps in errtype record
+errtype_pos equ 2
+
+i	equ	1
+k	equ	3
+cPtr	equ	5	local copy of chPtr
+r0	equ	9	work register
+lch	equ	11	temp character
+
+	sub	,12
+
+	jsl	KeyPress	if <a key has been pressed> then begin
+	tay
+	beq	kp1
+	jsl	DrawHourglass	  DrawHourglass;
+kp0	jsl	Keypress	  repeat
+	tay
+	beq	kp0	  until KeyPress;
+	jsl	ClearHourglass	  ClearHourglass;
+kp1	anop		  end;
+	lda	LIST	if (list or (errinx > 0)) and
+	ora	ERRINX	  linecount then begin
+	jeq	lb9
+	lda	LINECOUNT
+	jeq	lb9
+	put2	LINECOUNT,#4	  write(linecount:4,' ');
+	putc	#' '
+	move4	chPtr,cPtr	  while line[i] <> return do begin
+	ldy	#0
+lb1	lda	[cPtr],Y
+	and	#$00FF
+	cmp	#return
+	beq	lb2
+	phy		    write(line[i]);
+	sta	lch
+	putc	lch
+	ply
+	iny		    i := i+1;
+	bra	lb1	    end;
+lb2	jsl	LineFeed	  LineFeed;
+	ldx	#1	  for i := 1 to errinx do begin
+	stx	i
+lb3	lda	i
+	cmp	ERRINX
+	jgt	lb8
+	puts	#'****'	    write('****');
+	lda	i	    for k := 1 to errlist[i].pos-1 do
+	asl	A
+	asl	A
+	tax
+	lda	errList-4+errtype_pos,X
+	dec	a
+	beq	lb5
+	bmi	lb5
+	cmp	#maxcnt
+	bge	lb5
+	sta	k
+lb4	putc	#' '	      write(' ');
+	dbne	k,lb4
+lb5	puts	#'^ '	    write('^ ');
+	lla	r0,msgs	    <find error message>
+	lda	i
+	asl	A
+	asl	A
+	tax
+	lda	errList-4+errtype_nmr,X
+	sta	k
+lb6	dbeq	k,lb7
+	lda	(r0)
+	and	#$00FF
+	sec
+	adc	r0
+	sta	r0
+	bra	lb6
+lb7	dec	r0	    <write the error message>
+	puts	{r0}
+	inc	r0
+	jsl	LineFeed	    LineFeed;
+	lda	allTerm	    if allTerm then
+	beq	lb7a
+	lda	i	      chCnt := errlist[i].pos-2;
+	asl	A
+	asl	A
+	tax
+	lda	errList-4+errtype_pos,X
+	dec	a
+	dec	a
+	sta	chCnt
+	ph2	#0	      TermError(0, r0);
+	ph2	#msgs|(-16)
+	ph2	r0
+	jsl	TermError
+lb7a	inc	i	    end;
+	brl	lb3
+lb8	lda	ERRINX	  if (errinx > 0) and 
+	beq	lb9	    (not printer) then
+	lda	printer
+	bne	lb9
+	jsl	WaitForKeyPress	    WaitForKeyPress;
+lb9	anop		  end;
+	jsl	Spin	  Spin;
+	ret
+
+msgs	dw	'error in simple type'	1
+	dw	'identifier expected'
+	dw	'''program'' expected'
+	dw	''')'' expected'
+	dw	''':'' expected'
+	dw	'illegal symbol'
+	dw	'error in parameter list'
+	dw	'''of'' expected'
+	dw	'''('' expected'
+	dw	'error in type'	10
+	dw	'''['' expected'
+	dw	''']'' expected'
+	dw	'''end'' expected'
+	dw	''';'' expected'
+	dw	'integer expected'
+	dw	'''='' expected'
+	dw	'''begin'' expected'
+	dw	'error in declaration part'
+	dw	'error in field-list'
+	dw	''','' expected'	20
+	dw	'''.'' expected'
+	dw	'error in constant'
+	dw	''':='' expected'
+	dw	'''then'' expected'
+	dw	'''until'' expected'
+	dw	'''do'' expected'
+	dw	'''to'' expected'
+	dw	'error in factor'
+	dw	'error in variable'
+	dw	'identifier declared twice' 30
+	dw	'low bound exceeds high bound'
+	dw	'identifier is not of appropriate class'
+	dw	'identifier not declared'
+	dw	'sign not allowed'
+	dw	'number expected'
+	dw	'incompatible subrange types'
+	dw	'quoted file name expected'
+	dw	'type must not be real'
+	dw	'tagfield type must be scalar or subrange'
+	dw	'incompatible with tagfield type' 40
+	dw	'index type must be scalar or subrange'
+	dw	'base type must not be real'
+	dw	'base type must be scalar or subrange'
+	dw	'error in type of standard procedure parameter'
+	dw	'forward declared; repitition of parameter list not allowed'
+	dw	'function result type must be scalar, subrange or pointer'
+	dw	'file value parameter not allowed'
+	dw	'forward declared function; cannot repeat type'
+	dw	'missing result type in function declaration'
+	dw	'F-format for real only' 50
+	dw	'error in type of standard function parameter'
+	dw	'number of parameters does not agree with declaration'
+	dw	'result type of function does not agree with declaration'
+	dw	'type conflict of operands'
+	dw	'expression is not of set type'
+	dw	'only tests on equality allowed'
+	dw	'strict inclusion not allowed'
+	dw	'file comparison not allowed'
+	dw	'illegal type of operand(s)'
+	dw	'type of operand must be boolean' 60
+	dw	'set element type must be scalar or subrange'
+	dw	'set element types not compatible'
+	dw	'type of variable is not array'
+	dw	'index type is not compatible with declaration'
+	dw	'type of variable is not record'
+	dw	'type of variable must be file or pointer'
+	dw	'illegal parameter substitution'
+	dw	'illegal type of loop control variable'
+	dw	'illegal type of expression'
+	dw	'type conflict'	70
+	dw	'assignment of files not allowed'
+	dw	'label type incompatible with selecting expression'
+	dw	'subrange bounds must be scalar'
+	dw	'74'
+	dw	'assignment to standard function is not allowed'
+	dw	'assignment to formal function is not allowed'
+	dw	'no such field in this record'
+	dw	'actual parameter must be a variable'
+	dw	'control var must be declared at this level'
+	dw	'multidefined case label' 80
+	dw	'only extern, forward, ProDOS or tool allowed in uses'
+	dw	'missing corresponding variant declaration'
+	dw	'''..'' expected'
+	dw	'previous declaration was not forward'
+	dw	'again forward declared'
+	dw	'parameter size must be constant'
+	dw	'multidefined label'
+	dw	'multideclared label'
+	dw	'undeclared label'
+	dw	'error in base set'	90
+	dw	'missing ''input'' in program heading'
+	dw	'missing ''output'' in program heading'
+	dw	'assignment to function identifier not allowed here'
+	dw	'multidefined record variant'
+	dw	'cannot use as formal parameter'
+	dw	'no assignment to function found'
+	dw	'cannot modify control variable'
+	dw	'wrong number of selectors'
+	dw	'illegal goto'
+	dw	'misplaced directive'	100
+	dw	'extern allowed at program level only'
+	dw	'label space exhausted'
+	dw	'digit expected'
+	dw	'string constant must not exceed source line'
+	dw	'integer constant exceeds range'
+	dw	'zero string not allowed'
+	dw	'too many nested scopes of identifiers'
+	dw	'too many nested procedures and/or functions'
+	dw	'further errors supressed'
+	dw	'element expression out of range' 110
+	dw	'implementation restriction'
+	dw	'not iso standard'
+	dw	'compiler error'
+	dw	'114'
+	dw	'uses allowed at program level only'
+	dw	'error in uses'
+	dw	'file cannot contain another file'
+	dw	'''implementation'' expected'
+	dw	'''interface'' expected'
+	dw	'body must appear in implementation part' 120
+	dw	'casted expression must be scalar or pointer'
+	dw	'use memory model 1 for memory blocks larger than 64K'
+	dw	'objects cannot have a variant part'
+	dw	'undeclared method'
+	dw	'not a known object'
+	dw	'methods must be declared at the program level'
+	dw	'objects must be declared as a named type'
+	dw	'object expected'
+	dw	'type of variable must be object'
+	dw	'there is no method to inherit' 130
+	dw	'string expected'
+	dw	'implementation restriction: string space exhausted'
+	dw	'Unexpected end of file'
+	end    
+
+****************************************************************
+*
+*  Match - Insure that the next symbol is the one requested
+*
+*  Inputs:
+*	sym - symbol to match
+*	ern - number of error of there is no match
+*
+****************************************************************
+*
+Match	start
+	using GetCom
+
+	sub	(2:sym,2:ern),0
+	lda	sym	if sy = sym then
+	cmp	SY
+	bne	lb1
+	jsl	InSymbol	  insymbol
+	bra	lb2	else
+lb1	lda	ern	  error(ern);
+	pha
+	jsl	Error
+lb2	ret
+	end
+
+****************************************************************
+*
+*  NextCH - Get Next Character
+*
+*  Inputs:
+*	EOFL - at end of file?
+*	eol - at end of line?
+*	fHeadGS - head of copied files list
+*	chCnt - number of character read from the line so far
+*
+*  Outputs:
+*	EOFL - set if at end of file
+*	eol - set if at end of line
+*	chCnt - updated
+*	CH - next character to process
+*
+****************************************************************
+*
+NextCH	private
+	using GetCom
+cPtr	equ	1	local copy of chPtr
+fPtr	equ	5	local copy of fHeadGS
+
+	sub	,8
+
+	move4	chPtr,cPtr	cPtr := chPtr;
+	lda	EOFL	if not eofl then begin
+	beq	ef1
+	lda	#' '
+	sta	CH
+	brl	ret
+
+ef1	lda	eol	  if eol then begin
+	jeq	lb8
+lab1	clc		1:  if eof(prd) then begin
+	lda	chCnt
+	adc	cPtr
+	tax
+	lda	cPtr+2
+	adc	#0
+	cmp	chEndPtr+2
+	bne	ef2
+	cpx	chEndPtr
+ef2	jlt	lb5
+lb0	jsl	PurgeSource	      <purge the file>;
+	lda	fHeadGS	      if fHeadGS = nil then begin
+	ora	fHeadGS+2
+	bne	lb1
+	lda	eofDisable		if not eofDisable then begin
+	bne	lb0a
+	ph2	#133		  <flag the error>;
+	jsl	Error
+	inc	NUMERR		  numerr := numerr+1
+lb0a	anop			  end;
+	la	EOFL,true		eofl := true;
+	stz	TEST		test := false;
+	lda	#' '		ch := ' ';
+	sta	CH
+	brl	ret	      else
+lb1	add4	fHeadGS,#4,cPtr		with fHeadGS^ do begin
+	short M		  fName := name;
+	ldy	#maxPath+4-1
+lb2	lda	[cPtr],Y
+	sta	fNameGS,Y
+	dbpl	Y,lb2
+	long	M
+	jsl	OpenGS		  <open the file>;
+	move4	fHeadGS,fPtr
+	ldy	#maxPath+4+4		  seek(prd,pos);
+	clc
+	lda	[fPtr],Y
+	adc	filePtr
+	sta	cPtr
+	iny
+	iny
+	lda	[fPtr],Y
+	adc	filePtr+2
+	sta	cPtr+2
+	stz	chCnt
+	ldy	#maxPath+4+4+4		  <push uses flag>
+	lda	[fPtr],Y
+	pha
+	ldy	#maxPath+4+4+4+2		  lineCount := fHeadGS^.lineCount;
+	lda	[fPtr],Y
+	sta	lineCount
+	ldy	#2		  fHeadGS := fHeadGS^.next;
+	lda	[fPtr],Y
+	sta	fHeadGS+2
+	lda	[fPtr]
+	sta	fHeadGS
+	dispose fPtr		  dispose(fPtr);
+	pla			  {if this is a uses, mark it}
+	beq	lb3
+	lda	#' '
+	sta	CH
+	lda	#true
+	sta	endOfUses
+	stz	eol
+	bra	ret
+lb3	brl	lab1		  goto 1;
+;				  end;
+;			      end
+lb5	anop		    else begin
+	move4	cPtr,chPtr	      EndOfLine;
+	jsl	EndOfLine
+	move4	chPtr,cPtr
+lb5a	ldy	#0	      while (line[chCnt+1]<>return) and
+	short M		(charTp[line[chCnt+1]]=chSpace) do
+lb6	lda	[cPtr],Y	      chCnt := chCnt+1;
+	cmp	#' '
+	beq	lb6A
+	cmp	#tab
+	beq	lb6A
+	cmp	#$CA
+	bne	lb6B
+	lda	#' '
+lb6A	iny
+	bra	lb6
+lb6B	long	M
+	tya
+	sta	chCnt
+lb7	anop		    end;
+lb8	anop		  end;
+	lda	#0
+	short M
+	ldy	chCnt	eol := line[chCnt] = return;
+	tax
+	lda	[cPtr],Y
+	cmp	#return
+	bne	lb9
+	inx
+	lda	#' '
+lb9	stx	eol
+	tax		ch := line[chCnt];
+	lda	upperCase,X	if (ch >= 'a') and (ch <= 'z') then
+	sta	CH	  ch := chr(ord(ch)-ord('a')+ord('A');
+	stz	CH+1
+	long	M
+	inc	chCnt	chCnt := chCnt+1;
+lb11	anop
+	anop		end;
+
+ret	move4	cPtr,chPtr
+	ret
+	end
+
+****************************************************************
+*
+*  SaveDigits - Save a sequence of digits
+*
+*  Inputs:
+*	X - disp in digit
+*	Y - disp in input line
+*
+*  Outputs:
+*	digit - contains any digits read
+*
+*  Notes:
+*	Entry at SaveDigits2 skips the check that insures
+*	some digits exist.
+*
+*	Assumes cPtr has been set up in a valid DP area at 1
+*
+****************************************************************
+*
+SaveDigits private
+	using GetCom
+cPtr	equ	1	copy of chPtr
+
+	lda	[cPtr],Y	if charTp[ch] <> number then
+	and	#$00FF
+	cmp	#'0'
+	blt	lb1
+	cmp	#'9'+1
+	blt	SaveDigits2
+lb1	phx		  error(103)
+	phy
+	listerror #103
+	ply
+	plx
+	rts
+
+SaveDigits2 entry	else
+	short M
+	anop		  repeat
+	lda	[cPtr],Y	    savedigit
+lb2	sta	digit,X
+	iny
+	inx
+	lda	[cPtr],Y	  until charTp[ch] <> number;
+	cmp	#'0'
+	blt	lb3
+	cmp	#'9'+1
+	blt	lb2
+lb3	long	M
+	rts		  end;
+	end
+
+****************************************************************
+*
+*  SaveString - does the work for InSymbol and UsesInsymbol
+*
+*  Notes: Assumes that a constant record is a word followed by
+*	a p-string.
+*
+****************************************************************
+*
+SaveString private
+	using GetCom
+
+	aif	constant_sval=2,.OK
+	mnote	'constant_sval assumed to be 2',16
+.OK
+
+lvp	equ	1	new constant record pointer
+
+	sub	,4
+
+	lda	LGTH	if lgth = 1 then
+	dec	a
+	bne	qt8
+	lda	lString+1	  val.ival := ord(lString[1])
+	and	#$00FF
+	sta	VAL+valu_ival
+	bra	end	else begin
+
+qt8	lda	lgth	  lvp := pointer(Malloc(lgth+5)));
+	clc		  {extra 2 bytes leave room for
+	adc	#5	   possible expansion in LoadString}
+	pha
+	jsl	Malloc
+	sta	lvp
+	stx	lvp+2
+	lda	#strg	  lvp^.cclass:=strg;
+	sta	[lvp]
+	lda	lgth	  lvp^.sval := lString;
+	and	#$00FF
+	tax
+	ldy	#constant_sval
+	short	M
+	sta	[lvp],Y
+	cpx	#0
+	beq	lb2
+lb1	iny
+	lda	lString-constant_sval,Y
+	sta	[lvp],Y
+	dex
+	bne	lb1
+lb2	long	M
+	move4 lvp,VAL+valu_valp	  val.valp := lvp;
+!			  end; {else}
+end	ret
+	end
+
+****************************************************************
+*
+*  Scanner_Init - Initialize the scanner
+*
+****************************************************************
+*
+Scanner_Init start
+	using GetCom
+;
+;  Initialize volitile variables
+;
+	stz	title+1	delete any old title
+	stz	intPrefixGS+2	wipe out old interface prefix
+	stz	chCnt	no characters read from current line
+	lda	#true	at end of line
+	sta	eol
+	stz	LIST	listing defaults to off
+	stz	doingOption	not compiling an option (directive)
+	stz	fHeadGS	fHeadGS := nil
+	stz	fHeadGS+2
+	stz	lCnt	no lines on printed page
+	stz	langNum	language number not yet determined
+	stz	eofDisable	enable eofl error check
+	stz	endOfUses	not at end of a uses
+	stz	didKeep	no $keep found, yet
+;
+;  Find out how long a page is.
+;
+	la	pageSize,60	assume a size of 60
+	ReadVariableGS rvRec	read the actual size, if any
+	bcs	pl1
+	lda	variable+2	if there is a variable then
+	beq	pl1
+	ph2	#0	  find its value
+	ph4	#variable+2
+	ph2	variable+2
+	ph2	#0
+	_dec2int
+	pla
+	sta	pageSize	  save the value
+pl1	anop		endif
+;
+;  Set printer to true if output has been redirected.
+;
+	direction dr_dcb
+	lda	direction
+	sta	printer
+;
+;  Get the inputs and open the initial file.
+;
+	jsl	InitFile	get shell interface stuff
+	jsl	OpenGS	open the file
+;
+;  Set up the partial compile name list.
+;
+	jsl	GetPartialNames
+;
+;  Read the first character.
+;
+	jsl	NextCh
+	rtl
+;
+;  Local data
+;
+rvRec	dc	i'3'	ReadVariableGS record
+	dc	a4'name,variable'
+	ds	2
+
+name	dosw	PrinterLines	name of the printer line variable
+variable dc	i'9,0',c'     '	value of PrinterLines
+
+dr_dcb	anop		direction dcb
+	dc	i'1'	find direction of standard out
+direction ds	2	direction of standard out
+	end
+
+****************************************************************
+*
+*  UsesInSymbol - returns a symbol from an interface file
+*
+*  Inputs:
+*	tInSymbol - bytes to restore InSymbol with after the
+*		file is processed
+*	usesLength - bytes remaining in file
+*	usesPtr - pointer to next byte in file
+*
+*  Outputs:
+*	sy - symbol
+*	op - operator
+*	id - identifier name
+*	val - constant value
+*
+****************************************************************
+*
+UsesInSymbol start
+	using GetCom
+uPtr	equ	1	local copy of usesPtr
+lvp	equ	5	constant pointer
+
+	sub	,8
+
+	jsl	Spin	Spin;
+	move4	usesPtr,uPtr	uPtr := usesPtr;
+	lda	[uPtr]	SY := uPtr^;
+	and	#$00FF
+	sta	SY
+	inc4	uPtr	++uPtr;
+	dec4	usesLength	--usesLength;
+	stz	OP	op := noop;
+	lda	SY	if sy in [addop,mulop,relop] then begin
+	cmp	#addop
+	beq	la1
+	cmp	#mulop
+	beq	la1
+	cmp	#relop
+	bne	la2
+la1	lda	[uPtr]	  OP := uPtr^;
+	and	#$00FF
+	sta	OP
+	inc4	uPtr	  ++uPtr;
+	dec4	usesLength	  --usesLength;
+la2	anop		  end;
+	lda	SY	if sy = ident then begin
+	cmp	#ident
+	bne	lb2
+	ldy	#0	  y := 0;
+lb1	anop		  while X >= 0 do begin
+	lda	[uPtr]	    id[y+1] := uPtr^;
+	and	#$00FF
+	cmp	#' '
+	beq	lb1a
+	short	M
+	sta	id+1,Y
+	long	M
+	iny		    y := y+1;
+	inc4	uPtr	    uPtr++;
+	dec4	usesLength	    usesLength--;
+	bpl	lb1	    end
+lb1a	short	I	  id[0] := chr(y);
+	sty	id
+	long	I
+	inc4	uPtr	  uPtr++;
+	dec4	usesLength	  usesLength--;
+	brl	lb7	  end
+lb2	cmp	#intconst	else if sy = intconst then begin
+	bne	lb3
+	lda	[uPtr]	  val.ival := uPtr^;
+	sta	VAL+valu_ival
+	add4	uPtr,#2	  uPtr += 2;
+	sub4	usesLength,#2	  usesLength -= 2;
+	brl	lb7	  end
+lb3	cmp	#longintconst	else if sy = longintconst then begin
+	bne	lb4
+	ph2	#constantSize_longC	  lvp := pointer(Malloc(sizeof(constantRec)));
+	jsl	Malloc
+	sta	lvp
+	stx	lvp+2
+	lda	#long	  lvp^.cclass := long;
+	sta	[lvp]
+	ldy	#2	  lvp^.lval := uPtr^;
+	lda	[uPtr],Y
+	ldy	#constant_lval+2
+	sta	[lvp],Y
+	dey
+	dey
+	lda	[uPtr]
+	sta	[lvp],Y
+	move4 lvp,VAL+valu_valp	  val.valp := lvp;
+	add4	uPtr,#4	  uPtr += 4;
+	sub4	usesLength,#4	  usesLength -= 4;
+	brl	lb7	  end
+lb4	cmp	#realconst	else if sy = realconst then begin
+	bne	lb5
+	ph2	#constantSize_reel	  lvp := pointer(Malloc(sizeof(constantRec)));
+	jsl	Malloc
+	sta	lvp
+	stx	lvp+2
+	lda	#reel	  lcp^.cclass := reel;
+	sta	[lvp]
+	move4 lvp,VAL+valu_valp	  val.valp := lvp;
+	add4	lvp,#valu_valp	  lvp^.rval := uPtr^;
+	ldy	#2
+	lda	[uPtr]
+	sta	[lvp]
+	lda	[uPtr],Y
+	sta	[lvp],Y
+	iny
+	iny
+	lda	[uPtr],Y
+	sta	[lvp],Y
+	iny
+	iny
+	lda	[uPtr],Y
+	sta	[lvp],Y
+	add4	uPtr,#8	  uPtr += 8;
+	sub4	usesLength,#8	  usesLength -= 8;
+	bra	lb7	  end
+lb5	cmp	#stringconst	else if sy = stringconst then begin
+	bne	lb7
+	lda	[uPtr]	  lgth := uPtr^;
+	and	#$00FF
+	sta	lgth
+	tay
+	ldx	#0	  for x := 1 to lgth do begin
+lb6	lda	[uPtr]	    lString[x] := uPtr^;
+	and	#$00FF
+	sta	lString,X
+	inc4	uPtr	    uPtr++;
+	dec4	usesLength	    usesLength--;
+	inx		    end;
+	dey
+	bpl	lb6
+	jsl	SaveString	  if lgth = 1 then
+;			    val.ival := lString[1]
+;			  else begin
+;			    new(lvp,strg);
+;			    lvp^.cclass := strg;
+;			    lvp^.slgth := lgth;
+;			    for i := 1 to lgth do
+;			      lvp^.sval[i] := lString[i];
+;			    val.valp := lvp;
+;			    end;
+;			  end;
+lb7	lda	usesLength+2	if usesLength <= 0 then
+	bmi	lb8
+	ora	usesLength
+	bne	lb9
+lb8	lda	tInSymbol	  <fix InSymbol>
+	sta	InSymbol
+	lda	tInSymbol+1
+	sta	InSymbol+1
+	lla	ffPathname,usesFileNameGS  purge the uses file
+	FastFileGS ffDCB
+lb9	anop		  end;
+
+	move4	uPtr,usesPtr	usesPtr := uPtr;
+	ret
+
+ffDCB	anop
+	dc	i'5'	pCount
+	dc	i'7'	action
+	dc	i'0'	index
+	dc	i'$C000'	flags
+	dc	a4'0'	fileHandle
+ffPathName ds	4	pathName
+	end
diff --git a/scanner.macros b/scanner.macros
old mode 100755
new mode 100644
index ddb409c..a61b416
--- a/scanner.macros
+++ b/scanner.macros
@@ -1 +1,786 @@
- macro
&l ret &r
&l anop
 lclc &len
 aif c:&r,.a
 lclc &r
&r setc 0
&len setc 0
 ago .h
.a
&len amid &r,2,1
 aif "&len"=":",.b
&len amid &r,1,2
&r amid &r,4,l:&r-3
 ago .c
.b
&len amid &r,1,1
&r amid &r,3,l:&r-2
.c
 aif &len<>2,.d
 ldy &r
 ago .h
.d
 aif &len<>4,.e
 ldx &r+2
 ldy &r
 ago .h
.e
 aif &len<>10,.g
 ldy #&r
 ldx #^&r
 ago .h
.g
 mnote 'Not a valid return length',16
 mexit
.h
 aif &totallen=0,.i
 lda &worklen+2
 sta &worklen+&totallen+2
 lda &worklen+1
 sta &worklen+&totallen+1
.i
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 aif &len=0,.j
 tya
.j
 rtl
 mend
 macro
&l sub &parms,&work
&l anop
 aif c:&work,.a
 lclc &work
&work setc 0
.a
 gbla &totallen
 gbla &worklen
&worklen seta &work
&totallen seta 0
 aif c:&parms=0,.e
 lclc &len
 lclc &p
 lcla &i
&i seta c:&parms
.b
&p setc &parms(&i)
&len amid &p,2,1
 aif "&len"=":",.c
&len amid &p,1,2
&p amid &p,4,l:&p-3
 ago .d
.c
&len amid &p,1,1
&p amid &p,3,l:&p-2
.d
&p equ &totallen+4+&work
&totallen seta &totallen+&len
&i seta &i-1
 aif &i,^b
.e
 tsc
 aif &work=0,.f
 sec
 sbc #&work
 tcs
.f
 phd
 tcd
 mend
 macro
&l put2 &n1,&f1,&cr,&errout
 aif c:&f1,.a
 lclc &f1
&f1 setc #0
.a
&l ~setm
 ph2 &n1
 ph2 &f1
 ph2 #c:&cr
 ph2 #c:&errout
 jsl ~put2
 ~restm
 mend
 macro
&l puts &n1,&f1,&cr,&errout
&l ~setm
 lclc &c
&c amid "&n1",1,1
 aif "&c"<>"#",.c
 aif l:&n1>127,.a
 bra ~&syscnt
 ago .b
.a
 brl ~&syscnt
.b
&n1 amid "&n1",2,l:&n1-1
~l&syscnt dc i1"l:~s&syscnt"
~s&syscnt dc c&n1
~&syscnt anop
&n1 setc ~l&syscnt-1
.c
 ~pusha &n1
 aif c:&f1,.c1
 pea 0
 ago .c2
.c1
 ph2 &f1
.c2
 ph2 #c:&cr
 ph2 #c:&errout
 jsl ~puts
 ~restm
 mend
 macro
&l putc &n1,&f1,&cr,&errout
 lclc &f1
&f1 setc #0
.a
&l ~setm
 ph2 &n1
 aif c:&f1,.a
 pea 0
 ago .b
.a
 ph2 &f1
.b
 ph2 #c:&cr
 ph2 #c:&errout
 jsl ~putc
 ~restm
 mend
 macro
&l add4 &m1,&m2,&m3
 lclb &yistwo
 lclc &c
&l ~setm
 aif c:&m3,.a
&c amid "&m2",1,1
 aif "&c"<>"#",.a
&c amid "&m1",1,1
 aif "&c"="{",.a
 aif "&c"="[",.a
&c amid "&m2",2,l:&m2-1
 aif &c>=65536,.a
 clc
 ~lda &m1
 ~op adc,&m2
 ~sta &m1
 bcc ~&syscnt
 ~op.h inc,&m1
~&syscnt anop
 ago .c
.a
 aif c:&m3,.b
 lclc &m3
&m3 setc &m1
.b
 clc
 ~lda &m1
 ~op adc,&m2
 ~sta &m3
 ~lda.h &m1
 ~op.h adc,&m2
 ~sta.h &m3
.c
 ~restm
 mend
 macro
&l sub4 &m1,&m2,&m3
 lclb &yistwo
 lclc &c
&l ~setm
 aif c:&m3,.a
&c amid "&m2",1,1
 aif "&c"<>"#",.a
&c amid "&m1",1,1
 aif "&c"="{",.a
 aif "&c"="[",.a
&c amid "&m2",2,l:&m2-1
 aif &c>=65536,.a
 sec
 ~lda &m1
 ~op sbc,&m2
 ~sta &m1
 bcs ~&syscnt
 ~op.h dec,&m1
~&syscnt anop
 ago .c
.a
 aif c:&m3,.b
 lclc &m3
&m3 setc &m1
.b
 sec
 ~lda &m1
 ~op sbc,&m2
 ~sta &m3
 ~lda.h &m1
 ~op.h sbc,&m2
 ~sta.h &m3
.c
 ~restm
 mend
 macro
&l dbeq &r,&bp
 aif "&r"="X",.l1
 aif "&r"="Y",.l1
 aif "&r"="x",.l1
 aif "&r"="y",.l1
&l dec &r
 beq &bp
 mexit
.l1
&l de&r
 beq &bp
 mend
 macro
&l dbne &r,&bp
 aif "&r"="X",.l1
 aif "&r"="Y",.l1
 aif "&r"="x",.l1
 aif "&r"="y",.l1
&l dec &r
 bne &bp
 mexit
.l1
&l de&r
 bne &bp
 mend
 macro
&l dbpl &r,&bp
 aif "&r"="X",.l1
 aif "&r"="Y",.l1
 aif "&r"="x",.l1
 aif "&r"="y",.l1
&l dec &r
 bpl &bp
 mexit
.l1
&l de&r
 bpl &bp
 mend
 macro
&l dec4 &a
&l ~setm
 lda &a
 bne ~&syscnt
 dec 2+&a
~&syscnt dec &a
 ~restm
 mend
 macro
&l inc4 &a
&l ~setm
 inc &a
 bne ~&syscnt
 inc 2+&a
~&syscnt ~restm
 mend
 macro
&l jeq &bp
&l bne *+5
 brl &bp
 mend
 macro
&l jge &bp
&l blt *+5
 brl &bp
 mend
 macro
&l jgt &bp
&l beq *+7
 blt *+5
 brl &bp
 mend
 macro
&l jne &bp
&l beq *+5
 brl &bp
 mend
 macro
&l la &ad1,&ad2
&l anop
 lcla &lb
 lclb &la
 aif s:longa,.a
 rep #%00100000
 longa on
&la setb 1
.a
 lda #&ad2
&lb seta c:&ad1
.b
 sta &ad1(&lb)
&lb seta &lb-1
 aif &lb,^b
 aif &la=0,.d
 sep #%00100000
 longa off
.d
 mend
 macro
&l lla &ad1,&ad2
&l anop
 lcla &lb
 lclb &la
 aif s:longa,.a
 rep #%00100000
 longa on
&la setb 1
.a
 lda #&ad2
&lb seta c:&ad1
.b
 sta &ad1(&lb)
&lb seta &lb-1
 aif &lb,^b
 lda #^&ad2
&lb seta c:&ad1
.c
 sta 2+&ad1(&lb)
&lb seta &lb-1
 aif &lb,^c
 aif &la=0,.d
 sep #%00100000
 longa off
.d
 mend
 macro
&l long &a,&b
 lclb &i
 lclb &m
&a amid &a,1,1
&m setb ("&a"="M").or.("&a"="m")
&i setb ("&a"="I").or.("&a"="i")
 aif c:&b=0,.a
&b amid &b,1,1
&m setb ("&b"="M").or.("&b"="m").or.&m
&i setb ("&b"="I").or.("&b"="i").or.&i
.a
&l rep #&m*32+&i*16
 aif .not.&m,.b
 longa on
.b
 aif .not.&i,.c
 longi on
.c
 mend
 macro
&l move4 &m1,&m2
 lclb &yistwo
&l ~setm
 ~lda &m1
 ~sta &m2
 ~lda.h &m1
 ~sta.h &m2
 ~restm
 mend
 macro
&l ph2 &n1
 aif "&n1"="*",.f
 lclc &c
&l anop
&c amid &n1,1,1
 aif "&c"="#",.d
 aif s:longa=1,.a
 rep #%00100000
.a
 aif "&c"<>"{",.b
&c amid &n1,l:&n1,1
 aif "&c"<>"}",.g
&n1 amid &n1,2,l:&n1-2
 lda (&n1)
 pha
 ago .e
.b
 aif "&c"="<",.c
 lda &n1
 pha
 ago .e
.c
&n1 amid &n1,2,l:&n1-1
 pei &n1
 ago .e
.d
&n1 amid &n1,2,l:&n1-1
 pea &n1
 ago .f
.e
 aif s:longa=1,.f
 sep #%00100000
.f
 mexit
.g
 mnote "Missing closing '}'",16
 mend
 macro
&l ph4 &n1
 aif "&n1"="*",.f
 lclc &c
&l anop
&c amid &n1,1,1
 aif "&c"="#",.d
 aif s:longa=1,.a
 rep #%00100000
.a
 aif "&c"<>"{",.b
&c amid &n1,l:&n1,1
 aif "&c"<>"}",.g
&n1 amid &n1,2,l:&n1-2
 ldy #2
 lda (&n1),y
 pha
 lda (&n1)
 pha
 ago .e
.b
 aif "&c"<>"[",.c
 ldy #2
 lda &n1,y
 pha
 lda &n1
 pha
 ago .e
.c
 aif "&c"<>"<",.c1
&n1 amid &n1,2,l:&n1-1
 pei &n1+2
 pei &n1
 ago .e
.c1
 lda &n1+2
 pha
 lda &n1
 pha
 ago .e
.d
&n1 amid &n1,2,l:&n1-1
 pea +(&n1)|-16
 pea &n1
 ago .f
.e
 aif s:longa=1,.f
 sep #%00100000
.f
 mexit
.g
 mnote "Missing closing '}'",16
 mend
 macro
&l short &a,&b
 lclb &i
 lclb &m
&a amid &a,1,1
&m setb ("&a"="M").or.("&a"="m")
&i setb ("&a"="I").or.("&a"="i")
 aif c:&b=0,.a
&b amid &b,1,1
&m setb ("&b"="M").or.("&b"="m").or.&m
&i setb ("&b"="I").or.("&b"="i").or.&i
.a
&l sep #&m*32+&i*16
 aif .not.&m,.b
 longa off
.b
 aif .not.&i,.c
 longi off
.c
 mend
 macro
&l ~lda &op
 lclc &c
&c amid "&op",1,1
 aif "&c"<>"{",.b
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
&l lda &op
 mend
 macro
&l ~lda.h &op
&l anop
 lclc &c
&c amid "&op",1,1
 aif "&c"="[",.b
 aif "&c"<>"{",.d
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
 aif &yistwo,.c
&yistwo setb 1
 ldy #2
.c
&op setc "&op,y"
 lda &op
 mexit
.d
 aif "&c"<>"#",.e
&op amid "&op",2,l:&op-1
&op setc "#^&op"
 lda &op
 mexit
.e
 lda 2+&op
 mend
 macro
&l ~op &opc,&op
 lclc &c
&c amid "&op",1,1
 aif "&c"<>"{",.b
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
&l &opc &op
 mend
 macro
&l ~op.h &opc,&op
&l anop
 lclc &c
&c amid "&op",1,1
 aif "&c"="[",.b
 aif "&c"<>"{",.d
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
 aif &yistwo,.c
&yistwo setb 1
 ldy #2
.c
&op setc "&op,y"
 &opc &op
 mexit
.d
 aif "&c"<>"#",.e
&op amid "&op",2,l:&op-1
&op setc "#^&op"
 &opc &op
 mexit
.e
 &opc 2+&op
 mend
 macro
&l ~pusha &n1
 lclc &c
&l anop
&c amid &n1,1,1
 aif "&c"<>"{",.b
&c amid &n1,l:&n1,1
 aif "&c"<>"}",.g
&n1 amid &n1,2,l:&n1-2
 sep #$20
 longa off
 lda #0
 pha
 rep #$20
 longa on
 phk
 lda &n1
 pha
 mexit
.b
 aif "&c"<>"[",.c
&n1 amid &n1,2,l:&n1-2
 lda &n1+2
 pha
 lda &n1
 pha
 mexit
.c
 pea +(&n1)|-16
 pea &n1
 mexit
.g
 mnote "Missing closing '}'",16
 mend
 macro
&l ~restm
&l anop
 aif (&~la+&~li)=2,.i
 sep #32*(.not.&~la)+16*(.not.&~li)
 aif &~la,.h
 longa off
.h
 aif &~li,.i
 longi off
.i
 mend
 macro
&l ~setm
&l anop
 aif c:&~la,.b
 gblb &~la
 gblb &~li
.b
&~la setb s:longa
&~li setb s:longi
 aif s:longa.and.s:longi,.a
 rep #32*(.not.&~la)+16*(.not.&~li)
 longa on
 longi on
.a
 mend
 macro
&l ~sta &op
 lclc &c
&c amid "&op",1,1
 aif "&c"<>"{",.b
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
&l sta &op
 mend
 macro
&l ~sta.h &op
&l anop
 lclc &c
&c amid "&op",1,1
 aif "&c"="[",.b
 aif "&c"<>"{",.d
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
 aif &yistwo,.c
&yistwo setb 1
 ldy #2
.c
&op setc "&op,y"
 sta &op
 mexit
.d
 sta 2+&op
 mend
 macro
&l direction &p
&l ~setm
 jsl $E100A8
 dc i2'$010F'
 dc i4'&p'
 ~restm
 mend
 macro
&l stop &p
&l ~setm
 jsl $E100A8
 dc i2'$0113'
 dc i4'&p'
 ~restm
 mend
 MACRO
&LAB ENUM &LIST,&START
&LAB ANOP
 AIF C:&~ENUM,.A
 GBLA &~ENUM
.A
 AIF C:&START=0,.B
&~ENUM SETA &START
.B
 LCLA &CNT
&CNT SETA 1
.C
&LIST(&CNT) EQU &~ENUM
&~ENUM SETA &~ENUM+1
&CNT SETA &CNT+1
 AIF &CNT<=C:&LIST,^C
 MEND
 MACRO
&LAB LISTERROR &ERR
&LAB LDA 0
 PHA
 PH2 &ERR
 JSL ERROR
 PLA
 STA 0
 MEND
 MACRO
&LAB FCSTR2DEC
&LAB PEA 2
 LDX #$0A0A
 JSL $E10000
 MEND
 MACRO
&LAB _DEC2LONG
&LAB LDX #$290B
 JSL $E10000
 MEND
 MACRO
&LAB FDEC2D
&LAB PEA $0109
 LDX #$090A
 JSL $E10000
 MEND
 MACRO
&LAB _DEC2INT
&LAB LDX #$280B
 JSL $E10000
 MEND
 MACRO
&LAB DISPOSE &PTR
&LAB PH4 &PTR
 JSL ~DISPOSE
 MEND
 macro
&l readvariablegs &p
&l ~setm
 jsl $E100A8
 dc i2'$014B'
 dc i4'&p'
 ~restm
 mend
 MACRO
&LAB DOSW &S
&LAB DC I'L:~A&SYSCNT'
~A&SYSCNT DC C'&S'
 MEND
 macro
&l jlt &bp
&l bge *+5
 brl &bp
 mend
 macro
&l dw &adr
&l dc i1"l:~&sysname&syscnt"
~&sysname&syscnt dc c"&adr"
 mend
 macro
&l fastfilegs &p
&l ~setm
 jsl $E100A8
 dc i2'$014E'
 dc i4'&p'
 ~restm
 mend
\ No newline at end of file
+ macro
+&l ret &r
+&l anop
+ lclc &len
+ aif c:&r,.a
+ lclc &r
+&r setc 0
+&len setc 0
+ ago .h
+.a
+&len amid &r,2,1
+ aif "&len"=":",.b
+&len amid &r,1,2
+&r amid &r,4,l:&r-3
+ ago .c
+.b
+&len amid &r,1,1
+&r amid &r,3,l:&r-2
+.c
+ aif &len<>2,.d
+ ldy &r
+ ago .h
+.d
+ aif &len<>4,.e
+ ldx &r+2
+ ldy &r
+ ago .h
+.e
+ aif &len<>10,.g
+ ldy #&r
+ ldx #^&r
+ ago .h
+.g
+ mnote 'Not a valid return length',16
+ mexit
+.h
+ aif &totallen=0,.i
+ lda &worklen+2
+ sta &worklen+&totallen+2
+ lda &worklen+1
+ sta &worklen+&totallen+1
+.i
+ pld
+ tsc
+ clc
+ adc #&worklen+&totallen
+ tcs
+ aif &len=0,.j
+ tya
+.j
+ rtl
+ mend
+ macro
+&l sub &parms,&work
+&l anop
+ aif c:&work,.a
+ lclc &work
+&work setc 0
+.a
+ gbla &totallen
+ gbla &worklen
+&worklen seta &work
+&totallen seta 0
+ aif c:&parms=0,.e
+ lclc &len
+ lclc &p
+ lcla &i
+&i seta c:&parms
+.b
+&p setc &parms(&i)
+&len amid &p,2,1
+ aif "&len"=":",.c
+&len amid &p,1,2
+&p amid &p,4,l:&p-3
+ ago .d
+.c
+&len amid &p,1,1
+&p amid &p,3,l:&p-2
+.d
+&p equ &totallen+4+&work
+&totallen seta &totallen+&len
+&i seta &i-1
+ aif &i,^b
+.e
+ tsc
+ aif &work=0,.f
+ sec
+ sbc #&work
+ tcs
+.f
+ phd
+ tcd
+ mend
+ macro
+&l put2 &n1,&f1,&cr,&errout
+ aif c:&f1,.a
+ lclc &f1
+&f1 setc #0
+.a
+&l ~setm
+ ph2 &n1
+ ph2 &f1
+ ph2 #c:&cr
+ ph2 #c:&errout
+ jsl ~put2
+ ~restm
+ mend
+ macro
+&l puts &n1,&f1,&cr,&errout
+&l ~setm
+ lclc &c
+&c amid "&n1",1,1
+ aif "&c"<>"#",.c
+ aif l:&n1>127,.a
+ bra ~&syscnt
+ ago .b
+.a
+ brl ~&syscnt
+.b
+&n1 amid "&n1",2,l:&n1-1
+~l&syscnt dc i1"l:~s&syscnt"
+~s&syscnt dc c&n1
+~&syscnt anop
+&n1 setc ~l&syscnt-1
+.c
+ ~pusha &n1
+ aif c:&f1,.c1
+ pea 0
+ ago .c2
+.c1
+ ph2 &f1
+.c2
+ ph2 #c:&cr
+ ph2 #c:&errout
+ jsl ~puts
+ ~restm
+ mend
+ macro
+&l putc &n1,&f1,&cr,&errout
+ lclc &f1
+&f1 setc #0
+.a
+&l ~setm
+ ph2 &n1
+ aif c:&f1,.a
+ pea 0
+ ago .b
+.a
+ ph2 &f1
+.b
+ ph2 #c:&cr
+ ph2 #c:&errout
+ jsl ~putc
+ ~restm
+ mend
+ macro
+&l add4 &m1,&m2,&m3
+ lclb &yistwo
+ lclc &c
+&l ~setm
+ aif c:&m3,.a
+&c amid "&m2",1,1
+ aif "&c"<>"#",.a
+&c amid "&m1",1,1
+ aif "&c"="{",.a
+ aif "&c"="[",.a
+&c amid "&m2",2,l:&m2-1
+ aif &c>=65536,.a
+ clc
+ ~lda &m1
+ ~op adc,&m2
+ ~sta &m1
+ bcc ~&syscnt
+ ~op.h inc,&m1
+~&syscnt anop
+ ago .c
+.a
+ aif c:&m3,.b
+ lclc &m3
+&m3 setc &m1
+.b
+ clc
+ ~lda &m1
+ ~op adc,&m2
+ ~sta &m3
+ ~lda.h &m1
+ ~op.h adc,&m2
+ ~sta.h &m3
+.c
+ ~restm
+ mend
+ macro
+&l sub4 &m1,&m2,&m3
+ lclb &yistwo
+ lclc &c
+&l ~setm
+ aif c:&m3,.a
+&c amid "&m2",1,1
+ aif "&c"<>"#",.a
+&c amid "&m1",1,1
+ aif "&c"="{",.a
+ aif "&c"="[",.a
+&c amid "&m2",2,l:&m2-1
+ aif &c>=65536,.a
+ sec
+ ~lda &m1
+ ~op sbc,&m2
+ ~sta &m1
+ bcs ~&syscnt
+ ~op.h dec,&m1
+~&syscnt anop
+ ago .c
+.a
+ aif c:&m3,.b
+ lclc &m3
+&m3 setc &m1
+.b
+ sec
+ ~lda &m1
+ ~op sbc,&m2
+ ~sta &m3
+ ~lda.h &m1
+ ~op.h sbc,&m2
+ ~sta.h &m3
+.c
+ ~restm
+ mend
+ macro
+&l dbeq &r,&bp
+ aif "&r"="X",.l1
+ aif "&r"="Y",.l1
+ aif "&r"="x",.l1
+ aif "&r"="y",.l1
+&l dec &r
+ beq &bp
+ mexit
+.l1
+&l de&r
+ beq &bp
+ mend
+ macro
+&l dbne &r,&bp
+ aif "&r"="X",.l1
+ aif "&r"="Y",.l1
+ aif "&r"="x",.l1
+ aif "&r"="y",.l1
+&l dec &r
+ bne &bp
+ mexit
+.l1
+&l de&r
+ bne &bp
+ mend
+ macro
+&l dbpl &r,&bp
+ aif "&r"="X",.l1
+ aif "&r"="Y",.l1
+ aif "&r"="x",.l1
+ aif "&r"="y",.l1
+&l dec &r
+ bpl &bp
+ mexit
+.l1
+&l de&r
+ bpl &bp
+ mend
+ macro
+&l dec4 &a
+&l ~setm
+ lda &a
+ bne ~&syscnt
+ dec 2+&a
+~&syscnt dec &a
+ ~restm
+ mend
+ macro
+&l inc4 &a
+&l ~setm
+ inc &a
+ bne ~&syscnt
+ inc 2+&a
+~&syscnt ~restm
+ mend
+ macro
+&l jeq &bp
+&l bne *+5
+ brl &bp
+ mend
+ macro
+&l jge &bp
+&l blt *+5
+ brl &bp
+ mend
+ macro
+&l jgt &bp
+&l beq *+7
+ blt *+5
+ brl &bp
+ mend
+ macro
+&l jne &bp
+&l beq *+5
+ brl &bp
+ mend
+ macro
+&l la &ad1,&ad2
+&l anop
+ lcla &lb
+ lclb &la
+ aif s:longa,.a
+ rep #%00100000
+ longa on
+&la setb 1
+.a
+ lda #&ad2
+&lb seta c:&ad1
+.b
+ sta &ad1(&lb)
+&lb seta &lb-1
+ aif &lb,^b
+ aif &la=0,.d
+ sep #%00100000
+ longa off
+.d
+ mend
+ macro
+&l lla &ad1,&ad2
+&l anop
+ lcla &lb
+ lclb &la
+ aif s:longa,.a
+ rep #%00100000
+ longa on
+&la setb 1
+.a
+ lda #&ad2
+&lb seta c:&ad1
+.b
+ sta &ad1(&lb)
+&lb seta &lb-1
+ aif &lb,^b
+ lda #^&ad2
+&lb seta c:&ad1
+.c
+ sta 2+&ad1(&lb)
+&lb seta &lb-1
+ aif &lb,^c
+ aif &la=0,.d
+ sep #%00100000
+ longa off
+.d
+ mend
+ macro
+&l long &a,&b
+ lclb &i
+ lclb &m
+&a amid &a,1,1
+&m setb ("&a"="M").or.("&a"="m")
+&i setb ("&a"="I").or.("&a"="i")
+ aif c:&b=0,.a
+&b amid &b,1,1
+&m setb ("&b"="M").or.("&b"="m").or.&m
+&i setb ("&b"="I").or.("&b"="i").or.&i
+.a
+&l rep #&m*32+&i*16
+ aif .not.&m,.b
+ longa on
+.b
+ aif .not.&i,.c
+ longi on
+.c
+ mend
+ macro
+&l move4 &m1,&m2
+ lclb &yistwo
+&l ~setm
+ ~lda &m1
+ ~sta &m2
+ ~lda.h &m1
+ ~sta.h &m2
+ ~restm
+ mend
+ macro
+&l ph2 &n1
+ aif "&n1"="*",.f
+ lclc &c
+&l anop
+&c amid &n1,1,1
+ aif "&c"="#",.d
+ aif s:longa=1,.a
+ rep #%00100000
+.a
+ aif "&c"<>"{",.b
+&c amid &n1,l:&n1,1
+ aif "&c"<>"}",.g
+&n1 amid &n1,2,l:&n1-2
+ lda (&n1)
+ pha
+ ago .e
+.b
+ aif "&c"="<",.c
+ lda &n1
+ pha
+ ago .e
+.c
+&n1 amid &n1,2,l:&n1-1
+ pei &n1
+ ago .e
+.d
+&n1 amid &n1,2,l:&n1-1
+ pea &n1
+ ago .f
+.e
+ aif s:longa=1,.f
+ sep #%00100000
+.f
+ mexit
+.g
+ mnote "Missing closing '}'",16
+ mend
+ macro
+&l ph4 &n1
+ aif "&n1"="*",.f
+ lclc &c
+&l anop
+&c amid &n1,1,1
+ aif "&c"="#",.d
+ aif s:longa=1,.a
+ rep #%00100000
+.a
+ aif "&c"<>"{",.b
+&c amid &n1,l:&n1,1
+ aif "&c"<>"}",.g
+&n1 amid &n1,2,l:&n1-2
+ ldy #2
+ lda (&n1),y
+ pha
+ lda (&n1)
+ pha
+ ago .e
+.b
+ aif "&c"<>"[",.c
+ ldy #2
+ lda &n1,y
+ pha
+ lda &n1
+ pha
+ ago .e
+.c
+ aif "&c"<>"<",.c1
+&n1 amid &n1,2,l:&n1-1
+ pei &n1+2
+ pei &n1
+ ago .e
+.c1
+ lda &n1+2
+ pha
+ lda &n1
+ pha
+ ago .e
+.d
+&n1 amid &n1,2,l:&n1-1
+ pea +(&n1)|-16
+ pea &n1
+ ago .f
+.e
+ aif s:longa=1,.f
+ sep #%00100000
+.f
+ mexit
+.g
+ mnote "Missing closing '}'",16
+ mend
+ macro
+&l short &a,&b
+ lclb &i
+ lclb &m
+&a amid &a,1,1
+&m setb ("&a"="M").or.("&a"="m")
+&i setb ("&a"="I").or.("&a"="i")
+ aif c:&b=0,.a
+&b amid &b,1,1
+&m setb ("&b"="M").or.("&b"="m").or.&m
+&i setb ("&b"="I").or.("&b"="i").or.&i
+.a
+&l sep #&m*32+&i*16
+ aif .not.&m,.b
+ longa off
+.b
+ aif .not.&i,.c
+ longi off
+.c
+ mend
+ macro
+&l ~lda &op
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"<>"{",.b
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+&l lda &op
+ mend
+ macro
+&l ~lda.h &op
+&l anop
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"="[",.b
+ aif "&c"<>"{",.d
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+ aif &yistwo,.c
+&yistwo setb 1
+ ldy #2
+.c
+&op setc "&op,y"
+ lda &op
+ mexit
+.d
+ aif "&c"<>"#",.e
+&op amid "&op",2,l:&op-1
+&op setc "#^&op"
+ lda &op
+ mexit
+.e
+ lda 2+&op
+ mend
+ macro
+&l ~op &opc,&op
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"<>"{",.b
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+&l &opc &op
+ mend
+ macro
+&l ~op.h &opc,&op
+&l anop
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"="[",.b
+ aif "&c"<>"{",.d
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+ aif &yistwo,.c
+&yistwo setb 1
+ ldy #2
+.c
+&op setc "&op,y"
+ &opc &op
+ mexit
+.d
+ aif "&c"<>"#",.e
+&op amid "&op",2,l:&op-1
+&op setc "#^&op"
+ &opc &op
+ mexit
+.e
+ &opc 2+&op
+ mend
+ macro
+&l ~pusha &n1
+ lclc &c
+&l anop
+&c amid &n1,1,1
+ aif "&c"<>"{",.b
+&c amid &n1,l:&n1,1
+ aif "&c"<>"}",.g
+&n1 amid &n1,2,l:&n1-2
+ sep #$20
+ longa off
+ lda #0
+ pha
+ rep #$20
+ longa on
+ phk
+ lda &n1
+ pha
+ mexit
+.b
+ aif "&c"<>"[",.c
+&n1 amid &n1,2,l:&n1-2
+ lda &n1+2
+ pha
+ lda &n1
+ pha
+ mexit
+.c
+ pea +(&n1)|-16
+ pea &n1
+ mexit
+.g
+ mnote "Missing closing '}'",16
+ mend
+ macro
+&l ~restm
+&l anop
+ aif (&~la+&~li)=2,.i
+ sep #32*(.not.&~la)+16*(.not.&~li)
+ aif &~la,.h
+ longa off
+.h
+ aif &~li,.i
+ longi off
+.i
+ mend
+ macro
+&l ~setm
+&l anop
+ aif c:&~la,.b
+ gblb &~la
+ gblb &~li
+.b
+&~la setb s:longa
+&~li setb s:longi
+ aif s:longa.and.s:longi,.a
+ rep #32*(.not.&~la)+16*(.not.&~li)
+ longa on
+ longi on
+.a
+ mend
+ macro
+&l ~sta &op
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"<>"{",.b
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+&l sta &op
+ mend
+ macro
+&l ~sta.h &op
+&l anop
+ lclc &c
+&c amid "&op",1,1
+ aif "&c"="[",.b
+ aif "&c"<>"{",.d
+&c amid "&op",l:&op,1
+ aif "&c"="}",.a
+ mnote "Missing closing '}'",2
+&op setc &op}
+.a
+&op amid "&op",2,l:&op-2
+&op setc (&op)
+.b
+ aif &yistwo,.c
+&yistwo setb 1
+ ldy #2
+.c
+&op setc "&op,y"
+ sta &op
+ mexit
+.d
+ sta 2+&op
+ mend
+ macro
+&l direction &p
+&l ~setm
+ jsl $E100A8
+ dc i2'$010F'
+ dc i4'&p'
+ ~restm
+ mend
+ macro
+&l stop &p
+&l ~setm
+ jsl $E100A8
+ dc i2'$0113'
+ dc i4'&p'
+ ~restm
+ mend
+ MACRO
+&LAB ENUM &LIST,&START
+&LAB ANOP
+ AIF C:&~ENUM,.A
+ GBLA &~ENUM
+.A
+ AIF C:&START=0,.B
+&~ENUM SETA &START
+.B
+ LCLA &CNT
+&CNT SETA 1
+.C
+&LIST(&CNT) EQU &~ENUM
+&~ENUM SETA &~ENUM+1
+&CNT SETA &CNT+1
+ AIF &CNT<=C:&LIST,^C
+ MEND
+ MACRO
+&LAB LISTERROR &ERR
+&LAB LDA 0
+ PHA
+ PH2 &ERR
+ JSL ERROR
+ PLA
+ STA 0
+ MEND
+ MACRO
+&LAB FCSTR2DEC
+&LAB PEA 2
+ LDX #$0A0A
+ JSL $E10000
+ MEND
+ MACRO
+&LAB _DEC2LONG
+&LAB LDX #$290B
+ JSL $E10000
+ MEND
+ MACRO
+&LAB FDEC2D
+&LAB PEA $0109
+ LDX #$090A
+ JSL $E10000
+ MEND
+ MACRO
+&LAB _DEC2INT
+&LAB LDX #$280B
+ JSL $E10000
+ MEND
+ MACRO
+&LAB DISPOSE &PTR
+&LAB PH4 &PTR
+ JSL ~DISPOSE
+ MEND
+ macro
+&l readvariablegs &p
+&l ~setm
+ jsl $E100A8
+ dc i2'$014B'
+ dc i4'&p'
+ ~restm
+ mend
+ MACRO
+&LAB DOSW &S
+&LAB DC I'L:~A&SYSCNT'
+~A&SYSCNT DC C'&S'
+ MEND
+ macro
+&l jlt &bp
+&l bge *+5
+ brl &bp
+ mend
+ macro
+&l dw &adr
+&l dc i1"l:~&sysname&syscnt"
+~&sysname&syscnt dc c"&adr"
+ mend
+ macro
+&l fastfilegs &p
+&l ~setm
+ jsl $E100A8
+ dc i2'$014E'
+ dc i4'&p'
+ ~restm
+ mend
diff --git a/scanner.pas b/scanner.pas
old mode 100755
new mode 100644
index 3b54796..0fea42e
--- a/scanner.pas
+++ b/scanner.pas
@@ -1 +1,1101 @@
-{$optimize 15}
{---------------------------------------------------------------}
{								}
{  Scanner							}
{								}
{---------------------------------------------------------------}

unit Scanner;

{$segment 'Pascal2'}

interface

{$libprefix '0/obj/'}

uses PCommon, CGI;

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

var
					{misc}
                                        {----}
   debugType: (stop,breakPoint,autoGo);	{kind of debugging for this line}
   doingInterface: boolean;		{compiling an interface?}
   partiallist: partialptr;		{list of partial compile names}
   partial: boolean;			{is this a partial compile?}

					{returned by InSymbol}
					{--------------------}
   sy: symbol;				{last symbol}
   op: operator;			{classification of last symbol}
   val: valu;				{value of last constant}
   lgth: integer; 			{length of last string constant}
   id: pString;				{last identifier}
   ch: char;				{last character}
   eofl: boolean; 			{end of file flag}

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

procedure InSymbol; extern;

{ read the next token from the source stream			}


procedure Match (sym: symbol; ern: integer); extern;

{ insure that the next symbol is the one requested		}
{								}
{ parameters:							}
{    sym - symbol expected					}
{    ern - error number; used if the symbol is not correct	}


procedure OpenUses;

{ copies the contents of a uses file				}


procedure Scanner_Init; extern;

{ initialize the scanner					}


procedure Scanner_Fini;

{ shut down the scanner						}


procedure Skip (fsys: setofsys);

{ skip input string until relavent symbol found			}
{								}
{ parameters:							}
{    fsys - symbol kind to skip to				}

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

implementation

type
   copyFilePtr = ^copyFileRecord;	{copied file chain}
   copyFileRecord = record
      fnext: copyFilePtr;		{next copied file record}
      fname: gsosOutString;		{file name}
      fpos: longint;			{disp in file}
      fuses: boolean;			{doing uses?}
      flineCount: integer;		{line count}
      end;

var
					{misc}
                                        {----}
   didKeep: boolean;			{have we found a $keep directive?}
   doingOption: boolean;		{compiling an option?}
   eofDisable: boolean;			{disable end of file error check?}
   eol: boolean;			{end of line flag}
   fHeadGS: copyFilePtr;		{copied file chain}
   langNum: integer;			{language number}
   listFixed: boolean;			{was the list option specified on the cl?}
   lString: pString;			{last string}
   usesLength: longint;			{# bytes in current uses buffer}
   usesPtr: ptr;			{ptr to next byte in uses buffer}
   
{- Private subroutines -----------------------------------------}

procedure EndOfLine; extern;

{ Read in the next source line					}


procedure FakeInsymbol; extern;

{ install the uses file InSymbol patch				}


procedure GetPartialNames;

{ Form a linked list of partial compile names			}


   function GetName: boolean;

   { Read a name from subsGS					}
   {								}
   { Returns: false if there are no more names, else true	}

   var
      i: unsigned;			{loop/index variable}
      pn: partialptr;			{new partial compile entry}
      pname: pStringPtr;		{work string}


      function GetCh: char;

      { Get a character						}
      {								}
      { returns: next character from subsGS			}

      var
         ch: char;			{work character}

      begin {GetCh}
      if subsGS.theString.size = 0 then
         GetCh := chr(0)
      else begin
         ch := subsGS.theString.theString[1];
         if ch in ['a'..'z'] then
            ch := chr(ord(ch)-ord('a')+ord('A'));
         GetCh := ch;
         end; {else}
      end; {GetCh}


      procedure NextCh;

      { Remove the next character from subsGS			}

      var
         i: unsigned;			{loop/index variable}

      begin {NextCh}
      with subsGS.theString do
         if size <> 0 then begin
            for i := 2 to size do
               theString[i-1] := theString[i];
            size := size-1;
            end; {with}
      end; {NextCh}


   begin {GetName}
   while GetCh = ' ' do
      NextCh;
   if subsGS.theString.size = 0 then
      GetName := false
   else begin
      GetName := true;
      i := 0;
      new(pn);
      new(pname);
      pn^.pname := pname;
      while not (GetCh in [' ', chr(0)]) do begin
         i := i+1;
         pname^[i] := GetCh;
         NextCh;
         end; {while}
      pname^[0] := chr(i);
      pn^.next := partialList;
      partialList := pn;
      end; {else}
   end; {GetName}


begin {GetPartialNames}
partialList := nil;		{assume no list}
partial := false;
if subsGS.theString.size <> 0 then begin
   repeat until not GetName;
   partial := true;
   end; {if}
end; {GetPartialNames}


procedure InitFile;

{ get the command line and GetLInfo information			}

const
                                        {bit masks for GetLInfo flags}
                                        {----------------------------}
   flag_d       = $10000000;            {generate debug code?}
   flag_e       = $08000000;            {abort to editor on terminal error?}
   flag_l       = $00100000;            {list source lines?}
   flag_m       = $00080000;            {memory based compile?}
   flag_o       = $00020000;            {optimize?}
   flag_p       = $00010000;            {print progress info?}
   flag_s       = $00002000;            {list symbol tables?}
   flag_t       = $00001000;            {treat all errors as terminal?}
   flag_w       = $00000200;            {wait when an error is found?}

var
   i: unsigned;				{loop/index variable}

begin {InitFile}
fNameGS.maxSize := maxPath+4;
fNameGS.theString.size := 0;
for i := 1 to maxPath do
   fNameGS.theString.theString[i] := chr(0);
kNameGS := fNameGS;
subsGS := fNameGS;
ldInfoGS := fNameGS;
with liDCBGS do begin
   pCount := 11;
   sFile := @fNameGS;
   dFile := @kNameGS;
   namesList := @subsGS;
   iString := @ldInfoGS;
   end; {with}
GetLInfoGS(liDCBGS);
with liDCBGS do begin
   if pFlags & flag_l <> 0 then begin	{set up source listing flags}
      list := true;
      listFixed := true;
      end
   else if mFlags & flag_l <> 0 then
      listFixed := true
   else
      listFixed := false;
   wait := pFlags & flag_w <> 0;          {wait when an error is found?}
   allTerm := pFlags & flag_t <> 0;	  {all errors terminal?}
   gotoEditor := pFlags & flag_e <> 0;    {enter editor on terminal errors?}
   debugFlag := pFlags & flag_d <> 0;     {generate debug code?}
   profileFlag := debugFlag;		  {generate profile code?}
   memoryFlag := pflags & flag_m <> 0;    {memory based compile?}
   progress := mflags & flag_p = 0;       {write progress info?}
   printSymbols := pflags & flag_s <> 0;  {print the symbol table?}
   cLineOptimize := pFlags & flag_o <> 0; {turn optimizations on?}
   end; {liDCB}
if list then                              {we don't need both...}
   progress := false;
keepFlag := liDCBGS.kFlag;		{set up the code generator}
codeGeneration := keepFlag <> 0;
end; {InitFile}


procedure ListLine; extern;

{ List the current line and any errors found			}


procedure NextCh; extern;

{ Fetch the next source character				}


procedure OpenGS;

{ Open a source file						}

var
   ffDCBGS: fastFileDCBGS;		{for FastFile load}
   erRec: errorDCBGS;			{for reporting shell error}

begin {OpenGS}    
with ffDCBGS do begin			{read the source file}
   pCount := 14;
   action := 0;
   flags := $C000;
   pathName := @fNameGS.theString;
   end; {with}
FastFileGS(ffDCBGS);
if ToolError <> 0 then begin
   erRec.pcount := 1;
   erRec.error := ToolError;
   ErrorGS(erRec);
   TermError(4, nil);
   end; {if}
if langNum <> 0 then begin		{check the language number}
   if ffDCBGS.auxType <> langNum then
      TermError(2, nil);
   end {if}
else
   langNum := long(ffDCBGS.auxType).lsw;
filePtr := ffDCBGS.fileHandle^;		{set beginning of file pointer}
chEndPtr := pointer(ord4(filePtr)+ffDCBGS.fileLength);;
chPtr := pointer(ord4(chEndPtr)-1);	{make sure the file ends with a CR}
if chPtr^ <> 13 then
   TermError(11, nil);
chPtr := filePtr;			{set the character pointer}
end; {OpenGS}


procedure OpenUses;

{ Open a file for the uses statement				}

var
   exRec: ExpandDevicesDCBGS;		{ExpandDevices record}
   ffRec: FastFileDCBGS;		{FastFile record}
   i: unsigned;				{loop/index variable}
   lNameGS: gsosOutString;		{work string for forming path name}
   separator: char;			{separator character}

begin {OpenUses}
if intPrefixGS.theString.size = 0 then begin
   lNameGS.theString.theString := concat('13:ORCAPascalDefs:', id, '.int');
   lNameGS.theString.size := length(lNameGS.theString.theString);
   if GetFileType(lNameGS) = -1 then 
      lNameGS.theString.theString := concat('8:', id, '.int');
   end {if}
else begin
   i := 0;
   separator := ' ';
   while (i < intPrefixGS.theString.size) and (separator = ' ') do begin
      if intPrefixGS.theString.theString[i] in [':', '/'] then
         separator := intPrefixGS.theString.theString[i];
      i := i+1;
      end; {while}
   if separator = ' ' then
      separator := ':';
   lNameGS.theString := intPrefixGS.theString;
   if intPrefixGS.theString.size < maxPath then
      lNameGS.theString.theString[intPrefixGS.theString.size] := chr(0);
   if intPrefixGS.theString.theString[intPrefixGS.theString.size-1] <> separator
      then
      lNameGS.theString.theString :=
         concat(lNameGS.theString.theString, separator);
   lNameGS.theString.theString := concat(lNameGS.theString.theString, id);
   lNameGS.theString.theString := concat(lNameGS.theString.theString, '.int');
   end; {else}
lNameGS.theString.size := length(lNameGS.theString.theString);
exRec.pcount := 2;			{expand devices}
exRec.inName := @lNameGS.theString;
exRec.outName := @usesFileNameGS;
usesFileNameGS.maxSize := maxPath+4;
ExpandDevicesGS(exRec);
if ToolError <> 0 then
   usesFileNameGS := lNameGS;
ffRec.pcount := 14;			{read the file}
ffRec.action := 0;
ffRec.flags := $C000;
ffRec.pathName := @usesFileNameGS.theString;
FastFileGS(ffRec);
if ToolError <> 0 then
   TermError(6, nil);
usesPtr := ffRec.fileHandle^;		{save the file pointer}
usesLength := ffRec.fileLength;		{save the file length}
if ffRec.fileType = DVU then begin	{skip the version number}
   usesPtr := pointer(ord4(usesPtr)+1);
   usesLength := usesLength-1;
   end; {if}
FakeInsymbol;				{set up the InSymbol patch}
end; {OpenUses}


procedure SkipComment;

{ Skip to the end of a comment					}

begin {SkipComment}
repeat
   while not ((ch = '*') or (ch = '}')) and not eofl do
      NextCh;
   if ch = '*' then
      NextCh;
until (ch = ')') or (ch = '}') or eofl;
NextCh;
end; {SkipComment}


function Options: boolean;

{ Compile compiler directives					}
{								}
{ Returns: True if the parser should continue to scan for an	}
{    end of comment, else false					}

const
   nameLen = 12;			{max length of a directive name}

var
   dName: string[nameLen];		{directive name}


   function IsAlpha (ch: char): boolean;

   { See if a character is alphabetic				}
   {								}
   { parameters:						}
   {    ch - character to check					}
   {								}
   { Returns: True for an alphabetic character, else false	}

   begin {IsAlpha}
   IsAlpha := ch in ['a'..'z', 'A'..'Z'];
   end; {IsAlpha}


   procedure SkipBlanks;

   { skip to the next non-blank character			}

   const
      tab = 9;				{tab key code}

   begin {SkipBlanks}
   while (ch in [' ', chr(tab), chr($CA)]) and (not eofl) do
      NextCh;
   end; {SkipBlanks}


   function ToUpper (ch: char): char;

   { Return an uppercase character				}
   {								}
   { parameters:						}
   {    ch - character to check					}
   {								}
   { Returns: Uppercase equivalent of ch			}

   begin {ToUpper}
   if ch in ['a'..'z'] then
      ch := chr(ord(ch)-ord('a')+ord('A'));
   ToUpper := ch;
   end; {ToUpper}


   procedure Expand (var name: pString);

   { Expands a name to a full pathname				}
   {								}
   { parameters:						}
   {    name - file name to expand				}

   var
      exRec: expandDevicesDCBGS;	{expand devices}

   begin {Expand}
   exRec.pcount := 2;
   new(exRec.inName);
   exRec.inName^.theString := name;
   exRec.inName^.size := length(name);
   new(exRec.outName);
   exRec.outName^.maxSize := maxPath+4;
   ExpandDevicesGS(exRec);
   if toolerror = 0 then
      with exRec.outName^.theString do begin
         if size < maxPath then
            theString[size+1] := chr(0);
         name := theString;
         end; {with}
   dispose(exRec.inName);
   dispose(exRec.outName);
   end; {Expand}


   function GetIdent: pStringPtr;

   { Read an identifier						}
   {								}
   { Returns: pointer to the identifier, or nil			}

   var
      disp: integer;			{characters in the string}
      sPtr: pStringPtr;			{dynamic string pointer}
      str: pString;			{work buffer}

   begin {GetIdent}
   SkipBlanks;
   sPtr := nil;
   disp := 0;
   if IsAlpha(ch) then begin
      while ch in ['a'..'z', 'A'..'Z', '0'..'9', '_'] do begin
         if disp < maxLine then
            disp := disp+1;
	 str[disp] := ch;
	 NextCh;
	 end; {while}
      str[0] := chr(disp);
      sPtr := pStringPtr(Malloc(length(str)+1));
      sPtr^ := str;
      end; {if}
   GetIdent := sPtr;
   end; {GetIdent}


   function GetInteger: integer;

   { Read an (possibly signed) integer value			}
   {								}
   { Returns: Value read					}

   var
      sign: boolean;			{is the value negative?}
      temp: integer;			{temp val.ival}

   begin {GetInteger}
   temp := val.ival;
   SkipBlanks;
   sign := false;
   if ch = '-' then begin
      NextCh;
      sign := true;
      end; {if}
   InSymbol;
   if sy = longintconst then
   if val.valp^.lval >> 16 = 0 then begin
      val.ival := ord(val.valp^.lval);
      sy := intconst;
      end; {if}
   if sy <> intconst then
      Error(15);
   if sign then
      val.ival := -val.ival;
   GetInteger := val.ival;
   val.ival := temp;
   end; {GetInteger}


   function GetString: boolean;

   { read a string						}
   {								}
   { Returns: True if a string was found, else false		}
   {								}
   { Notes:							}
   {    1. If a string is found, it is placed in lString	}
   {    2. If a string is not found, no error is reported	}

   begin {GetString}
   SkipBlanks;
   GetString := ch = '''';
   if ch = '''' then
      InSymbol
   else
      Error(6);
   end; {GetString}


   function SetOption: boolean;

   { Check for a +/- options flag				}
   {								}
   { Returns: True for +, false for -				}

   begin {SetOption}
   SetOption := true;
   if ch in ['+','-'] then begin
      SetOption := ch = '+';
      NextCh;
      end {if}
   else
      Error(6);
   end; {SetOption}  


   procedure DoAppend;

   { Append							}

   var
      ffRec: FastFileDCBGS;		{FastFile record}

   begin {DoAppend}
   if GetString then begin		{get the source name}
      EndOfLine;			{read the next source line}
      PurgeSource;			{purge the current source file}
      eol := false;			{don't reprint the line}
      Expand(lString);			{set the new path name}
      fNameGS.theString.theString := lString;
      fNameGS.theString.size := length(lString);
      if not eofDisable then begin
	 OpenGS;			{open the file}
	 lineCount := 1;
         end; {if}
      end {if}
   else begin
      eofl := true;
      Error(37);
      end; {else}
   Options := false;			{we won't scan for end of comment}
   doingOption := false;
   end; {DoAppend}


   procedure DoCDev;

   { CDev							}

   begin {DoCDev}
   if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
      or isNBA then
      Error(100);
   isCDev := true;
   openName := GetIdent;
   end; {DoCDev}


   procedure DoClassicDesk;

   { ClassicDesk						}

   begin {DoClassicDesk}
   if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
      or isNBA then
      Error(100);
   isClassicDeskAcc := true;
   if GetString then
      menuLine := lString
   else
      Error(131);
   openName := GetIdent;
   closeName := GetIdent;
   end; {DoClassicDesk}


   procedure DoCopy;

   { Copy							}

   var
      ffRec: FastFileDCBGS;		{FastFile record}
      fRec: copyFilePtr;		{copy file record}

   begin {DoCopy}
   new(fRec);				{create a copy record}
   fRec^.fnext := fHeadGS;
   fHeadGS := fRec;
   fRec^.fName := fNameGS;		{fill in the current file name}
   if GetString then begin		{get the source name}
      SkipComment;			{skip to the end of the directive}
					{save the file position}
      fRec^.fpos := ord4(chPtr) + chCnt - ord4(filePtr);
      fRec^.fuses := false;		{not doing a uses}
      fRec^.flineCount := lineCount+1;	{save the new line count}
      EndOfLine;			{read the next source line}
      PurgeSource;			{purge the current source file}
      eol := false;			{don't reprint the line}
      Expand(lString);			{set the new path name}
      fNameGS.theString.theString := lString;
      fNameGS.theString.size := length(lString);
      OpenGS;				{open the file}
      lineCount := 1;
      end {if}
   else begin
      eofl := true;
      Error(37);
      end; {else}
   Options := false;			{we won't scan for end of comment}
   doingOption := false;
   end; {DoCopy}                                       


   procedure DoDataBank;

   { DataBank							}

   begin {DoDataBank}
   dataBank := SetOption;
   end; {DoDataBank}


   procedure DoDebug;

   { Debug							}

   var
      val: unsigned;			{debug flag word}

   begin {DoDebug}
   val := GetInteger;
   debugFlag := odd(val);
   profileFlag := (val & $0002) <> 0;
   end; {DoDebug}


   procedure DoEject;

   { Eject							}

   begin {DoEject}
   if printer then
      if list then begin
         write(chr(12));
         lCnt := 0;
         if length(title) <> 0 then begin
            write(title);
            LineFeed;
            LineFeed;
            end; {if}
         end; {if}
   end; {DoEject}


   procedure DoFloat;

   { Float							}

   begin {DoFloat}
   floatCard := GetInteger;
   end; {DoFloat}


   procedure DoISO;

   { ISO							}

   begin {DoISO}
   iso := SetOption;
   if iso then
      debug := true;
   end; {DoISO}


   procedure DoKeep;

   { Keep							}

   begin {DoKeep}
   if progFound or didKeep then
      Error(100)
   else if GetString then begin
      codeGeneration := true;
      Expand(lString);
      kNameGS.theString.theString := lString;
      kNameGS.theString.size := length(lString);
      keepFlag := 1;
      didKeep := true;
      end; {else if}
   end; {DoKeep}


   procedure DoLibPrefix;

   { LibPrefix							}

   var
      i: unsigned;			{loop/index variable}
      len: unsigned;			{length(lString)}
      separator: char;			{path separaotr character}

   begin {DoLibPrefix}
   if GetString then begin
      len := length(lString);
      if len = 0 then
         intPrefixGS.theString.size := 0
      else begin
	 separator := ' ';
	 i := 1;
	 while i < len do
            if lString[i] in [':','/'] then begin
               separator := lString[i];
               i := maxint;
               end {if}
            else
               i := i+1;
	 if separator = ' ' then
            separator := ':';
	 if lString[len] <> separator then
            lString := concat(lString, separator);
	 intPrefixGS.theString.theString := lString;
	 intPrefixGS.theString.size := length(lString);
         end; {else}
      end {if}
   else
      Error(37);
   end; {DoLibPrefix}


   procedure DoList;

   { List							}

   var
      llist: boolean;			{local list}

   begin {DoList}
   llist := SetOption;
   if not listFixed then
      list := llist;
   end; {DoList}


   procedure DoMemoryModel;

   { MemoryModel						}

   begin {DoMemoryModel}
   if progFound then
      Error(100);
   smallMemoryModel := GetInteger = 0;
   end; {DoMemoryModel}


   procedure DoNames;

   { Names							}

   begin {DoNames}
   traceBack := SetOption;
   end; {DoNames}


   procedure DoNBA;

   { NBA							}

   begin {DoNBA}
   if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
      or isNBA then
      Error(100);
   isNBA := true;
   openName := GetIdent;
   end; {DoNBA}


   procedure DoNewDeskAcc;

   { NewDeskAcc							}

   begin {DoNewDeskAcc}
   if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
      or isNBA then
      Error(100);
   isNewDeskAcc := true;
   openName := GetIdent;
   closeName := GetIdent;
   actionName := GetIdent;
   initName := GetIdent;
   refreshPeriod := GetInteger;
   eventMask := GetInteger;
   if GetString then
      menuLine := lString
   else
      Error(131);
   end; {DoNewDeskAcc}


   procedure DoOptimize;

   { Optimize							}

   var
      val: unsigned;			{optimize flag word}

   begin {DoOptimize}
   val := GetInteger;
   peepHole := odd(val);
   nPeepHole := (val & $0002) <> 0;
   registers := (val & $0004) <> 0;
   commonSubexpression := (val & $0008) <> 0;
   loopOptimizations := (val & $0010) <> 0;
   jslOptimizations := (val & $0020) <> 0;
   end; {DoOptimize}


   procedure DoRangeCheck;

   { RangeCheck							}

   begin {DoRangeCheck}
   debug := SetOption;
   rangeCheck := debug;
   end; {DoRangeCheck}


   procedure DoRTL;

   { RTL							}

   begin {DoRTL}
   if isNewDeskAcc or isClassicDeskAcc or isCDev or rtl then
      Error(100);
   rtl := true;
   end; {DoRTL}


   procedure DoSegment;

   { Segment							}

   var
      i: unsigned;			{loop/index variable}
      seg: segNameType;			{segment name}

   begin {DoSegment}
   if GetString then begin
      seg := lString;
      for i := length(seg)+1 to 10 do
         seg[i] := ' ';
      DefaultSegName(seg);
      isDynamic := false;
      end {if}
   else
      Error(6);
   end; {DoSegment}


   procedure DoDynamic;

   { Dynamic							}

   begin {DoDynamic}
   DoSegment;
   isDynamic := true;
   end; {DoDynamic}


   procedure DoStackSize;

   { StackSize							}

   begin {DoStackSize}
   if progFound then
      Error(100);
   stackSize := GetInteger;
   end; {DoStackSize}


   procedure DoToolParms;

   { ToolParms							}

   begin {DoToolParms}
   toolParms := SetOption;
   end; {DoToolParms}


   procedure DoTitle;

   { Title							}

   begin {DoTitle}
   if GetString then
      title := lString
   else
      title := '';
   end; {DoTitle}


   procedure DoXCMD;

   { XCMD							}

   begin {DoXCMD}
   if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
      or isNBA then
      Error(100);
   isXCMD := true;
   openName := GetIdent;
   end; {DoXCMD}


begin {Options} 
Options := true;			{assume we will scan for end of comment}
doingOption := true;			{processing an option}
repeat
   NextCh;
   if (ch <> '*') and (ch <> '}') then begin
      dName[0] := chr(0);		{get a directive name}
      SkipBlanks;
      while IsAlpha(ch) and (ord(dName[0]) < nameLen) do begin
         dName[0] := succ(dName[0]);
         dName[ord(dName[0])] := ToUpper(ch);
         NextCh;
         end; {while}
					{call the correct handler}
      if dName = 'MEMORYMODEL' then DoMemoryModel
      else if dName = 'APPEND' then DoAppend
      else if dName = 'COPY' then DoCopy
      else if dName = 'DEBUG' then DoDebug
      else if dName = 'EJECT' then DoEject
      else if dName = 'FLOAT' then DoFloat
      else if dName = 'ISO' then DoISO
      else if dName = 'KEEP' then DoKeep
      else if dName = 'LIST' then DoList
      else if dName = 'NAMES' then DoNames
      else if dName = 'RANGECHECK' then DoRangeCheck
      else if dName = 'STACKSIZE' then DoStackSize
      else if dName = 'TITLE' then DoTitle
      else if dName = 'RTL' then DoRTL
      else if dName = 'NEWDESKACC' then DoNewDeskAcc
      else if dName = 'OPTIMIZE' then DoOptimize
      else if dName = 'SEGMENT' then DoSegment
      else if dName = 'DYNAMIC' then DoDynamic
      else if dName = 'TOOLPARMS' then DoToolParms
      else if dName = 'DATABANK' then DoDataBank
      else if dName = 'LIBPREFIX' then DoLibPrefix
      else if dName = 'CLASSICDESK' then DoClassicDesk
      else if dName = 'CDEV' then DoCDev
      else if dName = 'XCMD' then DoXCMD
      else if dName = 'NBA' then DoNBA
      else doingOption := false;  
      end {if}
   else
      doingOption := false;
   if doingOption then begin		{check for another one}
      SkipBlanks;
      doingOption := ch = ',';
      end; {if}
until not doingOption;
end; {Options}

{- Public subroutines ------------------------------------------}

procedure Scanner_Fini;

{ Shut down the scanner						}

var
   i: unsigned;				{loop/index variable}
   tp: partialPtr;			{work pointer}

begin {Scanner_Fini}
PurgeSource;				{purge the last source file}
fNameGS.theString.size := 0;		{handle a trailing append}
eofDisable := true;
InSymbol;
if fNameGS.theString.size <> 0 then begin
   liDCBGS.sFile := @fNameGS;
   liDCBGS.namesList := @subsGS;
   subsGS.theString.size := 0;
   while partialList <> nil do begin
      tp := partialList;
      partialList := tp^.next;
      for i := 1 to length(tp^.pname^) do begin
         subsGS.theString.size := subsGS.theString.size+1;
         subsGS.theString.theString[subsGS.theString.size] := tp^.pname^[i];
         end; {for}
      dispose(tp);
      if partialList <> nil then begin
         subsGS.theString.size := subsGS.theString.size+1;
         subsGS.theString.theString[subsGS.theString.size] := ' ';
         end; {if}
      end; {while}
   if keepFlag <> 0 then
      liDCBGS.kFlag := 3;
   end {if}
else begin				{no append; the compile is over}
   liDCBGS.lOps := liDCBGS.lOps & $FFFE;
   if keepFlag <> 0 then
      liDCBGS.kFlag := 3
   else
      liDCBGS.lOps := 0;
   liDCBGS.sFile := @kNameGS;
   end; {else}
with liDCBGS do begin			{pass info back to the shell}
   sFile := pointer(ord4(sFile)+2);
   dFile := pointer(ord4(dFile)+2);
   namesList := pointer(ord4(namesList)+2);
   iString := pointer(ord4(iString)+2);
   end; {with}
SetLInfoGS(liDCBGS);
StopSpin;				{stop the spinner}
ListLine;				{finish the listing}
if list or progress then begin
   LineFeed;
   writeln(errorOutput, numErr:1, ' errors found');
   end; {if}
end; {Scanner_Fini}


procedure Skip {fsys: setofsys};

{ skip input string until relavent symbol found			}
{								}
{ parameters:							}
{    fsys - symbol kind to skip to				}

begin {Skip}
if not eofl then begin
   while not (sy in fsys) and (not eofl) do
      InSymbol;
   if not (sy in fsys) then
      InSymbol;
   end; {if}
end; {Skip}

end.

{$append 'scanner.asm'}
\ No newline at end of file
+{$optimize 15}
+{---------------------------------------------------------------}
+{								}
+{  Scanner							}
+{								}
+{---------------------------------------------------------------}
+
+unit Scanner;
+
+{$segment 'Pascal2'}
+
+interface
+
+{$libprefix '0/obj/'}
+
+uses PCommon, CGI;
+
+{---------------------------------------------------------------}
+
+var
+					{misc}
+                                        {----}
+   debugType: (stop,breakPoint,autoGo);	{kind of debugging for this line}
+   doingInterface: boolean;		{compiling an interface?}
+   partiallist: partialptr;		{list of partial compile names}
+   partial: boolean;			{is this a partial compile?}
+
+					{returned by InSymbol}
+					{--------------------}
+   sy: symbol;				{last symbol}
+   op: operator;			{classification of last symbol}
+   val: valu;				{value of last constant}
+   lgth: integer; 			{length of last string constant}
+   id: pString;				{last identifier}
+   ch: char;				{last character}
+   eofl: boolean; 			{end of file flag}
+
+{---------------------------------------------------------------}
+
+procedure InSymbol; extern;
+
+{ read the next token from the source stream			}
+
+
+procedure Match (sym: symbol; ern: integer); extern;
+
+{ insure that the next symbol is the one requested		}
+{								}
+{ parameters:							}
+{    sym - symbol expected					}
+{    ern - error number; used if the symbol is not correct	}
+
+
+procedure OpenUses;
+
+{ copies the contents of a uses file				}
+
+
+procedure Scanner_Init; extern;
+
+{ initialize the scanner					}
+
+
+procedure Scanner_Fini;
+
+{ shut down the scanner						}
+
+
+procedure Skip (fsys: setofsys);
+
+{ skip input string until relavent symbol found			}
+{								}
+{ parameters:							}
+{    fsys - symbol kind to skip to				}
+
+{---------------------------------------------------------------}
+
+implementation
+
+type
+   copyFilePtr = ^copyFileRecord;	{copied file chain}
+   copyFileRecord = record
+      fnext: copyFilePtr;		{next copied file record}
+      fname: gsosOutString;		{file name}
+      fpos: longint;			{disp in file}
+      fuses: boolean;			{doing uses?}
+      flineCount: integer;		{line count}
+      end;
+
+var
+					{misc}
+                                        {----}
+   didKeep: boolean;			{have we found a $keep directive?}
+   doingOption: boolean;		{compiling an option?}
+   eofDisable: boolean;			{disable end of file error check?}
+   eol: boolean;			{end of line flag}
+   fHeadGS: copyFilePtr;		{copied file chain}
+   langNum: integer;			{language number}
+   listFixed: boolean;			{was the list option specified on the cl?}
+   lString: pString;			{last string}
+   usesLength: longint;			{# bytes in current uses buffer}
+   usesPtr: ptr;			{ptr to next byte in uses buffer}
+   
+{- Private subroutines -----------------------------------------}
+
+procedure EndOfLine; extern;
+
+{ Read in the next source line					}
+
+
+procedure FakeInsymbol; extern;
+
+{ install the uses file InSymbol patch				}
+
+
+procedure GetPartialNames;
+
+{ Form a linked list of partial compile names			}
+
+
+   function GetName: boolean;
+
+   { Read a name from subsGS					}
+   {								}
+   { Returns: false if there are no more names, else true	}
+
+   var
+      i: unsigned;			{loop/index variable}
+      pn: partialptr;			{new partial compile entry}
+      pname: pStringPtr;		{work string}
+
+
+      function GetCh: char;
+
+      { Get a character						}
+      {								}
+      { returns: next character from subsGS			}
+
+      var
+         ch: char;			{work character}
+
+      begin {GetCh}
+      if subsGS.theString.size = 0 then
+         GetCh := chr(0)
+      else begin
+         ch := subsGS.theString.theString[1];
+         if ch in ['a'..'z'] then
+            ch := chr(ord(ch)-ord('a')+ord('A'));
+         GetCh := ch;
+         end; {else}
+      end; {GetCh}
+
+
+      procedure NextCh;
+
+      { Remove the next character from subsGS			}
+
+      var
+         i: unsigned;			{loop/index variable}
+
+      begin {NextCh}
+      with subsGS.theString do
+         if size <> 0 then begin
+            for i := 2 to size do
+               theString[i-1] := theString[i];
+            size := size-1;
+            end; {with}
+      end; {NextCh}
+
+
+   begin {GetName}
+   while GetCh = ' ' do
+      NextCh;
+   if subsGS.theString.size = 0 then
+      GetName := false
+   else begin
+      GetName := true;
+      i := 0;
+      new(pn);
+      new(pname);
+      pn^.pname := pname;
+      while not (GetCh in [' ', chr(0)]) do begin
+         i := i+1;
+         pname^[i] := GetCh;
+         NextCh;
+         end; {while}
+      pname^[0] := chr(i);
+      pn^.next := partialList;
+      partialList := pn;
+      end; {else}
+   end; {GetName}
+
+
+begin {GetPartialNames}
+partialList := nil;		{assume no list}
+partial := false;
+if subsGS.theString.size <> 0 then begin
+   repeat until not GetName;
+   partial := true;
+   end; {if}
+end; {GetPartialNames}
+
+
+procedure InitFile;
+
+{ get the command line and GetLInfo information			}
+
+const
+                                        {bit masks for GetLInfo flags}
+                                        {----------------------------}
+   flag_d       = $10000000;            {generate debug code?}
+   flag_e       = $08000000;            {abort to editor on terminal error?}
+   flag_l       = $00100000;            {list source lines?}
+   flag_m       = $00080000;            {memory based compile?}
+   flag_o       = $00020000;            {optimize?}
+   flag_p       = $00010000;            {print progress info?}
+   flag_s       = $00002000;            {list symbol tables?}
+   flag_t       = $00001000;            {treat all errors as terminal?}
+   flag_w       = $00000200;            {wait when an error is found?}
+
+var
+   i: unsigned;				{loop/index variable}
+
+begin {InitFile}
+fNameGS.maxSize := maxPath+4;
+fNameGS.theString.size := 0;
+for i := 1 to maxPath do
+   fNameGS.theString.theString[i] := chr(0);
+kNameGS := fNameGS;
+subsGS := fNameGS;
+ldInfoGS := fNameGS;
+with liDCBGS do begin
+   pCount := 11;
+   sFile := @fNameGS;
+   dFile := @kNameGS;
+   namesList := @subsGS;
+   iString := @ldInfoGS;
+   end; {with}
+GetLInfoGS(liDCBGS);
+with liDCBGS do begin
+   if pFlags & flag_l <> 0 then begin	{set up source listing flags}
+      list := true;
+      listFixed := true;
+      end
+   else if mFlags & flag_l <> 0 then
+      listFixed := true
+   else
+      listFixed := false;
+   wait := pFlags & flag_w <> 0;          {wait when an error is found?}
+   allTerm := pFlags & flag_t <> 0;	  {all errors terminal?}
+   gotoEditor := pFlags & flag_e <> 0;    {enter editor on terminal errors?}
+   debugFlag := pFlags & flag_d <> 0;     {generate debug code?}
+   profileFlag := debugFlag;		  {generate profile code?}
+   memoryFlag := pflags & flag_m <> 0;    {memory based compile?}
+   progress := mflags & flag_p = 0;       {write progress info?}
+   printSymbols := pflags & flag_s <> 0;  {print the symbol table?}
+   cLineOptimize := pFlags & flag_o <> 0; {turn optimizations on?}
+   end; {liDCB}
+if list then                              {we don't need both...}
+   progress := false;
+keepFlag := liDCBGS.kFlag;		{set up the code generator}
+codeGeneration := keepFlag <> 0;
+end; {InitFile}
+
+
+procedure ListLine; extern;
+
+{ List the current line and any errors found			}
+
+
+procedure NextCh; extern;
+
+{ Fetch the next source character				}
+
+
+procedure OpenGS;
+
+{ Open a source file						}
+
+var
+   ffDCBGS: fastFileDCBGS;		{for FastFile load}
+   erRec: errorDCBGS;			{for reporting shell error}
+
+begin {OpenGS}    
+with ffDCBGS do begin			{read the source file}
+   pCount := 14;
+   action := 0;
+   flags := $C000;
+   pathName := @fNameGS.theString;
+   end; {with}
+FastFileGS(ffDCBGS);
+if ToolError <> 0 then begin
+   erRec.pcount := 1;
+   erRec.error := ToolError;
+   ErrorGS(erRec);
+   TermError(4, nil);
+   end; {if}
+if langNum <> 0 then begin		{check the language number}
+   if ffDCBGS.auxType <> langNum then
+      TermError(2, nil);
+   end {if}
+else
+   langNum := long(ffDCBGS.auxType).lsw;
+filePtr := ffDCBGS.fileHandle^;		{set beginning of file pointer}
+chEndPtr := pointer(ord4(filePtr)+ffDCBGS.fileLength);;
+chPtr := pointer(ord4(chEndPtr)-1);	{make sure the file ends with a CR}
+if chPtr^ <> 13 then
+   TermError(11, nil);
+chPtr := filePtr;			{set the character pointer}
+end; {OpenGS}
+
+
+procedure OpenUses;
+
+{ Open a file for the uses statement				}
+
+var
+   exRec: ExpandDevicesDCBGS;		{ExpandDevices record}
+   ffRec: FastFileDCBGS;		{FastFile record}
+   i: unsigned;				{loop/index variable}
+   lNameGS: gsosOutString;		{work string for forming path name}
+   separator: char;			{separator character}
+
+begin {OpenUses}
+if intPrefixGS.theString.size = 0 then begin
+   lNameGS.theString.theString := concat('13:ORCAPascalDefs:', id, '.int');
+   lNameGS.theString.size := length(lNameGS.theString.theString);
+   if GetFileType(lNameGS) = -1 then 
+      lNameGS.theString.theString := concat('8:', id, '.int');
+   end {if}
+else begin
+   i := 0;
+   separator := ' ';
+   while (i < intPrefixGS.theString.size) and (separator = ' ') do begin
+      if intPrefixGS.theString.theString[i] in [':', '/'] then
+         separator := intPrefixGS.theString.theString[i];
+      i := i+1;
+      end; {while}
+   if separator = ' ' then
+      separator := ':';
+   lNameGS.theString := intPrefixGS.theString;
+   if intPrefixGS.theString.size < maxPath then
+      lNameGS.theString.theString[intPrefixGS.theString.size] := chr(0);
+   if intPrefixGS.theString.theString[intPrefixGS.theString.size-1] <> separator
+      then
+      lNameGS.theString.theString :=
+         concat(lNameGS.theString.theString, separator);
+   lNameGS.theString.theString := concat(lNameGS.theString.theString, id);
+   lNameGS.theString.theString := concat(lNameGS.theString.theString, '.int');
+   end; {else}
+lNameGS.theString.size := length(lNameGS.theString.theString);
+exRec.pcount := 2;			{expand devices}
+exRec.inName := @lNameGS.theString;
+exRec.outName := @usesFileNameGS;
+usesFileNameGS.maxSize := maxPath+4;
+ExpandDevicesGS(exRec);
+if ToolError <> 0 then
+   usesFileNameGS := lNameGS;
+ffRec.pcount := 14;			{read the file}
+ffRec.action := 0;
+ffRec.flags := $C000;
+ffRec.pathName := @usesFileNameGS.theString;
+FastFileGS(ffRec);
+if ToolError <> 0 then
+   TermError(6, nil);
+usesPtr := ffRec.fileHandle^;		{save the file pointer}
+usesLength := ffRec.fileLength;		{save the file length}
+if ffRec.fileType = DVU then begin	{skip the version number}
+   usesPtr := pointer(ord4(usesPtr)+1);
+   usesLength := usesLength-1;
+   end; {if}
+FakeInsymbol;				{set up the InSymbol patch}
+end; {OpenUses}
+
+
+procedure SkipComment;
+
+{ Skip to the end of a comment					}
+
+begin {SkipComment}
+repeat
+   while not ((ch = '*') or (ch = '}')) and not eofl do
+      NextCh;
+   if ch = '*' then
+      NextCh;
+until (ch = ')') or (ch = '}') or eofl;
+NextCh;
+end; {SkipComment}
+
+
+function Options: boolean;
+
+{ Compile compiler directives					}
+{								}
+{ Returns: True if the parser should continue to scan for an	}
+{    end of comment, else false					}
+
+const
+   nameLen = 12;			{max length of a directive name}
+
+var
+   dName: string[nameLen];		{directive name}
+
+
+   function IsAlpha (ch: char): boolean;
+
+   { See if a character is alphabetic				}
+   {								}
+   { parameters:						}
+   {    ch - character to check					}
+   {								}
+   { Returns: True for an alphabetic character, else false	}
+
+   begin {IsAlpha}
+   IsAlpha := ch in ['a'..'z', 'A'..'Z'];
+   end; {IsAlpha}
+
+
+   procedure SkipBlanks;
+
+   { skip to the next non-blank character			}
+
+   const
+      tab = 9;				{tab key code}
+
+   begin {SkipBlanks}
+   while (ch in [' ', chr(tab), chr($CA)]) and (not eofl) do
+      NextCh;
+   end; {SkipBlanks}
+
+
+   function ToUpper (ch: char): char;
+
+   { Return an uppercase character				}
+   {								}
+   { parameters:						}
+   {    ch - character to check					}
+   {								}
+   { Returns: Uppercase equivalent of ch			}
+
+   begin {ToUpper}
+   if ch in ['a'..'z'] then
+      ch := chr(ord(ch)-ord('a')+ord('A'));
+   ToUpper := ch;
+   end; {ToUpper}
+
+
+   procedure Expand (var name: pString);
+
+   { Expands a name to a full pathname				}
+   {								}
+   { parameters:						}
+   {    name - file name to expand				}
+
+   var
+      exRec: expandDevicesDCBGS;	{expand devices}
+
+   begin {Expand}
+   exRec.pcount := 2;
+   new(exRec.inName);
+   exRec.inName^.theString := name;
+   exRec.inName^.size := length(name);
+   new(exRec.outName);
+   exRec.outName^.maxSize := maxPath+4;
+   ExpandDevicesGS(exRec);
+   if toolerror = 0 then
+      with exRec.outName^.theString do begin
+         if size < maxPath then
+            theString[size+1] := chr(0);
+         name := theString;
+         end; {with}
+   dispose(exRec.inName);
+   dispose(exRec.outName);
+   end; {Expand}
+
+
+   function GetIdent: pStringPtr;
+
+   { Read an identifier						}
+   {								}
+   { Returns: pointer to the identifier, or nil			}
+
+   var
+      disp: integer;			{characters in the string}
+      sPtr: pStringPtr;			{dynamic string pointer}
+      str: pString;			{work buffer}
+
+   begin {GetIdent}
+   SkipBlanks;
+   sPtr := nil;
+   disp := 0;
+   if IsAlpha(ch) then begin
+      while ch in ['a'..'z', 'A'..'Z', '0'..'9', '_'] do begin
+         if disp < maxLine then
+            disp := disp+1;
+	 str[disp] := ch;
+	 NextCh;
+	 end; {while}
+      str[0] := chr(disp);
+      sPtr := pStringPtr(Malloc(length(str)+1));
+      sPtr^ := str;
+      end; {if}
+   GetIdent := sPtr;
+   end; {GetIdent}
+
+
+   function GetInteger: integer;
+
+   { Read an (possibly signed) integer value			}
+   {								}
+   { Returns: Value read					}
+
+   var
+      sign: boolean;			{is the value negative?}
+      temp: integer;			{temp val.ival}
+
+   begin {GetInteger}
+   temp := val.ival;
+   SkipBlanks;
+   sign := false;
+   if ch = '-' then begin
+      NextCh;
+      sign := true;
+      end; {if}
+   InSymbol;
+   if sy = longintconst then
+   if val.valp^.lval >> 16 = 0 then begin
+      val.ival := ord(val.valp^.lval);
+      sy := intconst;
+      end; {if}
+   if sy <> intconst then
+      Error(15);
+   if sign then
+      val.ival := -val.ival;
+   GetInteger := val.ival;
+   val.ival := temp;
+   end; {GetInteger}
+
+
+   function GetString: boolean;
+
+   { read a string						}
+   {								}
+   { Returns: True if a string was found, else false		}
+   {								}
+   { Notes:							}
+   {    1. If a string is found, it is placed in lString	}
+   {    2. If a string is not found, no error is reported	}
+
+   begin {GetString}
+   SkipBlanks;
+   GetString := ch = '''';
+   if ch = '''' then
+      InSymbol
+   else
+      Error(6);
+   end; {GetString}
+
+
+   function SetOption: boolean;
+
+   { Check for a +/- options flag				}
+   {								}
+   { Returns: True for +, false for -				}
+
+   begin {SetOption}
+   SetOption := true;
+   if ch in ['+','-'] then begin
+      SetOption := ch = '+';
+      NextCh;
+      end {if}
+   else
+      Error(6);
+   end; {SetOption}  
+
+
+   procedure DoAppend;
+
+   { Append							}
+
+   var
+      ffRec: FastFileDCBGS;		{FastFile record}
+
+   begin {DoAppend}
+   if GetString then begin		{get the source name}
+      EndOfLine;			{read the next source line}
+      PurgeSource;			{purge the current source file}
+      eol := false;			{don't reprint the line}
+      Expand(lString);			{set the new path name}
+      fNameGS.theString.theString := lString;
+      fNameGS.theString.size := length(lString);
+      if not eofDisable then begin
+	 OpenGS;			{open the file}
+	 lineCount := 1;
+         end; {if}
+      end {if}
+   else begin
+      eofl := true;
+      Error(37);
+      end; {else}
+   Options := false;			{we won't scan for end of comment}
+   doingOption := false;
+   end; {DoAppend}
+
+
+   procedure DoCDev;
+
+   { CDev							}
+
+   begin {DoCDev}
+   if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
+      or isNBA then
+      Error(100);
+   isCDev := true;
+   openName := GetIdent;
+   end; {DoCDev}
+
+
+   procedure DoClassicDesk;
+
+   { ClassicDesk						}
+
+   begin {DoClassicDesk}
+   if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
+      or isNBA then
+      Error(100);
+   isClassicDeskAcc := true;
+   if GetString then
+      menuLine := lString
+   else
+      Error(131);
+   openName := GetIdent;
+   closeName := GetIdent;
+   end; {DoClassicDesk}
+
+
+   procedure DoCopy;
+
+   { Copy							}
+
+   var
+      ffRec: FastFileDCBGS;		{FastFile record}
+      fRec: copyFilePtr;		{copy file record}
+
+   begin {DoCopy}
+   new(fRec);				{create a copy record}
+   fRec^.fnext := fHeadGS;
+   fHeadGS := fRec;
+   fRec^.fName := fNameGS;		{fill in the current file name}
+   if GetString then begin		{get the source name}
+      SkipComment;			{skip to the end of the directive}
+					{save the file position}
+      fRec^.fpos := ord4(chPtr) + chCnt - ord4(filePtr);
+      fRec^.fuses := false;		{not doing a uses}
+      fRec^.flineCount := lineCount+1;	{save the new line count}
+      EndOfLine;			{read the next source line}
+      PurgeSource;			{purge the current source file}
+      eol := false;			{don't reprint the line}
+      Expand(lString);			{set the new path name}
+      fNameGS.theString.theString := lString;
+      fNameGS.theString.size := length(lString);
+      OpenGS;				{open the file}
+      lineCount := 1;
+      end {if}
+   else begin
+      eofl := true;
+      Error(37);
+      end; {else}
+   Options := false;			{we won't scan for end of comment}
+   doingOption := false;
+   end; {DoCopy}                                       
+
+
+   procedure DoDataBank;
+
+   { DataBank							}
+
+   begin {DoDataBank}
+   dataBank := SetOption;
+   end; {DoDataBank}
+
+
+   procedure DoDebug;
+
+   { Debug							}
+
+   var
+      val: unsigned;			{debug flag word}
+
+   begin {DoDebug}
+   val := GetInteger;
+   debugFlag := odd(val);
+   profileFlag := (val & $0002) <> 0;
+   end; {DoDebug}
+
+
+   procedure DoEject;
+
+   { Eject							}
+
+   begin {DoEject}
+   if printer then
+      if list then begin
+         write(chr(12));
+         lCnt := 0;
+         if length(title) <> 0 then begin
+            write(title);
+            LineFeed;
+            LineFeed;
+            end; {if}
+         end; {if}
+   end; {DoEject}
+
+
+   procedure DoFloat;
+
+   { Float							}
+
+   begin {DoFloat}
+   floatCard := GetInteger;
+   end; {DoFloat}
+
+
+   procedure DoISO;
+
+   { ISO							}
+
+   begin {DoISO}
+   iso := SetOption;
+   if iso then
+      debug := true;
+   end; {DoISO}
+
+
+   procedure DoKeep;
+
+   { Keep							}
+
+   begin {DoKeep}
+   if progFound or didKeep then
+      Error(100)
+   else if GetString then begin
+      codeGeneration := true;
+      Expand(lString);
+      kNameGS.theString.theString := lString;
+      kNameGS.theString.size := length(lString);
+      keepFlag := 1;
+      didKeep := true;
+      end; {else if}
+   end; {DoKeep}
+
+
+   procedure DoLibPrefix;
+
+   { LibPrefix							}
+
+   var
+      i: unsigned;			{loop/index variable}
+      len: unsigned;			{length(lString)}
+      separator: char;			{path separaotr character}
+
+   begin {DoLibPrefix}
+   if GetString then begin
+      len := length(lString);
+      if len = 0 then
+         intPrefixGS.theString.size := 0
+      else begin
+	 separator := ' ';
+	 i := 1;
+	 while i < len do
+            if lString[i] in [':','/'] then begin
+               separator := lString[i];
+               i := maxint;
+               end {if}
+            else
+               i := i+1;
+	 if separator = ' ' then
+            separator := ':';
+	 if lString[len] <> separator then
+            lString := concat(lString, separator);
+	 intPrefixGS.theString.theString := lString;
+	 intPrefixGS.theString.size := length(lString);
+         end; {else}
+      end {if}
+   else
+      Error(37);
+   end; {DoLibPrefix}
+
+
+   procedure DoList;
+
+   { List							}
+
+   var
+      llist: boolean;			{local list}
+
+   begin {DoList}
+   llist := SetOption;
+   if not listFixed then
+      list := llist;
+   end; {DoList}
+
+
+   procedure DoMemoryModel;
+
+   { MemoryModel						}
+
+   begin {DoMemoryModel}
+   if progFound then
+      Error(100);
+   smallMemoryModel := GetInteger = 0;
+   end; {DoMemoryModel}
+
+
+   procedure DoNames;
+
+   { Names							}
+
+   begin {DoNames}
+   traceBack := SetOption;
+   end; {DoNames}
+
+
+   procedure DoNBA;
+
+   { NBA							}
+
+   begin {DoNBA}
+   if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
+      or isNBA then
+      Error(100);
+   isNBA := true;
+   openName := GetIdent;
+   end; {DoNBA}
+
+
+   procedure DoNewDeskAcc;
+
+   { NewDeskAcc							}
+
+   begin {DoNewDeskAcc}
+   if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
+      or isNBA then
+      Error(100);
+   isNewDeskAcc := true;
+   openName := GetIdent;
+   closeName := GetIdent;
+   actionName := GetIdent;
+   initName := GetIdent;
+   refreshPeriod := GetInteger;
+   eventMask := GetInteger;
+   if GetString then
+      menuLine := lString
+   else
+      Error(131);
+   end; {DoNewDeskAcc}
+
+
+   procedure DoOptimize;
+
+   { Optimize							}
+
+   var
+      val: unsigned;			{optimize flag word}
+
+   begin {DoOptimize}
+   val := GetInteger;
+   peepHole := odd(val);
+   nPeepHole := (val & $0002) <> 0;
+   registers := (val & $0004) <> 0;
+   commonSubexpression := (val & $0008) <> 0;
+   loopOptimizations := (val & $0010) <> 0;
+   jslOptimizations := (val & $0020) <> 0;
+   end; {DoOptimize}
+
+
+   procedure DoRangeCheck;
+
+   { RangeCheck							}
+
+   begin {DoRangeCheck}
+   debug := SetOption;
+   rangeCheck := debug;
+   end; {DoRangeCheck}
+
+
+   procedure DoRTL;
+
+   { RTL							}
+
+   begin {DoRTL}
+   if isNewDeskAcc or isClassicDeskAcc or isCDev or rtl then
+      Error(100);
+   rtl := true;
+   end; {DoRTL}
+
+
+   procedure DoSegment;
+
+   { Segment							}
+
+   var
+      i: unsigned;			{loop/index variable}
+      seg: segNameType;			{segment name}
+
+   begin {DoSegment}
+   if GetString then begin
+      seg := lString;
+      for i := length(seg)+1 to 10 do
+         seg[i] := ' ';
+      DefaultSegName(seg);
+      isDynamic := false;
+      end {if}
+   else
+      Error(6);
+   end; {DoSegment}
+
+
+   procedure DoDynamic;
+
+   { Dynamic							}
+
+   begin {DoDynamic}
+   DoSegment;
+   isDynamic := true;
+   end; {DoDynamic}
+
+
+   procedure DoStackSize;
+
+   { StackSize							}
+
+   begin {DoStackSize}
+   if progFound then
+      Error(100);
+   stackSize := GetInteger;
+   end; {DoStackSize}
+
+
+   procedure DoToolParms;
+
+   { ToolParms							}
+
+   begin {DoToolParms}
+   toolParms := SetOption;
+   end; {DoToolParms}
+
+
+   procedure DoTitle;
+
+   { Title							}
+
+   begin {DoTitle}
+   if GetString then
+      title := lString
+   else
+      title := '';
+   end; {DoTitle}
+
+
+   procedure DoXCMD;
+
+   { XCMD							}
+
+   begin {DoXCMD}
+   if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
+      or isNBA then
+      Error(100);
+   isXCMD := true;
+   openName := GetIdent;
+   end; {DoXCMD}
+
+
+begin {Options} 
+Options := true;			{assume we will scan for end of comment}
+doingOption := true;			{processing an option}
+repeat
+   NextCh;
+   if (ch <> '*') and (ch <> '}') then begin
+      dName[0] := chr(0);		{get a directive name}
+      SkipBlanks;
+      while IsAlpha(ch) and (ord(dName[0]) < nameLen) do begin
+         dName[0] := succ(dName[0]);
+         dName[ord(dName[0])] := ToUpper(ch);
+         NextCh;
+         end; {while}
+					{call the correct handler}
+      if dName = 'MEMORYMODEL' then DoMemoryModel
+      else if dName = 'APPEND' then DoAppend
+      else if dName = 'COPY' then DoCopy
+      else if dName = 'DEBUG' then DoDebug
+      else if dName = 'EJECT' then DoEject
+      else if dName = 'FLOAT' then DoFloat
+      else if dName = 'ISO' then DoISO
+      else if dName = 'KEEP' then DoKeep
+      else if dName = 'LIST' then DoList
+      else if dName = 'NAMES' then DoNames
+      else if dName = 'RANGECHECK' then DoRangeCheck
+      else if dName = 'STACKSIZE' then DoStackSize
+      else if dName = 'TITLE' then DoTitle
+      else if dName = 'RTL' then DoRTL
+      else if dName = 'NEWDESKACC' then DoNewDeskAcc
+      else if dName = 'OPTIMIZE' then DoOptimize
+      else if dName = 'SEGMENT' then DoSegment
+      else if dName = 'DYNAMIC' then DoDynamic
+      else if dName = 'TOOLPARMS' then DoToolParms
+      else if dName = 'DATABANK' then DoDataBank
+      else if dName = 'LIBPREFIX' then DoLibPrefix
+      else if dName = 'CLASSICDESK' then DoClassicDesk
+      else if dName = 'CDEV' then DoCDev
+      else if dName = 'XCMD' then DoXCMD
+      else if dName = 'NBA' then DoNBA
+      else doingOption := false;  
+      end {if}
+   else
+      doingOption := false;
+   if doingOption then begin		{check for another one}
+      SkipBlanks;
+      doingOption := ch = ',';
+      end; {if}
+until not doingOption;
+end; {Options}
+
+{- Public subroutines ------------------------------------------}
+
+procedure Scanner_Fini;
+
+{ Shut down the scanner						}
+
+var
+   i: unsigned;				{loop/index variable}
+   tp: partialPtr;			{work pointer}
+
+begin {Scanner_Fini}
+PurgeSource;				{purge the last source file}
+fNameGS.theString.size := 0;		{handle a trailing append}
+eofDisable := true;
+InSymbol;
+if fNameGS.theString.size <> 0 then begin
+   liDCBGS.sFile := @fNameGS;
+   liDCBGS.namesList := @subsGS;
+   subsGS.theString.size := 0;
+   while partialList <> nil do begin
+      tp := partialList;
+      partialList := tp^.next;
+      for i := 1 to length(tp^.pname^) do begin
+         subsGS.theString.size := subsGS.theString.size+1;
+         subsGS.theString.theString[subsGS.theString.size] := tp^.pname^[i];
+         end; {for}
+      dispose(tp);
+      if partialList <> nil then begin
+         subsGS.theString.size := subsGS.theString.size+1;
+         subsGS.theString.theString[subsGS.theString.size] := ' ';
+         end; {if}
+      end; {while}
+   if keepFlag <> 0 then
+      liDCBGS.kFlag := 3;
+   end {if}
+else begin				{no append; the compile is over}
+   liDCBGS.lOps := liDCBGS.lOps & $FFFE;
+   if keepFlag <> 0 then
+      liDCBGS.kFlag := 3
+   else
+      liDCBGS.lOps := 0;
+   liDCBGS.sFile := @kNameGS;
+   end; {else}
+with liDCBGS do begin			{pass info back to the shell}
+   sFile := pointer(ord4(sFile)+2);
+   dFile := pointer(ord4(dFile)+2);
+   namesList := pointer(ord4(namesList)+2);
+   iString := pointer(ord4(iString)+2);
+   end; {with}
+SetLInfoGS(liDCBGS);
+StopSpin;				{stop the spinner}
+ListLine;				{finish the listing}
+if list or progress then begin
+   LineFeed;
+   writeln(errorOutput, numErr:1, ' errors found');
+   end; {if}
+end; {Scanner_Fini}
+
+
+procedure Skip {fsys: setofsys};
+
+{ skip input string until relavent symbol found			}
+{								}
+{ parameters:							}
+{    fsys - symbol kind to skip to				}
+
+begin {Skip}
+if not eofl then begin
+   while not (sy in fsys) and (not eofl) do
+      InSymbol;
+   if not (sy in fsys) then
+      InSymbol;
+   end; {if}
+end; {Skip}
+
+end.
+
+{$append 'scanner.asm'}
diff --git a/smac b/smac
old mode 100755
new mode 100644
index c6ec8ff..178fff1
--- a/smac
+++ b/smac
@@ -1 +1,257 @@
-         MACRO
&LAB     ENUM  &LIST,&START
&LAB     ANOP
         AIF   C:&~ENUM,.A
         GBLA  &~ENUM
.A
         AIF   C:&START=0,.B
&~ENUM   SETA  &START
.B
         LCLA  &CNT
&CNT     SETA  1
.C
&LIST(&CNT) EQU &~ENUM
&~ENUM   SETA  &~ENUM+1
&CNT     SETA  &CNT+1
         AIF   &CNT<=C:&LIST,^C
         MEND


         MACRO
&LAB     SUBR  &PARMS
&LAB     PHD
         LDA   MY_DP
         TCD
         AIF   C:&PARMS=0,.F
         LCLC  &PARM
         LCLA  &P
         LCLA  &LEN
         LCLA  &TOTALLEN
         LCLC  &C
&P       SETA  1
.A
&PARM    SETC  &PARMS(&P)
&C       AMID  &PARM,1,1
&PARM    AMID  &PARM,3,L:&PARM-2
&LEN     SETA  &C
&PARM    EQU   &TOTALLEN
&TOTALLEN SETA &TOTALLEN+&C
&P       SETA  &P+1
         AIF   &P<=C:&PARMS,^A
         AIF   &TOTALLEN<>2,.B
         LDA   6,S
         STA   0
         LDA   4,S
         STA   6,S
         LDA   2,S
         STA   4,S
         PLA
         STA   1,S
         MEXIT
.B
         AIF   &TOTALLEN<>4,.C
         LDA   6,S
         STA   0
         LDA   8,S
         STA   2
         LDA   4,S
         STA   8,S
         LDA   2,S
         STA   6,S
         PLA
         STA   3,S
         PLA
         MEXIT
.C
         PHB
         PLA
         STA   R0
         PLA
         STA   R2
         PLA
         STA   R4
         AIF   (&TOTALLEN/2*2)<>&TOTALLEN,.D
         LDX   #0
~&SYSCNT PLA
         STA   0,X
         INX
         INX
         CPX   #&TOTALLEN
         BNE   ~&SYSCNT
         AGO   .E
.D
         SEP   #$20
         LDX   #0
~&SYSCNT PLA
         STA   0,X
         INX
         CPX   #&TOTALLEN
         BNE   ~&SYSCNT
         REP   #$20
.E
         LDA   R4
         PHA
         LDA   R2
         PHA
         LDA   R0
         PHA
         PLB
.F
         MEND


         MACRO
&LAB     RETURN &VAL
         AIF   C:&VAL<>0,.A
&LAB     PLD
         RTL
         MEXIT
.A
         AIF   "&VAL"<>"2",.B
&LAB     PLD
         TAX
         RTL
         MEXIT
.B
         MNOTE 'Return values not implemented yet.',16
         MEND


         MACRO
&LAB     PASCAL
&LAB     TSC
         PLD
         PLB
         TCS
         MEND


         MACRO
&LAB     ASSEMBLY
&LAB     PHK
         PLB
         LDA   MY_DP
         TCD
         MEND


         MACRO
&LAB     MOVE4 &A,&B
&LAB     LDA   &A
         STA   &B
         LDA   2+&A
         STA   2+&B
         MEND


         MACRO
&LAB     TERR  &ERR
&LAB     LDA   &ERR
         PHA
         JSL   TERMERROR
         MEND


         MACRO
&LAB     LISTERROR &ERR
&LAB     LDA   0
         PHA
         PH2   &ERR
         JSL   ERROR
         PLA
         STA   0
         MEND


        macro
&lab    FastFile &DCB
&lab    ~setm
        jsl     $E100A8
        dc      i2'$010E'
        dc      i4'&DCB'
        ~restm
        mend


         macro
&lab     sub   &p,&w
&lab     anop
         lcla  &pc
         lclc  &n
         lclc  &s
         lclc  &pr
         gbla  &disp
         gbla  &ws
&ws      seta  &w
&pc      seta  1
&disp    seta  3+&w
.a
&pr      setc  &p(&pc)
&s       amid  &pr,1,1
&n       amid  &pr,3,l:&pr-2
&n       equ   &disp
&disp    seta  &disp+&s
&pc      seta  &pc+1
         aif   &pc<=c:&p,^a
         tdc
         tax
         tsc
         sec
         sbc   #&w-1
         tcd
         dec   a
         tcs
         phx
         mend


         macro
&lab     return
&lab     lda   &ws
         sta   &disp-3
         lda   &ws+1
         sta   &disp-2
         clc
         tdc
         adc   #&disp-4
         plx
         tcs
         txa
         tcd
         rtl
         mend


         macro
&lab     enum  &list,&start
&lab     anop
         aif   c:&~enum,.a
         gbla  &~enum
.a
         aif   c:&start=0,.b
&~enum   seta  &start
.b
         lcla  &cnt
&cnt     seta  1
.c
&list(&cnt) equ &~enum
&~enum   seta  &~enum+1
&cnt     seta  &cnt+1
         aif   &cnt<=c:&list,^c
         mend


         macro
&lab     terr  &err
&lab     lda   &err
         brl   termerror
         mend


         macro
&lab     move4 &a,&b
&lab     lda   &a
         sta   &b
         lda   2+&a
         sta   2+&b
         mend
\ No newline at end of file
+         MACRO
+&LAB     ENUM  &LIST,&START
+&LAB     ANOP
+         AIF   C:&~ENUM,.A
+         GBLA  &~ENUM
+.A
+         AIF   C:&START=0,.B
+&~ENUM   SETA  &START
+.B
+         LCLA  &CNT
+&CNT     SETA  1
+.C
+&LIST(&CNT) EQU &~ENUM
+&~ENUM   SETA  &~ENUM+1
+&CNT     SETA  &CNT+1
+         AIF   &CNT<=C:&LIST,^C
+         MEND
+
+
+         MACRO
+&LAB     SUBR  &PARMS
+&LAB     PHD
+         LDA   MY_DP
+         TCD
+         AIF   C:&PARMS=0,.F
+         LCLC  &PARM
+         LCLA  &P
+         LCLA  &LEN
+         LCLA  &TOTALLEN
+         LCLC  &C
+&P       SETA  1
+.A
+&PARM    SETC  &PARMS(&P)
+&C       AMID  &PARM,1,1
+&PARM    AMID  &PARM,3,L:&PARM-2
+&LEN     SETA  &C
+&PARM    EQU   &TOTALLEN
+&TOTALLEN SETA &TOTALLEN+&C
+&P       SETA  &P+1
+         AIF   &P<=C:&PARMS,^A
+         AIF   &TOTALLEN<>2,.B
+         LDA   6,S
+         STA   0
+         LDA   4,S
+         STA   6,S
+         LDA   2,S
+         STA   4,S
+         PLA
+         STA   1,S
+         MEXIT
+.B
+         AIF   &TOTALLEN<>4,.C
+         LDA   6,S
+         STA   0
+         LDA   8,S
+         STA   2
+         LDA   4,S
+         STA   8,S
+         LDA   2,S
+         STA   6,S
+         PLA
+         STA   3,S
+         PLA
+         MEXIT
+.C
+         PHB
+         PLA
+         STA   R0
+         PLA
+         STA   R2
+         PLA
+         STA   R4
+         AIF   (&TOTALLEN/2*2)<>&TOTALLEN,.D
+         LDX   #0
+~&SYSCNT PLA
+         STA   0,X
+         INX
+         INX
+         CPX   #&TOTALLEN
+         BNE   ~&SYSCNT
+         AGO   .E
+.D
+         SEP   #$20
+         LDX   #0
+~&SYSCNT PLA
+         STA   0,X
+         INX
+         CPX   #&TOTALLEN
+         BNE   ~&SYSCNT
+         REP   #$20
+.E
+         LDA   R4
+         PHA
+         LDA   R2
+         PHA
+         LDA   R0
+         PHA
+         PLB
+.F
+         MEND
+
+
+         MACRO
+&LAB     RETURN &VAL
+         AIF   C:&VAL<>0,.A
+&LAB     PLD
+         RTL
+         MEXIT
+.A
+         AIF   "&VAL"<>"2",.B
+&LAB     PLD
+         TAX
+         RTL
+         MEXIT
+.B
+         MNOTE 'Return values not implemented yet.',16
+         MEND
+
+
+         MACRO
+&LAB     PASCAL
+&LAB     TSC
+         PLD
+         PLB
+         TCS
+         MEND
+
+
+         MACRO
+&LAB     ASSEMBLY
+&LAB     PHK
+         PLB
+         LDA   MY_DP
+         TCD
+         MEND
+
+
+         MACRO
+&LAB     MOVE4 &A,&B
+&LAB     LDA   &A
+         STA   &B
+         LDA   2+&A
+         STA   2+&B
+         MEND
+
+
+         MACRO
+&LAB     TERR  &ERR
+&LAB     LDA   &ERR
+         PHA
+         JSL   TERMERROR
+         MEND
+
+
+         MACRO
+&LAB     LISTERROR &ERR
+&LAB     LDA   0
+         PHA
+         PH2   &ERR
+         JSL   ERROR
+         PLA
+         STA   0
+         MEND
+
+
+        macro
+&lab    FastFile &DCB
+&lab    ~setm
+        jsl     $E100A8
+        dc      i2'$010E'
+        dc      i4'&DCB'
+        ~restm
+        mend
+
+
+         macro
+&lab     sub   &p,&w
+&lab     anop
+         lcla  &pc
+         lclc  &n
+         lclc  &s
+         lclc  &pr
+         gbla  &disp
+         gbla  &ws
+&ws      seta  &w
+&pc      seta  1
+&disp    seta  3+&w
+.a
+&pr      setc  &p(&pc)
+&s       amid  &pr,1,1
+&n       amid  &pr,3,l:&pr-2
+&n       equ   &disp
+&disp    seta  &disp+&s
+&pc      seta  &pc+1
+         aif   &pc<=c:&p,^a
+         tdc
+         tax
+         tsc
+         sec
+         sbc   #&w-1
+         tcd
+         dec   a
+         tcs
+         phx
+         mend
+
+
+         macro
+&lab     return
+&lab     lda   &ws
+         sta   &disp-3
+         lda   &ws+1
+         sta   &disp-2
+         clc
+         tdc
+         adc   #&disp-4
+         plx
+         tcs
+         txa
+         tcd
+         rtl
+         mend
+
+
+         macro
+&lab     enum  &list,&start
+&lab     anop
+         aif   c:&~enum,.a
+         gbla  &~enum
+.a
+         aif   c:&start=0,.b
+&~enum   seta  &start
+.b
+         lcla  &cnt
+&cnt     seta  1
+.c
+&list(&cnt) equ &~enum
+&~enum   seta  &~enum+1
+&cnt     seta  &cnt+1
+         aif   &cnt<=c:&list,^c
+         mend
+
+
+         macro
+&lab     terr  &err
+&lab     lda   &err
+         brl   termerror
+         mend
+
+
+         macro
+&lab     move4 &a,&b
+&lab     lda   &a
+         sta   &b
+         lda   2+&a
+         sta   2+&b
+         mend
diff --git a/symbols.asm b/symbols.asm
old mode 100755
new mode 100644
index c2cbbe8..7d2e599
--- a/symbols.asm
+++ b/symbols.asm
@@ -1 +1,392 @@
-	mcopy symbols.macros
****************************************************************
*
*  EnterId - Enter an identifier in the symbol table
*
*  Inputs:
*	fcp - pointer to the identifier record
*
****************************************************************
*
EnterId	start
	using GetCom
lcp	equ	1	local identifier pointer
lcpl	equ	5	last lcp
lleft	equ	9	left link?
p1	equ	13	work pointers
p2	equ	17

	sub	(4:fcp),20

	ldx	#displaySize	lcp := display[top].fname;
	lda	TOP
	jsl	~mul2
	clc
	adc	#display_fname
	tax
	lda	DISPLAY,X
	sta	lcp
	lda	DISPLAY+2,X
	sta	lcp+2
	ora	lcp	if lcp = nil then
	bne	lb1
	lda	fcp	  display[top].fname := fcp
	sta	DISPLAY,X
	lda	fcp+2
	sta	DISPLAY+2,X
	brl	lb10	else begin
lb1	anop		  repeat
	move4 lcp,lcpl	    lcpl := lcp;
	ldy	#2	    comp :=
	lda	[lcp],Y	      compnames(lcp^.name^,fcp^.name^);
	pha
	lda	[lcp]
	pha
	lda	[fcp],Y
	pha
	lda	[fcp]
	pha
	jsl	CompNames
	tax		    if comp = 0 then begin
 	bne	lb4	      {name conflict, follow right link}
	listerror #30	      error(30);
!			      lcp := lcp^.rlink;
!			      lleft := false;
	bra	lb5	      end
lb4	bpl	lb6	    else if comp < 0 then begin
lb5	ldy	#identifier_rlink	      lcp := lcp^.rlink;
	lda	[lcp],Y
	tax
	iny
	iny
	lda	[lcp],Y
	sta	lcp+2
	stx	lcp
	stz	lleft	      lleft := false;
	bra	lb7	      end
lb6	anop		    else begin
	ldy	#identifier_llink	      lcp := lcp^.llink;
	lda	[lcp],Y
	tax
	iny
	iny
	lda	[lcp],Y
	sta	lcp+2
	stx	lcp
	lda	#true	      lleft := true;
	sta	lleft
!			      end
lb7	lda	lcp	  until lcp = nil;
	ora	lcp+2
	bne	lb1
	lda	lleft	  if lleft then
	beq	lb8
	ldy	#identifier_llink	    lcpl^.llink := fcp
	bra	lb9	  else
lb8	ldy	#identifier_rlink	    lcpl^.rlink := fcp
lb9	lda	fcp
	sta	[lcpl],Y
	iny
	iny
	lda	fcp+2
	sta	[lcpl],Y
lb10	anop		  end;
	ldy	#identifier_llink	fcp^.llink := nil;
	lda	#0	fcp^.rlink := nil;
	sta	[fcp],Y
	iny
	iny
	sta	[fcp],Y
	iny
	iny
	sta	[fcp],Y
	iny
	iny
	sta	[fcp],Y

	ret
	end
 
****************************************************************
*
*  MarkAsUsed - Insert a name into the list of names used from other levels
*
*  Inputs:
*	name - pointer to name used
*	top - index to display for the proper used list
*
****************************************************************
*
MarkAsUsed private
	using GetCom
p1	equ	1	work pointer
p2	equ	5
p3	equ	9

	sub	(4:name),12

	lda	TOP	p1 := @display[top].labsused;
	ldx	#DisplaySize
	jsl	~mul2
	clc
	adc	#display_labsused
	adc	#display
	sta	p1
	lda	#^display
	sta	p1+2
	ldy	#2	p2 := p1^;
	lda	[p1]
	sta	p2
	lda	[p1],Y
	sta	p2+2
lb1	lda	p2	while p2 <> nil do begin
	ora	p2+2
	beq	lb3
	ldy	#ltype_name	  if p2^.name = name then
	lda	[p2],Y
	cmp	name
	bne	lb2
	iny
	iny
	lda	[p2],Y
	cmp	name+2
	beq	lb4	    goto 1;

lb2	ldy	#ltype_next	  p2 := p2^.next;
	lda	[p2],Y
	tax
	iny
	iny
	lda	[p2],Y
	sta	p2+2
	stx	p2
	bra	lb1	  end;
lb3	ph2	#ltypeSize	new(p3);
	jsl	Malloc
	sta	p3
	stx	p3+2
	ldy	#ltype_name	p3^.name := name;
	lda	name
	sta	[p3],Y
	iny
	iny
	lda	name+2
	sta	[p3],Y
	ldy	#ltype_next	p3^.next := p1^;
	lda	[p1]
	sta	[p3],Y
	ldy	#2
	lda	[p1],Y
	ldy	#ltype_next+2
	sta	[p3],Y
	ldy	#ltype_disx	p3^.disx := disx;
	lda	DISX
	sta	[p3],Y
	lda	p3	p1^ := p3;
	sta	[p1]
	ldy	#2
	lda	p3+2
	sta	[p1],Y
lb4	anop		1:

	ret
	end

****************************************************************
*
*  SearchId - find an identifier
*
*  Inputs:
*	fidcls - set of allowable identifiers
*	fcp - address to place pointer to identifier found
*
****************************************************************
*
SearchId start
	using GetCom
lcp	equ	1	pointer to current symbol
ldisx	equ	5	address of display record being searched
len	equ	9	length of the string
p1	equ	11

!DISX	pointer	display level where the symbol is found
typesSet equ	1	set masks for elements of idclass
konstSet equ	2
varsmSet equ	4
fieldSet equ	8
procSet	equ	16

;	sub	(1:fidcls,4:fcp),14	Pascal 1.x
	sub	(2:fidcls,4:fcp),14	Pascal 2.x

	lda	id	len := length(ID)+1;
	and	#$00FF
	inc	a
	sta	len
	lda	TOP	for ldisx := top downto 0 do begin
	sta	DISX	  disx := ldisx;
	ldx	#displaySize
	jsl	~mul2
	clc
	adc	#DISPLAY
	sta	ldisx
	lda	#^DISPLAY
	adc	#0
	sta	ldisx+2
lb1	ldy	#display_fname	  lcp := display[disx].fname;
	lda	[ldisx],Y
	sta	lcp
	iny
	iny
	lda	[ldisx],Y
	sta	lcp+2
lb2	lda	lcp	  while lcp <> nil do begin
	ora	lcp+2
	beq	lb12
	ldy	#2	    comp := compnames(lcp^.name^,id);
	lda	[lcp],Y
	pha
	lda	[lcp]
	pha
	ph4	#id
	jsl	CompNames
	tax
	bne	lb8	    if comp = 0 then
	ldy	#identifier_klass	      if lcp^.klass in fidcls then begin
	lda	[lcp],Y
	tax
	lda	#0
	sec
lb5	rol	A
	dbpl	X,lb5
	and	fidcls
	beq	lb6
	lda	[ldisx]		gispacked :=
	sta	GISPACKED		  display[disx].ispacked;
	lda	TOP		if top <> disx then
	cmp	DISX
	beq	lb5a
	ph4	p1		  MarkAsUsed(lcp^.name);
	jsl	MarkAsUsed
lb5a	brl	lab1		goto 1;
!				end
lb6	anop		      else begin
	lda	PRTERR		if prterr then
	beq	lb7
	listerror #32		  error(32);
lb7	bra	lb9		lcp := lcp^.rlink
!				end
lb8	bpl	lb10	    else if comp < 0 then
lb9	ldy	#identifier_rlink	      lcp := lcp^.rlink
	bra	lb11	    else
lb10	ldy	#identifier_llink	      lcp := lcp^.llink
lb11	lda	[lcp],Y
	tax
	iny
	iny
	lda	[lcp],Y
	sta	lcp+2
	stx	lcp
	bra	lb2	    end; {while}
lb12	sub4	ldisx,#displaySize	  end; {for}
	dec	DISX
	jpl	lb1
	lda	PRTERR	if prterr then begin
	beq	lab1
	listerror #33	  error(33);
	lda	fidcls	  {to avoid returning nil, reference
	bit	#typesSet	   an entry for an undeclared id of
	beq	la1	   appropriate class
	ldx	UTYPPTR+2	   --> procedure enterundecl}
!			  {types,konst,varsm,field,proc,func,
	lda	UTYPPTR	   directive,prog}
	bra	la6	  if types in fidcls then
la1	bit	#varsmSet	    lcp := utypptr
	beq	la2	  else if varsm in fidcls then
	ldx	UVARPTR+2	    lcp := uvarptr
	lda	UVARPTR
	bra	la6	  else if field in fidcls then
la2	bit	#fieldSet	    lcp := ufldptr
	beq	la3
	ldx	UFLDPTR+2
	lda	UFLDPTR
	bra	la6
la3	bit	#konstSet	  else if konst in fidcls then
	beq	la4	    lcp := ucstptr
	ldx	UCSTPTR+2
	lda	UCSTPTR
	bra	la6
la4	bit	#procSet	  else if proc in fidcls then
	beq	la5	    lcp := uprcptr
	ldx	UPRCPTR+2
	lda	UPRCPTR
	bra	la6
la5	ldx	UFCTPTR+2	  else
	lda	UFCTPTR	    lcp := ufctptr;
la6	sta	lcp	  end;
	stx	<lcp+2
lab1	anop		1:
	ldy	#2	fcp := lcp
	lda	lcp
	sta	[fcp]
	lda	lcp+2
	sta	[fcp],Y

la7	ret
	end

****************************************************************
*
*  SearchSection - find record fields and forward declared proc id's
*
*  Inputs:
*	fcp - top of identifier chain
*
*  Outputs:
*	fcpl - output identifier
*
****************************************************************
*
SearchSection start
	using GetCom
	longa on
	longi on
p1	equ	1	work pointer

	sub	(4:fcp,4:fcpl),4

lb1	lda	fcp	while fcp <> nil do begin
	ora	fcp+2
	beq	lb6
	ldy	#2	  comp := compnames(fcp^.name^,id);
	lda	[fcp],Y
	pha
	lda	[fcp]
	pha
	ph4	#id
	jsl	CompNames
	tax
	beq	lb6	  if comp = 0 then
!			    goto 1
	bpl	lb4	  else if comp < 0 then
	ldy	#identifier_rlink	    fcp := fcp^.rlink
	bra	lb5	  else
lb4	ldy	#identifier_llink	    fcp := fcp^.llink;
lb5	lda	[fcp],Y
	tax
	iny
	iny
	lda	[fcp],Y
	sta	fcp+2
	stx	fcp
	bra	lb1	  end;
lb6	anop		1:
	ldy	#2	fcpl := fcp
	lda	fcp
	sta	[fcpl]
	lda	fcp+2
	sta	[fcpl],Y

	ret
	end
 
\ No newline at end of file
+	mcopy symbols.macros
+****************************************************************
+*
+*  EnterId - Enter an identifier in the symbol table
+*
+*  Inputs:
+*	fcp - pointer to the identifier record
+*
+****************************************************************
+*
+EnterId	start
+	using GetCom
+lcp	equ	1	local identifier pointer
+lcpl	equ	5	last lcp
+lleft	equ	9	left link?
+p1	equ	13	work pointers
+p2	equ	17
+
+	sub	(4:fcp),20
+
+	ldx	#displaySize	lcp := display[top].fname;
+	lda	TOP
+	jsl	~mul2
+	clc
+	adc	#display_fname
+	tax
+	lda	DISPLAY,X
+	sta	lcp
+	lda	DISPLAY+2,X
+	sta	lcp+2
+	ora	lcp	if lcp = nil then
+	bne	lb1
+	lda	fcp	  display[top].fname := fcp
+	sta	DISPLAY,X
+	lda	fcp+2
+	sta	DISPLAY+2,X
+	brl	lb10	else begin
+lb1	anop		  repeat
+	move4 lcp,lcpl	    lcpl := lcp;
+	ldy	#2	    comp :=
+	lda	[lcp],Y	      compnames(lcp^.name^,fcp^.name^);
+	pha
+	lda	[lcp]
+	pha
+	lda	[fcp],Y
+	pha
+	lda	[fcp]
+	pha
+	jsl	CompNames
+	tax		    if comp = 0 then begin
+ 	bne	lb4	      {name conflict, follow right link}
+	listerror #30	      error(30);
+!			      lcp := lcp^.rlink;
+!			      lleft := false;
+	bra	lb5	      end
+lb4	bpl	lb6	    else if comp < 0 then begin
+lb5	ldy	#identifier_rlink	      lcp := lcp^.rlink;
+	lda	[lcp],Y
+	tax
+	iny
+	iny
+	lda	[lcp],Y
+	sta	lcp+2
+	stx	lcp
+	stz	lleft	      lleft := false;
+	bra	lb7	      end
+lb6	anop		    else begin
+	ldy	#identifier_llink	      lcp := lcp^.llink;
+	lda	[lcp],Y
+	tax
+	iny
+	iny
+	lda	[lcp],Y
+	sta	lcp+2
+	stx	lcp
+	lda	#true	      lleft := true;
+	sta	lleft
+!			      end
+lb7	lda	lcp	  until lcp = nil;
+	ora	lcp+2
+	bne	lb1
+	lda	lleft	  if lleft then
+	beq	lb8
+	ldy	#identifier_llink	    lcpl^.llink := fcp
+	bra	lb9	  else
+lb8	ldy	#identifier_rlink	    lcpl^.rlink := fcp
+lb9	lda	fcp
+	sta	[lcpl],Y
+	iny
+	iny
+	lda	fcp+2
+	sta	[lcpl],Y
+lb10	anop		  end;
+	ldy	#identifier_llink	fcp^.llink := nil;
+	lda	#0	fcp^.rlink := nil;
+	sta	[fcp],Y
+	iny
+	iny
+	sta	[fcp],Y
+	iny
+	iny
+	sta	[fcp],Y
+	iny
+	iny
+	sta	[fcp],Y
+
+	ret
+	end
+ 
+****************************************************************
+*
+*  MarkAsUsed - Insert a name into the list of names used from other levels
+*
+*  Inputs:
+*	name - pointer to name used
+*	top - index to display for the proper used list
+*
+****************************************************************
+*
+MarkAsUsed private
+	using GetCom
+p1	equ	1	work pointer
+p2	equ	5
+p3	equ	9
+
+	sub	(4:name),12
+
+	lda	TOP	p1 := @display[top].labsused;
+	ldx	#DisplaySize
+	jsl	~mul2
+	clc
+	adc	#display_labsused
+	adc	#display
+	sta	p1
+	lda	#^display
+	sta	p1+2
+	ldy	#2	p2 := p1^;
+	lda	[p1]
+	sta	p2
+	lda	[p1],Y
+	sta	p2+2
+lb1	lda	p2	while p2 <> nil do begin
+	ora	p2+2
+	beq	lb3
+	ldy	#ltype_name	  if p2^.name = name then
+	lda	[p2],Y
+	cmp	name
+	bne	lb2
+	iny
+	iny
+	lda	[p2],Y
+	cmp	name+2
+	beq	lb4	    goto 1;
+
+lb2	ldy	#ltype_next	  p2 := p2^.next;
+	lda	[p2],Y
+	tax
+	iny
+	iny
+	lda	[p2],Y
+	sta	p2+2
+	stx	p2
+	bra	lb1	  end;
+lb3	ph2	#ltypeSize	new(p3);
+	jsl	Malloc
+	sta	p3
+	stx	p3+2
+	ldy	#ltype_name	p3^.name := name;
+	lda	name
+	sta	[p3],Y
+	iny
+	iny
+	lda	name+2
+	sta	[p3],Y
+	ldy	#ltype_next	p3^.next := p1^;
+	lda	[p1]
+	sta	[p3],Y
+	ldy	#2
+	lda	[p1],Y
+	ldy	#ltype_next+2
+	sta	[p3],Y
+	ldy	#ltype_disx	p3^.disx := disx;
+	lda	DISX
+	sta	[p3],Y
+	lda	p3	p1^ := p3;
+	sta	[p1]
+	ldy	#2
+	lda	p3+2
+	sta	[p1],Y
+lb4	anop		1:
+
+	ret
+	end
+
+****************************************************************
+*
+*  SearchId - find an identifier
+*
+*  Inputs:
+*	fidcls - set of allowable identifiers
+*	fcp - address to place pointer to identifier found
+*
+****************************************************************
+*
+SearchId start
+	using GetCom
+lcp	equ	1	pointer to current symbol
+ldisx	equ	5	address of display record being searched
+len	equ	9	length of the string
+p1	equ	11
+
+!DISX	pointer	display level where the symbol is found
+typesSet equ	1	set masks for elements of idclass
+konstSet equ	2
+varsmSet equ	4
+fieldSet equ	8
+procSet	equ	16
+
+;	sub	(1:fidcls,4:fcp),14	Pascal 1.x
+	sub	(2:fidcls,4:fcp),14	Pascal 2.x
+
+	lda	id	len := length(ID)+1;
+	and	#$00FF
+	inc	a
+	sta	len
+	lda	TOP	for ldisx := top downto 0 do begin
+	sta	DISX	  disx := ldisx;
+	ldx	#displaySize
+	jsl	~mul2
+	clc
+	adc	#DISPLAY
+	sta	ldisx
+	lda	#^DISPLAY
+	adc	#0
+	sta	ldisx+2
+lb1	ldy	#display_fname	  lcp := display[disx].fname;
+	lda	[ldisx],Y
+	sta	lcp
+	iny
+	iny
+	lda	[ldisx],Y
+	sta	lcp+2
+lb2	lda	lcp	  while lcp <> nil do begin
+	ora	lcp+2
+	beq	lb12
+	ldy	#2	    comp := compnames(lcp^.name^,id);
+	lda	[lcp],Y
+	pha
+	lda	[lcp]
+	pha
+	ph4	#id
+	jsl	CompNames
+	tax
+	bne	lb8	    if comp = 0 then
+	ldy	#identifier_klass	      if lcp^.klass in fidcls then begin
+	lda	[lcp],Y
+	tax
+	lda	#0
+	sec
+lb5	rol	A
+	dbpl	X,lb5
+	and	fidcls
+	beq	lb6
+	lda	[ldisx]		gispacked :=
+	sta	GISPACKED		  display[disx].ispacked;
+	lda	TOP		if top <> disx then
+	cmp	DISX
+	beq	lb5a
+	ph4	p1		  MarkAsUsed(lcp^.name);
+	jsl	MarkAsUsed
+lb5a	brl	lab1		goto 1;
+!				end
+lb6	anop		      else begin
+	lda	PRTERR		if prterr then
+	beq	lb7
+	listerror #32		  error(32);
+lb7	bra	lb9		lcp := lcp^.rlink
+!				end
+lb8	bpl	lb10	    else if comp < 0 then
+lb9	ldy	#identifier_rlink	      lcp := lcp^.rlink
+	bra	lb11	    else
+lb10	ldy	#identifier_llink	      lcp := lcp^.llink
+lb11	lda	[lcp],Y
+	tax
+	iny
+	iny
+	lda	[lcp],Y
+	sta	lcp+2
+	stx	lcp
+	bra	lb2	    end; {while}
+lb12	sub4	ldisx,#displaySize	  end; {for}
+	dec	DISX
+	jpl	lb1
+	lda	PRTERR	if prterr then begin
+	beq	lab1
+	listerror #33	  error(33);
+	lda	fidcls	  {to avoid returning nil, reference
+	bit	#typesSet	   an entry for an undeclared id of
+	beq	la1	   appropriate class
+	ldx	UTYPPTR+2	   --> procedure enterundecl}
+!			  {types,konst,varsm,field,proc,func,
+	lda	UTYPPTR	   directive,prog}
+	bra	la6	  if types in fidcls then
+la1	bit	#varsmSet	    lcp := utypptr
+	beq	la2	  else if varsm in fidcls then
+	ldx	UVARPTR+2	    lcp := uvarptr
+	lda	UVARPTR
+	bra	la6	  else if field in fidcls then
+la2	bit	#fieldSet	    lcp := ufldptr
+	beq	la3
+	ldx	UFLDPTR+2
+	lda	UFLDPTR
+	bra	la6
+la3	bit	#konstSet	  else if konst in fidcls then
+	beq	la4	    lcp := ucstptr
+	ldx	UCSTPTR+2
+	lda	UCSTPTR
+	bra	la6
+la4	bit	#procSet	  else if proc in fidcls then
+	beq	la5	    lcp := uprcptr
+	ldx	UPRCPTR+2
+	lda	UPRCPTR
+	bra	la6
+la5	ldx	UFCTPTR+2	  else
+	lda	UFCTPTR	    lcp := ufctptr;
+la6	sta	lcp	  end;
+	stx	<lcp+2
+lab1	anop		1:
+	ldy	#2	fcp := lcp
+	lda	lcp
+	sta	[fcp]
+	lda	lcp+2
+	sta	[fcp],Y
+
+la7	ret
+	end
+
+****************************************************************
+*
+*  SearchSection - find record fields and forward declared proc id's
+*
+*  Inputs:
+*	fcp - top of identifier chain
+*
+*  Outputs:
+*	fcpl - output identifier
+*
+****************************************************************
+*
+SearchSection start
+	using GetCom
+	longa on
+	longi on
+p1	equ	1	work pointer
+
+	sub	(4:fcp,4:fcpl),4
+
+lb1	lda	fcp	while fcp <> nil do begin
+	ora	fcp+2
+	beq	lb6
+	ldy	#2	  comp := compnames(fcp^.name^,id);
+	lda	[fcp],Y
+	pha
+	lda	[fcp]
+	pha
+	ph4	#id
+	jsl	CompNames
+	tax
+	beq	lb6	  if comp = 0 then
+!			    goto 1
+	bpl	lb4	  else if comp < 0 then
+	ldy	#identifier_rlink	    fcp := fcp^.rlink
+	bra	lb5	  else
+lb4	ldy	#identifier_llink	    fcp := fcp^.llink;
+lb5	lda	[fcp],Y
+	tax
+	iny
+	iny
+	lda	[fcp],Y
+	sta	fcp+2
+	stx	fcp
+	bra	lb1	  end;
+lb6	anop		1:
+	ldy	#2	fcpl := fcp
+	lda	fcp
+	sta	[fcpl]
+	lda	fcp+2
+	sta	[fcpl],Y
+
+	ret
+	end
+ 
diff --git a/symbols.macros b/symbols.macros
old mode 100755
new mode 100644
index abdd502..5bf4ced
--- a/symbols.macros
+++ b/symbols.macros
@@ -1 +1,438 @@
- MACRO
&LAB PH4 &N1
 LCLC &C
&LAB ANOP
&C AMID &N1,1,1
 AIF "&C"="#",.D
 AIF S:LONGA=1,.A
 REP #%00100000
.A
 AIF "&C"<>"{",.B
&C AMID &N1,L:&N1,1
 AIF "&C"<>"}",.G
&N1 AMID &N1,2,L:&N1-2
 LDY #2
 LDA (&N1),Y
 PHA
 LDA (&N1)
 PHA
 AGO .E
.B
 AIF "&C"<>"[",.C
 LDY #2
 LDA &N1,Y
 PHA
 LDA &N1
 PHA
 AGO .E
.C
 LDA &N1+2
 PHA
 LDA &N1
 PHA
 AGO .E
.D
&N1 AMID &N1,2,L:&N1-1
 PEA +(&N1)|-16
 PEA &N1
 AGO .F
.E
 AIF S:LONGA=1,.F
 SEP #%00100000
.F
 MEXIT
.G
 MNOTE "Missing closing '}'",16
 MEND
 MACRO
&lab move4 &a,&b
&lab lda &a
 sta &b
 lda 2+&a
 sta 2+&b
 mend
 MACRO
&LAB LISTERROR &ERR
&LAB LDA 0
 PHA
 PH2 &ERR
 JSL ERROR
 PLA
 STA 0
 MEND
 MACRO
&LAB SUB4 &M1,&M2,&M3
 LCLB &YISTWO
 LCLC &C
&LAB ~SETM
 AIF C:&M3,.A
&C AMID "&M2",1,1
 AIF "&C"<>"#",.A
&C AMID "&M1",1,1
 AIF "&C"="{",.A
 AIF "&C"="[",.A
&C AMID "&M2",2,L:&M2-1
 AIF &C>=65536,.A
 SEC
 ~LDA &M1
 ~OP SBC,&M2
 ~STA &M1
 BCS ~&SYSCNT
 ~OP.H DEC,&M1
~&SYSCNT ANOP
 AGO .C
.A
 AIF C:&M3,.B
 LCLC &M3
&M3 SETC &M1
.B
 SEC
 ~LDA &M1
 ~OP SBC,&M2
 ~STA &M3
 ~LDA.H &M1
 ~OP.H SBC,&M2
 ~STA.H &M3
.C
 ~RESTM
 MEND
 MACRO
&LAB DBPL &R,&BP
 AIF "&R"="X",.L1
 AIF "&R"="Y",.L1
&LAB DEC &R
 BPL &BP
 MEXIT
.L1
&LAB DE&R
 BPL &BP
 MEND
 MACRO
&LAB LONG &A,&B
 LCLB &I
 LCLB &M
&A AMID &A,1,1
&M SETB "&A"="M"
&I SETB "&A"="I"
 AIF C:&B=0,.A
&B AMID &B,1,1
&M SETB ("&B"="M").OR.&M
&I SETB ("&B"="I").OR.&I
.A
&LAB REP #&M*32+&I*16
 AIF .NOT.&M,.B
 LONGA ON
.B
 AIF .NOT.&I,.C
 LONGI ON
.C
 MEND
 MACRO
&LAB SHORT &A,&B
 LCLB &I
 LCLB &M
&A AMID &A,1,1
&M SETB "&A"="M"
&I SETB "&A"="I"
 AIF C:&B=0,.A
&B AMID &B,1,1
&M SETB ("&B"="M").OR.&M
&I SETB ("&B"="I").OR.&I
.A
&LAB SEP #&M*32+&I*16
 AIF .NOT.&M,.B
 LONGA OFF
.B
 AIF .NOT.&I,.C
 LONGI OFF
.C
 MEND
 MACRO
&LAB JPL &BP
&LAB BMI *+5
 BRL &BP
 MEND
 MACRO
&LAB PH2 &N1
 LCLC &C
&LAB ANOP
&C AMID &N1,1,1
 AIF "&C"="#",.D
 AIF S:LONGA=1,.A
 REP #%00100000
.A
 AIF "&C"<>"{",.B
&C AMID &N1,L:&N1,1
 AIF "&C"<>"}",.G
&N1 AMID &N1,2,L:&N1-2
 LDA (&N1)
 PHA
 AGO .E
.B
 LDA &N1
 PHA
 AGO .E
.D
&N1 AMID &N1,2,L:&N1-1
 PEA &N1
 AGO .F
.E
 AIF S:LONGA=1,.F
 SEP #%00100000
.F
 MEXIT
.G
 MNOTE "Missing closing '}'",16
 MEND
 MACRO
&LAB ~OP.H &OPC,&OP
&LAB ANOP
 LCLC &C
&C AMID "&OP",1,1
 AIF "&C"="[",.B
 AIF "&C"<>"{",.D
&C AMID "&OP",L:&OP,1
 AIF "&C"="}",.A
 MNOTE "Missing closing '}'",2
&OP SETC &OP}
.A
&OP AMID "&OP",2,L:&OP-2
&OP SETC (&OP)
.B
 AIF &YISTWO,.C
&YISTWO SETB 1
 LDY #2
&OP SETC "&OP,Y"
.C
 &OPC &OP
 MEXIT
.D
 AIF "&C"<>"#",.E
&OP AMID "&OP",2,L:&OP-1
&OP SETC "#^&OP"
 &OPC &OP
 MEXIT
.E
 &OPC 2+&OP
 MEND
 MACRO
&LAB ~LDA.H &OP
&LAB ANOP
 LCLC &C
&C AMID "&OP",1,1
 AIF "&C"="[",.B
 AIF "&C"<>"{",.D
&C AMID "&OP",L:&OP,1
 AIF "&C"="}",.A
 MNOTE "Missing closing '}'",2
&OP SETC &OP}
.A
&OP AMID "&OP",2,L:&OP-2
&OP SETC (&OP)
.B
 AIF &YISTWO,.C
&YISTWO SETB 1
 LDY #2
&OP SETC "&OP,Y"
.C
 LDA &OP
 MEXIT
.D
 AIF "&C"<>"#",.E
&OP AMID "&OP",2,L:&OP-1
&OP SETC "#^&OP"
 LDA &OP
 MEXIT
.E
 LDA 2+&OP
 MEND
 MACRO
&LAB ~STA.H &OP
&LAB ANOP
 LCLC &C
&C AMID "&OP",1,1
 AIF "&C"="[",.B
 AIF "&C"<>"{",.D
&C AMID "&OP",L:&OP,1
 AIF "&C"="}",.A
 MNOTE "Missing closing '}'",2
&OP SETC &OP}
.A
&OP AMID "&OP",2,L:&OP-2
&OP SETC (&OP)
.B
 AIF &YISTWO,.C
&YISTWO SETB 1
 LDY #2
&OP SETC "&OP,Y"
.C
 STA &OP
 MEXIT
.D
 STA 2+&OP
 MEND
 MACRO
&LAB ~SETM
&LAB ANOP
 AIF C:&~LA,.B
 GBLB &~LA
 GBLB &~LI
.B
&~LA SETB S:LONGA
&~LI SETB S:LONGI
 AIF S:LONGA.AND.S:LONGI,.A
 REP #32*(.NOT.&~LA)+16*(.NOT.&~LI)
 LONGA ON
 LONGI ON
.A
 MEND
 MACRO
&LAB ~RESTM
&LAB ANOP
 AIF (&~LA+&~LI)=2,.I
 SEP #32*(.NOT.&~LA)+16*(.NOT.&~LI)
 AIF &~LA,.H
 LONGA OFF
.H
 AIF &~LI,.I
 LONGI OFF
.I
 MEND
 MACRO
&LAB ~LDA &OP
 LCLC &C
&C AMID "&OP",1,1
 AIF "&C"<>"{",.B
&C AMID "&OP",L:&OP,1
 AIF "&C"="}",.A
 MNOTE "Missing closing '}'",2
&OP SETC &OP}
.A
&OP AMID "&OP",2,L:&OP-2
&OP SETC (&OP)
.B
&LAB LDA &OP
 MEND
 MACRO
&LAB ~STA &OP
 LCLC &C
&C AMID "&OP",1,1
 AIF "&C"<>"{",.B
&C AMID "&OP",L:&OP,1
 AIF "&C"="}",.A
 MNOTE "Missing closing '}'",2
&OP SETC &OP}
.A
&OP AMID "&OP",2,L:&OP-2
&OP SETC (&OP)
.B
&LAB STA &OP
 MEND
 MACRO
&LAB ~OP &OPC,&OP
 LCLC &C
&C AMID "&OP",1,1
 AIF "&C"<>"{",.B
&C AMID "&OP",L:&OP,1
 AIF "&C"="}",.A
 MNOTE "Missing closing '}'",2
&OP SETC &OP}
.A
&OP AMID "&OP",2,L:&OP-2
&OP SETC (&OP)
.B
&LAB &OPC &OP
 MEND
 macro
&l ret &r
&l anop
 lclc &len
 aif c:&r,.a
 lclc &r
&r setc 0
&len setc 0
 ago .h
.a
&len amid &r,2,1
 aif "&len"=":",.b
&len amid &r,1,2
&r amid &r,4,l:&r-3
 ago .c
.b
&len amid &r,1,1
&r amid &r,3,l:&r-2
.c
 aif &len<>2,.d
 ldy &r
 ago .h
.d
 aif &len<>4,.e
 ldx &r+2
 ldy &r
 ago .h
.e
 aif &len<>10,.g
 ldy #&r
 ldx #^&r
 ago .h
.g
 mnote 'Not a valid return length',16
 mexit
.h
 aif &totallen=0,.i
 lda &worklen+2
 sta &worklen+&totallen+2
 lda &worklen+1
 sta &worklen+&totallen+1
.i
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 aif &len=0,.j
 tya
.j
 rtl
 mend
 macro
&l sub &parms,&work
&l anop
 aif c:&work,.a
 lclc &work
&work setc 0
.a
 gbla &totallen
 gbla &worklen
&worklen seta &work
&totallen seta 0
 aif c:&parms=0,.e
 lclc &len
 lclc &p
 lcla &i
&i seta c:&parms
.b
&p setc &parms(&i)
&len amid &p,2,1
 aif "&len"=":",.c
&len amid &p,1,2
&p amid &p,4,l:&p-3
 ago .d
.c
&len amid &p,1,1
&p amid &p,3,l:&p-2
.d
&p equ &totallen+4+&work
&totallen seta &totallen+&len
&i seta &i-1
 aif &i,^b
.e
 tsc
 aif &work=0,.f
 sec
 sbc #&work
 tcs
.f
 phd
 tcd
 mend
\ No newline at end of file
+ MACRO
+&LAB PH4 &N1
+ LCLC &C
+&LAB ANOP
+&C AMID &N1,1,1
+ AIF "&C"="#",.D
+ AIF S:LONGA=1,.A
+ REP #%00100000
+.A
+ AIF "&C"<>"{",.B
+&C AMID &N1,L:&N1,1
+ AIF "&C"<>"}",.G
+&N1 AMID &N1,2,L:&N1-2
+ LDY #2
+ LDA (&N1),Y
+ PHA
+ LDA (&N1)
+ PHA
+ AGO .E
+.B
+ AIF "&C"<>"[",.C
+ LDY #2
+ LDA &N1,Y
+ PHA
+ LDA &N1
+ PHA
+ AGO .E
+.C
+ LDA &N1+2
+ PHA
+ LDA &N1
+ PHA
+ AGO .E
+.D
+&N1 AMID &N1,2,L:&N1-1
+ PEA +(&N1)|-16
+ PEA &N1
+ AGO .F
+.E
+ AIF S:LONGA=1,.F
+ SEP #%00100000
+.F
+ MEXIT
+.G
+ MNOTE "Missing closing '}'",16
+ MEND
+ MACRO
+&lab move4 &a,&b
+&lab lda &a
+ sta &b
+ lda 2+&a
+ sta 2+&b
+ mend
+ MACRO
+&LAB LISTERROR &ERR
+&LAB LDA 0
+ PHA
+ PH2 &ERR
+ JSL ERROR
+ PLA
+ STA 0
+ MEND
+ MACRO
+&LAB SUB4 &M1,&M2,&M3
+ LCLB &YISTWO
+ LCLC &C
+&LAB ~SETM
+ AIF C:&M3,.A
+&C AMID "&M2",1,1
+ AIF "&C"<>"#",.A
+&C AMID "&M1",1,1
+ AIF "&C"="{",.A
+ AIF "&C"="[",.A
+&C AMID "&M2",2,L:&M2-1
+ AIF &C>=65536,.A
+ SEC
+ ~LDA &M1
+ ~OP SBC,&M2
+ ~STA &M1
+ BCS ~&SYSCNT
+ ~OP.H DEC,&M1
+~&SYSCNT ANOP
+ AGO .C
+.A
+ AIF C:&M3,.B
+ LCLC &M3
+&M3 SETC &M1
+.B
+ SEC
+ ~LDA &M1
+ ~OP SBC,&M2
+ ~STA &M3
+ ~LDA.H &M1
+ ~OP.H SBC,&M2
+ ~STA.H &M3
+.C
+ ~RESTM
+ MEND
+ MACRO
+&LAB DBPL &R,&BP
+ AIF "&R"="X",.L1
+ AIF "&R"="Y",.L1
+&LAB DEC &R
+ BPL &BP
+ MEXIT
+.L1
+&LAB DE&R
+ BPL &BP
+ MEND
+ MACRO
+&LAB LONG &A,&B
+ LCLB &I
+ LCLB &M
+&A AMID &A,1,1
+&M SETB "&A"="M"
+&I SETB "&A"="I"
+ AIF C:&B=0,.A
+&B AMID &B,1,1
+&M SETB ("&B"="M").OR.&M
+&I SETB ("&B"="I").OR.&I
+.A
+&LAB REP #&M*32+&I*16
+ AIF .NOT.&M,.B
+ LONGA ON
+.B
+ AIF .NOT.&I,.C
+ LONGI ON
+.C
+ MEND
+ MACRO
+&LAB SHORT &A,&B
+ LCLB &I
+ LCLB &M
+&A AMID &A,1,1
+&M SETB "&A"="M"
+&I SETB "&A"="I"
+ AIF C:&B=0,.A
+&B AMID &B,1,1
+&M SETB ("&B"="M").OR.&M
+&I SETB ("&B"="I").OR.&I
+.A
+&LAB SEP #&M*32+&I*16
+ AIF .NOT.&M,.B
+ LONGA OFF
+.B
+ AIF .NOT.&I,.C
+ LONGI OFF
+.C
+ MEND
+ MACRO
+&LAB JPL &BP
+&LAB BMI *+5
+ BRL &BP
+ MEND
+ MACRO
+&LAB PH2 &N1
+ LCLC &C
+&LAB ANOP
+&C AMID &N1,1,1
+ AIF "&C"="#",.D
+ AIF S:LONGA=1,.A
+ REP #%00100000
+.A
+ AIF "&C"<>"{",.B
+&C AMID &N1,L:&N1,1
+ AIF "&C"<>"}",.G
+&N1 AMID &N1,2,L:&N1-2
+ LDA (&N1)
+ PHA
+ AGO .E
+.B
+ LDA &N1
+ PHA
+ AGO .E
+.D
+&N1 AMID &N1,2,L:&N1-1
+ PEA &N1
+ AGO .F
+.E
+ AIF S:LONGA=1,.F
+ SEP #%00100000
+.F
+ MEXIT
+.G
+ MNOTE "Missing closing '}'",16
+ MEND
+ MACRO
+&LAB ~OP.H &OPC,&OP
+&LAB ANOP
+ LCLC &C
+&C AMID "&OP",1,1
+ AIF "&C"="[",.B
+ AIF "&C"<>"{",.D
+&C AMID "&OP",L:&OP,1
+ AIF "&C"="}",.A
+ MNOTE "Missing closing '}'",2
+&OP SETC &OP}
+.A
+&OP AMID "&OP",2,L:&OP-2
+&OP SETC (&OP)
+.B
+ AIF &YISTWO,.C
+&YISTWO SETB 1
+ LDY #2
+&OP SETC "&OP,Y"
+.C
+ &OPC &OP
+ MEXIT
+.D
+ AIF "&C"<>"#",.E
+&OP AMID "&OP",2,L:&OP-1
+&OP SETC "#^&OP"
+ &OPC &OP
+ MEXIT
+.E
+ &OPC 2+&OP
+ MEND
+ MACRO
+&LAB ~LDA.H &OP
+&LAB ANOP
+ LCLC &C
+&C AMID "&OP",1,1
+ AIF "&C"="[",.B
+ AIF "&C"<>"{",.D
+&C AMID "&OP",L:&OP,1
+ AIF "&C"="}",.A
+ MNOTE "Missing closing '}'",2
+&OP SETC &OP}
+.A
+&OP AMID "&OP",2,L:&OP-2
+&OP SETC (&OP)
+.B
+ AIF &YISTWO,.C
+&YISTWO SETB 1
+ LDY #2
+&OP SETC "&OP,Y"
+.C
+ LDA &OP
+ MEXIT
+.D
+ AIF "&C"<>"#",.E
+&OP AMID "&OP",2,L:&OP-1
+&OP SETC "#^&OP"
+ LDA &OP
+ MEXIT
+.E
+ LDA 2+&OP
+ MEND
+ MACRO
+&LAB ~STA.H &OP
+&LAB ANOP
+ LCLC &C
+&C AMID "&OP",1,1
+ AIF "&C"="[",.B
+ AIF "&C"<>"{",.D
+&C AMID "&OP",L:&OP,1
+ AIF "&C"="}",.A
+ MNOTE "Missing closing '}'",2
+&OP SETC &OP}
+.A
+&OP AMID "&OP",2,L:&OP-2
+&OP SETC (&OP)
+.B
+ AIF &YISTWO,.C
+&YISTWO SETB 1
+ LDY #2
+&OP SETC "&OP,Y"
+.C
+ STA &OP
+ MEXIT
+.D
+ STA 2+&OP
+ MEND
+ MACRO
+&LAB ~SETM
+&LAB ANOP
+ AIF C:&~LA,.B
+ GBLB &~LA
+ GBLB &~LI
+.B
+&~LA SETB S:LONGA
+&~LI SETB S:LONGI
+ AIF S:LONGA.AND.S:LONGI,.A
+ REP #32*(.NOT.&~LA)+16*(.NOT.&~LI)
+ LONGA ON
+ LONGI ON
+.A
+ MEND
+ MACRO
+&LAB ~RESTM
+&LAB ANOP
+ AIF (&~LA+&~LI)=2,.I
+ SEP #32*(.NOT.&~LA)+16*(.NOT.&~LI)
+ AIF &~LA,.H
+ LONGA OFF
+.H
+ AIF &~LI,.I
+ LONGI OFF
+.I
+ MEND
+ MACRO
+&LAB ~LDA &OP
+ LCLC &C
+&C AMID "&OP",1,1
+ AIF "&C"<>"{",.B
+&C AMID "&OP",L:&OP,1
+ AIF "&C"="}",.A
+ MNOTE "Missing closing '}'",2
+&OP SETC &OP}
+.A
+&OP AMID "&OP",2,L:&OP-2
+&OP SETC (&OP)
+.B
+&LAB LDA &OP
+ MEND
+ MACRO
+&LAB ~STA &OP
+ LCLC &C
+&C AMID "&OP",1,1
+ AIF "&C"<>"{",.B
+&C AMID "&OP",L:&OP,1
+ AIF "&C"="}",.A
+ MNOTE "Missing closing '}'",2
+&OP SETC &OP}
+.A
+&OP AMID "&OP",2,L:&OP-2
+&OP SETC (&OP)
+.B
+&LAB STA &OP
+ MEND
+ MACRO
+&LAB ~OP &OPC,&OP
+ LCLC &C
+&C AMID "&OP",1,1
+ AIF "&C"<>"{",.B
+&C AMID "&OP",L:&OP,1
+ AIF "&C"="}",.A
+ MNOTE "Missing closing '}'",2
+&OP SETC &OP}
+.A
+&OP AMID "&OP",2,L:&OP-2
+&OP SETC (&OP)
+.B
+&LAB &OPC &OP
+ MEND
+ macro
+&l ret &r
+&l anop
+ lclc &len
+ aif c:&r,.a
+ lclc &r
+&r setc 0
+&len setc 0
+ ago .h
+.a
+&len amid &r,2,1
+ aif "&len"=":",.b
+&len amid &r,1,2
+&r amid &r,4,l:&r-3
+ ago .c
+.b
+&len amid &r,1,1
+&r amid &r,3,l:&r-2
+.c
+ aif &len<>2,.d
+ ldy &r
+ ago .h
+.d
+ aif &len<>4,.e
+ ldx &r+2
+ ldy &r
+ ago .h
+.e
+ aif &len<>10,.g
+ ldy #&r
+ ldx #^&r
+ ago .h
+.g
+ mnote 'Not a valid return length',16
+ mexit
+.h
+ aif &totallen=0,.i
+ lda &worklen+2
+ sta &worklen+&totallen+2
+ lda &worklen+1
+ sta &worklen+&totallen+1
+.i
+ pld
+ tsc
+ clc
+ adc #&worklen+&totallen
+ tcs
+ aif &len=0,.j
+ tya
+.j
+ rtl
+ mend
+ macro
+&l sub &parms,&work
+&l anop
+ aif c:&work,.a
+ lclc &work
+&work setc 0
+.a
+ gbla &totallen
+ gbla &worklen
+&worklen seta &work
+&totallen seta 0
+ aif c:&parms=0,.e
+ lclc &len
+ lclc &p
+ lcla &i
+&i seta c:&parms
+.b
+&p setc &parms(&i)
+&len amid &p,2,1
+ aif "&len"=":",.c
+&len amid &p,1,2
+&p amid &p,4,l:&p-3
+ ago .d
+.c
+&len amid &p,1,1
+&p amid &p,3,l:&p-2
+.d
+&p equ &totallen+4+&work
+&totallen seta &totallen+&len
+&i seta &i-1
+ aif &i,^b
+.e
+ tsc
+ aif &work=0,.f
+ sec
+ sbc #&work
+ tcs
+.f
+ phd
+ tcd
+ mend
diff --git a/symbols.pas b/symbols.pas
old mode 100755
new mode 100644
index 4da1e22..48c56da
--- a/symbols.pas
+++ b/symbols.pas
@@ -1 +1,1285 @@
-{$optimize -1}
{------------------------------------------------------------}
{							     }
{  SymbolTables						     }
{							     }
{  This unit implements the symbol table for ORCA/Pascal.    }
{  Also included are many of the declarations that tie the   }
{  various units together.  The specialized memory manager   }
{  used to make symbol table disposal more efficient is also }
{  included in this module.				     }
{							     }
{  The interfaces for the scanner and object module output   }
{  units are in this unit.  This eliminates the need for a   }
{  common module that would have most of the pertinant	     }
{  symbol table type information.			     }
{							     }
{  By Mike Westerfield					     }
{							     }
{  Copyright August 1987 				     }
{  By the Byte Works, Inc.				     }
{							     }
{------------------------------------------------------------}

unit SymbolTables;

{$segment 'Pascal2'}

interface

{$libprefix '0/obj/'}

uses PCommon, CGI, CGC, ObjOut, Native, Scanner;

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

var
					{pointers:}
					{---------}
   intptr,realptr,charptr,
   byteptr,longptr,compptr,
   doubleptr,extendedptr,stringptr,
   boolptr,nilptr,textptr: stp;		{pointers to entries of standard ids}
   externIdentifier: ctp; 		{extern ID entry}
   forwardIdentifier: ctp;		{forward ID entry}
   utypptr,ucstptr,uvarptr,
   ufldptr,uprcptr,ufctptr,		{pointers to entries for undeclared ids}
   fwptr: ctp;				{head of chain for forw decl type ids}
   inptr,outptr,erroroutputptr: ctp;	{standard I/O}
   dummyString: stp;			{index entry for string constants}

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

function CompObjects (fsp1, fsp2: stp): boolean;

{ See if two objects are assignment compatible			}
{								}
{ parameters:							}
{    fsp1 - object to assign to					}
{    fsp2 - object to assign					}
{								}
{ Returns: True if the structures are compatible, else false	}


function CompTypes (fsp1, fsp2: stp): boolean;

{ determine if two structures are type compatible		}
{								}
{ parameters:							}
{    fsp1, fsp2 - structures to check				}
{								}
{ Returns: True if the structures are compatible, else false	}


procedure EnterStdTypes;

{ enter the base types						}


procedure EntStdNames;

{ enter standard names in the program symbol table		}


procedure EnterId (fcp: ctp); extern;

{ Enter an identifier at the current stack frame level		}
{								}
{ parameters:							}
{    fcp - identifier to enter					}


procedure EnterUndecl;

{ enter fake identifiers for use when identifiers are		}
{ undeclared							}


procedure GenSymbols (sym: ctp; doGlobals: integer);

{ generate the symbol table                                     }
{								}
{ Notes: Defined as extern in Native.pas			}


procedure GetBounds (fsp: stp; var fmin,fmax: longint);

{ get internal bounds of subrange or scalar type		}
{ (assume fsp<>longptr and fsp<>realptr)			}
{								}
{ parameters:							}
{    fsp - type to get the bounds for				}
{    fmin, fmax - (output) bounds				}


function GetType (tp: stp; isPacked: boolean): baseTypeEnum;

{ find the base type for a variable type			}
{								}
{ parameters:							}
{    tp - variable type						}
{    isPacked - is the variable packed?				}
{								}
{ returns: Variable base type					}


function IsReal (fsp: stp): boolean;

{ determine if fsp is one of the real types			}
{								}
{ parameters:							}
{    fsp - structure to check					}
{								}
{ Returns: True if fsp is a real, else false			}


function IsString (fsp: stp): boolean;

{ determine if fsp is a string					}
{								}
{ parameters:							}
{    fsp - structure to check					}
{								}
{ Returns: True if fsp is a string, else false			}


procedure SearchSection (fcp: ctp; var fcpl: ctp); extern;

{ find record fields and forward declared procedure id's	}
{								}
{ parameters:							}
{    fcp - top of identifier tree				}
{    fcpl - (outout) identifier					}


procedure SearchId (fidcls: setofids; var fcp: ctp); extern;

{ find an identifier						}
{								}
{ parameters:							}
{    fidcls - kinds of identifiers to look for			}
{    fcp - (output) identifier found				}


function StrLen (tp: stp): integer;

{ Find the length of a string variable (for library calls)	}
{								}
{ parameters:							}
{    tp - string variable					}
{								}
{ Returns: length of the string					}

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

implementation

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

function CompObjects {fsp1, fsp2: stp): boolean};

{ See if two objects are assignment compatible			}
{								}
{ parameters:							}
{    fsp1 - object to assign to					}
{    fsp2 - object to assign					}
{								}
{ Returns: True if the structures are compatible, else false	}

begin {CompObjects}
CompObjects := false;
if fsp1^.form = objects then begin
  if fsp2^.form = objects then begin
    while fsp2 <> nil do begin
      if fsp1 = fsp2 then begin
	fsp2 := nil;
	CompObjects := true;
	end {if}
      else
	fsp2 := fsp2^.objparent;
      end; {while}
    end {if}
  else if fsp2 = nilptr then
    CompObjects := true;
  end; {if}
end; {CompObjects}


function CompTypes {fsp1,fsp2: stp): boolean};

{ determine if two structures are type compatible		}
{								}
{ parameters:							}
{    fsp1, fsp2 - structures to check				}
{								}
{ Returns: True if the structures are compatible, else false	}

var
   lmin1,lmin2: integer;
   comp: boolean;

begin {CompTypes}
if fsp1 = fsp2 then
   CompTypes := true
else if (fsp1 <> nil) and (fsp2 <> nil) then begin
   if fsp1^.form = subrange then begin
      if fsp2^.form = subrange then
	 CompTypes := CompTypes(fsp1^.rangetype,fsp2^.rangetype)
      else
	 CompTypes := CompTypes(fsp1^.rangetype,fsp2);
      end {if}
   else if fsp2^.form = subrange then
      CompTypes := CompTypes(fsp1,fsp2^.rangetype)
   else if fsp1 = byteptr then
      CompTypes := CompTypes(fsp2,intptr)
   else if fsp2 = byteptr then
      CompTypes := CompTypes(fsp1,intptr)
   else if fsp1^.form = fsp2^.form then begin
      if fsp1^.form = power then
	 CompTypes := CompTypes(fsp1^.elset,fsp2^.elset) and
	    ((fsp1^.ispacked = pkeither) or (fsp2^.ispacked = pkeither) or
	    (fsp1^.ispacked = fsp2^.ispacked))
      else if fsp1^.form = arrays then begin
	 comp := IsString(fsp1) and IsString(fsp2);
	 if iso then
	    comp := comp and (fsp1^.size = fsp2^.size);
	 CompTypes := comp;
	 end {else if}
      else if fsp1^.form = pointerStruct then
	 CompTypes := (fsp1 = nilptr) or (fsp2 = nilptr)
      else
	 CompTypes := IsReal(fsp1) and IsReal(fsp2);
      end {else if}
   else if fsp1^.form = objects then
      CompTypes := fsp2 = nilptr
   else if fsp2^.form = objects then
      CompTypes := fsp1 = nilptr
   else
      CompTypes := false
   end
else
   CompTypes := true
end; {CompTypes}
 

procedure EnterStdTypes;

{ enter the base types						}

begin {EnterStdTypes}
byteptr := pointer(Malloc(sizeof(structure)));	{byte}
with byteptr^ do begin
   size := bytesize;
   ispacked := pkunpacked;
   form := scalar;
   scalkind := standard;
   hasSFile := false;
   end; {with}
intptr := pointer(Malloc(sizeof(structure)));	{integer}
with intptr^ do begin
   size := intsize;
   ispacked := pkunpacked;
   form := scalar;
   scalkind := standard;
   hasSFile := false;
   end; {with}
longptr := pointer(Malloc(sizeof(structure)));	{long}
with longptr^ do begin
   size := longsize;
   ispacked := pkunpacked;
   form := scalar;
   scalkind := standard;
   hasSFile := false;
   end; {with}
realptr := pointer(Malloc(sizeof(structure)));	{real}
with realptr^ do begin
   size := realsize;
   ispacked := pkunpacked;
   form := scalar;
   scalkind := standard;
   hasSFile := false;
   end; {with}
doubleptr := pointer(Malloc(sizeof(structure))); {double}
with doubleptr^ do begin
   size := doublesize;
   ispacked := pkunpacked;
   form := scalar;
   scalkind := standard;
   hasSFile := false;
   end; {with}
compptr := pointer(Malloc(sizeof(structure))); {comp}
with compptr^ do begin
   size := compsize;
   ispacked := pkunpacked;
   form := scalar;
   scalkind := standard;
   hasSFile := false;
   end; {with}
extendedptr := pointer(Malloc(sizeof(structure))); {extended}
with extendedptr^ do begin
   size := extendedsize;
   ispacked := pkunpacked;
   form := scalar;
   scalkind := standard;
   hasSFile := false;
   end; {with}
charptr := pointer(Malloc(sizeof(structure)));	{char}
with charptr^ do begin
   size := charsize;
   ispacked := pkunpacked;
   form := scalar;
   scalkind := standard;
   hasSFile := false;
   end; {with}
stringptr := pointer(Malloc(sizeof(structure))); {string}
with stringptr^ do begin
   size := packedcharsize*2;
   ispacked := pkpacked;
   form := arrays;
   hasSFile := false;
   aeltype := charptr;
   inxtype := pointer(Malloc(sizeof(structure)));
   with inxtype^ do begin
      size := intsize;
      form := subrange;
      rangetype := intptr;
      min := 1;
      max := 2;
      end; {with}
   end; {with}
boolptr := pointer(Malloc(sizeof(structure)));	{bool}
with boolptr^ do begin
   size := boolsize;
   ispacked := pkunpacked;
   form := scalar;
   scalkind := declared;
   hasSFile := false;
   end; {with}
nilptr := pointer(Malloc(sizeof(structure)));	{nil}
with nilptr^ do begin
   eltype := nil;
   size := ptrsize;
   ispacked := pkunpacked;
   form := pointerStruct;
   hasSFile := false;
   end; {with}
textptr := pointer(Malloc(sizeof(structure)));	{text}
with textptr^ do begin
   filtype := charptr;
   filsize := packedcharsize*2;
   size := ptrsize;
   ispacked := pkunpacked;
   form := files;
   hasSFile := true;
   end; {with}
end; {EnterStdTypes}


procedure EntStdNames;

{ enter standard names in the program symbol table		}

var
   cp,cp1: ctp;
   i: integer;

begin {EntStdNames}
cp := pointer(Malloc(sizeof(identifier)));	{integer}
with cp^ do begin
   name := @'INTEGER';
   idtype := intptr;
   klass := types;
   hasIFile := false;
   end; {with}
EnterId(cp);
cp := pointer(Malloc(sizeof(identifier)));	{byte}
with cp^ do begin
   name := @'BYTE';
   idtype := byteptr;
   klass := types;
   hasIFile := false;
   end; {with}
EnterId(cp);  
cp := pointer(Malloc(sizeof(identifier)));	{longint}
with cp^ do begin
   name := @'LONGINT';
   idtype := longptr;
   klass := types;
   hasIFile := false;
   end; {with}
EnterId(cp);  
cp := pointer(Malloc(sizeof(identifier)));	{real}
with cp^ do begin
   name := @'REAL';
   idtype := realptr;
   klass := types;
   hasIFile := false;
   end; {with}
EnterId(cp);  
cp := pointer(Malloc(sizeof(identifier)));	{double}
with cp^ do begin
   name := @'DOUBLE';
   idtype := doubleptr;
   klass := types;
   hasIFile := false;
   end; {with}
EnterId(cp);  
cp := pointer(Malloc(sizeof(identifier)));	{comp}
with cp^ do begin
   name := @'COMP';
   idtype := compptr;
   klass := types;
   hasIFile := false;
   end; {with}
EnterId(cp);  
cp := pointer(Malloc(sizeof(identifier)));	{extended}
with cp^ do begin
   name := @'EXTENDED';
   idtype := extendedptr;
   klass := types;
   hasIFile := false;
   end; {with}
EnterId(cp);  
cp := pointer(Malloc(sizeof(identifier)));	{char}
with cp^ do begin
   name := @'CHAR';
   idtype := charptr;
   klass := types;
   hasIFile := false;
   end; {with}
EnterId(cp);  
cp := pointer(Malloc(sizeof(identifier)));	{boolean}
with cp^ do begin
   name := @'BOOLEAN';
   idtype := boolptr;
   klass := types;
   hasIFile := false;
   end; {with}
EnterId(cp);  
cp := pointer(Malloc(sizeof(identifier)));	{text}
with cp^ do begin
   name := @'TEXT';
   idtype := textptr;
   klass := types;
   hasIFile := true;
   end; {with}
EnterId(cp);  
cp1 := nil;
for i := 1 to 2 do begin
   cp := pointer(Malloc(sizeof(identifier)));	{false,true}
   with cp^ do begin
      name := na[i];
      idtype := boolptr;
      next := cp1;
      values.ival := i-1;
      klass := konst;
      hasIFile := false;
      end; {with}
   EnterId(cp);
   cp1 := cp
   end; {with}
boolptr^.fconst := cp;
cp := pointer(Malloc(sizeof(identifier)));	{forward}
with cp^ do begin
   name := @'FORWARD';
   next := nil;
   klass := directive;
   drkind := drforw;
   hasIFile := false;
   end; {with}
EnterId(cp);
forwardIdentifier := cp;
cp := pointer(Malloc(sizeof(identifier)));	{extern}
with cp^ do begin
   name := @'EXTERN';
   next := nil;
   klass := directive;
   drkind := drextern;
   hasIFile := false;
   end; {with}
EnterId(cp);
externIdentifier := cp;
cp := pointer(Malloc(sizeof(identifier)));	{external}
with cp^ do begin
   name := @'EXTERNAL';
   next := nil;
   klass := directive;
   drkind := drextern;
   hasIFile := false;
   end; {with}
EnterId(cp);
cp := pointer(Malloc(sizeof(identifier)));	{override}
with cp^ do begin
   name := @'OVERRIDE';
   next := nil;
   klass := directive;
   drkind := droverride;
   hasIFile := false;
   end; {with}
EnterId(cp);
cp := pointer(Malloc(sizeof(identifier)));	{prodos}
with cp^ do begin
   name := @'PRODOS';
   next := nil;
   klass := directive;
   drkind := drprodos;
   hasIFile := false;
   end; {with}
EnterId(cp);
cp := pointer(Malloc(sizeof(identifier)));	{tool}
with cp^ do begin
   name := @'TOOL';
   next := nil;
   klass := directive;
   drkind := drtool1;
   hasIFile := false;
   end; {with}
EnterId(cp);
cp := pointer(Malloc(sizeof(identifier)));	{usertool}
with cp^ do begin
   name := @'USERTOOL';
   next := nil;
   klass := directive;
   drkind := drtool2;
   hasIFile := false;
   end; {with}
EnterId(cp);
cp := pointer(Malloc(sizeof(identifier)));	{vector}
with cp^ do begin
   name := @'VECTOR';
   next := nil;
   klass := directive;
   drkind := drvector;
   hasIFile := false;
   end; {with}
EnterId(cp);
cp := pointer(Malloc(sizeof(identifier)));	{maxint}
with cp^ do begin
   name := @'MAXINT';
   idtype := intptr;
   next := nil;
   values.ival := maxint;
   klass := konst;
   hasIFile := false;
   end; {with}
EnterId(cp);
cp := pointer(Malloc(sizeof(identifier)));	{maxint4}
with cp^ do begin
   name := @'MAXINT4';
   idtype := longptr;
   next := nil;
   values.valp := pointer(Malloc(constantRec_longC));
   values.valp^.lval := 2147483647;
   values.valp^.cclass := longC;
   klass := konst;
   hasIFile := false;
   end; {with}
EnterId(cp);
for i := 3 to 4 do begin 			{input,output}
   cp := pointer(Malloc(sizeof(identifier)));
   with cp^ do begin
      name := na[i];
      idtype := textptr;
      klass := varsm;
      vkind := actual;
      next := nil;
      vlev := 1;
      vcontvar := false;
      vrestrict := false;
      fromUses := false;
      hasIFile := true;
      end; {with}
   EnterId(cp);
   if i = 3 then inptr := cp else outptr := cp;
   end; {with}
cp := pointer(Malloc(sizeof(identifier)));	{erroroutput}
with cp^ do begin
   name := @'ERROROUTPUT';
   idtype := textptr;
   klass := varsm;
   vkind := actual;
   next := nil;
   vlev := 1;
   vcontvar := false;
   vrestrict := false;
   fromUses := false;
   hasIFile := true;
   end; {with}
EnterId(cp);
erroroutputptr := cp;
for i := 5 to 23 do begin
   cp := pointer(Malloc(sizeof(identifier)));	{std procs}
   with cp^ do begin
      name := na[i];
      idtype := nil;
      next := nil;
      key := i-4;
      klass := proc;
      pfdeckind := standard;
      hasIFile := false;
      end; {with}
   EnterId(cp)
   end; {with}
for i := 24 to 40 do begin
   cp := pointer(Malloc(sizeof(identifier)));	{std funcs}
   with cp^ do begin
      name := na[i];
      idtype := nil;
      next := nil;
      key := i-23;
      klass := func;
      pfdeckind := standard;
      hasIFile := false;
      end; {with}
   EnterId(cp);
   end; {with}
for i := 41 to 50 do begin
   cp := pointer(Malloc(sizeof(identifier)));	{more std procs}
   with cp^ do begin
      name := na[i];
      idtype := nil;
      next := nil;
      key := i-21;
      klass := proc;
      pfdeckind := standard;
      hasIFile := false;
      end; {with}
   EnterId(cp)
   end; {with}
for i := 51 to 77 do begin
   cp := pointer(Malloc(sizeof(identifier)));	{more std funcs}
   with cp^ do begin
      name := na[i];
      idtype := nil;
      next := nil;
      key := i-33;
      klass := func;
      pfdeckind := standard;
      hasIFile := false;
      end; {with}
   EnterId(cp);
   end; {with}
end; {EntStdNames}


procedure EnterUndecl;

{ enter fake identifiers for use when identifiers are		}
{ undeclared							}

begin {EnterUndecl}
utypptr := pointer(Malloc(sizeof(identifier)));	
with utypptr^ do begin
   name := @'  ';
   idtype := nil;
   klass := types;
   hasIFile := false;
   end; {with}
ucstptr := pointer(Malloc(sizeof(identifier)));	
with ucstptr^ do begin
   name := @'  ';
   idtype := nil;
   next := nil;
   values.ival := 0;
   klass := konst;
   hasIFile := false;
   end; {with}
uvarptr := pointer(Malloc(sizeof(identifier)));	
with uvarptr^ do begin
   name := @'  ';
   idtype := nil;
   vkind := actual;
   next := nil;
   vlev := 0;
   vlabel := 1;
   vcontvar := false;
   vrestrict := false;
   klass := varsm;
   fromUses := false;
   hasIFile := false;
   end; {with}
ufldptr := pointer(Malloc(sizeof(identifier)));	
with ufldptr^ do begin
   name := @'  ';
   idtype := nil;
   next := nil;
   fldaddr := 0;
   klass := field;
   hasIFile := false;
   end; {with}
uprcptr := pointer(Malloc(sizeof(identifier)));	
with uprcptr^ do begin
   name := @'  ';
   idtype := nil;
   pfdirective := drnone;
   next := nil;
   pflev := 0;
   pfname := GenLabel;
   fldvar := false;
   klass := proc;
   pfdeckind := declared;
   pfkind := actual;
   hasIFile := false;
   end; {with}
ufctptr := pointer(Malloc(sizeof(identifier)));	
with ufctptr^ do begin
   name := @'  ';
   idtype := nil;
   next := nil;
   pfdirective := drnone;
   pflev := 0;
   pfname := GenLabel;
   klass := func;
   pfdeckind := declared;
   pfkind := actual;
   hasIFile := false;
   end; {with}
dummyString := pointer(Malloc(sizeof(structure)));	
with dummyString^ do begin
   size := 2;
   ispacked := pkpacked;
   form := subrange;
   hasSFile := false;
   rangetype := intptr;
   min := 1;
   max := 2;
   end; {with}
end; {EnterUndecl}
 

procedure GenSymbols {sym: ctp; doGlobals: integer};

{ generate the symbol table                                     }
{								}
{ Notes: Defined as extern in Native.pas			}

type
   tpPtr = ^tpRecord;			{type list displacements}
   tpRecord = record
      next: tpPtr;
      tp: stp;
      disp: integer;
      end;

var
   tpList,tp2: tpPtr;			{type displacement list}


   function GetTypeDisp (tp: stp): integer;

   { Look for an existing entry for this type			}
   {								}
   { Parameters:						}
   {    tp - type to look for					}
   {								}
   { Returns: Disp to a variable of the same type, or 0 if	}
   {    there is no such entry.					}
   {								}
   { Notes: If the type is not in the type list, it is entered	}
   {   in the list by this call.				}

   var
      tp1, tp2: tpPtr;			{used to manipulate type list}

   begin {GetTypeDisp}
   tp1 := tpList;			{look for the type}
   tp2 := nil;
   while tp1 <> nil do
      if tp1^.tp = tp then begin
         tp2 := tp1;
         tp1 := nil;
         end {if}
      else
         tp1 := tp1^.next;
   if tp2 <> nil then            
      GetTypeDisp := tp2^.disp		{return disp to entry}
   else begin
      GetTypeDisp := 0;			{no entry}
      new(tp1);				{create a new entry}
      tp1^.next := tpList;
      tpList := tp1;
      tp1^.tp := tp;
      tp1^.disp := symLength;
      end; {else}
   end; {GetTypeDisp}


   procedure GenSymbol (sym: ctp; maybeLast: boolean);

   { generate one symbol entry					}
   {								}
   { parameters:						}
   {    sym - identifier to generate				}
   {    maybelast - true if this may be the last node in a	}
   {       record or object tree, false if not; unused for	}
   {       variables						}

   var
      disp: integer;			{disp to symbol of same type}


      procedure WriteAddress (sym: ctp);

      { Write the address and DP flag				}
      {								}
      { parameters:						}
      {    sym - identifier					}
      {    maybeLast - true if this might be the last entry,	}
      {       else false					}

      var
         size: longint;			{used to break apart longints}

      begin {WriteAddress}
      if sym^.klass = field then begin
         size := sym^.fldaddr;
         CnOut2(long(size).lsw);
         CnOut2(long(size).msw);
         CnOut(ord(not(maybeLast and (sym^.rlink = nil))));
         end {if}
      else if sym^.vlev = 1 then begin
         RefName(sym^.name, 0, 4, 0);
         CnOut(1);
         end {else if}
      else begin
         CnOut2(localLabel[sym^.vlabel]);
         CnOut2(0);
         CnOut(0);
         end; {else}
      end; {WriteAddress}


      procedure WriteName (sym: ctp);

      { Write the name field for an identifier			}
      {								}
      { parameters:						}
      {    sym - identifier					}

      var
         len: 0..maxint;		{string length}
         j: 0..maxint;			{loop/index variable}

      begin {WriteName}
      Purge;				{generate the address of the variable  }
      Out(235); Out(4);			{ name                                 }
      LabelSearch(maxLabel, 4, 0, 0);
      if stringsize <> 0 then begin
         Out(129);
         Out2(stringsize); Out2(0);
         Out(1);
         end; {if}
      Out(0);
      len := length(sym^.name^);	{place the name in the string buffer}
      if maxstring-stringsize >= len+1 then begin
         stringspace[stringsize+1] := chr(len);
         for j := 1 to len do
            stringspace[j+stringsize+1] := sym^.name^[j];
         stringsize := stringsize+len+1;
         end {if}
      else
         Error(132);
      end; {WriteName}


      procedure WriteScalarType (tp: stp; modifiers, subscripts: integer);

      { Write a scalar type and subscipt field			}
      {								}
      { parameters:						}
      {    tp - type pointer					}
      {    modifiers - value to or with the type code		}
      {    subscripts - number of subscripts			}

      var
         val: integer;			{type value}

      begin {WriteScalarType}
      case GetType(tp, tp^.isPacked) of
	 cgByte:	val := $40;
         cgUByte:	val := $00;
         cgWord:	val := $01;
         cgUWord:	val := $41;
         cgLong:	val := $02;
         cgULong:	val := $42;
         cgReal:	val := $03;
         cgDouble:	val := $04;
         cgComp:	val := $0A;
         cgExtended:	val := $05;
         otherwise:	val := $01;
         end; {case}
      CnOut(val | modifiers);		{write the format byte}
      CnOut2(subscripts);		{write the # of subscripts}
      end; {WriteScalarType}


      procedure WritePointerType (tp: stp; subscripts: integer);

      { write a pointer type field				}
      {								}
      { parameters:						}
      {    tp - pointer type					}
      {    subscripts - number of subscript fields		}

      begin {WritePointerType}
      case tp^.eltype^.form of
         scalar:	WriteScalarType(tp^.eltype, $80, subscripts);
         subrange:	WriteScalarType(tp^.eltype^.rangetype, $80, subscripts);
         otherwise:	begin
        		CnOut(11);
        		CnOut2(subscripts);
                        end;
         end; {case}
      end; {WritePointerType}


      procedure ExpandPointerType (tp: stp); forward;
      

      procedure ExpandRecordType (tp: stp);

      { write the type entries for a record or object		}
      {								}
      { parameters:						}
      {    tp - record/object type				}

      var
         ip: ctp;			{used to trace the field list}

      begin {ExpandRecordType}
      if tp^.form = records then
         ip := tp^.fstfld
      else
         ip := tp^.objfld;
      GenSymbol(ip, true);
      end; {ExpandRecordType}


      procedure WriteArrays (tp: stp);

      { handle an array type					}
      {								}
      { parameters:						}
      {    tp - array type					}

      var
         count: unsigned;		{# of subscripts}
         lmin, lmax: addrrange;		{index range}
         tp2: stp;			{used to trace array type list}

      begin {WriteArrays}
      count := 0;			{count the subscripts}
      tp2 := tp;
      while tp2^.form = arrays do begin
         count := count+1;
         tp2 := tp2^.aeltype;
         end; {while}
      if tp2^.form = scalar then	{write the type code}
         if GetType(tp2, tp^.isPacked) in [cgByte,cgUByte] then begin
            count := count-1;
            CnOut(6);
            CnOut2(count);
            end {if}
         else
            WriteScalarType(tp2, 0, count)
      else if tp2^.form = subrange then
         WriteScalarType(tp2^.rangetype, 0, count)
      else if tp2^.form = pointerStruct then
         WritePointerType(tp2, count)
      else begin
         CnOut(12);
         CnOut2(count);
         end; {else if}
      while count <> 0 do begin		{write the subscript entries}
         CnOut2(0); CnOut2(0);
         GetBounds(tp, lmin, lmax);
         CnOut2(long(lmin).lsw); CnOut2(long(lmin).msw);
         CnOut2(long(lmax).lsw); CnOut2(long(lmax).msw);
         symLength := symLength+12;
         tp := tp^.aeltype;
         count := count-1;
         end; {while}
      if tp2^.form = pointerStruct then	{expand complex types}
         ExpandPointerType(tp2)
      else if tp2^.form in [records,objects] then
         ExpandRecordType(tp2);
      end; {WriteArrays}


      procedure ExpandPointerType {tp: stp};

      { write the type entries for complex pointer types	}
      {								}
      { parameters:						}
      {    tp - pointer type					}

      var
	 disp: integer;			{disp to symbol of same type}

      begin {ExpandPointerType}
      if tp^.eltype <> nil then
	 if tp^.eltype^.form in [pointerStruct,arrays,records,objects] then
            begin
            symLength := symLength+12;
            CnOut2(0); CnOut2(0);
            CnOut2(0); CnOut2(0);
            CnOut(0);
	    case tp^.eltype^.form of
               pointerStruct:	begin
         		   	WritePointerType(tp^.eltype, 0);
                           	ExpandPointerType(tp^.eltype);
                           	end;
               arrays:		WriteArrays(tp^.aeltype);
               records,
               objects:		begin
				disp := GetTypeDisp(tp^.eltype);
                                if disp = 0 then begin
                                   if tp^.eltype^.form = records then
        		   	      CnOut(12)
                                   else
        		   	      CnOut(14);
        		   	   CnOut2(0);
                           	   ExpandRecordType(tp^.eltype);
                                   end {if}
                                else begin
        		   	   CnOut(13);
        		   	   CnOut2(disp);
                                   end; {else}
                           	end;
               end; {case}
            end; {if}
      end; {ExpandPointerType}


   begin {GenSymbol}
   if sym^.llink <> nil then
      GenSymbol(sym^.llink, false);

   if sym^.klass in [varsm,field] then
      if sym^.idtype <> nil then
         if sym^.idtype^.form in
            [scalar,subrange,pointerStruct,arrays,records,objects] then begin
	    WriteName(sym);		{write the name field}
	    WriteAddress(sym);		{write the address field}
	    case sym^.idtype^.form of
               scalar:		WriteScalarType(sym^.idtype, 0, 0);
               subrange:	WriteScalarType(sym^.idtype^.rangetype, 0, 0);
               pointerStruct:	begin
         			WritePointerType(sym^.idtype, 0);
                        	ExpandPointerType(sym^.idtype);
                        	end;
               arrays:		WriteArrays(sym^.idtype);
               records,
               objects:		begin
				disp := GetTypeDisp(sym^.idtype);
                        	if disp = 0 then begin
                                   if sym^.idtype^.form = records then
        			      CnOut(12)
                                   else
        			      CnOut(14);
        			   CnOut2(0);
                        	   ExpandRecordType(sym^.idtype);
                        	   end {if}
                        	else begin
        			   CnOut(13);
        			   CnOut2(disp);
                        	   end; {else}
                        	end;
               end; {case}
	    symLength := symLength+12;	{update length of symbol table}
            end; {if}

   if sym^.rlink <> nil then
      GenSymbol(sym^.rlink, maybeLast);
   end; {GenSymbol}


begin {GenSymbols}
tpList := nil;				{no types so far}
if sym <> nil then			{generate the symbols}
   GenSymbol(sym, false);
while tpList <> nil do begin		{dispose of type list}
   tp2 := tpList;
   tpList := tp2^.next;
   dispose(tp2);
   end; {while}
end; {GenSymbols}


procedure GetBounds {fsp: stp; var fmin,fmax: longint};

{ get internal bounds of subrange or scalar type		}
{ (assume fsp<>longptr and fsp<>realptr)			}
{								}
{ parameters:							}
{    fsp - type to get the bounds for				}
{    fmin, fmax - (output) bounds				}

begin {GetBounds}
fmin := 0;
fmax := 0;
if fsp <> nil then
with fsp^ do
   if form = subrange then begin
      fmin := min;
      fmax := max;
      end {if}
   else if fsp = charptr then begin
      fmin := ordminchar;
      fmax := ordmaxchar;
      end {else if}
   else if fsp = intptr then begin
      fmin := -maxint;
      fmax := maxint;
      end {else if}
   else if fsp = byteptr then
      fmax := 255
   else if fconst <> nil then
      fmax := fconst^.values.ival
end; {GetBounds}
 

function GetType {tp: stp; isPacked: boolean): baseTypeEnum};

{ find the base type for a variable type			}
{								}
{ parameters:							}
{    tp - variable type						}
{    isPacked - is the variable packed?				}
{								}
{ returns: Variable base type					}

begin {GetType}
case tp^.form of
   scalar:
      if tp=intptr then GetType := cgWord
      else if (tp=boolptr) or (tp=charptr) then
	 if isPacked then
            GetType := cgUByte
	 else
            GetType := cgUWord
      else if tp^.scalkind = declared then GetType := cgUWord
      else if tp=realptr then GetType := cgReal
      else if tp=byteptr then GetType := cgUByte
      else if tp=longptr then GetType := cgLong
      else if tp=doubleptr then GetType := cgDouble
      else if tp=extendedptr then GetType := cgExtended
      else if tp=compptr then GetType := cgComp
      else begin
	 GetType := cgWord;
	 Error(113);
	 end; {else}
   subrange: begin
      if tp^.rangetype = intptr then
	 if tp^.min >= 0 then
            GetType := cgUWord
	 else
            GetType := cgWord
      else if tp^.rangetype = longptr then
	 if tp^.min >= 0 then
            GetType := cgULong
	 else
            GetType := cgLong
      else
	 GetType := GetType(tp^.rangetype, isPacked);
      end;
   pointerStruct,
   files,
   objects:
      GetType := cgULong;
   power:
      GetType := cgSet;
   arrays,
   records:
      GetType := cgString;
   otherwise: begin
      GetType := cgWord;
      Error(113);
      end;
   end; {case}
end; {GetType}


function IsReal {fsp: stp): boolean};

{ determine if fsp is one of the real types			}
{								}
{ parameters:							}
{    fsp - structure to check					}
{								}
{ Returns: True if fsp is a real, else false			}

begin {IsReal}
if fsp = realptr then
   IsReal := true
else if fsp = doubleptr then
   IsReal := true
else if fsp = extendedptr then
   IsReal := true
else if fsp = compptr then
   IsReal := true
else          
   IsReal := false;
end; {IsReal}


function IsString {fsp: stp): boolean};

{ determine if fsp is a string					}
{								}
{ parameters:							}
{    fsp - structure to check					}
{								}
{ Returns: True if fsp is a string, else false			}

var
   low,hi: longint;			{range of index variable}

begin {IsString}
IsString := false;
if fsp <> nil then
   with fsp^ do
      if form = arrays then
         if aeltype = charptr then
	    if CompTypes(inxtype,intptr) then
	       if ispacked = pkpacked then
	          if inxtype = nil then
	             {string constants have nil index types}
	             IsString := true
	          else begin
	             GetBounds(inxtype,low,hi);
	             IsString := ((low = 1) or ((low = 0) and (not iso)))
		        and (hi > 1);
	             end; {else}
end; {IsString}


function StrLen {tp: stp): integer};

{ Find the length of a string variable (for library calls)	}
{								}
{ parameters:							}
{    tp - string variable					}
{								}
{ Returns: length of the string					}

var
   low,hi: longint;			{range of index variable}

begin {StrLen}
if tp <> nil then
   with tp^ do 
      if (inxType = dummyString) or (inxType = nil) then
	 StrLen := long(size).lsw
      else begin
	 GetBounds(inxType,low,hi);
	 if low = 0 then
	    StrLen := -long(hi).lsw
	 else
	    StrLen := long(hi).lsw;
	 end; {else}
end; {StrLen}

end.

{$append 'symbols.asm'}
\ No newline at end of file
+{$optimize -1}
+{------------------------------------------------------------}
+{							     }
+{  SymbolTables						     }
+{							     }
+{  This unit implements the symbol table for ORCA/Pascal.    }
+{  Also included are many of the declarations that tie the   }
+{  various units together.  The specialized memory manager   }
+{  used to make symbol table disposal more efficient is also }
+{  included in this module.				     }
+{							     }
+{  The interfaces for the scanner and object module output   }
+{  units are in this unit.  This eliminates the need for a   }
+{  common module that would have most of the pertinant	     }
+{  symbol table type information.			     }
+{							     }
+{  By Mike Westerfield					     }
+{							     }
+{  Copyright August 1987 				     }
+{  By the Byte Works, Inc.				     }
+{							     }
+{------------------------------------------------------------}
+
+unit SymbolTables;
+
+{$segment 'Pascal2'}
+
+interface
+
+{$libprefix '0/obj/'}
+
+uses PCommon, CGI, CGC, ObjOut, Native, Scanner;
+
+{---------------------------------------------------------------}
+
+var
+					{pointers:}
+					{---------}
+   intptr,realptr,charptr,
+   byteptr,longptr,compptr,
+   doubleptr,extendedptr,stringptr,
+   boolptr,nilptr,textptr: stp;		{pointers to entries of standard ids}
+   externIdentifier: ctp; 		{extern ID entry}
+   forwardIdentifier: ctp;		{forward ID entry}
+   utypptr,ucstptr,uvarptr,
+   ufldptr,uprcptr,ufctptr,		{pointers to entries for undeclared ids}
+   fwptr: ctp;				{head of chain for forw decl type ids}
+   inptr,outptr,erroroutputptr: ctp;	{standard I/O}
+   dummyString: stp;			{index entry for string constants}
+
+{---------------------------------------------------------------}
+
+function CompObjects (fsp1, fsp2: stp): boolean;
+
+{ See if two objects are assignment compatible			}
+{								}
+{ parameters:							}
+{    fsp1 - object to assign to					}
+{    fsp2 - object to assign					}
+{								}
+{ Returns: True if the structures are compatible, else false	}
+
+
+function CompTypes (fsp1, fsp2: stp): boolean;
+
+{ determine if two structures are type compatible		}
+{								}
+{ parameters:							}
+{    fsp1, fsp2 - structures to check				}
+{								}
+{ Returns: True if the structures are compatible, else false	}
+
+
+procedure EnterStdTypes;
+
+{ enter the base types						}
+
+
+procedure EntStdNames;
+
+{ enter standard names in the program symbol table		}
+
+
+procedure EnterId (fcp: ctp); extern;
+
+{ Enter an identifier at the current stack frame level		}
+{								}
+{ parameters:							}
+{    fcp - identifier to enter					}
+
+
+procedure EnterUndecl;
+
+{ enter fake identifiers for use when identifiers are		}
+{ undeclared							}
+
+
+procedure GenSymbols (sym: ctp; doGlobals: integer);
+
+{ generate the symbol table                                     }
+{								}
+{ Notes: Defined as extern in Native.pas			}
+
+
+procedure GetBounds (fsp: stp; var fmin,fmax: longint);
+
+{ get internal bounds of subrange or scalar type		}
+{ (assume fsp<>longptr and fsp<>realptr)			}
+{								}
+{ parameters:							}
+{    fsp - type to get the bounds for				}
+{    fmin, fmax - (output) bounds				}
+
+
+function GetType (tp: stp; isPacked: boolean): baseTypeEnum;
+
+{ find the base type for a variable type			}
+{								}
+{ parameters:							}
+{    tp - variable type						}
+{    isPacked - is the variable packed?				}
+{								}
+{ returns: Variable base type					}
+
+
+function IsReal (fsp: stp): boolean;
+
+{ determine if fsp is one of the real types			}
+{								}
+{ parameters:							}
+{    fsp - structure to check					}
+{								}
+{ Returns: True if fsp is a real, else false			}
+
+
+function IsString (fsp: stp): boolean;
+
+{ determine if fsp is a string					}
+{								}
+{ parameters:							}
+{    fsp - structure to check					}
+{								}
+{ Returns: True if fsp is a string, else false			}
+
+
+procedure SearchSection (fcp: ctp; var fcpl: ctp); extern;
+
+{ find record fields and forward declared procedure id's	}
+{								}
+{ parameters:							}
+{    fcp - top of identifier tree				}
+{    fcpl - (outout) identifier					}
+
+
+procedure SearchId (fidcls: setofids; var fcp: ctp); extern;
+
+{ find an identifier						}
+{								}
+{ parameters:							}
+{    fidcls - kinds of identifiers to look for			}
+{    fcp - (output) identifier found				}
+
+
+function StrLen (tp: stp): integer;
+
+{ Find the length of a string variable (for library calls)	}
+{								}
+{ parameters:							}
+{    tp - string variable					}
+{								}
+{ Returns: length of the string					}
+
+{---------------------------------------------------------------}
+
+implementation
+
+{---------------------------------------------------------------}
+
+function CompObjects {fsp1, fsp2: stp): boolean};
+
+{ See if two objects are assignment compatible			}
+{								}
+{ parameters:							}
+{    fsp1 - object to assign to					}
+{    fsp2 - object to assign					}
+{								}
+{ Returns: True if the structures are compatible, else false	}
+
+begin {CompObjects}
+CompObjects := false;
+if fsp1^.form = objects then begin
+  if fsp2^.form = objects then begin
+    while fsp2 <> nil do begin
+      if fsp1 = fsp2 then begin
+	fsp2 := nil;
+	CompObjects := true;
+	end {if}
+      else
+	fsp2 := fsp2^.objparent;
+      end; {while}
+    end {if}
+  else if fsp2 = nilptr then
+    CompObjects := true;
+  end; {if}
+end; {CompObjects}
+
+
+function CompTypes {fsp1,fsp2: stp): boolean};
+
+{ determine if two structures are type compatible		}
+{								}
+{ parameters:							}
+{    fsp1, fsp2 - structures to check				}
+{								}
+{ Returns: True if the structures are compatible, else false	}
+
+var
+   lmin1,lmin2: integer;
+   comp: boolean;
+
+begin {CompTypes}
+if fsp1 = fsp2 then
+   CompTypes := true
+else if (fsp1 <> nil) and (fsp2 <> nil) then begin
+   if fsp1^.form = subrange then begin
+      if fsp2^.form = subrange then
+	 CompTypes := CompTypes(fsp1^.rangetype,fsp2^.rangetype)
+      else
+	 CompTypes := CompTypes(fsp1^.rangetype,fsp2);
+      end {if}
+   else if fsp2^.form = subrange then
+      CompTypes := CompTypes(fsp1,fsp2^.rangetype)
+   else if fsp1 = byteptr then
+      CompTypes := CompTypes(fsp2,intptr)
+   else if fsp2 = byteptr then
+      CompTypes := CompTypes(fsp1,intptr)
+   else if fsp1^.form = fsp2^.form then begin
+      if fsp1^.form = power then
+	 CompTypes := CompTypes(fsp1^.elset,fsp2^.elset) and
+	    ((fsp1^.ispacked = pkeither) or (fsp2^.ispacked = pkeither) or
+	    (fsp1^.ispacked = fsp2^.ispacked))
+      else if fsp1^.form = arrays then begin
+	 comp := IsString(fsp1) and IsString(fsp2);
+	 if iso then
+	    comp := comp and (fsp1^.size = fsp2^.size);
+	 CompTypes := comp;
+	 end {else if}
+      else if fsp1^.form = pointerStruct then
+	 CompTypes := (fsp1 = nilptr) or (fsp2 = nilptr)
+      else
+	 CompTypes := IsReal(fsp1) and IsReal(fsp2);
+      end {else if}
+   else if fsp1^.form = objects then
+      CompTypes := fsp2 = nilptr
+   else if fsp2^.form = objects then
+      CompTypes := fsp1 = nilptr
+   else
+      CompTypes := false
+   end
+else
+   CompTypes := true
+end; {CompTypes}
+ 
+
+procedure EnterStdTypes;
+
+{ enter the base types						}
+
+begin {EnterStdTypes}
+byteptr := pointer(Malloc(sizeof(structure)));	{byte}
+with byteptr^ do begin
+   size := bytesize;
+   ispacked := pkunpacked;
+   form := scalar;
+   scalkind := standard;
+   hasSFile := false;
+   end; {with}
+intptr := pointer(Malloc(sizeof(structure)));	{integer}
+with intptr^ do begin
+   size := intsize;
+   ispacked := pkunpacked;
+   form := scalar;
+   scalkind := standard;
+   hasSFile := false;
+   end; {with}
+longptr := pointer(Malloc(sizeof(structure)));	{long}
+with longptr^ do begin
+   size := longsize;
+   ispacked := pkunpacked;
+   form := scalar;
+   scalkind := standard;
+   hasSFile := false;
+   end; {with}
+realptr := pointer(Malloc(sizeof(structure)));	{real}
+with realptr^ do begin
+   size := realsize;
+   ispacked := pkunpacked;
+   form := scalar;
+   scalkind := standard;
+   hasSFile := false;
+   end; {with}
+doubleptr := pointer(Malloc(sizeof(structure))); {double}
+with doubleptr^ do begin
+   size := doublesize;
+   ispacked := pkunpacked;
+   form := scalar;
+   scalkind := standard;
+   hasSFile := false;
+   end; {with}
+compptr := pointer(Malloc(sizeof(structure))); {comp}
+with compptr^ do begin
+   size := compsize;
+   ispacked := pkunpacked;
+   form := scalar;
+   scalkind := standard;
+   hasSFile := false;
+   end; {with}
+extendedptr := pointer(Malloc(sizeof(structure))); {extended}
+with extendedptr^ do begin
+   size := extendedsize;
+   ispacked := pkunpacked;
+   form := scalar;
+   scalkind := standard;
+   hasSFile := false;
+   end; {with}
+charptr := pointer(Malloc(sizeof(structure)));	{char}
+with charptr^ do begin
+   size := charsize;
+   ispacked := pkunpacked;
+   form := scalar;
+   scalkind := standard;
+   hasSFile := false;
+   end; {with}
+stringptr := pointer(Malloc(sizeof(structure))); {string}
+with stringptr^ do begin
+   size := packedcharsize*2;
+   ispacked := pkpacked;
+   form := arrays;
+   hasSFile := false;
+   aeltype := charptr;
+   inxtype := pointer(Malloc(sizeof(structure)));
+   with inxtype^ do begin
+      size := intsize;
+      form := subrange;
+      rangetype := intptr;
+      min := 1;
+      max := 2;
+      end; {with}
+   end; {with}
+boolptr := pointer(Malloc(sizeof(structure)));	{bool}
+with boolptr^ do begin
+   size := boolsize;
+   ispacked := pkunpacked;
+   form := scalar;
+   scalkind := declared;
+   hasSFile := false;
+   end; {with}
+nilptr := pointer(Malloc(sizeof(structure)));	{nil}
+with nilptr^ do begin
+   eltype := nil;
+   size := ptrsize;
+   ispacked := pkunpacked;
+   form := pointerStruct;
+   hasSFile := false;
+   end; {with}
+textptr := pointer(Malloc(sizeof(structure)));	{text}
+with textptr^ do begin
+   filtype := charptr;
+   filsize := packedcharsize*2;
+   size := ptrsize;
+   ispacked := pkunpacked;
+   form := files;
+   hasSFile := true;
+   end; {with}
+end; {EnterStdTypes}
+
+
+procedure EntStdNames;
+
+{ enter standard names in the program symbol table		}
+
+var
+   cp,cp1: ctp;
+   i: integer;
+
+begin {EntStdNames}
+cp := pointer(Malloc(sizeof(identifier)));	{integer}
+with cp^ do begin
+   name := @'INTEGER';
+   idtype := intptr;
+   klass := types;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);
+cp := pointer(Malloc(sizeof(identifier)));	{byte}
+with cp^ do begin
+   name := @'BYTE';
+   idtype := byteptr;
+   klass := types;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);  
+cp := pointer(Malloc(sizeof(identifier)));	{longint}
+with cp^ do begin
+   name := @'LONGINT';
+   idtype := longptr;
+   klass := types;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);  
+cp := pointer(Malloc(sizeof(identifier)));	{real}
+with cp^ do begin
+   name := @'REAL';
+   idtype := realptr;
+   klass := types;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);  
+cp := pointer(Malloc(sizeof(identifier)));	{double}
+with cp^ do begin
+   name := @'DOUBLE';
+   idtype := doubleptr;
+   klass := types;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);  
+cp := pointer(Malloc(sizeof(identifier)));	{comp}
+with cp^ do begin
+   name := @'COMP';
+   idtype := compptr;
+   klass := types;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);  
+cp := pointer(Malloc(sizeof(identifier)));	{extended}
+with cp^ do begin
+   name := @'EXTENDED';
+   idtype := extendedptr;
+   klass := types;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);  
+cp := pointer(Malloc(sizeof(identifier)));	{char}
+with cp^ do begin
+   name := @'CHAR';
+   idtype := charptr;
+   klass := types;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);  
+cp := pointer(Malloc(sizeof(identifier)));	{boolean}
+with cp^ do begin
+   name := @'BOOLEAN';
+   idtype := boolptr;
+   klass := types;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);  
+cp := pointer(Malloc(sizeof(identifier)));	{text}
+with cp^ do begin
+   name := @'TEXT';
+   idtype := textptr;
+   klass := types;
+   hasIFile := true;
+   end; {with}
+EnterId(cp);  
+cp1 := nil;
+for i := 1 to 2 do begin
+   cp := pointer(Malloc(sizeof(identifier)));	{false,true}
+   with cp^ do begin
+      name := na[i];
+      idtype := boolptr;
+      next := cp1;
+      values.ival := i-1;
+      klass := konst;
+      hasIFile := false;
+      end; {with}
+   EnterId(cp);
+   cp1 := cp
+   end; {with}
+boolptr^.fconst := cp;
+cp := pointer(Malloc(sizeof(identifier)));	{forward}
+with cp^ do begin
+   name := @'FORWARD';
+   next := nil;
+   klass := directive;
+   drkind := drforw;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);
+forwardIdentifier := cp;
+cp := pointer(Malloc(sizeof(identifier)));	{extern}
+with cp^ do begin
+   name := @'EXTERN';
+   next := nil;
+   klass := directive;
+   drkind := drextern;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);
+externIdentifier := cp;
+cp := pointer(Malloc(sizeof(identifier)));	{external}
+with cp^ do begin
+   name := @'EXTERNAL';
+   next := nil;
+   klass := directive;
+   drkind := drextern;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);
+cp := pointer(Malloc(sizeof(identifier)));	{override}
+with cp^ do begin
+   name := @'OVERRIDE';
+   next := nil;
+   klass := directive;
+   drkind := droverride;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);
+cp := pointer(Malloc(sizeof(identifier)));	{prodos}
+with cp^ do begin
+   name := @'PRODOS';
+   next := nil;
+   klass := directive;
+   drkind := drprodos;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);
+cp := pointer(Malloc(sizeof(identifier)));	{tool}
+with cp^ do begin
+   name := @'TOOL';
+   next := nil;
+   klass := directive;
+   drkind := drtool1;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);
+cp := pointer(Malloc(sizeof(identifier)));	{usertool}
+with cp^ do begin
+   name := @'USERTOOL';
+   next := nil;
+   klass := directive;
+   drkind := drtool2;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);
+cp := pointer(Malloc(sizeof(identifier)));	{vector}
+with cp^ do begin
+   name := @'VECTOR';
+   next := nil;
+   klass := directive;
+   drkind := drvector;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);
+cp := pointer(Malloc(sizeof(identifier)));	{maxint}
+with cp^ do begin
+   name := @'MAXINT';
+   idtype := intptr;
+   next := nil;
+   values.ival := maxint;
+   klass := konst;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);
+cp := pointer(Malloc(sizeof(identifier)));	{maxint4}
+with cp^ do begin
+   name := @'MAXINT4';
+   idtype := longptr;
+   next := nil;
+   values.valp := pointer(Malloc(constantRec_longC));
+   values.valp^.lval := 2147483647;
+   values.valp^.cclass := longC;
+   klass := konst;
+   hasIFile := false;
+   end; {with}
+EnterId(cp);
+for i := 3 to 4 do begin 			{input,output}
+   cp := pointer(Malloc(sizeof(identifier)));
+   with cp^ do begin
+      name := na[i];
+      idtype := textptr;
+      klass := varsm;
+      vkind := actual;
+      next := nil;
+      vlev := 1;
+      vcontvar := false;
+      vrestrict := false;
+      fromUses := false;
+      hasIFile := true;
+      end; {with}
+   EnterId(cp);
+   if i = 3 then inptr := cp else outptr := cp;
+   end; {with}
+cp := pointer(Malloc(sizeof(identifier)));	{erroroutput}
+with cp^ do begin
+   name := @'ERROROUTPUT';
+   idtype := textptr;
+   klass := varsm;
+   vkind := actual;
+   next := nil;
+   vlev := 1;
+   vcontvar := false;
+   vrestrict := false;
+   fromUses := false;
+   hasIFile := true;
+   end; {with}
+EnterId(cp);
+erroroutputptr := cp;
+for i := 5 to 23 do begin
+   cp := pointer(Malloc(sizeof(identifier)));	{std procs}
+   with cp^ do begin
+      name := na[i];
+      idtype := nil;
+      next := nil;
+      key := i-4;
+      klass := proc;
+      pfdeckind := standard;
+      hasIFile := false;
+      end; {with}
+   EnterId(cp)
+   end; {with}
+for i := 24 to 40 do begin
+   cp := pointer(Malloc(sizeof(identifier)));	{std funcs}
+   with cp^ do begin
+      name := na[i];
+      idtype := nil;
+      next := nil;
+      key := i-23;
+      klass := func;
+      pfdeckind := standard;
+      hasIFile := false;
+      end; {with}
+   EnterId(cp);
+   end; {with}
+for i := 41 to 50 do begin
+   cp := pointer(Malloc(sizeof(identifier)));	{more std procs}
+   with cp^ do begin
+      name := na[i];
+      idtype := nil;
+      next := nil;
+      key := i-21;
+      klass := proc;
+      pfdeckind := standard;
+      hasIFile := false;
+      end; {with}
+   EnterId(cp)
+   end; {with}
+for i := 51 to 77 do begin
+   cp := pointer(Malloc(sizeof(identifier)));	{more std funcs}
+   with cp^ do begin
+      name := na[i];
+      idtype := nil;
+      next := nil;
+      key := i-33;
+      klass := func;
+      pfdeckind := standard;
+      hasIFile := false;
+      end; {with}
+   EnterId(cp);
+   end; {with}
+end; {EntStdNames}
+
+
+procedure EnterUndecl;
+
+{ enter fake identifiers for use when identifiers are		}
+{ undeclared							}
+
+begin {EnterUndecl}
+utypptr := pointer(Malloc(sizeof(identifier)));	
+with utypptr^ do begin
+   name := @'  ';
+   idtype := nil;
+   klass := types;
+   hasIFile := false;
+   end; {with}
+ucstptr := pointer(Malloc(sizeof(identifier)));	
+with ucstptr^ do begin
+   name := @'  ';
+   idtype := nil;
+   next := nil;
+   values.ival := 0;
+   klass := konst;
+   hasIFile := false;
+   end; {with}
+uvarptr := pointer(Malloc(sizeof(identifier)));	
+with uvarptr^ do begin
+   name := @'  ';
+   idtype := nil;
+   vkind := actual;
+   next := nil;
+   vlev := 0;
+   vlabel := 1;
+   vcontvar := false;
+   vrestrict := false;
+   klass := varsm;
+   fromUses := false;
+   hasIFile := false;
+   end; {with}
+ufldptr := pointer(Malloc(sizeof(identifier)));	
+with ufldptr^ do begin
+   name := @'  ';
+   idtype := nil;
+   next := nil;
+   fldaddr := 0;
+   klass := field;
+   hasIFile := false;
+   end; {with}
+uprcptr := pointer(Malloc(sizeof(identifier)));	
+with uprcptr^ do begin
+   name := @'  ';
+   idtype := nil;
+   pfdirective := drnone;
+   next := nil;
+   pflev := 0;
+   pfname := GenLabel;
+   fldvar := false;
+   klass := proc;
+   pfdeckind := declared;
+   pfkind := actual;
+   hasIFile := false;
+   end; {with}
+ufctptr := pointer(Malloc(sizeof(identifier)));	
+with ufctptr^ do begin
+   name := @'  ';
+   idtype := nil;
+   next := nil;
+   pfdirective := drnone;
+   pflev := 0;
+   pfname := GenLabel;
+   klass := func;
+   pfdeckind := declared;
+   pfkind := actual;
+   hasIFile := false;
+   end; {with}
+dummyString := pointer(Malloc(sizeof(structure)));	
+with dummyString^ do begin
+   size := 2;
+   ispacked := pkpacked;
+   form := subrange;
+   hasSFile := false;
+   rangetype := intptr;
+   min := 1;
+   max := 2;
+   end; {with}
+end; {EnterUndecl}
+ 
+
+procedure GenSymbols {sym: ctp; doGlobals: integer};
+
+{ generate the symbol table                                     }
+{								}
+{ Notes: Defined as extern in Native.pas			}
+
+type
+   tpPtr = ^tpRecord;			{type list displacements}
+   tpRecord = record
+      next: tpPtr;
+      tp: stp;
+      disp: integer;
+      end;
+
+var
+   tpList,tp2: tpPtr;			{type displacement list}
+
+
+   function GetTypeDisp (tp: stp): integer;
+
+   { Look for an existing entry for this type			}
+   {								}
+   { Parameters:						}
+   {    tp - type to look for					}
+   {								}
+   { Returns: Disp to a variable of the same type, or 0 if	}
+   {    there is no such entry.					}
+   {								}
+   { Notes: If the type is not in the type list, it is entered	}
+   {   in the list by this call.				}
+
+   var
+      tp1, tp2: tpPtr;			{used to manipulate type list}
+
+   begin {GetTypeDisp}
+   tp1 := tpList;			{look for the type}
+   tp2 := nil;
+   while tp1 <> nil do
+      if tp1^.tp = tp then begin
+         tp2 := tp1;
+         tp1 := nil;
+         end {if}
+      else
+         tp1 := tp1^.next;
+   if tp2 <> nil then            
+      GetTypeDisp := tp2^.disp		{return disp to entry}
+   else begin
+      GetTypeDisp := 0;			{no entry}
+      new(tp1);				{create a new entry}
+      tp1^.next := tpList;
+      tpList := tp1;
+      tp1^.tp := tp;
+      tp1^.disp := symLength;
+      end; {else}
+   end; {GetTypeDisp}
+
+
+   procedure GenSymbol (sym: ctp; maybeLast: boolean);
+
+   { generate one symbol entry					}
+   {								}
+   { parameters:						}
+   {    sym - identifier to generate				}
+   {    maybelast - true if this may be the last node in a	}
+   {       record or object tree, false if not; unused for	}
+   {       variables						}
+
+   var
+      disp: integer;			{disp to symbol of same type}
+
+
+      procedure WriteAddress (sym: ctp);
+
+      { Write the address and DP flag				}
+      {								}
+      { parameters:						}
+      {    sym - identifier					}
+      {    maybeLast - true if this might be the last entry,	}
+      {       else false					}
+
+      var
+         size: longint;			{used to break apart longints}
+
+      begin {WriteAddress}
+      if sym^.klass = field then begin
+         size := sym^.fldaddr;
+         CnOut2(long(size).lsw);
+         CnOut2(long(size).msw);
+         CnOut(ord(not(maybeLast and (sym^.rlink = nil))));
+         end {if}
+      else if sym^.vlev = 1 then begin
+         RefName(sym^.name, 0, 4, 0);
+         CnOut(1);
+         end {else if}
+      else begin
+         CnOut2(localLabel[sym^.vlabel]);
+         CnOut2(0);
+         CnOut(0);
+         end; {else}
+      end; {WriteAddress}
+
+
+      procedure WriteName (sym: ctp);
+
+      { Write the name field for an identifier			}
+      {								}
+      { parameters:						}
+      {    sym - identifier					}
+
+      var
+         len: 0..maxint;		{string length}
+         j: 0..maxint;			{loop/index variable}
+
+      begin {WriteName}
+      Purge;				{generate the address of the variable  }
+      Out(235); Out(4);			{ name                                 }
+      LabelSearch(maxLabel, 4, 0, 0);
+      if stringsize <> 0 then begin
+         Out(129);
+         Out2(stringsize); Out2(0);
+         Out(1);
+         end; {if}
+      Out(0);
+      len := length(sym^.name^);	{place the name in the string buffer}
+      if maxstring-stringsize >= len+1 then begin
+         stringspace[stringsize+1] := chr(len);
+         for j := 1 to len do
+            stringspace[j+stringsize+1] := sym^.name^[j];
+         stringsize := stringsize+len+1;
+         end {if}
+      else
+         Error(132);
+      end; {WriteName}
+
+
+      procedure WriteScalarType (tp: stp; modifiers, subscripts: integer);
+
+      { Write a scalar type and subscipt field			}
+      {								}
+      { parameters:						}
+      {    tp - type pointer					}
+      {    modifiers - value to or with the type code		}
+      {    subscripts - number of subscripts			}
+
+      var
+         val: integer;			{type value}
+
+      begin {WriteScalarType}
+      case GetType(tp, tp^.isPacked) of
+	 cgByte:	val := $40;
+         cgUByte:	val := $00;
+         cgWord:	val := $01;
+         cgUWord:	val := $41;
+         cgLong:	val := $02;
+         cgULong:	val := $42;
+         cgReal:	val := $03;
+         cgDouble:	val := $04;
+         cgComp:	val := $0A;
+         cgExtended:	val := $05;
+         otherwise:	val := $01;
+         end; {case}
+      CnOut(val | modifiers);		{write the format byte}
+      CnOut2(subscripts);		{write the # of subscripts}
+      end; {WriteScalarType}
+
+
+      procedure WritePointerType (tp: stp; subscripts: integer);
+
+      { write a pointer type field				}
+      {								}
+      { parameters:						}
+      {    tp - pointer type					}
+      {    subscripts - number of subscript fields		}
+
+      begin {WritePointerType}
+      case tp^.eltype^.form of
+         scalar:	WriteScalarType(tp^.eltype, $80, subscripts);
+         subrange:	WriteScalarType(tp^.eltype^.rangetype, $80, subscripts);
+         otherwise:	begin
+        		CnOut(11);
+        		CnOut2(subscripts);
+                        end;
+         end; {case}
+      end; {WritePointerType}
+
+
+      procedure ExpandPointerType (tp: stp); forward;
+      
+
+      procedure ExpandRecordType (tp: stp);
+
+      { write the type entries for a record or object		}
+      {								}
+      { parameters:						}
+      {    tp - record/object type				}
+
+      var
+         ip: ctp;			{used to trace the field list}
+
+      begin {ExpandRecordType}
+      if tp^.form = records then
+         ip := tp^.fstfld
+      else
+         ip := tp^.objfld;
+      GenSymbol(ip, true);
+      end; {ExpandRecordType}
+
+
+      procedure WriteArrays (tp: stp);
+
+      { handle an array type					}
+      {								}
+      { parameters:						}
+      {    tp - array type					}
+
+      var
+         count: unsigned;		{# of subscripts}
+         lmin, lmax: addrrange;		{index range}
+         tp2: stp;			{used to trace array type list}
+
+      begin {WriteArrays}
+      count := 0;			{count the subscripts}
+      tp2 := tp;
+      while tp2^.form = arrays do begin
+         count := count+1;
+         tp2 := tp2^.aeltype;
+         end; {while}
+      if tp2^.form = scalar then	{write the type code}
+         if GetType(tp2, tp^.isPacked) in [cgByte,cgUByte] then begin
+            count := count-1;
+            CnOut(6);
+            CnOut2(count);
+            end {if}
+         else
+            WriteScalarType(tp2, 0, count)
+      else if tp2^.form = subrange then
+         WriteScalarType(tp2^.rangetype, 0, count)
+      else if tp2^.form = pointerStruct then
+         WritePointerType(tp2, count)
+      else begin
+         CnOut(12);
+         CnOut2(count);
+         end; {else if}
+      while count <> 0 do begin		{write the subscript entries}
+         CnOut2(0); CnOut2(0);
+         GetBounds(tp, lmin, lmax);
+         CnOut2(long(lmin).lsw); CnOut2(long(lmin).msw);
+         CnOut2(long(lmax).lsw); CnOut2(long(lmax).msw);
+         symLength := symLength+12;
+         tp := tp^.aeltype;
+         count := count-1;
+         end; {while}
+      if tp2^.form = pointerStruct then	{expand complex types}
+         ExpandPointerType(tp2)
+      else if tp2^.form in [records,objects] then
+         ExpandRecordType(tp2);
+      end; {WriteArrays}
+
+
+      procedure ExpandPointerType {tp: stp};
+
+      { write the type entries for complex pointer types	}
+      {								}
+      { parameters:						}
+      {    tp - pointer type					}
+
+      var
+	 disp: integer;			{disp to symbol of same type}
+
+      begin {ExpandPointerType}
+      if tp^.eltype <> nil then
+	 if tp^.eltype^.form in [pointerStruct,arrays,records,objects] then
+            begin
+            symLength := symLength+12;
+            CnOut2(0); CnOut2(0);
+            CnOut2(0); CnOut2(0);
+            CnOut(0);
+	    case tp^.eltype^.form of
+               pointerStruct:	begin
+         		   	WritePointerType(tp^.eltype, 0);
+                           	ExpandPointerType(tp^.eltype);
+                           	end;
+               arrays:		WriteArrays(tp^.aeltype);
+               records,
+               objects:		begin
+				disp := GetTypeDisp(tp^.eltype);
+                                if disp = 0 then begin
+                                   if tp^.eltype^.form = records then
+        		   	      CnOut(12)
+                                   else
+        		   	      CnOut(14);
+        		   	   CnOut2(0);
+                           	   ExpandRecordType(tp^.eltype);
+                                   end {if}
+                                else begin
+        		   	   CnOut(13);
+        		   	   CnOut2(disp);
+                                   end; {else}
+                           	end;
+               end; {case}
+            end; {if}
+      end; {ExpandPointerType}
+
+
+   begin {GenSymbol}
+   if sym^.llink <> nil then
+      GenSymbol(sym^.llink, false);
+
+   if sym^.klass in [varsm,field] then
+      if sym^.idtype <> nil then
+         if sym^.idtype^.form in
+            [scalar,subrange,pointerStruct,arrays,records,objects] then begin
+	    WriteName(sym);		{write the name field}
+	    WriteAddress(sym);		{write the address field}
+	    case sym^.idtype^.form of
+               scalar:		WriteScalarType(sym^.idtype, 0, 0);
+               subrange:	WriteScalarType(sym^.idtype^.rangetype, 0, 0);
+               pointerStruct:	begin
+         			WritePointerType(sym^.idtype, 0);
+                        	ExpandPointerType(sym^.idtype);
+                        	end;
+               arrays:		WriteArrays(sym^.idtype);
+               records,
+               objects:		begin
+				disp := GetTypeDisp(sym^.idtype);
+                        	if disp = 0 then begin
+                                   if sym^.idtype^.form = records then
+        			      CnOut(12)
+                                   else
+        			      CnOut(14);
+        			   CnOut2(0);
+                        	   ExpandRecordType(sym^.idtype);
+                        	   end {if}
+                        	else begin
+        			   CnOut(13);
+        			   CnOut2(disp);
+                        	   end; {else}
+                        	end;
+               end; {case}
+	    symLength := symLength+12;	{update length of symbol table}
+            end; {if}
+
+   if sym^.rlink <> nil then
+      GenSymbol(sym^.rlink, maybeLast);
+   end; {GenSymbol}
+
+
+begin {GenSymbols}
+tpList := nil;				{no types so far}
+if sym <> nil then			{generate the symbols}
+   GenSymbol(sym, false);
+while tpList <> nil do begin		{dispose of type list}
+   tp2 := tpList;
+   tpList := tp2^.next;
+   dispose(tp2);
+   end; {while}
+end; {GenSymbols}
+
+
+procedure GetBounds {fsp: stp; var fmin,fmax: longint};
+
+{ get internal bounds of subrange or scalar type		}
+{ (assume fsp<>longptr and fsp<>realptr)			}
+{								}
+{ parameters:							}
+{    fsp - type to get the bounds for				}
+{    fmin, fmax - (output) bounds				}
+
+begin {GetBounds}
+fmin := 0;
+fmax := 0;
+if fsp <> nil then
+with fsp^ do
+   if form = subrange then begin
+      fmin := min;
+      fmax := max;
+      end {if}
+   else if fsp = charptr then begin
+      fmin := ordminchar;
+      fmax := ordmaxchar;
+      end {else if}
+   else if fsp = intptr then begin
+      fmin := -maxint;
+      fmax := maxint;
+      end {else if}
+   else if fsp = byteptr then
+      fmax := 255
+   else if fconst <> nil then
+      fmax := fconst^.values.ival
+end; {GetBounds}
+ 
+
+function GetType {tp: stp; isPacked: boolean): baseTypeEnum};
+
+{ find the base type for a variable type			}
+{								}
+{ parameters:							}
+{    tp - variable type						}
+{    isPacked - is the variable packed?				}
+{								}
+{ returns: Variable base type					}
+
+begin {GetType}
+case tp^.form of
+   scalar:
+      if tp=intptr then GetType := cgWord
+      else if (tp=boolptr) or (tp=charptr) then
+	 if isPacked then
+            GetType := cgUByte
+	 else
+            GetType := cgUWord
+      else if tp^.scalkind = declared then GetType := cgUWord
+      else if tp=realptr then GetType := cgReal
+      else if tp=byteptr then GetType := cgUByte
+      else if tp=longptr then GetType := cgLong
+      else if tp=doubleptr then GetType := cgDouble
+      else if tp=extendedptr then GetType := cgExtended
+      else if tp=compptr then GetType := cgComp
+      else begin
+	 GetType := cgWord;
+	 Error(113);
+	 end; {else}
+   subrange: begin
+      if tp^.rangetype = intptr then
+	 if tp^.min >= 0 then
+            GetType := cgUWord
+	 else
+            GetType := cgWord
+      else if tp^.rangetype = longptr then
+	 if tp^.min >= 0 then
+            GetType := cgULong
+	 else
+            GetType := cgLong
+      else
+	 GetType := GetType(tp^.rangetype, isPacked);
+      end;
+   pointerStruct,
+   files,
+   objects:
+      GetType := cgULong;
+   power:
+      GetType := cgSet;
+   arrays,
+   records:
+      GetType := cgString;
+   otherwise: begin
+      GetType := cgWord;
+      Error(113);
+      end;
+   end; {case}
+end; {GetType}
+
+
+function IsReal {fsp: stp): boolean};
+
+{ determine if fsp is one of the real types			}
+{								}
+{ parameters:							}
+{    fsp - structure to check					}
+{								}
+{ Returns: True if fsp is a real, else false			}
+
+begin {IsReal}
+if fsp = realptr then
+   IsReal := true
+else if fsp = doubleptr then
+   IsReal := true
+else if fsp = extendedptr then
+   IsReal := true
+else if fsp = compptr then
+   IsReal := true
+else          
+   IsReal := false;
+end; {IsReal}
+
+
+function IsString {fsp: stp): boolean};
+
+{ determine if fsp is a string					}
+{								}
+{ parameters:							}
+{    fsp - structure to check					}
+{								}
+{ Returns: True if fsp is a string, else false			}
+
+var
+   low,hi: longint;			{range of index variable}
+
+begin {IsString}
+IsString := false;
+if fsp <> nil then
+   with fsp^ do
+      if form = arrays then
+         if aeltype = charptr then
+	    if CompTypes(inxtype,intptr) then
+	       if ispacked = pkpacked then
+	          if inxtype = nil then
+	             {string constants have nil index types}
+	             IsString := true
+	          else begin
+	             GetBounds(inxtype,low,hi);
+	             IsString := ((low = 1) or ((low = 0) and (not iso)))
+		        and (hi > 1);
+	             end; {else}
+end; {IsString}
+
+
+function StrLen {tp: stp): integer};
+
+{ Find the length of a string variable (for library calls)	}
+{								}
+{ parameters:							}
+{    tp - string variable					}
+{								}
+{ Returns: length of the string					}
+
+var
+   low,hi: longint;			{range of index variable}
+
+begin {StrLen}
+if tp <> nil then
+   with tp^ do 
+      if (inxType = dummyString) or (inxType = nil) then
+	 StrLen := long(size).lsw
+      else begin
+	 GetBounds(inxType,low,hi);
+	 if low = 0 then
+	    StrLen := -long(hi).lsw
+	 else
+	    StrLen := long(hi).lsw;
+	 end; {else}
+end; {StrLen}
+
+end.
+
+{$append 'symbols.asm'}