1{****************************************************************} 2{ CODE GENERATOR TEST PROGRAM } 3{****************************************************************} 4{ NODE TESTED : secondin() } 5{****************************************************************} 6{ PRE-REQUISITES: secondload() } 7{ secondassign() } 8{ secondtypeconv() } 9{ secondadd() for sets } 10{ secondsetelement() } 11{ secondcalln() } 12{ secondfuncret() } 13{****************************************************************} 14{ DEFINES: } 15{ FPC = Target is FreePascal compiler } 16{****************************************************************} 17{ REMARKS: } 18{ } 19{ } 20{ } 21{****************************************************************} 22 23type 24 { DO NOT CHANGE THE VALUES OF THESE ENUMERATIONS! } 25 26 { This will fit into a 32-bit small set } 27 tsmallenum = (dA,dB,dC,dd,de,df,dg,dh,di,dj,dk,dl,dm,dn,dop,dp,dq,dr); 28 { This will fit into a normal 32-byte set } 29 tbigenum = (A_ABCD, 30 A_ADD,A_ADDA,A_ADDI,A_ADDQ,A_ADDX,A_AND,A_ANDI, 31 A_ASL,A_ASR,A_BCC,A_BCS,A_BEQ,A_BGE,A_BGT,A_BHI, 32 A_BLE,A_BLS,A_BLT,A_BMI,A_BNE,A_BPL,A_BVC,A_BVS, 33 A_BCHG,A_BCLR,A_BRA,A_BSET,A_BSR,A_BTST,A_CHK, 34 A_CLR,A_CMP,A_CMPA,A_CMPI,A_CMPM,A_DBCC,A_DBCS,A_DBEQ,A_DBGE, 35 A_DBGT,A_DBHI,A_DBLE,A_DBLS,A_DBLT,A_DBMI,A_DBNE,A_DBRA, 36 A_DBPL,A_DBT,A_DBVC,A_DBVS,A_DBF,A_DIVS,A_DIVU, 37 A_EOR,A_EORI,A_EXG,A_ILLEGAL,A_EXT,A_JMP,A_JSR, 38 A_LEA,A_LINK,A_LSL,A_LSR,A_MOVE,A_MOVEA,A_MOVEI,A_MOVEQ, 39 A_MOVEM,A_MOVEP,A_MULS,A_MULU,A_NBCD,A_NEG,A_NEGX, 40 A_NOP,A_NOT,A_OR,A_ORI,A_PEA,A_ROL,A_ROR,A_ROXL, 41 A_ROXR,A_RTR,A_RTS,A_SBCD,A_SCC,A_SCS,A_SEQ,A_SGE, 42 A_SGT,A_SHI,A_SLE,A_SLS,A_SLT,A_SMI,A_SNE, 43 A_SPL,A_ST,A_SVC,A_SVS,A_SF,A_SUB,A_SUBA,A_SUBI,A_SUBQ, 44 A_SUBX,A_SWAP,A_TAS,A_TRAP,A_TRAPV,A_TST,A_UNLK, 45 A_RTE,A_RESET,A_STOP, 46 A_BKPT,A_MOVEC,A_MOVES,A_RTD, 47 A_BFCHG,A_BFCLR,A_BFEXTS,A_BFEXTU,A_BFFFO, 48 A_BFINS,A_BFSET,A_BFTST,A_CALLM,A_CAS,A_CAS2, 49 A_CHK2,A_CMP2,A_DIVSL,A_DIVUL,A_EXTB,A_PACK,A_RTM, 50 A_TRAPCC,A_TRACS,A_TRAPEQ,A_TRAPF,A_TRAPGE,A_TRAPGT, 51 A_TRAPHI,A_TRAPLE,A_TRAPLS,A_TRAPLT,A_TRAPMI,A_TRAPNE, 52 A_TRAPPL,A_TRAPT,A_TRAPVC,A_TRAPVS,A_UNPK, 53 { FPU Processor instructions - directly supported only. } 54 { IEEE aware and misc. condition codes not supported } 55 A_FABS,A_FADD, 56 A_FBEQ,A_FBNE,A_FBNGT,A_FBGT,A_FBGE,A_FBNGE, 57 A_FBLT,A_FBNLT,A_FBLE,A_FBGL,A_FBNGL,A_FBGLE,A_FBNGLE, 58 A_FDBEQ,A_FDBNE,A_FDBGT,A_FDBNGT,A_FDBGE,A_FDBNGE, 59 A_FDBLT,A_FDBNLT,A_FDBLE,A_FDBGL,A_FDBNGL,A_FDBGLE,A_FBDNGLE, 60 A_FSEQ,A_FSNE,A_FSGT,A_FSNGT,A_FSGE,A_FSNGE, 61 A_FSLT,A_FSNLT,A_FSLE,A_FSGL,A_FSNGL,A_FSGLE,A_FSNGLE, 62 A_FCMP,A_FDIV,A_FMOVE,A_FMOVEM, 63 A_FMUL,A_FNEG,A_FNOP,A_FSQRT,A_FSUB,A_FSGLDIV, 64 A_FSFLMUL,A_FTST, 65 A_FTRAPEQ,A_FTRAPNE,A_FTRAPGT,A_FTRAPNGT,A_FTRAPGE,A_FTRAPNGE, 66 A_FTRAPLT,A_FTRAPNLT,A_FTRAPLE,A_FTRAPGL,A_FTRAPNGL,A_FTRAPGLE,A_FTRAPNGLE, 67 A_CPRESTORE,A_CPSAVE, 68 A_FRESTORE,A_FSAVE,A_PFLUSH,A_PFLUSHA,A_PLOAD,A_PMOVE,A_PTEST, 69 A_LABEL,A_NONE); 70 71 { this is also a normal set } 72 tregister = (R_NO, 73 R_EAX,R_ECX,R_EDX,R_EBX,R_ESP,R_EBP,R_ESI,R_EDI, 74 R_AX,R_CX,R_DX,R_BX,R_SP,R_BP,R_SI,R_DI, 75 R_AL,R_CL,R_DL,R_BL,R_AH,R_CH,R_BH,R_DH, 76 R_CS,R_DS,R_ES,R_SS,R_FS,R_GS, 77 R_ST,R_ST0,R_ST1,R_ST2,R_ST3,R_ST4,R_ST5,R_ST6,R_ST7, 78 R_DR0,R_DR1,R_DR2,R_DR3,R_DR6,R_DR7, 79 R_CR0,R_CR2,R_CR3,R_CR4, 80 R_TR3,R_TR4,R_TR5,R_TR6,R_TR7, 81 R_MM0,R_MM1,R_MM2,R_MM3,R_MM4,R_MM5,R_MM6,R_MM7, 82 R_XMM0,R_XMM1,R_XMM2,R_XMM3,R_XMM4,R_XMM5,R_XMM6,R_XMM7 83 ); 84const 85 LoReg = R_EAX; 86 HiReg = R_DH; 87 88 89 90type 91 tnormalset = set of tbigenum; 92 tsmallset = set of tsmallenum; 93 tregset = set of LoReg..HiReg; 94 95 96 97 procedure checkpassed(passed : boolean); 98 begin 99 if passed then 100 WriteLn('Passed!') 101 else 102 begin 103 WriteLn('Failure.'); 104 Halt(1); 105 end; 106 end; 107 108 109var 110 NewRegsEncountered : TRegSet; 111 112 113 114 function Reg32 : tregister; 115 begin 116 Reg32:=R_EAX; 117 end; 118 119 120{*******************************************************************} 121{ The following cases are possible } 122{ jump table usage } 123{ small set or normal set } 124{ source location : REFERENCE,MEMORY,CONSTANT or REGISTER } 125{*******************************************************************} 126 127 { NO GENERATION OF JUMP TABLE } 128 { SMALL SET } 129 procedure smallsettestone; 130 var 131 op1 : tsmallset; 132 op2 : tsmallset; 133 op3 : tsmallset; 134 op : tsmallenum; 135 passed : boolean; 136 begin 137 passed := true; 138 Write('Small set in operator test (without case table)...'); 139 140 { LEFT : LOC_REFERENCE (not a constant node) } 141 { RIGHT : LOC_REFERENCE } 142 op1 := [DI]; 143 op2 := [DI]; 144 op := DI; 145 if not (op in op1) then 146 passed := false; 147 148 { LEFT : LOC_REFERENCE (a constant node) } 149 { RIGHT: LOC_REFERENCE } 150 op1 := [DL]; 151 op := DI; 152 if not (DL in op1) then 153 passed := false; 154 { LEFT : LOC_REFERENCE (a constant node) } 155 { THIS CAN NEVER HAPPEN - EVALUATED AT COMPILE TIME BY COMPILER } 156 op1 := [DB]; 157 op := DB; 158 if not (DB in [DA..DL]) then 159 passed := false; 160 { LEFT : LOC_REFERENCE (not a constant node) } 161 { RIGHT : LOC_REGISTER,LOC_CREGISTER } 162 op := DF; 163 op2 := [DB]; 164 op3 := [DF]; 165 if not (op in (op2+op3)) then 166 passed := false; 167 168 { LEFT : LOC_REGISTER (a constant node) } 169 { RIGHT : LOC_REGISTER,LOC_CREGISTER } 170 op2 := [DB]; 171 op3 := [DF]; 172 if not (DB in (op2+op3)) then 173 passed := false; 174 checkpassed(passed); 175 end; 176 177 178 { returns result in register } 179 function getsmallop : tsmallenum; 180 begin 181 getsmallop := DQ; 182 end; 183 184 { NO GENERATION OF JUMP TABLE } 185 { SMALL SET } 186 procedure smallsettestthree; 187 var 188 op1 : tsmallset; 189 op2 : tsmallset; 190 op3 : tsmallset; 191 op : tsmallenum; 192 passed : boolean; 193 begin 194 passed := true; 195 Write('Small set in operator test (without case table)...'); 196 197 { LEFT : LOC_REGISTER (not a constant node) } 198 { RIGHT : LOC_REFERENCE } 199 op1 := [DQ]; 200 op2 := [DQ]; 201 if not (getsmallop in op1) then 202 passed := false; 203 204 { LEFT : LOC_REGISTER (not a constant node) } 205 { RIGHT : LOC_REGISTER } 206 op := DF; 207 op2 := [DB,DQ]; 208 op3 := [DF]; 209 if not (getsmallop in (op2+op3)) then 210 passed := false; 211 212 checkpassed(passed); 213 end; 214 215 { GENERATION OF JUMP TABLE } 216 { SMALL SET } 217 procedure smallsettesttwo; 218 var 219 op1 : tsmallset; 220 op2 : tsmallset; 221 op : tsmallenum; 222 passed : boolean; 223 begin 224 Write('Small set in operator test (with case table)...'); 225 passed := true; 226 op := DN; 227 { LEFT : LOC_REFERENCE } 228 { RIGHT: range constant set (carry flag) } 229 if not (op in [DB..DN]) then 230 passed := false; 231 { LEFT : LOC_REFERENCE } 232 { RIGHT: NOT range constant set (zero flag) } 233 op := DH; 234 if not (op in [DB,DH,DP]) then 235 passed := false; 236 { LEFT : LOC_REFERENCE } 237 { RIGHT : range constant set with full set } 238 op:=DK; 239 if not (op in [dA,dB,dC,dd,de,df,dg,dh,di,dj,dk,dl,dm,dn,dop,dp,dq,dr]) then 240 passed := false; 241 242 { LEFT : LOC_REGISTER } 243 { RIGHT : NOT range constant set (zero flag) } 244 op := DH; 245 if not (getsmallop in [DA,DB..DN,DQ]) then 246 passed := false; 247 { LEFT : LOC_REGISTER } 248 { RIGHT : range constant set with full set } 249 if not (getsmallop in [dA,dB,dC,dd,de,df,dg,dh,di,dj,dk,dl,dm,dn,dop,dp,dq,dr]) then 250 passed := false; 251 checkpassed(passed); 252 end; 253 254 255 { returns result in register } 256 function getop : tbigenum; 257 begin 258 getop := A_BFSET; 259 end; 260 261 { NO JUMP TABLE } 262 { NORMAL SETS } 263 procedure settestone; 264 var 265 op1 : tnormalset; 266 op2 : tnormalset; 267 op : tbigenum; 268 passed : boolean; 269 begin 270 Write('Normal set in operator test (without case table)...'); 271 passed := true; 272 { RIGHT NODE = immediate value in reference field ?? } 273 { RIGHT node = ordconstn (how is this possible?) - it goes through } 274 { analizeset! } 275 { Left : LOC_REGISTER } 276 { right : LOC_REFERENCE (call to sys) } 277 if not (getop in [A_BFSET,A_MOVE,A_TRAP,A_CMP,A_CMPI,A_FADD,A_LABEL,A_ASL,A_ADDX]) then 278 passed := false; 279 280 op := A_MOVE; 281 { Left : LOC_REFERENCE } 282 { right : LOC_REFERENCE } 283 if not (op in [A_BFSET,A_MOVE,A_TRAP,A_CMP,A_CMPI,A_FADD,A_LABEL,A_ASL,A_ADDX]) then 284 passed := false; 285 { Left : ordinal constant } 286 { right : LOC_REFERENCE } 287 op1 := [A_MOVE,A_TRAP]; 288 if not (A_MOVE in op1) then 289 passed := false; 290 291 checkpassed(passed); 292 end; 293 294 295 { WITH JUMP TABLE } 296 { NORMAL SETS } 297 procedure settesttwo; 298 var 299 op1 : tnormalset; 300 op2 : tnormalset; 301 bs : set of boolean; 302 op : tbigenum; 303 passed : boolean; 304 begin 305 Write('Normal set in operator test (with case table)...'); 306 passed := true; 307 { Left : LOC_REGISTER } 308 { right : LOC_REFERENCE with ranges } 309 if not (getop in [A_BFSET,A_MOVE,A_ASL..A_BCC]) then 310 passed := false; 311 { Left : LOC_REGISTER } 312 { right : LOC_REFERENCE no ranges } 313 314 if not (getop in [A_BFSET,A_MOVE]) then 315 passed := false; 316 317 { Left : LOC_REGISTER } 318 { right : no set at all } 319 if getop in [] then 320 passed:=false; 321 322 { Left : LOC_REGISTER } 323 { right : complete set definition } 324 if not (getop in [A_ABCD..A_NONE]) then 325 passed:=false; 326 327 328 op := A_MOVE; 329 { Left : LOC_REFERENCE } 330 { right : LOC_REFERENCE with ranges } 331 if not (getop in [A_BFSET,A_MOVE,A_ASL..A_BCC]) then 332 passed := false; 333 334 op:= A_MOVE; 335 if not (getop in [A_BFSET,A_MOVE]) then 336 passed := false; 337 338 { Left : LOC_REFERENCE } 339 { right : no set at all } 340 op := A_MOVE; 341 if op in [] then 342 passed:=false; 343 344 { Left : LOC_REFERENCE } 345 { right : complete set definition } 346 op:=A_MOVE; 347 if not (op in [A_ABCD..A_NONE]) then 348 passed:=false; 349 350 checkpassed(passed); 351 352 353 { LEFT : LOC_JUMP } 354 { RIGHT : LOC_REGISTER,LOC_CREGISTER } 355 bs:=[false,true]; 356 op:=A_MOVE; 357 passed:=true; 358 if not(not(op in [A_BFSET,A_MOVE,A_ASL..A_BCC]) in bs) then 359 passed := false; 360 if not((op in [A_BFSET,A_MOVE,A_ASL..A_BCC]) in bs) then 361 passed := false; 362 363 bs:=[false]; 364 if ((op in [A_BFSET,A_MOVE,A_ASL..A_BCC]) in bs) then 365 passed := false; 366 367 checkpassed(passed); 368 end; 369 370 { WITH JUMP TABLE } 371 { NORMAL SETS } 372 procedure settestthree; 373 var 374 passed : boolean; 375 begin 376 Write('Normal set in operator test II (without case table)...'); 377 passed := false; 378 NewRegsEncountered := [R_EAX..R_EDX]; 379 If (Reg32 in NewRegsEncountered) Then 380 passed := true; 381 checkpassed(passed); 382 end; 383 384Begin 385 smallsettestone; 386 smallsettesttwo; 387 smallsettestthree; 388 389 settestone; 390 settesttwo; 391 settestthree; 392end. 393