! 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