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