! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
%ownstring(90) copyright = " Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved."

!* 09May 96                                                                 uiocp17
!*    Flattened for translation to C
!* 27-Nov-92                                                                uiocp16
!*      Simple IMP version all library duplicat material chopped out
!*

%externalroutine Stop %alias "s_stop"

%externalroutinespec iocp %alias "s_iocp"(%integer ep,n)
%externalroutinespec exit %alias "exit"

 iocp(11,0)  { flush buffer }
 printstring("
Program stopped
")

  exit

%end;! Stop
%conststring(1) %array Hex(0:15) =
"0","1","2","3","4","5","6","7","8","9","A","B","C","D","E","F"

%externalroutine Phexbyte(%integer n)
  printstring(Hex((n>>4)&15))
  printstring(Hex(n&15))
%end;! Phexbyte
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!



!************************************************************
!*                                                          *
!*  IOCP - IMP stream input/output package                  *
!*     (This is a cut down version for the Fortran compiler *
!*                                                          *
!************************************************************

%constinteger Stdin  = 0,
              Stdout = 1,
              Stderr = 2

%externalroutinespec     Close (%integer id)                 { Sys Call }
%externalintegerfnspec   Open  (%integer ad,mode)
%externalintegerfnspec   Filewrite %alias "write" (%integer id,bytead,len)
%externalintegerfnspec   Fileread  %alias "read"  (%integer id,bytead,len)

%ownintegerarray streamtable(0:100)

%externalroutine Openfile(%integer stream, %string(128) name)
   %integer i
   %ownbyteintegerarray cname(0:127)

   %unless 0<=stream<=100 %then printstring(" invalid stream number ") %andstop
   string(addr(cname(0)))=name.tostring(0)
   i=open(addr(cname(1)),0)   { open reading }
   streamtable(stream)=i
%end;! Openfile

%externalroutine Openinput(%integer stream, %string(128) name)
   %integer i
   %ownbyteintegerarray cname(0:127)

   %unless 0<=stream<=100 %then printstring(" invalid stream number ") %andstop
   string(addr(cname(0)))=name.tostring(0)
   i=open(addr(cname(1)),0)   { open reading }
   streamtable(stream)=i
%end;! Openfile

%externalroutine Openoutput(%integer stream, %string(128) name)
   %integer i
   %ownbyteintegerarray cname(0:127)

   %unless 0<=stream<=100 %then printstring(" invalid stream number ") %andstop
   string(addr(cname(0)))=name.tostring(0)
   i=open(addr(cname(1)),1)   { open for writing }
   streamtable(stream)=i
%end;! Openfile

%externalroutine Closeoutput
%end

%externalroutine Closeinput
%end

!*
%STRING(15) %FN Itos(%INTEGER K)
  %INTEGER REM,NUM,NF
  %STRING(15) STR

  STR=""
  NF=0
  %IF K<0 %START
    NF=1
    K = K *(-1)
  %FINISH
  %CYCLE
    NUM=K
    K = K//10
    REM = NUM-(K*10)
    STR = TOSTRING(REM+'0').STR
    %IF K=0 %THEN %EXIT
  %REPEAT
  %IF NF=1 %THEN STR = "-".STR
  %RESULT = STR
%END;! Itos
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!


  %routine Ioerr(%integer ep,n,%string(255) s)
  %integer i
   s = "
IOCP ERROR ".s." ep = ".itos(ep)." n = ".itos(n)."
"
   i = Filewrite(Stderr,(addr(s)  )+1,length(S))
  %end;! Ioerr
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
%externalintegerfn Iocp %alias "s_iocp"(%integer ep,n)
  %switch entry(1:19)
  %constinteger Maxlinelen = 132
  %ownbyteintegerarray Line(0:Maxlinelen+1)
  %ownbyteintegerarray inbuf(0:4096)
  %owninteger left,inptr
  %owninteger endgiven=0
  %integer bytead,len
  %owninteger Lptr
  %integer i,ch,j
  %owninteger OutID = Stdout, InID = Stdin

!%string(255) mess

! mess = "
! IOCP( ".itos(ep)." ".itos(n)." Lptr = ".itos(lptr)
! i = Filewrite(1,(addr(mess)*2) + 1, length(mess))
! 

!


! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!




  %unless 1<=ep<=19 %then IOERR(ep,n," Bad entry ") %and OutID=Stderr
 ->entry(ep)
  
  entry(*):  IOERR(ep,n," Entry not implemented ")
      OutID=Stderr

! entry(4):
  entry(1):                                              { READSYMBOL }
  entry(2):                                              { NEXTSYMBOL }
  entry(18):                                             { nextsymbol }
              %if left=0 %start
                  left = Fileread(streamtable(inid),addr(inbuf(0))  ,4096)
                %if left=0 %start
                   %if endgiven=0 %start
                     endgiven=1
                     printstring("End of input file") 
                     %result=0
                   %finish %else %stop
                %finish
                %if left = -1 %then printstring(" read fails ") %and %result=0
                inptr=-1
              %finish
             
              %if ep=1 %start
                inptr=inptr+1
                left=left-1
                %result = inbuf(inptr)
             %finishelsestart
                %result=inbuf(inptr+1)
             %finish

  entry(3):                                              { PRINTSYMBOL }
  entry(5):                                              { PRINTCH }
             %result=0 %if OutID<0
             Line(Lptr) = n
             Lptr = Lptr + 1
             %if ch = NL %or Lptr >= Maxlinelen %start
                 i = FileWRITE(OutID,addr(Line(0))  ,Lptr)
                 %if i#Lptr %then ioerr(ep,n," Write fails ") %and OutID=Stderr
                 Lptr = 0
             %finish
             %result=0 

  entry(15):                           {only valid symbols PRINTSTRING }
  entry(7):                                              { PRINTSTRING }
             %result=0 %if OutID<0
             bytead = n
             Len = byteinteger(bytead)
             %result=0 %if len = 0
             %cycle i = 1,1,Len
               ch = byteinteger(bytead+i)
               Line(Lptr) = ch
               Lptr = Lptr + 1
               %if ch = NL %or Lptr >= Maxlinelen %start
                    j = FileWRITE(OutID,addr(Line(0))  ,Lptr)
                    %if j#Lptr %then ioerr(ep,n," Write fails ") %and OutID=Stderr
                    Lptr = 0
                %finish
             %repeat
             %result=0 

 entry(8):                                               { SELECTINPUT }
             InID = n
             %result=0


entry(9):    %if n=0 %then n=1   { map 0 to STDOUT }
                                                        { SELECTOUTPUT }
             %if Lptr>0 %start
                 i = FileWRITE(OutID,addr(Line(0))  ,Lptr)
                 %if i#Lptr %then ioerr(ep,n," Write fails ") %and OutID=Stderr
                 Lptr = 0
             %finish
             OutID = n 
             %result=0

entry(11):   %result=0 %if OutID<0
                                                       { Flush buffer }
             %if Lptr>0 %start
                 i = FileWRITE(OutID,addr(Line(0))  ,Lptr)
                 %if i#Lptr %then ioerr(ep,n," Write fails ") %and OutID=Stderr
                 Lptr = 0
             %finish
            %result=0

entry(16):   %result=0 %if OutID<0
                                                         { CLOSE }
             %if Lptr>0 %start
                 i = FileWRITE(OutID,addr(Line(0))  ,Lptr)
                 %if i#Lptr %then ioerr(ep,n," Write fails ") %and OutID=Stderr
                 Lptr = 0
             %finish
             CLOSE(n) %unless n < 3
             %result=0

entry(17):                                              { PRINTSYMBOL n times }
             %result=0 %if OutID<0
             ch = n&255
             %if n> 0 %thenstart
                %cycle  i=1,1,(n>>8)&255
                  Line(Lptr) = ch
                  Lptr = Lptr + 1
                  %if Lptr >= Maxlinelen %start
                   i = FileWRITE(OutID,addr(Line(0))  ,Lptr)
                   %if i#Lptr %then ioerr(ep,n," Write fails ") %and OutID=Stderr
                   Lptr = 0
                 %finish
                %repeat
                %if ch=NL %start
                   i = FileWRITE(OutID,addr(Line(0))  ,Lptr)
                   %if i#Lptr %then ioerr(ep,n," Write fails ") %and OutID=Stderr
                   Lptr = 0
                 %finish

             %finish
             %result=0
entry(19):                           ! return output line ptr
      %result=Lptr
%end; !Iocp
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!



!%externalroutine Fdiag %alias "f_fdiag"(%integer LNB,gla,PC,ADIAGS,first,%integername flag) 
!%end;! Fdiag
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!
%endoffile
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!
