!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 WhiteChapel = 19 %constinteger Perq3 = 20 %constinteger target = GOULD %constinteger host = GOULD %externalSTRING(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 !*********************************************************************** %if host= PERQ %thenstart %externalroutine reversebytes(%integer ad,len) %byteintegerarrayformat bfm(0:100000) %byteintegerarrayname b %integer i,j %return %if len<=0 len = (len+1)&(-2) b == array(ad,bfm) %cycle i = 0,2,len j = b(i) b(i) = b(i+1) b(i+1) = j %repeat %end %finish !************************************************************** !***** Convert an IMP string into a C string **************** !************************************************************** %systemroutine Cstring(%string(*) %name S,%integer bad{byte ad}) %integer i, sbad, len %if host=PNX %then sbad= addr(s)*2 %c %else sbad= addr(s) len = length(S) byteinteger(Bad+(i-1)) = byteinteger(Sbad + i ) %for i=1,1,len byteinteger(Bad+len)=0 reversebytes(bad//2,len+1) %if host = PNX %end %systemROUTINE WRITE %ALIAS "s_write"(%INTEGER VALUE,PLACES) !*********************************************************************** !* SIMPLE MINDED ALL IMP VERSION NOT USING STRINGS * !*********************************************************************** %INTEGER SIGN,WORK,PTR %OWNBYTEINTEGERARRAY CH(0:15) SIGN=' ' %if value=X'80000000' %start spaces(places-10) %if places>10 printstring("-2147483648") %return %Finish %IF VALUE<0 %THEN SIGN='-' %AND VALUE=-VALUE PTR=0 %CYCLE WORK=VALUE//10 CH(PTR)=VALUE-10*WORK VALUE=WORK PTR=PTR+1 %REPEATUNTIL VALUE=0 %IF PLACES>PTR %THEN SPACES(PLACES-PTR) WORK=PTR-1 PRINT SYMBOL(SIGN) PRINT SYMBOL(CH(PTR)+'0') %FOR PTR=WORK,-1,0 %END %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 !*********************************************************************** %externalroutine Phex(%integer Val) %integer I %cycle I=28,-4,0 printstring(Hex((Val>>I)&15)) %repeat %end !*********************************************************************** %externalstring(*) %fn htos(%integer i,size) %integer j %string(8) s s="" %cycle j=(size*4)-4,-4,0 s=s.hex((i>>j)&15) %repeat %result=s %end !*********************************************************************** %externalroutine ByteMove(%integer len,from,to) %if host#PNX %start %byteintegerarrayformat bfm(0:10000) %byteintegerarrayname a,b %integer i %finish %if host = PNX %start ! **from ! **to ! **len ! *MVB %finishelsestart a==array(from,bfm) b==array(to,bfm) %cycle i = 0,1,len-1 b(i)=a(i) %repeat %finish %end %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 %systemROUTINE MOVE %ALIAS "move"(%INTEGER LENGTH,FROM,TO) { word address} %integer l,i %if host#PNX %start %byteintegerarrayformat bfm(0:10000) %byteintegerarrayname a,b %finish %RETURNIF LENGTH<=0 l = (length+1)//2 %if host = PNX %start !**from !**to !**l !*MVWD %finishelsestart a==array(from,bfm) b==array(to,bfm) %cycle i = 0,1,length-1 b(i)=a(i) %repeat %finish %END %systemROUTINE FILL %ALIAS "fill"(%INTEGER LENGTH,at,FILLER) %INTEGER I,f,t,l %RETURNIF LENGTH<=0 %if host#PNX %start byteinteger((at )+i) = filler %for i= 0,1,length-1 %finishelsestart %if length<=16 %then l=length-1 %else l = 15 byteinteger((at*2)+i) = filler %for i= 0,1,l %return %if length<=16 { minimum overlap is 16bytes} f = at t = at + 8 i = (length-16+1)//2 !**f !**t !**i !*MVWD %finish %END %if host\= Perq3 %and host\= Gould %thenstart %EXTERNALINTEGERFN SIZE OF %ALIAS "s_sizeof"(%NAME X) !*********************************************************************** !* returns the size of a %NAME paramterer * !*********************************************************************** %CONSTBYTEINTEGERARRAY BYTES(0:7)= 1(4),2,4,8,16 %INTEGER I %IF target=emas %START *LSS_(%LNB +5) *ST_I %IF I&X'C2000000'#0 %THENRESULT=I&X'00FFFFFF' I=(I>>27)&7 %FINISHELSEIF target=perq %START **x+4; **=i %IF i&7>=3 %THENRESULT=i>>16 i=(i>>4)&7 %FINISH%ELSE %IF target=pnx %START *ILP2; **=i %if i&7>=3 %THEN %RESULT=i>>16 i=(i>>4)&7 %FINISH %RESULT=BYTES(I) %END %finish; !if not Perq3 or Gould !************************************************************ !* * !* 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) !%externalroutinespec printf(%integer bytead) %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 ") %and %stop Cstring(name,addr(cname(0))) i=open(addr(cname(0)),0) { open reading } streamtable(stream)=i %end %externalintegerfn IOCP %alias "s_iocp"(%integer ep,n) %switch entry(1:18) %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 %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<=18 %then IOERR(" Bad entry ") ->entry(ep) entry(*): IOERR(" Entry not implemented ") ! entry(4): entry(1): { READSYMBOL } entry(2): { NEXTSYMBOL } entry(18): { nextsymbol } %if left=0 %start left = Fileread(streamtable(inid),addr(inbuf(0)) ,4096) %if host\= pnx left = Fileread(streamtable(Inid),addr(inbuf(0))*2,4096) %if host = pnx %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 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 %result=0 entry(9): %if n=0 %then n=1 { map 0 to STDOUT } 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 %externalroutine Fdiag(%integer LNB,gla,PC,ADIAGS,first,%integername flag) %end %CONSTLONGLONGREALARRAY POWER OF TEN(-78:75)= %C {Ten to the -78} R'001DA48CE468E7C7' , {Ten to the -77} R'011286D80EC190DC' , {Ten to the -76} R'01B94470938FA89C' , {Ten to the -75} R'0273CAC65C39C961' , {Ten to the -74} R'03485EBBF9A41DDD' , {Ten to the -73} R'042D3B357C0692AA' , {Ten to the -72} R'051C45016D841BAA' , {Ten to the -71} R'0611AB20E472914A' , {Ten to the -70} R'06B0AF48EC79ACE8' , {Ten to the -69} R'076E6D8D93CC0C11' , {Ten to the -68} R'084504787C5F878B' , {Ten to the -67} R'092B22CB4DBBB4B7' , {Ten to the -66} R'0A1AF5BF109550F2' , {Ten to the -65} R'0B10D9976A5D5297' , {Ten to the -64} R'0BA87FEA27A539EA' , {Ten to the -63} R'0C694FF258C74432' , {Ten to the -62} R'0D41D1F7777C8A9F' , {Ten to the -61} R'0E29233AAAADD6A4' , {Ten to the -60} R'0F19B604AAACA626' , {Ten to the -59} R'101011C2EAABE7D8' , {Ten to the -58} R'10A0B19D2AB70E6F' , {Ten to the -57} R'11646F023AB26905' , {Ten to the -56} R'123EC56164AF81A3' , {Ten to the -55} R'13273B5CDEEDB106' , {Ten to the -54} R'1418851A0B548EA4' , {Ten to the -53} R'14F53304714D9266' , {Ten to the -52} R'15993FE2C6D07B80' , {Ten to the -51} R'165FC7EDBC424D30' , {Ten to the -50} R'173BDCF495A9703D' , {Ten to the -49} R'18256A18DD89E627' , {Ten to the -48} R'1917624F8A762FD8' , {Ten to the -47} R'19E9D71B689DDE72' , {Ten to the -46} R'1A9226712162AB07' , {Ten to the -45} R'1B5B5806B4DDAAE4' , {Ten to the -44} R'1C391704310A8ACF' , {Ten to the -43} R'1D23AE629EA696C1' , {Ten to the -42} R'1E164CFDA3281E39' , {Ten to the -41} R'1EDF01E85F912E38' , {Ten to the -40} R'1F8B61313BBABCE3' , {Ten to the -39} R'20571CBEC554B60E' , {Ten to the -38} R'213671F73B54F1C9' , {Ten to the -37} R'2222073A8515171D' , {Ten to the -36} R'23154484932D2E72' , {Ten to the -35} R'23D4AD2DBFC3D078' , {Ten to the -34} R'2484EC3C97DA624B' , {Ten to the -33} R'255313A5DEE87D6F' , {Ten to the -32} R'2633EC47AB514E65' , {Ten to the -31} R'272073ACCB12D0FF' , {Ten to the -30} R'2814484BFEEBC2A0' , {Ten to the -29} R'28CAD2F7F5359A3B' , {Ten to the -28} R'297EC3DAF9418065' , {Ten to the -27} R'2A4F3A68DBC8F03F' , {Ten to the -26} R'2B318481895D9627' , {Ten to the -25} R'2C1EF2D0F5DA7DD9' , {Ten to the -24} R'2D1357C299A88EA7' , {Ten to the -23} R'2DC16D9A0095928A' , {Ten to the -22} R'2E78E480405D7B96' , {Ten to the -21} R'2F4B8ED0283A6D3E' , {Ten to the -20} R'302F394219248447' , {Ten to the -19} R'311D83C94FB6D2AC' , {Ten to the -18} R'3212725DD1D243AC' , {Ten to the -17} R'32B877AA3236A4B4' , {Ten to the -16} R'33734ACA5F6226F1' , {Ten to the -15} R'34480EBE7B9D5856' , {Ten to the -14} R'352D09370D425736' , {Ten to the -13} R'361C25C268497682' , {Ten to the -12} R'37119799812DEA11' , {Ten to the -11} R'37AFEBFF0BCB24AB' , {Ten to the -10} R'386DF37F675EF6EB' , {Ten to the -9} R'3944B82FA09B5A53' , {Ten to the -8} R'3A2AF31DC4611874' , {Ten to the -7} R'3B1AD7F29ABCAF48' , {Ten to the -6} R'3C10C6F7A0B5ED8D' , {Ten to the -5} R'3CA7C5AC471B4784' , {Ten to the -4} R'3D68DB8BAC710CB3' , {Ten to the -3} R'3E4189374BC6A7F0' , {Ten to the -2} R'3F28F5C28F5C28F6' , {Ten to the -1} R'401999999999999A' , {Ten to the 0} R'4110000000000000' , {Ten to the 1} R'41A0000000000000' , {Ten to the 2} R'4264000000000000' , {Ten to the 3} R'433E800000000000' , {Ten to the 4} R'4427100000000000' , {Ten to the 5} R'45186A0000000000' , {Ten to the 6} R'45F4240000000000' , {Ten to the 7} R'4698968000000000' , {Ten to the 8} R'475F5E1000000000' , {Ten to the 9} R'483B9ACA00000000' , {Ten to the 10} R'492540BE40000000' , {Ten to the 11} R'4A174876E8000000' , {Ten to the 12} R'4AE8D4A510000000' , {Ten to the 13} R'4B9184E72A000000' , {Ten to the 14} R'4C5AF3107A400000' , {Ten to the 15} R'4D38D7EA4C680000' , {Ten to the 16} R'4E2386F26FC10000' , {Ten to the 17} R'4F16345785D8A000' , {Ten to the 18} R'4FDE0B6B3A764000' , {Ten to the 19} R'508AC7230489E800' , {Ten to the 20} R'5156BC75E2D63100' , {Ten to the 21} R'523635C9ADC5DEA0' , {Ten to the 22} R'5321E19E0C9BAB24' , {Ten to the 27} R'54152D02C7E14AF6' , {Ten to the 24} R'54D3C21BCECCEDA1' , {Ten to the 25} R'5584595161401485' , {Ten to the 26} R'5652B7D2DCC80CD3' , {Ten to the 27} R'5733B2E3C9FD0804' , {Ten to the 28} R'58204FCE5E3E2502' , {Ten to the 29} R'591431E0FAE6D721' , {Ten to the 30} R'59C9F2C9CD04674F' , {Ten to the 31} R'5A7E37BE2022C091' , {Ten to the 32} R'5B4EE2D6D415B85B' , {Ten to the 33} R'5C314DC6448D9339' , {Ten to the 34} R'5D1ED09BEAD87C03' , {Ten to the 35} R'5E13426172C74D82' , {Ten to the 36} R'5EC097CE7BC90716' , {Ten to the 37} R'5F785EE10D5DA46E' , {Ten to the 38} R'604B3B4CA85A86C4' , {Ten to the 39} R'612F050FE938943B' , {Ten to the 40} R'621D6329F1C35CA5' , {Ten to the 41} R'63125DFA371A19E7' , {Ten to the 42} R'63B7ABC627050306' , {Ten to the 43} R'6472CB5BD86321E4' , {Ten to the 44} R'6547BF19673DF52E' , {Ten to the 45} R'662CD76FE086B93D' , {Ten to the 46} R'671C06A5EC5433C6' , {Ten to the 47} R'68118427B3B4A05C' , {Ten to the 48} R'68AF298D050E4396' , {Ten to the 49} R'696D79F82328EA3E' , {Ten to the 50} R'6A446C3B15F99267' , {Ten to the 51} R'6B2AC3A4EDBBFB80' , {Ten to the 52} R'6C1ABA4714957D30' , {Ten to the 53} R'6D10B46C6CDD6E3E' , {Ten to the 54} R'6DA70C3C40A64E6C' , {Ten to the 55} R'6E6867A5A867F104' , {Ten to the 56} R'6F4140C78940F6A2' , {Ten to the 57} R'7028C87CB5C89A25' , {Ten to the 58} R'71197D4DF19D6057' , {Ten to the 59} R'71FEE50B7025C36A' , {Ten to the 60} R'729F4F2726179A22' , {Ten to the 61} R'7363917877CEC055' , {Ten to the 62} R'743E3AEB4AE13835' , {Ten to the 63} R'7526E4D30ECCC321' , {Ten to the 64} R'76184F03E93FF9F5' , {Ten to the 65} R'76F316271C7FC391' , {Ten to the 66} R'7797EDD871CFDA3A' , {Ten to the 67} R'785EF4A74721E864' , {Ten to the 68} R'793B58E88C75313F' , {Ten to the 69} R'7A25179157C93EC7' , {Ten to the 70} R'7B172EBAD6DDC73D' , {Ten to the 71} R'7BE7D34C64A9C85D' , {Ten to the 72} R'7C90E40FBEEA1D3A' , {Ten to the 73} R'7D5A8E89D7525244' , {Ten to the 74} R'7E3899162693736B' , {Ten to the 75} R'7F235FADD81C2823'; %constinteger dz=0 %constlongreal pmax=115 %ROUTINESPEC PRINTFL (%LONGREAL X, %INTEGER N) %systemROUTINE PRINT %ALIAS "s_print"(%LONGREAL X, %INTEGER N,M) !*********************************************************************** !* PRINTS A REAL NUMBER (X) ALLOWING N PLACES BEFORE THE DECIMAL * !* POINT AND M PLACES AFTER.IT REQUIRES (M+N+2) PRINT PLACES * !* UNLESS (M=0) WHEN (N+1) PLACES ARE REQUIRED. * !* * !* A LITTLE CARE IS NEEDED TO AVOID UNNECESSARY LOSS OF ACCURACY * !* AND TO AVOID OVERFLOW WHEN DEALING WITH VERY LARGE NUMBERS * !*********************************************************************** %LONGREAL Y,Z,ROUND,FACTOR %INTEGER I,J,L %INTEGER SIGN M=M&63; ! DEAL WITH STUPID PARAMS %IF N<0 %THEN N=1; N=N&31; ! DEAL WITH STUPID PARAMS X=X+DZ; ! NORMALISE SIGN=' '; ! '+' IMPLIED %IF X<0 %THEN SIGN='-' Y=MOD(X); ! ALL WORK DONE WITH Y ROUND=0.5/POWER OF TEN (M); ! ROUNDING FACTOR %IF Y>PMAX %OR N=0 %THENSTART; ! MEANINGLESS FIGURES GENERATED %IF N>M %THEN M=N; ! FOR FIXED POINT PRINTING PRINT FL(X,M); ! OF ENORMOUS NUMBERS %RETURN; ! SO PRINT IN FLOATING FORM %FINISH I=0; Z=1; Y=Y+ROUND %UNTIL Z>Y %CYCLE; ! COUNT LEADING PLACES I=I+1; Z=10*Z; ! NO DANGER OF OVERFLOW HERE %REPEAT SPACES(N-I); ! O.K FOR ZERO OR -VE SPACES PRINT SYMBOL(SIGN) J=I-1; Z=POWER OF TEN (J) FACTOR= 0.1@0 %CYCLE %UNTIL J<0 %CYCLE L=INT PT(Y/Z) %IF HOST\= PERQ3; ! OBTAIN NEXT DIGIT L= TRUNC(Y/Z) %IF HOST = PERQ3; ! OBTAIN NEXT DIGIT Y=Y-L*Z; Z=Z*FACTOR; ! AND REDUCE TOTAL PRINT SYMBOL(L+'0') J=J-1 %REPEAT %IF M=0 %THENRETURN; ! NO DECIMAL PART TO BE O/P PRINTSTRING(".") J=M-1; Z=POWER OF TEN (J-1); M=0 Y=10*Y*Z %REPEAT %END; ! OF ROUTINE PRINT %systemROUTINE PRINTFL %alias "s_printfl"(%LONGREAL X, %INTEGER N) !*********************************************************************** !* PRINTS IN FLOATING POINT FORMAT WITH N PLACES AFTER THE * !* DECIMAL POINT. ALWAYS TAKES N+7 PRINTING POSITIONS. * !* CARE REQUIRED TO AVOID OVERFLOW WITH LARGE X * !*********************************************************************** %LONGREAL SIGN,ROUND,FACTOR,LB,UB %INTEGER COUNT,INC ROUND=0.5/POWER OF TEN (N); ! TO ROUND SCALED NO LB=1-ROUND; UB=10-ROUND SIGN=1 X=X+DZ; ! NORMALISE %IF X=0 %THEN COUNT=-99 %ELSESTART %IF X<0 %THEN X=-X %AND SIGN=-SIGN INC=1; COUNT=0 FACTOR= 0.1@0 %IF X<=1 %THEN FACTOR=10 %AND INC=-1 ! FORCE INTO RANGE 1->10 %WHILE X=UB %CYCLE X=X*FACTOR; COUNT=COUNT+INC %REPEAT %FINISH PRINT(SIGN*X,1,N) PRINTSTRING("@") WRITE(COUNT,2) %END; ! OF ROUTINE PRINTFL %endoffile