From dbb32024b682042ce8ed2b4554dbf028141bc51d Mon Sep 17 00:00:00 2001
From: mikew50 <mikew50@aol.com>
Date: Sun, 11 Mar 2018 20:21:14 -0600
Subject: [PATCH] ORCA/Pascal 2.2 source from the Opus ][ CD

---
 LICENSE.txt    | 11 +++++++++++
 README.md      | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++
 backup         |  1 +
 call.pas       |  1 +
 cgc.asm        |  1 +
 cgc.macros     |  1 +
 cgc.pas        |  1 +
 cgi.asm        |  1 +
 cgi.comments   |  1 +
 cgi.pas        |  1 +
 count          |  1 +
 dag.asm        |  1 +
 dag.macros     |  1 +
 dag.pas        |  1 +
 gen.pas        |  1 +
 linkit         |  1 +
 make           |  1 +
 native.asm     |  1 +
 native.macros  |  1 +
 native.pas     |  1 +
 objout.asm     |  1 +
 objout.macros  |  1 +
 objout.pas     |  1 +
 parser.pas     |  1 +
 pascal.notes   |  1 +
 pascal.pas     |  1 +
 pascal.rez     |  1 +
 pcommon.asm    |  1 +
 pcommon.macros |  1 +
 pcommon.pas    |  1 +
 scanner.asm    |  1 +
 scanner.macros |  1 +
 scanner.pas    |  1 +
 smac           |  1 +
 symbols.asm    |  1 +
 symbols.macros |  1 +
 symbols.pas    |  1 +
 37 files changed, 98 insertions(+)
 create mode 100644 LICENSE.txt
 create mode 100644 README.md
 create mode 100755 backup
 create mode 100755 call.pas
 create mode 100755 cgc.asm
 create mode 100755 cgc.macros
 create mode 100755 cgc.pas
 create mode 100755 cgi.asm
 create mode 100755 cgi.comments
 create mode 100755 cgi.pas
 create mode 100755 count
 create mode 100755 dag.asm
 create mode 100755 dag.macros
 create mode 100755 dag.pas
 create mode 100755 gen.pas
 create mode 100755 linkit
 create mode 100755 make
 create mode 100755 native.asm
 create mode 100755 native.macros
 create mode 100755 native.pas
 create mode 100755 objout.asm
 create mode 100755 objout.macros
 create mode 100755 objout.pas
 create mode 100755 parser.pas
 create mode 100755 pascal.notes
 create mode 100755 pascal.pas
 create mode 100755 pascal.rez
 create mode 100755 pcommon.asm
 create mode 100755 pcommon.macros
 create mode 100755 pcommon.pas
 create mode 100755 scanner.asm
 create mode 100755 scanner.macros
 create mode 100755 scanner.pas
 create mode 100755 smac
 create mode 100755 symbols.asm
 create mode 100755 symbols.macros
 create mode 100755 symbols.pas

diff --git a/LICENSE.txt b/LICENSE.txt
new file mode 100644
index 0000000..cfc0c91
--- /dev/null
+++ b/LICENSE.txt
@@ -0,0 +1,11 @@
+ORCA/Pascal is released by the copyright holder under the terms of the original copyright.
+
+The Byte Works, Inc. grants you the right to use this source code privately, fork it, and change it.
+
+You may not redistribute the code in any form other than submission to this repository without the written permission of the copyright holder.
+
+The copyright holder decided to do things this way for two reasons:
+
+1. Reserve commercial distribution rights.
+
+2. Ensure that any contributions and updates are available from a centralized source (this GitHib repository, for now).
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..cfbaa20
--- /dev/null
+++ b/README.md
@@ -0,0 +1,52 @@
+# ORCA-Pascal
+Apple IIGS ORCA/Pascal Compiler, an ISO Pascal compiler for the 65816 with libraries for the Apple IIGS
+
+__Binary downloads for the latest ORCA/Pascal release are on the [releases page][releases].__
+
+[releases]: https://github.com/byteworksinc/ORCA-Pascal/releases
+
+If you would like to make changes to this compiler and distribute them to others, feel free to submit them here. If the changes apply to compilation on and for an Apple IIGS, they will generally be approved for distribution on the master branch unless the changes deviate significantly from the ISO Pascal standard. For changes that deviate from ISO Pascal or changes that retarget the compiler to run on a different platform or generate code for a different platform, the project will either be forked or a new repository will be created, as appropriate.
+
+The general conditions that must be met before a change is released on master are:
+
+1. The modified compiler must compile under the currently released version of ORCA/M and ORCA/Pascal.
+
+2. All samples from the original ORCA/Pascal distribution must compile and execute under the modified compiler, or the sample must be updated, too.
+
+3. The compiler must pass the ORCA/Pascal test suite, or the test suite must be suitably modified, too. The test suite is based on a commercial product, so it cannot be uploaded here. Contributors should contact the Byte Works to inquire about acces to the test suite.
+
+4. The compiler must work with the current ORCA/Pascal libraries, or the libraries must be modified, too.
+
+Contact support@byteworks.us if you need contributor access.
+
+A complete distribution of the ORCA languages, including installers and documentation, is available from the Juiced GS store at https://juiced.gs/store/category/software/. It is distributed as part of the Opus ][ package.
+
+## Line Endings and File Types
+
+The text and source files in this repository originally used CR line endings, as usual for Apple II text files, but they have been converted to use LF line endings because that is the format expected by Git. If you wish to move them to a real or emulated Apple II and build them there, you will need to convert them back to CR line endings.
+
+If you wish, you can configure Git to perform line ending conversions as files are checked in and out of the Git repository. With this configuration, the files in your local working copy will contain CR line endings suitable for use on an Apple II. To set this up, perform the following steps in your local copy of the Git repository (these should be done when your working copy has no uncommitted changes):
+
+1. Add the following lines at the end of the `.git/config` file:
+```
+[filter "crtext"]
+	clean = LC_CTYPE=C tr \\\\r \\\\n
+	smudge = LC_CTYPE=C tr \\\\n \\\\r
+```
+
+2. Add the following line to the `.git/info/attributes` file, creating it if necessary:
+```
+* filter=crtext
+```
+
+3. Run the following commands to convert the existing files in your working copy:
+```
+rm .git/index
+git checkout HEAD -- .
+```
+
+Alternatively, you can keep the LF line endings in your working copy of the Git repository, but convert them when you copy the files to an Apple II. There are various tools to do this.  One option is `udl`, which is [available][udl] both as a IIGS shell utility and as C code that can be built and used on modern systems.
+
+[udl]: http://ftp.gno.org/pub/apple2/gs.specific/gno/file.convert/udl.114.shk
+
+In addition to converting the line endings, you will also have to set the files to the appropriate file types before building ORCA/C on a IIGS. The included `settypes` script (for use under the ORCA shell) does this for the sources to the ORCA/C compiler itself, although it does not currently cover the test cases and headers.
diff --git a/backup b/backup
new file mode 100755
index 0000000..8ee69e4
--- /dev/null
+++ b/backup
@@ -0,0 +1 @@
+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
diff --git a/call.pas b/call.pas
new file mode 100755
index 0000000..1c1e3d8
--- /dev/null
+++ b/call.pas
@@ -0,0 +1 @@
+{$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
diff --git a/cgc.asm b/cgc.asm
new file mode 100755
index 0000000..e03b76f
--- /dev/null
+++ b/cgc.asm
@@ -0,0 +1 @@
+	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
diff --git a/cgc.macros b/cgc.macros
new file mode 100755
index 0000000..cf7e582
--- /dev/null
+++ b/cgc.macros
@@ -0,0 +1 @@
+ 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
diff --git a/cgc.pas b/cgc.pas
new file mode 100755
index 0000000..6735084
--- /dev/null
+++ b/cgc.pas
@@ -0,0 +1 @@
+{$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
diff --git a/cgi.asm b/cgi.asm
new file mode 100755
index 0000000..042b7aa
--- /dev/null
+++ b/cgi.asm
@@ -0,0 +1 @@
+****************************************************************
*
*  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
diff --git a/cgi.comments b/cgi.comments
new file mode 100755
index 0000000..7dcf594
--- /dev/null
+++ b/cgi.comments
@@ -0,0 +1 @@
+{-- 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
diff --git a/cgi.pas b/cgi.pas
new file mode 100755
index 0000000..9ae5e3e
--- /dev/null
+++ b/cgi.pas
@@ -0,0 +1 @@
+{$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
diff --git a/count b/count
new file mode 100755
index 0000000..b705717
--- /dev/null
+++ b/count
@@ -0,0 +1 @@
+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
diff --git a/dag.asm b/dag.asm
new file mode 100755
index 0000000..ebc8a08
--- /dev/null
+++ b/dag.asm
@@ -0,0 +1 @@
+	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
diff --git a/dag.macros b/dag.macros
new file mode 100755
index 0000000..c34e1e5
--- /dev/null
+++ b/dag.macros
@@ -0,0 +1 @@
+ 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
diff --git a/dag.pas b/dag.pas
new file mode 100755
index 0000000..c883d82
--- /dev/null
+++ b/dag.pas
@@ -0,0 +1 @@
+{$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
diff --git a/gen.pas b/gen.pas
new file mode 100755
index 0000000..966b2ad
--- /dev/null
+++ b/gen.pas
@@ -0,0 +1 @@
+{$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
diff --git a/linkit b/linkit
new file mode 100755
index 0000000..8b180ad
--- /dev/null
+++ b/linkit
@@ -0,0 +1 @@
+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
diff --git a/make b/make
new file mode 100755
index 0000000..48f4a31
--- /dev/null
+++ b/make
@@ -0,0 +1 @@
+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
diff --git a/native.asm b/native.asm
new file mode 100755
index 0000000..46a01a5
--- /dev/null
+++ b/native.asm
@@ -0,0 +1 @@
+         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
diff --git a/native.macros b/native.macros
new file mode 100755
index 0000000..33a7632
--- /dev/null
+++ b/native.macros
@@ -0,0 +1 @@
+ 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
diff --git a/native.pas b/native.pas
new file mode 100755
index 0000000..2fdcb09
--- /dev/null
+++ b/native.pas
@@ -0,0 +1 @@
+{$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
diff --git a/objout.asm b/objout.asm
new file mode 100755
index 0000000..a757805
--- /dev/null
+++ b/objout.asm
@@ -0,0 +1 @@
+	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
diff --git a/objout.macros b/objout.macros
new file mode 100755
index 0000000..7e78a6e
--- /dev/null
+++ b/objout.macros
@@ -0,0 +1 @@
+ 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
diff --git a/objout.pas b/objout.pas
new file mode 100755
index 0000000..9ae7c9e
--- /dev/null
+++ b/objout.pas
@@ -0,0 +1 @@
+{$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
diff --git a/parser.pas b/parser.pas
new file mode 100755
index 0000000..8fd63f7
--- /dev/null
+++ b/parser.pas
@@ -0,0 +1 @@
+{$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
diff --git a/pascal.notes b/pascal.notes
new file mode 100755
index 0000000..cbea926
--- /dev/null
+++ b/pascal.notes
@@ -0,0 +1 @@
+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
diff --git a/pascal.pas b/pascal.pas
new file mode 100755
index 0000000..3bffe9e
--- /dev/null
+++ b/pascal.pas
@@ -0,0 +1 @@
+{$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
diff --git a/pascal.rez b/pascal.rez
new file mode 100755
index 0000000..fcb3874
--- /dev/null
+++ b/pascal.rez
@@ -0,0 +1 @@
+#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
diff --git a/pcommon.asm b/pcommon.asm
new file mode 100755
index 0000000..d285348
--- /dev/null
+++ b/pcommon.asm
@@ -0,0 +1 @@
+	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
diff --git a/pcommon.macros b/pcommon.macros
new file mode 100755
index 0000000..48d0b2f
--- /dev/null
+++ b/pcommon.macros
@@ -0,0 +1 @@
+ 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
diff --git a/pcommon.pas b/pcommon.pas
new file mode 100755
index 0000000..5f389ca
--- /dev/null
+++ b/pcommon.pas
@@ -0,0 +1 @@
+{$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
diff --git a/scanner.asm b/scanner.asm
new file mode 100755
index 0000000..c6d87ec
--- /dev/null
+++ b/scanner.asm
@@ -0,0 +1 @@
+	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
diff --git a/scanner.macros b/scanner.macros
new file mode 100755
index 0000000..ddb409c
--- /dev/null
+++ b/scanner.macros
@@ -0,0 +1 @@
+ 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
diff --git a/scanner.pas b/scanner.pas
new file mode 100755
index 0000000..3b54796
--- /dev/null
+++ b/scanner.pas
@@ -0,0 +1 @@
+{$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
diff --git a/smac b/smac
new file mode 100755
index 0000000..c6ec8ff
--- /dev/null
+++ b/smac
@@ -0,0 +1 @@
+         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
diff --git a/symbols.asm b/symbols.asm
new file mode 100755
index 0000000..c2cbbe8
--- /dev/null
+++ b/symbols.asm
@@ -0,0 +1 @@
+	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
diff --git a/symbols.macros b/symbols.macros
new file mode 100755
index 0000000..abdd502
--- /dev/null
+++ b/symbols.macros
@@ -0,0 +1 @@
+ 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
diff --git a/symbols.pas b/symbols.pas
new file mode 100755
index 0000000..4da1e22
--- /dev/null
+++ b/symbols.pas
@@ -0,0 +1 @@
+{$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