1{****************************************************************}
2{  CODE GENERATOR TEST PROGRAM                                   }
3{****************************************************************}
4{ NODE TESTED : secondadd()                                      }
5{****************************************************************}
6{ PRE-REQUISITES: secondload()                                   }
7{                 secondassign()                                 }
8{                 secondsetelement()                             }
9{****************************************************************}
10{ DEFINES:                                                       }
11{            FPC     = Target is FreePascal compiler             }
12{****************************************************************}
13{ REMARKS:                                                       }
14{                                                                }
15{                                                                }
16{                                                                }
17{****************************************************************}
18
19Program taddsetint;
20
21{$modeswitch exceptions}
22
23{$macro on}
24{$define write:=jlsystem.fout.print}
25{$define writeln:=jlsystem.fout.println}
26
27uses
28  {$ifdef java}jdk15{$else}androidr14{$endif};
29
30procedure halt(l: longint);
31begin
32  write('exit code: ');
33  writeln(l);
34  raise jlexception.create('error');
35end;
36
37var
38  Err : boolean;
39
40type
41       { DO NOT CHANGE THE VALUES OF THESE ENUMERATIONS! }
42       tsmallenum = (dA,dB,dC,dd,de,df,dg,dh,di,dj,dk,dl,dm,dn,dop,dp,dq,dr);
43       tasmop = (A_ABCD,
44         A_ADD,A_ADDA,A_ADDI,A_ADDQ,A_ADDX,A_AND,A_ANDI,
45         A_ASL,A_ASR,A_BCC,A_BCS,A_BEQ,A_BGE,A_BGT,A_BHI,
46         A_BLE,A_BLS,A_BLT,A_BMI,A_BNE,A_BPL,A_BVC,A_BVS,
47         A_BCHG,A_BCLR,A_BRA,A_BSET,A_BSR,A_BTST,A_CHK,
48         A_CLR,A_CMP,A_CMPA,A_CMPI,A_CMPM,A_DBCC,A_DBCS,A_DBEQ,A_DBGE,
49         A_DBGT,A_DBHI,A_DBLE,A_DBLS,A_DBLT,A_DBMI,A_DBNE,A_DBRA,
50         A_DBPL,A_DBT,A_DBVC,A_DBVS,A_DBF,A_DIVS,A_DIVU,
51         A_EOR,A_EORI,A_EXG,A_ILLEGAL,A_EXT,A_JMP,A_JSR,
52         A_LEA,A_LINK,A_LSL,A_LSR,A_MOVE,A_MOVEA,A_MOVEI,A_MOVEQ,
53         A_MOVEM,A_MOVEP,A_MULS,A_MULU,A_NBCD,A_NEG,A_NEGX,
54         A_NOP,A_NOT,A_OR,A_ORI,A_PEA,A_ROL,A_ROR,A_ROXL,
55         A_ROXR,A_RTR,A_RTS,A_SBCD,A_SCC,A_SCS,A_SEQ,A_SGE,
56         A_SGT,A_SHI,A_SLE,A_SLS,A_SLT,A_SMI,A_SNE,
57         A_SPL,A_ST,A_SVC,A_SVS,A_SF,A_SUB,A_SUBA,A_SUBI,A_SUBQ,
58         A_SUBX,A_SWAP,A_TAS,A_TRAP,A_TRAPV,A_TST,A_UNLK,
59         A_RTE,A_RESET,A_STOP,
60         { MC68010 instructions }
61         A_BKPT,A_MOVEC,A_MOVES,A_RTD,
62         { MC68020 instructions }
63         A_BFCHG,A_BFCLR,A_BFEXTS,A_BFEXTU,A_BFFFO,
64         A_BFINS,A_BFSET,A_BFTST,A_CALLM,A_CAS,A_CAS2,
65         A_CHK2,A_CMP2,A_DIVSL,A_DIVUL,A_EXTB,A_PACK,A_RTM,
66         A_TRAPCC,A_TRACS,A_TRAPEQ,A_TRAPF,A_TRAPGE,A_TRAPGT,
67         A_TRAPHI,A_TRAPLE,A_TRAPLS,A_TRAPLT,A_TRAPMI,A_TRAPNE,
68         A_TRAPPL,A_TRAPT,A_TRAPVC,A_TRAPVS,A_UNPK,
69         { FPU Processor instructions - directly supported only. }
70         { IEEE aware and misc. condition codes not supported   }
71         A_FABS,A_FADD,
72         A_FBEQ,A_FBNE,A_FBNGT,A_FBGT,A_FBGE,A_FBNGE,
73         A_FBLT,A_FBNLT,A_FBLE,A_FBGL,A_FBNGL,A_FBGLE,A_FBNGLE,
74         A_FDBEQ,A_FDBNE,A_FDBGT,A_FDBNGT,A_FDBGE,A_FDBNGE,
75         A_FDBLT,A_FDBNLT,A_FDBLE,A_FDBGL,A_FDBNGL,A_FDBGLE,A_FBDNGLE,
76         A_FSEQ,A_FSNE,A_FSGT,A_FSNGT,A_FSGE,A_FSNGE,
77         A_FSLT,A_FSNLT,A_FSLE,A_FSGL,A_FSNGL,A_FSGLE,A_FSNGLE,
78         A_FCMP,A_FDIV,A_FMOVE,A_FMOVEM,
79         A_FMUL,A_FNEG,A_FNOP,A_FSQRT,A_FSUB,A_FSGLDIV,
80         A_FSFLMUL,A_FTST,
81         A_FTRAPEQ,A_FTRAPNE,A_FTRAPGT,A_FTRAPNGT,A_FTRAPGE,A_FTRAPNGE,
82         A_FTRAPLT,A_FTRAPNLT,A_FTRAPLE,A_FTRAPGL,A_FTRAPNGL,A_FTRAPGLE,A_FTRAPNGLE,
83         { Protected instructions }
84         A_CPRESTORE,A_CPSAVE,
85         { FPU Unit protected instructions                    }
86         { and 68030/68851 common MMU instructions            }
87         { (this may include 68040 MMU instructions)          }
88         A_FRESTORE,A_FSAVE,A_PFLUSH,A_PFLUSHA,A_PLOAD,A_PMOVE,A_PTEST,
89         { Useful for assembly langage output }
90         A_LABEL,A_NONE);
91
92         tsmallenumint = ord(low(tsmallenum))..ord(high(tsmallenum));
93         tasmopint = ord(low(tasmop))..ord(high(tasmop));
94
95
96
97type
98  topset = set of tasmopint;
99  tsmallset = set of tsmallenumint;
100
101const
102
103   { NORMAL SETS }
104   constset1 : array[1..3] of topset =
105   (
106       { 66 }    { 210 }  { 225 }
107     ([ord(A_MOVE),    { 66  : LONG 2 - BIT 2  }
108       ord(A_FTST),    { 210 : LONG 6 - BIT 18 }
109       ord(A_CPSAVE)]),{ 225 : LONG 7 - BIT 1 }
110       { 1..8 }
111     ([ord(A_ADD)..ord(A_ASL)]),
112       { 134 }
113     ([ord(A_CHK2)])
114   );
115
116   constset2 : array[1..3] of topset =
117   (
118     ([ord(A_MOVE),ord(A_FTST),ord(A_CPSAVE)]),
119     ([ord(A_ADD)..ord(A_ASL)]),
120     ([ord(A_CHK2)])
121   );
122
123   { SMALL SETS }
124   constset3 : array[1..3] of tsmallset =
125   (
126     ([ord(DA),             { 0 :  LONG 0 : bit 0 }
127       ord(DD),             { 3 :  LONG 0 : bit 3 }
128       ord(DM)]),           { 12 :  LONG 0 : bit 12  }
129     ([ord(DB)..ord(DI)]),       { 1..8 : LONG 0 : bits 1-8  }
130     ([ord(DR)])            { 17 :  LONG 0 : bit 17 }
131   );
132
133   constset4 : array[1..3] of tsmallset =
134   (
135     ([ord(DA),ord(DD),ord(DM)]),
136     ([ord(DB)..ord(DI)]),
137     ([ord(DR)])
138   );
139
140
141 procedure CheckPassed(passed:boolean);
142 begin
143   if passed then
144     WriteLn('Success.')
145   else
146     begin
147       WriteLn('Failure.');
148       Halt(1);
149       Err:=true;
150     end;
151 end;
152
153 procedure SetTestEqual;
154 { FPC_SET_COMP_SETS }
155  var
156    op2list :set of tasmopint;
157    oplist: set of tasmopint;
158    passed : boolean;
159  Begin
160   Write('Normal Set == Normal Set test...');
161   passed := true;
162   op2list:=[];
163   oplist:=[];
164   if not (oplist=op2list) then
165     passed := false;
166   if not (constset1[2] = constset2[2]) then
167     passed := false;
168   if (constset1[1] = constset2[2]) then
169     passed := false;
170   if not (constset1[1] = [ord(A_MOVE),ord(A_FTST),ord(A_CPSAVE)]) then
171     passed := false;
172    CheckPassed(passed);
173  end;
174
175 procedure SetTestNotEqual;
176 { FPC_SET_COMP_SETS }
177  var
178    op2list :set of tasmopint;
179    oplist: set of tasmopint;
180    passed : boolean;
181  Begin
182   Write('Normal Set <> Normal Set test...');
183   passed := true;
184   op2list:=[];
185   oplist:=[];
186   if not (oplist=op2list) then
187     passed := false;
188   if (constset1[2] <> constset2[2]) then
189     passed := false;
190   if not (constset1[1] <> constset2[2]) then
191     passed := false;
192{   if ( [ord(A_ADD)] <> [ord(A_ADD)] ) then optimized out.
193     passed := false;
194   if ( [ord(A_BLE)..ord(A_BPL)] <> [ord(A_BLE)..ord(A_BPL)] ) then
195     passed := false; }
196   if (constset1[1] <> [ord(A_MOVE),ord(A_FTST),ord(A_CPSAVE)]) then
197     passed := false;
198    CheckPassed(passed);
199  end;
200
201  procedure SetTestLt;
202  var
203    op2list :set of tasmopint;
204    oplist: set of tasmopint;
205    passed : boolean;
206   begin
207    Write('Normal Set <= Normal Set test...');
208    passed := true;
209    if constset1[1] <= constset2[2] then
210      passed := false;
211    oplist := [];
212    op2list := [ord(A_MOVE)];
213    if op2list <= oplist then
214     passed := false;
215    oplist := [ord(A_MOVE),ord(A_CPRESTORE)..ord(A_CPSAVE)];
216    if oplist <= op2list then
217     passed := false;
218    CheckPassed(passed);
219   end;
220
221  Procedure SetTestAddOne;
222 { FPC_SET_SET_BYTE }
223 { FPC_SET_ADD_SETS }
224    var
225     op : tasmopint;
226     oplist: set of tasmopint;
227  Begin
228    Write('Set + Set element testing...');
229    op:=ord(A_LABEL);
230    oplist:=[];
231    oplist:=oplist+[op];
232    CheckPassed(oplist = [ord(A_LABEL)]);
233  end;
234
235Procedure SetTestAddTwo;
236{ SET_ADD_SETS }
237var
238 op2list :set of tasmopint;
239 oplist: set of tasmopint;
240Begin
241 Write('Complex Set + Set element testing...');
242 op2list:=[];
243 oplist:=[];
244 oplist:=[ord(A_MOVE)]+[ord(A_JSR)];
245 op2list:=[ord(A_LABEL)];
246 oplist:=op2list+oplist;
247 CheckPassed(oplist = [ord(A_MOVE),ord(A_JSR),ord(A_LABEL)]);
248end;
249
250
251
252
253
254Procedure SetTestSubOne;
255{ SET_SUB_SETS }
256var
257 op2list :set of tasmopint;
258 oplist: set of tasmopint;
259 op :tasmopint;
260 passed : boolean;
261Begin
262 Write('Set - Set element testing...');
263 passed := true;
264 op2list:=[];
265 oplist:=[];
266 op := ord(A_TRACS);
267 oplist:=[ord(A_MOVE)]+[ord(A_JSR)]+[op];
268 op2list:=[ord(A_MOVE)]+[ord(A_JSR)];
269 oplist:=oplist-op2list;
270 if oplist <> [ord(A_TRACS)] then
271   passed := false;
272
273 oplist:=[ord(A_MOVE)]+[ord(A_JSR)]+[op];
274 op2list:=[ord(A_MOVE)]+[ord(A_JSR)];
275 oplist:=op2list-oplist;
276 if oplist <> [] then
277   passed := false;
278 CheckPassed(passed);
279end;
280
281Procedure SetTestSubTwo;
282{ FPC_SET_SUB_SETS }
283const
284 b: tasmopint = (ord(A_BSR));
285var
286 op2list :set of tasmopint;
287 oplist: set of tasmopint;
288 op : tasmopint;
289 passed : boolean;
290Begin
291 Write('Complex Set - Set element testing...');
292 op := ord(A_BKPT);
293 passed := true;
294 oplist:=[ord(A_MOVE)]+[ord(A_JSR)]-[op];
295 op2list:=[ord(A_MOVE)]+[ord(A_JSR)];
296 if oplist <> op2list then
297   passed := false;
298 oplist := [ord(A_MOVE)];
299 oplist := oplist - [ord(A_MOVE)];
300 if oplist <> [] then
301   passed := false;
302 oplist := oplist + [b];
303 if oplist <> [b] then
304   passed := false;
305 oplist := oplist - [b];
306 if oplist <> [] then
307   passed := false;
308 CheckPassed(passed);
309end;
310
311
312Procedure SetTestMulSets;
313{ FPC_SET_MUL_SETS }
314var
315 op2list :set of tasmopint;
316 oplist: set of tasmopint;
317 passed : boolean;
318Begin
319 passed := true;
320 Write('Set * Set element testing...');
321 op2list:=[];
322 oplist:=[];
323 oplist:=[ord(A_MOVE)]+[ord(A_JSR)];
324 op2list:=[ord(A_MOVE)];
325 oplist:=oplist*op2list;
326 if oplist <> [ord(A_JSR)] then
327   passed := false;
328 oplist := [ord(A_MOVE),ord(A_FTST)];
329 op2list := [ord(A_MOVE),ord(A_FTST)];
330 oplist := oplist * op2list;
331 if oplist <> [ord(A_MOVE),ord(A_FTST)] then
332   passed := false;
333 CheckPassed(passed);
334end;
335
336procedure SetTestRange;
337var
338 op2list :set of tasmopint;
339 oplist: set of tasmopint;
340 passed : boolean;
341 op1 : tasmopint;
342 op2 : tasmopint;
343begin
344 passed := true;
345 Write('Range Set + element testing...');
346 op1 := ord(A_ADD);
347 op2 := ord(A_ASL);
348 oplist := [];
349 oplist := [op1..op2];
350 if oplist <> constset1[2] then
351   passed := false;
352 CheckPassed(passed);
353end;
354
355procedure SetTestByte;
356var
357 op2list :set of tasmopint;
358 oplist: set of tasmopint;
359 passed : boolean;
360 op1 : tasmopint;
361 op2 : tasmopint;
362 op : tasmopint;
363begin
364 Write('Simple Set + element testing...');
365 passed := true;
366 op := ord(A_LABEL);
367 oplist := [ord(A_MOVE),op,ord(A_JSR)];
368 if oplist <> [ord(A_MOVE),ord(A_LABEL),ord(A_JSR)] then
369   passed := false;
370 CheckPassed(passed);
371end;
372
373
374{------------------------------ TESTS FOR SMALL VALUES ---------------------}
375 procedure SmallSetTestEqual;
376  var
377    op2list :set of tsmallenumint;
378    oplist: set of tsmallenumint;
379    passed : boolean;
380  Begin
381   Write('Small Set == Small Set test...');
382   passed := true;
383   op2list:=[];
384   oplist:=[];
385   if not (oplist=op2list) then
386     passed := false;
387   if not (constset3[2] = constset4[2]) then
388     passed := false;
389   if (constset3[1] = constset4[2]) then
390     passed := false;
391   if not (constset3[1] = [ord(DA),ord(DD),ord(DM)]) then
392     passed := false;
393 CheckPassed(passed);
394  end;
395
396 procedure SmallSetTestNotEqual;
397  var
398    op2list :set of tsmallenumint;
399    oplist: set of tsmallenumint;
400    passed : boolean;
401  Begin
402   Write('Small Set <> Small Set test...');
403   passed := true;
404   op2list:=[];
405   oplist:=[];
406   if not (oplist=op2list) then
407     passed := false;
408   if (constset3[2] <> constset4[2]) then
409     passed := false;
410   if not (constset3[1] <> constset4[2]) then
411     passed := false;
412{   if ( [ord(A_ADD)] <> [ord(A_ADD)] ) then optimized out.
413     passed := false;
414   if ( [ord(A_BLE)..ord(A_BPL)] <> [ord(A_BLE)..ord(A_BPL)] ) then
415     passed := false; }
416   if (constset3[1] <> [ord(DA),ord(DD),ord(DM)]) then
417     passed := false;
418 CheckPassed(passed);
419  end;
420
421  procedure SmallSetTestLt;
422  var
423    op2list :set of tsmallenumint;
424    oplist: set of tsmallenumint;
425    passed : boolean;
426   begin
427    Write('Small Set <= Small Set test...');
428    passed := true;
429    if constset3[1] <= constset4[2] then
430      passed := false;
431    oplist := [];
432    op2list := [ord(DC)];
433    if op2list <= oplist then
434     passed := false;
435    oplist := [ord(DC),ord(DF)..ord(DM)];
436    if oplist <= op2list then
437     passed := false;
438 CheckPassed(passed);
439   end;
440
441  Procedure SmallSetTestAddOne;
442    var
443     op : tsmallenumint;
444     oplist: set of tsmallenumint;
445  Begin
446    Write('Small Set + Small Set element testing...');
447    op:=ord(DG);
448    oplist:=[];
449    oplist:=oplist+[op];
450    CheckPassed( oplist = [ord(DG)] );
451  end;
452
453Procedure SmallSetTestAddTwo;
454var
455 op2list :set of tsmallenumint;
456 oplist: set of tsmallenumint;
457Begin
458 Write('Small Complex Set + Small Set element testing...');
459 op2list:=[];
460 oplist:=[];
461 oplist:=[ord(DG)]+[ord(DI)];
462 op2list:=[ord(DM)];
463 oplist:=op2list+oplist;
464 CheckPassed( oplist = [ord(DG),ord(DI),ord(DM)] );
465end;
466
467
468Procedure SmallSetTestSubOne;
469var
470 op2list :set of tsmallenumint;
471 oplist: set of tsmallenumint;
472 op :tsmallenumint;
473 passed : boolean;
474Begin
475 Write('Small Set - Small Set element testing...');
476 passed := true;
477 op2list:=[];
478 oplist:=[];
479 op := ord(DL);
480 oplist:=[ord(DG)]+[ord(DI)]+[op];
481 op2list:=[ord(DG)]+[ord(DI)];
482 oplist:=oplist-op2list;
483 if oplist <> [ord(DL)] then
484   passed := false;
485
486 oplist:=[ord(DG)]+[ord(DI)]+[op];
487 op2list:=[ord(DG)]+[ord(DI)];
488 oplist:=op2list-oplist;
489 if oplist <> [] then
490   passed := false;
491 CheckPassed(passed);
492end;
493
494Procedure SmallSetTestSubTwo;
495const
496 b: tsmallenumint = (ord(DH));
497var
498 op2list :set of tsmallenumint;
499 oplist: set of tsmallenumint;
500 op : tsmallenumint;
501 passed : boolean;
502Begin
503 Write('Small Complex Set - Small Set element testing...');
504 op := ord(DL);
505 passed := true;
506 oplist:=[ord(DG)]+[ord(DI)]-[op];
507 op2list:=[ord(DG)]+[ord(DI)];
508 if oplist <> op2list then
509   passed := false;
510 oplist := [ord(DG)];
511 oplist := oplist - [ord(DG)];
512 if oplist <> [] then
513   passed := false;
514 oplist := oplist + [b];
515 if oplist <> [b] then
516   passed := false;
517 oplist := oplist - [b];
518 if oplist <> [] then
519   passed := false;
520 CheckPassed(passed);
521end;
522
523
524Procedure SmallSetTestMulSets;
525var
526 op2list : set of tsmallenumint;
527 oplist: set of tsmallenumint;
528 passed : boolean;
529Begin
530 passed := true;
531 Write('Small Set * Small Set element testing...');
532 op2list:=[];
533 oplist:=[];
534 oplist:=[ord(DG)]+[ord(DI)];
535 op2list:=[ord(DG)];
536 oplist:=oplist*op2list;
537 if oplist <> [ord(DI)] then
538   passed := false;
539 oplist := [ord(DG),ord(DK)];
540 op2list := [ord(DG),ord(DK)];
541 oplist := oplist * op2list;
542 if oplist <> [ord(DG),ord(DK)] then
543   passed := false;
544 CheckPassed(passed);
545end;
546
547procedure SmallSetTestRange;
548var
549 op2list :set of tsmallenumint;
550 oplist: set of tsmallenumint;
551 passed : boolean;
552 op1 : tsmallenumint;
553 op2 : tsmallenumint;
554begin
555 passed := true;
556 Write('Small Range Set + element testing...');
557 op1 := ord(DB);
558 op2 := ord(DI);
559 oplist := [];
560 oplist := [op1..op2];
561 if oplist <> constset3[2] then
562   passed := false;
563 CheckPassed(passed);
564end;
565
566procedure SmallSetTestByte;
567var
568 op2list : set of tsmallenumint;
569 oplist: set of tsmallenumint;
570 passed : boolean;
571 op1 : tsmallenumint;
572 op2 : tsmallenumint;
573 op : tsmallenumint;
574begin
575 Write('Small Simple Set + element testing...');
576 passed := true;
577 op := ord(DD);
578 oplist := [ord(DG),op,ord(DI)];
579 if oplist <> [ord(DG),ord(DD),ord(DI)] then
580   passed := false;
581 CheckPassed(passed);
582end;
583
584(*
585
586const
587 b: myenum = (ord(dA));
588var
589 enum: set of myenum;
590 oplist: set of tasmopint;
591 l : word;
592Begin
593  SetTestEqual;
594  SetTestNotEqual;
595{ small sets }
596 enum:=[];
597 { add }
598 enum:=enum+[ord(da)];
599 { subtract }
600 enum:=enum-[ord(da)];
601 if ord(DA) in enum then
602  WriteLn('Found ord(A_LABEL)');
603 { very large sets       }
604 { copy loop test        }
605 WRITELN('LARGE SETS:');
606 oplist := [ord(A_LABEL)];
607 { secondin test         }
608 if ord(A_LABEL) in oplist then
609  WriteLn('TESTING SIMPLE SECOND_IN: PASSED.');
610 { }
611 oplist:=[];
612 if ord(A_LABEL) in oplist then
613  WriteLn('SECOND IN FAILED.');
614{ SecondinSets;}
615 SetSetByte;
616 SetAddSets;
617 SetSubSets;
618 SetCompSets;
619 SetMulSets;
620 WRITELN('SMALL SETS:');
621 SmallInSets;
622 SmallAddSets;
623 SmallSubSets;
624 SmallCompSets;
625 SmallMulSets;
626 l:=word(ord(A_CPRESTORE));
627 if l = word(ord(A_CPRESTORE)) then
628  Begin
629  end;
630
631*)
632Begin
633  WriteLn('----------------------- Normal sets -----------------------');
634  { Normal sets }
635  SetTestEqual;
636  SetTestNotEqual;
637  SetTestAddOne;
638  SetTestAddTwo;
639  SetTestSubOne;
640  SetTestSubTwo;
641  SetTestRange;
642  SetTestLt;
643  SetTestByte;
644  { Small sets }
645  WriteLn('----------------------- Small sets -----------------------');
646  SmallSetTestEqual;
647  SmallSetTestNotEqual;
648  SmallSetTestAddOne;
649  SmallSetTestAddTwo;
650  SmallSetTestSubOne;
651  SmallSetTestSubTwo;
652  SmallSetTestRange;
653  SmallSetTestLt;
654  SmallSetTestByte;
655
656  if Err then
657   Halt(1);
658end.
659