IMD 1.18: 20/01/2023 23:42:52
PRQ-SFT-HSC-3
3RCC PERQ PASCAL COMPILER SOURCE DISTRIBUTION FLOPPY
Copyright (C) Three Rivers Computer Corporation, 1981
single density, double sided   C.3

Group name                Command file
PASCAL.SOURCE             SRC.CMD
        	
   IdType:=LSP;
            VAddr:=LC;
            LC:=LC+LSize;
            NXT:=Next;
            if Next = 0 then
       Miles A. Barel
{ Implementation of Long Integers
{ }
{ 15-Jan-81  1.12  Miles A. Barel
{ hashing for compiler names and use          if LSP <> nil then
                    if LSP^.Form = Files then
                        begin {put IdList into locar globals
{ }
{ 6-Jan-81  1.6  Miles A. Barel
{ General cleanup and first use of standard 3RCC file formats
{ }

procedurl file list}
                        Next:=Display[Top].FFile;
                        Display[Top].FFile:=IdList
           e ProcDeclaration(FSy: Symbol; Kynd: IdKind; var LCP: identifier);
{--------------------------------------
{ Abstract:
{    P             end
            end;
        WriteNum(LCP)
        end;
    if Sy = SemiColon then
        begin
        InSyrocess procedure and function declarations (with the exception
{    of the procedure/function body; this is done by BodyPart)
mbol;
        if not (Sy in FSys+[Ident]) then
          begin Error(6); Skip(FSys+[Ident]) end
        end
until (Sy <> Ide{
{ Parameters:
{    FSy - ProcSy or FuncSy; depending upon the type of declaration
{    Kynd - determines whether routine dent) and not (Sy in TypeDels);
if FwPtr <> 0 then
  begin Error(117); FwPtr:=0 end        { unresolved forward reference }
endclaration is Actual or Formal
{    LCP - returns the identifier for the routine name here
{
{ Side Effects:
{    The state o { VarDeclaration };
                                                                                                          f CurIFile may be modified
{    New identifiers will be entered in the symbol table
{    The lexical state and display windowse:=nil;
                if Seg <> MainSeg then
                    VLev:=-Seg
                else
                    VLev: =Level;
                IdNum:=NextINum
                end;
            EnterId(LCP);
            NXT:=LCP.IdNum;
             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 {------------------------------------------
{
{ Declarations Processor Part C
{ Copyright (C) 1981  Three Rivers Computer CorInSymbol
    until Test;
    if Sy = Colon then InSymbol else Error(5);
    IdList:=NXT;
    Typ(FSys+[SemiColon]+TypeDels,Lporation
{
{ Abstract:
{    Last portion of the declarations processor.  Handles procedure and
{    function declarations, aSP,LSize);
    while NXT <> 0 do
        begin
        LookupNum(NXT,LCP);
        with LCP do
            begin
         nd the main declaration parsing
{
{ File: Dec2.Pas
{
{------------------------------------------}

{ }
{ 03-Feb-81  2.0    	
                              ;dô;d?   i ;d€»;dZ   ià ;dہء;dS   iگ ;d ب;d   iہ	 اjغ   iً %ve;d@   iہ ] ;dK   i
 ث:d ;d   iہ ث€»;d7   iً ثہء;d   i°  ث ب;d)   i8 ـء‍;d   ip ـً ;d   iہ ـ،;d   iہ ـ@،;d3   i ـh،  	
----------------------------}
      var LCP1,ExcLCP,TLCP:Identifier; LCP2,TS,i: integer;
          LSP,LSP1: STP; ThisHandler:   InSymbol;                 { remove '(' }
    if not (Sy in [Ident,VarSy,ProcSy,FuncSy]) then
        begin
        Error(7 pHandList;
          Forw, GotOne, OldErr: boolean; 
          LLexStk: LexStkRec; TSet: SetOfSys;

function ParameterList);
        Skip(FSys + [Ident,RParent])
        end;
    while Sy in [Ident,VarSy,ProcSy,FuncSy] do
        begin
        i(FSy: SetOfSys; var FCP: Identifier; ReDec: boolean)
    : boolean;
{----------------------------------------
{ Abstract:
{ f Sy in [ProcSy,FuncSy] then
            begin
            LSy := Sy;
            InSymbol;
            if ReDec then
        Parse the declaration of the procedure/function parameter list
{
{ Parameters:
{    FSy - The legal terminator for the par           Error(399)
            else
                begin
                ProcDeclaration(LSy,Formal,LCP4);
             ameter list (either ; or :)
{    FCP - The identifier for the procedure or function name
{    ReDec - true if routine is being   with LCP4 do
                    if IdNum <> 0 then
                        begin
                        PFParms := Next; redeclared
{
{ Results:
{    Returns true if a parameter list is given, false otherwise
{
{ Side Effects:
{    The state 
                        PFLevel := Level;
                        Next := LCP1;
                        WriteNum(LCP4);
   of CurIFile will be modified
{    New identifiers may be entered in the Symbol Table
{
{ Calls:
{    Error
{    Skip
{                         LCP1 := IdNum;
                        LC := LC + VRDSize
                        end
                enInSymbol
{    NextINum
{    EnterId
{    SearchId
{    LookupNum
{    WriteNum
{------------------------------------------d
            end
        else
            begin
            if Sy = VarSy then       { is the parm by value or reference? }}
    var LCP,LCP4: Identifier; LCP1,LCP2,LCP3,NextP: integer; LSP: STP;
        LClass: IdClass; LLC,Len : AddrRange; count :
                begin
                LClass := FormalVars;
                InSymbol
                end       { reference  integer; Test: Boolean;
    type
        PListPtr = ^PList;
        PList = record
                    Name: Alpha;
      }
            else
                LClass := ActualVars;                          { value }
            LCP2 := 0;
          may be altered
{    A new procedure/function Id may be allocated
{    A new CurHeap segment will be created if the procedure/              Next: PListPtr
                   end;
    var PL0,PL1,PL2: PListPtr; LSy: Symbol;
begin
LCP1 := 0;
NextP := function
{        declaration is not of any FORWARD variety
{
{ Calls:
{    TreeSearch
{    Error
{    NextINum
{    EnteFCP.Next;
if not (Sy in FSy + [LParent]) then
    begin
    Error(7);
    Skip(FSys + FSy + [LParent])
    end;
if Sy = LPrId
{    InSymbol
{    ParameterList
{    SearchId
{    WriteNum
{    LookupNum
{    CreateSegment
{    New
{-----------arent then          { we have a parameter list }
    begin
    ParameterList:=true;      { yes! there is a parameter list }
    	
      ;dD   i  ##;d   i°	 #0u;d   i° #Xu;dS   iب #€u;d1   iˆ	 #¨u;d3   i0 كf•.;d   iک ‘(،Z;d   iH ¶z@} <   i¸  éjہv;d   i8 +(e^;d   iذ اjغ<   iط U(gz;d   i¨  [q*’<   i€ “y  ج   iب ث  ¸ô   i  € ½}   Mˆ+O´m      os>CLOCK.SEG                                                                      \ںہ ]ںہ ^ںہ _ںہ `ںہ                                                                                                                             `ںہےے Zںہ           	
   count := 0;
            PL0:=nil;
            repeat                        { get all the names }
                if Sy <>en  { now get the type that goes with these names }
                begin
                InSymbol;
                if Sy = I Ident then
                    Error(2)
                else
                    begin
                    if ReDec then
 dent then
                    begin
                    SearchId([Types],LCP);
                    InSymbol;
                                      begin
                        new(PL2);
                        with PL2^ do
                              LSP := LCP.IdType;
                    if LSP <> nil then
                        if ReDec then
                           begin
                            Name := Id;
                            Next := nil;
                            if PL0     begin
                            while (PL0 <> nil) and (NextP <> 0) do
                                begin
          = nil then
                                PL0 := PL2
                            else
                                PL1^.N                      LookupNum(NextP,LCP4);
                                if (LCP4.Name <> PL0^.Name) or
                  ext := PL2;
                            PL1 := PL2
                            end
                        end
                            (LCP4.Klass <> LClass) or
                                 (LCP4.IdType <> LSP) then
                                 else
                        begin
                        with LCP do
                            begin
                       begin
                                     Error(196);
                                     Skip(FSys + [SemiColon]                Name := Id; IdType := nil; Next := LCP2;
                            Klass := LClass;
                        );
                                     exit(ParameterList)
                                     end;
                           VLev := Level;
                            IdNum:=NextINum;
                            end;
                        Ente         PL1 := PL0;
                                PL0 := PL0^.Next;
                                Dispose(PL1);
        rId(LCP);
                        LCP2 := LCP.IdNum; count := count + 1
                        end;
                    InSy                        NextP := LCP4.Next
                                end;
                            if PL0 <> nil thenmbol
                    end;
                if not (Sy in FSys + [Comma,SemiColon,Colon]) then
                    begin
 
                                begin
                                Error(196);
                                while PL0                    Error(7);
                    Skip(FSys + [Comma,SemiColon,RParent,Colon])
                    end;
      <> nil do
                                    begin
                                    PL1 := PL0;
                                   Test := Sy <> Comma;
                if not Test then InSymbol
            until Test;
            if Sy = Colon th           PL0 := PL0^.Next;
                                    Dispose(PL1)
                                    end;
         	
****************************************}

{ }
{ 3 Apr 81  4.0  Don Scelza & Miles Barel
{ Release version for POS version 
{ New Switch - $N or /NAMES /NONAMES - to include/exclude procedure names
{              at the end of the procedure dictionarC Beta test sites.
{ }
{ 2 Apr 81  3.2  Miles A. Barel
{ Official Release of 3.1
{ }
{ 1 Apr 81  3.1  Miles A. Barel
{ Fixy
{ }
{ 13-Jan-81  1.10  Miles A. Barel
{ Remove statistics recording
{ }
{ 09-Jan-81  1.9  Miles A. Barel
{ Deleted NullS Command and Filename parser for the new OS
{ }
{ 19 Mar 81  3.0  Miles A. Barel
{ QCode Version Numbers Implemented
{ Max Ftring - Not used anywhere (except for being initialized)
{ Better Source Text Printing when an Error Occurs
{ Space used for iilename length extended to 100 characters
{ Single word scalar functions now only return ONE word
{ }
{ 19-Mar-81  2.6  Milesnline string constants is now returned
{ }
{ 08-Jan-81  1.7  Miles A. Barel
{ Bug Fix - Write(File,Char) where File is a var  A. Barel
{ RECAST Bug Fix
{ }
{ 17-Mar-81  2.5  Miles A. Barel
{ Import Bug Fix
{ }
{ 16-Mar-81  2.4  Miles A. Barel
{ Sparameter now works
{ }
{ 30-Dec-80  1.6  Miles A. Barel
{ Improved use of New and Dispose
{ }
{ 22-Dec-80  1.5  Miles A. Bet Bug Fix
{ }
{ 09-Mar-81  2.2  Miles A. Barel
{ Conversion to run under C.80
{ }
{ 06-Feb-81  2.1  Miles A. Barel
{ Namearel
{  Disposable Expression Trees
{ }
{ 18-Dec-80  1.4  Miles A. Barel
{ Various Range Check problems and other cleanup
{  Compatibility
{ }
{ 2-Feb-81  2.0  Miles A. Barel
{ Implementation of Long Integers
{ }
{ 28-Jan-81  1.15  Miles A. Barel 
{ New Switch structure, along with $MESSAGE, $COMMENT, and conditional
{ compilation
{ }
{ 22-Jan-81  1.14  Miles A. Barel
 { Exit Goto Implemented
{ }
{ 21-Jan-81  1.13  Miles A. Barel
{ Fix WordSize Bug (for WordSize in constants)
{ }
{ 15-Jan-8 1  1.12  Miles A. Barel
{ Identifier Hashing for compiler names and user globals
{ It is important to note that only these twoProgram PascalCompiler;

{***********************************************************

           3RCC  Pascal  Compiler

 levels may be hashed.
{ The structure of the compiler prohibits hashing any other levels
{ (as the head of any other level mu    Based on Zurich P2 Portable Compiler
    Extensively modified by Miles A. Barel
    Copyright (C) 1981  Three Rivers Compust be representable as a single
{ integer - for procedures, functions and records)
{ Default number of symbol table blocks chater Corporation
    720 Gross Street
    Pittsurgh, PA 15224
    (412) 621-6250

    File: Pascal.Pas

******************nged from 12 to 16
{ }
{ 14-Jan-81  1.11  Miles A. Barel
{ Bug Fix - functions of non-scalars now cleans up temp stack space  	
         end;
                if LCP.IdNum <> 0 then      { chain with previous parameters }
                  begin LCP.Next  IdType <> nil then
                            LLC := LLC - IdType^.Size;
                    VAddr:=LLC
                   := LCP1; LCP1 := LCP3; WriteNum(LCP) end
                end
            end { Actual or Formal Declaration };
        if not end;
                WriteNum(LCP);
                LCP3 := LCP1; LCP1 := LCP2
                end;
            end
       (Sy in FSys + [SemiColon,RParent]) then
          begin Error(7); Skip(FSys + [SemiColon,RParent]) end;
        if Sy = SemiC  end
    end { Sy = LParent }
else
    begin
    ParameterList:=false;
    LCP3 := 0
    end;
if not ReDec then      { s                          Skip(FSys + [SemiColon]);
                                exit(ParameterList)
                      olon then
            begin
            InSymbol;
            if not (Sy in FSys + [Ident,VarSy,ProcSy,FuncSy]) then
                 end
                            end
                       else
                           if LClass = ActualVars t       begin Error(7); Skip(FSys + [Ident,RParent]) end
            end
        end { while Sy in [Ident,VarSy,ProcSy,FuncSy] hen
                               begin
                               if LSP^.Form = Files then Error(121);
               };
    if Sy = RParent then
        begin
        InSymbol;
        if not (Sy in FSy + FSys) then
          begin Error(6)                Len:=LSP^.Size
                               end
                           else {LClass = Formal}
         ; Skip(FSy + FSys) end
        end
    else
        Error(4);
    if ReDec then
        if NextP <> 0 then Error(196) else                      Len:=PtrSize
                    else {LSP = Nil}
                        Len:=0;
                    i
    else
        begin
        FCP.LocalLC := LC; LCP3 := 0; LLC:=LC;
        WriteNum(FCP);
        while LCP1 <> 0 do    f not ReDec then LC := LC + count * Len
                    end
                else
                    Error(2)
              { invert the list, so first is first, and }
            begin                 { perform space allocation }
            Loo      end
            else
                Error(5);
            if not ReDec then
                begin
                LCkupNum(LCP1,LCP);
            with LCP do
                begin
                LCP2 := Next; Next := LCP3;
                P3 := LCP2;
                while LCP2 <> 0 do            { assign the type to each name }
                    begin
        if Klass in [Proc,Func] then
                    begin
                    LLC := LLC - VRDSize;
                    PFAddr:=            LookupNum(LCP2,LCP);
                    with LCP do
                        begin
                        IdTypeLLC
                    end
                else
                    begin
                    if Klass = FormalVars then
  := LSP;
                        LCP2 := Next;
                        WriteNum(LCP)
                        end
                                  LLC := LLC - PtrSize
                    else { if Klass = ActualVars then }
                        if   	
lemented
{ Optional '.PAS'
{ Inclusion of '_' in identifiers now legal
{ }
{ 17-Nov-80  1.0d  Miles A. Barel
{ Unlimited Ne8000;
      MainSeg = 0;              { Main Segment Number }
      MainLex = 1;              { Main Body Lex Level }
      sting of Includes and Imports allowed
{ }
{ 14-Nov-80  1.0c  Miles A. Barel
{ Automatic generation of RESET(INPUT) and REWRIT
      IntgrSize = 1;            { Number of words to store an integer }
      RealSize = 2;             { Number of words to sE(OUTPUT) code.
{ Bug Fixes:
{    Array[Boolean] of xxx allocation fixed.
{    Array [x..y] of chr(i)..chr(j) fixed.
{    Sotore a Real }
      LongSize = 2;             { Number of words to store a Long }
      BitsPerWd = 16;           { Number of me random Nil pointer references caught.
{    (**) comment now possible.
{ }
{ 13-Nov-80  1.0b  Miles A. Barel
{ Bug Fixes:bits in a word }
      CharSize = 1;
      BoolSize = 1;
      PtrSize = 2;
      VRDSize = 4;              { Size of the Va
{    Exit(program_name) from a module fixed
{    No room for output file handled correctly
{    Comment between FROM and fileriable Routine Descriptors }
      FDSize = 15;              { Size of File Descriptor minus element size }
      TextSize = 1 name in IMPORTS decl allowed
{    Automatic Imports fixed (uses DefIEntension instead of .TEXT)
{ }
{ 11-Nov-80  ??  Miles A6;            { Size of text File Descriptor including the }
                                { character = FDSize + 1 }
      . Barel
{ Functions may now return any type except FILE
{ Parameter lists of FORWARD declared procedures and function
{ may bEofBit = 2;               { Bit position of Eof flag in File Descriptor }
      EolnBit = 1;              { Bit position of Eole repeated (optional)
{ }
{ 09-Sep-80  ??  Miles A. Barel
{ Installed Real Command Parser
{ }

EXPORTS

const
      { n flag in File Descriptor}
      CharReadyBit = 0;         { Bit position of Character Ready flag in File}
                   Conditional Constants }
      IncReals = false;         { Full implementation of reals }
      {$IFC not IncReals THEN}
                  { Descriptor, must be = 0! }
      BitsPerChr = 8;           { Number of bits in a character }
      ChrsPerWd =  }
{ 08-Dec-80  1.3  Miles A. Barel
{  Fixed Code Buffer Allocation
{ }
{ 02-Dec-80  1.1d  Miles A. Barel
{ WordSize replac {$Message Reals Not Enabled}
      {$ENDC}

      DebGen = false;           { Print info on Code Generation }
      {$IFC Des SizeOf (and returns size of anything)
{ }
{ 22-Nov-80  1.1b  Miles A. Barel
{ Stacking Switch Options.
{ Version Switch
ebGen THEN}
      {$Message Code Generation Debugging Enabled}
      {$ENDC}

      DebEStack = false;        { Print info o{ Copyright Switch
{ }
{ 21-Nov-80  1.1a  Miles A. Barel
{ Symbol Table Dump included for Debugging
{ }
{ 20-Nov-80  1.1  Mn EStack pushes and pops }
      {$IFC DebEStack THEN}
      {$Message EStack Debugging Enabled}
      {$ENDC}

Imports Fililes A. Barel
{ Official Release of previous modifications
{ }
{ 19-Nov-80  1.0e  Miles A. Barel
{ AUTO NOAUTO $A Switch ImpeUtils from FileUtils;

const VersionString = 'V4.0';

      DispLimit = 12;
      MaxLevel = DispLimit;
      MaxAddr = 2  	
en declared before }
    if not Forw then            { create the new entry }
        begin
        with LCP do
            );
if Top < DispLimit then
    begin
    Top := Top + 1;
    with Display[Top] do
        begin
        if Forw then
    begin
            Name := Id;
            IdType := nil;
            IdNum:=NextINum;
            PFDecKind := Declared;
          FName := LCP.Next
        else
            FName := 0;
        ForwCount:=0;
        FLabel := nil;
        FFile :          PFKind := Kynd;
            LocalLC := 0;
            if Kynd = Actual then
                begin
                = 0;
        Occur := Blck
        end
    end
else
    Error(250);
if FSy = ProcSy then              { it's a procedure }InScope := false;
                PFLev := Level;
                ForwDecl := false;
                PFName := NextProc;
   
    if ParameterList(TSet,LCP,Forw) then else
else                              { we've got a function }
    begin
    GotO             PFSeg := Seg;
                if NextProc = MaxProcNum then
                    Error(251)
                elsene := ParameterList(TSet + [Colon],LCP,Forw);
    if Sy = Colon then
        begin           { now the function type }
      
                    NextProc := NextProc + 1
                end;
            if FSy = ProcSy then
                Klass :=   InSymbol;
        if Sy = Ident then
            begin
            SearchId([Types],LCP1);
            if Forw then
     ave the parameter list in Next field of procedure }
    begin
    FCP.Next:=LCP3;
    WriteNum(FCP)
    end
end { ParameterProc
            else
                Klass := Func
            end;
        EnterId(LCP)
        end
    else
        ifList };

begin { ProcDeclaration }
if Sy = Ident then              { is the name already declared? }
    begin              Seg <> LCP.PFSeg then      { make sure it was defined in this seg }
            Error(397);
    InSymbol
    end
else
              { if so must be because of forward decl }
    if Top <= HashLevels then
        TS := HashTable[Top,HashIx(Id)]
   begin
    Error(2);
    LookupNum(UPrcPtr,LCP)
    end;
with LLexStk do                 { save current state }
    begin
  else
        TS := Display[Top].FName;
    TS := TreeSearch(TS,LCP,Id);
    if TS = 0 then              { the name is alread   DLLC := LC;
    LC := LCP.LocalLC;         { also setting some new state as we go }
    DOldLev:=Level; 
    DOldTop:=Top;y defined }
        if LCP.Klass in [Proc,Func] then
            begin
            Forw:=LCP.ForwDecl and (FSy in [ProcSy,Fun 
    POldProc:=CurProc; 
    DFProcP:=LCP.IdNum;
    end;
LineInfo := LC;                { for list file control }
DP := tcSy]);{ true if forward }
                                                            { decl'd procedure}
            if not Frue;
if Kynd = Actual then
    begin
    CurProc := LCP.PFName;      { advance to next lex & window levels }
    TSet := [Seorw then Error(160)
            end
        else
            Error(101)
    else
        Forw := false;          { never bemiColon]
    end
else
    TSet := [SemiColon,RParent];
if Level < MaxLevel then
    Level := Level + 1
else
    Error(251   	
  MaxInt = 32767;           { Bigest integer }
      DefStrgLgth = 80;         { Default string length }
      MaxFNLength = 1alConst,StringConst,
                NotSy,MulOp,AddOp,RelOp,SetSy,PackedSy,ArraySy,RecordSy,
                FileSy,ModSy,Imp00;        { Maximum length of a Source File Name }
      
      EOL = 13;                 { Carriage return character }
    ortSy,ExportSy,PrivateSy,FromSy,OthrWiseSy,
                ChangeSy,OtherSy,DotDot,RCurly,ExceptSy,HandleSy,RaiseSy);

       
      MaxSeg = 32;              { Highest allowable segment }
      MaxProcNum = 149;         { Max number of procedures peOperator = { Types of Operators }
                
                (Mul,RDiv,AndOp,IDiv,IMod,Plus,Minus,OrOp,LtOp,LeOp,
     r segment }
      ResCount = 41;            { number of reserved words }
      MinId = 1;                { Lowest valid Id # }            GeOp,GtOp,NeOp,EqOp,InOp,NoOp,
                    { the following are special tree node operators }
             
      
      EDepth = 16;              { Max depth of expression evaluation stack }
      ESpare = 1;               { Extra     ArrayAccessor, FieldAccessor, PtrAccessor, FileAccessor,
                 PushParm, CallPF,
                 FltOp, NotOprEStack space reserved for MicroCode }
      EMax = EDepth - ESpare;   { Usable EStack Space }
      
    PDFileName = 'PASCAL, SNSOp, SRSOp, SGSOp, UNIOp,
                 Neg, SelectOp,StrchOp);

     SetOfSys = set of Symbol;

     RotShiModes = .TMPD$';         { name for temporary procedure }
                                        { dictionary file }
    DefIExtensio(ShiMode,RotMode);

                                                    { Constants }
     
     CstClass = (Reel,Strg,Trix)n = '.PAS';             { default source file extension }
    DefOExtension = '.SEG';             { and same for segment file };     { Types of constants }
     StrCstClass = (DefCst,DynCst);  { class of string constant - defined
                       
    DefLExtension = '.LST';             { and same for list file }

type
     FyleName = string[MaxFNLength];

     AByte                 constant or dynamic constant
                                      }
     ChrsOfString = packed array [1..Str = 0..255;    { just A Byte }
     
     Symbol =  { Types of lexemes                     }
               { NOTE: ChangeSy agLgth] of char;
     CSP = ^ ConstRec;                          { Constant descriptor }
     ConstRec = packed record case CClnd OtherSy are internal symbols }

               (Ident,Comma,Colon,SemiColon,LParent,RParent,DoSy,ToSy,
                Dowass: CstClass of { Type of this const }
                         Trix: (CstVal: array [1..2] of integer);
                    nToSy,EndSy,UntilSy,OfSy,ThenSy,ElseSy,Becomes,LBrack,
                RBrack,Arrow,Period,BeginSy,IfSy,CaseSy,RepeatSy,WhileSy     Reel: (RVal: real);
                         Strg: (SLgth: 0..StrgLgth;     { length of str }
                           2;            { Number of characters in a word }
      StrgLgth = 255;           { Max number of characters in a string }
    ,
                ForSy,WithSy,GotoSy,LabelSy,ConstSy,TypeSy,VarSy,ProcSy,
                FuncSy,ProgSy,ForwardSy,IntConst,Re  	
 begin
                        with IdType^ do
                            begin
                                begin
       end
    else
        if not Forw then
            Error(123)
        else
            if GotOne then
                Err                           LC := LC + Size;
                                LocalLC := LocalLC + Size
                        or(196)       { parameters respec'd without function type }
    end;
if Kynd = Actual then
    begin
    if Sy = SemiColon t        end;
                            if Form = Files then
                                { files are the only type which hen InSymbol else Error(14);
    if (Sy = ForwardSy) or (Seg <> MainSeg) or (Exporting) or (FSy = ExceptSy)
      then
      cannot be
                                  returned, since we can't even perform
                                  assignment  begin
        if Forw then
            Error(161)
        else
          with LCP do
            begin
            ForwD of file variables - to set up the
                                  return value
                                }
         ecl := true;
            ImpDecl := Seg <> MainSeg;
            if not ImpDecl then
                with Display[Top-1] do Fo                       begin
                                Error(120);
                                LCP.IdType := nil
  rwCount:=ForwCount+1;
            if Sy = ForwardSy then 
                begin
                if (not Exporting) and (Seg =                              end
                            else
                                begin   { adjust LC of para MainSeg) then
                    begin
                    InSymbol;
                    if Sy = SemiColon then InSymbol elmeters }
                                LookupNum(LCP.Next,LCP1);
                                with LCP1 do
             se Error(14)
                    end
                else
                    Error(189)
                end;
            W                       while IdNum <> 0 do
                                        begin
                                     riteNum(LCP)
            end;
        if not (Sy in FSys+[PrivateSy]) then
          begin Error(6); Skip(FSys) end
                   if GotOne or (LCP.Next = 0) then
                    if LCP1.IdType = LCP.IdType then
                        { red       VAddr := VAddr + Size;
                                        WriteNum(LCP1);
                                        eclaration matches }
                    else
                        Error(196)   { redec mismatch }
                else
 LookupNum(Next,LCP1)
                                        end
                                end
                                           Error(196)   { func redec without parameter redec }
            else
                with LCP do
             end
                        end;
                    WriteNum(LCP)
                    end;
            InSymbol
                 begin
                    IdType := LCP1.IdType;
                    if IdType <> nil then
                             end
        else
            begin
            Error(2);
            Skip(FSys + [SemiColon])
            end
         	
ter to!     }
                     Power:    (ElSet: STP);
                     Arrays:   (AElType,        { Type of array eleet of IdClass;
     IdKind = (Actual,Formal);

Const
     UniqLength = 8;                    { Length of Unique Identifier }ments   }
                                InxType: STP;   { Type of array index      }
                                case AI

Type
     Alpha = packed array [1..UniqLength] of char;         { Identifier String }
     
     Identifier = record          STyp: StrCstClass;      { dynamic or static }
                                SVal: ChrsOfString)
                       sPackd:boolean of {packed array flag}
                                  true: (ElsPerWd,     { Elements per word }
             end;

     Valu = record case boolean of
                     true:  (IVal: integer);
                     false: (ValP: C                              ElWidth: BitRange; { Bits/element }
                                         case AIsStrng: booleSP)
                   end;

                                                  { Data Structures }
     BitRange = 0..BitsPean of
                                                { ^ Array is really a string }
                                         rWd;
     ProcRange = 0..MaxProcNum;
     LevRange = 0..MaxLevel;
     AddrRange = 0..MaxAddr;
     SegRange = 0..MaxSeg;
        true:(MaxLeng: 0..StrgLgth)));
                                                {       ^ length of said str }
             DispRange = 0..DispLimit;
     
     StructForm = { Data Types }
                  (Scalar,SubRange,Pointr,Power,Arrays,            Records:  (FstFld: integer; RecVar: STP);
                     Files:    (FilType: STP;   { type of file contents }
                   Records,Files,TagFld,Variant);

     DeclKind = (Declared,Special);    { declaration types }

     STP =
                                ElWordSize, ElBitSize: integer);
                     TagFld:   (TagFieldP: integer; FstVar:  ^ Structure;
     Structure = record                         { Definition of a data type }
                   Size: AddrRangeSTP);
                                                { ^ Top node of a set of 'cased'
                                       ;             { number of words needed?? }
                   case Form: StructForm of     { Type of structure }
                        fields }
                     Variant:  (NxtVar,         {pointer to next field of case}
                                  Scalar:    { Integer, Real, Char, Boolean }
                               (Case ScalKind: DeclKind of
                     SubVar: STP;    {link fields of this case     }
                                VarVal: Valu)
                   
                        Declared: (FConst: integer));
                     SubRange: (RangeType: STP; Min,Max: Valu);
                           end;

                                                            {NAMES}
     IdClass = { Types of Identifiers        Pointr:   (ElType: STP);   { Pointer to the structure }
                                                { we are a poin }
               (Types,Konst,FormalVars,ActualVars,Field,
                Proc,Func,Modul,Except,Handle);
     SetOfIds = s  	
get to DeclarationPart for new lex level }
        NotDone:=true;      { to get out of Declaration Part }
        with LLexStkLabelSy:  LabelDeclaration;
            ConstSy:  ConstDeclaration;
            TypeSy:   TypeDeclaration;
            VarSy: do
            begin 
            DMarkP:=CurHeap;
            CreateSegment(CurHeap,1,1,256);
            with LCP do
       VarDeclaration;
            ProcSy,
            FuncSy,
            ExceptSy,
            HandleSy: ProcDeclaration(LSy,             begin
                if ForwDecl then
                    if not ImpDecl then
                        with DispActual,LCP)
          end { case };
        if (Sy = PrivateSy) then
            begin
            if Seg <> MainSeg then
 lay[Top-1] do ForwCount:=ForwCount-1;
                ForwDecl := false;          { no longer forward }
                InScop               Exit(DeclarationPart)       { time to return to importer }
            else
                begin
            e := true;
                WriteNum(LCP)
                end;
            BFSy:=SemiColon;
            PrevLexStackP:=TOS
     InSymbol;  { in main module, ignore private and keep on going }
                Exporting:=false        { done with exports           end;
        New(TOS);
        TOS^:=LLexStk;
        Exit(ProcDeclaration);
        end;
    if FSy = ExceptSy  }
                end
            end
        end { while };
    if not (Sy in [BeginSy]) then
        if (not ((CurIFile^then
        with PDFile^ do
            begin
            ProcNum := CurProc;
            ProcName := LCP.Name;
          .PrevFile <> nil) or NotDone))
          or not(Sy in BlockBegSys) then
            begin
            Error(18); Skip(FSys);  PS := LCP.LocalLC;
            RPS := LCP.LocalLC;
            ACS := 0;
            EntA := 0;
            ExtA := 0;
  
            end;
until (Sy in (StatBegSys + [EndSy]));
NewBlock:=false; 
end { DeclarationPart }.
                                   LL := Level;
            Put(PDFile)
            end
    end { Kynd = Actual };
with LLexStk do  { Forward or Impo rt declaration, so restore state }
    begin 
    Level:=DOldLev; 
    Top:=DOldTop;
    LC:=DLLC; 
    CurProc:=POldProc
     end
end; { ProcDeclaration }

begin { DeclarationPart }
repeat
    NotDone:=false;
    while Sy in (BlockBegSys - [BeModule BodyPrt;
{-----------------------------------------
{
{ Executable Body Parsing
{ Copyright (C) 1981  Three Rivers CoginSy]) do
        begin
        LSy:=Sy;
        InSymbol;
        case LSy of
            ImportSy: if Level = MainLex thmputer Corporation
{
{ Abstract:
{    Perform the processing of procedure and function bodies.  Code is
{    generated for send
    else
        begin               { the actual procedure defn - her comes the body }
        NewBlock:=true;     { to en
                          ImportDeclaration
                      else
                          Error(409);
               	
                                       { ID types                             }
                                       {-------       Declared: (LocalLC: AddrRange;
                                        case PFKind: IdKind of { ACTUAL or    }
        -------------------------------}
                                       { List of names in an enumerated type  }
                                                                    { FORMAL       }
                                         Actual: (
                             {--------------------------------------}
                  case Klass: IdClass of       { Class of th                                            PFLev: LevRange;   { Lex Level }
                                               PFNe ID }
                  
                    Konst: (Values: Valu);     { record capable of storing }
                      ame: ProcRange; { Proc #    }
                                               PFSeg: SegRange;   { Seg #     }
                                         { the value of the constant }
                    
               FormalVars,
               ActualV                               ForwDecl,
                                               ImpDecl, { only if ForwDecl }
                  { Identifier definition                }
                  Name: Alpha;         { Symbolic Name (1-8 characters)     ars: (VLev: LevRange;
                            VAddr: AddrRange);
                    
                    Field: (FldAddr  }
                  IdNum: integer;      { Numerical Id                         }
                  IdType: STP;         { T: AddrRange;
                            case FIsPackd: boolean of { Field IS PACKeD }
                              true: (Flype if Identifier                   }
                  LLink,RLink: integer;{ Binary Tree Links                    }
        dRBit,FldWidth: BitRange));
                                               { FieLD Rightmost BIT ?? 0..16 }
                            Next: integer;       {--------------------------------------}
                                       { If symbol is a                             { FieLD WIDTH 0..16 }
                    
                    Proc,
                    Func,
 func of proc then NEXT}
                                       { is used to chain together the defns  }
                                         Except,
                    Handle:(case PFDecKind: DeclKind of  { Type of the Proc or}
                                    { of the formal parameters             }
                                       {----------------------------                                       { function           }
                                                         { Specia----------}
                                       { Links fields of a RECORD together    }
                                  l = OS Calls }
                                                         { Standard = CSPs    }
                                    {--------------------------------------}
                                       { Used to link together forward refs of}
                          { Decld = Usr defned }
                             Special:  (Key: integer);
                        	
{ Abstract:
{    The first part of body processing.  Deals mainly with Operand recognition.
{
{ File: Body0.Pas
{
{--------: ESP;  FORWARD;

function Selector(FSys: SetOfSys; var FCP: Identifier): ESP;
{-----------------------------------------
{----------------------------}

{ }
{ 6-Jan-81  1.6  Miles A. Barel
{ General Cleanup and first use of standard 3RCC file fo Abstract:
{    Parse the operands, begining with identifiers, of an expression
{
{ Parameters:
{    FSys - Legal terminal statement constructs, however generation of code for
{    expressions is postponed until ExpExpression
{
{ File: BodyPart.Pasrmat
{ }

Procedure BodyPart(FSys: SetOfSys; FProcP: Identifier);
{-----------------------------------
{ Abstract:
{    T
{
{------------------------------------------}

{ }
{ 03-Feb-81  2.0  Miles A. Barel
{ Implementation of Long Integers
{he main body of the Body processing module (body actually in Body3.Pas)
{    Calls Statement until the entire body is processed }
{ 06-Jan-81  1.6  Miles A. Barel
{ Institute standard 3RCC file formats
{ }

EXPORTS

Imports PascalCompiler from Pas, and then makes the
{    initial procedure dictionary entry for the body just compiled.
{
{ Parameters:
{    FSys - the poscal;

Var
    ExpHeap: integer;           { Heap for allocation of Expression Tree Nodes
                                  asible terminal symbols for the body
{    FProcP - the identifier which names the body to be compiled
{
{ Environment:
{    Pnd related "stuff" }

Procedure BodyPart(FSys: SetOfSys; FProcP: Identifier);

PRIVATE
{$C Copyright (C) 1981  Three RiversDFile must be open for output (the file used to store the procedure
{    dictionary until it may finally be written out to the  Computer Corporation }

Imports QCodes from QCodes.Dfs;
Imports DecPart from DecPart;
Imports CodeGeneration from CodeGen;code file);
{    named PASCAL.TMPD
{
{ Side Effects:
{    Labels declared by the body are generated.
{    Code is generated
Imports ExpandExpression from ExpExpr;
Imports InitGlobals from Compinit;

Imports Memory from Memory;

{$R-}

{$INC Bod.
{    Procedure dictionary entry is made
{    Code is written out to the output file
{    Sizes of the Code Buffer segment ay0 }         { These files contain the bodies of this segment }
{$INC Body1 }
{$INC Body2 }
{$INC Body3 }
                  nd the Expression Tree segment
{        are reset to their initial sizes.
{    The state of CurIFile may be modified
{
{ Cal ls:
{    WriteLn
{    GenLabel
{    Statement
{    InSymbol
{    Error
{    QGen0
{    GenByte
{    Put
{    WriteCode 
{    ChangeSize
{    DecRefCount
{    CreateSegment
{-----------------------------------}
  var ExitIC: AddrRange;  LCP: Id{-----------------------------------
{
{ Body Processing  Part A
{ Copyright (C) 1981  Three Rivers Computer Corporation
{
entifier;  LOp: AByte;
      LLP: LabelP;  LMin,LMax,CurSpace: integer; Test: Boolean;


function Expression(FSys: SetOfSys)   	
  VAccess = (Drct,Indrct,Packd,Multi,Bite,Chracter);

     Attr = Record TyPtr: STP;
              case Kind: AttrKind of
  vRange;
                   POldProc,SOldProc: ProcRange;
                   DOldSeg: SegRange;
                   DLLC: AddrR              Cst:   (CVal: Valu);
                Varbl: (Case Access: VAccess of
                          Drct:   (VLevel: ange;
                   BFSy: Symbol;
                   DFProcP: integer;
                   DMarkP: integer;
            LevRange; Dplmt: AddrRange);
                          Indrct: (IDplmt: AddrRange));
                Expr:  (DispLev: DispRang       PrevLexStackP: pLexStkRec
                 end;
     
                 
     ETNType = (Opr,Opnd);      { Expression e)     { this is NOT used for exprs, }
                                                { it is used for field vars }
         tree node types }
     EOpTypes = (Idd,Kst);      { Operand types }
     ESP = ^ETNode;
     ETNode = record                                                        { early in the game - a KLUDGE }
            end;

                                                   { Expression Tree Node }
                EAttr: Attr;                         { Node Type & Access Info }
                 { Labels }
     LBP = ^ CodeLabel;
     CodeLabel = record
                   Defined: boolean;    { true if IC             SSy: Symbol;                         { Node Symbol (as returned}
                                                  is defined }
                   OccurIC: AddrRange;  { IC of label or listhead of forward }
                                     { from InSymbol           }
                case EType: ETNType of               { Node Type }
                    Opr: ( O      { references to it (defined=false) }
                   OccurSeg: SegRange;  { Segment of destination }
                pp: Operator;            { Operator }
                           LLink,RLink: ESP );       { Tree Links }
                                                                    { is true }
                                               InScope: boolean
     OccurProc: ProcRange;{ Procedure Of Destination }
                   OccurOfst,           { Block offset to jump inst }
                                                );
                                         Formal: (
                                           OccurBlk: integer    { Block containing jump }
                 end;

     LabelP = ^ UserLabel;
     UserLa                    PFAddr: AddrRange;
                                               PFParms: integer;
                      bel = record
                   LabVal: integer;     { # representing the label }
                   NextLab: LabelP;     { pt                         PFLevel: LevRange  { Lex Level }
                                               )))
                 r to the next label in this blk }
                   CodeLbP: LBP
                 end;

     pLexStkRec = ^LexStkRec;
     end;


                                              { Expressions }
     AttrKind = (Cst,Varbl,Expr,Result,VRDVarbl);
    LexStkRec = record                 { Lex Stack Record }
                   DOldTop: DispRange;
                   DOldLev: Le  	
begin
{ [ } if Sy = LBrack then                       { Array Access }
          begin
          repeat
              LAttr             begin Error(140); TyPtr := nil end;
                  InSymbol;
                  if Sy = Ident then
            := GAttr;
              with LAttr do
                  if TyPtr <> nil then
                      if TyPtr^.Form <> Arrays t          begin
                      if TyPtr <> nil then
                          begin
                          if TreeShen
                          begin Error(138); TyPtr := nil end;
              InSymbol;
              Node2:=Expression(FSyearch(TyPtr^.FstFld,LCP,Id) <> 0 then
                              begin
                              Error(152);
         s + [Comma,RBrack]);
              New(ExpHeap,1,Node1,Opr);
              with Node1^ do
                  begin
                               TyPtr := nil
                              end
                          else
                                  EAttr:=LAttr;
                  EType:=Opr;
                  SSy:=LBrack;
                  Opp:=ArrayAccessor;
       TyPtr := LCP.IdType;
                          end;
                      New(ExpHeap,1,Node2,Opnd,Idd);
                ymbols for the 'selector'
{    FCP - The identifier which leads off the 'selector'
{
{ Results:
{    The root node of the ex               LLink:=Node;
                  RLink:=Node2
                  end;
              Node:=Node1;
              ipression tree describing the 'selector'
{
{ Side Effects:
{    The state of CurIFile may be modified
{
{ Calls:
{    New
f GAttr.TyPtr <> nil then
                  if GAttr.TyPtr^.Form > SubRange then Error(113);
              if LAttr.TyPtr <> n{    Error
{    Skip
{    InSymbol
{    Expression
{    CompTypes
{    TreeSearch
{---------------------------------------il then
                  with LAttr.TyPtr^ do
                      begin
                      if not CompTypes(InxType,GAt---}
    var LAttr: Attr; LCP: Identifier; LMin,LMax: integer;
        Node,Node1,Node2,Node3:ESP;
        LOpp: Operator;
 tr.TyPtr) then Error(139);
                      with GAttr do
                          begin
                          TyPt begin
  with FCP, GAttr do
      begin
      TyPtr := IdType; Kind := Varbl;
      New(ExpHeap,1,Node3,Opnd,Idd);
      wir := AElType; Kind := Varbl;
                          end;
                      Node1^.EAttr:=GAttr;
                      th Node3^ do
          begin
          EType:=Opnd;
          SSy:=Ident;
          OpClass:=Idd;
          IIdent:=IdNum;end
          until Sy <> Comma;
          if Sy = RBrack then InSymbol else Error(12)
          end {if Sy = LBrack}
      
          EAttr:=GAttr;
          if FCP.Klass = Field then EAttr.DispLev:=Disx
          end;
      end {with};
  if not (else
  { . }   if Sy = Period then                   { Record Field Access }
              begin
              with GAttr doSy in SelectSys + FSys) then
    begin Error(59); Skip(SelectSys + FSys) end;
  Node:=nil;
  while Sy in SelectSys do
      
                  begin
                  if TyPtr <> nil then
                    if TyPtr^.Form <> Records then
           	  	
mbol;
                    Opr: Operator
                end;
    
    EStackType = (Data16,Data32,Off20,Ptr32);
    
    pMaxCodeSize = 64;               { max number of blocks allowable - Note:
                                      This restricts pProcRec = ^ProcRec;
    ProcRec = record    { procedure dictionary entry }
                ProcNum:integer;{ procedure number rocedure size, not
                                      segment size.
                                    }
                of this proc }
                ProcName: Alpha;{ name of this procedure }
                PS,             { parameter size }
                    
Var

    CodeP: pCodeArray;             { Code Buffer until WriteOut }
    CodeSeg,                                    RPS,            { result + parameter size }
                ACS,            { activation size }
                  { Segment used for Code Buffer }
    CodeSize,                       { Current size of Code Buffer (in blocks) }
    MaxCo  EntA,           { enter address }
                ExtA,           { exit address }
                LL:integer      { lex levde: integer;               { Current size of Code Buffer (in bytes) }
    
    GAttr: Attr;                    { Describes curel }
            end;

    DEP = ^DicEntry;
    
    DicEntry = record
                Next,Prev:DEP;  { doubly linked lisrent expression }

    Top: DispRange;                 { Top of display }
    LC, IC: AddrRange;              { Location and t of DicEntries }
                PR: pProcRec
            end;

    LinkInfo = record
                ModName:Alpha;
    instruction counters }
    Seg: SegRange;                  { Current segment number }
                                    { Sc            FilName:FyleName
              end;
              
    PackageName = (Dynamic, Stream, Reader, Writer);
    
  anner globals...NEXT FOUR VARS }
                                    { MUST BE IN THIS ORDER for IdSearch }
    Sy: Symbol;     RoutineName = (PNone,
                   PNew, PDispose,
                   PStreamInit, PStreamOpen, PStreamClose,
                         { Symbol found by InSymbol }
    Op: Operator;                   { Classification of last symbol }
    Id: A            PGetB, PPutB, PGetC, PPutC, PReedln, PRiteln,
                   PRdBoolean, PRdCh, PRdChArray, PRdIdentifier, PRdIlpha;                      { Last identifier found }
    PrsFilNam: boolean;             { TRUE when InSymbol is looking for anteger,
                   PRdString, PRdX,
                   PWrBoolean, PWrCh, PWrChArray, PWrIdentifier, PWrInteger,
    
                                      File Name }
    InSymStr: string;               { Full string parsed by InSymbol (up to Opnd:( case OpClass: EOpTypes of { Operand Type }
                               Idd: (IIdent: integer){ Identifier }
                       PWrString, PWrX, PRdLong, PWrLong);

    pCodeArray = ^ CodeArray;
    CodeArray = packed array[0..0] of AByte                 )
              end;

    ResWrdRec = record
                    RWord: Alpha;
                    Sym: Sy;  { Buffer for Code Generation }

Const
    DefCodeSize = 1;                { default size in blocks for Code Buffer }
     	 	
      RLink:=Node2
                          end;
                      Node:=Node1;
                      InSymbol
         end
      end { while };
  if Node = nil then
      Selector:=Node3
  else
      begin
      New(ExpHeap,1,Node1,Opr);
               end { Sy = Ident }
                  else
                      Error(2)
                  end {with GAttr}
       with Node1^ do
          begin
          EAttr:=GAttr;
          EType:=Opr;
          SSy:=Ident;         { This shoul            end { if Sy = Period }
          else
  { ^ }       begin                             { Pointer Access }
        d get us to ExpSelect if we need it }
          Opp:=SelectOp;
          LLink:=Node3;
          RLink:=Node
          end;      if GAttr.TyPtr <> nil then
                  with GAttr,TyPtr^ do
                      if ((Form = Pointr) or (Form = F
      Selector:=Node1
      end
  end { Selector };
                                                                        iles)) then
                          begin
                          Kind := Varbl;
                          if Form = Poin{---------------------------------------------
{
{ Main Body Porcessing  Part B
{ Copyright (C) 1981  Three Rivers Computer Ctr then
                              begin
                              TyPtr := ElType;
                              LOpporporation
{
{ Abstract:
{    The second portion of main body processing - deals primarily with
{    procedure calls
{
{ F := PtrAccessor
                              end
                          else
                              begin
       ile: Body1.Pas
{
{----------------------------------------------}

{ }
{ 06-Feb-81  2.1  Miles A. Barel
{ Name Compatibil                       TyPtr := FilType;
                              LOpp := FileAccessor;
                              if ity
{ }
{ 7-Jan-81  1.6  Miles A. Barel
{ General cleanup and first use of standard 3RCC file formats
{ }

function Call(      with Node2^ do
                          begin
                          EAttr:=GAttr;
                          EType:TyPtr = nil then Error(399)
                              end;
                          end
                      else
    =Opnd;
                          SSy:=Ident;
                          OpClass:=Idd;
                          IIdent:=LCP.Id                      Error(141);
              New(ExpHeap,1,Node1,Opr);
              with Node1^ do
                  begiNum
                          end;
                      New(ExpHeap,1,Node1,Opr);
                      with Node1^ do
    n
                  EAttr:=GAttr;
                  EType:=Opr;
                  SSy:=Arrow;
                  Opp:=LOpp;
                      begin
                          EAttr:=GAttr;
                          EType:=Opr;
                                     LLink:=Node;
                  RLink:=nil
                  end;
              Node:=Node1;
                     SSy:=Period;
                          Opp:=FieldAccessor;
                          LLink:=Node;
                    InSymbol
              end;
          if not (Sy in FSys + SelectSys) then
            begin Error(6); Skip(FSys + SelectSys) 
  	
t recent Error info }
    ErrOnLine: boolean;             { true if statement has errors }
                                   e file for error msgs }
        PrevLine,
        CurLine: string[255];   { Current line, or as much as parsed }
        Next80
                                      chars }
    
    Lgth: integer;                  { Length of last string constant in { used for list file }
    SConst: CSP;                    { InSymbol string results }

    LineInfo: integer;

    CurPro chars }
    Val: Valu;                      { Value of last constant }
    Disx: DispRange;                { Level of last Idc,NextProc: ProcRange;     { Procedure number assignment }

    STypeBegSys,TypeBegSys,BlockBegSys,SelectSys,
    FacBegSys,S searched }

    LCMax: AddrRange;               { Temporaries location counter }

                            { Switches }tatBegSys,TypeDels: SetOfSys;
    
    Vars: SetOfIds;

type
    Where = (Blck, CRec, VRec, Rec);
    pHandList = ^HandLis
Const
    SwStrLen = 80;            { Max Length for Copyright and Version strings }
Type
    SwPtr = ^SwList;
    SwList =t;
    HandList = record
                  Hand: Integer;    { IdNum of handler to be enabled }
                  Next: pHand record
                Sw: Boolean;
                Previous: SwPtr
              end;
Var
    PrtErr,BPTOnLine,DP,ExitFunList
                end;

var
    Display: array [DispRange] of
                record
                  FName:integer;
c,List,
    GetStmtLev, IsProgram, Exporting,AutoInit: boolean;
    RangeCheck,Names,Noisy,Debug: SwPtr;
    VerStr,CopyStr:                   ForwCount:integer; { count of unresolved forward references }
                  case Occur: Where of
       string[SwStrLen];
    
                                    { Pointers to standard Ids }
    IntPtr,RealPtr,LongPtr,CharPtr,Bo             Blck: (FFile: integer; FLabel: LabelP);
                    CRec: (CLev: LevRange; CDspl: AddrRange);
           olPtr,
    TextPtr,NilPtr,StrgPtr: STP;
    
    UTypPtr,UCstPtr,UVarPtr,
    UFldPtr,UPrcPtr,UFctPtr,        { Pointers to          VRec: (VDspl: AddrRange; VTyp: EStackType)
                  end;

    LP: Text;
    
    CurByte, CurBlk: integerundeclared Ids }
    OuterBlock,FwPtr: integer;

    Level: LevRange;                { Current static level }
    BegStmtLev;       { refer to current input source file }

Type
    pDiskBuffer = ^ DskBuffer;
    DskBuffer = packed array [0..511] of,StmtLev: integer;    { Current statement nesting level }
    TOS: pLexStkRec;                { Top of lex stack }
    CurHeap AByte;

Var
    DiskBuf : pDiskBuffer;
    UniqueId: integer;              { next unique Id to be given by NextINum }
    : integer;               { Current Segment for New/Dispose }
    NewBlock: boolean;              { Indicates need to push lex s
    OutFile: FileId;                { Output File }
    OutFileName: FyleName;

Type
    pText = ^Text;
    IFPtr = ^Inputack }
    
    NextSeg,LastSeg: integer;       { Next Segment #, Last Seg usable }
    ErrNum,ErrLine: integer;        { MostFile;         { record keeping for multiple input files }
    InputFile = record
        FName: FyleName;        { Name of th 
 	
tifier representing the procedure/function to be called
{
{ Results:
{    The root node of the expression tree representing tExpHeap,1,Node3,Opr);
      with Node3^ do
          begin
          EType:=Opr;
          Opp:=PushParm;
          SSy:=FShe call
{
{ Side Effects:
{     The state of CurIFile will be modified
{
{ Calls:
{    Error
{    New
{    InSymbol
{  y;
          LLink:=Node2;
          RLink:=nil
          end;
      Node1^.RLink:=Node3;
      Node1:=Node3
      end { P  SearchId
{    LookupNum
{    Expression
{    ByteArray
{    CompTypes
{    PAOfChar
{    StrgType
{    GetBounds
{    aram };

begin { Call }
    ReadWrite:=false;
    NumParms:= 0;       { number of parameters processed thus far }
    if FParam
{
{ Design:
{    We are not going to build the traditional tree here.  For
{    ease of expansion (of the Special ProcCP.PFDecKind = Declared then
        begin
        NonSpecial:=true;
        ExitFunc:=false;
        Recasting:=false;
   edures in particular) we're
{    going to build a linear list (or something like this).  The Top
{    Node is the Calling Oper     ReadWrite:=false;
        with FCP do                         { Procedure/Function Identifier }
            if PFKind = Aator, and its left son, the proc or func to
{    be called.  The Right son of the top node is the parameter list.
{    Each Pactual then
                NXT := Next
            else
                NXT := PFParms
        end
    else
        beginrameter is the left son of a PushParm operator.  The right son
{    of the PushParm operator is the next parameter.  This is no
        NonSpecial:=false;
        if FCP.Key in [9,29] then       { RECAST and MAKEPTR }
            begin
            Recat a real
{    tree since the first parameter is at the top of the tree, not the
{    bottom.
{-------------------------------sting:=true;    { Special cases - LAST parameter is a type, }
            if FCP.Key = 9 then { not an expression }
          ----}
  label 1;
  var NXT: integer; LCP,LCP1: Identifier;
      Node,Node1,Node2,Node3: ESP; TChr: char;
      NonSpecial,R      TypeOff := 1    { RECAST - 2nd parameter is type }
            else
                TypeOff := 2    { MAKEPTR - 3rd paraeadWrite,Recasting: boolean;
      LMin, LMax, TypeOff, NumParms: integer;
      LSys: SetOfSys;

procedure Param(FSy: Symbmeter is type }
            end
        else
            Recasting:=false;
        ReadWrite := FCP.Key in [38..41];  { Readol);
{--------------------------------
{ Abstract:
{    Add a parameter to the expression tree
{
{ Parameters:
{    The sy, Write, Readln, Writeln }
        if FCP.Key in [8,30] then ExitFunc:=true        { EXIT or MAKEVRD }
        end;
    New(EFSys: SetOfSys; FCP:Identifier): ESP;
{-----------------------------------
{ Abstract:
{    Parse Procedure/Function calls anmbol terminating the parameter (either ',' or ':' - ':' used for
{    special read/write formatting stuff)
{
{ Side Effects:d build an expression tree
{
{ Parameters:
{    FSys - Legal terminators for the procedure/function call
{    FCP - The iden
{    Node1 (defined in Call) is modified
{
{ Calls:
{    New
{-----------------------------------}
      begin
      New(   	
ay[PackageName] of record
                Seg: SegRange;
                ModNam: Alpha;
                FilNam: string[23]
 y[1..MaxSymBlocks] of boolean;
                                    { true if BlockBuf has been written into }
    CurUsage: ar            end;
             
    Routine: array[RoutineName] of packed record
                Pkg: PackageName;
          ray[1..MaxSymBlocks] of integer;
                                    { counter to keep track of access freq }
    LastUsed: in      Rtn: ProcRange
             end;
             
const
    MaxSymBlocks = 32;          { maximum number of ST cache blocteger;              { freq index }
    SymFile: FileId;                { symbol table file }

const                          ks }
    DefSymBlocks = 24;          { standard number of ST cache blocks }
    STFileName = 'PASCAL.SYMBOL$';       { Symbol      { definitions for identifier hashing }
    HashSize = 257;                 { Size of the Hash Table }
    HashMax = HashSCh: char;           { one character look ahead }
        LinNum: integer;        { current line in source file }
        PrevFTable File }

var
    SymBlocks: integer;             { Actual # of Symbol Table Buffers }
    LastWritten: integer;        ile: IFPtr;        { ptr to record of previous file }
        EOL: boolean;           { true when NextCh contains first charact   { Greatest Symbol Table block used so far }
    TotalErrors: integer;           { Total Number of Errors }
type
    TestP er }
                                { of a new line and CurLine contains previous }
                                { line }= ^ TestPointer;
    TestPointer = record
                     ELT1,ELT2 : STP;
                     LastTestP : TestP
     
        IncludeFile: boolean;   { true when file is an include file }
        InFile: pText           { the actual file variab              end;

var
    GlobTestP: TestP;           { Last Test Pointer }

const                                   { Syle }
      end;

Var
    CurIFile: IFPtr;            { current Input File }
    InFileNesting: integer;     { input file nembol Table Stuff }
    IdsPerBlk = 12;             { number of Ids in a symbol table }
                                { cachesting depth }
    
    ResWords: array[1..ResCount] of ResWrdRec;  { res word table }
    ResHash: array[65..91] of integer;  block }
    
type                            { Symbol Table Stuff }
    pIdBlock = ^ IdBlock;
    IdBlock = record
                { hash index into ResWords }
    
    EStack:Array[1..EDepth] of EStackType;
    ETos: 0..EDepth;
    QCode: packed  Ids: Packed Array [0..IdsPerBlock-1] of Identifier;
         Filler: Packed Array [0..15] of integer;
       end;

var
   array [AByte] of packed record
                Src,Dst:0..15
              end;
    
    PDFile: file of ProcRec;
    Link  BlockBuf: array[1..MaxSymBlocks] of pIdBlock;
                                    { symbol table buffer }
    CurBlocks: arrList: array[SegRange] of LinkInfo;
    
    NextPEnter: integer;        { enter IC of next procedure }
    
    Package: array[1..MaxSymBlocks] of integer;
                                    { disk block # of contents of BlockBuf }
    CleanUp: arra  	
   SearchId([Proc,Func],LCP1);
                PrtErr := true;
                if LCP1.IdNum <> 0 then
                    be                                 STyp:=DynCst;
                                        CClass:=Strg
                          xpHeap,1,Node,Opnd);   { The Procedure or Function to be called }
    with Node^ do
        begin
        SSy:=Ident;
      gin
                    InSymbol;
                    if CompProcs(LCP,LCP1) then
                        begin
              EAttr:=GAttr;
        EType:=Opnd;
        OpClass:=Idd;
        IIdent:=FCP.IdNum
        end;
    New(ExpHeap,1,Node1,O            { parameter is OK }
                        New(ExpHeap,1,Node2,Opnd,Idd);
                        with Node2^ dopr);   { The Calling operator }
    with Node1^ do
        begin
        SSy:=Ident;
        EAttr:=GAttr;
        EType:=O
                            begin
                            SSy := Sy;
                            EType := Opnd;
        pr;
        Opp:=CallPF;
        LLink:=Node;
        RLink:=nil
        end;
    Node:=Node1;
    LSys := FSys + [Comma,R                    OpClass := Idd;
                            IIdent := LCP1.IdNum
                            end
        Parent];
    if ReadWrite then LSys := LSys + [Colon];
    if Sy = LParent then
        begin
        if (not NonSpecial) an                end                        
                    else
                        Error(142)
                    ed (FCP.Key = 11) then
            begin
            { Special Case: WORDSIZE  - One parameter, may be VAR, TYPE,
            nd
                else
                    Error(142)
                end
            else
                begin
          CONST or FUNCTION }
            InSymbol;
            SearchId([Types,FormalVars,ActualVars,Konst,Field,Func],LCP);
               Node2:=Expression(LSys);
                if NonSpecial then
                    if (GAttr.TyPtr <> nil) then
             New(ExpHeap,1,Node2);
            with Node2^ do
                begin
                EAttr.TyPtr:=LCP.IdType;
                       begin
                        with GAttr do
                            if (Kind = Cst) and (TyPtr = CharPtr)          RLink:=nil;
                LLink:=nil
                end;
            Node1^.RLink:=Node2;
            InSymbol;then
                                if ByteArray(LCP.IdType) then
                                    begin
                
            end
        else
          repeat
            if NonSpecial then
                begin
                if NXT                     TyPtr:=LCP.IdType;
                                    TChr:=chr(CVal.IVal);
                             = 0 then Error(126);
                LookupNum(NXT,LCP)
                end;
            InSymbol;
            NumParms:=Num       New(CurHeap,1,CVal.ValP,Strg);
                                    with CVal.ValP^ do
                                 Parms + 1;
            if LCP.Klass in [Func,Proc] then
                begin
                PrtErr := false;
                    begin
                                        SVal[1]:=TChr;
                                        SLgth:=1;
          	
earch (Root: integer; var Found: Identifier; SName: Alpha):
                                                               inteess;
Imports CmdParse from CmdParse;

const
{ Keys of Ord,Chr, ReCast and WordSize functions - used by Constant }
    OrdKeger;
procedure SearchId (FiDcls: SetOfIds; var FCP: Identifier);
procedure GetBounds (FSP: STP; var FMin,FMax: integer);
procy    = 3;
    ChrKey    = 13;
    ReCastKey = 26;
    WrdSizKey = 11;

    EMFileName = 'PASCAL.SYNTAX';       { Error Messedure Skip (FSys: SetOfSys);
function  PAOfChar (FSP: STP): boolean;
function  StrgType (FSP: STP): boolean;
function  ByteArage File }

{$R-}

{$INC PAS0 }
{$INC PAS1 }
{$INC PAS2 }
                                                               ray (LSP: STP): boolean;
function  MultiAccess (LSP: STP): boolean;
procedure Constant (FSys: SetOfSys; var FSP: STP; var FVal{-----------------------------
{
{ General Compiler Procedures (Part A)
{ Copyright (C) 1981 Three Rivers Computer Corporatiou: Valu);
function  CompTypes (FSP1,FSP2: STP): boolean;
procedure GenByte (FByte: AByte);
procedure GenWord (FWord: integer)n
{
{ Abstract:
{    General Compiler Utility Routines
{
{ File:
{    Pas0.Pas
{
{-----------------------------}

{ };
procedure GenNAWord (FWord: integer);
procedure WriteCode (ForceBuf: boolean);
procedure Block (FSys: SetOfSys);
function 
{ 1 Apr 81  3.1  Miles A. Barel
{ Update for new OS Filenames
{ }
{ 03-Feb-81  2.0  Miles A. Barel
{ Implementation of Lon NextINum: integer;
procedure WriteNum (var FCP: Identifier);
procedure LookupNum (IdNm: integer; var FCP: Identifier);
proceg Integers
{ }
{ 28-Jan-81  1.15  Miles A. Barel
{ New switch structure, along with conditional compilation, $COMMENT switch,ize - 1;         { Highest index into the hash table }
    HashLevels = 1;                 { greatest TOP value to be hashed }dure NewIFile (var FilName:FyleName; InclFile: boolean);
procedure EPush (Typ:EStackType);
procedure EPop (HowMany: integer);
    
var                                 { the hash table }
    HashTable: array[0..HashLevels,0..HashMax] of integer;

typ
procedure EQuick (Deep:integer);
procedure GetFileExtension (var FStr:FyleName);
function  HashIx (Name: Alpha):integer;
fune
    Conditionals = (CondOn, CondOff, CondEOn, CondEOff);
    CondPtr = ^CondSwitch;
    CondSwitch = record
        Cond: ction CompProcs(var LCP1,LCP2: Identifier):boolean;
function CompParms(FSP1,FSP2: STP; Class: IdClass):boolean;

PRIVATE

Conditionals;
        Prev: CondPtr
      end;
var
    CondCompile: CondPtr;

{------------------------------------------{$C Copyright (C) 1981  Three Rivers Computer Corporation }

Imports System from System;
Imports Memory From Memory;
Imports}
{
{ Global Utility Procedures / Functions
{
{------------------------------------------}

procedure Error (ErrorNum: int PERQ_String from Perq_String;
Imports Code from Code;

Imports QCodes from QCodes.Dfs;
Imports InitGlobals from CompInit;
eger);
procedure PrintLine;
procedure EnterId (var FCP: Identifier);
procedure Advance;
procedure InSymbol;
function  TreeSImports DecPart from DecPart;
Imports BodyPrt from BodyPart;
Imports CodeGeneration from CodeGen;
Imports Progress from Progr  	
                Error(142)
                                        end
                                end
                  pe;
                                    LLink:=nil;
                                    RLink:=nil
                                    else
                                Error(142)
                        end
                end;
            Param          end;
                                GAttr.TyPtr:=LCP.IdType;
                                Node1^.RLink:=Node2;
(Comma);
            if NonSpecial then
                begin
                if NXT <> 0 then NXT := LCP.Next
                                             InSymbol;
                                if Sy <> RParent then Error(4)
                        end
            else
                if ReadWrite then
                    begin
                    if Sy = Colon then
           end
                            end
          until Sy <> Comma;
        if Sy = RParent then InSymbol else Error(              end;
                                    Node2^.EAttr:=GAttr
                                    end;
                                 begin
                        InSymbol;
                        Node2 := Expression(LSys);
                         if not CompParms(LCP.IdType,GAttr.TyPtr,LCP.Klass) then
                            if PAOfChar(LCP.IdType) and               Param(Colon);
                        if Sy = Colon then
                            begin
                    StrgType(GAttr.TyPtr)
                              and (GAttr.Kind = Cst) then
                                begin
               InSymbol;
                            Node2 := Expression(LSys - [Colon]);
                            Param(Colon)
                          { we've got a formal PA of Char and actual
                                  string constant - If leng                           end
                        end
                    end
                else
                    ths are the same,
                                  then OK
                                }
                               if Recasting then
                      { NOTE: Type parameter MUST BE LAST PARM }
                        if NumParms = TypeO if LCP.IdType <> nil then
                                  with LCP.IdType^ do
                                    if InxTypff then
                            begin
                            if Sy <> Comma then
                                Erre <> nil then
                                        begin
                                        GetBounds(InxType,LMin,LMaor(126)
                            else
                                begin
                                InSymbol;
   x);
                                        if LMax-LMin+1 = GAttr.CVal.ValP^.SLgth
                                                                       SearchId([Types],LCP);
                                New(ExpHeap,1,Node2);
                    then
                                            {}
                                        else
                                        with Node2^ do
                                    begin
                                    EAttr.TyPtr:=LCP.IdTy   	
onto the simulated EStack
{ Parameters:
{    Typ - The item to be pushed onto the EStack
{ Side Effects:
{    ETos and EStac if Debug^.Sw then
    begin
    write('EPOP(',HowMany:1,')');
    if ETos > 0 then
        for i:=ETos Downto 1 do write(' k are modified to reflect the new stack item.
{ Errors:
{    EStack Overflo
{ Calls:
{    Error
{--------------------------',ord(EStack[i]):1)
    else
        write(' <empty>');
    writeln
    end;
{$ENDC }
end { EPop };

Procedure EQuick(D---}
  var i:integer;
begin
if (Typ = Data16) or (Typ = Off20) then
    if ETos >= EMax then
        begin
        ETos:=0eep:integer);
{--------------------------
{ Abstract:
{    See if there is enough room on the EStack for some quick temporari;
        Error(307)
        end
else
    if ETos+1 >= EMax then
        begin
        ETos:=0;
        Error(307)
     es
{ Parameters:
{    Deep - Number of words needed
{ Errors:
{    EStack Overflo
{ Calls:
{    Error
{------------------   end;
ETos:=ETos+1;
case Typ of
    Data16:     EStack[ETos]:=Data16;
    
    Data32:     begin
                EStack[--------}
begin
if ETos+Deep > EMax then Error(307);
{$IFC DebEStack THEN }
  if Debug^.Sw then writeln('EQUICK(',Deep:1,')'ETos]:=Data32;
                ETos:=ETos+1;
                EStack[ETos]:=Data32
                end;

    Ptr32:      beg);
{$ENDC }
end { EQuick };

procedure Error(ErrorNum: integer);
{---------------------------------
{ Abstract:
{    Repin
                EStack[ETos]:=Ptr32;
                ETos:=ETos+1;
                EStack[ETos]:=Ptr32
                enort compilation errors to the programmer
{ Parameters:
{    ErrorNum - The Error Number
{ Environment:
{    Opens and reads d;

    Off20:      EStack[ETos]:=Off20
    
    end { case };
{$IFC DebEStack THEN }
  if Debug^.Sw then
      begin
  PASCAL.SYNTAX to get error text
{ Side Effects:
{    May terminate compiler execution
{ Calls:
{    Write/Writeln
{    Rese    write('EPUSH(',ord(Typ):1,')');
      for i:=ETos Downto 1 do write(' ',ord(EStack[i]):1);
      writeln
      end;
{$ENt
{    Get
{    Close
{    Readln
{    CreateWindow
{    ChangeWindow
{    QuitProgress
{--------------------------------DC }
end { EPush };

Procedure EPop(HowMany: integer);
{---------------------------
{ Abstract:
{    Remove items from th-}
  type ErrRec = record
          ErrNum: integer;
          ErrMsg: string[80]
      end;
  var Errs: file of ErrRec; Co
{ and $MESSAGE switch
{ }
{ 15-Jan-81  1.12  Miles A. Barel
{ Hashing for compiler names and user globals
{ }
{ 14-Jan-81e simulation EStack
{ Parameters:
{    HowMay - number of items to pop from the stack
{ Side Effects:
{    Modifies ETos
{   1.11  Miles A. Barel
{ New Switch - $N /NAMES /NONAMES
{ }
{ 30-Dec-80  1.6  Miles A. Barel
{ Cleanup and first use of staErrors:
{    EStack Underflo
{ Calls:
{    Error
{----------------------------}
  var i:integer;
begin
ETos:=ETos-HowManyndard 3RCC file formats
{ }

procedure EPush(Typ:EStackType);
{-----------------------------
{ Abstract:
{    Push items ;
if ETos < 0 then
    begin             { EStack Underflo }
    ETos:=0;
    Error(308)
    end;
{$IFC DebEStack THEN }
  	
function Expression(FSys: SetOfSys): ESP;
{----------------------------------------------
{ Abstract:
{    The first pass parr);
            with Node^ do
                begin
                EAttr:=Node1^.EAttr;
                EAttr.TyPtr:=RealPtsing of expressions.  Builds an expression tree to
{    be expanded later to code by ExpExpression.
{
{ Parameters:
{    FSyr;
                EType:=Opr;
                SSy:=ChangeSy;
                Opp:=FltOp;
                LLink:=nil;
     s - Legal terminal symbols for the expression
{
{ Results:
{    The root node of the expression tree representing the express           RLink:=Node1
                end;
            Node1:=Node
            end;
        if CompTypes(Node2^.EAttr.TyPtion
{
{ Side Effects:
{    The state of CurIFile is modified
{
{ Calls:
{    SimpleExpression
{    InSymbol
{    CompTypr,IntPtr) then
            begin
            New(ExpHeap,1,Node,Opr);
            with Node^ do
                begin
     es
{    Error
{    ByteArray
{    New
{    FloatNode
{    StrchNode
{
{ Design:
{    Note: Expression is declared forwar           EAttr:=Node2^.EAttr;
                EAttr.TyPtr:=RealPtr;
                EType:=Opr;
                SSy:=Changed in Body0.Pas
{----------------------------------------------}
    var LAttr: Attr; LOp: Operator; SaveSy: Symbol;
        NSy;
                Opp:=FltOp;
                LLink:=nil;
                RLink:=Node2
                end;
            Node,Node1,Node2:ESP; TChr: char;

procedure FloatNode(var Node1,Node2:ESP;ForceFloat: boolean);
{---------------------------ode2:=Node
            end
        end
    end { FloatNode };

procedure StrchNode(var Node1,Node2:ESP;ForceStrch: boolean4)
        end { LParent };
    if FCP.IdType <> nil then GAttr.TyPtr := FCP.IdType;
    if NonSpecial then
        begin
 --------
{ Abstract:
{    Checks for mixed REAL and INTEGER operands - where conversion to REAL
{    of the INTEGER operand w       if NXT <> 0 then Error(126)
        end
    else
        ExitFunc:=false;
    Call:=Node
    end { Call };
        ill be needed - and placed operator to later
{    generate a FLT QCode into the expression tree
{
{ Parameters:
{    Node1 -{--------------------------------------------
{
{ Main Body Processing  Part C
{ Copyright (C) 1981  Three Rivers Computer Co The first operand root node
{    Node2 - The second operand root node
{    ForceFloat - True if all operands must be REAL
{rporation
{
{ Abstract:
{    The third part of main body processing - mainly deals with expressions.
{
{ File: Body2.Pas
{
{ Side Effects:
{    Node1 and/or Node2 may be modified
{
{ Calls:
{    CompTypes
{---------------------------------------
{---------------------------------------------

{ }
{ 9-Jan-81  1.9  Miles A. Barel
{ Space allocated to dynamic string c-}
      var Node:ESP;
    begin
    if (Node1^.EAttr.TyPtr = RealPtr) or (Node2^.EAttr.TyPtr = RealPtr) or
      ForceFloatonstants is now returned
{ }
{ 7-Jan-81  1.6  Miles A. Barel
{ General Cleanup and institution of 3RCC file formats
{ }

 then
        begin
        if CompTypes(Node1^.EAttr.TyPtr,IntPtr) then
            begin
            New(ExpHeap,1,Node,Op   	
ntFlg:string;
begin
if not ((ErrorNum in [306..308]) and (CurIFile^.LinNum <= (ErrLine + 4))) then
    begin
    TotalErrorsnteger; NStr: string;
begin
i:=FSLookup(FStr,Blks,Bits);
if i = 0 then
    begin
    NStr:=Concat(FStr,DefIExtension);
   :=TotalErrors+1;
    ErrNum:=ErrorNum;
    ErrLine:=CurIFile^.LinNum;
    ErrOnLine:=true;
    writeln(chr(7),CurIFile^.Prev i:=FSLookup(NStr,Blks,Bits);
    if i <> 0 then
        FStr:=NStr;
    end
end { GetFileExtension };

procedure NewIFilLine);
    writeln(CurIFile^.CurLine);
    with CurIFile^ do
        begin
        writeln('File ',FName,', Line ',LinNum);e(var FilName:FyleName; InclFile: boolean);
{----------------------------------
{ Abstract:
{    Open a new input file for re
        write('Error ',ErrNum)
        end;
    reset(Errs,EMFileName);
    while (Errs^.ErrNum < ErrNum) and (Errs^.ErrNum ading (nested within any currently open files)
{    and get the first lexeme from the new file
{ Parameters:
{    FilName - t>= 0) do
        Get(Errs);
    writeln(Errs^.ErrMsg);
    close(Errs);
    Write(Output,'<ret>(continue), Q<ret>(terminate)he name of the file to be opened (default extension processing
{              is done here.
{    InclFile - TRUE if the file t');
    readln(Input,ContFlg);
    if length(ContFlg) > 0 then
        if (ContFlg[1] = 'Q') or (ContFlg[1] = 'q') then
    o be opened is an INCLUDE file (This affects
{               the actions taken on End-Of-File)
{ Side Effects:
{    Places a         begin
            FSClose(SymFile,0,0);
            FSDelete(STFileName);
            Close(PDFile);
            FSDnew IFPtr in the chain of open files.
{    Redirects input to come from the new file.
{    Gets new value for Sy, Id and Op
{elete(PDFileName);
            FSCLose(OutFile,0,0);
            FSDelete(OutFileName);
            Exit(PascalCompiler)
    Errors:
{    File Not Found
{    Empty File is illegit.
{ Calls:
{    GetFileExtension
{    New
{    Reset
{    Error
{         end;
    end
end { Error };

procedure GetFileExtension(var FStr: FyleName);
{-------------------------------
{     Get
{    InSymbol
{------------------------------------}
  var TmpIFile: IFPtr;
begin
new(TmpIFile);
with TmpIFile^ doAbstract:
{    Find the correct name for input files.  If the named file does not
{    exist, try appending the default input 
    begin
    new(InFile);
    GetFileExtension(FilName);
    reset(InFile^,FilName);
    if EOF(InFile^) then            file name extension
{ Parameters:
{    FStr - the name of the file to be found.  Will be returned with the
{           defaul    { Null File is Illegit }
        begin
        Error(401);
        Exit(PascalCompiler)
        end;
    FName:=FilNamet extension appended if this is the filename to be used.
{ Results:
{    The full name of the input file to be used is returne;
    PrevLine:='';
    CurLine:='';
    NextCh:=InFile^^;
    Get(InFile^);
    EOL:=false;
    IncludeFile:=InclFile;
 d in FStr
{ Calls:
{    FSLookup
{    FSClose
{    Concat
{----------------------------------}
  var i:FileId; Bits,Blks:i   LinNum:=0;
    PrevFile:=CurIFile
    end;
CurIFile:=TmpIFile;
InSymbol;
WriteLn(Output,'':InFileNesting,'[',FilName,']'  	
ue if all operands must be LONG
{
{ Side Effects:
{    Node1 and/or Node2 may be modified
{
{ Calls:
{    CompTypes
{----File is modified
{
{ Calls:
{    InSymbol
{    Term
{    New
{    FloatNode
{    StrchNode
{    Error
{    CompTypes
{------------------------------------}
      var Node:ESP;
    begin
    if (Node1^.EAttr.TyPtr = LongPtr) or (Node2^.EAttr.Ty--------------------------------------------}
      var LAttr: Attr; LOp: Operator; Signed: boolean;
          Node,Node1,NodePtr = LongPtr) or
      ForceStrch then
        begin
        if CompTypes(Node1^.EAttr.TyPtr,IntPtr) then
            begin2:ESP;

function Term(FSys: SetOfSys): ESP;
{-------------------------------------------
{ Abstract:
{    Parse Terms - ba
            New(ExpHeap,1,Node,Opr);
            with Node^ do
                begin
                EAttr:=Node1^.EAttr;
sically includes operators *, /, DIV, MOD and AND
{
{ Parameters:
{    FSys - legal terminals for the simple expression
{
{                EAttr.TyPtr:=LongPtr;
                EType:=Opr;
                SSy:=ChangeSy;
                Opp:=StrchOp Results:
{    The root node of the expression tree representing the term parsed
{
{ Side Effects:
{    The state of CurIFil;
                LLink:=nil;
                RLink:=Node1
                end;
            Node1:=Node
            end;
 e is modified
{
{ Calls:
{    InSymbol
{    Factor
{    New
{    FloatNode
{    StrchNode
{    Error
{    CompTypes
{-       if CompTypes(Node2^.EAttr.TyPtr,IntPtr) then
            begin
            New(ExpHeap,1,Node,Opr);
            with N-------------------------------------------}
        var LAttr: Attr; LSP: STP; LOp: Operator;
            Node,Node1,Node2:ESode^ do
                begin
                EAttr:=Node2^.EAttr;
                EAttr.TyPtr:=LongPtr;
                ETyP;

function Factor(FSys: SetOfSys): ESP;
{-------------------------------------------
{ Abstract:
{    Parse Factors - bape:=Opr;
                SSy:=ChangeSy;
                Opp:=StrchOp;
                LLink:=nil;
                RLink:=Nodsically includes recognition of 'selectors', parsing of
{    constants, complex expressions, set expressions and the NOT operate2
                end;
            Node2:=Node
            end
        end
    end { FloatNode };

function SimpleExpreor
{
{ Parameters:
{    FSys - legal terminals for the simple expression
{
{ Results:
{    The root node of the expression);
{-----------------------------------
{ Abstract:
{    Checks for mixed LONG and INTEGER operands - where conversion to LONssion(FSys: SetOfSys): ESP;
{-------------------------------------------
{ Abstract:
{    Parse Simple Expressions - basicallG
{    of the INTEGER operand will be needed - and placed operator to later
{    generate a STRCHL QCode into the expression ty includes operators +, -, and OR
{
{ Parameters:
{    FSys - legal terminals for the simple expression
{
{ Results:
{    ree
{
{ Parameters:
{    Node1 - The first operand root node
{    Node2 - The second operand root node
{    ForceStrch - TrThe root node of the expression tree representing the simple expression
{    parsed
{
{ Side Effects:
{    The state of CurI   	
   May cause another block already loaded to be swapped back out to
{    the symbol table file (a write only occurs if the blocesident, it will be
{    loaded first.  The buffer containing the symbol table block will
{    be flagged as dirty.
{ Calls:k is flagged as
{    being dirty
{ Calls:
{    FSBlkWrite
{    FSBlkRead
{----------------------------}
  label 1,2;
  va
{    LoadBlock
{---------------------------}
  var I,J: integer; LCP: Identifier;
begin
I:=FCP.IdNum div IdsPerBlk;     { Gr i,j,k:integer;
begin
{ do we already have the block? }
for i:=1 to SymBlocks do
    if CurBlocks[i] = BNum then
        bet disk block number for Id }
J:=LoadBlock(I);                { Make sure we've got the block in memory }
CleanUp[J]:=true;   );
InFileNesting:=InFileNesting+2
end { NewIFile };

procedure PrintLine;
{-----------------------------
{ Abstract:
{  egin
        j:=i;
        goto 1
        end;
{ we don't have it }
{ is there already a free buffer ? }
for i:=1 to SymBl  Print List File
{ Environment:
{    List File must be open on file variable LP
{-----------------------------}
  var DOrLeocks do
    if CurBlocks[i]=-1 then
        begin
        j:=i;
        goto 2
        end;
{ no free buffer, punt one firv,StarOrC: char; 
begin
StarOrC := ':';
if DP then
    DOrLev := 'D'
else
    DOrLev := chr((BegStmtLev mod 10) + ord('0')st }
k:=32767; j:=1;
for i:=1 to SymBlocks do
    if CurUsage[i] < k then
        begin
        k:=CurUsage[i];
        j:);
if BPTOnLine then StarOrC := '*';
Write(LP,CurIFile^.LinNum:6,Seg:4,CurProc:5,
            StarOrC,DOrLev,LineInfo:6,' ');=i;
        end;
{ j is index of block to punt }
if CleanUp[j] then
    { must write old contents out first }
    FSBlkWrit
WriteLn(LP,CurIFile^.CurLine);
if ErrOnLine then
    begin
    WriteLn(LP,'>>> Error # ',ErrNum);
    ErrOnLine:=false
  e(SymFile,CurBlocks[j],recast(BlockBuf[j],pDirBlk));
2: CleanUp[j]:=false;
CurBlocks[j]:=BNum;
if BNum <= LastWritten then
   end
end { PrintLine };

function NextINum;
{--------------------------
{ Abstract:
{    Get the next unique identifier    FSBlkRead(SymFile,BNum,recast(BlockBuf[j],pDirBlk))
else
    LastWritten := BNum;
1: LastUsed:=LastUsed+1;
if LastUsed <=IdNum
{ Results:
{    The unique IdNum
{--------------------------}
begin
UniqueId:=UniqueId+1;
NextINum:=UniqueId;
end; 0 then
    begin
    { we can't really handle wrap around so...chocolate covered fudge }
    LastUsed:=1;
    for i:=1 to S

function LoadBlock(BNum:integer):integer;
{---------------------------
{ Abstract:
{    Load a Symbol Table Block from thymBlocks do
        CurUsage[i]:=0
    end;
CurUsage[j]:=LastUsed;
LoadBlock:=j
end {LoadBlock};

procedure WriteNum(vare Symbol table file
{ Parameters:
{    BNum - The absolute block of the symbol table file to be loaded
{ Results:
{    The B FCP: Identifier);
{--------------------------
{ Abstract:
{    Write an Identifier out to the Symbol Table
{ Parameters:
{uffer index for the block
{ Environment:
{    The Symbol Table file must be open on file variable SymFile
{ Side Effects:
{     FCP - the identifier to be entered in the symbol table
{ Side Effects:
{    If the appropriate symbol table block is not r  	
 tree representing the factor parsed
{
{ Side Effects:
{    The state of CurIFile is modified
{
{ Calls:
{    Error
{      New(ExpHeap,1,Node,Opnd,Kst);
                                     with Node^ do
                                         beNew
{    InSymbol
{    Expression
{    Factor
{    CompTypes
{    SearchId
{    Call
{    Selector
{--------------------gin
                                         EAttr:=GAttr;
                                         SSy:=SaveSy;
            ------------------------}
          var LCP: Identifier; LVP,LVP1: CSP;
              LSP: STP; LIC,LOp: integer;
                                        OpClass:=Kst;
                                         EType:=Opnd
                                 CstPart: set of 0..127; Test: Boolean;
              LAttr: Attr; Node,Node1,Node2,Node3: ESP;
              SaveSy: Symbol           end;
                                     end
                             else
                                 N;
        begin
        if not (Sy in FacBegSys) then
            begin
            Error(58); Skip(FSys + FacBegSys);
    ode:=Selector(FSys,LCP)
                         end
                     else
                         begin
                      Node:=nil;
            GAttr.TyPtr := nil
            end;
        if Sy in FacBegSys then   { redundant test for err           SearchId([Func,Proc],LCP);
                         New(ExpHeap,1,Node,Opnd,Idd);
                         with Nodor recovery attempt }
            begin
            SaveSy:=Sy;
            case Sy of
      { Id }  Ident: if not ExitFunc e^ do
                             begin
                             SSy:=Ident;
                             OpClass:=Idd;then
                         begin
                        SearchId([Konst,FormalVars,ActualVars,Field,Func],LCP);
         
                             EType:=Opnd;
                             IIdent:=LCP.IdNum
                             end;
                 InSymbol;
                         if LCP.Klass = Func then
                             begin
                                      InSymbol
                         end;
      
      { Cst } IntConst:
                  begin
                    Node:=Call(FSys,LCP);
                             GAttr.Kind := Expr;
                             Node^.EAttr             with GAttr do
                      begin
                      TyPtr := IntPtr; Kind := Cst;
                  :=GAttr
                             end
                         else
                             if LCP.Klass = Konst then    CVal := Val
                      end;
                  New(ExpHeap,1,Node,Opnd,Kst);
                  with Node^ do
 
                                 with GAttr, LCP do
                                     begin
                                                  begin
                      EAttr:=GAttr;
                      EType:=Opnd;
                      SSy:=        TyPtr := IdType; Kind := Cst;
                                     CVal := Values;
                                   IntConst;
                      OpClass:=Kst
                      end;
                  InSymbol
                  end;
    	
 with FCP do
        begin
        IdNum:=0;
        RLink:=0;
        LLink:=0;
        end
else
    begin
    I:=IdNm        end;
        if I = 1 then
            LCP.RLink:=FCP.IdNum
        else
            LCP.LLink:=FCP.IdNum;
        Wdiv IdsPerBlk;      { Get disk block number }
    J:=LoadBlock(i);            { Get the block in memory }
    I := IdNm mod IdriteNum(LCP);
        end
    end
else
    begin
    if Display[Top].FName = 0 then
        { first Id of Display[Top] }
sPerBlk;    { Get index into BlockBuf }
    FCP := BlockBuf[J]^.Ids[I]
    end
end {LookupNum};

function HashIx(Name: Alp        Display[Top].FName:=FCP.IdNum
    else
        begin
        I:=TreeSearch(Display[Top].FName,LCP,FCP.Name);
       ha):integer;
{-----------------------
{ Abstract:
{    Compute the hash value for an identifier
{
{ Parameters:
{    Name  while I = 0 do
            begin
            Error(101);
            { Id declared twice (or more maybe) }
            if L- The name of the identifier to hash with
{
{ Results:
{    The hash value for the specified identifier name
{--------------CP.RLink = 0 then
                I := 1
            else
                I := TreeSearch(LCP.RLink,LCP,FCP.Name);
         ---------}
  var Val,i:integer;
begin
Val:=0;
for i:=1 to UniqLength do
    Val:=Val + Ord(Name[i]);
HashIx := Val Mod Has   end;
        if I = 1 then
            LCP.RLink:=FCP.IdNum
        else
            LCP.LLink:=FCP.IdNum;
        Write            { we're gonna write on BlockBuf }
I:=FCP.IdNum mod IdsPerBlk;     { Get correct index into BlockBuf.Ids }
BlockBufhSize
end { HashIx };

procedure EnterId(var FCP: Identifier);
{-----------------------
{ Abstract:
{    Enter a NEW iden[J]^.Ids[I]:=FCP                { copy the identifier }
end {WriteNum};

procedure LookupNum(IdNm: integer; var FCP:Identifitifier in the symbol table
{
{ Parameters:
{    FCP - The identifier to be entered
{
{ Side Effects:
{    May cause symboler);
{------------------------
{ Abstract:
{    Lookup an identifier in the symbol table (by number)
{ Parameters:
{    IdN table swapping
{
{ Calls:
{    TreeSearch
{    Error
{    WriteNum
{-------------------------}
  var I,Hash: integer;  Lm - the unique ID of the identifier to be looked up
{    FCP  - place to return the identifier
{ Results:
{    The requested CP: Identifier;
begin
if Top <= HashLevels then
    begin
    Hash:=HashIx(FCP.Name);
    if HashTable[Top,Hash] = 0 then
identifier is returned in FCP
{ Side Effects:
{    May cause symbol table swapping
{ Errors:
{    If IdNm is invalid n ident        HashTable[Top,Hash] := FCP.IdNum
    else
        begin
        I:=TreeSearch(HashTable[Top,Hash],LCP,FCP.Name);
   ifier is returned with IdNum = 0 and
{    both LLink and RLink = 0.
{ Calls:
{    LoadBlock
{------------------------}
  va     while I = 0 do
            begin
            Error(101);
            { Id declared twice (or more maybe) }
            r I,J:integer;
begin
{ first check for IdNm validity }
if (IdNm < MinId) or (IdNm > UniqueId) then
    { IdNm invalid }
   if LCP.RLink = 0 then
                I := 1
            else
                I := TreeSearch(LCP.RLink,LCP,FCP.Name);
       	
               New(ExpHeap,1,Node,Opnd,Kst);
                  with Node^ do
                      begin
                    l
                              end
                      end;
        
      { [ }   LBrack:
                  begin
      EAttr:=GAttr;
                      EType:=Opnd;
                      SSy:=StringConst;
                      OpClass:=Kst              InSymbol;
                  Node:=nil;
                  New(CurHeap,1,LSP,Power);
                  with LSP^ 
                      end;
                  InSymbol
                  end;

      { ( }   LParent:
                  bedo
                    begin ElSet := nil; Size := 0; Form := Power end;
                  if Sy = RBrack then
                             
              RealConst:
                  begin
                  with GAttr do
                      begingin
                  New(ExpHeap,1,Node,Opr);
                  with Node^ do
                      begin
                 
                      TyPtr := RealPtr; Kind := Cst;
                      CVal := Val
                      end;
              SSy:=LParent;
                      EType:=Opr;
                      { Don't care about Opp }
                      InS         New(ExpHeap,1,Node,Opnd,Kst);
                  with Node^ do
                      begin
                      EAttymbol;
                      LLink:=Expression(FSys + [RParent]);
                      RLink:=nil;
                      EAtr:=GAttr;
                      EType:=Opnd;
                      SSy:=RealConst;
                      OpClass:=Kst
      tr:=LLink^.EAttr
                      end;
                  if Sy = RParent then InSymbol else Error(4)
                  e                end;
                  InSymbol
                  end;
                
              StringConst:
        nd;
        
      { Not } NotSy:
                  with GAttr do
                      begin
                      InSymbo          begin
                  with GAttr do
                      begin
                      if Lgth = 1 then
         l; Node1:=Factor(FSys);
                      New(ExpHeap,1,Node,Opr);
                      with Node^ do
                                   begin
                          TyPtr := CharPtr;
                          CVal.IVal := Val.IVal
                  begin
                          EAttr:=GAttr;
                          EType:=Opr;
                          SSy:=No                end
                      else
                          begin
                          TyPtr := StrgPtr;
 tSy;
                          Opp:=NotOpr;
                          LLink:=nil;
                          RLink:=Node1
                            New(CurHeap,1,CVal.ValP,Strg);
                          CVal.ValP^:=Val.ValP^;
                                            end;
                      if TyPtr <> nil then
                          if not CompTypes(TyPtr,BoolPt     CVal.ValP^.STyp:=DynCst
                          end;
                      Kind := Cst
                      end;
   r) then
                              begin
                              Error(135);
                              TyPtr:=ni   	
    return to the previous input file
{ Errors:
{    Unexpected end of input - causing compiler termination
{ Calls:
{    Erere applicable.
{ Errors:
{    Invalid character in text
{ Calls:
{    Advance
{    Error
{-------------------------------ror
{    Dispose
{    Close
{    Get
{---------------------------}
  var TmpIFile: IFPtr;
begin
if CurIFile = nil then
 -}
  var LVP: CSP; GotASymbol: boolean;

procedure Search;
{-----------------------------------
{ Abstract:
{    Get the    begin
    Error(401);
    Exit(PascalCompiler)
    end;
if CurIFile^.InFile = nil then
    begin
    Error(401);
    Enext alpha-numeric name from the input file, and check to see
{    if it's a reserved word.
{ Side Effects:
{    Sy, Id and Oxit(PascalCompiler)
    end;
with CurIFile^ do
    begin
    if EOL then       { currently have first character of line in Np will be modified.
{    The state of CurIFile will be modified.
{ Calls:
{    Advance
{------------------------------------extCh }
        begin
        EOL := false;
        PrevLine:=CurLine;
        {$R-}
        CurLine[0]:=chr(1);
        C-}
    var i,count:integer; GoodChrs: Set of Char; Ch: char;
  begin
  count:=0;
  GoodChrs := ['0'..'9','A'..'Z','a'..'z','urLine[1]:=NextCh;
        {$R=}
        end
    else
        begin         { append character to CurLine }
        {$R-}
_'];
  if PrsFilNam then
      GoodChrs := GoodChrs + [':','.','>','$'];
  InSymStr := '';
  with CurIFile^ do
    while Ne        CurLine[0]:=chr(Length(CurLine)+1);
        CurLine[Length(CurLine)]:=NextCh;
        {$R=}
        end;
    EOL:=EOxtCh in GoodChrs do
      begin
      if (NextCh >= 'a') and (NextCh <= 'z') then
           Ch:=chr(ord(NextCh)-ord(' '))
 LN(InFile^);
    if EOF(InFile^) then
        begin
        Close(InFile^);
        Dispose(InFile);
        InFile:=nil;       else
           Ch:=NextCh;
      if count < UniqLength then
          begin
          count:=count+1;
          Id[co     { Just to make sure }
        if IncludeFile then
            begin
            TmpIFile:=PrevFile;
            Disposeunt]:=Ch
          end;
      if PrsFilNam then
          if Length(InSymStr) < 80 then
              begin
              {Num(LCP);
        end
    end;
FCP.LLink:=0;
FCP.RLink:=0;
WriteNum(FCP)
end { EnterId };

procedure Advance;
{-------(CurIFile);
            CurIFile:=TmpIFile
            end;
        InFileNesting:=InFileNesting-2
        end
    else
  ------------------
{ Abstract:
{    Get the next character from the current Input File
{ Environment:
{    There must be  fi      begin
        NextCh:=InFile^^;
        Get(InFile^)
        end
    end
end { Advance };

procedure InSymbol;
{-le open on file variable CurIFile^.InFile
{ Side Effects:
{    The state of CurIFile will be modified.
{    If the current In------------------------------
{ Abstract:
{    Gets the next lexeme from the Input file
{ Side Effects:
{    Sy, Id and Op put File reached EOF then the current file variable
{    and the current CurIFile will be disposed and input processing will
{will be modified.
{    The state of CurIFile will be modified.
{    Processes compiler switches - and takes desired actions wh  	
               begin
                                  Error(136);
                                  GAttr.TyPtr := nil;
       GAttr.TyPtr:=nil;
                                              Node2^.EAttr.TyPtr:=nil
                                                                 Node1^.EAttr.TyPtr:=nil
                                  end
                              else           end;
                                          with Node3^ do
                                              begin
 if CompTypes(GAttr.TyPtr,RealPtr) then
                                  begin
                                  Error(109);                                              Opp:=SRSOp;
                                              LLink:=Node2
         
                                  GAttr.TyPtr := nil;
                                  Node1^.EAttr.TyPtr := nil
                                                end
                                          end
                                      e                       end
                              else
                                  if CompTypes(LSP^.ElSet,GAttr.lse
                                          with Node3^ do
                                              begin
            TyPtr) then
                                      begin
                                      New(ExpHeap,1,Node3,Opr);
                                       Opp:=SGSOp;
                                              LLink:=nil
                               begin
                      { Null Set }
                      with GAttr do
                        begin TyPtr := L                                 with Node3^ do
                                          begin
                              SP; Kind := Expr end;
                      New(ExpHeap,1,Node,Opr);
                      with Node^ do
                                EType:=Opr;
                                          RLink:=Node1;
                                          SSy:      begin
                          EAttr:=GAttr;
                          EType:=Opr;
                          SSy:=LBra=LBrack
                                          end;
                                      if Sy = DotDot then
            ck;
                          Opp:=SNSOp;
                          LLink:=nil;
                          RLink:=nil
                                     begin
                                          InSymbol;
                                                         end;
                      InSymbol
                      end
                  else
                        LAttr:=GAttr;
                                          Node2:=Expression(FSys +
                                           begin
                      repeat
                          Node1:=Expression(FSys + [Comma,RBrack,DotDot]);
                  [Comma,RBrack]);
                                          if LAttr.TyPtr <> GAttr.TyPtr then
                                        if GAttr.TyPtr <> nil then
                              if GAttr.TyPtr^.Form > SubRange then
                                      begin
                                              Error(137);
                                              	
             end;
      Advance;
      end;
  while count < UniqLength do
      begin
      count:=count+1;
      Id[countErrors:
{    Bad Switch
{    Attempt to pop to previous switch value when there was none
{ Calls:
{    New
{    Dispose
{ ]:=' '
      end;
  if not PrsFilNam then
      for i:=ResHash[ord(Id[1])] to ResHash[ord(Id[1])+1]-1 do
          if Id = R   Advance
{    String Utilities (from PString)
{    NewIFile
{    ReWrite
{    Error
{------------------------------------esWords[i].RWord then
              begin
              Sy:=ResWords[i].Sym;
              Op:=ResWords[i].Opr;
            -}
    label 1;
    type SwitchValues = (SReserved,SInclude,SRange,SAuto,SList,SDebug,SVersion,
                         SCom  Exit(Search)
              end;
  Sy:=Ident;
  Op:=NoOp
  end { Search };

procedure CheckEnd;
{----------------------ment,SMessage,SQuiet,SNames,SIf,SElse,SEnd);
    const
        SwInclude = ord(SInclude);
        SwRange = ord(SRange);
   --------
{ Abstract:
{    Checks for the end of a source line and peforms general End-Of-Line
{    bookkeeping.
{
{ Side Ef     SwAuto = ord(SAuto);
        SwList = ord(SList);
        SwDebug = ord(SDebug);
        SwVersion = ord(SVersion);
   fects:
{    State of CurIFile is altered.
{    The LIST File is written onto (if one exists).
{
{ Calls:
{    PrintLine
{      SwComment = ord(SComment);
        SwMessage = ord(SMessage);
        SwQuiet = ord(SQuiet);
        SwNames = ord(SName   ShowProgress
{---------------------------------}
  begin
  with CurIFile^ do
      if EOL then
          begin
        s);
        SwIf = ord(SIf);
        SwElse = ord(SElse);
        SwEnd = ord(SEnd);
        NumSwitches = SwEnd;
    var S  LinNum:=LinNum+1;
          if List then PrintLine;
          ErrOnLine:=false;
          BPTOnLine := false;
          ifw: char; LTitle: string[MaxFNLength]; TmpSw: SwPtr;
        Switches: CmdArray; SwIx: integer; SwStr: string; TmpCond: CondPtr; DP then LineInfo := LC else LineInfo := IC;
          ShowProgress
          end
  end { CheckEnd };

procedure Commenter
        LSP: STP; Val: Valu; SwOK: boolean;
  begin
  Switches[SwInclude]:='INCLUDE';
  Switches[SwRange]:='RANGE';
  Swit(Stopper: char);
{----------------------------------
{ Abstract:
{    Process both comments and compiler switches.  Performs ches[SwAuto]:='AUTO';
  Switches[SwList]:='LIST';
  Switches[SwDebug]:='DEBUG';
  Switches[SwVersion]:='VERSION';
  Switchesswitch actions
{    where applicable.
{ Parameters:
{    Stopper - the character to terminate the comment: either <asterisk> [SwComment]:='COMMENT';
  Switches[SwMessage]:='MESSAGE';
  Switches[SwQuiet]:='QUIET';
  Switches[SwNames]:='NAMES';
  Switor
{              <right-curly-bracket>. <asterisk> actually indicated termination
{              with an <asterisk><right-parches[SwIf]:='IFC';
  Switches[SwElse]:='ELSEC';
  Switches[SwEnd]:='ENDC';
  GotASymbol := false;
  with CurIFile^ do
     $R-}
              InSymStr[0]:=chr(Length(InSymStr)+1);
              InSymStr[Length(InSymStr)]:=Ch;
              {$R=}
 en> pair.
{ Side Effects:
{    The state of compiler switches may be altered.
{    The state of CurIFile will be modified
{   	
                                        begin
                                              EAttr:=GAttr;
                         StrchNode(Node,Node1,false);
                      if Node <> nil then LAttr:=Node^.EAttr;
                      if Node1                          SSy:=LBrack;
                                              EType:=Opr;
                              <> nil then GAttr:=Node1^.EAttr
                      end;
      
      { Div }  IDiv:  begin
                      StrchNo                 Opp:=UNIOp;
                                              LLink:=Node;
                                      de(Node,Node1,false);
                      if Node <> nil then LAttr:=Node^.EAttr;
                      if Node1 <> nil then        RLink:=Node3
                                              end;
                                          Node:=Node1; GAttr:=Node1^.EAttr
                      end;
      
      { / }     RDiv: begin
                      FloatNode(Node,Node
                                          end
                                      else
                                   1,true);
                      StrchNode(Node,Node1,false);
                      if Node <> nil then LAttr:=Node^.EAttr;
          Node:=Node3
                                      end
                                  else
                                            if Node1 <> nil then GAttr:=Node1^.EAttr;
                      if (LAttr.TyPtr<>RealPtr) or (GAttr.TyPtr<>R             Error(137);
                                  Test := Sy <> Comma;
                                  if not Test ealPtr) then
                          begin Error(134); GAttr.TyPtr := nil;
                            Node1^.EAttr.TyPtr:=nthen InSymbol
                      until Test;
                      if Sy = RBrack then InSymbol else Error(12)
           il end
                      end;
      
      { Mod }   IMod: StrchNode(Node,Node1,false);
      
      { And }   AndOp:
           end;
                  end
            end { case };
            if not (Sy in FSys) then
              begin Err                    if (not CompTypes(LAttr.TyPtr,BoolPtr)) or
                       (not CompTypes(GAttr.TyPtr,BoolPtr)) then                       end;
                                      LSP^.ElSet := GAttr.TyPtr;
                                 or(6); Skip(FSys + FacBegSys) end
            end { while };
        Factor:=Node
        end { Factor };

begin { Term }     GAttr.TyPtr := LSP;
                                      GAttr.Kind:=Expr;
                                      Node3^.
      Node:=Factor(FSys + [MulOp]);
      while Sy = MulOp do
          begin
          LAttr := GAttr;
          LOp := OpEAttr:=GAttr;
                                      if Node <> nil then
                                          begin
     ;
          InSymbol;
          Node1:=Factor(FSys + [MulOp]);
          if (LAttr.TyPtr <> nil) and (GAttr.TyPtr <> nil) the                                     New(ExpHeap,1,Node1,Opr);
                                          with Node1^ do
      n
              case LOp of
      { * }     Mul:  begin
                      FloatNode(Node,Node1,false);
                    	
416);
                  goto 1
                  end;
              SwOK:=true;
              if CondCompile <> nil then
               Cond := CondOn
                                    else
                                        Cond := CondOff
                if CondCompile^.Cond in [CondOff,CondEOff] then
                      SwOk:=SwIx in [SwIf,SwElse,SwEnd];
                                         end
                                  else
                                    Cond := Con begin
      Advance;      { point to first character past "{" }
      if NextCh='$' then { We have a compiler switch here, no         if SwOK then
                begin
                while NextCh = ' ' do Advance;
                if SwIx in [SwRangt just a comment }
          begin
          Advance;          { Skip over the "$" }
          repeat
              TmpCond:e,SwAuto,SwList,SwDebug,SwQuiet,SwNames] then
                    begin
                    Sw := NextCh;
                   =CondCompile;
              CondCompile:=nil;
              InSymbol;         { Get the Switch }
              CondCompile:=T if (Sw = Stopper) or (Sw = ',') then
                        Sw := '+'
                    else if Sw in ['+','-','='] then
mpCond;
              if Sy <> Ident then
                  begin
                  Error(2);
                  goto 1                              Advance
                    end;
                case SwIx of
                      SwIf:
            { treat this as just a comment }
                  end;
              { convert ID (type Alpha) to a string }
                               begin    { Conditional Compilation IF }
                            New(TmpCond);
                           SwStr:='';
              SwIx:=1;
              while (SwIx <= UniqLength) and (Id[SwIx] <> ' ') do
                  begin  with TmpCond^ do
                                begin
                                Prev := CondCompile;
               
                  {$R-}
                  SwStr[0]:=chr(Length(SwStr)+1);
                  {$R=}
                  SwStr[Le                 if CondCompile <> nil then
                                  if CondCompile^.Cond in [CondOn,CondEOn] then
  ngth(SwStr)]:=Id[SwIx];
                  SwIx:=SwIx+1
                  end;
              SwIx:=UniqueCmdIndex(SwStr,Switch                                  begin
                                    InSymbol;
                                    Conses,NumSwitches);
              { Temporary compatiblity hack - Let I = INCLUDE }
              if (SwIx = (NumSwitches + 2)) atant([ThenSy],LSP,Val);
                                    if not CompTypes(LSP,BoolPtr) then
                               nd (SwStr = 'I') then
                  begin
                  writeln('WARN-Change $I to $INCLUDE');
                  SwIx         begin
                                        Error(135);
                                        goto 1
           :=SwInclude
                  end;
              if SwIx > NumSwitches then
                  begin
                  Error(                             end;
                                    if Val.IVal = ord(True) then
                             	
                   Node1^.EAttr.TyPtr:=nil
                          end
              end { case }
          else
         ,false);
                  if Node <> nil then LAttr:=Node^.EAttr;
                  if Node1 <> nil then GAttr:=Node1^.EAttr     GAttr.TyPtr := nil;
          New (Node2,Opr);
          with Node2^ do
              begin
              EAttr:=Node1^
                  end;
   
    { Or }    OrOp: if (not CompTypes(LAttr.TyPtr,BoolPtr)) or
                       (not CompTy.EAttr;
              EType:=Opr;
              SSy:=MulOp;
              Opp:=LOp;
              LLink:=Node;
            pes(GAttr.TyPtr,BoolPtr)) then
                           begin
                           Error(134);
                        RLink:=Node1
              end;
          Node:=Node2
          end; { while }
      Term:=Node
      end { Term };

b     GAttr.TyPtr := nil;
                           Node1^.EAttr.TyPtr:=nil
                           end
            end { egin { SimpleExpression }
    Signed := false;
    if (Sy = AddOp) and (Op in [Plus,Minus]) then
      begin Signed := Op = Mcase }
        else
            GAttr.TyPtr := nil;
        New(ExpHeap,1,Node2,Opr);
        with Node2^ do
            beinus; InSymbol end;
    Node:=Term(FSys + [AddOp]);
    if Signed then
        begin
        New(ExpHeap,1,Node1,Opr);
    gin
            EAttr:=GAttr;
            EType:=Opr;
            SSy:=AddOp;
            Opp:=LOp;
            LLink:=Node    with Node1^ do
            begin
            EAttr:=GAttr;
            EType:=Opr;
            SSy:=AddOp;
            ;
            RLink:=Node1
            end;
        Node:=Node2
        end { while };
    SimpleExpression:=Node
    end Opp:=Neg;
            LLink:=nil;
            RLink:=Node
            end;
        Node:=Node1
        end;
    while Sy ={ SimpleExpression };

begin { Expression }
  Node:=SimpleExpression(FSys + [RelOp]);
  if Sy = RelOp then
      begin
   AddOp do
        begin
        LAttr := GAttr;
        LOp := Op;
        InSymbol;
        Node1:=Term(FSys + [AddOp]);
    LAttr := GAttr;
      LOp := Op;
      SaveSy:=Sy;
      InSymbol;
      Node1:=SimpleExpression(FSys);
      if (LAttr        if (LAttr.TyPtr <> nil) and (GAttr.TyPtr <> nil) then
            case LOp of
    { + }     Plus:
                  b.TyPtr <> nil) and (GAttr.TyPtr <> nil) then
          begin
          if LOp = InOp then
              begin
              egin
                  FloatNode(Node,Node1,false);
                  StrchNode(Node,Node1,false);
                  if Node if GAttr.TyPtr^.Form = Power then
                  if CompTypes(LAttr.TyPtr,GAttr.TyPtr^.ElSet) then
                      { <> nil then LAttr:=Node^.EAttr;
                  if Node1 <> nil then GAttr:=Node1^.EAttr
                  end;
    
    {null then }
                  else
                      begin Error(129); GAttr.TyPtr := nil;
                        Node1^
                          begin
                          Error(134);
                          GAttr.TyPtr := nil;
        - }     Minus:
                  begin
                  FloatNode(Node,Node1,false);
                  StrchNode(Node,Node1   	
                        if CondCompile = nil then
                                begin
                                Error(                 TmpCond := CondCompile;
                            CondCompile := CondCompile^.Prev;
                       56);
                                goto 1
                                end;
                            with CondCompile     Dispose(TmpCond);
                            goto 1
                            end;
                            
    ^ do
                                case Cond of
                                    CondEOff,CondEOn:
                                       SwVersion:     { Version Switch }
                            begin
                            if Length(Ve                   begin
                                        Error(13);
                                        goto 1
  rStr) <> 0 then Error(414);
                            while NextCh in [' ',chr(9),chr(12)] do Advance;
                                                           end;
                                    CondOn:
                                              while (NextCh <> Stopper) and
                              (not EOLN(CurIFile^.InFile^)) do
                          dOff
                                else
                                    begin
                                    InSym Cond := CondEOff;
                                    CondOff:
                                        if Prev <> nil then
 bol;
                                    Constant([ThenSy],LSP,Val);
                                    if not CompTypes(LSP,                                           if Prev^.Cond in [CondOff,CondEOff]
                                              thBoolPtr) then
                                        begin
                                        Error(135);
             en
                                                Cond := CondEOff
                                            else
                                   goto 1
                                        end;
                                    if Val.IVal                                        Cond := CondEOn
                                        else
                          = ord(True) then
                                        Cond := CondOn
                                    else
                              Cond := CondEOn
                                  end { case };
                            goto 1
                                    Cond := CondOff
                                    end
                                end;
                        end;
                            
                      SwEnd:
                            begin    { Co                         CondCompile := TmpCond;
                            goto 1
                            end;
        nditional Compilation END }
                            if CondCompile = nil then
                                begin
                         
                      SwElse:
                            begin    { Conditional Compilation ELSE }
                               Error(56);
                                goto 1
                                end;
             	
;
                          New(CurHeap,1,CVal.ValP,Strg);
                          with CVal.ValP^ do
                     {----------------------------------------------------
{
{ Main Body Processing  Part D
{ Copyright (C) 1981  Three Rivers Com         begin
                              SVal[1]:=TChr;
                              SLgth:=1;
                         puter Corporation
{
{ Abstract:
{    The last part of the main body processing - deals mainly with statements,
{    and the .EAttr.TyPtr:=nil end
              else
                  begin Error(130); GAttr.TyPtr := nil;
                    Node1^.E     STyp:=DynCst;
                              CClass:=Strg
                              end;
                          NoAttr.TyPtr:=nil end
              end
          else
              begin
              { if we've got a string and a charactde^.EAttr:=LAttr
                          end;
                      end;
              if LAttr.TyPtr <> GAttr.TyPtr then
er constant, convert }
              { the character constant into a string constant }
              with GAttr do
                            begin
                  FloatNode(Node,Node1,false);
                  StrchNode(Node,Node1,false);
               if (Kind = Cst) and (TyPtr = CharPtr) then
                      begin
                      if ByteArray(LAttr.TyPtr)           LAttr:=Node^.EAttr;
                  GAttr:=Node1^.EAttr
                  end;
              end;
          New then
                          begin
                          TyPtr:=LAttr.TyPtr;
                          TChr:=chr(CVal.(ExpHeap,1,Node2,Opr);
          with Node2^ do
              begin
              EAttr:=GAttr;
              SSy:=SaveSy;
IVal);
                          New(CurHeap,1,CVal.ValP,Strg);
                          with CVal.ValP^ do
                              EType:=Opr;
              Opp:=LOp;
              LLink:=Node;
              RLink:=Node1
              end;
              begin
                              SVal[1]:=TChr;
                              SLgth:=1;
                              Node:=Node2
          end;
      GAttr.TyPtr := BoolPtr;
      GAttr.Kind := Expr;
      Node^.EAttr:=GAttr
               STyp:=DynCst;
                              CClass:=Strg
                              end;
                        end { Sy = RelOp };
  Expression:=Node
  end { Expression };
                                                                  Node1^.EAttr:=GAttr
                          end;
                      end;
              with LAttr do
                   if (Kind = Cst) and (TyPtr = CharPtr) then
                      begin
                      if ByteArray(GAttr.TyPtr) then 
                          begin
                          TyPtr:=GAttr.TyPtr;
                          TChr:=chr(CVal.IVal)    	
or(415);
                            while NextCh in [' ',chr(9),chr(12)] do Advance;
                            while (NextC           while ((InFile^^ <> ')') and (Stopper <> '}')) or
                              (NextCh <> Stopper) do
            h <> Stopper) and
                              (not EOLN(CurIFile^.InFile^)) do
                                begin
                          while NextCh <> Stopper do
                                    begin
                                    C                          {$R-}
                                CopyStr[0]:=chr(Length(CopyStr)+1);
                          heckEnd;
                                    Advance
                                    end;
                            if       CopyStr[length(CopyStr)]:=NextCh;
                                {$R=}
                                Advance
       Stopper = '*' then Advance;
                            Advance;
                            NewIFile(LTitle,true);
                                  end
                            end;
                            
                      SwMessage:                     Exit(InSymbol)
                            end;
                  
                      SwList:
          { Message Switch }
                            begin
                            while NextCh in [' ',chr(9),chr(12)] do Adv                   begin
                           if (Sw='+') or (Sw='-') then
                               begin
       ance;
                            SwStr:='';
                            while (NextCh <> Stopper) and
                                              List := (Sw='+');
                               if List then
                                   begin        (not EOLN(CurIFile^.InFile^)) do
                                begin
                                {$R-}
        
                                   with LinkList[0] do
                                     if Pos(FilName,DefIExtension) =
      begin
                                {$R-}
                                VerStr[0]:=chr(Length(VerStr)+1);
                                 SwStr[0]:=chr(Length(SwStr)+1);
                                SwStr[length(SwStr)]:=NextCh;
                               VerStr[length(VerStr)]:=NextCh;
                                {$R=}
                                A                        {$R=}
                                Advance
                                end;
                  dvance
                                end
                            end;
                            
                             writeln(Output,SwStr)
                            end;
                            
                      SwInclude   SwComment:    { Comment Switch }
                      { Not yet implemented correctly! }
                      { Currently:    { Include Switch }
                            begin
                            PrsFilNam:=true;
                       done as old copyright switch }
                            begin
                            if Length(CopyStr) <> 0 then Err      InSymbol;
                            LTitle:=InSymStr;
                            PrsFilNam:=false;
                   	
ndStatement
{    GotoStatement
{    IfStatement
{    CaseStatement
{    WhileStatement
{    RepeatStatement
{    ForStatemxpression(Expression(FSys));
        if ByteArray(LAttr.TyPtr) then
            { convert character constants to string constaent
{    WithStatement
{-------------------------------------}
    label 1;
    var LCP: Identifier; TTop: DispRange; LLP: Lnts }
            if GAttr.Kind = Cst then
                if GAttr.TyPtr = CharPtr then
                    begin
         abelP;

procedure Assignment(var FCP: Identifier);
{-------------------------------------------
{ Abstract:
{    Parse ass           with GAttr do
                        begin
                        TyPtr:=LAttr.TyPtr;
                        TCignment statements and generate the assignment code
{
{ Parameters:
{    FCP - The identifier (or atleast the first identifiehr:=chr(CVal.IVal);
                        New(CurHeap,1,CVal.ValP,Strg);
                        with CVal.ValP^ do
       r which begins the
{          'selector') to receive the result
{
{ Side Effects:
{    The state of CurIFile may be modified                     begin
                            SVal[1]:=TChr;
                            SLgth:=1;
                 main body of the body processor
{
{ File: Body3.Pas
{
{------------------------------------------------------}

{ }
{ 03.
{    Code may be generated
{
{ Calls:
{    ExpExpression
{    Selector
{    LoadAddress
{    ByteArray
{    GenLDC
{ -Feb-81  2.0  Miles A. Barel
{ Implementation of Long Integers
{ }
{ 13-Jan-81  1.11 Miles A. Barel
{ Bug Fix - Functions re   EPush
{    InSymbol
{    Expression
{    New
{    Dispose
{    LoadExpr
{    CompTypes
{    QGen0
{    EPop
{    Getturning non-scalar types now return temp stack space
{ }
{ 7-Jan-81  1.6  Miles A. Barel
{ General Cleanup and institution ofBounds
{    Error
{    QGen1
{    Store
{    EQuick
{    QGen1A
{------------------------------------------}
      var LA standard 3RCC file formats
{ }

procedure Statement(FSys: SetOfSys);
{-----------------------------------
{ Abstract:
{ ttr: Attr; CString,WasResult: boolean; LMin,LMax,SLen: integer;
          TChr: char;
    begin
    ExpExpression(Selector(FS   Main statement processor - recognizes specific statement types and
{    calls appropriate routines to handle the specific stys + [Becomes],FCP));
    if Sy = Becomes then
        begin
        LMax := 0; CString := false;
        if GAttr.TyPtr <> atement type.
{    Also recognizes and 'places' user defined labels.
{
{ Parameters:
{    FSys - legal terminal symbols for nil then
            if (GAttr.Access = Indrct) or (GAttr.TyPtr^.Form > Power) then
                begin
                Loathe statement
{
{ Errors:
{    EStack Not Empty
{
{ Side Effects:
{    The state of CurIFile may be modified
{
{ Calls:dAddress;
                if ByteArray(GAttr.TyPtr) then
                    begin
                    GenLDC(0);
          
{    Error
{    Skip
{    PutLabel
{    InSymbol
{    SearchId
{    ExpExpression
{    Call
{    Assignment
{    Compou          EPush(Data16)
                    end
                end;
        LAttr := GAttr;
        InSymbol;
        ExpE   	
)-
                                               length(DefIExtension))
                                         else
                                  begin
                               New(TmpSw);
                               TmpSw^.Sw := (Sw='                                     LTitle:=FilName;
                                   LTitle:=Concat(LTitle,DefLExtension);-');
                               TmpSw^.Previous:=Noisy;
                               Noisy:=TmpSw
                     
                                   ReWrite(LP,LTitle)
                                   end
                               e          end;

                      SwRange:
                           if Sw = '=' then
                               wind
                           else
                               begin
                               PrsFilNam:=true;
    th RangeCheck^ do
                                   if Previous = nil then
                                      writeln('No                            InSymbol;
                               LTitle:=InSymStr;
                               PrsFilNamPrevious Range Switch Value')
                                   else
                                       begin
          :=false;
                               if Pos(LTitle,DefLExtension) <> Length(LTitle)-
                                 Lengt                             TmpSw:=RangeCheck;
                                       RangeCheck:=Previous;
                 h(DefLExtension) + 1 then
                                   LTitle:=Concat(LTitle,DefLExtension);
                                                 Dispose(TmpSw)
                                       end
                           else
                 List :=true
                               end;
                           if List then ReWrite(LP,LTitle)
                                begin
                               New(TmpSw);
                               TmpSw^.Sw := (Sw='+');
                 end;
                      
                      SwQuiet:
                           if Sw = '=' then
                                   TmpSw^.Previous:=RangeCheck;
                               RangeCheck:=TmpSw
                                            with Noisy^ do
                                   if Previous = nil then
                                        end;

                      SwDebug:
                           if Sw = '=' then
                               wi        writeln('No Previous Quiet Switch Value')
                                   else
                                    th Debug^ do
                                   if Previous = nil then
                                      writeln('No Previ                                       length(FilName)-length(DefIExtension)+1
                                         then
    begin
                                       TmpSw:=Noisy;
                                       Noisy:=Previous;
                                                 LTitle:=SubStr(FilName,1,
                                             length(FilName                                Dispose(TmpSw)
                                       end
                           else
     	
(0);
                    EPush(Data16)
                    end
                end;
        if (LAttr.TyPtr <> nil) and (GAt                    IC:=IC-1;
                            GenLDC(1);
                            GAttr.TyPtr := LAttr.TyPtr
 tr.TyPtr <> nil) then
            begin
            if CompTypes(GAttr.TyPtr,IntPtr) then
                if RealPtr = LAttr.                           end
                        end
                    else
                        GAttr.TyPtr := LATyPtr then
                  begin
                  QGen0(FLT);
                  EPop(1);
                  EPush(Data32);ttr.TyPtr;
            if CompTypes(LAttr.TyPtr,GAttr.TyPtr) then
                begin
                case LAttr.TyPtr^.For
                  GAttr.TyPtr := RealPtr
                  end;
            if CompTypes(GAttr.TyPtr,IntPtr) then
         m of
                    Power:    begin
                              QGen1(ADJ,LAttr.TyPtr^.Size);
                               if LongPtr = LAttr.TyPtr then
                  begin
                  QGen0(EXPL);
                  EPop(1);
           EPop(1);
                              Store(LAttr)
                              end;
                      
                     EPush(Data32);
                  GAttr.TyPtr := LongPtr
                  end;
            if GAttr.TyPtr = Long            Scalar,
                    SubRange: begin
                              if RangeCheck^.Sw then
                Ptr then
                if CompTypes(IntPtr,LAttr.TyPtr) then
                  begin
                  QGen0(SHRKL);
                       if (LAttr.TyPtr <> IntPtr) and
                                    (LAttr.TyPtr^.Size = 1) then
                         EPop(2);
                  EPush(Data16);
                  GAttr.TyPtr := IntPtr
                  end;
                                begin
                                      GetBounds(LAttr.TyPtr,LMin,LMax);
                                 CClass:=Strg
                            end
                        end;
                    CString:=true
           if ByteArray(LAttr.TyPtr) then
                if not LAttr.TyPtr^.AIsStrng then
                    if LAttr.TyPtr^.Inx               end
                else
                    CString := StrgType(GAttr.TyPtr);
        if CString then SLen :=Type <> nil then
                        begin
                        GetBounds(LAttr.TyPtr^.InxType,LMin,LMax);
            GAttr.CVal.ValP^.SLgth;
        WasResult:=false;
        if GAttr.TyPtr <> nil then
            if GAttr.TyPtr^.Form <= Pow             LMax := LMax - LMin + 1;
                        if CString then
                            { when assigning strer then
                LoadExpr
            else
                begin
                WasResult:=GAttr.Kind = Result;
   ing constant to PA of char }
                            { convert constant to PA of char (only if lengths }
                              LoadAddress;
                if ByteArray(GAttr.TyPtr) then
                    begin
                    GenLDC           { match) }
                            begin
                            if LMax <> SLen then Error(129);
           	
utoInit := (Sw <> '-')
                  
                  end {cases}
                end
              until NextCh <> ', := Strg;
              SLgth := TP;
              SVal:=T;
              Val.ValP := SConst
              end
      end
 ous Debug Switch Value')
                                   else
                                       begin
               '
          end;
      end;
1: while ((CurIFile^.InFile^^ <> ')') and (Stopper <> '}')) or
      (CurIFile^.NextCh <> Stoppe                        TmpSw:=Debug;
                                       Debug:=Previous;
                                r) do
          begin
          while CurIFile^.NextCh <> Stopper do
              begin
              Advance;
                  Dispose(TmpSw)
                                       end
                           else
                               CheckEnd
              end;
          if (Stopper = '*') and (CurIFile^.InFile^^ <> ')') then Advance
          end;
  if   begin
                               New(TmpSw);
                               TmpSw^.Sw := (Sw='+');
                    Stopper = '*' then Advance;
  Advance
  end { Commenter };

procedure SString;
{------------------------
{ Abstract:
{             TmpSw^.Previous:=Debug;
                               Debug:=TmpSw
                               end;

          Scan off string expressions from the source file
{ Side Effects:
{    The string constant is returned in VAL
{    Sy and O               SwNames:
                           if Sw = '=' then
                               with Names^ do
           p are modified.
{    SConst and Lgth are modified
{ Errors:
{    String Too Long
{ Calls:
{    Advance
{    Error
{------                        if Previous = nil then
                                       writeln('No Previous Names Switch Value')------------------}
    label 1;
    var T: ChrsOfString; TP: integer;
  begin
  with CurIFile^ do
      begin
      TP :=
                                   else
                                       begin
                                        0; { Index into temporary string }
      repeat
          repeat
              Advance;      { on to the next/first characteTmpSw:=Debug;
                                       Names:=Previous;
                                       Dispose(TmpSw)
 r }
              if TP > StrgLgth then begin Error(260); goto 1 end;
              TP := TP+1;
              T[TP] := NextCh                                      end
                           else
                               begin
              ;
          until NextCh='''';
          Advance;  { pass the closing ' }
      until NextCh<>'''';
    1:TP := TP-1;   { re                 New(TmpSw);
                               TmpSw^.Sw := (Sw='+');
                               TmpSw^.Previmove the close '; we'd put it in }
      Sy := StringConst; Op := NoOp;
      Lgth := TP;
      if TP=1 then { Single charactous:=Names;
                               Names:=TmpSw
                               end;

                      SwAuto: Aer constant }
          Val.IVal := ord(T[1])
      else
          with SConst^ do
              begin
              CClass  	
  Store(LAttr)
                              end;
                              
                    Pointr:   Store(LAttr);   if TyPtr <> nil then
                                          QGen1A(ATPB,-TyPtr^.Size)
                              end;
                    
                     Arrays:  begin
                              If ByteArray(LAttr.TyPtr) then
      
                     
                     Files:   Error(146)
                  end { case };
                if WasResult                            if LAttr.TyPtr^.AIsStrng then
                                      begin
                         then
                    QGen1A(ATPB,-GAttr.TyPtr^.Size)
                end
            else
                Error(129)
               GenLDC(LAttr.TyPtr^.MaxLeng);
                                      EPush(Data16);
                                        end
        end { Sy = Becomes }
    else
        Error(51)
    end { Assignment };

procedure GotoStatement;         QGen0(SAS);
                                      EPop(5)
                                      end
                
{-------------------------------------------
{ Abstract:
{    Parse GOTO statements and generate the appropriate code
{
{ S                  else
                                      begin
                                      QGen1A(MVBB,LMax);
 ide Effects:
{    The state of CurIFile may be modified.
{    Code may be generated
{
{ Calls:
{    QGenJmp
{    Error
{                                      EPop(4)
                                      end
                              else
      InSymbol
{------------------------------------------}
      var LLP: LabelP; NotFound,ExGoto: boolean; TTop: DispRange;
                                 begin
                                  QGen1A(MOVB,LAttr.TyPtr^.Size);
                         begin
    if Sy = IntConst then
        begin
        NotFound := true; TTop := Top; ExGoto := false;
        while (TTop            EPop(2)
                                  end;
                              with GAttr do
                       >= 0) and NotFound do
            begin
            while (Display[TTop].Occur <> Blck) and (TTop >= 0) and NotFound do
                if Kind = Result then
                                      if TyPtr <> nil then
                                             TTop := TTop - 1;
            if TTop >= 0 then
                begin
                LLP := Display[TTop].FLabel;        QGen1A(ATPB,-TyPtr^.Size)
                              end;
                                  
                     
                while (LLP <> nil) and NotFound do
                    with LLP^ do
                        if LabVal = Val.                GenLDC(LMin);
                                      GenLDC(LMax);
                                      QGen0(Records: begin
                              QGen1A(MOVB,LAttr.TyPtr^.Size);
                              EPop(2);
         CHK);
                                      EQuick(2)
                                      end;
                                                 with GAttr do
                                  if Kind = Result then
                                      	
 result:=10.0;
    for i:=2 to Pwr do result:=result * 10.0;
    PwrOfTen := result
    end
*)
{$ENDC}
end { PwrOfTen };
+' then
                  Advance;
          EPart := Ix+1; {Beginning of exponent}
          while (NextCh>='0') and (NextCh
  begin { Number }
  with CurIFile^ do
      begin
      Tipe := IntegerTipe;
      Radix:=10;    { default is decimal }<='9') do
              begin
              Ix:=Ix+1;
              NumBuf[Ix]:=NextCh;
              Advance
             
      EndI := 0;
      EndF := 0;
      EndE := 0;
      Sign := 1;
      EPart := 9999; {Out of Reach}
      Ix := 0;
   end;
          EndE := Ix;
          if EndE<EPart then Error(201); {Error in real constant}
          end;
      if (Radix    if NextCh = '#' then
          begin
          Radix:=8;
          Advance;
          end;
      repeat
          Ix:= <>  10) and (Tipe = RealTipe) then
          Error(399);
      {Now convert to internal form}
      if Tipe=IntegerTipe then end { SString };

procedure Number;
{------------------------------
{ Abstract:
{    Scan off numerical literals from souIx+1;
          NumBuf[Ix]:=NextCh;
          Advance
      until (NextCh<'0') or (NextCh>chr(Radix+ord('/')));
      if Nexrce.  It can parse reals, and
{    single precision integers (NO LONG INTEGERS YET!).  Also, only
{    decimal and octal radiitCh in ['0'..'9'] then
          begin
          { bad constant }
          Error(261);
          while NextCh in ['0'..'9', are available for integers
{
{ Side Effects:
{    The constant is returned in VAL
{    The state of CurIFile is altered
{'.','E','e'] do
              Advance
          end;
      { NextCh now contains the first character past integer part }
   
{ Calls:
{    Advance
{    Error
{    New
{----------------------------------}
    var
      Exponent,EndI,EndF,EndE,Sign   EndI := Ix; {Mark the end of IPart}
      if (NextCh='.') and (InFile^^ <> '.') then
          begin
          Advance;
 ,FPart,EPart,
      Radix,ISum,Ix:  integer;
      Tipe: (RealTipe,IntegerTipe);
      RSum: real;
      J,K: integer;
             Tipe := RealTipe;
          FPart := Ix+1; {Beginning of FPart}
          while (NextCh >= '0') and (NextCh <= '9') d  NumBuf: packed array[1..80] of char;

function PwrOfTen(Pwr:integer):real;
{---------------------------
{ Abstract:
{   o
              begin
              Ix:=Ix+1;
              write('''',nextch,'''');
              NumBuf[Ix]:=NextCh;
     compute powers of ten (for real number conversion) }
{ Parameters:
{    Pwr - Power of 10 to be returned
{ Environment:
{            Advance
              end;
          if Ix+1 = FPart then Error(201);
          EndF := Ix
          end;
      i  Pwr must be >= 0
{ Results:
{    10 raised to the Pwr power
{----------------------------}
  var i:integer; result:real;
f NextCh in ['E','e'] then
          begin
          Tipe := RealTipe;
          Advance;
          if NextCh='-' then
    begin
{$IFC IncReals THEN }
{$ME Comment Must Be Removed to Compile}
(*if Pwr = 0 then
    PwrOfTen:=1
else
    begin
             begin
              Advance;
              Sign := -1;
              end
          else
              if NextCh='  	
{ Abstract:
{    Parse IF statements and generate the appropriate code
{
{ Side Effects:
{    The state of CurIFile may be mf not CondCompile then PutLabel(LCIX1)
    end { IfStatement };

procedure CaseStatement;
{--------------------------------IVal then
                            begin
                            if debug^.sw then writeln('Label ',LabVal:1,
        odified.
{    Code may be generated
{
{ Calls:
{    ExpExpression
{    Expression
{    GenLabel
{    QGenBJmp
{    EPop                              ' Top ',TTop:1);
                            NotFound := false;
                            with
{    InSymbol
{    Error
{    Statement
{    QGenJmp
{    PutLabel
{------------------------------------------}
      var CodeLbP^ do
                                if (OccurSeg = Seg) and
                                  (OccurProc = CurProc) t LCIX1,LCIX2: LBP; LIC: integer; CondCompile,NothenClause: boolean;
    begin
    CondCompile := false;
    ExpExpression(Exphen
                                    QGenJmp(JMPB,CodeLbP)
                                else
                          ression(FSys + [ThenSy]));
    if (GAttr.Kind = Cst) then
        if CompTypes(GAttr.TyPtr,BoolPtr) then
            begin
           QGenJmp(EXGO,CodeLbP)
                            end
                        else
                            LLP            CondCompile := true;
            NothenClause := not odd(GAttr.CVal.IVal);
            LIC := IC
            end;:= NextLab;
                TTop := TTop - 1
                end
            end;
        if NotFound then Error(167);
    
        if not CondCompile then
            begin
            GenLabel(LCIX1); 
            QGenBJmp(JFB,LCIX1);
              InSymbol
        end
    else
        Error(15)
    end { GotoStatement };

procedure CompoundStatement;
{----------  EPop(1)
            end;
        if Sy = ThenSy then InSymbol else Error(52);
        Statement(FSys + [ElseSy]);
        ---------------------------------
{ Abstract:
{    Parse compound statements
{
{ Side Effects:
{    The state of CurIFile mif CondCompile then
            if NothenClause then
                IC := LIC
            else
                LIC := IC;
ay be modified.
{
{ Calls:
{    Statement
{    Error
{    InSymbol
{------------------------------------------}
      var        if Sy = ElseSy then
            begin
            if not CondCompile then
                begin
                GenL Test: Boolean;
    begin
    repeat
        repeat
            Statement(FSys + [SemiColon,EndSy])
        until not (Sy iabel(LCIX2);
                QGenJmp(JMPB,LCIX2);
                PutLabel(LCIX1)
                end;
            InSymbol;n StatBegSys);
        Test := Sy <> SemiColon;
        if not Test then InSymbol
    until Test;
    if Sy = EndSy then InS
            Statement(FSys);
            if CondCompile then
                begin
                if not NothenClause thenymbol else Error(13)
    end { CompoundStatemenet };

procedure IfStatement;
{-------------------------------------------
 IC := LIC
                end
            else
                PutLabel(LCIX2)
            end
        else
            i   	
      begin { Real number here }
          RSum := 0;
          for J := 1 to EndI do
              RSum := RSum*10+(ord(NumB Commenter('}');
      
      '(':  begin
            Advance;
            if CurIFile^.NextCh = '*' then
                Cuf[j])-ord('0'));
          for J := EndF downto FPart do
              RSum := RSum+(ord(NumBuf[j])-ord('0'))/PwrOfTen(J-FParommenter('*')
            else
                Sy := LParent;
            end;
      
      ')':  begin
            Sy := t+1);
          Exponent := 0;
          for J := EPart to EndE do
              Exponent := Exponent*10+ord(NumBuf[j])-ord('RParent;
            Advance
            end;
      
      ',':  begin
            Sy := Comma;
            Advance
     0');
          if Sign=-1 then
              RSum := RSum/PwrOfTen(Exponent)
          else
              RSum := RSum*PwrOf       end;
      
      ' ',chr(9),chr(12):
            GotASymbol:=false;
      
      '.':  begin
            Advance;Ten(Exponent);
          Sy := RealConst;  Op := NoOp;
{$Message Check Out This Call To New}
          New(CurHeap,1,LVP,Reel
            if CurIFile <> nil then
                if CurIFile^.NextCh = '.' then
                    begin
               );
          LVP^.CClass := Reel;
          LVP^.RVal := RSum;
          Val.ValP := LVP;
          end
{$ELSEC }
             Advance;
                    Sy := DotDot
                    end
                else
                    Sy := Period  Error(399)
{$ENDC }
      end
  end { Number };

begin { InSymbol }
if GetStmtLev then
  begin BegStmtLev := StmtLev; 
            else
                Sy := Period;
            end;
      
      ':':  begin
            Advance;
          
          begin
          ISum := 0;
          for J := 1 to EndI do
              begin
              K:=ord(NumBuf[j]) -GetStmtLev := false end;
Op := NoOp;
Sy := OtherSy; { If no cases exercised blow up }

repeat
  GotASymbol:=true;       { A ord('0');
              case Radix of
                  8: if LAnd(ISum,#160000) <> 0 then
                         Error(20ssume that we'll get a Symbol }
  { Skip leading blanks }
  while (CurIFile^.NextCh in [' ',chr(9),chr(12)]) or CurIFile^.EOL 3)
                     else
                         ISum:=Shift(ISum,3) + K;
                 10: if (ISum>MaxInt div 10) odo
    begin
    CheckEnd;
    Advance
    end;

  case CurIFile^.NextCh of
      
      '''': SString;
      
      'r ((ISum=MaxInt div 10) and 
                       (K > MaxInt mod 10)) then
                         Error(203)
           #','0','1','2','3','4','5','6','7','8','9':
            Number;
      
      'A','B','C','D','E','F','G','H','I','J','K','L',          else
                         ISum := ISum*10+K
                end { case }
              end;
          Sy := In'M',
      'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
      'a','b','c','d','e','f','g','h','i','j','k','l','m',
  tConst;  Op := NoOp;
          Val.IVal := ISum;
          end { Tipe = IntegerTipe }
      else
{$IFC IncReals THEN }
        'n','o','p','q','r','s','t','u','v','w','x','y','z','_':
            Search  { reserved word search };
      
      '{':   	
  }
    GenLabel(LCIX);                     { label of XJP QCode }
    QGenJmp(JMPB,LCIX);                 { we'll put XJP afto put new case }
                                    if CsLab <= LMin then
                                        begin { Thier case code }
    LSP := GAttr.TyPtr;                 { Type OK for case stmt? }
    if LSP <> nil then
      with LSP^ do
s is the place }
                                        If CsLab = LMin then Error(156);
                                            if (Form > SubRange) or (Size <> 1) then
          begin Error(144); LSP := nil end;
    if Sy = OfSy then InSymbol el    goto 1
                                        end;
                                    LPT2 := LPT1;
                   se Error(8);
    EPop(1);                    { Ignore Case Expression on EStack }
    FstPtr := nil;
    GenLabel(LAddr);                     LPT1 := Next
                                    end;
                1:          New(CurHeap,1,LPT3);
     -----------
{ Abstract:
{    Parse CASE statements and generate the appropriate code
{
{ Side Effects:
{    The state of Cu                { Next QCode after XJP }
    repeat
        LPT3 := nil;
        repeat                          { Get labelsrIFile may be modified.
{    Code may be generated
{
{ Calls:
{    ExpExpression
{    Expression
{    LoadExpr
{    GenLa for this case }
            if Sy <> OthrWiseSy then
                begin
                Constant(FSys + [Comma,DotDot,Colbel
{    QGenJmp
{    Error
{    InSymbol
{    EPop
{    Constant
{    CompTypes
{    New
{    Dispose
{    Statement
on],LSP1,LVal);
                if Sy = DotDot then
                    begin
                    InSymbol;
                {    PutLabel
{    QGen0
{    GenWord
{------------------------------------------}
      label 1;
      type CIP = ^CaseInf    Constant(FSys + [Comma,Colon],LSP2,LVal1)
                    end
                else
                    begin
       o;
           CaseInfo = record
                        Next: CIP;              { next case info }
                        Cs             LSP2:=LSP1;
                    LVal1:=LVal
                    end;
                if LSP <> nil then
       Start: integer;       { IC of start of cse code }
                        CsLab: integer          { Value of this case }
                  if CompTypes(LSP,LSP1) and CompTypes(LSP,LSP2) then
                        { Type OK? }
                                         end;
      var LSP,LSP1,LSP2: STP; FstPtr,LPT1,LPT2,LPT3,OtherCIP: CIP;
          LVal,LVal1: Valu; LAddr, LCfor LMin := LVal.IVal to LVal1.IVal do
                            begin
                            LPT1 := FstPtr;{ keep allIX: LBP; NulStmt, LMin, LMax: integer;
          Test: Boolean;
    begin
    OtherCIP:=nil;
    OtherCIP:=nil;
    ExpExpr labels in sorted list - }
                            LPT2 := nil;   { largest to smallest }
                            whilession(Expression(FSys + [OfSy,Comma,Colon])); { get value of case }
    LoadExpr;                           { expr on ETOS    e LPT1 <> nil do
                                with LPT1^ do
                                    begin{ find place in list t   	
nd;
      
      '[':  begin
            Sy := LBrack;
            Advance
            end;
      
      ']':  begin
   
      begin
      Error(400);
      Advance;
      GotASymbol := false
      end
until GotASymbol
end { InSymbol };
             Sy := RBrack;
            Advance
            end;
      
      '}':  begin         { no one ever really wants this , but it keeps error }
            Sy := RCurly; { messages straight - particularly for conditional  }
            Advance    {-----------------------------------------
{
{ General Compiler Utilities  Miles A. Barel
{ Copyright (C) 1981 - Three Rivers   { compilation syntax errors }
            end;
      
      '*':  begin Sy := MulOp; Op := Mul; Advance end;
      
     Computer Corporation
{
{ Abstract:
{    General Compiler Utility Routines (Part B)
{
{ File:
{    Pas1.Pas
{
{---------  '+':  begin Sy := AddOp; Op := Plus; Advance end;
      
      '-':  begin Sy := AddOp; Op := Minus; Advance end;
      
 ---------------------------------}

{ }
{ 03-Feb-81  2.0  Miles A. Barel
{ Implementation of Long Integers
{ }
{ 21-Jan-8     '/':  begin Sy := MulOp; Op := RDiv; Advance end;
      
      '<':  begin
            Advance;
            Sy := RelOp1  1.13  Miles A. Barel
{ Fix WordSize bug
{ }
{ 15-Jan-81  1.12  Miles A. Barel
{ Hashing for compiler names and use global;
            Op := LtOp;
            case CurIFile^.NextCh of
                '>': begin
                     Op := NeOp;
s
{ }
{ 9-Jan-81  1.9  Miles A. Barel
{ Return space allocated for dynamic string constants
{ }
{ 31-Dec-80  1.6  Miles A.                      Advance
                     end;
                
                '=': begin
                     Op :Barel
{ Cleanup and insertion of standard file format stuff
{ }

function TreeSearch(Root:integer; var Found:Identifier; SN= LeOp;
                     Advance;
                     end
              end;
            end;
       
       '=': begame:alpha):integer;
{------------------------------
{ Abstract:
{    Search a symbol table subtree for a symbol with a given in Sy := RelOp; Op := EqOp; Advance end;
       
       '>': begin
            Advance;
            Sy := RelOp;
          name
{
{ Parameters:
{    Root - Id Number of top node of subtree to be searched
{    Found - Identifier is returned here
{  if CurIFile^.NextCh = '=' then
                begin
                Advance;
                Sy := Becomes;
               if CurIFile^.NextCh = '=' then
                begin
                Op := GeOp;
                Advance
                e   end
            else
                Sy := Colon
            end;
      
      ';':  begin
            Sy := SemiColon;nd
            else
                Op := GtOp;
            end
      end { Case NextCh of };
  if CondCompile <> nil then
            Advance
            end;
      
      '^':  begin
            Sy := Arrow;
            Advance
            e
      if CondCompile^.Cond in [CondOff,CondEOff] then
          GotASymbol := false;
  if (Sy = OtherSy) and GotASymbol then  	
IP = nil then
                    begin
                    New(CurHeap,1,OtherCIP);
                    OtherCIP^.CsStart:=IrCIP^.CsStart;
            Dispose(OtherCIP)
            end;
        GenWord(NulStmt-IC);            { self relative offset C;
                    InSymbol
                    end
                else
                    Error(156);
            Teto next QCode }
        repeat                          { now write out the table! }
            with FstPtr^ do
            st := Sy <> Comma;
            if not Test then InSymbol
        until Test;
        if Sy = Colon then InSymbol else Error(5    begin
                while LMin < CsLab do
                    begin               { table entries which are not defined );
        repeat                          { generate case code }
            Statement(FSys + [SemiColon])
        until not}
                    GenWord(NulStmt-IC);{ self relative offset to next QCode }
                    LMin := LMin + 1    { on  (Sy in StatBegSys);
        QGenJmp(JMPB,LAddr);        { end case code with JMP past XJP }
        Test := Sy <> SemiColon;to the next table entry }
                    end;
                GenWord(CsStart-IC); { self relative offset to this case co
        if not Test then InSymbol
    until Test or (Sy = EndSy);         { until all cases done }
    PutLabel(LCIX);       de }
                LPT1 := Next;        { on to next defined case }
                Dispose(FstPtr);
                FstPtr              { now put out the XJP & table }
    if FstPtr <> nil then               { get min & max values }
        begin
:=LPT1;
                LMin := LMin + 1     { and onto next actual case }
                end
        until FstPtr = nil;                          { create & init record for new case }
                            with LPT3^ do
                               LMax := FstPtr^.CsLab;          { Max value }
        LPT1 := FstPtr;                 { turn the list around - now smal         begin
                                Next := LPT1;   { list insertion }
                                CsLab := LMilest }
        FstPtr := nil;                  { to largest }
        repeat
            LPT2 := LPT1^.Next;
            LPTn;  { Value of this case }
                                CsStart := IC   { Starting IC of case code }
                      1^.Next := FstPtr;
            FstPtr := LPT1;
            LPT1 := LPT2
        until LPT1 = nil;
        LMin := FstPtr^.Cs          end;
                            if LPT2 = nil then  { finish list insertion }
                                FstPtLab;          { Min Value }
        QGen0(XJP);                     { XJP QCode }
        GenWord(LMin);                  { Mir := LPT3
                            else
                                LPT2^.Next := LPT3
                            endn Value, yes word aligned }
        GenWord(LMax);                  { Max Value }
        if OtherCIP = nil then
            
                    else
                        Error(147)
                end
            else
                if OtherCNulStmt := IC + ((LMax - LMin +1)*2) + 2 { IC of QCode after XJP }
        else
            begin
            NulStmt := Othe   	
    SName - Name of the identifier to be found
{
{ Results:
{     0: Id found.  Found := Target.
{     1: No match.  Target   FCP - Place to return the identifier found
{
{ Environment:
{    Global Variable ID must have the name of the identifier to> leaf node.  Found :=Leaf Node.
{    -1: No match.  Target < leaf node.  Found :=Leaf Node.
{     Result=1, Found=0 if root d be found
{
{ Errors:
{    Identifier found is not in the set of possible classes
{    Identifier is not defined
{
{ Callsoesn't exist.
{
{ Calls:
{    LookupNum
{-------------------------------}
begin
LookupNum(Root,Found);
If Found.IdNum = 0:
{    TreeSearch
{    LookupNum
{    Error
{    HashIx
{------------------------------}
  label 1;
  var Root:integer;
 then
    begin                           { no root }
    TreeSearch:=1;
    Exit(TreeSearch)
    end;
while true do
    ibegin
for Disx:=Top downto 0 do
    begin
    if Disx <= HashLevels then
        Root := HashTable[Disx,HashIx(Id)]
    elsf Found.Name = SName then      { We FOUND It }
        begin
        TreeSearch:=0;
        Exit(TreeSearch)
        end
  e
        Root:=Display[Disx].FName;
    if TreeSearch(Root,FCP,Id) = 0 then
        if FCP.Klass in FiDcls then
             else if SName < Found.Name then      { traverse left link }
        if Found.LLink = 0 then
            begin                goto 1                        { We found it }
        else
            if PrtErr then
                Error(103)        { Id      { no ID }
            TreeSearch:=-1;
            Exit(TreeSearch)
            end
        else
            begin
   not of appropriate class }
    end;
if not PrtErr then
    FCP.IdNum:=0                   { Return - Id not found }
else
           LookupNum(Found.LLink,Found)
            end
    else { SName > Found.Name }          { traverse right link }
        begin
    Error(104);                    { undeclared identifier }
    if Types in FiDcls then
        LookupNum(UTypPtr,F   if Found.RLink = 0 then
            begin                    { no ID }
            TreeSearch:=1;
            Exit(TreeSeaCP)
    else if ActualVars in FiDcls then
        LookupNum(UVarPtr,FCP)
    else if Field in FiDcls then
        LookupNum(rch)
            end
        else
            begin
            LookupNum(Found.RLink,Found)
            end;
end {TreeSeaUFldPtr,FCP)
    else if Konst in FiDcls then
        LookupNum(UCstPtr,FCP)
    else if Proc in FiDcls then
        LookupNrch};

procedure SearchId(FiDcls: SetOfIds; var FCP: Identifier);
{-----------------------------
{ Abstract:
{    Search tum(UPrcPtr,FCP)
    else
        LookupNum(UFctPtr,FCP);
    end;
1:
end { SearchId };

procedure GetBounds(FSP: STP; vahe entire symbol table for an identifier, where the
{    identifier must not only match by name, but also be in a given
{    cr FMin,FMax: integer);
{-----------------------------------
{ Abstract:
{    Get the minimum and maximum allowable values forlass of identifier (ex: constants or types only)
{
{ Parameters:
{    FiDcls - The set of possible classes to be matched
{   a subrange or
{    enumerated type
{
{ Parameters:
{    FSP - The type for which we want the valid range
{    FMin - Place  	
fects:
{    Code may be generated
{
{ Calls:
{    Statement
{    GenLabel
{    PutLabel
{    ExpExpression
{    Expressiopriate code
{
{ Side Effects:
{    The state of CurIFile may be modified.
{    Code may be generated
{
{ Calls:
{    Genon
{    QGenBJmp
{    EPop
{    Error
{------------------------------------------}
      var LAddr: LBP; Test: Boolean;
  Label
{    PutLabel
{    ExpExpression
{    Expression
{    SearchId
{    Error
{    CompTypes
{    InSymbol
{    Skip
  begin
    GenLabel(LAddr);
    PutLabel(LAddr);
    repeat
        repeat
            Statement(FSys + [SemiColon,UntilSy{    LoadExpr
{    GenLDC
{    QGen0
{    EQuick
{    Store
{    QGen1A
{    QGen2
{    QGenCmp
{    EPop
{    QGenJmp])
        until not (Sy in StatBegSys);
        Test := Sy <> SemiColon;
        if not Test then InSymbol
    until Test;
{    Statement
{------------------------------------------}
      var LAttr: Attr; LSP: STP;  LSy: Symbol;
          LCIX, L
    if Sy = UntilSy then
        begin
        InSymbol;
        ExpExpression(Expression(FSys));
        QGenBJmp(JFB,LAddAddr: LBP;
    begin
    if Sy = Ident then
        begin
        SearchId(Vars,FCP);
        with FCP, LAttr do
         r);
        EPop(1)
        end
    else
        Error(53)
    end { RepeatStatement };

procedure WhileStatement;
{---   begin
            TyPtr := IdType;
            Kind := Varbl;
            if Klass = ActualVars then
                begi----------------------------------------
{ Abstract:
{    Parse WHILE statements and generate the appropriate code
{
{ Side n
                Access := Drct; VLevel := VLev;
                Dplmt := VAddr
                end
            else
     Effects:
{    The state of CurIFile may be modified.
{    Code may be generated
{
{ Calls:
{    GenLabel
{    PutLabel
{            begin Error(155); TyPtr := nil end
            end;
        if LAttr.TyPtr <> nil then
            with LAttr.TyPt   ExpExpression
{    Expression
{    QGenBJmp
{    EPop
{    InSymbol
{    Error
{    Statement
{    QGenJmp
{---------r^ do
                if (Form > SubRange) or (Size <> 1) then
                    begin Error(143); LAttr.TyPtr := nil end;
---------------------------------}
      var LAddr, LCIX: LBP;
    begin
    GenLabel(LAddr);
    PutLabel(LAddr);
    ExpE        InSymbol
        end
    else
        begin
        Error(2);
        Skip(FSys + [Becomes,ToSy,DownToSy,DoSy])
            { until the entire table is written }
        PutLabel(LAddr)           { and place the label for QCode after XJP }
xpression(Expression(FSys + [DoSy]));
    GenLabel(LCIX); QGenBJmp(JFB,LCIX); EPop(1);
    if Sy = DoSy then InSymbol else Err        end;
    if Sy = EndSy then InSymbol else Error(13)
    end { CaseStatement };

procedure RepeatStatement;
{------or(54);
    Statement(FSys);
    QGenJmp(JMPB,LAddr); PutLabel(LCIX)
    end { WhileStatement };

procedure ForStatement(v-------------------------------------
{ Abstract:
{    Parse REPEAT statements and generate the appropriate code
{
{ Side Efar FCP: Identifier);
{-------------------------------------------
{ Abstract:
{    Parse FOR statements and generate the appr   	
ers, otherwise false
{--------------------}
begin
PAOfChar := false;
if FSP <> nil then
    with FSP ^ do
        if Form  (Size > IntgrSize)) or (Form = Power) then
            MultiAccess:=true
end { MultiAccess };

procedure Constant(FSys: Se= Arrays then
            PAOfChar := AIsPackd and (AElType = CharPtr)
end { PAOfChar };

function StrgType(FSP: STP): booltOfSys; var FSP: STP; var FValu: Valu);
{---------------------
{ Abstract:
{    Parse a constant expression from the source pean;
{--------------------
{ Abstract:
{    Determine if a structure is a string
{
{ Parameters:
{    FSP - The structure rogram and return the
{    resultant value
{
{ Parameters:
{    FSys - Possible symbols to terminate the constant expression to return the minimum allowable value
{    FMax -   "   "     "    "  maximum     "       "
{
{ Calls:
{    LookupNum
{---to be tested
{
{ Results:
{    True if FSP is a string, otherwise false
{--------------------}
begin
StrgType := false;
i--------------------------------}
  var FCP: Identifier;
begin
with FSP^ do
    if Form = SubRange then
      begin FMin :=f PAOfChar(FSP) then StrgType := FSP^.AIsStrng
end { StrgType };

function ByteArray(LSP: STP): boolean;
{ true if LSP is a Min.IVal; FMax := Max.IVal end
    else
        begin FMin := 0;
        if FSP = CharPtr then FMax := 255
        else
  cessed with byte or string QCodes }
{--------------------
{ Abstract:
{    Determine if a structure is a packed array of byte          if FSP^.FConst <> 0 then
                begin
                LookupNum(FSP^.FConst,FCP);
                FMax := s
{
{ Parameters:
{    LSP - The structure to be tested
{
{ Results:
{    True if LSP is a packed array of bytes, otherwisFCP.Values.IVal
                end
            else
                FMax := 0
        end
end { GetBounds };

proceduree false
{--------------------}
begin
ByteArray:=false;
if LSP <> nil then
    with LSP^ do
        if Form = Arrays then
 Skip(FSys: SetOfSys);
{---------------------
{ Abstract:
{    Skip over input stream until the current symbol is in  certain            if AIsPackd then
                ByteArray := ElWidth = 8
end { ByteArray };

function MultiAccess(LSP: STP): b class
{
{ Parameters:
{    FSys - The set of symbols on which to stop skipping over
{
{ Side Effects:
{    State of CurIFoolean;
{--------------------
{ Abstract:
{    Determine if a structure requires use of Load/Store Multiple Word
{    QCodesile may change
{
{ Calls:
{    InSymbol
{---------------------}
begin
while not(Sy in FSys) do InSymbol
end { Skip };
 to gain access to it
{
{ Parameters:
{    LSP - The structure to be tested
{
{ Results:
{    True if access to LSP requir
function PAOfChar(FSP: STP): boolean;
{--------------------
{ Abstract:
{    Determine if a structure is a packed array of ces Load/Store Multiple Word Qcodes,
{    otherwise false
{--------------------}
{ true if LSP requires use of LDMW, STMW, LDDharacters
{
{ Parameters:
{    FSP - The structure to be tested
{
{ Results:
{    True if FSP is a packed array of charactW, STDW to gain access to it }
begin
MultiAccess:=false;
if LSP <> nil then
    with LSP^ do
        if ((Form < Power) and  	
      end;
    if Sy = Becomes then
        begin
        InSymbol;
        ExpExpression(Expression(FSys + [ToSy,DownToSy,D
                            QGen0(CHK);
                            EQuick(2)
                            end;
            oSy]));
        if GAttr.TyPtr <> nil then
            if GAttr.TyPtr^.Form > SubRange then
                Error(144)
             if Level = MainLex then
                        QGen1A(STOB,LC)
                    else
                        QGen       else
                if CompTypes(LAttr.TyPtr,GAttr.TyPtr) then
                    begin
                    LoadExpr2(STIB,0,LC);
                    PutLabel(LAddr);
                    GAttr := LAttr;
                    LoadExpr;
       ;
                    if LAttr.TyPtr <> nil then
                        if (LAttr.TyPtr^.Form=SubRange) and RangeCheck^.Sw th             if Level = MainLex then
                        QGen1A(LDOB,LC)
                    else
                       en
                            begin
                            GenLDC(LAttr.TyPtr^.Min.IVal);
                            G QGen2(LDIB,0,LC);
                    LC := LC + IntgrSize;
                    if LC > LCMax then LCMax := LC;
            enLDC(LAttr.TyPtr^.Max.IVal);
                            QGen0(CHK);
                            EQuick(2)
                         if LSy = ToSy then
                        QGenCmp(LEQ,CInt,IntgrSize)
                    else
                                end;
                    Store(LAttr)
                    end
                else
                    Error(145)   QGenCmp(GEQ,CInt,IntgrSize);
                    EPop(1)
                    end
                else
                   
        end
    else
        begin Error(51); Skip(FSys + [ToSy,DownToSy,DoSy]) end;
    GenLabel(LAddr);
    if Sy in [To Error(145)
        end
    else
      begin Error(55); Skip(FSys + [DoSy]) end;
    GenLabel(LCIX); QGenJmp(JFB,LCIX); EPopSy,DownToSy] then
        begin
        LSy := Sy; InSymbol; ExpExpression(Expression(FSys + [DoSy]));
        if GAttr.TyPtr(1);
    if Sy = DoSy then InSymbol else Error(54);
    Statement(FSys);
    GAttr := LAttr; LoadExpr; GenLDC(1);
    if LSy <> nil then
            if GAttr.TyPtr^.Form > SubRange then
                Error(144)
            else
                if = ToSy then QGen0(ADI) else QGen0(SBI); EQuick(1);
    Store(LAttr); QGenJmp(JMPB,LAddr); PutLabel(LCIX);
    LC := LC - Intg CompTypes(LAttr.TyPtr,GAttr.TyPtr) then
                    begin
                    LoadExpr;
                    if LAttrrSize
    end { ForStatement };

procedure WithStatement;
{-------------------------------------------
{ Abstract:
{    P.TyPtr <> nil then
                        if (LAttr.TyPtr^.Form = SubRange) and RangeCheck^.Sw then
                         arse WITH statements and generate the appropriate code
{
{ Side Effects:
{    The state of CurIFile may be modified.
{    Co   begin
                            GenLDC(LAttr.TyPtr^.Min.IVal);
                            GenLDC(LAttr.TyPtr^.Max.IVal);de may be generated
{
{ Calls:
{    SearchId
{    InSymbol
{    LookupNum
{    Error
{    ExpExpression
{    Selector
{   	
ct:
{    Push a new value on the constant evaluation stack
{
{ Parameters:
{    Val - the value to be pushed
{
{ Side Effeator;          { Operator Found }
        Signed:boolean;        { flag for unary minus }

procedure CTerm(FSys:SetOfSys);
cts:
{    CSPtr is incremented and a new element is inserted into CStack
{
{ Errors:
{    Stack Overflo
{
{ Calls:
{    E{-----------------------
{ Abstract:
{    Portion of constant expression evaluation
{    Evaluates the following operators:
rror
{-----------------------}
begin
if CSPtr = CStackSize then
    Error(175)
else
    begin
    CSPtr:=CSPtr+1;
    CS{        Multiply
{        Divide
{        Mod
{        And
{
{ Parameters:
{    FSys - legal terminal symbols
{
{ Envirtack[CSPtr]:=Val
    end
end { CPush };

procedure CExpr(FSys:SetOfSys);
{-----------------------
{ Abstract:
{    Portionment:
{    Arguments for the operators are to be on the CStack
{
{ Side Effects:
{    CSPtr and the contents of CStack wilon of constant expression evaluation
{    Evaluates the relational operators
{
{ Parameters:
{    FSys - legal terminal symbl be modified
{
{ Calls:
{    CFactor
{    CompTypes
{    Error
{-----------------------}
      var LOp:Operator;        ols
{
{ Environment:
{    Arguments for the operators are to be on the CStack
{
{ Side Effects:
{    CSPtr and the content { Operator Found }

procedure CFactor(FSys:SetOfSys);
{-----------------------
{ Abstract:
{    Portion of constant expre
{    FSP - Place to return the type of the constant expression
{    FValu - Place to return the value of the expression
{
{s of CStack will be modified
{
{ Calls:
{    CSimpleExpr
{    CompTypes
{    Error
{-----------------------}
  var
      Side Effects:
{    State of CurIFile may be modified
{
{ Calls:
{    CExpr
{    New
{    Error
{    Skip
{
{ Design:
 LocLSP: STP;
      TChr: char; SaveOp: Operator;
      S1,S2: packed record case boolean of
                 true: (Str: str{    The compiler uses a stack with limitted depth for constant evaluation.
{    Also, the layout of the subparts which make uping[StrgLgth]);
                 false:(SLen: 0..255;
                        Chrs: ChrsOfString)
                end;

pr this procedure follow the
{    layout of the normal compiler expression evaluation parsing.
{
{    NOTE: Currently Constant ocedure CSimpleExpr(FSys:SetOfSys);
{-----------------------
{ Abstract:
{    Portion of constant expression evaluation
{   Long Integers are not supported
{----------------------}
  Const CStackSize = 16;                { constant evaluation stack s Evaluates the following operators:
{        Plus
{        Minus
{        Or
{
{ Parameters:
{    FSys - legal terminal syize }
  Var   LSP: STP; LVP: CSP;
        CStack: array[1..CStackSize] of Valu;     { cst evaluation stack }
        CSPtr: 0mbols
{
{ Environment:
{    Arguments for the operators are to be on the CStack
{
{ Side Effects:
{    CSPtr and the conte..CStackSize;                     { cst eval. stack pointer }

procedure CPush(Val: Valu);
{----------------------
{ Abstrants of CStack will be modified
{
{ Calls:
{    CTerm
{    CompTypes
{    Error
{-----------------------}
    var LOp:Oper  	
                 begin
                                if Level = MainLex then
                                    QGen1A(STOB if Sy = DoSy then InSymbol else Error(54);
    Statement(FSys);
    Top := Top - LCnt1; LC := LC - LCnt2
    end { WithState,LC)
                                else
                                    QGen2(STIB,0,LC);
                             ment };

begin { Statement }
  StmtLev := StmtLev + 1;
  if Sy = IntConst then { Label }
      begin
      TTop := Top;
   EPop(1);
                                VTyp:=Off20;
                                VDspl := LC;
                             while Display[TTop].Occur <> Blck do TTop := TTop-1;
      LLP := Display[TTop].FLabel;
      while LLP <> nil do
         LoadAddress
{    QGen1A
{    QGen2
{    EPop
{    QGen0
{    EPush
{    Statement
{----------------------------------         LC:=LC+1;
                                LCnt2:=LCnt2+1
                                end
                       --------}
      var LCP: Identifier; LCnt1,LCnt2: DispRange; Test: Boolean;
    begin
    LCnt1 := 0; LCnt2 := 0;
    repeat     else { ETos = 2 }
                                begin
                                QGen0(MMS2);
                   
        if Sy = Ident then
          begin SearchId(Vars + [Field],LCP); InSymbol end
        else
          begin Error(2)             EPop(2);
                                if Level = MainLex then
                                    QGen1A(LOAB,; LookupNum(UVarPtr,LCP) end;
        ExpExpression(Selector(FSys + [Comma,DoSy],LCP));
        if GAttr.TyPtr <> nil then
  LC)
                                else
                                    QGen2(LIAB,0,LC);
                                        if GAttr.TyPtr^.Form = Records then
                if Top < DispLimit then
                    begin
               EPush(Off20);
                                QGen0(MES2);
                                EPush(Data32);
                        Top := Top + 1; LCnt1 := LCnt1 + 1;
                    with Display[Top] do
                        begin FName := GAt               QGen0(STDW);
                                EPop(3);
                                VTyp:=Ptr32;
           tr.TyPtr^.FstFld end;
                    if GAttr.Access = Drct then
                        with Display[Top] do
                               VDspl := LC;
                                LC:=LC+2;
                                LCnt2:=LCnt2+2
                    begin
                            Occur := CRec; CLev := GAttr.VLevel;
                            CDspl :=                               end;
                            Occur := VRec;
                            if LC > LCMax then LGAttr.Dplmt
                            end
                    else
                        with Display[Top] do
          CMax := LC
                            end
                    end
                else
                    Error(250)
                      begin
                            LoadAddress;
                            if ETos = 1 then
                       else
                Error(140);
        Test := Sy <> Comma;
        if not Test then InSymbol
    until Test;
      	
ons (ORD, CHR, RECAST, WORDSIZE)
{
{ Side Effects:
{    CSPtr and the contents of CStack will be modified
{
{ Errors:
{   
                          if LCP1.IdType <> nil then
                              TVal.IVal:=LCP1.IdType^.Size
             Error in constant
{    Type conflict of operands
{
{ Calls:
{    SearchId
{    CompTypes
{    CPush
{    InSymbol
{                  else
                              TVal.IVal:=0;
                          CPush(TVal);
                       Error
{-------------------------}
        var LCP,LCP1:Identifier; SaveFSP:STP; TVal: Valu;
      begin
      if Sy = Ident    InSymbol;
                          if Sy <> RParent then Error(4) else InSymbol;
                          end
          then
          begin
          SearchId([Konst,Func],LCP);
          if LCP.Klass = Konst then
              with LCP do
              else
                          Error(129)
                      end
                  else
                                     if CompTypes(LSP,IdType) then
                      begin
                      CPush(Values);
               begin
                      SaveFSP:=LSP;
                      LSP:=nil;
                      CSimpleExpr(FSys);
                if LSP = nil then
                          begin
                          LSP:=IdType;
                          wh              with LCP do
                          case Key of
                              OrdKey,ChrKey:
                ile LSP^.Form = SubRange do LSP:=LSP^.RangeType
                          end;
                      InSymbol
                                 if CompTypes(SaveFSP,IdType) then
                                      begin
                                     end
                  else
                      Error(129)
          else
              if LCP.PFDecKind <> Special         if SaveFSP = nil then SaveFSP:=IdType
                                      end
                                  elsethen
                  Error(50)
              else
                  begin
                  InSymbol;
                  i
                                      Error(129);
                              ReCastKey:
                                 ssion evaluation
{    Evaluates the Not operator and parenthesized expressions
{
{ Parameters:
{    FSys - legal terminal syf Sy <> LParent then Error(9) else InSymbol;
                  if not (LCP.Key in [OrdKey,ChrKey,ReCastKey,WrdSizKey]) then
  mbols
{
{ Environment:
{    Arguments for the operators are to be on the CStack
{
{ Side Effects:
{    CSPtr and the conte                    Error(50)
                  else if LCP.Key = WrdSizKey then
                      begin
                nts of CStack will be modified
{
{ Calls:
{    CVar
{    Error
{    Skip
{-----------------------}

procedure CVar;
{-      if CompTypes(LSP,IntPtr) then
                          begin
                          if LSP = nil then LSP := IntPtr;-----------------------
{ Abstract:
{    Portion of constant expression evaluation
{    Evaluates operands and special functi
                          SearchId([Konst,Types,FormalVars,ActualVars,Field,
                                    Func],LCP1);  	
                    CompoundStatement end;
            GotoSy:   begin InSymbol;
                      GotoStatement end;
    start word aligned or }
                                { alignment of string consts, and anything }
                                 IfSy:     begin InSymbol;
                      IfStatement end;
            CaseSy:   begin InSymbol;
                     { which requires alignment, is bizarre }
LLP := Display[Top].FLabel;  { Check Undefined Labels }
while LLP <> nil do
         CaseStatement end;
            WhileSy:  begin InSymbol;
                      WhileStatement end;
            Repea    with LLP^,CodeLbP^ do
        begin
        if not Defined then
            if OccurIC <> MaxAddr then Error(168);
     tSy: begin InSymbol;
                      RepeatStatement end;
            ForSy:    begin InSymbol;
                      F   LLP := NextLab
        end;
{ Generate Procedure Dictionary Entry }
with FProcP,PDFile^ do
    begin
    ProcNum:=PFNameorStatement(LCP) end;
            WithSy:   begin InSymbol;
                      WithStatement end;
            RaiseSy:  be;
    ProcName:=Name;
    if IsProgram and (PFName = 0) then
        begin
        PS:=0;
        RPS:=0;
        ACS:=0
gin InSymbol;
                      if Sy <> Ident then
                          begin Error(2); Skip(FSys) end;
                   end
    else
        begin
        { parameter size }
        if Klass = Func then
            if IdType <> nil the     with LLP^ do
              if LabVal = Val.IVal then
                  begin
                  if CodeLbP^.Defined then            SearchId([Handle,Except],LCP);
                      InSymbol;
                      ExpExpression(Call(FSys,LCP))Error(165);
                  PutLabel(CodeLbP);
                  goto 1
                  end
              else
        
                      end
        end {cases};
      if ETos > 0 then
          begin
          Error(306);
          ETos          LLP := NextLab;
      Error(167);
1:    InSymbol;
      if Sy = Colon then InSymbol else Error(5)
      end;
  if:=0
          end;
      if not (Sy in [SemiColon,EndSy,ElseSy,UntilSy]) then
        begin Error(6); Skip(FSys) end
      e not (Sy in FSys + [Ident]) then
    begin Error(6); Skip(FSys) end;
  if Sy in StatBegSys + [Ident] then
      begin
      nd;
  StmtLev := StmtLev - 1
  end { Statement };

begin { BodyPart }
if (FProcP.IdNum <> 0) and Noisy^.Sw then     { tell  case Sy of
            Ident:    begin
                      SearchId(Vars + [Field,Func,Proc],LCP);
                       the user where we are }
    writeln('':FProcP.PFLev*2,FProcP.Name);
LCMax := LC;
repeat
    repeat
        Statement(FSys InSymbol;
                      if LCP.Klass = Proc then
                          ExpExpression(Call(FSys,LCP))
            + [SemiColon,EndSy])
    until not (Sy in StatBegSys);
    Test := Sy <> SemiColon;
    if not Test then InSymbol
until Test          else
                          Assignment(LCP)
                      end;
            BeginSy:  begin InSymbol;
  ;
if Sy = EndSy then InSymbol else Error(13);
ExitIC := IC;
QGen0(RETURN);
if odd(IC) then GenByte(NOP);   { procedures must   	
<> Ident then Error(2);
                                  SearchId([Types],LCP);
                                  if CompType             Error(129)
          end
      else if (Sy = StringConst) and (Lgth = 1) then
          begin
          if Comps (SaveFSP,IdType) then
                                      begin
                                      if SaveFSP = nil theTypes(LSP,CharPtr) then
              begin
              if LSP = nil then LSP:=CharPtr;
              CPush(Val);
        n
                                          if IdType^.Form <= SubRange then
                                              if       InSymbol
              end
          else
              Error(129)
          end
      else if (Sy = StringConst) andIdType <> RealPtr then
                                                  SaveFSP:=IdType
                                      (Lgth <> 1) then
          begin
          if CompTypes(LSP,StrgPtr) then
              begin
              if LSP = nil th         else
                                                  Error(109)
                                          else
   en LSP := StrgPtr;
              New(CurHeap,1,LVP,Strg);
              LVP^ := Val.ValP^;
              LVP^.STyp := DynCst;                                           Error(115)
                                      end
                              
              Val.ValP := LVP;
              CPush(Val);
              InSymbol
              end
          else
            else
                                      Error(129);
                                  InSymbol
                             Error(129)
          end
      else
          Error(50)
      end { CVar };

    begin { CFactor }
    if not (Sy            end
                              end { case };
                      if Sy <> RParent then Error(4) else InSymbol;in FacBegSys - [LBrack]) then
        begin
        Error(50);
        Skip(FSys+FacBegSys)
        end;
    if Sy In FacBe
                      LSP:=SaveFSP
                      end
                  end
          end
      else if Sy = IntCongSys - [LBrack] then
        if Sy = NotSy then
            begin
            InSymbol;
            CFactor(FSys);
        st then
          begin
          if CompTypes(LSP,IntPtr) then
              begin
              if LSP = nil then LSP := I    if LSP <> BoolPtr then
                Error(129)
            else
                if CSPtr > 0 then
                   ntPtr;
              CPush(Val);
              InSymbol
              end
          else
              Error(129)
         CStack[CSPtr].IVal:=ord(not 
                        Recast(CStack[CSPtr].IVal,boolean))
                else
                end
      else if Sy = RealConst then
          begin
          if CompTypes(LSP,RealPtr) then
              begin
            Error(50)
            end
        else if Sy = LParent then
            begin
            InSymbol;
            CExpr begin
                                  if Sy <> Comma then Error(62) else InSymbol;
                                  if Sy         if LSP = nil then LSP:=RealPtr;
              CPush(Val);
              InSymbol
              end
          else
   	
Size(CodeSeg,DefCodeSize);   { give back any extra we took }
CodeSize:=DefCodeSize;
MaxCode:=DefCodeSize*512-1;
DecRefCount(E 1;
        CReal     = 2;
        CStr      = 3;
        CByte     = 4;
        CPowr     = 5;
        CWord     = 6;
   xpHeap);              { give back the old expression heap }
CreateSegment(ExpHeap,1,1,256)     { and create a fresh one - with      CLong     = 7;

Procedure ExpExpression(Node: ESP);

PRIVATE

{$C Copyright (C) 1981  Three Rivers Computer Corporatia clean
                                     free space list }
end { BodyPart }.
                                            on }

Imports BodyPrt from BodyPart;
Imports QCodes from QCodes.Dfs;
Imports CodeGeneration from CodeGen;

{$R-}

{$INC  Expr0 }
{$INC Expr1 }
{$INC Expr2 }
{$INC Expr3 }
                                                                             {-----------------------------------
{
{ Expression Expansion  Part A
{ Copyright (C) 1981  Three Rivers Computer CorporationModule ExpandExpression;
{----------------------------------------------------
{
{ Expression Expansion
{ Copyright (C) 1981
{
{ Abstract:
{    The first part of expression expansion - deals mainly with expansion
{    of 'selectors', and also the d  Three Rivers Computer Corporation
{
{ Abstract:
{    Expand Expression Trees - causing the appropriate code to be generatedisposal of the expression tree (once the
{    expansion is complete).
{
{ File: Expr0.Pas
{
{------------------------------
{
{ File: ExpExpr.Pas
{
{---------------------------------------------------}

{ }
{ 19-Mar-81  2.6  Miles A. Barel
{ -----}

{ }
{ 06-Feb-81  2.0  Miles A. Barel
{ Implementation of Long Integers
{ }
{ 13-Jan-81  1.11  Miles A. Barel
{ Bn
                PS:=LocalLC-IdType^.Size
            else
                PS:=LocalLC
        else
            PS:=LocalLRECAST Bug Fix
{ }
{ 04-Feb-81  2.0  Miles A. Barel
{ Implementation of Long Integers
{ }
{ 7-Jan-81  1.6  Miles A. Barel
C;
        { Result + Parameter Size }
        RPS:=LocalLC;
        { Activation Size }
        ACS:=LCMax-RPS
        end{ Institution of standard 3RCC file formats
{ }

EXPORTS

Imports PascalCompiler from Pascal;

Const
{ Boolean Comparis;
    { Enter IC }
    EntA:=NextPEnter;
    { Exit IC }
    ExtA:=NextPEnter+ExitIC;
    NextPEnter:=NextPEnter+IC;
    {on Constants }
    { Comparison Types : }
        EQL       = 0;
        NEQ       = 1;
        LEQ       = 2;
        LES  Lex Level }
    LL:=Level
    end;
Put(PDFile);

WriteCode(false);        { Write out the code - or atleast Q it }
Change      = 3;
        GEQ       = 4;
        GTR       = 5;
    { Operand Types : }
        CBool     = 0;
        CInt      =    	
hen
                        CStack[CSPtr-1].IVal:=CStack[CSPtr-1].IVal mod
                                              CStac Error(129);
            Minus:if CompTypes(LSP,IntPtr) then
                      CStack[CSPtr-1].IVal:=CStack[CSPtr-1].IVal k[CSPtr].IVal
                    else
                        Error(129);
              AndOp:if CompTypes(LSP,BoolPtr) then-
                                            CStack[CSPtr].IVal
                  else if CompTypes(LSP,RealPtr) then
      (FSys + [RParent]);
            if Sy = RParent then InSymbol else Error(4)
            end
        else
            CVar
 
                        CStack[CSPtr-1].IVal:=
                            ord(Recast(CStack[CSPtr-1].IVal,boolean) and
       end { CFactor };

  begin { CTerm }
  CFactor(FSys+[MulOp]);
  while Sy = MulOp do
      begin
      LOp:=Op;
      I                            Recast(CStack[CSPtr].IVal,boolean))
                    else
                        Error(129)
 nSymbol;
      CFactor(FSys+[MulOp]);
      if CSPtr < 2 then
          Error(50)
      else
          case LOp of
                end { case };
      CSPtr:=CSPtr-1
      end
  end { CTerm };

begin { CSimpleExpr }
Signed:=false;
if (Sy = Ad       Mul: if CompTypes(LSP,IntPtr) then
                       CStack[CSPtr-1].IVal:=CStack[CSPtr-1].IVal *
                dOp) and (Op in [Plus,Minus]) then
    begin
    Signed:=Op = Minus;
    InSymbol
    end;
CTerm(FSys+[AddOp]);
if Signed                             CStack[CSPtr].IVal
                   else if CompTypes(LSP,RealPtr) then
                       Cthen
    if CSPtr > 0 then
        if CompTypes(LSP,IntPtr) then
            CStack[CSPtr].IVal:=-CStack[CSPtr].IVal
       Stack[CSPtr-1].ValP^.RVal:=CStack[CSPtr-1].ValP^.RVal *
                                                   CStack[CSPtr].ValP^. else if CompTypes(LSP,RealPtr) then
            CStack[CSPtr].ValP^.RVal:=-CStack[CSPtr].ValP^.RVal
        else
           RVal
                   else
                       Error(129);
              RDiv: if CompTypes(LSP,RealPtr) then
          Error(129)
    else
        Error(50);
while Sy = AddOp do
    begin
    LOp:=Op;
    InSymbol;
    CTerm(FSys+[AddOp]);               CStack[CSPtr-1].ValP^.RVal:=CStack[CSPtr-1].ValP^.RVal /
                                                    CSt
    if CSPtr < 2 then
        Error(50)
    else
        case LOp of
            Plus: if CompTypes(LSP,IntPtr) then
    ack[CSPtr].ValP^.RVal
                    else
                        Error(129);
              IDiv: if CompTypes(LSP,IntPt                  CStack[CSPtr-1].IVal:=CStack[CSPtr-1].IVal +
                                            CStack[CSPtr].IVal
r) then
                        CStack[CSPtr-1].IVal:=CStack[CSPtr-1].IVal div
                                              C                  else if CompTypes(LSP,RealPtr) then
                      CStack[CSPtr-1].ValP^.RVal:=CStack[CSPtr-1].ValP^.RStack[CSPtr].IVal
                    else
                        Error(129);
              IMod: if CompTypes(LSP,IntPtr) tVal +
                                                  CStack[CSPtr].ValP^.RVal
                  else
                        	
tution of standard 3RCC file formats
{ }

procedure TreeDispose(Head: ESP);
{----------------------------------
{ Abstractil then
                begin
                Prev := Cur;
                Cur := tmp
                end
            else:
{    Procedure to dispose of an expression tree

{ Parameters:
{    Head - The head of the tree to be disposed
{
{ Side 
                goto 1   { no right son, try left }
            end
        else if SSy = OtherSy then
            begin
  Effects:
{    Memory is released back to the free space pool in the ExpHeap segment
{
{ Calls:
{    Dispose
{    
{ Design          { second visit to the node - go down its left link }
          1:tmp := LLink;
            LLink := Prev;
         :
{    It is known that the symbols OTHERSY and VARSY never occur in an
{    Expression tree node, hence they are used to mark   SSy := VarSy;      { mark node as visited twice }
            if tmp <> nil then
                begin
                Pre the state of the node
{------------------------------------}
  label 1,2;
  var Prev, Cur, tmp, tmp1: ESP; Junk: record casev := Cur;
                Cur := tmp
                end
            else
                goto 2     { no left son, dispose! boolean of
                                         true: (ptr: ESP);
                                         false:(seg,ofs }
            end
        else
            begin
            { last visit - dispose of the node and back up }
          2:t:integer)
                                      end;
begin
Cur := Head;      { the current node }
Prev := nil;      { the ptmp:=Cur;
            tmp1 := RLink;
            if RLink <> nil then
                Prev := RLink^.RLink
            elsearent of the current node }
while Cur <> nil do
    with Cur^ do
        begin
        if EType = Opnd then
            beg
                Prev := nil;
            RLink:=nil;
            LLink:=nil;
            Cur := tmp1;
            Dispose(tin
            tmp := Cur;
            tmp1 := Prev;
            if tmp1 <> nil then
                Prev := tmp1^.RLink
  mp,Opr)
            end
        end
end { TreeDispose };

procedure ExpExpression(Node: ESP);
{--------------------------          else
                Prev := nil;
            case OpClass of
                Idd: Dispose(tmp,Opnd,Idd);
        ---------------
{ Abstract:
{    The main body of the expression expansion stuff (the body of this
{    procedure is actually        Kst: Dispose(tmp,Opnd,Kst)
              end;
            Cur := tmp1
            end
        else if not (SSy in [O in Expr3.Pas) - deals mainly with relational
{    operators and the IN operator
{
{ Parameters:
{    Node - the root node otherSy,VarSy]) then
            begin
            { this is the first visit to a node - go down its right link }
            f the tree to be expanded
{
{ Side Effects:
{    Code may be generated
{    The tree will be disposed of on completion
{
{ug Fix - functions of non-scalars now return temp stack space
{ }
{ 7-Jan-81  1.6  Miles A. Barel
{ General cleanup and institmp := RLink;
            RLink := Prev;
            SSy := OtherSy;    { mark node as visited once }
            if tmp <> n !  	
               LSP := LocLSP;
                TChr:=chr(CStack[CSPtr].IVal);
                New(CurHeap,1,CStack[CSPtr].ValP,al);
                                  GtOp: CStack[CSPtr-1].IVal :=
                                     ord(CStack[CSPtr-1].Strg);
                with CStack[CSPtr].ValP^ do
                    begin
                    SVal[1]:=TChr;
            IVal >
                                         CStack[CSPtr].IVal);
                                  GeOp: CStack[CSPtr-1].I        SLgth:=1;
                    STyp:=DynCst;
                    CClass:=Strg
                    end
               Val :=
                                     ord(CStack[CSPtr-1].IVal >=
                                         CStack[CSPtr] end;
            if (LocLSP = CharPtr) and ByteArray(LSP) then
                begin
                LocLSP := LSP;
       .IVal);
                                  EqOp: CStack[CSPtr-1].IVal :=
                                     ord(CStack[CSPtr-         TChr:=chr(CStack[CSPtr-1].IVal);
                New(CurHeap,1,CStack[CSPtr-1].ValP,Strg);
                with CStac1].IVal =
                                         CStack[CSPtr].IVal);
                                  NeOp: CStack[CSPtr-1                CStack[CSPtr-1].ValP^.RVal:=CStack[CSPtr-1].ValP^.RVal -
                                                  CStak[CSPtr-1].ValP^ do
                    begin
                    SVal[1]:=TChr;
                    SLgth:=1;
             ck[CSPtr].ValP^.RVal
                  else
                      Error(129);
            OrOp: if CompTypes(LSP,BoolPtr) the       STyp:=DynCst;
                    CClass:=Strg
                    end
                end;
            if LSP <> niln
                      CStack[CSPtr-1].IVal:=
                          ord(Recast(CStack[CSPtr-1].IVal,boolean) or
         then
                if CompTypes(LocLSP,LSP) then
                    begin
                    case LSP^.Form of
                              Recast(CStack[CSPtr].IVal,boolean))
                  else
                      Error(129)
                           Scalar,Subrange:
                            if CompTypes(LSP,RealPtr) then
                                Er end { case };
    CSPtr:=CSPtr-1
    end { While }
end { CSimpleExpr };

begin { CExpr }
CSimpleExpr(FSys + [RelOp]);
iror(399)
                            else
                                begin
                                case SaveOp of Sy = RelOp then
    begin
    LocLSP:=LSP;
    LSP:=nil;
    SaveOp:=Op;
    InSymbol;
    CSimpleExpr(FSys);
    if CSf
                                  LtOp: CStack[CSPtr-1].IVal :=
                                     ord(CStack[CSPtr-1].IVaPtr <> 2 then
        Error(50)
    else if (LocLSP <> nil) and (LSP <> nil) then
        if SaveOp = InOp then
            l <
                                         CStack[CSPtr].IVal);
                                  LeOp: CStack[CSPtr-1].IValError(399)
        else
            begin
            if (LSP = CharPtr) and ByteArray(LocLSP) then
                begin
  :=
                                     ord(CStack[CSPtr-1].IVal <=
                                         CStack[CSPtr].IV ! 	
Select(Node: ESP);
{-----------------------------------------
{ Abstract:
{    Recognize operators used in selectors and callen0(SBI)
                    end
                end
            end { with LAttr.TyPtr^ };
        with GAttr do
          the appropriate routines
{    to handle the individual operators
{
{ Parameters:
{    Node - The root of the subselection
   begin
            TyPtr := LAttr.TyPtr^.AElType;
            Kind := Varbl;
            Access := Indrct;
            IDp Calls:
{    ExpSimpleExpression
{    LoadExpr
{    LoadAddress
{    ExpFloat
{    ExpStretch
{    GenLDC
{    EPush
{  {
{ Calls:
{    ExpSubSelect
{    ArraySelect
{    FieldSelect
{    PtrSelect
{    FileSelect
{--------------------------  ByteArray
{    QGen0
{    QGen1A
{    EPop
{    PAOfChar
{    MakePa
{    Error
{    GetBounds
{    QGenCmp
{    Tree-----------------}

procedure ArraySelect;
{------------------------------------------
{ Abstract:
{    Generate Code for Dispose
{
{ Design:
{    The structure of ExpExpression basically follows the same structure as
{    used in Expression
{--the array selection process
{
{ Side Effects:
{    Disposal of the tree representing the indexing expression
{    Generation---------------------------------------}
    var LAttr: Attr; TypInd: integer;
        LSize: AddrRange; LString,GString: bool of code to perform the indexing
{
{ Calls:
{    LoadAddress
{    ExpExpression
{    LoadExpr
{    StrgType
{    GetBoundean;
        LOp: Operator; LMin,LMax,PS,BytePtr,LLen,GLen,MPop: integer;
        Son: ESP; Float,Stretch: boolean;
        Ns
{    EQuick
{    GenLDC
{    QGen0
{    QGen2
{    QGen1A
{    QPop
{    MultiAccess
{--------------------------------extParm: ESP;

procedure ExpSelector(Node:ESP);
{------------------------------------------
{ Abstract:
{    Expand 'selec--------------}
      var LAttr: Attr;
    begin
    LAttr := GAttr;
    LoadAddress;
    ExpExpression(Node^.RLink);
    tors'
{
{ Parameters:
{    Node - the root node of the 'selector'
{
{ Side Effects:
{    Code may be generated
{
{ CallsNode^.RLink:=nil;
    LoadExpr;
    if LAttr.TyPtr <> nil then
        begin
        with LAttr.TyPtr^ do
            begin:
{    LookupNum
{    QGen1A
{    QGen2
{    EPush
{    EPop
{    QGen0
{    LoadAddress
{    StrgType
{    GenLDC
{  
            if (InxType <> nil) and
              not StrgType(LAttr.TyPtr) then
                begin
                GetB  Error
{    MultiAccess
{    ExpSubSelect
{
{ Design:
{    The construction of ExpSelector differs slightly from Selector ounds(InxType,LMin,LMax);
                if RangeCheck^.Sw then
                    begin
                    EQuick(2);
  in the
{    use of ExpSubSelect to handle the more complex selectors (as opposed to
{    Selector which does it all itself).
                  GenLDC(LMin); GenLDC(LMax);
                    QGen0(CHK)
                    end;
                if LMin{--------------------------------------------}
  var Node1: ESP; FCP:Identifier;
      StartTos: integer;

procedure ExpSub <> 0 then
                    begin
                    EQuick(1);
                    GenLDC(LMin);
                    QG "  	
                              Chrs := CStack[CSPtr-1].ValP^.SVal
                                        end;
                 Error(399)
                      end { case };
                    LSP := BoolPtr
                    end
                e                    with S2 do
                                        begin
                                        SLen := Clse
                    Error(129)
            end
    end
end { CExpr };

begin { Constant }
LSP := nil; FValu.IVal := Stack[CSPtr].ValP^.SLgth;
                                        Chrs := CStack[CSPtr].ValP^.SVal
                           0;
if not(Sy in STypeBegSys) then
  begin Error(50); Skip(FSys+STypeBegSys) end;
if Sy in STypeBegSys then
    begin
    CS             end;
                                    case SaveOp of
                                        LtOp: CStack[CSPtPtr:=0;
    CExpr(FSys);
    if CSPtr <> 1 then
        Error(50)
    else
        FValu:=CStack[1];
    if not (Sy in FSyr-1].IVal :=
                                           ord(S1.Str < S2.Str);
                                        LeOp: CSs) then
      begin Error(6); Skip(FSys) end
    end;
FSP := LSP
end { Constant };

function CompProcs(var LCP1,LCP2: Idetack[CSPtr-1].IVal :=
                                           ord(S1.Str <= S2.Str);
                                      ntifier):boolean;
{-------------------------------------
{ Abstract:
{    Check an actual and formal procedure for compatibil  GtOp: CStack[CSPtr-1].IVal :=
                                           ord(S1.Str > S2.Str);
                             ity.
{
{ Parameters:
{    LCP1,LCP2 - The routines to be compared
{
{ Results:
{    True if the procedures are compatible,           GeOp: CStack[CSPtr-1].IVal :=
                                           ord(S1.Str >= S2.Str);
                    false otherwise
{
{ Calls:
{--------------------------------------}
  label 1;
  var List1,List2:integer; P1,P2:Identifier].IVal :=
                                     ord(CStack[CSPtr-1].IVal <>
                                         CStack[CSP                     EqOp: CStack[CSPtr-1].IVal :=
                                           ord(S1.Str = S2.Str);
          tr].IVal)
                                 end { case };
                               CSPtr := CSPtr - 1
                                                NeOp: CStack[CSPtr-1].IVal :=
                                           ord(S1.Str <> S2.Str)
              end;
                        Arrays:
                            if PAOfChar(LSP) then
                                                               end { case };
                                     CSPtr := CSPtr - 1
                         if LSP^.AIsStrng then
                                    begin
                                    with S1 do
                          end
                                 else
                                     Error(399)
                                                 begin
                                        SLen := CStack[CSPtr-1].ValP^.SLgth;
                       else
                                 Error(399);
                        Otherwise:
                            " 	
record offset computation
{
{ Calls:
{    LookupNum
{    Error
{    LoadAddress
{    StrgType
{    GenLDC
{    EPush
{ rSelect;
{---------------------------------------------
{ Abstract:
{    Generate Code to handle the pointer selection proces   MultiAccess
{----------------------------------------------}
      var FCP: Identifier;
    begin
    with GAttr do
    s
{
{ Calls:
{    LoadExpr
{    MultiAccess
{---------------------------------------------}
    begin
    if GAttr.TyPtr     if TyPtr <> nil then
            begin
            LookupNum(Node^.RLink^.IIdent,FCP);
            with FCP do
         <> nil then
        with GAttr,TyPtr^ do
            begin
            LoadExpr; Kind := Varbl;
            Access := Indrct       begin
                TyPtr := IdType;
                case Access of
                    Drct:   Dplmt := Dplmt + Fld; IDplmt := 0;
            TyPtr := ElType;
            if MultiAccess(TyPtr) then Access := Multi
            end
    end {Addr;
                    Indrct: IDplmt := IDplmt + FldAddr;
                    Multi,Bite,
                    Packd:  Err PtrSelect };

procedure FileSelect;
{----------------------------------
{ Abstract:
{    Generate Code to handle file elelmt := 0;
            with LAttr.TyPtr^ do
                if AIsPackd then
                    if ElWidth = 8 then
        or(400)
                end {case Access};
                if FIsPackd then
                    begin
                    Lo                if StrgType(LAttr.TyPtr) then
                            Access := Chracter
                        else
   adAddress;
                    if ((FldRBit = 0) or (FldRBit = 8))
                      and (FldWidth = 8) then
                                     Access := Bite
                    else
                        begin
                        Access            begin
                        if StrgType(TyPtr) then
                            Access:=Chracter
               := Packd;
                        QGen2(IXP,ElsPerWd-1,ElWidth-1)
                        end
                else
                  else
                            Access := Bite;
                        if FldRBit = 8 then GenLDC(1) else GenLDC(0            begin
                    if TyPtr <> nil then QGen1A(IXAB,TyPtr^.Size);
                    EPop(1);
           );
                        EPush(Data16);
                        end
                    else
                        begin         if MultiAccess(TyPtr) then Access := Multi
                    end
            end { with GAttr }
        end { if L
                        Access := Packd;
                        GenLDC(MakeByte(FldRBit,FldWidth-1));
                     Attr.TyPtr <> nil }
    end { ArraySelect };

procedure FieldSelect;
{------------------------------------------
{ Abstrac   EPush(Data16)
                        end
                    end;
                if MultiAccess(TyPtr) then
           t:
{    Generate Code to handle the record field selection process
{
{ Side Effects:
{    Generation of code to perform the          begin LoadAddress; Access := Multi end
                end
            end
    end { FieldSelect };

procedure Pt #  	
ions? }
    if LCP1.IdType <> LCP2.IdType then { YES }
        goto 1;           { Function result types not identical }
withil) then
    CompParms:=true
else
    if Class = ActualVars then
        CompParms := CompTypes(FSP1,FSP2)
    else { Forma LCP1 do              { get the first parameter list }
    if PFDecKind = Special then
        List1 := Next
    else if PFKilVars  }
        CompParms := StrgType(FSP1) and StrgType(FSP2)
end { CompParms };

function CompTypes(FSP1,FSP2: STP) : bond  = Actual then
        List1 := Next
    else
        List1 := PFParms;
with LCP2 do              { get the second parameolean;
{------------------------
{ Abstract:
{    Determine to two types are compatable
{
{ Parameters:
{    FSP1, FSP2 - ter list }
    if PFDecKind = Special then
        List2 := Next
    else if PFKind  = Actual then
        List2 := Next
  the two structures to be compared for compatability
{
{ Results:
{    True if the two types are compatable, false otherwise
  else
        List2 := PFParms;
while (List1 <> 0) and (List2 <> 0) do { compare the parameter lists }
    begin
    Lookup{
{ Calls:
{    CompTypes
{    PAOfChar
{    StrgType
{---------------------------}
  var NXT1,NXT2: Identifier; Comp: booNum(List1,P1);
    LookupNum(List2,P2);
    if (P1.IdType <> P2.IdType) or (P1.Klass <> P2.Klass) then
        goto 1;       lean;
      LTestP : TestP;
begin
if FSP1 <> nil then
    if FSP1^.Form = SubRange then
        FSP1 := FSP1^.RangeType;
i   { parameters are not an exact match }
    if P1.Klass in [Proc,Func] then
        if not CompProcs(P1,P2) then
           f FSP2 <> nil then
    if FSP2^.Form = SubRange then
        FSP2 := FSP2^.RangeType;
if FSP1 = FSP2 then
    CompTypes := t goto 1;
    List1 := P1.Next;
    List2 := P2.Next
    end;
if (List1 <> 0) or (List2 <> 0) then
    goto 1            { #rue
else
    if (FSP1 = nil) or (FSP2 = nil) then
        CompTypes := true
    else
        if FSP1^.Form = FSP2^.Form the parameters do not match }
else
    CompProcs := true   { All is OK }
end { CompProcs };

function CompParms(FSP1,FSP2: STn
            case FSP1^.Form of
                Pointr:
                    CompTypes := (FSP1 = NilPtr) or (FSP2 = NilPtr);P; Class: IdClass): boolean;
{-------------------------------------
{ Abstract:
{    Check procedure parameters for compatibi
                
                Power:
begin
if Debug^.Sw then write('Comparing Sets ');
                    CompTypes :=lity
{
{ Parameters:
{    FSP1,FSP2 - structure of the formal and actual parameters, respectively
{    Class - IdClass of th CompTypes(FSP1^.ElSet,FSP2^.ElSet);
if Debug^.Sw then writeln(CompTypes(FSP1^.ElSet,FSP2^.ElSet));
end;
            
      ;
begin
if ((LCP1.Klass <> LCP2.Klass) or not (LCP1.Klass in [Func,Proc])) and
  ((LCP1.Klass <> Except) or (LCP2.Klass <> Hae formal parameter (Actual,Formal)
{
{ Results:
{    True if the parameter is OK; false otherwise
{
{ Calls:
{    CompTypendle)) then
    begin
  1:CompProcs:=false;
    exit(CompProcs)
    end;
if LCP1.Klass = Func then { are we comparing Functs
{---------------------------------------}
begin
if FSP1 = FSP2 then
    CompParms:=true
else if (FSP1 = nil) or (FSP2 = n # 	
= FilType;
            if MultiAccess(TyPtr) then
                begin
                LoadAddress;
                Access                     if Occur = CRec then
                        begin
                        Access := Drct; VLevel := CLev;:= Multi
                end
            end
    end { FileSelect };

begin { ExpSubSelect }
  with Node^ do  
      beg
                        Dplmt := CDspl + FldAddr
                        end
                    else
                     in
      if LLink <> nil then ExpSubSelect(LLink);
      if Opp = ArrayAccessor then
          ArraySelect
      else if Opp   begin
                        if VTyp = Ptr32 then
                            begin
                            if Level  = FieldAccessor then
          FieldSelect
      else if Opp = PtrAccessor then
          PtrSelect
      else if Opp = Fil= MainLex then
                                QGen1A(LOAB,VDspl)
                            else
                          eAccessor then
          FileSelect
      { else ill-formed tree, do nothing }
      end
  end { ExpSubSelect };

begin {      QGen2(LIAB,0,VDspl);
                            EPush(Off20);
                            QGen0(LDDW);
                ExpSelector }
StartTos := ETos;
if Node^.EType = Opr then
    Node1:=Node^.LLink  { Opr must be SelectOp }
else
    Node1:             EPop(1);
                            EPush(Ptr32)
                            end
                        else
=Node;
with Node1^ do
    begin
    LookupNum(IIdent,FCP);
    GAttr:=EAttr;
    with FCP, GAttr do
        begin
                                   begin
                            if Level = MainLex then
                                QGen1A(L case Klass of
            ActualVars:
                begin
                VLevel := VLev;
                Dplmt := VAddr;DOB,VDspl)
                            else
                                QGen2(LDIB,0,VDspl);
                            ment selection
{
{ Calls:
{    CompTypes
{    LoadAddress
{    Guard
{    Error
{    MultiAccess
{----------------------
                Access := Drct
                end;
            FormalVars:
                begin
                if VLev -----------}
    begin
    if GAttr.TyPtr <> nil then
        with GAttr,TyPtr^ do
            begin
            if CompTyp= MainLex then
                    QGen1A(LOAB,VAddr)
                else if VLev < MainLex then
                    QGen2(Les(FilType,CharPtr) then
                begin
                LoadAddress;
                Guard(StartTos)
                GAB,-VLev,VAddr)
                else
                    QGen2(LIAB,Level-VLev,VAddr);
                EPush(Off20);
      end;
            case Access of
                Drct:   Dplmt := Dplmt + FDSize;
                Indrct: IDplmt := IDplmt + F          QGen0(LDDW);
                EPop(1);
                EPush(Ptr32);
                Access := Indrct;
            DSize;
                Multi,Bite,
                Packd:  Error(400)
                end {case Access};
            TyPtr :    IDplmt := 0
                end;
            Field:
                with Display[DispLev] do
                    begin
 $  	
Sw then writeln('GW ',FWord:6);
{$ENDC}
if odd(IC) then IC:=IC+1;
while IC+1 > MaxCode do
    begin
    MaxCode:=MaxCode + SysCall
{    HashIx
{-------------------------}
  var LCP: Identifier; InOut: integer; { 0 = Input, 1 = Output }
begin
for           Arrays:
                    CompTypes:=StrgType(FSP1) and StrgType(FSP2);
                
                Otherwis512;
    CodeSize:=CodeSize+1;
    ChangeSize(CodeSeg,CodeSize);
    end;
with Trik do
    begin
    Int:=FWord;
    {$R-e:
                    CompTypes := false
            end { case }
        else
            CompTypes := false
end { CompTy}
    CodeP^[IC]:=lobyte;
    CodeP^[IC+1]:=hibyte;
    {$R=}
    end;
IC := IC + 2
end { GenWord };

procedure GenNAWopes };

procedure GenByte(FByte: AByte);
{---------------------
{ Abstract:
{    Put a byte in the output code stream
{
rd(FWord: integer);
{---------------------
{ Abstract:
{    Put a word in the output code stream, no special alignment is req{ Parameters:
{    FByte - the byte to be generated
{
{ Side Effects:
{    The Code buffer is modified, and its size may be uired
{
{ Parameters:
{    FWord - the word to be generated
{
{ Side Effects:
{    The Code buffer is modified, and its siincreased
{
{ Calls:
{    ChangeSize
{    PrintStats
{----------------------}
begin
{$IFC DebGen THEN}
  if Debug^.Sw thze may be increased.
{
{ Calls:
{    ChangeSize
{    PrintStats
{----------------------}
  var Trik: packed record case boen writeln('GB ',FByte:3);
{$ENDC}
while IC > MaxCode do
    begin
    MaxCode:=MaxCode + 512;
    CodeSize:=CodeSize+1;
 olean of
        true: (Int: integer);
        false:(lobyte: AByte;
               hibyte: AByte)
       end;
begin
{$IFC   ChangeSize(CodeSeg,CodeSize);
    end;
{$R-}
CodeP^[IC] := FByte; IC := IC+1;
{$R=}
end { GenByte };

procedure GenWo DebGen THEN}
if Debug^.Sw then writeln('GNAW ',FWord:6);
{$ENDC}
while IC+1 > MaxCode do
    begin
    MaxCode:=MaxCode + rd(FWord: integer);
{---------------------
{ Abstract:
{    Put a word in the output code stream, aligned to a word boundary512;
    CodeSize:=CodeSize+1;
    ChangeSize(CodeSeg,CodeSize);
    end;
with Trik do
    begin
    Int:=FWord;
    {$R-
{
{ Parameters:
{    FWord - the word to be generated
{
{ Side Effects:
{    The Code buffer is modified, and its size may}
    CodeP^[IC]:=lobyte;
    CodeP^[IC+1]:=hibyte;
    {$R=}
    end;
IC := IC + 2
end { GenNAWord };

procedure InitI be increased.
{    If a filler byte is needed for word alignment, the contents of
{    the filler byte will be arbitrary
{
nputOutput;
{--------------------
{ Abstract:
{    Generate Code to initialize INPUT and OUTPUT (i.e., hide REWRITE(OUTPUT)
{ Calls:
{    ChangeSize
{    PrintStats
{----------------------}
  var Trik: packed record case boolean of
        true: ({    and RESET(INPUT) from the client
{
{ Environment:
{    INPUT and OUTPUT must be defined at display level 0
{
{ Side EfInt: integer);
        false:(lobyte: AByte;
               hibyte: AByte)
       end;
begin
{$IFC DebGen THEN}
if Debug^.fects:
{    Generates code in the output stream
{
{ Calls:
{    GenByte
{    TreeSearch
{    QGen1A
{    GenLDC
{    Gen $ 	
              if ((FldRBit = 0) or (FldRBit = 8)) 
                          and (FldWidth = 8) then
                             begin
                            if StrgType(TyPtr) then
                                Access:=Chracter
               {--------------------------------------------
{
{ Expression Expansion  Part B
{ Copyright (C) 1981  Three Rivers Computer Co             else
                                Access := Bite;
                            if FldRBit = 8 then GenLDC(1) elrporation
{
{ Abstract:
{    The second part of expression expansion - one of two files dealing
{    with procedure/functionse GenLDC(0);
                            EPush(Data16)
                            end
                        else
        calls
{
{ File: Expr1.Pas
{
{---------------------------------------------}

{ }
{ 04-Feb-81  2.0  Miles A. Barel
{ Im                     begin
                            Access := Packd;
                            GenLDC(MakeByte(FldRBit,Flplementation of Long Integers
{ }
{ 8-Jan-81  1.7  Miles A. Barel
{ Bug Fix - previously Write(File,Char) where File was a vadWidth-1));
                            EPush(Data16)
                            end;
                        end
         r parameter would
{           not work. Now Fixed!!
{ }
{ 7-Jan-81  1.6  Miles A. Barel
{ General cleanup and institution of           end;
            Func:
                if PFDecKind <> Declared then
                    Error(150)
              standard 3RCC file formats
{ }

procedure ExpCall(Node: ESP);
{--------------------------------
{ Abstract:
{    The mai   else
                    if not InScope then
                        Error(103)
                    else
                n body of all procedure/function call expansions.  Handles
{    several of the intrinsics itself, passes the others off to ExpR        begin
                        Access := Drct; VLevel := PFLev + 1;
                        Dplmt := 0
               outine
{    and passes user procedure/function calls off to ExpCallNonSpecial.
{    (Main body of this procedure is in Expr2.P         end
        end {case};
        if MultiAccess(TyPtr) then
            begin LoadAddress; Access := Multi end
     as)
{
{ Parameters:
{    The root node of the procedure/function call
{
{ Side Effects:
{    Code will be generated
{
{    end {with FCP,GAttr};
    end {with Node1};
if Node^.EType = Opr then { must be SelectOp }
    ExpSubSelect(Node^.RLink)
Calls:
{    LookupNum
{    ExpCallNonSpecial
{    Error
{    NextExp
{    LoadExpr
{    ExpRoutine
{    GenLDC
{    EQuiEPush(Off20)
                            end;
                        Access := Indrct; IDplmt := FldAddr
                   end { ExpSelector };
                                                                                                               end;
                    if FIsPackd then
                        begin
                        LoadAddress;
            %  	
var CodeInx,LIC,I,J: integer;
begin
CodeInx := 0;
LIC := IC;
repeat
    I := 512-CurByte;
    if I > LIC then I := LIC;
 
if (CurByte Mod 8) <> 0 then
    for i:=1 to 8-(CurByte mod 8) do GenByte(0);
if IC <> 0 then WriteCode(false);
J:=(CurBlk-1   {$R-}
    for j:=0 to (i-1) do DiskBuf^[CurByte+j]:=CodeP^[CodeInx+j];
    {$R=}
    CodeInx := CodeInx+I;
    CurByte :=)*512 + CurByte;
IC:=0;
Close(PDFile);           { This shouldn't be needed!! }
Reset(PDFile,PDFileName);{ reset the dictiona CurByte+I;
    if (CurByte = 512) or ForceBuf then
        begin
        FSBlkWrite(OutFile,CurBlk,recast(DiskBuf,pDirBlk));ry file so we can read it in now }
FirstPD:=nil;
while not EOF(PDFile) do
    begin
    New(CurHeap,1,PDE);
    with PDE^ d
        CurBlk := CurBlk+1; CurByte := 0
        end;
    LIC := LIC-I
until LIC = 0;
end { WriteCode };

procedure Fino
        begin
        New(CurHeap,1,PR);
        PR^:=PDFile^;
        if FirstPD = nil then
            begin
         InOut:=0 to 1 do
    begin
    GenByte(LSSN);
    if InOut = 0 then
        if TreeSearch(HashTable[0,HashIx('INPUT   ')],LCishSeg;
{-----------------------------
{ Abstract:
{    Finish off book keeping at the completion of compiling a segment
{  P,'INPUT   ') <> 0 then
            Error(413)
        else
    else
        if TreeSearch(HashTable[0,HashIx('OUTPUT  ')],L      1) Write out the procedure dictionary
{        2) Write out the Linker information
{        3) Write out the header blocCP,'OUTPUT  ') <> 0 then
            Error(413);
    QGen1A(LOAB,LCP.VAddr);
    GenByte(MMS2);
    GenByte(LSA);
    if Odk
{
{ Environment:
{    A temporary procedure dictionary file must have been written
{    This file should still be open ford(IC) then IC:=IC+1;
    GenByte(0);
    GenByte(MMS2);
    GenLDC(0);
    GenByte(MMS);
    GenLDC(8);
    GenByte(MMS); writing
{
{ Side Effects:
{    The output file is written
{
{ Calls:
{    GenByte
{    GenWord
{    Close
{    Reset

    GenLDC(1);
    GenByte(MMS);
    GenLDC(InOut);
    GenByte(MMS);
    GenSysCall(PStreamOpen)
    end
end { InitInput{    EOF
{    Get
{    New
{    WriteCode
{    FSBlkRead
{    FSBlkWrite
{
{ Design:
{    The Linker and Loader require Output };

procedure WriteCode(ForceBuf: boolean);
{--------------------------
{ Abstract:
{    Flush the code buffer out that the Filenames given in the SEG file be
{    word aligned (the compiler really couldn't care)
{---------------------------to the output file
{
{ Parameters:
{    ForceBuf - True indicates to force writing a partially filled last
{               b-----}
  var I,J: integer;
      FirstPD,CurPD,PDE:DEP;
      NotFound:boolean;
      LinkBlock:integer;
      Trik: packedlock; otherwise it remains buffered until it is filled
{
{ Side Effects:
{    The output file is written
{    DiskBuf buffer record case boolean of
                true: (lobyte:AByte;
                       hibyte:AByte);
                false:(Int contents are modified.
{    CurBlk and CurByte may be modified
{
{ Calls:
{    FSBlkWrite
{--------------------------}
  :integer)
              end;
begin
{ time to write out procedure dictionary }
{ first must quad align output file }
IC:=0; % 	
xpVariable };

procedure ExpStrgVar(Node: ESP; MustBeVar: boolean);
{---------------------------------
{ Abstract:
{    Ex                end
            else
                begin
                if GAttr.TyPtr <> nil then Error(125);
          ck
{    QGen0
{    CompTypes
{    EPush
{    NextStrgVar
{    EPop
{    QGenCmp
{    GenByte
{    GenNAWord
{    GenWorpand a 'string variable' parameter
{
{ Parameters:
{    Node - the root node of the string variable
{    MustBeVar - TRUE ifd
{    LoadAddress
{    Store
{
{ Design:
{    The intrinsics handled directly by ExpCall include:
{        PRED
{        the parameter must be a variable, FALSE if string
{                constants are acceptable
{
{ Environment
{    The caller SUCC
{        ORD
{        SQR
{        ABS
{        LENGTH
{        RECAST
{        TRUNC
{        ROUND
{        ODD of this routine must set the original pointer to the
{    root of the string variable (passed into this procedure) to nil
{  
{        CHR
{        LXOR
{        STARTIO
{        RASTEROP
{        INLINEBYTE
{        INLINEWORD
{        INLINEAWOR  after the call is made (since ExpExpression is called - which will
{    dispose of the expression tree).  If not, two attemptD
{        LOADEXPRESSION
{        LOADADR
{        STOREXPRESSION
{        MAKEPTR
{----------------------------------}
 s will be made
{    to dispose of the tree!
{
{ Calls:
{    ExpExpression
{    StrgType
{    CompTypes
{    LoadAddress
   var LKey: 1..24; FCP,LCP: Identifier;
        LAttr: Attr; StartTos,i: integer;

procedure ExpVariable(Node :ESP);
{----{    Error
{---------------------------------}
    begin
    ExpExpression(Node);
    with GAttr do
        if ((Kind = Cst--------------------------
{ Abstract:
{    Expand a 'variable' parameter (constants or expressions won't do)
{
{ Parameters) and (CompTypes(TyPtr,CharPtr)))
          or StrgType(TyPtr) then
            if Kind = Varbl then
                LoadAddr:
{    Node - the root node of the selector expression tree
{
{ Calls:
{    LookupNum
{    ExpSelector
{    Error
{------ess
            else
                begin
                if MustBeVar then Error(154);
                if Kind = Cst then-------------------------}
      var LCP: Identifier; Node1: ESP;
    begin
    if(Node^.EType = Opr) and (Node^.Opp = Select
                    begin
                    if CompTypes(TyPtr,CharPtr) then
                        begin
               Op) then
        Node1:=Node^.LLink
    else
        Node1:=Node;
    with Node1^ do
        if EType = Opnd then
                 with SConst^ do
                            begin
                            CClass := Strg; SLgth := 1;
              begin
            LookupNum(IIdent,LCP);
            if LCP.Klass in [ActualVars, FormalVars, Field] then
                                 SVal[1] := chr(CVal.IVal)
                            end;
                        CVal.ValP := SConst;
    ExpSelector(Node)
            else
                Error(2)
            end
        else
            Error(2)
    end { E                     TyPtr := StrgPtr;
                        end;
                    LoadAddress
                    end
 &  	
cNum > CurPD^.PR^.ProcNum then
                            NotFound:=false
                        end;
            if CurPD  write out Leader Block of File (block 0) }
CurBlk:=0;
CurByte:=0;
IC:=0;
GenByte(ord(IsProgram));               { First byt= nil then {insert at head of list}
                begin
                Next:=FirstPD;
                Prev:=nil;
        e, type of segment }
GenByte(QCodeVersion);                 { Second byte is the QCode version
                                       FirstPD:=PDE
                end
            else
                begin
                Next:=CurPD^.Next;
                  that we're compiling for }
with LinkList[0] do
    begin
    for i:=1 to UniqLength do
        GenByte(ord(ModName        Prev:=CurPD;
                CurPD^.Next:=PDE
                end;
            if Next <> nil then Next^.Prev:=PDE;
[i]));       { Then, the Name of the segment }
    for i:=0 to MaxFNLength do
        {$R-}
        GenByte(ord(FilName[i]));            CurPD:=PDE
            end
        end;
    Get(PDFile);
    end;
Close(PDFile);
FSDelete(PDFileName);
CurPD:      { followed by the name of the file }
        {$R=}
    end;
GenWord(NextSeg-1);                    { and the number of =FirstPD;
while CurPD <> nil do
    with CurPD^,PR^ do
        begin
        GenWord(PS);
        GenWord(RPS);
        ifimported segments }
GenWord(LinkBlock);                    { and the block containing the imports }
GenWord(LCMax);            (ProcNum = 0) and IsProgram then GenWord(0) else GenWord(ACS);
        GenWord(EntA);
        GenWord(ExtA);
        GenWord             { And the Size of the GDB }
for i:=0 to SwStrLen do                { Write out the version string }
    if i > le   FirstPD:=PDE;
            CurPD:=PDE;
            Next:=nil;
            Prev:=nil
            end
        else
       (LL);
        GenWord(0);
        GenWord(0);
        CurPD:=Next
        end;
CurPD:=FirstPD;
if Names^.Sw then
    whil     begin
            NotFound:=true;
            while NotFound do
                if PDFile^.ProcNum > CurPD^.PR^.ProcNum e CurPD <> nil do
        with CurPD^,PR^ do
            begin
            for i:=1 to UniqLength do
                GenBytethen
                    if CurPD^.Next <> nil then
                        CurPD:=CurPD^.Next
                    else
    (ord(ProcName[i]));
            CurPD:=Next
            end;
WriteCode(true);
LinkBlock:=CurBlk;
{ put Header Info at begin                    NotFound:=false
                else
                    if CurPD^.Prev = nil then
                      ning of segment }
FSBlkRead(OutFile,1,recast(DiskBuf,pDirBlk));
with Trik do
    begin
    Int:=J div 2;             { Offse  begin
                        CurPD:=nil;
                        NotFound:=false
                        end
            t to Procedure dictionary }
    DiskBuf^[0]:=lobyte;
    DiskBuf^[1]:=hibyte;
    Int:=NextProc;      { Number of Procedures         else
                        begin
                        CurPD:=CurPD^.Prev;
                        if PDFile^.Proin Segment }
    DiskBuf^[2]:=lobyte;
    DiskBuf^[3]:=hibyte
    end;
FSBlkWrite(OutFile,1,recast(DiskBuf,pDirBlk));
{ now & 	
r
{--------------------------------------}
    { get the next parameter ( of type string variable ) }
    begin
    StartTossable
{
{ Side Effects:
{    Code will be generated
{
{ Calls:
{    Error
{    LoadAddress
{    QGen0
{    EPush
{     := ETos;
    if NextParm <> nil then     { make sure we've got one }
        with NextParm^ do
            begin
          EPop
{
{ Design:
{    Note that only standard procedures may receive a string constant as
{    a reference parameter, thus o  ExpStrgVar(LLink,MustBeVar);{ evaluate it }
            LLink:=nil;
            NextParm:=RLink             { set up for nexnly expansion of calls to standard
{    procedures may set MustBeVar to false; expansion of all user calls
{    will always hat parameter }
            end
    else
        Error(126)              { incorrect number of paramters }
    end { NextStrgVve MustBeVar set to true.
{---------------------------------------}
    begin
    if GAttr.Kind <> Varbl then
        if Mus      GAttr.TyPtr := StrgPtr
                end
    end { StrgVar };

procedure NextVar;
{-------------------------------ar };

procedure NextExp;
{----------------------------------
{ Abstract:
{    Get the next parameter (any expression will---
{ Abstract:
{    Get the next parameter (only variables are permissable) and advance so
{    that the next time we want a do here) and advance
{    so that the next time we want a parameter we'll get the next one
{
{ Side Effects:
{    NextParm  parameter we'll get the next one
{
{ Side Effects:
{    NextParm will be advanced
{
{ Calls:
{    ExpVariable
{    Errorwill be advanced
{
{ Calls:
{    ExpExpression
{    Error
{--------------------------------------}
    { get the next para
{--------------------------------------}
    begin
    StartTos := ETos;
    if NextParm <> nil then     { make sure we've meter ( of type expression ) }
    begin
    StartTos := ETos;
    if NextParm <> nil then     { make sure we've got one }
 got one }
        with NextParm^ do
            begin
            ExpVariable(LLink);         { evaluate it }
            Ne       with NextParm^ do
            begin
            ExpExpression(LLink);       { evaluate it }
            LLink:=nil;
 xtParm:=RLink             { set up for next parameter }
            end
    else
        Error(126)              { incorrect            NextParm:=RLink             { set up for next parameter }
            end
    else
        Error(126)             number of paramters }
    end { NextVar };

procedure NextStrgVar(MustBeVar:boolean);
{----------------------------------
 { incorrect number of paramters }
    end { NextExp };

procedure ParamAddr( MustBeVar: boolean);
{-----------------------{ Abstract:
{    Get the next parameter (only string variables are permissable) and advance
{    so that the next time we want------------
{ Abstract:
{    Get the virtual address of the current parameter (for passing parameters
{    by reference
{
 a parameter we'll get the next one
{
{ Side Effects:
{    NextParm will be advanced
{
{ Calls:
{    ExpStrgVar
{    Erro{ Parameters:
{    MustBeVar - TRUE if the parameter must be a variable, FALSE if string
{                constants are permis '  	
o out the rest }
WriteCode(true);
CurBlk:=LinkBlock;
if NextSeg <> 1 then
    begin
    { write out the remainder of the li----------------------
{ Abstract:
{    Process the block level construct of a program
{
{ Parameters:
{    FSys - The possnker info }
    CurByte:=0;
    IC:=0;
    for j:=1 to NextSeg-1 do
        with LinkList[j] do
            begin
        ible terminal symbols for the block
{
{ Side Effects:
{    The state of CurIFile will be modified
{    The output file may b    for i:=1 to UniqLength do GenByte(ord(ModName[i]));
            {$R-}
            for i:=0 to MaxFNLength do GenByte(ord(Fe written onto
{
{ Errors:
{    Semicolon Expected
{    Period Expected
{    Begin Expected
{
{ Calls:
{    FindForw
{ ilName[i]));
            {$R=}
            {$IFC ((MaxFNLength div 2) * 2) = MaxFNLength THEN }
                GenByte(0);     LookupNum
{    InSymbol
{    Error
{    InitInputOutput
{    BodyPart
{    Skip
{    DeclarationPart
{    WriteNum
{          { If the filename length is even, put }
            {$ENDC}                   { out an extra byte to word align the }   DecRefCount
{    FinishSeg
{-------------------------------------}
 label 1,2;
 var BFSyFound: boolean;
     FCP,TLCP: I
                                      { names.  This is required for the    }
                                      { linker adentifier;
     ThisHandler,TmpHandler: pHandList;
     OldTOS: pLexStkRec;
     OldHeap,i: integer;

procedure FindForw(Lnd loader }
            end;
    WriteCode(true)
    end;
end { FinishSeg };
                                              CP: integer);
{--------------------------------
{ Abstract:
{    Check for unresolved forward referenced procedures and funct ions
{
{ Parameters:
{    LCP - The top node of the symbol table subtree to be searched
{
{ Errors:
{    Undefined procedu re/function
{
{ Calls:
{    LookupNum
{    FindForw
{    Writeln
{---------------------------------}
  var FCP: Identifie{-----------------------------------
{
{ General Compiler Routines (Part C)
{ Copyright (C) 1981  Three Rivers Computer Corpor;
    begin
    LookupNum(LCP,FCP);
    with FCP do
        begin
        if Klass in [Proc,Func] then
            if PFDngth(VerStr) then
        GenByte(ord(' '))
    else
        {$R-}
        GenByte(ord(VerStr[i]));
        {$R=}
for i:=0ration
{
{ Abstract:
{    General Compiler Routines (and main body)
{
{ File:
{    Pas2.Pas
{
{------------------------- to SwStrLen do                 { Write out the copyright string }
    if i > length(CopyStr) then
        GenByte(ord(' '))
-----------}

{ }
{ 15-Jan-81  1.12  Miles A. Barel
{ Hashing of compiler names and user globals
{ }
{ 2-Jan-81  1.6  Mil    else
        {$R-}
        GenByte(ord(CopyStr[i]));
        {$R=}
while IC < 512 do GenWord(0);          { finally, zeres A. Barel
{ General cleanup and first use of standard 3RCC file formats
{ }

procedure Block(FSys: SetOfSys);
{--------- ' 	
xpRoutine(LKey: integer);
{-----------------------------------------
{ Abstract:
{    Handles the expansion of about half of pose;
{---------------------------------
{ Abstract:
{    Generate Code for calls to the NEW and DISPOSE intrinsics
{
{ Sidthe system intrinsics - mostly the
{    hairier ones (the rest are done in ExpExpression).
{
{ Parameters:
{    The ID of the Effects:
{    Code will be generated
{    Automatic importation of memory manager segments may be invoked
{    NextParm maye intrinsic to be called (they are assigned in EntStdProcs
{    in CompInit.Pas).
{
{ Calls:
{    NewDispose
{    Exxit
{  be altered
{
{ Calls:
{    NextExp
{    CompTypes
{    LoadExpr
{    QGen0
{    EPop
{    EQuick
{    GenLDC
{    Par   WordSiz
{    ShiftRotate
{    LogAnd
{    LogOr
{    LogNot
{    VRD
{    ReSetWrite
{    EofEoln
{    Get
{    PutamAddr
{    Error
{    StrgType
{    LookupNum
{    GenSysCall
{-----------------------------------}
      label 1;
     
{    ReadWrite
{    Close
{---------------------------------------}
    var FileAttr: Attr;
        Reading: boolean;

p var LSP,LSP1: STP;
          LSize: AddrRange; LVal: Valu; LCP: Identifier;
          Defaults: boolean;
      begin
      rocedure DefaultFile;
{--------------------------------
{ Abstract:
{    Get the variables for the default files for Write anNextExp;
      if LKey = 6 { New } then
          begin
          Defaults := true;
          if GAttr.TyPtr <> nil then
  d Read (INPUT and
{    OUTPUT).
{
{ Side Effects:
{    Changes the contents of FileAttr (defined by ROUTINE) to reflect the            if CompTypes(GAttr.TyPtr,IntPtr) then
                  begin { segment number and alignment }
                  LtBeVar then
            Error(154)
        else
            if GAttr.Kind = Cst then { must be a string constant }
         
{    desired file variable
{
{ Calls:
{    SegNumber
{---------------------------------}
      begin
      with FileAttr        LoadAddress
            else
                Error(116);
    if GAttr.TyPtr <> nil then
        if GAttr.Access in [Bdo { default file variables }
          begin
          TyPtr := TextPtr;
          Kind := Varbl;
          Access := Drct;ite,Chracter,Packd] then
            Error(195);
    case ETos - StartTos of
        0:  begin
            QGen0(LSSN);
   
          if IsProgram then
              VLevel := MainLex
          else
              VLevel := -SegNumber('        ',''         EPush(Data16)
            end;
        
        1:  begin
            QGen0(LSSN);
            QGen0(EXCH);
     );  { main program segment }
          if Reading then           { 'Input' is always allocated at  }
              Dplmt := 0        EPop(1);
            EPush(Ptr32)    { keep EStack up to date }
            end;
        
        2:  { Already have            { LC=0 in the main program        }
          else                      { 'Output' is always allocated at }
       virtual address }
      end { case };
    LoadAddress;
    EPop(2);
    EPush(Ptr32)
    end { ParamAddr };

procedure E       Dplmt := TextSize     { LC=TextSize in the main program }
          end
      end { DefaultFile };

procedure NewDis (  	
ecKind = Declared then
                if PFKind = Actual then
                    if (ForwDecl) and (not ImpDecl) then
     FSys + [CaseSy] - [EndSy],FCP);
              BFSyFound := (Sy = TOS^.BFSy);
              if not BFSyFound then
                               begin
                        Writeln(Output,chr(13),Name,' undefined');
                        Error(117)      begin 
                  if TOS^.BFSy = SemiColon then
                    if Sy = Period then
                      go
                        end;
        if RLink <> 0 then FindForw(RLink);
        if LLink <> 0 then FindForw(LLink)
       to 1
                    else
                      Error(14)  { semicolon expected }
                  else
                end
    end { FindForw };

  begin { Block }
  NewBlock:=true;
  repeat
      if not NewBlock then
          begin
        Error(20);  { period expected }
                  Skip(FSys + [TOS^.BFSy]);
                  BFSyFound := (Sy = TOS^.BFS       DP := false; StmtLev := 0; IC := 0; LineInfo := 0;
          with Display[Top] do
              if ForwCount <> 0 theny)
                  end
          until (BFSyFound) or (Sy in BlockBegSys);
          if not BFSyFound then
              b
                  begin
                  if Top <= HashLevels then
                      for i:=0 to HashMax do
           egin
              if TOS^.BFSy = SemiColon then
                  Error(14)
              else
                  Error(20);               if HashTable[Top,i] <> 0 then
                              FindForw(HashTable[Top,i])
                         { period expected }
              DeclarationPart(FSys);
              end
          else
              begin
              else
                  else
                      with Display[Top] do
                          if FName <> 0 then FindFor  if Sy = SemiColon then InSymbol;
              if (not(Sy in BlockBegSys)) and (TOS^.BFSy = SemiColon) then
                w(FName)
                  end;
          if Sy = Period then
              begin
              LookupNum(TOS^.DFProcP,FCP);  begin
                  Error(6); Skip(FSys);
                  DeclarationPart(FSys);
                  end
             
              if FCP.Klass = Modul then
                  begin
                  LCMax:=LC;     { get size of globals back  else
  1:              begin
                  with TOS^ do
                      begin
                      LookupNum(DFP}
                  goto 2
                  end
              end;
          if Sy = BeginSy then InSymbol else Error(17);rocP,FCP);
                      if FCP.IdNum <> 0 then
                          begin
                          FCP.InScope
          repeat 
              LookupNum(TOS^.DFProcP,FCP);
              if FCP.Klass = Modul then Error(412);
           :=false;
                          WriteNum(FCP)
                          end;
                      Level:=DOldLev;
         if IsProgram and (Seg=MainSeg) and (CurProc=0) and AutoInit then
                  InitInputOutput;
              BodyPart(                Top:=DOldTop;
                      LC:=DLLC;
                      CurProc:=POldProc;
                       ( 	
     QGen0(MMS);
              GenLDC(1);
              QGen0(MMS)
              end
          end;
      ParamAddr(true);en
                                  begin
                                  LSP1 := LSP^.FstVar;
                           
      QGen0(MMS2);
      EPop(2);
      LSP := nil; LSize := 0;
      if GAttr.TyPtr <> nil then
          with GAttr.TyPtr       while LSP1 <> nil do
                                      with LSP1^ do
                                          if V^ do
              if Form = Pointr then
                  begin
                  if ElType <> nil then
                   arVal.IVal = LVal.IVal then
                                              begin
                                                 with ElType^ do
                          begin
                          LSize := Size;
                          if FormLSize := Size;
                                              LSP := SubVar;
                                              goto = Records then LSP := RecVar
                          end
                  end
              else
                  Error 1
                                              end
                                          else
                         (196);
      while NextParm <> nil do
          with NextParm^ do
              begin
              LSP1:=nil;
                                 LSP1 := NxtVar;
                                  LSize := LSP^.Size;
                                  L  LVal.IVal:=0;
              if LLink <> nil then
                  with LLink^ do
                      if OpClass = Kst thSP := nil
                                  end
                              else
                                  Error(11en
                          begin
                          LSP1:=EAttr.TyPtr;
                          LVal:=EAttr.CVal
 6)
                              end;
  1:          NextParm:=RLink
              end { with };
      if LSize = 0 then LSiz                         end
                      else
                          Error(50);
              if LSP = nil thene := 1;
      GenLDC(LSize);
      QGen0(MMS);
      if LKey = 6 { New } then
          GenSysCall(PNew)
      else
      
                  Error(158)
              else
                  if LSP^.Form <> TagFld then
                      Error(16    GenSysCall(PDispose)
      end { NewDispose };

procedure Exxit;
{---------------------------------
{ Abstract:
{    oadExpr;
                  QGen0(MMS);
                  EPop(1);
                  NextExp;
                  LoadExpr;
  2)
                  else
                      if LSP^.TagFieldP <> 0 then
                          if StrgType(LSP1) or (L                QGen0(MMS);
                  EPop(1);
                  NextExp;
                  Defaults := false
      SP1 = RealPtr) then
                              Error(159)
                          else
                              beg            end;
          if Defaults then
              begin
              EQuick(2);
              GenLDC(0);
         in
                              LookupNum(LSP^.TagFieldP,LCP);
                              if CompTypes(LCP.IdType,LSP1) th )  	
  }
if WordSize(IdBlock) <> 256 then
    begin
    writeln('?Warning: WordSize(IdBlock) = ',WordSize(IdBlock):1);
    Error(nment of all EQU,NEQ,LEQ,LES }
     NEQBool   = 34;             {    GEQ and GTR qcodes are important      }
     LEQBool   = 413)
    end;
LoadCurs;
CompInit;
DumpCompInit;


Block(BlockBegSys+StatBegSys-[CaseSy]);

if Sy <> Period then Error(235;
     LESBool   = 36;
     GEQBool   = 37;
     GTRBool   = 38;
     EQUI      = 39;
     NEQI      = 40;
     LEQI    0);
if List then
    begin
    PrintLine;
    Close(LP)
    end;
QuitProgress;
if TotalErrors = 0 then
    WriteLn(OutFi  = 41;
     LESI      = 42;
     GEQI      = 43;
     GTRI      = 44;
     EQUReal   = 45;
     NEQReal   = 46;
     LEQROldHeap:=DMarkP;
                      OldTOS:=PrevLexStackP
                      end;
                  DecRefCount(CurHeapleName,' Written')
else
    Writeln(Output,TotalErrors:1,' Errors Detected');
FSClose(OutFile,CurBlk,4096);
FSClose(SymFile,);
                  CurHeap:=OldHeap;
                  Dispose(TOS);
                  TOS:=OldTOS;
                  NewB0,0);
FSDelete(STFileName)
end {  PascalCompiler  }.
                                                                        lock:=(Sy in (BlockBegSys-[BeginSy]))
                  end
              end
          end
      else   
          if Expo rting then
              DeclarationPart(FSys+[PrivateSy])
          else
              DeclarationPart(FSys)
  until TOS = module QCodes;

Exports

Const

{ QCode OpCode Definitions }
     
     LDC0      = 0;         { Assignment of Byte/Wordnil;
  2:FinishSeg
  end { Block };

Procedure DumpCompInit;
{-----------------------------
{ Abstract:
{    Destroy the opcodes are important }
     LDC1      = 1;
     LDC2      = 2;
     LDC3      = 3;
     LDC4      = 4;
     LDC5      = 5 code segment containing CompInit
{
{ Side Effects:
{    The CompInit segment is no longer valid.  Any calls could be fatal,;
     LDC6      = 6;
     LDC7      = 7;
     LDC8      = 8;
     LDC9      = 9;
     LDC10     = 10;
     LDC11     = 11
{    but we'll never all it again.
{
{ Calls:
{    DecRefCount
{
{ Design:
{    We'd better never attempt to call any pro;
     LDC12     = 12;
     LDC13     = 13;
     LDC14     = 14;
     LDC15     = 15;
     LDCMO     = 16;
     LDCB      cedures in the CompInit
{    Segment after we do this!! (but it'll give us lots of memory back!)
{----------------------------= 17;
     LDCW      = 18;
     LSA       = 19;
     ROTSHI    = 20;
     STIND     = 21;
     LDCN      = 22;
     LDB   --}
  var i:array[0..3] of integer;
begin
LoadAdr(i);
MakeVRD(CompInit);
InLineByte(MMS);
InLineByte(MMS);
InLineByte(MMS    = 23;
     STB       = 24;
     LDCH      = 25;
     LDP       = 26;
     STPF      = 27;
     STCH      = 28;
     EX);
InLineByte(MMS);
InLineByte(LDC4);
InLineByte(STMW);
DecRefCount(i[3])
end { DumpCompInit };

begin {  PascalCompilerGO      = 29;
     QAND      = 30;
     QOR       = 31;
     QNOT      = 32;
     EQUBool   = 33;             { Opcode assig ) 	
Generate code for the EXIT intrinsic
{
{ Side Effects:
{    Code will be generated
{    NextParm will be altered
{
{ Calls       begin Error(125); LCP.IdNum:=0 end
              else
                  if NextParm^.LLink^.SSy = Ident then
         :
{    Error
{    QGen2
{    LookupNum
{------------------------------------}
        var LCP: Identifier;
      begin
               LookupNum(NextParm^.LLink^.IIdent,LCP)
                  else
                      begin Error(125); LCP.IdNum:=    if NextParm <> nil then
          begin
          if NextParm^.LLink^.EType <> Opnd then
              begin Error(125); 0 end;
           NextParm:=NextParm^.RLink
           end
       else
           Error(126);
      with LCP do
          LCP.IdNum:=0 end
          else
              if NextParm^.LLink^.OpClass <> Idd then
                  begin Error(125); LCPif IdNum <> 0 then
              if PFDecKind = Declared then
                  QGen3(LVRD,PFSeg,PFName,PFLev+1)    { Lex of b.IdNum:=0 end
              else
                  if NextParm^.LLink^.SSy = Ident then
                      LookupNum(NextPody, not decl }
              else
                  Error(125);
      ETos := 0
      end { VRD };

procedure WordSiz;
arm^.LLink^.IIdent,LCP)
                  else
                      begin Error(125); LCP.IdNum:=0 end;
           NextParm:{---------------------------------
{ Abstract:
{    Generate code for the WORDSIZE intrinsic
{
{ Side Effects:
{    Code wi=NextParm^.RLink
           end
       else
           Error(126);
      with LCP do
          if IdNum <> 0 then
        ll be generated
{    NextParm will be altered
{
{ Calls:
{    Error
{    GenLDC
{    EPush
{-----------------------------      if PFDecKind = Declared then
                  QGen2(EXITT,PFSeg,PFName)
              else
                  Error(125-------}
        var LCP: Identifier;
      begin
      if NextParm = nil then
          Error(126)
      else
          b)
      end { Exxit };

procedure VRD;            { Gen LVRD }
{---------------------------------
{ Abstract:
{    Generaegin
          with NextParm^ do
              if EAttr.TyPtr <> nil then
                  begin
                  GenLDC(Ete code for MAKEVRD (Make Variable Routine Descriptor) intrinsic
{
{ Side Effects:
{    Code will be generated
{    NextParmAttr.TyPtr^.Size);
                  EPush(Data16)
                  end;
          NextParm:=NextParm^.RLink
          end; will be altered
{
{ Calls:
{    Error
{    QGen3
{    LookupNum
{------------------------------------}
        var LCP: 
      GAttr.TyPtr := IntPtr
      end { WordSiz };

procedure ReSetWrite;
{------------------------------------
{ AbstraIdentifier;
      begin
      if NextParm <> nil then
          begin
          if NextParm^.LLink^.EType <> Opnd then
    ct:
{    Generate code for the RESET and  REWRITE
{
{ Side Effects:
{    Code will be generated
{    NextParm will be alter          begin Error(125); LCP.IdNum:=0 end
          else
              if NextParm^.LLink^.OpClass <> Idd then
           ed
{
{ Calls:
{    NextVar
{    ParamAddr
{    QGen0
{    EPop
{    LoadAddress
{    NextStrgVar
{    EQuick
{    GenL *  	
0;
     RND       = 81;
     ABR       = 82;
     ADR       = 83;
     NGR       = 84;
     SBR       = 85;
     MPR           LDO15     = 154;
     LOAB      = 155;
     LOAW      = 156;
     STOB      = 157;
     STOW      = 158;
     STO0     = 86;
     DVR       = 87;
     INN       = 88;
     UNI       = 89;
     QINT      = 90;
     DIF       = 91;
     EXITT  = 159;
     STO1      = 160;
     STO2      = 161;
     STO3      = 162;
     STO4      = 163;
     STO5      = 164;
        = 92;
     NOP       = 93;
     REPL      = 94;
     REPL2     = 95;
     MMS       = 96;
     MES       = 97;
     L  STO6      = 165;
     STO7      = 166;
     MVBB      = 167;
     MVBW      = 168;
     MOVB      = 169;
     MOVW      =VRD      = 98;
     LSSN      = 99;
     XJP       = 100;
     PSW       = 101;
     RASTOP    = 102;
     STRTIO    = 103; 170;
     INDB      = 171;
     INDW      = 172;
     IND0      = 173;
     IND1      = 174;
     IND2      = 175;
     I
     PBLK      = 104;
     INTOFF    = 105;
     INTON     = 106;
     LDLB      = 107;
     LDLW      = 108;
     LDL0  ND3      = 176;
     IND4      = 177;
     IND5      = 178;
     IND6      = 179;
     IND7      = 180;
     LDIND     = 17    = 109;
     LDL1      = 110;
     LDL2      = 111;
     LDL3      = 112;
     LDL4      = 113;
     LDL5      = 114;
 3;          { Same as IND0 }
     LGAWW     = 181;
     STMW      = 182;
     STDW      = 183;
     SAS       = 184;
     Aeal   = 47;
     LESReal   = 48;
     GEQReal   = 49;
     GTRReal   = 50;
     EQUStr    = 51;
     NEQStr    = 52;
         LDL6      = 115;
     LDL7      = 116;
     LDL8      = 117;
     LDL9      = 118;
     LDL10     = 119;
     LDL11    LEQStr    = 53;
     LESStr    = 54;
     GEQStr    = 55;
     GTRStr    = 56;
     EQUByt    = 57;
     NEQByt    = 58;
  = 120;
     LDL12     = 121;
     LDL13     = 122;
     LDL14     = 123;
     LDL15     = 124;
     LLAB      = 125;
        LEQByt    = 59;
     LESByt    = 60;
     GEQByt    = 61;
     GTRByt    = 62;
     EQUPowr   = 63;
     NEQPowr   = 64 LLAW      = 126;
     STLB      = 127;
     STLW      = 128;
     STL0      = 129;
     STL1      = 130;
     STL2      = ;
     LEQPowr   = 65;
     SGS       = 66;             { there is no LESPowr }
     GEQPowr   = 67;
     SRS       = 68;   131;
     STL3      = 132;
     STL4      = 133;
     STL5      = 134;
     STL6      = 135;
     STL7      = 136;
     LD          { there is no GTRPowr }
     EQUWord   = 69;             { Word is the last comparison and only EQU }
     NEQWord  OB      = 137;
     LDOW      = 138;
     LDO0      = 139;
     LDO1      = 140;
     LDO2      = 141;
     LDO3      = 142 = 70;             {   and NEQ exist }
     ABI       = 71;
     ADI       = 72;
     NGI       = 73;
     SBI       = 74;
;
     LDO4      = 143;
     LDO5      = 144;
     LDO6      = 145;
     LDO7      = 146;
     LDO8      = 147;
     LDO9      MPI       = 75;
     DVI       = 76;
     MODI      = 77;
     CHK       = 78;
     FLT       = 79;
     TNC       = 8     = 148;
     LDO10     = 149;
     LDO11     = 150;
     LDO12     = 151;
     LDO13     = 152;
     LDO14     = 153;
 * 	
Gen0(MMS2);
                  EPop(2);
                  EQuick(1);
                  GenLDC(ElWordSize);
                  5 { Eoln } then
                      Bit := EolnBit
                  else
                      Bit := EofBit;
           QGen0(MMS);
                  GenLDC(ElBitSize);
                  QGen0(MMS);
                  GenLDC(ord(CompTypes(FilType       GenLDC(MakeByte(Bit,0));
                  EPush(Data16);
                  QGen0(LDP);
                  EPop(2)
   ,CharPtr)));
                  QGen0(MMS)
                  end
              else
                  Error(116);
      EQui               end
              else
                  Error(125)
              end;
      EPush(Data16);
      GAttr.TyPtDC
{    Error
{    GenSysCall
{    New
{-----------------------------------------}
        var NullString: CSP;
      begick(1);
      if LKey = 32 { Reset } then
          GenLDC(ord(false))
      else
          GenLDC(ord(true));
      QGen0(Mn
      NextVar;
      if GAttr.TyPtr <> nil then
          with GAttr.TyPtr^ do
              if Form = Files then
       MS);
      GenSysCall(PStreamOpen)
      end { ReSetWrite };

procedure EofEoln;
{------------------------------
{ Abstra           begin
                  ParamAddr(true);
                  QGen0(MMS2);
                  EPop(2);
              ct:
{    Generate code for the EOF and EOLN intrinsics
{
{ Side Effects:
{    Code will be generated
{    NextParm will be     if NextParm <> nil then
                      begin
                      NextStrgVar(false);
                      Parammodified
{
{ Calls:
{    NextVar
{    DefaultFile
{    LoadAddress
{    CompTypes
{    Guard
{    Error
{    GenLDC
{ Addr(false)
                      end
                  else
                      begin
                      New(NullStrin   EPush
{    EPop
{    QGen0
{-------------------------------}
        var Bit: integer;
      begin
      if NextParm <>g,Strg);  { Space allocated will be }
                      with NullString^ do    { by QGen0 (called by     }
                nil then
          NextVar
      else
          begin
          Reading := true;
          StartTos := ETos;  { DefaultFil           begin              { LoadAddress) }
                          CClass:=Strg;
                          SLgth:=0;
  e does not set StartTos }
          DefaultFile;
          GAttr := FileAttr
          end;
      with GAttr do
          i                        STyp:=DynCst
                          end;
                      with GAttr do
                     f TyPtr <> nil then
              begin
              if TyPtr^.Form = Files then
                  begin
                       begin
                          TyPtr:=StrgPtr;
                          Kind:=Cst;
                          CVal.ValPLoadAddress;
                  if CompTypes(TyPtr^.FilType,CharPtr) then
                      Guard(StartTos)
              :=NullString
                          end;
                      LoadAddress
                      end;
                  Q    else
                      if LKey = 35 { Eoln } then
                          Error(125);
                  if LKey = 3 +  	
     = 207;
     JTB       = 208;
     JTW       = 209;
     JEQB      = 210;
     JEQW      = 211;
     JNEB      = 212;
Computer Corporation
{
{ Abstract:
{    General Compiler Initialization Code and Command Parsing.
{
{ File:
{    CompInit.     JNEW      = 213;
     IXP       = 214;
     LDIB      = 215;
     LDIW      = 216;
     LIAB      = 217;
     LIAW    Pas
{-----------------------------------------}

{ }
{ 1-Apr-81  3.1  Miles A. Barel
{ Fix Command Parsing for the new sys  = 218;
     STIB      = 219;
     STIW      = 220;
     IXAB      = 221;
     IXAW      = 222;
     IXA1      = 223;
   tem
{ }
{ 2-Feb-81  2.0  Miles A. Barel
{ Implementation of Long Integers
{ }
{ 15-Jan-81  1.12  Miles A. Barel
{ Hashing   IXA2      = 224;
     IXA3      = 225;
     IXA4      = 226;
     TLATE0    = 227;
     TLATE1    = 228;
     TLATE2    =compiler declared identifiers and user globals
{ }
{ 14-Jan-81  1.11  Miles A. Barel
{ New switch - $N /NAMES /NONAMES
{ }
 229;
     EXCH      = 230;
     EXCH2     = 231;
     INCB      = 232;
     INCW      = 233;
     CALLXB    = 234;
     C{ 13-Jan-81  1.10  Miles A. Barel
{ New switch - to enable saving procedure names in code file
{ }
{ 9-Jan-81  1.9  Miles A. ALLXW    = 235;
     LDMC      = 236;
     LDDC      = 237;
     LDMW      = 238;
     LDDW      = 239;
     STLATE    = 24Barel
{ Remove InitStructures - only initialized NullString which is not used
{ anywhere!
{ }
{ 02-Dec-80 Miles A. Barel
{ 0;
     QLINE      = 241;
     ENABLE    = 242;
     QRAISE    = 243;
     LDAP      = 244;
     INCDDS    = 251;
     BREReplaced SizeOf with WordSize
{ }
{ 14-Nov-80 Miles A. Barel
{ New Input File control and structures implemented (use of ^TexAK     = 254;
     ReFillOp  = 255;
     RESERVD   = 255;
     
{$MESSAGE Long Integer OpCodes Not Yet Assigned}
     CMPL t)
{ }
{ 13-Nov-80 Miles A. Barel
{ Fixed Auto Import File Names
{ }

EXPORTS

Procedure CompInit;

PRIVATE

{$C Co     = 000;          { QCode Opcodes to be assigned }
     ADL       = 000;
     SBL       = 000;
     MPL       = 000;
    pyright (C) 1981  Three Rivers Computer Corporation }

Imports PascalCompiler from Pascal;
Imports Bodyprt from Bodypart;
ImDJ       = 185;
     CALLL     = 186;
     CALLV     = 187;
     ATPB      = 188;
     ATPW      = 189;
     WCS       = 19 DVL       = 000;
     MODL      = 000;
     SHRKL     = 000;
     EXPL      = 000;
     
     {198..199, 245..250, 252..250;
     JCS       = 191;
     LDGB      = 192;
     LDGW      = 193;
     LGAB      = 194;
     LGAW      = 195;
     STGB3  Free}
     

Private

                                                                                                        = 196;
     STGW      = 197;
    {          = 198;}
    {          = 199;}
     RETURN    = 200;
     MMS2      = 201 ;
     MES2      = 202;
     LDTP      = 203;
     JMPB      = 204;
     JMPW      = 205;
     JFB       = 206;
     JFW  Module InitGlobals;
{-----------------------------------------}
{ Compiler Initialization
{ Copyright (C) 1981  Three Rivers  + 	
                   EPush(Data16);
                          GenLDC(ord(false));
                          EPush(Data16);
    and WRITELN
{
{ Side Effects:
{    Code will be generated
{    NextParm will be modified
{
{ Calls:
{    DefaultFile
{                        QGen0(STPF);
                          EPop(3)
                          end
                      else  NextExp
{    CompTypes
{    CheckFormats
{    ParamAddr
{    QGen0
{    EPop
{    LoadAddress
{    EPush
{    Read
{ 
                          begin
                          ParamAddr(true);
                          QGen0(MMS2);
            Write
{    Error
{    FileAddr
{    GenSysCall
{---------------------------------------}
      var LAttr: Attr;
                        EPop(2);
                          GenSysCall(PGetB)
                          end
              else
        LDrct, Done: boolean;

procedure CheckFormats;
{----------------------------------------
{ Abstract:
{    Procedure to              Error(116)
      end { Get };

procedure Put;
{--------------------------------
{ Abstract:
{    Generate comake sure that no more format info is present
{
{ Side Effects:
{    NextParm may be altered
{
{ Calls:
{    Error
{-----de for the PUT intrinsic
{
{ Side Effects:
{    Code will be generated
{    NextParm will be modified
{
{ Calls:
{    Nex-----------------------------------}
  var Done: boolean;
begin
if NextParm <> nil then
    if NextParm^.SSy = Colon then
 r := BoolPtr
      end { EofEoln };

procedure Get;
{----------------------------------
{ Abstract:
{    Generate code fotVar
{    Error
{    ParamAddr
{    QGen0
{    EPop
{    CompTypes
{    GenSysCall
{----------------------------------}
r the GET intrinsic
{
{ Side Effects:
{    Code is generated
{    NextParm will be altered
{
{ Calls:
{    Error
{    Co      begin
      NextVar;
      with GAttr do
          if TyPtr <> nil then
              if TyPtr^.Form = Files then
   mpTypes
{    LoadAddress
{    Guard
{    GenLDC
{    EPush
{    EPop
{    QGen0
{    ParamAddr
{    GenSysCall
{-------               if TyPtr^.FilType = nil then Error(399)
                  else
                      begin
                   ----------------------------}
      begin
      NextVar;
      with GAttr do
          if TyPtr <> nil then
              i   ParamAddr(true);
                      QGen0(MMS2);
                      EPop(2);
                      if CompTypes(TyPtf TyPtr^.Form = Files then
                  if TyPtr^.FilType = nil then
                      Error(399)
                  r^.FilType,CharPtr) then
                          GenSysCall(PPutC)
                      else
                          Genelse
                      if CompTypes(TyPtr^.FilType,CharPtr) then
                          begin
                        SysCall(PPutB)
                      end
              else
                  Error(116)
      end { Put };

procedure Re  LoadAddress;
                          Guard(StartTos);
                          GenLDC(MakeByte(CharReadyBit,0));
       adWrite;
{--------------------------------------
{ Abstract:
{    Handle generation of code for calls to READ, READLN, WRITE  ,  	

Imports System from System;
Imports CmdParse from CmdParse;
Imports Screen from Screen;

{$R-}

Const
    SegLeadIn = 4;--}
    label 1,               { loop to get command line }
          2,               { illegal command line reporting }
               { # Bytes in segment before first code byte }
    
    RWFileName = 'Pascal.ResWords';     { name of reserved word       3;               { illegal switch reporting }
    var Src,Sw,CmdLine: string;
        ix,i,j:integer;
        Spaces:  file }


Procedure CompInit;
{---------------------------------------
{ Abstract:
{    Compiler Initialization Main Bodystring[2];
        NameDels,SwDels,NSwDels: string[4];
        BrkChr: string[1];
        Switches: CmdArray;
    const
   .  Calls individual routines and
{    parses MODULE or PROGRAM line of the program.
{
{ Side Effects:
{    Opens Input, Outp     NumSwitches = 14;

Procedure SkipToDel;
{-----------------------------------------
{ Abstract:
{    Skip to the next ut and List Files,  initializes most global variables,
{    initializes compiler switches, allocates symbol table cache blocks.real delimiter (spaces and tabs don't count)
{
{ Side Effects:
{    Modifies BrkChr and CmdLine (both defined by ParseCmdLine
{
{ Errors:
{    Bad Program/Module heading
{
{ Calls:
{    Concat
{    CreateWindow
{    ChangeWindow
{    Rewrite
{)
{
{ Calls:
{    Pos
{    RemDelimiters
{    SubStr
{------------------------------------------}
begin
if (Pos(BrkChr,'    InitSearch
{    InitScalars
{    InitSets
{    InitQCodes
{    EntStdTypes
{    EntStdNames
{    EntSpcProcs
{    Ent ') <> 0) or (Pos(BrkChr,'	') <> 0) then
    RemDelimiters(CmdLine,Spaces,BrkChr);     { get to the delimiter }
CmdLine:=SubStSysCalls
{    EntAllException
{    EntUndecl
{    Error
{    InSymbol
{    EnterId
{    New
{----------------------------r(CmdLine,2,Length(CmdLine)-1)  { Remove the delimiter from }
end { SkipToDel };                            { the command line -------------}
  var CID:Identifier; TitleStr: string;

procedure ParseCmdLine;
{--------------------------------------
{ }

  begin { ParseCmdLine }
  { Initialize locals of the procedure }
  Spaces := '  ';  Spaces[2]:=chr(9);    { Space dels Abstract:
{    Parse the command line, setting desired options and opening
{    appropriate files.
{
{ Side Effects:
{    Oare space and tab }
  NameDels:=Concat('/=',Spaces);          { Output Name delimiters }
  SwDels:=Concat('/:',Spaces);       pens Input, Output and List files.  Sets initial switch values.
{
{ Errors:
{    Bad Command Line
{    No room for output fi     { Switch Delimiters }
  NSwDels:=Concat('/',Spaces);            { Switch Argument Delimiters }
  Switches[1]:='RANGE';
 le
{
{ Calls:
{    Concat
{    RemDelimiters
{    GetSymbol
{    SkipToDel
{    New
{    Readln
{    Write/Writeln
{   Switches[2]:='NORANGE';
  Switches[3]:='QUIET';
  Switches[4]:='VERBOSE';
  Switches[5]:='LIST';
  Switches[6]:='SYMBOLS';ports QCodes from QCodes.Dfs;

{ OS Support Imporations }
Imports Memory from Memory;
Imports Perq_String from Perq_String;  Pos
{    SubStr
{    UniqueCmdIndex
{    Rewrite
{    Reset
{    Close
{    Get
{-------------------------------------- , 	
rated
{    NextParm may be altered
{
{ Calls:
{    GenLDC
{    EPush
{    NextExp
{    LoadExpr
{    CompTypes
{    QGegin
            QGen0(LSSN);
            EPush(Data16);
            LoadAddress;
            EPop(2)
            end
     n0
{    EPop
{---------------------------------}
  var Default: boolean;
        begin
        if NextParm = nil then
       else
            begin
            LoadAddress;
            QGen0(LDDW);
            EPop(1)
            end;
        E        Default := true
        else
            Default := NextParm^.SSy <> Colon;
        if Default then
            begiPush(Ptr32);
        GAttr := LAttr
        end { FileAddr };

procedure Read;
{-----------------------------
{ Abstract:n
            GenLDC(F);
            EPush(Data16)
            end
        else
            begin
            NextExp;
  
{    Handle the generation specifically related to the case of READ and READLN
{
{ Side Effects:
{    Code will be generate          LoadExpr;
            if not CompTypes(GAttr.TyPtr,IntPtr) then
                Error(116)
            end;
      d
{    NextParm may be altered
{
{ Calls:
{    Error
{    ParamAddr
{    CompTypes
{    LoadAddress
{    FileAddr
{      QGen0(MMS);
        EPop(1)
        end { Format };

procedure Call(R: RoutineName; Formats, Default1, Default2: integer)Guard
{    QGen1A
{    Store
{    GenLDC
{    EPush
{    EPop
{    QGen0
{    CheckFormats
{    Call
{    StrgType
{  ;
{----------------------------------
{ Abstract:
{    Set up formats and generate call to the read and write routines
{
{   EQuick
{    PAOfChar
{    GetBounds
{    NextExp
{------------------------------}
        var Len, LMin, LMax: integer;
Side Effects:
{    Code will be generated
{    NextParm may be modified
{
{ Calls:
{    Format
{    CheckFormats
{    Gen            LAttr: Attr;
            Done: boolean;
        begin
        Done := false;
        repeat
            if GAttSysCall
{----------------------------------}
  begin
  if Formats >= 1 then Format(Default1);
  if Formats >= 2 then Format(r.Kind <> Varbl then
                begin
                Error(116);
                ETos := 0
                end
             begin
        Error(124);
        repeat
            NextParm := NextParm^.RLink;
            if NextParm = nil thenDefault2);
  CheckFormats;
  if R <> PNone then GenSysCall(R)
  end { Call };

procedure FileAddr;
{---------------------
                Done := true
            else
                Done := NextParm^.SSy <> Colon
        until Done
        end-------------
{ Abstract:
{    Get the virtual address of the file to which I/O is to be performed
{
{ Side Effects:
{    C
end { CheckFormats };

procedure Format(F: integer);
{----------------------------------
{ Abstract:
{    Generate code ode will be generated
{
{ Calls:
{    QGen0
{    EPush
{    LoadAddress
{    EPop
{--------------------------------}
   for read and write format information
{
{ Parameters:
{    F - the default format
{
{ Side Effects:
{    Code will be gene     var LAttr: Attr;
        begin
        LAttr := GAttr;
        GAttr := FileAttr;
        if LDrct then
            be -  	

      RemDelimiters(CmdLine,Spaces,BrkChr)
      end;
  ConvUpper(CmdLine);
  
  { Get Output file (and possibly Input) }                 end;
          NumSwitches + 1: goto 3;
          1,2: RangeCheck^.Sw := ix = 1;
          3,4: Noisy^.Sw :=
  GetSymbol(CmdLine,OutFileName,NameDels,BrkChr);
  SkipToDel;
  if Length(OutFileName) = 0 then
      begin
    2:writeln( ix = 4;
          5:   if List then
                   begin
                   { List File Already exists, warn LUser and S
  Switches[7]:='AUTO';
  Switches[8]:='NOAUTO';
  Switches[9]:='VERSION';
  Switches[10]:='COPYRIGHT';
  Switches[11]:='DEB'?Illegal Command Line');
      goto 1
      end;
  {$R-}
  if (Length(BrkChr) > 0) and (BrkChr[1] = '=') then
  {$R=}
   UG';
  Switches[12]:='NODEBUG';
  Switches[13]:='NAMES';
  Switches[14]:='NONAMES';

  CmdLine:=UsrCmdLine;                   { I know this could be a range error, but they are disabled and
        there will be no ill side effects }
      begin
    { Pick up initial command line }
  RemDelimiters(CmdLine,Spaces,BrkChr); { And remove compile command }
  GetSymbol(CmdLine,    { Separate Source Name coming }
      RemDelimiters(CmdLine,Spaces,BrkChr);
      GetSymbol(CmdLine,Src,NameDels,BrkChr);OutFileName,Spaces,BrkChr);
  RemDelimiters(CmdLine,Spaces,BrkChr);
  
  List := false;
  SymBlocks:=DefSymBlocks;          
      if Length(Src) = 0 then goto 2;
      SkipToDel
      end
  else
      begin
      { Use same root name for Src as f  { Default on Number of ST Blocks }
  CondCompile := nil;
  AutoInit:=true;
  new(Noisy);
  with Noisy^ do
      begin
  or OutFileName }
      Src := OutFileName;
      if (Pos(OutFileName,DefIExtension) <> 0) and (Pos(OutFileName,DefIExtension)     Sw:=true;
      Previous:=nil
      end;
  new(RangeCheck);
  with RangeCheck^ do
      begin
      Sw:=true;
      P=
        Length(OutFileName)-Length(DefIExtension)+1) then
          OutFileName:=SubStr(OutFileName,1,Length(OutFileName)-Lerevious:=nil
      end;
  new(Debug);
  with Debug^ do
      begin
      Sw:=false;
      Previous:=nil
      end;
  newngth(DefIExtension))
      end;
  if (Pos(OutFileName,DefOExtension) = 0) or (Pos(OutFileName,DefOExtension) <>
    length(Ou(Names);
  with Names^ do
      begin
      Sw:=false;
      Previous:=nil
      end;
  VerStr:='';
  CopyStr:='';
    tFileName)-length(DefOExtension)+1) then
      OutFileName:=Concat(OutFileName,DefOExtension);
  GetFileExtension(Src);
  
 
  while Length(CmdLine) = 0 do
      begin
      goto 1;
    3:writeln('?Bad Switch');
      { Initial Default Switch Value { Scan off switches }
  while BrkChr = '/' do
      begin
      RemDelimiters(CmdLine,SwDels,BrkChr);
      GetSymbol(CmdLis First }
    1:if List then
          begin
          List:=false;
          Close(LP)
          end;
      RangeCheck^.Sne,Sw,SwDels,BrkChr);
      SkipToDel;
      ix:=UniqueCmdIndex(Sw,Switches,NumSwitches);
      case ix of
          NumSwitw:=true;
      Noisy^.Sw:=true;
      Names^.Sw:=false;
      Debug^.Sw:=false;
      write('PAS>');
      readln(CmdLine);ches + 2: begin
                           writeln('?''',Sw,''' is not unique');
                           goto 1
           - 	
                 begin
                    LAttr := GAttr;
                    StartTos := ETos;
                                        else if PAOfChar(GAttr.TyPtr) then
                        with GAttr.TyPtr^ do
                            begin   { LoadAddress and FileAddr do not set StartTos }
                    if LDrct then
                        begin
         
                            EQuick(1);
                            Len := 0;
                            if InxType <> nil th               GAttr := FileAttr;
                        LoadAddress
                        end
                    else Fien
                                begin
                                GetBounds(InxType,LMin,LMax);
                      leAddr;
                    Guard(StartTos);
                    QGen1A(INDB,FDSize);
                    Store(LAttr);
              Len := LMax - LMin + 1
                                end;
                            GenLDC(Len);
                              if LDrct then
                        begin
                        GAttr := FileAttr;
                                    QGen0(MMS);
                            Call(PRdChArray,1,Len,0)
                            end
                LoadAddress
                        end
                    else FileAddr;
                    GenLDC(MakeByte(CharReadyBit      else if CompTypes(GAttr.TyPtr,BoolPtr) then
                        Call(PRdBoolean,0,0,0)
                    else if C,0));
                    EPush(Data16);
                    GenLDC(ord(false));
                    EPush(Data16);
        ompTypes(GAttr.TyPtr,LongPtr) then
                        Call(PRdLong,0,0,0)
                    else
                                 QGen0(STPF);
                    EPop(3);
                    CheckFormats
                    end
                begin
                        Error(116);
                        Call(PNone,2,0,0)
                        end
            else
                    begin
                    FileAddr;
                    QGen0(MMS2);
                    EPop(2)           end
            end;
            if NextParm = nil then
                Done := true
            else
          ;
                    QGen0(MMS2);
                    EPop(2);
                    if CompTypes(GAttr.TyPtr,IntPtr) then
        NextExp
        until Done
        end { Read };

procedure Write;
{-----------------------------
{ Abstract:
{                         Call(PRdInteger,0,0,0)
                    else if StrgType(GAttr.TyPtr) then
                        be Handle the generation specifically related to WRITE and WRITELN
{
{ Side Effects:
{    Code will be generated
{    NextParmgin
                        EQuick(1);
                        Len := GAttr.TyPtr^.MaxLeng;
                        GenLDC(Le may be altered
{
{ Calls:
{    Error
{    CompTypes
{    LoadExpr
{    Store
{    FileAddr
{    QGen0
{    QGen1A
{        else
                begin
                ParamAddr(true);
                if CompTypes(GAttr.TyPtr,CharPtr) then
   n);
                        QGen0(MMS);
                        Call(PRdString,1,Len,0)
                        end
         .  	
 if Length(Sw) = 0 then
                           begin
                           writeln('?Bad List File Name');
         begin
               { Version Switch }
               if Length(VerStr) <> 0 then
                   Writeln(chr(7),'?Versio                  goto 1
                           end;
                       if ((Pos(Sw,DefLExtension) = 0) or
          n Already Defined');
               if BrkChr <> ':' then goto 3;
               RemDelimiters(CmdLine,Spaces,BrkChr);
                     (Pos(Sw,DefLExtension) <>
                         length(Sw)-length(DefLExtension)+1)) and
                            GetSymbol(CmdLine,VerStr,'/',BrkChr);
               SkipToDel;
               if Length(VerStr) = 0 then
                (Sw <> 'CONSOLE:') then
                           Sw:=Concat(Sw,DefLExtension)
                       end;
                    begin
                   writeln('?Bad Version String');
                   goto 1
                   end
                 ReWrite(LP,Sw);
                   List:=true
                   end;
            6: begin
               i:=0;
         end;
           10: begin
               { Copyright Switch }
               if Length(CopyStr) <> 0 then
            kip over Sw }
                   writeln('?Using Existing List File');
                   if BrkChr = ':' then
                          if BrkChr <> ':' then
                   goto 2;     { Illegal Command Line }
               RemDelimiters(CmdLine         begin
                       RemDelimiters(CmdLine,Spaces,BrkChr);
                       GetSymbol(CmdLine,Sw,NSwDel,Spaces,BrkChr);
               GetSymbol(CmdLine,Sw,NSwDels,BrkChr);
               SkipToDel;
               if length(Sw) s,BrkChr);
                       SkipToDel
                       end
                   end
               else
         < 1 then
                   begin
                   writeln('?Bad Numerical Input');
                   goto 1
                      begin
                   if BrkChr <> ':' then
                       { Use Default Name }
                       b       end;
               for j:=1 to Length(Sw) do
                   if Sw[j] in ['0'..'9'] then
                       i:egin
                       Sw:=SubStr(OutFileName,1,
                         length(OutFileName)-Length(DefOExtension));
  =i*10+(ord(Sw[j])-ord('0'))
                   else
                       begin
                       writeln('?Bad Numeric                     Sw:=Concat(Sw,DefLExtension)
                       end
                   else
                       {al Input');
                       goto 1
                       end;
               if (i < 1) or (i > MaxSymBlocks) then
  get list file name from the command line }
                       begin
                       RemDelimiters(CmdLine,Spaces,B                  begin
                   writeln('?',i:1,' out of range (1..',MaxSymBlocks:1,')');
                   goto 1rkChr);
                       GetSymbol(CmdLine,Sw,NSwDels,BrkChr);
                       SkipToDel;
                      
                   end;
               SymBlocks:=i
               end;
          7,8: AutoInit := ix = 7;
            9:  . 	
      EPop(1);
                            FileAddr;
                            QGen1A(INCB,FDSize);
                       p(2);
                    Call(PWrString,1,0,0)
                    end
                else if PAOfChar(GAttr.TyPtr) then
      QGen0(MES);
                            EPush(Data16)
                            end;
                        QGen0(STI                   with GAttr.TyPtr^ do
                        begin
                        ParamAddr(false);
               EPop
{    EPush
{    GenSysCall
{    Call
{    Format
{    StrgType
{    ParamAddr
{    GetBounds
{    GenLDC
{    NeND);
                        EPop(2)
                        end;
                    FileAddr;
                    QGen0(MMxtExp
{------------------------------}
        var Len, LMin, LMax: integer;
            LAttr: Attr;
            Done, DeciS2);
                    EPop(2);
                    GenSysCall(PPutC)
                    end
                else
      mal, UnFormatted: boolean;
        begin
        Done := false;
        repeat
            if CompTypes(GAttr.TyPtr,CharPtr)              begin
                    FileAddr;
                    QGen0(MMS2);
                    EPop(2);
             then
                begin
                UnFormatted := true;
                if NextParm <> nil then
                           LoadExpr;
                    QGen0(MMS);
                    EPop(1);
                    Call(PWrCh,1,1,0)
        UnFormatted := NextParm^.SSy <> Colon;
                if UnFormatted then
                    begin
                    if              end
                end
            else
                begin
                FileAddr;
                QGen0LDrct then
                        begin
                        LoadExpr;
                        LAttr := FileAttr;
      (MMS2);
                EPop(2);
                if CompTypes(GAttr.TyPtr,IntPtr) then
                    begin
                             LAttr.TyPtr := CharPtr;
                        LAttr.Dplmt := LAttr.Dplmt + FDSize;
                                LoadExpr;
                    QGen0(MMS);
                    EPop(1);
                    Format(8);
              Store(LAttr)
                        end
                    else
                        begin
                        if        if NextParm = nil then
                        Decimal := true
                    else
                        DecimaStartTos = ETos then
                            begin
                            FileAddr;
                            QGenl := NextParm^.SSy <> Colon;
                    if Decimal then
                        Call(PWrInteger,0,0,0)
             1A(INCB,FDSize);
                            LoadExpr
                            end
                        else
                else
                        Call(PWrX,1,10,0)
                    end
                else if StrgType(GAttr.TyPtr) t                   begin
                            LoadExpr;
                            QGen0(MMS);
                      hen
                    begin
                    ParamAddr(false);
                    QGen0(MMS2);
                    EPo /  	


  InFileNesting := 0;
  New(CurIFile);
  with CurIFile^ do
      begin
      FName:=Src;
      CurLine:='';
      New(    while ch <> ResWords[i].RWord[1] do
              begin
              ch:=chr(ord(ch)+1);
              ResHash[ord(ch)]:InFile);
      Reset(InFile^,Src);
      NextCh := InFile^^;
      Get(InFile^);
      LinNum:=0;
      PrevFile:=nil;
   =i
              end
      end;
  while ch <> chr(91) do
      begin
      ch:=chr(ord(ch)+1);
      ResHash[ord(ch)]:=Res   EOL:=false;
      IncludeFile:=false;
      LinkList[0].FilName:=Src;
      writeln('[',FName,']')
      end;
  OutFile:Count+1
      end;
  Close(ResFile)
  end { InitSearch };

procedure InitQCodes;
{-----------------------
{ Abstract:
{=FSEnter(OutFileName);
  if OutFile = 0 then
      begin
      writeln('Cannot create ',OutFileName);
      exit(PascalCompi    Initialize TLATE attributes of all QCodes
{
{ Side Effects:
{    The array QCodes is initialized
{
{ Design:
{    The ler)
      end;

  for i:=1 to SymBlocks do
      begin
      New(0,256,BlockBuf[i]);
      CurBlocks[i]:=-1;
      CleanQCodes array is used to determine if TLATE QCodes are required
{    before the generation of any other QCode.
{---------------Up[i]:=false;
      CurUsage[i]:=0
      end;
  LastUsed:=0
  end { ParseCmdLine };

procedure InitSearch;
{----------------------}
    var i:integer;
  begin
  for i:=0 to 255 do
      with QCode[i] do
          { first let's get all TLATE0 c----------------------------
{ Abstract:
{    Initialize definition of reserved words
{
{ Environment:
{    The file PASCALandidates }
          if i in [LDDW,INDB..IND7{,LDIND - same as IND0}] then
              begin
              Src:=0;
      .RESWORDS is read to get the reserved word definitions
{
{ Side Effects:
{    Sets up the contents of ResWords and ResHash
{        Dst:=15
              end
          { next all the TLATE1 candidates }
          else if i in [STIND,LDMW,STMW,LDB,LD       Writeln(chr(7),'?Copyright Already Defined');
               if BrkChr <> ':' then goto 3;
               RemDelimiters
{ Calls:
{    Reset
{    Get
{    Close
{
{ Design:
{    The Reserved Word file contains the ID, Symbol and Operator typ(CmdLine,Spaces,BrkChr);
               GetSymbol(CmdLine,CopyStr,'/',BrkChr);
               SkipToDel;
               if Lee
{    of each reserved word.  The Symbol and Operator types in the file
{    must match those of the enumerated types SYMBOL ngth(CopyStr) = 0 then
                   begin
                   writeln('?Bad Copyright String');
                   goto and OPERATOR; defined
{    in PASCAL.PAS
{-----------------------------------------}
    var ch:char; i:integer; ResFile:file1
                   end
               end;
        11,12: Debug^.Sw := ix = 11;
        13,14: Names^.Sw := ix = 13
      of ResWrdRec;
  begin
  Reset(ResFile,RWFileName);
  ResWords[1]:=ResFile^;
  ResHash[ord('A')]:=1;
  ch:='A';
  for i:=2      end { case }
      end { while BrkChr = '/' };
      
  if (Length(BrkChr) > 0) and (BrkChr <> '/') then
      goto 3; to ResCount do
      begin
      Get(ResFile);
      ResWords[i]:=ResFile^;
      if ResWords[i].RWord[1] > ch then
       / 	
    else
                    begin
                    Error(116);
                    Call(PNone,2,0,0)
                                             QGen0(MES2);
                          EPush(Ptr32);
                          QGen0(STDW);
        end
                end;
            if NextParm = nil then
                Done := true
            else
                                   EPop(3)
                          end;
                      if NextParm = nil then
                      NextExp
        until Done
        end { Write };

begin { ReadWrite }
      Reading := LKey in [38,40] { Read, Readln };    Done := true
                      else
                          NextExp
                      end
                  el
      LDrct := true;
      if NextParm = nil then { use defaults }
          begin
          DefaultFile;
          Done :=se
                      DefaultFile
              else
                  DefaultFile
          else
              DefaultF true
          end
      else
          begin
          Done := false;
          NextExp;
          if GAttr.TyPtr <> nilile
          end;
      if not Done then
          if Reading then
              Read
          else
              Write           QGen0(MMS2);
                        EPop(2);
                        EQuick(1);
                        Len := 0; then
              if GAttr.TyPtr^.Form = Files then
                  if CompTypes(GAttr.TyPtr^.FilType,CharPtr) then
     
                        if InxType <> nil then
                            begin
                            GetBounds(InxTy                 begin
                      CheckFormats;
                      if GAttr.Access = Drct then FileAttr := GAttrpe,LMin,LMax);
                            Len := LMax - LMin + 1
                            end;
                        Ge
                      else
                          begin
                          LDrct := false;
                      nLDC(Len);
                        QGen0(MMS);
                        Call(PWrChArray,1,Len,0)
                        end
    ParamAddr(true);
                          QGen0(MMS2);
                          EPop(2);
                          with                else if CompTypes(GAttr.TyPtr,BoolPtr) then
                    begin
                    LoadExpr;
          FileAttr do
                              begin
                              TyPtr := TextPtr;
                                       QGen0(MMS);
                    EPop(1);
                    Call(PWrBoolean,1,6,0)
                    end
       Kind := Varbl;
                              Access := Drct;
                              VLevel := Level;
                          else if CompTypes(GAttr.TyPtr,LongPtr) then
                    begin
                    LoadExpr;
                             Dplmt := LC
                              end;
                          LC := LC + PtrSize;
                       QGen0(MMS);
                    EPop(1);
                    Call(PWrLong,1,10,0)
                    end
                     if LC > LCMax then LCMax := LC;
                          GAttr := FileAttr;
                          LoadAddress;
 0  	
t:=15
              end
          { now for all the special STLATE candidates }
          else if i in [MVBB,EQUStr..GTRByt]  do
      begin Size := PtrSize; Form := Pointr; ElType := nil end;
    
    New(TextPtr,Files);
    with TextPtr^ do
     then
              begin
              Src:=1;
              Dst:=3
              end
          else if i in [MVBW,SAS] the begin
        Size := TextSize; Form := Files; FilType := CharPtr;
        ElWordSize := 0; ElBitSize := 8
      end;
    n
              begin
              Src:=2;
              Dst:=4
              end
          else if i in [MOVB,EQUWord..NE
    New(StrgPtr,Arrays,true,true);
    with StrgPtr^ do
      begin Form := Arrays; Size := (DefStrgLgth + ChrsPerWd) div ChrQWord] then
              begin
              Src:=0;
              Dst:=1
              end
          else if i in [MOVW] sPerWd;
        AIsPackd := true; AIsStrng := true; InxType := IntPtr;
        ElWidth := BitsPerChr; ElsPerWd := ChrsPerWd;
then
              begin
              Src:=1;
              Dst:=2
              end
          { the default case - no TLA        AElType := CharPtr; MaxLeng := DefStrgLgth;
      end;
    
    New(LongPtr,Scalar,Special);
    with LongPtr^ do
 TEs at all }
          else
              begin
              Src:=15;
              Dst:=15
              end
  end { Ini     begin Size := LongSize; Form := Scalar; ScalKind:=Special end
  end { EntStdTypes } ;

procedure EntStdNames;
{-------tQCodes };

procedure EntStdTypes;
{------------------------------
{ Abstract:
{    Define STRUCTUREs for the predefined s--------------------
{ Abstract:
{    Enter the predefined identifiers in the symbol table
{
{ Calls:
{    EnterId
{    Netandard types (INTEGER, REAL,
{    CHAR, BOOLEAN, STRING, TEXT, NIL, POINTER)
{
{ Calls:
{    New
{------------------------xtINum
{---------------------------}
    var i:integer; CID:Identifier;
  begin
  with CID do
      for i:=1 to 11 do
    ------}
  begin
    New(IntPtr,Scalar,Special);
    with IntPtr^ do
      begin Size := IntgrSize; Form := Scalar; ScalKind       begin
          case i of
            1: begin
               Name:='INTEGER ';  IdType:=IntPtr;
               Klass::= Special end;
    
    New(RealPtr,Scalar,Special);
    with RealPtr^ do
      begin Size := RealSize; Form := Scalar; Sca=Types;  { Next:=don't care }
               end;
               
            2: begin
               Name:='REAL    ';  IdTlKind := Special end;
    
    New(CharPtr,Scalar,Special);
    with CharPtr^ do
      begin Size := CharSize; Form := Scalaype:=RealPtr;
               { other values the same as the previous entry }
               end;

            3: begin
    CH,LDP] then
              begin
              Src:=1;
              Dst:=15
              end
          { next all the TLAr; ScalKind := Special end;
    
    New(BoolPtr,Scalar,Declared);
    with BoolPtr^ do
        begin
          Size := BooTE2 candidates }
          else if i in [STPF,STCH,STB,STDW] then
              begin
              Src:=2;
              DslSize; Form := Scalar;
          ScalKind := Declared; FConst:=0
        end;
    
    New(NilPtr,Pointr);
    with NilPtr^ 0 	
altered
{
{ Calls:
{    NextExp
{    LoadExpr
{    CompTypes
{    EQuick
{    GenLDC
{    QGen0
{    QGen1
{    EPop
tr,IntPtr) then
          Error(125);
      NextExp;
      LoadExpr;
      if not CompTypes(GAttr.TyPtr,IntPtr) then
      {-----------------------------------}
        var LAttr: Attr;
      begin
      LAttr:=GAttr;
      NextExp;
      LoadExp    Error(125);
      QGen0(QOR);
      EPop(IntgrSize)
      end { LogOr };

procedure LogNot;
{------------------------r;
      if not CompTypes(GAttr.TyPtr,IntPtr) then Error(125);
      if RangeCheck^.Sw then
          begin
          EQuick---------
{ Abstract:
{    Generate code for the Logical NOT (LNOT) intrinsic
{
{ Side Effects:
{    Code will be generated(2);
          if LKey = 21 then GenLDC(-15) else GenLDC(0);
          GenLDC(15);
          QGen0(CHK)
          end;
    
{    NextParm will be altered
{
{ Calls:
{    Error
{    CompTypes
{    NextExp
{    LoadExpr
{    GenLDC
{    QGen0
  if LKey = 21 then
          QGen1(ROTSHI,ord(ShiMode))
      else
          QGen1(ROTSHI,ord(RotMode));
      EPop(1);
  {    EPop
{-----------------------------------}
      begin
      GenLDC(-1);
      EPush(Data16);
      NextExp;
      Lo    GAttr:=LAttr
      end { ShiftRotate };

procedure LogAnd;
{---------------------------------
{ Abstract:
{    GeneraadExpr;
      if not CompTypes(GAttr.TyPtr,IntPtr) then Error(125);
      QGen0(SBI);
      EPop(IntgrSize)
      end { LogNte code for the Logical AND (LAND) intrinsic
{
{ Side Effects:
{    Code will be generated
{    NextParm will be altered
{ot };

Procedure Close;
{---------------------------------
{ Abstract:
{    Generate code for the CLOSE intrinsic
{
{ Si
{ Calls:
{    Error
{    CompTypes
{    NextExp
{    LoadExpr
{    QGen0
{    EPop
{-----------------------------------}de Effects:
{    Code will be generated
{    NextParm will be altered
{
{ Calls:
{    Error
{    NextVar
{    ParamAddr

      else
          if LKey in [38,39] { Read, Write } then
              Error(116);
      if LKey in [40,41] { Readln, Wr
      begin
      if not CompTypes(GAttr.TyPtr,IntPtr) then
          Error(125);
      NextExp;
      LoadExpr;
      ifiteln } then
          begin
          FileAddr;
          QGen0(MMS2);
          EPop(2);
          if LKey = 40 then
    not CompTypes(GAttr.TyPtr,IntPtr) then
          Error(125);
      QGen0(QAND);
      EPop(IntgrSize)
      end { LogAnd };           GenSysCall(PReedln)
          else
              GenSysCall(PRiteln)
          end;
      if not LDrct then
    

procedure LogOr;
{---------------------------------
{ Abstract:
{    Generate code for the Logical OR (LOR) intrinsic
{      LC := FileAttr.Dplmt
      end { ReadWrite };

procedure ShiftRotate;
{--------------------------------
{ Abstract:
{ Side Effects:
{    Code will be generated
{    NextParm will be altered
{
{ Calls:
{    Error
{    CompTypes
{    Nex
{    Generate code for the ROTATE and SHIFT intrinsics
{
{ Side Effects:
{    Code will be generated
{    NextParm will be tExp
{    LoadExpr
{    QGen0
{    EPop
{-----------------------------------}
      begin
      if not CompTypes(GAttr.TyP 1  	
{    and allocate their data space
{
{ Calls:
{    EnterId
{    NextINum
{---------------------}
    var CID: Identifier;overy
{
{ Calls:
{    WriteNum
{    NextINum
{----------------------------}
    var i:integer; CID:Identifier;
  begin
            Name:='LONG    ';  IdType:=LongPtr;
               { other values the same as the previous entry }
               e
  begin
  with CID do
      begin
      Name:='INPUT   ';  IdType:=TextPtr;
      Klass:=ActualVars;  VLev:=Level;  VAddr:=nd;
  
            4: begin
               Name:='CHAR    ';  IdType:=CharPtr;
               end;
               
       LC; LC := LC + TextSize;
      IdNum := NextINum;
      EnterId(CID);
      Name:='OUTPUT  ';  VAddr:=LC; LC := LC + TextSize     5: begin
               Name:='BOOLEAN ';  IdType:=BoolPtr;
               end;
               
            6: begin
 ;
      IdNum := NextINum;
      EnterId(CID)
      end
  end { EntInOut };

procedure EntAllException;
{---------------              Name:='STRING  ';  IdType:=StrgPtr;
               end;
               
            7: begin
               Na------------
{ Abstract:
{    Enter the predefined ALL Exception in the symbol table
{
{ Calls:
{    EnterId
{    NextINumme:='TEXT    ';  IdType:=TextPtr;
               end;
               
            8: begin
               Name:='TRUE    '; 
{---------------------------}
    var i:integer; ExcLCP,PLCP:Identifier;
begin
with PLCP do        { create the parameters  IdType:=BoolPtr;  Next:=0;
               Values.IVal:=1;  Klass:=Konst;
               end;
               
            9:}
    begin
    IdNum := 0;
    IdType := IntPtr;   { all parameters to ALL exception are integers (4) }
    Klass := Actual begin
               BoolPtr^.FConst:=IdNum;    { This is actually IdNum of TRUE }
               Name:='FALSE   ';  Next:=IdVars
    end;
for i:=0 to 3 do        { there are 4 parameters }
    with PLCP do
        begin
        Next := IdNum;  { cNum { This is IdNum of TRUE };
               Values.IVal:=0;
               end;
               
           10: begin
    hain the parameters }
        IdNum := NextINum;
        WriteNum(PLCP)
        end;
with ExcLCP do
    begin
    Name :=            Name:='NIL     ';  IdType:=NilPtr;
               Next:=0;  Values.IVal:=0;
               end;
               
 'ALL     ';
    IdNum := NextINum;
    IdType := nil;
    Next := PLCP.IdNum;
    Klass := Except;
    PFDecKind := Declare          11: begin
               Name:='MAXINT  ';  IdType:=IntPtr;  Values.IVal:=MaxInt
               end
               d;
    LocalLC := 4;
    PFKind := Actual;
    PFName := -1;
    PFSeg := -1;
    ForwDecl := false;
    ImpDecl := false;
            end {case};
          IdNum:=NextINum;
          EnterId(CID);
          end {for}
  end { EntStdNames };


    InScope := true
    end;
EnterId(ExcLCP)
end { EntAllException };

procedure EntUndecl;
{--------------------------procedure EntInOut;
{---------------------
{ Abstract:
{    Enter the predefined files INPUT and OUTPUT in the symbol table
--
{ Abstract:
{    Define a "Null" structure for all standard types (except FormalVals
{    and Modules); used for error rec 1 	
amAddr(true);
                  QGen0(MMS2);
                  EPop(2)
                  end
              else
            of non-scalar types now return temp stack space
{ }
{ 7-Jan-81  1.6  Miles A. Barel
{ General cleanup and institution of sta       Error(116);
      GenSysCall(PStreamClose)
      end { Close };

begin { ExpRoutine }
case LKey of
     6,31:   Nendard 3RCC file formats
{ }

procedure ExpCallNonSpecial(Node: ESP);
{-------------------------------------
{ Abstract:
{wDispose;
     8:      Exxit;
    11:      WordSiz;
    21,22:   ShiftRotate;
    23:      LogAnd;
    24:      LogOr;
       Expand calls to user defined procedures and functions
{
{ Parameters:
{    Node - the root node of the procedure/function 25:      LogNot;
    30:      VRD;
    32,33:   ReSetWrite;
    34,35:   EofEoln;
    36:      Get;
    37:      Put;
    call expression tree; this
{           node contains the call operator
{
{ Side Effects:
{    Code will be generated
{     38,39,
    40,41:   ReadWrite;
    42:      Close
  end {case}
end { ExpRoutine };
                                       NextParm may be altered
{
{ Calls:
{    QGen1A
{    ExpParam
{    QGen2
{    GenByte
{    EPush
{    GenLDC
{    QGen0 
{    EQuick
{    EPop
{    QGen1
{--------------------------------------}
      label 1;
      var LCP: Identifier { for c urrent parameter defn }; i:integer;

procedure ExpParam(Node: ESP);
{--------------------------------------------
{ Abstrac t:
{    Set up a parameter for passing
{
{ Parameters:
{    Node - The root node of the expression tree representing the par{-----------------------------------------------
{
{ Expression Expansion  Part C
{ Copyright (C) 1981  Three Rivers Computerameter
{           (actually the PushParm operator
{
{ Side Effects:
{    Code will be generated
{
{ Calls:
{    ExpExpre Corporation
{
{ Abstract:
{    The third part of expression expansion - the second of two parts which
{    deal with the exssion
{    ParamAddr
{    LookupNum
{    Error
{    QGen0
{    EPop
{    CompTypes
{    LoadExpr
{    QGen1
{    QGen1Apansion of procedure/function calls (some of the
{    compiler intrinsics and user procedure/function calls)
{
{ File: Expr2.
{    GenLDC
{    EPush
{    StrgType
{    GetBounds
{    ByteArray
{    LoadAddress
{
{ Design:
{    Parameters passed{    QGen0
{    EPop
{    GenSysCall
{-----------------------------------}
      begin
      NextVar;
      if GAttr.TyPtrPas
{
{-------------------------------------------------}

{ }
{ 19-Mar-81  2.6  Miles A. Barel
{ RECAST Bug Fix
{ }
{  <> nil then
          with GAttr.TyPtr^ do
              if Form = Files then
                  begin
                  Par04-Feb-81  2.0  Miles A. Barel
{ Implementation of Long Integers
{ }
{ 13-Jan-81  1.11  Miles A. Barel
{ Bug Fix - functions 2  	
;

procedure EntSpcProcs;
{----------------------------
{ Abstract:
{    Define the Instrinsic Procedures and Functions (ao
                begin
                Name := NA[i];
                IdNum:=NextINum;
                if i in [3,7,10..11,long with Function Types)
{
{ Calls:
{    EnterId
{    NextINum
{----------------------------}
    const NumSpcProcs = 43;14..15,23..25,43] then
                    IdType:=IntPtr
                else if i in [12,34,35] then
                    Id
    var i: integer; IsFunc: boolean; CID:Identifier;
        NA: array [1..NumSpcProcs] of Alpha;
  begin
    NA[ 1] := 'PRType:=BoolPtr
                else if i in [13] then
                    IdType:=CharPtr
                else
              ED    '; NA[ 2] := 'SUCC    '; NA[ 3] := 'ORD     ';
    NA[ 4] := 'SQR     '; NA[ 5] := 'ABS     '; NA[ 6] := 'NEW     ';
         IdType:=nil;
                if IsFunc then Klass := Func else Klass := Proc;
                Key := i
                 with CID do
      for i:=1 to 6 do
          begin
          IdNum:=NextINum;
          case i of
            1: begin
   NA[ 7] := 'LENGTH  '; NA[ 8] := 'EXIT    '; NA[ 9] := 'RECAST  ';
    NA[10] := 'TRUNC   '; NA[11] := 'WORDSIZE'; NA[12] := 'O             Name:='        ';  IdType:=nil;
               Klass:=Types;  UTypPtr:=IdNum;
               end;
      
      DD     ';
    NA[13] := 'CHR     '; NA[14] := 'ROUND   '; NA[15] := 'LXOR    ';
    NA[16] := 'STARTIO '; NA[17] := 'RASTEROP'      2: begin
               Next:=0;  Values.IVal:=0;
               Klass:=Konst;  UCstPtr:=IdNum;
               end;
  ; NA[18] := 'INLINEBY';
    NA[19] := 'INLINEWO'; NA[20] := 'INLINEAW'; NA[21] := 'SHIFT   ';
    NA[22] := 'ROTATE  '; NA[23]             
            3: begin
               VLev:=Level;  VAddr:=0;
               Klass:=ActualVars;  UVarPtr:=IdNum; := 'LAND    '; NA[24] := 'LOR     ';
    NA[25] := 'LNOT    '; NA[26] := 'LOADEXPR'; NA[27] := 'LOADADR ';
    NA[28] := 'STO
               end;
               
            4: begin
               FldAddr:=0;  Klass:=Field;
               UFldPtr:=REXPR'; NA[29] := 'MAKEPTR '; NA[30] := 'MAKEVRD ';
    NA[31] := 'DISPOSE '; NA[32] := 'RESET   '; NA[33] := 'REWRITE ';
    IdNum;
               end;
               
            5: begin
               ForwDecl:=false;  InScope:=false;
          NA[34] := 'EOF     '; NA[35] := 'EOLN    '; NA[36] := 'GET     ';
    NA[37] := 'PUT     '; NA[38] := 'READ    '; NA[39] := 'WR     LocalLC:=0;
               PFLev:=Level;  PFName:=0;  PFSeg:=0;
               Klass:=Proc;  PFDecKind:=Declared;
      ITE   ';
    NA[40] := 'READLN  '; NA[41] := 'WRITELN '; NA[42] := 'CLOSE   ';
    NA[43] := 'SHORT   ';
        
    with C         PFKind:=Actual;  UPrcPtr:=IdNum;
               end;
               
            6: begin
               Klass:=FunID do
        begin
        Next:=0; PFDecKind:=Special;
        end {with};
    for i := 1 to NumSpcProcs do
        if NAc;  UFctPtr:=IdNum;
               end
            end {case};
        WriteNum(CID);
        end {for}
  end { EntUndecl }[i] <> '        ' then
            begin
            IsFunc := i in [1..5,7,9..15,21..25,29,34,35,43];
            with CID d 2 	
                   LoadAddress;
                                          QGen1(LDMW,VRDSize);
                                                   QGen1(ADJ,LSP^.Size);
                                  EPop(1);
                                  QGen0(L by reference (VAR parameters) must be passed by
{    virtual address
{--------------------------------------------}
                   EPop(1);
                                          QGen0(MES2);
                                          QGen0(MESvar LSP: STP; LB,WasResult: boolean; LMin, LMax: integer;
            LCP1: Identifier;
      begin
      while Node <> nil d2);
                                          QGen0(EXCH);
                                          QGen0(EXCH2);
          o
          begin
          if LCP.Klass in [Proc,Func] then
              begin
              if Node^.LLink <> nil then
                                 QGen0(EXCH);
                                          QGen0(MMS2);
                                           with Node ^.LLink^ do
                      if EType = Opnd then
                          if OpClass = Idd t                QGen0(MMS2)
                                          end
                             end
              endhen
                              begin
                              LookupNum(IIdent,LCP1);
                              w
          else
              begin
              LSP:=LCP.IdType;
              if LSP <> nil then
                begin
 ith LCP1 do
                                  if Klass in [Proc,Func] then
                                      if PFKind = A               if LCP.Klass = ActualVars then
                  begin
                  { expansion of value parameters }
   ctual then
                                          begin
                                          QGen3(LVRD,PFSeg,PFName,P               if LSP^.Form <= Power then
                      begin
                      { Scalars : Integer, Real, CharactFLev+1);
                                          QGen0(MMS2);
                                          QGen0(MMS2)
       er, Boolean, Long }
                      { SubRange }
                      { Pointer  }
                      { PowerSet }                                   end
                                      else
                                          be
                      ExpExpression(Node^.LLink);
                      Node^.LLink:=nil;
                      if GAttr.TyPtgin
                                          with GAttr do
                                              begin
             r <> nil then
                          begin
                          LB := CompTypes(GAttr.TyPtr,CharPtr) and
                                             Kind := VRDVarbl;
                                              VLevel := PFLevel;
                              (GAttr.Kind = Cst);
                          LoadExpr;
                          case GAttr.TyPtr^.Form o                                    Dplmt := PFAddr
                                              end;
                       f
                              
                              Power:
                                  begin
               3  	
of this routine in its code segment
{
{ Side Effects:
{    Modifies the array ROUTINE
{---------------------------}
    beg---------------
{ Abstract:
{    Initialize simle global scalars, allocate a buffer 256 words long,
{    aligned on a 256 worin
    Routine[R].Pkg := P;
    Routine[R].Rtn := N
    end { Rtn };

  begin { EntSysCalls }
    with Package[Dynamic] dd boundary for general disk IO, allocate the
{    code buffer
{
{ Calls:
{    New
{    CreateSegment
{--------------------o
         begin
         Seg := 0;
         ModNam := 'DYNAMIC ';
         FilNam:=Concat('DYNAMIC',DefIExtension)
       --}
   var i,j:integer;
  begin
  { set up symbol table stuff }
  UniqueId:=MinId-1;
  ErrNum:=0;
  ErrLine:=-10;
  ErrOn  end;
    with Package[Stream] do
         begin
         Seg := 0;
         ModNam := 'STREAM  ';
         FilNam:=ConcatLine:=false;
  FwPtr := 0;
  ExitFunc:=false;
  LineInfo := 0;
  LC := 0;
  DP := true;
  New(SConst,Strg);
  SConst^.STy('STREAM',DefIExtension)
         end;
    with Package[Reader] do
         begin
         Seg := 0;
         ModNam := 'REp:=DefCst;
  CreateSegment(CodeSeg,DefCodeSize,1,MaxCodeSize); { create buffer for }
  CodeP:=MakePtr(CodeSeg,0,pCodeArray);  ADER  ';
         FilNam:=Concat('READER',DefIExtension)
         end;
    with Package[Writer] do
         begin
                    { code generation   }
  CodeSize:=DefCodeSize;
  MaxCode:=DefCodeSize*512-1;
  New(0,256,DiskBuf);
  Level:=MainLSeg := 0;
         ModNam := 'WRITER  ';
         FilNam:=Concat('WRITER',DefIExtension)
         end;
    Rtn(PNew,Dynamic,ex - 1;
  Seg :=MainSeg; NextSeg := MainSeg+1; LastSeg:=MaxSeg+1;
  CurBlk := 1; CurByte := SegLeadIn;
  Exporting:=false;
 end {with};
            EnterId(CID);
            end {for}
  end { EntSpcProcs };

procedure EntSysCalls;
{-------------0);
    Rtn(PDispose,Dynamic,1);
    Rtn(PStreamInit,Stream,0);
    Rtn(PStreamOpen,Stream,1);
    Rtn(PStreamClose,Stream,2--------------
{ Abstract:
{    Define system call procedures (Those segments and procedures which are
{    implicitly import);
    Rtn(PGetB,Stream,3);
    Rtn(PPutB,Stream,4);
    Rtn(PGetC,Stream,5);
    Rtn(PPutC,Stream,6);
    Rtn(PReedln,Streed if the client attempt to use their contents
{
{ Calls:
{    Rtn
{    Concat
{----------------------------}

proceduream,7);
    Rtn(PRiteln,Stream,8);
    Rtn(PRdBoolean,Reader,0);
    Rtn(PRdCh,Reader,1);
    Rtn(PRdChArray,Reader,2);
     Rtn(R: RoutineName; P:PackageName; N:ProcRange);
{---------------------------
{ Abstract:
{    Place an individual system roRtn(PRdIdentifier,Reader,3);
    Rtn(PRdInteger,Reader,4);
    Rtn(PRdString,Reader,5);
    Rtn(PRdX,Reader,6);
    Rtn(PWrButine in the system call definition table
{    (ROUTINE)
{
{ Parameters:
{    R - The logical routine number being defined (oolean,Writer,0);
    Rtn(PWrCh,Writer,1);
    Rtn(PWrChArray,Writer,2);
    Rtn(PWrIdentifier,Writer,3);
    Rtn(PWrIntegerused within the compiler)
{    P - The internal Id of the segment containing the routine
{    N - The physical routine number ,Writer,4);
    Rtn(PWrString,Writer,5);
    Rtn(PWrX,Writer,6)
  end { EntSysCalls };
 
procedure InitScalars;
{-------- 3 	
yPtr,IntPtr) and
                                    CompTypes(LSP,RealPtr) then
                                      begin
             end
                      end
                  else { Form > Power }
                      begin
                                                   QGen0(FLT);
                                      EPop(1);
                                      { open a hole for the parameters in the callee's }
                      { stack }
                      QGen0(LDTP);         EPush(Data32);
                                      GAttr.TyPtr := RealPtr
                                      end EPush(Off20);
                      if ByteArray(LSP) then
                          begin
                          GenLDC(
                                  else
                                      if LB and StrgType(LSP) then
                  0); EPush(Data16);
                          end;
                      QGen1A(ATPB,LSP^.Size);
                      { now gDTP);
                                  EPush(Off20);
                                  GenLDC(LSP^.Size);
                                          GAttr.TyPtr := StrgPtr;
                                  if GAttr.TyPtr^.Size = 2 then
                              QGen0(SBI);
                                  QGen0(REPL);
                                  EPush(Off20);
                          begin
                                      QGen0(MMS2);
                                      EPop(2)                                QGen0(LDTP);
                                  EPush(Off20);
                                 
                                      end
                                  else
                                      begin QGen1A(ATPB,LSP^.Size);
                                  QGen0(EXCH);
                                  QGen1A(MOVB,LSP^.Siz
                                      if RangeCheck^.Sw then
                                          if not CompTypes(LSP,Ie);
                                  EPop(2);
                                  QGen1(STMW,LSP^.Size);
                     ntPtr) then
                                              begin
                                              GetBounds(LSP,LM             EPop(1)
                                  end;
                          
                              Pointr:in,LMax);
                                              GenLDC(LMin);
                                              GenLDC(LMa
                                  begin
                                  QGen0(MMS2);
                                  EPopx);
                                              QGen0(CHK)
                                              end;
             (2)
                                  end;
                                  
                              Scalar,
                                 QGen0(MMS);
                                      EPop(1)
                                      end
                      SubRange:
                                  begin
                                  if CompTypes(GAttr.T                                  end
                              
                              end { case }
              4  	
---}
  begin
  STypeBegSys:= [AddOp,IntConst,RealConst,StringConst,Ident,NotSy,LParent];
  TypeBegSys := [Arrow,PackedSy,Arra and switches  }
Level := MainLex - 1;
EntStdTypes;          { create std types }
EntStdNames;          { and standard names;ySy,RecordSy,SetSy,FileSy] + STypeBegSys;
  TypeDels := [ArraySy,RecordSy,SetSy,FileSy];
  BlockBegSys := [ImportSy,LabelSy,Co names of std types, etc }
EntSpcProcs;          { enter std system proc/func's in symbol table }
EntAllException;      { entenstSy,TypeSy,VarSy,ProcSy,FuncSy,BeginSy];
  SelectSys := [Arrow,Period,LBrack];
  FacBegSys := [IntConst,RealConst,StringConsr the ALL exception in the symbol table }
EntSysCalls;          { initialize system call descriptor tables }
Level := MainLex;t,Ident,
                LParent,LBrack,NotSy];
  StatBegSys := [BeginSy,GotoSy,IfSy,WhileSy,RepeatSy,ForSy,WithSy,CaseSy];
 
EntUndecl;            { create undefn'd obj of each type - for err recovery }
if Sy = ProgSy then
    begin
    EntInOut;   Vars := [FormalVars,ActualVars]
  end { InitSets } ;
  
begin { CompInit }
TitleStr:=Concat('PERQ Pascal Compiler  ',Versi           { create pre-defined files Input and Output }
    CurProc:=0;
    NextProc:=1;
    IsProgram:=true
    end
else onString);

ChangeTitle(TitleStr);

CurHeap:=0;                     { Start be using default data segment for the
         if Sy = ModSy then
    begin
    CurProc:=-1;
    NextProc:=0;
    IsProgram:=false
    end
else
    begin
    Error(3);                         heap }
ParseCmdLine;                   { command parse & open Input/Output Files }
ChangeTitle(Concat
    Exit(PascalCompiler)
    end;
InSymbol;       { get ride of PROGRAM/MODULE and get name of 'whatever' }
If Sy = Ident t(Concat(TitleStr,'   '),OutFileName));
GlobTestP:=nil;
SymFile:=FSEnter(STFileName);   { open the symbol table file }
LastWrihen  { the Program/Module name }
    begin
    LinkList[0].ModName:=Id;
    with CID do
        begin
        Next:=0;     tten:=-1;                { no blocks of the symbol table have been
                                  written into yet! }
Rewri           { no parameters }
        Name:=Id;               { procedure/module name }
        IdNum:=NextINum;
        Next:te(PDFile,PDFileName);     { create the procedure dictionary file }
TotalErrors:=0;
InitSearch;                     { reserved=0;                { no parameters }
        IdType:= nil;           { procedure/module has no type }
        if IsProgram the BPTOnLine := false;
  PrtErr := true;
  GetStmtLev := true;
  BegStmtLev := 0;
  ETos:=0;
  NextPEnter:=SegLeadIn;
  PrsF word list }
InitScalars;                    { initial general scalar values }
InitSets;                       { initialize usilNam := false;
  for i:=0 to HashLevels do
      for j:= 0 to HashMax do
          HashTable[i,j]:=0
  end { InitScalars };eful sets }
InitQCodes;
Top := 0;                       { initial top of 'Display' }
with Display[0] do
    begin
    FName

procedure InitSets;
{-----------------------
{ Abstract:
{    Initialize special sets of Symbols
{--------------------- := 0; ForwCount:=0; FFile := 0;
    FLabel := nil; Occur := Blck
    end;
InSymbol;             { Scan off openning comments 4 	
                  GenLDC(0);  EPush(Data16);
                                      GenLDC(LSP^.MaxLeng); EPush(Data16);
                           end;
                              if WasResult then QGen1A(ATPB,-Size)
                              end                                QGen0(SAS);
                                      EPop(5)
                                    
                          end
                      end
                  end
              else { Klass = FormalVars }
    end
                                  else
                                      begin
                                                    begin
                  { Keep track of where we began, so we'll know if we need to }
                  { de-r  with LSP^ do
                                          if InxType <> nil then
                                              eference the parameter to a virtual address. NOTE: If }
                  { you haven't figured it out yet, Parameters passed bbegin
                                              GetBounds(InxType,LMin,LMax);
                                            y }
                  { reference must be passed by virtual address! }
                  StartTos:=ETos;  { ExpExpression does  if LB then
                                                  { Convert string const to a
                                    not set StartTos }
                  ExpExpression(Node^.LLink);
                  Node^.LLink:=nil;
                  Param                 PA of Char }
                                                  begin
                                        Addr(true);
                  if GAttr.TyPtr <> nil then
                      if LSP <> nil then
                          iet the actual parameter }
                      ExpExpression(Node^.LLink);
                      Node^.LLink:=nil;
                   GenLDC(1);{ make a byte ptr }
                                                  GAttr.TyPtr:=LSP
                                if GAttr.TyPtr <> nil then
                          begin
                          LB := StrgType(GAttr.TyPtr)                                end
                                              else
                                           { A string constant? }
                                  and (GAttr.Kind = Cst);
                          WasResult := GAt          GenLDC(0);{ make a byte ptr }
                                              EPush(Data16);
                         tr.Kind = Result;
                          LoadAddress;
                          with GAttr.TyPtr^ do
                                          QGen1A(MVBB,LMax-LMin+1);
                                              EPop(4)
                                  begin
                              if ByteArray(LSP) then
                                  if LSP^.AIsStrng then
                      end
                                      end
                              else
                                                            begin
                                      { Get a string pointer }
                               begin
                                  QGen1A(MOVB,Size);
                                  EPop(2)
              5  	
n
            begin
            Klass:=Proc;        { we've got a procedure by this name }
            PFDecKind:=Declared;{ Computer Corporation
{
{ Abstract:
{    Code Generating Procedures
{
{ File:
{    Codegen.Pas
{
{-----------------------it's an actual procedure }
            PFName:=CurProc;    { and this is it's number }
            PFSeg:=Seg;
            PF---------------------}

{ }
{ 03-Feb-81  2.0  Miles A. Barel
{ Implementation of Long Integers
{ }
{ 9-Jan-81  1.9  MilesLev:=Level;
            PFKind:=Actual;
            LocalLC:=LC;        { ? }
            ForwDecl:=false;    { It's declared A. Barel
{ Now will release space occupied by dynamic string constants after their use
{ }
{ 2-Jan-81  1.6  Miles A. Barel
 right here }
            InScope:=true;      { ? }
            end
        else
            Klass:=Modul;      { only a nam{ Cleanup and institution of standard 3RCC file format stuff
{ }

EXPORTS

  Imports PascalCompiler from Pascal;
  
  tye }
        OuterBlock:=IdNum;
        EnterId(CID)
        end;
    end
else
    Error(2);
Top := Top + 1;
with Displaype
      Nibble = 0..15;
      
  Function  MakeByte(Nibble1,Nibble2: Nibble):integer;
  Procedure GenLDC(IVal: integer);
 [Top] do
    begin
    FName := 0; FFile := 0; ForwCount := 0;
    FLabel := nil; Occur := Blck
    end;
InSymbol;   { remo Procedure QGen0(FOp: AByte);
  Procedure QGen1(FOp: AByte; FP1:integer);
  Procedure QGen1A(FOp: AByte; FP1:integer);
  Procve Prog/Mod name }
if (Sy = LParent) and IsProgram then    { ?? Allow but ignore formal parameter }
    begin                 edure QGen2(FOp: AByte; FP1,FP2: integer);
  Procedure QGen3(FOp: AByte; FP1,FP2,FP3: integer);
  Procedure QGenJmp(FOp: AByte              { list. Just match ( to a )            }
    repeat InSymbol
    until Sy in [RParent,SemiColon]+BlockBegSys;
 ; FLBP: LBP);
  Procedure QGenBJmp(FOp: AByte; FLBP: LBP);
  Procedure QGenCmp(CompareOp,OpndType,ArraySize: integer);
  Func   if Sy = RParent then InSymbol else Error(4)
    end;
if Sy = SemiColon then InSymbol else Error(14);
if Sy = ExportSy thention  SegNumber(ModNam: Alpha; FilNam: String): SegRange;
  Procedure GenSysCall(FR: RoutineName);
  Procedure GenLabel(var FL begin Exporting:=true; InSymbol end;
New(TOS);
with TOS^ do  { make LexStkRec for OuterBlock }
    begin
    PrevLexStackP:BP: LBP);
  Procedure PutLabel(FLBP: LBP);
  Procedure LoadExpr;
  Procedure Store(var FAttr: Attr);
  Procedure LoadAddress=nil;
    BFSy:=Period;
    DFProcP:=OuterBlock;
    DLLC:=LC;
    DOldLev:=Level;
    DOldTop:=Top;
    POldProc:=CurProc;
  Procedure Guard(StartTos: integer);

PRIVATE

  Imports QCodes from QCodes.Dfs;
  Imports ExpandExpression from ExpExp;
    DMarkP:=0;
    CreateSegment(CurHeap,1,1,256);
    CreateSegment(ExpHeap,1,1,256)
    end
end { CompInit }.
        r;
  Imports Memory from Memory;

{$R-}

  const
      MinCst = 0;               { smallest cst loadable by short load conModule CodeGeneration;
{---------------------------------------------
{
{ Code Generator
{ Copyright (C) 1981  Three Rivers stant }
      MaxCst = 15;              { Max cst loadable by short load constant }

function ByteRange(IVal: integer): bool 5 	
end { ExpParam };

begin { ExpCallNonSpecial }
    with FCP do
      begin
      if Klass = Func then 
          if IdTyp end
                      else
                          begin
                          GenByte(MES2);
                   e <> nil then
              QGen1A(ATPB,IdType^.Size);{ make room for the result }
      if Node^.RLink <> nil then        { w       EPush(Data32)
                          end
                  else if Form = Power then
                      begin
 e've got parameters }
          begin
          if FCP.PFKind = Actual then
              LookupNum(FCP.Next,LCP)
                               GenByte(LDTP);
                      EPush(Off20);
                      GenLDC(Size);
                 else
              LookupNum(FCP.PFParms,LCP);
          ExpParam(Node^.RLink)         { expand them }
          end;
           QGen0(SBI);
                      EQuick(1);
                      GenByte(REPL);
                      EPush(Off20);
 { now for the call }
      if PFKind = Actual then
          if PFSeg <> Seg then
              QGen2(CALLXB,PFSeg,PFName)
                      QGen1(LDMW,Size);
                      EPop(1);
                      GenByte(LDTP);
                           else
              QGen1A(CALLL,PFName)
      else
          begin
          with GAttr do
              begin
      EPush(Off20);
                      GenLDC(Size);
                      QGen0(SBI);
                      EQuick(1);
               Kind := VRDVarbl;
              VLevel := PFLevel;
              Dplmt := PFAddr
              end;
          Lo                   QGen1A(MOVB,Size);
                      EPop(2);
                      QGen1A(ATPB,-Size);
              adAddress;
          QGen1(LDMW,VRDSize);
          EPop(1);
          if Odd(VRDSize) then Error(413);
          QGen0(MES2        GenLDC(Size);
                      EPush(Data16);
                      GAttr.Kind:=Expr
                      end
);
          EPush(Data32);
          QGen0(MES2);
          EPush(Data32);
          QGen0(EXCH);
          QGen0(EXCH2);                  else if Form = Arrays then
                      GAttr.Kind:=Result
                  else if Form = Records
          QGen0(EXCH);
          QGen0(CALLV);
          EPop(VRDSize)
          end;
      if Klass = Func then          { then
                      GAttr.Kind:=Result
              end;
      GAttr.TyPtr:=IdType
      end
  end { ExpCallNonSpef LSP^.Form = Power then
                              if GAttr.TyPtr^.Size <> LSP^.Size then
                                 get the result back }
          if IdType <> nil then
              begin
              GAttr.Kind := Expr;
              w  Error(142);
                  QGen0(MMS2);
                  EPop(2)
                  end
                end
          ith IdType^ do
                  if Form in [Scalar,Subrange,Pointr] then
                      if Size = 1 then
                end;
          Node:=Node^.RLink;
          if LCP.Next <> 0 then LookupNum(LCP.Next,LCP)
          end { while }
                    begin
                          GenByte(MES);
                          EPush(Data16)
                          6  	
;
  Trik.Nib2:=Nibble2;
  MakeByte:=ord(Trik.Byt)
  end { MakeByte };

procedure TLCheck(FOp: AByte);
{------------------t <> 15) then
              begin
              { we have some form of tlate here }
              if ((dt = 15) or (st = 15))-------------
{ Abstract:
{    See If a TLATE is required
{
{ Parameters:
{    FOp - The QCode to be generated
{
{ Enviro and (dt + st <= 17) then
                  { we have a TLATE0-2 }
                  GenByte(TLATE0+dt+st-15)
              enment:
{    The TLATE decision is based on the contents of EStack
{
{ Side Effects:
{    Code may be generated and the contelse
                  { need to used STLATE }
                  begin
                  GenByte(STLATE);
                  iean;
{-----------------------
{ Abstract:
{    Determine is a value can be stored in a signed byte
{
{ Parameters:
{    IVnts of EStack may be altered
{
{ Calls:
{    GenByte
{    MakeByte
{-------------------------------}
    var i,st,dt:integal - the value in question
{
{ Results:
{    True if -128 <= IVal <= 127; false otherwise
{------------------------}
  begier;
  begin
  with QCode[FOp] do
      if Dst = 15 then          { at most, a single TLATE }
          begin
          if Sn
  ByteRange:=(IVal >= -128) and (IVal <= 127)
  end { ByteRange };

function UByteRange(IVal :integer):boolean;
{-------rc <> 15 then      { Yes, possible TLATE0-2 }
              if EStack[ETos-Src] <> Off20 then
                  begin
       ----------------
{ Abstract:
{    Determine is a value can be stored in an unsigned byte
{
{ Parameters:
{    IVal - the va           GenByte(TLATE0+Src);
                  EStack[ETos-Src]:=Off20;
                  for i:=ETos-Src+1 to ETos-1 do
 lue in question
{
{ Results:
{    True if 0 <= IVal <= 255; false otherwise
{------------------------}
  begin
  UByteRang                     EStack[i]:=EStack[i+1];
                  EPop(1)
                  end
          end
      else       e:=(IVal >= 0) and (IVal <= 255)
  end { UByteRange };

function MakeByte(Nibble1,Nibble2: Nibble): integer;
{-------------               { possible STLATE }
          begin
          st:=15;
          dt:=15;
          if EStack[ETos-Src] <> Off2-------------
{ Abstract:
{    Pack two nibbles (4 bits) into one byte
{
{ Parameters:
{    Nibble1 - 4 bits to be packed i0 then
              begin
              st:=Src;
              EStack[ETos-st]:=Off20;
              for i:=ETos-st+1 to ETnto bits 4-7 of the byte
{    Nibble2 - 4 bits to be packed into bits 0-3 of the byte
{
{ Results:
{    The byte composed ofos-1 do
                  EStack[i]:=EStack[i+1];
              EPop(1)
              end;
          if EStack[ETos-Dst] <>  the two nibbles
{---------------------------}
    var Trik:packed record
                case boolean of
                  Off20 then
              begin
              dt:=Dst;
              EStack[ETos-dt]:=Off20;
              for i:=ETos-dt+1 t      true: (Byt: 0..255);
                        false:(Nib1,Nib2:Nibble)
               end;
  begin
  Trik.Nib1:=Nibble1o ETos-1 do
                  EStack[i]:=EStack[i+1];
              EPop(1)
              end;
          if (dt <> 15) or (s 6 	
cial };

begin { ExpCall }
  LookupNum(Node^.LLink^.IIdent,FCP);    { get the proc/func identifier }
  NextParm:=Node^.RLin       QGen0(REPL);
                       QGen0(MPI);
                       EQuick(1)
                       end
         k;                { PushParm Opr of first parm (or nil) }
  if FCP.PFDecKind <> Special then
      ExpCallNonSpecial(Node)
            else
                       if COmpTypes(GAttr.TyPtr,RealPtr) then
                           begin
               else
      begin
      LKey := FCP.Key;
      if LKey in [1..33,36..39,43] then
          if NextParm = nil then
                      QGen0(REPL2);
                           QGen0(MPR);
                           EQuick(2)
                           Error(9);
      if LKey in [1..5,10,12..16,21..24,26,29,43] then
          begin
          NextExp;
          LoadExpr
    end
                       else
                           begin Error(125); GAttr.TyPtr := IntPtr end;
               
          end;
      if LKey in [6,8,11,21..25,30..42] then
          ExpRoutine(LKey)
      else
          case LKey of
                  5: begin { Abs }
                   if CompTypes(GAttr.TyPtr,IntPtr) then
                       QGen0(ABI)
             1,2: begin        { PredSucc }
                   GenLDC(1);
                   EQuick(1);
                   if                   else
                       if CompTypes(GAttr.TyPtr,RealPtr) then
                           QGen0(ABR)
  GAttr.TyPtr <> nil then
                       if GAttr.TyPtr^.Form = Scalar then
                           if LKey = 2 then                     else
                           begin Error(125); GAttr.TyPtr := IntPtr end
                   end { Abs 
                               QGen0(ADI)
                           else
                               QGen0(SBI)
        };
               
                7: begin { Length }
                   NextStrgVar(false);
                   GenLDC(0);                else
                           Error(115)
                   end { PredSucc };
                
              EPush(Data16);  { make byte ptr to length byte }
                   QGen0(LDB);
                   EPop(2);
                   3: begin { Ord }
                   if GAttr.TyPtr <> nil then
                       if GAttr.TyPtr^.Form >= Pointr then    EPush(Data16);
                   GAttr.TyPtr := IntPtr
                   end { Length };
                   
         
                           Error(125)
                       else
                           if GAttr.TyPtr^.Size <> 1 then
       9: begin { Recast }
                   NextExp;
                   if NextParm <> nil then
                       with                               Error(125);
                   GAttr.TyPtr := IntPtr
                   end { Ord };
          NextParm^ do
                           begin
                           if EAttr.TyPtr^.Size = GAttr.TyPtr^.Size then
           
                4: if CompTypes(GAttr.TyPtr,IntPtr) then         { SQR }
                       begin
                                          GAttr.TyPtr:=EAttr.TyPtr
                           else
                               Error(173); 7  	

      end
  else
      begin
      GenByte(LDCW);
      GenNAWord(IVal)
      end
  end { GenLDC };

procedure QGen0(FVal.ValP^.CstVal[I] <> 0 then
                  goto 1
              else
                  I := I - 1;
1:        end;
    Op: AByte);
{-----------------------
{ Abstract:
{    Generate QCodes which have no parameters.
{
{ Parameters:
{    FOp -  GAttr.TyPtr^.Size := I;
      if I = Double then
          GenByte(LDDC)
      else
          GenByte(LDMC);
      if I > the QCode to be generated
{
{ Side Effects:
{    Code is generated
{
{ Calls:
{    TLCheck
{    GenByte
{    Dispose
{ 1 then
          begin
          if I <> Double then GenByte(I);
          for J := I downto 1 do
              GenNAWord(G
{ Design:
{    Special case QCodes generated here are:
{        LSA
{-----------------------}
    var I: integer;
  beginAttr.CVal.ValP^.CstVal[J])
          end
      else
          begin
          IC := IC - 1;
          if I = 1 then GenLDC(
  TLCheck(FOp);
  GenByte(FOp);                 { output the qcode }
  if FOp = LSA then
      with GAttr.CVal.ValP^ do
  GAttr.CVal.ValP^.CstVal[1])
          end
      end
  else if (FOp in [LDMW,STMW]) then
      begin
      GenLDC(FP1);
           begin
          if odd(IC) then IC:=IC+1;
          GenByte(SLgth);
          for I := 1 to SLgth do GenByte(ord(SVal   EPush(Data16);    { Push Word Count }
      TLCheck(FOp);
      GenByte(FOp);
      EPop(1)      { Pop ONLY Word Count herf st = 15 then st := 0 else st := st + 1;
                  if dt = 15 then
                      dt := 0
                  e[I]));
          if STyp = DynCst then Dispose(GAttr.CVal.ValP,Strg)
          end
  end { Gen0 };

procedure QGen1(FOp: Alse
                      if st <> 0 then
                          dt:=dt + 2
                      else
                  Byte; FP1: integer);
{------------------------
{ Abstract:
{    Generate QCodes which have one argument
{
{ Parameters:
{         dt := dt + 1;
                  GenByte(MakeByte(dt,st))
                  end
              end
          end
  en   FOp - the QCode to be generated
{    FP1 - the argument to go with it
{
{ Side Effects:
{    Code is generated
{
{ Calld { TLCheck };

procedure GenLDC(IVal: integer);
{---------------------
{ Abstract:
{    Generate Load Constant QCodes
{s:
{    TLCheck
{    GenByte
{    GenNAWord
{    GenLDC
{    EPush
{    EPop
{
{ Design:
{    Standard QCodes handled h
{ Parameters:
{    IVal - the constant to be loaded
{
{ Side Effects:
{    Code is generated
{
{ Calls:
{    GenByte
{ ere are: ADJ, CALL
{    Special cases are: LDDC, LDMC, LDMW, STMW
{------------------------}
    label 1;
    const Double =   GenNAWord
{    ByteRange
{---------------------}
  begin
  if IVal in [MinCst..MaxCst] then
      GenByte(IVal)
  else  2;     { number of words in 2 words }
    Var I,J: integer;
  begin
  if FOp = LDMC then
      begin
      if FP1 = Doubleif IVal = -1 then
      GenByte(LDCMO)
  else if ByteRange(IVal) then
      begin
      GenByte(LDCB);
      GenByte(IVal) then
          I := Double
      else
          begin
          I := 8;
          while I > 0 do
              if GAttr.C 7 	
                        Error(125)
                       else
                           if GAttr.TyPtr^.Size <> 1 then
           NextExp;
                       LoadExpr;
                       if not CompTypes(GAttr.TyPtr,IntPtr) then
                                      Error(125);
                   GenLDC(1);   { Insure value of true or false is 0 or 1 }
                           Error(125)
                       end;
                   { get DArea }
                   NextExp; LoadExpr;        QGen0(QAND);
                   GAttr.TyPtr:=BoolPtr { true,odd is 1, false is 0 }
                   end;            
                   if GAttr.TyPtr <> nil then
                       if GAttr.TyPtr^.Form <> Pointr then
                   
                           NextParm:=NextParm^.RLink
                           end
                   else
                     { wasn't that easy?? }
               
               13: begin { Chr }
                   if GAttr.TyPtr <> nil then
        Error(126)
                   end { RECast };
                   
            10,14: begin { Trunc, Round }
                               if GAttr.TyPtr^.Form >= Pointr then
                           Error(125)
                       else
           if CompTypes(GAttr.TyPtr,RealPtr) then
                       begin
                       if LKey = 10 then
                                if GAttr.TyPtr^.Size <> 1 then
                               Error(125);
                   GAttr.T                     QGen0(TNC)
                       else
                           QGen0(RND);
                       EPoyPtr := CharPtr
                   end;
                   
               15: begin { LXOR }
                   if not Compp(2);
                       EPush(Data16)
                       end
                   else
                       Error(1Types(GAttr.TyPtr,IntPtr) then
                       Error(125);
                   NextExp;
                   LoadExpr;
 25);
                   GAttr.TyPtr := IntPtr
                   end;
                   
               43: begin { Short }                  if not CompTypes(GAttr.TyPtr,IntPtr) then
                       Error(125);
                   QGenCmp(NEQ,
                   if GAttr.TyPtr = LongPtr then
                       begin
                       QGen0(SHRKL);
        CBool,BoolSize);
                   EPop(IntgrSize)
                   end;
                   
               16: begin { S               EPop(2);
                       EPush(Data16)
                       end
                   else
            TARTIO }
                   if not CompTypes(GAttr.TyPtr,IntPtr) then Error(125);
                   QGen0(STRTIO);
                    Error(125);
                   GAttr.TyPtr := IntPtr
                   end;
                   
               1          EPop(1)
                   end;
                   
               17: begin { Raster Op }
                   { ge2: begin { Odd }
                   if GAttr.TyPtr <> nil then
                       if GAttr.TyPtr^.Form >= Pointr then
   t Function, Width, Height, DX, DY, DSLen }
                   for i:= 0 to 5 do
                       begin
                 8  	
ith it
{
{ Side Effects:
{    Code is generated
{
{ Calls:
{    ByteRange
{    UByteRange
{    TLCheck
{    GenByte
{  end
      else
          begin
          TLCheck(FOp+1);
          GenByte(FOp+1);
          GenNAWord(FP1)
          end   GenNAWord
{    GenLDC
{    EQuick
{    EPush
{    EPop
{
{ Design:
{    The QCode opcode assignments of all QCodes whi
  end { Gen1A };

procedure QGen2(FOp: AByte; FP1,FP2: integer);
{----------------------------
{ Abstract:
{    Generatech have both a Byte
{    and Word form are assigned sequentially, with the byte version being
{    one less than the word vers QCodes with two arguments
{
{ Parameters:
{    FOp - the QCode to be generated
{    FP1 - the first argument
{    FP2 - thion (i.e., LOAW = LOAB + 1).
{    Standard cases: LLA, LOA, INC
{    Special cases: LDL, LDO, STL, STO, IND, IXA, MOV, MVB, ATe second argument
{
{ Side Effects:
{    Code is generated
{
{ Calls:
{    GenByte
{    MakeByte
{    GenNAWord
{    QGP
{-----------------------------}
  begin
  if FOp = ATPB then
      if ByteRange(FP1) then
          begin
          GenBen1A
{    UByteRange
{
{ Design:
{    None of these QCodes ever need TLATEs
{    Special cases: LDI, LIA, STI, CALLX, IXP, yte(FOp);
          GenByte(FP1)
          end
      else
          begin
          EQuick(1);
          GenLDC(FP1);
   LGA, LDG, STG, EXIT
{------------------------------}
  begin
  if FOp = IXP then
      begin
      GenByte(FOp);
      Gen       GenByte(FOp+1)
          end
  else if UByteRange(FP1) then
      { ALL other Special Case fit into this catagory }
 Byte(MakeByte(FP1,FP2))
      end
  else if FOp = CALLXB then
      begin
      if UByteRange(FP1) then
          begin
       begin
      if ((FOp in [LDLB,LDOB]) and (FP1 <= 15)) or
         ((FOp in [STLB,STOB]) and (FP1 <= 7)) then
          G        GenByte(FOp);
          GenByte(FP1);
          GenByte(FP2)
          end
      else
          begin
          GeenByte(FOp+FP1+2)            { These never get TLATEd }
      else if ((FOp = INDB) and (FP1 <= 7)) then
          begin
    nByte(FOp+1);
          GenNAWord(FP1);
          GenByte(FP2)
          end
      end
  else if FOp = EXITT then { This ise }
      end
  else          { the standard case - none of these every get TLATEd }
      begin
      GenByte(FOp);
            TLCheck(FOp+FP1+2);
          GenByte(FOp+FP1+2)
          end
      else if ((FOp = IXAB) and (FP1 <= 4)) then
      GenByte(FP1)
      end
  end { Gen1 };

procedure QGen1A(FOp: AByte; FP1: integer);
{----------------------------
{ Abstr    GenByte(FOp+FP1+1)    { This never gets TLATEd }
      else
           begin
           TLCheck(FOp);
           GenByteact:
{    Generate QCodes with one argument where the variant of the QCode used
{    is dependant on the argument to go with i(FOp);
           GenByte(FP1)
           end
      end
  else
      if FOp in [MOVB,MVBB,IXAB] then
          begin
    t (byte or word range)
{
{ Parameters:
{    FOp - The BYTE form of the QCode to be generated
{    FP1 - The argument to go w      EPush(Data16);
          GenLDC(FP1);
          TLCheck(FOp+1);
          GenByte(FOp+1);
          EPop(1)
          8 	
   if (Kind = Cst) and CompTypes(TyPtr,IntPtr) then
                           case LKey of
                               18:r(126)
                   end
            end { Special Cases };
      if NextParm <> nil then Error(126); { Gee! Extra param GenByte(CVal.IVal);
                               19: GenNAWord(CVal.IVal);
                               20: GenWord(CVal.eters! }
      if LKey <> 9 then GAttr.Kind := Expr
      end; { Special Procedures and Functions }
  if FCP.Klass <> Func thIVal)
                             end {case}
                       else
                           Error(125)
            en
      GAttr.TyPtr := nil
 end { ExpCall };
                                                                                      end;
                   
               26: ETos:=0;     { LoadExp }
                   
               27: begin         { LoadAdr }
                   NextExp;
                   LoadAddress;
                   ETos:=0
                   en{-------------------------------------------
{
{ Expression Expansion  Part D
{ Copyright (C) 1981  Three Rivers Computer Cord;
                   
               28: begin        { StoreExp }
                   ETos:=15;    { To prevent EStack Underporation
{
{ Abstract:
{    The last portion of expression expnsion - deals primarily with operator
{    expansion
{
{ Fil        Error(142);
                   { get SX, SY, SSLen }
                   for i:= 0 to 2 do
                       begiFlo }
                   NextExp;
                   if StartTos <> ETos then Error(125);
                   Store(GAttr);
 n
                       NextExp;
                       LoadExpr;
                       if not CompTypes(GAttr.TyPtr,IntPtr                  ETos:=0
                   end;
                   
               29: begin        { MakePtr }
          ) then
                           Error(125)
                       end;
                   { get SArea }
                           if not CompTypes(GAttr.TyPtr,IntPtr) then Error(125);
                   NextExp;
                   LoadExpr;
      NextExp; LoadExpr;
                   if GAttr.TyPtr <> nil then
                       if GAttr.TyPtr^.Form <> Pointr then
              if not CompTypes(GAttr.TyPtr,IntPtr) then Error(125);
                   if NextParm <> nil then
                                          Error(142);
                   QGen0(STLATE);
                   GenByte(#141 {6,,1} );
                  with NextParm^ do
                           begin
                           if EAttr.TyPtr^.Form = Pointr then
             QGen0(RASTOP);
                   EPop(13)
                   end;
                   
         18,19,20: begin                               GAttr:=EAttr
                           else
                               Error(125);
              { InLineByte, InLineWord, InLineAWord }
                   NextExp;
                   with GAttr do
                                     NextParm:=NextParm^.RLink
                           end
                   else
                       Erro 9  	
n { LDI, LIA, STI, LDG, LGA, STG }
      if FP1 = 0 then
          { Convert to LDL, LLA or STL }
          case FOp of
    eal multiword, etc.)
{    ArraySize - The size of the type (for multiword structures only)
{
{ Side Effects:
{    Code is ge          LDIB: QGen1A(LDLB,FP2);
              LIAB: QGen1A(LLAB,FP2);
              STIB: QGen1A(STLB,FP2)
            end nerated
{
{ Calls:
{    UByteRange
{    TLCheck
{    GenByte
{    GenLDC
{
{ Design:
{    Once again, the opcode assign{ case }
      else if UByteRange(FP1) then
          begin
          if UByteRange(FP2) then
              begin
         ment of the comparison opcodes is extremely
{    important.
{--------------------------------}
    var FOp:AByte;
        Sa     GenByte(FOp);
              GenByte(FP1);
              GenByte(FP2)
              end
          else
              beveIC:integer;
        SaveTL:packed record
                  Opr: 0..255;
                  case boolean of
                gin
              GenByte(FOp+1);
              GenByte(FP1);
              GenNAWord(FP2)
              end
          end      true: (Opnd: 0..255);
                      false:(Arg1,Arg2:0..15)
                    end;
  begin
  FOp:=EQUBool + 
      else
          Error(399)
      end
  end { Gen2 };

procedure QGen3(FOp: AByte; FP1,FP2,FP3: integer);
{---------CompareOp + (OpndType*6);
  if OpndType in [CByte,CWord] then
      begin
      if ArraySize = 0 then
          begin
     -------------------
{ Abstract:
{    Generate QCodes with three arguments
{
{ Parameters:
{    FOp - the QCode to be genera     Error(305);
          ArraySize:=1
          end;
      if UByteRange(ArraySize) then
          begin
          TLChected
{    FP1 - the first argument
{    FP2 - the second argument
{    FP3 - the third argument
{
{ Side Effects:
{    Codek(FOp);
          GenByte(FOp);
          GenByte(ArraySize)
          end
      else
          begin
          SaveIC:=IC is generated
{
{ Calls:
{    GenByte
{    GenNAWord
{
{ Design:
{    None of these QCodes ever need TLATEs
{    Special;
          TLCheck(FOp);
          case IC-SaveIC of       { must be 0,1 or 2 }
          
           0: { No translates we cases: LVRD, RAISE, ENABLE
{------------------------------}
  begin
  GenByte(FOp);
  GenNAWord(FP1);
  GenByte(FP2);
  ire generated }
              SaveTL.Opr:=0;
              
           1: { Simple TLATE0-2 }
              begin
          f FOp = QRAISE then
      GenNAWord(FP3)
  else {LVRD, ENABLE}
      GenByte(FP3)
  end { Gen3 };

procedure QGenCmp(Comp    IC:=SaveIC; { backup to the TLATE Q-Code }
              {$R-}
              SaveTL.Opr:=ord(CodeP^[IC]);
              {areOp,OpndType,ArraySize: integer);
{--------------------------------
{ Abstract:
{    Generate Comparison QCodes
{
{ Param$R=}
              end;
              
           2: { A STLATE }
              begin
              IC:=SaveIC; { backup to the standard case }
      begin
      GenByte(FOp);
      GenNAWord(FP1);
      GenByte(FP2)
      end
  else
      begieters:
{    CompareOp - The comparison to be performed (<, =, etc.)
{    OpndType - The basic form of the operands (integer, r 9 	
ill be generated
{    Alters GAttr
{
{ Calls
{    QGen0
{    EPop
{    EPush
{---------------------------}
begin
QGen0(tch: boolean; Son: ESP;

procedure ExpFactor(Node: ESP);
{-----------------------------------
{ Abstract:
{    Expansion oFLT);
EPop(1);
EPush(Data32);
GAttr.TyPtr := RealPtr
end { ExpFloat };

procedure ExpStretch;
{-------------------------f Factors - deals mainly with recognition of selectors and
{    procedure calls, expansion of parenthesized expressions, set ex--
{ Abstract:
{    Expand the stretch operator (to convert integers to longs)
{
{ Side Effects:
{    Code will be generatepressions
{    and the NOT operator
{
{ Parameters:
{    Node - the root node of the factor to be expanded
{
{ Side Effectd
{    Alters GAttr
{
{ Calls
{    QGen0
{    EPop
{    EPush
{---------------------------}
begin
QGen0(EXPL);
EPop(1)s:
{    Code may be generated
{
{ Calls:
{    ExpCall
{    ExpSelector
{    LookupNum
{    ExpExpression
{    ExpFactor;
EPush(Data32);
GAttr.TyPtr := LongPtr
end { ExpStretch };

procedure ExpSimpleExpression(Node: ESP);
{-----------------
{    LoadExpr
{    QGen0
{    ExpLBrack
{------------------------------------}
          var LCP: Identifier; LVP: CSP;
  ------------------
{ Abstract:
{    Expansion of Simple Expressions - deals mainly with the +, -, and OR
{    operators
{
{            LSP: STP; LIC,LOp: integer;
              CstPart: set of 0..127;
              LAttr: Attr;

procedure ExpLBra Parameters:
{    Node - the root node of the simple expression to be expanded
{
{ Side Effects:
{    Code will be generatedck(Node: ESP);
{-------------------------------------
{ Abstract:
{    Expansion of set expressions
{
{ Parameters:
{    N
{
{ Calls:
{    ExpSimpleExpression
{    ExpTerm
{    LoadExpr
{    ExpFloat
{    ExpStretch
{    CompTypes
{    QGen0ode - the root of the set expression to be expanded
{
{ Side Effects:
{    Code will be generated
{
{ Calls:
{    GenLDC

{    Error
{    EPop
{------------------------------------}
      var LAttr: Attr; Signed,Float,Stretch: boolean; Son: ESP;{    EPush
{    EPop
{    ExpExpression
{    LoadExpr
{    QGen0
{    ExpLBrack
{-----------------------------------------e: Expr3.Pas
{
{-------------------------------------------}

{ }
{ 06-Feb-81  2.0  Miles A. Barel
{ Implementation of Lo

procedure ExpTerm(Node: ESP);
{-----------------------------------
{ Abstract:
{    Expansion of Terms - deals mainly wing Integers
{ }
{ 13-Jan-81  1.11  Miles A. Barel
{ Bug Fix - non-scalar functions now return temp stack space
{ }
{ 7-Jan-th the *, /, DIV, MOD and AND
{    operators
{
{ Parameters:
{    Node - the root node of the term to be expanded
{
{ Side81  1.6  Miles A. Barel
{ General Cleanup and institution of standard 3RCC file formats
{ }

procedure ExpFloat;
{-------- Effects:
{    Code will be generated
{
{ Calls:
{    ExpTerm
{    ExpFactor
{    LoadExpr
{    ExpFloat
{    ExpStretch-------------------
{ Abstract:
{    Expand the float operator (to convert integers to reals)
{
{ Side Effects:
{    Code w
{    CompTypes
{    QGen0
{    EPop
{    Error
{------------------------------------}
        var LAttr: Attr; Float,Stre :  	
 Code is generated
{
{ Calls:
{    ByteRange
{    GenByte
{    GenNAWord
{
{ Design:
{    Again the Byte/Word opcode asse(FOp+1);
              GenNAWord(OccurIC);
              OccurIC:=IC-2
              end
  end { QGenJmp };

procedure Qignment restrictions (as with QGen1A) hold
{    true.  Currently only backward jumps may utilize Byte Jumps, since
{    for foGenBJmp(FOp: AByte; FLBP: LBP);
{-------------------------------
{ Abstract:
{    Generate jump QCodes where the jump is base the TLATE Q-Code }
              {$R-}
              SaveTL.Opr:=ord(CodeP^[IC]);
              SaveTL.Opnd:=ord(CodeP^[IC+1rward jumps we don't yet know the distance to be jumped.
{-----------------------------------}
    var Disp,SaveIC: integer;
]);
              {$R=}
              end
            end { case };
          GenLDC(ArraySize);
          if SaveTL.Opr <>  begin
  with FLBP^ do
      if Defined then
          { we know where we're jumping - must be backward }
          begin
 0 then         { add one to depth of all translates }
              if SaveTL.Opr in [TLATE0,TLATE1] then
                  G          Disp := OccurIC-IC-2; { assume byte mode for now }
          if ByteRange(Disp) then
              { we can do it thenByte(SaveTL.Opr+1)
              else if SaveTL.Opr = TLATE2 then
                  begin
                  GenByte(STLATE)e short way }
              begin
              GenByte(FOp);
              GenByte(Disp)
              end
          else;
                  GenByte(MakeByte(15,3))
                  end
              else        { Opr was STLATE }
             
              begin
              { must use full word }
              GenByte(FOp+1);
              GenNAWord(Disp-1)           begin
                  GenByte(STLATE);
                  if SaveTL.Arg1 <> 15 then SaveTL.Arg1:=SaveTL.Arg1+1;
          { -1 to compensate for 2 byte offset }
              end
          end
      else
          { jump is forward - will eith           if SaveTL.Arg2 <> 15 then SaveTL.Arg2:=SaveTL.Arg2+1;
                  GenByte(SaveTL.Opnd)
                  end;er by EXGO or JMPW }
          if FOp = EXGO then     { it's an EXIT GOTO }
              begin
              GenByte(EXGO);
          GenByte(FOp);
          GenByte(0)
          end
      end
  else if OpndType = CLong then
      begin
      G
              SaveIC := IC;    { the IC of the Jump Parameters }
              GenNAWord(OccurBlk);  { block of previous ExGo enByte(CMPL);
      GenByte(CompareOp)
      end
  else
      begin
      TLCheck(FOp);
      GenByte(FOp)
      end
  eto this label }
              GenByte(OccurProc);   { proc # of same }
              GenNAWord(OccurOfst); { offset within thend { QGenCmp };

procedure QGenJmp(FOp: AByte; FLBP: LBP);
{-------------------------------
{ Abstract:
{    Generate jump block of same }
              OccurBlk := CurBlk;   { add this jump to the list }
              OccurOfst := SaveIC + CurByte QCodes
{
{ Parameters:
{    FOp - The jump to be generated
{    FLBP - The label to be jumped to.
{
{ Side Effects:
{   
              end
          else
              begin              { it's a local forward jump - JMPW }
              GenByt : 	
                 SNSOp:{ just a null set }
                        begin
                        GenLDC(0);
                 tr.Kind := Result}
                          end
                      else
                          ExpSelector(Node)
           EPush(Data16)
                        end;
                  
                  SRSOp:{ a range set }
                             else
                      if OpClass = Idd then
                          begin
                          Look         begin
                        ExpExpression(RLink);
                        RLink:=nil;
                        LoadupNum(IIdent,LCP);
                          if LCP.Klass <> Konst then
                              ExpSelector(Node)
     Expr;
                        ExpExpression(LLink);
                        LLink:=nil;
                        LoadExpr;
                       end
                  end;
  
      { ( }   LParent:
                  begin
                  ExpExpr                      QGen0(SRS);
                        EPop(1)
                        end;
                        
    ession(Node^.LLink);
                  Node^.LLink:=nil
                  end;
        
      { Not } NotSy:
                            SGSOp:{ a singleton set }
                        begin
                        ExpExpression(RLink);
             with GAttr do
                      begin
                      ExpFactor(Node^.RLink);
                      LoadExpr;
               RLink:=nil;
                        LoadExpr;
                        QGen0(SGS)
                        end;                      QGen0(QNOT)
                      end;
        
      { [ }   LBrack:
                  ExpLBrack(Node
                  
                  UNIOp:{ union of two set types }
                        begin
                        )
              end { case };
            end
        end { ExpFactor };

begin { ExpTerm }
      { A term is either a MuExpLBrack(LLink);
                        ExpLBrack(RLink);
                        QGen0(UNI);
                        EPop(lOp with two sons, which may be either }
      { terms or factors (determined by top node of son), or simply }
      { a facto1)
                        end
                  end { case };
              GAttr:=Node^.EAttr
              end
         r }
      with Node^ do
          if SSy = MulOp then
              begin
              { expand the left son first }
      end { ExpLBrack };

begin { ExpFactor }
        with Node^ do
            begin
            GAttr:=Node^.EAttr;
                 { first remove FltOps from son }
              Float:=false;
              Stretch:=false;
              Son := LLin    case SSy of
      { Id }  Ident:
                  begin
                  if (EType = Opr) then
                      ik;
              while Son^.SSy = ChangeSy do
                  begin
                  if Son^.Opp = FltOp then
           }
          begin
          with Node^ do
              begin
              case Opp of  { must be UNI, SRS, SGS or SNS }
 f (Opp = CallPF) then
                          begin
                          ExpCall(Node);
                          {GAt ;  	
 number will be assigned
{
{ Errors:
{    Too many segments
{
{ Calls:
{    Error
{------------------------------------}ns
{
{ Parameters:
{    FLBP - returns with a pointer to the label
{
{ Environment:
{    There is never code in block 0 of
  label 1;
  var I: integer;
  begin
  I := 0;
  while I < NextSeg do
      with LinkList[I] do
          if (ModName = M the SEG file.  This info is used to
{    indicate the end of an EXGO chain
{
{ Calls:
{    New
{--------------------------odNam) and (FilName = FilNam) then
              begin SegNumber := I; goto 1 end
          else I := I + 1;
  I := LastSeg;----}
  begin
  New(CurHeap,1,FLBP);
  with FLBP^ do
      begin
      Defined := false;         { We don't have an IC for 
  while I <= MaxSeg do
      with LinkList[I] do
          if (ModName = ModNam) and (FilName = FilNam) then
              bthe label yet }
      OccurIC := MaxAddr;       { and there are currently no references to it }
      OccurBlk := 0;          egin SegNumber := I; goto 1 end
          else I := I + 1;
  if NextSeg < LastSeg then
      begin
      with LinkList[NextS  { There is NEVER code in block 0 }
      OccurProc := CurProc;     { Procedure containing the target }
      OccurSeg := Segd on a boolean condition
{
{ Parameters:
{    FOp - The jump to be generated
{    FLBP - The label to be jumped to.
{
{ Sieg] do
          begin
          ModName := ModNam;
          FilName := FilNam
          end;
      SegNumber := NextSeg;de Effects:
{    Code is generated
{    Code to load the current expression will be generated (if needed)
{
{ Errors:
{    
      NextSeg := NextSeg + 1
      end
  else
      begin
      Error(256);
      SegNumber := 1
      end;
  1:
  end Expression is not of type BOOLEAN
{
{ Calls:
{    LoadExpr
{    QGenJmp
{-----------------------------------}
  begin
  L{ SegNumber };

procedure GenSysCall(FR: RoutineName);
{----------------------------
{ Abstract:
{    Generate code to peroadExpr;
  if CompTypes(GAttr.TyPtr,BoolPtr) then
  else Error(135);
  QGenJmp(FOp,FLBP)
  end { QGenBJmp };

function Seform a system call (a call to a system routine that
{    the compiler knows about; the user does not have to import).
{
{ PargNumber(ModNam: Alpha; FilNam: String): SegRange;
{----------------------------------
{ Abstract:
{    Return the internal seameters:
{    FR - The system routine to be called
{
{ Side Effects:
{    Code is generated
{
{ Calls:
{    QGen2
{    Sgment number for a particular imported segment
{
{ Parameters:
{    ModNam - The module name for which we want the segment nuegNumber
{-----------------------------}
  begin
  with Routine[FR] do
      with Package[Pkg] do
          begin
        mber
{    FilNam - The file name from which the module comes
{
{ Results:
{    The internal segment number for the segment
  if Seg = 0 then Seg := SegNumber(ModNam,FilNam);
          QGen2(CALLXB,Seg,Rtn)
          end
  end { GenSysCall };

pr{
{ Side Effects:
{    If the named segment is not currently in the LinkList, then it will
{    be inserted and a new segmentocedure GenLabel(var FLBP: LBP);
{----------------------------
{ Abstract:
{    Create a label to be used for jump destinatio ; 	
 and perform float if needed }
              if Float then ExpFloat;
              if Stretch then ExpStretch;
               
      { / }     RDiv: begin
                      QGen0(DVR);
                      EPop(2)
                      end;
  { finally, it's time to perform the desired operation }
              case Opp of
      { * }     Mul:  begin
                   
      { Div }   IDiv: begin
                      if CompTypes(LAttr.TyPtr,IntPtr) and
                        CompTypes           Float:=true
                  else
                      Stretch:=true;
                  Son:=Son^.RLink
              if CompTypes(GAttr.TyPtr,IntPtr) and
                        CompTypes(LAttr.TyPtr,IntPtr) then
                                  end;
              { now expand real son }
              if Son^.SSy = MulOp then        { it's another term }
      begin
                          QGen0(MPI);
                          EPop(1)
                          end
                            ExpTerm(Son)
              else                              { no, it's a factor }
                  begin
            else
                          if CompTypes(GAttr.TyPtr,RealPtr) and
                            CompTypes(LAttr.TyPt               ExpFactor(Son);
                  LoadExpr
                  end;
              { and perform float if needed r,RealPtr) then
                              begin
                              QGen0(MPR);
                              E}
              if Float then ExpFloat;
              if Stretch then ExpStretch;
              LAttr:=GAttr;
              Pop(2)
                              end
                      else
                          if CompTypes(GAttr.TyPtr,LongPt{ now expand the right son }
              { first remove FltOps from son }
              Float:=false;
              Stretchr) and
                            CompTypes(LAttr.TyPtr,LongPtr) then
                              begin
                  :=false;
              Son := RLink;
              while Son^.SSy = ChangeSy do
                  begin
                  if            QGen0(MPL);
                              EPop(2)
                              end
                          els Son^.Opp = FltOp then
                      Float:=true
                  else
                      Stretch:=true;
       e
                            if LAttr.TyPtr <> nil then
                              if (LAttr.TyPtr^.Form = Power)
                  Son:=Son^.RLink
                  end;
              { now expand actual son }
              if RLink^.SSy = MulOp                         and CompTypes(LAttr.TyPtr,GAttr.TyPtr) then
                                  begin
                  then        { another term }
                  ExpTerm(Son)
              else                              { no, a factor }                 QGen0(QINT);
                                  EPop(1)
                                  end
               
                  begin
                  ExpFactor(Son);
                  LoadExpr
                  end;
              {               else
                                  begin Error(134); GAttr.TyPtr:=nil end
                      end;
      <  	
  end;
    var LRef,Dum: integer;
        OldTrik,NewTrik:IntByteType;
    type
        Buffer = packed array [0..511] of ABences within this proc }
      while LRef < MaxAddr do
          with OldTrik do
              begin
              IC := LReyte;
        BufPtr = ^Buffer;
    var
        Buf: BufPtr;
        Blk,Ofst,CBlk: integer;

function GetWord(Buf: BufPtrf;           { IC of reference }
              {$R-}
              lobyte:=CodeP^[IC];   { First copy out the next reference }; Ofst:integer):integer;
{-----------------------------
{ Abstract:
{    Get a word out of a buffer (composed out of two byte
              hibyte:=CodeP^[IC+1];
              {$R=}
              LRef:=Int;
              Int:=OccurIC-IC-2;    { and s, not necessarily
{    word aligned)
{
{ Parameters:
{    Buf - the address of the buffer from which the word is to come
{put in the real offset }
              {$R-}
              CodeP^[IC]:=lobyte;
              CodeP^[IC+1]:=hibyte;
             Ofst - the offset within the buffer of the low byte of the word
{
{ Results:
{    Returns the word described by the param     {$R=}
              end;
      IC := OccurIC;            { restore the real IC }
      { now resolve any EXGO referenceseters
{--------------------------------}
  var trik: IntByteType;
begin
with trik do
    begin
    LoByte:=Buf^[Ofst];
   }
      if OccurBlk <> 0 then
          { there are EXGO references to be resolved }
          begin
          new(0,256,Bu  HiByte:=Buf^[Ofst+1];
    GetWord:=Int
    end
end { GetWord };

procedure PutWord(Buf: BufPtr; Ofst,Wurd:integer);
{--f);
          CBlk := -1;
          LRef := OccurIC + Shift(CurBlk-1,9) + CurByte;   { get label offset
                     ---------------------------
{ Abstract:
{    Put a word into a buffer ( not necessarily word aligned)
{
{ Parameters:
{                                            code base }
          while OccurBlk <> 0 do
              begin
              Blk :=           { Segment containing the target }
      end
  end { GenLabel };

procedure PutLabel(FLBP: LBP);
{--------------Buf - the address of the buffer into which the word goes
{    Ofst - the offset within the buffer of the low byte of the word
----------------
{ Abstract:
{    Associate a label with the current location in the program
{
{ Parameters:
{    FLBP - th{    Wurd - the word to put into the buffer
{--------------------------------}
  var trik: IntByteType;
begin
with trik do
e label to be associated with the current location
{
{ Side Effects:
{    The code buffer may be modified to resolve forward     begin
    Int:=Wurd;
    Buf^[Ofst]:=LoByte;
    Buf^[Ofst+1]:=HiByte
    end
end { PutWord };

  begin
  with FLBPreferences to this
{    label
{------------------------------}
    type
        IntByteType =  packed record case boolean of^ do
      begin
      LRef := OccurIC;       { get first forward reference within this proc }
      Defined := true;       {
                true: (Int:integer);
                false:(lobyte: abyte;
                       hibyte: abyte)
           the label is now defined }
      OccurIC := IC;         { this is the IC of the label }
      { now resolve the forward refer < 	
            QGen0(MODL);
                          EPop(2)
                          end
                      else
                              end;
                { now expand the real son }
                if Son <> nil then
                                     begin Error(134); GAttr.TyPtr := nil end
                      end;

      { And }   AndOp: begin
         if Son^.SSy = AddOp then        { it's another SimpleExp }
                        ExpSimpleExpression(Son)
                                QGen0(QAND);
                       EPop(1)
                       end
              
                end { c   else                            { no it's a Term }
                        begin
                        ExpTerm(Son);
   ase }
              end { SSy = MulOp }
          else
              { we've only got a factor }
              ExpFactor(Nod                     LoadExpr
                        end;
                { and perform float if needed }
                ife)
      end { Term };

begin { ExpSimpleExpression }
   { A SimpleExpression is either an AddOp with two sons, which may b Float then ExpFloat;
                if Stretch then ExpStretch;
                end;
            LAttr:=GAttr;
           (GAttr.TyPtr,IntPtr) then
                          begin
                          QGen0(DVI);
                          EPoe either }
   { SimpleExpressions or Terms (determined by the top node of the son), the  }
   { AddOp Unary Minus with only a p(1)
                          end
                      else if CompTypes(LAttr.TyPtr,LongPtr) and
                        Cright son which is a Term, or simply a     }
   { Term. }
    with Node^ do
        begin
        if SSy = AddOp then
     ompTypes(GAttr.TyPtr,LongPtr) then
                          begin
                          QGen0(DVL);
                           begin
            { expand left son first. Take note if left son is nil }
            if LLink = nil then
                  EPop(2)
                          end
                      else
                          begin Error(134); GAttr.TyPt    Signed:=true            { a unary minus here! }
            else
                begin                   { procedure normar := nil end
                      end;
      
      { Mod }   IMod: begin
                      if CompTypes(LAttr.TyPtr,Inlly (two sons) }
                Signed:=false;
                { first remove float oprs }
                Float:=false;
  tPtr) and
                        CompTypes(GAttr.TyPtr,IntPtr) then
                          begin
                                      Stretch:=false;
                Son:=LLink;
                if Son <> nil then
                    if Son^.SSy   QGen0(MODI);
                          EPop(1)
                          end
                      else if CompTypes(LAttr.= ChangeSy then
                        begin
                        if Son^.Opp = FltOp then
                            FlTyPtr,LongPtr) and
                        CompTypes(GAttr.TyPtr,LongPtr) then
                          begin
              oat:=true
                        else
                            Stretch:=true;
                        Son:=Son^.RLink
   =  	
               OccurOfst:=GetWord(recast(DiskBuf,BufPtr),Ofst+3);
                  PutWord(recast(DiskBuf,BufPtr),Ofst,OccurSe         if Ofst < 511 then
                      begin
                      OccurOfst:=GetWord(Buf,Ofst);
                 g);
                  PutWord(recast(DiskBuf,BufPtr),Ofst+3,LRef)
                  end
              else
                      PutWord(Buf,Ofst,LRef)
                      end
                  else
                      begin
                    begin
                  if Blk <> CBlk then
                      begin
                      if CBlk <> -1 then
             NewTrik.Int:=LRef;
                      OldTrik.LoByte:=Buf^[511];
                      Buf^[511]:=NewTrik.LoByte;
                     FSBlkWrite(OutFile,CBlk,recast(Buf,pDirBlk));
                      CBlk := Blk;
                      FSBlkRe                 FSBlkWrite(OutFile,CBlk,recast(Buf,pDirBlk));
                      CBlk:=CBlk+1;
                      FSBlkad(OutFile,Blk,recast(Buf,pDirBlk))
                      end;
                  if Ofst < 511 then
                      begRead(OutFile,CBlk,recast(Buf,pDirBlk));
                      OldTrik.HiByte:=Buf^[0];
                      Buf^[0]:=NewTrik.in
                      OccurBlk:=GetWord(Buf,Ofst);
                      PutWord(Buf,Ofst,OccurSeg)
                      HiByte;
                      OccurOfst:=OldTrik.Int
                      end
                  end
              end;
   end
                  else
                      begin
                      NewTrik.Int:=OccurSeg;
                      Ol       if CBlk <> -1 then
              FSBlkWrite(OutFile,CBlk,recast(Buf,pDirBlk));
          Dispose(Buf)
          end
 dTrik.LoByte:=Buf^[511];
                      Buf^[511]:=NewTrik.LoByte;
                      FSBlkWrite(OutFile,CBlk,recast     end
  end { PutLabel };

procedure LoadExpr;
{-----------------------------------
{ Abstract:
{     Generate code (i(Buf,pDirBlk));
                      CBlk:=CBlk+1;
                      FSBlkRead(OutFile,CBlk,recast(Buf,pDirBlk));
      f needed) to load the current expression (described
{     by GAttr.
{
{ Environment:
{    The global GAttr should describe t                OldTrik.HiByte:=Buf^[0];
                      Buf^[0]:=NewTrik.HiByte;
                      OccurBlk:=OldTrihe expression (also reflecting
{    any code which may have already been generated)
{
{ Side Effects:
{    Code may be generk.Int
                      end;
                  Ofst:=Ofst+3;
                  if Ofst > 511 then
                      ated.  The type of GAttr becomes EXPRession.
{
{ Calls:
{    EPush
{    EPop
{    GenLDC
{    QGen0
{    QGen1
{    QGen OccurBlk + OccurOfst div 512;
              Ofst := OccurOfst mod 512;
              if Blk = CurBlk then
                  begin
                      FSBlkWrite(OutFile,CBlk,recast(Buf,pDirBlk));
                      CBlk:=CBlk+1;
               { the code is still in memory }
                  begin
                  OccurBlk:=GetWord(recast(DiskBuf,BufPtr),Ofst);
          FSBlkRead(OutFile,CBlk,recast(Buf,pDirBlk));
                      Ofst:=Ofst-512
                      end;
          = 	
    ExpTerm(Son);
                    LoadExpr
                    end;
            if Float then ExpFloat;
            if Sn0(ADL);
                          EPop(2)
                          end
                      else if LAttr.TyPtr <> nil thetretch then ExpStretch;
            { finally, it's time to perform the desired operation }
            if Signed then { unaryn
                          if (LAttr.TyPtr^.Form = Power)
                            and CompTypes(LAttr.TyPtr,GAttr.TyPtr)  negate }
                begin
                if CompTypes(GAttr.TyPtr,IntPtr) then
                    QGen0(NGI)
       then
                              begin
                              QGen0(UNI);
                              EPop(1)
            else if CompTypes(GAttr.TyPtr,RealPtr) then
                    QGen0(NGR)
                else if CompTypes(GAttr.Ty                           end
                          else
                              begin Error(134); GAttr.TyPtr := nPtr,LongPtr) then
                    begin
                    GenLDC(0);
                    GenLDC(0);
                  il end
                      end;
        
        { - }     Minus:
                      begin
                      if Co  EQuick(2);
                    QGen0(Exch2);
                    QGen0(SBL)
                    end
                else
mpTypes(LAttr.TyPtr,IntPtr) and
                        CompTypes(GAttr.TyPtr,IntPtr) then
                          begin
                      begin Error(134); GAttr.TyPtr := nil end
                end
            else
                case Opp of                        QGen0(SBI);
                          EPop(1)
                          end
                      els
        { + }     Plus:
                      begin
                      if CompTypes(LAttr.TyPtr,IntPtr) and
            e if CompTypes(LAttr.TyPtr,RealPtr) and
                        CompTypes(GAttr.TyPtr,RealPtr) then
                           { now expand the right son, as before }
            Float:=false;
            Stretch:=false;
            Son:=RLink;
                 CompTypes(GAttr.TyPtr,IntPtr) then
                          begin
                          QGen0(ADI);
               if Son <> nil then
                if Son^.SSy = ChangeSy then
                    begin
                        if So                  EPop(1)
                          end
                      else if CompTypes(LAttr.TyPtr,RealPtr) and
    n^.Opp = FltOp then
                            Float:=true
                        else
                            Stretch:                    CompTypes(GAttr.TyPtr,RealPtr) then
                          begin
                          QGen0(ADR);=true;
                    Son:=Son^.RLink
                    end;
            if Son <> nil then
                if Son^.S
                          EPop(2)
                          end
                      else if CompTypes(LAttr.TyPtr,LongPtr) Sy = AddOp then
                    ExpSimpleExpression(Son)
                else
                    begin
                and
                        CompTypes(GAttr.TyPtr,LongPtr) then
                          begin
                          QGe >  	
   EPush(Data16)
                           end;
                           
                   Packd:  begin
                 end {case Access};
          Expr,Result:
          end {case Kind};
          with TyPtr^ do
            if (Form = Powe1A
{    QGen2
{----------------------------------}
    var j: integer;
  begin
  with GAttr do
      if TyPtr <> nil then             QGen0(LDP);
                           EPop(2);
                           EPush(Data16)
                       
          begin
          case Kind of
          Cst:   if (TyPtr^.Form = Scalar) and (TyPtr^.Size = 1) then
                   end;
                           
                   Multi:  with TyPtr^ do
                               if Form = Power          begin
                         EPush(Data16);
                         GenLDC(CVal.IVal)
                         e then  { Only use LDMW, no LDDWs }
                                   begin
                                   QGen1(LDMW,Sizend
                     else
                         if TyPtr = NilPtr then
                             begin
            );
                                   EPop(1)
                                   end
                               else
                    EPush(Ptr32);
                             QGen0(LDCN)
                             end
                                                    if TyPtr^.Size = 2 then
                                       begin
                              else
                             if (TyPtr = RealPtr) or (TyPtr = LongPtr) then
                                 begin
              QGen0(LDDW);
                                       EPop(1);
                                       EPush(Data32                                 EPush(Data32);
                                 QGen1(LDMC,2)
                               )
                                       end
                                   else
                                       b  end;
          Varbl: case Access of
                   Drct:   begin
                           if VLevel = MainLex then
egin
                                       QGen1(LDMW,Size);
                                       EPop(1)
                                               QGen1A(LDOB,Dplmt)
                           else if VLevel < MainLex then
                                          end;
                           
                   Bite:   begin
                           QGen0(LDB            QGen2(LDGB,-VLevel,Dplmt)
                           else
                               QGen2(LDIB,Level-VLevel,D);
                           EPop(2);
                           EPush(Data16)
                           end;
            plmt);
                           EPush(Data16)
                           end;
                           
                               
               Chracter:   begin
                           if RangeCheck^.Sw then QGen0(LDCH) else QGen0(LDB)   Indrct: begin
                           QGen1A(INDB,IDplmt);
                           EPop(1);
                        ;
                           EPop(2);
                           EPush(Data16)
                           end
               > 	
         begin
                          QGen0(SBL);
                          EPop(2)
                          end
       trLen then Error(129)
        end;
StrgFSP := PAFSP
end { MakePa };

begin { ExpExpression }
  if Node <> nil then
    i               else if LAttr.TyPtr <> nil then
                              if (LAttr.TyPtr^.Form = Power)
                  f Node^.SSy <> RelOp then
        ExpSimpleExpression(Node)
    else
      begin
      MPop := 0;
      LOp:=Node^.Opp;                  and CompTypes(LAttr.TyPtr,GAttr.TyPtr) then
                                  begin
                                   { the operator }
      { remove possible float and stretch from left son }
      Float:=false;
      Stretch:=false;
      QGen0(DIF);
                                  EPop(1)
                                  end
                                 Son:=Node^.LLink;
      if Son <> nil then
          if Son^.SSy = ChangeSy then
              begin
              if    else
                                  begin Error(134); GAttr.TyPtr := nil end
                      end;
       
      Son^.Opp = FltOp then
                  Float:=true
              else
                  Stretch:=true;
              Son:=S  { Or }    OrOp: begin
                        QGen0(QOR);
                        EPop(1)
                        end
    on^.RLink
              end;
      ExpSimpleExpression(Son);
      LString := (GAttr.Kind = Cst) and StrgType(GAttr.TyPtr);
                    
                end { case }
            end { SSy = AddOp }
        else
            { we've got only       if LString then LLen := GAttr.CVal.ValP^.SLgth;
      if GAttr.TyPtr <> nil then
          begin
          if GAttr.Kina Term }
            ExpTerm(Node);
        end { with }
    end { SimpleExpression };

procedure MakePa(var StrgFSP: STP;d = Result then MPop := GAttr.TyPtr^.Size;
          if GAttr.TyPtr^.Form <= Power then
              LoadExpr
          else StrLen:integer; PAFSP: STP);
{-------------------------------------
{ Abstract:
{    Check for compatibility between a strin
              LoadAddress
          end;
      if Float then ExpFloat;
      if Stretch then ExpStretch;
      if ByteArrag and a packed array of characters
{    and perform the type coersion
{
{ Parameters:
{    StrgFSP - The string type
{    Py(GAttr.TyPtr) then
          begin
          BytePtr := IC;
          GenLDC(0);            { Get a byte pointer }
        AFSP - The Packed array of character type
{
{ Side Effects:
{    StrgFSP is replaced by PAFSP
{
{ Calls:
{    GetBounds
{  EPush(Data16)
          end;
      LAttr := GAttr;
      { remove possible float and stretch from right son }
      Float:begin
                          QGen0(SBR);
                          EPop(2)
                          end
                    Error
{---------------------------------------}
  var LMin,LMax: integer;
begin
if PAFSP <> nil then
    if (PAFSP^.Inx      else if CompTypes(LAttr.TyPtr,LongPtr) and
                        CompTypes(GAttr.TyPtr,LongPtr) then
                 Type <> nil) and (StrgFSP <> nil) then
        begin
        GetBounds(PAFSP^.InxType,LMin,LMax);
        if LMax-LMin+1 <> S ?  	
el-VLevel,Dplmt);
                    EPop(1)
                    end;
            
            Indrct: if IDplmt <> 0 theny the current attribute
{    record GAttr
{
{ Environment:
{    GAttr must describe the item who's address is to be loaded

                        Error(413)
                    else
                        begin
                        QGen0(STIN{
{ Side Effects:
{    GAttr will be modified.  Code may be generated.
{
{ Errors:
{    Attempt to load the address of a noD);
                        EPop(2)
                        end;
                        
            Packd:  begin
       n-string constant
{    Attempt to load the address of a packed field
{
{ Calls:
{    StrgType
{    EPush
{    EQuick
{                QGen0(STPF);
                    EPop(3)
                    end;
                    
            Multi:  with QGen0
{    QGen1A
{    QGen2
{    GenByte
{    GenLDC
{    Error
{------------------------------}
  begin
  with GAttr r) and (Kind <> Expr) then
                begin
                GenLDC(Size);
                EPush(Data16)
                TyPtr^ do
                        if Form = Power then { Only use STMW, no STDWs }
                            begin
        end;
          Kind := Expr
          end
  end { LoadExpr };

procedure Store(var FAttr: Attr);
{----------------------                     QGen1(STMW,Size);
                            EPop(1)
                            end
                  -----
{ Abstract:
{    Generate code to store the expression described by GAttr into the
{    location described by FAttr
{      else
                            if TyPtr^.Size = 2 then
                                begin
                        
{ Parameters:
{    FAttr - the attribute record describing the destination for the
{            store operation
{
{ Side Ef        QGen0(STDW);
                                EPop(3)
                                end
                            fects:
{    Code may be generated
{
{ Errors:
{    Internal Compiler Error - attempt to store indirect with a non-zero
{   else
                                begin
                                QGen1(STMW,TyPtr^.Size);
                          offset (no QCode to do this)
{
{ Calls:
{    EPop
{    QGen0
{    QGen1
{    QGen1A
{    QGen2
{    Error
{-----------       EPop(1)
                                end;
            
            Bite:   begin
                    QGen0(STB);
------------------}
  begin
  with FAttr do
      if TyPtr <> nil then
          case Access of
            Drct:   begin
                    EPop(3)
                    end;
            
        Chracter:   begin
                    if RangeChec                    if VLevel = MainLex then
                        QGen1A(STOB,Dplmt)
                    else if VLevel < Mk^.Sw then QGen0(STCH) else QGen0(STB);
                    EPop(3)
                    end
              end
  end { Store ainLex then
                        QGen2(STGB,-VLevel,Dplmt)
                    else
                        QGen2(STIB,Lev};

procedure LoadAddress;
{----------------------------
{ Abstract:
{    Generate code to load the address of described b ? 	
 lot 
                            of knowledge as to what an LDC0 and LDC1 are
                          }
                                  end;
                    
                    Power:
                        begin
                        i=false;
      Stretch:=false;
      Son:=Node^.RLink;
      if Son <> nil then
          if Son^.SSy = ChangeSy then
              MakePa(LAttr.TyPtr,LLen,GAttr.TyPtr)
                          end
                  end
              else
                begin
              if Son^.Opp = FltOp then
                  Float:=true
              else
                  Stre          if GString then
                      begin
                      if PAOfChar(LAttr.TyPtr) then
                   tch:=true;
              Son:=Son^.RLink
              end;
      ExpSimpleExpression(Son);
      GString := (GAttr.Kind = C       if not LAttr.TyPtr^.AIsStrng then
                              begin
                              IC:=IC-1;         {st) and StrgType(GAttr.TyPtr);
      if GString then GLen := GAttr.CVal.ValP^.SLgth;
      if GAttr.TyPtr <> nil then
        Convert LDC0 to LDC1 }
                              GenLDC(1);
                              MakePa(GAttr.TyPtr,GLen,LAttr.T   begin
          if GAttr.Kind = Result then MPop := MPop + GAttr.TyPtr^.Size;
          if GAttr.TyPtr^.Form <= Power thenyPtr)
                              end
                      end;
              if CompTypes(LAttr.TyPtr,GAttr.TyPtr) then

              LoadExpr
          else
              LoadAddress
          end;
      if Float then ExpFloat;
      if Stre                  begin
                  LSize := LAttr.TyPtr^.Size;
                  case LAttr.TyPtr^.Form of
           tch then ExpStretch;
      if ByteArray(GAttr.TyPtr) then
          begin
          GenLDC(0);
          EPush(Data16)
             Scalar,
                    SubRange:
                        if LAttr.TyPtr = RealPtr then
                              end;
      if (LAttr.TyPtr <> nil) and (GAttr.TyPtr <> nil) then
          if Node^.Opp = InOp then
              begin    begin TypInd := CReal; PS:=4 end
                        else if LAttr.TyPtr = LongPtr then
                            be
              QGen0(INN);
              EPop(1)
              end
          else
              begin
              TypIndgin TypInd := CLong; PS:=4 end
                        else
                            begin
                            if :=CInt;
              PS:=0;    { Pop Stack Amount after Comparison }
              if LString then
                  begin
LAttr.TyPtr = BoolPtr then
                                TypInd := CBool;
                            PS:=2
                                 if PAOfChar(GAttr.TyPtr) then
                      if not GAttr.TyPtr^.AIsStrng then
                                   end;
                    
                    Pointr:
                        begin
                        if     begin
                          CodeP^[BytePtr]:=1;
                          { Change LDC0 to LDC1 - WARNING: this uses aLOp in [LtOp,LeOp,GtOp,GeOp] then Error(131);
                        TypInd := CReal;
                        PS:=4
         @  	
             end;
                     
                     Indrct: if IDplmt <> 0 then QGen1A(INCB,IDplmt);
               
{    Code is generated
{
{ Calls:
{    EPush
{    QGen0
{-------------------------}
      begin
      if ETos - StartTo      
                     Packd:  Error(195)
                    end {case Access};
            Result: begin
            s = 1 then
          begin
          QGen0(Repl);
          EPush(Off20)
          end
      else
          begin
               GenByte(LDTP);
                    EPush(Off20);
                    GenLDC(TyPtr^.Size);
                    GenByte   QGen0(Repl2);
          EPush(Ptr32)
          end
      end { Replicate };

  begin
  LoadAddress;
  Replicate;
  Q(SBI);
                    EQuick(1)
                    end;
          VRDVarbl: begin
                    if VLevel = MainGen1A(INDB,0);
  GenLabel(LCIX);
  QGenJmp(JTB,LCIX);
  EPop(1);
  Replicate;
  if ETos - StartTos = 2 then { 2 20-bit offsLex then
                        QGen1A(LOAB,Dplmt)
                    else if VLevel < MainLex then
                       ets }
      begin
      QGen0(LSSN);
      QGen0(EXCH);
      EPop(1);
      EPush(Ptr32)
      end;
  QGen0(MMS2);
  EP QGen2(LGAB,-VLevel,Dplmt)
                    else
                        QGen2(LIAB,Level-VLevel,Dplmt);
                 op(2);
  GenSysCall(PGetC);
  PutLabel(LCIX)
  end { Guard }.
                                                                 EPush(Off20)
                    end;
            Expr:
          end {case Kind};
          Kind := Varbl; Access := Ind do
      if TyPtr <> nil then
          begin
          case Kind of
            Cst:   if StrgType(TyPtr) then
           rct; IDplmt := 0
      end
  end { LoadAddress };

procedure Guard(StartTos: integer);
{-------------------------------
{            begin
                       QGen0(LSA);
                       EPush(Ptr32)
                       end
         Abstract:
{     Generate code to guard access to the file element of a character file
{
{ Parameters:
{    StartTos - ?
{           else
                       Error(399);
            Varbl: case Access of
                     Drct:   begin
    
{ Side Effects:
{    Code will be generated
{
{ Calls:
{    LoadAddress
{    Replicate
{    QGen1A
{    GenLabel
{    Q                         if VLevel = MainLex then
                                 QGen1A(LOAB,Dplmt)
                        GenJmp
{    EPop
{    QGen0
{    EPush
{    GenSysCall
{    PutLabel
{-------------------------------}
  var LCIX: LBP;
     else if VLevel < MainLex then
                                 QGen2(LGAB,-VLevel,Dplmt)
                             els
procedure Replicate;
{------------------------
{ Abstract:
{    replicate the item on the top of the stack
{
{ Environmee
                                 QGen2(LIAB,Level-VLevel,Dplmt);
                             EPush(Off20)
                nt:
{    StartTos (defined in Guard) is used to determine whether the item is
{    a single or double word
{
{ Side Effects; @ 	
             
                    Records:
                        Error(134);
                    
                    File--------------------------}

{ }
{ 2-Jan-81  1.6  Miles A. Barel
{ Initial Creation
{ }

Exports
    Procedure LoadCurs:
                        Error(133)
                  end {cases};
                      
                  case LOp of
 s;
    Procedure ShowProgress;
    Procedure QuitProgress;
Private

Var CursPos:integer;

Imports IO from IO;

Procedu                     LtOp: QGenCmp(LES,TypInd,LSize);
                      LeOp: QGenCmp(LEQ,TypInd,LSize);
                 re LoadCurs;
{------------------------------
{ Abstract:
{    Set up the cursor so that we can show compilation in progress
     GtOp: QGenCmp(GTR,TypInd,LSize);
                      GeOp: QGenCmp(GEQ,TypInd,LSize);
                      NeOp: QGenC{
{ Calls:
{    New
{    Dispose
{    IOLoadCursor
{    IOCursorMode
{    IOSetCursorPos
{------------------------------}f LOp in [LtOp,GtOp] then Error(132);
                        TypInd := CPowr;
                        PS:=2
                mp(NEQ,TypInd,LSize);
                      EqOp: QGenCmp(EQL,TypInd,LSize)
                    end {cases};
                        end;
                    
                    Arrays:
                        begin
                        if PAOfC  EPop(PS);
                  EPush(Data16)
                  end
              else
                  Error(129)
         har(LAttr.TyPtr) then
                            if LAttr.TyPtr^.AIsStrng then
              {1:}              begin
            end;
      with GAttr do
          begin
          TyPtr := BoolPtr;
          Kind := Expr
          end;
      if M                         TypInd := CStr;
                                PS:=4
                                end
          Pop <> 0 then QGen1A(ATPB,-MPop)
      end { Sy = RelOp };
  TreeDispose(Node)          { Give the space from the expression t                  else
                                begin
                                PS:=4;
                         ree back }
  end { ExpExpression }.
                                                                                                 TypInd := CByte;
                                with LAttr.TyPtr^ do
                                    if InxType <>  nil then
                                        begin
                                        GetBounds(InxType,LMin,LMax); 
                                        LSize := LMax - LMin + 1
                                        end
                Module Progress;
{-----------------------------------
{
{ Progress Reporting Routines
{ Copyright (C) 1981  Three Rivers Com                end
                        else
                            Error(134)
                        end;
       puter Corporation
{
{ Abstract:
{    Routines to show progress of the compiler
{
{ File:
{    Progress.Pas
{
{---------- A  	
el
{ Import Bug Fix
{ }
{ 03-Feb-81  2.0  Miles A. Barel
{ Implementation of Long Integers
{ }
{ 15-Jan-81  1.12  Miles A.tion part
{
{ Calls:
{    InSymbol
{    ImportDeclaration
{    LabelDeclaration
{    ConstDeclaration
{    TypeDeclaratio Barel
{ Hashing for compiler names and user globals
{ }
{ 6-Jan-81  1.6  Miles A. Barel
{ Institute standard 3RCC file formn
{    VarDeclaration
{    ProcDeclaration
{    Error
{    Skip
{--------------------------------}
  var LSy: Symbol;     ats
{ }

Exports

Imports PascalCompiler from Pascal;

Procedure DeclarationPart(FSys: SetOfSys);

Private

{$C Copy { used to store first symbol of declaration segment }
      NotDone: boolean; LCP: Identifier;

procedure Typ(FSys: SetOfSyright (C) 1981  Three Rivers Computer Corporation }

Imports BodyPrt from BodyPart;
{Imports Perq_String from Perq.String;}
s; var FSP: STP; var FSize: AddrRange);
{-----------------------------------
{ Abstract:
{    Main body of the TYPE processorImports Memory from Memory;
Imports CodeGeneration from CodeGen;

{$R-}

{$INC Dec0 }
{$INC Dec1 }
{$INC Dec2 }
        .  Determines the basic type and
{    then calls a specialized routine.
{
{ Parameters:
{    FSys - the possible set of term{--------------------------------
{
{ Declaration Processor Part A
{ Copyright (C) 1981  Three Rivers Computer Corporation
{inal symbols for the declaration
{    FSP - place to return the structure parsed
{    FSize - place to return the size of the 
{ Abstract:
{    The first part of the declaration processor code - primarily deals
{    with the declaration and/or recognistructuure parsed
{
{ Side Effects:
{    The state of CurIFile may be modified
{
{ Errors:
{    Error in TYPE
{    Illegation of a TYPE
{
{ File: Dec0.Pas
{
{-------------------------------}

{ }
{ 03-Feb-81  2.0  Miles A. Barel
{ Implementl Symbol (possibly missing ; on previous line)
{
{ Calls:
{    Error
{    Skip
{    SimpleType
{    PointerType
{    InSyation of Long Integers
{ }
{ 6-Jan-81  1.6  Miles A. Barel
{ General Cleanup and first use of standard 3RCC file formats
{ }mbol
{    ArrayType
{    RecordType
{    SetType
{    FileType
{-----------------------------------}
    var LSP,LSP1,LSP2




Procedure DeclarationPart(FSys: SetOfSys);
{--------------------------------
{ Abstract:
{    Main Body of the dec: STP; OldTop: DispRange; LCP: Identifier;
        LSize,Displ: AddrRange; LMin,LMax: integer;
        Packing: boolean; NextBModule DecPart;
{----------------------------------------
{
{ Compiler Declarations Processor
{ Copyright (C) 1981  Three Rilaration processor (body is actually in file: Dec2.Pas
{
{ Parameters:
{    FSys - the set of possible terminal symbols for tvers Computer Corporation
{
{ Abstract:
{    Parse Pascal declarations - creating symbol table entries and structure
{    dehe declarations section
{           being parsed
{
{ Side Effects:
{    The symbol table may be modified, new structures mayfinitions as we go
{
{ File: Decpart.Pas
{
{---------------------------------------}

{ }
{ 17-Mar-81  2.5  Miles A. Bar be created, new
{    labels may be generated
{    The state of CurIFile will be modified
{
{ Errors:
{    Error in declara A 	
----------------}
begin
IOCursorMode(OffCursor)
end;

Procedure ShowProgress;
{-----------------------------------------l symbol (possibly missing ';' on line above) 
7: Error in parameter list
8: 'OF' expected
9: '(' expected
10: Error in type
{ Abstract:
{    Indicate progress - move the cursor down one scan line
{
{ Side Effects:
{    CursPos is modified
{
{ Ca
11: '[' expected
12: ']' expected
13: 'END' expected
14: ';' expected (possibly on line above)
15: Integer expected
16: 'lls:
{    IOSetCursorPos
{-----------------------------------------}
begin
CursPos:=LAnd(CursPos+1,#1777);
IOSetCursorPos(7=' expected
17: 'BEGIN' expected
18: Error in declaration part
19: error in <field-list>
20: '.' expected
21: '*' expected48,CursPos)
end.
                                                                                                             
22: 'Interface' expected
23: 'Implementation' expected
24: 'Unit' expected
25: '..' expected
50: Error in constant
51: ': program FSyntax;
{ Program to generate Pascal.Syntax from a textfile }
type ErrRec = record
                  errnum:integer;=' expected
52: 'THEN' expected
53: 'UNTIL' expected
54: 'DO' expected
55: 'TO' or 'DOWNTO' expected in for statement
56: '
                  errmsg:string[80]
                end;
var f:file of ErrRec;
    g:text;
    s:string;
begin
rewrite(oIF' expected
57: 'FILE' expected
58: Error in <factor> (bad expression)
59: Error in variable
60: 'FROM' expected
61: 'EXPOutput);
reset(input);
writeln('FSYNTAX V1.0');
write('Input File[Syntax.Dat]: ');
readln(s);
if length(s) = 0 then s:='SyntRTS' expected
62: ',' expected
101: Identifier declared twice
102: Low bound exceeds high bound
103: Identifier is not of th
  var x,y:integer;
      Curs: CurPatPtr;
begin
new(0,4,Curs);
for y:=0 to 63 do
    for x:=0 to 3 do
        Curs^[y,x]ax.Dat';
reset(g,s);
rewrite(f,'Pascal.Syntax');
while not eof(g) do
    begin
    readln(g,F^.ErrNum,F^.ErrMsg);
    put( := 0;
Curs^[2,0] := #700;
Curs^[3,0] := #3100;
Curs^[4,0] := #4200;
Curs^[5,0] := #10400;
Curs^[6,0] := #61777;
Curs^[7,0f)
    end;
close(g);
close(F)
end.
                                                                                       ] := #120001;
Curs^[8,0] := #121776;
Curs^[9,0] := #121020;
Curs^[10,0] := #121740;
Curs^[11,0] := #121040;
Curs^[12,0] :=  #121700;
Curs^[13,0] := #61100;
Curs^[14,0] := #17600;
IOLoadCursor(Curs,0,0);
Dispose(Curs);
IOCursorMode(IndepCursor);
C ursPos:=0;
IOSetCursorPos(748,CursPos)
end { LoadCurs };

Procedure QuitProgress;
{--------------------------------------- -
{ Abstract:
{    No more progress to report, turn off the cursor
{
{ Calls:
{    IOCursorMode
{-------------------------1: Error in simple type
2: Identifier expected
3: 'PROGRAM' or 'MODULE' expected
4: ')' expected
5: ': ' expected
6: Illega B  	
it,NumBits: BitRange;

procedure SimpleType(FSys:SetOfSys; var FSP:STP; var FSize:AddrRange);
{-----------------------------pe := LSP; Next := LCP1;
                        Values.IVal := LCnt; Klass := Konst; IdNum:=NextINum
                        -----
{ Abstract:
{    Parse simple type declarations - any predefined type or user type
{    which has already been declaredend;
                    EnterId(LCP);
                    LCnt := LCnt + 1;
                    LCP1 := LCP.IdNum;
        , enumerated types and subranges.
{
{ Parameters:
{    FSys - the possible set of terminal symbols
{    FSP - place to retur            InSymbol
                    end
                else
                    Error(2);
                if not (Sy in the structure parsed
{    FSize - place to return the size of the structure parsed
{
{ Side Effects:
{    The state of Curn FSys + [Comma,RParent]) then
                  begin Error(6); Skip(FSys + [Comma,RParent]) end
            until Sy <> CommIFile may be modified.
{    New structures may be allocated
{    New symbols may be defined
{
{ Calls:
{    Error
{    Skia;
            LSP^.FConst := LCP1; Top := TTop;
            if Sy = RParent then InSymbol else Error(4)
            end
   p
{    New
{    InSymbol
{    EnterId
{    NextINum
{    SearchId
{    Constant
{    StrgType
{-------------------------     else
            begin
            if Sy = Ident then
                begin
                SearchId([Types,Konst,Func]----------}
      var LSP,LSP1: STP; TTop: DispRange; LCnt: integer; LValu: Valu;
          LCP: Identifier; LCP1: integer;
 ,LCP);
                if LCP.Klass in [Konst,Func] then
                    begin
                    New(CurHeap,1,LSP,SubR   
    begin
    FSize := 1;
    if not (Sy in STypeBegSys) then
      begin Error(1); Skip(FSys + STypeBegSys) end;
    iange);
                    with LSP^, LCP do
                        begin
                        Constant(FSys + [DotDot],Rf Sy in STypeBegSys then
        begin
        if Sy = LParent then
            begin
            TTop := Top;
            angeType,LValu);
                        Form := SubRange;
                        if StrgType(RangeType) then
              while Display[Top].Occur <> Blck do Top := Top - 1;
            New(CurHeap,1,LSP,Scalar,Declared);
            with LSP^ do
            begin Error(148); RangeType := nil end;
                        Min := LValu; Size := IntgrSize
                                  begin
                Size := IntgrSize; Form := Scalar;
                ScalKind := Declared
                     end;
                    if Sy = DotDot then InSymbol else Error(25);
                    Constant(FSys,LSP1,LValu);
   end;
            LCP1 := 0; LCnt := 0;
            repeat
                InSymbol;
                if Sy = Ident then
                     LSP^.Max := LValu;
                    if LSP^.RangeType <> LSP1 then Error(107)
                    end
                   begin
                    with LCP do
                        begin
                        Name := Id; IdTy              else
                    begin
                    InSymbol;
                    LSP := LCP.IdType;
           B 	
al
115: Base type must be a scalar or a subrange
116: Error in type of standard procedure parameter
117: Unsatisified forwardin this record
153: Type error in read
154: Actual parameter must be a variable
155: Control variable cannot be formal or non reference
118: Forward reference type identifier in variable declaration
119: Re-specified params not OK for a forward declar-local
156: Multidefined case label
158: No such variant in this record
159: Real or string tagfields not allowed
160: Previed procedure
120: Function result type must not be FILE
121: File value parameter not allowed
122: A forward declared functioous declaration was not forward
161: Again forward declared
162: Parameter size must be constant
163: Missing variant in decln's result type can't be re-specified
123: Missing result type in function declaration
124: F-format for reals only
125: Erroaration
164: Substition of standard proc/func not allowed
165: Multidefined label
166: Multideclared label
167: Undeclared lr in type of standard procedure parameter
126: Number of parameters does not agree with declaration
127: Illegal parameter subabel
168: Undefined label
169: Error in base set
170: Value parameter expected
171: Standard file was re-declared
172: Undestitution
128: Result type does not agree with declaration
129: Type conflict of operands
130: Expression is not of set typeclared external file
173: Size of types are not the same
174: Pascal function or procedure expected
175: Constant Expression 
131: Tests on equality allowed only
132: Strict inclusion not allowed
133: File comparison not allowed
134: Illegal type of too complicated
176: Type is not parametric
177: Parameter type does not match type of forward declaration
178: Number of paroperand(s)
135: Type of operand must be boolean
136: Set element type must be scalar or subrange
137: Set element types must ameters does not match forward declaration
187: Attempt to open library unsuccessful
189: Forward Declaration not permitted inbe compatible
138: Type of variable is not array
139: Index type is not compatible with the declaration
140: Type of variable Export Section
193: Not enough room for this operation
194: Comment must appear at top of program
195: Variable must not be  is not record
141: Type of variable must be non-generic file or non-generic pointer
142: Illegal parameter substitution
143:Packed
196: Parameter List does not match previous declaration
201: Error in real number - digit expected
202: String constane appropriate class
104: Undeclared identifier
105: sign not allowed
106: Number expected
107: Incompatible subrange types
 Illegal type of loop control variable
144: Illegal type of expression
145: Type conflict
146: Assignment of files not allowe108: File not allowed here
109: Type must not be real
110: <tagfield> type must be scalar or subrange
111: Incompatible with d
147: Label type incompatible with selecting expression
148: Subrange bounds must be scalar
149: Index type must not be inte<tagfield> part
112: Index type must not be real
113: Index type must be a scalar or a subrange
114: Base type must not be reger
150: Assignment to standard function is not allowed
151: Assignment to formal function is not allowed
152: No such field  C  	
         if LSP <> nil then FSize := LSP^.Size
                    end
                end { Sy = Ident }
            else
 erwise.
{
{ Calls:
{    GetBounds
{    Packable
{
{ Design:
{    A structure is packable if the number of bits required t               begin
                New(CurHeap,1,LSP,SubRange); LSP^.Form := SubRange;
                Constant(FSys + [DotDo represent
{    the structure is less than the number of bits in a word
{--------------------------------------------}
     ot],LSP1,LValu);
                if StrgType(LSP1) then
                  begin Error(148); LSP1 := nil end;
                 var LMin,LMax: integer;
    begin
    Packable := false;
    if (FSP <> nil) and Packing then
        with FSP^ do
                 if (LSP = StrgPtr) and (Sy = LBrack) then
                        begin
                        InSymbol;
         with LSP^ do
                    begin
                    RangeType:=LSP1;
                    Min:=LValu;
                               Constant(FSys + [RBrack],LSP1,LValu);
                        if LSP1 = IntPtr then
                               Size:=IntgrSize
                    end;
                if Sy = DotDot then InSymbol else Error(25);
                Con begin
                            if (LValu.IVal <= 0) or
                              (LValu.IVal > StrgLgth) then
       stant(FSys,LSP1,LValu);
                LSP^.Max := LValu;
                if LSP^.RangeType <> LSP1 then Error(107)
                                 begin
                                Error(203);
                                LValu.IVal := DefSt        end;
            if LSP <> nil then
                with LSP^ do
                    if Form = SubRange then
       rgLgth
                                end;
                            if LValu.IVal <> DefStrgLgth then
                                    if RangeType <> nil then
                            if RangeType^.Size <> 1 then
                                        begin
                                New(CurHeap,1,LSP);
                                LSP^ := StrgPtr^;
         Error(399)
                            else
                                if Min.IVal > Max.IVal then
                                            with LSP^,LValu do
                                    begin
                                    M                  begin Error(102); Max.IVal := Min.IVal end
            end;
        FSP := LSP;
        if not (Sy in FSys)axLeng := IVal;
                                    Size := (IVal+ChrsPerWd) div ChrsPerWd
                                    then
          begin Error(6); Skip(FSys) end
        end
    else
        FSP := nil
    end { SimpleType };

function end
                                end
                            end
                        else
                       Packable(FSP: STP): boolean;
{-----------------------------------------
{ Abstract:
{    Determine is a structure may be pac      Error(15);
                        if Sy = RBrack then InSymbol else Error(12)
                        end;
           ked
{
{ Parameters:
{    FSP - the structure to be tested
{
{ Results:
{    TRUE if the structure may be packed, FALSE oth C 	
t must not exceed source line
203: Integer constant exceeds range
204: 8 or 9 in octal number
250: Too many scopes of nested xceptions may not be Forward Declared
420: Handler and Exception are not compatible
421: Handler may not be global in a Moduleidentifiers
251: Too many nested procedures or functions
252: Too many forward references of procedure entries
253: Procedure
-1: Undefined Error
                                                                                                          too long
254: Too many long constants in this procedure
256: Too many segments
257: Too many externals
258: Too many local  files
259: Expression too complicated
260: String constant too long
261: Invalid character in numerical constant
300: Divisi on by zero
301: No case provided for this value
302: Index expression out of bounds
303: Value to be assinged is out of bound s
304: Element expression out of range
305: Internal Error - Attempt to generate an Illegal QCode
306: Internal Error - EStacProgram QDis;

{************************************************}
{ QCode Disassembler                             }
{ Writtk is not empty
307: EStack Overflow - Expression too complicated
308: Internal Error - EStack Underflow
397: Forward declaraten by: Miles A. Barel                     }
{             July 21, 1979                      }
{ COPYRIGHT (C) 1981  Three Rivion was in another segment
398: Implementation restriction
399: Implementation restriction
400: Illegal character in text
40er Computer Corporation }
{               Pittsburgh, PA 15217             }
{************************************************1: Unexpected end of input
402: Error in writing code file, not enough room
403: Error in reading INCLUDE or IMPORT file
404:}

{ }
{ 1 Apr 81  V1.5  Miles A. Barel
{ Conversions to run uner the new OS
{ }
{ 30-Mar-81  V1.4  Miles A. Barel
{ Spec Error in writing list file, not enough room
405: Call not allowed in separate procedure
406: Include file not legal
407: Errial handling for Exception Definitions and TEMPORARILY REMOVED Long
{ Integer Stuff (As they are not yet available
{ }
{ 04-For Reading Symbol Table
408: Error Writing Symbol Table
409: Import file not legal
410: Module not found
411: Error in readieb-81  V1.3  Miles A. Barel
{ Added disassembly of Long Integer QCodes
{ }
{ 23-Jan-81  V1.2  Miles A. Barel
{ Fixed disasseng code file
412: Module may not have a main body
413: Internal Compiler Error
414: Version Switch Too Long
415: Copyright Smbly of EXGO
{ }

Label
        1,2;

Imports QCodes from QCodes.Dfs;     { QCode constant definitions }
Imports FileSyswitch Too Long
416: No Such Switch
417: Switch is not unique
418: Exception not defined for this Handler
419: Handlers and Etem from FileSystem;
Imports IO from IO;
Imports IOErrors from IOErrors;
Imports Perq_String from Perq_String;

Const
     D  	
;
                       LMax := LMax + 1;
                       if LMax < BitsPerWd then
                           begin
:
{    When extra bits are left at the end of a word, if the last field
{    may be changed to look like a byte (without affec                           Packable := true;
                           NumBits := LMax
                           end
      ting the use of the
{    field) this is done, as byte accesses are cheaper than packed field
{    accesses
{-----------------                 end
              end {case}
    end { Packable };

procedure FieldList(FSys: SetOfSys; var FRecVar: STP);----------------------}
        var OnBound: boolean;  NCP: Identifier;
      begin
      OnBound := false;
      with FCP d
{--------------------------------
{ Abstract:
{    Parse the field list of a record declaration
{
{ Parameters:
{    FSyso
          if Packable(IdType) then
              begin
              if (NumBits + NextBit) > BitsPerWd then
              - the possible terminal symbols for the field list
{    FRecVar - place to return the first field of the list
{
{ Side Effec   begin Displ := Displ + 1; NextBit := 0; OnBound := true end;
              FldAddr := Displ; FIsPackd := true;
            ts:
{    The state of CurIFile will be modified
{    New structures may be allocated
{    New identifiers will be entered in   FldWidth := NumBits; FldRBit := NextBit;
              NextBit := NextBit + NumBits
              end
          else
          case Form of
              SubRange,
              Scalar:  if (FSP <> IntPtr) and (FSP^.Size = 1) then
                the Symbol Table
{
{ Calls:
{    Error
{    Skip
{    NextINum
{    EnterId
{    InSymbol
{    Typ
{    LookupNum
{              begin
                           GetBounds(FSP,LMin,LMax);
                           if LMin >= 0 then
           Allocate
{    WriteNum
{    VariantList
{------------------------------------}
      var LSP,LSP1,LSP2,LSP3,LSP4: STP;
                        begin
                               Packable := true;
                               NumBits := 1; LMin        NXT,NXT1,Last: integer;  LCP,LCP1: Identifier;
          MinSize,MaxSize,LSize: AddrRange; LValu: Valu;
          MaxBi:= 1;
                               while LMin < LMax do
                                   begin
                          t,MinBit: BitRange; Test:boolean;

procedure Allocate(var FCP: Identifier);
{------------------------------------
{ Abstrac         LMin := LMin + 1;
                                   LMin := LMin + LMin - 1;
                                   NumBt:
{    Allocate space for the next field in a record (allocated as an offset
{    from the base of the record).
{
{ Parametits := NumBits + 1
                                   end
                               end
                           end;ers:
{    FCP - the identifier which names the field to be allocated
{
{ Side Effects:
{    The identifier FCP will be modif
              Power:   if Packable(ElSet) then
                       begin
                       GetBounds(ElSet,LMin,LMax)ied.
{    The previous field identifier may be modified
{
{ Calls:
{    Packable
{    LookupNum
{    WriteNum
{
{ Design D 	
rrent block number }
        CurBase,                                { the base block number, from }
                         f Str[i] in ['0'..'9'] then
            IVal:=IVal*10 + ord(str[i]) - ord('0')
        else
            begin
            Ge                       { which positions are relative }
        CurPtr,                                 { current position withtNum:=-1;
            exit(GetNum)
            end;
    GetNum:=IVal
    end
end { GetNum };

Function GetByte(Pos:integein Buf }
        CurPos,                                 { current position relative to }
                                    r):integer;
{ get byte with offset Pos from CurBase block byte 0 }
begin
CurPos:=Pos;
if (CurMin <= Pos) and (Pos <= CurMax)    QDISVersion = 'V1.5';

Type
        QCodes = LDC0..RESERVD;
        QStr = packed array[0..6] of char;
        QFile =             { CurBase byte 0 }
        CurMin,                                 { min pos within Buf }
        CurMax:integer; array [0..255] of record QName:QStr end;
        PRP = ^ProcRec;
        ProcRec = record
                        Next: PRP;                        { max pos within Buf }
        
Procedure Init;
{ procedure to initialize the sets of Q-Code types }
                        PS,RPS,ACS,EntA,ExtA,LL: Integer
                    end;
        ReadBuffer = packed array[0..511] o
begin
New(0,256,Buf);
Q0:=[LDC0..LDCMO,LSA,STIND..STCH,QAND..GTRSTR,EQUPOWR..SRS,ABI..DIF,NOP..MES,
     LSSN,PSW..INTON,LDLf char;

Var
        I,J,Offset: integer;
        Infile: FileId;         { File to disassemble }
        OutFile: Text;   0..LDL15,STL0..STL7,LDO0..LDO15,STO0..STO7,MVBW,MOVW,
     IND0..IND7,STMW..SAS,CALLV,ATPW,RETURN..LDTP,IXA1..EXCH2,LDMW,
           { File for disassembly output }
        DatFil: file of QFile;  { File with QCode nmemonics }
        IFName,OFName: st LDDC,LDDW,RESERVD,REFILLOP];
Q1S:=[LDCB,ROTSHI,ATPB,JMPB,JFB,JTB,JEQB,JNEB];
Q1B:=[EQUBYT..GTRBYT,EQUWORD..NEQWORD,LDLB,LLAB,ring;  { input and output file names }
        Procs: integer;         { number of procedures in segment Seg }
        TProc: STLB,LDOB,LOAB,STOB,MVBB,MOVB,
      INDB,ADJ..CALLL,IXP,IXAB,INCB,LDMC,STLATE,CMPL];
Q1W:=[LDCW,LDLW,LLAW,STLW,LDOW,LOAW,STOWinteger;         { currently selected procedure }
        QC,LastQC: integer;     { Current and Last QCodes }
        Q0,Q1S,Q,INDW,JMPW,JFW,JTW,JEQW,JNEW,IXAW,INCW];
Q2B:=[LDIB,STIB,LIAB,LDGB,LGAB,STGB,CALLXB];
Q2BW:=[LDGW,LGAW,STGW,LDIW,LIAW,STIW];
1B,Q1W,Q2B,     { sets of different Q-Code formats }
        Q2BW,Q2WB,Q2W,Q3WBB,Q3WBW: set of QCodes;
        FirstPR,CurPR:PQ2WB:=[EXITT,CALLXW];
Q2W:=[LGAWW];
Q3WBB:=[LVRD,ENABLE];
Q3WBW:=[QRAISE]
end;

Function GetNum(Str: string): Integer;
{ RP;
        CurIC: integer;         { Current IC within procedure }
        
        { Stuff for reading the input file }
  return numerical value of string (in decimal). }
{ returns -1 if invalid character in string or null string }
  var IVal,I: In      Buf: ^ReadBuffer;                       { current block buffer }
        CurBlock,                               { the cuteger;
begin
if Length(str) = 0 then
    GetNum:=-1
else
    begin
    IVal:=0;
    for i:=1 to Length(str) do
        i E  	
else
                      if (FldWidth <= 8) and (FldRBit <= 8) then
                        begin FldWidth := 8; FldRBit := Colon then InSymbol else Error(5)
              end;
          if Sy = Ident then
              begin
              SearchId8 end;
          WriteNum(NCP);
          end
      end { Allocate };

procedure VariantList;
{--------------------------([Types],LCP1);
              LSP1 := LCP1.IdType;
              if LSP1 <> nil then
                  begin
               --------
{ Abstract:
{    Parse the variant portion of a Field List
{
{ Side Effects:
{    The state of CurIFile will be mo   if LSP1^.Form <= SubRange then
                      begin
                      if LSP1^.Size <> 1 then Error(179);
     dified
{    New identifiers may be entered in the Symbol Table
{    New structures may be allocated
{    The variant list wil                 LCP.IdType := LSP1;
                      LSP^.TagFieldP := LCP1.IdNum;
                      if GotTagName tl be tagged onto FRecVar (defined by FieldList)
{
{ Calls:
{    New
{    InSymbol
{    SearchId
{    NextINum
{    EnterIhen
                          begin
                          Allocate(LCP);
                          WriteNum(LCP)
       d
{    Error
{    CompTypes
{    Allocate
{    WriteNum
{    Skip
{    Constant
{    LookupNum
{    FieldList
{--------                   end
                      end
                  else
                      Error(110)
                  e---------------------------}
        var GotTagName: boolean;  NCP: Identifier; Test: boolean;
      begin
      New(CurHeap,nd;
              InSymbol
              end
          else
            begin Error(2); Skip(FSys + [OfSy,LParent]) end
   1,LSP,TagFld);
      with LSP^ do
        begin TagFieldP := 0; FstVar := nil; Form := TagFld end;
      FRecVar := LSP;
          end
      else
        begin Error(2); Skip(FSys + [OfSy,LParent]) end;
      LSP^.Size := Displ + ord(NextBit > 0);
   InSymbol;
      if Sy = Ident then
          begin
          GotTagName := false; PrtErr := false;
          SearchId([Ty      if Sy = OfSy then InSymbol else Error(8);
      LSP1 := nil; MinSize := Displ; MaxSize := Displ;
      MinBit := NextBit         begin
              Displ := Displ + ord(NextBit > 0);
              NextBit := 0; OnBound := true;
              FIpes],LCP1); PrtErr := true;
          if LCP1.IdNum = 0 then
              begin
              GotTagName := true;
         sPackd := false; FldAddr := Displ;
              if IdType <> nil then
                  Displ := Displ + IdType^.Size;
          with LCP do         { LCP is defined in FieldList }
                  begin
                  IdType := nil;
                    end;
      if OnBound and (Last <> 0) then
          begin
          LookupNum(Last,NCP);
          with NCP do
         Klass:=Field;
                  Next := 0;
                  FIsPackd := false;
                  IdNum:=NextINum;
              if FIsPackd then
                  if FldRBit = 0 then
                      FIsPackd := false
                                  Name := Id
                  end;
              EnterId(LCP);
              InSymbol;
              if Sy =  E 	
) }
begin
CurPos:=CurPos - 1;
CurPtr:=CurPtr - 1;
CurIC:=CurIC-1;
if CurPtr < 0 then
    { must backup a block }
    begiroc in [0..Procs-1]) then
        begin
        writeln('You don''t have that procedure');
        goto 1
        end;
Selen
    CurMax:=CurMin-1;
    CurMin:=CurMax-511;
    CurBlock:=CurBlock-1;
    CurPtr:=511
    end;
LastByte:=Ord(Buf^[CurPctProc:=Proc
end { SelectProc };

Procedure PrintPrcTbl;
{ print the procedure table }
begin
WriteLn(chr(12),'Routine   Letr])
end { LastByte };

Function GetWord(Pos: integer):integer;
{ get word with offset Pos from CurBase block byte 0 }
var x Lev   PS      RPS     LTS     Enter   Exit');
CurPR:=FirstPR;
i:=0;
while CurPR <> nil do
    with CurPR^ do
        begiword:packed record
                   case boolean of
                        true: (HiByte,LoByte:0..255);
                 n
        write(i:5,ll:10,ps:8,rps:8,acs:8);
        if (enta = 0) and (exta = 0) then
            writeln('      Exception')       false:(Wrd:integer)
                      end;
begin
Word.LoByte:=GetByte(pos);
Word.HiByte:=NextByte;
GetWord:=Word
        else
            writeln(enta:8,exta:8);
        i:=i+1;
        CurPR:=Next
        end
end { PrintPrcTbl };

.Wrd
end { GetWord };

Function NextWord: integer;
{ get the next word (i.e. curpos +1,,+2) }
var Word:packed record
     Function GetProcBase(Proc:integer):integer;
{ print the entry IC for procedure PROC }
  var TmpPR:PRP; i:integer;
begin
TmpP then
    { byte is in Buf }
    CurPtr:=Pos-CurMin          { position the cursor to it }
else
    { byte is in a different              case boolean of
                        true: (HiByte,LoByte:0..255);
                        false:(Wrd:integer block }
    begin
    CurBlock:=CurBase + (Pos div 512);  { determine the block number }
    FSBlkRead(InFile,CurBlock,recas)
                      end;
begin
Word.LoByte:=NextByte;
Word.HiByte:=NextByte;
NextWord:=Word.Wrd
end { NextWord };

Ft(Buf,PDirBlk));
    CurMin:=(CurBlock - CurBase) * 512;
    CurMax:=CurMin + 511;
    CurPtr:=Pos mod 512
    end;
GetByteunction LastWord: integer;
{ get the previous word (i.e. CurPtr -2,,-1) }
var Word:packed record
                   case bool:=Ord(Buf^[CurPtr])
end { GetByte };

function NextByte:integer;
{ get next byte (i.e. curpos +1) }
begin
CurPos:=CurPos+1ean of
                        true: (HiByte,LoByte:0..255);
                        false:(Wrd:integer)
                    ;
CurIC:=CurIC+1;
CurPtr:=CurPtr+1;
if CurPtr = 512 then
    { must move on to the next block }
    begin
    CurMin:=CurM  end;
begin
Word.HiByte:=LastByte;
Word.LoByte:=LastByte;
LastWord:=Word.Wrd
end { LastWord };

Function SelectProc: Intax+1;
    CurMax:=CurMin+511;
    CurBlock:=CurBlock+1;
    CurPtr:=0;
    FSBlkRead(InFile,CurBlock,recast(Buf,PDirBlk));
eger;
{ Select proc for disassembly - returns -1 if invalid proc is given }
  label 1;
  var str:string; Proc: Integer;
begi    end;
NextByte:=Ord(Buf^[CurPtr])
end { NextByte };

Function LastByte: integer;
{ get the previous byte (i.e. CurPtr -1n
1:Write(chr(13),'Routine to Disassemble (<CR> to quit)?');
ReadLn(Str);
Proc:=GetNum(Str);
if Proc > 0 then
    if not (P F  	
],LSP3,LValu);
              if LSP^.TagFieldP <> 0 then
                  begin
                  LookupNum(LSP^.TagFieldP,N    Displ := MinSize; NextBit := MinBit
              end
      until (Test) or (Sy = EndSy);
      Displ := MaxSize; NextBitCP);
                  if not CompTypes(NCP.IdType,LSP3) then
                      Error(111);
                  end;
      := MaxBit;
      LSP^.FstVar := LSP1
      end { VariantList };

begin { FieldList }
    NXT1 := 0; LSP := nil; Last := 0         New(CurHeap,1,LSP3,Variant);
              with LSP3^ do
                  begin
                  NxtVar := LSP1; S;
    if not (Sy in [Ident,CaseSy]) then
      begin Error(19); Skip(FSys + [Ident,CaseSy]) end;
    while Sy = Ident do
   ubVar := LSP2;
                  VarVal := LValu; Form := Variant
                  end;
              LSP1 := LSP3; LSP2 :=      begin
        NXT := NXT1;
        repeat
            if Sy = Ident then
                begin
                with LCLSP3;
              Test := Sy <> Comma;
              if not Test then InSymbol
          until Test;
          if Sy = ColP do
                    begin
                    Name := Id; IdType := nil; Next := NXT;
                    Klass := Fieldon then InSymbol else Error(5);
          if Sy = LParent then InSymbol else Error(9);
          if Sy = RParent then
       ; FIsPackd := false;
                    IdNum:=NextINum;
                    end;
                NXT := LCP.IdNum;
              LSP2 := nil
          else
              FieldList(FSys + [RParent,SemiColon],LSP2);
          if Displ > MaxSize then         EnterId(LCP);
                InSymbol
                end
            else
                Error(2);
            
            begin MaxSize := Displ; MaxBit := NextBit end
          else
              if (Displ = MaxSize) and (NextBit > Mif not (Sy in [Comma,Colon]) then
              begin Error(6); Skip(FSys + [Comma,Colon,SemiColon,CaseSy]) end;
            TaxBit) then
                  MaxBit := NextBit;
          while LSP3 <> nil do
              begin
              LSP4 := LSest := Sy <> Comma;
            if not Test then InSymbol
        until Test;
        if Sy = Colon then InSymbol else Error(P3^.SubVar; LSP3^.SubVar := LSP2;
              LSP3^.Size := Displ + ord(NextBit > 0);
              LSP3 := LSP4
          5);
        Typ(FSys + [CaseSy,SemiColon],LSP,LSize);
        while NXT <> NXT1 do
            begin
            LookupNum(N    end;
          if Sy = RParent then
              begin
              InSymbol;
              if not (Sy in FSys + [SemiXT,LCP1);
            with LCP1 do
                begin
                IdType := LSP;
                Allocate(LCP1);
   Colon]) then
                begin Error(6); Skip(FSys + [SemiColon]) end
              end
          else
              Err             WriteNum(LCP1);
                if Next = NXT1 then Last := NXT;
                NXT := Next
                end; MaxBit := NextBit;
      repeat
          LSP2 := nil;
          repeat
              Constant(FSys + [Comma,Colon,LParentor(4);
          Test := Sy <> SemiColon;
          if not Test then
              begin
              InSymbol;
           F 	
extWord:8)
else if QC = LSA then
    begin
    WordAlign;
    cnt:=NextByte;
    write(OutFile,'  ''');
    for i:=1 to cniNib:8)
            end
        end
else if QC in [EQUByt..GTRByt,EQUWord..NEQWord] then
    begin
    Tmp:=NextByte;
    t do
        begin
        ch:=chr(NextByte);
        write(OutFile,ch)
        end;
    write(OutFile,'''')
    end;
wriif Tmp = 0 then
        write(OutFile,'ETOS':8)
    else
        write(OutFile,Tmp:8)
    end
else if QC = CMPL then
    cteln(OutFile)
end { Dis0 };

Procedure Dis1S;
{ for QCodes with One Signed Byte arguments }
{ Special Case: ROTSHI }
  varase NextByte of
        0: write('=':8);
        1: write('<>':8);
        2: write('<=':8);
        3: write('<':8);
      Word:packed record
                     case boolean of
                             true: (HiByte,LoByte:0..255);
            4: write('>=':8);
        5: write('>':8)
      end
else
    begin
    Tmp:=NextByte;
    write(OutFile,Tmp:8);
    if                    false:(Wrd:integer)
                   end;
begin
Word.LoByte:=NextByte;
if QC = ROTSHI then
    if Wor QC = LDMC then
        begin
        for i:=1 to Tmp do
            if i = 1 then
                write(OutFile,NextWord:8)d.LoByte = 0 then
        write(OutFile,'SHIFT':8)
    else
        write(OutFile,'ROTATE':8)
else
    begin
    if Word.L
            else
                write(OutFile,chr(13),' ':17,NextWord:8)
        end
    end;
writeln(OutFile)
end { DisoByte > 127 then
        Word.HiByte:=255
    else
        Word.HiByte:=0;
    if not (QC in [JMPB,JFB,JTB,JEQB,JNEB]) then1B };

Procedure Dis1W;
{ for QCodes with one word argument }
  var Ofst:integer;
begin
if QC in [JMPW,JFW,JTW,JEQW,JNEW] 
        write(OutFile,Word.Wrd:8)
    else
        write(OutFile,CurPos+1+Word.Wrd-CurPR^.EntA:8)
    end;
writeln(OutFile)then
    begin
    Ofst:=NextWord;
    writeln(OutFile,CurPos+1+Ofst-CurPR^.EntA:8)
    end
else
    writeln(OutFile,NextW
end { Dis1S };

Procedure Dis1B;
{ for QCodes with one UNSIGNED byte argument }
  var Byt:packed record
                 ord:8)
end { Dis1W };

Procedure Dis2B;
{ for QCodes with 2 UNSIGNED byte arguments }
begin
writeln(OutFile,NextByte:8,NexR:=FirstPR;
for i:=0 to Proc-1 do TmpPR:=TmpPR^.Next;
GetProcBase:=TmpPR^.EntA
end { PrintPrcTbl };

Procedure WriteIC;
{    case boolean of
                            true: (HiNib,LoNib:0..15);
                            false:(By:0..255)
     write out the current IC }
begin
Write(OutFile,CurIC:8,': ')
end { WriteIC };

Procedure WordAlign;
{ procedure to word al            end;
      Tmp,i: integer;
begin
if QC in [IXP,STLATE] then
    with Byt do
        begin
        By:=NextByteign IC (CurPos) }
  var junk:integer;
begin
if not odd(CurPos) then junk:=NextByte
end { WordAlign };

Procedure Dis0;
{ ;
        if QC = IXP then
            write(OutFile,HiNib:8,LoNib:8,'  Elements/Word   Field Width')
        else { QC = STLDisassemble QCodes with no arguments }
  var cnt,i:integer; ch: char;
begin
if QC = LDDC then
    Write(OutFile,NextWord:8,NATE }
            begin
            if LoNib <> 0 then write(OutFile,LoNib:8);
            if HiNib <> 0 then write(OutFile,H G  	
             begin
                Name := Id; IdType := LSP;
                Next := FwPtr; Klass := Types;
                r then
                    begin Error(149); LSP2 := nil end;
              LSP^.InxType := LSP2
              end
         IdNum:=NextINum;
                end;
            WriteNum(LCP);
            FwPtr := LCP.IdNum
            end
        els else
              begin Error(113); LSP2 := nil end;
        Test := Sy <> Comma;
        if not Test then InSymbol
    un;
            end;
        NXT1 := LCP.IdNum;
        if Sy = SemiColon then
            begin
            InSymbol;
     e
            begin
            if LCP.IdType <> nil then
                LSP^.ElType := LCP.IdType
            end;
             if not (Sy in [Ident,EndSy,CaseSy]) then
              begin Error(19); Skip(FSys + [Ident,CaseSy]) end
            end  InSymbol;
        end
    else
        Error(2)
    end { PointerType };

procedure ArrayType;
{----------------------
        end {while};
    NXT := 0;
    while NXT1 <> 0 do
        begin
        LookupNum(NXT1,LCP1);
        LookupNum(L-------------------
{ Abstract:
{    Parse the declaration of an array type
{
{ Side Effects:
{    The state of CurIFile wiCP1.Next,LCP);
        LCP1.Next:=NXT;
        NXT:=NXT1;
        NXT1:=LCP.IdNum;
        WriteNum(LCP1);
        end;
  ll be modified
{    New structures will be allocated
{
{ Calls:
{    New
{    SimpleType
{    Error
{    InSymbol
{    T  if Sy = CaseSy then
        VariantList
    else
        FRecVar := nil
    end { FieldList };

procedure PointerType;yp
{    Packable
{    GetBounds
{-----------------------------------------}
      var Test:Boolean;
    begin
    InSymbol
{-----------------------------------------
{ Abstract:
{    Parse the declaration of a pointer type
{
{ Side Effects:
{   ;
    if Sy = LBrack then InSymbol else Error(11);
    LSP1 := nil;
    repeat
        if Packing then
            New(CurH The state of CurIFile will be modified
{    New structures will be allocated
{    New symbol table entries may be made
{
{ eap,1,LSP,Arrays,true,false)
        else
            New(CurHeap,1,LSP,Arrays,false);
        with LSP^ do
            begiCalls:
{    New
{    SearchId
{    NextINum
{    WriteNum
{    InSymbol
{    Error
{-------------------------------------n
            AElType := LSP1; InxType := nil;
            if Packing then AIsStrng := false;
            AIsPackd := false; ----}
    begin
    New(CurHeap,1,LSP,Pointr); FSP := LSP;
    with LSP^ do
      begin ElType := nil; Size := PtrSize; Form Form := Arrays
            end;
        LSP1 := LSP;
        SimpleType(FSys + [Comma,RBrack,OfSy],LSP2,LSize);
        LSP := Pointr end;
    InSymbol;
    if Sy = Ident then
        begin
        PrtErr := false;
        SearchId([Types],LCP); 1^.Size := LSize;
        if LSP2 <> nil then
          if LSP2^.Form <= SubRange then
              begin
              if PrtErr := true;
        if LCP.IdNum = 0 then   { forward referenced type Id }
            begin
            with LCP do
   LSP2^.Size <> 1 then
                  begin Error(179); LSP2 := nil end
              else
                  if LSP2 = IntPt G 	
utFile,NextByte:8,NextWord:8)
end { Dis2BW };

Procedure Dis2WB;
{ for QCodes with first arg WORD and second arg UNSIGNED byif QC in Q3WBW then Dis3WBW
{ Case Jump - a class by itself }
else if QC = XJP then
    DisXJP
{ Exit Goto - in a class by ite }
begin
writeln(OutFile,NextWord:8,NextByte:8)
end { Dis2WB };

Procedure Dis2W;
{ for QCodes with two Word arguments }tself }
else if QC = EXGO then
    DisEXGO
{ we don't know about this QCode???? Sigh* }
else
    writeln(OutFile,'Undefined
begin
writeln(OutFile,NextWord:8,NextWord:8)
end { Dis2W };

Procedure Dis3WBB;
{ for QCodes with first arg WORD and 2nd  QCode ',QC);
QC:=NextByte
end { NextQCode };

Procedure Disassemble;
{ main body of disassembly here }
begin
{ Title lisand 3rd UNSIGNED byte }
begin
writeln(OutFile,NextWord:8,NextByte:8,NextByte:8)
end { Dis3WBB };

Procedure Dis3WBW;
{ forting }
writeln(OutFile,'File ',IFName,'     Procedure ',TProc,chr(13));
CurPR:=FirstPR;
for i:=1 to TProc do CurPR:=CurPR^.Ne QCodes with first arg WORD, 2nd UNSIGNED byte, 3rd WORD }
begin
writeln(OutFile,NextWord:8,NextByte:8,NextWord:8)
end { Dis3xt;
WriteLn(OutFile,'Lex Lev   PS      RPS     LTS     Enter   Exit');
with CurPR^ do
    begin
    write(OutFile,ll:5,ps:8,WBB };

Procedure DisXJP;
{ for Case QCode }
  var Min,Max,Ofst,i:integer;
begin
WordAlign;
Min:=NextWord;
Max:=NextWordrps:8,acs:8);
    if (enta = 0) and (exta = 0) then
        begin
        writeln('      Exception');
        exit(Disassemb;
Ofst:=NextWord;
writeln(outfile,min:8,max:8,CurPos-1+Ofst:8,'  Min,Max,Default IC');
for i:=min to max do
    begin
    wle)
        end
    else
        writeln(enta:8,exta:8)
    end;
WriteLn(OutFile);
QC:=GetByte(CurPR^.EntA);              rite(outfile,' ':10,'case ',i:8,':  ');
    Ofst:=NextWord;
    writeln(outfile,CurPos-1+Ofst-CurPR^.EntA:8)
    end
end { D              { first byte }
CurIC:=0;
LastQC:=0;
repeat
    NextQCode
until (LastQC = RETURN) and (CurPos >= CurPR^.ExtA)isXJP };

Procedure DisEXGO;
{ for EXGO QCode }
  var PNum:integer;
begin
write(OutFile,NextWord:8);          { The Segmen
end { Disassemble };

function DoProc:boolean;
{ procedure to select procedures from current segment until no more proceduret number }
PNum:=NextByte;
writeln(OutFile,PNum:8,(NextWord-GetProcBase(PNum)):8)
end { DisEXGO };

Procedure NextQCode;
{s }
{ in this segment are desired }
  var c:char;
begin
PrintPrcTbl;
TProc:=SelectProc;
if TProc >= 0 then
    begin
    QCode type differentiation done here }
begin
LastQC:=QC;
WriteIC;
Write(OutFile,DatFil^[QC].QName:7);
if QC in Q0 then Dis Disassemble;
    write('Type <space> to continue');
    c:='a';
    while c <> ' ' do
         while IOCRead(TransKey,c) <>0
else if QC in Q1S then Dis1S
else if QC in Q1B then Dis1B
else if QC in Q1W then Dis1W
else if QC in Q2B then Dis2B
else  IOEIOC do ;
    DoProc:=true
    end
else
    DoProc:=false
end;

begin { QDis }
rewrite(output);
reset(input);

WritByte:8)
end { Dis2B };

Procedure Dis2BW;
{ for QCodes with first arg UNSIGNED byte and secord arg WORD }
begin
writeln(Oif QC in Q2BW then Dis2BW
else if QC in Q2WB then Dis2WB
else if QC in Q2W then Dis2W
else if QC in Q3WBB then Dis3WBB
else  H  	
 LSize := 1 end;
                Size := LSize
                end
            end;
        LSP := LSP1; LSP1 := LSP2
    ur (LSP1 = IntPtr) then
            begin Error(115); LSP1 := nil end
        else
            if LSP1^.Size <> 1 then
      ntil LSP1 = nil
    end { ArrayType };

Procedure RecordType;
{-----------------------------------------
{ Abstract:
{           begin Error(114); LSP1 := nil end;
    New(CurHeap,1,LSP,Power);
    with LSP^ do
        begin
        ElSet := LSP Parse the declaration of a record type
{
{ Side Effects:
{    The state of CurIFile will be modified
{    New structures wi1; Form := Power;
        if LSP1 <> nil then
            begin
            GetBounds(LSP1,LMin,LMax);
            if (LMin ll be allocated
{
{ Calls:
{    InSymbol
{    Error
{    FieldList
{    New
{-----------------------------------------}
< 0) or (LMax < 0) then
                begin Error(169); LMax:=0 end;
            Size := (LMax + BitsPerWd) div BitsPerWd
     begin
    InSymbol;
    OldTop := Top;
    if Top < DispLimit then
        begin
        Top := Top + 1;
        with            end
        else
            Size := 0
        end
    end { SetType };

Procedure FileType;
{---------------til Test;
    if Sy = RBrack then InSymbol else Error(12);
    if Sy = OfSy then InSymbol else Error(8);
    Typ(FSys,LSP,LSiDisplay[Top] do
          begin FName := 0; Occur := Rec end
        end
    else
        Error(250);
    Displ := 0; NextBze);
    if Packable(LSP) then
        if NumBits + NumBits <= BitsPerWd then
            with LSP1^ do
                begiit := 0;
    FieldList(FSys-[SemiColon]+[EndSy],LSP1);
    Displ := Displ + ord(NextBit > 0);
    New(CurHeap,1,LSP,Records);n
                AIsPackd := true;
                ElsPerWd := BitsPerWd div NumBits;
                if ElsPerWd = 2 then

    with LSP^ do
        begin
        FstFld := Display[Top].FName;
        RecVar := LSP1; Size := Displ;
        Form :                    ElWidth:=8 { might as well just use a byte }
                else
                    ElWidth := NumBits
= Records
        end;
    Top := OldTop;
    if Sy = EndSy then InSymbol else Error(13)
    end { RecordType };

Procedu                end;
    repeat
        with LSP1^ do
            begin
            LSP2 := AElType; AElType := LSP;
      re SetType;
{-----------------------------------------
{ Abstract:
{    Parse the declaration of a set type
{
{ Side Effect      if InxType <> nil then
                begin
                GetBounds(InxType,LMin,LMax);
                if AIsPackd s:
{    The state of CurIFile will be modified
{    New structures will be allocated
{
{ Calls:
{    InSymbol
{    Error
then
                    LSize := (LMax-LMin+ElsPerWd)
                                     div ElsPerWd
                else{    New
{    SimpleType
{    GetBounds
{-----------------------------------------}
    begin
    InSymbol;
    if Sy = Of
                    LSize := LSize*(LMax - LMin + 1);
                if LSize <= 0 then
                  begin Error(398);Sy then InSymbol else Error(8);
    SimpleType(FSys,LSP1,LSize);
    if LSP1 <> nil then
        if (LSP1^.Form > SubRange) o H 	
 ngth(ThisStr) do
                QName[i-1]:=ThisStr[i];
        put(outfile);
        cur:=cur+1
        end;
close(InFileProgram FQCODES;
{ program to format QCODES.TEXT into QCODES }
Type
        QStr = Packed array[0..6] of char;
        QRec );
close(OutFile)
end.
                                                                                                      teLn(chr(12),'QCode Disassembler ',QDISVersion);
Init;
reset(DatFil,'QCodes');
1:Write('Input File: ');
ReadLn(IFName);
for= record
                   QName:QStr
                 end;
Var
        InFile:Text;
        OutFile:File of QRec;
       i:=1 to Length(IFName) do
    if IFName[i] in ['a'..'z'] then
        IFName[i]:=chr(ord(IFName[i])-32);
if Pos(IFName,'.SEG  Cur,Num,i:integer;
        ThisStr,Str:string;
        FilNam: string;

begin
reset(input);
rewrite(output);

writeln(') = 0 then IFName:=Concat(IFName,'.SEG');
InFile:=FSLookup(IFName,i,i);
Write('Output File[Console:]');
ReadLn(OFName);
if 'FQCODES V1.0');
writeln('Program to format QCode definitions file for QCode Disassembler');

writeln('Input File is QCODES.DLength(OFName) = 0 then OFName:='CONSOLE:';
ReWrite(OutFile,OFName);
{ Get the Procedure Dictionary }
FSBlkRead(InFile,1,recaAT');
reset(InFile,'QCODES.DAT');

writeln('Output File is QCODES');
rewrite(outfile,'QCODES');

Cur:=0;
read(InFile,num)st(Buf,PDirBlk));
CurBlock:=1;
CurBase:=1;
CurMin:=0;
CurMax:=511;
Offset:=GetWord(0) * 2;
Procs:=NextWord;
FirstPR:=nil;;
readln(infile,Str);
while Cur <= 255 do
    with OutFile^ do
        begin
        if num < cur then
            begin

for i:=1 to Procs do
    begin
    if FirstPR = nil then
        begin
        New(FirstPR);
        CurPR:=FirstPR;
               writeln('?FQCODES-F-',num,' multiply defined or out of order');
            exit(FQCODES)
            end;
           CurPR^.PS:=GetWord(Offset)
        end
    else
        begin
        New(CurPR^.Next);
        CurPR:=CurPR^.Next;
   if num = cur then
            begin
            ThisStr:=str;
            Read(InFile,num);
            if num <> 0 then
       CurPR^.PS:=NextWord
        end;
    with CurPR^ do
        begin
        Next:=nil;
        RPS:=NextWord;
                       readln(infile,str)
            else
                num:=256
            end
        else
            begin ACS:=NextWord;
        EntA:=NextWord;
        ExtA:=NextWord;
        LL:=NextWord;
        j:=NextWord;
        j:=NextW
            ThisStr:='UNDEFND';
            writeln('QCode ',cur,' undefined')
            end;
        QName:='       ';
ord
        end
    end;
while DoProc do ;
Close(OutFile)
end.

                                                                 if length(ThisStr) > 7 then
            begin
            writeln('Warning - ',ThisStr,' truncated to 7 characters'); 
            for i:=1 to 7 do
                QName[i-1]:=ThisStr[i]
            end
        else
            for i:=1 to le I  	
            end
        else
            begin
            Size := FDSize + LSize;
            ElWordSize := LSP1^.Size
             end;
        ElBitSize := 0;
        if Packable(LSP1) then
            if NumBits + NumBits <= BitsPerWd then
                 begin
                ElWordSize := 0;
                ElBitSize := NumBits
                end
        end
   {----------------------------------------
{
{ Declarations Processor Part B
{ Copyright (C) 1981  Three Rivers Computer Corpo end { FileType };

begin { Typ }
  Packing := false;
  if not (Sy in TypeBegSys) then
      begin Error(10); Skip(FSys + ration
{
{ Abstract:
{    The second part of the declarations processor - deals mainly with
{    Import, Label, Const, Type TypeBegSys) end;
  if Sy in TypeBegSys then
      begin
      if Sy in STypeBegSys then
          SimpleType(FSys,FSP,FSize)and Var declarations
{
{ File: Dec1.Pas
{
{---------------------------------------}

{ }
{ 17-Mar-81  2.5  Miles A. Bare
      else
{ ^ }     if Sy = Arrow then
              PointerType
          else
              begin
              if Sy l
{ Import Bug Fix
{ }
{ 03-Feb-81  2.0  Miles A. Barel
{ Fixed Error Detection for Module Not Found on Import Declaration
= PackedSy then
                  begin
                  InSymbol; Packing := true;
                  if not (Sy in TypeDels{ }
{ 9-Jan-81  1.8  Miles A. Barel
{ Fixed declaration of non-descriminent variant record.  The correct type
{ information f) then
                    begin Error(10); Skip(FSys + TypeDels) end
                  end;
{ Array }     if Sy = ArraySy thor the variant is now kept.
{ }
{ 6-Jan-81  1.6  Miles A. Barel
{ General cleanup and first use of standard 3RCC file formats--------------------------
{ Abstract:
{    Parse the declaration of a set type
{
{ Side Effects:
{    The state of CurIFilen
                  ArrayType
              else
{ Record }        if Sy = RecordSy then
                      RecordType
e will be modified
{    New structures will be allocated
{
{ Calls:
{    InSymbol
{    New
{    Typ
{    Packable
{-----                  else
{ Set }               if Sy = SetSy then
                         SetType
                     else
{------------------------------------}
    begin
    InSymbol; New(CurHeap,1,LSP,Files);
    if Sy = OfSy then
        begin  File }                 if Sy = FileSy then
                             FileType;
              FSP := LSP
              endInSymbol; Typ(FSys,LSP1,LSize) end
    else
        LSP1 := nil;
    with LSP^ do
        begin
        Form := Files;
   ; { Sy <> Arrow }
      if not (Sy in FSys) then
        begin Error(6); Skip(FSys) end
      end { Sy in TypeBegSys }
  els     FilType := LSP1;
        if LSP1 = nil then
            begin
            Size := FDSize;
            ElWordSize := 1
e
      FSP := nil;
  if FSP = nil then FSize := 1 else FSize := FSP^.Size
  end { Typ };
                                   I 	
NI
90INT
91DIF
92EXIT
93NOOP
94REPL
95REPL2
96MMS
97MES
98LVRD
99LSSN
100XJP
101PSW
102RAST-OP
103STARTIO
104BLOC K
105INTOFF
106INTON
107LDLB
108LDLW
109LDL0
110LDL1
111LDL2
112LDL3
113LDL4
114LDL5
115LDL6
116LDL7
117LDL8
118LDProgram FResWords;

{-----------------------------------------------------------
{
{ FResWords - Format Compiler's Reserved L9
119LDL10
120LDL11
121LDL12
122LDL13
123LDL14
124LDL15
125LLAB
126LLAW
127STLB
128STLW
129STL0
130STL1
131STL2
1Word File
{ Copyright (C)  1981  Three Rivers Computer Corporation
{ Written by: Miles A. Barel
{
{ Abstract:
{    Convert 32STL3
133STL4
134STL5
135STL6
136STL7
137LDOB
138LDOW
139LDO0
140LDO1
141LDO2
142LDO3
143LDO4
144LDO5
145LDO6
146a textual form of the compiler's reserved word definitions
{ to the binary form used by the compiler fopr initialization.  NOTELDO7
147LDO8
148LDO9
149LDO10
150LDO11
151LDO12
152LDO13
153LDO14
154LDO15
155LOAB
156LOAW
157STOB
158STOW
159STO0: the
{ reserved words must be given in alphabetical order.  The format of the
{ source file is as follows (one line for each  
160STO1
161STO2
162STO3
163STO4
164STO5
165STO6
166STO7
167MVBB
168MVBW
169MOVB
170MOVW
171INDB
172INDW
173LDIND
 174IND1
175IND2
176IND3
177IND4
178IND5
179IND6
180IND7
181LGAWW
182STMW
183STDW
184SAS
185ADJ
186CALL
187CALLV
180LDC0
1LDC1
2LDC2
3LDC3
4LDC4
5LDC5
6LDC6
7LDC7
8LDC8
9LDC9
10LDC10
11LDC11
12LDC12
13LDC13
14LDC14
15LDC15
16LD8ATPB
189ATPW
190WCS
191JCS
192LDGB
193LDGW
194LGAB
195LGAW
196STGB
197STGW
200RETURN
201MMS2
202MES2
203LDTP
204JCMO
17LDCB
18LDCW
19LSA
20ROTSHI
21STIND
22LDCN
23LDB
24STB
25LDCH
26LDP
27STP
28STCH
29EXGO
30LAND
31LOR
32LNOTMPB
205JMPW
206JFB
207JFW
208JTB
209JTW
210JEQB
211JEQW
212JNEB
213JNEW
214IXP
215LDIB
216LDIW
217LIAB
218LIAW
21
33EQUBOOL
34NEQBOOL
35LEQBOOL
36LESBOOL
37GEQBOOL
38GTRBOOL
39EQUI
40NEQI
41LEQI
42LESI
43GEQI
44GTRI
45EQUREAL
49STIB
220STIW
221IXAB
222IXAW
223IXA1
224IXA2
225IXA3
226IXA4
227TLATE1
228TLATE2
229TLATE3
230EXCH
231EXCH2
232INC6NEQREAL
47LEQREAL
48LESREAL
49GEQREAL
50GTRREAL
51EQUSTR
52NEQSTR
53LEQSTR
54LESSTR
55GEQSTR
56GTRSTR
57EQUBYT
58NEB
233INCW
234CALLXB
235CALLXW
236LDMC
237LDDC
238LDMW
239LDDW
240STLATE
241LINE
242ENABLE
243RAISE
244LDAP
251INCDDQBYT
59LEQBYT
60LESBYT
61GEQBYT
62GTRBYT
63EQUPOWR
64NEQPOWR
65LEQPOWR
66SGS
67GEQPOWR
68SRS
69EQUWORD
70EQUWORD
71S
254BREAK
255REFILL
0
                                                                                                     ABI
72ADI
73NGI
74SBI
75MPI
76DVI
77MODI
78CHK
79FLT
80TNC
81RND
82ABR
83ADR
84NGR
85SBR
86MPR
87DVR
88INN
89U  J  	
nt.
{
{ Side Effects:
{    The state of CurIFile is modified (a new input file is openned)
{    If this is the first import            { and get it (it'll be in InSymStr) }
FilNam:=InSymStr;
PrsFilNam:=false;     { back to normal now }
GetFileExtensof the segment, LinkList will be modified
{    A new symbol will be entered in the symbol table if we are importing
{        tion(FilNam);
for Int:=0 to NextSeg-1 do
    with LinkList[Int] do
        if (ModName = ModNam) and (FilName = FilNam) then
he main program
{
{ Errors:
{    Too Many Segments
{    Module does not exist in names file
{
{ Calls:
{    Error
{    S            goto 2;
for Int:=LastSeg to MaxSeg do
    with LinkList[Int] do
        if (ModName = ModNam) and (FilName = FilNkip
{    InSymbol
{    GetFileExtension
{    NewIFile
{    EnterId
{    NextINum
{    DeclarationPart
{    Close
{    Diam) then
            goto 2;
FirstFile:=CurIFile^.InFile;
NewIFile(FilNam,false);
with LexStk do
    begin
    DLLC:=LC;
spose
{
{ Design:
{    THIS IS A "HACK".  If a module is imported which contains NO code or
{    variables, and it in turn i    POldProc:=CurProc;
    SOldProc:=NextProc;
    DOldSeg:=Seg
    end;
LC := 0;
{ we've got the file, now let's make suremports another module which DOES contain
{    code or variables, then the "null" module cannot be removed from the
{    import we've got the right module }
if (Sy<>ModSy) and (Sy<>ProgSy) then
    begin
    Error(3);
    goto 3
    end;
if Sy = Pro list (as the later segments have been assigned segment numbers
{    already and removing the entry would alter this assignmentgSy then
    begin
    NextProc:=1;
    LC:=2*TextSize;
    IsProg:=true
    end
else
    begin
    NextProc:=0;
    Is).  The module
{    of program which is being compiled is replaced as the entry for this
{    "null" module, as to prevent theProg:=false
    end;
InSymbol;
if Sy <> Ident then
    begin
    Error(2);
    goto 3
    end;
if Id <> ModNam then
    LINKER and LOADER from looking for a
{    .SEG file which does not exist
{-------------------------------------}
  label 2,3 begin
    Error(410);
    goto 3
    end
else
    begin              { Import found - proceed with it! }
    if NextSeg <;
  var ModNam:Alpha; Int,ImpdSeg:integer; LexStk: LexStkRec; FilNam: string;
      IsProg: boolean; TmpIFile: IFPtr; LCP: Ide LastSeg then
        begin
        Seg:=NextSeg;
        NextSeg:=NextSeg+1;
        ImpdSeg := Seg;
        with LinkListntifier; FirstFile: pText;
begin
if Sy <> Ident then     { this should be the module name }
  begin Error(2); Skip(FSys); Exi[Seg] do
            begin
            ModName:=ModNam;
            FilName:=FilNam
            end;
        end
    else
{ }

procedure ImportDeclaration;
{-----------------------------------------
{ Abstract:
{    Parse IMPORT declarations.t(ImportDeclaration) end;
ModNam:=Id;            { save the name until we find it }
InSymbol;
if Sy <> FromSy then
  begin E  Only handles IMPORTS line in original
{    program - DeclarationPart actually parses the contents of the imported
{    segmerror(60); Skip(FSys); Exit(ImportDeclaration) end;
PrsFilNam:=true;      { Tell InSymbol we're after a file name }
InSymbol;   J 	
BeginSy,IfSy,CaseSy,RepeatSy,WhileSy,
                ForSy,WithSy,GotoSy,LabelSy,ConstSy,TypeSy,VarSy,ProcSy,
               efDstFile;
rewrite(DstFile,DstFileName);

Count:=0;
PrevWord.RWord := '        ';
while not EOF(SrcFile) do
    with ResWo FuncSy,ProgSy,ForwardSy,IntConst,RealConst,StringConst,
                NotSy,MulOp,AddOp,RelOp,SetSy,PackedSy,ArraySy,RecordSrd do
        begin
        read(SrcFile,RWord);
        if RWord < PrevWord.RWord then
            begin
            writey,
                FileSy,ModSy,ImportSy,ExportSy,PrivateSy,FromSy,OthrWiseSy,
                ChangeSy,OtherSy,DotDot,RCurly,ln('?FATAL ERROR - Reserved Words are NOT in alphabetical ',
                    'order');
            exit(FResWords)
      ExceptSy,EnableSy,RaiseSy);

     Operator = { Types of Operators }
                
                (Mul,RDiv,AndOp,IDiv,IM      end;
        read(SrcFile,X);
        Sym := recast(X,Symbol);
        readln(SrcFile,X);
        Opr := recast(X,Operod,Plus,Minus,OrOp,LtOp,LeOp,
                 GeOp,GtOp,NeOp,EqOp,InOp,NoOp,
                    { the following are special ator);
        DstFile^ := ResWord;
        Put(DstFile);
        PrevWord := ResWord;
        writeln(Output,RWord,ord(Sym)tree node operators }
                 ArrayAccessor, FieldAccessor, PtrAccessor, FileAccessor,
                 PushParm, Cal:3,ord(Opr):3);
        Count:=Count+1
        end;
close(SrcFile);
close(DstFile);
writeln('Reserved Word Count is ',CountlPF,
                 FltOp, NotOpr, SNSOp, SRSOp, SGSOp, UNIOp,
                 Neg, SelectOp,StrchOp);

const
     UniqL:1)
end.

                                                                                                                   ength = 8;                    { Length of Unique Identifier }

Type
    Alpha = packed array[1..UniqLength] of char;
    Res reserved word):
{
{         Reserved Word Lexeme   ord(Symbol)   ord(Operator)
{
{------------------------------------------WrdRec = record
                    RWord: Alpha;
                    Sym: Symbol;
                    Opr: Operator
       -----------------

{ }
{ 27 Mar 81  1.0  Miles A. Barel
{ Creation
{ }

const
      VersionString = 'V1.0';
      Def         end;
    
var
    SrcFileName, DstFileName: string[100];
    SrcFile: Text;
    DstFile: file of ResWrdRec;
    CSrcFile = 'RESWORDS.DAT';
      DefDstFile = 'PASCAL.RESWORDS';

type
     Symbol =  { Types of lexemes                     ount,X: integer;
    ResWord,PrevWord: ResWrdRec;

begin
writeln('FResWords  Version ',VersionString);  writeln;

write('I}
               { NOTE: ChangeSy and OtherSy are internal symbols }

               (Ident,Comma,Colon,SemiColon,LParent,RPanput File [',DefSrcFile,']: ');
readln(SrcFileName);
if length(SrcFileName) = 0 then SrcFileName := DefSrcFile;
reset(SrcFilerent,DoSy,ToSy,
                DownToSy,EndSy,UntilSy,OfSy,ThenSy,ElseSy,Becomes,LBrack,
                RBrack,Arrow,Period,,SrcFileName);
write('Output File [',DefDstFile,']: ');
readln(DstFileName);
if length(DstFileName) = 0 then DstFileName := D K  	
iColon then InSymbol else Error(14)
end { ImportDeclaration };

procedure LabelDeclaration;
{------------------------------IFile may be modified
{    New symbol table entries will be made
{
{ Calls:
{    Error
{    Skip
{    NextINum
{    Enter
        Error(256);
    if NextProc = 1 then          { Just imported the main program }
        with LCP do
            beg----------
{ Abstract:
{    Parse the declaration of labels.
{
{ Side Effects:
{    New LabelP's are allocated and chained in
            Name:=Id;
            IdNum:=NextINum;
            IdType:=nil;
            Next:=0;
            Klass:=Procinto the current display
{    The state of CurIFile may be modified
{
{ Calls:
{    Error
{    New
{    InSymbol
{    Ski;
            PFDecKind:=Declared;
            PFLev:=MainLex;
            PFName:=0;
            PFSeg:=Seg;
            Pp
{    GenLabel
{-----------------------------------------}
  var LLP: LabelP; Redef,Test: boolean;
begin
repeat
    if SyFKind:=Formal;     { This way we can't call it! }
            EnterId(LCP)
            end;
    InSymbol
    end;
if IsProg = IntConst then
        with Display[Top] do
            begin
            LLP:=FLabel;
            Redef:=false;
         then while Sy <> SemiColon do InSymbol;
if Sy <> SemiColon then Error(14) else InSymbol;
if Sy <> ExportSy then Error(61) els    while (LLP <> nil) and not Redef do
                if LLP^.LabVal <> Val.IVal then
                    LLP:=LLP^.NextLabe InSymbol;
DeclarationPart(FSys+[PrivateSy]);     { got it - read the declarations }
if (((not IsProg) and (NextProc = 0) and
                else
                    begin Redef:=true; Error(166) end;
            if not Redef then
                be (LC = 0)) or 
  (IsProg and (NextProc = 1) and (LC = 2*TextSize))) then
    begin
    LastSeg:=LastSeg-1;
    if LastSeg < gin
                New(CurHeap,1,LLP);
                with LLP^ do
                    begin
                    LabVal:=VNextSeg then Error(256);
    LinkList[LastSeg]:=LinkList[ImpdSeg];
    if ImpdSeg+1 = NextSeg then
        begin
        Nexal.IVal;
                    GenLabel(CodeLbP);
                    NextLab:=FLabel
                    end;
               tSeg:=NextSeg-1;
        LinkList[ImpdSeg]:=LinkList[0];
        end
    end;
3: with LexStk do
    begin
    LC:=DLLC;
  FLabel:=LLP
                end;
            InSymbol
            end
    else
        Error(15);
    if not (Sy in FSys+   CurProc:=POldProc;
    NextProc:=SOldProc;
    Seg:=DOldSeg
    end;
while CurIFile^.InFile <> FirstFile do
    begin
 [Comma,SemiColon]) then
      begin Error(6); Skip(FSys+[Comma,SemiColon]) end;
    Test:=Sy <> Comma;
    if not Test then I   with CurIFile^ do
        begin
        Close(InFile^);
        Dispose(InFile)
        end;
    TmpIFile:=CurIFile;
  nSymbol
until Test;
if Sy = SemiColon then InSymbol else Error(14)
end { LabelDeclaration };

procedure ConstDeclaration;  CurIFile:=CurIFile^.PrevFile;
    Dispose(TmpIFile);
    InFileNesting:=InFileNesting-2
    end;
2: InSymbol;
if Sy = Sem
{---------------------------------------
{ Abstract:
{    Parse Const declarations
{
{ Side Effects:
{    The state of Cur K 	
AND      39  2
ARRAY    44 15
BEGIN    19 15
CASE     21 15
CONST    28 15
DIV      39  3
DO        6 15
DOWNTO    8 15
     BODY2.PAS
Get BODY3.PAS            BODY3.PAS
Get EXPEXP.PAS           EXPEXPR.PAS
Get EXPR0.PAS            EXPR0.PAS
GeELSE     13 15
END       9 15
EXPORTS  49 15
FILE     46 15
FOR      24 15
FORWARD  34 15
FROM     51 15
FUNCTION 32 15
t EXPR1.PAS            EXPR1.PAS
Get EXPR2.PAS            EXPR2.PAS
Get EXPR3.PAS            EXPR3.PAS
Get PROGRE.PAS        GOTO     26 15
IF       20 15
IMPORTS  48 15
IN       41 14
LABEL    27 15
MOD      39  4
MODULE   47 15
NOT      38 15
   PROGRESS.PAS
Get FSYNTA.PAS           FSYNTAX.PAS
Get SYNTAX.DAT           SYNTAX.DAT
Get QDIS.PAS             QDIS.PAS
GOF       11 15
OR       40  7
OTHERWIS 52 15
PACKED   43 15
PRIVATE  50 15
PROCEDUR 31 15
PROGRAM  33 15
RECORD   45 15
et FQCODE.PAS           FQCODES.PAS
Get QCODES.DAT           QCODES.DAT
Get FRESWO.PAS           FRESWORDS.PAS
Get RESWOR.DATREPEAT   22 15
SET      42 15
THEN     12 15
TO        7 15
TYPE     29 15
UNTIL    10 15
VAR      30 15
WHILE    23 15
           RESWORDS.DAT
                                                                                                       WITH     25 15
                                                                                                                     Sides 2
Density SINGLE
Fast


! PASCAL.SOURCE - PASCAL COMPILER SOURCES
! Created 03 Apr 81 12:58:26

Get PASCAL.PAS            PASCAL.PAS
Get PAS0.PAS             PAS0.PAS
Get PAS1.PAS             PAS1.PAS
Get PAS2.PAS             PAS2.PAS
Get  QCODES.DFS           QCODES.DFS
Get COMPIN.PAS           COMPINIT.PAS
Get CODEGE.PAS           CODEGEN.PAS
Get DECPAR.PAS             DECPART.PAS
Get DEC0.PAS             DEC0.PAS
Get DEC1.PAS             DEC1.PAS
Get DEC2.PAS             DEC2.PAS
Get  BODYPA.PAS           BODYPART.PAS
Get BODY0.PAS            BODY0.PAS
Get BODY1.PAS            BODY1.PAS
Get BODY2.PAS        L  	
{    Skip
{    InSymbol
{    Typ
{    NextINum
{    EnterId
{    LookupNum
{    WriteNum
{-------------------------------ifiers will be entered in the Symbol Table
{
{ Calls:
{    NextINum
{    EnterId
{    InSymbol
{    Error
{    Skip
{   --}

  var LCP1,LCP2: integer;  LCP,NCP,NCP1: Identifier;
      LSP: STP;  LSize: AddrRange;
begin
if Sy <> Ident then
  b Typ
{    LookupNum
{    WriteNum
{---------------------------------------}
  var LCP: Identifier; NXT,IdList: integer; LSP:egin Error(2); Skip(FSys+[Ident]) end;
 while Sy = Ident do
    begin
    with LCP do
      begin Name:=Id; IdType:=nil; Kla STP; LSize: AddrRange;
      Test: Boolean;
begin
NXT:=0;
repeat
    repeat
        if Sy = Ident then
            beginss:=Types; IdNum:=NextINum end;
    InSymbol;
    if (Sy = RelOp) and (Op = EqOp) then InSymbol else Error(16);
    Typ(FSys+
            with LCP do
                begin
                Name:=Id; Next:=NXT; Klass:=ActualVars;
                IdTypId
{    InSymbol
{    Constant
{-----------------------------------------}
  var LCP: Identifier; LSP: STP; LValu: Valu;
be[SemiColon],LSP,LSize);
    LCP.IdType:=LSP;
    EnterId(LCP);
    LCP1:=FwPtr;
    LCP2:=FwPtr;
    while LCP1 <> 0 do
  gin
if Sy <> Ident then
  begin Error(2); Skip(FSys+[Ident]) end;
 while Sy = Ident do
    begin
    with LCP do
        b      begin
        LookupNum(LCP1,NCP);
        if NCP.Name = LCP.Name then
            begin
            NCP.IdType^.ElTypegin
        Name:=Id;
        IdType:=nil;
        Next:=0;
        Klass:=Konst;
        IdNum:=NextINum
        end;
 e:=LCP.IdType;
            if LCP1 <> FwPtr then
                begin
                LookupNum(LCP2,NCP1);
                  InSymbol;
    if (Sy = RelOp) and (Op = EqOp) then InSymbol else Error(16);
    Constant(FSys+[SemiColon],LSP,LValu);
     NCP1.Next:=NCP.Next;
                WriteNum(NCP1)
                end
            else
                FwPtr:=NCP.Next;
LCP.IdType:=LSP;
    LCP.Values:=LValu;
    if StrgType(LSP) then LValu.ValP^.STyp := DefCst;
    EnterId(LCP);
    if Sy =             WriteNum(NCP)
            end
        else
            LCP2:=LCP1;
        LCP1:=NCP.Next
        end;
    if SemiColon then
        begin
        InSymbol;
        if not (Sy in FSys + [Ident]) then
          begin Error(6); Skip(FSySy = SemiColon then
        begin
        InSymbol;
        if not (Sy in FSys+[Ident]) then
          begin Error(6); Skip(s+[Ident]) end
        end
    else
        Error(14)
    end
end { ConstDeclaration };

procedure TypeDeclaration;
{--FSys+[Ident]) end
        end
    else
        Error(14)
    end;
if FwPtr <> 0 then
    begin Error(117); FwPtr:=0 end   -----------------------------
{ Abstract:
{    Process TYPE declarations
{
{ Side Effects:
{    The state of CurIFile may b   { unresolved forward reference }
end { TypeDeclaration };

procedure VarDeclaration;
{----------------------------------e modified
{    New identifiers may be entered in the symbol table
{    Old symbols may be modified
{
{ Calls:
{    Error
-----
{ Abstract:
{    Parse VAR declarations
{
{ Side Effects:
{    The state of CurIFile will be modified
{    New ident L 	
                          