Source: ERCS08:F77REL.SRCE200_XCONTRL8 Compiled: 25/11/87 17.09.10 Object: .NULL Parms set: NOCHECK,NOARRAY,XREF ERCC. Portable Imp80 Compiler Release 4 Version 14 Sep 87 2047 4095 1 ! xcontrl8 2 ! 28/09/87 - increase ares sizes if PARM MAXDICT set 3 ! new version no. 2.16 4 ! xcontrl7b 5 ! 23/09/87 - intialise inclevel in ICL9CEIBMF77 6 ! 28/07/87 - new version no. 2.15 7 ! xcontrl7a 8 ! 02/07/87 - new version no. 2.12 9 ! xcontrld7 10 ! 30/06/87 - in Icl9ceibmf77, set OPT1 bit in OPT1, if Parm opt2; set OPT bit in 11 ! - Control, if Parm Opt1; set minbound bit in F77parm, if not Parm OPT 12 ! 09/06/87 - change BSIZE to 128 13 ! new version no. 2.11 14 ! xcontrl6 15 ! 29/05/87 - new code in SOURCELINE & SELECTINCLUDE, define new own 16 ! - variables; new dynamic specs 17 ! - set OPT2 for Include listing 18 ! 06/05/87 - define Get Space and own integers gsconad, gsfindex, gsflen 19 ! xcontrl5d 20 ! 13/04/87 - change vsn to 2.10 21 ! xcontrl5b 22 ! 28/04/87 - change version t. 2.08 23 ! xcontrl5a 24 ! 06/04/87 - change version to 2.07 25 ! xcontrl5 26 ! 26/03/87 - set DIAGLEVEL from CONTROL in ICL9CEIBMF77 27 ! 18/03/87 - change vsn to 2.06 28 ! xcontrol4 29 ! 17/03/87 - change VSN to 2.05 30 ! 02/02/87 - remove strict,nowarnings,nocomments from OPT1 31 ! 32 ! modified 18/11/86 33 ! 34 %CONSTSTRING (5) VSN = "2.16" 35 ! 36 %owninteger inclevel 37 %ownintegerarray sfchan(0:10) 38 %owninteger gsconad,gsfindex ; ! used by Get Space 39 %owninteger gsflen=256*1024 ;! initial size of temp file created by Get Space 40 41 %dynamicroutinespec EMAS3CLAIMCHANNEL(%integername chan) 42 %dynamicroutinespec EMAS3DEFINE(%stringname file,%integername chan,flag) 43 %dynamicroutinespec EMAS3CLOSE(%integername chan,flag) 44 %dynamicroutinespec EMAS3CLEAR(%integername chan,flag) 45 ! 46 %externalroutinespec EMAS3EXISTTYPE(%stringname file,%integername flag) 47 %EXTERNALROUTINESPEC EMONON 48 %EXTERNALROUTINESPEC MOVE %ALIAS "S#MOVE" (%INTEGER LENGTH, FROM, TO) 49 %EXTERNALROUTINESPEC OUTFILE %ALIAS "EMAS3OUTFILE" (%STRINGNAME FILE, %INTEGERNAME SIZE, HOLE, PROT, CONAD, FLAG) 50 %externalroutinespec changefilesize %alias "emas3changefilesize" %c C (%stringname file,%integername newsize,flag) 52 %EXTERNALINTEGERMAPSPEC COMREGMAP %ALIAS "S#COMREGMAP" (%INTEGER X) 53 %EXTERNALINTEGERFNSPEC FORT77 (%INTEGER CONTROL, OPT1, OPT2, F77PARM, OPTFLAGS, SRFLAGS, CONSOLE, LSTREAM, %C C DSTREAM, DIAGLEV, DSIZE, TSIZE, BSIZE, LSIZE, ASIZE, SP2) 55 ! 56 %ROUTINE SIM2 (%INTEGER EP, R1, R2, %INTEGERNAME R3) 57 %BYTEINTEGER SYM 58 ! 59 %ON %EVENT 9 %START 60 byteinteger(R1+R3)=25 {EM} 61 BYTEINTEGER(R1 + R3 + 1) = NL 62 R3 = R3 + 2 63 %RETURN 64 %FINISH 65 ! 66 %CYCLE R3 = 0, 1, 159 67 READSYMBOL(SYM) 68 BYTEINTEGER(R1 + R3) = SYM 69 %IF SYM = NL %THEN %START 70 R3 = R3 + 1 71 %RETURN 72 %FINISH 73 %REPEAT 74 %END 75 ! 76 %EXTERNALROUTINE ICL9CEIBMF77 77 %INTEGER FLAG, CONTROL, OPT1, OPT2, F77PARM, SRFLAGS, LSTREAM, DSTREAM, OPTFLAGS, DIAGLEVEL, %C C ASIZE, BSIZE, DSIZE, LSIZE, TSIZE, SP2 79 LSTREAM = COMREGMAP(23) 80 CONTROL = COMREGMAP(27) 81 OPT1 = COMREGMAP(28) 82 DSTREAM = COMREGMAP(40) 83 OPT2 = COMREGMAP(53) ; ! (used by sub_system ??? ) 84 OPT2 = x'10' ;! PRO TEM - 'INCLUDE' listing 85 SRFLAGS = COMREGMAP(54) 86 F77PARM = COMREGMAP(55) 87 OPTFLAGS = COMREGMAP(56) 88 OPTFLAGS = (OPTFLAGS << 15) >> 15 89 %if Control&X'10000'#0 %then Control=Control!X'30' 90 F77parm=F77parm!(opt1&X'E0');!! strict,nowarnings,nocomments 91 opt1=opt1&(\(x'e0')) 92 %if opt1&x'200000'#0 %then Opt1=opt1!x'100000' ;! opt1 93 %if opt1&x'100000'#0 %then control=control!x'30' ;! opt 94 %if control&x'20'=0 %then F77parm=F77parm!x'8' ;! minbound 95 %if F77parm&X'40'#0 %then F77parm=F77parm!X'1000';! nowarnings -> noF77warnings 96 %IF CONTROL & 1 # 0 %THEN EMONON 97 diaglevel=4 98 %if Control&(1<<2)#0 %then diaglevel=0 99 %if Control&(1<<6)#0 %then diaglevel=0 100 inclevel=0 101 ASIZE = 0 102 BSIZE = 128 103 DSIZE = 64 104 LSIZE = 4 105 TSIZE = 256 106 %if OPT1&256#0 %thenstart; ! PARM MAXDICT set 107 bsize=bsize*2;dsize=dsize*2;tsize=tsize*2 108 %finish 109 SP2 = 0 110 Comregmap(24)=-1 111 %IF LSTREAM # 0 %THEN %START 112 NEWLINES(3) 113 PRINTSTRING(" Edinburgh Amdahl Fortran77 Compiler Version ".VSN) 114 NEWLINES(3) 115 %FINISH 116 FLAG = FORT77(CONTROL,OPT1,OPT2,F77PARM,OPTFLAGS,SRFLAGS,DSTREAM,LSTREAM,DSTREAM, %C C DIAGLEVEL,DSIZE,TSIZE,BSIZE,LSIZE,ASIZE,SP2) 118 %IF FLAG > 0 %THEN %START 119 ! WRITE(FLAG,1) 120 Comregmap(47)=Flag 121 COMREGMAP(24) = 0 122 ! PRINTSTRING(" Statements Compiled") 123 %FINISH %ELSE %START 124 ! PRINTSTRING("Program contains") 125 ! WRITE(-FLAG,1) 126 ! PRINTSTRING(" faults") 127 Comregmap(47)=-Flag 128 %FINISH 129 ! NEWLINE 130 %END 131 ! 132 %EXTERNALROUTINE F77AREA (%INTEGER INDEX, SIZE, %INTEGERNAME CONAD) 133 %INTEGER FLAG 134 %STRING (31) FILE 135 %CONSTSTRING (6) %ARRAY AREAS (0:6) = %C C "DICT", "NAMES", "TRIADS", "BLOCKS", "TABS", "LOOPS", "ASAVE" 137 FILE = "T#".AREAS(INDEX) 138 OUTFILE(FILE,SIZE,SIZE,0,CONAD,FLAG) 139 %IF FLAG # 0 %THEN %START 140 CONAD = -FLAG 141 %RETURN 142 %FINISH 143 %END 144 ! 145 %externalintegerfn Get Space(%integer Size) 146 %integer newconad,flag 147 %if gsconad=0 %thenstart 148 outfile("t#opt2",gsflen,0,0,gsconad,flag) 149 %if flag#0 %then %result=-1 150 gsfindex=size 151 %result=gsconad 152 %finish 153 newconad=gsconad+gsfindex 154 gsfindex=gsfindex+size 155 %if gsfindex>gsflen %thenstart 156 gsflen=gsfindex 157 changefilesize("t#opt2",gsflen,flag) 158 %if flag#0 %then %result=-1 159 %finish 160 %result=newconad 161 %end 162 163 %EXTERNALROUTINE SOURCE LINE (%INTEGER ABUFF) 164 %INTEGER I, L,cic,flag 165 SIM2(0,ABUFF + 1,0,L) 166 BYTEINTEGER(ABUFF) = L - 1 167 %if byteinteger(abuff+1)=25 %and inclevel>0 %thenstart 168 cic=comregmap(22) 169 inclevel=inclevel-1 170 selectinput(sfchan(inclevel)) 171 emas3close(cic,flag) 172 emas3clear(cic,flag) 173 %return 174 %finish 175 %IF L < 73 %THEN %START 176 %CYCLE I = L, 1, 72 177 BYTEINTEGER(ABUFF + I) = ' ' 178 %REPEAT 179 %FINISH 180 %END 181 ! 182 %EXTERNALROUTINE SETFUN 183 %END 184 ! 185 %EXTERNALintegerfn SELECTINCLUDE (%STRING (255) NAME) 186 %integer flag,cic 187 ! PRINTSTRING("CALLING SELECTINCLUDE") 188 ! NEWLINE 189 emas3existtype(name,flag) 190 %if flag<3 %or flag>4 %then %result=-1 191 sfchan(inclevel)=comregmap(22) 192 inclevel=inclevel+1 193 emas3claimchannel(cic) 194 emas3define(name,cic,flag) 195 %if flag#0 %then %result=flag 196 selectinput(cic) 197 %result=0 198 %END 199 ! 200 %EXTERNALROUTINE QPUT (%INTEGER A, B, C, D) 201 PRINTSTRING("CALLING QPUT");NEWLINE 202 %END 203 ! 204 %EXTERNALROUTINE QCODE (%INTEGER A, B, C, D) 205 PRINTSTRING("CALLING QCODE");NEWLINE 206 %END 207 ! 208 %EXTERNALROUTINE FREE (%INTEGER ADDRESS) 209 { PRINTSTRING("FREE");NEWLINE} 210 %END 211 ! 212 %ENDOFFILE 212 LINES ANALYSED SIZE= 6408 ? Warning :- Name r2 not used at line No 74 ? Warning :- Name ep not used at line No 74 ? Warning :- Name d not used at line No 202 ? Warning :- Name c not used at line No 202 ? Warning :- Name b not used at line No 202 ? Warning :- Name a not used at line No 202 ? Warning :- Name d not used at line No 206 ? Warning :- Name c not used at line No 206 ? Warning :- Name b not used at line No 206 ? Warning :- Name a not used at line No 206 ? Warning :- Name address not used at line No 210 ? Warning :- Name move not used at line No 212 IBM CODE 2992+ 256 BYTES GLAP 320+ 0 BYTES DIAG TABLES 888 BYTES TOTAL 4512 BYTES 156 STATEMENTS COMPILED ROUTINE/FN/MAP cross reference tables for file ERCC07:L1 ROUTINE/FN/MAP TYPE REFERENCES CHANGEFILESIZE ............ EXTERNALROUTINE .... 50 (SPEC) 157 COMREGMAP EXTERNALINTEGERMAP 52 (SPEC) 79 80 81 82 83 85 86 87 110 120 121 127 168 191 EMAS3CLAIMCHANNEL DYNAMICROUTINE 41 (SPEC) 193 EMAS3CLEAR ................ DYNAMICROUTINE ..... 44 (SPEC) 172 EMAS3CLOSE DYNAMICROUTINE 43 (SPEC) 171 EMAS3DEFINE ............... DYNAMICROUTINE ..... 42 (SPEC) 194 EMAS3EXISTTYPE EXTERNALROUTINE 46 (SPEC) 189 EMONON .................... EXTERNALROUTINE .... 47 (SPEC) 96 F77AREA EXTERNALROUTINE 132 (DECLN) FORT77 .................... EXTERNALINTEGERFN .. 53 (SPEC) 116 FREE EXTERNALROUTINE 208 (DECLN) GETSPACE .................. EXTERNALINTEGERFN .. 145 (DECLN) ICL9CEIBMF77 EXTERNALROUTINE 76 (DECLN) MOVE ...................... EXTERNALROUTINE .... 48 (SPEC) OUTFILE EXTERNALROUTINE 49 (SPEC) 138 148 QCODE ..................... EXTERNALROUTINE .... 204 (DECLN) QPUT EXTERNALROUTINE 200 (DECLN) SELECTINCLUDE ............. EXTERNALINTEGERFN .. 185 (DECLN) SETFUN EXTERNALROUTINE 182 (DECLN) SIM2 ...................... ROUTINE ............ 56 (DECLN) 165 SOURCELINE EXTERNALROUTINE 163 (DECLN) Source: ERCS08:F77REL.SRCE200_FALLOC3A Compiled: 25/11/87 17.09.24 Object: .NULL Parms set: NOCHECK,NOARRAY,XREF ERCC. Portable Imp80 Compiler Release 4 Version 14 Sep 87 2047 4095 1 ! falloc3a 2 ! 20/07/87 - Genfmt, set com_ioareaca=4 if zero 3 ! falloc2a 4 ! 09/04/87 - include contents of csyn71 instead of ftn_csynt70 5 ! falloc1a 6 ! 15/01/87 - insert %alis for FORMATCD 7 ! 8 ! falloc1 9 ! 16/11/86 - incorporate changes up to ftnalloc15 10 ! 23/09/86 - include files inserted 11 ! ftnalloc13 12 ! 16/09/86 - syntax modified to fault missing WHILE 13 ! ftnalloc12 14 ! 06/08/86 - use BSS for local arrays when practicable 15 ! ftnalloc11 16 ! 13/08/86 - allow up to 15Mb of common 17 ! 22/08/86 - correct -I2 action for lit int and log args (in Alloc Const) 18 !* 07/07/86 ftnalloc10 19 !* 20 %include "ftn_ht" 21 !* modified 16/11/86 22 ! add definitions of Cpu,Numoptregs 23 !* modified 10/10/85 24 !* 25 %constinteger ICL2900 = 1 26 %constinteger PERQPNX = 2 27 %constinteger ACCENT = 3 28 %constinteger IBM = 4 29 %constinteger VAX = 5 30 %constinteger M68000 = 6 31 %constinteger INTEL = 7 32 %constinteger LATTICE = 8 33 %constinteger VNS = 9 34 %constinteger GOULD =10 35 %constinteger WWC = 11 36 %constinteger WCW = 11 37 !* 38 %constinteger POSITIVE = 1 39 %constinteger NEGATIVE = -1 40 !* 41 %constinteger HOST = IBM 42 %constinteger TARGET = IBM 43 %constinteger STACK DIRECTION = POSITIVE 44 !* 45 %constinteger Concept = 0 46 %constinteger NP1 = 1 47 %constinteger Cpu = Concept {used only for Target=Gould at present } 48 !* 49 %constinteger Numoptregs = 0 {number of regs available for allocation} 50 {by Fortran optimiser - normally 0 or 1 } 51 !* 52 %constinteger IMP = 1 53 %constinteger fortran = 2 54 %constinteger ccomp = 11 55 %constinteger pascal = 14 56 %if target=LATTICE %thenstart 57 %externalroutinespec ICdatarec(%integer idrec,adict,anames) 58 %finish 59 {%include "ercs01:csyn71"} 60 !* 61 !* Syntax tables generated from file SYNTAX71 on 06/04/87 at 16.09.36 62 !* 63 %CONSTSHORTINTEGERARRAY COMP(0:3000)= %C C 0, 258, 0, 258, 0, 259, 0, 260, 0, 261, C 0, 262, 0, 263, 0, 264, 0, 0, 1, 1025, C 50, 5377, 17921, 0, 1, 1026, 70, 5377, 17922, 808, C 0, 265, 0, 0, 1, 1027, 94, 5377, 17923, 552, C 90, 265, 0, 0, 1, 0, 1, 1028, 114, 266, C 108, 17925, 0, 1, 28672, 0, 1, 1029, 146, 5125, C 267, 0, 1026, 0, 5377, 5888, 17922, 808, 0, 265, C 0, 0, 1, 268, 202, 554, 180, 5379, 5632, 1026, C 0, 5377, 5888, 17922, 808, 0, 265, 0, 0, 1, C 1026, 0, 5377, 5888, 17922, 808, 0, 265, 0, 0, C 1, 1030, 0, 20224, 0, 1, 5383, 0, 1, 269, C 0, 573, 0, 270, 0, 15111, 1536, 0, 0, 2, C 27392, 1536, 254, 271, 0, 0, 17, 5376, 13568, 1536, C 0, 0, 22, 272, 0, 273, 0, 32768, 1536, 354, C 554, 302, 15106, 274, 0, 275, 298, 0, 25, 0, C 37, 559, 346, 559, 328, 15106, 274, 0, 275, 324, C 0, 47, 0, 57, 15106, 274, 0, 275, 342, 0, C 64, 0, 76, 275, 0, 0, 86, 0, 94, 555, C 372, 15106, 276, 0, 0, 100, 557, 386, 15106, 276, C 0, 0, 105, 574, 406, 15360, 1536, 0, 15107, 270, C 0, 0, 110, 545, 420, 15108, 270, 0, 0, 114, C 550, 434, 15108, 270, 0, 0, 118, 638, 448, 15108, C 270, 0, 0, 122, 547, 0, 15108, 270, 0, 0, C 128, 1536, 0, 273, 0, 32768, 1536, 528, 554, 498, C 15106, 274, 0, 275, 494, 0, 134, 0, 147, 559, C 520, 15106, 274, 0, 275, 516, 0, 158, 0, 171, C 275, 0, 0, 182, 0, 191, 1536, 0, 273, 0, C 554, 554, 15106, 274, 0, 0, 198, 559, 582, 559, C 572, 15106, 274, 0, 0, 209, 15106, 274, 0, 0, C 218, 0, 229, 277, 0, 1031, 604, 15106, 273, 0, C 0, 236, 0, 242, 552, 644, 5382, 1536, 628, 13568, C 1536, 0, 0, 245, 15616, 271, 0, 809, 0, 15872, C 0, 248, 5376, 552, 776, 14336, 1536, 0, 17664, 1536, C 744, 1536, 714, 1536, 686, 278, 0, 28163, 30720, 1536, C 0, 0, 253, 553, 700, 1536, 0, 20992, 0, 259, C 279, 0, 809, 0, 20992, 0, 261, 280, 0, 13056, C 552, 740, 278, 0, 28163, 30720, 1536, 0, 0, 265, C 0, 273, 553, 758, 14848, 1536, 0, 0, 278, 281, C 0, 809, 0, 14848, 1536, 0, 0, 280, 13568, 1536, C 0, 0, 286, 5377, 552, 878, 16640, 1536, 0, 21504, C 1536, 854, 1536, 824, 278, 0, 28161, 30720, 1536, 0, C 0, 289, 280, 0, 19968, 552, 850, 278, 0, 28161, C 30720, 1536, 0, 0, 295, 0, 303, 553, 864, 20480, C 0, 308, 282, 0, 809, 0, 20480, 0, 311, 13824, C 1536, 0, 0, 314, 555, 898, 15110, 0, 317, 557, C 908, 15110, 0, 320, 604, 938, 15109, 555, 924, 15110, C 0, 323, 557, 934, 15110, 0, 326, 0, 329, 0, C 332, 570, 978, 29696, 1536, 0, 553, 966, 29696, 1536, C 0, 0, 335, 283, 0, 809, 0, 0, 337, 283, C 0, 826, 0, 553, 1000, 29696, 1536, 0, 0, 341, C 283, 0, 809, 0, 0, 345, 15616, 28172, 270, 0, C 15111, 15872, 0, 351, 28172, 285, 0, 0, 356, 27392, C 1536, 1054, 286, 0, 15111, 0, 359, 5376, 26368, 1536, C 0, 0, 364, 272, 0, 287, 0, 288, 1094, 289, C 0, 290, 1090, 0, 367, 0, 379, 290, 1102, 0, C 389, 0, 397, 291, 1118, 292, 0, 0, 403, 293, C 0, 286, 0, 0, 408, 1536, 0, 1536, 0, 287, C 0, 288, 1162, 289, 0, 290, 1158, 0, 413, 0, C 426, 290, 1170, 0, 437, 0, 446, 1536, 0, 1536, C 0, 287, 0, 288, 1198, 289, 0, 0, 453, 0, C 464, 294, 0, 1031, 1220, 15106, 287, 0, 0, 471, C 0, 480, 552, 1260, 5382, 1536, 1244, 26369, 1536, 0, C 0, 483, 15616, 286, 0, 809, 0, 15872, 0, 486, C 5376, 26368, 1536, 0, 0, 491, 1032, 1282, 15106, 0, C 494, 559, 1292, 15106, 0, 497, 554, 0, 15106, 0, C 500, 555, 1312, 15106, 0, 503, 557, 0, 15106, 0, C 506, 574, 1338, 15360, 1536, 0, 15107, 0, 509, 545, C 1348, 15108, 0, 512, 550, 1358, 15108, 0, 515, 638, C 1368, 15108, 0, 518, 547, 0, 15108, 0, 521, 554, C 1402, 5379, 12544, 556, 1398, 281, 0, 0, 524, 0, C 1, 550, 1426, 5379, 12544, 556, 1422, 281, 0, 0, C 527, 0, 1, 1033, 1466, 270, 0, 15111, 1536, 0, C 14592, 1536, 0, 553, 0, 556, 1462, 281, 0, 0, C 530, 0, 541, 295, 0, 15111, 1536, 0, 14592, 1536, C 0, 556, 1494, 281, 0, 0, 544, 0, 555, 27392, C 1536, 1512, 270, 0, 0, 564, 5376, 32256, 1536, 0, C 0, 567, 270, 0, 15111, 16384, 1536, 0, 556, 1548, C 280, 0, 0, 570, 809, 0, 0, 578, 5377, 20736, C 556, 1572, 282, 0, 0, 1, 0, 1, 270, 0, C 15111, 1536, 0, 21248, 1536, 0, 556, 1604, 279, 0, C 0, 584, 0, 597, 32512, 1034, 1638, 5379, 14081, 1536, C 0, 1035, 0, 5377, 11776, 1536, 0, 0, 608, 1036, C 1666, 2566, 296, 0, 556, 1662, 28161, 297, 0, 0, C 614, 0, 626, 1037, 1690, 552, 1682, 298, 0, 0, C 635, 299, 0, 0, 641, 1038, 1708, 2561, 5127, 30976, C 300, 0, 0, 1, 1039, 1768, 5377, 552, 1754, 16896, C 1536, 0, 553, 1736, 1536, 0, 0, 650, 281, 0, C 12800, 1536, 0, 553, 0, 0, 655, 16896, 1536, 0, C 1536, 0, 0, 663, 1040, 1776, 0, 668, 1041, 1788, C 301, 0, 0, 1, 1042, 1802, 6912, 302, 0, 0, C 1, 1043, 1834, 5123, 30976, 554, 1826, 5379, 5632, 303, C 0, 0, 1, 300, 0, 0, 1, 1029, 1854, 5125, C 30976, 267, 0, 303, 0, 0, 1, 1044, 1872, 2562, C 5129, 30976, 300, 0, 0, 1, 1045, 1888, 808, 0, C 298, 0, 0, 670, 1046, 1900, 304, 0, 0, 1, C 1047, 1912, 305, 0, 0, 1, 1048, 1944, 5126, 30976, C 554, 1936, 5379, 5632, 303, 0, 0, 1, 300, 0, C 0, 1, 1049, 1960, 5128, 30976, 300, 0, 0, 1, C 1050, 1996, 33280, 11521, 1536, 0, 1307, 0, 270, 0, C 15111, 1536, 0, 809, 0, 33536, 0, 676, 1052, 2008, C 306, 0, 0, 1, 1053, 2022, 26624, 307, 0, 0, C 1, 1054, 2046, 552, 2038, 298, 0, 0, 682, 299, C 0, 0, 688, 1055, 2056, 28931, 0, 697, 1056, 2066, C 33024, 0, 700, 1057, 2076, 4865, 0, 702, 1058, 2102, C 4864, 5377, 17924, 552, 2098, 265, 0, 0, 1, 0, C 1, 1059, 2130, 270, 0, 15111, 1536, 0, 809, 0, C 1316, 0, 28929, 0, 704, 1061, 2140, 28930, 0, 713, C 1062, 2150, 22528, 0, 1, 1063, 2174, 308, 0, 809, C 0, 1836, 0, 270, 0, 0, 716, 1064, 2190, 5376, C 14080, 1536, 0, 0, 722, 1065, 2222, 5121, 30976, 554, C 2214, 5379, 5632, 303, 0, 0, 1, 303, 0, 0, C 1, 1066, 2248, 1067, 2238, 2563, 9985, 0, 1, 309, C 0, 9984, 0, 1, 1068, 2262, 26627, 307, 0, 0, C 1, 1069, 2278, 808, 0, 298, 0, 0, 724, 1070, C 2288, 33792, 0, 1, 1071, 2320, 5124, 30976, 554, 2312, C 5379, 5632, 303, 0, 0, 1, 303, 0, 0, 1, C 1072, 2342, 2568, 5377, 21760, 815, 0, 310, 0, 0, C 1, 1073, 2358, 808, 0, 298, 0, 0, 730, 1074, C 2384, 296, 0, 556, 2380, 28161, 297, 0, 0, 736, C 0, 748, 1075, 2400, 808, 0, 311, 0, 0, 1, C 1076, 2426, 22784, 1536, 2414, 0, 757, 5381, 12288, 1536, C 0, 0, 759, 1077, 2458, 5122, 30976, 554, 2450, 5379, C 5632, 303, 0, 0, 1, 303, 0, 0, 1, 1078, C 2502, 552, 2480, 312, 0, 28161, 297, 0, 0, 761, C 296, 0, 556, 2498, 28161, 297, 0, 0, 770, 0, C 782, 1079, 2526, 28416, 1536, 2516, 0, 791, 28172, 270, C 0, 0, 793, 1080, 2550, 552, 2542, 298, 0, 0, C 797, 299, 0, 0, 803, 1081, 2576, 22784, 1536, 2564, C 0, 812, 5381, 12288, 1536, 0, 0, 814, 1082, 2600, C 30976, 22784, 1536, 2592, 0, 1, 313, 0, 0, 1, C 1083, 2628, 2567, 296, 0, 556, 2624, 28161, 297, 0, C 0, 816, 0, 828, 1084, 2650, 808, 0, 312, 0, C 28161, 297, 0, 0, 837, 1085, 2660, 10240, 0, 1, C 1086, 2670, 10241, 0, 1, 1030, 2680, 20224, 0, 1, C 1087, 0, 25088, 0, 1, 554, 2748, 552, 2736, 554, C 2716, 809, 0, 31488, 1836, 0, 0, 1, 284, 0, C 809, 0, 31489, 5632, 1836, 0, 0, 1, 5379, 5632, C 1836, 0, 0, 1, 0, 1, 554, 2798, 552, 2790, C 554, 2774, 809, 0, 31490, 0, 1, 284, 0, 809, C 0, 31489, 6144, 0, 1, 5379, 6144, 0, 1, 0, C 1, 1065, 2812, 5121, 0, 1, 1077, 2822, 5122, 0, C 1, 1043, 2832, 5123, 0, 1, 1071, 2842, 5124, 0, C 1, 1048, 2852, 5126, 0, 1, 1029, 2862, 5125, 0, C 1, 1038, 2874, 2561, 5127, 0, 1, 1049, 2884, 5128, C 0, 1, 1044, 0, 2562, 5129, 0, 1, 5377, 5888, C 315, 0, 556, 2916, 300, 0, 0, 1, 559, 2940, C 316, 0, 556, 2936, 300, 0, 0, 1, 0, 1, C 0, 1, 5377, 5888, 315, 0, 314, 2996, 556, 2968, C 303, 0, 0, 1, 559, 2992, 316, 0, 556, 2988, C 303, 0, 0, 1, 0, 1, 0, 1, 556, 3008, C 303, 0, 0, 1, 0, 1, 7680, 7936, 317, 0, C 0, 1, 552, 3038, 6400, 318, 0, 0, 1, 0, C 1, 554, 3058, 29184, 809, 0, 8960, 0, 1, 319, C 0, 6656, 556, 3076, 318, 0, 0, 1, 553, 3086, C 8960, 0, 1, 826, 0, 554, 3106, 29185, 809, 0, C 8960, 0, 1, 319, 0, 6657, 556, 3124, 318, 0, C 0, 1, 809, 0, 8960, 0, 1, 284, 0, 0, C 846, 5381, 554, 3176, 9216, 5381, 9472, 556, 3166, 317, C 0, 0, 1, 815, 0, 9728, 0, 1, 9472, 556, C 3190, 317, 0, 0, 1, 815, 0, 9728, 0, 1, C 5377, 552, 0, 6400, 318, 0, 556, 3224, 304, 0, C 0, 1, 0, 1, 559, 3242, 6912, 302, 0, 0, C 1, 5377, 7168, 815, 0, 302, 0, 0, 1, 5377, C 7424, 315, 0, 556, 3290, 559, 3282, 301, 0, 0, C 1, 302, 0, 0, 1, 559, 3302, 301, 0, 0, C 1, 0, 1, 5377, 7680, 321, 0, 815, 0, 317, C 0, 31232, 1836, 0, 305, 0, 0, 1, 7680, 322, C 0, 559, 0, 317, 0, 31232, 1836, 0, 305, 0, C 0, 1, 552, 3388, 323, 0, 556, 3384, 322, 0, C 0, 1, 0, 1, 5377, 552, 3416, 8192, 324, 0, C 556, 3412, 322, 0, 0, 1, 0, 1, 7936, 556, C 3430, 322, 0, 0, 1, 0, 1, 10496, 325, 0, C 0, 1, 552, 3464, 323, 0, 812, 0, 325, 0, C 0, 1, 5377, 552, 3488, 10497, 326, 0, 812, 0, C 325, 0, 0, 1, 829, 0, 10498, 327, 0, 10499, C 812, 0, 327, 0, 10500, 556, 3530, 327, 0, 10501, C 809, 0, 10503, 0, 1, 809, 0, 10503, 10502, 0, C 1, 327, 0, 10504, 556, 3560, 326, 0, 0, 1, C 809, 0, 10505, 0, 1, 328, 0, 30208, 0, 1, C 285, 0, 0, 851, 552, 3616, 8192, 324, 0, 556, C 3612, 5377, 321, 0, 0, 1, 0, 1, 7936, 556, C 3632, 5377, 321, 0, 0, 1, 0, 1, 8193, 1536, C 3654, 278, 0, 30208, 7937, 0, 1, 329, 0, 0, C 1, 284, 0, 30208, 8448, 556, 3682, 329, 0, 0, C 1, 809, 0, 552, 3702, 278, 0, 30208, 8705, 0, C 1, 8705, 0, 1, 5377, 21761, 556, 3724, 310, 0, C 0, 1, 559, 3746, 21762, 5377, 21760, 815, 0, 310, C 0, 0, 1, 21762, 0, 1, 330, 0, 30208, 556, C 3770, 311, 0, 0, 1, 809, 0, 0, 1, 5377, C 829, 0, 26112, 1536, 0, 285, 0, 30720, 1536, 0, C 0, 856, 268, 3904, 554, 3880, 552, 3852, 284, 0, C 809, 0, 31489, 5632, 808, 0, 331, 0, 556, 3848, C 309, 0, 0, 1, 0, 1, 5379, 5632, 808, 0, C 331, 0, 556, 3876, 309, 0, 0, 1, 0, 1, C 808, 0, 331, 0, 556, 3900, 309, 0, 0, 1, C 0, 1, 1088, 0, 2564, 552, 3936, 5120, 331, 0, C 556, 3932, 309, 0, 0, 1, 0, 1, 9985, 0, C 1, 10752, 557, 3970, 11008, 556, 3962, 331, 0, 0, C 1, 809, 0, 0, 1, 556, 3982, 331, 0, 0, C 1, 809, 0, 0, 1, 808, 0, 5377, 7680, 321, C 0, 809, 0, 11264, 556, 4020, 306, 0, 0, 1, C 0, 1, 5379, 12544, 556, 4040, 308, 0, 0, 861, C 12800, 1536, 0, 0, 864, 332, 4074, 556, 4066, 333, C 0, 0, 867, 809, 0, 0, 872, 299, 0, 556, C 4114, 333, 4090, 0, 875, 296, 0, 556, 4106, 333, C 0, 0, 883, 809, 0, 0, 896, 809, 0, 0, C 907, 332, 0, 556, 4138, 333, 0, 0, 913, 809, C 0, 0, 918, 554, 4154, 0, 921, 28161, 270, 0, C 0, 924, 554, 4172, 0, 927, 28161, 270, 0, 0, C 930, 1089, 4194, 299, 0, 0, 933, 1090, 4206, 296, C 0, 0, 939, 1091, 4220, 28161, 270, 0, 0, 945, C 1092, 4234, 5376, 1536, 0, 0, 951, 1093, 4248, 5376, C 1536, 0, 0, 955, 1094, 0, 28161, 270, 0, 0, C 959, 332, 4286, 556, 4278, 334, 0, 0, 965, 809, C 0, 0, 970, 334, 4294, 0, 973, 299, 0, 556, C 4310, 334, 0, 0, 976, 809, 0, 0, 984, 28161, C 332, 4344, 556, 4336, 334, 0, 0, 990, 809, 0, C 0, 995, 335, 0, 270, 0, 556, 4364, 334, 0, C 0, 998, 809, 0, 0, 1007, 1095, 4380, 0, 1014, C 1096, 4388, 0, 1017, 1097, 4396, 0, 1020, 1098, 4404, C 0, 1023, 1099, 4412, 0, 1026, 1100, 4420, 0, 1029, C 1101, 4428, 0, 1032, 1102, 4436, 0, 1035, 1103, 4444, C 0, 1038, 1104, 4452, 0, 1041, 1105, 4460, 0, 1044, C 1106, 4468, 0, 1047, 1107, 4476, 0, 1050, 1108, 4484, C 0, 1053, 1109, 4492, 0, 1056, 1110, 4500, 0, 1059, C 1111, 4508, 0, 1062, 1112, 4516, 0, 1065, 1113, 0, C 0, 1068, 552, 4608, 18688, 297, 0, 573, 4594, 19456, C 1536, 0, 336, 0, 812, 0, 336, 0, 556, 4576, C 336, 0, 809, 0, 337, 0, 0, 1071, 12033, 1536, C 0, 809, 0, 337, 0, 0, 1086, 809, 0, 23808, C 337, 0, 0, 1099, 32000, 1536, 4640, 1536, 4622, 0, C 1, 5377, 32256, 18432, 1536, 0, 337, 0, 0, 1104, C 28161, 270, 0, 15111, 1536, 0, 337, 0, 0, 1109, C 556, 4674, 17408, 297, 0, 0, 1120, 0, 1, 5377, C 17152, 556, 4694, 307, 0, 0, 1, 0, 1, 559, C 4726, 5377, 31745, 815, 0, 556, 4722, 313, 0, 0, C 1, 0, 1, 5377, 31744, 556, 4742, 313, 0, 0, C 1, 0, 1, 553, 4754, 0, 1, 554, 4780, 18944, C 556, 4772, 265, 0, 0, 1, 809, 0, 0, 1, C 5377, 19200, 556, 4796, 265, 0, 0, 1, 809, 0, C 0, 1, 1114, 0, 270, 0, 15111, 1536, 0, 809, C 0, 16128, 1536, 4872, 4608, 5379, 14080, 4352, 1536, 0, C 556, 0, 5379, 14080, 4352, 1536, 0, 556, 0, 5379, C 14080, 4352, 1536, 0, 0, 1123, 1114, 4940, 270, 0, C 15111, 1536, 0, 553, 0, 16128, 1536, 0, 4608, 5379, C 14080, 4352, 1536, 0, 556, 0, 5379, 14080, 4352, 1536, C 0, 556, 0, 5379, 14080, 4352, 1536, 0, 0, 1130, C 1060, 4950, 28928, 0, 1143, 258, 0, 0, 1152, 1114, C 0, 270, 0, 15111, 1536, 0, 809, 0, 19712, 259, C 0, 0, 1162, 580, 0, 847, 0, 33280, 11520, 1536, C 0, 1836, 0, 5377, 11777, 1536, 0, 829, 0, 336, C 0, 812, 0, 336, 0, 556, 5042, 336, 0, 0, C 1172, 12033, 1536, 0, 0, 1180, 28169, 270, 0, 15111, C 0, 1186, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 0; 365 366 367 {%include "ftn_fmts2"} 368 !* 09/12/85 - add recordformat SUBFMT 369 !* modified 14/03/85 370 !* 371 !*********************************************************************** 372 !* Formats for accessing dictionary records * 373 !*********************************************************************** 374 !* 375 %recordformat PRECF(%byteinteger CLASS,TYPE,X0,X1, C %integer LINK1, LINK2, C (%shortinteger COORD,LINK3 %OR %integer LAST %C C %OR %integer CONSTRES %OR %integer INF3), C %integer ADDR4, C %shortinteger DISP,LEN,IDEN,IIN, C %integer LINE,XREF,CMNLENGTH,CMNREFAD) 382 !* 383 %recordformat SRECF(%integer INF0, LINK1, INF2, INF3, INF4) 384 !* 385 %recordformat RESF((%integer W %OR %shortinteger H0, C (%shortinteger H1 %OR %byteinteger FORM,MODE))) 387 !* 388 %recordformat DORECF( %C C %integer LABEL, LINK1, C %record(RESF) LOOPAD, ENDREF, INDEXRD, INCRD, FINALRD, ICRD, C %integer LABLIST,LINE) 392 !* 393 %recordformat BFMT(%integer L,U,M) 394 !* 395 %recordformat ARRAYDVF(%integer DIMS, ADDRDV,ADDRZERO, %C C %integer ZEROTOFIRST, ADFIRST, NUMELS, ELLENGTH, %C C %record(BFMT) %ARRAY B(1 : 7)) 398 !* 399 !* 400 %recordformat LRECF(%integer NOTFLAG,LINK1, C %record(RESF) ORLAB,ANDLAB, C %integer RELOP) 403 !* 404 %recordformat IFRECF(%integer TYPE,LINK1, C %record(RESF) ENDIFLAB,FALSELAB, C %integer LABLIST,LINE) 407 !* 408 %recordformat LABRECF(%shortinteger BLKIND,%byteinteger X0,X1, %C C %integer LINK1,LINK2,LINK3,ADDR4,LINK5,LAB,LINE, %C C %shortinteger DOSTART,DOEND,IFSTART,IFEND) 411 !* 412 %recordformat PLABF(%shortinteger BLKIND,%byteinteger USE,X1, C %integer INDEX,CODEAD,REF,REFCHAIN) 414 !* 415 %recordformat IMPDORECF(%integer VAL,LINK,IDEN) 416 !* 417 %recordformat CONSTRECF(%shortinteger MODE,LENGTH, C (%integer VALUE %OR %integer LINK1), C %integer DADDR,CADDR) 420 !* 421 %recordformat TMPF((%byteinteger CLASS,TYPE, C %shortinteger LEN %OR %integer W0), C %integer LINK1, C %byteinteger REG,MODE,%shortinteger INDEX, C %shortinteger COORD,USECNT, C %integer ADDR) 427 !* 428 %recordformat CHARF(%integer ADESC,LINK,LEN) 429 !* 430 %recordformat FNRECF(%integer FPTR,LINK1,HEAD,PCT) 431 !* 432 %recordformat TERECF(%shortinteger MODE,LOOP, C %integer CHAIN,DISP1,INDEX, C %shortinteger COORD,FLAGS) 435 !* 436 %recordformat DTRECF(%shortinteger MODE,IDENT, C %integer CHAIN,DISP2, C %shortinteger FLAGS,INDEX, C (%integer LOOP %OR %record(RESF) CONST)) 440 !* 441 !* 442 !*********************************************************************** 443 !* TRIAD record format * 444 !*********************************************************************** 445 !* 446 %recordformat TRIADF( %C C %byteinteger OP, C (%byteinteger USE %OR %byteinteger VAL2), C %shortinteger CHAIN, C (%record(RESF) RES1 %OR %C C (%shortinteger OPD1,%byteinteger QOPD1,MODE %OR %C C (%integer SLN %OR %integer VAL1))), C (%record(RESF) RES2 %OR %C C %shortinteger OPD2,%byteinteger QOPD2,MODE2)) 455 !* 456 !*********************************************************************** 457 !* COM record format * 458 !*********************************************************************** 459 !* 460 %recordformat COMFMT(%integer CONTROL,OPT,OPTIONS1,OPTIONS2,PTRACE, C ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR, C MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD, C SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST, C RESCOM1,RESCOM2,F77PARM,FNO,FAULTY,LINEST,CMNIIN,SFMK, C LISTL,LISTSTREAM,DIAGSTREAM,LISTMODE,XREF, C PACKCMN,ITSMODE,PATHANAL,CHARACTER CODE,SPACE CHAR, C HEADINGS,ARRAYCHECKS,JBRMODE,MESSLEN,NAMESLEN, C NEXTCH,FUNRESDISP,WARNCOUNT,INP,MAXINP,MESSCOUNT, C UNASSPATTERN,LISTCODE,PI21INT,DOPTR,SUBPROGPTR, C FNLST,LAB,NAMESFREE,ALGOLREF,FIRSTSTATNUM,CEXPDICT, C COMMONBASE,FASTPROLOGUE,STATEMENT,IFPTR, C CNSTCA,COMMENTCNT,ADIDENT,ADERRIDEN, C ADEXT,MAXDICT,MAXNAMES,MAXOUTPUT,MAXEXT, C ACOMP,ASUBNAMES,MAXPSTACK, C ATRIADS,TRFILEID,TRBLOCK,CMNCNT,SCANONLY,NOISY, C MAXANAL,MAXGEN,SAVEANAL,SAVEGEN,OPTFLAGS,NEXTBIT, C ACMNBITS,NEXTTEMP,ASSGOTOS,TMPPTR,DESTEMPS,OBJADDR, C AREAADDR,PASTART,ADOPTDATA,TMINDEX,VRETURN,ENTRIES, C EQUCHK,LABWARN,LINENO,MAXIBUFF, C COMMENTS,DIAGLEVEL,WARNNOT77,WARNLENGTH,ALLOWUNIX,ALLOWVAX, C ONETRIP,HOST,TARGET,MONERRS,CODECA, C GLACA,DIAGCA,SSTCA,GSTCA,CONSTCA,SCALARCA,IOAREACA,ZGSTCA,STACKCA, C W1,W2,W4,STATORDERMODE,CURSTATCLASS,LISTPOINT,STACKBASE, C NEXTTRIAD,ASAVE,MAXSAVE,SUBTAB,LASTSUBTAB, C INHIBOP4,ARGCNT,IDCNT,LABCNT,TMLIST,MAINPROG,PROCINDEX,CONSOLE) 486 !* 487 !*********************************************************************** 488 !* record format for communicating with optimiser * 489 !*********************************************************************** 490 !* 491 %recordformat OBJFMT(%string(35) MODULE,%integer MAINEP,I,J,K, C ADATE,ATIME,OPTIONS2,EXTPROCS,ATRIADS,MAXTRIADS, C ABLOCKS,MAXBLOCKS,ALOOP,MAXLOOP,ATABS,MAXTABS, C SRFLAGS,INHIBMASK,OPT,OPTFLAGS,OPTDESC0,OPTDESC1, C D1,D2,D3,D4) 496 !* 497 !*********************************************************************** 498 !* 499 !* 500 %RECORDFORMAT SUBRECF(%INTEGER LINK,FLAGS,TRIADS,DICT,NAMES,PTRS,PROG, C LABCNT,ARGCNT,IDCNT,TRCNT,REFSCNT,SUBSCNT, C DPTR,NEXTTRIAD,NAMESFREE,NEXTBIT,SUBPROGTYPE,SUBPROGPTR, C CBNPTR,SCPTR,CMNIIN,FUNRESDISP,CMNCNT,ASSGOTOS,VRETURN,ENTRIES, C TMLIST,ALABS,ALHEADS,NEXTPLAB, C %STRING(32) NAME,%INTEGERARRAY COORDS(0:15)) 506 !* 507 %CONSTINTEGER SUBSIZE=232 508 %CONSTINTEGER LABSIZE=128 509 %CONSTINTEGER LHEADSIZE=620 510 !* 511 {%include "ftn_consts"} 512 !* modified 23/09/86 513 !* 514 !* 515 %constinteger WSCALE = 2;! scale word address to byte address 516 %constinteger BSCALE = 0;! scaling factor for words to architectural units 517 %constinteger CSCALE = 0;! byte offset to architectural unit offset 518 %constinteger DSCALE = 2;! dict pointer scaling in RES records 519 !* 520 %constinteger W1 = 4 ;! 1 word in architectural units 521 %constinteger W2 = 8 ;! 2 words in architectural units 522 %constinteger W3 = 12 ;! 3 words in architectural units 523 %constinteger W4 = 16 ;! 4 words in architectural units 524 !* 525 %constinteger TRIADLENGTH = 12 ;! size of an individual triad 526 %constinteger BLRECSIZE = 44 ;! size of a block table entry in architectural units 527 %constinteger LOOPRECSIZE = 16 ;! size of a loop table entry 528 %constinteger PROPRECSIZE = 12 ;! size of a propagation table entry 529 %constinteger CLOOPSZ = 12 ;! size of cloop table entry 530 %constinteger FRSIZE = 8 ;! size of freelist created by PUSHFREE 531 %constinteger TESZ = 20 532 %constinteger DTSZ = 20 533 %constinteger ARTICSZ = 4 534 %constinteger CTSIZE = 2 ;! used in OP3 535 %constinteger EXTNSIZE = 4 ;! used in OP3 536 !* 537 !* following used in strength reduction 538 !* 539 %constinteger RDSZ = 8 540 %constinteger RUSESZ = 12 541 %constinteger RTESTSZ = 4 542 %constinteger RDEFSZ = 16 543 %constinteger USESZ = 32 544 %constinteger SRUSESZ = 2 545 %constinteger SRSCALE = 2;! SR==RECORD(ABLOCKS + SRPTR<>1 864 %finishelsestart 865 L=Length 866 %finish 867 I=Com_Dptr 868 Com_Dptr=Com_Dptr+L 869 %if Com_Dptr>Com_Diclen %then Dicful 870 Zero(Com_Adict+I,Length) 871 %result=I 872 %end;! Dictspace 873 !* 874 !****************************************************************************** 875 !* * 876 !* LIST MANIPULATION * 877 !* * 878 !****************************************************************************** 879 !* 880 !* 881 %externalintegerfn FREESP(%integer N) 882 !*********************************************************************** 883 !* OBTAIN N-WORD(32 BIT) LIST ITEM * 884 !*********************************************************************** 885 %integer PTR 886 %record(SRECF) %name SS 887 PTR=ASL(N) 888 %if PTR = 0 %thenstart 889 PTR = Dict Space(N<<2) 890 SS == RECORD(ADICT+PTR) 891 %finishelsestart 892 SS == RECORD(ADICT+PTR) 893 ASL(N) = SS_LINK1 894 %finish 895 SS_LINK1 = 0 896 %result=PTR 897 %end; ! FREESP 898 !* 899 %externalroutine FREE LIST CELL(%integername LISTHEAD,%integer N) 900 %integer J 901 %record(SRECF) %name SS 902 SS==record(ADICT+LISTHEAD) 903 J=SS_LINK1;! NEW LISTHEAD 904 SS_LINK1=ASL(N) 905 ASL(N)=LISTHEAD 906 LISTHEAD=J 907 %end;! FREE LIST CELL 908 !* 909 %externalintegerfn NEW LIST CELL(%integername LISTHEAD,%integer N) 910 %integer PTR 911 %record(SRECF) %name SS 912 PTR=FREESP(N) 913 SS==record(ADICT+PTR) 914 SS_LINK1=LISTHEAD 915 LISTHEAD=PTR 916 %result=PTR 917 %end;! NEW LIST CELL 918 !* 919 !****************************************************************************** 920 !* * 921 !* NAME, LABEL AND CONST HANDLING * 922 !* * 923 !****************************************************************************** 924 !* 925 !* 926 %externalintegerfn SETLAB(%integer LAB,%integername LABRECPTR) 927 !*********************************************************************** 928 !* LOCATE ENTRY IN LABEL LIST OR CREATE NEW ENTRY * 929 !*********************************************************************** 930 %integer LPTR,PTR,I,J 931 %record(LABRECF) %name LABREC 932 PTR = LABH(LAB&31) 933 LPTR=PTR 934 %while PTR # 0 %cycle 935 LABREC == RECORD(ADICT+PTR) 936 %if LABREC_LAB = LAB %C C %then LABRECPTR=PTR %AND %result=0 938 PTR = LABREC_LINK1 939 %repeat 940 PTR = Dictspace(LABRECSIZE) 941 LABREC == RECORD(ADICT+PTR) 942 LABREC_BLKIND=0 943 LABREC_LINK1 = LPTR 944 LABREC_LAB = LAB 945 LPTR = PTR 946 LABH(LAB&31) = LPTR 947 LABRECPTR=PTR 948 Com_Labcnt=Com_Labcnt+1 ;! for Op4 949 %result=1 950 %end; ! SETLAB 951 !* 952 %externalintegerfn SETCONREC(%record(RESF) RES) 953 !*********************************************************************** 954 !* On entry a copy of the const is held as the item last added to DICT * 955 !* RES = (PTR>>DSCALE) << 16 ! x'100' ! mode * 956 !* For numeric constants a search is made of the appropriate list * 957 !* of 4, 8, or 16 byte entries to see whether a copy is already held. * 958 !* If not, and also for non-numeric constants, a new 4 word record is * 959 !* added to the appropriate list * 960 !* Content is MODE mode * 961 !* LINK1 link through chain of consts of same size * 962 !* DADDR DICT @ of const * 963 !* CADDR @ of const in CONSTS if allocated, else 0 * 964 !*********************************************************************** 965 %CONSTBYTEINTEGERARRAY LIST(0:15)=1,1,2,1,2,0,2,0,0,1,0,0,0,0,0,0 966 %integer I,J,K,M,R,Val,Len 967 %record(CONSTRECF) %name CON 968 %SWITCH S(0:3) 969 M=RES_MODE 970 R=RES_H0<S(I) 975 !* 976 S(1): J=CHEAD1 977 %while J#0 %cycle 978 CON==record(ADICT+J) 979 %if Val=INTEGER(ADICT+CON_DADDR) %C C %AND M=CON_MODE %thenstart 981 HIT: %result=J 982 %finish 983 J=CON_LINK1 984 %repeat 985 J=CHEAD1 986 CHEAD1=COM_DPTR 987 Len=4 988 SET: I=Dict Space(CONRECSIZE) 989 CON==record(ADICT+I) 990 CON_MODE=M 991 %if M=HOLMODE %thenstart 992 Val=((Val+3)>>2)<<2 993 %if Val>Len %then Len=Val 994 %finish 995 Con_Length=Len 996 CON_LINK1=J 997 CON_DADDR=R 998 CON_CADDR=0 999 %result=I 1000 !* 1001 S(2): J=CHEAD2 1002 %while J#0 %cycle 1003 CON==record(ADICT+J) 1004 %if Val=integer(Adict+Con_Daddr) %c C %and M=Con_Mode %thenstart 1006 %if integer(K+Com_W1)=integer(Adict+Con_Daddr+Com_W1) %then ->Hit 1007 %finish 1008 J=CON_LINK1 1009 %repeat 1010 J=CHEAD2 1011 CHEAD2=COM_DPTR 1012 Len=8 1013 ->SET 1014 !* 1015 S(0): J=CHEAD0 1016 CHEAD0=COM_DPTR 1017 Len=16 1018 ->SET 1019 %end;! SETCONREC 1020 !* 1021 %externalintegerfn Conin(%integer Val) 1022 %record(RESF) R 1023 R_Mode=INT4 1024 %if 0<=Val<=X'7FFF' %thenstart 1025 R_Form=LIT 1026 R_H0=Val 1027 %result=R_W 1028 %finish 1029 %if -X'7FFF'<=Val<0 %thenstart 1030 R_Form=NEGLIT 1031 R_H0=-Val 1032 %result=R_W 1033 %finish 1034 integer(Adict+Com_Dptr)=Val 1035 R_H0=Com_Dptr>>DSCALE 1036 R_Form=1 1037 Com_Dptr=Com_Dptr+W1 1038 R_H0=Setconrec(R)>>DSCALE 1039 R_Form=CNSTID 1040 %result=R_W 1041 %end;! Conin 1042 !* 1043 {%include "pf_setbit"} 1044 !* 1045 %ROUTINE SETBIT(%INTEGER STRIPADDR,INDEX) 1046 %INTEGER WD,BIT 1047 %INTEGERARRAYNAME BS 1048 %ownINTEGERARRAYFORMAT BSFMT(0:100) 1049 BS==ARRAY(STRIPADDR,BSFMT) 1050 WD=INDEX>>5 1051 BIT=31-INDEX&X'1F' 1052 BS(WD)=BS(WD)!(1<F(R_Form) 1098 !* 1099 F(NEGLIT): 1100 Val=-Val 1101 !* 1102 F(LIT): 1103 Ad=Dictspace(4) 1104 integer(Com_Adict+Ad)=Val 1105 R_H0=Ad>>DSCALE 1106 Ad=Setconrec(R) 1107 Set: Con==record(Adict+Ad) 1108 ! %if Con_Caddr=0 %thenstart 1109 Con_Caddr=Const Space(Con_Length,IIN) 1110 Cad=Con_Caddr 1111 Ad=Adict+Con_Daddr 1112 %if Modetobytes(R_Mode)=2 %then Ad=Ad+2 1113 %if Con_Mode=HOLMODE %then Ad=Ad+W1 1114 Edbytes(IIN,Cad,Con_Length,Ad) 1115 ! %finish 1116 %result=Con_Caddr 1117 !* 1118 F(CNSTID): 1119 Ad=R_H0<Set 1121 %end;! Alloc Const 1122 !* 1123 %externalroutine NEW TEMP(%record(RESF)%name RES,%integer MODE,USE) 1124 !*********************************************************************** 1125 !* Get temp scalar DICT record * 1126 !*********************************************************************** 1127 %integer IIN,J 1128 %record(TMPF)%name TMP 1129 %record(COMFMT)%name COM 1130 COM==record(COMAD) 1131 J=Dict Space(TMPRECSIZE) 1132 TMP==record(COM_ADICT+J) 1133 TMP_MODE=MODE 1134 TMP_REG=0 1135 TMP_LINK1=0 1136 TMP_ADDR=0 1137 TMP_W0=0 1138 TMP_USECNT=USE 1139 TMP_INDEX=COM_NEXT TEMP 1140 COM_NEXT TEMP=COM_NEXT TEMP+1 1141 %IF COM_NEXTBIT<512 %THENSTART 1142 TMP_COORD=COM_NEXTBIT 1143 COM_NEXTBIT=COM_NEXTBIT+1 1144 %FINISHELSE TMP_COORD=3 1145 RES_FORM=TMPID 1146 RES_MODE=MODE 1147 RES_H0=J>>DSCALE 1148 %end;! GET TEMP 1149 !* 1150 !* 1151 %externalroutine BSSreloc(%integer Ptr) 1152 %record(Precf)%name PP 1153 %record(Arraydvf)%name Dvrec 1154 %record(Srecf)%name SS 1155 %integer I,Link,N,Base 1156 Link=addr(BSSarrays) 1157 I=BSSarrays 1158 %while I#0 %cycle 1159 SS==record(Com_Adict+I) 1160 %if SS_Inf0=Ptr %or SS_Inf3=Ptr %thenstart 1161 integer(Link)=SS_Link1 1162 PP==record(Com_Adict+SS_Inf0) 1163 Dvrec==record(Com_Adict+PP_Addr4) 1164 PP_IIN=GST 1165 Base=Com_Gstca 1166 Dvrec_Adfirst=Base 1167 Dvrec_Addrzero=Dvrec_Adfirst-Dvrec_Addrzero 1168 N=((SS_Inf2+7)>>3)<<3 1169 Com_Gstca=Com_Gstca+N 1170 Set Array Head(Dvrec_Addrdv,GST,Dvrec_Adfirst, %c C Dvrec_Addrzero,PP_Type) 1172 %if SS_Inf3#0 %thenstart;! equivalenced array 1173 PP==record(Com_Adict+SS_Inf3) 1174 Dvrec==record(Com_Adict+PP_Addr4) 1175 PP_IIN=GST 1176 Dvrec_Adfirst=Base 1177 Dvrec_Addrzero=Dvrec_Adfirst-Dvrec_addrzero 1178 Set Array Head(Dvrec_addrdv,GST,Dvrec_Adfirst, %c C Dvrec_Addrzero,PP_Type) 1180 %finish 1181 %return 1182 %finish 1183 I=SS_Link1 1184 Link=addr(SS_Link1) 1185 %repeat 1186 %end;! BSSreloc 1187 !* 1188 %externalroutine BSStidy 1189 %record(Precf)%name PP 1190 %record(Arraydvf)%name Dvrec 1191 %record(Srecf)%name SS 1192 %integer I,Link,N,Base 1193 I=BSSarrays 1194 %while I#0 %cycle 1195 SS==record(Com_Adict+I) 1196 PP==record(Com_Adict+SS_Inf0) 1197 Dvrec==record(Com_Adict+PP_Addr4) 1198 PP_IIN=ZEROGST 1199 Base=Com_Zgstca 1200 Dvrec_Adfirst=Base 1201 Dvrec_Addrzero=Dvrec_Adfirst-Dvrec_Addrzero 1202 N=((SS_Inf2+7)>>3)<<3 1203 Com_Zgstca=Com_Zgstca+N 1204 Set Array Head(Dvrec_Addrdv,ZEROGST,Dvrec_Adfirst, %c C Dvrec_Addrzero,PP_Type) 1206 %if SS_Inf3#0 %thenstart;! equivalenced array 1207 PP==record(Com_Adict+SS_Inf3) 1208 Dvrec==record(Com_Adict+PP_Addr4) 1209 PP_IIN=ZEROGST 1210 Dvrec_Adfirst=Base 1211 Dvrec_Addrzero=Dvrec_Adfirst-Dvrec_addrzero 1212 Set Array Head(Dvrec_addrdv,ZEROGST,Dvrec_Adfirst, %c C Dvrec_Addrzero,PP_Type) 1214 %finish 1215 I=SS_Link1 1216 %repeat 1217 BSSarrays=0 1218 %end;! BSStidy 1219 !* 1220 %externalroutine Alloc(%integer PTR) 1221 !*********************************************************************** 1222 !* ON ENTRY PTR POINTS AT RECORD FOR AN IDENTIFIER FOR WHICH * 1223 !* STORAGE MUST BE ALLOCATED. THIS MAY REQUIRE ALLOCATION OF A COMPLETE* 1224 !* COMMON BLOCK, OR ALL ITEMS INVOLVED IN EQUIVALENCE CHAINS. * 1225 !*********************************************************************** 1226 !* 1227 %routinespec DV(%integer DVADDR,MODE) 1228 %integerfnspec Next Coord 1229 !* 1230 %record(ARRAYDVF) %name DVREC 1231 !* 1232 %integer I, T, IIN 1233 %integer J, K, L, M, N, P, Q, U, V, W, TEMP,CHAR,CMNBLKAD 1234 %integer SAVEPTR, DATAMODE, CMNIND, CCOORD 1235 %integer CLASS,SZTYPE,DR1 1236 %integer BOUND, BEND, ER 1237 %integer BSSinhib,BSScount 1238 %owninteger Curbit;! to carry across recursive call to Alloc equiv item 1239 %record(PRECF) %name PP 1240 %record(PRECF) %name QQ 1241 %record(SRECF) %name WW 1242 %record(SRECF) %name SS 1243 %record(Srecf) %name BSSrec 1244 %record(PRECF) %name CMNBLK 1245 %SWITCH SW(0 : 6) 1246 %SWITCH TW(8 : 14) 1247 !* 1248 PP == RECORD(COM_ADICT+PTR) 1249 I = PP_X1 1250 DATAMODE = I&2 1251 SAVEPTR = PTR 1252 CLASS = PP_CLASS&X'1F' 1253 SZTYPE=PP_TYPE 1254 %if I&1#0 %thenstart;! allocated (at least partially) 1255 %unless PP_CLASS&6=6 %then %RETURN;! unless COMMON array 1256 %if COM_SUBPROGTYPE=5 %then %RETURN;! blockdata 1257 DVREC==record(COM_ADICT+PP_ADDR4) 1258 %if DVREC_ADDRDV#0 %then %RETURN;! fully allocated 1259 DV(PP_ADDR4,2);! complete allocation 1260 SET ARRAY HEAD(DVREC_ADDRDV,PP_IIN,DVREC_ADFIRST, %c C Dvrec_Addrzero,Sztype) 1262 %RETURN 1263 %finish 1264 Curbit = 3 1265 L = PP_ADDR4 1266 N = NUMBYTES(SZTYPE>>4) 1267 %if SZTYPE=5 %then N=PP_LEN 1268 %if N>0 %then T=N-1;! NO OF BYTES IN ELEMENT-1 1269 %if SZTYPE&15 = 3 %then N=N+N;! complex 1270 -> SW(CLASS&3!(PP_X1&4)); ! EQUIV:COMMON:PARAM 1271 !* 1272 !*** LOCAL SCALARS OR ARRAYS 1273 SW(0):PP_X1=PP_X1!1; ! SET ALLOCATED BIT 1274 PP_Coord=Next Coord 1275 PP_Link2=Com_Scptr;! ADD TO DIAGS LIST 1276 Com_Scptr=Ptr 1277 %if Class&4 # 0 %thenstart; ! ARRAY 1278 Dv(PP_Addr4,0) 1279 Dvrec_Adfirst = Array Space(N,IIN,1) 1280 %if Target=Gould %and IIN=ZEROGST %thenstart 1281 SS==record(Com_Adict+Newlistcell(BSSarrays,4)) 1282 SS_Inf0=Ptr 1283 SS_Inf2=N 1284 SS_Inf3=0 1285 %finishelsestart 1286 Dvrec_Addrzero= Dvrec_Adfirst-Dvrec_Addrzero 1287 Set Array Head(Dvrec_Addrdv,IIN,Dvrec_Adfirst, %c C Dvrec_Addrzero,PP_Type) 1289 %finish 1290 %finishelsestart; ! SCALAR 1291 %if Sztype=5 %thenstart 1292 PP_Addr4=Alloc Char(N,0,IIN) 1293 %finishelsestart 1294 PP_Addr4 = Scalar Space(N,IIN) 1295 %finish 1296 %finish 1297 PP_IIN=IIN 1298 %if target=LATTICE %thenstart 1299 ICdatarec(addr(PP_Class),Com_Adict,Com_Anames) 1300 %finish 1301 %return 1302 !* 1303 !*** PARAM 1304 SW(1):PP_X1=PP_X1!1; ! SET ALLOCATED BIT 1305 %if PP_CLASS=9 %thenstart;! SUBPROG 1306 PP_Addr4=Scalar Space(8,IIN);! space for ref and length 1307 PP_IIN=IIN 1308 %return 1309 %finish 1310 PP_Link2=Com_Scptr;! FOR DIAGNOSTICS 1311 Com_Scptr=Ptr 1312 %if Class = 5 %thenstart; ! PARAMETER ARRAY 1313 DV(PP_Addr4,0); ! CONSTRUCT REST OF DOPE VECTOR 1314 PP_Coord=1;! bit for array and char params(i.e. ref values) 1315 Setbit(Com_Acmnbits,1) 1316 %finishelsestart; ! SCALAR 1317 I=Com_Checklist;! OF ITEMS WHICH SHOULD APPEAR AS PARAMS 1318 %while I#0 %cycle 1319 SS==record(Com_Adict+I) 1320 %if SS_Inf0=Ptr %then SS_Inf2=0;! ENTRY TO BE IGNORED 1321 I=SS_Link1 1322 %repeat 1323 !! %if PP_X0&1 # 0 %and Sztype#5 %thenstart;! 'VALUE' PARAM SCALAR 1324 !! PP_Coord=Next Coord;! same as local scalar 1325 !! %finishelsestart;! 'NAME' PARAM SCALAR - only char in F77 1326 PP_Coord=1 1327 Setbit(Com_Acmnbits,1) 1328 PP_X0=PP_X0&X'FE' 1329 %if PP_Type=CHARTYPE %then N=8 %else N=4 1330 !! %finish 1331 PP_Addr4=Scalar Space(N,IIN) 1332 PP_IIN=IIN 1333 %finish 1334 %if target=LATTICE %thenstart 1335 ICdatarec(addr(PP_Class),Com_Adict,Com_Anames) 1336 %finish 1337 %return 1338 !*** COMMON 1339 SW(2):Cmnblk == record(Com_Adict+PP_Link3<>4) 1363 %if Target=Gould %thenstart {leave gaps in common} 1364 %if N=2 %and M&1#0 %then M=M+1 1365 %if N=4 %and M&3#0 %then M=(M+3)&X'fffffc' 1366 %if N=8 %and M&7#0 %thenstart 1367 M=(M+7)&X'fffff8' 1368 Tfault(358,Com_Anames+Cmnblk_Iden,0) 1369 %finish 1370 %finish 1371 Char=Char!2 1372 %if PP_Type&15=3 %then N=N+N;! COMPLEX 1373 %if N>2 %then T=3 %else T=N-1 1374 ! NO. OF BYTES IN ELEMENT - 1 1375 ! (PER PART IF COMPLEX) 1376 %unless M = (M+T)&ROND(T) %or Er = 0 %thenstart 1377 ! UNLESS ALLIGNMENT O.K. OR FAULT ALREADY REPORTED 1378 ! LFAULT(ER) **** CANNOT HAPPEN UNTIL I*2 ALLOWED 1379 ER = 0 1380 %finish 1381 %finish 1382 PP_X1=PP_X1!1; ! SET ALLOCATED BIT 1383 %if PP_CLASS&4 # 0 %thenstart;! ARRAY 1384 SZTYPE=PP_TYPE 1385 %if PTR=SAVEPTR %OR COM_SUBPROGTYPE=1 %then I=0 %C C %else I=1 1387 ! full alloc if specifically referenced 1388 ! or in main program 1389 DV(PP_ADDR4,I); ! SET DOPE VECTOR(UNLESS BLOCK DATA) 1390 ! CALCULATE TOTAL ARRAY SIZE 1391 DVREC_ADFIRST=M 1392 Dvrec_Addrzero=M-Dvrec_Addrzero 1393 !* N.B. RELOCATION BY COMMON BASE AS FOR LOCAL ARRAYS 1394 %unless COM_SUBPROGTYPE=5 %OR I=1 %thenstart 1395 SET ARRAY HEAD(DVREC_ADDRDV,IIN,M,Dvrec_Addrzero,Sztype) 1396 %finish 1397 %finishelsestart 1398 PP_ADDR4=M;! bytes 1399 %finish 1400 M = M+N 1401 %finish 1402 PP_Coord=Curbit 1403 PP_Coord=Next Coord;! to be suppressed if in trouble 1404 Setbit(Com_Acmnbits,PP_Coord) 1405 %if target=LATTICE %thenstart 1406 ICdatarec(addr(PP_Class),Com_Adict,Com_Anames) 1407 %finish 1408 PTR = PP_LINK2; ! NEXT ITEM ON THE LIST 1409 %repeat 1410 %if CHAR=3 %thenstart 1411 TFAULT(183,COM_ANAMES+CMNBLK_IDEN,0) 1412 %finish 1413 CMNBLK_CMNLENGTH = M 1414 %if M>MAX AREA SIZE %thenstart 1415 TFAULT(317,COM_ANAMES+CMNBLK_IDEN,0) 1416 %finish 1417 %RETURN 1418 !*** ITEM IS ON AN EQUIVALENCE LIST 1419 SW(4): 1420 SW(6): 1421 W = N; ! ITEM LENGTH 1422 K = 0; ! FOR DISPLACEMENT 1423 T = 0 1424 M = 0; ! MAX VALUE OF N DISPL 1425 J = PTR; ! STARTING POINT 1426 P = PTR 1427 V = PP_LINK2; ! CORRESPONDING EQUIV CHAIN ENTRY 1428 CHAR=0 1429 SS == RECORD(COM_ADICT+V) 1430 !* 1431 !* STAGE 1 CHOOSE AN ELEMENT WHOSE @ WILL BE FIXED. COMMON ELSE 1432 !* ARRAY EL WITH GREATEST DISPLACEMENT ELSE ARRAYNAME ELSE 1433 !* SCALAR 1434 !* V POINTS TO LIST & P POINTS TO ELEMENT 1435 !* 1436 BSSinhib=0 1437 BSScount=0 1438 %cycle 1439 BSScount=BSScount+1 1440 PP==record(COM_ADICT+P) 1441 %if PP_TYPE=5 %thenstart 1442 BSSinhib=1 1443 N=PP_LEN 1444 CHAR=CHAR!1 1445 %finishelsestart 1446 N = NUMBYTES(PP_TYPE>>4) 1447 CHAR=CHAR!2 1448 ER=SS_INF3 1449 %finish 1450 U = SS_INF2; ! DISPL OF EQUIVALENCED ITEM FROM BASE 1451 %unless U=0 %then BSSinhib=1 1452 %if PP_X1&1 # 0 %thenstart; ! ALLOCATED 1453 K = U 1454 PTR = P; ! SET TO POINT AT ITEM TO BE USED AS ROOT 1455 T = 3; ! ALLOCATED (MAY BE COMMON ITEM IN CHAIN) 1456 BSSinhib=1 1457 %finishelsestart 1458 %if PP_Class&2#0 %thenstart;! item in common 1459 BSSinhib=1 1460 PP_X1=PP_X1&X'F3';! clear equiv flag 1461 Alloc(P) 1462 K=U 1463 Ptr=P 1464 T=3 1465 %finishelsestart 1466 %if PP_TYPE&15=3 %then N=N+N;! COMPLEX 1467 %if PP_CLASS&4 # 0 %thenstart;! ARRAY 1468 %unless K > U %OR T = 3 %thenstart 1469 ! WILL BE ROOT UNLESS ALLOCATED OR COMMON ITEM, OR 1470 ! ARRAY WITH BIGGER DISPLACEMENT IS FOUND 1471 K = U 1472 PTR = P 1473 %finish 1474 SZTYPE=PP_TYPE 1475 DV(PP_ADDR4,0); ! SET UP DOPE VECTOR, N TOTAL SIZE IN BYTES 1476 %finishelsestart 1477 BSSinhib=1 1478 %if PP_TYPE=5 %thenstart 1479 %unless K>=U %OR T=3 %thenstart 1480 K=U 1481 PTR=P 1482 %finish 1483 %finish 1484 %finish 1485 %if N-U > M %then M = N-U; ! MAX LENGTH REQUIRED BEYOND ALLIGNMENT POINT 1486 %finish 1487 %finish 1488 %if SS_link1=0 %then %exit;! previous error - avoid loop 1489 SS == RECORD(COM_ADICT+SS_LINK1); ! NEXT ITEM DESCRIPTOR IN EQUIV CHAIN 1490 P = SS_INF0 1491 %repeat %until P = J 1492 %unless BSScount=2 %then BSSinhib=1 1493 %if CHAR=3 %thenstart 1494 IFAULT(357,ER);! equivalence of char and non-char items 1495 %finish 1496 CHAR=CHAR&1 1497 PP == RECORD(COM_ADICT+PTR); ! ITEM WHOSE ADDRESS IS TO BE FIXED FIRST 1498 P = PP_ADDR4 1499 DVREC == RECORD(COM_ADICT+PP_ADDR4) 1500 !* 1501 !* STAGE 2 ALLOCATE @ OF THE CHOSEN ELEMENT 1502 !* 1503 %unless T > 0 %thenstart; ! NOT YET ALLOCATED 1504 PP_X1=(PP_X1&X'F0')!1; ! CLEAR EQUIV FLAGS & SET ALLOC BIT 1505 T=4;! indicate local rather than common 1506 %if BSSinhib=0 %then I=1 %else I=0 1507 Q=Array Space(M+K,IIN,I) 1508 %if IIN=ZEROGST %thenstart 1509 BSSrec==record(Com_Adict+Newlistcell(BSSarrays,4)) 1510 BSSrec_Inf0=Ptr 1511 BSSrec_Inf2=M 1512 BSSrec_Inf3=0 1513 %finishelsestart 1514 BSSinhib=1 1515 %if PP_CLASS&4#0 %thenstart 1516 DVREC==record(COM_ADICT+PP_ADDR4) 1517 DVREC_ADFIRST=Q 1518 Dvrec_Addrzero=Q-Dvrec_Addrzero 1519 SET ARRAY HEAD(DVREC_ADDRDV,IIN,Q,Dvrec_Addrzero,PP_Type) 1520 %finishelsestart 1521 PP_ADDR4=Q 1522 %finish 1523 %finish 1524 PP_IIN=IIN 1525 PP_Link2=Com_Scptr 1526 Com_Scptr=Ptr 1527 %finishelsestart; ! COMMON ELEMENT (ALREADY ALLOCATED) 1528 T=3;! indicates common later 1529 %if PP_CLASS&4=0 %thenstart;! NOT AN ARRAY 1530 P=PTR 1531 Q=PP_ADDR4 1532 %finishELSE Q=DVREC_ADFIRST 1533 CMNBLKAD=PP_Link3 1534 CMNBLK==record(COM_ADICT+CMNBLKAD<CMNBLK_CMNLENGTH %then CMNBLK_CMNLENGTH=M+K+Q 1536 IIN=CMNBLK_IIN 1537 !* set all items in this block to the same coord pro tem 1538 QQ==RECORD(COM_ADICT+CMNBLK_LINK2) 1539 CCOORD=QQ_COORD 1540 %WHILE QQ_LINK2#0 %CYCLE 1541 QQ==RECORD(COM_ADICT+QQ_LINK2) 1542 QQ_COORD=CCOORD 1543 %IF COM_OPT&1#0 %THEN QQ_X1=QQ_X1!X'80';! to ensure always BOEX 1544 %REPEAT 1545 CURBIT=CCOORD 1546 %finish 1547 !*********** STAGE 3 1548 BOUND = K+Q; ! DISPL. OF EQUIVALENCING POINT FROM START OF FIRST ITEM 1549 ! +DISPL. OF FIRST ITEM FROM AREA BASE 1550 ! W = V; ! POINTS TO FIRST ITEM IN LIST 1551 ! %cycle 1552 ! WW == RECORD(COM_ADICT+W) 1553 ! QQ == RECORD(COM_ADICT+WW_INF0) 1554 ! %unless QQ_TYPE=5 %thenstart 1555 ! L = NUMBYTES(QQ_TYPE>>4)-1 1556 ! %if L>3 %then L=3 1557 ! Q = WW_INF2; ! DISPLACEMENT 1558 ! %if BOUND-Q # (BOUND-Q+L)&ROND(L) %thenstart 1559 ! ! WRONG ALLIGNMENT 1560 !ALLIGNERROR: FAULT(304) 1561 ! %EXIT 1562 ! %finish 1563 ! %finish 1564 ! W = WW_LINK1 1565 ! %repeat %until W = V ;! I.E. COMPLETE LIST PROCESSED 1566 !* 1567 K = V; ! POINTER TO LIST 1568 SS == RECORD(COM_ADICT+K) 1569 PTR = J 1570 %cycle 1571 PP == RECORD(COM_ADICT+PTR) 1572 PP_Coord=Curbit 1573 %if PP_X1&1 = 0 %thenstart; ! NOT USED/ALLOCATED 1574 PP_X1=PP_X1!DATAMODE!1; ! SET DATA IF NEC. AND ALLOCATED BIT 1575 M = BOUND-SS_INF2; ! START OF THIS ITEM RELATIVE TO THE BASE 1576 %if PP_TYPE=5 %AND T=2 %thenstart;! local char scalars 1577 %if PP_LINK2=0 %thenstart 1578 PP_LINK2=COM_SCPTR 1579 COM_SCPTR=PTR 1580 %finish 1581 PP_ADDR4=M;! bytes 1582 ->MEET3 1583 %finish 1584 W = T; ! FIXED ITEM IS: 2 SCALAR 3 COMMON 4 ARRAY 1585 -> TW(T+6+PP_CLASS&4); ! 8 SCALAR:SCALAR 12 SCALAR:ARRAY 1586 ! 9 COMMON:SCALAR 13 COMMON:ARRAY 1587 !10 ARRAY :SCALAR 14 ARRAY :ARRAY 1588 TW(13): ! ARRAY EQUIV COMMON 1589 W = 4; ! TO INDICATE THAT ADDRESS IS TO GO IN DOPE VECTOR 1590 TW(9): !SCALAR EQUIV COMMON 1591 %if M < 0 %then FAULT(268);! ATTEMPT TO EXTEND BACKWARDS 1592 PP_LINK2=CMNBLK_LINK2 1593 CMNBLK_LINK2=PTR 1594 PP_Link3 = CMNBLKAD; ! ADDRESS OF COMMON BLOCK RECORD 1595 PP_X0=PP_X0!4 1596 PP_CLASS=PP_CLASS!2; ! COMMON MARKER ?? 1597 -> MEET2 1598 TW(8): ! SCALAR EQUIV SCALAR 1599 TW(10): ! SCALAR EQUIV ARRAY 1600 PP_LINK2 = COM_SCPTR; ! LINK TO SCALAR LIST FOR DIAGNOSTICS 1601 COM_SCPTR = PTR 1602 PP_ADDR4=M;! bytes 1603 -> MEET3 1604 TW(14): ! ARRAY EQUIV ARRAY 1605 PP_LINK2=COM_SCPTR 1606 COM_SCPTR=PTR 1607 MEET2: %if W = 3 %thenstart; ! COMMON OR SCALAR IN ARRAY AREA 1608 PP_ADDR4=M;! bytes 1609 %finishelsestart; ! ARRAY 1610 %if BSSinhib=0 %thenstart 1611 BSSrec_Inf3=Ptr 1612 %finishelsestart 1613 DVREC == RECORD(COM_ADICT+PP_ADDR4) 1614 !* N.B RELOCATE ARRAY BASE BY START OF AREA 1615 DVREC_ADFIRST = M 1616 Dvrec_Addrzero=M-Dvrec_Addrzero 1617 %if COM_SUBPROGTYPE#5 %thenstart;! EXCEPT BLOCKDATA 1618 SET ARRAY HEAD(DVREC_ADDRDV,IIN,M,Dvrec_Addrzero,PP_Type) 1619 %finish 1620 %finish 1621 %finish 1622 %finish 1623 MEET3: PTR = K 1624 PP_IIN=IIN 1625 K = SS_LINK1; ! TO POINT AT NEXT ITEM DESCRIPTOR 1626 !! SS_LINK1=ASL(3) 1627 !! ASL(3)=PTR ! temporarily conceeding this list space 1628 %if K=0 %then %exit;! previous error 1629 SS == RECORD(COM_ADICT+K) 1630 PTR = SS_INF0 1631 %if target=LATTICE %thenstart 1632 ICdatarec(addr(PP_Class),Com_Adict,Com_Anames) 1633 %finish 1634 %repeat %until PTR = J 1635 %RETURN 1636 !* 1637 %INTEGERFN NEXT COORD 1638 %IF COM_NEXTBIT<512 %THENSTART 1639 CURBIT=COM_NEXTBIT 1640 COM_NEXTBIT=CURBIT+1 1641 %FINISH 1642 %RESULT=CURBIT 1643 %END;! NEXT COORD 1644 !* 1645 %routine Dv(%integer Dvaddr,Mode) 1646 !* generate dope vector for array 1647 !* Mode = 0 normal allocation 1648 !* 1 partial allocation (no dvarea descriptors) 1649 !* 2 finalise allocation (set dvarea descriptors) 1650 %integer I,J,K,L,D,Dvbase 1651 Dvrec ==record(Com_Adict+Dvaddr) 1652 %if Mode<2 %thenstart 1653 Dvrec_Ellength = N 1654 Dvrec_Addrzero=Dvrec_Zerotofirst*Dvrec_Ellength 1655 %finish 1656 Dvrec_Addrdv=0;! in case only partial init 1657 %if Com_Subprogtype # 5 %and Mode#1 %thenstart 1658 %if DVAREA=GLA %then K=Com_Glaca %else K=Com_Scalarca 1659 Dvbase=K 1660 %if Class=5 %thenstart;! param - reserve hole for zerotofirst 1661 Ed4(DVAREA,K,Dvrec_Zerotofirst) 1662 K=K+4 1663 %finish 1664 %if Sztype=CHARTYPE %thenstart 1665 %if PP_Len=0 %then K=K+4;! reserve space for actual arg len 1666 I=Dvrec_Numels*PP_Len 1667 %finishelsestart 1668 I=Dvrec_Numels 1669 %finish 1670 K=K+4 1671 Dvrec_Addrdv=K 1672 K=K+8 1673 Ed4(DVAREA,K-4,I);! numels or numchars(for char arrays) 1674 %if PP_Class&X'C0'#0 %and Dvrec_Dims>1 %thenstart;! > 1 adj dim 1675 %cycle I=2,1,Dvrec_Dims 1676 Ed4(DVAREA,K,Dvrec_B(I)_M) 1677 K=K+4 1678 %repeat 1679 %finish 1680 J=Dv Space(K-Dvbase,I) 1681 %finish 1682 %if Mode<2 %thenstart;! first time for this array 1683 N = Dvrec_Numels*N 1684 %finish 1685 %end; ! Dv 1686 !* 1687 !* 1688 %end; ! ALLOC 1689 !* 1690 %externalintegerfn New Subprogram(%integer Ptr,P1,Ctyp,%integername Er) 1691 !*********************************************************************** 1692 !* FOLLOWS PROGRAM, SUBROUTINE, FUNCTION, ENTRY OR BLOCKDATA * 1693 !*********************************************************************** 1694 !* 1695 %conststring(12)%array Prg(0:5)= %C C "main program", C "program ", C "function ", C "subroutine ", C " entry ", C "blockdata " 1702 !* 1703 %integer I,J 1704 !* 1705 %record(Precf) %name PP 1706 %record(Precf) %name QQ 1707 PP==record(Com_Adict+Ptr) 1708 %if P1 = 4 %thenstart; ! entry 1709 Com_Entries=Com_Entries+1 1710 Er = 100; ! SYNTAX 1711 %result = 4 %unless 2 <= Com_Subprogtype <= 3 1712 ! UNLESS FUNCTION OR SUBROUTINE 1713 Er = 141; ! INVALID ENTRY name 1714 %result=4 %unless Ctyp<0 %or PP_X1&1=0;! MUST BE A 'NEW' OR UNUSED IDENTIFIER 1715 %result=4 %if PP_Class#0 1716 Er=235 1717 %result=4 %unless Com_Doptr=0 %and Com_Ifptr=0;! NOT VALID INSIDE A DO LOOP OR IF BLOCK 1718 PP_Coord=2;! standard value for fn result 1719 I = Com_Subprogptr 1720 QQ==record(Com_Adict+I) 1721 J=QQ_Type 1722 %if Com_Subprogtype=2 %thenstart;! function 1723 %if PP_Type=5 %thenstart 1724 %unless J=5 %then Er=197 %and %result=4;! entry is char,fn is not 1725 %finishelsestart 1726 %if J=5 %then Er=198 %and %result=4;! fn is char,entry is not 1727 %finish 1728 %finish 1729 %while I>0 %cycle; ! THROUGH ENTRY POINT LIST 1730 QQ == record(Com_Adict+I) 1731 I = QQ_Link3<>DSCALE 1734 %finishelsestart 1735 %if P1<=1 %thenstart 1736 Com_Subprogtype=1 1737 %if Mainprog#0 %then Lfault(316);! multiple main prog 1738 Mainprog=1 1739 %finishelse Com_Subprogtype=P1 1740 %if Com_Opt&2#0 %then I=Op4 Ref(string(Com_Anames+PP_Iden)) 1741 Com_Subprogptr=Ptr 1742 Com_Funresdisp=0;! NO RESULT SPACE YET ASSIGNED FOR FUNCTION 1743 Com_Pastart=Com_Linest 1744 %finish 1745 %if Com_Subprogtype=2 %then PP_Coord=2;! function 1746 %if P1<=4 %and Com_Noisy#0 %thenstart 1747 selectoutput(Com_Console) 1748 spaces(3) 1749 printstring(Prg(P1)) 1750 {%if P1<=1 %then printstring("MAIN ")} 1751 %if P1>0 %thenstart 1752 printstring(string(Anames+PP_Iden)) 1753 %finish 1754 newline 1755 %if Com_Liststream>=0 %then selectoutput(Com_Liststream) 1756 %finish 1757 %if P1#5 %thenstart 1758 Lastsubprogep = Ptr; ! LOCATE THE 'LATEST' SUBPROG ENTRY 1759 Paramlink = addr(PP_Link2); ! PARAM CHAIN LINK 1760 PP_Class = 11 1761 Com_Rescom1=Ptr;! will identify record for definition of plabel 1762 %finish 1763 %if P1=0 %then P1=1;! unnamed main program 1764 %if P1<5 %then PP_X1=PP_X1!((P1-1)<<4) 1765 %if Com_Opt&2#0 %thenstart 1766 %if P1<4 %then Com_Procindex=Com_Procindex+1 1767 %if Com_Procindex=1 %or P1=4 %then Com_Inhibop4=1;! first or entries 1768 %finish 1769 %result = 1 1770 %end;! New Subprogram 1771 !* 1772 %externalintegerfn Formal Parameter(%integer Ptr,Mode,Ctyp) 1773 !*********************************************************************** 1774 !* PROCESS FORMAL PARAMETER * 1775 !* MODE = 0 'value' TYPE * 1776 !* 1 'name' TYPE, I.E. / / * 1777 !*********************************************************************** 1778 !* 1779 %integer I,Er 1780 %record(Precf) %name PP 1781 %record(Srecf) %name SS 1782 PP==record(Com_Adict+Ptr) 1783 Er = 129; ! INVALID ARGUMENT 1784 %if Ctyp >= 0 %thenstart; ! NOT FIRST OCCURENCE OF THIS IDEN 1785 %if PP_Class&2#0 %or PP_Class&X'1F'>9 %C C %or PP_X1&X'80'#0 %thenstart ;! in common or namelist or equiv etc. 1787 Err: string(Com_Adident)=string(Anames+PP_Iden) 1788 %result=4 1789 %finish 1790 %if PP_Class&1=0 %and PP_X1&1#0 %then %result=4;! param on entry already referenced 1791 %unless PP_X1&1#0 %then PP_Class=PP_Class!1;! MARK AS PARAM UNLESS ALLOC. 1792 %if PP_Class&X'60'=X'60' %then PP_Class=PP_Class&X'DF';! clear 'not known as param' bit 1793 PP_X0=PP_X0!1 %unless PP_Type=5 %AND PP_Class&4=0;! except for char scalars 1794 %finishelsestart; ! 'NEW' IDENTIFIER 1795 PP_X0 = 1; ! 'VALUE' PARAM 1796 PP_Class=1 1797 %finish 1798 I=Freesp(2) 1799 SS==record(Com_Adict+I) 1800 SS_Inf0 = Ptr 1801 integer(Paramlink) = I; ! PARAMLINK LOCATES PREVIOUS LINK POSITION 1802 Paramlink = addr(SS_Link1) 1803 Com_Argcnt=Com_Argcnt+1;! for Op4 1804 %result = 1 1805 %end;! Formal Parameter 1806 !* 1807 %externalintegerfn Genfmt(%byteintegerarrayname Input,Type, C %string(*)%name Identifier) 1809 %integer ER,I,J,Ptr,Tablen,Fmtlen,Ad,Len 1810 %record(LABRECF)%name LABREC 1811 I=SETLAB(COM_LAB,PTR);! 1 NEW 0 ALREADY EXISTS 1812 LABREC==record(ADICT+PTR) 1813 COM_PI21INT=COM_LAB;! IN CASE OF FAULT 77 1814 COM_LAB = 0 1815 %unless LABREC_ADDR4 = 0 %thenstart 1816 COM_PI21INT=LABREC_LINE 1817 %result = 227;! LABEL SET TWICE 1818 %finish 1819 COM_LABWARN = 0 1820 ER=0 1821 Labrec==record(Com_Adict+Ptr) 1822 %if Com_Ioareaca=0 %then Com_Ioareaca=4 1823 Labrec_Addr4=Com_Ioareaca 1824 Labrec_Line=Com_Linest 1825 %if I = 0 %thenstart;! ALREADY REFERENCED 1826 ER = 302;! AS A STATEMENT LABEL 1827 %if LABREC_X0=16 %thenstart;! ASSIGNed 1828 LABREC_X0=8;! mark as definitely format 1829 %finishelsestart 1830 %result=ER %if LABREC_X0#8 1831 %finish 1832 %finishelsestart 1833 LABREC_X0=8 1834 %finish 1835 I = COM_INP 1836 L870: %unless TYPE(I)=12 %AND INPUT(I)=10 %then I=I+1 %AND ->L870 1837 %unless TYPE(I)=12 %then I=I+1 %AND ->L870 1838 Len=I-COM_INP 1839 LABREC_LINK3=Len 1840 Ad=Com_Adict+Com_Dptr;! workspace 1841 Er=Formatcd(addr(Input(0)),Com_Inp,Ad,Len,Len*4,0,0,Tablen,Fmtlen) 1842 %if Er=0 %thenstart 1843 Tablen=(Tablen+3)&X'FFFC' 1844 Edbytes(IOAREA,Com_Ioareaca,Tablen,Ad) 1845 Com_Ioareaca=Com_Ioareaca+Tablen 1846 %finishelsestart 1847 %if FMTLEN>32 %then FMTLEN=32 1848 %cycle J=1,1,FMTLEN 1849 INPUT(J)=INPUT(TABLEN+J-1) 1850 %repeat 1851 INPUT(0)=FMTLEN;! this fiddle is to ensure word allignment 1852 IDENTIFIER=string(addr(Input(0))) 1853 %finish 1854 COM_INP=I 1855 %result=ER 1856 %end;! GEN FMT 1857 !* 1858 !*********************************************************************** 1859 !* ROUTINES TO DUMP DICTIONARY RECORDS * 1860 !*********************************************************************** 1861 !* 1862 %ROUTINE PRHEX(%INTEGER J) 1863 %INTEGER K 1864 %CYCLE K = 28,-4,0 1865 PRINT SYMBOL(HEX((J>>K)&15)) 1866 %REPEAT 1867 %END 1868 !* 1869 %ROUTINE PH(%INTEGER I) 1870 %INTEGER J,K,L 1871 prhex(integer(i)) 1872 spaces(2) 1873 %return 1874 %END 1875 !* 1876 %ROUTINE DICREC(%INTEGER A,ID) 1877 %RECORD(PRECF)%NAME PP 1878 %INTEGER I 1879 I = ADICT+A 1880 PP==RECORD(I) 1881 PRHEX(A) 1882 SPACES(6) 1883 PH(I) 1884 PH(I+W1) 1885 SPACES(2) 1886 PH(I+W2) 1887 PH(I+3*W1) 1888 SPACES(2) 1889 NEWLINE 1890 WRITE(A,7) 1891 SPACES(6) 1892 PH(I+W4) 1893 PH(I+5*W1) 1894 SPACES(2) 1895 PH(I+6*W1) 1896 PH(I+7*W1) 1897 SPACES(2) 1898 %IF ID#0 %THENSTART 1899 WRITE(PP_COORD,2) 1900 SPACES(2) 1901 PRINTSTRING(STRING(ANAMES+PP_IDEN)) 1902 %FINISH 1903 NEWLINES(2) 1904 %END 1905 !* 1906 %ROUTINE DICRECLIST(%INTEGER HEAD,ID) 1907 %RECORD(PRECF) %NAME P 1908 %WHILE HEAD # 0 %CYCLE 1909 P == RECORD(ADICT+HEAD) 1910 DICREC(HEAD,ID) 1911 %IF ID#0 %AND P_CLASS&X'C'=4 %THEN DICREC(P_ADDR4,0);! ARRAY DV 1912 %IF P_CLASS=12 %THEN DICREC(HEAD+32,0);! common block 1913 HEAD = P_LINK1 1914 %REPEAT 1915 %END; ! DICRECLIST 1916 !* 1917 %externalroutine Dumpdict(%integer Mode) 1918 %INTEGER I, J 1919 NEWLINE 1920 PRINTSTRING("IDEN LISTS:") 1921 NEWLINE 1922 %CYCLE I = 0,1,154 1923 J = INTEGER(COM_ADLHEAD+I<<2{BSCALE}) 1924 %IF J # 0 %THENSTART 1925 WRITE(I,1); NEWLINE 1926 DICRECLIST(J,1) 1927 %FINISH 1928 %REPEAT 1929 PRINTSTRING("LABEL LISTS:") 1930 NEWLINE 1931 %CYCLE I = 0,1,31 1932 J = INTEGER(COM_ALABH+I<<2{BSCALE}) 1933 %IF J # 0 %THENSTART 1934 WRITE(I,1) 1935 NEWLINE 1936 DICRECLIST(J,0) 1937 %FINISH 1938 %REPEAT 1939 %if Mode=0 %then %return 1940 printstring(" 1941" Full Dict: 1942" ") 1943 I=0 1944 J=0 1945 %while I SEARCH 984 %finish 985 !* 986 !******** NEW ENTRY SO CONSOLIDATE DICT ENTRY 987 !* 988 %if Target=LATTICE %thenstart 989 J=Com_Namesfree 990 %if J&2#0 %then J=J+2 991 integer(Com_Anames+J)=0 992 Com_Namesfree=J+4 993 %finish 994 J=IDRECSIZE 995 %if Com_Xref#0 %then J=J+XREFSIZE 996 Ptr = Dictspace(J) 997 PP == record(Com_Adict+PTR) 998 %if Com_Namesfree+32 > Com_Nameslen %then NAMESFUL 999 J=Com_Namesfree 1000 %if HOST=PERQPNX %or HOST=ACCENT %thenstart 1001 J=J>>1;! strings based on word addressing 1002 %finish 1003 STRING(Com_Anames+J) = IDENTIFIER 1004 PP_IDEN=J 1005 PP_COORD=0 1006 PP_IIN=0 1007 Com_Namesfree = Com_Namesfree + (LENGTH(IDENTIFIER) + 2)&X'FFFE' 1008 %if Com_Xref#0 %thenstart 1009 PP_LINE=Com_Linest;! line no of start of statement 1010 PP_XREF=0;! XREF chain 1011 %finish 1012 %if TTYP&X'F'=5 %thenstart;! CHARACTER 1013 PP_LEN=TTYP>>8 1014 TTYP=5 1015 %finish 1016 PP_TYPE=TTYP 1017 PP_LINK1 = LHEAD(HASHVALUE) 1018 LHEAD(HASHVALUE) = PTR 1019 CTYP = -1; ! TYPE NOT ABSOLUTELY DETERMINED 1020 %if Com_Warnlength#0 %thenstart 1021 %if LENGTH(IDENTIFIER)>6 %thenstart 1022 ERRIDEN=IDENTIFIER 1023 LENGTH(ERRIDEN)=4 1024 LFAULT(201);! iden too long 1025 %finish 1026 %finish 1027 Com_Idcnt=Com_Idcnt+1;! for Op4 1028 %result=PTR 1029 %end; ! FINDA 1030 !* 1031 %routine SETNAME 1032 !*********************************************************************** 1033 !* EXTRACT IDEN FROM INPUT RECORD AND SET IN IDENTIFIER * 1034 !*********************************************************************** 1035 %integer I,J 1036 %OWNBYTEINTEGERARRAY A(0 : 32) 1037 HASHVALUE = 0 1038 WARNLEN = 0 1039 I = 1 1040 %while 1 <= TYPE(Com_Inp) <= 3 %cycle; ! A - Z, 0 - 9 1041 %if I <= 31 %thenstart 1042 J = INPUT(Com_Inp) 1043 A(I) = J 1044 J=J&31 1045 HASHVALUE = HASHVALUE+J 1046 %finishelsestart 1047 I=I-1 1048 %finish 1049 I = I+1 1050 Com_Inp = Com_Inp+1 1051 %repeat 1052 A(0) = I-1 1053 IDENTIFIER = STRING(ADDR(A(0))) 1054 %if I=2 %thenstart 1055 HASHVALUE=J+127 1056 %finishelsestart 1057 HASHVALUE = (HASHVALUE-J+J<<3)&127 1058 %finish 1059 %end; ! SETNAME 1060 !* 1061 %INTEGERFN LOCATE NAME(%STRING(*)%NAME NAME) 1062 !*********************************************************************** 1063 !* LOCATE DICTIONARY ENTRY FOR NAME. USE EXISTING ENTRY IF IT EXISTS * 1064 !* OTHERWISE CREATE A NEW ONE * 1065 !*********************************************************************** 1066 %integer I,J,K,PTR 1067 %OWNBYTEINTEGERARRAY A(0 : 32) 1068 HASHVALUE = 0; ! FOR HASH VALUE 1069 STRING(ADDR(A(0))) = NAME 1070 K=A(0);! to avoid pnximp bug 1071 %cycle I = 1,1,K 1072 J=A(I)&31 1073 HASHVALUE = HASHVALUE+J 1074 %repeat 1075 IDENTIFIER = NAME 1076 HASHVALUE = (HASHVALUE-J+J<<3)&127 1077 PTR = LHEAD(HASHVALUE) 1078 WARNLEN = 0 1079 %result=FINDA(PTR) 1080 %end; ! LOCATE NAME 1081 !* 1082 %routine Check Do Index(%integer Rd,Dohead) 1083 %record(Resf) Res 1084 %record(Dorecf) %name Dorec 1085 Res_W=Rd 1086 %unless LSCALID<=Res_Form<=PSCALID %thenstart 1087 Com_Inp=Com_Inp-2 1088 Fault(137) 1089 Com_Inp=Com_Inp+2 1090 %return 1091 %finish 1092 %while Dohead#0 %cycle 1093 Dorec==record(Com_Adict+Dohead) 1094 %if Dorec_Indexrd_W=Rd %thenstart;! NESTED USE OF DO VAR 1095 Lfault(147) 1096 %return 1097 %finish 1098 Dohead=Dorec_Link1 1099 %repeat 1100 %end;! Check Do Index 1101 !* 1102 %routine CHECK SAVELIST 1103 !*********************************************************************** 1104 !* Check that all items in SAVE lists are valid * 1105 !*********************************************************************** 1106 %integer I,J,ER 1107 %record(SRECF) %name SS 1108 %record(PRECF) %name PP 1109 I=SAVELIST 1110 %while I#0 %cycle 1111 SS==record(Com_Adict+I) 1112 PP==record(Com_Adict+SS_INF0) 1113 IDENTIFIER=STRING(Com_Anames+PP_IDEN) 1114 J=PP_CLASS&X'1F' 1115 %if SS_INF3=1 %thenstart;! common 1116 %unless J=12 %thenstart 1117 ER=188;! not a common block 1118 ERROR: IFAULT(ER,SS_INF2) 1119 %finish 1120 %finishelsestart 1121 %if J&1#0 %then ER=184 %and ->ERROR;! argument 1122 %if J&2#0 %then ER=186 %and ->ERROR;! in common 1123 %if J&8#0 %thenstart 1124 %if J=12 %then ER=187 %else ER=185;! is a common block else procedure 1125 ->ERROR 1126 %finish 1127 %finish 1128 I=SS_LINK1 1129 %repeat 1130 %end;! CHECK SAVELIST 1131 !* 1132 %routine CHECK ASSLIST 1133 %record(PRECF)%name ARR 1134 %record(SRECF)%name SS 1135 %integer I 1136 I=ASS CHECKLIST 1137 %while I#0 %cycle 1138 SS==record(Com_Adict+I) 1139 ARR==record(Com_Adict+SS_INF0) 1140 %if (ARR_CLASS&1=0 %or ARR_CLASS=8) %C C %and ARR_CLASS#16 %thenstart;! not a dummy argument or 'this' fn or const 1142 %unless ARR_TYPE=CHARTYPE %and ARR_LEN#0 %thenstart 1143 IDENTIFIER=STRING(Com_Anames+ARR_IDEN) 1144 LFAULT(189);! assumed size invalid unless dummy argument 1145 %finish 1146 %finish 1147 I=SS_LINK1 1148 %repeat 1149 Ass Checklist=0 1150 %end;! CHECK ASSLIST 1151 !* 1152 %routine ADD TO ASSLIST(%integer REC) 1153 %record(SRECF)%name SS 1154 %integer PTR 1155 PTR=NEW LIST CELL(ASS CHECKLIST,2) 1156 SS==record(Com_Adict+PTR) 1157 SS_INF0=REC 1158 %end;! ADD TO ASSLIST 1159 !* 1160 !* 1161 %integerfn Boundval(%integer Bound) 1162 %record(Resf) R 1163 R_W=Bound 1164 %if R_Form=0 %thenstart 1165 %result=R_H0 1166 %finishelsestart 1167 %result=integer(Com_Adict+R_H0<=Com_Maxanal %thenstart 1263 ! %if ANALFUL#0 %thenstart 1264 ! ER=307 1265 ! %result=1 1266 ! %finish 1267 ! %finish 1268 ! SAVEF==record(Com_Saveanal+I) 1269 ! SAVEF_II=II 1270 ! SAVEF_IJ=IJ 1271 ! SAVEF_SL=SAVELINK 1272 ! SAVEF_PATH=PATH 1273 ! SAVEF_ROUT=ROUT 1274 ! SAVEF_PARAM=PARAM 1275 ! %result=0 1276 !%end;! SAVE 1277 !* 1278 !%routine RESTORE 1279 !%record (SAVEFMT) %name SAVE 1280 !%integer I 1281 ! %if HOST=PERQPNX %or HOST=ACCENT %thenstart 1282 ! Saveindex=Saveindex-12 1283 ! %finishelsestart 1284 ! Saveindex=Saveindex-24 1285 ! %finish 1286 ! I=SAVEINDEX 1287 ! %if I<0 %then %MONITOR %and %STOP 1288 ! SAVE==record(Com_Saveanal+I) 1289 ! II=SAVE_II 1290 ! IJ=SAVE_IJ 1291 ! SAVELINK=SAVE_SL 1292 ! PATH=SAVE_PATH 1293 ! ROUT=SAVE_ROUT 1294 ! PARAM=SAVE_PARAM 1295 !!printstring("Restore") 1296 !!write(saveindex,4) 1297 !!write(II,4) 1298 !!write(ij,4) 1299 !!write(savelink,4) 1300 !!write(path,4) 1301 !!write(rout,4) 1302 !!write(param,4) 1303 !!newline 1304 !%end;! RESTORE 1305 !* 1306 {end "pf_anal0"} 1307 !* 1308 AINPUT=ADDR(INPUT(0)) 1309 LMAXOUTPUT=Com_Maxoutput;! for faster local access 1310 GSTATE=1 1311 DOIO=0 1312 FNMK=0 1313 Statfnrec=0 1314 INCLUDESTAT=0 1315 HGOLAB=0 1316 DOIOP=0 1317 IMPDOHEAD=0 1318 CEXMODE=0 1319 LL1=0 1320 Com_Curstatclass=0 1321 REPORTED ERROR=0 1322 Com_Statement=0;! WILL NOTE CURRENT STATEMENT TYPE IF NEED TO KNOW 1323 ICOMP=SUB(2+LTYPE) 1324 II=0 1325 IJ=0 1326 ROUT=0 1327 PARAM=0 1328 PATH = 0 1329 SAVELINK=0 1330 OUTP=1 1331 SAVEINDEX=0 1332 PTR=0 1333 !* 1334 {%include "pf_anal1"} 1335 !* 1336 ! I=Save 1337 ! 1338 *MVC_0(24,11),SAVELINK 1339 *LA_11,24(11) 1340 ! 1341 !* 1342 {end "pf_anal1"} 1343 !* 1344 SAVELINK=1 1345 ->L4 1346 ! META-VARIABLE 1347 PI(1):II = ICOMP 1348 ICOMP = SUB(P1) 1349 PATH = 1 1350 IJ = Com_Inp 1351 L7: 1352 !* 1353 {%include "pf_anal2"} 1354 !* 1355 ! %if SAVE#0 %then ->EXIT4 1356 ! 1357 *MVC_0(24,11),SAVELINK 1358 *LA_11,24(11) 1359 ! 1360 ROUT = PATH 1361 !* 1362 {end "pf_anal2"} 1363 !* 1364 L4: 1365 PIEXIT(1): 1366 EXIT1: 1367 %if HOST=PERQPNX %or HOST=ICL2900 %thenstart 1368 P=halfinteger(Com_Acomp+Icomp>>BSCALE) 1369 %finishelsestart 1370 P=shortinteger(Com_Acomp+Icomp>>BSCALE) 1371 %finish 1372 P1 = P&255 1373 P = (P>>8)&255 1374 ICOMP = ICOMP+2 1375 ! ->PI(P) 1376 %if Com_Ptrace#0 %thenstart 1377 STRACE 1378 %finish 1379 -> PI(P) 1380 ! SINGLE CHARACTER 1381 PI(2): -> L2 %if P1 # Com_Nextch 1382 L11: Com_Inp = Com_Inp+1 1383 L10: ICOMP = ICOMP+2 1384 Com_Nextch = INPUT(Com_Inp) 1385 -> L4 1386 ! SINGLE (OBLIGATORY) CHARACTER 1387 PI(3):%if P1#Com_Nextch %then ->SYNERR 1388 ->L11 1389 ! STRING 1390 PI(4):I = SHEADS(P1) 1391 %unless Com_Nextch=SSTRING(I+1) %then ->L2 1392 J = SSTRING(I) 1393 %cycle K = 1,1,J-1 1394 -> L2 %if INPUT(Com_Inp+K) # SSTRING(I+K+1) 1395 %repeat 1396 Com_Inp = Com_Inp+J 1397 -> L10 1398 ! OBLIGATORY STRING 1399 PI(5):I = SHEADS(P1) 1400 %unless Com_Nextch=SSTRING(I+1) %then ->Synerr 1401 J = SSTRING(I) 1402 %cycle K = 1,1,J-1 1403 -> Synerr %if INPUT(Com_Inp+K) # SSTRING(I+K+1) 1404 %repeat 1405 Com_Inp = Com_Inp+J 1406 -> L10 1407 ! @ SYMBOL 1408 PI(6):PARAM = RES_W 1409 II = ICOMP 1410 ICOMP = ICOMP+2 1411 IJ = Com_Inp 1412 PATH = 2 1413 -> L7 1414 ! SINGLE (OPTIONAL) CHARACTER 1415 PI(7):%if P1=Com_Nextch %thenstart 1416 Com_Inp=Com_Inp+1 1417 Com_Nextch=INPUT(Com_Inp) 1418 %finish 1419 ICOMP=ICOMP+2 1420 ->L4 1421 ! 1422 PI(9): 1423 %if HOST=PERQPNX %or HOST=ICL2900 %thenstart 1424 Icomp=halfinteger(Com_Acomp+Icomp>>BSCALE) 1425 %finishelsestart 1426 Icomp=shortinteger(Com_Acomp+Icomp>>BSCALE) 1427 %finish 1428 ->L4 1429 ! 1430 PIZERO: ! END OF DEFINITION 1431 PI(0): -> L1 %if ROUT = 1 1432 !* 1433 %if HOST=PERQPNX %or HOST=ICL2900 %thenstart 1434 Param=halfinteger(Com_Acomp+Icomp>>BSCALE) 1435 %finishelsestart 1436 Param=shortinteger(Com_Acomp+Icomp>>BSCALE) 1437 %finish 1438 !* 1439 LIN = -OUTP 1440 UP2: 1441 UP(2): 1442 OUTPUT(OUTP) = PARAM 1443 OUTP = OUTP+1 1444 %if OUTP>=LMAXOUTPUT %thenstart 1445 %if OUTPUTFUL#0 %thenstart 1446 ER=307 1447 ->EXIT4 1448 %finish 1449 LMAXOUTPUT=Com_Maxoutput 1450 %finish 1451 RET: 1452 !* 1453 {%include "pf_anal4"} 1454 !* 1455 ! RESTORE 1456 ! 1457 *LA_0,24 1458 *SR_11,0 1459 *MVC_SAVELINK(24),0(11) 1460 ! 1461 !* 1462 {%include "pf_anal4"} 1463 !* 1464 %if SAVELINK=0 %then LINVAL=LIN %and %result=1 1465 %if PATH=2 %then ->UP2 1466 %if PATH=0 %then ->UP0 1467 UP(1):ICOMP = II+2 1468 PARAM = LIN 1469 II = ICOMP+2 1470 IJ = Com_Inp 1471 PATH = 2 1472 -> L7 1473 UP0: 1474 UP(0):ICOMP = II 1475 %if Com_Maxinp>BSCALE) 1485 %finishelsestart 1486 Icomp=shortinteger(Com_Acomp+Icomp>>BSCALE) 1487 %finish 1488 !* 1489 -> L4 %unless ICOMP = 0 1490 !* 1491 {%include "pf_anal6"} 1492 !* 1493 ! RESTORE 1494 ! 1495 *LA_0,24 1496 *SR_11,0 1497 *MVC_SAVELINK(24),0(11) 1498 ! 1499 !* 1500 {end "pf_anal6"} 1501 !* 1502 PATH = 0 1503 %if SAVELINK=0 %then LINVAL=LIN %and %result=1 1504 ->UP(PATH) 1505 !* 1506 L1: 1507 %if HOST=PERQPNX %or HOST=ICL2900 %thenstart 1508 Lin=halfinteger(Com_Acomp+Icomp>>BSCALE) 1509 %finishelsestart 1510 Lin=shortinteger(Com_Acomp+Icomp>>BSCALE) 1511 %finish 1512 ->RET 1513 !* 1514 SYNERR:ER=100;! SYNTAX ERROR 1515 PIEXIT(4): 1516 1517 1518 EXIT4P:FAULT(ER);! WITH POINTER 1519 ->UP3 1520 EXIT4:LFAULT(ER) 1521 UP3: 1522 %if Com_Sfmk#0 %then STATFN_CLASS=0 %and STATFN_X0=0;! prevent consequent failure after bad stat fn 1523 UP(3):%result = 3 1524 ! ---------------------------------------------------------------------- 1525 LLFAULT:LFAULT(ER) 1526 ->EXIT1 1527 !* 1528 PI(10): 1529 !*********************************************************************** 1530 !* Give warnings or errors as appropriate for language extensions * 1531 !* P1 = 1 BYTE * 1532 !* 2 CHAR * 1533 !* 3 IMPLICIT NONE * 1534 !* 4 IMPLICIT UNDEFINED * 1535 !* 5 * after Dimlist * 1536 !* 6 ACCEPT * 1537 !* 7 TYPE * 1538 !* 8 NAMELIST * 1539 !*********************************************************************** 1540 %if Target=Gould %thenstart 1541 %if P1=1 %then ->Synerr {BYTE} 1542 %finishelsestart 1543 %if P1=2 %or 6<=P1<=8 %then ->Synerr 1544 %finish 1545 ->exit1 1546 !* 1547 PI(127): 1548 !*********************************************************************** 1549 !* Fast search for statements * 1550 !*********************************************************************** 1551 %if 'A'<=Com_Nextch<='Z' %then ICOMP=LOOKUP(Com_Nextch-'A') 1552 ->EXIT1 1553 !* 1554 PI(128): 1555 !*********************************************************************** 1556 !* Avoid operator search if not possible * 1557 !*********************************************************************** 1558 ICOMP=ICOMP+2 1559 %unless 9<=TYPE(Com_Inp)<=10 %then ->EXIT2;! unless * / + - > ! & ^ # 1560 ICOMP=ICOMP+2 1561 ->EXIT1 1562 !* 1563 PI(17): 1564 !*********************************************************************** 1565 !* FOLLOWING ARITHMETIC IF LABEL CHECK IF SAME AS NEXT LABEL * 1566 !*********************************************************************** 1567 %if CRM1 = Next Label %then RES = 0 1568 -> EXIT1 1569 !* 1570 PI(18): 1571 !*********************************************************************** 1572 !* BEFORE PROCESSING LABEL LIST TO ARITHMETIC IF DETERMINE * 1573 !* VALUE OF LABEL (IF ANY) TO NEXT STATEMENT * 1574 !*********************************************************************** 1575 CRM1 = Next Label 1576 -> EXIT1 1577 !* 1578 PI(19): 1579 !*********************************************************************** 1580 !* P1=1 END STATEMENT * 1581 !* 0 ENTRY * 1582 !*********************************************************************** 1583 Com_Labwarn = 0 1584 %if P1=0 %then ->EXIT1;! ENTRY 1585 %if Com_Statordermode>3 %and Com_Subprogtype=5 %then LFAULT(305);! exec stats in BLOCKDATA 1586 %if BLOCKIFSTATE#0 %then LFAULT(208);! missing ENDIF 1587 CHECK SAVELIST 1588 CHECK ASSLIST 1589 {2900 %if Com_Itsmode=1 %then FAULTNUM(173);! comment re ITS} 1590 !PPROFILE 1591 -> EXIT1 1592 !* 1593 PI(20): 1594 !*********************************************************************** 1595 !* NOTE DATA TYPE * 1596 !* P1 =X'00' undefined * 1597 !* X'01' INTEGER * 1598 !* X'02' REAL * 1599 !* X'03' COMPLEX * 1600 !* X'04' LOGICAL * 1601 !* X'05' CHARACTER * 1602 !* X'06' DOUBLE PRECISION * 1603 !* X'07' BYTE * 1604 !* X'08' DOUBLE COMPLEX * 1605 !* X'09' CHAR * 1606 !*********************************************************************** 1607 CRM8 = DEFAULT SIZE(P1) 1608 CHARLEN=1 1609 -> EXIT1 1610 !* 1611 PI(21): 1612 PI21: 1613 !*********************************************************************** 1614 !* SET UP NEXT IDENTIFIER OR CONSTANT FROM THE INPUT RECORD * 1615 !* ON ENTRY P1 INDICATES THE TYPE OF FIELD EXPECTED, AS FOLLOWS * 1616 !* P1 = 0 ANY FIELD * 1617 !* 1 IDENTIFIER * 1618 !* 3 INTEGER * 1619 !* 4 CONSTANT * 1620 !* 5 DATA CONSTANT * 1621 !* 6 COMPLEX CONSTANT (IF NOT EXITS TO ALTERNATIVE SYNTAX) * 1622 !* 7 OPTIONAL IDEN * 1623 !* ON EXIT CTYP IS SET AS FOLLOWS * 1624 !* CTYP = -1 'NEW' IDENTIFIER * 1625 !* 0 IDENTIFIER * 1626 !* 1 INTEGER * 1627 !* 2,10 REAL * 1628 !* 3,11 COMPLEX * 1629 !* 4 LOGICAL * 1630 !* 5 CHARACTER OR HOLLERITH * 1631 !* 6 HEX * 1632 !* 7 BLOCKDATA IDENTIFIER * 1633 !* FOR CTYP = -1 OR 0 PTR ADDRESSES THE DICT RECORD * 1634 !* CONSTANTS ARE SET IN A RECORD AT DPTR * 1635 !* PI21INT CONTAINS THE VALUE SET FOR INTEGER AND LOGICAL CONSTANTS * 1636 !* PI21LENGTH CONTAINS THE LENGTH OF THE CONSTANT FOR CTYP > 0 * 1637 !*********************************************************************** 1638 P3 = 0 1639 P2 = 0 1640 TINP = Com_Inp 1641 SAVEP1=P1 1642 %if SAVEP1=7 %then P1=1 %and BLOCKDATAID="" 1643 DD == record(Com_Adict+Com_Dptr) 1644 -> P210(TYPE(Com_Inp)) 1645 !******** $ 1646 P210(2): 1647 -> Synerr 1648 !******** A - Z 1649 P210(1): 1650 TTYP = IMPTYPE(INPUT(Com_Inp)); ! IMPLICIT TYPE FOR ALPHABETIC CHAR 1651 PI21IDEN: 1652 %if P1 <= 2 %or P1=5 %thenstart;! IDENTIFIER REQUIRED, OR ACCEPTABLE 1653 CTYP = 0; ! IDENTIFIER 1654 %if TYPE(Com_Inp+1)>3 %thenstart;! single letter - try fast search 1655 %if P1=5 %and Input(Com_Inp+1)='''' %thenstart 1656 %if Com_Nextch='X' %or Com_Nextch='Z' %or Com_Nextch='O' %c C %or Com_Nextch='B' %thenstart;! could be a hex const 1658 N=Com_Nextch 1659 I=Com_Inp+2 1660 K=I 1661 Hloop1: J=Input(K) 1662 %if J=10 %or K>1328 %then ->Bad Const 1663 %if J='''' %thenstart 1664 %if I=K %or I+16Bad Const 1665 Com_Inp=K+1 1666 Com_Nextch=Input(Com_Inp) 1667 ->Set Hex 1668 %finish 1669 K=K+1 1670 ->Hloop1 1671 %finish 1672 %finish 1673 %if Com_Sfmk=0 %and Com_Xref=0 %thenstart 1674 J=INPUT(Com_Inp) 1675 PTR=LHEAD(J+63) 1676 %if PTR#0 %thenstart;! seen it before 1677 PP==record(Com_Adict+PTR) 1678 LENGTH(IDENTIFIER)=1 1679 CHARNO(IDENTIFIER,1)=J 1680 TTYP=PP_TYPE 1681 Com_Inp=Com_Inp+1 1682 Hashvalue=J&31+127 1683 ->GOTID 1684 %finish 1685 %finish 1686 %finish 1687 SETNAME 1688 FIND; ! WILL SET CTYP=-1 IF A 'NEW' IDENTIFIER 1689 GOTID: RES_W=PTR 1690 PI21MODE=SETMODE(TTYP&X'3F');! TO ALLOW DIMENSION EXPRESSION ANALYSIS 1691 %if P1=5 %thenstart;! must be a constant name 1692 %if PP_CLASS=16 %thenstart 1693 CTYP=PP_TYPE 1694 RES_W=PP_CONSTRES 1695 Com_Pi21int=RES_H0 1696 %if Res_Form=1 %and Res_Mode=1 %then %C C Com_Pi21int=integer(Com_Adict+Com_Pi21int< 1703 %if Pi21mode=INT4 %thenstart 1704 Com_Pi21int=-Com_Pi21int 1705 integer(Com_Adict+Com_Dptr)=Com_Pi21int 1706 %finishelsestart 1707 %if Pi21mode=REAL4 %thenstart 1708 real(Com_Adict+Com_Dptr)= %c C -real(Com_Adict+Com_Pi21int<Bad Const 1712 longreal(Com_Adict+Com_Dptr)= %c C -longreal(Com_Adict+Com_Pi21int<>DSCALE 1717 Res_Form=1;Res_Mode=Pi21mode 1718 Com_Dptr=Com_Dptr+Pi21length 1719 %finish 1720 ->PI21EXIT 1721 %finishelsestart 1722 %if Input(Tinp)='Z' %thenstart;! could be 'old' hex 1723 I=Tinp+1 1724 K=Com_Inp 1725 N='Z' 1726 Set Hex: 1727 integer(Com_Adict+Com_Dptr)=0 1728 L=K-I;! no of hex chars 1729 M=0 1730 %if N='O' %thenstart 1731 %while L>0 %cycle 1732 J=Input(I) 1733 I=I+1 1734 %unless '0'<=J<='7' %then ->Bad Const 1735 M=(M<<3)!(J&7) 1736 L=L-1 1737 %repeat 1738 ->Set Hex2 1739 %finish 1740 %if N='B' %thenstart 1741 %while L>0 %cycle 1742 J=Input(I) 1743 I=I+1 1744 %unless '0'<=J<='1' %then ->Bad Const 1745 M=(M<<1)!(J&1) 1746 L=L-1 1747 %repeat 1748 Set Hex2: %if Bscale=1 %then N=2 %else N=4 1749 integer(Com_Adict+Com_Dptr+N)=M 1750 %finish 1751 %while L>0 %cycle 1752 J = Input(I) 1753 I=I+1 1754 %if 'A'<=J<='F' %or 'a'<=J<='f' %thenstart 1755 J=J&15+9 1756 %finishelsestart 1757 %if '0'<=J<='9' %then J=J&15 %else ->Bad Const 1758 %finish 1759 M=(M<<4)!J 1760 L=L-1 1761 %if L&7=0 %thenstart 1762 N=4-L>>1 1763 %if Bscale=1 %then N=N>>1 1764 integer(Com_Adict+Com_Dptr+N)=M 1765 M=0 1766 %finish 1767 %repeat 1768 Res_H0=Com_Dptr>>DSCALE; RES_Form=1; Res_Mode=HEXCONST 1769 %if Host=WWC %thenstart;! reverse everything 1770 I=integer(Com_Adict+Com_Dptr) 1771 integer(Com_Adict+Com_Dptr)=integer(Com_Adict+Com_Dptr+4) 1772 integer(Com_Adict+Com_Dptr+4)=I 1773 %finish 1774 Com_Dptr=Com_Dptr+8 1775 Ctyp = 6; ! hex constant 1776 Pi21length=8 1777 Pi21mode=HEXCONST 1778 !! Report Error(8,0,353);! non-standard 1779 -> Pi21exit 1780 %finish 1781 Bad Const: Er=116 1782 ->Exit4p 1783 %finish 1784 %finish 1785 %if SAVEP1=7 %then BLOCKDATAID=IDENTIFIER 1786 PI21EXIT:Com_Nextch = INPUT(Com_Inp) 1787 -> EXIT1 1788 %finish 1789 %if P1 = 6 %thenstart; ! SWITCH TO ALTERNATIVE SYNTAX(NOT COMPLEX CONST) 1790 SWITCH: Com_Inp = TINP 1791 ICOMP = ICOMP+2 1792 Com_Nextch = INPUT(Com_Inp) 1793 -> EXIT2 1794 %finish 1795 ->Bad Const 1796 !* 1797 !******** 0 - 9 1798 P210(3): 1799 ER = 144; ! VARIABLE NOT FOUND WHEN EXPECTED 1800 -> EXIT4P %if P1 = 1; ! IDENTIFIER REQUIRED 1801 !* 1802 !****** NON-ALPHANUMERICS 1803 P210(4): 1804 P210(7): 1805 P210(8): 1806 P210(9): 1807 P210(10): 1808 P210(11): 1809 P210(13): 1810 P210(14): 1811 P210(15): 1812 P210(16): 1813 P210(17): 1814 P210(18): 1815 %if Com_Nextch='+' %thenstart 1816 P3=1 1817 %finishelsestart 1818 %if Com_Nextch='-' %then P3=2;! indicates presence of a sign 1819 %finish 1820 %if P3#0 %thenstart 1821 %if Type(Com_Inp+1)=1 %thenstart 1822 Com_Inp = Com_Inp+1 1823 Com_Nextch = Input(Com_Inp) 1824 -> P210(1) 1825 %finish 1826 %finish 1827 !****** CHARACTER 1828 P210(5): 1829 Call Set: 1830 I=Set Constant(P1,Pi21length,Pi21mode,Ctyp,Er,Res,Input,Type) 1831 %if I=0 %then ->Pi21exit 1832 %if I=2 %then ->Switch 1833 ->Exit4p 1834 !* 1835 !****** END OF STATEMENT 1836 P210(12): 1837 ER = 104 1838 %if SAVEP1=7 %then ->PI112 1839 -> EXIT4 1840 !* 1841 PI(22): 1842 !*********************************************************************** 1843 !* CHECK THAT INT AFTER * IS VALID - MODIFY CRM8 IF NECESSARY * 1844 !*********************************************************************** 1845 %if CRM8=5 %thenstart;! CHARACTER 1846 %unless 0EXIT1 1849 %finish 1850 L22A: LFAULT(242);! warn about use of * 1851 Com_Inhibop4=1 1852 L = CRM8&7 1853 { %unless Com_Pi21int = VALIDT(L) %thenstart} 1854 { L = L+8} 1855 %unless Com_Pi21int=VALIDT(L) %thenstart 1856 L=L+8 1857 %unless Com_Pi21int=VALIDT(L) %thenstart 1858 L=L+8 1859 %unless Com_Pi21int=VALIDT(L) %then FAULT(124) %and ->EXIT1 1860 %finish 1861 %finish 1862 { %finish} 1863 %if P=24 %then PP_TYPE=VALIDST(L) %else CRM8=VALIDST(L) 1864 -> EXIT1 1865 !* 1866 PI(23): 1867 !*********************************************************************** 1868 !* EXPLICITLY SETS TYPE (CRM8) IN CURRENT PREC, CHECKING VALIDITY * 1869 !*********************************************************************** 1870 SAVEPTR=PTR;! saved for resetting in PI24 if necesary 1871 I = PP_CLASS 1872 %if I = 12 %then CBNAME %and I = PP_CLASS 1873 IDENTIFIER =STRING(Com_Anames+PP_IDEN) 1874 J = PP_X0 1875 %if J&8 = 0 %thenstart; ! NOT ALREADY TYPED 1876 %if I&X'1F' <= 8 %or (I = 11 %and Com_Subprogtype = 2) %C C %thenstart 1878 ! SCALAR OR ARRAY OR EXTERNAL FN OR 'THIS FN' 1879 ! CONSTANT NAME TREATED AS SCALAR 1880 PP_X0=J!8; ! INDICATES THAT TYPE IS SET EXPLICITLY 1881 PP_TYPE=CRM8 1882 %if CRM8 = 5 %thenstart 1883 PP_LEN=CHARLEN;! default character length 1884 %if CHARLEN=0 %thenstart 1885 L231: ADD TO ASSLIST(ADDR(PP_CLASS)-Com_Adict) 1886 %finish 1887 %finish 1888 -> EXIT1 1889 %finishelsestart 1890 %if I&X'10'#0 %then J=239 %else J=270 1891 ! name cannot be typed after it has appeared in a PARAMETER statement 1892 ! else name must not appear in a type statement 1893 LFAULT(J) 1894 ->EXIT1 1895 %finish 1896 %finish 1897 LFAULT(269); ! already typed 1898 ->EXIT1 1899 !* 1900 PI(24): 1901 1902 !*********************************************************************** 1903 !* OVERRIDE EXPLICIT TYPE SETTING AFTER * * 1904 !*********************************************************************** 1905 %if CRM8=5 %thenstart 1906 %unless 0L231;! check that it is an arg 1911 ->EXIT1 1912 %finish 1913 -> L22A 1914 !* 1915 PI(25): 1916 1917 !*********************************************************************** 1918 !* AFTER ( IN DIMENSION LIST * 1919 !*********************************************************************** 1920 %cycle 1921 I = PP_CLASS 1922 %if I&X'C' = 0 = PP_X1&3 %then %exit; ! NOT SUBPROG OR ARRAY OR USED 1923 ER = 254; ! WRONG CLASS OF VAR DIMENSIONED OR ARRAY ALREADY 1924 %if I&X'C'=4 %then ER=262;! ALREADY AN ARRAY 1925 %unless I = 12 %then -> EXIT4; ! FAULT UNLESS COMMON BLOCK NAME 1926 CBNAME 1927 %repeat 1928 ARRAYREC==record(Com_Adict+PTR);! REMEMBER THE CURRENT IDEN RECORD 1929 CEXMODE=3 1930 DIMSCOUNT = 0 1931 Com_Cexpdict=0 1932 -> EXIT1 1933 !* 1934 PI(26): 1935 !*********************************************************************** 1936 !* Following dimension value * 1937 !* P1 = 0 after lower, or only, bound * 1938 !* 1 after upper bound * 1939 !*********************************************************************** 1940 Com_Curstatclass=1 1941 %if Com_Statordermode>2 %then LFAULT(236) 1942 Com_Statordermode=2 1943 GENERATE RD 1944 I=RES_FORM&X'F';! form of expression 1945 %if I<=1 %thenstart;! integer const 1946 %if I#0 %thenstart 1947 %if RES_MODE=INT8 %then Res_H0=(Res_H0<>DSCALE 1948 %finish 1949 %finishelsestart;! iden or expression 1950 %if I=6 %thenstart;! expression 1951 INTEGER(Com_Adict+Com_Cexpdict)=Com_Dptr-Com_Cexpdict 1952 Res_H0=Com_Cexpdict>>DSCALE; Res_Form=7; Res_Mode=1 1953 %finish 1954 %if ARRAYREC_CLASS&1=0 %thenstart 1955 %if ARRAYREC_CLASS=2 %thenstart 1956 IDENTIFIER=STRING(Com_Anames+ARRAYREC_IDEN) 1957 ER=251;! adjustable dims 1958 ->EXIT4 1959 %finish 1960 ARRAYREC_CLASS=X'61' 1961 I=PTR 1962 PTR=NEW LIST CELL(Com_Checklist,3) 1963 SS==record(Com_Adict+PTR) 1964 SS_INF0=ADDR(ARRAYREC_CLASS)-Com_Adict 1965 SS_INF2=1;! CHECK IF PARAM 1966 PTR=I 1967 %finishelsestart 1968 %unless ARRAYREC_CLASS=X'61' %then ARRAYREC_CLASS=X'41' 1969 %finish 1970 %finish 1971 !***** entered from PI(114) after *) in dimension list 1972 PI26B:%if DIMSCOUNT <= 7 %thenstart 1973 %if P1=0 %thenstart;! after lower, or only, bound 1974 DIMSCOUNT=DIMSCOUNT+1 1975 Reslow_H0=1 1976 Reslow_Form=0 1977 Reslow_Mode=1 1978 LDIM(DIMSCOUNT)=Reslow_W 1979 %finishelsestart 1980 LDIM(DIMSCOUNT)=UDIM(DIMSCOUNT) 1981 %finish 1982 UDIM(DIMSCOUNT)=Res_W 1983 %finish 1984 Com_Cexpdict=0 1985 -> EXIT1 1986 !* 1987 PI(27): 1988 1989 !*********************************************************************** 1990 !* INTRODUCE BLANK COMMON, I.E. AFTER COMMON OR // * 1991 !*********************************************************************** 1992 PTR = BLCMPTR 1993 PP == record(Com_Adict+PTR) 1994 %if PP_LAST = BLCMPTR %then CTYP = -1 %else CTYP = 0 1995 !* 1996 PI(28): 1997 !*********************************************************************** 1998 !* INTRODUCE LABELLED COMMON, I.E. AFTER // * 1999 !*********************************************************************** 2000 Com_Curstatclass=1 2001 %if Com_Statordermode>2 %then ER=236 %and ->EXIT4 2002 Com_Statordermode=2 2003 { %cycle } 2004 Pi28b: CMNBLKPTR = PTR 2005 %if CTYP = -1 %thenstart; ! FIRST USE - ESTABLISH REFERENCE 2006 Pi28a: PP_CLASS=12; ! COMMON BLOCK NAME 2007 PP_ADDR4 = Com_Cbnptr 2008 Com_Cbnptr = PTR 2009 PP_CMNLENGTH = 0 2010 PP_LAST = PTR; ! LAST ITEM LINK TO ITSELF 2011 I=Dictspace(CMNRECEXT); ! RESERVE THE EXTRA DICT WORDS 2012 PP_CMNREFAD=0;! no reference set 2013 -> EXIT1 2014 %finish 2015 I = PP_CLASS 2016 -> EXIT1 %if I = 12; ! COMMON BLOCK ENTRY ALREADY ESTABLISHED 2017 ER = 121; ! ILLEGAL USE OF BLOCK NAME 2018 CMNBLKPTR = -1; ! UNLESS SET > 0 WILL INDICATE INVALID BLOCK NAME 2019 -> LLFAULT %if 8 < I < 12 2020 CBNAME 2021 ->Pi28b 2022 { %repeat } 2023 !* 2024 PI(29): 2025 2026 !*********************************************************************** 2027 !* AFTER IDEN IN COMMON LIST * 2028 !*********************************************************************** 2029 %if CMNBLKPTR < 0 %then -> EXIT1; ! INVALID BLOCK NAME ALREADY REPORTED 2030 %if PP_CLASS = 12 %then CBNAME 2031 I = PP_CLASS 2032 J = PP_X1 2033 %unless I&X'7B' = 0 %and J&1=0 %thenstart; ! IF PARAM, (ALREADY) COMMON, INITIALISED OR USED 2034 J=I&X'7B' 2035 %if J#0 %thenstart 2036 ER=142;! SUBPROGRAM NAME 2037 %if J=1 %then ER=123;! PARAMETER 2038 %if J=2 %then ER=122;! ALREADY IN COMMON 2039 %if J=16 %then ER=240;! SYMBOLIC CONSTANT NAME 2040 %if J&64#0 %then ER=251;! adjustable dims 2041 %finishelse ER=236;! ALREADY USED OR INITIALISED 2042 ->LLFAULT 2043 %finish 2044 PP_CLASS=I!2; ! SET COMMON MARKER 2045 PP_X0=PP_X0!4; ! scalar in array or common area 2046 PP_Link3 = CMNBLKPTR>>DSCALE 2047 CMNBLK == record(Com_Adict+CMNBLKPTR) 2048 QQ == record(Com_Adict+CMNBLK_LAST); ! PREVIOUS LAST ITEM IN THIS COMMON AREA 2049 QQ_LINK2 = PTR 2050 CMNBLK_LAST = PTR 2051 %if J&4 # 0 %thenstart; ! IF 'EQUIVALENCED FROM' 2052 L = PP_LINK2; ! LINK TO CORRESPONDING EQUIV CHAIN ENTRY 2053 PP_LINK2=0 2054 PP_X1=J&X'F3'; ! CLEAR EQUIVALENCE MARKERS 2055 ! ALLOC(PTR); ! FORCES ALLOCATION OF COMPLETE COMMON AREA 2056 ! SS == record(Com_Adict+L); ! EQUIV CHAIN ENTRY 2057 ! SS == record(Com_Adict+SS_LINK1); ! NEXT CHAIN ENTRY 2058 ! PTR = SS_INF0; ! CORRESPONDING DICT RECORD 2059 ! ALLOC(PTR); ! COMPLETE CHAIN 2060 %finish 2061 -> EXIT1 2062 !* 2063 PI(30): 2064 2065 !*********************************************************************** 2066 !* INITIALISATION FOR DATA OR EQUIVALENCE LIST * 2067 !*********************************************************************** 2068 Com_Curstatclass=1 2069 CRM3 = 0; ! -1 ERROR DETECTED 2070 VLISTHEAD = 0; ! LISTHEAD OF LIST RECORDS FORMAT SS 2071 CCOUNT = 1; ! DEFAULT MULTIPLIER IN DATA INIT, USED IN EQUIV TO 2072 ! CHECK THAT <= 1 COMMON IS INCLUDED 2073 VCOUNT=0;! to ensure data init calls GET NEXT VARIABLE 2074 Com_Labwarn=0;! to avoid 'inaccessable statement' messages 2075 -> EXIT1 2076 !* 2077 PI(31): 2078 2079 !*********************************************************************** 2080 !* MAKE A SCALAR ENTRY TO LIST (IN TYPE STATEMENT AFTER / INDICATING * 2081 !* INITIALISATION FOR PREVIOUS ITEM) * 2082 !*********************************************************************** 2083 %if P1=1 %thenstart 2084 PTR=DOIOP;! saved by PI32(1) 2085 PP==record(Com_Adict+PTR) 2086 %finish 2087 %if PP_CLASS = 12 %then CBNAME 2088 ER = 301; ! WRONG CLASS OF VARIABLE IN DATA OR EQUIVALENCE LIST 2089 %if PP_CLASS&X'19' # 0 %then CRM3 = -1 %and -> LLFAULT 2090 ! CONFLICT WITH PARAM OR SUBPROG NAME 2091 %if PP_Type=0 %then Notype 2092 I = 0 2093 PI31A: -> EXIT1 %if CRM3 = -1; ! PREVIOUS ERROR 2094 L = PTR 2095 PTR=FREESP(5) 2096 SS==record(Com_Adict+PTR) 2097 !****** Following code inserted to process char substrings 2098 %if P1=1 %thenstart;! substring 2099 RES_W=Com_Rescom1; J=RES_H0; %if J=0 %then J=1;! lower bound 2100 RES_W=Com_Rescom2; K=RES_H0; %if K=0 %then K=PP_LEN;! upper bound 2101 SS_INF4=K-J+1;! substring length 2102 I=I+J-1 2103 Com_Rescom1=0 2104 Com_Rescom2=0 2105 %finishelse SS_INF4=0 2106 SS_INF2 = I; ! DISPLACEMENT FROM BASE ADDRESS (!X'1000000' FOR ARRAY ELEMENT) 2107 SS_INF3=Com_Linest 2108 SS_INF0 = L 2109 %unless VLISTHEAD = 0 %thenstart 2110 SS == record(Com_Adict+VLISTTAIL) 2111 SS_LINK1 = PTR 2112 %finishelse VLISTHEAD = PTR 2113 VLISTTAIL = PTR; ! POINTER TO LAST ITEM ON LIST 2114 -> EXIT1 2115 !* 2116 PI(32): 2117 2118 !*********************************************************************** 2119 !* SAVE DPTR VALUE BEFORE PROCESSING DIMENSION IN LIST ARRAY ELEMENT * 2120 !*********************************************************************** 2121 %if P1=1 %thenstart;! insertion for substrings 2122 DOIOP=PTR;! saved for resetting in PI31(1) 2123 Com_Rescom1=0 2124 Com_Rescom2=0 2125 %if SCAN(':')=0 %thenstart;! no substring 2126 ICOMP=ICOMP+2 2127 ->EXIT2 2128 %finish 2129 %finishelse DIMSCOUNT=0 2130 -> EXIT1 2131 !* 2132 PI(33): 2133 2134 !*********************************************************************** 2135 !* PRESERVE INTEGER DIMENSION VALUE EVALUATED BY PI21 * 2136 !*********************************************************************** 2137 Com_Rescom1=0 2138 Com_Rescom2=0 2139 DIMSCOUNT = DIMSCOUNT+1 2140 %if DIMSCOUNT <= 7 %then LDIM(DIMSCOUNT) = Com_Pi21int 2141 -> EXIT1 2142 !* 2143 PI(34): 2144 2145 !*********************************************************************** 2146 !* AFTER ) TO DIMENSION LIST IN DATA STATEMENT * 2147 !* CALCULATE BYTE DISPLACEMENT OF ELEMENT AND MAKE LIST ENTRY * 2148 !*********************************************************************** 2149 %if P1=1 %thenstart 2150 PTR=DOIOP;! saved by PI32(1) 2151 PP==record(Com_Adict+PTR) 2152 %finish 2153 %if PP_CLASS=12 %then CBNAME 2154 ER = 245; ! SUBSCRIPTED VARIABLE NOT ARRAY NAME 2155 %unless PP_CLASS&13 = 4 %thenstart 2156 %if PP_CLASS&4#0 %then ER=301 2157 PI34ERR: CRM3 = -1 2158 -> EXIT4 2159 %finish 2160 %if PP_Type=0 %then Notype 2161 DVREC == record(Com_Adict+PP_ADDR4) 2162 J = DVREC_DIMS 2163 PI34A:I=1;! to avoid IMP compiler bug 2164 L = LDIM(I)-Boundval(DVREC_B(I)_L) 2165 ER = 264; ! WRONG NO. OF SUBSCRIPTS 2166 %if Dimscount # J %thenstart 2167 %if Dimscount#1 %or Com_Allowvax=NO %then ->Pi34err 2168 %cycle I=1,1,J 2169 %unless Boundval(Dvrec_B(I)_L)=1 %then ->Pi34err 2170 %repeat 2171 Lfault(337) 2172 %finish 2173 %if DIMSCOUNT > 1 %thenstart 2174 L = L+Boundval(DVREC_B(1)_L) 2175 %cycle I = 2,1,J 2176 L = L+DVREC_B(I-1)_M*LDIM(I) 2177 %repeat 2178 L = L-DVREC_ZEROTOFIRST 2179 %finish 2180 ER = 232 2181 %unless 0 <= L < DVREC_NUMELS %then %C C IDENTIFIER=STRING(Com_Anames+PP_IDEN) %and -> PI34ERR 2183 ! OUTSIDE DECLARED BOUNDS 2184 %if PP_TYPE=5 %then J=PP_LEN %else %C C J=NUMBYTES(PP_TYPE>>4);! BYTES PER ITEM 2186 %if PP_TYPE&7=3 %then J=J<<1;! COMPLEX 2187 I = (L*J)!X'1000000' 2188 -> PI31A 2189 !* 2190 PI(35): 2191 !*********************************************************************** 2192 !* FOLLOWING CLOSING ) TO ARRAY DECLARATION * 2193 !*********************************************************************** 2194 Com_Curstatclass=1 2195 %if Com_Statordermode>2 %then LFAULT(236) 2196 Com_Statordermode=2 2197 ER = 247; ! MORE THAN 7 DIMENSIONS 2198 %if DIMSCOUNT > 7 %then -> EXIT4 2199 J = ARRAYREC_CLASS 2200 ARRAYREC_CLASS=J!4;! array marker 2201 I = Dictspace(DVRECSIZE+12*DIMSCOUNT);! LINK TO DOPE VECTOR 2202 DVREC == record(Com_Adict+I) 2203 DVREC_DIMS = DIMSCOUNT 2204 %if J&1 # 0 %thenstart; ! PARAMETER ARRAY 2205 DVREC_ADFIRST = ARRAYREC_ADDR4;! DVAREA ADDRESS OF PARAM DESCRIPTOR 2206 %finishelse DVREC_ADFIRST=0 2207 ARRAYREC_ADDR4 = I 2208 N=0 2209 L=0; M=1 2210 %cycle I=1,1,DIMSCOUNT 2211 Reslow_W=LDIM(I) 2212 Resupp_W=UDIM(I) 2213 DVREC_B(I)_L=Reslow_W 2214 DVREC_B(I)_U=Resupp_W 2215 J=Reslow_H0 2216 %if Reslow_Form=1 %then J=integer(Com_Adict+J<PI35A;! already know it is adjustable 2229 %if Resupp_Form=8 %then K=0;! AVOID INTOVERFLOW 2230 L=L+M*J 2231 M=M*(K-J+1) 2232 DVREC_B(I)_M=M 2233 %finish 2234 %repeat 2235 Resupp_W=DVREC_B(DIMSCOUNT)_U 2236 %if Resupp_Form=8 %thenstart 2237 ARRAYREC_CLASS=ARRAYREC_CLASS!X'80';! assumed size 2238 ADD TO ASSLIST(ADDR(ARRAYREC_CLASS)-Com_Adict) 2239 %finish 2240 DVREC_NUMELS = M;! at least as far as can be 2241 DVREC_ZEROTOFIRST = L;! computed at compile time 2242 DVREC_ELLENGTH=NUMBYTES(ARRAYREC_TYPE>>4);! will be updated if nec. by ALLOC 2243 Dvrec_Addrzero=Dvrec_Zerotofirst*Dvrec_Ellength 2244 -> EXIT1 2245 !* 2246 PI(36): 2247 2248 !*********************************************************************** 2249 !* FOLLOWING MULTIPLIER IN DATA INITIALISATION LIST * 2250 !*********************************************************************** 2251 %unless CTYP&7 = 1 %then -> PI34ERR; ! MUST BE AN INTEGER 2252 -> EXIT1 %if CRM3 = -1 2253 CCOUNT = Com_Pi21int 2254 -> EXIT1 2255 !* 2256 PI(37): 2257 2258 !*********************************************************************** 2259 !* INITIALISE NEXT ENTRY IN DATA LIST * 2260 !*********************************************************************** 2261 !! %if Com_Statordermode<3 %then Com_Statordermode=3;! must not do this if type 2262 -> EXIT1 %if CRM3 = -1 2263 !* 2264 !* CCOUNT number of consts 2265 !* PI21LENGTH actual length of const 2266 !* PI21MODE mode of const 2267 !* 2268 %if Res_Form=0 %thenstart;! handle short literals like all others 2269 %if TARGET=ACCENT %and HOST#ACCENT %thenstart 2270 integer(Com_Adict)=Res_H0<<16 2271 %finishelsestart 2272 integer(Com_Adict)=Res_H0 2273 %finish 2274 RES_W=0 2275 %finishelse Res_W=Res_H0<EXIT4 2284 %finishelse ->EXIT4P 2285 %finish 2286 SAVEPTR=PTR 2287 %finishelse PTR=SAVEPTR;! in case it has been changed by a const name ref 2288 %if VCOUNT=0 %thenstart 2289 ER=286;! too many consts specified 2290 ->EXIT4P 2291 %finish 2292 !* 2293 I=PI21MODE 2294 J=RES_W 2295 K=PI21LENGTH 2296 %if I=VMODE %thenstart;! type and size(except char) matches 2297 %if I=CHARMODE %thenstart;! char, check const length 2298 PI37D: %if KCCOUNT %then L=CCOUNT;! L=MIN(VCOUNT,CCOUNT) 2307 %if TARGET=ACCENT %thenstart 2308 %if HOST#ACCENT %thenstart 2309 %if J#0 %and I#CHARMODE %and I#HOLMODE %thenstart 2310 %if Pi21length=4 %thenstart 2311 N=integer(Com_Adict+J) 2312 %finishelsestart 2313 N=integer(Com_Adict+J) 2314 M=N>>16 2315 N=(N<<16)!M 2316 integer(Com_Adict+W1)=N 2317 N=integer(Com_Adict+J+W1) 2318 %finish 2319 M=N>>16 2320 N=(N<<16)!M 2321 integer(Com_Adict)=N 2322 J=0 2323 %finish 2324 %finish 2325 %finish 2326 ADD DATA ITEM(PTR,L,VDISP,VLENGTH,J) 2327 VCOUNT=VCOUNT-L 2328 CCOUNT=CCOUNT-L 2329 VDISP=VDISP+L*VLENGTH 2330 %if CCOUNT=0 %then CCOUNT=1 %and ->EXIT1;! for the next const 2331 ->PI37A;! to prepare next variable 2332 %finish 2333 !* 2334 %if Pi21mode=HEXCONST %thenstart 2335 %if Vmode=CHARMODE %thenstart 2336 %unless Vlength=1 %then ->PI37E 2337 %finish 2338 %if Host=WWC %thenstart 2339 N=0 2340 %finishelsestart 2341 N=8-Vlength 2342 %finish 2343 %if BSCALE=1 %then N=N>>1 2344 J=Res_W+N 2345 ->PI37B 2346 %finish 2347 !* 2348 %if 1<=I<=8 %and 1<=VMODE<=8 %thenstart;! arithmetic coercion required 2349 M=VMODE 2350 PI37C: K=Com_Dptr 2351 J=COERCE CONST(J,I,M,Com_Adict,Com_Dptr) 2352 Com_Dptr=K 2353 ->PI37B 2354 %finish 2355 !* 2356 %if I=INT4 %thenstart 2357 %if VMODE=INT2 %thenstart;! I*2 init 2358 %if Host#WWC %thenstart 2359 %if Host=PERQPNX %then J=J+1 %else J=J+2 2360 %finish 2361 ->PI37B 2362 %finish 2363 %if Vlength=1 %thenstart 2364 I=integer(Com_Adict+J) 2365 %if -127<=I<=255 %thenstart 2366 %if Host#WWC %thenstart 2367 %if Host=PERQPNX %then J=J+1 %else J=J+3 2368 %finish 2369 ->PI37B 2370 %finish 2371 %finish 2372 %finish 2373 !* 2374 ! %if I=INT8 %and VMODE=INT2 %thenstart 2375 ! J=J+6 2376 ! ->PI37B 2377 ! %finish 2378 !* 2379 %if I=LOG4 %thenstart;! logical const - must be logical var 2380 %if VMODE=LOG1 %thenstart;! L*1 var 2381 %if Host#WWC %thenstart 2382 %if Host=PERQPNX %then J=J+1 %else J=J+3 2383 %finish 2384 ->PI37B 2385 %finish 2386 %if VMODE=LOG2 %thenstart;! L*2 init 2387 %if Host#WWC %thenstart 2388 %if Host=PERQPNX %then J=J+1 %else J=J+2 2389 %finish 2390 ->PI37B 2391 %finish 2392 ! %if VMODE=LOG8 %thenstart;! L*8 var 2393 ! I=1 2394 ! M=2 2395 ! ->PI37C;! use I*4 -> I*8 coercion 2396 ! %finish 2397 %finish 2398 !* 2399 %if I=HOLMODE %thenstart;! Hollerith - init any non-char 2400 %if VMODE=CHARMODE %then FAULT(285);! wrong type 2401 %if K>VLENGTH %thenstart 2402 Report Error(1,0,277);! Hollerith larger than item 2403 K=VLENGTH 2404 %finish 2405 Report Error(2,1,193);! Hollerith non-standard 2406 ->PI37D 2407 %finish 2408 !* 2409 %if I=CHARMODE %thenstart;! char 2410 Report Error(4,1,194);! char initialising non-char is non-standard 2411 ->PI37D 2412 %finish 2413 !* 2414 PI37E:ER=285;! const not compatible 2415 ->EXIT4P 2416 !* 2417 PI(38): 2418 2419 !*********************************************************************** 2420 !* AFTER / TERMINATING INITIALISATION DATA * 2421 !* UNWIND LIST AND REMOVE REDUNDANT ENTRIES * 2422 !*********************************************************************** 2423 %unless CRM3 = -1 %thenstart 2424 %if VLISTHEAD#0 %then ER=GET NEXT VARIABLE;! TO ENABLE CLOSURE OF IMP DO LISTS 2425 %if VLISTHEAD#0 %or VCOUNT#0 %then FAULT(287);! not enough consts 2426 %finish 2427 UNWIND: 2428 %while VLISTHEAD#0 %cycle 2429 FREE LIST CELL(VLISTHEAD,5) 2430 %repeat 2431 -> EXIT1 2432 !* 2433 PI(39): 2434 2435 !*********************************************************************** 2436 !* AFTER IMPLICIT LIST * 2437 !* P1 = 0 MODIFY FUNCTION AND PARAM TYPES IF NECESSARY * 2438 !* 1 IMPLICIT NONE * 2439 !*********************************************************************** 2440 Com_Curstatclass=1 2441 %if Com_Statordermode>1 %thenstart 2442 %if Com_Statordermode=2 %then ER=238 %else ER=236 2443 LFAULT(ER) 2444 %finish 2445 %if P1=1 %thenstart;! IMPLICIT NONE 2446 %cycle I='A',1,'Z' 2447 Imptype(I)=0 2448 %repeat 2449 ->Exit1 2450 %finish 2451 -> EXIT1 %unless 1 < Com_Subprogtype < 4; ! NECESSARY FOR FUNCTIONS AND SUBROUTINES ONLY 2452 PTR = Com_Subprogptr 2453 PP == record(Com_Adict+PTR) 2454 %if PP_X0&8 = 0 %thenstart; ! NOT EXPLICITLY TYPED 2455 J=Com_Anames+PP_Iden 2456 I = Imptype(Getbyte(J,1));! first char 2457 %if I&X'F'=5 %thenstart;! CHAR 2458 PP_LEN=I>>8 2459 I=5 2460 %finish 2461 PP_TYPE=I 2462 %finish 2463 PTR = PP_LINK2; ! LINK TO PARAMETER CHAIN 2464 %while PTR # 0 %cycle; ! THROUGH ALL PARAMETERS 2465 SS == record(Com_Adict+PTR) 2466 PTR = SS_INF0 2467 PP == record(Com_Adict+PTR) 2468 %if PP_X0&8 = 0 %thenstart 2469 J=Com_Anames+PP_Iden 2470 I = Imptype(Getbyte(J,1));! first char 2471 %if I&X'F'=5 %thenstart;! CHAR 2472 PP_LEN=I>>8 2473 I=5 2474 %finish 2475 PP_TYPE=I 2476 %finish 2477 PTR = SS_LINK1 2478 %repeat 2479 -> EXIT1 2480 !* 2481 PI(40): 2482 2483 !*********************************************************************** 2484 !* AFTER %PRINTD , DUMP CONTENTS OF DICTIONARY * 2485 !*********************************************************************** 2486 Dumpdict(p1) 2487 -> EXIT1 2488 !* 2489 PI(41): 2490 !*********************************************************************** 2491 !* Process DATA-implied-do * 2492 !*********************************************************************** 2493 Gstate=12 2494 I=DATA IMPLIED DO 2495 %if I=0 %then ->EXIT1 2496 %if I=1 %then ->EXIT4P 2497 %if I=2 %then ->EXIT4 2498 ->PI34ERR 2499 !* 2500 PI(42): 2501 2502 !*********************************************************************** 2503 !* AFTER FIRST OR ONLY LETTER IN IMPLICIT LIST ITEM * 2504 !*********************************************************************** 2505 CRM4 = Com_Nextch 2506 !* 2507 PI(43): 2508 2509 !*********************************************************************** 2510 !* AFTER SECOND LETTER IN IMPLICIT LIST ITEM * 2511 !*********************************************************************** 2512 %if TYPE(Com_Inp) = 1 %thenstart 2513 CRM5 = Com_Nextch 2514 %if CRM4 <= CRM5 %thenstart 2515 K=CRM8 2516 %if K=5 %then K=CHARLEN<<8!5;! CARRY CHARLEN 2517 %cycle I = CRM4,1,CRM5 2518 J=1<<(I-'A') 2519 %if CHARMASK&J#0 %thenstart 2520 %unless P=43 %and I=CRM4 %thenstart 2521 IDENTIFIER=TOSTRING(I) 2522 FAULT(274);! already specified 2523 %finish 2524 %finish 2525 CHARMASK=CHARMASK!J 2526 IMPTYPE(I) = K 2527 %repeat 2528 %finishelse LFAULT(273);! invalid alphabetic sequence 2529 %finishelse LFAULT(106);! invalid char 2530 Com_Inp = Com_Inp+1 2531 Com_Nextch = INPUT(Com_Inp) 2532 -> EXIT1 2533 !* 2534 PI(44): 2535 !*********************************************************************** 2536 !* FOLLOWING CLOSING ) OF AN EQUIVALENCE LIST * 2537 !* VLISTHEAD IS THE HEAD OF THE LIST OF ITEMS CREATED BY PI(31),PI(34) * 2538 !* VLISTTAIL POINTS TO THE LAST ENTRY ON THE LIST * 2539 !*********************************************************************** 2540 %if Com_Statordermode>2 %then ER=236 %and ->EXIT4 2541 Com_Statordermode=2 2542 Com_Inhibop4=1 2543 I=EQUIVALENCE 2544 %if I#0 %then ->UNWIND %else ->EXIT1 2545 !* 2546 PI(45): 2547 !*********************************************************************** 2548 !* FOLLOWING [POSSIBLE] LABEL IN DO * 2549 !* P1 = 0 conventional DO * 2550 !* 1 DO WHILE * 2551 !* RES = NESTLEVEL<<24!@ OF LABEL RECORD IN DICT * 2552 !*********************************************************************** 2553 %if Com_Doptr = 0 %then I = 1 %elsestart 2554 DOREC==record(Com_Adict+Com_Doptr) 2555 I = DOREC_LABEL>>24+1;! nesting level 2556 %finish 2557 %if Com_Pi21int=-1 %thenstart;! no label specified 2558 Res_W=I<<24 2559 %if P1=0 %then Gstate=9 %else Gstate=1 2560 ->Exit1 2561 %finish 2562 ER = 110;! INVALID STATEMENT NO. 2563 -> EXIT4 %unless 0 < Com_Pi21int <= 99999 2564 J=SETLAB(Com_Pi21int,PTR) 2565 LABREC==record(Com_Adict+PTR) 2566 %if LABREC_X0&3#0 %thenstart 2567 IFAULT(227,LABREC_Line);! label already set at line # 2568 %finishelsestart 2569 %if LABREC_X0&8#0 %then IFAULT(228,LABREC_LINK5);! already ref. as FORMAT label 2570 %finish 2571 RES_W = I<<24!(PTR>>DSCALE) 2572 %if P1=0 %then Gstate=9 %else Gstate=1 2573 -> EXIT1 2574 !* 2575 PI(46): 2576 !*********************************************************************** 2577 !* FOLLOWING COMPUTED GOTO INDEX,ASSIGNED IDEN, * 2578 !* DO CONTROLLED VARIABLE * 2579 !* IDENTIFIERS MUST BE SIMPLE VARIABLES * 2580 !*********************************************************************** 2581 ER=125;! INVALID CONST 2582 %if CTYP>0 %thenstart;! NOT AN IDENTIFIER 2583 ->EXIT4P %unless CTYP&7=1;! MUST BE A SIMPLE INTEGER 2584 %if 0EXIT1 2587 %finish 2588 PTR=SETCONREC(RES) 2589 P3=CNSTID;! CONST RECORD 2590 %finishelsestart;! AN IDENTIFIER 2591 !****** ENTRY FROM PI(55) TO PROCESS IDEN IN ASSIGNED GOTO 2592 L460: %if PP_CLASS=12 %then CBNAME 2593 %if P1=0 %then ER=126 %else ER=293 2594 %if PP_CLASS&X'1C'#0 %thenstart 2595 %unless PP_Class=11 %and Com_Subprogtype=2 %then ->EXIT4P {except cur fn} 2596 PP_X1=PP_X1!2 {fn assigned a value} 2597 %if PP_X1&1=0 %thenstart {this is first reference - no space allocated} 2598 PP_X1=PP_X1!1 2599 %if Com_Funresdisp=0 %thenstart 2600 Com_Funresdisp=Scalar Space(4,IIN) 2601 PP_IIN=IIN 2602 %finish 2603 PP_Addr4=Com_Funresdisp 2604 %finish 2605 %finish 2606 %if PP_Type=0 %then Notype 2607 J=PP_TYPE&7 2608 %if (P1=0 %and J#1) %or (P1=1 %and J>2) %then ->EXIT4P 2609 { %if PP_TYPE=X'41' %then ER=190 %and ->EXIT4P } {i*2 now allowed} 2610 ALLOC(PTR) 2611 J=PP_CLASS 2612 %if J=0 %thenstart;! LOCAL 2613 %if PP_X0&X'10'#0 %then P3=ASCALID %else P3=OSCALID 2614 %finishelsestart 2615 %if J=1 %thenstart;! PARAM 2616 P3=PSCALID;! DICT RECORD FOR SCALAR PARAM 2617 PP_X0=PP_X0!2 2618 PP_X1=PP_X1!2 2619 %finishelsestart;! COMMON 2620 P3=CSCALID;! DICT RECORD FOR COMMON SCALAR 2621 %finish 2622 %finish 2623 %finish 2624 Res_H0=PTR>>DSCALE; Res_Form=P3; Res_Mode=SETMODE(PP_TYPE&X'3F');! R.D. TO LOCATION 2625 ->EXIT1 2626 !* 2627 PI(47): 2628 !*********************************************************************** 2629 !* SET RES TO DESC TO SMALL INT VALUE P1 * 2630 !* USED TO SET DEFAULT DATA SET NUMS,DO INCREMENTS AND POSITION PARS * 2631 !*********************************************************************** 2632 Res_H0=P1; Res_Form=LIT; Res_Mode=INT4 2633 -> EXIT1 2634 !* 2635 PI(48): 2636 !*********************************************************************** 2637 !* PAUSE OR PAUSE ' ' * 2638 !* STOP OR STOP '' * 2639 !*********************************************************************** 2640 %if Ctyp&7=1 %thenstart 2641 Res_W=Conin(Com_Pi21int) 2642 %finishelsestart 2643 %unless Ctyp=CHARTYPE %then -> Synerr 2644 %finish 2645 -> Exit1 2646 !* 2647 PI(49): 2648 !*********************************************************************** 2649 !* FOLLOWING * I.E. LABEL PARAMETER TO SUBROUTINE * 2650 !* LABEL IN COMPUTED GOTO * 2651 !*********************************************************************** 2652 ER = 110;! STATEMENT NO. INVALID 2653 -> EXIT4 %unless 0 < Com_Pi21int <= 99999 2654 I=SETLAB(Com_Pi21int,PTR) 2655 LABREC==record(Com_Adict+PTR) 2656 RES=0 2657 %if LABREC_X0&8#0 %then IFAULT(228,LABREC_LINK5) 2658 LABREC_X1=LABREC_X1!1;! referenced 2659 I = PTR 2660 PTR=FREESP(3);! 3 words required for later use in forward ref. list 2661 SS==record(Com_Adict+PTR) 2662 SS_INF0=I 2663 %if CGOLAB = 0 %then HGOLAB = PTR %elsestart 2664 LABREC==record(Com_Adict+CGOLAB) 2665 LABREC_LINK1=PTR 2666 %finish 2667 CGOLAB = PTR 2668 -> EXIT1 2669 !* 2670 PI(50): 2671 !*********************************************************************** 2672 !* FOLLOWING PARAMLIST TO CALL (TO PROCESS ANY LABEL PARAMS) * 2673 !* LABEL LIST TO COMPUTED GOTO * 2674 !*********************************************************************** 2675 RES_W = HGOLAB 2676 -> EXIT1 2677 !* 2678 PI(51): 2679 !*********************************************************************** 2680 !* FOLLOWING CLOSING ) TO ARRAY ELEMENT SUBSCRIPT LIST IN EXP. * 2681 !*********************************************************************** 2682 CRM1 = 1; ! CRM1=0 IF ARRAY ELEMENT ON LHS OF ASSIGNMENT - SET BY PI(78) 2683 L511: SS==record(Com_Adict+Com_Fnlst) 2684 FREE LIST CELL(Com_Fnlst,5) 2685 I = SS_INF0 2686 NOTFLAG = I>>8 2687 GSTATE = I&X'FF' 2688 I = SS_INF3 2689 P1 = (I>>8)&X'FF'; ! NO. OF SUBSCRIPT EXPRESSIONS 2690 ER = 264; ! WRONG NO. OF SUBSCRIPTS 2691 %unless P1 = PCT %thenstart 2692 IDENTIFIER=STRING(Com_Anames+SS_INF4) 2693 ->EXIT4 2694 %finish 2695 PCT = I&X'FF' 2696 CTYP = I>>16 2697 -> L582 2698 !* 2699 PI(54): 2700 !*********************************************************************** 2701 !* REFERENCE TO SCALAR VARIABLE ON LHS OF ASSIGNMENT * 2702 !*********************************************************************** 2703 PI54: CRM1 = 0 2704 -> L533 2705 !* 2706 PI(126): ! in param list 2707 PI(53): 2708 !*********************************************************************** 2709 !* REFERENCE TO SCALAR IN EXPRESSION * 2710 !*********************************************************************** 2711 PI53: CRM1 = 1 2712 %if CTYP > 0 %thenstart; ! SCALAR IS A CONSTANT 2713 PI53A: P2 = 0 2714 %if CTYP&7=1 %or CTYP&7=4 %thenstart;! INTEGER OR LOGICAL 2715 %if Com_F77parm&X'08000000'#0 %thenstart;! -I2 option 2716 Ctyp=(Ctyp&7)!X'40' 2717 %finish 2718 %if 0<=Com_Pi21int<=X'7FFF' %thenstart 2719 RES_H0=Com_Pi21int 2720 RES_Form=LIT 2721 Res_Mode=SETMODE(CTYP&X'3F') 2722 ->L536 2723 %finish 2724 %finish 2725 RES_H0=SETCONREC(RES)>>DSCALE 2726 Res_Form=CNSTID 2727 %if PI21MODE=HOLMODE %thenstart 2728 Res_Mode=HOLMODE 2729 %finishelse Res_Mode=SETMODE(CTYP&X'3F') 2730 -> L536 2731 %finish 2732 L533: %if PP_CLASS = 12 %then CBNAME 2733 P2=PP_CLASS&X'1F' 2734 %if Ttyp=0 %and (P2&8)#8 %then Notype;! explicit type required and not set 2735 RES_H0=PTR>>DSCALE 2736 %if P2=0 %thenstart 2737 %if PP_X1=X'21' %thenstart;! stat fn param 2738 RES_H0=PP_ADDR4;! index 2739 RES_Form=VALTEMP 2740 %finishelsestart;! local scalar 2741 ALLOC(PTR) 2742 RES_Form=OSCALID 2743 %finish 2744 %finishelsestart 2745 %if P2<=2 %thenstart 2746 Alloc(Ptr) 2747 %if P2 = 2 %thenstart; ! common scalar 2748 RES_Form=CSCALID 2749 %finishelsestart; ! scalar param 2750 RES_Form=PSCALID 2751 %if CRM1=0 %or P=126 %then PP_X0=PP_X0!2;! MARK AS ASSIGNED TO 2752 %if CRM1=1 %or P=126 %then PP_X1=PP_X1!2;! mark as referenced 2753 %finish 2754 %finishelsestart 2755 %if P2=16 %thenstart;! constant name 2756 %if CRM1=0 %then ER=180 %and ->EXIT4P 2757 RES_W=PP_CONSTRES 2758 CTYP=PP_TYPE 2759 Com_Pi21int=RES_H0;! for compatability 2760 %if Res_Form=1 %and Res_Mode<=1 %then %C C Com_Pi21int=integer(Com_Adict+Com_Pi21int<PI53A 2763 %finish 2764 ER = 127; ! ILLEGAL USE OF SUBPROGRAM OR ARRAY NAME 2765 %if P2 = 11 %thenstart; !'CURRENT' SUBPROGRAM 2766 -> EXIT4 %unless Com_Subprogtype = 2; ! CAN ONLY BE VALID IF A FUNCTION 2767 RES_Form=PROCID 2768 CTYP = PP_TYPE 2769 %if CRM1=0 %thenstart;! fn assigned a value 2770 PP_X1=PP_X1!2 2771 QQ==record(Com_Adict+Com_Subprogptr) 2772 QQ_X1=QQ_X1!2 2773 %finish 2774 %if PP_X1&1 = 0 %thenstart; ! NOT YET USED 2775 PP_X1 = PP_X1!1 2776 %if Com_Funresdisp=0 %thenstart 2777 %if CTYP=5 %thenstart;! char fn 2778 Com_Funresdisp=Scalar Space(8,IIN) 2779 %finishelsestart 2780 Com_Funresdisp=Scalar Space(16,IIN) 2781 %finish 2782 %finishelsestart 2783 %if Target=IBM %thenstart 2784 IIN=SCALARS 2785 %finishelsestart 2786 IIN=Gla 2787 %finish 2788 %finish 2789 PP_IIN=IIN 2790 PP_ADDR4 = Com_Funresdisp 2791 %finish 2792 %finishelsestart;! must be external function or array name 2793 -> Exit4 %if P2 > 10; ! COMMON BLOCK OR STATEMENT FUNCTION 2794 %if P2 = 8 %thenstart; ! EXTERNAL SUBPROGRAM 2795 %if P=126 %thenstart;! in param list 2796 %if PP_X0&6=4 %thenstart 2797 Er=199;! this intrinsic fn cannot be a param 2798 ->Exit4 2799 %finish 2800 %finishelsestart 2801 -> Exit4 %unless PP_X0&7 = 0 2802 %finish 2803 { Setfun(Ptr) } 2804 %finishelsestart 2805 %unless P2=10 %then Alloc(Ptr);! unless namelist 2806 %finish 2807 -> Exit4 %unless Gstate = 1 %and Crm1 = 1 2808 %if 4<=P2<=6 %thenstart;! array name 2809 Res_Form=ARRID 2810 %finishelsestart 2811 Res_Form=PROCID 2812 %finish 2813 Res_Mode=Setmode(PP_Type&X'3F') 2814 Gstate = 15 2815 -> Exit1 2816 %finish 2817 %finish 2818 %finish 2819 Ctyp = PP_Type 2820 !* 2821 L532: RES_Mode=SETMODE(CTYP&X'3F') 2822 L536: I=RES_Mode 2823 L536A: %if MODETOST(I)&15 = LOGTYPE %thenstart; ! LOGICAL 2824 P1 = 1 2825 NOTFLAG = 2 2826 %finishelse P1 = 0 2827 ER = 130; ! INVALID EXPRESSION IN ARITHMETIC STATEMENT 2828 -> P53(GSTATE) 2829 P53(1): 2830 2831 P53(7): %if CRM1 = 0 %thenstart 2832 %if P1 = 0 %then GSTATE = 9 %else GSTATE = 1 2833 -> EXIT1 2834 %finish 2835 GSTATE = STATE(P1) 2836 -> EXIT1 2837 P53(2): -> EXIT4P %unless P1 = 0 2838 GSTATE = 3 2839 -> EXIT1 2840 P53(3): 2841 2842 P53(6): 2843 2844 P53(8): 2845 2846 P53(14): -> EXIT4P 2847 P53(4): 2848 2849 P53(5): %if P1#0 %then ->EXIT4P 2850 GSTATE = 6 2851 -> EXIT1 2852 P53(9): 2853 P53(10): %if P1#0 %then ->EXIT4P 2854 GSTATE = 11 2855 -> EXIT1 2856 P53(12): 2857 2858 P53(13): ER = 131 2859 -> EXIT4P %unless CTYP&15 <= 1 2860 GSTATE = 14 2861 -> EXIT1 2862 !* 2863 PI(55): 2864 !*********************************************************************** 2865 !* FOLLOWING GOTO * 2866 !* GOTO (ASSIGNED GOTO) * 2867 !* ASSIGN ... (P1=1) * 2868 !* ERR= * 2869 !* END= * 2870 !* LABEL IN ARITHMETIC IF * 2871 !*********************************************************************** 2872 %if CTYP<1 %thenstart;! ONLY POSS IN ASSIGNED GOTO 2873 %if Type(Com_Inp)#12 {newline} %thenstart 2874 %if Type(Com_Inp)=7 {comma} %then Com_Inp=Com_Inp+1 2875 %if Type(Com_Inp)#11 { '(' } %then ->Synerr 2876 %finish 2877 %while TYPE(Com_Inp)#12 %cycle 2878 Com_Inp=Com_Inp+1;! SKIP ASSIGNED LABEL LIST 2879 %repeat 2880 Com_Nextch=INPUT(Com_Inp) 2881 ->L460;! TO SET APPROPRIATE R.D. 2882 %finishelsestart;! INTEGER LABEL 2883 %if P1=1 %then Com_Inhibop4=1 2884 %unless 0 < Com_Pi21int <= 99999 %thenstart 2885 FAULT(110);! INVALID STATEMENT NO. 2886 Com_Pi21int=0 2887 %finish 2888 I=SETLAB(Com_Pi21int,PTR) 2889 LABREC==record(Com_Adict+PTR) 2890 CRM1=Com_Pi21int;! SAVE LABEL NO. FOR ARITH IF CHECK 2891 %if LABREC_X0=1 %then ER=225 %and ->EXIT4;! non-exec statement 2892 ER=228;! LABEL ALREADY USED AS A FORMAT LABEL 2893 Com_Pi21int=LABREC_LINE;! DECLARED LINE NO. (FOR ERROR MESSAGES) 2894 %if P1#1 %thenstart;! except ASSIGN 2895 I=1;! label in explicit GOTO 2896 ->EXIT4 %if LABREC_X0&8#0 2897 %finishelsestart 2898 I=2;! label in ASSIGN 2899 %if LABREC_X0&14=0 %then LABREC_X0=16;! may be exec or format 2900 %finish 2901 LABREC_X1=LABREC_X1!I 2902 Res_H0=PTR>>DSCALE; Res_Form=LABID; Res_Mode=INT4;! DICT RECORD FOR LABEL 2903 ->EXIT1 2904 %finish 2905 !* 2906 PI(56): 2907 !*********************************************************************** 2908 !* AFTER ( IN EXPRESSION * 2909 !* ALLOCATE EXTERNAL REFERENCE AND SET FN TYPE IF IMPLICITLY RECOGNISED* 2910 !* SET FNMK * 2911 !* RES= POINTER TO FN ENTRY IN DICT * 2912 !* PUSHDOWN ENTRY IN FNLST * 2913 !* RESET GSTATE * 2914 !*********************************************************************** 2915 %if PP_CLASS = 12 %then CBNAME 2916 %if CTYP>0 %then ER=130 %and ->EXIT4P 2917 I = PP_CLASS&X'1F';! to remove param array markers 2918 -> L561 %if 3 < I < 7; ! ARRAY 2919 -> L562 %if I = 13; ! STATEMENT FN. 2920 %if I = 8 %thenstart; ! EXTERNAL FUNCTION 2921 %if PP_X0&X'4'#0 %then ->L56B;! actually an intrinsic function 2922 ->L567 2923 %finish 2924 %if I = 9 %thenstart; ! EXTERNAL FUNCTION PARAM 2925 L569: ALLOC(PTR) 2926 PP_X0=PP_X0&X'F8';!CLEAR PARAM 'VALUE' MARKER IF SET 2927 -> L564 2928 %finish 2929 %if (0<=I<=2 %or I=16) %and PP_TYPE=5 %thenstart;! may be char substring 2930 %if PP_X1&X'F'#0 %or SCAN(':')#0 %thenstart 2931 PISW=12;! for PI69 switch 2932 ->PI53 2933 %finish 2934 %finish 2935 ER = 245; ! NOT AN ARRAY BEING SUBSCRIPTED 2936 -> EXIT4 %unless 0 <= I <= 1; ! LOCAL OR PARAMETER SCALAR (DEFAULT) 2937 -> EXIT4 %unless PP_X1&15 = 0; ! FAULT IF ALREADY USED AS A SCALAR 2938 PP_CLASS = I!8; ! SET FUNCTION BIT 2939 -> L569 %if I = 1; ! TO PROCESS AS FUNCTION PARAM 2940 !****** SEARCH INTRINSIC FUNCTION LIST 2941 L56B: I=FN HASH(HASH VALUE) 2942 J=ADDR(FN NAMES(0)) 2943 L56A: K=I&X'FFFF' 2944 %if Host=PERQPNX %or HOST=ACCENT %then K=K>>1;! index in words 2945 %if STRING(J+K)=IDENTIFIER %thenstart;! INTRINSIC FN 2946 L=I>>16&X'FF' 2947 I=FN DETAILS(L) 2948 K=FNSPECIALS(L) 2949 %if TARGET#IBM %thenstart 2950 %if K&X'8000'#0 %thenstart;! not there? 2951 %if K&X'800000'=0 %thenstart;! don't ignore the 'not there' bit 2952 !!! LFAULT(178);! comment - not an intrinsic fn 2953 ->L567 2954 %finish 2955 %finish 2956 %finish 2957 %if PP_X0&X'4'#0 %thenstart 2958 COPY(24,Com_Adict+PTR,0,Com_Adict+Com_Dptr,0) 2959 PTR=Dictspace(12) 2960 PP==record(Com_Adict+PTR) 2961 %finishelsestart 2962 L56D: %if Com_Dptr<=PTR+IDRECSIZE+XREFSIZE %thenstart;! RECOVER DICT SPACE 2963 !! Com_Dptr=PTR+W6;! KEEP MINIMAL RECORD 2964 LHEAD(HASH VALUE)=PP_LINK1;! REMOVE FROM IDEN LIST 2965 %finish 2966 %finish 2967 {following code only relevant if I8 and R8 defaults supported} 2968 ! J=I>>20&15;! modify parm requirements if necessary 2969 ! %if (J=1 %and INTEGER LENGTH=8) %or %C C ! (3<=J<=7 %and REAL LENGTH=8) %then I=I+X'00101000' 2971 ! J=I>>16&15;! modify fn result size if necessary 2972 ! %if (J=1 %and INTEGER LENGTH=8) %or %C C ! (3<=J<=7 %and REAL LENGTH=8) %then I=I+X'00010000' 2974 L56C: PP_LINK2=I;! FN DETAILS FOR SUBSEQUENT CHECKING/MODIFICATION 2975 J=I>>16&X'F';! FN MODE 2976 %if I#0 %then PP_TYPE=MODETOST(J);! N.B. WHAT IF ALREADY TYPED 2977 PP_X0=I>>2&3;! FN TYPE 2978 PP_X1=1 2979 ->L564 2980 %finishelsestart 2981 %if I>>24#0 %thenstart 2982 I=FNHASH(I>>24) 2983 ->L56A 2984 %finish 2985 %finish 2986 %cycle J=1,1,Numbitfns 2987 %if {Bitfnsperm(J)#0 %and} Bitfns(J)=Identifier %thenstart 2988 PP_Class=8 2989 I=Bitfnsdet(J) 2990 ->L56C 2991 %finish 2992 %repeat 2993 !* 2994 %if Target=Gould %thenstart 2995 %cycle J=1,1,Numgldfns 2996 %if Gldfns(J)=Identifier %thenstart 2997 PP_Class=8 2998 I=Gldfnsdet(J) 2999 ->L56D 3000 %finish 3001 %repeat 3002 %finish 3003 !* 3004 !****** STANDARD FUNCTION 3005 L567:{SETFUN(PTR) } 3006 L564: RES_W = PTR 3007 TTYP = PP_TYPE 3008 %if Ttyp=0 %then Notype;! explicit type required and not set 3009 PTR=NEW LIST CELL(Com_Fnlst,5) 3010 SS==record(Com_Adict+PTR) 3011 SS_INF2 = (PP_X0&7+1)<<8!TTYP; ! FNMK 1 FOR EXT FN, >1 FOR INTRINSIC AND STANDARD FNS 3012 SS_INF3 = PCT; ! SAVE INTRINSIC CODE FOR PARAMETER TYPE AND COUNT 3013 FNMK = 0 3014 PISW = 2;! for PI69 switch 3015 I = 1 3016 PP_X1=(PP_X1&X'CF')!X'10' 3017 -> PI56EXIT 3018 !****** ARRAY ELEMENT REFERENCE 3019 L561: ALLOC(PTR) 3020 TTYP = PP_TYPE 3021 %if Ttyp=0 %then Notype;! explicit type required and not set 3022 Res_H0=PTR>>DSCALE; Res_Form=ARRID; Res_Mode=SETMODE(TTYP&X'3F');! DICT RECORD FOR ARRAY 3023 DVREC == record(Com_Adict+PP_ADDR4); ! DOPE VECTOR IN DICT 3024 PTR=NEW LIST CELL(Com_Fnlst,5) 3025 SS==record(Com_Adict+PTR) 3026 SS_INF2 = PP_ADDR4; ! DOPE VECTOR IN DICT 3027 SS_INF3 = TTYP<<16!DVREC_DIMS<<8!PCT 3028 SS_INF4 = PP_IDEN;! FOR ERROR MESSAGES 3029 PISW = 6;! for PI69 switch 3030 I = 12;! RESTRICT TO INTEGER SUBSCRIPTS 3031 -> PI56EXIT 3032 !****** STATEMENT FN REFERENCE 3033 L562: %if Ptr=Statfnrec %thenstart 3034 Er=140 3035 ->Exit4p 3036 %finish 3037 {ER = 135; ! NESTED STATEMENT FUNCTION REFERENCE} 3038 {-> EXIT4P %if PP_X1&1 # 0 this restriction is no longer necessary 26/11/85} 3039 {ER = 136; ! INVALID ARRAY SUBSCRIPT IN IMPLIED DO} 3040 {-> EXIT4P %if DOIOP > 0 restriction lifted 03/11/86 } 3041 PP_X1 = PP_X1!1; ! WILL FAULT ANY STATEMENT FN REFERENCE IN PARAMS 3042 %if Ttyp=0 %then Notype;! explicit type required and not set 3043 RES_W = PTR 3044 PTR=NEW LIST CELL(Com_Fnlst,5) 3045 SS==record(Com_Adict+PTR) 3046 SS_INF2 = RES_W 3047 SS_INF3 = PCT 3048 I = 1 3049 PISW=10;! for PI69 switch 3050 PI56EXIT: 3051 SS_INF0=NOTFLAG<<8!GSTATE 3052 NOTFLAG = 0 3053 GSTATE = I 3054 PCT = 0 3055 -> EXIT1 3056 !* 3057 PI(57): 3058 !*********************************************************************** 3059 !* AFTER PARAMETER IN EXTERNAL FN/ROUTINE CALL * 3060 !*********************************************************************** 3061 SS == record(Com_Adict+Com_Fnlst) 3062 RES_H0=FNMK; RES_H1=SS_INF3&X'FF00'!PCT;! FNMK,PARAM TYPE,PCT 3063 PCT = PCT+1 3064 %if Com_Nextch = ',' %then FNMK = 0;! NOT LAST PARAM 3065 GSTATE = 1 3066 NOTFLAG = 0 3067 -> EXIT1 3068 !* 3069 PI(58): 3070 !*********************************************************************** 3071 !* FOLLOWING CLOSING ) OF PARAMETER LIST TO SUBPROGRAM CALL * 3072 !*********************************************************************** 3073 CRM1 = 1 3074 SS==record(Com_Adict+Com_Fnlst) 3075 FREE LIST CELL(Com_Fnlst,5) 3076 I = SS_INF0 3077 NOTFLAG = I>>8 3078 GSTATE = I&X'FF' 3079 I = SS_INF2 3080 %if FNMK = 0 %or FNMK = 4 %then FNMK = I>>8 3081 CTYP = I&X'FF' 3082 PCT = SS_INF3&X'FF' 3083 RES_W=PCT 3084 !***** merge with PI(51) - following array element reference 3085 L582: %if CTYP&7 = 4 %thenstart; ! LOGICAL 3086 P1 = 1 3087 NOTFLAG = 2 3088 %finishelsestart 3089 P1 = 0 3090 %finish 3091 ER = 130;! INVALID EXPRESSION 3092 -> P53(GSTATE) 3093 !* 3094 PI(59): 3095 !*********************************************************************** 3096 !* STATE TRANSITION TO CHECK VALIDITY OF SEQUENCE OF LOGICAL AND * 3097 !* ARITHMETIC OPERANDS AND OPERATORS * 3098 !*********************************************************************** 3099 ER = 132 3100 %if P1=8 %thenstart;! reject char as DO param 3101 %if RES_MODE=CHARMODE %then ER=296 %and ->EXIT4P 3102 P1=7 3103 %finish 3104 -> P59(GSTATE) 3105 P59(1): GSTATE = STATE(P1) 3106 -> EXIT4P %if GSTATE = 0 3107 %if P1 = 5 %then NOTFLAG = 1 3108 -> L591 3109 P59(2): 3110 3111 P59(5): 3112 3113 P59(10): 3114 3115 P59(13): -> EXIT4P 3116 P59(3): -> EXIT4P %if 7 > P1 > 3 3117 %if P1 = 7 %thenstart 3118 %if NOTFLAG#0 %then ->EXIT4P 3119 -> L591 3120 %finish 3121 GSTATE = STATE(P1+5) 3122 %if P1 = 3 %then NOTFLAG = 2 3123 -> EXIT1 3124 P59(4): -> EXIT4P %unless P1 = 6 3125 GSTATE = 5 3126 -> EXIT1 3127 P59(6): GSTATE = STATE(P1+7) 3128 -> EXIT4P %if GSTATE = 0 3129 -> L591 3130 P59(7): -> EXIT4P %unless P1 = 6 3131 GSTATE = 2 3132 -> EXIT1 3133 P59(8): %unless P1 = 3 %or P1 = 4 %or P1 = 7 %then ->EXIT4P 3134 GSTATE = 1 3135 -> L591 3136 P59(9): 3137 3138 P59(12): -> EXIT4P %unless P1 = 6 3139 GSTATE = GSTATE+1 3140 -> EXIT1 3141 P59(11): 3142 3143 P59(14): -> EXIT4P %if 2 < P1 < 7 3144 GSTATE = GSTATE-1 %unless P1=7 3145 -> L591 3146 P59(15): -> EXIT4P %unless P1 = 7 3147 L591: -> EXIT1 %unless P1 = 7 3148 RES_W = NOTFLAG 3149 NOTFLAG = 0 3150 -> EXIT1 3151 !* 3152 PI(60): 3153 !*********************************************************************** 3154 !* RES = COMPARATOR CODE FOLLOWING > SET BY READLINE * 3155 !* 1 .LT. 4 .GT. * 3156 !* 2 .LE. 5 .GT. * 3157 !* 3 .EQ. 6 .NE. * 3158 !*********************************************************************** 3159 RES_W = INPUT(Com_Inp)&15 3160 ER = 106;! INVALID CHAR 3161 -> EXIT4P %unless TYPE(Com_Inp) = 6;! CONFIRMS THAT ENTRY IS COMPARATOR CODE 3162 L601: Com_Inp = Com_Inp+1 3163 L602: Com_Nextch = INPUT(Com_Inp) 3164 -> EXIT1 3165 !* 3166 PI(61): 3167 !*********************************************************************** 3168 !* FOLLOWING ( INTRODUCING A BRACKETED EXPRESSION * 3169 !*********************************************************************** 3170 PTR=NEW LIST CELL(LL1,2) 3171 SS==record(Com_Adict+PTR) 3172 SS_INF0 = NOTFLAG<<8!GSTATE 3173 %if GSTATE = 1 %or GSTATE = 7 %then GSTATE = 1 %elsestart 3174 %if GSTATE > 10 %then GSTATE = 12 %else GSTATE = 9 3175 %finish 3176 -> EXIT1 3177 !* 3178 PI(62): 3179 !*********************************************************************** 3180 !* FOLLOWING ) TERMINATING A BRACKETED EXPRESSION * 3181 !*********************************************************************** 3182 SS==record(Com_Adict+LL1) 3183 FREE LIST CELL(LL1,2) 3184 NOTFLAG = SS_INF0>>8 3185 I = SS_INF0&X'FF' 3186 %if I>8 %thenstart 3187 %if I=11 %then GSTATE=11 3188 ->EXIT1 3189 %finish 3190 %if 5 < GSTATE < 11 %then NOTFLAG = 2 3191 -> EXIT1 %if GSTATE < 11 3192 %if I=2 %or I=3 %or NOTFLAG=0 %then GSTATE=3 %else GSTATE=6 3193 -> EXIT1 3194 !* 3195 PI(63): 3196 !*********************************************************************** 3197 !* FOLLOWING IF ( ) TO DETERMINE WHETHER ARITH OR LOG. * 3198 !*********************************************************************** 3199 ICOMP = ICOMP+2 3200 %if Type(Com_Inp)=12 {newline} %then ->Synerr 3201 %if RES_W # 0 %thenstart 3202 Com_Statement=3;! logical IF (required by EMAS ITS) 3203 -> EXIT2 3204 %finish 3205 ! TEST COMPLEX 3206 ICOMP = ICOMP+2 3207 -> EXIT1 3208 !* 3209 PI(64): 3210 !*********************************************************************** 3211 !* FOLLOWING RECOGNITION OF SUBSCRIPT TO ARRAY ELEMENT * 3212 !*********************************************************************** 3213 PCT = PCT+1 3214 RES_W=PCT 3215 GSTATE = 12;! RESTRICT TO INTEGER SUBSCRIPTS 3216 -> EXIT1 3217 !* 3218 PI(65): 3219 !*********************************************************************** 3220 !* FOLLOWING ( ON LHS OF ASSIGNMENT * 3221 !* DETERMINE WHETHER ARRAY ELEMENT OR STATEMENT FN DEFINITION * 3222 !*********************************************************************** 3223 %if PP_CLASS = 12 %then CBNAME 3224 %unless PP_Class=8 %then PP_X0=PP_X0!2;! to indicate assigned to 3225 {unless classed as fn due to previous error} 3226 I = PP_CLASS&X'1F';! to remove param array markers 3227 ER = 245;! IDEN IS NOT AN ARRAY NAME 3228 %if (0<=I<=2 %or I=11) %and PP_TYPE=5 %thenstart;! may be char substring 3229 PISW=8 3230 %if SCAN(':')#0 %then ->PI54 3231 %finish 3232 %if I # 0 %thenstart 3233 -> EXIT4 %unless 4 <= I <= 6; ! I.E. ONLY LOCAL PARAMETER OR COMMON ARRAY ALLOWED HERE 3234 -> L561; ! TO PROCESS IT 3235 %finishelsestart; ! CAN ONLY BE A STATEMENT FN DEFINITION 3236 -> EXIT4 %unless PP_X1 = 0 3237 STATFN==record(Com_Adict+PTR) 3238 STATFNREC=PTR 3239 STATFN_CLASS = 13 3240 J=NUMBYTES(STATFN_TYPE>>4) 3241 %if STATFN_TYPE&15=3 %then J=J+J 3242 I = (J+3)&X'FFFFFC';! SPACE FOR RESULT 3243 %if STATFN_TYPE=5 %then I=8;! for descriptor 3244 J=Generate(Triads,Output,Nexttriad,0,-3,0,Comad);! to register start of sf 3245 RES_H0=Scalar Space(I,IIN) 3246 RES_FORM=GLALIT 3247 RES_MODE=SETMODE(STATFN_TYPE&X'3F') 3248 STATFN_LINK2=RES_W 3249 RES_W = PTR 3250 QQ == record(Com_Adict+Com_Subprogptr) 3251 PCT = 0 3252 GSTATE = 1 3253 PISW=2;! for PI84 switch 3254 -> EXIT1 3255 %finish 3256 !* 3257 PI(66): 3258 !*********************************************************************** 3259 !* FOLLOWING CALL * 3260 !*********************************************************************** 3261 I = PP_CLASS 3262 RES_W = PTR 3263 -> L661 %if I = 8 %or I = 9; ! SUBPROGRAM(MAY BE AS PARAMETER) 3264 %if I=11 %then ER=244 %and ->EXIT4 3265 ER = 128; ! INVALID SUBPROGRAM NAME 3266 -> EXIT4 %unless 0 <= I <= 1; ! ONLY SETTING PERMITTED IS SCALAR PARAMETER 3267 -> EXIT4 %unless PP_X1 = 0; ! ALREADY USED AS SCALAR 3268 I = I!8; ! SET 'SUBPROGRAM' MARKER 3269 PP_CLASS = I 3270 L661: %if I # 8 %then ALLOC(PTR) {%else SETFUN(PTR)}; ! SET REFERENCE OR ALLOCATE PARAMETER SPACE 3271 PP==record(Com_Adict+PTR) 3272 PP_X1=(PP_X1&X'CF')!X'20' 3273 PP_X0=PP_X0&X'F8';! CLEAR PARAM 'VALUE' MARKER IF SET 3274 -> EXIT1 3275 !* 3276 PI(67): 3277 !*********************************************************************** 3278 !* FOLLOWING IN EXTERNAL LIST * 3279 !*********************************************************************** 3280 I=Com_Externals 3281 %while I#0 %cycle 3282 SS==record(Com_Adict+I) 3283 %if PTR=SS_INF0 %then FAULT(181) 3284 I=SS_LINK1 3285 %repeat 3286 %if PP_X0&X'40'#0 %then FAULT(179) %and ->EXIT1;! already in an INTRINSIC statement 3287 %if CRM8=1 %then PP_X0=PP_X0!X'80' 3288 I=PP_CLASS 3289 -> EXIT1 %if 8 <= I <= 9; ! ALREADY MARKED AS A SUBPROGRAM 3290 ER = 128; ! ILLEGAL IDENTIFIER IN AN EXTERNAL LIST 3291 -> EXIT4 %unless I&14 = 0; ! ONLY VALID SETTING IS 'PARAM' 3292 -> EXIT4 %if PP_X1 # 0 3293 PP_CLASS=PP_CLASS!8 3294 %if CRM8=3 %thenstart;! INTRINSIC 3295 I=FNHASH(HASH VALUE) 3296 J=ADDR(FN NAMES(0)) 3297 L67A: K=I&X'FFFF' 3298 %if HOST=PERQPNX %or HOST=ACCENT %thenstart 3299 K=K>>1;! index in words 3300 %finish 3301 %if STRING(J+K)=IDENTIFIER %thenstart 3302 K=I>>16&X'FF' 3303 L=FN SPECIALS(K) 3304 %if L&X'80C000'=X'4000' %thenstart;! valid in list 3305 PP_X0=PP_X0!4;! intrinsic marker 3306 FN SPECIALS(K)=L!X'400000' 3307 %if L&X'2000'#0 %then PP_X0=PP_X0!2 3308 PP_LINK2=FN DETAILS(K) 3309 PP_INF3=FN SPECIALS(K) 3310 ->EXIT1 3311 %finish 3312 %finishelsestart 3313 %if I>>24#0 %thenstart 3314 I=FNHASH(I>>24) 3315 ->L67A 3316 %finish 3317 %finish 3318 %if Com_Allowvax=YES %thenstart 3319 %cycle I=1,1,Numbitfns 3320 %if Bitfns(I)=Identifier %thenstart 3321 Lfault(178);! warn about non-standard fn 3322 Bitfnsperm(I)=1 3323 PP_X0=PP_X0!4;! intrinsic marker 3324 PP_Link2=Bitfnsdet(I) 3325 PP_Inf3=0 3326 ->Exit1 3327 %finish 3328 %repeat 3329 %finish 3330 LFAULT(279);! not a valid intrinsic name 3331 ->EXIT1 3332 %finish 3333 I=PTR 3334 PTR=NEW LIST CELL(Com_Externals,2) 3335 SS==record(Com_Adict+PTR) 3336 SS_INF0=I 3337 -> EXIT1 3338 !* 3339 PI(68): 3340 !*********************************************************************** 3341 !* SYNTAX CHECK AFTER , IN DEFN OF (PART OF DEFN) * 3342 !*********************************************************************** 3343 ER = 100;! SYNTAX 3344 %if Com_Nextch = NL %then -> EXIT4P %else -> EXIT1 3345 !* 3346 PI(69): 3347 !*********************************************************************** 3348 !* following ( switches to appropriate syntax * 3349 !* PISW has been set by PI(56) * 3350 !* 2 external function * 3351 !* 6 array element * 3352 !* 10 statement function * 3353 !* 12 possible character scalar substring * 3354 !*********************************************************************** 3355 ICOMP = ICOMP+PISW 3356 ->EXIT2 %unless PISW=12 3357 -> EXIT1; ! character scalar substring 3358 !* 3359 PI(70): 3360 !*********************************************************************** 3361 !* FOLLOWING SUBPROGRAM STATEMENT * 3362 !* P1 = 1 PROGRAM * 3363 !* 2 FUNCTION * 3364 !* 3 SUBROUTINE * 3365 !* 4 ENTRY * 3366 !* 5 BLOCKDATA * 3367 !*********************************************************************** 3368 PI70: Com_Curstatclass=1 3369 %unless P1=4 %thenstart 3370 Com_Statordermode=1 3371 DATAHEAD=0 3372 DATALAST=0 3373 ASS CHECKLIST=0 3374 %finish 3375 I=NEW SUBPROGRAM(PTR,P1,CTYP,ER) 3376 %if Com_Subprogtype#5 %and I#4 %thenstart 3377 J=Generate(Triads,Output,Nexttriad,0,-2,Com_Rescom1,Comad);! register private label 3378 %finish 3379 -> PIEXIT(I) 3380 !* 3381 PI(72): 3382 !*********************************************************************** 3383 !* FOLLOWING IN * 3384 !*********************************************************************** 3385 %if Com_Nextch='=' %thenstart;! controlled variable of implied-DO loop 3386 %if PP_CLASS&X'1C'#0 %or PP_TYPE&X'F'>2 %thenstart 3387 ER=293;! invalid iden 3388 ->EXIT4P 3389 %finish 3390 CRM4=RES_W 3391 RES_W=0;! will avoid attempt to process as I/O list item 3392 ->EXIT1 3393 %finish 3394 ! PP==record(Com_Adict+RES_H0<= ARRID %then ->EXIT1;! UNLESS SPECIAL IDEN 3398 ! -> EXIT4 %unless PP_CLASS&12 = 4;! MUST BE AN ARRAY NAME 3399 ! RES_MODE = SETMODE(PP_TYPE&X'3F') 3400 -> EXIT1 3401 !* 3402 PI(73): 3403 !*********************************************************************** 3404 !* FOLLOWING ( IN IOLIST, I.E. START OF IMPLIED DO * 3405 !*********************************************************************** 3406 %if SCAN(')')=1 %thenstart;! not start of implied DO 3407 Com_Inp=Com_Inp-1 3408 Com_Nextch=INPUT(Com_Inp) 3409 ICOMP=ICOMP-4 3410 ->L2 3411 %finish 3412 DOIOP = DOIOP+1 3413 -> EXIT1 3414 !* 3415 PI(74): 3416 !*********************************************************************** 3417 !* FOLLOWING * IN FORMAL PARAMETER LIST * 3418 !*********************************************************************** 3419 ER = 243; ! LABEL PARAMETER NOT ALLOWED IN FUNCTION 3420 -> EXIT4P %if Com_Subprogtype = 2 3421 -> EXIT1 3422 !* 3423 PI(75): 3424 !*********************************************************************** 3425 !* AFTER 'VALUE' FORMAL PARAMETER NAME * 3426 !*********************************************************************** 3427 ER=129 3428 -> PIEXIT(FORMAL PARAMETER(PTR,0,CTYP)) 3429 !* 3430 PI(76): 3431 !*********************************************************************** 3432 !* AFTER = IN IMPLIED DO * 3433 !*********************************************************************** 3434 DOIOP = DOIOP-1 3435 RES_W=CRM4 3436 CHECK DO INDEX(RES_W,Com_Doptr) 3437 -> EXIT1 3438 !* 3439 PI(77): 3440 !*********************************************************************** 3441 !* FOLLOWING IF ( ) WHEN FOLLOWS * 3442 !*********************************************************************** 3443 Com_Statement=3;! logical IF (required by EMAS ITS) 3444 ER = 133 3445 -> EXIT4 %if RES_W = 0 3446 -> EXIT1 3447 !* 3448 PI(78): 3449 !*********************************************************************** 3450 !* FOLLOWING CLOSING ) IN SUBSCRIPT LIST TO ARRAY ELEMENT ON * 3451 !* LHS OF ASSIGNMENT, ALSO IN I/0 LIST * 3452 !*********************************************************************** 3453 CRM1 = 0 3454 CRM10 = 0;! WILL TRIGGER FAULT IF USED AS CONTROL VAR IN IMPLIED DO 3455 -> L511 3456 !* 3457 PI(79): 3458 !*********************************************************************** 3459 !* CODE OR CODEX TO CONTROL LISTING OF COMPILED CODE * 3460 !* CODE0 CLEARS BUFFER THEN SETS FLAG FOR CODE LISTING * 3461 !*********************************************************************** 3462 Com_Curstatclass=1 3463 Com_Listcode=0 3464 Com_Ptrace=0 3465 %if Com_Nextch = NL %then Com_Listcode=1 %and ->EXIT1 3466 !!# %if Com_Nextch='0' %then PUSHBUFFER(1) %and Com_Listcode=1 3467 %if '1'<=Com_Nextch<='2' %then Com_Ptrace=Com_Nextch&3 3468 -> L601;! TO SKIP CHAR 3469 !* 3470 PI(80): 3471 !*********************************************************************** 3472 !* FOLLOWING CLOSING ) TO PARAMETER LIST ON LHS OF STATEMENT FN * 3473 !* DEFINITION * 3474 !*********************************************************************** 3475 Com_Curstatclass=1 3476 %if Com_Statordermode>3 %then LFAULT(237) 3477 Com_Statordermode=3 3478 STATFN_DISP = PCT 3479 PCT = 0 3480 Com_Sfmk = STATFNREC 3481 TTYP = STATFN_TYPE 3482 %if TTYP&4 = 4 %then GSTATE = 1 %else GSTATE = 9 3483 -> EXIT1 3484 !* 3485 PI(81): 3486 !*********************************************************************** 3487 !* AFTER STATEMENT FUNCTION FORMAL PARAM * 3488 !* CREATE NEW DICT ENTRY * 3489 !*********************************************************************** 3490 I=Com_Sfptr 3491 PTR=NEW LIST CELL(Com_Sfptr,8) 3492 QQ==record(Com_Adict+PTR) 3493 ZERO(Com_Adict+PTR,32) 3494 QQ_LINK1=I 3495 QQ_IDEN=PP_IDEN 3496 TTYP=PP_TYPE 3497 QQ_TYPE=TTYP 3498 QQ_X1=X'21';! AREA CODE(I.E. ON STACK), ALLOCATED 3499 QQ_INF3=STATFNREC 3500 PCT = PCT+1 3501 QQ_ADDR4=PCT 3502 -> EXIT1 3503 !* 3504 PI(82): 3505 !*********************************************************************** 3506 !* FOLLOWING CLOSING ) IN PARAMETER LIST TO STATEMENT FN REFERENCE * 3507 !*********************************************************************** 3508 SS==record(Com_Adict+Com_Fnlst) 3509 FREE LIST CELL(Com_Fnlst,5) 3510 QQ == record(SS_INF2+Com_Adict) 3511 QQ_X1 = QQ_X1&X'FE'; ! CLEAR MARKER WHICH INHIBITED NESTED STAT FN CALLS 3512 ER = 139; ! WRONG NO OF PARAMETERS IN STAT FN REFERENCE 3513 -> EXIT4 %unless QQ_DISP = PCT 3514 CTYP = QQ_TYPE 3515 CRM1 = 1 3516 NOTFLAG = SS_INF0>>8 3517 GSTATE = SS_INF0&X'FF' 3518 FNMK = 1 3519 PCT = SS_INF3&X'FF' 3520 -> L582 3521 !* 3522 PI(83): 3523 !*********************************************************************** 3524 !* FOLLOWING RECOGNITION OF A PARAMETER IN A STATEMENT FN. REFERENCE * 3525 !*********************************************************************** 3526 ER = 139; !WRONG NO. OF PARAMETERS 3527 -> EXIT4 %if GSTATE = 15 3528 GSTATE = 1 3529 SS == record(Com_Adict+Com_Fnlst) 3530 QQ==record(Com_Adict+SS_INF2);! STATEMENT FN RECORD 3531 J=QQ_Link3<EXIT4 3542 %finish 3543 J=SS_LINK1 3544 SS == record(Com_Adict+J) 3545 %repeat 3546 %finish 3547 PCT = PCT+1 3548 RES_W = J 3549 -> EXIT1 3550 !* 3551 PI(84): 3552 !*********************************************************************** 3553 !* SWITCH FOLLOWING ( ON LHS OF ASSIGNMENT TO PROCESS A * 3554 !* STATEMENT FN DEFINITION OR ARRAY ELEMENT REFERENCE * 3555 !*********************************************************************** 3556 ICOMP = ICOMP+PISW 3557 -> EXIT2 %unless PISW=8;! unless character substring 3558 -> EXIT1 3559 !* 3560 PI(85): 3561 !*********************************************************************** 3562 !* NAMELIST processing * 3563 !*********************************************************************** 3564 %if P1=0 %thenstart;! new namelist name being defined 3565 namelistuse=1;! to ensure params are copied in 3566 Com_Curstatclass=1 3567 %if Com_Statordermode>2 %then Lfault(236) 3568 Com_Statordermode=2 3569 Nmlptr=Ptr 3570 Nmlrec==record(Com_Adict+Nmlptr) 3571 Nmlrec_Class=10 3572 Nmlrec_Link3=0 3573 Nmllink=addr(Nmlrec_Last) 3574 ->Exit1 3575 %finish 3576 %if P1=1 %thenstart;! add entry to chain 3577 J=0 3578 I=New List Cell(J,2) 3579 SS==record(Com_Adict+I) 3580 SS_Inf0=Ptr;! item in namelist list 3581 SS_Link1=0 ;! end of chain 3582 integer(Nmllink)=I 3583 Nmllink=addr(SS_Link1) 3584 ->Exit1 3585 %finish 3586 -> Exit1 3587 !* 3588 PI(87): 3589 !*********************************************************************** 3590 !* RESET GSTATE AFTER SCALAR OR ARRAY ELEMENT ITEM IN * 3591 !*********************************************************************** 3592 GSTATE=1 3593 ->EXIT1 3594 !* 3595 PI(88): 3596 !*********************************************************************** 3597 !* FORMAT * 3598 !* PROCESS TEXT AND STORE IN GLA * 3599 !*********************************************************************** 3600 Com_Curstatclass=1 3601 %if Com_Lab = 0 %thenstart 3602 ER = 149;! NO LABEL ON FORMAT STATEMENT 3603 -> EXIT4 3604 %finish 3605 ER=GENFMT(INPUT,TYPE,IDENTIFIER) 3606 %if ER # 0 %then -> EXIT4 3607 Com_Nextch = INPUT(Com_Inp) 3608 -> EXIT1 3609 !* 3610 PI(89): 3611 !*********************************************************************** 3612 !* AVOID UNNECESSARY SEARCH IF NEXTCH IS NEWLINE * 3613 !* USED AFTER ,RETURN,PAUSE,STOP * 3614 !*********************************************************************** 3615 PI89: %if Com_Nextch = NL %thenstart;! SKIP ALTERNATIVE SWITCH 3616 ICOMP = ICOMP+4 3617 -> EXIT1 3618 %finish 3619 ICOMP = ICOMP+2;! SWITCH TO ALTERNATIVE DEFN 3620 -> EXIT2 3621 !* 3622 PI(90): 3623 !*********************************************************************** 3624 !* CONTROL * 3625 !*********************************************************************** 3626 Com_Control=Com_Pi21int 3627 -> EXIT1 3628 !* 3629 PI(92): 3630 !*********************************************************************** 3631 !* CHECK WHETHER CURRENT SUBSCRIPT IS SCALAR (DURING ) * 3632 !* RES = 1 SCALAR * 3633 !* 0 EXPRESSION (REQUIRING CO-ROUTINE IF IN IMPLIED DO OR READ * 3634 !*********************************************************************** 3635 K = Com_Inp 3636 ER = 100;! SYNTAX 3637 GSTATE = 12 3638 %while TYPE(K)<4 %cycle;! THROUGH ALPHANUMERICS 3639 K = K+1 3640 %repeat 3641 -> EXIT4 %if TYPE(K) = 12;! END OF STATEMENT 3642 %if TYPE(K)=7 %then RES_W=1 %and -> EXIT1;! , or ) 3643 RES_W=0;! C0-ROUTINE ALL SUBSCRIPT EXPRESSIONS 3644 -> EXIT1 3645 !* 3646 PI(93): 3647 !*********************************************************************** 3648 !* FOLLOWING CLOSING ) IN I/0 LIST - REDUNDANT BRACKET PAIR * 3649 !*********************************************************************** 3650 DOIOP = DOIOP-1 3651 -> EXIT1 3652 !* 3653 PI(98): 3654 !*********************************************************************** 3655 !* %MONITOR * 3656 !*********************************************************************** 3657 %MONITOR 3658 %STOP 3659 -> EXIT1 3660 !* 3661 PI(99): 3662 !*********************************************************************** 3663 !* FOLLOWING , * 3664 !* SET FREE FORMAT MARKER * 3665 !* BACKSPACE OVER , FOR PROCESSING * 3666 !*********************************************************************** 3667 Com_Inp = Com_Inp-1 3668 -> L602;! RESET Com_Nextch 3669 !* 3670 PI(102): 3671 !*********************************************************************** 3672 !* Following = in PARAMETER statement * 3673 !* Check that that no conflict exists * 3674 !*********************************************************************** 3675 Com_Curstatclass=1 3676 %if Com_Statordermode>2 %then LFAULT(236) 3677 GSTATE=1 3678 I=PP_CLASS 3679 %if I=16 %thenstart 3680 PI102A: ER=240;! already a PARAMETER 3681 ->EXIT4P 3682 %finish 3683 %if I&4#0 %thenstart;! AN ARRAY 3684 ERRIDEN="as an array" 3685 PI102B: ER=241 3686 ->EXIT4P 3687 %finish 3688 %if I&3#0 %thenstart 3689 ERRIDEN="as an argument" 3690 ->PI102B 3691 %finish 3692 %if I>7 %thenstart 3693 ERRIDEN="as an external name" 3694 ->PI102B 3695 %finish 3696 %if PP_X1&X'80'#0 %thenstart 3697 ERRIDEN="in an EQUIVALENCE statement" 3698 ->PI102B 3699 %finish 3700 PP_CLASS=16;! constant name 3701 PP_LINK2=Com_Scptr 3702 PP_CONSTRES=0 3703 PP_ADDR4=0 3704 PP_X1=1 3705 RES_W=PTR 3706 ->EXIT1 3707 !* 3708 PI(103): 3709 !*********************************************************************** 3710 !* Set RES for constant or 'restricted' identifier * 3711 !* Check for permitted content as determined by CEXMODE * 3712 !* CEXMODE = 0 any constant expression * 3713 !* 1 integer constant expression * 3714 !* 2 integer expression in DATA implied-D0 subscript * 3715 !* 3 integer dimension expression * 3716 !* P1 = 0 after var or non-complex const * 3717 !* 1 after complex const * 3718 !*********************************************************************** 3719 %if CEXMODE=2 %thenstart;! DATA implied-DO subscript 3720 %if CTYP>0 %thenstart;! constant 3721 Res_W=Com_Pi21int 3722 %if PI21MODE<=1 %then ->PI103C;! integer value 3723 ER=253;! subscript must be integer 3724 ->EXIT4P 3725 PI103C: Ctyp=1;! TYPE INT 3726 PI103D: CRM1=1 3727 I=1 3728 ->L536A 3729 %finishelsestart;! iden - note it 3730 Res_W=(1<<31)!Ptr 3731 ->PI103C 3732 %finish 3733 %finish 3734 %if CEXMODE=3 %thenstart;! dimension expression 3735 %if PI21MODE>2 %thenstart 3736 ER=249;! dimension must be integer 3737 ->EXIT4P 3738 %finish 3739 %if CTYP>0 %then ->PI103C;! const 3740 ! %if PP_TYPE=0 %then NOTYPE 3741 I=PP_CLASS 3742 PP_X1=PP_X1!2;! ensure that params are copied in 3743 %if 1<=I<=2 %thenstart;! common or param scalar 3744 %if I=1 %then Alloc(Ptr);! temp solution +++++++++++ 3745 Res_H0=PTR>>DSCALE; Res_Form=I+2; Res_Mode=Pi21mode 3746 ->PI103C 3747 %finish 3748 %if I>2 %thenstart 3749 %if I=16 %thenstart 3750 PI103B: RES_W=PP_CONSTRES;! pick up result descriptor 3751 %if RES_W=0 %then ->PI103E 3752 I=PP_TYPE&7 3753 ->PI103C 3754 %finish 3755 ER=246;! name invalid in dimension expression 3756 ->EXIT4P 3757 %finish 3758 CTYP=0;! to avoid untoward failure in PI(53) state check 3759 Res_H0=PTR>>DSCALE; Res_Form=5; Res_Mode=1;! name as yet unknown 3760 ->PI103C 3761 %finish 3762 %if P1=1 %then ->EXIT1;! no further checks for complex const 3763 I=CTYP&7 3764 %if CTYP>0 %then ->PI103D;! const 3765 I=PP_TYPE&7 3766 %if PP_CLASS=16 %then ->PI103B;! const name 3767 PI103E:ER=275;! not symbolic name of a constant 3768 ->EXIT4P 3769 !* 3770 PI(104): 3771 !*********************************************************************** 3772 !* P1 = 0 EXTERNAL * 3773 !* 1 EXTERNAL /ALGOL/ * 3774 !* 2 GENERIC * 3775 !* 3 INTRINSIC * 3776 !*********************************************************************** 3777 Com_Inhibop4=1 3778 Com_Curstatclass=1 3779 %if Com_Statordermode>2 %then ER=236 %and ->EXIT4 3780 Com_Statordermode=2 3781 %if P1=2 %then ->UP3;! IGNORE THIS STATEMENT (77+) 3782 %if P1=1 %thenstart 3783 %if Com_Options1&1#0 %then ER=100 %and ->EXIT4P;! allow /ALGOL/ on EMAS only 3784 Com_Algolref=1 3785 %finish 3786 CRM8=P1 3787 ->EXIT1 3788 !* 3789 PI(106): 3790 !*********************************************************************** 3791 !* SKIP REST OF STATEMENT * 3792 !*********************************************************************** 3793 ->UP3 3794 !* 3795 PI(107): 3796 !*********************************************************************** 3797 !* Scan potential expression for first non-alphanumeric or dot or EOL * 3798 !* If , or ) or EOL then take alternate path to simplify analysis * 3799 !*********************************************************************** 3800 I=Com_Inp 3801 %while TYPE(I)<7 %cycle 3802 I=I+1 3803 %repeat 3804 ICOMP=ICOMP+2 3805 J=TYPE(I) 3806 %if J=7 %or J=12 %then ->EXIT2;! if , or ) 3807 ICOMP=ICOMP+2 3808 ->EXIT1 3809 !* 3810 PI(108): 3811 !*********************************************************************** 3812 !* Skip rest of statement * 3813 !*********************************************************************** 3814 ->UP3;! SKIP REST OF STATEMENT 3815 !* 3816 PI(110): 3817 !*********************************************************************** 3818 !* Primarily to set GSTATE=12 prior to evaluating integer expressions * 3819 !*********************************************************************** 3820 %if P1=3 %then ->EXIT1 3821 GSTATE=P1 3822 NOTFLAG=0 3823 ->EXIT1 3824 !* 3825 PI(111): 3826 !*********************************************************************** 3827 !* Check if RETURN valid in context * 3828 !* Follow by PI(89) * 3829 !*********************************************************************** 3830 %if Com_Subprogtype=1 %then LFAULT(202) 3831 Com_Statement=1;! classification for ITS 3832 ->PI89 3833 !* 3834 PI(112): 3835 !*********************************************************************** 3836 !* Set default identifier for unnamed BLOCKDATA * 3837 !*********************************************************************** 3838 PI112:PTR=0;! to avoid unassigned check in call of NEWSUBPROGRAM 3839 P1=5;! TO INDICATE BLOCKDATA 3840 {2900} BLOCKDATAID="ICL9HFBLKDTA" 3841 !{PERQ} BLOCKDATAID="BLKDTA" 3842 ->PI70 3843 !* 3844 PI(113): 3845 !*********************************************************************** 3846 !* Check sequencing of block IF statements * 3847 !*********************************************************************** 3848 Com_Labwarn=0 3849 Com_Statement=10+P1;! needed to ensure that forward refs to ENDIF label are not rejected 3850 ER=IFCHECK(BLOCKIFSTATE<<2!P1) 3851 %if ER>200 %thenstart;! invalid seqence 3852 ->EXIT4 3853 %finish 3854 BLOCKIFSTATE=ER 3855 %if BLOCKIFSTATE=0 %thenstart 3856 I=Com_Ifptr 3857 %while I#0 %cycle 3858 IFREC==record(Com_Adict+I) 3859 I=IFREC_LINK1 3860 %if IFREC_TYPE=0 %then %EXIT;! matching IF 3861 %repeat 3862 %if I#0 %thenstart;! nested IFs 3863 IFREC==record(Com_Adict+I) 3864 BLOCKIFSTATE=IFREC_TYPE+1 3865 %finish 3866 %finish 3867 ->EXIT1 3868 PI(114): 3869 !*********************************************************************** 3870 !* after *) in dimension list * 3871 !*********************************************************************** 3872 Res_W=0 3873 Res_Form=8;! assumed size 3874 ->PI26B 3875 !* 3876 PI(116): 3877 !*********************************************************************** 3878 !* Note integer value in the analysis tree * 3879 !*********************************************************************** 3880 RES_W=P1 3881 ->EXIT1 3882 !* 3883 PI(118): 3884 !*********************************************************************** 3885 !* Call GENERATE to evaluate a const expression * 3886 !*********************************************************************** 3887 GENERATE RD 3888 ->EXIT1 3889 !* 3890 PI(120): 3891 !*********************************************************************** 3892 !* Note previous character position for errors reported by GENERATE * 3893 !*********************************************************************** 3894 RES_W=Com_Inp-1 3895 ->EXIT1 3896 !* 3897 PI(121): 3898 !*********************************************************************** 3899 !* Check statement order for type statement * 3900 !*********************************************************************** 3901 Com_Curstatclass=1 3902 %if Com_Statordermode>2 %then LFAULT(236) %and ->EXIT1 3903 Com_Statordermode=2 3904 ->EXIT1 3905 !* 3906 PI(122): 3907 !*********************************************************************** 3908 !* Report end of definition if NEXTCH is EOL * 3909 !*********************************************************************** 3910 %if Com_Nextch=10 %then ->PIZERO 3911 ->EXIT1 3912 !* 3913 PI(123): 3914 !*********************************************************************** 3915 !* Process char length of form (*) or * 3916 !*********************************************************************** 3917 Com_Inhibop4=1 3918 %if P1#1 %thenstart;! (*) 3919 %if P1#0 %then Com_Pi21int=0 %and ->PI24A;! ADJUST IDENTIFIER RECORD 3920 CHARLEN=0 3921 ->EXIT1 3922 %finish 3923 GENERATE RD 3924 Com_Pi21int=RES_H0 3925 %if RES_FORM=1 %thenstart 3926 %if RES_MODE=2 %thenstart 3927 Com_Pi21int=INTEGER(Com_Adict+Com_Pi21int<EXIT4;! bad character length 3933 ->EXIT1 3934 !* 3935 PI(124): 3936 !*********************************************************************** 3937 !* Following recognition of an identifier in a SAVE list * 3938 !* P1 = 0 not a common block name * 3939 !* 1 a common block name * 3940 !*********************************************************************** 3941 Com_Dptr=Com_Dptr+W4;! in case record just created for a common block 3942 PTR=FREESP(4) 3943 SS==record(Com_Adict+PTR) 3944 SS_INF0=RES_W;! dict @ of iden record 3945 SS_INF2=Com_Linest 3946 SS_INF3=P1 3947 SS_LINK1=SAVELIST 3948 SAVELIST=PTR 3949 %if P1=1 %and Ctyp<0 %thenstart;! new iden - set common block 3950 Ptr=Res_W 3951 PP==record(Com_Adict+Ptr) 3952 -> Pi28a;! to complete initialisation of a common block record 3953 %finish 3954 ->EXIT1 3955 !* 3956 PI(125): 3957 !*********************************************************************** 3958 !* Before I/O list item * 3959 !* Scan for EOL or iden only before , ) = EOL * 3960 !*********************************************************************** 3961 GSTATE=1 3962 %if Com_Nextch=NL %thenstart;! skip alternatives 3963 ICOMP=ICOMP+8 3964 ->EXIT1 3965 %finish 3966 %unless TYPE(Com_Inp)=1 %thenstart;! constant or expression 3967 PI125A: ICOMP=ICOMP+2 3968 ->EXIT2 3969 %finish 3970 I=Com_Inp+1 3971 %cycle 3972 J=TYPE(I) 3973 %if J>3 %thenstart 3974 %if J=7 %or J=12 %or INPUT(I)='=' %thenstart 3975 ICOMP=ICOMP+6 3976 ->EXIT2 3977 %finishelse ->PI125A 3978 %finish 3979 I=I+1 3980 %repeat 3981 !* 3982 PI(129): 3983 !*********************************************************************** 3984 !* Following END DO statement * 3985 !*********************************************************************** 3986 %if Com_Doptr=0 %then Er=334 %and ->Exit4;! no Do to match 3987 ->Exit1 3988 !* 3989 PI(130): 3990 !*********************************************************************** 3991 !* Following DO statement - traditional or DO WHILE * 3992 !* Investigate whether label is specified * 3993 !*********************************************************************** 3994 %if Type(Com_Inp)&X'7F'=3 %then P1=3 %and ->PI21;! label specified 3995 Com_Pi21int=-1 3996 ->Exit1 3997 !* 3998 PI(131): 3999 !*********************************************************************** 4000 !* following recognition of DO WHILE () * 4001 !*********************************************************************** 4002 ->Exit1 4003 !* 4004 PI(132): 4005 !*********************************************************************** 4006 !* following recognition of INCLUDE * 4007 !*********************************************************************** 4008 Includestat=1 4009 %if Include=0 %then ->Up3 %else ->Exit4 4010 ->Exit1 4011 !* 4012 %routine FIND 4013 !*********************************************************************** 4014 !* SET PTR TO HEAD OF IDEN HASH LIST AND SEARCH * 4015 !*********************************************************************** 4016 PTR=FINDA(LHEAD(HASHVALUE)) 4017 PP==record(Com_Adict+PTR) 4018 %end 4019 !* 4020 %routine CBNAME 4021 !*********************************************************************** 4022 !* NAME SEARCH HAS LOCATED A COMMON BLOCK NAME. IGNORE THIS AND * 4023 !* SEARCH FOR THE PERMITTED ALTERNATIVE DEFN. * 4024 !*********************************************************************** 4025 PP == record(Com_Adict+PTR) 4026 PTR=FINDA(PP_LINK1) 4027 PP==record(Com_Adict+PTR) 4028 %end; ! CBNAME 4029 !* 4030 %integerfn SCAN(%integer CHAR) 4031 !*********************************************************************** 4032 !* Scan for CHAR before next , or ) at current bracket level * 4033 !* Result = 0 not found * 4034 !* 1 found * 4035 !*********************************************************************** 4036 %integer I,J,BC 4037 BC=0 4038 I=Com_Inp 4039 J=INPUT(Com_Inp) 4040 %while J#10 %cycle;! to EOL 4041 %if BC=0 %thenstart 4042 %if J=CHAR %then %result=1 4043 %if J=',' %or J=')' %then %result=0 4044 %if J='(' %then BC=BC+1 4045 %finishelsestart 4046 %if J='(' %then BC=BC+1 4047 %if J=')' %then BC=BC-1 4048 %finish 4049 I=I+1 4050 J=INPUT(I) 4051 %repeat 4052 %result=0 4053 %end;! SCAN 4054 !* 4055 %routine GENERATE RD 4056 !*********************************************************************** 4057 !* Call generate to evaluate (what should be) a const expression * 4058 !*********************************************************************** 4059 %integer I 4060 I=Generate(Triads,Output,Nexttriad,Lin,-1,0,Comad) 4061 RES_W=Com_Rescom1 4062 RESL=RES_W 4063 RESR=Com_Rescom2 4064 %if RES_MODE=1 %thenstart;! integer 4065 %if RES_FORM=0 %thenstart;! value in RES 4066 Com_Pi21int=RES_H0 4067 %finishelsestart 4068 %if RES_FORM=1 %then Com_Pi21int=INTEGER(Com_Adict+RES_H0<Error 4095 Charno(S,I)=J 4096 %repeat 4097 %result=0 4098 %finish 4099 Er=360 4100 %result=1 4101 %end;! Include 4102 !* 4103 %routine Notype 4104 Lfault(333) 4105 Ttyp=X'51' 4106 PP_Type=Ttyp 4107 %end 4108 !* 4109 %routine WRIT(%integer I,J) 4110 %integer K 4111 K=I//1000 4112 %if K#0 %thenstart 4113 PRINTSYMBOL(HEX(K)) 4114 I=I-K*1000 4115 %finish 4116 K=I//100 4117 %if K#0 %thenstart 4118 PRINTSYMBOL(HEX(K)) 4119 I=I-K*100 4120 %finish 4121 J=I//10 4122 %unless J=0 %and K=0 %thenstart 4123 PRINTSYMBOL(HEX(J)) 4124 %finish 4125 PRINTSYMBOL(HEX(I-10*J)) 4126 %end 4127 !* 4128 %routine STRACE 4129 WRITE(ICOMP-2,4) %if Com_Ptrace=2 4130 WRITE(Com_Nextch,4) 4131 %if P > 9 %thenstart 4132 PRINTSTRING(" $") 4133 WRIT(P,2) 4134 PRINTSTRING("(") 4135 WRIT(P1,1) 4136 PRINTSTRING(")") 4137 NEWLINE 4138 %finishelsestart 4139 %if Com_Ptrace=2 %thenstart 4140 SPACES(4) 4141 %if P = 2 %then PRINTSYMBOL(P1) %and SPACES(5) 4142 %if P = 6 %then PRINTSTRING("<@>") %and SPACES(5) 4143 %if P = 1 %thenstart 4144 PRINTSTRING("<".SUBNAMES(P1).">") 4145 SPACES(5) 4146 %finish 4147 %if P=0 %then PRINTSTRING("===") %and SPACES(5) 4148 %if P=4 %thenstart 4149 PRINTSTRING(STRING(ADDR(SSTRING(SHEADS(P1))))) 4150 SPACES(5) 4151 %finish 4152 %if P=7 %thenstart 4153 PRINTSTRING("[") 4154 PRINTSYMBOL(P1) 4155 PRINTSTRING("]") 4156 %finish 4157 %if P=3 %thenstart 4158 PRINTSYMBOL(P1) 4159 PRINTSYMBOL('"') 4160 %finish 4161 NEWLINE 4162 %finish 4163 %finish 4164 %end;! STRACE 4165 !* 4166 !* 4167 %integerfn GET NEXT VARIABLE 4168 %integerfnspec IMPDO 4169 %CONSTBYTEINTEGERARRAY VSIZE(0:15)=2,4,8,4,8,16,8,16,32,1,2,4,8,1,0,1 4170 %CONSTBYTEINTEGERARRAY LOGMODE(0:6)=0(3),9,10,11,12 4171 %integer VTYPE,RES,ARRAY 4172 %record(SRECF) %name SS 4173 START:%if VLISTHEAD=0 %then %result=0;! VCOUNT still zero to provoke error 286 4174 SS==record(Com_Adict+VLISTHEAD) 4175 %if SS_INF3<=0 %thenstart;! IMPLIED DO 4176 RES=IMPDO 4177 %if RES>0 %then %result=-RES 4178 %if RES<0 %thenstart 4179 VLISTHEAD=SS_LINK1 4180 ->START 4181 %finish 4182 %finish 4183 PTR=SS_INF0 4184 PP==record(Com_Adict+PTR) 4185 IDENTIFIER=STRING(Com_Anames+PP_IDEN) 4186 VTYPE=PP_TYPE 4187 VMODE=SETMODE(VTYPE&X'3F') 4188 %if VTYPE&X'F'=4 %then VMODE=LOGMODE(VTYPE>>4) 4189 %if VTYPE=5 %thenstart 4190 %if SS_INF4#0 %then VLENGTH=SS_INF4 %C C %else VLENGTH=PP_LEN 4192 %finishelse VLENGTH=VSIZE(VMODE) 4193 VCOUNT=1 4194 VDISP=0 4195 ALLOC(PTR) 4196 %if PP_CLASS&2=0 %or PP_X0&16#0 %thenstart;! not in comon 4197 %if Com_Subprogtype=5 %then %result=284;! name not in common 4198 %finishelsestart;! in common 4199 %if Com_Subprogtype#5 %then %result=-282;! init common only in BLOCKDATA 4200 %if PP_Link3<0 %then FREE LIST CELL(VLISTHEAD,5) 4212 %result=0 4213 !* 4214 %integerfn IMPDO 4215 %integer INIT,INC,FINAL,I,J,L,C,AD,ER,Lbound 4216 %owninteger evaluating 4217 %switch A(0:5) 4218 !* 4219 %integerfn VAL(%integer P) 4220 %integer I,J,count,Op,Opl,Opr,arec 4221 %record(dexpfmt)%name dexprec 4222 %record(PRECF) %name PP 4223 %record(RESF) RES 4224 %if P&X'C0000000'#X'80000000' %then %result=P 4225 %if P&X'E0000000'=X'80000000' %thenstart;! simple var 4226 P=P&X'7FFFFFFF' 4227 %cycle I=DOLEVEL,-1,1 4228 %if DDO(I)_CONTID=P %then %result=DDO(I)_VALUE 4229 %repeat 4230 PP==record(Com_Adict+P) 4231 IDENTIFIER=STRING(Com_Anames+PP_IDEN) 4232 %if PP_CLASS=16 %thenstart;! CONST 4233 RES_W=PP_CONSTRES 4234 %if RES_MODE#1 %then LFAULT(253) %and %result=1 4235 J= RES_H0 4236 %if Res_Form=1 %and Res_Mode=1 %then J=INTEGER(Com_Adict+J<9 %thenstart 4265 J=Val(SS_Inf0) 4266 L=Ldim(SS_Inf2) 4267 %if I=10 %thenstart 4268 L=L*J 4269 Ass: Ldim(SS_Inf2)=L 4270 ->Check 4271 %finish 4272 %if I=11 %thenstart 4273 L=L//J 4274 ->Ass 4275 %finish 4276 %if I=12 %thenstart 4277 L=L+J 4278 ->Ass 4279 %finish 4280 L=L-J 4281 ->Ass 4282 %finish 4283 ->A(-SS_INF3) 4284 !* 4285 A(0): ! INITIALISE 4286 L=SS_INF0 4287 DOLEVEL=L 4288 INIT=VAL(DDO(L)_INIT) 4289 INC=VAL(DDO(L)_INCR) 4290 FINAL=VAL(DDO(L)_FINAL) 4291 %if ER#0 %then %result=ER 4292 %if INC=0 %then %result=295 4293 C=(FINAL-INIT+INC)//INC 4294 %if C<=0 %then %result=290 4295 DDO(L)_LEFT=C-1 4296 DDO(L)_VALUE=INIT 4297 %result=-1 4298 !* 4299 A(1): ! ARRAY NAME 4300 ARRAY=VLISTHEAD 4301 PP==record(Com_Adict+SS_INF0) 4302 DVREC==record(Com_Adict+PP_ADDR4) 4303 %result=-1 4304 !* 4305 A(2): ! SUBSCRIPT 4306 LDIM(SS_INF2)=VAL(SS_INF0) 4307 Check:%if ER#0 %then %result=ER 4308 %result=-1 4309 !* 4310 A(3): ! END OF SUBSCRIPT LIST 4311 VLISTHEAD=SS_LINK1 4312 SS==record(Com_Adict+ARRAY) 4313 J = DVREC_DIMS 4314 I=1;! to avoid IMP compiler bug 4315 L = LDIM(I)-Boundval(DVREC_B(I)_L) 4316 %if J > 1 %thenstart 4317 %cycle I = 2,1,J 4318 Lbound=Boundval(DVREC_B(I)_L) 4319 L = L+DVREC_B(I-1)_M*(LDIM(I)-Lbound) 4320 %repeat 4321 %finish 4322 %unless 0 <= L < DVREC_NUMELS %then %C C IDENTIFIER=STRING(Com_Anames+PP_IDEN) %and %result=232 4324 ! OUTSIDE DECLARED BOUNDS 4325 %if PP_TYPE=CHARTYPE %then J=PP_LEN %else %C C J=NUMBYTES(PP_TYPE>>4);! BYTES PER ITEM 4327 %if PP_TYPE&7=CMPLXTYPE %then J=J<<1;! COMPLEX 4328 I = (L*J)!X'1000000' 4329 SS_INF2=I 4330 %result=0 4331 !* 4332 A(4): ! END OF DO LOOP 4333 L=SS_INF0 4334 C=DDO(L)_LEFT 4335 %if C=0 %then %result=-1 4336 DDO(L)_LEFT=C-1 4337 DDO(L)_VALUE=DDO(L)_VALUE+VAL(DDO(L)_INCR) 4338 SS==record(Com_Adict+DDO(L)_START) 4339 %result=-1 4340 %end;! IMPDO 4341 %end;! GET NEXT VARIABLE 4342 !* 4343 %integerfn DATA IMPLIED DO 4344 %SWITCH P41(0:10) 4345 K=0 4346 ! %if P1>9 %thenstart 4347 ! K=Dimscount 4348 ! I=-P1 4349 ! ->PI41C 4350 ! %finish 4351 ->P41(P1) 4352 !* 4353 P41(0): ! ( 4354 Cexmode=2;! for correct expression processing 4355 DOIO=DOIO+1 4356 DOLEVEL=DOIO 4357 I=0 4358 J=DOIO 4359 PI41A:PTR=FREESP(5) 4360 SS==record(Com_Adict+PTR) 4361 SS_INF0=J; SS_INF4=0;! 5-word record needed for consistency with char substrings 4362 SS_INF2=K 4363 SS_INF3=I;! action switch 4364 %unless VLISTHEAD=0 %thenstart 4365 SS==record(Com_Adict+VLISTTAIL) 4366 SS_LINK1=PTR 4367 %finishelse VLISTHEAD=PTR 4368 VLISTTAIL=PTR 4369 %if P1=0 %then DDO(DOIO)_START=PTR 4370 %result=0 4371 !* 4372 P41(1): ! arrayid( 4373 %if PP_CLASS=12 %then CBNAME 4374 ER=245 4375 %unless PP_CLASS&13=4 %then %result=3 {PI34ERR} 4376 ERRIDEN=STRING(Com_Anames+PP_IDEN);! for subscript errors 4377 DVREC==record(Com_Adict+PP_ADDR4) 4378 DIMSCOUNT=0 4379 I=-1 4380 J=PTR 4381 ->PI41A;! to enter array record 4382 !* 4383 P41(2): ! after controlled iden 4384 DDO(DOLEVEL)_CONTID=PTR 4385 %result=0 4386 !* 4387 P41(3): ! initial 4388 P41(4): ! final 4389 P41(5): ! increment 4390 ! %if CTYP<=0 %thenstart 4391 ! J=1<<31!PTR 4392 ! %finishelsestart;! const 4393 ! %unless CTYP&15=1 %then ER=131 %and %result=1 {EXIT4P} 4394 ! J=Com_Pi21int 4395 ! %finish 4396 J=Com_Rescom1 4397 %if P1=3 %then DDO(DOLEVEL)_INIT=J %elsestart 4398 %if P1=4 %then DDO(DOLEVEL)_FINAL=J %else DDO(DOLEVEL)_INCR=J 4399 %finish 4400 %result=0 4401 !* 4402 P41(6): ! default incr 4403 DDO(DOLEVEL+1)_INCR=1 4404 %result=0 4405 !* 4406 P41(7): ! ) 4407 I=-4 4408 J=DOLEVEL 4409 DOLEVEL=DOLEVEL-1 4410 ->PI41A 4411 !* 4412 P41(8): ! after subscript 4413 %if DIMSCOUNT>DVREC_DIMS %thenstart 4414 PI41B: ER=264 4415 IDENTIFIER=ERRIDEN 4416 %result=2 {EXIT4} 4417 %finish 4418 DIMSCOUNT=DIMSCOUNT+1 4419 K=DIMSCOUNT 4420 I=-2 4421 ! %if CTYP<=0 %thenstart;! var 4422 ! J=1<<31!PTR 4423 ! %finishelsestart 4424 ! %unless CTYP&15=1 %then ER=136 %and %result=1 {EXIT4P} 4425 ! J=Com_Pi21int 4426 ! %finish 4427 J=Com_Rescom1 4428 ->PI41A 4429 P41(9): ! ) following aray element 4430 %unless DIMSCOUNT=DVREC_DIMS %then ->PI41B 4431 I=-3 4432 J=0 4433 ->PI41A 4434 %end;! DATA IMPLIED DO 4435 !* 4436 %integerfn EQUIVALENCE 4437 %if CRM3 = -1 %then %result=1; ! FAULT ALREADY DETECTED 4438 %if VLISTHEAD = VLISTTAIL %thenstart; ! < 2 ITEMS IN LIST 4439 ER = 265 4440 EQUIVERR:LFAULT(ER) 4441 %result=1 4442 %finish 4443 SPTR = VLISTHEAD 4444 %cycle 4445 SS == record(Com_Adict+SPTR) 4446 PTR = SS_INF0 4447 PP == record(Com_Adict+PTR) 4448 %if SS_INF2&X'FF000000'=X'01000000' %then %C C SS_INF2 = SS_INF2&X'FFFFFF'; ! CLEAR FLAG SET BY PI(34) FOR ARRAY ELEMENT(NOT RELEVANT FOR EQUIV) 4450 PP_X1=PP_X1!X'80' 4451 %if PP_CLASS&2 # 0 %thenstart; ! COMMON ELEMENT 4452 ER = 266; ! > 1 COMMON ELEMENT IN LIST 4453 %if CCOUNT # 1 %then -> EQUIVERR 4454 CCOUNT = PTR; ! SAVE COMMON ITEM POINTER 4455 %finishelsestart; ! NOT A COMMON ITEM 4456 K = PP_X1; ! EQUIV TO : EQUIV FROM : DATA : ALLOCATED 4457 ER = 236; ! VARIABLE ALREADY ALLOCATED 4458 %if K&1 # 0 %then %C C IDENTIFIER=STRING(Com_Anames+PP_IDEN) %and -> EQUIVERR 4460 P=PTR 4461 J = VLISTHEAD 4462 PI44A: %if J # SPTR %thenstart; ! CHAIN THROUGH PREVIOUS ENTRIES TO CHECK CONTRADICTIONS 4463 SSS == RECORD(Com_Adict+J) 4464 %if SSS_INF0 # PTR %thenstart 4465 J = SSS_LINK1 4466 -> PI44A 4467 %finishelsestart; ! SPTR ITEM ALREADY INCLUDED IN CURRENT LIST 4468 ER = 267; ! CONTRADICTION IN EQUIV LIST 4469 Com_Pi21int=SS_INF3 4470 %if SSS_INF2 # SS_INF2 %then -> EQUIVERR 4471 QQ_LINK1 = SS_LINK1; ! REMOVE DUPLICATE ENTRY FROM LIST 4472 FREE LIST CELL(SPTR,5) 4473 -> PI44B; ! LINK TO NEXT ITEM ALREADY SET 4474 %finish 4475 %finish 4476 %if (K&4#0 %and SPTR#PP_LINK2) %thenstart 4477 ! NOW LINK IN EXISTING EQUIVALENCE CHAIN 4478 J = SS_LINK1; ! SAVE LINK TO NEXT (AS YET UNCHECKED) ITEM 4479 L = PP_LINK2; ! TO CORRESPONDING ENTRY ALREADY IN AN EQUIV LOOP 4480 SSS == record(Com_Adict+L) 4481 K = SS_INF2-SSS_INF2; ! ADJUSTMENT REQUIRED TO ALLIGN EXISTING CHAIN 4482 N = SSS_LINK1 4483 SS_LINK1 = N; ! START EQUIV CHAIN FROM THE NEW RECORD 4484 %cycle 4485 SSS == record(Com_Adict+N) 4486 SSS_INF2 = SSS_INF2+K 4487 N = SSS_LINK1 4488 %if N=0 %then %result=1;! previously reported error 4489 %repeat %until N = L 4490 FREE LIST CELL(L,5) 4491 SSS_LINK1 = J 4492 %finishelse PP_X1= K!4; ! SET 'EQUIV FROM' BIT 4493 PP_LINK2 = SPTR 4494 %finish 4495 QQ == record(Com_Adict+SPTR) 4496 SPTR = SS_LINK1 4497 PI44B: %repeat %until SPTR = 0 4498 QQ_LINK1 = VLISTHEAD; ! COMPLETE THE LOOP 4499 %if CCOUNT # 1 %thenstart; ! COMMON ITEM IN CHAIN 4500 PTR=FREESP(2) 4501 SS==record(Com_Adict+PTR) 4502 SS_INF0=P;! will be allocated late to ensure correct common size 4503 SS_LINK1=Com_Equchk 4504 Com_Equchk=PTR 4505 %finish 4506 %result=0 4507 %end;! EQUIVALENCE 4508 !* 4509 %routine Report Error(%integer Index,Type,Errno) 4510 %if Reported Error&Index=0 %thenstart 4511 %if Type=0 %then Fault(Errno) %else Lfault(Errno) 4512 %finish 4513 Reported Error=Reported Error!Index 4514 %end;! Report Error 4515 !* 4516 %end;! ANALYSE 4517 !* 4518 %routine ANALINIT 4519 !*********************************************************************** 4520 !* Re-initialise at start of each subprogram * 4521 !*********************************************************************** 4522 %integer I,J,Ptr 4523 %integer C 4524 %record(Precf) %name PP 4525 %string(15) S 4526 Init Input(Comad) 4527 Init Alloc(1,Comad,0,0) 4528 Zero(addr(Lhead(0)),620) 4529 Zero(Com_Adict,256) 4530 %cycle I=0,1,Numbitfns 4531 Bitfnsperm(I)=1 4532 %repeat 4533 Com_Cbnptr=0 4534 Com_Doptr=0 4535 Com_Scptr=0 4536 Com_Sfptr=0 4537 Com_Subprogtype=0 4538 Com_Subprogptr=0 4539 Com_Fnlst=0 4540 Com_Sfmk=0 4541 Com_Headings=0 4542 Com_Checklist=0 4543 Datahead=0 4544 Com_Externals=0 4545 Com_Fno=0 4546 Cgolab=0 4547 Notflag=0 4548 Pct=0 4549 ASS CHECKLIST=0 4550 Blockifstate=0 4551 Com_Labwarn=0 4552 Com_Vreturn=0;! will be non-zero if any variable return 4553 Com_Entries=0;! will be non-zero if any side-entries 4554 Com_Assgotos=0;! list of assigned goto labels for optimiser 4555 Com_Tmpptr=0;! list of temps defined by GENERATE (for use by optimiser) 4556 Com_Destemps=0;! listhead of descriptor temp records created by optimiser 4557 Com_Namesfree=2;! free location for next identifier 4558 Com_Nextbit=4;! reserving bitstring entries 0 to 3 4559 Com_Nexttemp=1 4560 Com_Ifptr=0;! nest of active IF blocks 4561 Com_Nextplab=1;! private label index 4562 Com_Tmindex=0;! index of TM specifiers produced by optext 4563 Com_Inhibop4=0;! will be set to 1 if any reason to inhibit OP4 4564 Com_Argcnt=0;! no of args - used by Op4 4565 Com_Idcnt=0;! no of identifiers - used by Op4 4566 Com_Labcnt=0;! no of user defined labels - used by Op4 4567 Com_Tmlist=0;! listhead of TM specifiers used by optext 4568 Com_Inp = 1 4569 J=Default Size(2) 4570 %cycle I = 'A',1,'Z' 4571 Imptype(I) = J; ! set implicit type for alphabetics to real 4572 %repeat 4573 J=DEFAULT SIZE(1) 4574 %cycle I = 'I',1,'N' 4575 Imptype(I) = J; ! over-ride I - N with implicit integer 4576 %repeat 4577 !* 4578 %if Com_F77parm&X'00004000'#0 %thenstart;! undefined 4579 %cycle I='A',1,'Z' 4580 Imptype(I)=0 4581 %repeat 4582 %finish 4583 !* 4584 Charmask=0;! for implicit bit settings 4585 Com_Statordermode=0 4586 Com_Algolref=0;! WILL BE SET TO 1 IF EXTERNAL /ALGOL/ APPEARS 4587 %if Com_F77parm&X'800000'#0 %then Com_Algolref=1 4588 %cycle I=0,1,156 4589 Fnspecials(I)=Fnspecials(I)&X'FFFFF';! reset 4590 %repeat 4591 Com_Equchk=0;! list of equiv chains including a common item 4592 !* 4593 !******** INITIALISE BLANK COMMON ENTRY IN DICT 4594 !* 4595 Com_Dptr = Blcmptr 4596 S="F#BLCM" 4597 Ptr=Locate Name(S) 4598 Com_Dptr=Com_Dptr+Cmnrecext 4599 PP==record(Com_Adict+Ptr) 4600 PP_Class=12; ! COMMON BLOCK NAME 4601 PP_Last = Ptr; ! 'LAST ITEM' POINTER TO ITSELF - NO ITEMS YET DEFINED 4602 {2900} PP==record(Com_Adict+PSEUDOCMN);! local arrays treated as common sometimes 4603 {2900} PP_CMNREFAD=8;! only relevant entry is disp of ref @ 4604 {2900} Com_Dptr=200;! WILL ENSURE THAT CONST VALUES ARE >=256 BYTES UP DICT 4605 {2900} ! TO AVOID ERROR IN ADD DATA ITEM 4606 !* 4607 Com_Firststatnum=Com_Linest+1;! FOR STATEMENT MAP 4608 !* 4609 Savelist=0;! list of items in SAVE statements 4610 !* 4611 Com_Adblkdtaid=ADDR(BLOCKDATAID) 4612 !* 4613 %end;! ANALINIT 4614 !* 4615 !* 4616 %externalintegerfn Analstart(%record(Triadf)%arrayname Triads, C %integer Adcom,%integername Count) 4618 %integer I,J,TLTYP,PTR,SPTR,PATH,LIN,ER 4619 !* 4620 %record(DORECF)%name DOREC 4621 %record(IFRECF)%name IFREC 4622 %record(LABRECF)%name LABREC 4623 %record(SRECF)%name SS 4624 %string(15) S 4625 %ownintegerarrayformat Outputfmt(0:4000) 4626 %integerarrayname Output 4627 !* 4628 %routine Check Lab Ref 4629 %integer Er 4630 %if Com_Allowvax=NO %then Er=206 %else Er=331;! error else warning 4631 %if LABREC_DOSTART#0 %thenstart;! within a DO loop 4632 %unless SS_INF2>=LABREC_DOSTART %then IFAULT(Er,SS_INF2) 4633 %finish 4634 %if LABREC_IFSTART#0 %thenstart;! within an IF block 4635 %unless SS_INF2>=LABREC_IFSTART %or Com_Statement=13 %C C %then IFAULT(204,SS_INF2);! avoid test if ENDIF statement 4637 %finish 4638 %if Com_Curstatclass=1 %then IFAULT(218,SS_INF2) 4639 %end;! Check Lab Ref 4640 !* 4641 Comad=Adcom;! address of common data area 4642 Com==record(Adcom) 4643 Com_Adident=addr(Identifier) 4644 Com_Aderriden=addr(Erriden) 4645 Com_Adlhead=addr(Lhead(0)) 4646 Output==array(Com_Adoutput,Outputfmt) 4647 !* 4648 Default Size(1)=X'51' 4649 Default Size(2)=X'52' 4650 !* 4651 %if Com_Options2&Defreal8#0 %thenstart;! r8 4652 Default Size(2)=X'62' 4653 Default Size(3)=X'63' 4654 %finish 4655 !* 4656 %if Com_F77parm&X'08000000'#0 %thenstart;! I2 4657 Default Size(1)=X'41' 4658 Default Size(4)=X'44' 4659 %finish 4660 !* 4661 Analinit 4662 !* 4663 Com_Nexttriad=1 4664 Com_Trblock=0 4665 !* 4666 %if Count=0 %thenstart 4667 %unless Com_Lineno>0 %thenstart 4668 Com_Faulty=0 4669 Readnext 4670 %finish 4671 First Stat;! check for invalid first statement 4672 %finish 4673 !* 4674 NEXT STATEMENT: 4675 I=Readline(Input,Type,Ltype) 4676 %if I#0 %then %result=I 4677 LTYPE = MAPLTYPE(LTYPE); ! MAPLTYPE(0:7)=0,0,1,2,4,4,5,5 4678 TLTYP = LTYPE 4679 %if Com_Subprogtype = 0 %then LTYPE = 6 4680 ANALYSE LINE: 4681 LIN=0 4682 Com_Nextch = INPUT(1) 4683 Com_Inp = 1 4684 Com_Maxinp=1 4685 CGOLAB=0 4686 Com_Fnlst=0 4687 NOTFLAG=0 4688 PCT=0 4689 Com_Sfmk=0 4690 !* 4691 Path=Analyse(Triads,Com_Nexttriad,Ltype,Com_Adict,Lin,Output) 4692 !* 4693 %if Com_Subprogtype = 0 %and Com_Nextch # NL %thenstart; ! MUST BE A MAIN PROGRAM 4694 %if Includestat#0 %then -> NEXT STATEMENT 4695 %if TLTYP=0 %AND INPUT(1)='I' %AND INPUT(3)='C' %thenstart 4696 LTYPE=0 4697 ->ANALYSE LINE 4698 %FINISH 4699 S="F_MAIN" 4700 PTR=LOCATE NAME(S) 4701 I=NEW SUBPROGRAM(PTR,0,0,ER);! MAIN PROGRAM 4702 I=Generate(Triads,Output,Com_Nexttriad,0,-2,Com_Rescom1,Comad);! register private label 4703 LTYPE = TLTYP; ! ORIGINAL CLASSIFICATION (OVER-RIDDEN BECAUSE SUBPROGTYPE WAS 0) 4704 -> ANALYSE LINE 4705 %finish 4706 !* 4707 %if PATH#3 %and Com_Curstatclass=0 %and Com_Nextch=10 %C C %then Com_Statordermode=4;! executable statement 4709 !* 4710 %if Com_Lab = 0 %thenstart 4711 %if Com_Labwarn#0 %then LFAULT(177) 4712 PTR = 0 4713 %finishelsestart 4714 Com_Labwarn=0 4715 I=SETLAB(Com_Lab,PTR) 4716 LABREC==record(Com_Adict+PTR) 4717 %if LABREC_LINE # 0 %thenstart; ! LABEL ADDRESS ALREADY SPECIFIED 4718 IFAULT(227,LABREC_LINE); ! LABEL SET TWICE 4719 ->AFTER LABEL 4720 %finish 4721 LABREC_LINE=Com_Linest 4722 %if Com_Curstatclass=0 %then Com_Curstatclass=2 4723 LABREC_X0=LABREC_X0!Com_Curstatclass;! 1 non-exec 2 exec 4724 %if LABREC_X0&8 # 0 %thenstart 4725 IFAULT(228,LABREC_LINK5); ! LAB IS A FORMAT LABEL 4726 %finish 4727 %if Com_Doptr#0 %thenstart 4728 DOREC==record(Com_Adict+Com_Doptr) 4729 LABREC_DOSTART=DOREC_LINE;! start of DO enclosure 4730 LABREC_DOEND=X'7FFF' 4731 I=NEW LIST CELL(DOREC_LABLIST,2) 4732 SS==record(Com_Adict+I) 4733 SS_INF0=PTR 4734 %finish 4735 !* 4736 %if Com_Ifptr#0 %thenstart 4737 IFREC==record(Com_Adict+Com_Ifptr) 4738 LABREC_IFSTART=IFREC_LINE;! start of IF block enclosure 4739 LABREC_IFEND=X'7FFF' 4740 I=NEW LIST CELL(IFREC_LABLIST,2) 4741 SS==record(Com_Adict+I) 4742 SS_INF0=PTR 4743 %finish 4744 !* 4745 SPTR=LABREC_LINK2;! LIST OF FORWARD REFERENCES 4746 %while SPTR#0 %cycle 4747 SS==record(Com_Adict+SPTR) 4748 CHECK LAB REF 4749 FREE LIST CELL(SPTR,3);! abandon these list cells now that triads are used 4750 %repeat 4751 LABREC_LINK2=0;! new entries will be set in CODEGEN 4752 SPTR=LABREC_LINK3;! LIST OF GLA WORDS TO HOLD LABEL @ 4753 %while SPTR#0 %cycle 4754 SS==record(Com_Adict+SPTR) 4755 %if SS_INF2#0 %then CHECK LAB REF;! AVOID CHECK FOR ASSIGNED LABELS 4756 SPTR=SS_LINK1 4757 %repeat 4758 %finish 4759 AFTER LABEL: 4760 !* 4761 I=Generate(Triads,Output,Com_Nexttriad,Lin,Path,Ptr,Comad) 4762 !* 4763 %if Com_Subprogtype < 0 %thenstart;! END OF SUBPROGRAM 4764 Com_Faulty=Com_Faulty+Com_Fno 4765 newlines(2) %if Com_Listl#0 4766 ANALINIT 4767 Com_Nexttriad=1 4768 Com_Trblock=0 4769 %finish 4770 -> NEXT STATEMENT 4771 !* 4772 %end;! Analstart 4773 !* 4774 %endoffile 4774 LINES ANALYSED SIZE= 139816 ? Warning :- Unsupported precision used - nearest available substituted at line No 445 ? Warning :- Unsupported precision used - nearest available substituted at line No 449 ? Warning :- Name op not used at line No 4258 ? Warning :- Label pi102a not used at line No 4516 ? Warning :- Label l56d not used at line No 4516 ? Warning :- Label l532 not used at line No 4516 ? Warning :- Label pi37c not used at line No 4516 ? Warning :- Label pi34a not used at line No 4516 ? Warning :- Label callset not used at line No 4516 ? Warning :- Label pi21iden not used at line No 4516 ? Warning :- Name savefmt not used at line No 4516 ? Warning :- Name impdorec not used at line No 4516 ? Warning :- Name scomp1 not used at line No 4516 ? Warning :- Name scomp0 not used at line No 4516 ? Warning :- Name c not used at line No 4613 ? Warning :- Name j not used at line No 4772 ? Warning :- Name trace not used at line No 4774 ? Warning :- Name gldfnsdet not used at line No 4774 ? Warning :- Name gldfns not used at line No 4774 ? Warning :- Name stackspace not used at line No 4774 ? Warning :- Name analful not used at line No 4774 ? Warning :- Name dicful not used at line No 4774 ? Warning :- Name subrecf not used at line No 4774 ? Warning :- Name objfmt not used at line No 4774 ? Warning :- Name dtrecf not used at line No 4774 ? Warning :- Name terecf not used at line No 4774 ? Warning :- Name fnrecf not used at line No 4774 ? Warning :- Name charf not used at line No 4774 ? Warning :- Name tmpf not used at line No 4774 ? Warning :- Name constrecf not used at line No 4774 ? Warning :- Name plabf not used at line No 4774 ? Warning :- Name lrecf not used at line No 4774 ? Warning :- Name modetotempbytes not used at line No 4774 ? Warning :- Name csize not used at line No 4774 ? Warning :- Name reg1 not used at line No 4774 IBM CODE 45920+ 1320 BYTES GLAP 1552+ 1680 BYTES DIAG TABLES 3504 BYTES TOTAL 60216 BYTES 3348 STATEMENTS COMPILED ROUTINE/FN/MAP cross reference tables for file ERCC07:L3 ROUTINE/FN/MAP TYPE REFERENCES ADDDATAITEM ............... EXTERNALROUTINE .... 589 (SPEC) 2326 ADDTOASSLIST ROUTINE 1152 (DECLN) 1885 2238 ALLOC ..................... EXTERNALROUTINE .... 578 (SPEC) 2610 2741 2746 2805 2925 3019 3270 3744 4195 ANALFUL ................... EXTERNALINTEGERFN .. 577 (SPEC) ANALINIT ROUTINE 4518 (DECLN) 4661 4766 ANALSTART ................. EXTERNALINTEGERFN .. 4616 (DECLN) 560 (SPEC) ANALYSE INTEGERFN 1180 (DECLN) 4691 BOUNDVAL .................. INTEGERFN .......... 1161 (DECLN) 2164 2169 2174 4315 4318 CBNAME ROUTINE 4020 (DECLN) 1185 (SPEC) 1872 1926 2020 2030 2087 2153 2592 2732 2915 3223 4373 CHECKASSLIST ROUTINE 1132 (DECLN) 1588 CHECKDOINDEX .............. ROUTINE ............ 1082 (DECLN) 3436 CHECKLABREF ROUTINE 4628 (DECLN) 4748 4755 CHECKSAVELIST ............. ROUTINE ............ 1102 (DECLN) 1587 COERCECONST EXTERNALINTEGERFN 590 (SPEC) 2351 CONIN ..................... EXTERNALINTEGERFN .. 581 (SPEC) 2641 COPY ROUTINE 908 (DECLN) 2299 2958 DATAIMPLIEDDO ............. INTEGERFN .......... 4343 (DECLN) 1190 (SPEC) 2494 DICFUL EXTERNALROUTINE 574 (SPEC) DICTSPACE ................. EXTERNALINTEGERFN .. 582 (SPEC) 996 2011 2201 2959 DUMPDICT EXTERNALROUTINE 608 (SPEC) 2486 EQUIVALENCE ............... INTEGERFN .......... 4436 (DECLN) 1191 (SPEC) 2543 FAULT EXTERNALROUTINE 571 (SPEC) 1088 1518 1846 1859 1906 2226 2400 2425 2522 2885 3283 3286 4511 FILL ROUTINE 921 (DECLN) 2301 FIND ...................... ROUTINE ............ 4012 (DECLN) 1184 (SPEC) 1688 FINDA INTEGERFN 950 (DECLN) 1079 4016 4026 FIRSTSTAT ................. EXTERNALROUTINE .... 606 (SPEC) 4671 FORMALPARAMETER EXTERNALINTEGERFN 588 (SPEC) 3428 FREELISTCELL .............. EXTERNALROUTINE .... 569 (SPEC) 2429 2684 3075 3183 3509 4211 4472 4490 4749 FREESP .................... EXTERNALINTEGERFN .. 567 (SPEC) 970 2095 2660 3942 4359 4500 GCONVAL EXTERNALINTEGERFN 609 (SPEC) 4251 GENERATE .................. EXTERNALINTEGERFN .. 592 (SPEC) 3244 3377 4060 4702 4761 GENERATERD ROUTINE 4055 (DECLN) 1187 (SPEC) 1943 3887 3923 GENFMT .................... EXTERNALINTEGERFN .. 584 (SPEC) 3605 GETBYTE INTEGERFN 945 (DECLN) 2456 2470 GETNEXTVARIABLE ........... INTEGERFN .......... 4167 (DECLN) 1189 (SPEC) 2278 2424 IFAULT EXTERNALROUTINE 573 (SPEC) 1118 2567 2569 2657 4632 4635 4638 4718 4725 IMPDO INTEGERFN 4214 (DECLN) 4168 (SPEC) 4176 INCLUDE ................... INTEGERFN .......... 4073 (DECLN) 1194 (SPEC) 4009 INCLUDEFILE EXTERNALINTEGERFN 607 (SPEC) 4088 INITALLOC ................. EXTERNALROUTINE .... 580 (SPEC) 4527 INITINPUT EXTERNALROUTINE 601 (SPEC) 4526 LFAULT .................... EXTERNALROUTINE .... 572 (SPEC) 1024 1095 1144 1520 1525 1585 1586 1850 1893 1897 1941 2171 2195 2443 2528 2529 3321 3330 3476 3567 3676 3830 3902 4104 4234 4440 4511 4711 LOCATENAME ................ INTEGERFN .......... 1061 (DECLN) 4597 4700 NAMESFUL EXTERNALROUTINE 575 (SPEC) 998 NEWLISTCELL ............... EXTERNALINTEGERFN .. 568 (SPEC) 1155 1962 3009 3024 3044 3170 3334 3491 3578 4731 4740 NEWSUBPROGRAM ............. EXTERNALINTEGERFN .. 587 (SPEC) 3375 4701 NEXTLABEL EXTERNALINTEGERFN 605 (SPEC) 1567 1575 NOTYPE .................... ROUTINE ............ 4103 (DECLN) 1192 (SPEC) 2091 2160 2606 2734 3008 3021 3042 OUTPUTFUL ................. EXTERNALINTEGERFN .. 576 (SPEC) 1445 READLINE EXTERNALINTEGERFN 602 (SPEC) 4675 READNEXT .................. EXTERNALROUTINE .... 604 (SPEC) 4669 REPORTERROR ROUTINE 4509 (DECLN) 1193 (SPEC) 2402 2405 2410 SCALARSPACE ............... EXTERNALINTEGERFN .. 583 (SPEC) 2600 2778 2780 3245 SCAN INTEGERFN 4030 (DECLN) 1186 (SPEC) 2125 2930 3230 3406 SETCONREC ................. EXTERNALINTEGERFN .. 600 (SPEC) 2588 2725 SETCONSTANT EXTERNALINTEGERFN 596 (SPEC) 1830 SETLAB .................... EXTERNALINTEGERFN .. 570 (SPEC) 2564 2654 2888 4715 SETNAME ROUTINE 1031 (DECLN) 1687 STACKSPACE ................ EXTERNALINTEGERFN .. 579 (SPEC) STRACE ROUTINE 4128 (DECLN) 1188 (SPEC) 1377 TRACE ..................... ROUTINE ............ 1174 (DECLN) VAL INTEGERFN 4219 (DECLN) 4249 4250 4265 4288 4289 4290 4306 4337 WRIT ROUTINE 4109 (DECLN) 4133 4135 ZERO ...................... ROUTINE ............ 933 (DECLN) 3493 4528 4529 Source: ERCS08:F77REL.SRCE200_FARITH1 Compiled: 25/11/87 17.11.40 Object: .NULL Parms set: NOCHECK,NOARRAY,XREF ERCC. Portable Imp80 Compiler Release 4 Version 14 Sep 87 2047 4095 1 ! farith1 2 ! 09/10/86 - insert include files 3 ! ftnarith9 4 !* modified 15/06/86 ftnarith7 5 !* 6 %include "ftn_ht" 7 !* modified 16/11/86 8 ! add definitions of Cpu,Numoptregs 9 !* modified 10/10/85 10 !* 11 %constinteger ICL2900 = 1 12 %constinteger PERQPNX = 2 13 %constinteger ACCENT = 3 14 %constinteger IBM = 4 15 %constinteger VAX = 5 16 %constinteger M68000 = 6 17 %constinteger INTEL = 7 18 %constinteger LATTICE = 8 19 %constinteger VNS = 9 20 %constinteger GOULD =10 21 %constinteger WWC = 11 22 %constinteger WCW = 11 23 !* 24 %constinteger POSITIVE = 1 25 %constinteger NEGATIVE = -1 26 !* 27 %constinteger HOST = IBM 28 %constinteger TARGET = IBM 29 %constinteger STACK DIRECTION = POSITIVE 30 !* 31 %constinteger Concept = 0 32 %constinteger NP1 = 1 33 %constinteger Cpu = Concept {used only for Target=Gould at present } 34 !* 35 %constinteger Numoptregs = 0 {number of regs available for allocation} 36 {by Fortran optimiser - normally 0 or 1 } 37 !* 38 %constinteger IMP = 1 39 %constinteger fortran = 2 40 %constinteger ccomp = 11 41 %constinteger pascal = 14 42 {%include "ftn_consts3"} 43 !* modified 23/09/86 44 !* 45 !* 46 %constinteger WSCALE = 2;! scale word address to byte address 47 %constinteger BSCALE = 0;! scaling factor for words to architectural units 48 %constinteger CSCALE = 0;! byte offset to architectural unit offset 49 %constinteger DSCALE = 2;! dict pointer scaling in RES records 50 !* 51 %constinteger W1 = 4 ;! 1 word in architectural units 52 %constinteger W2 = 8 ;! 2 words in architectural units 53 %constinteger W3 = 12 ;! 3 words in architectural units 54 %constinteger W4 = 16 ;! 4 words in architectural units 55 !* 56 %constinteger TRIADLENGTH = 12 ;! size of an individual triad 57 %constinteger BLRECSIZE = 44 ;! size of a block table entry in architectural units 58 %constinteger LOOPRECSIZE = 16 ;! size of a loop table entry 59 %constinteger PROPRECSIZE = 12 ;! size of a propagation table entry 60 %constinteger CLOOPSZ = 12 ;! size of cloop table entry 61 %constinteger FRSIZE = 8 ;! size of freelist created by PUSHFREE 62 %constinteger TESZ = 20 63 %constinteger DTSZ = 20 64 %constinteger ARTICSZ = 4 65 %constinteger CTSIZE = 2 ;! used in OP3 66 %constinteger EXTNSIZE = 4 ;! used in OP3 67 !* 68 !* following used in strength reduction 69 !* 70 %constinteger RDSZ = 8 71 %constinteger RUSESZ = 12 72 %constinteger RTESTSZ = 4 73 %constinteger RDEFSZ = 16 74 %constinteger USESZ = 32 75 %constinteger SRUSESZ = 2 76 %constinteger SRSCALE = 2;! SR==RECORD(ABLOCKS + SRPTR<9 %OR NEWMODE>9 %THEN %RESULT=0;! error should have been reported 469 %if Oldmode=0 %then Oldmode=1 470 %if Newmode=0 %then Newmode=1 471 %if oldmode=newmode %thenstart 472 %if A=0 %thenstart;! was integer at Dict + 0 473 integer(Adict+Dptr)=integer(Adict) 474 A=Dptr 475 Dptr=Dptr+4 476 %finish 477 %result=A 478 %finish 479 ANEW=ADICT+DPTR 480 %if Anew&4#0 %thenstart 481 Anew=Anew+4 {ensures doubleword alignment} 482 Dptr=Dptr+4 483 %finish 484 A=ADICT+A 485 !* 486 LOOP: I=CONST TRAN(10*OLDMODE+NEWMODE) 487 TEMPMODE=I&15 488 ->C(I>>4) 489 !* 490 C(2): REAL(ANEW)=INTEGER(A) ;! I*4 -> R*4 491 ->CHECK 492 !* 493 C(3): LONGREAL(ANEW)=INTEGER(A) ;! I*4 -> R*8 494 ->CHECK 495 !* 496 C(6): ;! R*4 -> R*8/C*8 497 %if Tempmode=Real8 %thenstart 498 longreal(Anew)=real(A) 499 %finishelsestart 500 real(Anew)=real(A) 501 real(Anew+W1)=0 502 %finish 503 ->CHECK 504 !* 505 C(7): ;! R*8 -> R*16/C*16 506 longreal(Anew)=longreal(A) 507 longreal(Anew+W2)=0 508 ->CHECK 509 !* 510 C(9): ;! C*8 -> C*16 511 longreal(Anew)=real(A) 512 longreal(Anew+W2)=real(A+W1) 513 ->CHECK 514 !* 515 c(11): ;! R*4 -> I*4 516 R=real(A) 517 %if R<0 %thenstart 518 %if -R>2147483647.0 %then ->Intoverflow 519 %finishelsestart 520 %unless R<=2147483647.0 %then ->Intoverflow 521 %finish 522 %if R<0 %thenstart 523 integer(Anew)=-intpt(-R) 524 %finishelse integer(Anew)=intpt(R) 525 ->CHECK 526 527 !* 528 c(12): ;! R*8 -> I*4 529 RR=longreal(A) 530 %if RR<0 %thenstart 531 %if -RR>2147483647.0 %then ->Intoverflow 532 %finishelsestart 533 %unless RR<=2147483647.0 %then ->Intoverflow 534 %finish 535 %if RR<0 %thenstart 536 integer(Anew)=-intpt(-RR) 537 %finishelse integer(Anew)=intpt(RR) 538 ->CHECK 539 540 !* 541 CHECK:%IF TEMPMODE=NEWMODE %THENSTART 542 DPTR=DPTR+CSIZE(NEWMODE) 543 %RESULT=ANEW-ADICT 544 %FINISHELSESTART 545 A=ANEW 546 OLDMODE=TEMPMODE 547 ->LOOP 548 %FINISH 549 !* 550 C(13): ;! R*8 ->R4 551 real(Anew)=longreal(A) 552 ->CHECK 553 !* 554 C(14): ;! C*16 -> C*8 555 real(Anew)=longreal(A) 556 real(Anew+W1)=longreal(A+W2) 557 ->CHECK 558 !* 559 C(15):%IF A=ANEW %THEN ->CHECK ;! C*8/C*16/C*32 -> R*4/R*8/R*16 560 %IF TEMPMODE=NEWMODE %THENSTART 561 %RESULT=A-ADICT;! no new space required 562 %FINISHELSESTART 563 OLDMODE=TEMPMODE 564 ->LOOP 565 %FINISH 566 !* 567 INTOVERFLOW: 568 FAULT(112) 569 %RESULT=8;! int value 1 570 !* 571 REALOVERFLOW: 572 FAULT(112) 573 %RESULT=16;! real value 1 574 !* 575 C(0): FAULT(130) 576 %RESULT=A 577 !* 578 C(*): %monitor 579 %stop 580 !* 581 %END;! Coerce Const 582 !* 583 !* 584 %externalintegerfn Const Eval(%integer Resl,Op,Resr,%record(Resf)%name Res, C %integer Adict,%integername Dptr) 586 !* 587 %CONSTBYTEINTEGERARRAY OPERATING MODE(0:15)=1,1,1,3,4,0,6,7,0,1,1,1,0,13,1,1 588 !* 589 %INTEGER AL,FL,ML,AR,FR,MR,ARES,MRES,MMAX,I,IIN 590 %INTEGER IL,IR 591 %REAL RL,RR,CL,CR,RW,CW 592 %LONGREAL RRL,RRR,CCL,CCR,RRW,CCW 593 %record(Resf) Resll,Resrr 594 !* 595 %SWITCH OPMODE(0:15) 596 %SWITCH IOP(2:8) 597 %SWITCH ROP(2:8) 598 %SWITCH RROP(2:8) 599 %SWITCH COP(2:8) 600 %SWITCH CCOP(2:8) 601 !* 602 !* 603 RL=0 604 RR=0 605 CL=0 606 CR=0 607 RW=0 608 CW=0 609 RRL=0 610 RRR=0 611 CCL=0 612 CCR=0 613 RRW=0 614 CCW=0 615 Resll_W=Resl 616 Resrr_W=Resr 617 AL=Resll_H0<MMAX %THEN MMAX=MR 625 !* 626 %IF FL>2 %OR FR>2 %THENSTART;! param exp 627 %IF COM_CEXPDICT=0 %THENSTART;! start of exp 628 COM_CEXPDICT=DPTR 629 DPTR=DPTR+W1;! for length 630 %FINISH 631 INTEGER(ADICT+DPTR)=RESL 632 INTEGER(ADICT+DPTR+W1)=OP 633 INTEGER(ADICT+DPTR+W2)=RESR 634 Res_H0=Scalar Space(4,IIN);! temp in Gla 635 Res_Form=6 636 Res_Mode=1 637 INTEGER(ADICT+DPTR+W3)=RES_W 638 DPTR=DPTR+W4 639 %result=0 640 %FINISH 641 !* 642 %IF FL=0 %THENSTART;! store simple integers in DICT for simplicity 643 AL=AL>>DSCALE 644 INTEGER(ADICT)=AL 645 AL=0 646 %FINISH 647 %IF FR=0 %THENSTART 648 AR=AR>>DSCALE 649 INTEGER(ADICT+W1)=AR 650 AR=W1 651 %FINISH 652 !* 653 MRES=OPERATING MODE(ML) 654 I=OPERATING MODE(MR) 655 %IF OP=7 %THENSTART;! ** 656 %IF I#1 %THENSTART 657 LFAULT(113);! POWER MUST BE INTEGER 658 AR=4 659 INTEGER(ADICT)=1;! TO ALLOW CONTINUATION 660 %FINISH 661 %FINISHELSESTART 662 %IF I>MRES %THEN MRES=I;! evaluate expressions as I*4,R*4,R*8,C*8 or C*16 663 %FINISH 664 !* 665 %IF 1OPMODE(MRES) 678 !* 679 OPMODE(1): ! INTEGER*4 680 IL=INTEGER(AL) %unless Op=6 681 IR=INTEGER(AR) 682 ->IOP(OP) 683 !* 684 IOP(2):IR=IL+IR 685 IMEET: 686 IMEET2:%IF 0<=IR<=X'7FFF' %THENSTART 687 RES_H0=IR 688 Res_Form=0 689 Res_Mode=1 690 %result=0 691 %FINISH 692 INTEGER(ARES)=IR 693 RES_H0=DPTR>>DSCALE 694 Res_Form=1 695 Res_Mode=1 696 DPTR=DPTR+4 697 %result=0 698 !* 699 OVERI:%result=1 700 FAULT(112) 701 IR=1 702 ->IMEET2 703 !* 704 IOP(3):IR=IL-IR 705 ->IMEET 706 !* 707 IOP(4):IR=IL*IR 708 ->IMEET 709 !* 710 IOP(5):%IF IR=0 %THEN ->OVERI 711 IR=IL//IR 712 ->IMEET 713 !* 714 IOP(6):IR=-IR 715 ->IMEET 716 !* 717 IOP(7):%IF IR=0 %THEN IR=1 %ELSESTART 718 %IF IR<0 %THEN IR=0 %ELSESTART 719 I=IL 720 %WHILE IR>1 %CYCLE 721 I=I*IL 722 IR=IR-1 723 %REPEAT 724 IR=I 725 %FINISH 726 %FINISH 727 ->IMEET 728 !* 729 IOP(*):%monitor 730 %stop 731 !* 732 Opmode(3): 733 RL=REAL(AL) %unless Op=6 734 RR=REAL(AR) 735 ROPOP:->ROP(OP) 736 !* 737 ROP(2):RR=RL+RR 738 RMEET: 739 RMEET2:REAL(ARES)=RR 740 %IF MRES=6 %THEN REAL(ARES+W1)=CR 741 RES_H0=DPTR>>DSCALE 742 Res_Form=1 743 Res_Mode=0!MMAX 744 DPTR=DPTR+CSIZE(MMAX) 745 %result=0 746 !* 747 OVERR:%result=1 748 FAULT(112) 749 RR=1 750 ->RMEET2 751 !* 752 ROP(3):RR=RL-RR 753 ->RMEET 754 !* 755 ROP(4):RR=RL*RR 756 ->RMEET 757 !* 758 ROP(5):%IF RR=0 %THEN ->OVERR 759 RR=RL/RR 760 ->RMEET 761 !* 762 ROP(6):RR=-RR 763 ->RMEET 764 !* 765 ROP(7):IR=INTEGER(AR) 766 %IF IR=0 %THEN RR=1.0 %ELSESTART 767 %IF IR<0 %THEN RR=0 %ELSESTART 768 RR=RL 769 %WHILE IR>1 %CYCLE 770 RR=RR*RL 771 IR=IR-1 772 %REPEAT 773 %FINISH 774 %FINISH 775 ->RMEET 776 !* 777 ROP(*):%monitor 778 %stop 779 !* 780 Opmode(4): 781 %unless Op=6 %thenstart 782 copy(8,AL,0,addr(RRL),0) 783 %finish 784 copy(8,AR,0,addr(RRR),0) 785 RROPOP:->RROP(OP) 786 !* 787 RROP(2):RRR=RRL+RRR 788 RRMEET: 789 RRMEET2:LONGREAL(ARES)=RRR 790 %IF MRES=7 %THEN LONGREAL(ARES+W2)=CCR 791 RES_H0=DPTR>>DSCALE 792 RES_Form=1 793 RES_Mode=MMAX 794 DPTR=DPTR+CSIZE(MMAX) 795 %result=0 796 !* 797 OVERRR:%result=1 798 FAULT(112) 799 RRR=1 800 ->RRMEET2 801 !* 802 RROP(3):RRR=RRL-RRR 803 ->RRMEET 804 !* 805 RROP(4):RRR=RRL*RRR 806 ->RRMEET 807 !* 808 RROP(5):%IF RRR=0 %THEN ->OVERRR 809 RRR=RRL/RRR 810 ->RRMEET 811 !* 812 RROP(6):RRR=-RRR 813 ->RRMEET 814 !* 815 RROP(7):IR=INTEGER(AR) 816 %IF IR=0 %THEN RRR=1.0 %ELSESTART 817 %IF IR<0 %THEN RRR=0 %ELSESTART 818 RRR=RRL 819 %WHILE IR>1 %CYCLE 820 RRR=RRR*RRL 821 IR=IR-1 822 %REPEAT 823 %FINISH 824 %FINISH 825 ->RRMEET 826 !* 827 RROP(*):%monitor 828 %stop 829 !* 830 Opmode(6): 831 RL=real(AL) 832 CL=real(AL+W1) 833 %unless Op=6 %thenstart 834 RR=real(AR) 835 RW=RR 836 CR=real(AR+W1) 837 %finish 838 ->COP(Op) 839 !* 840 COP(2):CR=CL+CW 841 ->ROPOP 842 !* 843 COP(3):CR=CL-CW 844 ->ROPOP 845 !* 846 COP(4):RR=RL*RW-CL*CW 847 CR=RL*CW+RW*CL 848 ->RMEET 849 !* 850 COP5: 851 COP(5):RR=RL*RW+CL*CW 852 CR=RW*CL-RL*CW 853 RW=RW*RW+CW*CW 854 RR=RR/RW 855 CR=CR/RW 856 ->RMEET 857 !* 858 COP(6):CR=-CR 859 ->ROPOP 860 !* 861 COP(7):IR=INTEGER(AR) 862 IL=IR 863 %IF IR<0 %THEN IR=-IR 864 RR=RL 865 CR=CL 866 %WHILE IR>1 %CYCLE 867 RW=RR 868 CW=CR 869 RR=RL*RW-CL*CW 870 CR=RL*CW+RR*CL 871 IR=IR-1 872 %REPEAT 873 %IF IL<=0 %THENSTART 874 RW=RR 875 CW=CR 876 RL=1.0 877 RR=0 878 %IF IL#0 %THEN ->COP5 879 %FINISH 880 ->RMEET 881 !* 882 COP(*):%monitor 883 %stop 884 !* 885 Opmode(7): 886 copy(8,AL,0,addr(RRL),0) 887 copy(8,AL+W2,0,addr(CCL),0) 888 %unless Op=6 %thenstart 889 copy(8,AR,0,addr(RRR),0) 890 RRW=RRR 891 copy(8,AR+W2,0,addr(CCW),0) 892 %finish 893 ->CCOP(Op) 894 !* 895 CCOP(2):CCR=CCL+CCW 896 ->RROPOP 897 !* 898 CCOP(3):CCR=CCL-CCW 899 ->RROPOP 900 !* 901 CCOP(4):RRR=RRL*RRW-CCL*CCW 902 CCR=RRL*CCW+RRW*CCL 903 ->RRMEET 904 !* 905 CCOP5: 906 CCOP(5):RRR=RRL*RRW+CCL*CCW 907 CCR=RRW*CCL-RRL*CCW 908 RRW=RRW*RRW+CCW*CCW 909 RRR=RRR/RRW 910 CCR=CCR/RRW 911 ->RRMEET 912 !* 913 CCOP(6):CCR=-CCR 914 ->RROPOP 915 !* 916 CCOP(7):IR=INTEGER(AR) 917 IL=IR 918 %IF IR<0 %THEN IR=-IR 919 RRR=RRL 920 CCR=CCL 921 %WHILE IR>1 %CYCLE 922 RRW=RRR 923 CCW=CCR 924 RRR=RRL*RRW-CCL*CCW 925 CCR=RRL*CCW+RRR*CCL 926 IR=IR-1 927 %REPEAT 928 %IF IL<=0 %THENSTART 929 RRW=RRR 930 CCW=CCR 931 RRL=1.0 932 RRR=0 933 %IF IL#0 %THEN ->CCOP5 934 %FINISH 935 ->RRMEET 936 !* 937 CCOP(*):%monitor 938 %stop 939 !* 940 OP9: %result=1 941 FAULT(130) 942 RES_W=RESL 943 %result=0 944 !* 945 OPMODE(13):%UNLESS ML=MR %AND OP=1 %THEN ->OP9 946 FL=INTEGER(AL) 947 FR=INTEGER(AR) 948 INTEGER(ARES)=FL+FR 949 !! MOVE(FL,AL+4,ARES+4) 950 !! MOVE(FR,AR+4,ARES+4+FL) 951 RES_H0=DPTR>>DSCALE; RES_H1=X'10D' 952 DPTR=(DPTR+FL+FR+7)&(-4) 953 %result=0 954 !* 955 OPMODE(*): 956 %monitor 957 %stop 958 !* 959 %end;! Const Eval 960 !* 961 %integerfn Conout(%RECORD(RESF) R) 962 %RECORD(CONSTRECF)%NAME CON 963 %IF R_FORM=LIT %THEN %RESULT=R_H0 964 %IF R_FORM=NEGLIT %THEN %RESULT=-R_H0 965 CON==RECORD(COM_ADICT+R_H0<IOP(OP) 974 !* 975 IOP(2):VAL=IL+IR 976 IMEET: 977 IMEET2:%RESULT=VAL 978 !* 979 OVERI:VAL=1 980 %RESULT=1 981 !* 982 IOP(3):VAL=IL-IR 983 ->IMEET 984 !* 985 IOP(4):VAL=IL*IR 986 ->IMEET 987 !* 988 IOP(5):%IF IR=0 %THEN ->OVERI 989 VAL=IL//IR 990 ->IMEET 991 !* 992 IOP(6):VAL=-IR 993 ->IMEET 994 !* 995 IOP(7):%IF IR=0 %THEN IR=1 %ELSESTART 996 %IF IR<0 %THEN IR=0 %ELSESTART 997 I=IL 998 %WHILE IR>1 %CYCLE 999 I=I*IL 1000 IR=IR-1 1001 %REPEAT 1002 VAL=I 1003 %FINISH 1004 %FINISH 1005 ->IMEET 1006 !* 1007 IOP(*):%monitor 1008 %stop 1009 %end;! Conval 1010 !* 1011 %externalintegerfn Gconval(%integer IL,OP,IR,%integername Val) 1012 %INTEGER I 1013 %SWITCH IOP(2:8) 1014 ->IOP(OP) 1015 !* 1016 IOP(2):VAL=IL+IR 1017 IMEET: 1018 IMEET2:%RESULT=0 1019 !* 1020 OVERI:VAL=1 1021 %RESULT=1 1022 !* 1023 IOP(3):VAL=IL-IR 1024 ->IMEET 1025 !* 1026 IOP(4):VAL=IL*IR 1027 ->IMEET 1028 !* 1029 IOP(5):%IF IR=0 %THEN ->OVERI 1030 VAL=IL//IR 1031 ->IMEET 1032 !* 1033 IOP(6):VAL=-IR 1034 ->IMEET 1035 !* 1036 IOP(7):%IF IR=0 %THEN IR=1 %ELSESTART 1037 %IF IR<0 %THEN IR=0 %ELSESTART 1038 I=IL 1039 %WHILE IR>1 %CYCLE 1040 I=I*IL 1041 IR=IR-1 1042 %REPEAT 1043 VAL=I 1044 %FINISH 1045 %FINISH 1046 ->IMEET 1047 !* 1048 IOP(*):%monitor 1049 %stop 1050 %end;! Gconval 1051 !* 1052 %externalintegerfn Concheck(%record(Resf) Res) 1053 !*********************************************************************** 1054 !* if constant is any of -1, 0, 1, 2 then return integer val * 1055 !* else if -ve integer then return -2 * 1056 !* else if 0.5 then return 3 * 1057 !* else return 10 * 1058 !*********************************************************************** 1059 %CONSTINTEGERARRAY IVALS(0:3)=-1,0,1,2 1060 !$%CONSTINTEGERARRAY IIVALS(0:3) = -1,0,1,2 1061 !$%CONSTLONGLONGREALARRAY RVALS(0:4) = %C C !$ R'C110000000000000',0, C !$ R'4110000000000000',R'4120000000000000', C !$ R'4080000000000000' 1065 !$%LONGREAL RR 1066 !$%REAL R 1067 %INTEGER I,J 1068 !$%RECORD(CONSTRECF)%NAME CON 1069 !$%SWITCH M(0:5) 1070 !$ %UNLESS INT2M(RES_MODE) 1073 !$!* 1074 !$M(1): 1075 %if Res_Mode=INT4 %thenstart 1076 I=CONOUT(RES) 1077 %CYCLE J=0,1,3 1078 %IF I=IVALS(J) %THEN %RESULT=J-1 1079 %REPEAT 1080 %IF I<0 %THEN %RESULT=-2 1081 %RESULT=10 1082 %finish 1083 !$!* 1084 !$M2: %CYCLE J=0,1,3 1085 !$ %IF I=IIVALS(J)%THEN %RESULT=J-1 1086 !$ %REPEAT 1087 !$ %IF I<0 %THEN %RESULT=-2 1088 !$ %RESULT=10 1089 !$!* 1090 !$M(3): R=REAL(COM_ADICT+CON_DADDR) 1091 !$ RR=R 1092 !$ ->M5 1093 !$!* 1094 !$M(4): RR=LONGREAL(COM_ADICT+CON_DADDR) 1095 !$!* 1096 !$M5: %CYCLE J=0,1,4 1097 !$ %IF RR=RVALS(J) %THEN %RESULT=J-1 1098 !$ %REPEAT 1099 %RESULT=10 1100 !$!* 1101 !$M(*): %monitor 1102 !$ %stop 1103 %end;! Concheck 1104 %endoffile 1104 LINES ANALYSED SIZE= 30032 ? Warning :- Label realoverflow not used at line No 581 ? Warning :- Label operate not used at line No 959 ? Warning :- Label imeet2 not used at line No 1009 ? Warning :- Label imeet2 not used at line No 1050 ? Warning :- Name subrecf not used at line No 1104 ? Warning :- Name objfmt not used at line No 1104 ? Warning :- Name triadf not used at line No 1104 ? Warning :- Name dtrecf not used at line No 1104 ? Warning :- Name terecf not used at line No 1104 ? Warning :- Name fnrecf not used at line No 1104 ? Warning :- Name charf not used at line No 1104 ? Warning :- Name tmpf not used at line No 1104 ? Warning :- Name impdorecf not used at line No 1104 ? Warning :- Name plabf not used at line No 1104 ? Warning :- Name labrecf not used at line No 1104 ? Warning :- Name ifrecf not used at line No 1104 ? Warning :- Name lrecf not used at line No 1104 ? Warning :- Name arraydvf not used at line No 1104 ? Warning :- Name dorecf not used at line No 1104 ? Warning :- Name srecf not used at line No 1104 ? Warning :- Name precf not used at line No 1104 ? Warning :- Name setmode not used at line No 1104 ? Warning :- Name modetotempbytes not used at line No 1104 ? Warning :- Name modetobytes not used at line No 1104 ? Warning :- Name modetost not used at line No 1104 ? Warning :- Name reg1 not used at line No 1104 IBM CODE 8272+ 224 BYTES GLAP 336+ 0 BYTES DIAG TABLES 920 BYTES TOTAL 10352 BYTES 792 STATEMENTS COMPILED ROUTINE/FN/MAP cross reference tables for file ERCC07:L4 ROUTINE/FN/MAP TYPE REFERENCES COERCECONST ............... EXTERNALINTEGERFN .. 458 (DECLN) 398 (SPEC) 666 668 CONCHECK EXTERNALINTEGERFN 1052 (DECLN) 404 (SPEC) CONOUT .................... INTEGERFN .......... 961 (DECLN) 1076 CONSTEVAL EXTERNALINTEGERFN 584 (DECLN) 400 (SPEC) CONVAL .................... EXTERNALINTEGERFN .. 969 (DECLN) 402 (SPEC) COPY ROUTINE 440 (DECLN) 782 784 886 887 889 891 FAULT ..................... EXTERNALROUTINE .... 411 (SPEC) 568 572 575 700 748 798 941 GCONVAL ................... EXTERNALINTEGERFN .. 1011 (DECLN) 403 (SPEC) INITNUM EXTERNALROUTINE 454 (DECLN) 397 (SPEC) LFAULT .................... EXTERNALROUTINE .... 412 (SPEC) 657 SCALARSPACE EXTERNALINTEGERFN 410 (SPEC) 634 Source: ERCS08:F77REL.SRCE200_FCINNUM2A Compiled: 25/11/87 17.12.02 Object: .NULL Parms set: NOCHECK,NOARRAY,XREF ERCC. Portable Imp80 Compiler Release 4 Version 14 Sep 87 2047 4095 1 ! fcinnum2a 2 ! 23/03/87 - make both Host & Taget IBM 3 ! insert defs. for largestreal, maximumsingle &maximum double 4 ! fcinnum2 5 ! 23/03/87 - set unassigned patterns to 80 if taget = IBM 6 ! fcinnum1a 7 ! 15/01/87 - insert %alias for amdahl system routines 8 ! 9 ! Modified 5/June/86 8.00 10 11 12 13 14 15 16 17 18 !*********************************************************************** 19 !*********************************************************************%C C %C C %C C A SET OF NUMBER CONVERSION ROUTINES (version 6.0) %C C %C C FOR THE FORTRAN77 %C C %C C (used either by the compiler or F77IOA and F77IOC) %C C %C C %C C !*********************************************************************%C C !*********************************************************************** 31 32 33 34 !---Modes of Operation: 35 ! 36 ! 37 %constinteger Compile Time = 0 38 %constinteger Run Time1= 1 { report CONSTANT OUT OF RANGE} 39 %constinteger Run Time2= 2 {dont report CONSTANT OUT OF RANGE} 40 41 %constinteger MODE = Compile Time 42 43 !change MODE if running with the compiler! 44 45 46 47 48 49 50 51 52 53 54 !---Conditional Compilation Variables: 55 ! 56 ! 57 %constinteger EMAS = 0 58 %constinteger PERQ = 1 59 %constinteger PNX = 2 60 %constinteger IBM = 3 61 %constinteger PERQ3= 4 62 %constinteger Whitechapel= 5 63 %constinteger Gould= 6 64 65 %constinteger False= 0 66 %constinteger True = 1 67 68 69 70 71 72 !---------------------------------------! 73 ! ! 74 ! ! 75 ! CONDITIONAL COMPILATION CONSTANTS ! 76 ! ! 77 ! ! 78 !---------------------------------------! 79 80 %CONSTINTEGER TARGET= IBM 81 %CONSTINTEGER HOST= IBM 82 83 %CONSTINTEGER Relax Ansi= False 84 85 86 87 %IF TARGET=EMAS %THENSTART 88 ! 89 ! 90 ! Define Conditional Compilation Constants for EMAS 91 ! 92 ! 93 %CONSTINTEGER k= 0 ;!%C C k is set to the shift count required to convert %C C a byte displacement into an address displacement 96 97 %CONSTINTEGER HALFs= True ;!%C C HALFS= True implies that 16-bit entities are accessed%C C via the HALFINTEGER map and are unsigned 100 101 %CONSTINTEGER IEEE= False ;!%C C IEEE= False implies that floating point constants %C C conform to the 'excess-64' notation as %C C used by IBM and ICL 2900s 105 106 %CONSTINTEGER Byte Addressing= True ;!%C C Byte Addressing= True implies that {address}+1 %C C accesses the next byte and not the next word 109 110 %CONSTINTEGER CR Delimiter= False ;!%C C CR Delimiter= False implies that the Carriage Return %C C character is not an alternative record delimiter %C C to the Newline (NL) character in a formatted input%C C field 115 116 %CONSTINTEGER Output Len= 120 ;!%C C Output Len= the record length of the diagnostic %C C stream. If the record length of %C C this stream changes then only %C C this variable need be altered 121 122 %CONSTINTEGER UNIX IO= False ;!%C C UNIX IO= False implies that the underlying target %C C file system is not UNIX or UNIX based 125 126 %CONSTINTEGER Unassigned Word= X'80808080' 127 %CONSTINTEGER Unassigned Half= X'FFFF8080' 128 %CONSTINTEGER Unassigned Char= 0 129 130 ! {!!!} %CONSTLONGINTEGER Unassigned Long= R'8080808080808080' 131 %FINISH 132 133 134 135 136 %IF TARGET= IBM %THENSTART 137 ! 138 ! 139 ! Define Conditional Compilation Constants for Amdahl 140 ! 141 ! 142 %CONSTINTEGER k= 0 143 144 %CONSTINTEGER HALFs= False ;!%C C HALFS= False if 16-bit entities are accessed via %C C the SHORTINTEGER map and they are signed 147 %CONSTINTEGER IEEE= False 148 149 %CONSTINTEGER Byte Addressing= True 150 151 %CONSTINTEGER CR Delimiter= False 152 153 %CONSTINTEGER Output Len= 120 154 155 %CONSTINTEGER UNIX IO= False 156 157 %CONSTINTEGER Unassigned Word= X'80808080' 158 %CONSTINTEGER Unassigned Half= X'FFFF8080' 159 %CONSTINTEGER Unassigned Char= 0 160 161 ! {!!!} %CONSTLONGINTEGER Unassigned Long= R'8080808080808080' 162 %FINISH 163 164 165 166 %IF TARGET=PERQ %THENSTART 167 ! 168 ! 169 ! Define Conditional Compilation Constants for ACCENT or WHITECHAPEL 170 ! 171 ! 172 %CONSTINTEGER k= 1 173 174 %CONSTINTEGER HALFs= False 175 176 %CONSTINTEGER IEEE= True ;!%C C IEEE= True implies that floating point constants %C C conform to the IEEE Standard 179 180 %CONSTINTEGER Byte Addressing= False ;!%C C Byte Addressing= False implies that {address}+1 %C C accesses the next word and not the next byte 183 184 %CONSTINTEGER CR Delimiter= True ;!%C C CR Delimiter= True implies that the Carriage Return %C C character within a formatted input field is to be %C C regarded as an alternative record delimiter to the%C C Newline (NL) character 189 190 %CONSTINTEGER Output Len= 84 191 192 %CONSTINTEGER UNIX IO= False 193 194 %CONSTINTEGER Unassigned Word= X'80808080' 195 %CONSTINTEGER Unassigned Half= X'FFFF8080' 196 %CONSTINTEGER Unassigned Char= X'81' 197 %FINISH 198 199 200 201 %IF TARGET= PNX %THENSTART 202 ! 203 ! 204 ! Define Conditional Compilation Constants for PNX 205 ! 206 ! 207 %CONSTINTEGER k= 1 208 209 %CONSTINTEGER HALFs= True 210 211 %CONSTINTEGER IEEE= True 212 213 %CONSTINTEGER Byte Addressing= False 214 215 %CONSTINTEGER CR Delimiter= True 216 217 %CONSTINTEGER Output Len= 84 218 219 %CONSTINTEGER UNIX IO= True ;!%C C UNIX IO= True implies that the underlying target %C C file system is UNIX or UNIX-like 222 223 %CONSTINTEGER Unassigned Word= X'80808080' 224 %CONSTINTEGER Unassigned Half= X'FFFF8080' 225 %CONSTINTEGER Unassigned Char= X'80' 226 %FINISH 227 228 229 230 231 %IF TARGET= PERQ3 %THENSTART 232 ! 233 ! 234 ! Define Conditional Compilation Constants for PERQ3 235 ! 236 ! 237 %CONSTINTEGER k= 0 238 239 %CONSTINTEGER HALFs= False ;!%C C HALFS= False if 16-bit entities are accessed via %C C the SHORTINTEGER map and they are signed 242 %CONSTINTEGER IEEE= True 243 244 %CONSTINTEGER Byte Addressing= True 245 246 %CONSTINTEGER CR Delimiter = True 247 248 %CONSTINTEGER Output Len = 84 249 250 %CONSTINTEGER UNIX IO= True 251 252 %CONSTINTEGER Unassigned Word= X'81818181' 253 %CONSTINTEGER Unassigned Half= X'FFFF8181' 254 %CONSTINTEGER Unassigned Char= X'81' 255 %FINISH 256 257 258 259 260 %IF TARGET= Whitechapel %THENSTART 261 ! 262 ! 263 ! Define Conditional Compilation Constants for WHITECHAPEL 264 ! 265 ! 266 %CONSTINTEGER k= 0 267 268 %CONSTINTEGER HALFs= False ;!%C C HALFS= False if 16-bit entities are accessed via %C C the SHORTINTEGER map and they are signed 271 %CONSTINTEGER IEEE= True 272 273 %CONSTINTEGER Byte Addressing= False 274 275 %CONSTINTEGER CR Delimiter = True 276 277 %CONSTINTEGER Output Len = 84 278 279 %CONSTINTEGER UNIX IO= True 280 281 %CONSTINTEGER Unassigned Word= X'81818181' 282 %CONSTINTEGER Unassigned Half= X'FFFF8181' 283 %CONSTINTEGER Unassigned Char= X'81' 284 %FINISH 285 286 287 288 289 %IF TARGET= GOULD %THENSTART 290 ! 291 ! 292 ! Define Conditional Compilation Constants for GOULD 293 ! 294 ! 295 %CONSTINTEGER k= 0 296 297 %CONSTINTEGER HALFs= False ;!%C C HALFS= False if 16-bit entities are accessed via %C C the SHORTINTEGER map and they are signed 300 %CONSTINTEGER IEEE= False 301 302 %CONSTINTEGER Byte Addressing= True 303 304 %CONSTINTEGER CR Delimiter = True 305 306 %CONSTINTEGER Output Len = 80 307 308 %CONSTINTEGER UNIX IO= True 309 310 %CONSTINTEGER Unassigned Word= X'81818181' 311 %CONSTINTEGER Unassigned Half= X'FFFF8181' 312 %CONSTINTEGER Unassigned Char= X'81' 313 %FINISH 314 315 316 !NOTE: Other lines that might require changing are marked with the pattern {!!!} 317 318 319 320 321 322 323 324 325 %EXTERNALINTEGERFN IN NUMBER %ALIAS "S#INNUMBER" %C C (%INTEGER DATA AD, DATA LEN , FORMAT,BLANKS, C %INTEGER DECS, SCALE FACTOR, C %INTEGERNAME TEXT PTR , TEXT END , C %BYTEINTEGERARRAYNAME IO BUFFER, TEXT ) 330 ! 331 ! 332 ! 333 ! 334 ! This Procedure Analyses the Number in the Input Buffer 335 ! 336 ! to determine (A) if the Syntax is correct, C ! 338 ! (B) the scale of the number 339 ! 340 ! and to remove all occurrences of signs, exponents, and decimal points. 341 ! 342 ! 343 ! This Procedure then Converts the Number into Binary. 344 ! 345 ! 346 !The following table represents values assigned to each 347 ! character in the ISO Character Set. The assignments 348 ! are made on the following basis: 349 ! 350 %CONSTINTEGER Syntax Fault = 0 {for an invalid char}, C A Blank = 1 {for ' ' }, C A Digit = 2 {for '0' - '9' incl }, C A Sign = 3 {for '+' , '-' }, C A Decimal Point = 4 {for '.' }, C A Lower Case Exp{onent}= 5 {for 'd' , 'e' , 'q'}, C An Exponent = 6 {for 'D' , 'E' , 'Q'}, C A Comma = 7 {for premature end }; !%C C A Carriage Return = 7 { of field} 359 360 %CONSTBYTEINTEGERARRAY TYPE (0:127)= Syntax Fault (13), C A Comma {for Carriage Return}, C Syntax Fault (18), A Blank { }, C Syntax Fault (10), C A Sign { + } , A Comma , A Sign { - }, C A Decimal Point { . } , Syntax Fault , C A Digit {0-9} (10) , Syntax Fault (10), C An Exponent {D,E} ( 2) , Syntax Fault (11), C An Exponent { Q } , Syntax Fault (18), C A Lower Case Exp {d,e} ( 2) , Syntax Fault (11), C A Lower Case Exp { q} , Syntax Fault (14) 371 ! 372 ! 373 %SWITCH HANDLE (Syntax Fault:A Comma) 374 375 376 !NOTE that the parameter list makes no allowances for byte offsets 377 ! from word addresses which is required for type BYTE 378 ! when running on ACCENT, and hence it has been assumed 379 ! that for type BYTE the calling routine will nominate an 380 ! address of a four-byte work area which it will copy to 381 ! the final destination after IN NUMBER returns. 382 383 !NOTE if running in compiler mode then IN NUMBER returns -1 384 ! as a result if more digits are specified than can 385 ! be represented in the requested precision 386 ! 387 388 %IF MODE= Compile Time %THENSTART 389 ! 390 !INTEGER RESULT 391 392 %CONSTINTEGER No Comment= 0 , C Lost Significance= -1 394 395 %FINISH 396 397 398 399 ! 400 !*********************************************************************** 401 ! 402 ! CONSTANTS 403 ! 404 !*********************************************************************** 405 ! 406 %CONSTINTEGER CR =13 {for Carriage Return} 407 %CONSTINTEGER Zero = 0 408 %CONSTINTEGER Null = 0 409 %CONSTINTEGER Not Set = 0 410 %CONSTINTEGER Off = 0, On = 1 411 !Values taken by 'boolean' variables 412 ! (ie. Integers used as flags) 413 414 %CONSTINTEGER A Minus= 0 ; !values used internally 415 %CONSTINTEGER A Plus = 1 ; ! to indicate a positive or negative value is reqd 416 417 418 !Error Messages: 419 ! 420 ! 421 %CONSTINTEGER Invalid Integer = 140 422 %CONSTINTEGER Invalid Real = 141 423 %CONSTINTEGER Invalid Character = 148 424 {CONSTINTEGER Null Field = 133} 425 426 %IF MODE= Compile Time %THENSTART 427 %CONSTINTEGER Constant Out Of Range= 20 428 %FINISHELSESTART; %CONSTINTEGER Constant Out Of Range= 188 429 %FINISH 430 431 432 %IF HOST=EMAS %OR HOST= IBM %OR HOST= GOULD %THENSTART 433 434 %UNLESS TARGET= IBM %THENSTART 435 ! 436 ! Double Precision Floating-Point Constants 437 ! 438 %CONSTLONGREAL Largest Real= R'7FFFFFFFFFFFFFFF' 439 440 %FINISHELSESTART 441 ! 442 ! 'EXCESS 64' Notation Real Constants (for Amdahl) 443 ! 444 %CONSTLONGLONGREAL Largest Real= R'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' {!!} 445 %FINISH 446 447 %FINISHELSESTART 448 449 %IF HOST=PNX %OR HOST=PERQ3 %OR HOST=Whitechapel %THENSTART 450 ! 451 ! PNX/PERQ3/WHITECHAPEL Floating Point Constants 452 ! 453 %CONSTLONGREAL Largest Real= R'7FEFFFFFFFFFFFFF' 454 455 %FINISHELSESTART 456 ! 457 ! PERQ (POS) Floating-Point Constants 458 ! 459 %CONSTINTEGERARRAY PERQ LARGEST REAL (0:1)= X'FFFFFFFF', C X'7FEFFFFF' 461 %OWNLONGREALNAME LARGEST REAL ;!%C C LARGEST REAL is mapped onto PERQ LARGEST REAL 463 ! 464 ! 465 %FINISH; !if PERQ 466 %FINISH; !defining LARGEST REAL 467 468 469 470 %CONSTINTEGERARRAY Integer Power Of Ten (0:9)= %C C %C C 1, C 10, {by using this table } C 100, {we overcome any problem} C 1000, {we may have if integer } C 10000, {exponentiation has not } C 100000, {yet been implemented } C 1000000, C 10000000, C 100000000, C 1000000000 482 483 484 485 486 ! 487 !************************************************************************* 488 ! 489 ! SPECIFICATIONS FOR EXTERNAL PROCEDURES 490 ! 491 !************************************************************************* 492 ! 493 494 %EXTERNALLONGLONGREALFNSPEC POWER OF TEN %ALIAS "S#POWEROFTEN" (%INTEGER POWER) 495 496 497 498 499 500 ! 501 !************************************************************************ 502 ! 503 ! SPECIFICATIONS FOR LOCAL PROCEDURES 504 ! 505 !************************************************************************ 506 ! 507 508 %INTEGERFNSPEC TO INTEGER (%INTEGER DATA AD, DATA LEN , INT LEN , INT PTR) 509 %INTEGERFNSPEC TO REAL (%INTEGER DATA AD, DATA LEN , INT LEN , INT PTR) 510 511 %INTEGERFNSPEC COMPARE (%INTEGER LENGTH, THIS BASE, THIS DISP, C %INTEGER THAT BASE, THAT DISP) 513 514 515 516 517 518 ! 519 ! Local Variables 520 ! 521 %INTEGER D PTR ; !ptr to decimal digits in local buffer 522 %INTEGER E PTR ; !ptr to exponent digits in local buffer 523 %INTEGER E LEN ; !number of digits in the exponent 524 %INTEGER E SIGN; !set zero of no exponent sign 525 !set -ve if exponent sign='-' 526 !set +ve if exponent sign='+' 527 %INTEGER SIGN; !set zero if no numeric sign 528 !set -ve if numeric sign='-' 529 !set +ve if numeric sign='+' 530 %INTEGER B FLAG; ! if zero then leading spaces are to be ignored 531 %INTEGER C ; !the current character being analysed 532 %INTEGER I ; !the scanning ptr through the local buffer 533 %INTEGER LENGTH; !the number of digits specified 534 %INTEGER FAULT 535 ! 536 %INTEGER S1 PTR, S2 PTR, S PTR ;!%C C S1 PTR, S2 PTR are ptrs into the I/O buffer to positions %C C where significant digits for the numeric %C C and exponent parts respectively are expected 540 {and S PTR points to the exponent character in the I/O buffer} 541 %INTEGER PTR, PTR MAX ;!%C C PTR, PTR MAX point to the start and end of the text %C C in the I/O buffer respectively 544 545 %INTEGER INT PTR, INT LEN ;!%C C INT PTR, INT LEN describe the location and length of the %C C analysed text which has been placed in TEXT 548 549 ! 550 ! Exponent Related Variables 551 ! 552 %INTEGER EXP ; !the exponent converted into binary 553 %INTEGER MULT ; ! a multiplier used while converting the exponent 554 %INTEGER J ; !--a utility variable 555 556 557 ! 558 ! Initialise Variables 559 ! 560 D PTR = Not Set ; !=> no decimal point found 561 E PTR = Not Set ; !=> no exponent found 562 E SIGN= Not Set ; !=> no exponent sign found 563 SIGN= Not Set ; !=> no numeric sign found 564 B FLAG= Not Set ; !=> leading spaces are not significant 565 I = Not Set ; !=> no significant digits found 566 ! 567 PTR = TEXT PTR 568 PTR MAX = TEXT END 569 ! 570 !S1 PTR = PTR; !used to determine a null numeric 571 !S2 PTR = PTR; ! or null exponent part 572 573 ! 574 ! 575 ! ANALYSE THE NUMBER 576 ! 577 ! 578 %WHILE PTR HANDLE(TYPE(C)) {and go and process it} 583 584 585 HANDLE (Syntax Fault): ! Handle an ILLEGAL Character ! 586 ! ! 587 ! ! 588 INVALID CHAR : FAULT= Invalid Character; -> REPORT 589 INVALID REAL : FAULT= Invalid Real ; -> REPORT 590 INVALID INTEGER: FAULT= Invalid Integer 591 592 REPORT : TEXT PTR= PTR 593 %RESULT = FAULT 594 595 ! NULL FIELD1 : TEXT PTR= S1 PTR 596 ! %RESULT = Null Field 597 ! NULL FIELD2 : TEXT PTR= S2 PTR 598 ! %RESULT = Null Field 599 600 601 HANDLE (A Blank): ! Handle a SPACE Character ! 602 ! ! 603 ! ! 604 %CONTINUE %IF B FLAG= 0 %OR BLANKS\=Zero {ignore insignificant blanks} 605 ! 606 {otherwise} C ='0' {and fall through} 607 608 609 HANDLE (A Digit): ! Handle a DIGIT ! 610 ! ! 611 ! ! 612 I=I+1; TEXT(I)= C {save the digit} 613 B FLAG = ON 614 %CONTINUE 615 616 617 HANDLE (A Sign): ! Handle a SIGN (it may signify an exponent) ! 618 ! ! 619 ! ! 620 %IF E PTR=Not Set %THENSTART 621 %IF SIGN\=Not Set {ie we have already had a sign} %OR %C C I\=Not Set {ie we have at least one digit} %THEN %C C E SIGN= C %AND -> AN EXPONENT 624 {otherwise} SIGN= C {%AND S1 PTR= PTR} 625 %FINISHELSESTART 626 627 {IF E PTR \=Not Set %THENSTART} 628 %IF E PTR \= I+1 {ie sign is embedded in an exponent} %ORC C E SIGN\=Not Set {ie we have an exponent sign already} %C C %THEN -> INVALID REAL 631 E SIGN = C 632 {S2 PTR = PTR} 633 %FINISH 634 %CONTINUE 635 636 637 HANDLE (A Decimal Point): ! Handle a DECIMAL part ! 638 ! ! 639 ! ! 640 -> INVALID INTEGER %IF FORMAT='I' 641 -> INVALID REAL %IF D PTR\= 0 %C C %OR E PTR\= 0 643 644 B FLAG= ON {save any embedded blank} 645 D PTR = I+1 {note the decimal point} 646 %CONTINUE 647 648 649 HANDLE (A Lower Case Exp{onent}): ! Handle a Lower Case Exponent ! 650 ! ! 651 ! ! 652 C=C-' ' 653 {convert to upper case} 654 655 656 HANDLE (An Exponent): ! Handle an EXPONENT ! 657 AN EXPONENT : ! ! 658 ! ! 659 -> INVALID CHAR %IF C='Q' %AND RELAX ANSI= False 660 -> INVALID INTEGER %IF FORMAT='I' 661 -> INVALID REAL %IF E PTR\= Not Set 662 663 E PTR = I+1 664 B FLAG= Off 665 {S2 PTR= PTR %AND} S PTR= PTR 666 %CONTINUE 667 668 669 HANDLE (A Comma): ! Handle Premature End ! HANDLE (A Carriage Return): 670 ! of Input Field ! 671 ! ! 672 %IF CR Delimiter=False %AND C=CR %THEN -> INVALID CHAR 673 %EXIT 674 675 %REPEAT; !for the next character 676 677 678 LENGTH= I; TEXT PTR= PTR MAX - PTR 679 ! 680 ! ANALYSE THE ANALYSIS 681 ! 682 %IF E PTR\=Not Set %THENSTART 683 ! 684 ! Analyse the given Exponent 685 ! 686 %IF E PTR>LENGTH %THENSTART 687 ! -> NULL FIELD2 %IF BLANKS\=Zero %C C %OR S2 PTR = PTR 689 %FINISH 690 E LEN=LENGTH - (E PTR-1) 691 LENGTH= E PTR - 1 692 PTR= S PTR - 1 693 ! 694 ! Convert the given Exponent into Binary 695 ! 696 %IF E LEN> 9 %THENSTART 697 ! 698 !Use the Integer Conversion Routine for Large Exponents 699 ! 700 J=TO INTEGER(ADDR(EXP),4,E LEN,E PTR) 701 702 %FINISHELSESTART 703 ! 704 EXP = 0 705 %IF E LEN > 0 %THENSTART 706 ! 707 MULT= Integer Power Of Ten (E LEN - 1) 708 709 %WHILE MULT> 0 %CYCLE 710 EXP = EXP + (MULT * ( TEXT(E PTR) - '0')) 711 E PTR = E PTR+ 1 712 MULT= MULT//10 713 %REPEAT 714 %FINISH; %FINISH 715 ! 716 %IF EXP>32767 %THEN EXP= 32767 717 %IF E SIGN='-' %THEN EXP= -EXP 718 ! 719 SCALE FACTOR= -EXP 720 %FINISH 721 !Handling an Exponent 722 ! 723 ! Analyse the (rest of the) Number 724 ! 725 ! %IF LENGTH=Null %THENSTART 726 ! ! 727 ! -> NULL FIELD1 %IF S1 PTR = PTR - D PTR %OR %C C ! (S1 PTR\=S2 PTR - D PTR %AND BLANKS\=Zero) 729 ! %FINISH 730 %IF D PTR\=Null %THEN DECS=LENGTH - (D PTR-1) 731 732 ! 733 ! Prepare to Call a Numeric Conversion Routine 734 ! 735 %IF SIGN\= Not Set %THENSTART 736 ! 737 {set parameters} TEXT(0)= SIGN ; INT PTR= 0 738 {for a call on } INT LEN= LENGTH+1 739 { TO REAL } %FINISHELSESTART; INT LEN= LENGTH 740 { or on } INT PTR= 1 741 { TO INTEGER} %FINISH 742 743 ! 744 ! 745 ! NOW CONVERT TEXT INTO BINARY 746 ! 747 ! 748 %IF FORMAT= 'I' %THEN FAULT= TO INTEGER (DATA AD, DATA LEN, INT LEN, INT PTR) %C C %ELSE FAULT= TO REAL (DATA AD, DATA LEN, INT LEN, INT PTR) 750 751 %IF FAULT\= 0 %THEN TEXT PTR= PTR MAX 752 ! 753 %RESULT= FAULT 754 755 756 757 758 759 760 761 %INTEGERFN TO INTEGER (%INTEGER DATA AD , DATA LEN , TEXT LEN , TEXT INC) 762 ! 763 ! 764 ! 765 ! 766 ! THIS IS A PROCEDURE TO CONVERT A STRING OF CHARACTERS (which 767 ! 768 ! have been analysed syntactically) INTO AN INTEGER VALUE. 769 ! 770 ! 771 !The character string is assumed to be in the area TEXT, and is 772 !defined by the parameters TEXT LEN and TEXT INC which identify the 773 !length and start (relative to TEXT) of the string respectively. At 774 !exit the result is stored in the location defined by the parameters 775 !DATA AD and DATA LEN which identify the address and the length (in 776 !bytes) of the result location. 777 ! 778 ! 779 !NOTE1: It is assumed that there are no leading, embedded or trailing blanks 780 !NOTE2: The string of digits is assumed to represent a valid integer 781 ! 782 ! 783 ! At Exit: RESULT= 0 if the constant was within range 784 ! RESULT= 20 if the constant was out of range and MODE= Compile Time 785 ! RESULT=188 if the constant was out of range and MODE= Run Time1 786 ! 787 ! 788 ! 789 %IF TARGET= Gould %THENSTART 790 ! 791 ! 792 %CONSTINTEGERARRAY Maximum Of (0:2)= 0, -32768, X'80000000' 793 ! 794 !the values above represent the largest 795 ! values that may be assigned to a 796 ! INTEGER*1 or INTEGER*2 or INTEGER*4 respectively 797 %FINISHELSESTART 798 ! 799 ! 800 %CONSTINTEGERARRAY Maximum Of (0:2)= -128, -32768, X'80000000' 801 ! 802 !the values above represent the largest 803 ! values that may be assigned to a 804 ! BYTE or INTEGER*2 or INTEGER*4 respectively 805 %FINISH 806 807 808 !Text of the Largest Negative Integer: 809 ! 810 %CONSTBYTEINTEGERARRAY Largest Integer(0:9)= {-}'2','1','4','7','4', C '8','3','6','4','8' 812 813 ! 814 ! Variables used to Address the Digits 815 ! 816 %INTEGER PTR {scanning ptr through TEXT } 817 %INTEGER MAX PTR { maximum value PTR may have} 818 %INTEGER LEN ;!%C C LEN is the actual number %C C of significant digits in the TEXT 821 822 ! 823 ! Variables used to Convert the Digits to Binary 824 ! 825 %INTEGER SIGN ; !set +ve if value is positive, else set to zero 826 %INTEGER MULT ; !scaling to be applied to the next digit 827 %INTEGER SUM ; !the binary result 828 %INTEGER I 829 {a utility variable} 830 831 ! 832 ! Initialise Variables 833 ! 834 PTR= TEXT INC ; !initialise the scanning ptr 835 MAX PTR= TEXT LEN + PTR; !initialise its maximum value 836 837 ! 838 ! Check for a Sign 839 ! 840 SIGN= TEXT (PTR) 841 %IF SIGN< '0' %THENSTART 842 %IF SIGN='+' %THEN SIGN=A Plus %C C %ELSE SIGN=A Minus 844 PTR=PTR+1 845 %FINISH %ELSE SIGN=A Plus 846 847 ! 848 ! Check Magnitude of the Value 849 ! 850 LEN= MAX PTR - PTR 851 %IF LEN> 9 %THENSTART {chance of Integer Overflow later} 852 853 ! 854 ! Skip any Leading Spaces or Zeros 855 ! 856 A: I=TEXT(PTR) 857 %IF I='0' %THEN PTR= PTR + 1 %AND -> A 858 LEN= MAX PTR - PTR 859 -> INTEGER OVERFLOW %IF LEN> 10 860 -> SIMPLE APPROACH %IF LEN< 10 861 862 ! 863 ! Now Test for Integer Overflow (when there are 10 digits) 864 ! 865 I=COMPARE(10,ADDR(TEXT(0)),PTR,ADDR(Largest Integer(0)),0) 866 -> INTEGER OVERFLOW %C C %IF I+SIGN> 0 868 %FINISH 869 870 SIMPLE APPROACH: SUM=0; %IF LEN>0 %THENSTART 871 ! 872 ! Now Convert the Text into Binary 873 ! 874 MULT=-Integer Power Of Ten (LEN-1) 875 876 %WHILE MULT< 0 %CYCLE 877 ! 878 SUM = SUM + (MULT * (TEXT(PTR) - '0')) 879 PTR = PTR + 1 880 MULT= MULT//10 881 %REPEAT 882 883 SUM = -SUM %UNLESS SIGN=A Minus 884 %FINISH 885 886 %IF DATA LEN= 4 {bytes} %THENSTART 887 ! 888 ! 889 ! Assign the Value to an INTEGER*4 890 ! 891 ! 892 INTEGER(DATA AD)= SUM 893 %FINISHELSESTART 894 895 %IF DATA LEN= 2 {bytes} %THENSTART 896 ! 897 ! 898 ! Assign the Value to an INTEGER*2 899 ! 900 ! 901 %IF SIGN=A Minus %THENSTART 902 %IF SUM<-32768 %THEN -> INTEGER OVERFLOW 903 %FINISH %ELSE %IF SUM> 32767 %THEN -> INTEGER OVERFLOW 904 ! 905 ! 906 {Perform the Assignment} HALFINTEGER(DATA AD)= SUM %IF HALFs= True 907 SHORTINTEGER(DATA AD)= SUM %IF HALFs= False 908 909 %FINISHELSESTART 910 ! 911 ! 912 ! Assign the Value to a BYTE or (INTEGER*1 if Gould) 913 ! 914 ! 915 %IF SIGN=A Minus %THENSTART 916 917 %IF TARGET = Gould %AND SUM< 0 %THEN -> INTEGER OVERFLOW 918 %IF TARGET\= Gould %AND SUM<-128 %THEN -> INTEGER OVERFLOW 919 %FINISHELSESTART 920 921 %IF TARGET = Gould %AND SUM> 255 %THEN -> INTEGER OVERFLOW 922 %IF TARGET\= Gould %AND SUM> 127 %THEN -> INTEGER OVERFLOW 923 %FINISH 924 ! 925 ! 926 {Perform the Assignment} INTEGER(DATA AD)= SUM 927 ! Note that the calling routine is 928 %FINISH; ! expected to perform the actual 929 %FINISH; ! assignment 930 931 %RESULT= 0 {return with no errors} 932 933 934 INTEGER OVERFLOW: !check if this is a fault 935 ! 936 %IF MODE\= Run Time2 %THENRESULT= Constant Out Of Range 937 938 ! 939 ! Set Data Item to Maximum Permitted Value 940 ! 941 SUM= Maximum Of (DATA LEN >> 1) 942 SUM=-(SUM+1) %IF SIGN=A Plus 943 SUM= SUM & X'FF' %IF TARGET= Gould 944 ! 945 %IF DATA LEN= 2 %THENSTART 946 %IF Halfs= False %THEN SHORTINTEGER(DATA AD)= SUM %C C %ELSE HALFINTEGER(DATA AD)= SUM 948 %FINISHELSE INTEGER(DATA AD)= SUM 949 950 %RESULT= 0 951 952 %END; !of TO INTEGER 953 954 955 956 957 958 %INTEGERFN TO REAL (%INTEGER DATA AD, DATA LEN, INT LEN, INT PTR) 959 ! 960 ! 961 ! 962 ! 963 ! THIS PROCEDURE CONVERTS A STRING OF CHARACTERS (which have been 964 ! 965 ! analysed syntactically) INTO A FLOATING POINT NUMBER. 966 ! 967 ! 968 !The character string is assumed to be in an area TEXT and is defined 969 !by the parameters INT LEN, INT PTR, which identify the length and 970 !start (relative to TEXT) of the characters. The global integer DECS 971 !defines the implied positioning of the decimal point: while the global 972 !variable SCALE FACTOR defines the exponentiation to be applied to the 973 !result. The result is saved in the location defined by DATA AD and 974 !DATA LEN which specify its address and length (in bytes) respectively. 975 ! 976 ! 977 !NOTE1: There are no embedded or trailing blanks 978 !NOTE2: It is assumed that there are no leading spaces 979 !NOTE3: The character string is assumed to represent a 980 ! valid floating point number 981 ! 982 ! 983 ! At Exit: RESULT= 0 if the constant was within range 984 ! RESULT= 20 if the constant was out of range and MODE= Compile Time 985 ! RESULT=188 if the constant was out of range and MODE= Run Time1 986 ! 987 ! 988 ! 989 990 !NOTE if running in compiler mode then TO REAL returns -1 991 ! as a result if more digits are specified than can 992 ! be represented in the requested precision 993 ! 994 995 %IF MODE= Compile Time %THENSTART 996 ! 997 %INTEGER RESULT 998 999 !CONSTINTEGER No Comment= 0 , C Lost Significance= -1 1001 1002 %FINISH 1003 1004 1005 %IF IEEE= False %THENSTART; !-------------Define Excess-64 type Real Constants 1006 1007 %IF TARGET=EMAS %OR TARGET= IBM %THENSTART 1008 ! 1009 ! 1010 ! Declare IBM type specific Floating Point Constants 1011 ! 1012 ! 1013 %CONSTLONGLONGREAL Maximum Single = R'7FFFFFFF000000000000000000000000' {!!} 1014 %CONSTLONGLONGREAL Maximum Double = R'7FFFFFFFFFFFFFFF0000000000000000' {!!!} 1015 1016 %IF TARGET= EMAS %THENSTART 1017 ! 1018 !%OWNLONGLONGREAL Real4 Rounding= R'00000000800000000000000000000000' {!!!} 1019 !%OWNLONGLONGREAL Real8 Rounding= R'00000000000000000080000000000000' {!!!} 1020 ! 1021 !Note that on IBM style architectures, assignments to 1022 ! a shorter precision is rounded up, but not on 2900 1023 ! style architectures. 1024 %FINISH 1025 1026 %FINISHELSESTART 1027 ! 1028 ! Declare Gould specific Floating Point Constants 1029 ! 1030 %CONSTLONGREAL Maximum Single= R'7FFFFFFF00000000' 1031 %CONSTLONGREAL Maximum Double= R'7FFFFFFFFFFFFFFF' 1032 %FINISH 1033 1034 %CONSTINTEGER Max Power= 75 1035 %CONSTINTEGER Min Power= -78 1036 1037 %OWNSTRING(40) LARGEST POSSIBLE= "7237005577332262213973186563043052414499" 1038 1039 !LARGEST POSSIBLE is a representation, in characters, of 1040 ! the 40 most significant digits of the largest possible 1041 ! real in 'Excess 64' notation. 1042 1043 %FINISHELSESTART; !-------------Define IEEE type Real Constants 1044 ! 1045 ! 1046 ! Declare IEEE specific Floating Point Constants 1047 ! 1048 ! 1049 %CONSTLONGREAL Maximum Single= 3.40282356@+38 1050 %CONSTLONGREAL Minimum Single= 1.17549440@-38 1051 1052 %CONSTINTEGER Min Power = -306 1053 %CONSTINTEGER Max Power = 308 1054 1055 %OWNSTRING(16) LARGEST POSSIBLE= "1797693134862315" 1056 1057 !LARGEST POSSIBLE is a representation, in characters, of 1058 ! the 16 most significant digits of the largest possible 1059 ! real defined in the IEEE Standard 1060 %FINISH 1061 1062 ! 1063 ! Variables used to Address the Digits 1064 ! 1065 %INTEGER PTR {scanning ptr through TEXT } 1066 %INTEGER MAX PTR { maximum value PTR may have} 1067 %INTEGER LEN ;!%C C LEN is the actual number %C C of significant digits in the TEXT 1070 1071 ! 1072 ! Variables associated with the Scale of the Number 1073 ! 1074 %INTEGER MAX DIGITS; !maximum significant digits associated with the required precision 1075 %INTEGER VAL SIZE ; !scale of the leftmost significant digit 1076 %INTEGER EXP ; !scale of the rightmost significant digit 1077 %INTEGER SIGN ; ! sign of the value, either=A MINUS, C or=A PLUS 1079 ! 1080 ! Variables used in Numeric Conversion 1081 ! 1082 %INTEGER MULT ; !scaling to be applied to the next digit 1083 %INTEGER SUM ; ! binary integer value of the digits bar scaling 1084 %LONGLONGREAL X ; ! actual Real result 1085 %REAL Y 1086 1087 1088 EXP=-(SCALE FACTOR+DECS) 1089 ! 1090 !Initialise the exponentiation to be applied 1091 1092 ! 1093 ! 1094 ! Examine the Number 1095 ! 1096 ! 1097 SIGN=A Plus {guess} 1098 ! 1099 %IF INT LEN>0 %THENSTART 1100 ! 1101 ! Look for a Numeric Sign 1102 ! 1103 SIGN= TEXT(INT PTR) 1104 %IF SIGN<'0' %THENSTART 1105 %IF SIGN='-' %THEN SIGN=A Minus 1106 INT LEN=INT LEN-1 1107 INT PTR=INT PTR+1 1108 ! 1109 %FINISH 1110 %FINISH 1111 1112 PTR= 1; MAX PTR= INT LEN 1113 1114 ! 1115 ! Ignore Leading and Trailing Zeros 1116 ! 1117 PTR= PTR+1 %WHILE MAX PTR>=PTR %AND TEXT(PTR)='0' 1118 !ignore any leading zeros 1119 MAX PTR=MAX PTR-1 %AND %C C EXP= EXP+1 %WHILE MAX PTR>=PTR %AND TEXT(MAX PTR)='0' 1121 !ignore any trailing zeros 1122 1123 ! 1124 ! Determine the Magnitude of the Value 1125 ! 1126 LEN=MAX PTR - (PTR-1) %AND MAX DIGITS= DATA LEN << 1 1127 %IF LEN>MAX DIGITS %THENSTART {= 8 or 16 or 32} 1128 ! 1129 ! Ignore any digits which have no bearing on the result 1130 ! 1131 EXP= EXP + (LEN-MAX DIGITS) 1132 LEN= MAX DIGITS 1133 RESULT= Lost Significance %IF MODE= Compile Time 1134 ! 1135 %FINISHELSE %IF MODE= Compile Time %THEN RESULT= No Comment 1136 1137 VAL SIZE=EXP + (LEN-1); !NOTE: LEN=number of significant digits 1138 ! ! EXP= scale of rightmost digit 1139 ! ! VAL SIZE= scale of leftmost digit 1140 %IF VAL SIZE> Max Power %OR %C C EXP < Min Power %THEN -> FURTHER EXAMINATION 1142 !Jump if 1143 ! the value is around or beyond 1144 ! the capabilities of the code below 1145 1146 FORM RESULT: X=0.0 1147 ! 1148 ! Test for a Zero 1149 ! 1150 %IF LEN<= 0 %THENSTART 1151 ! 1152 -> ASSIGN A REAL4 %IF DATA LEN= 4 1153 -> ASSIGN A REAL8 %IF DATA LEN= 8 %OR TARGET\= IBM 1154 -> ASSIGN A REAL16 %IF TARGET= IBM 1155 %FINISH 1156 1157 ! 1158 ! 1159 ! Perform the Conversion 1160 ! 1161 ! 1162 %IF LEN> 9 %THENSTART 1163 %CYCLE; MULT= 100000000 {10 ** ** 8} 1164 SUM= 0 1165 1166 %CYCLE; SUM = SUM + (MULT * (TEXT(PTR) - '0')) 1167 PTR = PTR + 1 1168 MULT= MULT// 10 1169 %REPEAT %UNTIL MULT<= 0 1170 1171 LEN= LEN - 9 1172 X= X + (SUM * POWER OF TEN(EXP+LEN)) 1173 1174 %REPEAT %UNTIL LEN< 10 1175 %FINISH 1176 ! 1177 !The loop above is used when more than 9 digits are to be converted 1178 ! into a floating point number. Each set of nine digits (from 1179 ! left to right) are converted into an integer, then scaled as 1180 ! appropriate, and then added to the result of the previous 1181 ! loop (if any). Note if 10 or more digits were processed as a 1182 ! time then overflow would/could occur. 1183 1184 !The code below operates similarly as above but uses the final 1185 !N digits (N<=9), and incorporates the result into the running 1186 !total if any: 1187 1188 MULT= Integer Power Of Ten (LEN-1) 1189 SUM= 0 1190 1191 %CYCLE; SUM= SUM + (MULT * (TEXT(PTR) - '0')) 1192 PTR= PTR + 1 1193 MULT=MULT//10 1194 %REPEAT %UNTIL MULT<= 0 1195 1196 X= X + (SUM * POWER OF TEN(EXP)) 1197 1198 1199 RETURN RESULT: 1200 ! 1201 ! 1202 ! Assign the Value to the I/O Item 1203 ! 1204 ! 1205 1206 %IF DATA LEN= 4 %THENSTART 1207 ! 1208 ! Return a Single Precision Real 1209 ! 1210 %IF X>= Maximum Single %THENSTART 1211 1212 %IF TARGET\=IBM %AND X> Maximum Single %AND MODE\=Run Time2 %THEN -> CHECK MODE 1213 X= Maximum Single;%FINISHELSESTART 1214 1215 %IF TARGET\=IBM %ANDC C TARGET\=GOULD %AND X<=Minimum Single %THENSTART 1217 %IF X< Minimum Single %AND MODE\=Run Time2 %THEN -> CHECK MODE 1218 X= Minimum Single;%FINISH 1219 1220 %IF TARGET=EMAS %THEN BYTEINTEGER(ADDR(Real4 Rounding))=BYTEINTEGER(ADDR(X)) %C C %AND X= X + Real4 Rounding 1222 %FINISH 1223 1224 ASSIGN A REAL4: Y= X 1225 ! 1226 Y =-Y %IF SIGN=A Minus 1227 REAL(DATA AD)= Y 1228 -> RETURN 1229 %FINISH 1230 1231 %IF TARGET= IBM %AND DATA LEN= 16 %THENSTART 1232 ! 1233 ! Return an Extended Precision Real 1234 ! 1235 ASSIGN A REAL16: X =-X %IF SIGN=A Minus 1236 LONGLONGREAL(DATA AD)= X 1237 -> RETURN 1238 %FINISH 1239 1240 ! 1241 ! Return a Double Precision Real 1242 ! 1243 %IF TARGET = IBM %OR TARGET= EMAS %THENSTART 1244 ! 1245 %IF X>= Maximum Double %THEN X= Maximum Double %ELSESTART 1246 1247 %IF TARGET=EMAS %THEN BYTEINTEGER(ADDR(Real8 Rounding))= BYTEINTEGER(ADDR(X)) %C C %AND X=X + Real8 Rounding 1249 %FINISH 1250 %FINISH 1251 1252 ASSIGN A REAL8: X =-X %IF SIGN=A Minus 1253 LONGREAL(DATA AD)= X 1254 1255 RETURN: %RESULT= RESULT %IF MODE= Compile Time 1256 %RESULT= 0 1257 != 0 if run time 1258 1259 1260 FURTHER EXAMINATION: !required for very large or for very small 1261 ! values before conversion can be 1262 ! attempted 1263 ! 1264 %IF VAL SIZE< Min Power %THEN -> VALUE TOO SMALL 1265 %IF VAL SIZE>= Max Power %THENSTART 1266 %IF VAL SIZE = Max Power %THENSTART 1267 ! 1268 ! Compare Digits with the Largest Possible Real 1269 ! 1270 -> VALUE TOO LARGE %C C %IF COMPARE (LEN,ADDR(TEXT(0)), PTR, C ADDR(LARGEST POSSIBLE),1)>0 1273 %FINISHELSE %C C {!} %C C %IF LEN=0 %THEN -> VALUE TOO SMALL %C C %ELSE -> VALUE TOO LARGE 1277 %FINISH 1278 1279 %IF EXP< Min Power %THENSTART 1280 ! 1281 ! Ignore digit which will have no effect on the Result 1282 ! 1283 LEN = LEN + (EXP-Min Power) 1284 EXP = Min Power 1285 %FINISH 1286 1287 -> FORM RESULT 1288 1289 1290 ! 1291 ! HANDLE NUMBERS OUT OF THE PERMITTED RANGE 1292 ! 1293 VALUE TOO SMALL: X= 0.0 ; -> CHECK MODE 1294 VALUE TOO LARGE: X=LARGEST REAL; 1295 ! 1296 CHECK MODE : %IF MODE\= Run Time2 %THENRESULT= Constant Out Of Range 1297 !\=> it is a fault 1298 1299 -> RETURN RESULT 1300 ! 1301 ! 1302 ! 1303 %END; !of TO REAL 1304 1305 1306 1307 1308 ! 1309 !*********************************************************************** 1310 ! 1311 ! UTILITY PROCEDURES 1312 ! 1313 !*********************************************************************** 1314 ! 1315 1316 %INTEGERFN COMPARE (%INTEGER LENGTH, THIS BASE, THIS DISP, C THAT BASE, THAT DISP) 1318 ! 1319 ! 1320 ! 1321 ! 1322 ! A Utility Procedure to lexographically compare two texts 1323 ! 1324 ! of equal length and to return a value which 1325 ! 1326 ! represents the result of the comparision. 1327 ! 1328 ! 1329 ! At Exit: RESULT= 0 if Text(THIS BASE)=Text(THAT BASE) or LENGTH<=0 1330 ! RESULT= -1 if Text(THIS BASE)Text(THAT BASE) 1332 ! 1333 ! 1334 ! 1335 %IF TARGET= PERQ %OR TARGET= Whitechapel %THENSTART 1336 1337 %BYTEINTEGERARRAYFORMAT Byte Format (0:30000) 1338 %BYTEINTEGERARRAYNAME THIS 1339 %BYTEINTEGERARRAYNAME THAT 1340 THAT== ARRAY (THAT BASE, Byte Format) 1341 THIS== ARRAY (THIS BASE, Byte Format) 1342 %WHILE LENGTH>0 %CYCLE 1343 ! 1344 %RESULT= 1 {greater than} %IF THIS(THIS DISP)> THAT(THAT DISP) 1345 %RESULT=-1 { less than} %IF THIS(THIS DISP)< THAT(THAT DISP) 1346 1347 THIS DISP= THIS DISP + 1 1348 THAT DISP= THAT DISP + 1 1349 LENGTH= LENGTH - 1 1350 %REPEAT 1351 %RESULT= 0 {equal if we fall through the cycle} 1352 1353 %FINISHELSESTART 1354 ! 1355 %IF TARGET= PNX %THENSTART 1356 ! 1357 THIS BASE= THIS BASE + THIS BASE + THIS DISP 1358 THAT BASE= THAT BASE + THAT BASE + THAT DISP 1359 %FINISHELSESTART 1360 ! 1361 THAT BASE= THAT BASE +THAT DISP 1362 THIS BASE= THIS BASE +THIS DISP 1363 %FINISH 1364 1365 %WHILE LENGTH>0 %CYCLE 1366 ! 1367 %RESULT= 1 {greater than} %C C %IF BYTEINTEGER(THIS BASE)>BYTEINTEGER(THAT BASE) 1369 1370 %RESULT=-1 { less than} %C C %IF BYTEINTEGER(THIS BASE) (Etos) } 532 {02} %constinteger ISUB = 2 { (Etos-1) - (Etos) => (Etos) } 533 {03} %constinteger IMULT = 3 { (Etos-1) * (Etos) => (Etos) } 534 {04} %constinteger IDIV = 4 { (Etos-1) / (Etos) => (Etos) } 535 {05} %constinteger INEG = 5 { - (Etos) => (Etos) } 536 {06} %constinteger IABS = 6 { abs( (Etos) ) => (Etos) } 537 {07} %constinteger IREM = 7 { remainder from } 538 { (Etos-1) / (Etos)=> (Etos) } 539 ! 540 {08} %constinteger IAND = 8 { (Etos-1) & (Etos) => (Etos) } 541 {09} %constinteger IOR = 9 { (Etos-1) ! (Etos) => (Etos) } 542 {0A} %constinteger INOT = 10 { ~ (Etos) => (Etos) } 543 {0B} %constinteger IXOR = 11 { (Etos-1) !! (Etos) => (Etos) } 544 {0C} %constinteger ISHLL = 12 { (Etos-1) << (Etos) => (Etos) } 545 {0D} %constinteger ISHRL = 13 { (Etos-1) >> (Etos) => (Etos) } 546 {0E} %constinteger ISHLA = 14 { arithmetic left shift } 547 {0F} %constinteger ISHRA = 15 { arithmetic right shift } 548 ! 549 {10} %constinteger IGT = 16 { if } 550 {11} %constinteger ILT = 17 { (Etos-1) (Etos) } 551 {12} %constinteger IEQ = 18 { then } 552 {13} %constinteger INE = 19 { true (1) => (Etos) } 553 {14} %constinteger IGE = 20 { else } 554 {15} %constinteger ILE = 21 { false (0) => (Etos) } 555 {16} %constinteger BNOT= 22 { (Etos) = BNOT (Etos) 0<->1 } 556 ! 557 {18} %constinteger JIGT = 24 { if } 558 {19} %constinteger JILT = 25 { (Etos-1) (Etos) } 559 {1A} %constinteger JIEQ = 26 { then } 560 {1B} %constinteger JINE = 27 { ->