{****************************************************************************}
{                                                                            }
{                   System dependent routines.                               }
{                                                                            }
{****************************************************************************}

!%EXTERNAL %ROUTINE %SPEC Define %ALIAS "S#DEFINE"(%INTEGER channel,
   %STRING (255) File, %INTEGER %NAME Afd,Flag)
%EXTERNAL %INTEGER %MAP %SPEC ComReg %ALIAS "S#COMREGMAP"(%INTEGER N)
%EXTERNAL %ROUTINE %SPEC ICLpascalcompiler
%ROUTINE %SPEC InitialiseCompiler
%EXTERNAL %ROUTINE %SPEC EMAS3(%STRING (255) %NAME Command,Param,
   %INTEGER %NAME Flag)
%EXTERNAL %ROUTINE %SPEC EMAS3ClaimChannel(%INTEGER %NAME Chan)
%EXTERNAL %STRING (15) %FN %SPEC ItoS %ALIAS "S#ITOS"(%INTEGER N)
%EXTERNAL %ROUTINE %SPEC Eproc(%STRING %NAME Name, %INTEGER Prop,Numpars,
   Paramsize,Astacklen, %INTEGER %NAME Id)
%EXTERNAL %ROUTINE %SPEC Eentry(%INTEGER Index,Numpars,ParamSize,LocalSize,
   DiagDisp, %STRING %NAME Name)
%EXTERNAL %INTEGER %FN %SPEC Exname(%INTEGER Type, %STRING %NAME Xref)
%EXTERNAL %ROUTINE %SPEC Edataentry(%INTEGER Area,Offset,Length,
   %STRING %NAME Name)
%EXTERNAL %ROUTINE %SPEC Edataref(%INTEGER Area,Offset,Length,
   %STRING %NAME Name)
%EXTERNAL %INTEGER %FN %SPEC existtype %ALIAS "S#EXISTTYPE"(%STRING (255) file)
!%EXTERNAL %ROUTINE %SPEC PGenerateObject(%STRING %NAME ObjFileName)



%CONST %INTEGER SourceChannel= -81
%RECORD %FORMAT pf(%INTEGER bits1,bits2)
%EXTERNAL %RECORD (pf) pascparmbits=0
%EXTERNAL %ROUTINE EMASzPascal
      comreg(24)=8
      pascparmbits_bits1=comreg(27)
      pascparmbits_bits2=comreg(28)
         *la_1,8; *sll_1,12; *ar_11,1
      InitialiseCompiler
      ICLpascalcompiler

%END
{ IMP version of FILEIO, contains input support for Pascal compiler }

%CONST %INTEGER ForReading= 0, ForWriting = 1, ForBoth = 2

%OWN %INTEGER ResetFlag,RewriteFlag { Flag first call to Reset and Rewrite }


%OWN %INTEGER Tracing= 0


%RECORD %FORMAT UNIXString(%BYTE %INTEGER %ARRAY Contents(1:255))
%OWN %RECORD (UNIXString) Argv0,Argv1,Argv2,Argv3,Argv4,Argv5,Argv6
%OWN %INTEGER %ARRAY ArgV(0:6)
%EXTERNAL %INTEGER %SPEC PArgV
%OWN %INTEGER ArgC= 7
%EXTERNAL %INTEGER %SPEC PArgC

%RECORD %FORMAT UNIXFileFmt(%BYTE %INTEGER %ARRAY Buffer(1:512),
   %INTEGER Descriptor,FileAddress,StartofLine,EndofLine,EndofBuffer,
   BufferIndex,Mode,EOFFlag)

%STRING (255) %FN ImpString(%INTEGER Ad)

      { return an Imp string containing the characters in the array at Ad }
      %OWN %STRING (255) Str
      Str=""
      %WHILE 0#Byteinteger(Ad)#' ' %CYCLE
         Str=Str.ToString(Byteinteger(Ad))
         Ad=Ad+1
      %REPEAT
      %RESULT=Str
%END { of ImpString }

%ROUTINE CString(%STRING (255) %NAME S, %RECORD (UNIXString) %NAME CS)
      %INTEGER I
      CS=0
      %FOR I=1,1,Length(S) %CYCLE
         CS_Contents(I)=byteinteger(Addr(S)+I)
      %REPEAT
%END { of CString }

%RECORD %FORMAT CAPFmt(%INTEGER I,J,K)
%EXTERNAL %ROUTINE Terminate(%INTEGER StringAd)
      %INTEGER N
      %RECORD (UNIXString) %NAME CS
      CS==record(StringAd)
      N=1
      %WHILE CS_Contents(N)#' ' %CYCLE
         N=N+1
      %REPEAT
      CS_Contents(N)=0
%END { of Terminate }

%EXTERNAL %INTEGER %FN HeadsMatch(%INTEGER Name,U, %RECORD (CAPFmt) Prefix)
      { Dummy }
      %IF Tracing#0 %THEN %START
         printstring("heads match ")
         newline
         %MONITOR
      %FINISH
      %RESULT=1
%END { of Headsmatch }

%EXTERNAL %ROUTINE InitialiseCompiler
      { Initialise compiler environment for Pascal }
      ResetFlag=0
      RewriteFlag=0
      Tracing=Comreg(26)&32
      CString("Pascal",Argv0)
      CString("-d***G1D2",Argv1)
      CString("T1",Argv2)
      CString("OPTIONS",Argv3)
      CString("EMAS-A Vsn 1.02",Argv4)
      CString("",Argv5)
      CString("EMAS-A Pascal test compiler for Pascal",Argv6)
      ArgV(0)=Addr(Argv0)
      Argv(1)=Addr(Argv1)
      ArgV(2)=Addr(Argv2)
      ArgV(3)=Addr(Argv3)
      ArgV(4)=Addr(Argv4)
      ArgV(5)=Addr(Argv5)
      ArgV(6)=Addr(Argv6)
      PArgC=6
      PArgV=Addr(Argv(0))
%END { of InitialiseCompiler }

%EXTERNAL %INTEGER %FN Accessible(%INTEGER FileNameAd,Mode)
      %INTEGER ftype
      %STRING (60) FileName
      FileName=ImpString(FileNameAd)
      %IF Tracing#0 %THEN %START
         Printstring("accessible ")
         Printstring(FileName)
         Write(Mode,3)
         Newline
      %FINISH
      ftype=existtype(filename)
      %IF ftype=3 %THEN %RESULT=1;       ! exists and is a character file
      %RESULT=0
%END { of Acessible }

%EXTERNAL %ROUTINE ResetFile(%INTEGER FileAd,NameAd)
      %STRING (60) Name
      %RECORD (UNIXFileFmt) %NAME TheFile
      %INTEGER Chan,Flag

      Name=ImpString(NameAd)
      TheFile==record(FileAd)
      %IF tracing#0 %THEN %START
         printstring("reset source file")
         printstring(name)
         write(filead,12)
         newline
      %FINISH
      %IF ResetFlag=0 %THEN %START { First call this compilation }
         ResetFlag=1
         Chan=-81
      %FINISH %ELSE %START
         EMAS3ClaimChannel(Chan)
         EMAS3("DEFINE",ItoS(Chan).",".Name,Flag)
         %IF Flag#0 %THEN %MONITOR %AND %STOP
      %FINISH
      TheFile=0
      TheFile_Descriptor=Chan
      TheFile_BufferIndex=1
      TheFile_StartofLine=1
      TheFile_EndofLine=1
      TheFile_EndofBuffer=1
      TheFile_Mode=ForReading
%END { of ResetFile }

%EXTERNAL %ROUTINE ReadFileBuffer(%INTEGER FileAd)
      %INTEGER Amount,Char,I
      %RECORD (UNIXFileFmt) %NAME File

      %ON %EVENT 9 %START
         %IF tracing#0 %START
            printstring("file ended (trap) "); write(filead,12); newline
         %FINISH
         File_EOFFlag=1
         ->Set
      %FINISH

      %IF Tracing#0 %THEN %START
         printstring("read file buffer ")
         write(filead,12)
         newline
      %FINISH
      File==record(FileAd)
      %RETURN %IF File_EOFFlag#0
      selectinput(File_Descriptor)
      Amount=0

      Readch(Char)
      %WHILE Char#NL %CYCLE
         Amount=Amount+1
         File_Buffer(Amount)=Char
         ReadCh(Char)
         %IF Char=25 %THEN %START
            File_EOFFlag=1
            %IF tracing#0 %START
               printstring("file ended (em) "); write(filead,12)
               newline
            %FINISH
            ->Set
         %FINISH
      %REPEAT
Set:
      Amount=Amount+1
      File_Buffer(Amount)=NL
      %IF Tracing#0 %THEN %START
         %FOR I=1,1,Amount %CYCLE
            printch(file_buffer(I))
         %REPEAT
      %FINISH
      File_EndofBuffer=Amount
      File_StartofLine=1
      File_FileAddress=File_FileAddress+Amount
%END { of ReadFileBuffer }

%EXTERNAL %ROUTINE ReadFileLine(%INTEGER FileAd)
      %IF Tracing#0 %THEN %START
         printstring("read file line ")
         write(filead,12)
         newline
      %FINISH
      ReadFileBuffer(FileAd)
%END { of ReadFileLine }

%EXTERNAL %INTEGER %FN EndofFile(%INTEGER FileAd)
      %RECORD (UNIXFileFmt) %NAME File
      File==record(FileAd)
      %RESULT=File_EOFFlag
%END { of EndofFile }

%EXTERNAL %ROUTINE RewriteFile(%INTEGER FileAd,NameAd)
      %STRING (60) Name
      %RECORD (UNIXFileFmt) %NAME TheFile
      %INTEGER Chan,Flag

      Name=ImpString(NameAd)
      TheFile==record(FileAd)
      %IF RewriteFlag=0 %THEN %START { First call this compilation }
         RewriteFlag=1
         Chan=-81
      %FINISH %ELSE %START
         EMAS3ClaimChannel(Chan)
         EMAS3("DEFINE",ItoS(Chan).",".Name,Flag)
         %IF Flag#0 %THEN %MONITOR %AND %STOP
      %FINISH
      TheFile=0
      TheFile_Descriptor=Chan
      TheFile_BufferIndex=1
      TheFile_StartofLine=1
      TheFile_EndofLine=1
      TheFile_EndofBuffer=1
      TheFile_Mode=ForWriting
%END { of RewriteFile }

%EXTERNAL %ROUTINE WriteFileBuffer(%INTEGER FileAd)
      %INTEGER Amount,Char
      %RECORD (UNIXFileFmt) %NAME File

      %ON %EVENT 9 %START
         File_EOFFlag=1
         ->Set
      %FINISH

      File==record(FileAd)
      %RETURN %IF File_EOFFlag#0
      selectinput(File_Descriptor)
      Amount=0

      ReadCh(Char)
      %WHILE Char#NL %CYCLE
         Amount=Amount+1
         File_Buffer(Amount)=Char
         ReadCh(Char)
      %REPEAT
Set:
      Amount=Amount+1
      File_Buffer(Amount)=NL
      File_EndofBuffer=Amount
      File_StartofLine=1
      File_FileAddress=File_FileAddress+Amount
%END { of WriteFileBuffer }

%EXTERNAL %ROUTINE WriteFileLine(%INTEGER FileAd)
      WriteFileBuffer(FileAd)
%END { of WriteFileLine }

%EXTERNAL %ROUTINE WriteCh(%INTEGER FileAd,Char)
      { Dummy }
%END { of WriteCh)}

%EXTERNAL %ROUTINE WriteSp(%INTEGER FileAd,Count)
      { Dummy }
%END { of WriteSp }

%EXTERNAL %ROUTINE CloseFile(%INTEGER FileAd)
      { Dummy }
%END { of CloseFile }

{17/10/85 - new routines elinestart, eprecall   }
{21/10/85 - new routine eprocref    }
{23/10/85 - additional parameters to paseprc & Eproc  }
{28/10/85 - new routine writename    }
{28/11/85 - make Namesaddr & Names external   }
{   - remove param form call to Enextproc   }
{---------------------------------------------------------------}
{11/01/86 - add spec for Eproclevel. (agh)                      }
{22/01/86 - modify call to Eproc to omit Level in Prop field.   }
{           Add call to settrap to force errors to be taken by  }
{           IMP.                                                }
{27/01/86 - Add PNames to pass source and object file-names.    }
{06/02/86 - Add Psave, Prestore and Pdiscard.                   }
{17/02/86 - Add ECaseEntry, ECaseJump, and EcaseEnd.            }
{18/02/86 - Add Evrestore, and Evdiscard.                       }
{24/03/86 - Change Estkglobalind to Estkgind.                   }
{08/04/86 - Trap name-table overflow and modify SetName to PERQ }
{           addressing.                                         }
{08/04/86 - Add Eswapmode for byte-swap control.                }
{09/04/86 - Add ecode and mcode tracing control                 }
{01/05/86 - Delete name-table. Strings are passed when required }
{---------------------------------------------------------------}
{12/05/86 - Tidy version for boot.                              }
{21/05/86 - Add LRtoLR and LRtoSR for real/real conversions.    }
{26/05/86 - Add SRtoLR for real/real conversions.               }
!*
!***********************************************************************
!* Imports                                                             *
!***********************************************************************
!*
!*
!*
!***********************************************************************
!*           P A S C A L   E - C O D E   I N T E R F A C E             *
!***********************************************************************
!*
!*
%EXTERNAL %ROUTINE EndImp(%INTEGER Code)
!***********************************************************************
!* Terminate compiler returning "no of lines if successful.            *
!* If unsuccessful then returns no of errors                           *
!***********************************************************************
      %INTEGER i
      %IF code>=0 %THEN i=0 %ELSE i=8
      comreg(47)=imod(code)
      comreg(24)=i
%END;                                    ! EndImp
!*
%EXTERNAL %ROUTINE PasEprc(%INTEGER Adid,Level,Prop,Numpars,Paramsize,
   Astacklen, %INTEGER %NAME Id)
!***********************************************************************
!* Call procedure entry routine.                                       *
!***********************************************************************
      %STRING (32) %NAME Name
      Name==string(Adid)
      Eproc(Name,Prop,Numpars,Paramsize,Astacklen,Id)
%END;                                    ! PasEprc
!*
%EXTERNAL %ROUTINE PasEntr(%INTEGER Adid,Numpars,ParamSize,StackSize,DiagDisp)
!***********************************************************************
!* Call procedure side-entry (to pass diag-table displacement).        *
!***********************************************************************
      %STRING (32) %NAME Name
      Name==string(Adid)
      Eentry(0,Numpars,Paramsize,StackSize,DiagDisp,Name)
%END;                                    ! PasEntr
!*
%EXTERNAL %INTEGER %FUNCTION PasExnm(%INTEGER Type,Adid)
!***********************************************************************
!* Pass external name reference.                                       *
!***********************************************************************
      %STRING (32) %NAME Name
      Name==string(Adid)
      %RESULT=Exname(Type,Name)
%END;                                    ! PasExnm
!*
%EXTERNAL %ROUTINE Pasdent(%INTEGER Area,Offset,Length,Adid)
!***********************************************************************
!* Pass data entry.                                                    *
!***********************************************************************
      %STRING (32) %NAME Name
      Name==string(Adid)
      Edataentry(Area,Offset,Length,Name)
%END;                                    ! Pasdent
!*
%EXTERNAL %ROUTINE Pasdref(%INTEGER Area,Offset,Length,Adid)
!***********************************************************************
!* Pass external data reference.                                       *
!***********************************************************************
      %STRING (32) %NAME Name
      Name==string(Adid)
      Edataref(Area,Offset,Length,Name)
%END;                                    ! Pasdref
!*
%EXTERNAL %ROUTINE LRtoSR(%INTEGER R1Addr,R2Addr)
!***********************************************************************
!* Convert long (64-bit) real to short (32-bit) real.                  *
!***********************************************************************
      real(R2Addr)=longreal(R1Addr)
%END;                                    ! LRtoSR
!*
%EXTERNAL %ROUTINE LRtoLR(%INTEGER R1Addr,R2Addr)
!***********************************************************************
!* Convert long (64-bit) real to long (64-bit) real.                   *
!***********************************************************************
      longreal(R2Addr)=longreal(R1Addr)
%END;                                    ! LRtoLR
!*
%EXTERNAL %ROUTINE SRtoLR(%INTEGER R1Addr,R2Addr)
!***********************************************************************
!* Convert short (32-bit) real to long (64-bit) real.                  *
!***********************************************************************
      longreal(R2Addr)=real(R1Addr)
%END;                                    ! SRtoLR
!*
!*
!***********************************************************************
!*              P A S C A L   P U T   I N T E R F A C E                *
!***********************************************************************
!*
!*
%EXTERNAL %ROUTINE Pnames(%INTEGER SrcAdid,ObjAdid)
!***********************************************************************
!* Pass source and object file names.                                  *
!***********************************************************************
      %STRING (32) %NAME SrcName,ObjName
      SrcName==string(SrcAdid)
      ObjName==string(ObjAdid)
!      Psetfiles(SrcName,ObjName)
%END;                                    ! Pnames
!*
%EXTERNAL %ROUTINE Pgen(%INTEGER ObjAdid)
!***********************************************************************
!* Trigger object file generation.                                     *
!***********************************************************************
      %STRING (32) %NAME ObjName
      ObjName==string(ObjAdid)
!   PGenerateObject(ObjName)
%END;                                    ! Pgen
!*
!*
%END %OF %FILE