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

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

%externalroutinespec     exit(%integer rc)
%externalroutinespec     Close(%integer id)                 { Sys Call }
%externalintegerfnspec   FOpen(%integer id, mode)
%externalintegerfnspec   Fwrite %alias "fwrite" %c
                           (%integer bytead, len, num, id)
%externalintegerfnspec   Fread  %alias "fread" %c
                           (%integer bytead, len, num, id)

%constinteger debug = 0

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

! Although we're dealing in integers here, they're really FILE * variables
%owninteger ttyinf, ttyoutf, stdinf, stdoutf, nullinf, nulloutf
%ownintegerarray inmap(0:127)
%ownintegerarray outmap(0:127)
%owninteger instream, outstream;
%owninteger init = 0

%integerfn C(%string(255) s)
  %result = ADDR(s)+1
%end

!* 04-Apr-02
!*    Converted to C FILE* I/O and added several Imp77 compatible routines
!* 09-May-96                                                                 uiocp17
!*    Flattened for translation to C
!* 27-Nov-92                                                                uiocp16
!*    Simple IMP version all library duplicat material chopped out
!*

%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

%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

%routine IOerr(%integer ep, n, %string (255) s)
   %integer i
   s = "
IOCP ERROR ".s." ep = ".itos(ep)." n = ".itos(n)."
"
   i = Fwrite(C(s),length(S),1,stderr); ! maybe stderr is not best here
%end;! Ioerr

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

%routine init streams
  %if init = 1 %then %return
  init = 1
  ttyinf = fopen(C("/dev/tty\0"), C("r\0")); inmap(0) = ttyinf
  ttyoutf = fopen(C("/dev/tty\0"), C("w\0")); outmap(0) = ttyoutf
  stdinf = fopen(C("/dev/stdin\0"), C("r\0")); inmap(1) = stdinf
  stdoutf = fopen(C("/dev/stdout\0"), C("w\0")); outmap(1) = stdoutf
  nullinf = fopen(C("/dev/null\0"), C("r\0")); inmap(1) = stdinf
  nulloutf = fopen(C("/dev/null\0"), C("w\0")); outmap(1) = stdoutf
  instream = 0; outstream = 0
%end

%externalroutine Openfile(%integer stream, %string(128) name)
   %integer i
   %ownstring(127) cname

   init streams %if init=0

   %unless 0<=stream<=127 %then %C
      printstring(" invalid stream number ") %andstop

   cname=name.tostring(0)
   i=fopen(C(cname), C("r\0"))   { open reading }

   inmap(stream)=i

%end;! Openfile

%externalroutine Openinput(%integer stream, %string(128) name)
   %integer i
   %ownstring (127) cname

   init streams %if init=0

   %unless 0<=stream<=127 %then printstring(" invalid stream number ") %andstop

   cname=name.tostring(0)
   i=fopen(C(cname),C("r\0"))   { open reading }

   inmap(stream)=i

%end;! Openinput

%externalroutine Openoutput(%integer stream, %string(128) name)
   %integer i
   %ownstring (127) cname

   init streams %if init=0

   %unless 0<=stream<=127 %then %C
      printstring(" invalid stream number ") %andstop

   cname=name.tostring(0)
   i=fopen(C(cname), C("w\0"))   { open for writing }

   outmap(stream)=i

%end;! Openoutput

%externalroutine Closeoutput
   init streams %if init=0
   close(outmap(outstream))
   outmap(outstream) = 0
   outstream = 0
%end

%externalroutine Closeinput
   init streams %if init=0
   close(inmap(instream))
   inmap(instream) = 0
   instream = 0
%end

%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

  init streams %if init=0

  %if debug=1 %start
    %string(255) mess
    mess = "
    IOCP( ".itos(ep)." ".itos(n)." Lptr = ".itos(lptr)
    i = Filewrite(1,(addr(mess)*2) + 1, length(mess))
  %finish 

  %unless 1<=ep<=19 %then IOERR(ep,n," Bad entry ") %and outstream=Stderr

  ->entry(ep)
  
  entry(*):  IOERR(ep,n," Entry not implemented ")
             outstream=Stderr
             %result=0

! entry(4):
entry(1):                                              { READSYMBOL }
entry(2):                                              { NEXTSYMBOL }
entry(18):                                             { nextsymbol }
              %if left=0 %start
                  left = Fread(addr(inbuf(0)), 4096, 1, inmap(instream))
                %if left=0 %start
                   %if endgiven=0 %start
                     endgiven=1
                     printstring("End of input file"); newline
                     %result=0
                   %finish %else %stop
                %finish
                %if left = -1 %then %c
                  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 outstream<0
             Line(Lptr) = n
             Lptr = Lptr + 1
             %if ch = NL %or Lptr >= Maxlinelen %start
                 i = Fwrite(addr(Line(0)), Lptr, 1, outstream)
                 %if i#Lptr %then %c
                   IOerr(ep, n, " Write fails ") %and outstream=Stderr
                 Lptr = 0
             %finish
             %result=0 

entry(15):                           {only valid symbols PRINTSTRING }
entry(7):                                              { PRINTSTRING }
             %result=0 %if outstream<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 = Fwrite(addr(Line(0)), Lptr, 1, outstream)
                    %if j#Lptr %then %c
                      IOerr(ep,n," Write fails ") %and outstream=Stderr
                    Lptr = 0
                %finish
             %repeat
             %result=0 

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

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

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

entry(16):   %result=0 %if outstream<0
                                                         { CLOSE }
             %if Lptr>0 %start
                 i = Fwrite(addr(Line(0)), Lptr, 1, outstream)
                 %if i#Lptr %then %C
                   IOerr(ep, n, " Write fails ") %and outstream=Stderr
                 Lptr = 0
             %finish
             Close(n) %unless n < 3
             %result=0

entry(17):                                              { PRINTSYMBOL n times }
             %result=0 %if outstream<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 = Fwrite(addr(Line(0)), Lptr, 1, outstream)
                   %if i#Lptr %then %C
                     IOerr(ep, n, " Write fails ") %and outstream=Stderr
                   Lptr = 0
                 %finish
                %repeat
                %if ch=NL %start
                   i = Fwrite(addr(Line(0)), Lptr, 1, outstream)
                   %if i#Lptr %then %C
                     IOerr(ep,n," Write fails ") %and outstream=Stderr
                   Lptr = 0
                 %finish

             %finish
             %result=0
entry(19):                           ! return output line ptr
             %result=Lptr
%end; !Iocp

%externalroutine Stop %alias "s_stop"
  %integer rc
  rc = iocp(11,0)  { flush buffer }
  exit(0)
%end;! Stop

!%externalroutine Fdiag %alias "f_fdiag"(%integer LNB,gla,PC,ADIAGS,first,%integername flag) 
!%end;! Fdiag

%endoffile
