!Modified 22/Sept/86 - treat selectoutput(-1) as null device for IMP.
!Modified 25/June/86  use own rather than local arrays
!Modified 28/May/86   for GOULD (AK)

!***********************************************************************
!* IMP written routines supporting COMPILE TIME.                       *
!***********************************************************************

%CONSTINTEGER EMAS=10
%CONSTINTEGER PERQ=11
%CONSTINTEGER PNX=12
%CONSTINTEGER IBM=13
%CONSTINTEGER GOULD=14
%constinteger DRS=19
%constinteger WhiteChapel = 19
%constinteger Perq3 = 20
%constinteger target = DRS
%constinteger host = DRS
%constinteger EM=25

%owninteger rc=1
%STRING(15)%FN ITOS %ALIAS "s#itos"(%INTEGER N)
!***********************************************************************
!*    SIMPLE PRINT WITH NO LEADING SPACE                               *
!***********************************************************************
%STRING(16)S
%INTEGER SIGN, W, D
      %RESULT = "0" %IF N = 0
!
      SIGN = 1
      %IF N < 0 %START
         SIGN = -1
         %IF N = X'80000000' %THEN %RESULT="-2147483648"
         N = -N
      %FINISH
      S = ""
      %WHILE N > 0 %CYCLE
         W = N // 10
         D = N - W * 10
         S = TOSTRING('0' + D) . S
         N = W
      %REPEAT
      S = "-" . S %IF SIGN < 0
      %RESULT = S
%END; ! ITOS
%conststring(1)%array hex(0:15)=
"0","1","2","3","4","5","6","7","8","9","A","B","C","D","E","F";
%externalroutine phex(%integer val)
%integer i
%cycle i=28,-4,0
         printstring(hex(val>>i&15))
      %repeat
%end
%externalroutine setreturncode(%integer n)
rc=n
%end
%externalroutine stop %alias "s_stop"
%externalroutinespec iocp %alias "s_iocp"(%integer ep,n)
%externalroutinespec exit %alias "SYS$EXIT"(%integer n)
 printstring("
Program stopped
")
  exit(rc)
%end

!************************************************************
!*                                                          *
!*  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   Filewrite %alias "write" (%integer id,bytead,len)
%externalintegerfnspec   Fileread  %alias "read"  (%integer id,bytead,len)
!%externalroutinespec    printf(%integer bytead)

%externalintegerfn IOCP %alias "s_iocp"(%integer ep,n)
  %switch entry(1:17)
  %constinteger Maxlinelen = 132
  %ownbyteintegerarray Line(0:Maxlinelen+1)
  %ownbyteintegerarray inbuf(0:4096)
  %owninteger left,inptr
  %integer bytead,len
  %owninteger Lptr
  %integer i,ch
  %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))
! 

  %routine IOERR(%string(255) s)
  %integer i
   s = "
IOCP ERROR ".s." ep = ".itos(ep)." n = ".itos(n)."
"
   i = Filewrite(2,(addr(s)  )+1,length(S)) %if host\= pnx
   i = Filewrite(2,(addr(s)*2)+1,length(S)) %if host = pnx
    outid=2
    %monitor
    %stop
  %end
  %routine OutputLine
    %integer i

    %return %if Lptr=0
    i = FileWRITE(OutID,addr(Line(0))  ,Lptr) %if host\= pnx
    i = FileWRITE(OutID,addr(Line(0))*2,Lptr) %if host = pnx
    %if i#Lptr %then ioerr(" Write fails ")
    Lptr = 0
  %end




  %unless 1<=ep<=17 %then IOERR(" Bad entry ")
 ->entry(ep)
  
  entry(*):  IOERR(" Entry not implemented ")

! entry(4):
  entry(1):                                              { READSYMBOL }
  entry(2):
                                   { NEXTSYMBOL }
              %if left=-EM %then %signal %event 9,1
              %if left=0 %start
                  left = Fileread(InID,addr(inbuf(0))  ,4096) %if host\= pnx
                  left = Fileread(InID,addr(inbuf(0))*2,4096) %if host = pnx
                %if left=0 %then left=-EM %and %result=EM
                 %if left = -1 %then printstring(" read fails ") %and %result=0
                 inptr=-1
              %finish
             
              inptr=inptr+1
              left=left-1
              %result = inbuf(inptr)

  entry(3):                                              { PRINTSYMBOL }
  entry(5):                                              { PRINTCH }
             %result=0 %if OutID<0
             Line(Lptr) = n
             Lptr = Lptr + 1
             OutputLine %if n = NL %or Lptr >= Maxlinelen 
             %result=0 

  entry(15):                           {only valid symbols PRINTSTRING }
  entry(7):                                              { PRINTSTRING }
             %result=0 %if OutID<0
             bytead = n     %if host\= pnx
             bytead = n * 2 %if host = pnx
             Len = byteinteger(bytead)
             %result=0 %if len = 0
             %cycle i = 1,1,Len
               ch = byteinteger(bytead+i)
               Line(Lptr) = ch
               Lptr = Lptr + 1
               OutputLine %if ch = NL %or Lptr >= Maxlinelen
             %repeat
             %result=0 

 entry(8):                                               { SELECTINPUT }
             InID = n
           %if left=-EM %then left=0;         ! clear input ended
             %result=0


  entry(9):     OutputLine                               { SELECTOUTPUT }
               OutID = n 
               %result=0

  entry(11):   %result=0 %if OutID<0
               Outputline                                { Flush buffer }
              %result=0

  entry(16):   %result=0 %if OutID<0
               OutputLine                                { CLOSE }
               CLOSE(n) %unless n < 3
               %result=0

  entry(17):                                             { PRINTSYMBOL n times }
    %result=0 %if OutID<0
    ch = n&255
    %cycle  i=1,1,(n>>8)&255
      Line(Lptr) = ch
      Lptr = Lptr + 1
      OutputLine %if Lptr >= Maxlinelen
    %repeat
    Outputline %if ch=NL
    %result=0
%end
%endoffile