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;dZi ;d;dSi;d;di j i%ve;d@i] ;dKi :d;di;d7i;di;d)i8;dip;di ;di@;d3ih ----------------------------} 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 }  ;dDi##;di #0u;di#Xu;dSi#u;d1i #u;d3i0f.;di (Z;diHz@}< ijv;di8+(e^;dij<iU(gz;di[q*<iyii}M+Om  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-81 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 Import 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 { { Calls: { 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(' '); 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,'(continue), Q(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 [SwComment]:='COMMENT'; Switches[SwMessage]:='MESSAGE'; Switches[SwQuiet]:='QUIET'; Switches[SwNames]:='NAMES'; Switor { . actually indicated termination { with an 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 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 functions { { Parameters: { LCP - The top node of the symbol table subtree to be searched { { Errors: { Undefined procedure/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 Exporting 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.TyP1 { 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 rec1 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 current parameter defn }; i:integer; procedure ExpParam(Node: ESP); {-------------------------------------------- { Abstract: { 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 - functions2 ; 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 d2  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 comments4  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): bool5 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 (s6 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.C7  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 Erro9 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, r9 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 := Inddo 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 declaraA ----------------} 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 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 (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); CursPos:=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: IllegaB 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: 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 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 othC 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: Division by zero 301: No case provided for this value 302: Index expression out of bounds 303: Value to be assinged is out of bounds 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 { { DesignD 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 iE 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 ( to quit)?'); ReadLn(Str); Proc:=GetNum(Str); if Proc > 0 then if not (PF ],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,HG  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 = IntPtG 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 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) oH 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 leI  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 104BLOCK 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 89UJ 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; Resreserved 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 := DK 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 CurK 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 identL