! 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.
!