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