From d8d3c08e6347c0f1f99b2c9e27ff8fc424cc1d0b Mon Sep 17 00:00:00 2001 From: peter Date: Wed, 29 Nov 2000 23:09:09 +0000 Subject: [PATCH] * moved to oldtests module --- compiler/Makefile | 16 +- compiler/Makefile.fpc | 1 - tests/Makefile | 742 ---------------------- tests/Makefile.fpc | 413 ------------- tests/README | 58 -- tests/bugs.txt | 404 ------------ tests/dotest.pp | 20 - tests/erroru.pp | 77 --- tests/getret.pp | 74 --- tests/graph.lst | 13 - tests/readme.txt | 54 -- tests/tbf/tbf0008.pp | 6 - tests/tbf/tbf0010.pp | 6 - tests/tbf/tbf0029.pp | 12 - tests/tbf/tbf0036.pp | 9 - tests/tbf/tbf0049.pp | 11 - tests/tbf/tbf0060.pp | 21 - tests/tbf/tbf0061.pp | 3 - tests/tbf/tbf0071.pp | 5 - tests/tbf/tbf0075.pp | 31 - tests/tbf/tbf0085.pp | 3 - tests/tbf/tbf0086.pp | 15 - tests/tbf/tbf0087.pp | 15 - tests/tbf/tbf0088.pp | 3 - tests/tbf/tbf0089.pp | 3 - tests/tbf/tbf0094.pp | 5 - tests/tbf/tbf0097.pp | 39 -- tests/tbf/tbf0100.pp | 7 - tests/tbf/tbf0101.pp | 18 - tests/tbf/tbf0108.pp | 5 - tests/tbf/tbf0109.pp | 9 - tests/tbf/tbf0110.pp | 9 - tests/tbf/tbf0117.pp | 21 - tests/tbf/tbf0127.pp | 17 - tests/tbf/tbf0136.pp | 9 - tests/tbf/tbf0148.pp | 20 - tests/tbf/tbf0151.pp | 10 - tests/tbf/tbf0153.pp | 17 - tests/tbf/tbf0155.pp | 17 - tests/tbf/tbf0157.pp | 17 - tests/tbf/tbf0158.pp | 8 - tests/tbf/tbf0161.pp | 11 - tests/tbf/tbf0164.pp | 14 - tests/tbf/tbf0166.pp | 10 - tests/tbf/tbf0167.pp | 9 - tests/tbf/tbf0168.pp | 6 - tests/tbf/tbf0172.pp | 11 - tests/tbf/tbf0173.pp | 9 - tests/tbf/tbf0175.pp | 10 - tests/tbf/tbf0186.pp | 9 - tests/tbf/tbf0196.pp | 9 - tests/tbf/tbf0197.pp | 13 - tests/tbf/tbf0205.pp | 31 - tests/tbf/tbf0208.pp | 11 - tests/tbf/tbf0219.pp | 13 - tests/tbf/tbf0230.pp | 14 - tests/tbf/tbf0231.pp | 17 - tests/tbf/tbf0234.pp | 8 - tests/tbf/tbf0242.pp | 11 - tests/tbf/tbf0245.pp | 26 - tests/tbf/tbf0246.pp | 13 - tests/tbf/tbf0248.pp | 8 - tests/tbf/tbf0265.pp | 21 - tests/tbf/tbf0269.pp | 8 - tests/tbf/tbf0272.pp | 36 -- tests/tbf/tbf0281.pp | 19 - tests/tbf/tbf0284.pp | 9 - tests/tbf/tbf0298.pp | 11 - tests/tbf/tbf0300.pp | 4 - tests/tbf/tbf0301.pp | 8 - tests/tbf/tbf0310.pp | 10 - tests/tbf/tbf0311.pp | 11 - tests/tbf/tbf0314.pp | 9 - tests/tbf/tbf0315.pp | 5 - tests/tbf/tbf0320.pp | 27 - tests/tbf/tbf0323.pp | 6 - tests/tbf/tbf0324.pp | 10 - tests/tbf/tbf0325.pp | 14 - tests/tbf/tbf0326.pp | 6 - tests/tbf/tbf0328.pp | 21 - tests/tbf/tbf0342.pp | 5 - tests/tbf/tbf0343.pp | 9 - tests/tbf/tbf0345.pp | 5 - tests/tbf/tbf0347.pp | 9 - tests/tbf/tbf0349.pp | 14 - tests/tbf/tbf0351.pp | 10 - tests/tbf/tbf0352.pp | 15 - tests/tbf/tbf0353.pp | 9 - tests/tbf/tbf0354.pp | 8 - tests/tbf/tbf0355.pp | 8 - tests/tbf/tbf0356.pp | 8 - tests/tbf/tbf0357.pp | 9 - tests/tbf/tbf0358.pp | 9 - tests/tbf/tbf0359.pp | 9 - tests/tbf/tbf0360.pp | 23 - tests/tbf/tbff001.pp | 15 - tests/tbf/tbff002.pp | 31 - tests/tbs/tbs0001.pp | 9 - tests/tbs/tbs0002.pp | 83 --- tests/tbs/tbs0003.pp | 18 - tests/tbs/tbs0004.pp | 13 - tests/tbs/tbs0005.pp | 13 - tests/tbs/tbs0006.pp | 18 - tests/tbs/tbs0007.pp | 17 - tests/tbs/tbs0009.pp | 27 - tests/tbs/tbs0011.pp | 14 - tests/tbs/tbs0012.pp | 13 - tests/tbs/tbs0013.pp | 9 - tests/tbs/tbs0014.pp | 22 - tests/tbs/tbs0015.pp | 21 - tests/tbs/tbs0016.pp | 193 ------ tests/tbs/tbs0017.pp | 38 -- tests/tbs/tbs0018.pp | 12 - tests/tbs/tbs0019.pp | 13 - tests/tbs/tbs0021.pp | 39 -- tests/tbs/tbs0022.pp | 29 - tests/tbs/tbs0023.pp | 47 -- tests/tbs/tbs0024.pp | 24 - tests/tbs/tbs0025.pp | 15 - tests/tbs/tbs0026.pp | 22 - tests/tbs/tbs0027.pp | 5 - tests/tbs/tbs0028.pp | 10 - tests/tbs/tbs0029.pp | 20 - tests/tbs/tbs0030.pp | 6 - tests/tbs/tbs0031.pp | 8 - tests/tbs/tbs0032.pp | 12 - tests/tbs/tbs0033.pp | 13 - tests/tbs/tbs0034.pp | 16 - tests/tbs/tbs0035.pp | 15 - tests/tbs/tbs0037.pp | 49 -- tests/tbs/tbs0038.pp | 5 - tests/tbs/tbs0039.pp | 10 - tests/tbs/tbs0040.pp | 26 - tests/tbs/tbs0041.pp | 8 - tests/tbs/tbs0042.pp | 11 - tests/tbs/tbs0043.pp | 32 - tests/tbs/tbs0044.pp | 16 - tests/tbs/tbs0045.pp | 26 - tests/tbs/tbs0046.pp | 53 -- tests/tbs/tbs0047.pp | 13 - tests/tbs/tbs0048.pp | 44 -- tests/tbs/tbs0050.pp | 19 - tests/tbs/tbs0051.pp | 92 --- tests/tbs/tbs0052.pp | 49 -- tests/tbs/tbs0053.pp | 15 - tests/tbs/tbs0054.pp | 6 - tests/tbs/tbs0055.pp | 15 - tests/tbs/tbs0056.pp | 14 - tests/tbs/tbs0057.pp | 34 - tests/tbs/tbs0058.pp | 9 - tests/tbs/tbs0059.pp | 9 - tests/tbs/tbs0061.pp | 8 - tests/tbs/tbs0062.pp | 9 - tests/tbs/tbs0063.pp | 13 - tests/tbs/tbs0064.pp | 15 - tests/tbs/tbs0065.pp | 10 - tests/tbs/tbs0066.pp | 10 - tests/tbs/tbs0067.pp | 18 - tests/tbs/tbs0067b.pp | 27 - tests/tbs/tbs0068.pp | 9 - tests/tbs/tbs0069.pp | 25 - tests/tbs/tbs0070.pp | 10 - tests/tbs/tbs0072.pp | 15 - tests/tbs/tbs0073.pp | 30 - tests/tbs/tbs0074.pp | 28 - tests/tbs/tbs0076.pp | 24 - tests/tbs/tbs0077.pp | 9 - tests/tbs/tbs0077b.pp | 11 - tests/tbs/tbs0078.pp | 8 - tests/tbs/tbs0079.pp | 19 - tests/tbs/tbs0080.pp | 8 - tests/tbs/tbs0081.pp | 7 - tests/tbs/tbs0082.pp | 29 - tests/tbs/tbs0083.pp | 8 - tests/tbs/tbs0084.pp | 15 - tests/tbs/tbs0090.pp | 10 - tests/tbs/tbs0091.pp | 23 - tests/tbs/tbs0092.pp | 10 - tests/tbs/tbs0093.pp | 18 - tests/tbs/tbs0095.pp | 15 - tests/tbs/tbs0096.pp | 24 - tests/tbs/tbs0098.pp | 45 -- tests/tbs/tbs0099.pp | 7 - tests/tbs/tbs0102.pp | 19 - tests/tbs/tbs0103.pp | 8 - tests/tbs/tbs0104.pp | 16 - tests/tbs/tbs0105.pp | 46 -- tests/tbs/tbs0106.pp | 12 - tests/tbs/tbs0107.pp | 31 - tests/tbs/tbs0109.pp | 9 - tests/tbs/tbs0111.pp | 20 - tests/tbs/tbs0112.pp | 21 - tests/tbs/tbs0113.pp | 13 - tests/tbs/tbs0114.pp | 3 - tests/tbs/tbs0115.pp | 11 - tests/tbs/tbs0116.pp | 9 - tests/tbs/tbs0118.pp | 11 - tests/tbs/tbs0119.pp | 44 -- tests/tbs/tbs0120.pp | 14 - tests/tbs/tbs0121.pp | 18 - tests/tbs/tbs0122.pp | 9 - tests/tbs/tbs0123.pp | 18 - tests/tbs/tbs0124.pp | 41 -- tests/tbs/tbs0124b.pp | 21 - tests/tbs/tbs0125.pp | 12 - tests/tbs/tbs0126.pp | 5 - tests/tbs/tbs0128.pp | 9 - tests/tbs/tbs0129.pp | 12 - tests/tbs/tbs0130.pp | 11 - tests/tbs/tbs0131.pp | 11 - tests/tbs/tbs0132.pp | 13 - tests/tbs/tbs0133.pp | 14 - tests/tbs/tbs0134.pp | 31 - tests/tbs/tbs0135.pp | 10 - tests/tbs/tbs0137.pp | 45 -- tests/tbs/tbs0138.pp | 35 -- tests/tbs/tbs0139.pp | 23 - tests/tbs/tbs0139a.pp | 21 - tests/tbs/tbs0140.pp | 21 - tests/tbs/tbs0140a.pp | 14 - tests/tbs/tbs0141.pp | 67 -- tests/tbs/tbs0142.pp | 13 - tests/tbs/tbs0143.pp | 11 - tests/tbs/tbs0144.pp | 21 - tests/tbs/tbs0145.pp | 30 - tests/tbs/tbs0146.pp | 14 - tests/tbs/tbs0147.pp | 13 - tests/tbs/tbs0149a.pp | 10 - tests/tbs/tbs0149b.pp | 25 - tests/tbs/tbs0150.pp | 27 - tests/tbs/tbs0152.pp | 36 -- tests/tbs/tbs0154.pp | 8 - tests/tbs/tbs0156a.pp | 4 - tests/tbs/tbs0156b.pp | 12 - tests/tbs/tbs0157.pp | 10 - tests/tbs/tbs0159.pp | 22 - tests/tbs/tbs0160.pp | 16 - tests/tbs/tbs0162.pp | 10 - tests/tbs/tbs0163.pp | 16 - tests/tbs/tbs0164.pp | 17 - tests/tbs/tbs0165.pp | 19 - tests/tbs/tbs0169.pp | 12 - tests/tbs/tbs0170.pp | 13 - tests/tbs/tbs0171.pp | 12 - tests/tbs/tbs0174.pp | 19 - tests/tbs/tbs0175.pp | 10 - tests/tbs/tbs0176.pp | 17 - tests/tbs/tbs0177.pp | 6 - tests/tbs/tbs0178.pp | 64 -- tests/tbs/tbs0179.pp | 10 - tests/tbs/tbs0180.pp | 15 - tests/tbs/tbs0180a.pp | 13 - tests/tbs/tbs0181.pp | 9 - tests/tbs/tbs0181a.pp | 27 - tests/tbs/tbs0182.pp | 31 - tests/tbs/tbs0183.pp | 27 - tests/tbs/tbs0184.pp | 25 - tests/tbs/tbs0185.pp | 63 -- tests/tbs/tbs0187.pp | 118 ---- tests/tbs/tbs0188.pp | 42 -- tests/tbs/tbs0189.pp | 22 - tests/tbs/tbs0190.pp | 10 - tests/tbs/tbs0191.pp | 28 - tests/tbs/tbs0192.pp | 8 - tests/tbs/tbs0193.pp | 15 - tests/tbs/tbs0194.pp | 42 -- tests/tbs/tbs0195.pp | 44 -- tests/tbs/tbs0196.pp | 13 - tests/tbs/tbs0198.pp | 14 - tests/tbs/tbs0199.pp | 24 - tests/tbs/tbs0201.pp | 41 -- tests/tbs/tbs0202.pp | 31 - tests/tbs/tbs0203.pp | 13 - tests/tbs/tbs0203a.pp | 25 - tests/tbs/tbs0204.pp | 30 - tests/tbs/tbs0206.pp | 10 - tests/tbs/tbs0207.pp | 8 - tests/tbs/tbs0209.pp | 18 - tests/tbs/tbs0210.pp | 10 - tests/tbs/tbs0211.pp | 29 - tests/tbs/tbs0212.pp | 20 - tests/tbs/tbs0213.pp | 35 -- tests/tbs/tbs0213a.pp | 96 --- tests/tbs/tbs0214.pp | 29 - tests/tbs/tbs0215.pp | 52 -- tests/tbs/tbs0216.pp | 34 - tests/tbs/tbs0217.pp | 19 - tests/tbs/tbs0218.pp | 44 -- tests/tbs/tbs0220.pp | 15 - tests/tbs/tbs0221.pp | 13 - tests/tbs/tbs0222.pp | 11 - tests/tbs/tbs0223.pp | 20 - tests/tbs/tbs0224.pp | 19 - tests/tbs/tbs0225.pp | 30 - tests/tbs/tbs0226.pp | 9 - tests/tbs/tbs0227.pp | 12 - tests/tbs/tbs0228.pp | 15 - tests/tbs/tbs0229.pp | 34 - tests/tbs/tbs0232.pp | 8 - tests/tbs/tbs0233.pp | 31 - tests/tbs/tbs0234.pp | 10 - tests/tbs/tbs0235.pp | 17 - tests/tbs/tbs0236.pp | 40 -- tests/tbs/tbs0237.pp | 22 - tests/tbs/tbs0238.pp | 35 -- tests/tbs/tbs0239.pp | 47 -- tests/tbs/tbs0240.pp | 21 - tests/tbs/tbs0241.pp | 16 - tests/tbs/tbs0242b.pp | 28 - tests/tbs/tbs0243.pp | 35 -- tests/tbs/tbs0244.pp | 24 - tests/tbs/tbs0247.pp | 22 - tests/tbs/tbs0249.pp | 61 -- tests/tbs/tbs0250.pp | 29 - tests/tbs/tbs0251.pp | 26 - tests/tbs/tbs0252.pp | 18 - tests/tbs/tbs0253.pp | 18 - tests/tbs/tbs0254.pp | 4 - tests/tbs/tbs0255.pp | 9 - tests/tbs/tbs0256.pp | 13 - tests/tbs/tbs0257.pp | 18 - tests/tbs/tbs0258.pp | 63 -- tests/tbs/tbs0259.pp | 7 - tests/tbs/tbs0260.pp | 32 - tests/tbs/tbs0261.pp | 32 - tests/tbs/tbs0261a.pp | 54 -- tests/tbs/tbs0262.pp | 114 ---- tests/tbs/tbs0263.pp | 26 - tests/tbs/tbs0264.pp | 44 -- tests/tbs/tbs0266.pp | 16 - tests/tbs/tbs0267.pp | 28 - tests/tbs/tbs0268.pp | 30 - tests/tbs/tbs0270.pp | 21 - tests/tbs/tbs0271.pp | 31 - tests/tbs/tbs0272.pp | 33 - tests/tbs/tbs0273.pp | 18 - tests/tbs/tbs0274.pp | 13 - tests/tbs/tbs0275.pp | 5 - tests/tbs/tbs0276.pp | 46 -- tests/tbs/tbs0277.pp | 5 - tests/tbs/tbs0278.pp | 29 - tests/tbs/tbs0279.pp | 33 - tests/tbs/tbs0280.pp | 48 -- tests/tbs/tbs0282.pp | 33 - tests/tbs/tbs0283.pp | 12 - tests/tbs/tbs0284b.pp | 9 - tests/tbs/tbs0285.pp | 18 - tests/tbs/tbs0286.pp | 5 - tests/tbs/tbs0287.pp | 21 - tests/tbs/tbs0288.pp | 36 -- tests/tbs/tbs0289.pp | 11 - tests/tbs/tbs0290.pp | 25 - tests/tbs/tbs0291.pp | 25 - tests/tbs/tbs0292.pp | 47 -- tests/tbs/tbs0293.pp | 28 - tests/tbs/tbs0294.pp | 39 -- tests/tbs/tbs0295.pp | 18 - tests/tbs/tbs0296.pp | 13 - tests/tbs/tbs0297.pp | 14 - tests/tbs/tbs0299.pp | 29 - tests/tbs/tbs0302.pp | 19 - tests/tbs/tbs0303.pp | 21 - tests/tbs/tbs0304.pp | 19 - tests/tbs/tbs0305.pp | 28 - tests/tbs/tbs0306.pp | 45 -- tests/tbs/tbs0306.ree | 1 - tests/tbs/tbs0307.pp | 33 - tests/tbs/tbs0308.pp | 5 - tests/tbs/tbs0308a.pp | 26 - tests/tbs/tbs0309.pp | 81 --- tests/tbs/tbs0312.pp | 144 ----- tests/tbs/tbs0313.pp | 24 - tests/tbs/tbs0316.pp | 20 - tests/tbs/tbs0317.pp | 8 - tests/tbs/tbs0318.pp | 11 - tests/tbs/tbs0318.ree | 1 - tests/tbs/tbs0319.pp | 66 -- tests/tbs/tbs0321.pp | 6 - tests/tbs/tbs0322.pp | 24 - tests/tbs/tbs0327.pp | 52 -- tests/tbs/tbs0329.pp | 61 -- tests/tbs/tbs0330.pp | 26 - tests/tbs/tbs0331.pp | 15 - tests/tbs/tbs0332.pp | 11 - tests/tbs/tbs0333.pp | 16 - tests/tbs/tbs0334.pp | 22 - tests/tbs/tbs0335.pp | 7 - tests/tbs/tbs0336.pp | 45 -- tests/tbs/tbs0337.pp | 29 - tests/tbs/tbs0338.pp | 10 - tests/tbs/tbs0339.pp | 20 - tests/tbs/tbs0340.pp | 20 - tests/tbs/tbs0341.pp | 13 - tests/tbs/tbs0344.pp | 6 - tests/tbs/tbs0346a.pp | 9 - tests/tbs/tbs0346b.pp | 16 - tests/tbs/tbs0348.pp | 12 - tests/tbs/tbs0350.pp | 8 - tests/tbs/tbs0353.pp | 23 - tests/tbs/tbs0355.pp | 17 - tests/tbs/tbs0356.pp | 11 - tests/tbstbf.txt | 404 ------------ tests/tesi/tesicrt.pp | 105 ---- tests/tesi/tesidos.pp | 176 ------ tests/tesi/tesirand.pp | 157 ----- tests/test/divexcp.pp | 126 ---- tests/test/implprog.pp | 16 - tests/test/impluni1.pp | 13 - tests/test/impluni2.pp | 10 - tests/test/inline01.pp | 121 ---- tests/test/inoutres.pp | 307 ---------- tests/test/range.pp | 232 ------- tests/test/range2.pp | 30 - tests/test/range3.pp | 134 ---- tests/test/readme.txt | 49 -- tests/test/strreal.pp | 42 -- tests/test/strreal2.pp | 43 -- tests/test/testa2.pp | 40 -- tests/test/testac.pp | 38 -- tests/test/testansi.pp | 492 --------------- tests/test/testaoc.pp | 111 ---- tests/test/testarr1.pp | 19 - tests/test/testbd.pp | 38 -- tests/test/testcard.pp | 102 --- tests/test/testcas2.pp | 21 - tests/test/testcase.pp | 56 -- tests/test/testchar.pp | 157 ----- tests/test/testchr2.pp | 142 ----- tests/test/testcmov.pp | 29 - tests/test/testcstr.pp | 43 -- tests/test/testdiv.pp | 74 --- tests/test/testenm1.pp | 14 - tests/test/testexc.pp | 201 ------ tests/test/testexc.ree | 1 - tests/test/testexc2.pp | 27 - tests/test/testexc3.pp | 776 ----------------------- tests/test/testfail.pp | 90 --- tests/test/testfail.ree | 1 - tests/test/testfdi2.pp | 107 ---- tests/test/testfdi3.pp | 99 --- tests/test/testfdiv.pp | 98 --- tests/test/testfi1.pp | 21 - tests/test/testfpu.pp | 125 ---- tests/test/testfpu2.pp | 29 - tests/test/testgoto.pp | 27 - tests/test/testheap.pp | 170 ----- tests/test/testi642.pp | 1190 ----------------------------------- tests/test/testin64.pp | 96 --- tests/test/testinh.pp | 30 - tests/test/testinl.pp | 23 - tests/test/testintr.pp | 40 -- tests/test/testitf1.pp | 31 - tests/test/testitf4.pp | 47 -- tests/test/testitf5.pp | 11 - tests/test/testlib.pp | 35 -- tests/test/testmmx.pp | 84 --- tests/test/testobj.pp | 103 ---- tests/test/testop.pp | 15 - tests/test/testop1.pp | 38 -- tests/test/testop2.pp | 66 -- tests/test/testop3.pp | 20 - tests/test/testout.pp | 95 --- tests/test/testpusw.pp | 75 --- tests/test/testpva2.pp | 38 -- tests/test/testpvar.pp | 165 ----- tests/test/testrang.pp | 24 - tests/test/testreal.pp | 76 --- tests/test/testrstr.pp | 8 - tests/test/testrtti.pp | 570 ----------------- tests/test/testsave.pp | 18 - tests/test/testset.pp | 175 ------ tests/test/testset2.pp | 351 ----------- tests/test/teststr.pp | 271 -------- tests/test/teststr2.pp | 30 - tests/test/testti1.pp | 8 - tests/test/testu1.pp | 7 - tests/test/testu2.pp | 20 - tests/test/testu3.pp | 11 - tests/test/testu4.pp | 13 - tests/test/testu5.pp | 13 - tests/testopt/readme.txt | 9 - tests/testopt/testcse1.pp | 27 - tests/testopt/testcse2.pp | 72 --- tests/testopt/testcse3.pp | 40 -- tests/testopt/testreg1.pp | 26 - tests/testopt/testreg2.dat | 7 - tests/testopt/testreg2.pp | 42 -- tests/testopt/testreg3.pp | 33 - tests/tf/tf000001.pp | 11 - tests/tf/tf000002.pp | 8 - tests/tf/tf000003.pp | 10 - tests/tf/tf000004.pp | 10 - tests/tf/tf000005.pp | 10 - tests/tf/tf000006.pp | 14 - tests/tf/tf000007.pp | 20 - tests/tf/tf000008.pp | 20 - tests/to/to000000.pp | 53 -- tests/ts/th010018.pp | 14 - tests/ts/ts010000.pp | 36 -- tests/ts/ts010001.pp | 46 -- tests/ts/ts010002.pp | 217 ------- tests/ts/ts010003.pp | 55 -- tests/ts/ts010004.pp | 23 - tests/ts/ts010005.pp | 43 -- tests/ts/ts010006.pp | 13 - tests/ts/ts010007.pp | 52 -- tests/ts/ts010008.pp | 41 -- tests/ts/ts010009.pp | 13 - tests/ts/ts010010.pp | 15 - tests/ts/ts010014.pp | 58 -- tests/ts/ts010015.pp | 74 --- tests/ts/ts010016.pp | 37 -- tests/ts/ts010017.pp | 33 - tests/ts/ts010018.pp | 13 - tests/ts/ts010019.pp | 39 -- tests/ts/ts010020.pp | 10 - tests/ts/ts010021.pp | 19 - tests/ts/ts010022.pp | 46 -- tests/ts/ts010023.pp | 14 - tests/ts/ts010024.pp | 34 - tests/ts/ts010025.pp | 29 - tests/ts/ts010026.pp | 45 -- tests/ts/ts010027.pp | 25 - tests/ts/ts010028.pp | 13 - tests/ts/ts010029.pp | 45 -- tests/ts/ts010030.pp | 20 - tests/ts/ts010031.pp | 15 - tests/ts/ts010032.pp | 12 - tests/ts/ts010033.pp | 76 --- tests/ts/ts010100.pp | 9 - tests/ts/ts010101.pp | 13 - tests/units/Makefile | 1192 ------------------------------------ tests/units/Makefile.fpc | 63 -- tests/webtbf/bug856u.pp | 16 - tests/webtbf/tb1157a.pp | 41 -- tests/webtbf/tbug1157.pp | 41 -- tests/webtbf/tbug1238.pp | 23 - tests/webtbf/tbug744.pp | 9 - tests/webtbf/tbug744a.pp | 10 - tests/webtbf/tbug784.pp | 27 - tests/webtbf/tbug807.pp | 52 -- tests/webtbf/tbug856.pp | 7 - tests/webtbf/tbug890.pp | 19 - tests/webtbf/tbug896.pp | 16 - tests/webtbf/tbug896a.pp | 16 - tests/webtbs/tbug1021.pp | 55 -- tests/webtbs/tbug1023.pp | 29 - tests/webtbs/tbug1041.pp | 14 - tests/webtbs/tbug1046.pp | 8 - tests/webtbs/tbug1061.pp | 12 - tests/webtbs/tbug1066a.pp | 119 ---- tests/webtbs/tbug1066b.pp | 117 ---- tests/webtbs/tbug1068.pp | 14 - tests/webtbs/tbug1071.pp | 38 -- tests/webtbs/tbug1073.pp | 43 -- tests/webtbs/tbug1081.pp | 41 -- tests/webtbs/tbug1090.pp | 17 - tests/webtbs/tbug1092.pp | 21 - tests/webtbs/tbug1096.pp | 24 - tests/webtbs/tbug1097.pp | 26 - tests/webtbs/tbug1103.pp | 23 - tests/webtbs/tbug1104.pp | 14 - tests/webtbs/tbug1111.pp | 7 - tests/webtbs/tbug1117.pp | 27 - tests/webtbs/tbug1123.pp | 30 - tests/webtbs/tbug1124.pp | 18 - tests/webtbs/tbug1132.pp | 28 - tests/webtbs/tbug1133.pp | 34 - tests/webtbs/tbug1152.pp | 39 -- tests/webtbs/tbug1157.pp | 35 -- tests/webtbs/tbug1203.pp | 22 - tests/webtbs/tbug1204.pas | 73 --- tests/webtbs/tbug555.pp | 50 -- tests/webtbs/tbug555a.pp | 57 -- tests/webtbs/tbug630.pp | 34 - tests/webtbs/tbug701a.pp | 18 - tests/webtbs/tbug701b.pp | 6 - tests/webtbs/tbug701c.pp | 22 - tests/webtbs/tbug701d.pp | 18 - tests/webtbs/tbug701e.pp | 25 - tests/webtbs/tbug711.pp | 78 --- tests/webtbs/tbug719.pp | 17 - tests/webtbs/tbug735.pp | 25 - tests/webtbs/tbug736.pp | 130 ---- tests/webtbs/tbug738.pp | 15 - tests/webtbs/tbug739.pp | 13 - tests/webtbs/tbug748.pp | 4 - tests/webtbs/tbug751.pp | 6 - tests/webtbs/tbug753.pp | 44 -- tests/webtbs/tbug753.ree | 1 - tests/webtbs/tbug754.pp | 78 --- tests/webtbs/tbug755.pp | 40 -- tests/webtbs/tbug760.pp | 32 - tests/webtbs/tbug761.pp | 14 - tests/webtbs/tbug769.pp | 9 - tests/webtbs/tbug772.pp | 39 -- tests/webtbs/tbug776.pp | 16 - tests/webtbs/tbug784.pp | 27 - tests/webtbs/tbug788.pp | 68 -- tests/webtbs/tbug789.pp | 14 - tests/webtbs/tbug793.pp | 29 - tests/webtbs/tbug797.pp | 30 - tests/webtbs/tbug797a.pp | 26 - tests/webtbs/tbug801.pp | 12 - tests/webtbs/tbug802.pp | 9 - tests/webtbs/tbug803.pp | 17 - tests/webtbs/tbug809.pp | 7 - tests/webtbs/tbug809a.pp | 14 - tests/webtbs/tbug810.pp | 13 - tests/webtbs/tbug812.pp | 26 - tests/webtbs/tbug813.pp | 31 - tests/webtbs/tbug814.pp | 5 - tests/webtbs/tbug815.pp | 10 - tests/webtbs/tbug816.pp | 24 - tests/webtbs/tbug819.pp | 27 - tests/webtbs/tbug825.pp | 39 -- tests/webtbs/tbug839.pp | 18 - tests/webtbs/tbug840.pp | 24 - tests/webtbs/tbug840a.pp | 6 - tests/webtbs/tbug840b.pp | 6 - tests/webtbs/tbug848.pp | 28 - tests/webtbs/tbug852.pp | 13 - tests/webtbs/tbug855.pp | 16 - tests/webtbs/tbug859.pp | 31 - tests/webtbs/tbug866.pp | 17 - tests/webtbs/tbug868.pp | 51 -- tests/webtbs/tbug869.pp | 24 - tests/webtbs/tbug870.pp | 21 - tests/webtbs/tbug873.pp | 41 -- tests/webtbs/tbug873a.pp | 40 -- tests/webtbs/tbug876.pp | 30 - tests/webtbs/tbug877.pp | 26 - tests/webtbs/tbug879.pp | 13 - tests/webtbs/tbug881.pp | 14 - tests/webtbs/tbug882.pp | 30 - tests/webtbs/tbug890.pp | 43 -- tests/webtbs/tbug891.pp | 39 -- tests/webtbs/tbug892.pp | 18 - tests/webtbs/tbug893.pp | 17 - tests/webtbs/tbug895.pp | 14 - tests/webtbs/tbug896.pp | 34 - tests/webtbs/tbug900.pp | 14 - tests/webtbs/tbug902.pp | 12 - tests/webtbs/tbug909.pp | 7 - tests/webtbs/tbug911.pp | 8 - tests/webtbs/tbug912.pp | 44 -- tests/webtbs/tbug918.pp | 15 - tests/webtbs/tbug919.pp | 15 - tests/webtbs/tbug922.pp | 24 - tests/webtbs/tbug925.pp | 23 - tests/webtbs/tbug932.pp | 16 - tests/webtbs/tbug934.pp | 19 - tests/webtbs/tbug935.pp | 23 - tests/webtbs/tbug937.pp | 17 - tests/webtbs/tbug938.pp | 74 --- tests/webtbs/tbug944.pp | 26 - tests/webtbs/tbug947.pp | 59 -- tests/webtbs/tbug961.pp | 32 - tests/webtbs/tbug966.pp | 81 --- tests/webtbs/tbug976.pp | 41 -- tests/win95test.bat | 175 ------ 661 files changed, 7 insertions(+), 25654 deletions(-) delete mode 100644 tests/Makefile delete mode 100644 tests/Makefile.fpc delete mode 100644 tests/README delete mode 100644 tests/bugs.txt delete mode 100644 tests/dotest.pp delete mode 100644 tests/erroru.pp delete mode 100644 tests/getret.pp delete mode 100644 tests/graph.lst delete mode 100644 tests/readme.txt delete mode 100644 tests/tbf/tbf0008.pp delete mode 100644 tests/tbf/tbf0010.pp delete mode 100644 tests/tbf/tbf0029.pp delete mode 100644 tests/tbf/tbf0036.pp delete mode 100644 tests/tbf/tbf0049.pp delete mode 100644 tests/tbf/tbf0060.pp delete mode 100644 tests/tbf/tbf0061.pp delete mode 100644 tests/tbf/tbf0071.pp delete mode 100644 tests/tbf/tbf0075.pp delete mode 100644 tests/tbf/tbf0085.pp delete mode 100644 tests/tbf/tbf0086.pp delete mode 100644 tests/tbf/tbf0087.pp delete mode 100644 tests/tbf/tbf0088.pp delete mode 100644 tests/tbf/tbf0089.pp delete mode 100644 tests/tbf/tbf0094.pp delete mode 100644 tests/tbf/tbf0097.pp delete mode 100644 tests/tbf/tbf0100.pp delete mode 100644 tests/tbf/tbf0101.pp delete mode 100644 tests/tbf/tbf0108.pp delete mode 100644 tests/tbf/tbf0109.pp delete mode 100644 tests/tbf/tbf0110.pp delete mode 100644 tests/tbf/tbf0117.pp delete mode 100644 tests/tbf/tbf0127.pp delete mode 100644 tests/tbf/tbf0136.pp delete mode 100644 tests/tbf/tbf0148.pp delete mode 100644 tests/tbf/tbf0151.pp delete mode 100644 tests/tbf/tbf0153.pp delete mode 100644 tests/tbf/tbf0155.pp delete mode 100644 tests/tbf/tbf0157.pp delete mode 100644 tests/tbf/tbf0158.pp delete mode 100644 tests/tbf/tbf0161.pp delete mode 100644 tests/tbf/tbf0164.pp delete mode 100644 tests/tbf/tbf0166.pp delete mode 100644 tests/tbf/tbf0167.pp delete mode 100644 tests/tbf/tbf0168.pp delete mode 100644 tests/tbf/tbf0172.pp delete mode 100644 tests/tbf/tbf0173.pp delete mode 100644 tests/tbf/tbf0175.pp delete mode 100644 tests/tbf/tbf0186.pp delete mode 100644 tests/tbf/tbf0196.pp delete mode 100644 tests/tbf/tbf0197.pp delete mode 100644 tests/tbf/tbf0205.pp delete mode 100644 tests/tbf/tbf0208.pp delete mode 100644 tests/tbf/tbf0219.pp delete mode 100644 tests/tbf/tbf0230.pp delete mode 100644 tests/tbf/tbf0231.pp delete mode 100644 tests/tbf/tbf0234.pp delete mode 100644 tests/tbf/tbf0242.pp delete mode 100644 tests/tbf/tbf0245.pp delete mode 100644 tests/tbf/tbf0246.pp delete mode 100644 tests/tbf/tbf0248.pp delete mode 100644 tests/tbf/tbf0265.pp delete mode 100644 tests/tbf/tbf0269.pp delete mode 100644 tests/tbf/tbf0272.pp delete mode 100644 tests/tbf/tbf0281.pp delete mode 100644 tests/tbf/tbf0284.pp delete mode 100644 tests/tbf/tbf0298.pp delete mode 100644 tests/tbf/tbf0300.pp delete mode 100644 tests/tbf/tbf0301.pp delete mode 100644 tests/tbf/tbf0310.pp delete mode 100644 tests/tbf/tbf0311.pp delete mode 100644 tests/tbf/tbf0314.pp delete mode 100644 tests/tbf/tbf0315.pp delete mode 100644 tests/tbf/tbf0320.pp delete mode 100644 tests/tbf/tbf0323.pp delete mode 100644 tests/tbf/tbf0324.pp delete mode 100644 tests/tbf/tbf0325.pp delete mode 100644 tests/tbf/tbf0326.pp delete mode 100644 tests/tbf/tbf0328.pp delete mode 100644 tests/tbf/tbf0342.pp delete mode 100644 tests/tbf/tbf0343.pp delete mode 100644 tests/tbf/tbf0345.pp delete mode 100644 tests/tbf/tbf0347.pp delete mode 100644 tests/tbf/tbf0349.pp delete mode 100644 tests/tbf/tbf0351.pp delete mode 100644 tests/tbf/tbf0352.pp delete mode 100644 tests/tbf/tbf0353.pp delete mode 100644 tests/tbf/tbf0354.pp delete mode 100644 tests/tbf/tbf0355.pp delete mode 100644 tests/tbf/tbf0356.pp delete mode 100644 tests/tbf/tbf0357.pp delete mode 100644 tests/tbf/tbf0358.pp delete mode 100644 tests/tbf/tbf0359.pp delete mode 100644 tests/tbf/tbf0360.pp delete mode 100644 tests/tbf/tbff001.pp delete mode 100644 tests/tbf/tbff002.pp delete mode 100644 tests/tbs/tbs0001.pp delete mode 100644 tests/tbs/tbs0002.pp delete mode 100644 tests/tbs/tbs0003.pp delete mode 100644 tests/tbs/tbs0004.pp delete mode 100644 tests/tbs/tbs0005.pp delete mode 100644 tests/tbs/tbs0006.pp delete mode 100644 tests/tbs/tbs0007.pp delete mode 100644 tests/tbs/tbs0009.pp delete mode 100644 tests/tbs/tbs0011.pp delete mode 100644 tests/tbs/tbs0012.pp delete mode 100644 tests/tbs/tbs0013.pp delete mode 100644 tests/tbs/tbs0014.pp delete mode 100644 tests/tbs/tbs0015.pp delete mode 100644 tests/tbs/tbs0016.pp delete mode 100644 tests/tbs/tbs0017.pp delete mode 100644 tests/tbs/tbs0018.pp delete mode 100644 tests/tbs/tbs0019.pp delete mode 100644 tests/tbs/tbs0021.pp delete mode 100644 tests/tbs/tbs0022.pp delete mode 100644 tests/tbs/tbs0023.pp delete mode 100644 tests/tbs/tbs0024.pp delete mode 100644 tests/tbs/tbs0025.pp delete mode 100644 tests/tbs/tbs0026.pp delete mode 100644 tests/tbs/tbs0027.pp delete mode 100644 tests/tbs/tbs0028.pp delete mode 100644 tests/tbs/tbs0029.pp delete mode 100644 tests/tbs/tbs0030.pp delete mode 100644 tests/tbs/tbs0031.pp delete mode 100644 tests/tbs/tbs0032.pp delete mode 100644 tests/tbs/tbs0033.pp delete mode 100644 tests/tbs/tbs0034.pp delete mode 100644 tests/tbs/tbs0035.pp delete mode 100644 tests/tbs/tbs0037.pp delete mode 100644 tests/tbs/tbs0038.pp delete mode 100644 tests/tbs/tbs0039.pp delete mode 100644 tests/tbs/tbs0040.pp delete mode 100644 tests/tbs/tbs0041.pp delete mode 100644 tests/tbs/tbs0042.pp delete mode 100644 tests/tbs/tbs0043.pp delete mode 100644 tests/tbs/tbs0044.pp delete mode 100644 tests/tbs/tbs0045.pp delete mode 100644 tests/tbs/tbs0046.pp delete mode 100644 tests/tbs/tbs0047.pp delete mode 100644 tests/tbs/tbs0048.pp delete mode 100644 tests/tbs/tbs0050.pp delete mode 100644 tests/tbs/tbs0051.pp delete mode 100644 tests/tbs/tbs0052.pp delete mode 100644 tests/tbs/tbs0053.pp delete mode 100644 tests/tbs/tbs0054.pp delete mode 100644 tests/tbs/tbs0055.pp delete mode 100644 tests/tbs/tbs0056.pp delete mode 100644 tests/tbs/tbs0057.pp delete mode 100644 tests/tbs/tbs0058.pp delete mode 100644 tests/tbs/tbs0059.pp delete mode 100644 tests/tbs/tbs0061.pp delete mode 100644 tests/tbs/tbs0062.pp delete mode 100644 tests/tbs/tbs0063.pp delete mode 100644 tests/tbs/tbs0064.pp delete mode 100644 tests/tbs/tbs0065.pp delete mode 100644 tests/tbs/tbs0066.pp delete mode 100644 tests/tbs/tbs0067.pp delete mode 100644 tests/tbs/tbs0067b.pp delete mode 100644 tests/tbs/tbs0068.pp delete mode 100644 tests/tbs/tbs0069.pp delete mode 100644 tests/tbs/tbs0070.pp delete mode 100644 tests/tbs/tbs0072.pp delete mode 100644 tests/tbs/tbs0073.pp delete mode 100644 tests/tbs/tbs0074.pp delete mode 100644 tests/tbs/tbs0076.pp delete mode 100644 tests/tbs/tbs0077.pp delete mode 100644 tests/tbs/tbs0077b.pp delete mode 100644 tests/tbs/tbs0078.pp delete mode 100644 tests/tbs/tbs0079.pp delete mode 100644 tests/tbs/tbs0080.pp delete mode 100644 tests/tbs/tbs0081.pp delete mode 100644 tests/tbs/tbs0082.pp delete mode 100644 tests/tbs/tbs0083.pp delete mode 100644 tests/tbs/tbs0084.pp delete mode 100644 tests/tbs/tbs0090.pp delete mode 100644 tests/tbs/tbs0091.pp delete mode 100644 tests/tbs/tbs0092.pp delete mode 100644 tests/tbs/tbs0093.pp delete mode 100644 tests/tbs/tbs0095.pp delete mode 100644 tests/tbs/tbs0096.pp delete mode 100644 tests/tbs/tbs0098.pp delete mode 100644 tests/tbs/tbs0099.pp delete mode 100644 tests/tbs/tbs0102.pp delete mode 100644 tests/tbs/tbs0103.pp delete mode 100644 tests/tbs/tbs0104.pp delete mode 100644 tests/tbs/tbs0105.pp delete mode 100644 tests/tbs/tbs0106.pp delete mode 100644 tests/tbs/tbs0107.pp delete mode 100644 tests/tbs/tbs0109.pp delete mode 100644 tests/tbs/tbs0111.pp delete mode 100644 tests/tbs/tbs0112.pp delete mode 100644 tests/tbs/tbs0113.pp delete mode 100644 tests/tbs/tbs0114.pp delete mode 100644 tests/tbs/tbs0115.pp delete mode 100644 tests/tbs/tbs0116.pp delete mode 100644 tests/tbs/tbs0118.pp delete mode 100644 tests/tbs/tbs0119.pp delete mode 100644 tests/tbs/tbs0120.pp delete mode 100644 tests/tbs/tbs0121.pp delete mode 100644 tests/tbs/tbs0122.pp delete mode 100644 tests/tbs/tbs0123.pp delete mode 100644 tests/tbs/tbs0124.pp delete mode 100644 tests/tbs/tbs0124b.pp delete mode 100644 tests/tbs/tbs0125.pp delete mode 100644 tests/tbs/tbs0126.pp delete mode 100644 tests/tbs/tbs0128.pp delete mode 100644 tests/tbs/tbs0129.pp delete mode 100644 tests/tbs/tbs0130.pp delete mode 100644 tests/tbs/tbs0131.pp delete mode 100644 tests/tbs/tbs0132.pp delete mode 100644 tests/tbs/tbs0133.pp delete mode 100644 tests/tbs/tbs0134.pp delete mode 100644 tests/tbs/tbs0135.pp delete mode 100644 tests/tbs/tbs0137.pp delete mode 100644 tests/tbs/tbs0138.pp delete mode 100644 tests/tbs/tbs0139.pp delete mode 100644 tests/tbs/tbs0139a.pp delete mode 100644 tests/tbs/tbs0140.pp delete mode 100644 tests/tbs/tbs0140a.pp delete mode 100644 tests/tbs/tbs0141.pp delete mode 100644 tests/tbs/tbs0142.pp delete mode 100644 tests/tbs/tbs0143.pp delete mode 100644 tests/tbs/tbs0144.pp delete mode 100644 tests/tbs/tbs0145.pp delete mode 100644 tests/tbs/tbs0146.pp delete mode 100644 tests/tbs/tbs0147.pp delete mode 100644 tests/tbs/tbs0149a.pp delete mode 100644 tests/tbs/tbs0149b.pp delete mode 100644 tests/tbs/tbs0150.pp delete mode 100644 tests/tbs/tbs0152.pp delete mode 100644 tests/tbs/tbs0154.pp delete mode 100644 tests/tbs/tbs0156a.pp delete mode 100644 tests/tbs/tbs0156b.pp delete mode 100644 tests/tbs/tbs0157.pp delete mode 100644 tests/tbs/tbs0159.pp delete mode 100644 tests/tbs/tbs0160.pp delete mode 100644 tests/tbs/tbs0162.pp delete mode 100644 tests/tbs/tbs0163.pp delete mode 100644 tests/tbs/tbs0164.pp delete mode 100644 tests/tbs/tbs0165.pp delete mode 100644 tests/tbs/tbs0169.pp delete mode 100644 tests/tbs/tbs0170.pp delete mode 100644 tests/tbs/tbs0171.pp delete mode 100644 tests/tbs/tbs0174.pp delete mode 100644 tests/tbs/tbs0175.pp delete mode 100644 tests/tbs/tbs0176.pp delete mode 100644 tests/tbs/tbs0177.pp delete mode 100644 tests/tbs/tbs0178.pp delete mode 100644 tests/tbs/tbs0179.pp delete mode 100644 tests/tbs/tbs0180.pp delete mode 100644 tests/tbs/tbs0180a.pp delete mode 100644 tests/tbs/tbs0181.pp delete mode 100644 tests/tbs/tbs0181a.pp delete mode 100644 tests/tbs/tbs0182.pp delete mode 100644 tests/tbs/tbs0183.pp delete mode 100644 tests/tbs/tbs0184.pp delete mode 100644 tests/tbs/tbs0185.pp delete mode 100644 tests/tbs/tbs0187.pp delete mode 100644 tests/tbs/tbs0188.pp delete mode 100644 tests/tbs/tbs0189.pp delete mode 100644 tests/tbs/tbs0190.pp delete mode 100644 tests/tbs/tbs0191.pp delete mode 100644 tests/tbs/tbs0192.pp delete mode 100644 tests/tbs/tbs0193.pp delete mode 100644 tests/tbs/tbs0194.pp delete mode 100644 tests/tbs/tbs0195.pp delete mode 100644 tests/tbs/tbs0196.pp delete mode 100644 tests/tbs/tbs0198.pp delete mode 100644 tests/tbs/tbs0199.pp delete mode 100644 tests/tbs/tbs0201.pp delete mode 100644 tests/tbs/tbs0202.pp delete mode 100644 tests/tbs/tbs0203.pp delete mode 100644 tests/tbs/tbs0203a.pp delete mode 100644 tests/tbs/tbs0204.pp delete mode 100644 tests/tbs/tbs0206.pp delete mode 100644 tests/tbs/tbs0207.pp delete mode 100644 tests/tbs/tbs0209.pp delete mode 100644 tests/tbs/tbs0210.pp delete mode 100644 tests/tbs/tbs0211.pp delete mode 100644 tests/tbs/tbs0212.pp delete mode 100644 tests/tbs/tbs0213.pp delete mode 100644 tests/tbs/tbs0213a.pp delete mode 100644 tests/tbs/tbs0214.pp delete mode 100644 tests/tbs/tbs0215.pp delete mode 100644 tests/tbs/tbs0216.pp delete mode 100644 tests/tbs/tbs0217.pp delete mode 100644 tests/tbs/tbs0218.pp delete mode 100644 tests/tbs/tbs0220.pp delete mode 100644 tests/tbs/tbs0221.pp delete mode 100644 tests/tbs/tbs0222.pp delete mode 100644 tests/tbs/tbs0223.pp delete mode 100644 tests/tbs/tbs0224.pp delete mode 100644 tests/tbs/tbs0225.pp delete mode 100644 tests/tbs/tbs0226.pp delete mode 100644 tests/tbs/tbs0227.pp delete mode 100644 tests/tbs/tbs0228.pp delete mode 100644 tests/tbs/tbs0229.pp delete mode 100644 tests/tbs/tbs0232.pp delete mode 100644 tests/tbs/tbs0233.pp delete mode 100644 tests/tbs/tbs0234.pp delete mode 100644 tests/tbs/tbs0235.pp delete mode 100644 tests/tbs/tbs0236.pp delete mode 100644 tests/tbs/tbs0237.pp delete mode 100644 tests/tbs/tbs0238.pp delete mode 100644 tests/tbs/tbs0239.pp delete mode 100644 tests/tbs/tbs0240.pp delete mode 100644 tests/tbs/tbs0241.pp delete mode 100644 tests/tbs/tbs0242b.pp delete mode 100644 tests/tbs/tbs0243.pp delete mode 100644 tests/tbs/tbs0244.pp delete mode 100644 tests/tbs/tbs0247.pp delete mode 100644 tests/tbs/tbs0249.pp delete mode 100644 tests/tbs/tbs0250.pp delete mode 100644 tests/tbs/tbs0251.pp delete mode 100644 tests/tbs/tbs0252.pp delete mode 100644 tests/tbs/tbs0253.pp delete mode 100644 tests/tbs/tbs0254.pp delete mode 100644 tests/tbs/tbs0255.pp delete mode 100644 tests/tbs/tbs0256.pp delete mode 100644 tests/tbs/tbs0257.pp delete mode 100644 tests/tbs/tbs0258.pp delete mode 100644 tests/tbs/tbs0259.pp delete mode 100644 tests/tbs/tbs0260.pp delete mode 100644 tests/tbs/tbs0261.pp delete mode 100644 tests/tbs/tbs0261a.pp delete mode 100644 tests/tbs/tbs0262.pp delete mode 100644 tests/tbs/tbs0263.pp delete mode 100644 tests/tbs/tbs0264.pp delete mode 100644 tests/tbs/tbs0266.pp delete mode 100644 tests/tbs/tbs0267.pp delete mode 100644 tests/tbs/tbs0268.pp delete mode 100644 tests/tbs/tbs0270.pp delete mode 100644 tests/tbs/tbs0271.pp delete mode 100644 tests/tbs/tbs0272.pp delete mode 100644 tests/tbs/tbs0273.pp delete mode 100644 tests/tbs/tbs0274.pp delete mode 100644 tests/tbs/tbs0275.pp delete mode 100644 tests/tbs/tbs0276.pp delete mode 100644 tests/tbs/tbs0277.pp delete mode 100644 tests/tbs/tbs0278.pp delete mode 100644 tests/tbs/tbs0279.pp delete mode 100644 tests/tbs/tbs0280.pp delete mode 100644 tests/tbs/tbs0282.pp delete mode 100644 tests/tbs/tbs0283.pp delete mode 100644 tests/tbs/tbs0284b.pp delete mode 100644 tests/tbs/tbs0285.pp delete mode 100644 tests/tbs/tbs0286.pp delete mode 100644 tests/tbs/tbs0287.pp delete mode 100644 tests/tbs/tbs0288.pp delete mode 100644 tests/tbs/tbs0289.pp delete mode 100644 tests/tbs/tbs0290.pp delete mode 100644 tests/tbs/tbs0291.pp delete mode 100644 tests/tbs/tbs0292.pp delete mode 100644 tests/tbs/tbs0293.pp delete mode 100644 tests/tbs/tbs0294.pp delete mode 100644 tests/tbs/tbs0295.pp delete mode 100644 tests/tbs/tbs0296.pp delete mode 100644 tests/tbs/tbs0297.pp delete mode 100644 tests/tbs/tbs0299.pp delete mode 100644 tests/tbs/tbs0302.pp delete mode 100644 tests/tbs/tbs0303.pp delete mode 100644 tests/tbs/tbs0304.pp delete mode 100644 tests/tbs/tbs0305.pp delete mode 100644 tests/tbs/tbs0306.pp delete mode 100644 tests/tbs/tbs0306.ree delete mode 100644 tests/tbs/tbs0307.pp delete mode 100644 tests/tbs/tbs0308.pp delete mode 100644 tests/tbs/tbs0308a.pp delete mode 100644 tests/tbs/tbs0309.pp delete mode 100644 tests/tbs/tbs0312.pp delete mode 100644 tests/tbs/tbs0313.pp delete mode 100644 tests/tbs/tbs0316.pp delete mode 100644 tests/tbs/tbs0317.pp delete mode 100644 tests/tbs/tbs0318.pp delete mode 100644 tests/tbs/tbs0318.ree delete mode 100644 tests/tbs/tbs0319.pp delete mode 100644 tests/tbs/tbs0321.pp delete mode 100644 tests/tbs/tbs0322.pp delete mode 100644 tests/tbs/tbs0327.pp delete mode 100644 tests/tbs/tbs0329.pp delete mode 100644 tests/tbs/tbs0330.pp delete mode 100644 tests/tbs/tbs0331.pp delete mode 100644 tests/tbs/tbs0332.pp delete mode 100644 tests/tbs/tbs0333.pp delete mode 100644 tests/tbs/tbs0334.pp delete mode 100644 tests/tbs/tbs0335.pp delete mode 100644 tests/tbs/tbs0336.pp delete mode 100644 tests/tbs/tbs0337.pp delete mode 100644 tests/tbs/tbs0338.pp delete mode 100644 tests/tbs/tbs0339.pp delete mode 100644 tests/tbs/tbs0340.pp delete mode 100644 tests/tbs/tbs0341.pp delete mode 100644 tests/tbs/tbs0344.pp delete mode 100644 tests/tbs/tbs0346a.pp delete mode 100644 tests/tbs/tbs0346b.pp delete mode 100644 tests/tbs/tbs0348.pp delete mode 100644 tests/tbs/tbs0350.pp delete mode 100644 tests/tbs/tbs0353.pp delete mode 100644 tests/tbs/tbs0355.pp delete mode 100644 tests/tbs/tbs0356.pp delete mode 100644 tests/tbstbf.txt delete mode 100644 tests/tesi/tesicrt.pp delete mode 100644 tests/tesi/tesidos.pp delete mode 100644 tests/tesi/tesirand.pp delete mode 100644 tests/test/divexcp.pp delete mode 100644 tests/test/implprog.pp delete mode 100644 tests/test/impluni1.pp delete mode 100644 tests/test/impluni2.pp delete mode 100644 tests/test/inline01.pp delete mode 100644 tests/test/inoutres.pp delete mode 100644 tests/test/range.pp delete mode 100644 tests/test/range2.pp delete mode 100644 tests/test/range3.pp delete mode 100644 tests/test/readme.txt delete mode 100644 tests/test/strreal.pp delete mode 100644 tests/test/strreal2.pp delete mode 100644 tests/test/testa2.pp delete mode 100644 tests/test/testac.pp delete mode 100644 tests/test/testansi.pp delete mode 100644 tests/test/testaoc.pp delete mode 100644 tests/test/testarr1.pp delete mode 100644 tests/test/testbd.pp delete mode 100644 tests/test/testcard.pp delete mode 100644 tests/test/testcas2.pp delete mode 100644 tests/test/testcase.pp delete mode 100644 tests/test/testchar.pp delete mode 100644 tests/test/testchr2.pp delete mode 100644 tests/test/testcmov.pp delete mode 100644 tests/test/testcstr.pp delete mode 100644 tests/test/testdiv.pp delete mode 100644 tests/test/testenm1.pp delete mode 100644 tests/test/testexc.pp delete mode 100644 tests/test/testexc.ree delete mode 100644 tests/test/testexc2.pp delete mode 100644 tests/test/testexc3.pp delete mode 100644 tests/test/testfail.pp delete mode 100644 tests/test/testfail.ree delete mode 100644 tests/test/testfdi2.pp delete mode 100644 tests/test/testfdi3.pp delete mode 100644 tests/test/testfdiv.pp delete mode 100644 tests/test/testfi1.pp delete mode 100644 tests/test/testfpu.pp delete mode 100644 tests/test/testfpu2.pp delete mode 100644 tests/test/testgoto.pp delete mode 100644 tests/test/testheap.pp delete mode 100644 tests/test/testi642.pp delete mode 100644 tests/test/testin64.pp delete mode 100644 tests/test/testinh.pp delete mode 100644 tests/test/testinl.pp delete mode 100644 tests/test/testintr.pp delete mode 100644 tests/test/testitf1.pp delete mode 100644 tests/test/testitf4.pp delete mode 100644 tests/test/testitf5.pp delete mode 100644 tests/test/testlib.pp delete mode 100644 tests/test/testmmx.pp delete mode 100644 tests/test/testobj.pp delete mode 100644 tests/test/testop.pp delete mode 100644 tests/test/testop1.pp delete mode 100644 tests/test/testop2.pp delete mode 100644 tests/test/testop3.pp delete mode 100644 tests/test/testout.pp delete mode 100644 tests/test/testpusw.pp delete mode 100644 tests/test/testpva2.pp delete mode 100644 tests/test/testpvar.pp delete mode 100644 tests/test/testrang.pp delete mode 100644 tests/test/testreal.pp delete mode 100644 tests/test/testrstr.pp delete mode 100644 tests/test/testrtti.pp delete mode 100644 tests/test/testsave.pp delete mode 100644 tests/test/testset.pp delete mode 100644 tests/test/testset2.pp delete mode 100644 tests/test/teststr.pp delete mode 100644 tests/test/teststr2.pp delete mode 100644 tests/test/testti1.pp delete mode 100644 tests/test/testu1.pp delete mode 100644 tests/test/testu2.pp delete mode 100644 tests/test/testu3.pp delete mode 100644 tests/test/testu4.pp delete mode 100644 tests/test/testu5.pp delete mode 100644 tests/testopt/readme.txt delete mode 100644 tests/testopt/testcse1.pp delete mode 100644 tests/testopt/testcse2.pp delete mode 100644 tests/testopt/testcse3.pp delete mode 100644 tests/testopt/testreg1.pp delete mode 100644 tests/testopt/testreg2.dat delete mode 100644 tests/testopt/testreg2.pp delete mode 100644 tests/testopt/testreg3.pp delete mode 100644 tests/tf/tf000001.pp delete mode 100644 tests/tf/tf000002.pp delete mode 100644 tests/tf/tf000003.pp delete mode 100644 tests/tf/tf000004.pp delete mode 100644 tests/tf/tf000005.pp delete mode 100644 tests/tf/tf000006.pp delete mode 100644 tests/tf/tf000007.pp delete mode 100644 tests/tf/tf000008.pp delete mode 100644 tests/to/to000000.pp delete mode 100644 tests/ts/th010018.pp delete mode 100644 tests/ts/ts010000.pp delete mode 100644 tests/ts/ts010001.pp delete mode 100644 tests/ts/ts010002.pp delete mode 100644 tests/ts/ts010003.pp delete mode 100644 tests/ts/ts010004.pp delete mode 100644 tests/ts/ts010005.pp delete mode 100644 tests/ts/ts010006.pp delete mode 100644 tests/ts/ts010007.pp delete mode 100644 tests/ts/ts010008.pp delete mode 100644 tests/ts/ts010009.pp delete mode 100644 tests/ts/ts010010.pp delete mode 100644 tests/ts/ts010014.pp delete mode 100644 tests/ts/ts010015.pp delete mode 100644 tests/ts/ts010016.pp delete mode 100644 tests/ts/ts010017.pp delete mode 100644 tests/ts/ts010018.pp delete mode 100644 tests/ts/ts010019.pp delete mode 100644 tests/ts/ts010020.pp delete mode 100644 tests/ts/ts010021.pp delete mode 100644 tests/ts/ts010022.pp delete mode 100644 tests/ts/ts010023.pp delete mode 100644 tests/ts/ts010024.pp delete mode 100644 tests/ts/ts010025.pp delete mode 100644 tests/ts/ts010026.pp delete mode 100644 tests/ts/ts010027.pp delete mode 100644 tests/ts/ts010028.pp delete mode 100644 tests/ts/ts010029.pp delete mode 100644 tests/ts/ts010030.pp delete mode 100644 tests/ts/ts010031.pp delete mode 100644 tests/ts/ts010032.pp delete mode 100644 tests/ts/ts010033.pp delete mode 100644 tests/ts/ts010100.pp delete mode 100644 tests/ts/ts010101.pp delete mode 100644 tests/units/Makefile delete mode 100644 tests/units/Makefile.fpc delete mode 100644 tests/webtbf/bug856u.pp delete mode 100644 tests/webtbf/tb1157a.pp delete mode 100644 tests/webtbf/tbug1157.pp delete mode 100644 tests/webtbf/tbug1238.pp delete mode 100644 tests/webtbf/tbug744.pp delete mode 100644 tests/webtbf/tbug744a.pp delete mode 100644 tests/webtbf/tbug784.pp delete mode 100644 tests/webtbf/tbug807.pp delete mode 100644 tests/webtbf/tbug856.pp delete mode 100644 tests/webtbf/tbug890.pp delete mode 100644 tests/webtbf/tbug896.pp delete mode 100644 tests/webtbf/tbug896a.pp delete mode 100644 tests/webtbs/tbug1021.pp delete mode 100644 tests/webtbs/tbug1023.pp delete mode 100644 tests/webtbs/tbug1041.pp delete mode 100644 tests/webtbs/tbug1046.pp delete mode 100644 tests/webtbs/tbug1061.pp delete mode 100644 tests/webtbs/tbug1066a.pp delete mode 100644 tests/webtbs/tbug1066b.pp delete mode 100644 tests/webtbs/tbug1068.pp delete mode 100644 tests/webtbs/tbug1071.pp delete mode 100644 tests/webtbs/tbug1073.pp delete mode 100644 tests/webtbs/tbug1081.pp delete mode 100644 tests/webtbs/tbug1090.pp delete mode 100644 tests/webtbs/tbug1092.pp delete mode 100644 tests/webtbs/tbug1096.pp delete mode 100644 tests/webtbs/tbug1097.pp delete mode 100644 tests/webtbs/tbug1103.pp delete mode 100644 tests/webtbs/tbug1104.pp delete mode 100644 tests/webtbs/tbug1111.pp delete mode 100644 tests/webtbs/tbug1117.pp delete mode 100644 tests/webtbs/tbug1123.pp delete mode 100644 tests/webtbs/tbug1124.pp delete mode 100644 tests/webtbs/tbug1132.pp delete mode 100644 tests/webtbs/tbug1133.pp delete mode 100644 tests/webtbs/tbug1152.pp delete mode 100644 tests/webtbs/tbug1157.pp delete mode 100644 tests/webtbs/tbug1203.pp delete mode 100644 tests/webtbs/tbug1204.pas delete mode 100644 tests/webtbs/tbug555.pp delete mode 100644 tests/webtbs/tbug555a.pp delete mode 100644 tests/webtbs/tbug630.pp delete mode 100644 tests/webtbs/tbug701a.pp delete mode 100644 tests/webtbs/tbug701b.pp delete mode 100644 tests/webtbs/tbug701c.pp delete mode 100644 tests/webtbs/tbug701d.pp delete mode 100644 tests/webtbs/tbug701e.pp delete mode 100644 tests/webtbs/tbug711.pp delete mode 100644 tests/webtbs/tbug719.pp delete mode 100644 tests/webtbs/tbug735.pp delete mode 100644 tests/webtbs/tbug736.pp delete mode 100644 tests/webtbs/tbug738.pp delete mode 100644 tests/webtbs/tbug739.pp delete mode 100644 tests/webtbs/tbug748.pp delete mode 100644 tests/webtbs/tbug751.pp delete mode 100644 tests/webtbs/tbug753.pp delete mode 100644 tests/webtbs/tbug753.ree delete mode 100644 tests/webtbs/tbug754.pp delete mode 100644 tests/webtbs/tbug755.pp delete mode 100644 tests/webtbs/tbug760.pp delete mode 100644 tests/webtbs/tbug761.pp delete mode 100644 tests/webtbs/tbug769.pp delete mode 100644 tests/webtbs/tbug772.pp delete mode 100644 tests/webtbs/tbug776.pp delete mode 100644 tests/webtbs/tbug784.pp delete mode 100644 tests/webtbs/tbug788.pp delete mode 100644 tests/webtbs/tbug789.pp delete mode 100644 tests/webtbs/tbug793.pp delete mode 100644 tests/webtbs/tbug797.pp delete mode 100644 tests/webtbs/tbug797a.pp delete mode 100644 tests/webtbs/tbug801.pp delete mode 100644 tests/webtbs/tbug802.pp delete mode 100644 tests/webtbs/tbug803.pp delete mode 100644 tests/webtbs/tbug809.pp delete mode 100644 tests/webtbs/tbug809a.pp delete mode 100644 tests/webtbs/tbug810.pp delete mode 100644 tests/webtbs/tbug812.pp delete mode 100644 tests/webtbs/tbug813.pp delete mode 100644 tests/webtbs/tbug814.pp delete mode 100644 tests/webtbs/tbug815.pp delete mode 100644 tests/webtbs/tbug816.pp delete mode 100644 tests/webtbs/tbug819.pp delete mode 100644 tests/webtbs/tbug825.pp delete mode 100644 tests/webtbs/tbug839.pp delete mode 100644 tests/webtbs/tbug840.pp delete mode 100644 tests/webtbs/tbug840a.pp delete mode 100644 tests/webtbs/tbug840b.pp delete mode 100644 tests/webtbs/tbug848.pp delete mode 100644 tests/webtbs/tbug852.pp delete mode 100644 tests/webtbs/tbug855.pp delete mode 100644 tests/webtbs/tbug859.pp delete mode 100644 tests/webtbs/tbug866.pp delete mode 100644 tests/webtbs/tbug868.pp delete mode 100644 tests/webtbs/tbug869.pp delete mode 100644 tests/webtbs/tbug870.pp delete mode 100644 tests/webtbs/tbug873.pp delete mode 100644 tests/webtbs/tbug873a.pp delete mode 100644 tests/webtbs/tbug876.pp delete mode 100644 tests/webtbs/tbug877.pp delete mode 100644 tests/webtbs/tbug879.pp delete mode 100644 tests/webtbs/tbug881.pp delete mode 100644 tests/webtbs/tbug882.pp delete mode 100644 tests/webtbs/tbug890.pp delete mode 100644 tests/webtbs/tbug891.pp delete mode 100644 tests/webtbs/tbug892.pp delete mode 100644 tests/webtbs/tbug893.pp delete mode 100644 tests/webtbs/tbug895.pp delete mode 100644 tests/webtbs/tbug896.pp delete mode 100644 tests/webtbs/tbug900.pp delete mode 100644 tests/webtbs/tbug902.pp delete mode 100644 tests/webtbs/tbug909.pp delete mode 100644 tests/webtbs/tbug911.pp delete mode 100644 tests/webtbs/tbug912.pp delete mode 100644 tests/webtbs/tbug918.pp delete mode 100644 tests/webtbs/tbug919.pp delete mode 100644 tests/webtbs/tbug922.pp delete mode 100644 tests/webtbs/tbug925.pp delete mode 100644 tests/webtbs/tbug932.pp delete mode 100644 tests/webtbs/tbug934.pp delete mode 100644 tests/webtbs/tbug935.pp delete mode 100644 tests/webtbs/tbug937.pp delete mode 100644 tests/webtbs/tbug938.pp delete mode 100644 tests/webtbs/tbug944.pp delete mode 100644 tests/webtbs/tbug947.pp delete mode 100644 tests/webtbs/tbug961.pp delete mode 100644 tests/webtbs/tbug966.pp delete mode 100644 tests/webtbs/tbug976.pp delete mode 100644 tests/win95test.bat diff --git a/compiler/Makefile b/compiler/Makefile index 67a02f7a8f..14693fcd11 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -1,5 +1,5 @@ # -# Makefile generated by fpcmake v1.00 [2000/10/12] +# Makefile generated by fpcmake v1.00 [2000/10/27] # defaultrule: all @@ -354,7 +354,7 @@ endif # To install files ifndef INSTALL ifdef inUnix -INSTALL:=install -m 644 +INSTALL:=install -c -m 644 else INSTALL:=$(COPY) endif @@ -363,7 +363,7 @@ endif # To install programs ifndef INSTALLEXE ifdef inUnix -INSTALLEXE:=install -m 755 +INSTALLEXE:=install -c -m 755 else INSTALLEXE:=$(COPY) endif @@ -1212,7 +1212,7 @@ else $(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR) ifdef USETAR $(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT) - cd $(PACKDIR) ; $(TARPROG) c$(TAROPT) --file $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT) * ; cd $(BASEDIR) + cd $(PACKDIR) ; $(TARPROG) cf$(TAROPT) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT) * ; cd $(BASEDIR) else $(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT) cd $(PACKDIR) ; $(ZIPPROG) -Dr $(ZIPOPT) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT) * ; cd $(BASEDIR) @@ -1583,15 +1583,12 @@ override PPEXEFILE:=$(wildcard $(EXENAME)) # This will only install the ppc386.exe, not the message files etc. quickinstall: - $(MKDIR) $(BININSTALLDIR) -ifdef UPXPROG - -$(UPXPROG) $(EXENAME) -endif # Install fpc.exe ifneq ($(FPCEXEFILE),) ifdef UPXPROG -$(UPXPROG) $(FPCEXEFILE) endif + $(MKDIR) $(BININSTALLDIR) $(INSTALLEXE) $(FPCEXEFILE) $(BININSTALLDIR) endif # Install ppc386.exe @@ -1603,6 +1600,7 @@ ifdef UNIXINSTALLDIR $(MKDIR) $(BASEINSTALLDIR) $(INSTALLEXE) $(EXENAME) $(BASEINSTALLDIR) else + $(MKDIR) $(BININSTALLDIR) $(INSTALLEXE) $(EXENAME) $(BININSTALLDIR) endif endif @@ -1647,4 +1645,4 @@ localmake:=$(strip $(wildcard makefile.loc)) ifdef localmake include ./$(localmake) -endif \ No newline at end of file +endif diff --git a/compiler/Makefile.fpc b/compiler/Makefile.fpc index bd7756c17f..d4c150570c 100644 --- a/compiler/Makefile.fpc +++ b/compiler/Makefile.fpc @@ -334,7 +334,6 @@ override PPEXEFILE:=$(wildcard $(EXENAME)) # This will only install the ppc386.exe, not the message files etc. quickinstall: - $(MKDIR) $(BININSTALLDIR) # Install fpc.exe ifneq ($(FPCEXEFILE),) ifdef UPXPROG diff --git a/tests/Makefile b/tests/Makefile deleted file mode 100644 index de88cadbab..0000000000 --- a/tests/Makefile +++ /dev/null @@ -1,742 +0,0 @@ -# -# Makefile generated by fpcmake v1.00 [2000/10/27] -# - -defaultrule: info - -##################################################################### -# Autodetect OS (Linux or Dos or Windows NT) -# define inUnix when running under Unix (Linux,FreeBSD) -# define inWinNT when running under WinNT -##################################################################### - -# We need only / in the path -override PATH:=$(subst \,/,$(PATH)) - -# Search for PWD and determine also if we are under linux -PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(subst ;, ,$(PATH))))) -ifeq ($(PWD),) -PWD:=$(strip $(wildcard $(addsuffix /pwd,$(subst :, ,$(PATH))))) -ifeq ($(PWD),) -nopwd: - @echo You need the GNU utils package to use this Makefile! - @echo Get ftp://ftp.freepascal.org/pub/fpc/dist/go32v2/utilgo32.zip - @exit -else -inUnix=1 -endif -else -PWD:=$(firstword $(PWD)) -endif - -# Detect NT - NT sets OS to Windows_NT -# Detect OS/2 - OS/2 has OS2_SHELL defined -ifndef inUnix -ifeq ($(OS),Windows_NT) -inWinNT=1 -else -ifdef OS2_SHELL -inOS2=1 -endif -endif -endif - -# The extension of executables -ifdef inUnix -SRCEXEEXT= -else -SRCEXEEXT=.exe -endif - -# The path which is searched separated by spaces -ifdef inUnix -SEARCHPATH=$(subst :, ,$(PATH)) -else -SEARCHPATH=$(subst ;, ,$(PATH)) -endif - -# Base dir -ifdef PWD -BASEDIR:=$(shell $(PWD)) -else -BASEDIR=. -endif - -##################################################################### -# FPC version/target Detection -##################################################################### - -# What compiler to use ? -ifndef FPC -# Compatibility with old makefiles -ifdef PP -FPC=$(PP) -else -FPC=ppc386 -endif -endif -override FPC:=$(subst $(SRCEXEEXT),,$(FPC)) -override FPC:=$(subst \,/,$(FPC))$(SRCEXEEXT) - -# Target OS -ifndef OS_TARGET -OS_TARGET:=$(shell $(FPC) -iTO) -endif - -# Source OS -ifndef OS_SOURCE -OS_SOURCE:=$(shell $(FPC) -iSO) -endif - -# Target CPU -ifndef CPU_TARGET -CPU_TARGET:=$(shell $(FPC) -iTP) -endif - -# Source CPU -ifndef CPU_SOURCE -CPU_SOURCE:=$(shell $(FPC) -iSP) -endif - -# FPC version -ifndef FPC_VERSION -FPC_VERSION:=$(shell $(FPC) -iV) -endif - -export FPC OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FPC_VERSION - -##################################################################### -# FPCDIR Setting -##################################################################### - -# Test FPCDIR to look if the RTL dir exists -ifdef FPCDIR -override FPCDIR:=$(subst \,/,$(FPCDIR)) -ifeq ($(wildcard $(FPCDIR)/rtl),) -ifeq ($(wildcard $(FPCDIR)/units),) -override FPCDIR=wrong -endif -endif -else -override FPCDIR=wrong -endif - -# Detect FPCDIR -ifeq ($(FPCDIR),wrong) -ifdef inUnix -override FPCDIR=/usr/local/lib/fpc/$(FPC_VERSION) -ifeq ($(wildcard $(FPCDIR)/units),) -override FPCDIR=/usr/lib/fpc/$(FPC_VERSION) -endif -else -override FPCDIR:=$(subst /$(FPC),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC),$(SEARCHPATH)))))) -override FPCDIR:=$(FPCDIR)/.. -ifeq ($(wildcard $(FPCDIR)/rtl),) -ifeq ($(wildcard $(FPCDIR)/units),) -override FPCDIR:=$(FPCDIR)/.. -ifeq ($(wildcard $(FPCDIR)/rtl),) -ifeq ($(wildcard $(FPCDIR)/units),) -override FPCDIR=c:/pp -endif -endif -endif -endif -endif -endif - -##################################################################### -# User Settings -##################################################################### - - -# Targets - - -# Clean - - -# Install - -ZIPTARGET=install - -# Defaults - - -# Directories - - -# Packages - - -# Libraries - - -##################################################################### -# Default extensions -##################################################################### - -# Default needed extensions (Go32v2,Linux) -LOADEREXT=.as -EXEEXT=.exe -PPLEXT=.ppl -PPUEXT=.ppu -OEXT=.o -ASMEXT=.s -SMARTEXT=.sl -STATICLIBEXT=.a -SHAREDLIBEXT=.so -RSTEXT=.rst -FPCMADE=fpcmade - -# Go32v1 -ifeq ($(OS_TARGET),go32v1) -PPUEXT=.pp1 -OEXT=.o1 -ASMEXT=.s1 -SMARTEXT=.sl1 -STATICLIBEXT=.a1 -SHAREDLIBEXT=.so1 -FPCMADE=fpcmade.v1 -endif - -# Go32v2 -ifeq ($(OS_TARGET),go32v2) -FPCMADE=fpcmade.dos -endif - -# Linux -ifeq ($(OS_TARGET),linux) -EXEEXT= -HASSHAREDLIB=1 -FPCMADE=fpcmade.lnx -endif - -# Linux -ifeq ($(OS_TARGET),freebsd) -EXEEXT= -HASSHAREDLIB=1 -FPCMADE=fpcmade.freebsd -endif - -# Win32 -ifeq ($(OS_TARGET),win32) -PPUEXT=.ppw -OEXT=.ow -ASMEXT=.sw -SMARTEXT=.slw -STATICLIBEXT=.aw -SHAREDLIBEXT=.dll -FPCMADE=fpcmade.w32 -endif - -# OS/2 -ifeq ($(OS_TARGET),os2) -PPUEXT=.ppo -ASMEXT=.so2 -OEXT=.oo2 -SMARTEXT=.so -STATICLIBEXT=.ao2 -SHAREDLIBEXT=.dll -FPCMADE=fpcmade.os2 -endif - -# library prefix -LIBPREFIX=lib -ifeq ($(OS_TARGET),go32v2) -LIBPREFIX= -endif -ifeq ($(OS_TARGET),go32v1) -LIBPREFIX= -endif - -# determine which .pas extension is used -ifndef PASEXT -ifdef EXEOBJECTS -override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(EXEOBJECTS))))) -else -override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(UNITOBJECTS))))) -endif -ifeq ($(TESTPAS),) -PASEXT=.pp -else -PASEXT=.pas -endif -endif - - - -##################################################################### -# Default Directories -##################################################################### - -# Linux and freebsd use unix dirs with /usr/bin, /usr/lib -# When zipping use the target as default, when normal install then -# use the source os as default -ifdef ZIPNAME -# Zipinstall -ifeq ($(OS_TARGET),linux) -UNIXINSTALLDIR=1 -endif -ifeq ($(OS_TARGET),freebsd) -UNIXINSTALLDIR=1 -endif -else -# Normal install -ifeq ($(OS_SOURCE),linux) -UNIXINSTALLDIR=1 -endif -ifeq ($(OS_SOURCE),freebsd) -UNIXINSTALLDIR=1 -endif -endif - -# set the prefix directory where to install everything -ifndef PREFIXINSTALLDIR -ifdef UNIXINSTALLDIR -PREFIXINSTALLDIR=/usr -else -PREFIXINSTALLDIR=/pp -endif -endif -export PREFIXINSTALLDIR - -# Where to place the resulting zip files -ifndef DESTZIPDIR -DESTZIPDIR:=$(BASEDIR) -endif -export DESTZIPDIR - -##################################################################### -# Redirection -##################################################################### - -ifndef REDIRFILE -REDIRFILE=log -endif - -ifdef REDIR -ifndef inUnix -override FPC=redir -eo $(FPC) -endif -# set the verbosity to max -override FPCOPT+=-va -override REDIR:= >> $(REDIRFILE) -endif - -##################################################################### -# Standard rules -##################################################################### - -##################################################################### -# Local Makefile -##################################################################### - -ifneq ($(wildcard fpcmake.loc),) -include fpcmake.loc -endif - -##################################################################### -# Users rules -##################################################################### - -.PHONY: all units tests cont_tests - -# Unix like OS ? -ifeq ($(OS_TARGET),linux) -INUNIX=1 -endif -ifeq ($(OS_TARGET),freebsd) -INUNIX=1 -endif - -# For linux by default no graph tests -ifdef INUNIX -NOGRAPH=1 -endif - -DIRS=tf ts tbs tbf test tesi to webtbs webtbf - -# defining -# NOGRAPH excludes tests using the graph unit, defining -# GRAPH includes those tests. -ifdef NOGRAPH -include graph.lst -endif -ifdef GRAPH -graphlst= -endif - -all : info - -units : - $(MAKE) -C units - -tests : clean all_compilations - -cont_tests : all_compilations - -setdate : - $(FPC) setdate.pp - setdate$(EXEEXT) - call setdate.bat - -.PHONY : setdate - -getret$(EXEEXT) : getret.pp - $(FPC) getret - -getreturncode : getret$(EXEEXT) -ifndef INUNIX - redir -ea $(FILE).log -oa $(FILE).log getret $(COMMAND) - cp retcode $(FILE).$(RESEXT) -else - getret $(COMMAND) > $(FILE).log 2>$(FILE).log - cp retcode $(FILE).$(RESEXT) -# @echo "Return code of $(FILE) is $(cat retcode)" -endif - - -# retcode should be between 0 and 255 -# 256 is for halt -# 512+doserror if doserror<>0 -# 1024 RESFILE does not exist -# 2048 RESFILE is not set -ifndef RESFILE -RETVAL=2048 -else -ifeq ($(wildcard $(RESFILE)*),$(RESFILE)) -RETVAL=$(shell cat $(RESFILE)) -else -RETVAL=1024 -endif -endif - -ifeq ($(RETVAL),0) -testsuccess: - @echo "Test for $(FILE) success (compiles)" - @echo "Test for $(FILE) success (compiles)" >>$(LOG) -else -testsuccess: - @echo "Test for $(FILE) fails (does not compile) error $(RETVAL)" - @echo "Test for $(FILE) fails (does not compile) error $(RETVAL)" >> $(LOG) -ifdef LONGLOG - @echo ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>" >> $(LONGLOG) - @echo "Test for $(FILE) fails (does not compile) error $(RETVAL)" >> $(LONGLOG) - @echo "" >> $(LONGLOG) - cat $(FILE).log >> $(LONGLOG) - @echo "" >> $(LONGLOG) -endif - @echo $(FILE) does not compile >> ts_fail - @echo $(FILE) does not compile error $(RETVAL) >> faillist -endif - -ifdef EXCFILE -ifeq ($(wildcard $(EXCFILE)*),$(EXCFILE)) -EXERETVAL:=$(shell cat $(EXCFILE)) -else -EXERETVAL=$(EXCFILE) does not exist -endif -else -EXERETVAL=No EXCFILE variable defined -endif - -ifdef REEFILE -ifeq ($(wildcard $(REEFILE)*),$(REEFILE)) -export EXPECTEDRETVAL:=$(strip $(shell cat $(REEFILE))) -else -export EXPECTEDRETVAL=0 -endif -endif - -ifdef FILE -ifneq ($(CFGFILE),$(FILE).cfg) -ifneq ($(wildcard $(FILE).cfg),) -export CFGFILE:=$(FILE).cfg -export COMPILEROPT:=$(filter-out COMPILEROPT=,$(shell grep COMPILEROPT= $(CFGFILE))) -export RUNARGS:=$(filter-out RUNARGS=,$(shell grep RUNARGS= $(CFGFILE))) -export POSTPROCESS:=$(filter-out POSTPROCESS=,$(shell grep POSTPROCESS= $(CFGFILE))) -else -CFGFILE= -COMPILEROPT= -RUNARGS= -POSTPROCESS= -endif -endif -endif - -ifeq ($(EXERETVAL),$(EXPECTEDRETVAL)) -ifeq ($(EXPECTEDRETVAL),0) -testexecsuccess: - @echo "Test for exec $(FILE) success (runs without error)" - @echo "Test for $(FILE) success (runs without error)" >> $(LOG) -else -testexecsuccess: - @echo "Test for exec $(FILE) success (gives correct error $(EXERETVAL))" - @echo "Test for $(FILE) success (gives correct error $(EXERETVAL))" >> $(LOG) -endif -else -ifeq ($(EXPECTEDRETVAL),0) -testexecsuccess: - @echo "Test for exec $(FILE) fails exec error $(EXERETVAL)" - @echo "Test for exec $(FILE) fails exec error $(EXERETVAL)" >> $(LOG) - @echo "Running $(FILE) fails with error $(EXERETVAL)" >> faillist -ifdef LONGLOG - @echo ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>" >> $(LONGLOG) - @echo "Test for exec $(FILE) fails exec error $(EXERETVAL)" >> $(LONGLOG) - @echo "" >> $(LONGLOG) - cat $(FILE).elg >> $(LONGLOG) - @echo $(FILE) >> ex_fail -endif -else -testexecsuccess: - @echo "Test for exec $(FILE) fails exec error $(EXERETVAL) ($(EXPECTEDRETVAL) expected)" - @echo "Test for exec $(FILE) fails exec error $(EXERETVAL) ($(EXPECTEDRETVAL) expected)" >> $(LOG) - @echo "Running $(FILE) fails with error $(EXERETVAL) ($(EXPECTEDRETVAL) expected)" >> faillist -ifdef LONGLOG - @echo ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>" >> $(LONGLOG) - @echo "Test for exec $(FILE) fails exec error $(EXERETVAL) ($(EXPECTEDRETVAL) expected)" >> $(LONGLOG) - @echo "" >> $(LONGLOG) - cat $(FILE).elg >> $(LONGLOG) - @echo $(FILE) >> ex_fail -endif -endif -endif - -ifeq ($(wildcard $(FILE)$(EXEEXT)),$(FILE)$(EXEEXT)) -testexec: - @echo "Testing $(FILE)$(EXEEXT)" -ifdef NOREDIR - getret $(FILE)$(EXEEXT) - @echo CFGFILE is $(CFGFILE) -ifdef POSTPROCESS - echo Running post process - -$(POSTPROCESS) -endif -else -ifndef INUNIX - redir -e $(FILE).elg -o $(FILE).elg getret $(FILE)$(EXEEXT) $(RUNARGS) - @echo CFGFILE is $(CFGFILE) -ifdef POSTPROCESS - @echo Running post process - -redir -ea $(FILE).elg -oa $(FILE).elg $(POSTPROCESS) -endif -else - getret $(FILE)$(EXEEXT) $(RUNARGS) > $(FILE).elg 2>$(FILE).elg - @echo CFGFILE is $(CFGFILE) -ifdef POSTPROCESS - echo Running post process - -$(POSTPROCESS) >> $(FILE).elg 2>> $(FILE).elg -endif -endif -endif - cp -f retcode $(FILE).exc - $(MAKE) testexecsuccess 'FILE=$(FILE)' 'EXCFILE=$(FILE).exc' 'REEFILE=$(FILE).ree' -else -testexec: -ifeq ($(wildcard $(FILE)$(PPUEXT)),$(FILE)$(PPUEXT)) - @echo "file is a unit $(FILE)$(PPUEXT)" - @echo "unit" > $(FILE).elg -else -ifeq ($(wildcard $(FILE).dll),$(FILE).dll) - @echo "file is a DLL $(FILE)$(PPUEXT)" - @echo "DLL" > $(FILE).elg -else - @echo "No exefile $(FILE)$(EXEEXT)" -ifdef LONGLOG - @echo "No exefile $(FILE)$(EXEEXT) was generated" >> $(LONGLOG) -endif -endif -endif -endif - -test_exc : - @echo $(wildcard $(FILE).exc*) - @echo xx$(wildcard $(EXCFILE)*)xx xx$(EXCFILE)xx - cat $(FILE).exc - -ifneq ($(RETVAL),0) -testfail: - @echo "Test for $(FILE) success (does not compile) error $(RETVAL)" - @echo "Test for $(FILE) success (does not compile) error $(RETVAL)" >> $(LOG) -else -testfail: - @echo "Test for $(FILE) fails (does compile and should not)" - @echo "Test for $(FILE) fails (does compile and should not)" >> $(LOG) -ifdef LONGLOG - @echo "Test for $(FILE) fails (does compile and should not)" >> $(LONGLOG) -endif - @echo $(FILE) >> tf_fail - @echo $(FILE) compiles >> faillist -endif - -ifndef LONGLOG -export LONGLOG:=longlog -endif - -ifndef LOG -export LOG:=log -endif - - -listcfg : - @echo CFGFILE is "$(CFGFILE)" - @echo COMPILEROPT is "$(COMPILEROPT)" - @echo RUNARGS is "$(RUNARGS)" - @echo EXPECTEDRETVAL is "$(EXPECTEDRETVAL)" - @echo POSTPROCESS is "$(POSTPROCESS)" - -ifdef FILE -OPTFILE=$(wildcard $(FILE).opt) -endif - -ifdef OPTFILE -override OPT+=$(OPTFILE) -endif - -ifndef FILE -FILE=ts/ts00001.pp -endif - -testone : - $(MAKE) getreturncode 'COMMAND=$(FPC) $(OPT) $(COMPILEROPT) $(FILE).pp' 'RESEXT=$(RESEXT)' 'FILE=$(FILE)' - - -%.res : %.pp - $(MAKE) testone 'FILE=$*' 'RESEXT=res' - $(MAKE) testsuccess 'FILE=$*' 'RESFILE=$*.res' - -%.ref : %.pp - $(MAKE) testone 'FILE=$*' 'RESEXT=ref' - $(MAKE) testfail 'FILE=$*' 'RESFILE=$*.ref' - -# exec log files -# creates two files -# *.elg log file -# *.exc exicode of program -%.elg : %.res - $(MAKE) testexec 'FILE=$*' - -%.eli : %.res - $(MAKE) testexec 'FILE=$*' 'NOREDIR=YES' - -allts : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard ts/ts*.pp))) - -alltbs : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard tbs/tbs*.pp))) - -allwebtbs : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard webtbs/tbug*.pp))) - -tbs0to99 : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard tbs/tbs00*.pp))) -tbs100to199 : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard tbs/tbs01*.pp))) -tbs200to299 : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard tbs/tbs02*.pp))) -tbs300to399 : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard tbs/tbs03*.pp))) - -alltest : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard test/test*.pp))) - -alltesi : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard tesi/tesi*.pp))) - -alltis : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard tis/tis*.pp))) - -alltf : $(patsubst %.pp,%.ref,$(filter-out $(graphlst),$(wildcard tf/tf*.pp))) - -alltbf : $(patsubst %.pp,%.ref,$(filter-out $(graphlst),$(wildcard tbf/tbf*.pp))) - -allwebtbf : $(patsubst %.pp,%.ref,$(filter-out $(graphlst),$(wildcard webtbf/tbug*.pp))) - -allto : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard to/to*.pp))) - -ifndef TS_FAIL_LIST -ifeq ($(wildcard ts_fail*),ts_fail) -TS_FAIL_LIST=$(shell cat ts_fail) -export TS_FAIL_LIST -endif -endif - -ifndef TF_FAIL_LIST -ifeq ($(wildcard tf_fail*),tf_fail) -TF_FAIL_LIST=$(shell cat tf_fail) -export TF_FAIL_LIST -endif -endif - -ifndef EXEC_FAIL_LIST -ifeq ($(wildcard ex_fail*),ex_fail) -EXEC_FAIL_LIST=$(shell cat ex_fail) -export EXEC_FAIL_LIST -endif -endif - -clean_fail : - -rm -f $(addsuffix .res,$(TS_FAIL_LIST)) - -rm -f $(addsuffix .ref,$(TF_FAIL_LIST)) - -rm -f $(addsuffix .res,$(EXEC_FAIL_LIST)) - -rm -f $(addsuffix .elg,$(EXEC_FAIL_LIST)) - -# Test all failure of last time -# don't forget to try to run them again -again : - $(MAKE) internal_again LOG=again.log LONGLOG=again.llg - -internal_again : clean_fail $(addsuffix .res,$(TS_FAIL_LIST)) \ - $(addsuffix .ref,$(TF_FAIL_LIST)) \ - $(addsuffix .elg,$(EXEC_FAIL_LIST) $(TS_FAIL_LIST)) - grep fails $(LOG) - -all_compilations : allts alltbs allwebtbs alltf alltbf allwebtbf allto alltest alltesi alltis - grep fails $(LOG) - -allexec : alltsexec alltbsexec allwebtbsexec alltestexec - grep fails $(LOG) - -alltestexec: $(patsubst %.pp,%.elg,$(wildcard test/test*.pp)) - -allfails : - grep fails $(LOG) > fails.log - -# these test are interactive -# no redirection !!! - -alltesiexec: $(patsubst %.pp,%.eli,$(filter-out $(graphlst),$(wildcard tesi/tesi*.pp))) - -alltsexec: $(patsubst %.pp,%.elg,$(filter-out $(graphlst),$(wildcard ts/ts*.pp))) - -alltbsexec: $(patsubst %.pp,%.elg,$(filter-out $(graphlst),$(wildcard tbs/tbs*.pp))) - -allwebtbsexec: $(patsubst %.pp,%.elg,$(filter-out $(graphlst),$(wildcard webtbs/tbug*.pp))) - -tbsexec0to99 : $(patsubst %.pp,%.elg,$(filter-out $(graphlst),$(wildcard tbs/tbs00*.pp))) -tbsexec100to199 : $(patsubst %.pp,%.elg,$(filter-out $(graphlst),$(wildcard tbs/tbs01*.pp))) -tbsexec200to299 : $(patsubst %.pp,%.elg,$(filter-out $(graphlst),$(wildcard tbs/tbs02*.pp))) -tbsexec300to399 : $(patsubst %.pp,%.elg,$(filter-out $(graphlst),$(wildcard tbs/tbs03*.pp))) - -alltisexec: $(patsubst %.pp,%.eli,$(filter-out $(graphlst),$(wildcard tis/tis*.pp))) - -clean: - -rm -f $(addsuffix /*.ref,$(DIRS)) - -rm -f $(addsuffix /*.res,$(DIRS)) - -rm -f $(addsuffix /*$(PPUEXT),$(DIRS)) - -rm -f $(addsuffix /*$(OEXT),$(DIRS)) - -rm -f $(addsuffix /*.log,$(DIRS)) - -rm -f $(addsuffix /*.elg,$(DIRS)) - -rm -f $(addsuffix /*.exc,$(DIRS)) -ifdef INUNIX - -rm -f $(patsubst %.pp,%$(EXEEXT),$(wildcard $(addsuffix /t*.pp,$(DIRS)))) -else - -rm -f $(addsuffix /*$(EXEEXT),$(DIRS)) -endif - -rm -f *.tmp - -rm -f $(LOG) $(LONGLOG) faillist ts_fail tf_fail ex_fail - -rm -f fpcmaked ppas.sh ppas.bat retcode - -full : clean all_compilations allexec - -info : - @echo This Makefile allows to test the compiler - @echo compilation of 'ts*.pp' should succeed - @echo compilation of 'tf*.pp' should fail - @echo compilation of 'test*.pp' should succeed - @echo 'to*.pp' files should also compile - @echo simply run \'make tests\' to test all compilation - @echo run \'make allexec\' to test also if the executables - @echo created behave like the should - @echo run \'make tesiexec\' to test executables - @echo that require interactive mode diff --git a/tests/Makefile.fpc b/tests/Makefile.fpc deleted file mode 100644 index 0250bae25a..0000000000 --- a/tests/Makefile.fpc +++ /dev/null @@ -1,413 +0,0 @@ -# -# Makefile.fpc for Free Pascal Tests directory -# - -[defaults] -defaultrule=info - -[sections] -none=1 -exts=1 - -[rules] -.PHONY: all units tests cont_tests - -# Unix like OS ? -ifeq ($(OS_TARGET),linux) -INUNIX=1 -endif -ifeq ($(OS_TARGET),freebsd) -INUNIX=1 -endif - -# For linux by default no graph tests -ifdef INUNIX -NOGRAPH=1 -endif - -DIRS=tf ts tbs tbf test tesi to webtbs webtbf - -# defining -# NOGRAPH excludes tests using the graph unit, defining -# GRAPH includes those tests. -ifdef NOGRAPH -include graph.lst -endif -ifdef GRAPH -graphlst= -endif - -all : info - -units : - $(MAKE) -C units - -tests : clean all_compilations - -cont_tests : all_compilations - -setdate : - $(FPC) setdate.pp - setdate$(EXEEXT) - call setdate.bat - -.PHONY : setdate - -getret$(EXEEXT) : getret.pp - $(FPC) getret - -getreturncode : getret$(EXEEXT) -ifndef INUNIX - redir -ea $(FILE).log -oa $(FILE).log getret $(COMMAND) - cp retcode $(FILE).$(RESEXT) -else - getret $(COMMAND) > $(FILE).log 2>$(FILE).log - cp retcode $(FILE).$(RESEXT) -# @echo "Return code of $(FILE) is $(cat retcode)" -endif - - -# retcode should be between 0 and 255 -# 256 is for halt -# 512+doserror if doserror<>0 -# 1024 RESFILE does not exist -# 2048 RESFILE is not set -ifndef RESFILE -RETVAL=2048 -else -ifeq ($(wildcard $(RESFILE)*),$(RESFILE)) -RETVAL=$(shell cat $(RESFILE)) -else -RETVAL=1024 -endif -endif - -ifeq ($(RETVAL),0) -testsuccess: - @echo "Test for $(FILE) success (compiles)" - @echo "Test for $(FILE) success (compiles)" >>$(LOG) -else -testsuccess: - @echo "Test for $(FILE) fails (does not compile) error $(RETVAL)" - @echo "Test for $(FILE) fails (does not compile) error $(RETVAL)" >> $(LOG) -ifdef LONGLOG - @echo ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>" >> $(LONGLOG) - @echo "Test for $(FILE) fails (does not compile) error $(RETVAL)" >> $(LONGLOG) - @echo "" >> $(LONGLOG) - cat $(FILE).log >> $(LONGLOG) - @echo "" >> $(LONGLOG) -endif - @echo $(FILE) does not compile >> ts_fail - @echo $(FILE) does not compile error $(RETVAL) >> faillist -endif - -ifdef EXCFILE -ifeq ($(wildcard $(EXCFILE)*),$(EXCFILE)) -EXERETVAL:=$(shell cat $(EXCFILE)) -else -EXERETVAL=$(EXCFILE) does not exist -endif -else -EXERETVAL=No EXCFILE variable defined -endif - -ifdef REEFILE -ifeq ($(wildcard $(REEFILE)*),$(REEFILE)) -export EXPECTEDRETVAL:=$(strip $(shell cat $(REEFILE))) -else -export EXPECTEDRETVAL=0 -endif -endif - -ifdef FILE -ifneq ($(CFGFILE),$(FILE).cfg) -ifneq ($(wildcard $(FILE).cfg),) -export CFGFILE:=$(FILE).cfg -export COMPILEROPT:=$(filter-out COMPILEROPT=,$(shell grep COMPILEROPT= $(CFGFILE))) -export RUNARGS:=$(filter-out RUNARGS=,$(shell grep RUNARGS= $(CFGFILE))) -export POSTPROCESS:=$(filter-out POSTPROCESS=,$(shell grep POSTPROCESS= $(CFGFILE))) -else -CFGFILE= -COMPILEROPT= -RUNARGS= -POSTPROCESS= -endif -endif -endif - -ifeq ($(EXERETVAL),$(EXPECTEDRETVAL)) -ifeq ($(EXPECTEDRETVAL),0) -testexecsuccess: - @echo "Test for exec $(FILE) success (runs without error)" - @echo "Test for $(FILE) success (runs without error)" >> $(LOG) -else -testexecsuccess: - @echo "Test for exec $(FILE) success (gives correct error $(EXERETVAL))" - @echo "Test for $(FILE) success (gives correct error $(EXERETVAL))" >> $(LOG) -endif -else -ifeq ($(EXPECTEDRETVAL),0) -testexecsuccess: - @echo "Test for exec $(FILE) fails exec error $(EXERETVAL)" - @echo "Test for exec $(FILE) fails exec error $(EXERETVAL)" >> $(LOG) - @echo "Running $(FILE) fails with error $(EXERETVAL)" >> faillist -ifdef LONGLOG - @echo ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>" >> $(LONGLOG) - @echo "Test for exec $(FILE) fails exec error $(EXERETVAL)" >> $(LONGLOG) - @echo "" >> $(LONGLOG) - cat $(FILE).elg >> $(LONGLOG) - @echo $(FILE) >> ex_fail -endif -else -testexecsuccess: - @echo "Test for exec $(FILE) fails exec error $(EXERETVAL) ($(EXPECTEDRETVAL) expected)" - @echo "Test for exec $(FILE) fails exec error $(EXERETVAL) ($(EXPECTEDRETVAL) expected)" >> $(LOG) - @echo "Running $(FILE) fails with error $(EXERETVAL) ($(EXPECTEDRETVAL) expected)" >> faillist -ifdef LONGLOG - @echo ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>" >> $(LONGLOG) - @echo "Test for exec $(FILE) fails exec error $(EXERETVAL) ($(EXPECTEDRETVAL) expected)" >> $(LONGLOG) - @echo "" >> $(LONGLOG) - cat $(FILE).elg >> $(LONGLOG) - @echo $(FILE) >> ex_fail -endif -endif -endif - -ifeq ($(wildcard $(FILE)$(EXEEXT)),$(FILE)$(EXEEXT)) -testexec: - @echo "Testing $(FILE)$(EXEEXT)" -ifdef NOREDIR - getret $(FILE)$(EXEEXT) - @echo CFGFILE is $(CFGFILE) -ifdef POSTPROCESS - echo Running post process - -$(POSTPROCESS) -endif -else -ifndef INUNIX - redir -e $(FILE).elg -o $(FILE).elg getret $(FILE)$(EXEEXT) $(RUNARGS) - @echo CFGFILE is $(CFGFILE) -ifdef POSTPROCESS - @echo Running post process - -redir -ea $(FILE).elg -oa $(FILE).elg $(POSTPROCESS) -endif -else - getret $(FILE)$(EXEEXT) $(RUNARGS) > $(FILE).elg 2>$(FILE).elg - @echo CFGFILE is $(CFGFILE) -ifdef POSTPROCESS - echo Running post process - -$(POSTPROCESS) >> $(FILE).elg 2>> $(FILE).elg -endif -endif -endif - cp -f retcode $(FILE).exc - $(MAKE) testexecsuccess 'FILE=$(FILE)' 'EXCFILE=$(FILE).exc' 'REEFILE=$(FILE).ree' -else -testexec: -ifeq ($(wildcard $(FILE)$(PPUEXT)),$(FILE)$(PPUEXT)) - @echo "file is a unit $(FILE)$(PPUEXT)" - @echo "unit" > $(FILE).elg -else -ifeq ($(wildcard $(FILE).dll),$(FILE).dll) - @echo "file is a DLL $(FILE)$(PPUEXT)" - @echo "DLL" > $(FILE).elg -else - @echo "No exefile $(FILE)$(EXEEXT)" -ifdef LONGLOG - @echo "No exefile $(FILE)$(EXEEXT) was generated" >> $(LONGLOG) -endif -endif -endif -endif - -test_exc : - @echo $(wildcard $(FILE).exc*) - @echo xx$(wildcard $(EXCFILE)*)xx xx$(EXCFILE)xx - cat $(FILE).exc - -ifneq ($(RETVAL),0) -testfail: - @echo "Test for $(FILE) success (does not compile) error $(RETVAL)" - @echo "Test for $(FILE) success (does not compile) error $(RETVAL)" >> $(LOG) -else -testfail: - @echo "Test for $(FILE) fails (does compile and should not)" - @echo "Test for $(FILE) fails (does compile and should not)" >> $(LOG) -ifdef LONGLOG - @echo "Test for $(FILE) fails (does compile and should not)" >> $(LONGLOG) -endif - @echo $(FILE) >> tf_fail - @echo $(FILE) compiles >> faillist -endif - -ifndef LONGLOG -export LONGLOG:=longlog -endif - -ifndef LOG -export LOG:=log -endif - - -listcfg : - @echo CFGFILE is "$(CFGFILE)" - @echo COMPILEROPT is "$(COMPILEROPT)" - @echo RUNARGS is "$(RUNARGS)" - @echo EXPECTEDRETVAL is "$(EXPECTEDRETVAL)" - @echo POSTPROCESS is "$(POSTPROCESS)" - -ifdef FILE -OPTFILE=$(wildcard $(FILE).opt) -endif - -ifdef OPTFILE -override OPT+=$(OPTFILE) -endif - -ifndef FILE -FILE=ts/ts00001.pp -endif - -testone : - $(MAKE) getreturncode 'COMMAND=$(FPC) $(OPT) $(COMPILEROPT) $(FILE).pp' 'RESEXT=$(RESEXT)' 'FILE=$(FILE)' - - -%.res : %.pp - $(MAKE) testone 'FILE=$*' 'RESEXT=res' - $(MAKE) testsuccess 'FILE=$*' 'RESFILE=$*.res' - -%.ref : %.pp - $(MAKE) testone 'FILE=$*' 'RESEXT=ref' - $(MAKE) testfail 'FILE=$*' 'RESFILE=$*.ref' - -# exec log files -# creates two files -# *.elg log file -# *.exc exicode of program -%.elg : %.res - $(MAKE) testexec 'FILE=$*' - -%.eli : %.res - $(MAKE) testexec 'FILE=$*' 'NOREDIR=YES' - -allts : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard ts/ts*.pp))) - -alltbs : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard tbs/tbs*.pp))) - -allwebtbs : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard webtbs/tbug*.pp))) - -tbs0to99 : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard tbs/tbs00*.pp))) -tbs100to199 : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard tbs/tbs01*.pp))) -tbs200to299 : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard tbs/tbs02*.pp))) -tbs300to399 : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard tbs/tbs03*.pp))) - -alltest : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard test/test*.pp))) - -alltesi : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard tesi/tesi*.pp))) - -alltis : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard tis/tis*.pp))) - -alltf : $(patsubst %.pp,%.ref,$(filter-out $(graphlst),$(wildcard tf/tf*.pp))) - -alltbf : $(patsubst %.pp,%.ref,$(filter-out $(graphlst),$(wildcard tbf/tbf*.pp))) - -allwebtbf : $(patsubst %.pp,%.ref,$(filter-out $(graphlst),$(wildcard webtbf/tbug*.pp))) - -allto : $(patsubst %.pp,%.res,$(filter-out $(graphlst),$(wildcard to/to*.pp))) - -ifndef TS_FAIL_LIST -ifeq ($(wildcard ts_fail*),ts_fail) -TS_FAIL_LIST=$(shell cat ts_fail) -export TS_FAIL_LIST -endif -endif - -ifndef TF_FAIL_LIST -ifeq ($(wildcard tf_fail*),tf_fail) -TF_FAIL_LIST=$(shell cat tf_fail) -export TF_FAIL_LIST -endif -endif - -ifndef EXEC_FAIL_LIST -ifeq ($(wildcard ex_fail*),ex_fail) -EXEC_FAIL_LIST=$(shell cat ex_fail) -export EXEC_FAIL_LIST -endif -endif - -clean_fail : - -rm -f $(addsuffix .res,$(TS_FAIL_LIST)) - -rm -f $(addsuffix .ref,$(TF_FAIL_LIST)) - -rm -f $(addsuffix .res,$(EXEC_FAIL_LIST)) - -rm -f $(addsuffix .elg,$(EXEC_FAIL_LIST)) - -# Test all failure of last time -# don't forget to try to run them again -again : - $(MAKE) internal_again LOG=again.log LONGLOG=again.llg - -internal_again : clean_fail $(addsuffix .res,$(TS_FAIL_LIST)) \ - $(addsuffix .ref,$(TF_FAIL_LIST)) \ - $(addsuffix .elg,$(EXEC_FAIL_LIST) $(TS_FAIL_LIST)) - grep fails $(LOG) - -all_compilations : allts alltbs allwebtbs alltf alltbf allwebtbf allto alltest alltesi alltis - grep fails $(LOG) - -allexec : alltsexec alltbsexec allwebtbsexec alltestexec - grep fails $(LOG) - -alltestexec: $(patsubst %.pp,%.elg,$(wildcard test/test*.pp)) - -allfails : - grep fails $(LOG) > fails.log - -# these test are interactive -# no redirection !!! - -alltesiexec: $(patsubst %.pp,%.eli,$(filter-out $(graphlst),$(wildcard tesi/tesi*.pp))) - -alltsexec: $(patsubst %.pp,%.elg,$(filter-out $(graphlst),$(wildcard ts/ts*.pp))) - -alltbsexec: $(patsubst %.pp,%.elg,$(filter-out $(graphlst),$(wildcard tbs/tbs*.pp))) - -allwebtbsexec: $(patsubst %.pp,%.elg,$(filter-out $(graphlst),$(wildcard webtbs/tbug*.pp))) - -tbsexec0to99 : $(patsubst %.pp,%.elg,$(filter-out $(graphlst),$(wildcard tbs/tbs00*.pp))) -tbsexec100to199 : $(patsubst %.pp,%.elg,$(filter-out $(graphlst),$(wildcard tbs/tbs01*.pp))) -tbsexec200to299 : $(patsubst %.pp,%.elg,$(filter-out $(graphlst),$(wildcard tbs/tbs02*.pp))) -tbsexec300to399 : $(patsubst %.pp,%.elg,$(filter-out $(graphlst),$(wildcard tbs/tbs03*.pp))) - -alltisexec: $(patsubst %.pp,%.eli,$(filter-out $(graphlst),$(wildcard tis/tis*.pp))) - -clean: - -rm -f $(addsuffix /*.ref,$(DIRS)) - -rm -f $(addsuffix /*.res,$(DIRS)) - -rm -f $(addsuffix /*$(PPUEXT),$(DIRS)) - -rm -f $(addsuffix /*$(OEXT),$(DIRS)) - -rm -f $(addsuffix /*.log,$(DIRS)) - -rm -f $(addsuffix /*.elg,$(DIRS)) - -rm -f $(addsuffix /*.exc,$(DIRS)) -ifdef INUNIX - -rm -f $(patsubst %.pp,%$(EXEEXT),$(wildcard $(addsuffix /t*.pp,$(DIRS)))) -else - -rm -f $(addsuffix /*$(EXEEXT),$(DIRS)) -endif - -rm -f *.tmp - -rm -f $(LOG) $(LONGLOG) faillist ts_fail tf_fail ex_fail - -rm -f fpcmaked ppas.sh ppas.bat retcode - -full : clean all_compilations allexec - -info : - @echo This Makefile allows to test the compiler - @echo compilation of 'ts*.pp' should succeed - @echo compilation of 'tf*.pp' should fail - @echo compilation of 'test*.pp' should succeed - @echo 'to*.pp' files should also compile - @echo simply run \'make tests\' to test all compilation - @echo run \'make allexec\' to test also if the executables - @echo created behave like the should - @echo run \'make tesiexec\' to test executables - @echo that require interactive mode \ No newline at end of file diff --git a/tests/README b/tests/README deleted file mode 100644 index 4ca3f8517a..0000000000 --- a/tests/README +++ /dev/null @@ -1,58 +0,0 @@ -This directory contains a testsuite for the Free Pascal Compiler. - -Tests starting with 'ts' have to compile and execute. -Tests starting with 'tf' will throw an error when compiling. - -You can use the batch files to do all tests. testall.bat will compile all -tests. - -template1.bat is a template for compiling tests that have to run and -execute. - -template2.bat is a template for compiling tests that should crash the -compiler. The test is considered passed if the compiler reports -an error (crashes aren't allowed). - - -Test files ----------- -ts010000.pp tests properties -ts010001.pp tests class references (class of) -ts010002.pp common Delphi object model test -ts010003.pp tests the crt unit colors -ts010004.pp tests forward classes -ts010005.pp tests method overriding -ts010006.pp tests libraries -ts010015.pp tests typed files. -ts010016.pp tests conversion of smallsets in normsets in consts -ts010017.pp tests the problem of iocheck inside iocheck routines -ts010018.pp tests the problem of enums inside objects -ts010019.pp tests problems of name mangling -ts010020.pp tests for const strings problems if const is a single char. -ts010021.pp test for long mangled names (they are strings, ie no longer then - 255 chars (but they have to be allways shorten the same way !!) -ts010022.pp tests a problem of writing pchar in files -ts010023.pp tests set of char parameter passing -ts010024.pp tests att asm reference parsing -ts010025.pp tests intel asm reference parsing -- -ts10100.pp tests for delphi object model -ts101xx.pp - -tf000001.pp stupid example that creates a GPF sometimes -tf000002.pp tests that use of a type as a member of an expression is not possible - -to000000.pp shows when uncertain optimizations can cause wrong code - -testcrt.pp test crt unit functions -testdos.pp test dos unit functions -testset.pp test set functions -testheap.pp test heap functions -teststr.pp test string functions and speed -testaoc.pp test Array of construct. -testansi.pp test ansistrings -testrtti.pp test RTTI generation and typinfo unit. -testexc.pp test exceptions. -testi642.pp test int64/qword -testpvar.pp test procedure variables -testgoto.pp test goto (very simple) diff --git a/tests/bugs.txt b/tests/bugs.txt deleted file mode 100644 index b55baa036b..0000000000 --- a/tests/bugs.txt +++ /dev/null @@ -1,404 +0,0 @@ -This directory contains test files for various FPC bugs. -The most files are very simple and it's neccessary to check the assembler -output. - -The first coloumn contains the file name. If the file name is indended, -the bug is fixed and the last coloumn contains the version where -the bug is fixed. - -In future, please add also your name short cut, when fixing a bug. - -Fixed bugs: ------------ - 1.pp produces a linker error under win32/linux, sorry for the filename - but the filename is the bug :) OK 0.99.11 (PFV) - bug0001.pp tests a bug in the .ascii output (#0 and too long) OK 0.9.2 - bug0002.pp tests for the endless bug in the optimizer OK 0.9.2 - bug0003.pp dito OK 0.9.2 - bug0004.pp tests the continue instruction in the for loop OK 0.9.2 - bug0005.pp tests the if 1=1 then ... bug OK 0.9.2 - bug0006.pp tests the wrong floating point code generation OK 0.9.2 - bug0007.pp tests the infinity loop when using byte counter OK 0.9.2 - bug0008.pp tests the crash when decrementing constants OK 0.9.2 - bug0009.pp tests comperations in function calls a(c<0); OK 0.9.2 - bug0010.pp tests string constants exceeding lines OK 0.9.2 - bug0011.pp tests div/mod bug, where edx is scrambled, if - a called procedure does a div/mod OK 0.9.2 - bug0012.pp tests type conversation byte(a>b) OK 0.9.9 (FK) - bug0015.pp tests for wrong allocated register for return result - of floating function (allocates int register) OK 0.9.2 - bug0018.pp tests for the possibility to declare all types - using pointers "forward" : type p = ^x; x=byte; OK 0.9.3 - bug0021.pp tests compatibility of empty sets with other set - and the evalution of constant sets OK 0.9.3 - bug0022.pp tests getting the address of a method OK 0.9.3 - bug0023.pp tests handling of self pointer in nested methods OK 0.9.3 - bug0025.pp tests for a wrong uninit. var. warning OK 0.9.3 - bug0026.pp tests for a wrong unused. var. warning OK 0.9.4 - bug0027.pp tests - type - enumtype = (One, two, three, forty:=40, fifty); OK 0.9.5 - bug0028.pp type enumtype = (a); writeln(ord(a)); - bug0029.pp tests typeof(object type) OK 0.99.1 (FK) - bug0030.pp tests type conversations in typed consts OK 0.9.6 - bug0031.pp tests array[boolean] of .... OK 0.9.8 - bug0032.pp tests for a bug with the stack OK 0.9.9 - bug0033.pp tests var p : pchar; begin p:='c'; end. OK 0.9.9 - bug0034.pp shows wrong line numbering when asmbler is parsed OK 0.9.9 - in direct mode. - bug0035.pp label at end of block gives error OK 0.9.9 (FK) - bug0036.pp assigning a single character to array of char ?OK 0.9.9 - gives a protection error - --------- cgi386.pas gives out gpf's when compiling the system OK 0.9.9 (FK) - unit. - bug0037.pp tests missing graph.setgraphmode OK RTL (FK) - bug0038.pp tests const ps : ^string = nil; OK 0.9.9 (FK) - bug0039.pp shows the else-else problem OK 0.9.9 (FK) - bug0040.pp shows the if b1 xor b2 problem where b1,b2 :boolean OK 0.9.9 (FK) - bug0041.pp shows the if then end. problem OK 0.9.9 (FK) - bug0042.pp shows assembler double operator expression problem OK 0.99.7 (PFV) - bug0043.pp shows assembler nasm output fpu opcodes problem OK 0.99.6 (PFV) - bug0044.pp shows $ifdef and comment nesting/directive problem OK 0.99.1 (PFV) - bug0045.pp shows problem with virtual private methods OK 0.9.9 (FK) - (might not be a true bug but more of an incompatiblity?) - the compiler warns now if there is a private and virtual - method - bug0046.pp problems with sets with values over 128 due to OK 0.99.1 (FK) - sign extension - (already fixed ) but also for SET_IN_BYTE - bug0047.pp compiling with -So crashes the compiler OK 0.99.1 (CEC) - bug0048.pp shows a problem with putimage on some computers OK 0.99.13 (JM) - bug0049.pp shows an error while defining subrange types OK 0.99.7 (PFV) - bug0050.pp can't set a function result in a nested procedure of a function OK 0.99.7 (PM) - bug0051.pp Graph, shows a problem with putpixel OK 0.99.9 (PM) - bug0052.pp Graph, collects missing graph unit routines OK 0.99.9 (PM) - bug0053.pp shows a problem with open arrays OK 0.99.1 (FK) - (crashes a win95-DOS box :) ) - bug0054.pp wordbool and longbool types are missed OK 0.99.6 (PFV) - bug0055.pp internal error 10 (means too few registers OK 0.99.1 (FK) - - i386 ONLY) - bug0056.pp shows a _very_ simple expression which generates OK 0.99.1 (FK) - wrong assembler - bug0057.pp Graph, shows a crash with switch graph/text/graph OK 0.99.9 (PM) - bug0058.pp causes an internal error 10 (problem with getregisterOK 0.99.1 (FK) - in secondsmaller - i386 ONLY) - bug0059.pp shows the problem with syntax error with ordinal OK 0.99.1 (FK) - constants - bug0060.pp shows missing type checking for case statements OK 0.99.1 (CEC) - bug0061.pp shows wrong errors when compiling (NOT A BUG) OK 0.99.1 - bug0062.pp shows illegal type conversion for boolean OK 0.99.6 (PFV) - bug0063.pp shows problem with ranges in sets for variables OK 0.99.7 (PFV) - bug0064.pp shows other types of problems with case statements OK 0.99.1 (FK) - bug0065.pp shows that frac() doesn't work correctly. OK 0.99.1 (PFV) - bug0066.pp shows that Round doesn't work correctly. (NOT A BUG) OK 0.99.1 - bug0067.pp and bug0067b.pp (Work together) OK 0.99.1 - Shows incorrect symbol resolution when using uses in implementation - More info can be found in file bug0067b.pp. - bug0068.pp Shows incorrect type of ofs() OK 0.99.1 (PFV and FK) - bug0069.pp Shows problem with far qualifier in units OK 0.99.1 (CEC) - bug0070.pp shows missing include and exclude from rtl OK 0.99.6 (MVC) - bug0071.pp shows that an unterminated constant string in a OK 0.99.1 (PFV) - writeln() statement crashes the compiler. - bug0072.pp causes an internal error 10 ( i386 ONLY ) OK 0.99.1 (FK) - bug0073.pp shows incompatiblity with bp for distance qualifiers OK 0.99.6 (PFV) - bug0074.pp shows MAJOR bug when trying to compile valid code OK 0.99.1 (PM/CEC) - bug0075.pp shows invalid pchar output to console OK 0.99.1 - ---------- compiling pp -Us -di386 -Sg system.pp gives GPF OK 0.99.1 - bug0076.pp Bug in intel asm generator. was already fixed OK 0.99.1 (FK) - bug0077.pp shows a bug with absolute in interface part of unit OK 0.99.1 (FK) - bug0077b.pp used by unit bug0077.pp - bug0078.pp Shows problems with longint constant in intel asm OK 0.99.1 (CEC) - parsers - bug0079.pp Shows problems with stackframe with assembler keyword OK 0.99.1 (CEC) - bug0080.pp Shows Missing High() (internal) function. OK 0.99.6 (MVC) - bug0081.pp Shows incompatibility with borland's 'array of char'. OK 0.99.1 (FK) - bug0082.pp Shows incompatibility with BP : Multiple destructors. OK 0.99.1 (FK) - bug0083.pp shows missing "dynamic" set constructor OK 0.99.7 (PFV) - bug0084.pp no more pascal type checking OK 0.99.1 (FK) - bug0085.pp shows runerror 216 OK 0.99.1 (CEC) - bug0086.pp shows runerror 216 OK 0.99.1 (CEC) - bug0087.pp shows internal error 12 - no more SegFaults OK 0.99.1 (FK) - bug0088.pp internal error 12 or Runerror 216 OK 0.99.1 (FK) - bug0089.pp internal error 12 or Runerror 216 OK 0.99.1 (FK) - bug0090.pp shows PChar comparison problem OK 0.99.7 (PFV) - bug0091.pp missing standard functions in constant expressions OK 0.99.7 (PFV) - bug0092.pp The unfixable bug. Maybe we find a solution one day. OK 0.99.6 (FK) - bug0093.pp Two Cardinal type bugs 0K 0.99.1 (FK/MvC) - bug0094.pp internal error when recordtype not found with case OK 0.99.1 - bug0095.pp case with ranges starting with #0 bugs OK 0.99.1 (FK) - bug0096.pp problem with objects as parameters OK 0.99.6 (PM) - bug0097.pp two errors in bp7 but not in FPC OK 0.99.6 (FK) - bug0098.pp File type casts are not allowed (works in TP7) OK 0.99.1 (FK) - bug0099.pp wrong assembler code is genereatoed for range check OK 0.99.1 (?) - (at least under 0.99.0) - bug0100.pp a unit may only occure once in uses OK 0.99.6 (PM) - bug0101.pp no type checking for routines in interfance and OK 0.99.1 (CEC) - implementation - bug0102.pp page fault when trying to compile under ppcm68k OK 0.99.1 - bug0103.pp problems with boolean typecasts (other type) OK 0.99.6 (PFV) - bug0104.pp cardinal greater than $7fffffff aren't written OK 0.99.1 (FK) - correct - bug0105.pp typecasts are now ignored problem (NOT A BUG) OK 0.99.1 - bug0106.pp typecasts are now ignored problem (NOT A BUG) OK 0.99.1 - bug0107.pp shows page fault problem (run in TRUE DOS mode) OK ??.?? - bug0108.pp gives wrong error message OK 0.99.1 (PFV) - bug0109.pp syntax error not detected when using a set as pointer OK 0.99.1 (FK) - bug0110.pp SigSegv when using undeclared var in Case OK 0.99.6 (PFV) - bug0112.pp still generates an internal error 10 OK 0.99.1 (FK) - bug0113.pp point initialization problems OK 0.99.1 (PM/FK) - bug0114.pp writeln problem (by Pavel Ozerski) OK 0.99.1 (PFV) - bug0115.pp missing writeln for comp data type OK 0.99.6 (FK) - bug0116.pp when local variable size is > $ffff, enter can't be OK 0.99.1 (FK) - used to create the stack frame, but it is with -Og - bug0117.pp internalerror 17 (and why is there an automatic float OK 0.99.6 (FK) - conversion?) - bug0118.pp Procedural vars cannot be assigned nil ? OK 0.99.6 (FK) - bug0119.pp problem with methods OK 0.99.6 (FK) - bug0120.pp inc/dec(enumeration) doesn't work OK 0.99.6 (MVC) - bug0121.pp cardinal -> byte conversion not work (and crashes) OK 0.99.6 (FK) - bug0122.pp exit() gives a warning that the result is not set OK 0.99.6 (FK) - bug0123.pp Asm, problem with intel assembler (shrd) OK 0.99.11 (PM) - bug0124.pp Asm, problem with -Rintel switch and indexing OK 0.99.11 (PM/PFV) - bug0125.pp wrong colors with DOS CRT unit OK 0.99.6 (PFV) - bug0126.pp packed array isn't allowed OK 0.99.6 (FK) - bug0127.pp problem with cdecl in implementation part OK 0.99.7 (PFV) - bug0128.pp problem with ^[ OK 0.99.6 (PFV) - bug0129.pp endless loop with while/continue OK 0.99.6 (FK) - bug0130.pp in [..#255] problem OK 0.99.6 (PFV) - bug0131.pp internal error 10 with highdimension arrays OK 0.99.6 (MVC) - bug0132.pp segmentation fault with type loop OK 0.99.7 (FK) - bug0134.pp 'continue' keyword is buggy. OK 0.99.6 (FK) - bug0135.pp Unsupported subrange type construction. OK 0.99.6 - bug0136.pp No types necessary in the procedure header OK 0.99.6 (PFV) - bug0137.pp Cannot assign child object variable to parent objcet type variable OK 0.99.6 - bug0138.pp with problem, %esi can be crushed and is not restored OK 0.99.6 (PM) - bug0139.pp Cannot access protected method of ancestor class from other unit. OK 0.99.6 - bug0140.pp Shows that interdependent units still are not OK. OK 0.99.6 (PFV) - bug0141.pp Wrong Class sizes when using forwardly defined classes. OK 0.99.6 - bug0142.pp sizeof(object) is not tp7 compatible when no constructor is used OK 0.99.9 (PM) - bug0143.pp cannot concat string and array of char in $X+ mode OK 0.99.7 (PFV) - bug0144.pp problem with 'with object do' OK 0.99.7 (PFV) - bug0145.pp typed files with huges records (needs filerec.size:longint) OK 0.99.7 (PFV) - bug0146.pp no sizeof() for var arrays and the size is pushed incorrect OK 0.99.7 (PFV) - bug0147.pp function b; is not allowed in implementation OK 0.99.7 (PFV) - bug0148.pp crash when setting function result of a declared but not yet OK 0.99.7 (PFV) - implemented function in another function - bug0149.pp (a, b) compile bug0149b twice and you'll get a crash OK 0.99.7 (PFV) - bug0150.pp Shows that the assert() macro is missing under Delphi OK 0.99.9 (PFV) - bug0151.pp crash when using undeclared variable in withstatement OK 0.99.7 (PFV) - bug0152.pp End value of loop variable must be calculated before loop - variable is initialized. OK 0.99.11 (PM) - bug0153.pp Asm, indexing a local/para var should produce an error like tp7 OK 0.99.9 (PFV) - bug0154.pp Subrange types give type mismatch when assigning to OK 0.99.7 (PFV) - bug0156.pp (a,b) forward type def in record crashes when loading ppu OK 0.99.7 (PM/PFV) - bug0155.pp Asm, Missing string return for asm functions - (this is a feature rather than a bug : OK 0.99.11 (FK) - complex return values are not allowed for assembler - functions (PM) Why not (FK)? ) - bug0157.pp Invalid compilation and also crashes OK 0.99.7 (PFV) - bug0158.pp Invalid boolean typecast OK 0.99.7 (PFV) - bug0159.pp Invalid virtual functions - should compile OK 0.99.7 (FK) - bug0160.pp Incompatibility with BP: Self shouldn't be a reserved word. OK 0.99.9 (PM) - bug0161.pp internal error when trying to create a set with another OK 0.99.9 (PFV) - bug0162.pp continue in repeat ... until loop doesn't work correct OK 0.99.8 (PFV) - bug0163.pp missing <= and >= operators for sets. OK 0.99.11 (JM) - bug0164.pp crash when using undeclared array index in with statement OK 0.99.8 (PFV) - bug0165.pp missing range check code for enumerated types. OK 0.99.9 (PFV) - bug0166.pp forward type used in declaration crashes instead of error OK 0.99.9 (PFV) - bug0167.pp crash when declaring a procedure with same name as object OK 0.99.9 (PFV) - bug0168.pp set:=set+element is allowed (should be: set:=set+[element]) OK 0.99.9 (PFV) - bug0169.pp missing new(type) support for not object/class OK 0.99.9 (PM) - bug0170.pp Asm, {$ifdef} is seen as a separator OK 0.99.9 (PFV) - bug0171.pp missing typecasting in constant expressions - solved for pointers OK 0.99.11 (PM) - bug0172.pp with with absolute seg:ofs should not be possible OK 0.99.9 (PM) - bug0173.pp secondbug is parsed as asm, but should be normal pascalcode OK 0.99.9 (PFV) - bug0174.pp Asm, offsets of fields are not possible yet OK 0.99.9 (PFV) - bug0175.pp Asm, mov word,%eax should not be allowed without casting - emits a warning (or error with range checking enabled) OK 0.99.11 (PM) - bug0176.pp unit.symbol not allowed for implementation vars OK 0.99.9 (PM) - bug0177.pp program.symbol not allowed (almost the same as bug 176) OK 0.99.9 (PM) - bug0178.pp problems with undefined labels and fail outside constructor OK 0.99.9 (PM) - bug0179.pp show a problem for -So mode OK 0.99.9 (PM) - bug0180.pp problem for units with names different from file name - should be accepted with -Un !! - Solved, but you still need to use the file name from other - units OK 0.99.9 (PM) - bug0181.pp shows a problem with name mangling OK 0.99.9 (PM) - bug0182.pp @record.field doesn't work in constant expr OK 0.99.9 (PM) - bug0183.pp internal error 10 in secondnot OK 0.99.11 (PM) - bug0184.pp multiple copies of the same constant set are stored in executable OK 0.99.9 (PFV) - bug0185.pp missing range checking for Val and subrange types OK 0.99.11 (JM/PFV) - bug0186.pp Erroneous array syntax is accepted. OK 0.99.9 (PFV) - bug0187.pp constructor in a WIth statement isn't called correct. - (works at lest in the case stated) OK 0.99.11 (PM) - bug0188.pp can't print function result of procedural var that returns a - function. Not a bug : wrong syntax !! See source (PM) - bug0189.pp cant compare adresses of function variables !! - As bug0188 FPC syntax problem see source (PM) - bug0190.pp can't have typecast for var params ?? OK 0.99.11 (PM) - bug0191.pp missing vecn constant evaluation OK 0.99.11 (PM) - bug0192.pp can't compare boolean result with true/false, because the - boolean result is already in the flags OK 0.99.11 (PFV) - bug0194.pp @procedure var returns value in it instead of address !! OK 0.99.11 (PM) - bug0195.pp Problem with Getimage, crash of DOS box, even with dpmiexcp!! (PFV) - Not a bug, you must use p^. - bug0196.pp "function a;" is accepted (should require result type) OK 0.99.1 (PM) - bug0197.pp should produce an error: problem with c1:=c2 255 are truncated (should work in -S2,-Sd) OK 0.99.11 (PFV) - bug0230.pp several strange happen on the ln function: ln(0): no - FPE and writeln can't write non numeric values - Gives out an exception on compiling because of zero div OK 0.99.11 (PM) - bug0231.pp Problem with comments OK 0.99.11 (PFV) - bug0232.pp const. procedure variables need a special syntax OK 0.99.13 (PFV) - if they use calling specification modifiers - bug0233.pp Problem with enum sets in args OK 0.99.11 (PFV) - bug0234.pp New with void pointer OK 0.99.11 (PM) - bug0235.pp Val(cardinal) bug OK 0.99.11 (JM) - bug0236.pp Problem with range check of subsets !! compile with -Cr OK 0.99.11 (PFV) - bug0237.pp Can't have sub procedures with names defined in interface OK 0.99.13 (PM) - bug0238.pp Internal error 432645 (from Frank MCCormick, mailinglist 24/2) OK 0.99.11 (PM) - bug0239.pp No warning for uninitialized class in IS statements OK 0.99.11 (PM) - bug0240.pp Problems with larges value is case statements OK 0.99.11 (FK) - bug0241.pp Problem with importing function from a DLL with .drv suffix ! OK 0.99.11 (PM) - bug0242.pp Crash when passing a procedure to formal parameter OK 0.99.11 (PM) - bug0244.pp nested procedures can't have same name as global ones (same as bug0237) OK 0.99.13 (PM) - bug0245.pp assigning pointers to address of consts is allowed (refused by BP !) OK 0.99.13 (PFV) - bug0246.pp const para can be changed without error OK 0.99.13 (PFV) - bug0247.pp var with initial value not supprted (Delphi var x : integer = 5;) - allowed in -Sd mode OK 0.99.11 (PM) - bug0248.pp Asm, Wrong assembler code accepted by new assembler reader OK 0.99.11 (PFV) - bug0249.pp procedure of object cannot be assigned to property. OK 0.99.11 (PFV) - bug0250.pp error with Ansistrings and loops. OK 0.99.11 (PFV) - bug0251.pp typed const are not aligned correctly OK 0.99.11 (PM) - bug0252.pp typecasting not possible within typed const OK 0.99.13 (PFV) - bug0253.pp problem with overloaded procedures and forward OK 0.99.11 (PFV) - bug0254.pp problem of endless loop if string at end of main - file without new line. OK 0.99.11 (PM) - bug0255.pp internal error 10 with in and function calls OK 0.99.12 (FK) - bug0256.pp problem with conditionnals in TP mode OK 0.99.11 (PM) - bug0257.pp problem with procvars in tp mode OK 0.99.11 (PM) - bug0258.pp bug in small const set extension to large sets OK 0.99.12 (PM) - bug0259.pp problem with optimizer for real math (use -O1) OK 0.99.12 (PM) - bug0260.pp problem with VMT generation if non virtual - method has a virtual overload OK 0.99.12 (PM) - bug0261.pp problems for assignment overloading OK 0.99.12a (PM) - bug0263.pp export directive is not necessary in delphi anymore OK 0.99.13 (PFV) - bug0264.pp methodpointer bugs OK 0.99.12b (FK) - bug0265.pp nested proc with for-counter in other lex level OK 0.99.13 (PFV) - bug0266.pp linux crt write cuts 256 char OK 0.99.13 (PFV) - bug0267.pp parameters after methodpointer are wrong OK 0.99.12b (FK) - bug0268.pp crash with exceptions OK 0.99.13 (FK) - bug0269.pp wrong linenumber for repeat until when type mismatch OK 0.99.12b (PM) - bug0270.pp unexpected eof in tp mode with (* and directives OK 0.99.13 (PFV) - bug0271.pp abstract methods can't be assigned to methodpointers OK 0.99.13 (??) - bug0272.pp No error issued if wrong parameter in function inside a second function OK 0.99.13 (PFV) - bug0273.pp small array pushing to array of char procedure is wrong OK 0.99.13 (PFV) - bug0274.pp @(proc) is not allowed OK 0.99.13 (PFV) - bug0276.pp Asm, intel reference parsing incompatibility OK 0.99.13 (PFV) - bug0277.pp typecasting with const not possible OK 0.99.13 (PFV) - bug0278.pp (* in conditional code is handled wrong for tp,delphi OK 0.99.13 (PFV) - bug0279.pp crash with ansistring and new(^ansistring) OK 0.99.13 (PFV) - bug0280.pp problem with object finalization. OK 0.99.13 (FK) - bug0282.pp long mangledname problem with -Aas OK 0.99.13 (PFV) - bug0283.pp bug in constant char comparison evaluation OK 0.99.13 (PFV) - bug0284.pp wrong file position with dup id in other unit OK 0.99.13 (PFV) - bug0285.pp Asm, TYPE not support in intel mode OK 0.99.13 (PFV) - bug0286.pp #$08d not allowed as Char constant OK 0.99.13 (PFV) - bug0287.pp (true > false) not supported OK 0.99.13 (PFV) - bug0288.pp crash with virtual method in except part OK 0.99.13 (PFV) - bug0289.pp no hint/note for unused types : implemented with -vnh OK 0.99.13 (PM) - bug0291.pp @procvar in tp mode bugs OK 0.99.13 (PFV) - bug0292.pp objects not finalized when disposed OK 0.99.13 (FK) - bug0295.pp forward type definition is resolved wrong OK 0.99.13 (PFV) - bug0296.pp exit(string) does not work (web form bug 613) OK 0.99.13 (PM) - bug0297.pp calling of interrupt procedure allowed but wrong code generated OK 0.99.13 (PM) - bug0298.pp l1+l2:=l1+l2 gives no error OK 0.99.13 (PFV) - bug0299.pp passing Array[0..1] of char by value to proc leads to problems OK 0.99.13 (PM) - bug0300.pp crash if method on non existing object is parsed (form bug 651) OK 0.99.13 (PFV) - bug0301.pp crash if destructor without object name is parsed OK 0.99.13 (PFV) - bug0302.pp inherited property generates wrong assembler OK 0.99.13 (PFV) - bug0303.pp One more InternalError(10) out of register ! OK 0.99.13 (FK) - bug0304.pp Label redefined when inlining assembler OK 0.99.13 (PFV) - bug0306.pp Address is not popped with exit in try...except block OK 0.99.13 (PFV) - bug0307.pp "with object_type" doesn't work correctly! OK 0.99.13 (?) - bug0308a.pp problem with objects that don't have VMT nor variable fields OK 0.99.13 (FK) - bug0309.pp problem with ATT assembler written by bin writer OK 0.99.14 (PFV) -bug0310.pp local and para dup are not detected OK 0.99.15 (FK) -bug0311.pp No dup id checking in variant records OK 0.99.15 (FK) - - -Unproducable bugs: ------------------- - - -Unfixed not important bugs (mostly incompatibilities): ------------------------------------------------------- -bug0111.pp blockread(typedfile,...) is not allowed in TP7 -bug0133.pp object type declaration not 100% compatibile with TP7 -bug0193.pp overflow checking for 8 and 16 bit operations wrong - overflow are just special range checks so - as all operations are done on 32 bit integers in FPC - overflow checking will only trap 32 bit overflow - you have to use range checks for byte or 16 bit integers -bug0243.pp Arguments of functions are computed from right to left this - is against pascal convention - but only BP respects this convention Delphi and GPC also - use right to left pushing !! -bug0281.pp dup id checking with property is wrong -bug0290.pp problem with storing hex numbers in integers -bug0294.pp parameter with the same name as function is allowed in tp7/delphi - Yes, but in BP this leads to being unable to set the return value ! - -Wishlist bugs: --------------- -bug0275.pp too many warnings - -Unfixed bugs: -------------- -bug0262.pp problems with virtual and overloaded methods -bug0293.pp no error with variable name = type name -bug0299.pp passing Array[0..1] of char by value to proc leads to problems -bug0305.pp Finally is not handled correctly after inputting 0 -bug0312.pp Again the problem of local procs inside methods \ No newline at end of file diff --git a/tests/dotest.pp b/tests/dotest.pp deleted file mode 100644 index 145dc1cdcb..0000000000 --- a/tests/dotest.pp +++ /dev/null @@ -1,20 +0,0 @@ -unit dotest; - - interface -{$ifdef go32v2} - uses - dpmiexcp,lineinfo; -{$endif go32v2} - - procedure do_error(l : longint); - - implementation - - procedure do_error(l : longint); - - begin - writeln('Error near: ',l); - halt(100); - end; - -end. diff --git a/tests/erroru.pp b/tests/erroru.pp deleted file mode 100644 index c9bb4c07c0..0000000000 --- a/tests/erroru.pp +++ /dev/null @@ -1,77 +0,0 @@ -unit erroru; - -interface - - procedure error; - - procedure accept_error(num : longint); - - procedure require_error(num : longint); - -implementation - -const program_has_error : boolean = false; - -procedure error; -begin - Writeln('Error in ',paramstr(0)); - program_has_error:=true; -end; - -const - store_exitproc : pointer = nil; - accepted_error_num : longint = 0; - required_error_num : longint = 0; - - -procedure accept_error(num : longint); -begin - accepted_error_num:=num; -end; - -procedure require_error(num : longint); -begin - required_error_num:=num; - accepted_error_num:=num; -end; - -procedure error_unit_exit; -begin - exitproc:=store_exitproc; - if exitcode<>0 then - begin - if (required_error_num<>0) and (exitcode<>required_error_num) then - begin - Write('Program ',paramstr(0)); - Write(' exited with error ',exitcode,' whereas error '); - Writeln(required_error_num,' was expected'); - Halt(1); - end - else if exitcode<>accepted_error_num then - begin - Write('Program ',paramstr(0)); - Write(' exited with error ',exitcode,' whereas only error '); - Writeln(accepted_error_num,' was expected'); - Halt(1); - end; - end - else if required_error_num<>0 then - begin - Write('Program ',paramstr(0)); - Write(' exited without error whereas error '); - Writeln(required_error_num,' was expected'); - Halt(1); - end; - if program_has_error then - Halt(1) - else - begin - exitcode:=0; - erroraddr:=nil; - end; -end; - -begin - store_exitproc:=exitproc; - exitproc:=@error_unit_exit; -end. diff --git a/tests/getret.pp b/tests/getret.pp deleted file mode 100644 index 5467bc83e5..0000000000 --- a/tests/getret.pp +++ /dev/null @@ -1,74 +0,0 @@ - -{ return the error code of the compiled file } -{ checks also if first line of source contains - $OPT= command line options needed } -program getret; - - uses dos; - - var com,args : string; - filename,firstline : string; - i : byte; - ppfile, retfile : text; - exefile : file; - -begin - assign(retfile,'retcode'); - rewrite(retfile); - args:=''; - if paramcount>1 then - begin - filename:=paramstr(paramcount); - if pos('.',filename)=0 then - filename:=filename+'.pp'; - assign(ppfile,filename); -{$I-} - reset(ppfile); - if ioresult=0 then - begin -{$I+} - readln(ppfile,firstline); - if pos('$OPT=',firstline)>0 then - args:=copy(Firstline,pos('=',Firstline)+1,255); - if pos('}',args)>0 then - args:=copy(args,1,pos('}',args)-1); - close(ppfile); - end; - end; - for i:=2 to paramcount do - args:=args+' '+paramstr(i); - com:=paramstr(1); -{$ifndef linux} - if pos('.',com)=0 then - com:=com+'.exe'; -{$endif not linux} - - assign(exefile,com); -{$I-} - Writeln('testing ',com); - reset(exefile,1); - if ioresult<>0 then - begin - com:=fsearch(com,getenv('PATH')); - end - else - close(exefile); -{$I+} - Writeln('Executing "',com,' ',args,'"'); - Flush(output); - swapvectors; - exec(com,args); - swapvectors; - if doserror<>0 then - write(retfile,512+doserror) - else - write(retfile,dosexitcode); - close(retfile); -{$ifdef CPU86} - { reset the FPU to avoid crashing make } -{$asmmode att} - asm - fninit - end; -{$endif CPU86} -end. \ No newline at end of file diff --git a/tests/graph.lst b/tests/graph.lst deleted file mode 100644 index b1affed1b4..0000000000 --- a/tests/graph.lst +++ /dev/null @@ -1,13 +0,0 @@ -# This file lists all the examples which need the graph unit -graphlst= \ -tbs/tbs0037.pp \ -tbs/tbs0048.pp \ -tbs/tbs0051.pp \ -tbs/tbs0052.pp \ -tbs/tbs0057.pp \ -tbs/tbs0195.pp \ -webtbs/tbug711.pp \ -webtbs/tbug816.pp - - - diff --git a/tests/readme.txt b/tests/readme.txt deleted file mode 100644 index a1f619d85d..0000000000 --- a/tests/readme.txt +++ /dev/null @@ -1,54 +0,0 @@ - TESTS directory for FPC : - - several test programs for FPC - with compilation and execution tests. - - Standard way : - 'make tests' will try to compile all the sources - will printout a list of errors - - programs that do not compile but should - - programs that do compile when they should create an error ! - - 'make allexec' will try to run all non interactive executables - 'make alltesiexec' will try to run all interactive executables - - source files are separated in different pattern : - - ts*.pp - files that should compile and run without error (if programs !) - -target 'allts' compiles all these files - ts*.log contains the output of the compiler - ts*.res contains the return code (should be zero !) - -target 'alltsexec' runs all these files - they are run non interactively without arguments - ts*.exc contains the return code should be zero - (I basically added some halt(1) if the - execution is faulty !) - ts*.elg contains the output of the program - - tf*.pp - files that should fail on compilation - target 'alltf' tries to compile all these files - tf*.res should have a non zero value !! - - to*.pp special case for optimization -(treated like ts*.pp) - - test*.pp are treated like ts*.pp -but with targets 'alltest' and 'alltestexec' - - tesi*.pp are special cases of programs that require interactive -handling (readln or keypressed ...) - these are only executed with tagert 'alltesiexec' - - Lastly : - - tbs*.pp are like ts*.pp -but are translations from the bugs directory -(i.e. tests that the bug has been removed !!) - - tbf*.pp are like tf*.pp - tis*.pp are like tesi*.pp - diff --git a/tests/tbf/tbf0008.pp b/tests/tbf/tbf0008.pp deleted file mode 100644 index af7b850af8..0000000000 --- a/tests/tbf/tbf0008.pp +++ /dev/null @@ -1,6 +0,0 @@ -const - compilerconst=1; - -begin - dec(compilerconst); -end. diff --git a/tests/tbf/tbf0010.pp b/tests/tbf/tbf0010.pp deleted file mode 100644 index bcca061be9..0000000000 --- a/tests/tbf/tbf0010.pp +++ /dev/null @@ -1,6 +0,0 @@ -program hello; - - begin - writeln('Hello); - end. - diff --git a/tests/tbf/tbf0029.pp b/tests/tbf/tbf0029.pp deleted file mode 100644 index c6d6a16d54..0000000000 --- a/tests/tbf/tbf0029.pp +++ /dev/null @@ -1,12 +0,0 @@ -type - TA = object - end; - -var - P: Pointer; - -begin - { must fail on compilation because - TA has no VMT } - P := pointer(TypeOf(TA)); -end. diff --git a/tests/tbf/tbf0036.pp b/tests/tbf/tbf0036.pp deleted file mode 100644 index bf4d7d754d..0000000000 --- a/tests/tbf/tbf0036.pp +++ /dev/null @@ -1,9 +0,0 @@ -program bug0036; - -{Discovered by Daniel Mantione.} - -var a:array[0..31] of char; - -begin - a:=' '; {Incorrect Pascal statement, but why a protection error?} -end. diff --git a/tests/tbf/tbf0049.pp b/tests/tbf/tbf0049.pp deleted file mode 100644 index 50bad33f2a..0000000000 --- a/tests/tbf/tbf0049.pp +++ /dev/null @@ -1,11 +0,0 @@ -type - days = (Mon,Tue,Wed,Thu,Fri,Sat,Sun); - weekend = Sat..Sun; - -var - w : weekend; - -begin - w:=5; - {$message the line before should produce an error } -end. diff --git a/tests/tbf/tbf0060.pp b/tests/tbf/tbf0060.pp deleted file mode 100644 index bf648bc12e..0000000000 --- a/tests/tbf/tbf0060.pp +++ /dev/null @@ -1,21 +0,0 @@ -Program Test; - -{ No errors -- problems is due to the fact that the rules for type -compatibility (p.47 language guide) -- are not respected, in other words -in case statements there is no type checking whatsoever in fpc!! - I think that these are separate cases: - 1st case) s32bit,u32bit,u8bit,s8bit,s16bit,u16bit - 2nd case) uchar - 3rd case) bool8bit -These are not /should not be compatible with each other in a case -statement imho - CEC -} - -var - myvar:char; -Begin - case myvar of - 1: ; - #2: ; - end; -end. diff --git a/tests/tbf/tbf0061.pp b/tests/tbf/tbf0061.pp deleted file mode 100644 index 1ebb7697c9..0000000000 --- a/tests/tbf/tbf0061.pp +++ /dev/null @@ -1,3 +0,0 @@ -Begin - 55ms; -end. diff --git a/tests/tbf/tbf0071.pp b/tests/tbf/tbf0071.pp deleted file mode 100644 index 5a71a1d144..0000000000 --- a/tests/tbf/tbf0071.pp +++ /dev/null @@ -1,5 +0,0 @@ -program tbf0071; - -begin - writeln (' -end. \ No newline at end of file diff --git a/tests/tbf/tbf0075.pp b/tests/tbf/tbf0075.pp deleted file mode 100644 index 9f7494e076..0000000000 --- a/tests/tbf/tbf0075.pp +++ /dev/null @@ -1,31 +0,0 @@ -Unit tbs0075; - -Interface - - -Procedure MyTest;Far; { IMPLEMENTATION expected error. } - -{ Further information: NEAR IS NOT ALLOWED IN BORLAND PASCAL } -{ Therefore the bugfix should only be for the FAR keyword. } - Procedure MySecondTest; - -Implementation - -{ near and far are not allowed here, but maybe we don't care since they are ignored by } -{ FPC. } -Procedure MyTest; -Begin -end; - -Procedure MySecondTest;Far;Forward; - - -Procedure MySecondTest;Far; -Begin -end; - - - - - -end. diff --git a/tests/tbf/tbf0085.pp b/tests/tbf/tbf0085.pp deleted file mode 100644 index 432ee2d0f2..0000000000 --- a/tests/tbf/tbf0085.pp +++ /dev/null @@ -1,3 +0,0 @@ -Begin - writeln(l); -end. diff --git a/tests/tbf/tbf0086.pp b/tests/tbf/tbf0086.pp deleted file mode 100644 index f4a5915514..0000000000 --- a/tests/tbf/tbf0086.pp +++ /dev/null @@ -1,15 +0,0 @@ - -var - v: word; - w: shortint; - z: byte; - y: integer; - -type - zz: shortint = 255; -Begin - y:=64000; - z:=32767; - w:=64000; - v:=-1; -end. diff --git a/tests/tbf/tbf0087.pp b/tests/tbf/tbf0087.pp deleted file mode 100644 index fafea37497..0000000000 --- a/tests/tbf/tbf0087.pp +++ /dev/null @@ -1,15 +0,0 @@ -{ - BP Error message is 'Pointer variable Expected' -} -type - tobj=object - l : longint; - constructor init; - end; -var - o : tobj; -begin - new(o); {This will create a internal error 9999} - new(o,init); {This will create a Segfault and Core Dump under linux} -end. - \ No newline at end of file diff --git a/tests/tbf/tbf0088.pp b/tests/tbf/tbf0088.pp deleted file mode 100644 index 194a7c08a2..0000000000 --- a/tests/tbf/tbf0088.pp +++ /dev/null @@ -1,3 +0,0 @@ -Begin - typeof(x1); { Gives out an internal error -- better then 9999 though } -end. diff --git a/tests/tbf/tbf0089.pp b/tests/tbf/tbf0089.pp deleted file mode 100644 index 3dad168655..0000000000 --- a/tests/tbf/tbf0089.pp +++ /dev/null @@ -1,3 +0,0 @@ -Begin - sizeof(x); -end. diff --git a/tests/tbf/tbf0094.pp b/tests/tbf/tbf0094.pp deleted file mode 100644 index 6457802a25..0000000000 --- a/tests/tbf/tbf0094.pp +++ /dev/null @@ -1,5 +0,0 @@ -begin - case textrec(l).mode of - 1 ; - end; -end. \ No newline at end of file diff --git a/tests/tbf/tbf0097.pp b/tests/tbf/tbf0097.pp deleted file mode 100644 index 789c524f92..0000000000 --- a/tests/tbf/tbf0097.pp +++ /dev/null @@ -1,39 +0,0 @@ -{ - This compiles fine with FPC, but not with Bp7 see 2 comments -} - -type - t=object - s : string; { No ; needed ? } - procedure p; - end; - - t2=object(t) - procedure p1(p : string); - end; - -procedure t2.p1(p : string); - - begin - end; - -procedure t.p; - -var - s : longint; { Not allowed with BP7 } - x : longint; - -procedure nested; - - var - s : longint; - - begin - end; - -begin -end; - - -begin -end. diff --git a/tests/tbf/tbf0100.pp b/tests/tbf/tbf0100.pp deleted file mode 100644 index 60c1c0a095..0000000000 --- a/tests/tbf/tbf0100.pp +++ /dev/null @@ -1,7 +0,0 @@ -unit tbs0100; -interface -uses dos; -implementation -uses dos; { Not Allowed in BP7} -end. - diff --git a/tests/tbf/tbf0101.pp b/tests/tbf/tbf0101.pp deleted file mode 100644 index d1d156c9d4..0000000000 --- a/tests/tbf/tbf0101.pp +++ /dev/null @@ -1,18 +0,0 @@ -Unit tbs0101; - -Interface - - Procedure MyProc(V: Integer); - - -Implementation - - Procedure MyProc(Y: Integer); - Begin - end; - - -end. - - - diff --git a/tests/tbf/tbf0108.pp b/tests/tbf/tbf0108.pp deleted file mode 100644 index 0ed4eec38c..0000000000 --- a/tests/tbf/tbf0108.pp +++ /dev/null @@ -1,5 +0,0 @@ -uses - dos, - ; -begin -end. \ No newline at end of file diff --git a/tests/tbf/tbf0109.pp b/tests/tbf/tbf0109.pp deleted file mode 100644 index dac689d5c7..0000000000 --- a/tests/tbf/tbf0109.pp +++ /dev/null @@ -1,9 +0,0 @@ -Type T = (aa,bb,cc,dd,ee,ff,gg,hh); - Tset = set of t; - -Var a: Tset; - -Begin - If (aa in a^) Then begin end; - {it seems that correct code is generated, but the syntax is wrong} -End. diff --git a/tests/tbf/tbf0110.pp b/tests/tbf/tbf0110.pp deleted file mode 100644 index 2cef690a03..0000000000 --- a/tests/tbf/tbf0110.pp +++ /dev/null @@ -1,9 +0,0 @@ -{ $OPT= -Fu../compiler } - -uses aasm; - -Begin - Case Pai(hp1)^.typ Of - ait_instruction: - End -End. diff --git a/tests/tbf/tbf0117.pp b/tests/tbf/tbf0117.pp deleted file mode 100644 index c75c365da2..0000000000 --- a/tests/tbf/tbf0117.pp +++ /dev/null @@ -1,21 +0,0 @@ -var - i: word; - j: integer; -Begin - i:=65530; - i:=i+1; { CF check } - i:=i-1; - i:=i*5; - i:=i/5; - i:=i shl 5; - i:=i shr 5; - Inc(i); { no check } - j:=32765; { OV check } - j:=j+1; - inc(j); - j:=j-1; - j:=j*5; - j:=j div 5; - j:=j shl 5; - j:=j shr 5; -end. \ No newline at end of file diff --git a/tests/tbf/tbf0127.pp b/tests/tbf/tbf0127.pp deleted file mode 100644 index 37cdab123e..0000000000 --- a/tests/tbf/tbf0127.pp +++ /dev/null @@ -1,17 +0,0 @@ -unit tbf0127; - - interface - - procedure x(l : longint); - - implementation - - procedure crash; - - begin - x(1234); { called with pascal calling conventions } - end; - - procedure x(l : longint);external;cdecl; - -end. diff --git a/tests/tbf/tbf0136.pp b/tests/tbf/tbf0136.pp deleted file mode 100644 index cd4d2382ab..0000000000 --- a/tests/tbf/tbf0136.pp +++ /dev/null @@ -1,9 +0,0 @@ -{ - No type declaration necessary ???? -} -procedure p(handle1,handle2); -begin -end; - -begin -end. diff --git a/tests/tbf/tbf0148.pp b/tests/tbf/tbf0148.pp deleted file mode 100644 index b4c9556ecc..0000000000 --- a/tests/tbf/tbf0148.pp +++ /dev/null @@ -1,20 +0,0 @@ -unit test; - -interface - -Function t(a: Byte): byte; -Function DoT(b: byte): Byte; - -implementation - -Function t(a: Byte): Byte; -var f: byte; -Begin - DoT := f; -End; - -Function DoT(b: byte): Byte; -Begin -End; - -end. diff --git a/tests/tbf/tbf0151.pp b/tests/tbf/tbf0151.pp deleted file mode 100644 index c8ece53d38..0000000000 --- a/tests/tbf/tbf0151.pp +++ /dev/null @@ -1,10 +0,0 @@ -type tr = record - l1, l2: longint - end; - -var r: tr; - -begin - with r do - inc(l) -end. diff --git a/tests/tbf/tbf0153.pp b/tests/tbf/tbf0153.pp deleted file mode 100644 index 87dff431be..0000000000 --- a/tests/tbf/tbf0153.pp +++ /dev/null @@ -1,17 +0,0 @@ -{$asmmode att} - -procedure asmfunc(p:pointer);assembler; -asm -{ - this is changed into movl %eax,(%ebx+8) which is not correct, and tp7 - also doesn't allow 'mov p[bx],ax' or 'mov p+bx,ax' - - Solution: for parameters and locals the index must be turned off - - Don't forget to check the intel assembler also -} - movl %eax,p(%ebx) -end; - -begin -end. diff --git a/tests/tbf/tbf0155.pp b/tests/tbf/tbf0155.pp deleted file mode 100644 index b46e41efe1..0000000000 --- a/tests/tbf/tbf0155.pp +++ /dev/null @@ -1,17 +0,0 @@ -{ this is not a real bug but rather a feature : - assembler function are only accepted for - simple return values - i.e. either in register or FPU (PM) } - -{ so for the moment this is rejected code ! } - -function asmstr:string;assembler; -asm - movl __RESULT,%edi - movl $0x4101,%al - stosw -end; - -begin - writeln(asmstr); -end; \ No newline at end of file diff --git a/tests/tbf/tbf0157.pp b/tests/tbf/tbf0157.pp deleted file mode 100644 index 11a0077afb..0000000000 --- a/tests/tbf/tbf0157.pp +++ /dev/null @@ -1,17 +0,0 @@ -{ this should be rejected because we only accept integer args } - -program write_it; -var x,y:real; - i : longint; - s : string; -begin -x:=5.6; -y:=45.789; -write(y:2:3,' ',x:3:4); -write(i:5); -s:='short'; -write(s:11); -write(i:5:2); -write(s:25:3); -write(x:5.2); -end. diff --git a/tests/tbf/tbf0158.pp b/tests/tbf/tbf0158.pp deleted file mode 100644 index e1cb21c71a..0000000000 --- a/tests/tbf/tbf0158.pp +++ /dev/null @@ -1,8 +0,0 @@ -program tmp; - -var - Molo :Boolean; - -begin - Molo := 1; { This should give out a Type mismatch error ! } -end. diff --git a/tests/tbf/tbf0161.pp b/tests/tbf/tbf0161.pp deleted file mode 100644 index 4dc7cb8319..0000000000 --- a/tests/tbf/tbf0161.pp +++ /dev/null @@ -1,11 +0,0 @@ -Program tbs0161; - -{the following program should give a syntax error, but causes an internal error} - -const s = [1,2,3,4,5]; - -var b: Byte; - -Begin - If b in [s] then; -End. diff --git a/tests/tbf/tbf0164.pp b/tests/tbf/tbf0164.pp deleted file mode 100644 index 0dcee6ad4d..0000000000 --- a/tests/tbf/tbf0164.pp +++ /dev/null @@ -1,14 +0,0 @@ -type t1r = record - a, b: Byte; - end; - t2r = record - l1, l2: Array[1..4] Of t1r; - end; - - -Var r: t2r; - -begin - with r.l1[counter] Do - Inc(a) -end. diff --git a/tests/tbf/tbf0166.pp b/tests/tbf/tbf0166.pp deleted file mode 100644 index 2f47de2b42..0000000000 --- a/tests/tbf/tbf0166.pp +++ /dev/null @@ -1,10 +0,0 @@ -type - punknown=^unknown; - - t=object - procedure p(i:unknown); - end; - -begin -end. - \ No newline at end of file diff --git a/tests/tbf/tbf0167.pp b/tests/tbf/tbf0167.pp deleted file mode 100644 index 0a9ed84ea1..0000000000 --- a/tests/tbf/tbf0167.pp +++ /dev/null @@ -1,9 +0,0 @@ -type ObjTest = Object - End; - -Procedure ObjTest; -Begin -end; - -Begin -end. diff --git a/tests/tbf/tbf0168.pp b/tests/tbf/tbf0168.pp deleted file mode 100644 index bb8c11fbcd..0000000000 --- a/tests/tbf/tbf0168.pp +++ /dev/null @@ -1,6 +0,0 @@ -var bset: set of 0..31; - b: byte; - -Begin - bset := bset + b; -End. diff --git a/tests/tbf/tbf0172.pp b/tests/tbf/tbf0172.pp deleted file mode 100644 index 24e6eac573..0000000000 --- a/tests/tbf/tbf0172.pp +++ /dev/null @@ -1,11 +0,0 @@ -type - rec=record - a : longint; - end; - -var - r1 : rec absolute $40:$49; -begin - with r1 do - a:=1; -end. diff --git a/tests/tbf/tbf0173.pp b/tests/tbf/tbf0173.pp deleted file mode 100644 index ac4fb2a3e4..0000000000 --- a/tests/tbf/tbf0173.pp +++ /dev/null @@ -1,9 +0,0 @@ -var - secondbug : word; -procedure p;assembler; -begin - if secondbug=0 then; -end; - -begin -end. \ No newline at end of file diff --git a/tests/tbf/tbf0175.pp b/tests/tbf/tbf0175.pp deleted file mode 100644 index 691d672b87..0000000000 --- a/tests/tbf/tbf0175.pp +++ /dev/null @@ -1,10 +0,0 @@ -{ this will just give out an error } -{$asmmode att} -{$R+} -var - w : word; -begin - asm - movl w,%ecx - end; -end. \ No newline at end of file diff --git a/tests/tbf/tbf0186.pp b/tests/tbf/tbf0186.pp deleted file mode 100644 index 29332b7861..0000000000 --- a/tests/tbf/tbf0186.pp +++ /dev/null @@ -1,9 +0,0 @@ - program bug0186; - var - endline:^integer; - line:array [1..endline^] of ^char; - begin - new (endline); - endline^:=5; - endline^:=10; - end. diff --git a/tests/tbf/tbf0196.pp b/tests/tbf/tbf0196.pp deleted file mode 100644 index c9f90a62c1..0000000000 --- a/tests/tbf/tbf0196.pp +++ /dev/null @@ -1,9 +0,0 @@ -Program bug0195; - -function a; -begin -end; - -begin - a -end. diff --git a/tests/tbf/tbf0197.pp b/tests/tbf/tbf0197.pp deleted file mode 100644 index c05c8daa43..0000000000 --- a/tests/tbf/tbf0197.pp +++ /dev/null @@ -1,13 +0,0 @@ - -var i : DWord; - c1, c2 : comp; - -begin - c1 := 20000; c2 := 100; - i := 0; - repeat - inc(i); - c1 := (abs(3*c1)-c2) < c2; { notice this !!! :) :) } - until (i > 1000); - Writeln(c1); -end. \ No newline at end of file diff --git a/tests/tbf/tbf0205.pp b/tests/tbf/tbf0205.pp deleted file mode 100644 index 739bd51cca..0000000000 --- a/tests/tbf/tbf0205.pp +++ /dev/null @@ -1,31 +0,0 @@ -program bug_show; -{ By PAV (pavsoft@usa.net) } - -function bad_uppercase(s:string):string; -var i:integer; -begin - for i:=1 to length(s) do - if (ord(s[i])>=97 and ord(s[i])<=122) then s[i]:=chr(ord(s[i])-97+65); - bad_uppercase:=s; -end; - -function good_uppercase(s:string):string; -var i:integer; -begin - for i:=1 to length(s) do - if (ord(s[i])>=97) and (ord(s[i])<=122) then s[i]:=chr(ord(s[i])-97+65); - good_uppercase:=s; -end; - -const cadena='Free Paskal Compiler 0.99.8 !!! (bug)'; -begin - writeln('This is the original string before convert it'); - writeln(cadena); - writeln(); - writeln('This is a bad result, using "if ( and )"'); - writeln(bad_uppercase(cadena)); - writeln(); - writeln('This is a good result, using "if () and ()"'); - writeln(good_uppercase(cadena)); - writeln(); -end. diff --git a/tests/tbf/tbf0208.pp b/tests/tbf/tbf0208.pp deleted file mode 100644 index e115414944..0000000000 --- a/tests/tbf/tbf0208.pp +++ /dev/null @@ -1,11 +0,0 @@ -program tbf0208; - -{ implicit boolean to integer conversion should not be - allowed } -var - b : boolean; - i : longint; -begin - b:=true; - i:=b; -end. \ No newline at end of file diff --git a/tests/tbf/tbf0219.pp b/tests/tbf/tbf0219.pp deleted file mode 100644 index d04a6d1ba2..0000000000 --- a/tests/tbf/tbf0219.pp +++ /dev/null @@ -1,13 +0,0 @@ -{ Should give '(' expected in line 6 } - - const - replaces=4; - replacetab : array[1..replaces,1..2] of string[32]=( - ':',' or colon', - 'mem8','mem or bits8', - 'mem16','mem or bits16', - 'mem32','mem or bits32' - ) -begin -end. - diff --git a/tests/tbf/tbf0230.pp b/tests/tbf/tbf0230.pp deleted file mode 100644 index 5a79b62636..0000000000 --- a/tests/tbf/tbf0230.pp +++ /dev/null @@ -1,14 +0,0 @@ -{$ifdef go32v2} -uses - dpmiexcp; -{$endif} - -var - e : extended; - -begin - e:=-1.0; - writeln(ln(0)); - writeln(power(0,1.0)); - writeln(ln(e)); -end . diff --git a/tests/tbf/tbf0231.pp b/tests/tbf/tbf0231.pp deleted file mode 100644 index 25e903d461..0000000000 --- a/tests/tbf/tbf0231.pp +++ /dev/null @@ -1,17 +0,0 @@ - -{$undef dummy} - -{$ifdef DUMMY} - (* <= this should not be considered as a - higher comment level !! - - test -{$endif dummy} - -var - e : extended; - -begin - e:=1.0; - writeln(ln(e)); -end. diff --git a/tests/tbf/tbf0234.pp b/tests/tbf/tbf0234.pp deleted file mode 100644 index 9dedcc2442..0000000000 --- a/tests/tbf/tbf0234.pp +++ /dev/null @@ -1,8 +0,0 @@ -program bug0232; - -var p:pointer; - -begin - new(p); - dispose(p); -end. diff --git a/tests/tbf/tbf0242.pp b/tests/tbf/tbf0242.pp deleted file mode 100644 index 6cc4d04fbf..0000000000 --- a/tests/tbf/tbf0242.pp +++ /dev/null @@ -1,11 +0,0 @@ -procedure p; -begin -end; - -procedure p1(var x); -begin -end; - -begin - p1(p); -end. \ No newline at end of file diff --git a/tests/tbf/tbf0245.pp b/tests/tbf/tbf0245.pp deleted file mode 100644 index 52c061656e..0000000000 --- a/tests/tbf/tbf0245.pp +++ /dev/null @@ -1,26 +0,0 @@ -const - r = 3.5; - s = 'test idiot'; -type - preal = ^real; - pstring = ^string; - - procedure ss; - begin - end; - -var - p : pointer; - pr : preal; - ps : pstring; - - begin - p:=@ss; - p:=@s; - pr:=@r; - ps:=@s; - pr^:=7.8; - ps^:='test3'; - Writeln('r=',r,' s=',s); - end. - diff --git a/tests/tbf/tbf0246.pp b/tests/tbf/tbf0246.pp deleted file mode 100644 index 2e0ef204ff..0000000000 --- a/tests/tbf/tbf0246.pp +++ /dev/null @@ -1,13 +0,0 @@ -type - tref=record - ofs : longint; - end; - -procedure p(const ref:tref); -begin - with ref do - ofs:=ofs+1; { This should issue an error, because ref is const ! } -end; - -begin -end. \ No newline at end of file diff --git a/tests/tbf/tbf0248.pp b/tests/tbf/tbf0248.pp deleted file mode 100644 index 7f69d43023..0000000000 --- a/tests/tbf/tbf0248.pp +++ /dev/null @@ -1,8 +0,0 @@ -{$asmmode att} - -begin - asm - call *%eax // this is correct - movl %esi,*%eax - end; -end. diff --git a/tests/tbf/tbf0265.pp b/tests/tbf/tbf0265.pp deleted file mode 100644 index 43ffa95c46..0000000000 --- a/tests/tbf/tbf0265.pp +++ /dev/null @@ -1,21 +0,0 @@ -PROGRAM t9; - -PROCEDURE Eeep; -VAR - X: BYTE; - NewNG: STRING; -PROCEDURE SubProc; - BEGIN - newng := 'alt'; - FOR X := 1 TO LENGTH(NewNG) DO BEGIN - WRITELN(X); - END; -END; -BEGIN - SubProc; -END; - -BEGIN - Eeep; -END. - diff --git a/tests/tbf/tbf0269.pp b/tests/tbf/tbf0269.pp deleted file mode 100644 index 9addc08be9..0000000000 --- a/tests/tbf/tbf0269.pp +++ /dev/null @@ -1,8 +0,0 @@ -{ No idea how I could test this !! PM } -{ we should parse the compiler output !! } -{ Wrong line number for error message } -begin - repeat - writeln('test'); - until sptr; -end. diff --git a/tests/tbf/tbf0272.pp b/tests/tbf/tbf0272.pp deleted file mode 100644 index 36ec3a331e..0000000000 --- a/tests/tbf/tbf0272.pp +++ /dev/null @@ -1,36 +0,0 @@ -program test_const_string; - -const - conststring = 'Constant string'; - -function astring(s :string) : string; - -begin - astring:='Test string'+s; -end; - -procedure testvar(var s : string); -begin - writeln('testvar s is "',s,'"'); -end; - -procedure testconst(const s : string); -begin - writeln('testconst s is "',s,'"'); -end; - -procedure testvalue(s : string); -begin - writeln('testvalue s is "',s,'"'); -end; - -const - s : string = 'test'; - -begin - testvalue(astring('e')); - testconst(astring(s)); - testconst(conststring); - testvar(conststring);{ refused a compile time } -end. - diff --git a/tests/tbf/tbf0281.pp b/tests/tbf/tbf0281.pp deleted file mode 100644 index 00ba1d50c9..0000000000 --- a/tests/tbf/tbf0281.pp +++ /dev/null @@ -1,19 +0,0 @@ -{$mode objfpc} - -type - test_one = class - protected - fTest : String; - public - property Test: String READ fTest WRITE fTest; - procedure Testen(Test: BOolean); - { ^ duplicate identifier? } - end; - - -procedure test_one.testen(test: boolean); -begin -end; - -begin -end. diff --git a/tests/tbf/tbf0284.pp b/tests/tbf/tbf0284.pp deleted file mode 100644 index a831db2591..0000000000 --- a/tests/tbf/tbf0284.pp +++ /dev/null @@ -1,9 +0,0 @@ -uses tbs0284b; -{$HINTS ON} -type - o2=object(o1) - p : longint; - end; - -begin -end. diff --git a/tests/tbf/tbf0298.pp b/tests/tbf/tbf0298.pp deleted file mode 100644 index 1728e4be0e..0000000000 --- a/tests/tbf/tbf0298.pp +++ /dev/null @@ -1,11 +0,0 @@ -program test_loc_mem; - -{$ifdef go32v2} - uses - dpmiexcp; -{$endif go32v2} - -var l1,l2 : longint; -begin - l1+l2:=l1+l2; -end. diff --git a/tests/tbf/tbf0300.pp b/tests/tbf/tbf0300.pp deleted file mode 100644 index f7fadebb6d..0000000000 --- a/tests/tbf/tbf0300.pp +++ /dev/null @@ -1,4 +0,0 @@ - procedure nonexistent_class_or_object.method; begin end; -begin -end. - diff --git a/tests/tbf/tbf0301.pp b/tests/tbf/tbf0301.pp deleted file mode 100644 index 6aa19996b7..0000000000 --- a/tests/tbf/tbf0301.pp +++ /dev/null @@ -1,8 +0,0 @@ -Program bug0301; - -destructor done; -begin -end; - -begin -end. \ No newline at end of file diff --git a/tests/tbf/tbf0310.pp b/tests/tbf/tbf0310.pp deleted file mode 100644 index 02fe780e12..0000000000 --- a/tests/tbf/tbf0310.pp +++ /dev/null @@ -1,10 +0,0 @@ -procedure p(s:string); -var - s : string; -begin - writeln(s); -end; - -begin - p('test'); -end. \ No newline at end of file diff --git a/tests/tbf/tbf0311.pp b/tests/tbf/tbf0311.pp deleted file mode 100644 index 38cd04de04..0000000000 --- a/tests/tbf/tbf0311.pp +++ /dev/null @@ -1,11 +0,0 @@ -type - tsplitextended = record - case byte of - 0: (a: array[0..9] of byte); - { the following "a" should give a duplicate identifier error } - 1: (a: array[0..4] of word); - 2: (a: array[0..1] of cardinal; w: word); - end; - -begin -end. diff --git a/tests/tbf/tbf0314.pp b/tests/tbf/tbf0314.pp deleted file mode 100644 index c3bcbae2e5..0000000000 --- a/tests/tbf/tbf0314.pp +++ /dev/null @@ -1,9 +0,0 @@ -procedure p(var b); -begin -end; - -var - s : string; -begin - p(@s[1]); -end. diff --git a/tests/tbf/tbf0315.pp b/tests/tbf/tbf0315.pp deleted file mode 100644 index 51083fc8f4..0000000000 --- a/tests/tbf/tbf0315.pp +++ /dev/null @@ -1,5 +0,0 @@ -begin -asm - movl $%1000, %eax -end; -end. diff --git a/tests/tbf/tbf0320.pp b/tests/tbf/tbf0320.pp deleted file mode 100644 index cb05ddf6eb..0000000000 --- a/tests/tbf/tbf0320.pp +++ /dev/null @@ -1,27 +0,0 @@ -{$ifdef fpc}{$mode delphi}{$endif} - -{ These should give an error, as also done in tp,delphi. - See tbs0319.pp for a test with class which should compile in - delphi mode } - -type - cl=object - k : longint; - procedure p1; - procedure p2; - end; - -procedure cl.p1; -var - k : longint; -begin -end; - -procedure cl.p2; -var - p1 : longint; -begin -end; - -begin -end. diff --git a/tests/tbf/tbf0323.pp b/tests/tbf/tbf0323.pp deleted file mode 100644 index b47d089147..0000000000 --- a/tests/tbf/tbf0323.pp +++ /dev/null @@ -1,6 +0,0 @@ -{$ifdef fpc}{$mode delphi}{$endif} -type - TA = (aOne := 1, aTwo, aThree, aFour, aSix); - -begin -end. diff --git a/tests/tbf/tbf0324.pp b/tests/tbf/tbf0324.pp deleted file mode 100644 index 8d37920d84..0000000000 --- a/tests/tbf/tbf0324.pp +++ /dev/null @@ -1,10 +0,0 @@ -{$ifdef fpc}{$mode delphi}{$endif} - -function k2:longint; -var - result : word; -begin -end; - -begin -end. \ No newline at end of file diff --git a/tests/tbf/tbf0325.pp b/tests/tbf/tbf0325.pp deleted file mode 100644 index 45504456e6..0000000000 --- a/tests/tbf/tbf0325.pp +++ /dev/null @@ -1,14 +0,0 @@ -{$ifdef fpc}{$mode delphi}{$endif} - -function k2(result:word):longint; -begin -end; - -function k3(l:word):longint; -var - result : word; -begin -end; - -begin -end. \ No newline at end of file diff --git a/tests/tbf/tbf0326.pp b/tests/tbf/tbf0326.pp deleted file mode 100644 index 8524cdc2be..0000000000 --- a/tests/tbf/tbf0326.pp +++ /dev/null @@ -1,6 +0,0 @@ -{$mode delphi} -const - anyconst = %11111; - -begin -end. diff --git a/tests/tbf/tbf0328.pp b/tests/tbf/tbf0328.pp deleted file mode 100644 index 9d5afae5e2..0000000000 --- a/tests/tbf/tbf0328.pp +++ /dev/null @@ -1,21 +0,0 @@ -{$ifdef fpc}{$mode delphi}{$endif} - -procedure k1(l:longint); -begin -end; - -procedure k1(l:string);overload; -begin -end; - -procedure k2(l:longint);overload; -begin -end; - -procedure k2(l:string); -begin -end; - - -begin -end. diff --git a/tests/tbf/tbf0342.pp b/tests/tbf/tbf0342.pp deleted file mode 100644 index dbf2bc9677..0000000000 --- a/tests/tbf/tbf0342.pp +++ /dev/null @@ -1,5 +0,0 @@ -type - WORD=word; - -begin -end. diff --git a/tests/tbf/tbf0343.pp b/tests/tbf/tbf0343.pp deleted file mode 100644 index a2b195dc0e..0000000000 --- a/tests/tbf/tbf0343.pp +++ /dev/null @@ -1,9 +0,0 @@ -{$mode delphi} -type - TListEntry = record - Next: ^TListEntry; (*<-- Error message here*) - Data: Integer; - end; - -begin -end. diff --git a/tests/tbf/tbf0345.pp b/tests/tbf/tbf0345.pp deleted file mode 100644 index 01fc0c6d72..0000000000 --- a/tests/tbf/tbf0345.pp +++ /dev/null @@ -1,5 +0,0 @@ -var - WORD : array[1..2] of word; - -begin -end. diff --git a/tests/tbf/tbf0347.pp b/tests/tbf/tbf0347.pp deleted file mode 100644 index 99ac642674..0000000000 --- a/tests/tbf/tbf0347.pp +++ /dev/null @@ -1,9 +0,0 @@ -{$mode delphi} - -type x = ^longint; - -var y:x; - -begin - y [5]:=5; -end. diff --git a/tests/tbf/tbf0349.pp b/tests/tbf/tbf0349.pp deleted file mode 100644 index b38c2a70de..0000000000 --- a/tests/tbf/tbf0349.pp +++ /dev/null @@ -1,14 +0,0 @@ -{$mode delphi} - -type - TCl=class; - -const - b=1; - -type - TCL=class - end; - -begin -end. diff --git a/tests/tbf/tbf0351.pp b/tests/tbf/tbf0351.pp deleted file mode 100644 index 904d78071c..0000000000 --- a/tests/tbf/tbf0351.pp +++ /dev/null @@ -1,10 +0,0 @@ -{ $OPT=-Sew } - -{$MACRO OFF} - -{ The next line should give a Warning that macro support not has - been turned on } -{$define mac1 := writeln('test')} - -begin -end. diff --git a/tests/tbf/tbf0352.pp b/tests/tbf/tbf0352.pp deleted file mode 100644 index 64e4b8e525..0000000000 --- a/tests/tbf/tbf0352.pp +++ /dev/null @@ -1,15 +0,0 @@ -{$ifdef fpc}{$MODE OBJFPC}{$endif} - -Procedure Proc1(args:array of const); -begin -end; - -Procedure Proc2(args:array of longint); -Begin - { this should give an error } - Proc1(args); -End; - -Begin - Proc1([0,1]); -End. diff --git a/tests/tbf/tbf0353.pp b/tests/tbf/tbf0353.pp deleted file mode 100644 index 827568068a..0000000000 --- a/tests/tbf/tbf0353.pp +++ /dev/null @@ -1,9 +0,0 @@ -{ $version >= 1.1} -type - ti = interface - private - procedure p; - end; - -begin -end. diff --git a/tests/tbf/tbf0354.pp b/tests/tbf/tbf0354.pp deleted file mode 100644 index 5214eb9d6a..0000000000 --- a/tests/tbf/tbf0354.pp +++ /dev/null @@ -1,8 +0,0 @@ -{ $version >= 1.1} -type - ti = interface - constructor create; - end; - -begin -end. diff --git a/tests/tbf/tbf0355.pp b/tests/tbf/tbf0355.pp deleted file mode 100644 index 50a9117763..0000000000 --- a/tests/tbf/tbf0355.pp +++ /dev/null @@ -1,8 +0,0 @@ -{ $version >= 1.1} -type - ti = interface - destructor destroy; - end; - -begin -end. diff --git a/tests/tbf/tbf0356.pp b/tests/tbf/tbf0356.pp deleted file mode 100644 index 0a6122ff71..0000000000 --- a/tests/tbf/tbf0356.pp +++ /dev/null @@ -1,8 +0,0 @@ -{ $version >= 1.1} -type - ti = interface - l : longint; - end; - -begin -end. diff --git a/tests/tbf/tbf0357.pp b/tests/tbf/tbf0357.pp deleted file mode 100644 index 250a0d28af..0000000000 --- a/tests/tbf/tbf0357.pp +++ /dev/null @@ -1,9 +0,0 @@ -{ $version >= 1.1} -type - ti = interface - protected - procedure p; - end; - -begin -end. diff --git a/tests/tbf/tbf0358.pp b/tests/tbf/tbf0358.pp deleted file mode 100644 index 57be5e4144..0000000000 --- a/tests/tbf/tbf0358.pp +++ /dev/null @@ -1,9 +0,0 @@ -{ $version >= 1.1} -type - ti = interface - public - procedure p; - end; - -begin -end. diff --git a/tests/tbf/tbf0359.pp b/tests/tbf/tbf0359.pp deleted file mode 100644 index 7dcb50c3b3..0000000000 --- a/tests/tbf/tbf0359.pp +++ /dev/null @@ -1,9 +0,0 @@ -{ $version >= 1.1} -type - ti = interface - published - procedure p; - end; - -begin -end. diff --git a/tests/tbf/tbf0360.pp b/tests/tbf/tbf0360.pp deleted file mode 100644 index 32985f1c04..0000000000 --- a/tests/tbf/tbf0360.pp +++ /dev/null @@ -1,23 +0,0 @@ -{$mode objfpc} -type - to1 = class - procedure p;virtual; - end; - - to2 = class(to1) - function p : longint;override; - end; - - procedure to1.p; - - begin - end; - - function to2.p : longint; - - begin - end; - -begin -end. - diff --git a/tests/tbf/tbff001.pp b/tests/tbf/tbff001.pp deleted file mode 100644 index 33b4b7a2c5..0000000000 --- a/tests/tbf/tbff001.pp +++ /dev/null @@ -1,15 +0,0 @@ -procedure myproc; -var - a: word; - a: word; - a: word; - a: word; - a: word; -begin - a := 1; - writeln (a); -end; - -begin - myproc; -end. diff --git a/tests/tbf/tbff002.pp b/tests/tbf/tbff002.pp deleted file mode 100644 index 21c30cfdc2..0000000000 --- a/tests/tbf/tbff002.pp +++ /dev/null @@ -1,31 +0,0 @@ -type - - ExecProc = Procedure; - -type - MenuItem = record - Caption: String[32]; - Exec: ExecProc; - end; - -Procedure AddItem(ACaption: String; AExec: ExecProc; var Item: MenuItem); -begin - Item.Caption:=ACaption; - Item.Exec:=AExec; -end; - -Procedure ExecFirstItem; -begin - Writeln('Result of "Item 1"'); -end; - -var M1,M2,M3: MenuItem; - Ep: ExecProc; - -begin - AddItem('Item 1',Nil,M1); - Ep:=ExecFirstItem; // should give error in fpc mode - AddItem('Item 2',Ep,M2); - AddItem('Item 3',@ExecFirstItem,M3); -end. - diff --git a/tests/tbs/tbs0001.pp b/tests/tbs/tbs0001.pp deleted file mode 100644 index 5cb86787e9..0000000000 --- a/tests/tbs/tbs0001.pp +++ /dev/null @@ -1,9 +0,0 @@ -program smalltest; - const - teststr : string = ' '#9#255#0; -begin - writeln(teststr); - teststr := 'gaga'; - writeln(teststr); - if teststr<>'gaga' then halt(1); -end. diff --git a/tests/tbs/tbs0002.pp b/tests/tbs/tbs0002.pp deleted file mode 100644 index 8c7728dbd3..0000000000 --- a/tests/tbs/tbs0002.pp +++ /dev/null @@ -1,83 +0,0 @@ -unit tbs0002; - - interface - - implementation - -{$message starting hexstr} - function hexstr(val : longint;cnt : byte) : string; - - const - hexval : string[16]=('0123456789ABCDEF'); - - var - s : string; - l2,i : integer; - l1 : longInt; - - begin - s[0]:=char(cnt); - l1:=longint($f) shl (4*(cnt-1)); - for i:=1 to cnt do - begin - l2:=(val and l1) shr (4*(cnt-i)); - l1:=l1 shr 4; - s[i]:=hexval[l2+1]; - end; - hexstr:=s; - end; - -{$message starting dump_stack} - - procedure dump_stack(bp : longint); - -{$message starting get_next_frame} - - function get_next_frame(bp : longint) : longint; - - begin - asm - movl bp,%eax - movl (%eax),%eax - movl %eax,__RESULT - end ['EAX']; - end; - - procedure dump_frame(addr : longint); - - begin - { to be used by symify } - writeln(' 0x',HexStr(addr,8)); - end; - -{$message starting get_addr} - - function get_addr(BP : longint) : longint; - - begin - asm - movl BP,%eax - movl 4(%eax),%eax - movl %eax,__RESULT - end ['EAX']; - end; - -{$message starting main} - - var - i,prevbp : longint; - - begin - prevbp:=bp-1; - i:=0; - while bp > prevbp do - begin - dump_frame(get_addr(bp)); - i:=i+1; - if i>max_frame_dump then exit; - prevbp:=bp; - bp:=get_next_frame(bp); - end; - end; - -end. diff --git a/tests/tbs/tbs0003.pp b/tests/tbs/tbs0003.pp deleted file mode 100644 index 832b65d393..0000000000 --- a/tests/tbs/tbs0003.pp +++ /dev/null @@ -1,18 +0,0 @@ -unit tbs0003; - - interface - - implementation - - - procedure dump_stack(bp : longint); - - function get_next_frame(bp : longint) : longint; - - begin - end; - - begin - end; - -end. diff --git a/tests/tbs/tbs0004.pp b/tests/tbs/tbs0004.pp deleted file mode 100644 index 4204d7c8f9..0000000000 --- a/tests/tbs/tbs0004.pp +++ /dev/null @@ -1,13 +0,0 @@ -var - i : longint; - -begin - for i:=1 to 100 do - begin - writeln('Hello'); - continue; - writeln('ohh'); - Halt(1); - end; -end. - diff --git a/tests/tbs/tbs0005.pp b/tests/tbs/tbs0005.pp deleted file mode 100644 index 2d6922a834..0000000000 --- a/tests/tbs/tbs0005.pp +++ /dev/null @@ -1,13 +0,0 @@ -uses - erroru; - -begin - if 1=1 then - begin - Writeln('OK'); - end; - if 1<>1 then - begin - Error; - end; -end. diff --git a/tests/tbs/tbs0006.pp b/tests/tbs/tbs0006.pp deleted file mode 100644 index 2c7049f8b8..0000000000 --- a/tests/tbs/tbs0006.pp +++ /dev/null @@ -1,18 +0,0 @@ -uses - erroru; -var - a,b,c,d,e,f,g,r : double; - -begin - a:=10.0; - b:=11.0; - c:=13.0; - d:=17.0; - e:=19.0; - f:=23.0; - r:=2.0; - a:= a - 2*b*e - 2*c*f - 2*d*g - Sqr(r); - writeln(a,' (must be -1010)'); - if a<>-1010.0 then - Error; -end. diff --git a/tests/tbs/tbs0007.pp b/tests/tbs/tbs0007.pp deleted file mode 100644 index 78f2f01538..0000000000 --- a/tests/tbs/tbs0007.pp +++ /dev/null @@ -1,17 +0,0 @@ -uses - erroru; - -var - count : byte; - test : longint; -begin - test:=0; - for count:=1 to 127 do - begin - inc(test); - writeln(count,'. loop'); - if test>127 then - Error; - end; -end. - diff --git a/tests/tbs/tbs0009.pp b/tests/tbs/tbs0009.pp deleted file mode 100644 index 85c4f65994..0000000000 --- a/tests/tbs/tbs0009.pp +++ /dev/null @@ -1,27 +0,0 @@ -var c:byte; - - Procedure a(b:boolean); - - begin - if b then writeln('TRUE') else writeln('FALSE'); - end; - - function Test_a(b:boolean) : string; - - begin - if b then Test_a:='TRUE' else Test_a:='FALSE'; - end; - - begin {main program} - a(true); {works} - if Test_a(true)<>'TRUE' then halt(1); - a(false); {works} - if Test_a(false)<>'FALSE' then halt(1); - c:=0; - a(c>0); {doesn't work} - if Test_a(c>0)<>'FALSE' then halt(1); - a(c<0); {doesn't work} - if Test_a(c<0)<>'FALSE' then halt(1); - a(c=0); - if Test_a(c=0)<>'TRUE' then halt(1); - end. diff --git a/tests/tbs/tbs0011.pp b/tests/tbs/tbs0011.pp deleted file mode 100644 index ea2968b472..0000000000 --- a/tests/tbs/tbs0011.pp +++ /dev/null @@ -1,14 +0,0 @@ -{$message don't know how to make a test from bug0011 (PM)} -var - vga : array[0..320*200-1] of byte; - -procedure test(x,y : longint); - - begin - vga[x+y mod 320]:=random(256); - vga[x+y mod 320]:=random(256); - end; - -begin -end. - diff --git a/tests/tbs/tbs0012.pp b/tests/tbs/tbs0012.pp deleted file mode 100644 index 58b0bd9c76..0000000000 --- a/tests/tbs/tbs0012.pp +++ /dev/null @@ -1,13 +0,0 @@ -var - a,b : longint; - -begin - a:=1; - b:=2; - if byte(a>b)=byte(a1210.0 then halt(1); -end. diff --git a/tests/tbs/tbs0016.pp b/tests/tbs/tbs0016.pp deleted file mode 100644 index 148ef70082..0000000000 --- a/tests/tbs/tbs0016.pp +++ /dev/null @@ -1,193 +0,0 @@ - uses - crt; - - const - { ... parameters } - w = 10; { max. 10 } - h = 10; { max. 10 } - - type - tp = array[0..w,0..h] of double; - - var - temp : tp; - phi : tp; - Bi : tp; - - boundary : array[0..w,0..h] of double; - - function start_temp(i,j : longint) : double; - - begin - start_temp:=(boundary[i,0]*(h-j)+boundary[i,h]*j+boundary[0,j]*(w-i)+boundary[w,j]*i)/(w+h); - end; - - procedure init; - - var - i,j : longint; - - begin - for i:=0 to w do - for j:=0 to h do - temp[i,j]:=start_temp(i,j); - end; - - procedure draw; - - var - i,j : longint; - - begin - for i:=0 to w do - for j:=0 to h do - begin - textcolor(white); - gotoxy(i*7+1,j*2+1); - writeln(temp[i,j]:6:0); - textcolor(darkgray); - gotoxy(i*7+1,j*2+2); - writeln(phi[i,j]:6:3); - end; - end; - - procedure calc_phi; - - var - i,j : longint; - - begin - for i:=0 to w do - for j:=0 to h do - begin - if (i=0) and (j=0) then - begin - phi[i,j]:=Bi[i,j]*boundary[i,j]+0.5*temp[i,j+1]+0.5*temp[i+1,j]-(1+Bi[i,j])*temp[i,j]; - end - else if (i=0) and (j=h) then - begin - phi[i,j]:=Bi[i,j]*boundary[i,j]+0.5*temp[i,j-1]+0.5*temp[i+1,j]-(1+Bi[i,j])*temp[i,j]; - end - else if (i=w) and (j=0) then - begin - phi[i,j]:=Bi[i,j]*boundary[i,j]+0.5*temp[i,j+1]+0.5*temp[i-1,j]-(1+Bi[i,j])*temp[i,j]; - end - else if (i=w) and (j=h) then - begin - phi[i,j]:=Bi[i,j]*boundary[i,j]+0.5*temp[i,j-1]+0.5*temp[i-1,j]-(1+Bi[i,j])*temp[i,j]; - end - else if i=0 then - begin - phi[i,j]:=Bi[i,j]*boundary[i,j]+temp[i+1,j]+0.5*temp[i,j-1]+0.5*temp[i,j+1]-(2+Bi[i,j])*temp[i,j]; - end - else if i=w then - begin - phi[i,j]:=Bi[i,j]*boundary[i,j]+temp[i-1,j]+0.5*temp[i,j-1]+0.5*temp[i,j+1]-(2+Bi[i,j])*temp[i,j]; - end - else if j=0 then - begin - phi[i,j]:=Bi[i,j]*boundary[i,j]+temp[i,j+1]+0.5*temp[i-1,j]+0.5*temp[i+1,j]-(2+Bi[i,j])*temp[i,j]; - end - else if j=h then - begin - phi[i,j]:=Bi[i,j]*boundary[i,j]+temp[i,j-1]+0.5*temp[i-1,j]+0.5*temp[i+1,j]-(2+Bi[i,j])*temp[i,j]; - end - else - phi[i,j]:=temp[i,j-1]+temp[i-1,j]-4*temp[i,j]+temp[i+1,j]+temp[i,j+1]; - end; - end; - - procedure adapt(i,j : longint); - - begin - if (i=0) and (j=0) then - begin - temp[i,j]:=(Bi[i,j]*boundary[i,j]+0.5*temp[i,j+1]+0.5*temp[i+1,j])/(1+Bi[i,j]); - end - else if (i=0) and (j=h) then - begin - temp[i,j]:=(Bi[i,j]*boundary[i,j]+0.5*temp[i,j-1]+0.5*temp[i+1,j])/(1+Bi[i,j]); - end - else if (i=w) and (j=0) then - begin - temp[i,j]:=(Bi[i,j]*boundary[i,j]+0.5*temp[i,j+1]+0.5*temp[i-1,j])/(1+Bi[i,j]); - end - else if (i=w) and (j=h) then - begin - temp[i,j]:=(Bi[i,j]*boundary[i,j]+0.5*temp[i,j-1]+0.5*temp[i-1,j])/(1+Bi[i,j]); - end - else if i=0 then - begin - temp[i,j]:=(Bi[i,j]*boundary[i,j]+temp[i+1,j]+0.5*temp[i,j-1]+0.5*temp[i,j+1])/(2+Bi[i,j]); - end - else if i=w then - begin - temp[i,j]:=(Bi[i,j]*boundary[i,j]+temp[i-1,j]+0.5*temp[i,j-1]+0.5*temp[i,j+1])/(2+Bi[i,j]); - end - else if j=0 then - begin - temp[i,j]:=(Bi[i,j]*boundary[i,j]+temp[i,j+1]+0.5*temp[i-1,j]+0.5*temp[i+1,j])/(2+Bi[i,j]); - end - else if j=h then - begin - temp[i,j]:=(Bi[i,j]*boundary[i,j]+temp[i,j-1]+0.5*temp[i-1,j]+0.5*temp[i+1,j])/(2+Bi[i,j]); - end - else - temp[i,j]:=(temp[i,j-1]+temp[i-1,j]+temp[i+1,j]+temp[i,j+1])/4; - end; - - var - iter,i,j,mi,mj : longint; - habs,sigma_phi : double; - - begin - clrscr; - iter:=0; - { setup boundary conditions } - for i:=0 to w do - for j:=0 to h do - begin - if (i=0) or (i=w) then - bi[i,j]:=100 - else - bi[i,j]:=100; - - if (j=0) then - boundary[i,j]:=1000 - else - boundary[i,j]:=300; - end; - init; - draw; - repeat - calc_phi; - mi:=0; - mj:=0; - sigma_phi:=0; - inc(iter); - habs:=abs(phi[mi,mj]); - for i:=0 to w do - for j:=0 to h do - begin - if abs(phi[i,j])>habs then - begin - mi:=i; - mj:=j; - habs:=abs(phi[mi,mj]); - end; - { calculate error } - sigma_phi:=sigma_phi+abs(phi[i,j]); - end; - adapt(mi,mj); - gotoxy(1,23); - textcolor(white); - writeln(iter,' iterations, sigma_phi=',sigma_phi); - until {keypressed or }(sigma_phi<0.5); - draw; - gotoxy(1,23); - textcolor(white); - writeln(iter,' iterations, sigma_phi=',sigma_phi); - {writeln('press a key'); - if readkey=#0 then - readkey;} - end. diff --git a/tests/tbs/tbs0017.pp b/tests/tbs/tbs0017.pp deleted file mode 100644 index 6cc0f2f176..0000000000 --- a/tests/tbs/tbs0017.pp +++ /dev/null @@ -1,38 +0,0 @@ - -{$ifdef go32v2} - uses dpmiexcp; - -{$endif go32v2} - -const - nextoptpass : longint = 0; - procedure init; - - const - endofparas : boolean = false; - - procedure getparastring; - - procedure nextopt; - - begin - endofparas:=true; - getparastring; - inc(nextoptpass); - init; - end; - - begin - if not endofparas then - nextopt; - end; - - begin - getparastring; - end; - -begin - init; - if nextoptpass<>1 then Halt(1); -end. - diff --git a/tests/tbs/tbs0018.pp b/tests/tbs/tbs0018.pp deleted file mode 100644 index 063088da5f..0000000000 --- a/tests/tbs/tbs0018.pp +++ /dev/null @@ -1,12 +0,0 @@ -type - p = ^x; - x = byte; - -var - b : p; - -begin - new(b); - b^:=12; -end. - diff --git a/tests/tbs/tbs0019.pp b/tests/tbs/tbs0019.pp deleted file mode 100644 index fe3813925a..0000000000 --- a/tests/tbs/tbs0019.pp +++ /dev/null @@ -1,13 +0,0 @@ -type - b = ^x; - - x = byte; - -var - pb : b; - -begin - new(pb); - pb^:=10; -end. - diff --git a/tests/tbs/tbs0021.pp b/tests/tbs/tbs0021.pp deleted file mode 100644 index f2148818a5..0000000000 --- a/tests/tbs/tbs0021.pp +++ /dev/null @@ -1,39 +0,0 @@ -{ tests constant set evalution } - -var - a : set of byte; - -const - b : set of byte = [0..255]+[9]; - -type - tcommandset = set of byte; - -const -cmZoom = 10; -cmClose = 5; -cmResize = 8; -cmNext = 12; -cmPrev = 15; - -CONST - CurCommandSet : TCommandSet = ([0..255] - - [cmZoom, cmClose, cmResize, cmNext, cmPrev]); - commands : tcommandset = []; - -var - CommandSetChanged : boolean; - -PROCEDURE DisableCommands (Commands: TCommandSet); - - BEGIN - {$IFNDEF PPC_FPK} { FPK bug } - CommandSetChanged := CommandSetChanged OR - (CurCommandSet * Commands <> []); { Set changed flag } - {$ENDIF} - CurCommandSet := CurCommandSet - Commands; { Update command set } - END; - -begin - a:=[byte(1)]+[byte(2)]; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0022.pp b/tests/tbs/tbs0022.pp deleted file mode 100644 index f64490b248..0000000000 --- a/tests/tbs/tbs0022.pp +++ /dev/null @@ -1,29 +0,0 @@ -type - tobject = object - procedure x; - constructor c; - end; - -procedure a; - - begin - end; - -procedure tobject.x; - - begin - end; - -constructor tobject.c; - - begin - end; - -var - p : pointer; - -begin - p:=@a; - p:=@tobject.x; - p:=@tobject.c; -end. diff --git a/tests/tbs/tbs0023.pp b/tests/tbs/tbs0023.pp deleted file mode 100644 index 39388a7a4f..0000000000 --- a/tests/tbs/tbs0023.pp +++ /dev/null @@ -1,47 +0,0 @@ -type - tobject = object - a : longint; - procedure t1; - procedure t2;virtual; - constructor init; - end; - -procedure tobject.t1; - - procedure nested1; - - begin - writeln; - a:=1; - end; - - begin - end; - -procedure tobject.t2; - - procedure nested1; - - begin - writeln; - a:=1; - end; - - begin - end; - -constructor tobject.init; - - procedure nested1; - - begin - writeln; - a:=1; - end; - - begin - end; - - -begin -end. \ No newline at end of file diff --git a/tests/tbs/tbs0024.pp b/tests/tbs/tbs0024.pp deleted file mode 100644 index a5b95f7487..0000000000 --- a/tests/tbs/tbs0024.pp +++ /dev/null @@ -1,24 +0,0 @@ - -type - charset=set of char; - - trec=record - junk : array[1..32] of byte; - t : charset; - end; - - var - tr : trec; - tp : ^trec; - - - procedure Crash(const k:charset); - - begin - tp^.t:=[#7..#10]+k; - end; - - begin - tp:=@tr; - Crash([#20..#32]); - end. \ No newline at end of file diff --git a/tests/tbs/tbs0025.pp b/tests/tbs/tbs0025.pp deleted file mode 100644 index 81088f0298..0000000000 --- a/tests/tbs/tbs0025.pp +++ /dev/null @@ -1,15 +0,0 @@ -procedure p1; -type - datetime=record - junk : string; -end; -var - dt : datetime; -begin - fillchar(dt,sizeof(dt),0); -end; - -begin - P1; -end. - diff --git a/tests/tbs/tbs0026.pp b/tests/tbs/tbs0026.pp deleted file mode 100644 index 13dcccccae..0000000000 --- a/tests/tbs/tbs0026.pp +++ /dev/null @@ -1,22 +0,0 @@ -const - HexTbl : array[0..15] of char=('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'); -function HexB(b:byte):string; -begin - HexB[0]:=#2; - HexB[1]:=HexTbl[b shr 4]; - HexB[2]:=HexTbl[b and $f]; -end; - - - -function HexW(w:word):string; -begin - HexW:=HexB(w shr 8)+HexB(w and $ff); -end; - - - -begin - HexW($fff); -end. - diff --git a/tests/tbs/tbs0027.pp b/tests/tbs/tbs0027.pp deleted file mode 100644 index 5cd4e28c3f..0000000000 --- a/tests/tbs/tbs0027.pp +++ /dev/null @@ -1,5 +0,0 @@ -type enumtype = (One, two, three, forty:=40, fifty); - -begin -end. - diff --git a/tests/tbs/tbs0028.pp b/tests/tbs/tbs0028.pp deleted file mode 100644 index 4cf2d0e261..0000000000 --- a/tests/tbs/tbs0028.pp +++ /dev/null @@ -1,10 +0,0 @@ -type - enumtype = (a); - -var - e : enumtype; - -begin - writeln(ord(e)); -end. - diff --git a/tests/tbs/tbs0029.pp b/tests/tbs/tbs0029.pp deleted file mode 100644 index 6b0fb63edb..0000000000 --- a/tests/tbs/tbs0029.pp +++ /dev/null @@ -1,20 +0,0 @@ -type - TA = object - constructor init; - procedure test;virtual; - end; - - constructor TA.init; - begin - end; - - procedure TA.test; - begin - end; - -var - P: Pointer; - -begin - P := pointer(TypeOf(TA)); -end. diff --git a/tests/tbs/tbs0030.pp b/tests/tbs/tbs0030.pp deleted file mode 100644 index 19c4a7e21d..0000000000 --- a/tests/tbs/tbs0030.pp +++ /dev/null @@ -1,6 +0,0 @@ -const - a : array[0..1] of real = (1,1); - -begin -end. - diff --git a/tests/tbs/tbs0031.pp b/tests/tbs/tbs0031.pp deleted file mode 100644 index 916fd8e955..0000000000 --- a/tests/tbs/tbs0031.pp +++ /dev/null @@ -1,8 +0,0 @@ -var - a : array[boolean] of longint; - -begin - a[true]:=1234; - a[false]:=123; -end. - diff --git a/tests/tbs/tbs0032.pp b/tests/tbs/tbs0032.pp deleted file mode 100644 index 7f532a3b62..0000000000 --- a/tests/tbs/tbs0032.pp +++ /dev/null @@ -1,12 +0,0 @@ -var - p : procedure(w : word); - - procedure pp(w :word); - begin - Writeln(w); - end; - -begin - p:=@pp; - p(1234); -end. diff --git a/tests/tbs/tbs0033.pp b/tests/tbs/tbs0033.pp deleted file mode 100644 index 705351c32e..0000000000 --- a/tests/tbs/tbs0033.pp +++ /dev/null @@ -1,13 +0,0 @@ -var - p1 : pchar; - p2 : array[0..10] of char; - s : string; - c : char; - -begin - p1:='c'; - s:='c'; - { this isn't allowed - p1:=c; - } -end. diff --git a/tests/tbs/tbs0034.pp b/tests/tbs/tbs0034.pp deleted file mode 100644 index 2f43eb2053..0000000000 --- a/tests/tbs/tbs0034.pp +++ /dev/null @@ -1,16 +0,0 @@ -{ line numbering problem } -{ I don't really know how to test this (PM } - var i : longint; - -begin - asm - movl %eax,%eax - movl %eax,%eax - movl %eax,%eax - movl %eax,%eax - movl %eax,%eax - movl %eax,%eax - movl %eax,%eax - end ; - i:=0; -end. diff --git a/tests/tbs/tbs0035.pp b/tests/tbs/tbs0035.pp deleted file mode 100644 index 9d3dc4ff51..0000000000 --- a/tests/tbs/tbs0035.pp +++ /dev/null @@ -1,15 +0,0 @@ -{ $OPT=-Sg } - -program bug0035; - -{Discovered by Daniel Mantione.} - -label hallo; - -begin - writeln('Hello'); - begin -hallo: {Error message: Incorrect expression.} - end; - writeln('Hello again'); -end. diff --git a/tests/tbs/tbs0037.pp b/tests/tbs/tbs0037.pp deleted file mode 100644 index 3a19be7acb..0000000000 --- a/tests/tbs/tbs0037.pp +++ /dev/null @@ -1,49 +0,0 @@ -{$ifdef go32v2} -{$define OK} -{$endif} -{$ifdef linux} -{$define OK} -{$endif} -{$ifdef win32} -{$define OK} -{$endif} - -{$ifdef OK} -uses - graph, - crt; - -var - gd,gm,res : integer; -{$endif OK} - -begin -{$ifdef OK} - gd:=detect; - initgraph(gd,gm,''); - res := graphresult; - if res <> grOk then - begin - graphErrorMsg(res); - halt(1); - end; - setviewport(0,0,getmaxx,getmaxy,clipon); - line(1,1,100,100); - {readkey;} - setgraphmode(m1024x768); - setviewport(0,0,getmaxx,getmaxy,clipon); - res := graphresult; - if res <> grOk then - begin - closegraph; - graphErrorMsg(res); - { no error, graph mode is simply not supported } - halt(0); - end; - line(100,100,1024,800); - {readkey;} - delay(1000); - closegraph; -{$endif OK} -end. - diff --git a/tests/tbs/tbs0038.pp b/tests/tbs/tbs0038.pp deleted file mode 100644 index ce9c4c5809..0000000000 --- a/tests/tbs/tbs0038.pp +++ /dev/null @@ -1,5 +0,0 @@ -CONST ps : ^STRING = nil; - -begin -end. - diff --git a/tests/tbs/tbs0039.pp b/tests/tbs/tbs0039.pp deleted file mode 100644 index 0e0ca1910d..0000000000 --- a/tests/tbs/tbs0039.pp +++ /dev/null @@ -1,10 +0,0 @@ -VAR a : BYTE; -BEGIN - a := 1; - IF a=0 THEN - IF a=1 THEN a:=2 - ELSE - ELSE a:=3; { "Illegal expression" } -END. - - diff --git a/tests/tbs/tbs0040.pp b/tests/tbs/tbs0040.pp deleted file mode 100644 index ffb08f984a..0000000000 --- a/tests/tbs/tbs0040.pp +++ /dev/null @@ -1,26 +0,0 @@ -{ xor operator bug } -{ needs fix in pass_1.pas line } -{ 706. as well as in the code } -{ generator - secondadd() } -var - b1,b2: boolean; -Begin - b1:=true; - b2:=false; - If (b1 xor b2) Then - begin - end - else - begin - writeln('Problem with bool xor'); - halt; - end; - b1:=true; - b2:=true; - If (b1 xor b2) Then - begin - writeln('Problem with bool xor'); - halt; - end; - writeln('No problem found'); -end. diff --git a/tests/tbs/tbs0041.pp b/tests/tbs/tbs0041.pp deleted file mode 100644 index 51f617c575..0000000000 --- a/tests/tbs/tbs0041.pp +++ /dev/null @@ -1,8 +0,0 @@ -var - b1: boolean; -Begin - begin - If b1 then { illegal expression } - end; - while b1 do -End. diff --git a/tests/tbs/tbs0042.pp b/tests/tbs/tbs0042.pp deleted file mode 100644 index e6137c36d8..0000000000 --- a/tests/tbs/tbs0042.pp +++ /dev/null @@ -1,11 +0,0 @@ -{ $OPT= -Rintel } -Program SomeCrash; -{ with pp -TDOS -Rintel bug0042.pp } -{ I'll try to fix this for next release -- Carl } - -Begin - asm - mov ax,3*-4 { evaluator stack underflow } - end; { due to two operators following each other } -end. { this will also happen in att syntax. } - diff --git a/tests/tbs/tbs0043.pp b/tests/tbs/tbs0043.pp deleted file mode 100644 index 92946ec303..0000000000 --- a/tests/tbs/tbs0043.pp +++ /dev/null @@ -1,32 +0,0 @@ -{ THE OUTPUT is incorrect but the } -{ parsing is correct. } -{ under nasm output only. } -{ works correctly under tasm/gas } -{ other problems occur with other } -{ things in math.inc } -{ pp -TDOS -Ratt -Anasm bug0043.pp } - procedure frac; - - begin - asm - subl $16,%esp - fnstcw -4(%ebp) - fwait { unknown instruction } - movw -4(%ebp),%cx - orw $0x0c3f,%cx - movw %cx,-8(%ebp) - fldcw -8(%ebp) - fwait { unknown instruction } - fldl 8(%ebp) - frndint - fsubl 8(%ebp) - fabsl - fclex - fldcw -4(%ebp) - leave - ret $8 - end ['ECX']; - end; - -Begin -end. diff --git a/tests/tbs/tbs0044.pp b/tests/tbs/tbs0044.pp deleted file mode 100644 index 5cbadb041b..0000000000 --- a/tests/tbs/tbs0044.pp +++ /dev/null @@ -1,16 +0,0 @@ - { Problem with nested comments -- as you can probably see } - { but it does give out kind of a funny error output :) } - - - {$UNDEF VP} - - {$IFDEF Windows} ssss {$ENDIF} {No Syntax Error} - - {$IFDEF VP} - {$D+}{$R+} - {$ELSE} - {$IFDEF Windows} ssss {$ENDIF} {Syntax Error at: Col 25 } - {$ENDIF} - - BEGIN - END. diff --git a/tests/tbs/tbs0045.pp b/tests/tbs/tbs0045.pp deleted file mode 100644 index 9aea8bd961..0000000000 --- a/tests/tbs/tbs0045.pp +++ /dev/null @@ -1,26 +0,0 @@ - -TYPE - tmyexample =object - public - constructor init; - destructor done; virtual; - private - procedure mytest;virtual; { syntax error --> should give only a -warning ? } - end; - - constructor tmyexample.init; - begin - end; - - destructor tmyexample.done; - Begin - end; - - procedure tmyexample.mytest; - begin - end; - -Begin -end. - diff --git a/tests/tbs/tbs0046.pp b/tests/tbs/tbs0046.pp deleted file mode 100644 index 45b3e107d1..0000000000 --- a/tests/tbs/tbs0046.pp +++ /dev/null @@ -1,53 +0,0 @@ -program test; - -{$R-} - -{$ifdef fpc} -{$ifdef go32v2} -uses - dpmiexcp; -{$endif} -{$endif} - -type byteset = set of byte; - bl = record i,j : longint; - end; -const set1 : byteset = [1,50,220]; - set2 : byteset = [55]; -var i : longint; - b : bl; - - function bi : longint; - - begin - bi:=b.i; - end; - -begin -set1:=set1+set2; -writeln('set 1 = [1,50,55,220]'); -i:=50; -if i in set1 then - writeln(i,' is in set1'); -i:=220; -if i in set1 then - writeln(i,' is in set1'); -i:=$100+220; -if i in set1 then - writeln(i,' is in set1'); -i:=-35; -if i in set1 then - writeln(i,' is in set1'); -b.i:=50; -i:=$100+220; -if i in [50,220] then - writeln(i,' is in [50,220]'); -if Bi in [50,220] then - writeln(b.i,' is in [50,220]'); -b.i:=220; -if bi in [50,220] then - writeln(b.i,' is in [50,220]'); -B.i:=-36; -if bi in [50,220] then - writeln(B.i,' is in [50,220]'); -end. diff --git a/tests/tbs/tbs0047.pp b/tests/tbs/tbs0047.pp deleted file mode 100644 index e00f64c8a1..0000000000 --- a/tests/tbs/tbs0047.pp +++ /dev/null @@ -1,13 +0,0 @@ -procedure test; - - begin - end; - -var - p1 : procedure; - p2 : pointer; - -begin - p1:=@test; - p2:=@test; -end. diff --git a/tests/tbs/tbs0048.pp b/tests/tbs/tbs0048.pp deleted file mode 100644 index cd0b3bfc83..0000000000 --- a/tests/tbs/tbs0048.pp +++ /dev/null @@ -1,44 +0,0 @@ -{$ifdef go32v2} -{$define OK} -{$endif} -{$ifdef linux} -{$define OK} -{$endif} -{$ifdef win32} -{$define OK} -{$endif} - -{$ifdef OK} -uses - graph,crt; - -var - gd,gm : integer; - i,size : longint; - p : pointer; -{$endif OK} - -begin -{$ifdef OK} - gd:=detect; - initgraph(gd,gm,''); - setcolor(brown); - line(0,0,getmaxx,0); - {readkey;}delay(1000); - size:=imagesize(0,0,getmaxx,0); - getmem(p,size); - getimage(0,0,getmaxx,0,p^); - cleardevice; - for i:=0 to getmaxy do - begin - putimage(0,i,p^,xorput); - end; - {readkey;}delay(1000); - for i:=0 to getmaxy do - begin - putimage(0,i,p^,xorput); - end; - {readkey;}delay(1000); - closegraph; -{$endif OK} -end. diff --git a/tests/tbs/tbs0050.pp b/tests/tbs/tbs0050.pp deleted file mode 100644 index b34224eac0..0000000000 --- a/tests/tbs/tbs0050.pp +++ /dev/null @@ -1,19 +0,0 @@ -function Append : Boolean; - - procedure DoAppend; - begin - Append := true; - end; - -begin - Append:=False; - DoAppend; -end; - -begin - If not Append then - begin - Writeln('TBS0050 fails'); - Halt(1); - end; -end. diff --git a/tests/tbs/tbs0051.pp b/tests/tbs/tbs0051.pp deleted file mode 100644 index e70f759633..0000000000 --- a/tests/tbs/tbs0051.pp +++ /dev/null @@ -1,92 +0,0 @@ -program TestPutP; - -{$ifdef go32v2} - {define has_colors_equal} -{$endif go32v2} - -{$ifdef go32v2} -{$define OK} -{$endif} -{$ifdef linux} -{$define OK} -{$endif} - -{$ifdef OK} -uses crt,graph; - -{$ifndef has_colors_equal} - function ColorsEqual(c1, c2 : longint) : boolean; - begin - ColorsEqual:=((GetMaxColor=$FF) and ((c1 and $FF)=(c2 and $FF))) or - ((GetMaxColor=$7FFF) and ((c1 and $F8F8F8)=(c2 and $F8F8F8))) or - ((GetMaxColor=$FFFF) and ((c1 and $F8FCF8)=(c2 and $F8FCF8))) or - ((GetMaxColor>$10000) and ((c1 and $FFFFFF)=(c2 and $FFFFFF))); - end; - -{$endif not has_colors_equal} - -var gd,gm,gError,yi,i : integer; - col: longint; - error : word; - -{$endif OK} -BEGIN -{$ifdef OK} - if paramcount=0 then - gm:=$111 {640x480/64K HiColor} - else - begin - val(paramstr(1),gm,error); - if error<>0 then - gm:=$111; - end; - gd:=detect; - - InitGraph(gd,gm,''); - gError := graphResult; - IF gError <> grOk - THEN begin - writeln ('graphDriver=',gd,' graphMode=',gm, - #13#10'Graphics error: ',gError); - halt(1); - end; - - for i := 0 to 255 - do begin - { new grpah unit used word type for colors } - col := {i shl 16 + }(i) shl 8 + (i div 2); - for yi := 0 to 20 do - PutPixel (i,yi,col); - SetColor (col); - Line (i,22,i,42); - end; - - for i:=0 to 255 do - if not ColorsEqual(getpixel(i,15),getpixel(i,30)) then - Halt(1); - {readkey;}delay(1000); - - closegraph; -{$endif OK} -END. - -{ - $Log$ - Revision 1.1 2000-07-13 09:21:54 michael - + Initial import - - Revision 1.2 2000/04/14 05:44:22 pierre - * adapted to new graph unit - - Revision 1.1 1999/12/02 17:37:38 peter - * moved *.pp into subdirs - * fpcmaked - - Revision 1.5 1999/11/28 12:17:14 jonas - * changed the requested graphdriver from $FF to VESA (= 10), so the - test program works again with the new graph unit - * undefined has_colors_equal for go32v2, because it is not anymore - in the new graph unit - - -} diff --git a/tests/tbs/tbs0052.pp b/tests/tbs/tbs0052.pp deleted file mode 100644 index cf1e02cf69..0000000000 --- a/tests/tbs/tbs0052.pp +++ /dev/null @@ -1,49 +0,0 @@ -{$ifdef go32v2} -{$define OK} -{$endif} -{$ifdef linux} -{$define OK} -{$endif} -{$ifdef win32} -{$define OK} -{$endif} - -{$ifdef OK} -uses - crt,graph; - -const - Triangle: array[1..3] of PointType = ((X: 50; Y: 100), (X: 100; Y:100), - (X: 150; Y: 150)); - Rect : array[1..4] of PointType = ((X: 50; Y: 100), (X: 100; Y:100), - (X: 75; Y: 150), (X: 80; Y : 50)); - Penta : array[1..5] of PointType = ((X: 250; Y: 100), (X: 300; Y:100), - (X: 275; Y: 150), (X: 280; Y : 50), (X:295; Y : 80) ); - -var Gd, Gm: Integer; -{$endif OK} -begin -{$ifdef OK} - Gd := Detect; - InitGraph(Gd, Gm, 'c:\bp\bgi'); - if GraphResult <> grOk then - Halt(1); - drawpoly(SizeOf(Triangle) div SizeOf(PointType), Triangle); - {readln;}delay(1000); - setcolor(red); - fillpoly(SizeOf(Triangle) div SizeOf(PointType), Triangle); - {readln;}delay(1000); - SetFillStyle(SolidFill,blue); - Bar(0,0,GetMaxX,GetMaxY); - Rectangle(25,25,GetMaxX-25,GetMaxY-25); - setViewPort(25,25,GetMaxX-25,GetMaxY-25,true); - clearViewPort; - setcolor(magenta); - SetFillStyle(SolidFill,red); - fillpoly(SizeOf(Rect) div SizeOf(PointType), Rect); - fillpoly(SizeOf(Penta) div SizeOf(PointType), Penta); - graphdefaults; - {readln;}delay(1000); - CloseGraph; -{$endif OK} -end. diff --git a/tests/tbs/tbs0053.pp b/tests/tbs/tbs0053.pp deleted file mode 100644 index 1e7ae3783f..0000000000 --- a/tests/tbs/tbs0053.pp +++ /dev/null @@ -1,15 +0,0 @@ -procedure abc(var a : array of char); - - begin - // error: a:='asdf'; - end; - -var - c : array[0..10] of char; - -begin - abc(c); - writeln(c); - // error: writeln(a); -end. - diff --git a/tests/tbs/tbs0054.pp b/tests/tbs/tbs0054.pp deleted file mode 100644 index 9955d6b31c..0000000000 --- a/tests/tbs/tbs0054.pp +++ /dev/null @@ -1,6 +0,0 @@ -var - wb : wordbool; - wl : longbool; - -begin -end. diff --git a/tests/tbs/tbs0055.pp b/tests/tbs/tbs0055.pp deleted file mode 100644 index e6fd4392ba..0000000000 --- a/tests/tbs/tbs0055.pp +++ /dev/null @@ -1,15 +0,0 @@ -type - tarraysingle = array[0..1] of single; - -procedure test(var a : tarraysingle); - -var - i,j,k : integer; - -begin - a[i]:=a[j]-a[k]; -end; - -begin -end. - diff --git a/tests/tbs/tbs0056.pp b/tests/tbs/tbs0056.pp deleted file mode 100644 index cc92e4bb8b..0000000000 --- a/tests/tbs/tbs0056.pp +++ /dev/null @@ -1,14 +0,0 @@ -PROGRAM ShowBug; - -(* This will compile -VAR N, E: Integer;*) - -(* This will NOT compile*) -VAR N, E: LongInt; - -BEGIN - E := 2; - WriteLn(E); - N := 44 - E; - WriteLn(N); -END. diff --git a/tests/tbs/tbs0057.pp b/tests/tbs/tbs0057.pp deleted file mode 100644 index ebd49656c0..0000000000 --- a/tests/tbs/tbs0057.pp +++ /dev/null @@ -1,34 +0,0 @@ -{$ifdef go32v2} -{$define OK} -{$endif} -{$ifdef linux} -{$define OK} -{$endif} -{$ifdef win32} -{$define OK} -{$endif} - -{$ifdef OK} -uses - graph,crt; - -var - gd,gm : integer; - -{$endif OK} -begin -{$ifdef OK} - gd:=detect; - gm:=$103; - initgraph(gd,gm,''); - setcolor(white); - line(1,1,100,100); - {readkey;}delay(1000); - closegraph; - initgraph(gd,gm,''); - line(100,100,1,100); - {readkey;}delay(1000); - closegraph; -{$endif OK} - writeln('OK'); -end. diff --git a/tests/tbs/tbs0058.pp b/tests/tbs/tbs0058.pp deleted file mode 100644 index 2b23efaf2a..0000000000 --- a/tests/tbs/tbs0058.pp +++ /dev/null @@ -1,9 +0,0 @@ -{$r+} -var - a1 : array[0..1,0..1] of word; - a2 : array[0..1,0..1] of longint; - i,j,l,n : longint; - -begin - a1[i,j]:=a2[l,n]; -end. diff --git a/tests/tbs/tbs0059.pp b/tests/tbs/tbs0059.pp deleted file mode 100644 index 05a247c2c4..0000000000 --- a/tests/tbs/tbs0059.pp +++ /dev/null @@ -1,9 +0,0 @@ -Program ConstBug; - -Const - S = ord('J'); - t: byte = ord('J'); - - -Begin -end. diff --git a/tests/tbs/tbs0061.pp b/tests/tbs/tbs0061.pp deleted file mode 100644 index 55cb7e4f5a..0000000000 --- a/tests/tbs/tbs0061.pp +++ /dev/null @@ -1,8 +0,0 @@ -var - r : double; - s : string; - -begin - r:=1234.0; - str(r,s); -end. diff --git a/tests/tbs/tbs0062.pp b/tests/tbs/tbs0062.pp deleted file mode 100644 index 0b729e1fae..0000000000 --- a/tests/tbs/tbs0062.pp +++ /dev/null @@ -1,9 +0,0 @@ -Program Bug0062; - - -var - myvar:boolean; -Begin - { by fixing this we also start partly implementing LONGBOOL/WORDBOOL } - myvar:=boolean(1); { illegal type conversion } -end. diff --git a/tests/tbs/tbs0063.pp b/tests/tbs/tbs0063.pp deleted file mode 100644 index 87a408e62c..0000000000 --- a/tests/tbs/tbs0063.pp +++ /dev/null @@ -1,13 +0,0 @@ -{ may also crash/do weird error messages with the compiler } -var - min: char; - max: char; - i: char; -begin - min:='c'; - max:='z'; - if i in [min..max] then - Begin - end; -end. - diff --git a/tests/tbs/tbs0064.pp b/tests/tbs/tbs0064.pp deleted file mode 100644 index 3fe56fd7dc..0000000000 --- a/tests/tbs/tbs0064.pp +++ /dev/null @@ -1,15 +0,0 @@ -var - i: byte; - j: integer; - c: char; -Begin - case i of - Ord('x'): ; - end; - case j of - Ord('x'): ; - end; - case c of - Chr(112): ; - end; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0065.pp b/tests/tbs/tbs0065.pp deleted file mode 100644 index 58d287aa6d..0000000000 --- a/tests/tbs/tbs0065.pp +++ /dev/null @@ -1,10 +0,0 @@ -Program Example27; - -{ Program to demonstrate the Frac function. } - -Var R : Real; - -begin - Writeln (Frac (123.456):0:3); { Prints O.456 } - Writeln (Frac (-123.456):0:3); { Prints -O.456 } -end. diff --git a/tests/tbs/tbs0066.pp b/tests/tbs/tbs0066.pp deleted file mode 100644 index bef31138a4..0000000000 --- a/tests/tbs/tbs0066.pp +++ /dev/null @@ -1,10 +0,0 @@ -Program Example54; - -{ Program to demonstrate the Round function. } - -begin - Writeln (Round(123.456)); { Prints 124 } - Writeln (Round(-123.456)); { Prints -124 } - Writeln (Round(12.3456)); { Prints 12 } - Writeln (Round(-12.3456)); { Prints -12 } -end. diff --git a/tests/tbs/tbs0067.pp b/tests/tbs/tbs0067.pp deleted file mode 100644 index 32fc19e6dc..0000000000 --- a/tests/tbs/tbs0067.pp +++ /dev/null @@ -1,18 +0,0 @@ -unit tbs0067; - -interface - -type - tlong=record - a : longint; - end; - -procedure p(var t:tlong); - -implementation - -procedure p(var t:tlong); -begin -end; - -end. diff --git a/tests/tbs/tbs0067b.pp b/tests/tbs/tbs0067b.pp deleted file mode 100644 index ab297dd6c1..0000000000 --- a/tests/tbs/tbs0067b.pp +++ /dev/null @@ -1,27 +0,0 @@ -unit tbs0067b; - -interface - - -type - tlong=record - a : longint; - end; - -procedure p(var l:tlong); - -implementation - -uses tbs0067; - -{ the tlong parameter is taken from unit bug0067, - and not from the interface part of this unit. - setting the uses clause in the interface part - removes the problem } - -procedure p(var l:tlong); -begin - tbs0067.p(tbs0067.tlong(l)); -end; - -end. diff --git a/tests/tbs/tbs0068.pp b/tests/tbs/tbs0068.pp deleted file mode 100644 index 906c0db169..0000000000 --- a/tests/tbs/tbs0068.pp +++ /dev/null @@ -1,9 +0,0 @@ -program bug0068; - -var - p : pointer; - l : longint; -begin - l:=Ofs(p); { Ofs returns a pointer type !? } - -end. diff --git a/tests/tbs/tbs0069.pp b/tests/tbs/tbs0069.pp deleted file mode 100644 index 7492d922cf..0000000000 --- a/tests/tbs/tbs0069.pp +++ /dev/null @@ -1,25 +0,0 @@ -Unit tbs0069; - -Interface - -Procedure MyTest;Far; { IMPLEMENTATION expected error. } - -{ Further information: NEAR IS NOT ALLOWED IN BORLAND PASCAL } -{ Therefore the bugfix should only be for the FAR keyword. } -(* Procedure MySecondTest;Near; *) - -Implementation - -{ near and far are not allowed here, but maybe we don't care since they are ignored by } -{ FPC. } -Procedure MyTest; -Begin -end; - -Procedure MySecondTest; -Begin -end; - - - -end. diff --git a/tests/tbs/tbs0070.pp b/tests/tbs/tbs0070.pp deleted file mode 100644 index aa6044669f..0000000000 --- a/tests/tbs/tbs0070.pp +++ /dev/null @@ -1,10 +0,0 @@ -Program Test; - -type - myenum = (YES,NO,MAYBE); -var - myvar:set of myenum; -Begin - Include(myvar,Yes); - Exclude(myvar,No); -end. diff --git a/tests/tbs/tbs0072.pp b/tests/tbs/tbs0072.pp deleted file mode 100644 index e6fd4392ba..0000000000 --- a/tests/tbs/tbs0072.pp +++ /dev/null @@ -1,15 +0,0 @@ -type - tarraysingle = array[0..1] of single; - -procedure test(var a : tarraysingle); - -var - i,j,k : integer; - -begin - a[i]:=a[j]-a[k]; -end; - -begin -end. - diff --git a/tests/tbs/tbs0073.pp b/tests/tbs/tbs0073.pp deleted file mode 100644 index a4da4e1799..0000000000 --- a/tests/tbs/tbs0073.pp +++ /dev/null @@ -1,30 +0,0 @@ -Unit tbs0073; - -Interface - - -Procedure MyTest;Far; { IMPLEMENTATION expected error. } - -{ Further information: NEAR IS NOT ALLOWED IN BORLAND PASCAL } -{ Therefore the bugfix should only be for the FAR keyword. } - Procedure MySecondTest; - -Implementation - -{ near and far are not allowed here, but maybe we don't care since they are ignored by } -{ FPC. } -Procedure MyTest; -Begin -end; - - - -Procedure MySecondTest;Far; -Begin -end; - - - - - -end. diff --git a/tests/tbs/tbs0074.pp b/tests/tbs/tbs0074.pp deleted file mode 100644 index a6683509da..0000000000 --- a/tests/tbs/tbs0074.pp +++ /dev/null @@ -1,28 +0,0 @@ -type - tmyobject = object - constructor init; - procedure callit; virtual; - destructor done; virtual; - end; - - - constructor tmyobject.init; - Begin - end; - - destructor tmyobject.done; - Begin - end; - - procedure tmyobject.callit; - Begin - WriteLn('Hello...'); - end; - - var - obj: tmyobject; - Begin - obj.init; - obj.callit; -{ obj.done;} - end. diff --git a/tests/tbs/tbs0076.pp b/tests/tbs/tbs0076.pp deleted file mode 100644 index 3b182210da..0000000000 --- a/tests/tbs/tbs0076.pp +++ /dev/null @@ -1,24 +0,0 @@ -program bug0076; - -{Generates wrong code when compiled with output set to intel asm. - - Reported from mailinglist by Vtech Kavan. - - 15 Januari 1998, Daniel Mantione} - -type TVtx2D = record x,y:longint end; - -var Vtx2d:array[0..2] of TVtx2D; - -function SetupScanLines(va,vb,vc:word):single; -var dx3d,dx2d,dy2d,dz,ex3d,ex2d,ez:longint; - r:single; -begin - dy2d := Vtx2d[vb].y; - r := (dy2d-Vtx2d[va].y); {this line causes error!!!!!!!!!!!!!!!!!!!} -end; - -begin - SetupScanLines(1,2,3); -end. - diff --git a/tests/tbs/tbs0077.pp b/tests/tbs/tbs0077.pp deleted file mode 100644 index ef928838e6..0000000000 --- a/tests/tbs/tbs0077.pp +++ /dev/null @@ -1,9 +0,0 @@ -uses - tbs0077b; - -begin - b:=89; - writeln(a); -end. - - diff --git a/tests/tbs/tbs0077b.pp b/tests/tbs/tbs0077b.pp deleted file mode 100644 index 0c1992dadb..0000000000 --- a/tests/tbs/tbs0077b.pp +++ /dev/null @@ -1,11 +0,0 @@ -unit tbs0077b; - - interface - - var - a : longint; - b : longint absolute a; - - implementation - -end. diff --git a/tests/tbs/tbs0078.pp b/tests/tbs/tbs0078.pp deleted file mode 100644 index ca6dec3bc2..0000000000 --- a/tests/tbs/tbs0078.pp +++ /dev/null @@ -1,8 +0,0 @@ -{ $OPT=-Rintel } -{ shows error with asm_size_mismatch } -Begin - asm - mov eax, 2147483647 - mov eax, 2000000000 - end; -end. diff --git a/tests/tbs/tbs0079.pp b/tests/tbs/tbs0079.pp deleted file mode 100644 index 31e9b5a0ab..0000000000 --- a/tests/tbs/tbs0079.pp +++ /dev/null @@ -1,19 +0,0 @@ -{ $OPT= -Rintel } - -procedure nothing(x,y: longint);assembler; -asm - mov eax,x - mov ebx,y -end; - - -{procedure nothing(x,y: longint); -begin - asm - mov eax,x - mov ebx,y - end; -end; } - -Begin -end. diff --git a/tests/tbs/tbs0080.pp b/tests/tbs/tbs0080.pp deleted file mode 100644 index e4885fd8e3..0000000000 --- a/tests/tbs/tbs0080.pp +++ /dev/null @@ -1,8 +0,0 @@ -program bug0080; - -type - - tHugeArray = array [ 1 .. High(Word) ] of byte; - -begin -end. \ No newline at end of file diff --git a/tests/tbs/tbs0081.pp b/tests/tbs/tbs0081.pp deleted file mode 100644 index 55a82d9fd4..0000000000 --- a/tests/tbs/tbs0081.pp +++ /dev/null @@ -1,7 +0,0 @@ -program bug0081; - -const - EOL : array [1..2] of char = #13 + #10; - -begin -end. diff --git a/tests/tbs/tbs0082.pp b/tests/tbs/tbs0082.pp deleted file mode 100644 index f6c6a6256d..0000000000 --- a/tests/tbs/tbs0082.pp +++ /dev/null @@ -1,29 +0,0 @@ -Unit tbs0082; - -interface - -Type T = OBject - Constructor Init; - Destructor Free; virtual; - Destructor Destroy; virtual; - end; - -implementation - -constructor T.INit; - -begin -end; - -Destructor t.Free; - -begin -end; - -Destructor t.Destroy; - -begin -end; - - -end. \ No newline at end of file diff --git a/tests/tbs/tbs0083.pp b/tests/tbs/tbs0083.pp deleted file mode 100644 index 4bd2cdd673..0000000000 --- a/tests/tbs/tbs0083.pp +++ /dev/null @@ -1,8 +0,0 @@ - -var - s1 : set of char; - c1,c2,c3 : char; - -begin - s1:=[c1..c2,c3]; -end. diff --git a/tests/tbs/tbs0084.pp b/tests/tbs/tbs0084.pp deleted file mode 100644 index f2b3c00151..0000000000 --- a/tests/tbs/tbs0084.pp +++ /dev/null @@ -1,15 +0,0 @@ -{$R-} - -{ Basic Pascal principles gone done the drain... !!!! } - -var - v: word; - w: shortint; - z: byte; - y: integer; -Begin - y:=64000; - z:=32767; - w:=64000; - v:=-1; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0090.pp b/tests/tbs/tbs0090.pp deleted file mode 100644 index 16e63cf34e..0000000000 --- a/tests/tbs/tbs0090.pp +++ /dev/null @@ -1,10 +0,0 @@ -{$X+} -var - mystr : array[0..4] of char; - -Begin - if mystr = #0#0#0#0 then - Begin - end; - mystr:=#0#0#0#0; -end. diff --git a/tests/tbs/tbs0091.pp b/tests/tbs/tbs0091.pp deleted file mode 100644 index 26acf31cc5..0000000000 --- a/tests/tbs/tbs0091.pp +++ /dev/null @@ -1,23 +0,0 @@ -{ Page 22 of The Language Guide of Turbo Pascal } -var - t: byte; -const - a = Trunc(1.3); - b = Round(1.6); - c = abs(-5); - ErrStr = 'Hello!'; - d = Length(ErrStr); - e = Lo($1234); - f = Hi($1234); - g = Chr(34); - h = Odd(1); - i = Ord('3'); - j = Pred(34); - l = Sizeof(t); - m = Succ(9); - n = Swap($1234); - o = ptr(0,0); -Begin -end. - - diff --git a/tests/tbs/tbs0092.pp b/tests/tbs/tbs0092.pp deleted file mode 100644 index eb9509a3cc..0000000000 --- a/tests/tbs/tbs0092.pp +++ /dev/null @@ -1,10 +0,0 @@ -{The unfixable bug. Maybe we get an idea when we keep looking at it. - Daniel Mantione 5 februari 1998.} - -const - a:1..4=2; {Crash 1.} - b:set of 1..4=[2,3]; {Also crashes, but is the same bug.} - -begin - writeln(a); -end. diff --git a/tests/tbs/tbs0093.pp b/tests/tbs/tbs0093.pp deleted file mode 100644 index f0a3c64b1c..0000000000 --- a/tests/tbs/tbs0093.pp +++ /dev/null @@ -1,18 +0,0 @@ -{ Two cardinal type bugs } -var - c : cardinal; - l : longint; - b : byte; - s : shortint; - w : word; -begin - b:=123; - w:=s; - l:=b; - c:=b; {generates movzbl %eax,%edx instead of movzbl %al,%edx} - - c:=123; - writeln(c); {Shows '0' outline right! instead of '123' outlined left} - c:=$7fffffff; - writeln(c); {Shows '0' outline right! instead of '123' outlined left} -end. diff --git a/tests/tbs/tbs0095.pp b/tests/tbs/tbs0095.pp deleted file mode 100644 index 5ddfd435bd..0000000000 --- a/tests/tbs/tbs0095.pp +++ /dev/null @@ -1,15 +0,0 @@ -var - ch : char; -begin - ch:=#3; - case ch of - #0..#31 : ; - else - writeln('bug'); - end; - case ch of - #0,#1,#3 : ; - else - writeln('bug'); - end; -end. diff --git a/tests/tbs/tbs0096.pp b/tests/tbs/tbs0096.pp deleted file mode 100644 index fc8051cd4b..0000000000 --- a/tests/tbs/tbs0096.pp +++ /dev/null @@ -1,24 +0,0 @@ -type - TParent = object - end; - - PParent = ^TParent; - - TChild = object(TParent) - end; - -procedure aProc(const x : TParent ); -begin -end; - -procedure anotherProc(var x : TParent ); -begin -end; - -var - y : TChild; - - begin - aProc(y); - anotherProc(y); - end. diff --git a/tests/tbs/tbs0098.pp b/tests/tbs/tbs0098.pp deleted file mode 100644 index dc5417b2f7..0000000000 --- a/tests/tbs/tbs0098.pp +++ /dev/null @@ -1,45 +0,0 @@ -program Test; -{ Show how to seek to an OFFSET (not a line number) in a textfile, } -{ without using asm. Arne de Bruijn, 1994, PD } -uses Dos; { For TextRec and FileRec } -var - F:text; - L:longint; - S:string; -begin - assign(F,'tbs/tbs0098.pp'); { Assign F to itself } - reset(F); { Open it (as a textfile) } - ReadLn(F); { Just read some lines } - ReadLn(F); - ReadLn(F); - FileRec((@F)^).Mode:=fmInOut; { Set to binary mode } - { (The (@F)^ part is to let TP 'forget' the type of the structure, so } - { you can type-caste it to everything (note that with and without (@X)^ } - { can give a different value, longint(bytevar) gives the same value as } - { bytevar, while longint((@bytevar)^) gives the same as } - { longint absolute Bytevar (i.e. all 4 bytes in a longint are readed } - { from memory instead of 3 filled with zeros))) } - FileRec((@F)^).RecSize:=1; { Set record size to 1 (a byte)} - L:=(FilePos(File((@F)^))-TextRec(F).BufEnd)+TextRec(F).BufPos; -{... This line didn't work the last time I tried, it chokes on the "File" -typecasting thing.} - - { Get the fileposition, subtract the already readed buffer, and add the } - { position in that buffer } - TextRec(F).Mode:=fmInput; { Set back to text mode } - TextRec(F).BufSize:=SizeOf(TextBuf); { BufSize overwritten by RecSize } - { Doesn't work with SetTextBuf! } - ReadLn(F,S); { Read the next line } - WriteLn('Next line:',S); { Display it } - FileRec((@F)^).Mode:=fmInOut; { Set to binary mode } - FileRec((@F)^).RecSize:=1; { Set record size to 1 (a byte)} - Seek(File((@F)^),L); { Do the seek } -{... And again here.} - - TextRec(F).Mode:=fmInput; { Set back to text mode } - TextRec(F).BufSize:=SizeOf(TextBuf); { Doesn't work with SetTextBuf! } - TextRec(F).BufPos:=0; TextRec(F).BufEnd:=0; { Reset buffer counters } - ReadLn(F,S); { Show that it worked, the same } - WriteLn('That line again:',S); { line readed again! } - Close(F); { Close it } -end. diff --git a/tests/tbs/tbs0099.pp b/tests/tbs/tbs0099.pp deleted file mode 100644 index ef8dc501af..0000000000 --- a/tests/tbs/tbs0099.pp +++ /dev/null @@ -1,7 +0,0 @@ - -{$R+} -var w:word; - s:Shortint; -begin - w := s; -end. diff --git a/tests/tbs/tbs0102.pp b/tests/tbs/tbs0102.pp deleted file mode 100644 index cc567c5574..0000000000 --- a/tests/tbs/tbs0102.pp +++ /dev/null @@ -1,19 +0,0 @@ -{ assembler reader of m68k for register ranges } - -unit tbs0102; - interface - - implementation - -{$ifdef M68K} - procedure int_help_constructor; - - begin - asm - movem.l d0-a7,-(sp) - end; - end; -{$endif M68K} - - - end. diff --git a/tests/tbs/tbs0103.pp b/tests/tbs/tbs0103.pp deleted file mode 100644 index d8eb8ecdbf..0000000000 --- a/tests/tbs/tbs0103.pp +++ /dev/null @@ -1,8 +0,0 @@ - -Var - out: boolean; - int: byte; -Begin - { savesize is different! } - out:=boolean((int AND $20) SHL 4); -end. diff --git a/tests/tbs/tbs0104.pp b/tests/tbs/tbs0104.pp deleted file mode 100644 index 8a50315e7b..0000000000 --- a/tests/tbs/tbs0104.pp +++ /dev/null @@ -1,16 +0,0 @@ -{$ifdef go32v2} -uses - dpmiexcp; -{$endif} - -{ Two cardinal type bugs } -var - c : cardinal; -begin - c:=$80000000; - writeln(c); - c:=$80001234; - writeln(c); - c:=$ffffffff; - writeln(c); -end. diff --git a/tests/tbs/tbs0105.pp b/tests/tbs/tbs0105.pp deleted file mode 100644 index d48e72950f..0000000000 --- a/tests/tbs/tbs0105.pp +++ /dev/null @@ -1,46 +0,0 @@ -{$ifdef go32v2} -{$define OK} -{$endif} -{$ifdef linux} -{$define OK} -{$endif} - -{ Win32 signal support is still missing ! } - -{$ifdef OK} - -{$ifdef go32v2} - uses dpmiexcp; -{$endif go32v2} -{$ifdef linux} - uses linux; -{$endif linux} - - function our_sig(l : longint) : longint;{$ifdef linux}cdecl;{$endif} - begin - { If we land here the program works correctly !! } - Writeln('Sigsegv signal recieved'); - our_sig:=0; - Halt(0); - end; - -Var - Sel: Word; - v: pointer; -{$endif OK} -Begin -{$ifdef OK} - Signal(SIGSEGV,signalhandler(@our_sig)); - { generate a sigsegv by writing to null-address } - sel:=0; - v:=nil; -{$ifdef go32v2} - { on win9X no zero page protection :( } - v:=pointer(-2); -{$endif go32v2} - word(v^):=sel; - { we should not go to here } - Writeln('Error : signal not called'); - Halt(1); -{$endif OK} -end. \ No newline at end of file diff --git a/tests/tbs/tbs0106.pp b/tests/tbs/tbs0106.pp deleted file mode 100644 index 44b917ce2b..0000000000 --- a/tests/tbs/tbs0106.pp +++ /dev/null @@ -1,12 +0,0 @@ -{$R-} - -{ I think this now occurs with most type casting... } -{ I think type casting is no longer considered?? } - -Var - Sel: Word; - Sel2: byte; -Begin - Sel:=word($7fffffff); - Sel2:=byte($7fff); -end. \ No newline at end of file diff --git a/tests/tbs/tbs0107.pp b/tests/tbs/tbs0107.pp deleted file mode 100644 index 157cb7f3df..0000000000 --- a/tests/tbs/tbs0107.pp +++ /dev/null @@ -1,31 +0,0 @@ -{ PAGE FAULT PROBLEM ... TEST UNDER DOS ONLY! Not windows... } -{ -Cr -g flags } - -Program Test1; - -{$ifdef go32v2} -uses - dpmiexcp; -{$endif} - -type - myObject = object - constructor init; - procedure v;virtual; - end; - - constructor myobject.init; - Begin - end; - - procedure myobject.v; - Begin - WriteLn('Hello....'); - end; - -var - my: myobject; -Begin - my.init; - my.v; -end. diff --git a/tests/tbs/tbs0109.pp b/tests/tbs/tbs0109.pp deleted file mode 100644 index 62c5b51107..0000000000 --- a/tests/tbs/tbs0109.pp +++ /dev/null @@ -1,9 +0,0 @@ -Type T = (aa,bb,cc,dd,ee,ff,gg,hh); - Tset = set of t; - -Var a: Tset; - -Begin - If (aa in a) Then begin end; - {it seems that correct code is generated, but the syntax is wrong} -End. diff --git a/tests/tbs/tbs0111.pp b/tests/tbs/tbs0111.pp deleted file mode 100644 index 35ee1280a9..0000000000 --- a/tests/tbs/tbs0111.pp +++ /dev/null @@ -1,20 +0,0 @@ -var - ft : text; - f : file of word; - i : word; - buf : string; -begin - assign(ft,'tbs0111.tmp'); - rewrite(ft); - for i:=1 to 40 do - Writeln(ft,'Dummy text to test bug 111'); - close(ft); - assign(f,'tbs0111.tmp'); - reset(f); - blockread(f,buf[1],127,i); { This is not allowed in BP7 } - buf[0]:=chr(i*2); - close(f); - writeln(i); - writeln(buf); - erase(f); -end. diff --git a/tests/tbs/tbs0112.pp b/tests/tbs/tbs0112.pp deleted file mode 100644 index 6b55c64e00..0000000000 --- a/tests/tbs/tbs0112.pp +++ /dev/null @@ -1,21 +0,0 @@ -type - TextBuf=array[0..127] of char; - TextRec=record - BufPtr : ^textbuf; - BufPos : word; - end; - -Function ReadNumeric(var f:TextRec;var s:string;base:longint):Boolean; -{ - Read Numeric Input, if buffer is empty then return True -} -begin - while ((base>=10) and (f.BufPtr^[f.BufPos] in ['0'..'9'])) or - ((base=16) and (f.BufPtr^[f.BufPos] in ['A'..'F'])) or - ((base=2) and (f.BufPtr^[f.BufPos] in ['0'..'1'])) do - Begin - End; -end; - -begin -end. diff --git a/tests/tbs/tbs0113.pp b/tests/tbs/tbs0113.pp deleted file mode 100644 index 05ebf08e65..0000000000 --- a/tests/tbs/tbs0113.pp +++ /dev/null @@ -1,13 +0,0 @@ -program test; - -type pRecord = ^aRecord; - aRecord = record - next : pRecord; - a, b, c : integer; - end; - -const rec1 : aRecord = (next : nil; a : 10; b : 20; c : 30); - rec2 : aRecord = (next : @rec1; a : 20; b : 30; c : 40); - -begin -end. diff --git a/tests/tbs/tbs0114.pp b/tests/tbs/tbs0114.pp deleted file mode 100644 index 534d6c6a1c..0000000000 --- a/tests/tbs/tbs0114.pp +++ /dev/null @@ -1,3 +0,0 @@ -begin - write{ln}(0.997:0:2); -end. diff --git a/tests/tbs/tbs0115.pp b/tests/tbs/tbs0115.pp deleted file mode 100644 index a75854e3e5..0000000000 --- a/tests/tbs/tbs0115.pp +++ /dev/null @@ -1,11 +0,0 @@ -var - c : comp; - -begin - c:=1234; - writeln(c); - {readln(c);} - c:=-258674; - writeln(c); -end. - diff --git a/tests/tbs/tbs0116.pp b/tests/tbs/tbs0116.pp deleted file mode 100644 index 478aaf4f33..0000000000 --- a/tests/tbs/tbs0116.pp +++ /dev/null @@ -1,9 +0,0 @@ -Procedure test; -{compile with -Og to show bug} - -Var a: Array[1..4000000] of longint; -Begin -End; - -Begin -End. diff --git a/tests/tbs/tbs0118.pp b/tests/tbs/tbs0118.pp deleted file mode 100644 index 342eb8128e..0000000000 --- a/tests/tbs/tbs0118.pp +++ /dev/null @@ -1,11 +0,0 @@ -program Test1; - - type - ExampleProc = procedure; - - var - Eg: ExampleProc; - - begin - Eg := nil; { This produces a compiler error } - end. diff --git a/tests/tbs/tbs0119.pp b/tests/tbs/tbs0119.pp deleted file mode 100644 index e0a55dfd9d..0000000000 --- a/tests/tbs/tbs0119.pp +++ /dev/null @@ -1,44 +0,0 @@ -program ObjTest; - uses crt; - - type - ObjectA = object - procedure Greetings; - procedure DoIt; - end; - ObjectB = object (ObjectA) - procedure Greetings; - procedure DoIt; - end; - - procedure ObjectA.Greetings; - begin - writeln(' A'); - end; - procedure ObjectA.DoIt; - begin - writeln('A '); - Greetings; - end; - - procedure ObjectB.Greetings; - begin - writeln(' B'); - end; - procedure ObjectB.DoIt; - begin - writeln('B'); - Greetings; - end; - - var - A: ObjectA; - B: ObjectB; - - begin - A.DoIt; - B.DoIt; - writeln; writeln('Now doing it directly:'); - A.Greetings; - B.Greetings; - end. \ No newline at end of file diff --git a/tests/tbs/tbs0120.pp b/tests/tbs/tbs0120.pp deleted file mode 100644 index 4ea15dbacd..0000000000 --- a/tests/tbs/tbs0120.pp +++ /dev/null @@ -1,14 +0,0 @@ -type - te = (enum1,enum2,enum3); - -var - e,f : te; - -begin - e:=enum1; - inc(e); - f:=enum3; - dec(f); - if e<>f then - halt(1); -end. diff --git a/tests/tbs/tbs0121.pp b/tests/tbs/tbs0121.pp deleted file mode 100644 index ac832db053..0000000000 --- a/tests/tbs/tbs0121.pp +++ /dev/null @@ -1,18 +0,0 @@ -{$R+} -var - - c : cardinal; - i : integer; - w : word; - b : byte; - si : shortint; - -begin - w:=c; - i:=c; - b:=c; - b:=si; -end. - - - diff --git a/tests/tbs/tbs0122.pp b/tests/tbs/tbs0122.pp deleted file mode 100644 index b542780b5b..0000000000 --- a/tests/tbs/tbs0122.pp +++ /dev/null @@ -1,9 +0,0 @@ - -function f:longint; -begin - exit(1); -end; - -begin - writeln(f); -end. diff --git a/tests/tbs/tbs0123.pp b/tests/tbs/tbs0123.pp deleted file mode 100644 index 90bf6c9541..0000000000 --- a/tests/tbs/tbs0123.pp +++ /dev/null @@ -1,18 +0,0 @@ -{ bug for shrd assemblerreader } -begin - if false then - begin -{$asmmode intel} - asm - SHRD [ESI-8], EAX, CL - SHLD EBX,ECX,5 - IMUL ECX,dword [EBP-8],5 - end; -{$asmmode att} - asm - shrdl %cl,%eax,-8(%esi) - shldl $5,%ecx,%ebx - imull $5,-8(%ebp),%ecx - end; - end; -end. diff --git a/tests/tbs/tbs0124.pp b/tests/tbs/tbs0124.pp deleted file mode 100644 index e124ebdca6..0000000000 --- a/tests/tbs/tbs0124.pp +++ /dev/null @@ -1,41 +0,0 @@ -{ $OPT= -Aas } -{ this problem comes from the fact that - L is a static variable, not a local one !! - but the static variable symtable is the localst of the - main procedure (PM) - It must be checked if we are at main level or not !! } - -var - l : longint; - - procedure error; - begin - Writeln('Error in tbs0124'); - Halt(1); - end; - -begin -{$asmmode direct} - asm - movl $5,l - end; - if l<>5 then error; -{$asmmode att} - asm - movl l,%eax - addl $2,%eax - movl %eax,l - end; - if l<>7 then error; -{$asmmode intel} - { problem here is that l is replaced by BP-offset } - { relative to stack, and the parser thinks all wrong } - { because of this. } - asm - mov eax,l - add eax,5 - mov l,eax - end; - if l<>12 then error; - Writeln('tbs0124 OK'); -end. diff --git a/tests/tbs/tbs0124b.pp b/tests/tbs/tbs0124b.pp deleted file mode 100644 index e051b7bb6f..0000000000 --- a/tests/tbs/tbs0124b.pp +++ /dev/null @@ -1,21 +0,0 @@ -{$asmmode intel} -var - i : byte; - l : array[0..7] of longint; -begin - { problem here is that l is replaced by BP-offset } - { relative to stack, and the parser thinks all wrong } - { because of this. } - - for i:=0 to 7 do - l[i]:=35; - asm - mov eax,3 - mov l[eax*4],55 - end; - if l[3]<>55 then - begin - Writeln('Error in parsing assembler'); - Halt(1); - end; -end. diff --git a/tests/tbs/tbs0125.pp b/tests/tbs/tbs0125.pp deleted file mode 100644 index 7b117500dd..0000000000 --- a/tests/tbs/tbs0125.pp +++ /dev/null @@ -1,12 +0,0 @@ -uses -crt; -var -i:integer; -begin -clrscr; -textcolor(blue); -writeln('ole'); -textcolor(red); -writeln('rasmussen'); -writeln(i); -end. diff --git a/tests/tbs/tbs0126.pp b/tests/tbs/tbs0126.pp deleted file mode 100644 index 0aeec2e852..0000000000 --- a/tests/tbs/tbs0126.pp +++ /dev/null @@ -1,5 +0,0 @@ -type - myarray = packed array[0..10] of longint; - -begin -end. diff --git a/tests/tbs/tbs0128.pp b/tests/tbs/tbs0128.pp deleted file mode 100644 index f8b2881421..0000000000 --- a/tests/tbs/tbs0128.pp +++ /dev/null @@ -1,9 +0,0 @@ -{ ^ followed by a letter must be interpreted differently - depending on context } - -const - ArrowKeysOrFirstLetter='arrow keys '^]^r^z' or First letter. '; - -begin - writeln(ord(^))); -end. diff --git a/tests/tbs/tbs0129.pp b/tests/tbs/tbs0129.pp deleted file mode 100644 index 6e139e845d..0000000000 --- a/tests/tbs/tbs0129.pp +++ /dev/null @@ -1,12 +0,0 @@ -var - e:boolean; - a:integer; -begin - e:=true; - a:=3; - while (a<5) and e do begin - e:=false; - write('*'); - continue; - end; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0130.pp b/tests/tbs/tbs0130.pp deleted file mode 100644 index ea807c8b2b..0000000000 --- a/tests/tbs/tbs0130.pp +++ /dev/null @@ -1,11 +0,0 @@ -var - c : char; -begin - c:=#91; - if c in [#64..#255] then - writeln('boe'); - c:=#32; - if c in [#64..#255] then - writeln('boe'); -end. - diff --git a/tests/tbs/tbs0131.pp b/tests/tbs/tbs0131.pp deleted file mode 100644 index c80aec4c2e..0000000000 --- a/tests/tbs/tbs0131.pp +++ /dev/null @@ -1,11 +0,0 @@ -type TA = Array[1..2,1..2,1..2,1..2,1..2,1..2,1..3,1..3,1..3,1..3] of Byte; - -var v,w: ta; - e: longint; - -Begin - e :=1; - v[e,e,e,e,e,e,e,e,e,e] :=1; - w[e,e,e,e,e,e,v[e,e,e,e,e,e,e,e,e,e],e,e,v[e,e,e,e,e,e,v[e,v[e,e,e,e,e,v[e,e,e,e,e,e,e,e,e,e],e,e,e,e],e,e,e,e,e,e,e,e],e,e,e]] := v [e,e,e,e,e,e,e,e,e,e]; - writeln(w[e,e,e,e,e,e,e,e,e,e]) -end. diff --git a/tests/tbs/tbs0132.pp b/tests/tbs/tbs0132.pp deleted file mode 100644 index 22a6f7973a..0000000000 --- a/tests/tbs/tbs0132.pp +++ /dev/null @@ -1,13 +0,0 @@ -type - - p=^p2; - p2 = ^p; - - var a:p; - a2:p2; - - begin - a:=@a2; - a2:=@a; - a:=a2^; - end. \ No newline at end of file diff --git a/tests/tbs/tbs0133.pp b/tests/tbs/tbs0133.pp deleted file mode 100644 index 5a6edb52ca..0000000000 --- a/tests/tbs/tbs0133.pp +++ /dev/null @@ -1,14 +0,0 @@ -type - t=object - f : longint; - procedure p; - g : longint; { Not allowed in BP7 } - end; - - procedure t.p; - begin - end; - - begin - end. - diff --git a/tests/tbs/tbs0134.pp b/tests/tbs/tbs0134.pp deleted file mode 100644 index 93b73231f4..0000000000 --- a/tests/tbs/tbs0134.pp +++ /dev/null @@ -1,31 +0,0 @@ -{ -In this simple examply, the even loop is wrong. When continue; is called, -it should go back to the top and check the loop conditions and exit when i = -4, but continue skips checking the loop conditions and does i=5 too, then it -is odd, doesn't run the continue, and the loop terminates properly. -} - - -procedure demoloop( max:integer ); -var i : integer; -begin -i := 1; -while (i <= max) do - begin - if (i mod 2 = 0) then - begin - writeln('Even ',i,' of ',max); - inc(i); - continue; - end; - writeln('Odd ',i,' of ',max); - inc(i); - end; -end; - -begin -writeln('Odd loop (continue is *not* last call):'); -demoloop(3); -writeln('Even loop (continue is last call):'); -demoloop(4); -end. diff --git a/tests/tbs/tbs0135.pp b/tests/tbs/tbs0135.pp deleted file mode 100644 index cce05b52d4..0000000000 --- a/tests/tbs/tbs0135.pp +++ /dev/null @@ -1,10 +0,0 @@ -program test; -const - A = 0; - B = 1; - C = 2; - -type D = A..C; - -begin -end. \ No newline at end of file diff --git a/tests/tbs/tbs0137.pp b/tests/tbs/tbs0137.pp deleted file mode 100644 index c9650b8651..0000000000 --- a/tests/tbs/tbs0137.pp +++ /dev/null @@ -1,45 +0,0 @@ -program OO_Test; - -Type TVater = Object - Constructor Init; - Procedure Gehen; Virtual; - Procedure Laufen; Virtual; - End; - - TSohn = Object(TVater) - Procedure Gehen; Virtual; - End; - -Var V : TVater; - S : TSohn; - -Constructor TVater.Init; -Begin -End; - -Procedure TVater.Gehen; -Begin - Writeln('langsam gehen'); -End; - -Procedure TVater.Laufen; -Begin - Gehen; - Gehen; -End; - -Procedure TSohn.Gehen; -Begin - Writeln('schnell gehen'); -End; - -Begin - V.Init; - S.Init; - V.Laufen; - Writeln; - S.Laufen; - Writeln; - V := S; - V.Gehen; -End. diff --git a/tests/tbs/tbs0138.pp b/tests/tbs/tbs0138.pp deleted file mode 100644 index 3a3dc9cd1f..0000000000 --- a/tests/tbs/tbs0138.pp +++ /dev/null @@ -1,35 +0,0 @@ -{program p; uncomment for a crash} -type - tpt=^tpo; - tpo=object - constructor init; - procedure pi1; - procedure pi2; - end; -constructor tpo.init; -begin -end; -procedure tpo.pi1; -begin -end; -procedure tpo.pi2; -begin -end; -procedure crushesi;assembler; -asm - movl %eax,%esi -end ['EAX','ESI']; -var - p1 : tpt; -begin - p1:=new(tpt,init); - with p1^ do - begin - pi1; - crushesi; { After this the %esi should be reloaded from the tempvariable } - pi1; - end; -{ There is here already a tempvar for %esi, why not use it here too ? } - p1^.pi2; - p1^.pi2; -end. diff --git a/tests/tbs/tbs0139.pp b/tests/tbs/tbs0139.pp deleted file mode 100644 index 1addc2f1fc..0000000000 --- a/tests/tbs/tbs0139.pp +++ /dev/null @@ -1,23 +0,0 @@ -unit tbs0139; - -{$mode objfpc} - - interface - uses - tbs0139a; - - type - AnotherClass=class(SomeClass) - protected - procedure doSomething; override; - end ; - - implementation - - procedure AnotherClass.doSomething; - begin - inherited doSomething; // this causes the error: " can not call protected - // method from here " ( or something similar ) - end ; - -end. \ No newline at end of file diff --git a/tests/tbs/tbs0139a.pp b/tests/tbs/tbs0139a.pp deleted file mode 100644 index b4ae7e986d..0000000000 --- a/tests/tbs/tbs0139a.pp +++ /dev/null @@ -1,21 +0,0 @@ - unit tbs0139a; - -{$mode objfpc} - - interface - - type - SomeClass=class(TObject) - protected - procedure doSomething; virtual; - end ; - - implementation - - - procedure SomeClass.doSomething; - begin - Writeln ('Hello from SomeClass.DoSomething'); - end ; - -end. \ No newline at end of file diff --git a/tests/tbs/tbs0140.pp b/tests/tbs/tbs0140.pp deleted file mode 100644 index e5e696ee95..0000000000 --- a/tests/tbs/tbs0140.pp +++ /dev/null @@ -1,21 +0,0 @@ -unit tbs0140; - -{ - The first compilation runs fine. - A second compilation (i.e; .ppu files exist already) crashes the compiler !! -} - -interface -type - TObject = object - constructor Init(aPar:byte); - end; -implementation - -uses tbs0140a; - -constructor TObject.Init(aPar:byte); - begin - if aPar=0 then Message(Self); - end; -end. diff --git a/tests/tbs/tbs0140a.pp b/tests/tbs/tbs0140a.pp deleted file mode 100644 index 43299014a1..0000000000 --- a/tests/tbs/tbs0140a.pp +++ /dev/null @@ -1,14 +0,0 @@ - -unit tbs0140a; - -interface - -uses tbs0140; - -procedure Message(var O:TObject); - -implementation - -procedure Message(var O:TObject); - begin writeln('Message') end; -end. diff --git a/tests/tbs/tbs0141.pp b/tests/tbs/tbs0141.pp deleted file mode 100644 index 19f4fe3866..0000000000 --- a/tests/tbs/tbs0141.pp +++ /dev/null @@ -1,67 +0,0 @@ -{ $OPT= -S2 } -program bug; - -{ uses objpas; not with -S2 !! } -type - // - TObjectAB = class; - TObjectABCD = class; - TObjectABCDEF = class; - // } - TObjectAB = class(tobject) - a, b: integer; - end ; - TObjectABCD = class(TObjectAB) - c, d: integer; - end ; - TObjectABCDEF = class(TObjectABCD) - e, f: integer; - end ; - -var - a, b, c: TObject; - -begin -a := TObjectAB.Create; -WriteLn(a.InstanceSize, ' Should be: 12'); -if a.InstanceSize + SizeOf(integer)*2 <> TObjectABCD.InstanceSize then - Halt(1); -b := TObjectABCD.Create; -if b.InstanceSize + SizeOf(integer)*2 <> TObjectABCDEF.InstanceSize then - Halt(1); -WriteLn(b.InstanceSize, ' Should be: 20'); -c := TObjectABCDEF.Create; -WriteLn(c.InstanceSize, ' Should be: 28'); -end. - -{ -Here are the VMT tables from the assembler file: - -.globl VMT_TD$_TOBJECTAB -VMT_TD$_TOBJECTAB: - .long 12,-12 - .long VMT_OBJPAS$_TOBJECT - .long _OBJPAS$$_$$_TOBJECT_DESTROY - .long _OBJPAS$$_$$_TOBJECT_NEWINSTANCE - .long _OBJPAS$$_$$_TOBJECT_FREEINSTANCE - .long _OBJPAS$$_$$_TOBJECT_SAFECALLEXCEPTION$TOBJECT$POINTER - .long _OBJPAS$$_$$_TOBJECT_DEFAULTHANDLER$$$$ -.globl VMT_TD$_TOBJECTABCD -VMT_TD$_TOBJECTABCD: - .long 12,-12 - .long VMT_TD$_TOBJECTAB - .long _OBJPAS$$_$$_TOBJECT_DESTROY - .long _OBJPAS$$_$$_TOBJECT_NEWINSTANCE - .long _OBJPAS$$_$$_TOBJECT_FREEINSTANCE - .long _OBJPAS$$_$$_TOBJECT_SAFECALLEXCEPTION$TOBJECT$POINTER - .long _OBJPAS$$_$$_TOBJECT_DEFAULTHANDLER$$$$ -.globl VMT_TD$_TOBJECTABCDEF -VMT_TD$_TOBJECTABCDEF: - .long 12,-12 - .long VMT_TD$_TOBJECTABCD - .long _OBJPAS$$_$$_TOBJECT_DESTROY - .long _OBJPAS$$_$$_TOBJECT_NEWINSTANCE - .long _OBJPAS$$_$$_TOBJECT_FREEINSTANCE - .long _OBJPAS$$_$$_TOBJECT_SAFECALLEXCEPTION$TOBJECT$POINTER - .long _OBJPAS$$_$$_TOBJECT_DEFAULTHANDLER$$$$ -} \ No newline at end of file diff --git a/tests/tbs/tbs0142.pp b/tests/tbs/tbs0142.pp deleted file mode 100644 index 1e5b7b3583..0000000000 --- a/tests/tbs/tbs0142.pp +++ /dev/null @@ -1,13 +0,0 @@ - -{$PACKRECORDS 1} - -type -Time = object - h,m,s:byte; -end; - -var OT:Time; - l : longint; -begin - l:=SizeOf(OT); -end. diff --git a/tests/tbs/tbs0143.pp b/tests/tbs/tbs0143.pp deleted file mode 100644 index 99eed1cc56..0000000000 --- a/tests/tbs/tbs0143.pp +++ /dev/null @@ -1,11 +0,0 @@ - - -const - string1 : string = 'hello '; - string2 : array[1..5] of char = 'there'; -var - s : string; -begin - s:=string1+string2; - writeln(string1+string2); -end. \ No newline at end of file diff --git a/tests/tbs/tbs0144.pp b/tests/tbs/tbs0144.pp deleted file mode 100644 index 9584c3d80b..0000000000 --- a/tests/tbs/tbs0144.pp +++ /dev/null @@ -1,21 +0,0 @@ -program done_bug; - -type -TObject = object - Constructor Init; - Destructor Done; -end; -PObject = ^TObject; - -Constructor TObject.Init; -begin end; -Destructor TObject.Done; -begin end; - -var P:PObject; - -begin -New(P,Init); -with P^ do Done; { Compiler PANIC here ! } -Dispose(P); -end. diff --git a/tests/tbs/tbs0145.pp b/tests/tbs/tbs0145.pp deleted file mode 100644 index 5c199b0671..0000000000 --- a/tests/tbs/tbs0145.pp +++ /dev/null @@ -1,30 +0,0 @@ -{$I+} -const - Mb=512; - siz=1024*Mb; - -type - buf=array[1..siz] of byte; - -var - fin, - fout : file of buf; - b1,a1 : buf; - -begin - fillchar(a1,sizeof(a1),1); - assign(fout,'tmp.tmp'); - rewrite(fout); - write(fout,a1); - close(fout); - - assign(fin,'tmp.tmp'); - reset(fin); - read(fin,b1); - close(fin); - if not b1[512*Mb]=1 then - begin - writeln('data err'); - Halt(1); - end; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0146.pp b/tests/tbs/tbs0146.pp deleted file mode 100644 index acfdff2c40..0000000000 --- a/tests/tbs/tbs0146.pp +++ /dev/null @@ -1,14 +0,0 @@ - -procedure myfunction(var t : array of char); -begin - writeln(sizeof(t)); { should be 51 } - if sizeof(t)<>51 then halt(1); -end; - -var - mycharstring : array[0..50] of char; - -begin - myfunction(mycharstring); - if sizeof(mycharstring)<>51 then halt(1); -end. diff --git a/tests/tbs/tbs0147.pp b/tests/tbs/tbs0147.pp deleted file mode 100644 index 63d4a70146..0000000000 --- a/tests/tbs/tbs0147.pp +++ /dev/null @@ -1,13 +0,0 @@ -{ $OPT= -So } -unit tbs0147; -interface - -function b:boolean; - -implementation - -function b; -begin -end; - -end. diff --git a/tests/tbs/tbs0149a.pp b/tests/tbs/tbs0149a.pp deleted file mode 100644 index 74edc4098b..0000000000 --- a/tests/tbs/tbs0149a.pp +++ /dev/null @@ -1,10 +0,0 @@ -unit tbs0149a; - -interface - -Const tset = [1,2,3,4,5]; - c = 1; - -implementation - -end. diff --git a/tests/tbs/tbs0149b.pp b/tests/tbs/tbs0149b.pp deleted file mode 100644 index 8b6d188951..0000000000 --- a/tests/tbs/tbs0149b.pp +++ /dev/null @@ -1,25 +0,0 @@ -{there is no crash when tset or c from unit a are used in OuterProcedure, - it's only a problem when using them in a nested procedure/function} - -unit tbs0149b; - -interface - -uses tbs0149a; - -implementation - -Procedure OuterProcedure; - - function t(a: byte): byte; - begin - if a = c then t := a else t := 0; - if a in tset {probably same bug} - then t := a - else t := 0 - end; - -Begin -End; - -end. diff --git a/tests/tbs/tbs0150.pp b/tests/tbs/tbs0150.pp deleted file mode 100644 index 9eac064419..0000000000 --- a/tests/tbs/tbs0150.pp +++ /dev/null @@ -1,27 +0,0 @@ -program bug0150; -{ - bug to show that there is no assert() macro and directive -} - -var B : boolean; - i : integer; - -begin - b:=true; - i:=0; - // First for assert messages should not give anything. - // First two generate code, but are OK. - // second two don't generate code ($C- !) -{$c+} - assert (b); - assert (I=0); -{$c-} - assert (not(b)); - assert (i<>0); -{$c+} - // This one should give the normal assert message. - assert (not(b)); - // This one should give a custom assert message. - // you must uncomment the previous one to see this one. - assert (not(I=0),'Custom assert message'); -end. diff --git a/tests/tbs/tbs0152.pp b/tests/tbs/tbs0152.pp deleted file mode 100644 index 044647a3b7..0000000000 --- a/tests/tbs/tbs0152.pp +++ /dev/null @@ -1,36 +0,0 @@ -Program tbs0152; - -{ - Shows wrong evaluation of loop boundaries. First end boundary must - be calculated, only then Loop variable should be initialized. - Change loop variable to J to see what should be the correct output. -} - -PROCEDURE LGrow(VAR S : String;C:CHAR;Count:WORD); - - VAR I,J :WORD; - -BEGIN - I:=ORD(S[0]); { Keeping length in local data eases optimalisations} - IF I'1111111abcedfghij' then - begin - writeln('tbs0152 fails'); - halt(1); - end; -end. diff --git a/tests/tbs/tbs0154.pp b/tests/tbs/tbs0154.pp deleted file mode 100644 index 2b4288dab6..0000000000 --- a/tests/tbs/tbs0154.pp +++ /dev/null @@ -1,8 +0,0 @@ -type - week=(mon,tue,wed); -Var - w : week; - w1 : mon..tue; -begin - w1:=w; -end. diff --git a/tests/tbs/tbs0156a.pp b/tests/tbs/tbs0156a.pp deleted file mode 100644 index 4e13e85455..0000000000 --- a/tests/tbs/tbs0156a.pp +++ /dev/null @@ -1,4 +0,0 @@ -uses tbs0156b; - -begin -end. diff --git a/tests/tbs/tbs0156b.pp b/tests/tbs/tbs0156b.pp deleted file mode 100644 index b43a908aa8..0000000000 --- a/tests/tbs/tbs0156b.pp +++ /dev/null @@ -1,12 +0,0 @@ -unit tbs0156b; -interface - -type - _win_st = record - _parent : ^WINDOW; - end; - WINDOW = _win_st; - -implementation - -end. \ No newline at end of file diff --git a/tests/tbs/tbs0157.pp b/tests/tbs/tbs0157.pp deleted file mode 100644 index 8916e719fc..0000000000 --- a/tests/tbs/tbs0157.pp +++ /dev/null @@ -1,10 +0,0 @@ -{ this should be rejected because we only accept integer args } - -program write_it; -var x,y:real; -begin -x:=5.6; -y:=45.789; -write(y:2:3,x:3:4); -{write(y:3.2,x:5.2);} -end. diff --git a/tests/tbs/tbs0159.pp b/tests/tbs/tbs0159.pp deleted file mode 100644 index 50ae20032c..0000000000 --- a/tests/tbs/tbs0159.pp +++ /dev/null @@ -1,22 +0,0 @@ -Type TParent = Object - Procedure SomeProc; - end; - - TChild = Object(TParent) - Procedure SomeProc; virtual; - end; - - - Procedure TParent.someproc; - Begin - end; - - - procedure TChild.Someproc; - Begin - end; - - - -Begin -end. \ No newline at end of file diff --git a/tests/tbs/tbs0160.pp b/tests/tbs/tbs0160.pp deleted file mode 100644 index 9909d55e3f..0000000000 --- a/tests/tbs/tbs0160.pp +++ /dev/null @@ -1,16 +0,0 @@ -program xxxx; - -procedure yyyy; - -var self:word; - -begin -end; - -procedure self; - -begin -end; - -begin -end. diff --git a/tests/tbs/tbs0162.pp b/tests/tbs/tbs0162.pp deleted file mode 100644 index f192e48ea6..0000000000 --- a/tests/tbs/tbs0162.pp +++ /dev/null @@ -1,10 +0,0 @@ -var - i : longint; - -begin - i:=1; - repeat - continue; - until i=1; -end. - diff --git a/tests/tbs/tbs0163.pp b/tests/tbs/tbs0163.pp deleted file mode 100644 index 87b94ec0ee..0000000000 --- a/tests/tbs/tbs0163.pp +++ /dev/null @@ -1,16 +0,0 @@ -Program test; - -{ shows missing <= and >= for sets } - -Type - Days = (Monday,tuesday,wednesday,thursday,friday,saturday,sunday); - -Var - FreeDays,Weekend : set of days; - -begin - Weekend := [saturday, sunday]; - FreeDays := [friday, saturday, sunday]; - If (Weekend <= Freedays) then - Writeln ('Free in weekend !'); -end. diff --git a/tests/tbs/tbs0164.pp b/tests/tbs/tbs0164.pp deleted file mode 100644 index 17a2ee7a01..0000000000 --- a/tests/tbs/tbs0164.pp +++ /dev/null @@ -1,17 +0,0 @@ -type t1r = record - a, b: Byte; - end; - t2r = record - l1, l2: Array[1..4] Of t1r; - end; - - -Var r: t2r; - counter : byte; - -begin - counter:=2; - - with r.l1[counter] Do - Inc(a) -end. diff --git a/tests/tbs/tbs0165.pp b/tests/tbs/tbs0165.pp deleted file mode 100644 index 530dbc329c..0000000000 --- a/tests/tbs/tbs0165.pp +++ /dev/null @@ -1,19 +0,0 @@ -{$R+} -Program bug0165; - -uses - erroru; - -{ No range check when -Cr given} - -Type Directions = (North, East,South,West); - -Var Go : Directions; - - -begin - Require_Error(201); - Go:=North; - Go:=Pred(Go); { must give run-time error } - Go:=Pred(North); { must give compile time error } -end. diff --git a/tests/tbs/tbs0169.pp b/tests/tbs/tbs0169.pp deleted file mode 100644 index f8ae052951..0000000000 --- a/tests/tbs/tbs0169.pp +++ /dev/null @@ -1,12 +0,0 @@ -type - psearchrec=^longint; - -Var Sr : PSearchrec; - -begin - Sr := New(PSearchRec); - Sr^ := 45; - if Sr^<>45 then - Halt(1); - Dispose(Sr); -end. diff --git a/tests/tbs/tbs0170.pp b/tests/tbs/tbs0170.pp deleted file mode 100644 index c3d528868c..0000000000 --- a/tests/tbs/tbs0170.pp +++ /dev/null @@ -1,13 +0,0 @@ -procedure free1; -begin -end; - -procedure free2; -begin -end; - -begin -asm - call {$ifdef dummy}free1{$else}free2{$endif} -end; -end. diff --git a/tests/tbs/tbs0171.pp b/tests/tbs/tbs0171.pp deleted file mode 100644 index f79828337b..0000000000 --- a/tests/tbs/tbs0171.pp +++ /dev/null @@ -1,12 +0,0 @@ -type - pstring=^string; -const - drivestr:string='c:'; - pdrivestr:pstring=pstring(@drivestr); -begin - if pdrivestr^<>'c:' then - begin - Writeln('Error in typecast of const'); - Halt(1); - end; -end. diff --git a/tests/tbs/tbs0174.pp b/tests/tbs/tbs0174.pp deleted file mode 100644 index 1f6a298fda..0000000000 --- a/tests/tbs/tbs0174.pp +++ /dev/null @@ -1,19 +0,0 @@ -{$ASMMODE ATT} - -type - tobj=object - l : longint; - end; -var - t : tobj; - -procedure kl;assembler; -asm - movl tobj.l,%eax // tobj.l should return the offset of l in tobj -end; - - -begin -end. - - diff --git a/tests/tbs/tbs0175.pp b/tests/tbs/tbs0175.pp deleted file mode 100644 index 48c216aae5..0000000000 --- a/tests/tbs/tbs0175.pp +++ /dev/null @@ -1,10 +0,0 @@ -{ this will just give out a warning } -{$asmmode att} -{$R-} -var - w : word; -begin - asm - movl w,%ecx - end; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0176.pp b/tests/tbs/tbs0176.pp deleted file mode 100644 index b54d30fe93..0000000000 --- a/tests/tbs/tbs0176.pp +++ /dev/null @@ -1,17 +0,0 @@ -{ $OPT= -Un } -{ no unit name checking !! } -unit bug0176; -interface - -var - l1 : longint; - -implementation - -var - l2 : longint; - -begin - bug0176.l1:=1; - bug0176.l2:=1; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0177.pp b/tests/tbs/tbs0177.pp deleted file mode 100644 index 01db6b1575..0000000000 --- a/tests/tbs/tbs0177.pp +++ /dev/null @@ -1,6 +0,0 @@ -program p; -var - l : longint; -begin - p.l:=1; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0178.pp b/tests/tbs/tbs0178.pp deleted file mode 100644 index c3022545e3..0000000000 --- a/tests/tbs/tbs0178.pp +++ /dev/null @@ -1,64 +0,0 @@ -{ $OPT=-Sg} -PROGRAM NoLabel; { this program compiles fine with TP but not with FP } - - type - ptestobj = ^ttestobj; - ttestobj = object - constructor init; - procedure test_self; - end; - - const - allowed : boolean = false; - - constructor ttestobj.init; - begin - if not allowed then - fail; - end; - procedure ttestobj.test_self; - function myself : ptestobj; - begin - myself:=@self; - end; - - begin - if myself<>@self then - begin - Writeln('problem with self'); - Halt(1); - end; - end; - - -LABEL - N1, - N2, - FAIL, { this is a reserved word in constructors only! - FP fails here -} - More; { label not defined - FP fails, but a warning is enough for that -} - { since label referenced nowhere } - var ptest : ptestobj; - self : longint; -BEGIN - new(ptest,init); - if ptest<>nil then - begin - Writeln('Fail does not work !!'); - Halt(1); - end; - allowed:=true; - new(ptest,init); - if ptest=nil then - begin - Writeln('Constructor does not work !!'); - Halt(1); - end - else - ptest^.test_self; - N1: Write; - N2: Write; - FAIL: Write; - self:=1; -END. diff --git a/tests/tbs/tbs0179.pp b/tests/tbs/tbs0179.pp deleted file mode 100644 index fa8eff4f26..0000000000 --- a/tests/tbs/tbs0179.pp +++ /dev/null @@ -1,10 +0,0 @@ -{ $OPT= -So } -UNIT tbs0179; -INTERFACE - PROCEDURE A(B:WORD); -IMPLEMENTATION - PROCEDURE A; { <-- works with TP, FP says overloading problem } - BEGIN - Write(B); - END; -END. diff --git a/tests/tbs/tbs0180.pp b/tests/tbs/tbs0180.pp deleted file mode 100644 index 035535722a..0000000000 --- a/tests/tbs/tbs0180.pp +++ /dev/null @@ -1,15 +0,0 @@ -{ $OPT=-Un } -{ this name should be accepted with -Un option !! } -UNIT bug0180; -INTERFACE - uses - tbs0180a; - - procedure dummy; -IMPLEMENTATION - procedure dummy; - begin - { Unit_with_strange_name.dummy; should this work ?? } - tbs0180a.dummy; - end; -END. diff --git a/tests/tbs/tbs0180a.pp b/tests/tbs/tbs0180a.pp deleted file mode 100644 index 1850873c3f..0000000000 --- a/tests/tbs/tbs0180a.pp +++ /dev/null @@ -1,13 +0,0 @@ -{ $OPT=-Un } -{ this name should be accepted with -Un option !! } -UNIT Unit_with_strange_name; -INTERFACE - procedure dummy; -IMPLEMENTATION - procedure dummy; - begin - end; - -begin - Unit_with_strange_name.dummy; -END. diff --git a/tests/tbs/tbs0181.pp b/tests/tbs/tbs0181.pp deleted file mode 100644 index fb192714fc..0000000000 --- a/tests/tbs/tbs0181.pp +++ /dev/null @@ -1,9 +0,0 @@ -{ shows a problem of name mangling } -Program bug0181; - - Uses tbs0181a; - - var l : mylongint; -begin - dummy(l); -end. diff --git a/tests/tbs/tbs0181a.pp b/tests/tbs/tbs0181a.pp deleted file mode 100644 index 230a892009..0000000000 --- a/tests/tbs/tbs0181a.pp +++ /dev/null @@ -1,27 +0,0 @@ -{ shows a problem of name mangling } -Unit tbs0181a; - -Interface - - type mylongint = longint; - mylongint2 = mylongint; - - procedure dummy(var l : mylongint); - -Implementation - - var l : longint; - - procedure use_before_implemented; - begin - dummy(l); - end; - - procedure dummy(var l : mylongint2); - begin - l:=78; - end; - -begin - use_before_implemented; -end. diff --git a/tests/tbs/tbs0182.pp b/tests/tbs/tbs0182.pp deleted file mode 100644 index c170ffc4f1..0000000000 --- a/tests/tbs/tbs0182.pp +++ /dev/null @@ -1,31 +0,0 @@ -TYPE Rec = RECORD - x:WORD; - y:WORD; - END; - - Rec1 = Record - x,y : longint; - end; - Rec2 = Record - r,s : Rec1; - z : word; - end; - plongint = ^longint; - -VAR s:WORD; - r:Rec; - rr : Rec2; - -CONST p1:POINTER = @s; { Works fine } - p2:POINTER = @R.y; { illegal expression } - p3:pointer = @rr.s.y; - p4:plongint = @rr.s.y; -BEGIN - rr.s.y:=15; - if plongint(p3)^<>15 then - Begin - Writeln('Error : wrong code generated'); - Halt(1); - End; -END. - diff --git a/tests/tbs/tbs0183.pp b/tests/tbs/tbs0183.pp deleted file mode 100644 index 408ac2bddb..0000000000 --- a/tests/tbs/tbs0183.pp +++ /dev/null @@ -1,27 +0,0 @@ -program Internal_Error_10; - -type - PBug = ^TBug; - TBug = array[1..1] of boolean; - -var - Left : PBug; - test : longint; - -begin - New(left); - test := 1; - -{ following shows internal error 10 only if the - - array index is a var on both sides - ( if either is a constant then it compiles fine, error only occurs if the - not is in the statement ) - bug only appears if the array is referred to using a pointer - - if using TBug, and no pointers it compiles fine - with PBug the error appears - } - - Left^[test] := not Left^[test]; -end. - diff --git a/tests/tbs/tbs0184.pp b/tests/tbs/tbs0184.pp deleted file mode 100644 index b2a9e4f090..0000000000 --- a/tests/tbs/tbs0184.pp +++ /dev/null @@ -1,25 +0,0 @@ -Program Bug0184; - -{ multiple copies of the constant sets are stored in the assembler file when - they are needed more than once} - -Var BSet: Set of Byte; - SSet: Set of 0..31; - b,c: byte; - s: 0..31; - -Begin - BSet := BSet + [b]; {creates a big, empty set} - BSet := BSet + [c]; {creates another one} - BSet := BSet + [3]; {creates a big set with element three set} - BSet := BSet + [3]; {and antoher one} - - SSet := SSet + [5]; {creates a small set containing 5} - SSet := SSet + [s]; {creates a small, empty set} - SSet := SSet + [5]; {creates another small set containing 5} - SSet := SSet + [s]; {creates another small, empty set} - -{BTW: small constant sets don't have to be stored seperately in the - executable, as they're simple 32 bit constants, like longints!} - -End. diff --git a/tests/tbs/tbs0185.pp b/tests/tbs/tbs0185.pp deleted file mode 100644 index 7334f7ad9d..0000000000 --- a/tests/tbs/tbs0185.pp +++ /dev/null @@ -1,63 +0,0 @@ -Program bug0185; - -{shows some bugs with rangechecks} -{ readln from input changed to from a file to render it non-interactive } - -var s: String; - i: integer; - code: word; - e: 0..10; - f : text; - should_generate_error : boolean; - oldexit : pointer; - - procedure myexit; - begin - exitproc:=oldexit; - if should_generate_error and (exitcode=201) then - begin - Writeln('Program generates a range check error correctly'); - errorcode:=0; - exitcode:=0; - erroraddr:=nil; - close(f); - erase(f); - end; - end; - -Begin - oldexit:=exitproc; - exitproc:=@myexit; - should_generate_error:=false; -{$R-} - s := '$fffff'; - val(s, i, code); {no range check error may occur here} - Writeln('Integer($fffff) = ',i); - - assign(f,'tbs0185.tmp'); - rewrite(f); - Writeln(f,'20'); - Writeln(f,'34'); - close(f); - reset(f); - Write('Enter the value 20 (should not give a rangecheck error): '); - Readln(f,e); - - -{$R+} - s := '$ffff'; - val(s, i, code); {no range check error may occur here} - Writeln('integer($ffff) = ', i,'(should not give range check error)'); - - Writeln('Enter value from 0-10 to test Val rangecheck, another for subrange rangecheck: '); - should_generate_error:=true; - Readln(f,e); - - Writeln('If you entered a value different from 0-10, subrange range checks don''t work!'); - s := '65535'; - val(s, i, code); {must give a range check error} - Writeln('Val range check failed!'); - close(f); - erase(f); - Halt(1); -End. diff --git a/tests/tbs/tbs0187.pp b/tests/tbs/tbs0187.pp deleted file mode 100644 index 8ce616db17..0000000000 --- a/tests/tbs/tbs0187.pp +++ /dev/null @@ -1,118 +0,0 @@ -{ $OPT=-St -Cr } -program test; - -{$static on} - -{$ifdef go32v2} - uses dpmiexcp; -{$endif go32v2} - -type - Tbaseclass = object - base_arg : longint; - st_count : longint;static; - constructor Init; - destructor Done; - procedure Run; virtual; - - end; - Totherclass = object(Tbaseclass) - other_arg : longint; - procedure Run; virtual; - - end; - -const - BaseRunCount : integer = 0; - OtherRunCount : integer = 0; - -constructor Tbaseclass.Init; - -begin - writeln('Init'); - Inc(st_count); - Run; -end; - -destructor Tbaseclass.Done; - -begin - writeln('Done'); - dec(st_count); -end; - -procedure Tbaseclass.Run; - -begin - writeln('Base method'); - inc(BaseRunCount); -end; - - -procedure Totherclass.Run; - -begin - writeln('Inherited method'); - inc(OtherRunCount); -end; - - { try this as local vars } - - procedure test_local_class_init; - var base1 : TbaseClass; - var other1 : TOtherClass; - begin - with other1 do - Init; - with base1 do - Init; - with other1 do - begin - Writeln('number of objects = ',st_count); - base_arg:=2; - other_arg:=6; - Run; - end; - { test if changed !! } - - if (other1.base_arg<>2) or (other1.other_arg<>6) then - Halt(1); - - with base1 do - begin - Run; - Done; - end; - other1.done; - end; - -var base : Tbaseclass; - other : Totherclass; - testfield : longint; - -begin -// Uncommenting here and commenting the init in the WIth solves it. -// Base.Init; - with base do - begin - Init; - Run; - Done; - end; -// Uncommenting here and commenting the init in the WIth solves it. -// Other.init; - with other do - begin - Init; - Run; - Done; - end; - - test_local_class_init; -{ Calls Tbaseclass.Run when it should call Totherclass.Run } - If (BaseRunCount<>4) or (OtherRunCount<>4) then - Begin - Writeln('Error in tbs0187'); - Halt(1); - End; -end. diff --git a/tests/tbs/tbs0188.pp b/tests/tbs/tbs0188.pp deleted file mode 100644 index 7c32128041..0000000000 --- a/tests/tbs/tbs0188.pp +++ /dev/null @@ -1,42 +0,0 @@ -{ this are no bugs, just wrong - understanding of FPC syntax } - -type testfunc = function:longint; - -var f : testfunc; - -var test: testfunc; - -function test_temp: longint; -begin - test_temp:=12; -end; - -procedure sound(test: testfunc); -begin - {writeln(test); this is wrong because - test is the function itself and write does not know how to - output a function ! - to call test you must use test() !! } - writeln(test()); -end; { proc. sound } - -var i : longint; -begin - i:=test_temp; - f:=@test_temp; - if f()<>i then - begin - Writeln('error calling f'); - Halt(1); - end; - - { this works for FPC - sound(test_temp); - but the correct syntax would be } - sound(@test_temp); - { imagine if a function would return its own type !! } - - { for f var this is correct also ! } - sound(f); -end. diff --git a/tests/tbs/tbs0189.pp b/tests/tbs/tbs0189.pp deleted file mode 100644 index bd5b858d78..0000000000 --- a/tests/tbs/tbs0189.pp +++ /dev/null @@ -1,22 +0,0 @@ -var m: procedure; - -procedure test; -begin -end; - -procedure test2; -begin -end; - -begin - if @test <> @test2 then - writeln('different!') - else - writeln('error'); - m:=@test; - - { here also the syntax was wrong !! } - { @m <> @test have different types !! } - if m <> @test then - writeln('error'); -end. diff --git a/tests/tbs/tbs0190.pp b/tests/tbs/tbs0190.pp deleted file mode 100644 index 88d9fc4a5e..0000000000 --- a/tests/tbs/tbs0190.pp +++ /dev/null @@ -1,10 +0,0 @@ -procedure a(var b: boolean); -begin - b:=true; -end; - -var C: byte; - -begin - a(boolean(c)); -end. diff --git a/tests/tbs/tbs0191.pp b/tests/tbs/tbs0191.pp deleted file mode 100644 index 7d42d01866..0000000000 --- a/tests/tbs/tbs0191.pp +++ /dev/null @@ -1,28 +0,0 @@ -type - trec=record - a,b : longint; - end; - prec=^trec; - -const - s : string = 'test'; - - cfg : array[1..2] of trec=( - (a:1;b:2), - (a:3;b:4) - ); - pcfg : prec = @cfg[2]; - - l : ^longint = @cfg[1].b; { l^ should be 2 } - - pc : pchar = @s[1]; - -begin - Writeln(' l^ = ',l^); - Writeln('pc[0] = ',pc[0]); - if (l^<>2) or (pc[0]<>'t') then - Begin - Writeln('Wrong code generated'); - RunError(1); - End; -end. diff --git a/tests/tbs/tbs0192.pp b/tests/tbs/tbs0192.pp deleted file mode 100644 index 6a3c76ea07..0000000000 --- a/tests/tbs/tbs0192.pp +++ /dev/null @@ -1,8 +0,0 @@ -var - k,l : word; -begin - if (k<>l)=false then - ; - if (k<>l)=true then - ; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0193.pp b/tests/tbs/tbs0193.pp deleted file mode 100644 index 7005c0a467..0000000000 --- a/tests/tbs/tbs0193.pp +++ /dev/null @@ -1,15 +0,0 @@ -{$R-} -{$Q+} -var i: integer; - b: byte; - -begin - i := 32767; - i := i + 15; - b := 255; - b := b + 18; - b := 255; - b := b * 8; - b := 255; - b := b * 17 -End. diff --git a/tests/tbs/tbs0194.pp b/tests/tbs/tbs0194.pp deleted file mode 100644 index fccdce47b5..0000000000 --- a/tests/tbs/tbs0194.pp +++ /dev/null @@ -1,42 +0,0 @@ -{$Q+} - -type - tproc = function : longint; - -var - f : tproc; - fa : array [0..1] of tproc; - - function dummy : longint; - begin - dummy:=25; - end; -const - prog_has_errors : boolean = false; - - procedure Wrong(const s : string); - begin - writeln(s); - prog_has_errors:=True; - end; - -Begin - f:=@dummy; - if f()<>25 then - Wrong('f() does not call dummy !!'); - if pointer(@f)=pointer(@dummy) then - Wrong('@f returns value of f !'); - if longint(f)=longint(@f) then - Wrong('longint(@f)=longint(f) !!!!'); - if f<>@dummy then - Wrong('f does not return the address of dummy'); - if longint(@f)=longint(@dummy) then - Wrong('longint(@f) returns address of dummy instead of address of f'); - fa[0]:=@dummy; - if longint(@f)=longint(@fa[0]) then - Wrong('arrays of procvar also wrong'); - if longint(f)<>longint(fa[0]) then - Wrong('arrays of procvar and procvars are handled differently !!'); - if prog_has_errors then - Halt(1); -End. diff --git a/tests/tbs/tbs0195.pp b/tests/tbs/tbs0195.pp deleted file mode 100644 index 96f8a72a1f..0000000000 --- a/tests/tbs/tbs0195.pp +++ /dev/null @@ -1,44 +0,0 @@ -{$ifdef go32v2} -{$define OK} -{$endif} -{$ifdef linux} -{$define OK} -{$endif} -{$ifdef win32} -{$define OK} -{$endif} - -{$ifdef OK} -uses graph -{$ifdef go32v2} -,dpmiexcp -{$endif go32v2}; -var - GDriver, GMode: Integer; - w:word; - p:pointer; -{$endif OK} -begin -{$ifdef OK} - GDriver := $FF; - GMode := $101; - InitGraph(GDriver, GMode, ''); - if (GraphResult <> grOK) then - Halt(0); - rectangle(0,0,getmaxx,getmaxy); - w := imagesize(0,0,111,111); - getmem(p, w); - - {---runtime-error!------} - { getimage(0,0,111,111, p); } - {-----------------------} - - { This is the correct usage (PFV) } - getimage(0,0,111,111, p^); - - - freemem(p, w); - closegraph; - readln; -{$endif OK} -end. diff --git a/tests/tbs/tbs0196.pp b/tests/tbs/tbs0196.pp deleted file mode 100644 index a19a1e9260..0000000000 --- a/tests/tbs/tbs0196.pp +++ /dev/null @@ -1,13 +0,0 @@ -{ $OPT= -So } -Unit tbs0196; -interface - - function a : integer; - -implementation - function a; -begin - a:=1; -end; - -end. diff --git a/tests/tbs/tbs0198.pp b/tests/tbs/tbs0198.pp deleted file mode 100644 index 379c8ab4e8..0000000000 --- a/tests/tbs/tbs0198.pp +++ /dev/null @@ -1,14 +0,0 @@ -{$mode objfpc} -type - to1 = class - function GetCaps1 : Longint;virtual;abstract; - function GetCaps2 : Longint;virtual;stdcall; - function GetCaps : Longint;virtual;stdcall;abstract; - end; - -function to1.GetCaps2 : Longint;stdcall; -begin -end; - -begin -end. diff --git a/tests/tbs/tbs0199.pp b/tests/tbs/tbs0199.pp deleted file mode 100644 index 2d81c239dc..0000000000 --- a/tests/tbs/tbs0199.pp +++ /dev/null @@ -1,24 +0,0 @@ -PROGRAM PRTest; - -TYPE - ptRec = ^tRec; - tRec = Record - D : DWORD; - END; - -VAR - pR1, pR2 : ptRec; -BEGIN - GetMem(pR1, SizeOf(tRec)); - GetMem(pR2, SizeOf(tRec)); - - pR1^.D := 10; - Move(pR1^,pR2^,SizeOf(tRec)); - WriteLn(pR1^.D:16,pR2^.D:16); - - pR1^.D := 1; - pR2^.D := pR1^.D*2; { THE BUG IS HERE } - WriteLn(pR1^.D:16,pR2^.D:16); - if (pR1^.D<>1) or (pR2^.D<>2) then - Halt(1); -END. diff --git a/tests/tbs/tbs0201.pp b/tests/tbs/tbs0201.pp deleted file mode 100644 index 9168909054..0000000000 --- a/tests/tbs/tbs0201.pp +++ /dev/null @@ -1,41 +0,0 @@ -{ $OPT= -Ratt } - -program bug0201; - -type rec = record - a : DWord; - b : Word; - end; - -{ this is really for tests but - this should be coded with const r1 and r2 !! } - -function x(r1 : rec; r2 : rec; var r3 : rec) : integer; assembler; -asm - movl r3, %edi - movl r1, %ebx - movl r2, %ecx - movl rec.a(%ebx), %eax - addl rec.a(%ecx), %eax - movl %eax, rec.a(%edi) - - movw rec.b(%ebx), %ax - addw rec.b(%ecx), %ax - movw %ax, rec.b(%edi) - movw $1,%ax -end; - -var r1, r2, r3 : rec; - -begin - r1.a := 100; r1.b := 200; - r2.a := 300; r2.b := 400; - x(r1, r2, r3); - Writeln(r3.a, ' ', r3.b); - if (r3.a<>400) or (r3.b<>600) then - begin - Writeln('Error in assembler code'); - Halt(1); - end; -end. - diff --git a/tests/tbs/tbs0202.pp b/tests/tbs/tbs0202.pp deleted file mode 100644 index bb5e6e4412..0000000000 --- a/tests/tbs/tbs0202.pp +++ /dev/null @@ -1,31 +0,0 @@ -program silly; - -var greater : boolean; - -procedure error; -begin - Writeln('Error in tbs0202'); - Halt(1); -end; - -procedure compare(i,j : integer); -begin - case (i>j) of - true : begin - greater:=true; - end; - false : begin - greater:=false; - end; - end; -end; - -begin - compare(45,2); - if not greater then - error; - compare(-5,26); - if greater then - error; -end. - diff --git a/tests/tbs/tbs0203.pp b/tests/tbs/tbs0203.pp deleted file mode 100644 index 8c41ae7a8d..0000000000 --- a/tests/tbs/tbs0203.pp +++ /dev/null @@ -1,13 +0,0 @@ -program tbs0203; - -uses -{$ifdef go32v2} - dpmiexcp, -{$endif def go32v2} - tbs0203a; - -begin - c; - a; -end. - diff --git a/tests/tbs/tbs0203a.pp b/tests/tbs/tbs0203a.pp deleted file mode 100644 index 0b78efca78..0000000000 --- a/tests/tbs/tbs0203a.pp +++ /dev/null @@ -1,25 +0,0 @@ -unit tbs0203a; - -interface - procedure a; - procedure c; - - const is_called : boolean = false; - -implementation - - procedure c; - begin - a; - end; - - procedure b;[public, alias : '_assembler_a']; - begin - Writeln('b called'); - Is_called:=true; - end; - - procedure a;external name '_assembler_a'; - -end. - diff --git a/tests/tbs/tbs0204.pp b/tests/tbs/tbs0204.pp deleted file mode 100644 index e7d9cea910..0000000000 --- a/tests/tbs/tbs0204.pp +++ /dev/null @@ -1,30 +0,0 @@ -{ boolean(byte) byte(boolean) - word(wordbool) wordbool(word) - longint(longbool) and longbool(longint) - must be accepted as var parameters - or a left of an assignment } - -procedure error; -begin - Writeln('Error in tbs0204'); - Halt(1); -end; - -var - b : boolean; - wb : wordbool; - lb : longbool; - -begin - byte(b):=1; - word(wb):=1; - longint(lb):=1; - if (not b) or (not wb) or (not lb) then - error; - byte(b):=2; - Writeln('if a boolean contains 2 it is considered as ',b); - byte(b):=3; - Writeln('if a boolean contains 3 it is considered as ',b); - shortint(b):=-1; - Writeln('if a boolean contains shortint(-1) it is considered as ',b); -end. \ No newline at end of file diff --git a/tests/tbs/tbs0206.pp b/tests/tbs/tbs0206.pp deleted file mode 100644 index 7cfad907c3..0000000000 --- a/tests/tbs/tbs0206.pp +++ /dev/null @@ -1,10 +0,0 @@ -PROGRAM SetRange_Bug; -CONST a:char='A';z:char='Z'; -VAR s:set of char;c:char; -BEGIN - s:=[a..z]; - for c:=#0 to #255 do - if c in s then - write(c); - writeln; -END. \ No newline at end of file diff --git a/tests/tbs/tbs0207.pp b/tests/tbs/tbs0207.pp deleted file mode 100644 index c5debd47c8..0000000000 --- a/tests/tbs/tbs0207.pp +++ /dev/null @@ -1,8 +0,0 @@ - -{$mode delphi} - var i : longint; - -begin - for i:=1 to 100 do - tobject.create.free; -end. diff --git a/tests/tbs/tbs0209.pp b/tests/tbs/tbs0209.pp deleted file mode 100644 index a203f85008..0000000000 --- a/tests/tbs/tbs0209.pp +++ /dev/null @@ -1,18 +0,0 @@ -program bug0209; - -{ problem with boolean expression mixing different boolean sizes } - -var - b : boolean; - wb : wordbool; - lb : longbool; -begin - b:=true; - wb:=true; - lb:=true; - if (not b) or (not wb) or (not lb) then - begin - Writeln('Error with boolean expressions of different sizes'); - Halt(1); - end; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0210.pp b/tests/tbs/tbs0210.pp deleted file mode 100644 index b29bfd369c..0000000000 --- a/tests/tbs/tbs0210.pp +++ /dev/null @@ -1,10 +0,0 @@ -{ boolean args are accepted for fillchar in BP } - -program test; - - var l : array[1..10] of boolean; - -begin - fillchar(l,sizeof(l),true); -end. - diff --git a/tests/tbs/tbs0211.pp b/tests/tbs/tbs0211.pp deleted file mode 100644 index 905ce1eee0..0000000000 --- a/tests/tbs/tbs0211.pp +++ /dev/null @@ -1,29 +0,0 @@ -var - a,b : boolean; - c : byte; - i : longint; - -procedure Error; -begin - Writeln('Error in bug0211'); - Halt(1); -end; - -begin - c:=5; - a:=boolean(c); - if a and not a then - Begin - Writeln('FPC is crazy !!'); - Error; - End; - i:=256; - a:=boolean(i); - { the value here is less trivial } - { BP returns false here !! } - { the problem is the converting wordbool to boolean } - { if wordbool is 256 should not convert true to false !! } - - Writeln('boolean(256) =',a); -end. - diff --git a/tests/tbs/tbs0212.pp b/tests/tbs/tbs0212.pp deleted file mode 100644 index c63cd49d1c..0000000000 --- a/tests/tbs/tbs0212.pp +++ /dev/null @@ -1,20 +0,0 @@ -program proptest; - -{$mode objfpc} - -type - TMyRec = record - Int: Integer; - Str: String; - end; - - TMyClass = class - private - FMyRec: TMyRec; - public - property AnInt: Integer read FMyRec.Int; - property AStr: String read FMyRec.Str; - end; - -begin -end. \ No newline at end of file diff --git a/tests/tbs/tbs0213.pp b/tests/tbs/tbs0213.pp deleted file mode 100644 index 284fe3108e..0000000000 --- a/tests/tbs/tbs0213.pp +++ /dev/null @@ -1,35 +0,0 @@ -uses - tbs0213a; - -PROCEDURE Testsomething(VAR A:LONGINT); - -FUNCTION Internaltest(L:LONGINT):LONGINT; - -BEGIN - InternalTest:=L+10; -END; - -BEGIN - A:=Internaltest(20)+5; -END; - -PROCEDURE Testsomething(VAR A:WORD); - -FUNCTION Internaltest(L:LONGINT):WORD; - -BEGIN - InternalTest:=L+15; -END; - -BEGIN - A:=Internaltest(20)+5; -END; - -VAR O : LONGINT; - O2 : WORD; - -BEGIN - TestSomething(O); - TestSomething(O2); -END. - diff --git a/tests/tbs/tbs0213a.pp b/tests/tbs/tbs0213a.pp deleted file mode 100644 index 83d19e6d9f..0000000000 --- a/tests/tbs/tbs0213a.pp +++ /dev/null @@ -1,96 +0,0 @@ -{ different tests for the problem of local - functions having the same name } - -unit tbs0213a; - -interface - -PROCEDURE Testsomething(VAR A:LONGINT); - -PROCEDURE Testsomething(VAR A:WORD); - -implementation - - -PROCEDURE Testsomething(VAR A:LONGINT); - -FUNCTION Internaltest(L:LONGINT):LONGINT; - -BEGIN - InternalTest:=L+10; -END; - -BEGIN - A:=Internaltest(20)+5; -END; - -PROCEDURE Testsomething(VAR A:WORD); - -FUNCTION Internaltest(L:LONGINT):WORD; - -BEGIN - InternalTest:=L+15; -END; - -BEGIN - A:=Internaltest(20)+5; -END; - -PROCEDURE Testsomething2(VAR A:LONGINT); - -FUNCTION Internaltest(L:LONGINT):LONGINT; - -BEGIN - InternalTest:=L+10; -END; - -BEGIN - A:=Internaltest(20)+5; -END; - -PROCEDURE Testsomething2(VAR A:WORD); - -FUNCTION Internaltest(L:LONGINT):WORD; - -BEGIN - InternalTest:=L+15; -END; - -BEGIN - A:=Internaltest(20)+5; -END; - -PROCEDURE Testsomething3(VAR A:WORD);forward; - -PROCEDURE Testsomething3(VAR A:LONGINT); - -FUNCTION Internaltest(L:LONGINT):LONGINT; - -BEGIN - InternalTest:=L+10; -END; - -BEGIN - A:=Internaltest(20)+5; -END; - -PROCEDURE Testsomething3(VAR A:WORD); - -FUNCTION Internaltest(L:LONGINT):WORD; - -BEGIN - InternalTest:=L+15; -END; - -BEGIN - A:=Internaltest(20)+5; -END; - -VAR O : LONGINT; - O2 : WORD; - -BEGIN - TestSomething(O); - TestSomething(O2); -END. - diff --git a/tests/tbs/tbs0214.pp b/tests/tbs/tbs0214.pp deleted file mode 100644 index ce5c252c1c..0000000000 --- a/tests/tbs/tbs0214.pp +++ /dev/null @@ -1,29 +0,0 @@ -{ $OPT=-St } - -Program SttcTest; -{ Note: I've cut a lot out of this program, it did originally have - constructors, destructors and instanced objects, but this - is the minimum required to produce the problem, and I think - that this should work, unless I've misunderstood the use of - the static keyword. } -Type - TObjectType1 = Object - Procedure Setup; static; - Procedure Weird; static; - End; - -Procedure TObjectType1.Setup; - Begin - End; - -Procedure TObjectType1.Weird; - Begin - End; - -Begin - TObjectType1.Setup; - TObjectType1.Weird; - TObjectType1.Weird; // GPFs before exiting "Weird" - Writeln('THE END.'); -End. - diff --git a/tests/tbs/tbs0215.pp b/tests/tbs/tbs0215.pp deleted file mode 100644 index 452ef549e4..0000000000 --- a/tests/tbs/tbs0215.pp +++ /dev/null @@ -1,52 +0,0 @@ -{ $OPT=-St } -{ allow static keyword } -{ submitted by Andrew Wilson } - -Program X; - -{$ifdef go32v2} - uses dpmiexcp; -{$endif go32v2} - -Type - PY=^Y; - Y=Object - A : LongInt; - P : PY; static; - Constructor Init(NewA:LongInt); - Procedure StaticMethod; static; - Procedure VirtualMethod; virtual; - End; - -Constructor Y.Init(NewA:LongInt); - Begin - A:=NewA; - P:=@self; - End; - -Procedure Y.StaticMethod; - Begin - Writeln(P^.A); // Compiler complains about using A. - P^.VirtualMethod; // Same with the virtual method. - With P^ do begin - Writeln(A); // These two seem to compile, but I - VirtualMethod; // can't get them to work. It seems to - End; // be the same problem as last time, so - End; // I'll check it again when I get the - // new snapshot. -Procedure Y.VirtualMethod; - Begin - Writeln('VirtualMethod ',A); - End; - -var T1,T2 : PY; - -Begin - New(T1,init(1)); - New(T2,init(2)); - T1^.VirtualMethod; - T2^.VirtualMethod; - Y.StaticMethod; - T1^.StaticMethod; - T2^.StaticMethod; -End. diff --git a/tests/tbs/tbs0216.pp b/tests/tbs/tbs0216.pp deleted file mode 100644 index 12b76b997c..0000000000 --- a/tests/tbs/tbs0216.pp +++ /dev/null @@ -1,34 +0,0 @@ -type rec = record - a : Longint; - b : Longint; - c : Longint; - d : record - e : Longint; - f : Word; - end; - g : Longint; - end; - -const r : rec = ( - a : 100; b : 200; c : 300; d : (e : 20; f : 30); g : 10); - - -begin - with r do begin - Writeln('A : ', a); - if a<>100 then halt(1); - Writeln('B : ', b); - if b<>200 then halt(1); - Writeln('C : ', c); - if c<>300 then halt(1); - Writeln('D'); - with d do begin - Writeln('E : ', e); - if e<>20 then halt(1); - Writeln('F : ', f); - if f<>30 then halt(1); - end; - Writeln('G : ', g); - if g<>10 then halt(1); - end; -end. diff --git a/tests/tbs/tbs0217.pp b/tests/tbs/tbs0217.pp deleted file mode 100644 index ff30bb3945..0000000000 --- a/tests/tbs/tbs0217.pp +++ /dev/null @@ -1,19 +0,0 @@ -{$ifdef fpc}{$mode tp}{$endif} - -type tmpproc=function:longint; - -function a:longint;{$ifndef fpc}far;{$endif} -begin - a:=-1; -end; - -procedure tmp(aa: tmpproc); -begin - writeln(aa); { "Cannot read/write variables of this type", TP kan dit -wel? } - if aa<>-1 then halt(1); -end; - -begin - tmp(a); { de TP manier , in FPC moet dit zijn tmp(@a); } -end. diff --git a/tests/tbs/tbs0218.pp b/tests/tbs/tbs0218.pp deleted file mode 100644 index 5d574931ee..0000000000 --- a/tests/tbs/tbs0218.pp +++ /dev/null @@ -1,44 +0,0 @@ -Program Wrong_Output; -{} -Var r,rr,error:Extended; - s:String; - code : word; -{} -Begin - Writeln('Size of Extended type (r)=',SizeOf(r),' bytes'); - r:=0.000058184639; - Writeln('r=',r); - Writeln('r=',r:16:13); - Writeln('r=',r:15:12); - Writeln('r=',r:14:11); - Writeln('r=',r:13:10); - Writeln('r=',r:12:9); - Writeln('r=',r:11:8); - Writeln('r=',r:10:7); - Writeln('r=',r:9:6); - Writeln('r=',r:8:5); - Writeln('r=',r:7:4); - Str(r,s); - Writeln('r=',s,' (as string)'); - str(r,s); - val(s,rr,code); - { calculate maximum possible precision } - if sizeof(extended) = 10 then - error := exp(17*ln(10)) - else if sizeof(extended) = 8 then - error := exp(14*ln(10)) - else if sizeof(extended) = 4 then - { the net may have to be 9 instead of 8, not sure } - error := exp(8*ln(10)) - else - begin - Writeln('unknown extended type size!'); - halt(1) - end; - if abs(r-rr) > error then - begin - Writeln('r=',r); - Writeln('is different from rr=',rr); - halt(1); - end; -End. \ No newline at end of file diff --git a/tests/tbs/tbs0220.pp b/tests/tbs/tbs0220.pp deleted file mode 100644 index f54ab7b994..0000000000 --- a/tests/tbs/tbs0220.pp +++ /dev/null @@ -1,15 +0,0 @@ -type - a = array[1..100] of char; - -var - a1 : a; - s : string; -begin - a1[1]:='1';a1[2]:='2';a1[3]:='3'; - a1[4]:='4';a1[5]:='5';a1[6]:='6'; - a1[7]:='7';a1[8]:='8';a1[9]:='9'; - a1[10]:='0';a1[11]:='1'; - s:=Copy(a1,1,10); - if s<>'1234567890' then halt(1); - writeln('ok'); -end. diff --git a/tests/tbs/tbs0221.pp b/tests/tbs/tbs0221.pp deleted file mode 100644 index 5a466246f4..0000000000 --- a/tests/tbs/tbs0221.pp +++ /dev/null @@ -1,13 +0,0 @@ - -var - r : double; - c : char; -begin - r:=1.; - c:=^.; { this compile in tp7, c should contain 'n'/#110 } - if c<>#110 then - begin - Writeln('FPC does not support ^. character!'); - Halt(1); - end; -end. diff --git a/tests/tbs/tbs0222.pp b/tests/tbs/tbs0222.pp deleted file mode 100644 index 7a53bec82f..0000000000 --- a/tests/tbs/tbs0222.pp +++ /dev/null @@ -1,11 +0,0 @@ - -type TStruct = record - x,y: Integer; - end; - -var i: TStruct; - -begin - for i.x:=1 to 10 do - writeln(i.x); -end. diff --git a/tests/tbs/tbs0223.pp b/tests/tbs/tbs0223.pp deleted file mode 100644 index 73e3df65c0..0000000000 --- a/tests/tbs/tbs0223.pp +++ /dev/null @@ -1,20 +0,0 @@ - -uses - erroru; - -var a:string; - -begin - writeln('B:'='B:'); { debbuger evaluates this to FALSE } - if 'B:'='B:' then - writeln('OK') - else - error; - a:='A:'; - inc(a[1]); - writeln(a='B:'); { TRUE } - if a='B:' then - writeln('OK') - else - error; -end. diff --git a/tests/tbs/tbs0224.pp b/tests/tbs/tbs0224.pp deleted file mode 100644 index a69f4e18ca..0000000000 --- a/tests/tbs/tbs0224.pp +++ /dev/null @@ -1,19 +0,0 @@ - -var f:text; - i:integer; -begin - assign(f,'bug0224.txt'); - rewrite(f); - write(f,' '); - reset(f); -{$I-} - readln(f,i); { you can't avoid run-time error generation } -{$I+} - if IOResult<>0 then - writeln('error...'); -{$I-} - close(f); - erase(f); -{$I+} - if IOResult<>0 then; -end. diff --git a/tests/tbs/tbs0225.pp b/tests/tbs/tbs0225.pp deleted file mode 100644 index 0db0daa788..0000000000 --- a/tests/tbs/tbs0225.pp +++ /dev/null @@ -1,30 +0,0 @@ - program bug0255; - -{$mode objfpc} - -{$R+} - - function erwwert(const feld: array of LongInt):extended; - var i: LongInt; - begin - Result:=0; - for i:=low(feld) to high(feld) - do begin - writeln(i); // gives "0" - Result:=Result+feld[i]; - end; //^^^^^^^ there occurs the segfault (216) - // on the first loop - Result:=Result/(high(feld)-low(feld)+1); - end; - - var werte: array[0..299] of LongInt; - i: LongInt; - - begin - //init the array - for i:=0 to 299 - do werte[i]:=Random(5)-2; - - //and do something with it - writeln(erwwert(werte):6:5); - end. diff --git a/tests/tbs/tbs0226.pp b/tests/tbs/tbs0226.pp deleted file mode 100644 index ab370c28e0..0000000000 --- a/tests/tbs/tbs0226.pp +++ /dev/null @@ -1,9 +0,0 @@ -{$ifdef fpc}{$asmmode intel}{$endif} -var - test : longint; -begin - exit; { don't run this code below !! } - asm - dd test - end; -end. diff --git a/tests/tbs/tbs0227.pp b/tests/tbs/tbs0227.pp deleted file mode 100644 index 5b82124e18..0000000000 --- a/tests/tbs/tbs0227.pp +++ /dev/null @@ -1,12 +0,0 @@ -function getheapsize:longint;assembler; -var - heapsize : longint;external name 'HEAPSIZE'; - sbrk : longint;external name '___sbrk'; -asm - movl HEAPSIZE,%eax -end ['EAX']; - -begin - writeln(getheapsize); -end. - diff --git a/tests/tbs/tbs0228.pp b/tests/tbs/tbs0228.pp deleted file mode 100644 index b2e7097eaa..0000000000 --- a/tests/tbs/tbs0228.pp +++ /dev/null @@ -1,15 +0,0 @@ -PROGRAM Buggy; - -{$ASMMODE ATT} - -PROCEDURE XX; ASSEMBLER; -TYPE - TabType=ARRAY[0..3] OF BYTE; -CONST - TabCent : TabType = (0,6,4,2); -ASM - movzbl TabCent(,%eax),%ebx -END; - -BEGIN -END. diff --git a/tests/tbs/tbs0229.pp b/tests/tbs/tbs0229.pp deleted file mode 100644 index 1d6758c8cf..0000000000 --- a/tests/tbs/tbs0229.pp +++ /dev/null @@ -1,34 +0,0 @@ -{$mode objfpc} -{$X-} - -const - CRLF = #13#10; - c = - '1-----------------'+CRLF+ - '2/PcbDict 200 dict'+CRLF+ - '3PcbDicljkljkljk b'+CRLF+ - '4PcbDict /DictMaix'+CRLF+ - '5% draw a pin-poll'+CRLF+ - '6% get x+CRLF+ y s'+CRLF+ - '7/thickness exch h'+CRLF+ - '8gsave x y transls'+CRLF+ - '9---------jljkljkl'+crlf+ - '10----------2jkljk'+crlf+ - '11----------jkllkk'+crlf+ - 'eeeeeeeeeeeeeeeeee'+crlf+ - '2-----------------'+CRLF+ - '2/PcbDict 200 dice'+CRLF+ - 'END____.XXXXXxjk b'+CRLF+ - '4PcbDict /DictMaix'+CRLF+ - '5% draw a pin-poll'+CRLF+ - '6% get x+CRLF+ y s'+CRLF+ - '7/thickness exch h'+CRLF+ - '8gsave x y transls'+CRLF+ - '9---------jljkljkl'+crlf+ - '10----------2jkljk'+crlf+ - '11----------jkllkk'+crlf+ - 'eeeeeeeeeeeeeeeeee12'; - -begin - write(c); -end. diff --git a/tests/tbs/tbs0232.pp b/tests/tbs/tbs0232.pp deleted file mode 100644 index 543cf8b07a..0000000000 --- a/tests/tbs/tbs0232.pp +++ /dev/null @@ -1,8 +0,0 @@ -const - p1 : procedure;stdcall=nil; { <----- this doesn't what you expect !!!!} - p2 : procedure stdcall=nil; { so delphi supports also this way of } - { declaration } - -begin -end. - diff --git a/tests/tbs/tbs0233.pp b/tests/tbs/tbs0233.pp deleted file mode 100644 index fbb595217e..0000000000 --- a/tests/tbs/tbs0233.pp +++ /dev/null @@ -1,31 +0,0 @@ -program except_test; - -type byteset = set of byte; - enumset = set of (zero,one,two,three); - -function test(s : byteset) : boolean; -begin - test:=false; - if 0 in s then - begin - Writeln('Contains zero !'); - test:=true; - end; -end; - -function testenum(s : enumset) : boolean; -begin - testenum:=false; - - if zero in s then - begin - Writeln('Contains zero !'); - testenum:=true; - end; -end; - -begin - if test([1..5,8]) then halt(1); - if not test([0,8,15]) then halt(1); - if not testenum([zero,two]) then halt(1); -end. diff --git a/tests/tbs/tbs0234.pp b/tests/tbs/tbs0234.pp deleted file mode 100644 index 1fe22415ad..0000000000 --- a/tests/tbs/tbs0234.pp +++ /dev/null @@ -1,10 +0,0 @@ -program bug0232; - -{$mode tp} - -var p:pointer; - -begin - new(p); - dispose(p); -end. diff --git a/tests/tbs/tbs0235.pp b/tests/tbs/tbs0235.pp deleted file mode 100644 index 55ad239eb7..0000000000 --- a/tests/tbs/tbs0235.pp +++ /dev/null @@ -1,17 +0,0 @@ -program bug0233; - -var s:string; - w:cardinal; - code:word; - -begin - s:='192'; - val(s,w,code); - if code<>0 then - begin - writeln('Error'); - halt(1); - end - else - writeln(w); -end. diff --git a/tests/tbs/tbs0236.pp b/tests/tbs/tbs0236.pp deleted file mode 100644 index 8e15fecad4..0000000000 --- a/tests/tbs/tbs0236.pp +++ /dev/null @@ -1,40 +0,0 @@ -{$R+} -program test_set_subrange; - -uses - erroru; - - type - enum = (zero,one,two,three); - - sub_enum = one..three; - prec = ^trec; - - trec = record - dummy : longint; - en : enum; - next : prec; - end; - - const - str : array[sub_enum] of string = ('one','two','three'); - -procedure test; - - var hp : prec; - t : sub_enum; - - begin - new(hp); - hp^.en:=zero; - new(hp^.next); - hp^.next^.en:=three; - t:=hp^.en; - Writeln('hp^.en = ',str[hp^.en]); - Writeln('hp^.next^.en = ',str[hp^.next^.en]); - end; - -begin - require_error(201); - test; -end. diff --git a/tests/tbs/tbs0237.pp b/tests/tbs/tbs0237.pp deleted file mode 100644 index f80f8392c8..0000000000 --- a/tests/tbs/tbs0237.pp +++ /dev/null @@ -1,22 +0,0 @@ -unit tbs0237; -interface - - procedure sub1(w1,w2:word); - -implementation - -procedure p1; - - procedure sub1(w:word); - begin - end; - -begin -end; - - -procedure sub1(w1,w2:word); -begin -end; - -end. diff --git a/tests/tbs/tbs0238.pp b/tests/tbs/tbs0238.pp deleted file mode 100644 index cfa1c514c0..0000000000 --- a/tests/tbs/tbs0238.pp +++ /dev/null @@ -1,35 +0,0 @@ -program test1; - - {compiles under TPC - PPC386 gives internal error} - -Type str1=string[160]; - -var - fileof :file of str1; - lol :array[1..8] of str1; - nu,n:integer; - i,tt :str1; - ul :text; - a: str1; - - -procedure test; - - -begin - for nu:=1 to 8 do read(fileof,lol[nu]); - writeln('File contents'); - for nu:=4 to 8 do writeln(lol[nu]); -end; - - -begin - assign(fileof,'tbs0238.tmp'); - rewrite(fileof); - a:='dummy string !!'; - for nu:=1 to 8 do write(fileof,a); - close(fileof); - reset(fileof); - test; - close(fileof); -end. diff --git a/tests/tbs/tbs0239.pp b/tests/tbs/tbs0239.pp deleted file mode 100644 index f5139ab704..0000000000 --- a/tests/tbs/tbs0239.pp +++ /dev/null @@ -1,47 +0,0 @@ -{$mode delphi} - uses -{$ifdef go32v2} - dpmiexcp, -{$endif go32v2} - sysutils; - type - ttest=class - end; - ttest2 = class(ttest) - end; - ttestclass=class of ttest; - var - i,j:ttest; - tt:tclass; - begin - tt:=ttest; - i:=ttest.create; - j:=ttest2.create; - Writeln('tt is a class of ttest initialized by "tt:=ttest"'); - Writeln('i is a ttest class initialized by "i:=ttest.create"'); - Writeln('j is a ttest class initialized by "j:=ttest2.create"'); - writeln('i is tobject ',i is tobject); - if not(i is tobject) then - Halt(1); - writeln('i is tt ',i is tt); - if not(i is tt) then - Halt(1); - writeln('i is ttest ',i is ttest); - if not(i is ttest) then - Halt(1); - writeln('i is ttest2 ',i is ttest2); - if (i is ttest2) then - Halt(1); - writeln('j is tobject ',j is tobject); - if not(j is tobject) then - Halt(1); - writeln('j is tt ',j is tt); - if not(j is tt) then - Halt(1); - writeln('j is ttest ',j is ttest); - if not(j is ttest) then - Halt(1); - writeln('j is ttest2 ',j is ttest2); - if not(j is ttest2) then - Halt(1); - end. diff --git a/tests/tbs/tbs0240.pp b/tests/tbs/tbs0240.pp deleted file mode 100644 index a4cd8438b6..0000000000 --- a/tests/tbs/tbs0240.pp +++ /dev/null @@ -1,21 +0,0 @@ -Program TEST; - -var CurFileCrc32f : cardinal{Longint}; - CheckThis : String; - -BEGIN - CurFileCrc32f := $C5CAF43C; - CheckThis := ''; - Case CurFileCrc32f of - $F3DC2AF0 : CheckThis := ' First '; - $27BF798B : CheckThis := ' Second '; - $7BA5BB19 : CheckThis := ' Third'; - $FA246A81 : CheckThis := ' Forth'; - $8A00B508 : CheckThis := ' Fifth'; - $C5CAF43C : CheckThis := ' Sixth'; - End; - Writeln( CheckThis ); - If CheckThis<>' Sixth' then halt(1); -END. - - diff --git a/tests/tbs/tbs0241.pp b/tests/tbs/tbs0241.pp deleted file mode 100644 index 0bd618f9b5..0000000000 --- a/tests/tbs/tbs0241.pp +++ /dev/null @@ -1,16 +0,0 @@ -{$ifdef win32} -program test_win32_drv; - -procedure printer;external 'winspool.drv' name 'AbortPrinter'; -procedure test; - - begin - Writeln('Loading of Winspool works '); - end; - -begin - test; -{$else} -begin -{$endif} -end. diff --git a/tests/tbs/tbs0242b.pp b/tests/tbs/tbs0242b.pp deleted file mode 100644 index 27e550de70..0000000000 --- a/tests/tbs/tbs0242b.pp +++ /dev/null @@ -1,28 +0,0 @@ - -const - test = 5; - - procedure test_const(const s : string;const x); - begin - writeln(s,' is ',longint(x)); - end; - - procedure change(var x); - begin - inc(longint(x)); - end; - const i : longint = 12; - var - j : longint; -begin - j:=34; - test_const('Const 5',5); - test_const('Untyped const test',test); - test_const('Typed_const i',i); - test_const('Var j',j); - {test_const('i<>j ',i<>j);} - change(i); - change(j); - { change(test); - change(longint); } -end. diff --git a/tests/tbs/tbs0243.pp b/tests/tbs/tbs0243.pp deleted file mode 100644 index dbe4804fe5..0000000000 --- a/tests/tbs/tbs0243.pp +++ /dev/null @@ -1,35 +0,0 @@ -program simpletest; - -var i : longint; - - function _next : longint; - begin - inc(i); - _next:=i; - end; - - procedure test(a,b : longint); - begin - Writeln('first arg is ',a); - Writeln('second arg is ',b); - end; - - procedure check(a,b : longint); - begin - if a>b then - begin - Writeln('FPC does not follow PASCAL rules for parameter passing'); - Halt(1); - end; - end; - -begin -{ this could give - first arg is 1 - second arg is 2 - but FPC parses the second arg before the first one ! } -test(_next,_next); -writeln('third arg is ',_next); -writeln('fourth arg is ',_next,' fifth arg is ',_next); -check(_next,_next); -end. diff --git a/tests/tbs/tbs0244.pp b/tests/tbs/tbs0244.pp deleted file mode 100644 index 55e482f542..0000000000 --- a/tests/tbs/tbs0244.pp +++ /dev/null @@ -1,24 +0,0 @@ -Unit tbs0244; - -{test also with -So !!!} - -Interface - -Procedure t(a,b: longint); - -Implementation - -Procedure t(a,b: longint); -begin -end; - -Procedure t2; - - Procedure t(l: Longint); - Begin - End; - -Begin -End; - -End. diff --git a/tests/tbs/tbs0247.pp b/tests/tbs/tbs0247.pp deleted file mode 100644 index 69a76f2eed..0000000000 --- a/tests/tbs/tbs0247.pp +++ /dev/null @@ -1,22 +0,0 @@ -{$mode delphi} - -var - x : integer = 34; -{ this is the way Delphi creates initialized vars - ++ its much more logical then BP - typed const !! - -- its incompatible with BP !! (PM) } - - y : array[0..2] of real = (0.0,1.23,2.56); - -{ these are true const in Delphi mode and thus - it should not be possible to change ! } - -const - z : real = 45.2; - -begin - y[2]:=z; - { this should be refused ! } - z:=y[1]; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0249.pp b/tests/tbs/tbs0249.pp deleted file mode 100644 index edddde5b59..0000000000 --- a/tests/tbs/tbs0249.pp +++ /dev/null @@ -1,61 +0,0 @@ -program TestEvent; - -{$mode objfpc} -{$M+} - -type - TNotifyEvent = procedure( Sender: TObject ) of object; - - THost = class - protected - FOnEvent: TNotifyEvent; - procedure SetOnEvent( Value: TNotifyEvent ); - public - constructor Create; - procedure Trigger; - procedure SayHello; - published - property OnEvent: TNotifyEvent read FOnEvent write SetOnEvent; - end; - - TDummy = class - procedure HandleEvent( Sender: TObject ); - end; - -constructor THost.Create; -begin - FOnEvent := nil; -end; - -procedure THost.Trigger; -begin - if @FOnEvent <> nil then - FOnEvent( Self ) -end; - -procedure THost.SetOnEvent( Value: TNotifyEvent ); -begin - FOnEvent := Value -end; - -procedure THost.SayHello; -begin - Writeln( 'Hello event' ) -end; - -procedure TDummy.HandleEvent( Sender: TObject ); -begin - THost( Sender ).SayHello -end; - - -var - Host: THost; - Dummy: TDummy; -begin - Dummy := TDummy.Create; - Host := THost.Create; - with Host,Dummy do - OnEvent := @HandleEvent; // this is 57, 27 is ";" - Host.Trigger; -end. diff --git a/tests/tbs/tbs0250.pp b/tests/tbs/tbs0250.pp deleted file mode 100644 index b39f6964c7..0000000000 --- a/tests/tbs/tbs0250.pp +++ /dev/null @@ -1,29 +0,0 @@ -program testme; - -uses erroru; - -// Removing this switch removes the bug !! -{$H+} - -var A : String; - P : PChar; - I : longint; - -begin - P := 'Some sample testchar'; - A := Ansistring(P); - Writeln ('A : ',A); - for I:=1 to length(A)-1 do - begin - A:='Some small test'; - A:=A+' ansistring'; - Writeln ('A : ',A); - If A<>'' then - Writeln ('All is fine') - else - begin - writeln ('Oh-oh!'); - error; - end; - end; -end. diff --git a/tests/tbs/tbs0251.pp b/tests/tbs/tbs0251.pp deleted file mode 100644 index ce1530ccb6..0000000000 --- a/tests/tbs/tbs0251.pp +++ /dev/null @@ -1,26 +0,0 @@ - -uses erroru; - -const - c : byte = 5; - r : real = 3.4; -var - l : longint; - cc : char; - rr : real; - -begin - l:=longint(@r); - if (l mod 4)<>0 then - begin - Writeln('static const are not aligned properly !'); - error; - end; - cc:='d'; - l:=longint(@rr); - if (l mod 4)<>0 then - begin - Writeln('static var are not aligned properly !'); - error; - end; -end. diff --git a/tests/tbs/tbs0252.pp b/tests/tbs/tbs0252.pp deleted file mode 100644 index 0fb04c2285..0000000000 --- a/tests/tbs/tbs0252.pp +++ /dev/null @@ -1,18 +0,0 @@ -type - wnd=procedure; - r=record - w : wnd; - end; - -procedure p; -begin -end; - -const - r1:r=( - w : wnd(@p); - ); - -begin -end. - diff --git a/tests/tbs/tbs0253.pp b/tests/tbs/tbs0253.pp deleted file mode 100644 index 3239523cb7..0000000000 --- a/tests/tbs/tbs0253.pp +++ /dev/null @@ -1,18 +0,0 @@ -procedure test(w : word);forward; - -procedure test(a : string); -begin - Writeln(a); - test(20); -end; - -procedure test(w :word); -begin - writeln(w); -end; - -begin - test('test'); - test(32); -end. - diff --git a/tests/tbs/tbs0254.pp b/tests/tbs/tbs0254.pp deleted file mode 100644 index a6c7830388..0000000000 --- a/tests/tbs/tbs0254.pp +++ /dev/null @@ -1,4 +0,0 @@ -begin -end. - -disposestr \ No newline at end of file diff --git a/tests/tbs/tbs0255.pp b/tests/tbs/tbs0255.pp deleted file mode 100644 index 43441d41a2..0000000000 --- a/tests/tbs/tbs0255.pp +++ /dev/null @@ -1,9 +0,0 @@ - -function a: char; -begin - a:='c'; -end; - -begin - if #12 in [a, a, a, a, a] then ; { <--- } -end. diff --git a/tests/tbs/tbs0256.pp b/tests/tbs/tbs0256.pp deleted file mode 100644 index a0a5ab3bf7..0000000000 --- a/tests/tbs/tbs0256.pp +++ /dev/null @@ -1,13 +0,0 @@ -{$mode tp} - -{$undef dummy } - -{$ifdef dummy} - procedure test; - begin - foreach({$ifndef TP}@{$endif}add_to_browserlog); - end; -{$endif BrowserLog} - -begin -end. diff --git a/tests/tbs/tbs0257.pp b/tests/tbs/tbs0257.pp deleted file mode 100644 index 96f0303036..0000000000 --- a/tests/tbs/tbs0257.pp +++ /dev/null @@ -1,18 +0,0 @@ -{$mode tp} - -type proc = procedure(a : longint); -procedure test(b : longint); -begin - Writeln('Test ',b); -end; - -var - t : proc; - -begin - t:=test; - t:=proc(test); - test(3); - t(5); -end. - diff --git a/tests/tbs/tbs0258.pp b/tests/tbs/tbs0258.pp deleted file mode 100644 index d6df06efbd..0000000000 --- a/tests/tbs/tbs0258.pp +++ /dev/null @@ -1,63 +0,0 @@ -{$ifdef fpc} -{$mode tp} -{$endif fpc} -program test_set; - -uses erroru; - -{$R-} - -procedure test; - - var - i : longint; - j : integer; - k : word; - l : shortint; - m : byte; - x : array [1..32] of byte; - - begin - for i:=1 to 32 do x[i]:=$ff; - i:=1; - if not(i in [1,3,5,8,11,14,15]) then - begin - writeln('Error in set'); - error; - end; - i:=135; - if i in [1,3,5,8,11,14,15] then - begin - writeln('Error : 135 is in [1,3,5,8,11,14,15]'); - error; - end; - i:=257; - if not(i in [1,3,5,8,11,14,15]) then - begin - writeln('Error : 257 isn''t in [1,3,5,8,11,14,15]'); - error; - end; - l:=-1; - if not(l in [1,3,5,8,11,14,15,255]) then - begin - writeln('Error : -1 isn''t in [1,3,5,8,11,14,15,255]'); - error; - end; - i:=257; - if not(l in [1,3,5,8,11,14,15,255]) then - begin - writeln('Error : longint(257) isn''t in [1,3,5,8,11,14,15,255]'); - error; - end; - for i:=1 to 32 do x[i]:=0; - i:=135; - if i in [1,3,5,8,11,14,15] then - begin - writeln('Second try Error : 135 is in [1,3,5,8,11,14,15]'); - error; - end; - end; - -begin - test; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0259.pp b/tests/tbs/tbs0259.pp deleted file mode 100644 index 2c6e3106b6..0000000000 --- a/tests/tbs/tbs0259.pp +++ /dev/null @@ -1,7 +0,0 @@ -{ $OPT= -O1} - -VAR time1,time2 : Real; -BEGIN - time1 := 0; - time2 := time1*time1; -END. diff --git a/tests/tbs/tbs0260.pp b/tests/tbs/tbs0260.pp deleted file mode 100644 index 3aec046d23..0000000000 --- a/tests/tbs/tbs0260.pp +++ /dev/null @@ -1,32 +0,0 @@ -program test; - - type - obj1 = object - st : string; - constructor init; - procedure writeit; - end; - - obj2 = object(obj1) - procedure writeit;virtual; - end; - - obj3 = object(obj2) - l : longint; - end; - - constructor obj1.init; - begin - end; - - procedure obj1.writeit; - begin - end; - - procedure obj2.writeit; - begin - end; - - -begin -end. diff --git a/tests/tbs/tbs0261.pp b/tests/tbs/tbs0261.pp deleted file mode 100644 index fc0c394b2c..0000000000 --- a/tests/tbs/tbs0261.pp +++ /dev/null @@ -1,32 +0,0 @@ -program bug0261; - -{ test for operator overloading } -{ Copyright (c) 1999 Lourens Veen } -{ why doesn't this work? } -uses - erroru, - tbs0261a; - - -var a : mythingy; - b : myotherthingy; - c : mythirdthingy; -begin - a.x:=55; - a.y:=45; - a.c:=7; - b:=a; - c:=a; - if b.d<>c.e then - begin - Writeln('Error in assignment overloading'); - Halt(1); - end; - if b<>c then - begin - Writeln('Error in equal overloading'); - Halt(1); - end; - Writeln('Sizeof(mythirdthingy)=',sizeof(mythirdthingy)); - Writeln('Sizeof(mynewthingy)=',sizeof(mynewthingy)); -end. diff --git a/tests/tbs/tbs0261a.pp b/tests/tbs/tbs0261a.pp deleted file mode 100644 index 5ccdfc364c..0000000000 --- a/tests/tbs/tbs0261a.pp +++ /dev/null @@ -1,54 +0,0 @@ -unit tbs0261a; - -{ test for operator overloading } -{ Copyright (c) 1999 Lourens Veen } -{ why doesn't this work? } - -interface - -type mythingy = record - x, y : longint; - c : byte; - end; - - myotherthingy = record - x, y : longint; - d : byte; - end; - - mythirdthingy = record - x, y : longint; - e : byte; - end; - - mynewthingy = record - x, y : longint; - e,f : byte; - end; - -operator := (a : mythingy) r : myotherthingy; -operator := (a : mythingy) r : mythirdthingy; -operator = (b : myotherthingy;c : mythirdthingy) res : boolean; - -implementation - -operator := (a : mythingy) r : myotherthingy; -begin - r.x := a.x; - r.y := a.y; - r.d := a.c; -end; - -operator := (a : mythingy) r : mythirdthingy; -begin - r.x := a.x; - r.y := a.y; - r.e := a.c; -end; - -operator = (b : myotherthingy;c : mythirdthingy) res : boolean; -begin - res:=(b.x=c.x) and (b.y=c.y) and (b.d=c.e); -end; - -end. diff --git a/tests/tbs/tbs0262.pp b/tests/tbs/tbs0262.pp deleted file mode 100644 index 42eee03bfc..0000000000 --- a/tests/tbs/tbs0262.pp +++ /dev/null @@ -1,114 +0,0 @@ -program test; - - type - obj1 = object - st2 : string; - constructor init; - procedure writeit; - procedure writeit(st : string);virtual; - end; - - obj2 = object(obj1) - procedure writeit;virtual; - end; - - obj3 = object(obj2) - l2 : longint; - procedure writeit(l : longint);virtual; - procedure writeit(st : string);virtual; - end; - - obj4 = object(obj3) - procedure writeit;virtual; - procedure writeit(st : string);virtual; - end; - - obj5 = object(obj4) - procedure writeit;virtual; - procedure writeit(st : string); - procedure writeit(l : longint);virtual; - end; - - constructor obj1.init; - begin - end; - - procedure obj1.writeit; - begin - Writeln('Obj1 writeit'); - end; - - procedure obj1.writeit(st : string); - begin - Writeln('Obj1 writeit(string) ',st); - end; - - procedure obj2.writeit; - begin - Writeln('Obj2 writeit'); - end; - - procedure obj3.writeit(st : string); - begin - Writeln('Obj3 writeit(string) ',st); - end; - - procedure obj3.writeit(l : longint); - begin - Writeln('Obj2 writeit(longint) ',l); - end; - - procedure obj4.writeit; - begin - Writeln('Obj4 writeit'); - end; - - procedure obj4.writeit(st : string); - begin - Writeln('Obj4 writeit(string) ',st); - end; - - procedure obj5.writeit; - begin - Writeln('Obj5 writeit'); - end; - - procedure obj5.writeit(st : string); - begin - Writeln('Obj5 writeit(string) ',st); - end; - - procedure obj5.writeit(l : longint); - begin - Writeln('Obj5 writeit(longint) ',l); - end; - -var - o1 : obj1; - o2 : obj2; - o3 : obj3; - o4 : obj4; - o5 : obj5; - - - -begin - o1.init; - o1.writeit; - o1.writeit('o1'); - o2.init; - o2.writeit; - o2.writeit('o2'); - o3.init; - o3.writeit; - o3.writeit('o3'); - o3.writeit(3); - o4.init; - o4.writeit; - o4.writeit('o4'); - o4.writeit(4); - o5.init; - o5.writeit; - o5.writeit('o5'); - o5.writeit(5); -end. diff --git a/tests/tbs/tbs0263.pp b/tests/tbs/tbs0263.pp deleted file mode 100644 index 912a81ed05..0000000000 --- a/tests/tbs/tbs0263.pp +++ /dev/null @@ -1,26 +0,0 @@ -{$ifdef linux} - {$define doit} -{$endif} -{$ifdef win32} - {$define doit} -{$endif} -{$ifdef doit} -library tbs0263; - -{ - The export directive is not necessary anymore in delphi, it's a leftover - from the 16bit model, just like near and far. -} - -procedure testp; -begin -end; - -exports - testp name 'testp'; - -end. -{$else} -begin -end. -{$endif} diff --git a/tests/tbs/tbs0264.pp b/tests/tbs/tbs0264.pp deleted file mode 100644 index dd74d8336f..0000000000 --- a/tests/tbs/tbs0264.pp +++ /dev/null @@ -1,44 +0,0 @@ -{$MODE DELPHI} - -type - a = class - c : procedure of object; - - constructor create; virtual; - destructor destroy; override; - - procedure e; virtual; - procedure f; virtual; - end; - -constructor a.create; -begin - c := @e; -end; - -destructor a.destroy; -begin -end; - -procedure a.e; -begin - Writeln('E'); - c := @f; -end; - -procedure a.f; -begin - Writeln('F'); - c := @e; -end; - -var - z : a; - -begin - z := a.create; - z.c; - z.c; - z.c; - z.free; -end. diff --git a/tests/tbs/tbs0266.pp b/tests/tbs/tbs0266.pp deleted file mode 100644 index 7788f2f708..0000000000 --- a/tests/tbs/tbs0266.pp +++ /dev/null @@ -1,16 +0,0 @@ -PROGRAM t10; - -USES CRT; - -VAR S: STRING; - X: BYTE; - - - BEGIN - S := ''; - FOR X := 1 TO 253 DO S:=S+'-'; - S := S+'_!'; - WRITE(S); - WRITE('*',S); - END. - \ No newline at end of file diff --git a/tests/tbs/tbs0267.pp b/tests/tbs/tbs0267.pp deleted file mode 100644 index 8a651b2f23..0000000000 --- a/tests/tbs/tbs0267.pp +++ /dev/null @@ -1,28 +0,0 @@ -{$MODE objfpc} - -program procofobject_arg; -type - TProcOfObject = procedure of object; - TTestClass = class - procedure SomeMethod; - end; - -procedure TTestClass.SomeMethod; begin end; - - -// the following proc won't print i2 correctly - -procedure CrashProc(i1: Integer;method: TProcOfObject; i2: Integer); -begin - WriteLn('i1 is :', i1); - WriteLn('i2 is :', i2); - if i2<>456 then - Halt(1); -end; - -var - instance: TTestClass; -begin - instance := TTestClass.Create; - CrashProc(123, @instance.SomeMethod, 456); -end. diff --git a/tests/tbs/tbs0268.pp b/tests/tbs/tbs0268.pp deleted file mode 100644 index 8d79aa0a82..0000000000 --- a/tests/tbs/tbs0268.pp +++ /dev/null @@ -1,30 +0,0 @@ -PROGRAM Test2; - -{$MODE DELPHI} - -USES SysUtils; // Dos for DosError because FindFirst is not a Function? - -PROCEDURE DirList; -(* Show all Files, gives me "unhandled exception occurred at xxx, access - violation" after inserting Try Except it worked but i got a "forever - scrolling screen", then i inserted raise and got a correct "Exception - in FindFirst" and "At end of ExceptionAddressStack" - Next i inserted the ON E:EXCEPTION and ,E.Message an got 9999 *) -VAR SR : TSearchRec; -BEGIN - TRY - FindFirst ('*',faAnyFile,SR); // why not a function ? - EXCEPT - ON E:EXCEPTION DO - WriteLn ('Exception in FindFirst !-', E.Message); - END; - repeat - Write (SR.Name,' '); - until FindNext (SR)<>0; - FindClose (SR); // and this is Delphi ? -END; - -BEGIN - WriteLn ('Hello, this is my first FPC-Program'); - DirList; -END. diff --git a/tests/tbs/tbs0270.pp b/tests/tbs/tbs0270.pp deleted file mode 100644 index e30c3d047f..0000000000 --- a/tests/tbs/tbs0270.pp +++ /dev/null @@ -1,21 +0,0 @@ -unit tbs0270; - -{$mode tp} - -interface - -const - s='df'; - -{$IFDEF VDE} - SFilterOpen = ' (*.nnn)|*.nnn' + '|' + 'Alle Files (*.*)|*.*'; - SFilterSave = ' (*.nnn)|*.nnn'; - SFilterOpen2 = ' (*.vvv)|*.vvv' + '|' + 'All Files (*.*)|*.*'; - SFilterSave2 = ' (*.vvv)|*.vvv'; - SFilterOpen3 = ' (*.eee)|*.eee' + '|' + 'All Files (*.*)|*.*'; - SFilterSave3 = ' (*.eee)|*.eee'; -{$ENDIF} - -implementation - -end. diff --git a/tests/tbs/tbs0271.pp b/tests/tbs/tbs0271.pp deleted file mode 100644 index dca7b39fb6..0000000000 --- a/tests/tbs/tbs0271.pp +++ /dev/null @@ -1,31 +0,0 @@ -{$mode fpc} - type - tproc = procedure; - -procedure proc1; -begin -end; - -var - _copyscan : tproc; - -procedure setproc; -begin - _copyscan := @proc1; -end; - -procedure testproc; -begin - if not (_copyscan=@proc1) then - begin - Writeln(' Problem procvar equality'); - Halt(1); - end - else - Writeln(' No problem with procedure equality'); -end; - -begin - setproc; - testproc; -end. diff --git a/tests/tbs/tbs0272.pp b/tests/tbs/tbs0272.pp deleted file mode 100644 index 1ced579894..0000000000 --- a/tests/tbs/tbs0272.pp +++ /dev/null @@ -1,33 +0,0 @@ -program test_const_string; - - -function astring(s :string) : string; - -begin - astring:='Test string'+s; -end; - -procedure testvar(var s : string); -begin - writeln('testvar s is "',s,'"'); -end; - -procedure testconst(const s : string); -begin - writeln('testconst s is "',s,'"'); -end; - -procedure testvalue(s : string); -begin - writeln('testvalue s is "',s,'"'); -end; - -const - s : string = 'test'; - conststr = 'Const test'; -begin - testvalue(astring('e')); - testconst(astring(s)); - testconst(conststr); -end. - diff --git a/tests/tbs/tbs0273.pp b/tests/tbs/tbs0273.pp deleted file mode 100644 index dd0ee23816..0000000000 --- a/tests/tbs/tbs0273.pp +++ /dev/null @@ -1,18 +0,0 @@ -Program CharArr; - -Var CharArray : Array[1..4] Of Char; - - S : String; - -Begin - CharArray:='BUG?'; - S:=CharArray; - WriteLn(S); { * This is O.K. * } - WriteLn(CharArray); { * GENERAL PROTECTION FAULT. * } - if CharArray<>'BUG?' then - begin - Writeln('Error comparing charaay to constant string'); - Halt(1); - end; -End. - diff --git a/tests/tbs/tbs0274.pp b/tests/tbs/tbs0274.pp deleted file mode 100644 index 98fdbb90ea..0000000000 --- a/tests/tbs/tbs0274.pp +++ /dev/null @@ -1,13 +0,0 @@ -type - proc=procedure(a:longint); - -procedure prc(a:longint); -begin -end; - -var - p : proc; -begin - p:=@prc; - p:=@(prc); { should this be allowed ? } -end. \ No newline at end of file diff --git a/tests/tbs/tbs0275.pp b/tests/tbs/tbs0275.pp deleted file mode 100644 index 9e3af60bda..0000000000 --- a/tests/tbs/tbs0275.pp +++ /dev/null @@ -1,5 +0,0 @@ -var - d : single; -begin - writeln(longint(d)); -end. diff --git a/tests/tbs/tbs0276.pp b/tests/tbs/tbs0276.pp deleted file mode 100644 index 250652bf70..0000000000 --- a/tests/tbs/tbs0276.pp +++ /dev/null @@ -1,46 +0,0 @@ -{$asmmode intel} -type - trec = record - ypos, - xpos : longint; - end; - - z80cont = record - dummy : longint; - page: array [0..11,0..16383] of byte; - end; - -var - rec : tRec; - myz80 : z80cont; - error : boolean; - test : byte; -begin - error:=false; - test:=23; - rec.xpos:=1; - myz80.page[0,5]:=15; - asm - lea edi, Rec - cmp byte ptr [edi+tRec.Xpos], 1 - jne @error - cmp byte ptr [edi].trec.Xpos, 1 - jne @error - mov ecx, 5 - mov dh,byte ptr myz80.page[ecx] - cmp dh,15 - jne @error - mov byte ptr myz80.page[ecx],51 - jmp @noerror - @error: - mov byte ptr error,1 - @noerror: - end; - if error or (test<>23) or (myz80.page[0,5]<>51) then - begin - Writeln('Error in assembler code generation'); - Halt(1); - end - else - Writeln('Correct assembler generated'); -end. diff --git a/tests/tbs/tbs0277.pp b/tests/tbs/tbs0277.pp deleted file mode 100644 index 279ba7af7d..0000000000 --- a/tests/tbs/tbs0277.pp +++ /dev/null @@ -1,5 +0,0 @@ - program bug0277; - const test_byte=pchar(1); - begin - writeln('Hello world'); - end. diff --git a/tests/tbs/tbs0278.pp b/tests/tbs/tbs0278.pp deleted file mode 100644 index b845e23f3c..0000000000 --- a/tests/tbs/tbs0278.pp +++ /dev/null @@ -1,29 +0,0 @@ -{$ifdef fpc}{$mode tp}{$endif} -unit tbs0278; - -interface - -{ -a string constant within $IFDEF that -contains "(*" causes an error; -compile it with "ppc386 test -So" or "-Sd" -} - -var - c : char; - -{$IFDEF not_defined} -const - c = 'b''(* - -{ $else} - -var - c : char; - -{$ENDIF} - - -implementation - -end. diff --git a/tests/tbs/tbs0279.pp b/tests/tbs/tbs0279.pp deleted file mode 100644 index 0ba1704ebf..0000000000 --- a/tests/tbs/tbs0279.pp +++ /dev/null @@ -1,33 +0,0 @@ -{$H+} -Program AnsiTest; - -Type - PS=^String; - -procedure test; -var - P:PS; -Begin - New(P); - P^:=''; - P^:=P^+'BLAH'; - P^:=P^+' '+P^; - Writeln(P^); - Dispose(P); -end; - -var - membefore : longint; - -begin - membefore:=memavail; - test; - if membefore<>memavail then - begin - Writeln('Memory hole using pointers to ansi strings'); - Halt(1); - end - else - Writeln('No memory hole with pointers to ansi strings'); -end. - diff --git a/tests/tbs/tbs0280.pp b/tests/tbs/tbs0280.pp deleted file mode 100644 index dee16512eb..0000000000 --- a/tests/tbs/tbs0280.pp +++ /dev/null @@ -1,48 +0,0 @@ -{$mode objfpc} -{$H+} - -program memhole; - -{$ifdef go32v2} -uses - dpmiexcp; -{$endif go32v2} - -type - TMyClass = class - s: String; - end; - plongint = ^longint; - -procedure dotest; - -var - c: TMyClass; - s : string; - -begin - s:='world'; - s:='Hallo '+s; - writeln((plongint(s)-4)^); - c := TMyClass.Create; - writeln(longint(c.s)); - c.s := Copy('Test', 1, 4); - writeln((plongint(c.s)-4)^); - c.free; -end; - -var - membefore : longint; -begin - membefore:=memavail; - writeln(memavail); - dotest; - writeln(memavail); - if membefore<>memavail then - begin - Writeln('Memory hole using ansi strings in classes'); - Halt(1); - end - else - Writeln('No memory hole unsing ansi strings in classes'); -end. diff --git a/tests/tbs/tbs0282.pp b/tests/tbs/tbs0282.pp deleted file mode 100644 index ffcbe08672..0000000000 --- a/tests/tbs/tbs0282.pp +++ /dev/null @@ -1,33 +0,0 @@ - -type very____long_____string___identifier= string[200]; - -procedure test(very__long_variable01: very____long_____string___identifier; - very__long_variable02: very____long_____string___identifier; - very__long_variable03: very____long_____string___identifier; - very__long_variable04: very____long_____string___identifier; - very__long_variable05: very____long_____string___identifier; - very__long_variable06: very____long_____string___identifier; - very__long_variable07: very____long_____string___identifier; - very__long_variable08: very____long_____string___identifier; - very__long_variable09: very____long_____string___identifier; - very__long_variable10: very____long_____string___identifier; - very__long_variable11: very____long_____string___identifier; - very__long_variable12: very____long_____string___identifier; - very__long_variable13: very____long_____string___identifier; - very__long_variable14: very____long_____string___identifier; - very__long_variable15: very____long_____string___identifier; - very__long_variable16: very____long_____string___identifier; - very__long_variable17: very____long_____string___identifier; - very__long_variable18: very____long_____string___identifier); -begin - writeln('hi!'); -end; - -begin - writeln('vreemd!'); - test('','','','','','','','','','', - '','','','','','','',''); -end. - - - diff --git a/tests/tbs/tbs0283.pp b/tests/tbs/tbs0283.pp deleted file mode 100644 index 113b9e9b80..0000000000 --- a/tests/tbs/tbs0283.pp +++ /dev/null @@ -1,12 +0,0 @@ -const dirsep = '\'; - -begin - if dirsep = '/' - then - begin - writeln('bug!'); - Halt(1); - end - else - writeln('ok'); -end. diff --git a/tests/tbs/tbs0284b.pp b/tests/tbs/tbs0284b.pp deleted file mode 100644 index bce19aa235..0000000000 --- a/tests/tbs/tbs0284b.pp +++ /dev/null @@ -1,9 +0,0 @@ -unit tbs0284b; -interface -type - o1=object - p : longint; - end; - -implementation -end. diff --git a/tests/tbs/tbs0285.pp b/tests/tbs/tbs0285.pp deleted file mode 100644 index 7b384c1c3a..0000000000 --- a/tests/tbs/tbs0285.pp +++ /dev/null @@ -1,18 +0,0 @@ -{$asmmode intel} - -TYPE something = RECORD big:LONGINT; small:BYTE; END; - -FUNCTION typesize:INTEGER; ASSEMBLER; -ASM - MOV EAX, TYPE something -END; - -BEGIN - writeln(typesize); - if typesize<>sizeof(something) then - begin - Writeln('Error in type inside intel asm'); - Halt(1); - end; -END. - diff --git a/tests/tbs/tbs0286.pp b/tests/tbs/tbs0286.pp deleted file mode 100644 index 19f6b3651f..0000000000 --- a/tests/tbs/tbs0286.pp +++ /dev/null @@ -1,5 +0,0 @@ -var - c : char; -begin - c:=#$08d; -end. diff --git a/tests/tbs/tbs0287.pp b/tests/tbs/tbs0287.pp deleted file mode 100644 index 7475ce252d..0000000000 --- a/tests/tbs/tbs0287.pp +++ /dev/null @@ -1,21 +0,0 @@ -var - b,bb : boolean; -begin - b:=(true > false); - if b then - writeln('ok 1') - else - halt(1); - b:=true; - b:=(b > false); - if b then - writeln('ok 2') - else - halt(1); - b:=false; - bb:=true; - if b $ffff then - begin - Writeln('i:=$ffff loads ',i,'$7fff if i is integer !'); - end; - j := 65535; - if j <> 65535 then - begin - Writeln('j:=65535 loads ',j,' if j is integer !'); - end; - if ($ffff=65535) and (i<>j) then - begin - Writeln('i and j are different !!!'); - Halt(1); - end; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0291.pp b/tests/tbs/tbs0291.pp deleted file mode 100644 index 5e229794f2..0000000000 --- a/tests/tbs/tbs0291.pp +++ /dev/null @@ -1,25 +0,0 @@ -{$mode tp} - -function ReturnString: string; -begin - ReturnString := 'A string'; -end; - -procedure AcceptString(S: string); -begin - WriteLn('Got: ', S); -end; - -type - TStringFunc = function: string; - -const - SF: TStringFunc = ReturnString; -var - S2: TStringFunc; -begin - @S2:=@ReturnString; - AcceptString(ReturnString); - AcceptString(SF); - AcceptString(S2); -end. diff --git a/tests/tbs/tbs0292.pp b/tests/tbs/tbs0292.pp deleted file mode 100644 index ee7844bda0..0000000000 --- a/tests/tbs/tbs0292.pp +++ /dev/null @@ -1,47 +0,0 @@ -{$mode objfpc} - -type - pobj = ^tobj; - tobj = object - a: ansistring; - constructor init(s: ansistring); - destructor done; - end; - - PAnsiRec = ^TAnsiRec; - TAnsiRec = Packed Record - Maxlen, - len, - ref : Longint; - First : Char; - end; - -const firstoff = sizeof(tansirec)-1; - -var o: pobj; - t: ansistring; - -constructor tobj.init(s: ansistring); -begin - a := s; -end; - -destructor tobj.done; -begin -end; - -const - s : string = ' with suffix'; -var - refbefore : longint; -begin - t:='test'+s; - refbefore:=pansirec(pointer(t)-firstoff)^.ref; - writeln('refcount before init: ',pansirec(pointer(t)-firstoff)^.ref); - new(o,init(t)); - writeln('refcount after init: ',pansirec(pointer(t)-firstoff)^.ref); - dispose(o,done); - writeln('refcount after done: ',pansirec(pointer(t)-firstoff)^.ref); - if refbefore<>pansirec(pointer(t)-firstoff)^.ref then - Halt(1); -end. diff --git a/tests/tbs/tbs0293.pp b/tests/tbs/tbs0293.pp deleted file mode 100644 index a37ab7e747..0000000000 --- a/tests/tbs/tbs0293.pp +++ /dev/null @@ -1,28 +0,0 @@ -program bug0293; - -{$ifdef fpc}{$mode objfpc}{$endif} - -TYPE Ttype = class - field :LONGINT; - CONSTRUCTOR DOSOMETHING; - END; - -CONSTRUCTOR TTYPE.DOSOMETHING; -BEGIN -END; - -var - longint : longint; - -procedure p; -VAR - TTYPE : TTYPE; -BEGIn - ttype:=ttype.dosomething; -END; - -begin - p; -end. - - diff --git a/tests/tbs/tbs0294.pp b/tests/tbs/tbs0294.pp deleted file mode 100644 index 1461c98b57..0000000000 --- a/tests/tbs/tbs0294.pp +++ /dev/null @@ -1,39 +0,0 @@ -{$mode tp} -{ this is allowed in BP !!! - but its complete nonsense because - this code sets parameter test - so the return value can not be set at all !!!!! - of course in Delphi you can use result so there it - makes sense to allow this ! PM } -function test(var test:longint):longint; -var - x : longint; -begin - { in BP the arg is change here !! } - test:=1; - x:=3; -end; - -function st(var st : string) : string; -begin - st:='OK'; -end; - -var t : longint; - myst : string; -begin - t:=2; - myst:='Before'; - test(t); - st(myst); - if (t<>1) then - begin - writeln('Test arg in Test function is not handled like in BP'); - halt(1); - end; - if (myst<>'OK') then - begin - writeln('St arg in St string function is not handled like in BP'); - halt(1); - end; -end. diff --git a/tests/tbs/tbs0295.pp b/tests/tbs/tbs0295.pp deleted file mode 100644 index fa803d4065..0000000000 --- a/tests/tbs/tbs0295.pp +++ /dev/null @@ -1,18 +0,0 @@ -type - t1=longint; - -procedure p; -type - pt1=^t1; - t1=string; -var - t : t1; - p : pt1; -begin - p:=@t; - p^:='test'; -end; - -begin - p; -end. diff --git a/tests/tbs/tbs0296.pp b/tests/tbs/tbs0296.pp deleted file mode 100644 index 267026ab9a..0000000000 --- a/tests/tbs/tbs0296.pp +++ /dev/null @@ -1,13 +0,0 @@ - -function test : string; - - begin - test:='This should not be printed'; - exit('this should be printed'); - end; - -begin - writeln(test); - if test<>'this should be printed' then - Halt(1); -end. diff --git a/tests/tbs/tbs0297.pp b/tests/tbs/tbs0297.pp deleted file mode 100644 index aed3c041e4..0000000000 --- a/tests/tbs/tbs0297.pp +++ /dev/null @@ -1,14 +0,0 @@ -program test_int; - -{$ifdef go32v2} - uses - dpmiexcp; -{$endif go32v2} - -procedure int;interrupt; -begin -end; - -begin - int; -end. diff --git a/tests/tbs/tbs0299.pp b/tests/tbs/tbs0299.pp deleted file mode 100644 index bb0ec856b7..0000000000 --- a/tests/tbs/tbs0299.pp +++ /dev/null @@ -1,29 +0,0 @@ -type - TwoChar = Array[0..1] of char; - Empty = Record - End; -const - asd : TwoChar = ('a','b'); - -procedure Tester(i:TwoChar; a: Empty;l : longint;var ll : longint); -begin - i[0]:=i[1]; - Writeln('l = ',l,' @l = ',hexstr(longint(@l),8),' @a = ',hexstr(longint(@a),8)); - inc(ll); -end; - -var - a : Empty; - l,ll : longint; -begin - l:=6; - ll:=15; - Writeln(Sizeof(asd)); - Tester(asd,a,l,ll); - Writeln(asd); - if (ll<>16) then - Begin - Writeln('Error with passing value parameter of type array [1..2] of char'); - Halt(1); - end; -end. diff --git a/tests/tbs/tbs0302.pp b/tests/tbs/tbs0302.pp deleted file mode 100644 index c4268bc3c9..0000000000 --- a/tests/tbs/tbs0302.pp +++ /dev/null @@ -1,19 +0,0 @@ -{$ifdef fpc}{$mode objfpc}{$endif} -type - c1=class - Ffont : longint; - property Font:longint read Ffont; - end; - - c2=class(c1) - function GetFont:longint; - end; - -function c2.GetFont:longint; -begin - result:=Font; - result:=inherited Font; -end; - -begin -end. diff --git a/tests/tbs/tbs0303.pp b/tests/tbs/tbs0303.pp deleted file mode 100644 index a4c7b74c44..0000000000 --- a/tests/tbs/tbs0303.pp +++ /dev/null @@ -1,21 +0,0 @@ - - type - intarray = array[1..1000,0..1] of longint; - - procedure test; - var - ar : intarray; - i : longint; - procedure local; - begin - i:=4; - ar[i,0]:=56; - ar[i-1,0]:=pred(ar[i,0]); - end; - begin - local; - end; - -begin - test; -end. diff --git a/tests/tbs/tbs0304.pp b/tests/tbs/tbs0304.pp deleted file mode 100644 index b7f33fc2b2..0000000000 --- a/tests/tbs/tbs0304.pp +++ /dev/null @@ -1,19 +0,0 @@ -{$asmmode intel} -{$inline on} - -var - cb : word; - -procedure A(B: word); assembler; inline; -asm - MOV AX,B - CMP AX,[CB] - JZ @@10 - MOV [CB],AX -@@10: -end; - -begin - a(1); - a(2); -end. \ No newline at end of file diff --git a/tests/tbs/tbs0305.pp b/tests/tbs/tbs0305.pp deleted file mode 100644 index cbd1e371e3..0000000000 --- a/tests/tbs/tbs0305.pp +++ /dev/null @@ -1,28 +0,0 @@ -{$mode objfpc} -uses -(* sysutils does not work correctly with DPMIEXCP unit - anyway, its not needed anymore - since the exception handler is now in system unit -{$ifdef go32v2} -dpmiexcp, -{$endif} *) -sysutils; -var i,j,k:real; -const except_called : boolean = false; -begin - i:=100; - j:=0; - try - k:=i/j; - writeln(k:5:3); - except - k:=0; - writeln('Illegal Input'); - except_called:=true; - end; - if not except_called then - begin - Writeln('Error in except handling'); - Halt(1); - end; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0306.pp b/tests/tbs/tbs0306.pp deleted file mode 100644 index e0cf5e4be9..0000000000 --- a/tests/tbs/tbs0306.pp +++ /dev/null @@ -1,45 +0,0 @@ -{$MODE objfpc} -{$H+} - -{ - Don't forget break,continue support -} - -program stackcrash; -uses sysutils; -type - TMyClass = class - public - procedure Proc1; - procedure Proc2; - end; - -procedure TMyClass.Proc1; -var - x, y: Integer; -begin - try - exit; - except - on e: Exception do begin e.Message := '[Proc1]' + e.Message; raise e end; - end; -end; - -procedure TMyClass.Proc2; -var - x: array[0..7] of Byte; - crash: Boolean; -begin - crash := True; // <--- ! This corrupts the stack?!? - raise Exception.Create('I will crash now...'); -end; - -var - obj: TMyClass; -begin - obj := TMyClass.Create; - obj.Proc1; - WriteLn('Proc1 done, calling Proc2...'); - obj.Proc2; - WriteLn('Proc2 done'); -end. diff --git a/tests/tbs/tbs0306.ree b/tests/tbs/tbs0306.ree deleted file mode 100644 index 6c3bac7ce2..0000000000 --- a/tests/tbs/tbs0306.ree +++ /dev/null @@ -1 +0,0 @@ -217 diff --git a/tests/tbs/tbs0307.pp b/tests/tbs/tbs0307.pp deleted file mode 100644 index 1bd5081def..0000000000 --- a/tests/tbs/tbs0307.pp +++ /dev/null @@ -1,33 +0,0 @@ -type - tobj = object - l: longint; - constructor init; - procedure setV(v: longint); - destructor done; - end; - -constructor tobj.init; -begin - l := 0; -end; - -procedure tobj.setV(v: longint); -begin - l := v; -end; - -destructor tobj.done; -begin -end; - -var t: tobj; - -begin - t.init; - with t do - setV(5); - writeln(t.l, ' (should be 5!)'); - if t.L<>5 then - Halt(1); - t.done; -end. diff --git a/tests/tbs/tbs0308.pp b/tests/tbs/tbs0308.pp deleted file mode 100644 index a5b6566633..0000000000 --- a/tests/tbs/tbs0308.pp +++ /dev/null @@ -1,5 +0,0 @@ -uses tbs0308a; - -begin - writeln(coursedb.name(60)); -end. diff --git a/tests/tbs/tbs0308a.pp b/tests/tbs/tbs0308a.pp deleted file mode 100644 index e9c28a9c37..0000000000 --- a/tests/tbs/tbs0308a.pp +++ /dev/null @@ -1,26 +0,0 @@ -unit tbs0308a; - -interface - -type - tcourses = object - function index(cName: string): integer; - function name(cIndex: integer): string; - end; - -var coursedb: tcourses; - l: longint; - -implementation - -function tcourses.index(cName: string): integer; -begin - index := byte(cName[0]); -end; - -function tcourses.name(cIndex: integer): string; -begin - name := char(byte(cIndex)); -end; - -end. diff --git a/tests/tbs/tbs0309.pp b/tests/tbs/tbs0309.pp deleted file mode 100644 index f36933682f..0000000000 --- a/tests/tbs/tbs0309.pp +++ /dev/null @@ -1,81 +0,0 @@ -{ This code was first written by Florian - to test the GDB output for FPU - he thought first that FPU output was wrong - but in fact it is a bug in FPC :( } -program bug0309; - -var - a,b : double; - _as,bs : single; - al,bl : extended; - aw,bw : integer; - ai,bi : longint; - ac : comp; -begin -{$ifdef CPU86} -{$asmmode att} - asm - fninit; - end; - a:=1; - b:=2; - asm - movl $1,%eax - fldl a - fldl b - faddp %st,%st(1) - fstpl a - end; - { the above generates wrong code in binary writer - fldl is replaced by flds !! - if using -alt option to force assembler output - all works correctly PM } - writeln('a = ',a,' should be 3'); - if a<>3.0 then - Halt(1); - a:=1.0; - a:=a+b; - writeln('a = ',a,' should be 3'); - _as:=0; - al:=0; - asm - fldl a - fsts _as - fstpt al - end; - if (_as<>3.0) or (al<>3.0) then - Halt(1); - ai:=5; - bi:=5; - asm - fildl ai - fstpl a - end; - if a<>5.0 then - Halt(1); - - ac:=5; - asm - fildl ai - fstpl a - end; - if a<>5.0 then - Halt(1); - aw:=-4; - bw:=45; - asm - fildw aw - fstpl a - end; - if a<>-4.0 then - Halt(1); - ac:=345; - asm - fildq ac - fstpl a - end; - if a<>345.0 then - Halt(1); - -{$endif CPU86} -end. \ No newline at end of file diff --git a/tests/tbs/tbs0312.pp b/tests/tbs/tbs0312.pp deleted file mode 100644 index 5c642ec730..0000000000 --- a/tests/tbs/tbs0312.pp +++ /dev/null @@ -1,144 +0,0 @@ -{ Program that showss a problem if - Self is not reloaded in %esi register - at entry in local procedure inside method } - -uses - objects; - -type -{$ifndef FPC} - sw_integer = integer; -{$endif not FPC} - - PMYObj = ^TMyObj; - - TMyObj = Object(TObject) - x : longint; - Constructor Init(ax : longint); - procedure display;virtual; - end; - - PMYObj2 = ^TMyObj2; - - TMyObj2 = Object(TMyObj) - y : longint; - Constructor Init(ax,ay : longint); - procedure display;virtual; - end; - - PMyCollection = ^TMyCollection; - - TMyCollection = Object(TCollection) - function At(I : sw_integer) : PMyObj; - procedure DummyThatShouldNotBeCalled;virtual; - end; - - { TMy is also a TCollection so that - ShowMy and DummyThatShouldNotBeCalled are at same position in VMT } - TMy = Object(TCollection) - Col : PMyCollection; - MyObj : PMyObj; - ShowMyCalled : boolean; - constructor Init; - destructor Done;virtual; - procedure ShowAll; - procedure AddMyObj(x : longint); - procedure AddMyObj2(x,y : longint); - procedure ShowMy;virtual; - end; - - Constructor TMyObj.Init(ax : longint); - begin - Inherited Init; - x:=ax; - end; - - Procedure TMyObj.Display; - begin - Writeln('x = ',x); - end; - - Constructor TMyObj2.Init(ax,ay : longint); - begin - Inherited Init(ax); - y:=ay; - end; - - Procedure TMyObj2.Display; - begin - Writeln('x = ',x,' y = ',y); - end; - - Function TMyCollection.At(I : sw_integer) : PMyObj; - begin - At:=Inherited At(I); - end; - - Procedure TMyCollection.DummyThatShouldNotBeCalled; - begin - Writeln('This method should never be called'); - Abstract; - end; - - Constructor TMy.Init; - - begin - New(Col,Init(5,5)); - MyObj:=nil; - ShowMyCalled:=false; - end; - - Destructor TMy.Done; - begin - Dispose(Col,Done); - Inherited Done; - end; - - Procedure TMy.ShowAll; - - procedure ShowIt(P : pointer);{$ifdef TP}far;{$endif} - begin - ShowMy; - PMyObj(P)^.Display; - end; - begin - Col^.ForEach(@ShowIt); - end; - - Procedure TMy.ShowMy; - begin - if assigned(MyObj) then - MyObj^.Display; - ShowMyCalled:=true; - end; - - Procedure TMy.AddMyObj(x : longint); - - begin - MyObj:=New(PMyObj,Init(x)); - Col^.Insert(MyObj); - end; - - Procedure TMy.AddMyObj2(x,y : longint); - begin - MyObj:=New(PMyObj2,Init(x,y)); - Col^.Insert(MyObj); - end; - -var - My : TMy; -begin - My.Init; - My.AddMyObj(5); - My.AddMyObj2(4,3); - My.AddMyObj(43); - { MyObj field is now a PMyObj with value 43 } - My.ShowAll; - If not My.ShowMyCalled then - begin - Writeln('ShowAll does not work correctly'); - Halt(1); - end; - My.Done; - -end. \ No newline at end of file diff --git a/tests/tbs/tbs0313.pp b/tests/tbs/tbs0313.pp deleted file mode 100644 index 560e05d7ce..0000000000 --- a/tests/tbs/tbs0313.pp +++ /dev/null @@ -1,24 +0,0 @@ - {$asmmode intel} - TYPE - TPoint3 = RECORD - x,y,z:Single; - END; - - OPERATOR + (CONST p1,p2:TPoint3) p : TPoint3; Assembler; - ASM - mov EBX,[p1] - mov EDI,[p2] - mov EDX,[p] - movq MM0,[EBX] - pfadd MM0,[EDI] - movq [EDX],MM0 - { Now the correct way would be something like: } - movd MM0,[EBX+8] // [movd reg??,mem?? - invalid combination of opcod - movd MM1,[EDI+8] // and here, too - pfadd MM0,MM1 - movd [EDX+8],MM0 // and here - femms - END; - -begin -end. diff --git a/tests/tbs/tbs0316.pp b/tests/tbs/tbs0316.pp deleted file mode 100644 index 3cb4deed5e..0000000000 --- a/tests/tbs/tbs0316.pp +++ /dev/null @@ -1,20 +0,0 @@ -{$asmmode intel} - -procedure test(b : longint); assembler; -type - splitlong = packed record b1, b2, b3, b4 : Byte; end; -asm - mov splitlong(b).b2, al -end; - -{$asmmode att} - -procedure test2(b : longint); assembler; -type - splitlong = packed record b1, b2, b3, b4 : Byte; end; -asm - movb splitlong(b).b2, %al -end; - -begin -end. diff --git a/tests/tbs/tbs0317.pp b/tests/tbs/tbs0317.pp deleted file mode 100644 index 258e74587e..0000000000 --- a/tests/tbs/tbs0317.pp +++ /dev/null @@ -1,8 +0,0 @@ -{ $OPT= -Sen } - -{ This shouldn't give a warning, because it can be used in an other program } -var - exportedc : longint;cvar;public; -begin - exportedc:=0; -end. diff --git a/tests/tbs/tbs0318.pp b/tests/tbs/tbs0318.pp deleted file mode 100644 index 224c25be68..0000000000 --- a/tests/tbs/tbs0318.pp +++ /dev/null @@ -1,11 +0,0 @@ -{ $OPT=-Sen } -{$mode objfpc} -uses sysutils; - -{ The exception is used in the raise statement, so no Note should be thrown } -var - e : exception; -begin - e:=exception.create('test'); - raise e; -end. diff --git a/tests/tbs/tbs0318.ree b/tests/tbs/tbs0318.ree deleted file mode 100644 index e99fdcc524..0000000000 --- a/tests/tbs/tbs0318.ree +++ /dev/null @@ -1 +0,0 @@ -217 \ No newline at end of file diff --git a/tests/tbs/tbs0319.pp b/tests/tbs/tbs0319.pp deleted file mode 100644 index 7a41ba95fb..0000000000 --- a/tests/tbs/tbs0319.pp +++ /dev/null @@ -1,66 +0,0 @@ -{$ifdef fpc}{$mode delphi}{$endif} - -function a:longint; -var - a : longint; -begin - a:=1; -end; - -type - cl=class - k : longint; - procedure p1; - procedure p2; - end; - - o = class - nonsense :string; - procedure flup(nonsense:string); - end; - - o2 = class - nonsense :string; - procedure flop; - procedure flup(nonsense:longint); - procedure flup2(flop:longint); - end; - -procedure o.flup(nonsense:string); -begin -end; - -procedure o2.flop; -begin -end; - -procedure o2.flup(nonsense:longint); -var - l : longint; -begin - l:=nonsense; -end; - -procedure o2.flup2(flop:longint); -var - l : longint; -begin - l:=flop; - flup(flop); -end; - - -procedure cl.p1; -var - k : longint; -begin -end; - -procedure cl.p2; -var - p1 : longint; -begin -end; - -begin -end. diff --git a/tests/tbs/tbs0321.pp b/tests/tbs/tbs0321.pp deleted file mode 100644 index c26f8eb049..0000000000 --- a/tests/tbs/tbs0321.pp +++ /dev/null @@ -1,6 +0,0 @@ -{$mode delphi} -type - tfunc = function : longint stdcall; - -begin -end. diff --git a/tests/tbs/tbs0322.pp b/tests/tbs/tbs0322.pp deleted file mode 100644 index 1b917b0a05..0000000000 --- a/tests/tbs/tbs0322.pp +++ /dev/null @@ -1,24 +0,0 @@ -{$ifdef fpc}{$asmmode intel}{$endif} -var - boxes : record - pbox : longint; - pbox2 : longint; - end; -var - s1,s2 : longint; -begin -asm - mov s1,type boxes.pbox - mov s2,type boxes -end; - if s1<>sizeof(boxes.pbox) then - begin - writeln('Wrong size for TYPE'); - halt(1); - end; - if s2<>sizeof(boxes) then - begin - writeln('Wrong size for TYPE'); - halt(1); - end; -end. \ No newline at end of file diff --git a/tests/tbs/tbs0327.pp b/tests/tbs/tbs0327.pp deleted file mode 100644 index 80d5d1c48e..0000000000 --- a/tests/tbs/tbs0327.pp +++ /dev/null @@ -1,52 +0,0 @@ -{$ifdef fpc}{$mode delphi}{$endif} -unit tbs0327; -interface - -type - tc=class - procedure l(i:integer);overload; - procedure l(s:string);overload; - end; - - procedure l2(i:integer);overload; - procedure l2(s:string);overload; - -implementation - - procedure l3(i:integer);forward;overload; - procedure l3(s:string);forward;overload; - -procedure tc.l(i:integer); -begin -end; - -procedure tc.l(s:string); -begin -end; - -procedure l2(i:integer); -begin -end; - -procedure l2(s:string); -begin -end; - -procedure l3(i:integer);overload; -begin -end; - -procedure l3(s:string); -begin -end; - -procedure k(l:longint);overload; -begin -end; - -procedure k(l:string);overload; -begin -end; - -begin -end. diff --git a/tests/tbs/tbs0329.pp b/tests/tbs/tbs0329.pp deleted file mode 100644 index faea8e8c52..0000000000 --- a/tests/tbs/tbs0329.pp +++ /dev/null @@ -1,61 +0,0 @@ -{$packrecords c} - -type - SHORT=smallint; - WINBOOL = longbool; - WCHAR=word; - UINT=cardinal; - - COORD = record - X : SHORT; - Y : SHORT; - end; - - KEY_EVENT_RECORD = packed record - bKeyDown : WINBOOL; - wRepeatCount : WORD; - wVirtualKeyCode : WORD; - wVirtualScanCode : WORD; - case longint of - 0 : ( UnicodeChar : WCHAR; - dwControlKeyState : DWORD; ); - 1 : ( AsciiChar : CHAR ); - end; - - MOUSE_EVENT_RECORD = record - dwMousePosition : COORD; - dwButtonState : DWORD; - dwControlKeyState : DWORD; - dwEventFlags : DWORD; - end; - - WINDOW_BUFFER_SIZE_RECORD = record - dwSize : COORD; - end; - - MENU_EVENT_RECORD = record - dwCommandId : UINT; - end; - - FOCUS_EVENT_RECORD = record - bSetFocus : WINBOOL; - end; - - INPUT_RECORD = record - EventType : WORD; - case longint of - 0 : ( KeyEvent : KEY_EVENT_RECORD ); - 1 : ( MouseEvent : MOUSE_EVENT_RECORD ); - 2 : ( WindowBufferSizeEvent : WINDOW_BUFFER_SIZE_RECORD ); - 3 : ( MenuEvent : MENU_EVENT_RECORD ); - 4 : ( FocusEvent : FOCUS_EVENT_RECORD ); - end; - -begin - if sizeof(INPUT_RECORD)<>20 then - begin - writeln('Wrong packing for Packrecords C and union ',sizeof(INPUT_RECORD),' instead of ',20); - halt(1); - end; -end. - diff --git a/tests/tbs/tbs0330.pp b/tests/tbs/tbs0330.pp deleted file mode 100644 index 7b089e69c2..0000000000 --- a/tests/tbs/tbs0330.pp +++ /dev/null @@ -1,26 +0,0 @@ -{$ifdef fpc}{$mode objfpc}{$endif} -uses - Classes; - -type - TMyClass = class(TPersistent); - -var - MyVar: Integer; - - -type - TMyClass2 = class(TObject) - procedure MyProc; - end; - - TMyOtherClass = class(TPersistent); - -procedure TMyClass2.MyProc; -var - MyImportantVar: Integer; -begin -end; - -begin -end. diff --git a/tests/tbs/tbs0331.pp b/tests/tbs/tbs0331.pp deleted file mode 100644 index 918c36e3ea..0000000000 --- a/tests/tbs/tbs0331.pp +++ /dev/null @@ -1,15 +0,0 @@ -{$mode tp} -unit tbs0331; - - interface - - procedure a(s : string); - - implementation - - procedure a; - - begin - end; - -end. diff --git a/tests/tbs/tbs0332.pp b/tests/tbs/tbs0332.pp deleted file mode 100644 index db75dc20a0..0000000000 --- a/tests/tbs/tbs0332.pp +++ /dev/null @@ -1,11 +0,0 @@ -{$MODE objfpc} -uses Classes; -var - o: TComponent; - begin - o := TComponent(TComponent.NewInstance); - o.Create(nil); - o.Free; - end. - - diff --git a/tests/tbs/tbs0333.pp b/tests/tbs/tbs0333.pp deleted file mode 100644 index b7a88bae32..0000000000 --- a/tests/tbs/tbs0333.pp +++ /dev/null @@ -1,16 +0,0 @@ -var - a,b : comp; - s1,s2 : string; -begin - a:=11384563; - b:=a*a; - str(a*a:0:0,s1); - str(b:0:0,s2); - writeln(s1); - writeln(s2); - if (s1<>'129608274700969') or (s2<>'129608274700969') then - begin - writeln('Error with comp type rounding'); - halt(1); - end; -end. diff --git a/tests/tbs/tbs0334.pp b/tests/tbs/tbs0334.pp deleted file mode 100644 index fbfdd0630b..0000000000 --- a/tests/tbs/tbs0334.pp +++ /dev/null @@ -1,22 +0,0 @@ -{$ifdef fpc}{$mode objfpc}{$endif} - -type - tvarrec=record - vpointer : pointer; - end; -var - r : tvarrec; - b : boolean; -function Next: TVarRec; -begin - next:=r; -end; - -begin - r.vpointer:=@b; - { The result of next is loaded and a value is assigned } - with Next do - boolean(VPointer^) := true; - if not b then - writeln('Error with assigning to function result'); -end. diff --git a/tests/tbs/tbs0335.pp b/tests/tbs/tbs0335.pp deleted file mode 100644 index 2d608dd606..0000000000 --- a/tests/tbs/tbs0335.pp +++ /dev/null @@ -1,7 +0,0 @@ -{$mode delphi} -procedure f;stdcall export; -asm -end; - -begin -end. \ No newline at end of file diff --git a/tests/tbs/tbs0336.pp b/tests/tbs/tbs0336.pp deleted file mode 100644 index 17499cab63..0000000000 --- a/tests/tbs/tbs0336.pp +++ /dev/null @@ -1,45 +0,0 @@ -{$mode objfpc} -Uses classes,sysutils; - - -const dsmerged=0; - dsopenerror=1; - dscreateerror=2; - dsconverterror=3; - dsmismatcherror=4; - dscrcerror=5; - dserror=6; - -type tvsmergediffs=class - procedure execute; - end; - - tvsdiffitem= class - status : longint; - end; - -EMismatchedDiffError =class(exception); -EDiffCrcCompareError= class(exception); - -procedure TvsMergeDiffs.Execute; -var - Stream: tFileStream; - Item: TvsDiffItem; - a : longint; -begin - try - Item.Status := dsMerged; - except - { Only the number of on xx do statements seems to matter, not - which ones, try commenting 3 or 4 out} - on EFOpenError do Item.Status := dsOpenError; - on EFCreateError do Item.Status := dsCreateError; - on EConvertError do Item.Status := dsConvertError; - on EMismatchedDiffError do Item.Status := dsMismatchError; - on EDiffCrcCompareError do Item.Status := dsCrcError; - on Exception do Item.Status := dsError; - end; -end; - -begin -end. \ No newline at end of file diff --git a/tests/tbs/tbs0337.pp b/tests/tbs/tbs0337.pp deleted file mode 100644 index eb55a3a7e3..0000000000 --- a/tests/tbs/tbs0337.pp +++ /dev/null @@ -1,29 +0,0 @@ -program vartest; - -{$ifdef fpc}{$mode objfpc}{$endif} - -uses - Classes; - -type - TMyComponent = class(TComponent) - aaaaaaaaaa: TComponent; - b: TComponent; - private - public - constructor Create(AOwner: TComponent); override; - end; - - -constructor TMyComponent.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - aaaaaaaaaa := TComponent.Create(Self); -end; - -var - MyComponent: TMyComponent; - -begin - MyComponent := TMyComponent.Create(nil); -end. diff --git a/tests/tbs/tbs0338.pp b/tests/tbs/tbs0338.pp deleted file mode 100644 index 680f997eb3..0000000000 --- a/tests/tbs/tbs0338.pp +++ /dev/null @@ -1,10 +0,0 @@ -{$mode delphi} - -{$define skip} - -begin - writeln('Hello world!'); -{$ifndef skip} - write('}'); -{$endif skip} -end. diff --git a/tests/tbs/tbs0339.pp b/tests/tbs/tbs0339.pp deleted file mode 100644 index 63e2a0f515..0000000000 --- a/tests/tbs/tbs0339.pp +++ /dev/null @@ -1,20 +0,0 @@ -{ $OPT=-Sen } -type - rec=record - x,y : longint; - end; -var - r : array[1..10] of rec; - i : longint; -begin - i:=1; - with r[i] do - begin - x:=1; - y:=1; - end; - with r[i] do - begin - writeln(x,y); - end; -end. diff --git a/tests/tbs/tbs0340.pp b/tests/tbs/tbs0340.pp deleted file mode 100644 index 89a82e01e1..0000000000 --- a/tests/tbs/tbs0340.pp +++ /dev/null @@ -1,20 +0,0 @@ -{$packenum 1} -type - t = (a,b,c,d,e); - -const arr: array[0..4] of t = (a,b,c,d,e); - -var - x: byte; - -begin - x := 0; - writeln(ord(arr[x]),' ',ord(arr[x+1]),' ',ord(arr[x+2]),' ',ord(arr[x+3]),' ',ord(arr[x+4])); - for x:=0 to 4 do - if ord(arr[x])<>x then - begin - writeln('error in {$packenum 1}'); - halt(1); - end; -end. - diff --git a/tests/tbs/tbs0341.pp b/tests/tbs/tbs0341.pp deleted file mode 100644 index 38101514d6..0000000000 --- a/tests/tbs/tbs0341.pp +++ /dev/null @@ -1,13 +0,0 @@ -procedure IncLimit(var B: Byte; const Limit: Byte; const Incr: Byte); -begin -end; -procedure IncLimit(var B: Longint; const Limit: Longint; const Incr: Longint); -begin -end; - -var - b : byte; -begin - inclimit(b,128,3); -end. - diff --git a/tests/tbs/tbs0344.pp b/tests/tbs/tbs0344.pp deleted file mode 100644 index a7b7772349..0000000000 --- a/tests/tbs/tbs0344.pp +++ /dev/null @@ -1,6 +0,0 @@ -var - r : record - word : array[1..2] of word; - end; -begin -end. diff --git a/tests/tbs/tbs0346a.pp b/tests/tbs/tbs0346a.pp deleted file mode 100644 index cf2c8ed17a..0000000000 --- a/tests/tbs/tbs0346a.pp +++ /dev/null @@ -1,9 +0,0 @@ -unit tbs0346a; -interface - -type - word = system.word; - -implementation - -end. diff --git a/tests/tbs/tbs0346b.pp b/tests/tbs/tbs0346b.pp deleted file mode 100644 index 77a6cb9dec..0000000000 --- a/tests/tbs/tbs0346b.pp +++ /dev/null @@ -1,16 +0,0 @@ -unit tbs0346b; -interface - -{ this uses system.word } -procedure p(w:word); - -implementation -uses - tbs0346a; - -{ this uses tbs0346a.word } -procedure p(w:word); -begin -end; - -end. diff --git a/tests/tbs/tbs0348.pp b/tests/tbs/tbs0348.pp deleted file mode 100644 index 17d836c197..0000000000 --- a/tests/tbs/tbs0348.pp +++ /dev/null @@ -1,12 +0,0 @@ -{$mode delphi} - -type fluparr=array[0..1000] of longint; - flupptr=^fluparr; - -var flup : Flupptr; - Flupresult : longint; - flupa : fluparr; -begin - flup:=@flupa; - flupresult:=flup[5]; -end. diff --git a/tests/tbs/tbs0350.pp b/tests/tbs/tbs0350.pp deleted file mode 100644 index c5caf1852d..0000000000 --- a/tests/tbs/tbs0350.pp +++ /dev/null @@ -1,8 +0,0 @@ -var - c : char; - i : integer; -begin - i:=integer(c); - c:=char(i); -end. - diff --git a/tests/tbs/tbs0353.pp b/tests/tbs/tbs0353.pp deleted file mode 100644 index 1cb77706fc..0000000000 --- a/tests/tbs/tbs0353.pp +++ /dev/null @@ -1,23 +0,0 @@ -Var - I : Int64; - j : longint; - K : Int64; - err : boolean; -begin - I:=2; - Writeln(i); - K:=1 shl 62; - For j:=1 to 61 do - begin - I:=I*2; - If I/k*100>100 then - begin - Writeln('Error'); - err:=true; - end - else - Writeln(j:2,': ',i:20,' ',i div 1024:20,' ',(i/k*100):4:1); - end; - if err then - halt(1); -end. diff --git a/tests/tbs/tbs0355.pp b/tests/tbs/tbs0355.pp deleted file mode 100644 index b3e38eca15..0000000000 --- a/tests/tbs/tbs0355.pp +++ /dev/null @@ -1,17 +0,0 @@ -{MvdV; published in core. - Element that is in the type zz too is not recognised as such. - } - -type xx=(notinsubset1,insubset1,insubset2,notinsubset2); - zz=insubset1..insubset2; - - ll=record - yy:zz; - end; - -const oo : array[0..1] of ll = ( - (yy:insubset1), - (yy:insubset2)); -begin -end. - diff --git a/tests/tbs/tbs0356.pp b/tests/tbs/tbs0356.pp deleted file mode 100644 index 99d694c5fc..0000000000 --- a/tests/tbs/tbs0356.pp +++ /dev/null @@ -1,11 +0,0 @@ -unit tbs0356; -interface -uses sysutils; -type - - Foo = - packed record - Dates : array[1..11] of Date; - end; -implementation -end. diff --git a/tests/tbstbf.txt b/tests/tbstbf.txt deleted file mode 100644 index b55baa036b..0000000000 --- a/tests/tbstbf.txt +++ /dev/null @@ -1,404 +0,0 @@ -This directory contains test files for various FPC bugs. -The most files are very simple and it's neccessary to check the assembler -output. - -The first coloumn contains the file name. If the file name is indended, -the bug is fixed and the last coloumn contains the version where -the bug is fixed. - -In future, please add also your name short cut, when fixing a bug. - -Fixed bugs: ------------ - 1.pp produces a linker error under win32/linux, sorry for the filename - but the filename is the bug :) OK 0.99.11 (PFV) - bug0001.pp tests a bug in the .ascii output (#0 and too long) OK 0.9.2 - bug0002.pp tests for the endless bug in the optimizer OK 0.9.2 - bug0003.pp dito OK 0.9.2 - bug0004.pp tests the continue instruction in the for loop OK 0.9.2 - bug0005.pp tests the if 1=1 then ... bug OK 0.9.2 - bug0006.pp tests the wrong floating point code generation OK 0.9.2 - bug0007.pp tests the infinity loop when using byte counter OK 0.9.2 - bug0008.pp tests the crash when decrementing constants OK 0.9.2 - bug0009.pp tests comperations in function calls a(c<0); OK 0.9.2 - bug0010.pp tests string constants exceeding lines OK 0.9.2 - bug0011.pp tests div/mod bug, where edx is scrambled, if - a called procedure does a div/mod OK 0.9.2 - bug0012.pp tests type conversation byte(a>b) OK 0.9.9 (FK) - bug0015.pp tests for wrong allocated register for return result - of floating function (allocates int register) OK 0.9.2 - bug0018.pp tests for the possibility to declare all types - using pointers "forward" : type p = ^x; x=byte; OK 0.9.3 - bug0021.pp tests compatibility of empty sets with other set - and the evalution of constant sets OK 0.9.3 - bug0022.pp tests getting the address of a method OK 0.9.3 - bug0023.pp tests handling of self pointer in nested methods OK 0.9.3 - bug0025.pp tests for a wrong uninit. var. warning OK 0.9.3 - bug0026.pp tests for a wrong unused. var. warning OK 0.9.4 - bug0027.pp tests - type - enumtype = (One, two, three, forty:=40, fifty); OK 0.9.5 - bug0028.pp type enumtype = (a); writeln(ord(a)); - bug0029.pp tests typeof(object type) OK 0.99.1 (FK) - bug0030.pp tests type conversations in typed consts OK 0.9.6 - bug0031.pp tests array[boolean] of .... OK 0.9.8 - bug0032.pp tests for a bug with the stack OK 0.9.9 - bug0033.pp tests var p : pchar; begin p:='c'; end. OK 0.9.9 - bug0034.pp shows wrong line numbering when asmbler is parsed OK 0.9.9 - in direct mode. - bug0035.pp label at end of block gives error OK 0.9.9 (FK) - bug0036.pp assigning a single character to array of char ?OK 0.9.9 - gives a protection error - --------- cgi386.pas gives out gpf's when compiling the system OK 0.9.9 (FK) - unit. - bug0037.pp tests missing graph.setgraphmode OK RTL (FK) - bug0038.pp tests const ps : ^string = nil; OK 0.9.9 (FK) - bug0039.pp shows the else-else problem OK 0.9.9 (FK) - bug0040.pp shows the if b1 xor b2 problem where b1,b2 :boolean OK 0.9.9 (FK) - bug0041.pp shows the if then end. problem OK 0.9.9 (FK) - bug0042.pp shows assembler double operator expression problem OK 0.99.7 (PFV) - bug0043.pp shows assembler nasm output fpu opcodes problem OK 0.99.6 (PFV) - bug0044.pp shows $ifdef and comment nesting/directive problem OK 0.99.1 (PFV) - bug0045.pp shows problem with virtual private methods OK 0.9.9 (FK) - (might not be a true bug but more of an incompatiblity?) - the compiler warns now if there is a private and virtual - method - bug0046.pp problems with sets with values over 128 due to OK 0.99.1 (FK) - sign extension - (already fixed ) but also for SET_IN_BYTE - bug0047.pp compiling with -So crashes the compiler OK 0.99.1 (CEC) - bug0048.pp shows a problem with putimage on some computers OK 0.99.13 (JM) - bug0049.pp shows an error while defining subrange types OK 0.99.7 (PFV) - bug0050.pp can't set a function result in a nested procedure of a function OK 0.99.7 (PM) - bug0051.pp Graph, shows a problem with putpixel OK 0.99.9 (PM) - bug0052.pp Graph, collects missing graph unit routines OK 0.99.9 (PM) - bug0053.pp shows a problem with open arrays OK 0.99.1 (FK) - (crashes a win95-DOS box :) ) - bug0054.pp wordbool and longbool types are missed OK 0.99.6 (PFV) - bug0055.pp internal error 10 (means too few registers OK 0.99.1 (FK) - - i386 ONLY) - bug0056.pp shows a _very_ simple expression which generates OK 0.99.1 (FK) - wrong assembler - bug0057.pp Graph, shows a crash with switch graph/text/graph OK 0.99.9 (PM) - bug0058.pp causes an internal error 10 (problem with getregisterOK 0.99.1 (FK) - in secondsmaller - i386 ONLY) - bug0059.pp shows the problem with syntax error with ordinal OK 0.99.1 (FK) - constants - bug0060.pp shows missing type checking for case statements OK 0.99.1 (CEC) - bug0061.pp shows wrong errors when compiling (NOT A BUG) OK 0.99.1 - bug0062.pp shows illegal type conversion for boolean OK 0.99.6 (PFV) - bug0063.pp shows problem with ranges in sets for variables OK 0.99.7 (PFV) - bug0064.pp shows other types of problems with case statements OK 0.99.1 (FK) - bug0065.pp shows that frac() doesn't work correctly. OK 0.99.1 (PFV) - bug0066.pp shows that Round doesn't work correctly. (NOT A BUG) OK 0.99.1 - bug0067.pp and bug0067b.pp (Work together) OK 0.99.1 - Shows incorrect symbol resolution when using uses in implementation - More info can be found in file bug0067b.pp. - bug0068.pp Shows incorrect type of ofs() OK 0.99.1 (PFV and FK) - bug0069.pp Shows problem with far qualifier in units OK 0.99.1 (CEC) - bug0070.pp shows missing include and exclude from rtl OK 0.99.6 (MVC) - bug0071.pp shows that an unterminated constant string in a OK 0.99.1 (PFV) - writeln() statement crashes the compiler. - bug0072.pp causes an internal error 10 ( i386 ONLY ) OK 0.99.1 (FK) - bug0073.pp shows incompatiblity with bp for distance qualifiers OK 0.99.6 (PFV) - bug0074.pp shows MAJOR bug when trying to compile valid code OK 0.99.1 (PM/CEC) - bug0075.pp shows invalid pchar output to console OK 0.99.1 - ---------- compiling pp -Us -di386 -Sg system.pp gives GPF OK 0.99.1 - bug0076.pp Bug in intel asm generator. was already fixed OK 0.99.1 (FK) - bug0077.pp shows a bug with absolute in interface part of unit OK 0.99.1 (FK) - bug0077b.pp used by unit bug0077.pp - bug0078.pp Shows problems with longint constant in intel asm OK 0.99.1 (CEC) - parsers - bug0079.pp Shows problems with stackframe with assembler keyword OK 0.99.1 (CEC) - bug0080.pp Shows Missing High() (internal) function. OK 0.99.6 (MVC) - bug0081.pp Shows incompatibility with borland's 'array of char'. OK 0.99.1 (FK) - bug0082.pp Shows incompatibility with BP : Multiple destructors. OK 0.99.1 (FK) - bug0083.pp shows missing "dynamic" set constructor OK 0.99.7 (PFV) - bug0084.pp no more pascal type checking OK 0.99.1 (FK) - bug0085.pp shows runerror 216 OK 0.99.1 (CEC) - bug0086.pp shows runerror 216 OK 0.99.1 (CEC) - bug0087.pp shows internal error 12 - no more SegFaults OK 0.99.1 (FK) - bug0088.pp internal error 12 or Runerror 216 OK 0.99.1 (FK) - bug0089.pp internal error 12 or Runerror 216 OK 0.99.1 (FK) - bug0090.pp shows PChar comparison problem OK 0.99.7 (PFV) - bug0091.pp missing standard functions in constant expressions OK 0.99.7 (PFV) - bug0092.pp The unfixable bug. Maybe we find a solution one day. OK 0.99.6 (FK) - bug0093.pp Two Cardinal type bugs 0K 0.99.1 (FK/MvC) - bug0094.pp internal error when recordtype not found with case OK 0.99.1 - bug0095.pp case with ranges starting with #0 bugs OK 0.99.1 (FK) - bug0096.pp problem with objects as parameters OK 0.99.6 (PM) - bug0097.pp two errors in bp7 but not in FPC OK 0.99.6 (FK) - bug0098.pp File type casts are not allowed (works in TP7) OK 0.99.1 (FK) - bug0099.pp wrong assembler code is genereatoed for range check OK 0.99.1 (?) - (at least under 0.99.0) - bug0100.pp a unit may only occure once in uses OK 0.99.6 (PM) - bug0101.pp no type checking for routines in interfance and OK 0.99.1 (CEC) - implementation - bug0102.pp page fault when trying to compile under ppcm68k OK 0.99.1 - bug0103.pp problems with boolean typecasts (other type) OK 0.99.6 (PFV) - bug0104.pp cardinal greater than $7fffffff aren't written OK 0.99.1 (FK) - correct - bug0105.pp typecasts are now ignored problem (NOT A BUG) OK 0.99.1 - bug0106.pp typecasts are now ignored problem (NOT A BUG) OK 0.99.1 - bug0107.pp shows page fault problem (run in TRUE DOS mode) OK ??.?? - bug0108.pp gives wrong error message OK 0.99.1 (PFV) - bug0109.pp syntax error not detected when using a set as pointer OK 0.99.1 (FK) - bug0110.pp SigSegv when using undeclared var in Case OK 0.99.6 (PFV) - bug0112.pp still generates an internal error 10 OK 0.99.1 (FK) - bug0113.pp point initialization problems OK 0.99.1 (PM/FK) - bug0114.pp writeln problem (by Pavel Ozerski) OK 0.99.1 (PFV) - bug0115.pp missing writeln for comp data type OK 0.99.6 (FK) - bug0116.pp when local variable size is > $ffff, enter can't be OK 0.99.1 (FK) - used to create the stack frame, but it is with -Og - bug0117.pp internalerror 17 (and why is there an automatic float OK 0.99.6 (FK) - conversion?) - bug0118.pp Procedural vars cannot be assigned nil ? OK 0.99.6 (FK) - bug0119.pp problem with methods OK 0.99.6 (FK) - bug0120.pp inc/dec(enumeration) doesn't work OK 0.99.6 (MVC) - bug0121.pp cardinal -> byte conversion not work (and crashes) OK 0.99.6 (FK) - bug0122.pp exit() gives a warning that the result is not set OK 0.99.6 (FK) - bug0123.pp Asm, problem with intel assembler (shrd) OK 0.99.11 (PM) - bug0124.pp Asm, problem with -Rintel switch and indexing OK 0.99.11 (PM/PFV) - bug0125.pp wrong colors with DOS CRT unit OK 0.99.6 (PFV) - bug0126.pp packed array isn't allowed OK 0.99.6 (FK) - bug0127.pp problem with cdecl in implementation part OK 0.99.7 (PFV) - bug0128.pp problem with ^[ OK 0.99.6 (PFV) - bug0129.pp endless loop with while/continue OK 0.99.6 (FK) - bug0130.pp in [..#255] problem OK 0.99.6 (PFV) - bug0131.pp internal error 10 with highdimension arrays OK 0.99.6 (MVC) - bug0132.pp segmentation fault with type loop OK 0.99.7 (FK) - bug0134.pp 'continue' keyword is buggy. OK 0.99.6 (FK) - bug0135.pp Unsupported subrange type construction. OK 0.99.6 - bug0136.pp No types necessary in the procedure header OK 0.99.6 (PFV) - bug0137.pp Cannot assign child object variable to parent objcet type variable OK 0.99.6 - bug0138.pp with problem, %esi can be crushed and is not restored OK 0.99.6 (PM) - bug0139.pp Cannot access protected method of ancestor class from other unit. OK 0.99.6 - bug0140.pp Shows that interdependent units still are not OK. OK 0.99.6 (PFV) - bug0141.pp Wrong Class sizes when using forwardly defined classes. OK 0.99.6 - bug0142.pp sizeof(object) is not tp7 compatible when no constructor is used OK 0.99.9 (PM) - bug0143.pp cannot concat string and array of char in $X+ mode OK 0.99.7 (PFV) - bug0144.pp problem with 'with object do' OK 0.99.7 (PFV) - bug0145.pp typed files with huges records (needs filerec.size:longint) OK 0.99.7 (PFV) - bug0146.pp no sizeof() for var arrays and the size is pushed incorrect OK 0.99.7 (PFV) - bug0147.pp function b; is not allowed in implementation OK 0.99.7 (PFV) - bug0148.pp crash when setting function result of a declared but not yet OK 0.99.7 (PFV) - implemented function in another function - bug0149.pp (a, b) compile bug0149b twice and you'll get a crash OK 0.99.7 (PFV) - bug0150.pp Shows that the assert() macro is missing under Delphi OK 0.99.9 (PFV) - bug0151.pp crash when using undeclared variable in withstatement OK 0.99.7 (PFV) - bug0152.pp End value of loop variable must be calculated before loop - variable is initialized. OK 0.99.11 (PM) - bug0153.pp Asm, indexing a local/para var should produce an error like tp7 OK 0.99.9 (PFV) - bug0154.pp Subrange types give type mismatch when assigning to OK 0.99.7 (PFV) - bug0156.pp (a,b) forward type def in record crashes when loading ppu OK 0.99.7 (PM/PFV) - bug0155.pp Asm, Missing string return for asm functions - (this is a feature rather than a bug : OK 0.99.11 (FK) - complex return values are not allowed for assembler - functions (PM) Why not (FK)? ) - bug0157.pp Invalid compilation and also crashes OK 0.99.7 (PFV) - bug0158.pp Invalid boolean typecast OK 0.99.7 (PFV) - bug0159.pp Invalid virtual functions - should compile OK 0.99.7 (FK) - bug0160.pp Incompatibility with BP: Self shouldn't be a reserved word. OK 0.99.9 (PM) - bug0161.pp internal error when trying to create a set with another OK 0.99.9 (PFV) - bug0162.pp continue in repeat ... until loop doesn't work correct OK 0.99.8 (PFV) - bug0163.pp missing <= and >= operators for sets. OK 0.99.11 (JM) - bug0164.pp crash when using undeclared array index in with statement OK 0.99.8 (PFV) - bug0165.pp missing range check code for enumerated types. OK 0.99.9 (PFV) - bug0166.pp forward type used in declaration crashes instead of error OK 0.99.9 (PFV) - bug0167.pp crash when declaring a procedure with same name as object OK 0.99.9 (PFV) - bug0168.pp set:=set+element is allowed (should be: set:=set+[element]) OK 0.99.9 (PFV) - bug0169.pp missing new(type) support for not object/class OK 0.99.9 (PM) - bug0170.pp Asm, {$ifdef} is seen as a separator OK 0.99.9 (PFV) - bug0171.pp missing typecasting in constant expressions - solved for pointers OK 0.99.11 (PM) - bug0172.pp with with absolute seg:ofs should not be possible OK 0.99.9 (PM) - bug0173.pp secondbug is parsed as asm, but should be normal pascalcode OK 0.99.9 (PFV) - bug0174.pp Asm, offsets of fields are not possible yet OK 0.99.9 (PFV) - bug0175.pp Asm, mov word,%eax should not be allowed without casting - emits a warning (or error with range checking enabled) OK 0.99.11 (PM) - bug0176.pp unit.symbol not allowed for implementation vars OK 0.99.9 (PM) - bug0177.pp program.symbol not allowed (almost the same as bug 176) OK 0.99.9 (PM) - bug0178.pp problems with undefined labels and fail outside constructor OK 0.99.9 (PM) - bug0179.pp show a problem for -So mode OK 0.99.9 (PM) - bug0180.pp problem for units with names different from file name - should be accepted with -Un !! - Solved, but you still need to use the file name from other - units OK 0.99.9 (PM) - bug0181.pp shows a problem with name mangling OK 0.99.9 (PM) - bug0182.pp @record.field doesn't work in constant expr OK 0.99.9 (PM) - bug0183.pp internal error 10 in secondnot OK 0.99.11 (PM) - bug0184.pp multiple copies of the same constant set are stored in executable OK 0.99.9 (PFV) - bug0185.pp missing range checking for Val and subrange types OK 0.99.11 (JM/PFV) - bug0186.pp Erroneous array syntax is accepted. OK 0.99.9 (PFV) - bug0187.pp constructor in a WIth statement isn't called correct. - (works at lest in the case stated) OK 0.99.11 (PM) - bug0188.pp can't print function result of procedural var that returns a - function. Not a bug : wrong syntax !! See source (PM) - bug0189.pp cant compare adresses of function variables !! - As bug0188 FPC syntax problem see source (PM) - bug0190.pp can't have typecast for var params ?? OK 0.99.11 (PM) - bug0191.pp missing vecn constant evaluation OK 0.99.11 (PM) - bug0192.pp can't compare boolean result with true/false, because the - boolean result is already in the flags OK 0.99.11 (PFV) - bug0194.pp @procedure var returns value in it instead of address !! OK 0.99.11 (PM) - bug0195.pp Problem with Getimage, crash of DOS box, even with dpmiexcp!! (PFV) - Not a bug, you must use p^. - bug0196.pp "function a;" is accepted (should require result type) OK 0.99.1 (PM) - bug0197.pp should produce an error: problem with c1:=c2 255 are truncated (should work in -S2,-Sd) OK 0.99.11 (PFV) - bug0230.pp several strange happen on the ln function: ln(0): no - FPE and writeln can't write non numeric values - Gives out an exception on compiling because of zero div OK 0.99.11 (PM) - bug0231.pp Problem with comments OK 0.99.11 (PFV) - bug0232.pp const. procedure variables need a special syntax OK 0.99.13 (PFV) - if they use calling specification modifiers - bug0233.pp Problem with enum sets in args OK 0.99.11 (PFV) - bug0234.pp New with void pointer OK 0.99.11 (PM) - bug0235.pp Val(cardinal) bug OK 0.99.11 (JM) - bug0236.pp Problem with range check of subsets !! compile with -Cr OK 0.99.11 (PFV) - bug0237.pp Can't have sub procedures with names defined in interface OK 0.99.13 (PM) - bug0238.pp Internal error 432645 (from Frank MCCormick, mailinglist 24/2) OK 0.99.11 (PM) - bug0239.pp No warning for uninitialized class in IS statements OK 0.99.11 (PM) - bug0240.pp Problems with larges value is case statements OK 0.99.11 (FK) - bug0241.pp Problem with importing function from a DLL with .drv suffix ! OK 0.99.11 (PM) - bug0242.pp Crash when passing a procedure to formal parameter OK 0.99.11 (PM) - bug0244.pp nested procedures can't have same name as global ones (same as bug0237) OK 0.99.13 (PM) - bug0245.pp assigning pointers to address of consts is allowed (refused by BP !) OK 0.99.13 (PFV) - bug0246.pp const para can be changed without error OK 0.99.13 (PFV) - bug0247.pp var with initial value not supprted (Delphi var x : integer = 5;) - allowed in -Sd mode OK 0.99.11 (PM) - bug0248.pp Asm, Wrong assembler code accepted by new assembler reader OK 0.99.11 (PFV) - bug0249.pp procedure of object cannot be assigned to property. OK 0.99.11 (PFV) - bug0250.pp error with Ansistrings and loops. OK 0.99.11 (PFV) - bug0251.pp typed const are not aligned correctly OK 0.99.11 (PM) - bug0252.pp typecasting not possible within typed const OK 0.99.13 (PFV) - bug0253.pp problem with overloaded procedures and forward OK 0.99.11 (PFV) - bug0254.pp problem of endless loop if string at end of main - file without new line. OK 0.99.11 (PM) - bug0255.pp internal error 10 with in and function calls OK 0.99.12 (FK) - bug0256.pp problem with conditionnals in TP mode OK 0.99.11 (PM) - bug0257.pp problem with procvars in tp mode OK 0.99.11 (PM) - bug0258.pp bug in small const set extension to large sets OK 0.99.12 (PM) - bug0259.pp problem with optimizer for real math (use -O1) OK 0.99.12 (PM) - bug0260.pp problem with VMT generation if non virtual - method has a virtual overload OK 0.99.12 (PM) - bug0261.pp problems for assignment overloading OK 0.99.12a (PM) - bug0263.pp export directive is not necessary in delphi anymore OK 0.99.13 (PFV) - bug0264.pp methodpointer bugs OK 0.99.12b (FK) - bug0265.pp nested proc with for-counter in other lex level OK 0.99.13 (PFV) - bug0266.pp linux crt write cuts 256 char OK 0.99.13 (PFV) - bug0267.pp parameters after methodpointer are wrong OK 0.99.12b (FK) - bug0268.pp crash with exceptions OK 0.99.13 (FK) - bug0269.pp wrong linenumber for repeat until when type mismatch OK 0.99.12b (PM) - bug0270.pp unexpected eof in tp mode with (* and directives OK 0.99.13 (PFV) - bug0271.pp abstract methods can't be assigned to methodpointers OK 0.99.13 (??) - bug0272.pp No error issued if wrong parameter in function inside a second function OK 0.99.13 (PFV) - bug0273.pp small array pushing to array of char procedure is wrong OK 0.99.13 (PFV) - bug0274.pp @(proc) is not allowed OK 0.99.13 (PFV) - bug0276.pp Asm, intel reference parsing incompatibility OK 0.99.13 (PFV) - bug0277.pp typecasting with const not possible OK 0.99.13 (PFV) - bug0278.pp (* in conditional code is handled wrong for tp,delphi OK 0.99.13 (PFV) - bug0279.pp crash with ansistring and new(^ansistring) OK 0.99.13 (PFV) - bug0280.pp problem with object finalization. OK 0.99.13 (FK) - bug0282.pp long mangledname problem with -Aas OK 0.99.13 (PFV) - bug0283.pp bug in constant char comparison evaluation OK 0.99.13 (PFV) - bug0284.pp wrong file position with dup id in other unit OK 0.99.13 (PFV) - bug0285.pp Asm, TYPE not support in intel mode OK 0.99.13 (PFV) - bug0286.pp #$08d not allowed as Char constant OK 0.99.13 (PFV) - bug0287.pp (true > false) not supported OK 0.99.13 (PFV) - bug0288.pp crash with virtual method in except part OK 0.99.13 (PFV) - bug0289.pp no hint/note for unused types : implemented with -vnh OK 0.99.13 (PM) - bug0291.pp @procvar in tp mode bugs OK 0.99.13 (PFV) - bug0292.pp objects not finalized when disposed OK 0.99.13 (FK) - bug0295.pp forward type definition is resolved wrong OK 0.99.13 (PFV) - bug0296.pp exit(string) does not work (web form bug 613) OK 0.99.13 (PM) - bug0297.pp calling of interrupt procedure allowed but wrong code generated OK 0.99.13 (PM) - bug0298.pp l1+l2:=l1+l2 gives no error OK 0.99.13 (PFV) - bug0299.pp passing Array[0..1] of char by value to proc leads to problems OK 0.99.13 (PM) - bug0300.pp crash if method on non existing object is parsed (form bug 651) OK 0.99.13 (PFV) - bug0301.pp crash if destructor without object name is parsed OK 0.99.13 (PFV) - bug0302.pp inherited property generates wrong assembler OK 0.99.13 (PFV) - bug0303.pp One more InternalError(10) out of register ! OK 0.99.13 (FK) - bug0304.pp Label redefined when inlining assembler OK 0.99.13 (PFV) - bug0306.pp Address is not popped with exit in try...except block OK 0.99.13 (PFV) - bug0307.pp "with object_type" doesn't work correctly! OK 0.99.13 (?) - bug0308a.pp problem with objects that don't have VMT nor variable fields OK 0.99.13 (FK) - bug0309.pp problem with ATT assembler written by bin writer OK 0.99.14 (PFV) -bug0310.pp local and para dup are not detected OK 0.99.15 (FK) -bug0311.pp No dup id checking in variant records OK 0.99.15 (FK) - - -Unproducable bugs: ------------------- - - -Unfixed not important bugs (mostly incompatibilities): ------------------------------------------------------- -bug0111.pp blockread(typedfile,...) is not allowed in TP7 -bug0133.pp object type declaration not 100% compatibile with TP7 -bug0193.pp overflow checking for 8 and 16 bit operations wrong - overflow are just special range checks so - as all operations are done on 32 bit integers in FPC - overflow checking will only trap 32 bit overflow - you have to use range checks for byte or 16 bit integers -bug0243.pp Arguments of functions are computed from right to left this - is against pascal convention - but only BP respects this convention Delphi and GPC also - use right to left pushing !! -bug0281.pp dup id checking with property is wrong -bug0290.pp problem with storing hex numbers in integers -bug0294.pp parameter with the same name as function is allowed in tp7/delphi - Yes, but in BP this leads to being unable to set the return value ! - -Wishlist bugs: --------------- -bug0275.pp too many warnings - -Unfixed bugs: -------------- -bug0262.pp problems with virtual and overloaded methods -bug0293.pp no error with variable name = type name -bug0299.pp passing Array[0..1] of char by value to proc leads to problems -bug0305.pp Finally is not handled correctly after inputting 0 -bug0312.pp Again the problem of local procs inside methods \ No newline at end of file diff --git a/tests/tesi/tesicrt.pp b/tests/tesi/tesicrt.pp deleted file mode 100644 index 4a77f168a7..0000000000 --- a/tests/tesi/tesicrt.pp +++ /dev/null @@ -1,105 +0,0 @@ -{ - $Id$ - - Program to test CRT unit by Mark May. - Only standard TP functions are tested (except WhereX, WhereY). -} -program tesicrt; - -uses crt; -var - i,j : longint; - fil : text; - c : char; -begin -{Window/AssignCrt/GotoXY} - clrscr; - writeln ('This should be on a clear screen...'); - gotoxy (10,10); - writeln ('(10,10) is the coordinate of this sentence'); - window (10,11,70,22); - writeln ('Window (10,11,70,22) executed.'); - writeln ('Sending some output to a file, assigned to crt.'); - assigncrt ( fil); - rewrite (fil); - writeln (fil,'This was written to the file, assigned to the crt.'); - writeln (fil,'01234567890123456789012345678901234567890123456789012345678901234567890'); - close (fil); - writeln ('The above too, but this not any more'); - write ('Press any key to continue'); - c:=readkey; - clrscr; - writeln ('the small window should have been cleared.'); - write ('Press any key to continue'); - c:=readkey; - -{Colors/KeyPressed} - window (1,1,80,25); - clrscr; - writeln ('Color testing :'); - writeln; - highvideo; - write ('highlighted text'); - normvideo; - write (' normal text '); - lowvideo; - writeln ('And low text.'); - writeln; - writeln ('Color chart :'); - for i:=black to lightgray do - begin - textbackground (i); - textcolor (0); - write ('backgr. : ',i:2,' '); - for j:= black to white do - begin - textcolor (j); - write (' ',j:2,' '); - end; - writeln; - end; - normvideo; - writeln ('The same, with blinking foreground.'); - for i:=black to lightgray do - begin - textbackground (i); - textcolor (0); - write ('backgr. : ',i:2,' '); - for j:= black to white do - begin - textcolor (j+128); - write (' ',j:2,' '); - end; - writeln; - end; - textcolor (white); - textbackground (black); - writeln; - writeln ('press any key to continue'); - repeat until keypressed; - c:=readkey; - -{ClrEol/DelLine/InsLine} - clrscr; - writeln ('Testing some line functions :'); - writeln ; - writeln ('This line should become blank after you press enter'); - writeln; - writeln ('The following line should then become blank from column 10'); - writeln ('12345678901234567890'); - writeln; - writeln ('This line should dissapear.'); - writeln; - writeln ('Between this line and the next, an empty line should appear.'); - writeln ('This is the next line, above which the empty one should appear'); - writeln; - write ('Press any key to observe the predicted effects.'); - readkey; - gotoxy(1,3);clreol; - gotoxy (10,6);clreol; - gotoxy (1,8);delline; - gotoxy (1,10); insline; - gotoxy (17,13); clreol; - writeln ('end.'); - readkey; -end. diff --git a/tests/tesi/tesidos.pp b/tests/tesi/tesidos.pp deleted file mode 100644 index af1ace2e5c..0000000000 --- a/tests/tesi/tesidos.pp +++ /dev/null @@ -1,176 +0,0 @@ -{ - $Id$ - - Program to test DOS unit by Peter Vreman. - Only main TP functions are tested (nothing with Interrupts/Break/Verify). -} -{$V-} -program tesidos; -uses dos; - -procedure TestInfo; -var - dt : DateTime; - ptime : longint; - wday : word; - HSecs : word; -begin - writeln; - writeln('Info Functions'); - writeln('**************'); - writeln('Dosversion : ',lo(DosVersion),'.',hi(DosVersion)); - GetDate(Dt.Year,Dt.Month,Dt.Day,wday); - writeln('Current Date : ',Dt.Month,'-',Dt.Day,'-',Dt.Year,' weekday ',wday); - GetTime(Dt.Hour,Dt.Min,Dt.Sec,HSecs); - writeln('Current Time : ',Dt.Hour,':',Dt.Min,':',Dt.Sec,' hsecs ',HSecs); - PackTime(Dt,ptime); - writeln('Packed like dos: ',ptime); - UnpackTime(ptime,DT); - writeln('Unpacked again : ',Dt.Month,'-',Dt.Day,'-',Dt.Year,' ',Dt.Hour,':',Dt.Min,':',Dt.Sec); - writeln; - write('Press Enter'); - Readln; -end; - - -procedure TestEnvironment; -var - i : longint; -begin - writeln; - writeln('Environment Functions'); - writeln('*********************'); - writeln('Amount of environment strings : ',EnvCount); - writeln('GetEnv TERM : ',GetEnv('TERM')); - writeln('GetEnv HOST : ',GetEnv('HOST')); - writeln('GetEnv PATH : ',GetEnv('PATH')); - writeln('GetEnv SHELL: ',GetEnv('SHELL')); - write('Press Enter for all Environment Strings using EnvStr()'); - Readln; - for i:=1 to EnvCount do - writeln(EnvStr(i)); - write('Press Enter'); - Readln; -end; - - -procedure TestExec; -begin - writeln; - writeln('Exec Functions'); - writeln('**************'); - write('Press Enter for an Exec of ''ls -la'''); - Readln; -{$ifdef linux } - Exec('ls','-la'); -{$else not linux } - SwapVectors; - Exec('ls','-la'); - SwapVectors; -{$endif not linux } - write('Press Enter'); - Readln; -end; - - - -procedure TestDisk; -var - Dir : SearchRec; -begin - writeln; - writeln('Disk Functions'); - writeln('**************'); - writeln('DiskFree 0 : ',DiskFree(0)); - writeln('DiskSize 0 : ',DiskSize(0)); - {writeln('DiskSize 1 : ',DiskSize(1)); this is a: on dos ??! } - writeln('DiskSize 1 : ',DiskSize(3)); { this is c: on dos } -{$IFDEF LINUX} - AddDisk('/fd0'); - writeln('DiskSize 4 : ',DiskSize(4)); -{$ENDIF} - write('Press Enter for FindFirst/FindNext Test'); - Readln; - - FindFirst('*.*',$20,Dir); - while (DosError=0) do - begin - Writeln(dir.Name,' ',dir.Size); - FindNext(Dir); - end; - write('Press Enter'); - Readln; -end; - - - -procedure TestFile; -var - test, - name,dir,ext : string; -begin - writeln; - writeln('File(name) Functions'); - writeln('********************'); -{$ifdef linux } - test:='/usr/local/bin/ppc.so'; - writeln('FSplit(',test,')'); - FSplit(test,dir,name,ext); - writeln('dir: ',dir,' name: ',name,' ext: ',ext); - test:='/usr/bin.1/ppc'; - writeln('FSplit(',test,')'); - FSplit(test,dir,name,ext); - writeln('dir: ',dir,' name: ',name,' ext: ',ext); - test:='mtools.tar.gz'; - writeln('FSplit(',test,')'); - FSplit(test,dir,name,ext); - writeln('dir: ',dir,' name: ',name,' ext: ',ext); - - Writeln('Expanded dos.pp : ',FExpand('dos.pp')); - Writeln('Expanded ../dos.pp : ',FExpand('../dos.pp')); - Writeln('Expanded /usr/local/dos.pp : ',FExpand('/usr/local/dos.pp')); - Writeln('Expanded ../dos/./../././dos.pp : ',FExpand('../dos/./../././dos.pp')); - - test:='../;/usr/;/usr/bin/;/usr/bin;/bin/;'; -{$else not linux } - test:='\usr\local\bin\ppc.so'; - writeln('FSplit(',test,')'); - FSplit(test,dir,name,ext); - writeln('dir: ',dir,' name: ',name,' ext: ',ext); - test:='\usr\bin.1\ppc'; - writeln('FSplit(',test,')'); - FSplit(test,dir,name,ext); - writeln('dir: ',dir,' name: ',name,' ext: ',ext); - test:='mtools.tar.gz'; - writeln('FSplit(',test,')'); - FSplit(test,dir,name,ext); - writeln('dir: ',dir,' name: ',name,' ext: ',ext); - - Writeln('Expanded dos.pp : ',FExpand('dos.pp')); - Writeln('Expanded ..\dos.pp : ',FExpand('..\dos.pp')); - Writeln('Expanded \usr\local\dos.pp : ',FExpand('\usr\local\dos.pp')); - Writeln('Expanded ..\dos\.\..\.\.\dos.pp : ',FExpand('..\dos\.\..\.\.\dos.pp')); - - test:='..\;\usr\;\usr\bin\;\usr\bin;\bin\;'; -{$endif not linux} - test:=test+getenv('PATH'); -{$ifdef linux} - Writeln('FSearch ls: ',FSearch('ls',test)); -{$else not linux} - Writeln('FSearch ls: ',FSearch('ls.exe',test)); -{$endif not linux} - - write('Press Enter'); - Readln; -end; - - - -begin - TestInfo; - TestEnvironment; - TestExec; - TestDisk; - TestFile; -end. - diff --git a/tests/tesi/tesirand.pp b/tests/tesi/tesirand.pp deleted file mode 100644 index 6fa463139c..0000000000 --- a/tests/tesi/tesirand.pp +++ /dev/null @@ -1,157 +0,0 @@ -{ - $Id$ - - This program test the random function - It gets 10M random values - that are placed in 10000 windows - and print the number of occurence for each window - and the profile of the distribution - of the counts - - - this gave very bad value due to a modulo problem - but after this solved - it still shows strange wings !! -} -program test_random; - -uses -{$ifdef go32v2} - dpmiexcp, -{$endif go32v2} - graph; - - -const max = 1000; - maxint = 10000*max; - - -var x : array[0..max-1] of longint; - y : array[-100..100] of longint; - - mean,level,i : longint; - maxcount,delta,maximum,minimum : longint; - st,st2 : string; - gm,gd : integer; - color : longint; - -begin - -{$ifdef go32v2} - gm:=m640x400x256; - gd:=vesa; -{$else } - gd:=detect; -{$endif } - InitGraph(gd,gm,'\tp\bgi'); -{$ifdef FPC} - SetWriteMode(NormalPut); -{$endif FPC} - SetColor(red); - color:=blue; - - mean:=maxint div max; - - setfillstyle(solidfill,blue); - for level:=0 to 10 do - begin - - for i:=0 to max-1 do - x[i]:=0; - for i:=-100 to 100 do - y[i]:=0; - for i:=0 to maxint-1 do - begin - if level=0 then - inc(x[trunc(random*max)]) - else - inc(x[random(max*level) div (level)]); - if i mod (maxint div 10) = 0 then - begin - bar(20+textwidth('iteration '),17, - 20+textwidth('iteration 0000000'),26); - st:=''; - str(i,st); - st:='iteration '+st; - OutTextXY(20,20,st); - {Writeln(stderr,st);} - end; - end; - maximum:=0; - minimum:=$7FFFFFFF; - maxcount:=0; - for i:=0 to max-1 do - begin - if x[i]>maximum then - maximum:=x[i]; - if x[i]maxcount then - maxcount:=y[i]; - if maxcount=0 then - inc(maxcount); - - OutTextXY(GetMaxX div 2,GetMaxY-30,'Random Test Program'); - - str(level,st); - st:='Level '+st; - bar(30,GetMaxY-65, - 30+textwidth(st),getMaxY-52); - OutTextXY(30,GetMaxY-59,st); - str(maximum,st); - str(minimum,st2); - st:='Maximum = '+st+' Minimum ='+st2; - bar(30,GetMaxY-35, - 30+Textwidth(st),getMaxY-22); - OutTextXY(30,GetMaxY-29,st); - - for i:=0 to max-1 do - putpixel( (i*getmaxX) div max, - GetMaxY-(x[i]*getMaxY) div (2*mean), color); - inc(color); - setColor(color); - delta:=maximum-minimum+1; - for i:=-100 to 100 do - begin - if i=minimum then - moveto( ((i+100)*getMaxX) div 201, - GetMaxY-(y[i]*getMaxY) div maxcount) - else - lineto( ((i+100)*getMaxX) div 201, - GetMaxY-(y[i]*getMaxY) div maxcount); - if y[i]>0 then - circle( ((i+100)*getMaxX) div 201, - GetMaxY-(y[i]*getMaxY) div maxcount,5); - end; - readln; - inc(color); - end; - CloseGraph; -end. - -{ - $Log$ - Revision 1.1 2000-07-13 09:22:04 michael - + Initial import - - Revision 1.2 2000/03/25 13:45:35 jonas - * works with new graph unit - - Revision 1.1 1999/12/02 17:37:44 peter - * moved *.pp into subdirs - * fpcmaked - - Revision 1.3 1999/01/25 20:23:13 peter - * linux updates - - Revision 1.2 1998/11/23 23:44:52 pierre - + several bugs converted - -} - diff --git a/tests/test/divexcp.pp b/tests/test/divexcp.pp deleted file mode 100644 index 71ec644b99..0000000000 --- a/tests/test/divexcp.pp +++ /dev/null @@ -1,126 +0,0 @@ - -{$mode objfpc} - -uses - sysutils; - -const - Program_has_errors : boolean = false; - exception_called : boolean = false; - TestNumber : longint = 10000; - -procedure test_exception(const s : string); - begin - if not(exception_called) then - begin - Writeln('Exception not called : ',s); - Program_has_errors := true; - end; - end; - -var - i,j : longint; - e : extended; - exception_count,level : longint; -begin - j:=0; - i:=100; - try - exception_called:=false; - j := i div j; - except - on e : exception do - begin - Writeln('First integer exception called ',e.message); - exception_called:=true; - end; - end; - test_exception('First division by zero for integers'); - try - exception_called:=false; - j := i div j; - except - on e : exception do - begin - Writeln('Second integer exception called ',e.message); - exception_called:=true; - end; - end; - test_exception('Second division by zero for integers'); - try - exception_called:=false; - e:=i/j; - except - on e : exception do - begin - Writeln('First real exception called ',e.message); - exception_called:=true; - end; - end; - test_exception('First division by zero for reals'); - try - exception_called:=false; - e:=i/j; - except - on e : exception do - begin - Writeln('Second real exception called ',e.message); - exception_called:=true; - end; - end; - test_exception('Second division by zero for reals'); - try - exception_called:=false; - j := i div j; - except - on e : exception do - begin - Writeln('exception called ',e.message); - exception_called:=true; - end; - end; - test_exception('third division by zero for integers'); - exception_count:=0; - level:=0; - for j:=1 to TestNumber do - begin - try - i:=0; - inc(level); - e:=j/i; - except - on e : exception do - begin - inc(exception_count); - if level>1 then - Writeln('exception overrun'); - dec(level); - end; - end; - - end; - if exception_count<>TestNumber then - begin - program_has_errors:=true; - Writeln('Could not generate ',TestNumber,' consecutive exceptions'); - Writeln('Only ',exception_count,' exceptions were generated'); - end - else - begin - Writeln(TestNumber,' consecutive exceptions generated successfully'); - end; - try - exception_called:=false; - i := -1; - e := ln(i); - except - on e : exception do - begin - Writeln('exception called ',e.message); - exception_called:=true; - end; - end; - test_exception('ln(-1)'); - if program_has_errors then - Halt(1); -end. \ No newline at end of file diff --git a/tests/test/implprog.pp b/tests/test/implprog.pp deleted file mode 100644 index cc387a2876..0000000000 --- a/tests/test/implprog.pp +++ /dev/null @@ -1,16 +0,0 @@ -uses impluni1; - - Type - BEC_Single_Error = record - E : integer; - M : string [80]; - end; - - Const - BEC_Err_Msgs: array [0..1] of BEC_Single_Error = - ((E : impluni1.ICanUseThis; M : '[1] No Error'), - (E : impluni2.ICantUseThis; M : '[10000] A Bug?')); - -begin -end. - diff --git a/tests/test/impluni1.pp b/tests/test/impluni1.pp deleted file mode 100644 index c0e1563c1d..0000000000 --- a/tests/test/impluni1.pp +++ /dev/null @@ -1,13 +0,0 @@ -unit impluni1; - -interface - -uses impluni2; - -const - ICanUseThis = 1; - -implementation - -end. - diff --git a/tests/test/impluni2.pp b/tests/test/impluni2.pp deleted file mode 100644 index ccddf2f405..0000000000 --- a/tests/test/impluni2.pp +++ /dev/null @@ -1,10 +0,0 @@ -unit impluni2; - -interface - -const - ICantUseThis = 10000; - -implementation - -end. diff --git a/tests/test/inline01.pp b/tests/test/inline01.pp deleted file mode 100644 index de9d0507c0..0000000000 --- a/tests/test/inline01.pp +++ /dev/null @@ -1,121 +0,0 @@ -program inline01; - -var - starti: longint; - i:longint; - - -{$INLINE ON} - -procedure kkainl(var c: longint); inline; -begin - if c <> starti then - begin - writeln('bug'); - halt(1); - end; - writeln('kka ',c); - c:=c+1; - if i <> starti+1 then - begin - writeln('bug'); - halt(1); - end; -end; - -procedure kka(var c:longint); -begin - if c <> starti then - begin - writeln('bug'); - halt(1); - end; - writeln('kka ',c); - c:=c+1; - if i <> starti+1 then - begin - writeln('bug'); - halt(1); - end; -end; - -procedure kkb(var c:longint);inline; -begin - if c <> starti then - begin - writeln('bug'); - halt(1); - end; - kka(c); - if i <> starti+1 then - begin - writeln('bug'); - halt(1); - end; - writeln('kkb ',c); -end; - -procedure kkb2(var c:longint);inline; -begin - if c <> starti then - begin - writeln('bug'); - halt(1); - end; - kkainl(c); - if i <> starti+1 then - begin - writeln('bug'); - halt(1); - end; - writeln('kkb ',c); -end; - -procedure kkc(var c: longint); -begin - if c <> starti then - begin - writeln('bug'); - halt(1); - end; - kkb(c); - if i <> starti+1 then - begin - writeln('bug'); - halt(1); - end; -end; - -procedure kkcinl(var c: longint); inline; -begin - if c <> starti then - begin - writeln('bug'); - halt(1); - end; - kkb2(c); - if i <> starti+1 then - begin - writeln('bug'); - halt(1); - end; -end; - -begin - i:=5; - starti := 5; - kkc(i); - starti := i; - kkc(i); - starti := i; - kkb(i); - starti := i; - kkb(i); - starti := i; - kka(i); - starti := i; - kkcinl(i); - starti := i; - kkb2(i); -end. - diff --git a/tests/test/inoutres.pp b/tests/test/inoutres.pp deleted file mode 100644 index 911a70afcc..0000000000 --- a/tests/test/inoutres.pp +++ /dev/null @@ -1,307 +0,0 @@ -{ checks if the correct RTE's are generated for invalid io operations } - -{$i-} - -procedure test(value, required: longint); -begin - if value <> required then - begin - writeln('Got ',value,' instead of ',required); - halt(1); - end; -end; - -procedure test_read_text; -var - f: text; - s: string; -begin - { to avoid influence of previous runs/procedures } - fillchar(f,sizeof(f),0); - write('Reading from not opened text file...'); - read(f,s); - test(ioresult,103); - readln(f); - test(ioresult,103); - writeln(' Passed!'); - - write('Seekeoln from not opened text file...'); - seekeoln(f); - test(ioresult,103); - writeln(' Passed!'); - - write('Seekeof from not opened text file...'); - seekeof(f); - test(ioresult,103); - writeln(' Passed!'); - - assign(f,'inoutrte.$$$'); - rewrite(f); - test(ioresult,0); - - write('Reading from write-only (rewritten) text file...'); - read(f,s); - test(ioresult,104); - readln(f); - test(ioresult,104); - writeln(' Passed!'); - - write('Seekeoln from write-only (rewritten) text file...'); - seekeoln(f); - test(ioresult,104); - writeln(' Passed!'); - - write('Seekeof from write-only (rewritten) text file...'); - seekeof(f); - test(ioresult,104); - writeln(' Passed!'); - - close(f); - test(ioresult,0); - append(f); - test(ioresult,0); - - write('Reading from write-only (appended) text file...'); - read(f,s); - test(ioresult,104); - readln(f); - test(ioresult,104); - writeln(' Passed!'); - - write('Seekeoln from write-only (appended) text file...'); - seekeoln(f); - test(ioresult,104); - writeln(' Passed!'); - - write('Seekeof from write-only (appended) text file...'); - seekeof(f); - test(ioresult,104); - writeln(' Passed!'); - - close(f); - test(ioresult,0); - erase(f); - test(ioresult,0); -end; - -procedure test_read_typed; -var - f: file of byte; - s: byte; -begin - { to avoid influence of previous runs/procedures } - fillchar(f,sizeof(f),0); - - write('Reading from not opened typed file...'); - read(f,s); - test(ioresult,103); - writeln(' Passed!'); - - { with filemode 2, the file is read-write } - filemode := 1; - assign(f,'inoutrte.$$$'); - rewrite(f); - test(ioresult, 0); - write(f,s); - test(ioresult, 0); - close(f); - test(ioresult, 0); - reset(f); - test(ioresult, 0); - write('Reading from write-only typed file...'); - read(f,s); - test(ioresult,104); - writeln(' Passed!'); - - filemode := 2; - close(f); - test(ioresult, 0); - erase(f); - test(ioresult, 0); -end; - -procedure test_read_untyped; -var - f: file; - r: longint; - s: byte; -begin - { to avoid influence of previous runs/procedures } - fillchar(f,sizeof(f),0); - - write('Reading from not opened untyped file...'); - blockread(f,s,1,r); - test(ioresult,103); - writeln(' Passed!'); - - { with filemode 2, the file is read-write } - filemode := 1; - assign(f,'inoutrte.$$$'); - rewrite(f); - test(ioresult, 0); - blockwrite(f,s,1); - test(ioresult, 0); - close(f); - test(ioresult, 0); - reset(f); - test(ioresult, 0); - write('Reading from write-only utyped file...'); - blockread(f,s,1,r); - test(ioresult,104); - writeln(' Passed!'); - - filemode := 2; - close(f); - test(ioresult, 0); - erase(f); - test(ioresult, 0); -end; - - -procedure test_write_text; -var f: text; - s: string; -begin - { to avoid influence of previous runs/procedures } - fillchar(f,sizeof(f),0); - - write('Writing to not opened text file...'); - write(f,s); - test(ioresult,103); - writeln(f); - test(ioresult,103); - writeln(' Passed!'); - - assign(f,'inoutrte.$$$'); - rewrite(f); - close(f); - test(ioresult,0); - reset(f); - test(ioresult,0); - - write('Writing to read-only text file...'); - write(f,s); - test(ioresult,105); - writeln(f); - test(ioresult,105); - Writeln(' Passed!'); - - close(f); - test(ioresult,0); - erase(f); - test(ioresult,0); -end; - -procedure test_write_typed; -var f: file of byte; - s: byte; -begin - { to avoid influence of previous runs/procedures } - fillchar(f,sizeof(f),0); - - write('Writing to not opened typed file...'); - write(f,s); - test(ioresult,103); - writeln(' Passed!'); - - assign(f,'inoutrte.$$$'); - rewrite(f); - close(f); - test(ioresult,0); - filemode := 0; - reset(f); - test(ioresult,0); - - write('Writing to read-only typed file...'); - write(f,s); - test(ioresult,105); - Writeln(' Passed!'); - - filemode := 2; - close(f); - test(ioresult,0); - erase(f); - test(ioresult,0); -end; - -procedure test_write_untyped; -var f: file; - r: longint; - s: byte; -begin - { to avoid influence of previous runs/procedures } - fillchar(f,sizeof(f),0); - - write('Writing to not opened untyped file...'); - blockwrite(f,s,1,r); - test(ioresult,103); - writeln(' Passed!'); - - assign(f,'inoutrte.$$$'); - rewrite(f); - close(f); - test(ioresult,0); - filemode := 0; - reset(f); - test(ioresult,0); - - write('Writing to read-only untyped file...'); - blockwrite(f,s,1,r); - test(ioresult,105); - Writeln(' Passed!'); - - filemode := 2; - close(f); - test(ioresult,0); - erase(f); - test(ioresult,0); -end; - - -procedure test_close_text; -var f: text; -begin - { to avoid influence of previous runs/procedures } - fillchar(f,sizeof(f),0); - - write('Testing closing of not opened text file...'); - close(f); - test(ioresult,103); - writeln(' Passed!'); -end; - -procedure test_close_typed; -var f: file of byte; -begin - { to avoid influence of previous runs/procedures } - fillchar(f,sizeof(f),0); - - write('Testing closing of not opened typed file...'); - close(f); - test(ioresult,103); - writeln(' Passed!'); -end; - -procedure test_close_untyped; -var f: file; -begin - { to avoid influence of previous runs/procedures } - fillchar(f,sizeof(f),0); - - write('Testing closing of not opened untyped file...'); - close(f); - test(ioresult,103); - writeln(' Passed!'); -end; - -begin - test_read_text; - test_read_typed; - test_read_untyped; - test_write_text; - test_write_typed; - test_write_untyped; - test_close_text; - test_close_typed; - test_close_untyped; -end. diff --git a/tests/test/range.pp b/tests/test/range.pp deleted file mode 100644 index e2170e022b..0000000000 --- a/tests/test/range.pp +++ /dev/null @@ -1,232 +0,0 @@ -{$mode objfpc} -uses sysutils; - -var - error: boolean; - -{$r+} -function testlongint_int64(i: int64; shouldfail: boolean): boolean; -var - l: longint; - failed: boolean; -begin - failed := false; - try - l := i; - except - failed := true; - end; - result := failed = shouldfail; - error := error or not result; -end; - -function testlongint_qword(i: qword; shouldfail: boolean): boolean; -var - l: longint; - failed: boolean; -begin - failed := false; - try - l := i; - except - failed := true; - end; - result := failed = shouldfail; - error := error or not result; -end; - -function testdword_int64(i: int64; shouldfail: boolean): boolean; -var - l: dword; - failed: boolean; -begin - failed := false; - try - l := i; - except - failed := true; - end; - result := failed = shouldfail; - error := error or not result; -end; - -function testdword_qword(i: qword; shouldfail: boolean): boolean; -var - l: dword; - failed: boolean; -begin - failed := false; - try - l := i; - except - failed := true; - end; - result := failed = shouldfail; - error := error or not result; -end; - -{$r-} - -var - i: int64; - q: qword; -begin - error := false; -{ *********************** int64 to longint ********************* } - writeln('int64 to longint'); - i := $ffffffffffffffff; - writeln(i); - if not testlongint_int64(i,false) then - writeln('test1 failed'); - i := i and $ffffffff00000000; - writeln(i); - if not testlongint_int64(i,true) then - writeln('test2 failed'); - inc(i); - writeln(i); - if not testlongint_int64(i,true) then - writeln('test3 failed'); - longint(i) := $80000000; - writeln(i); - if not testlongint_int64(i,false) then - writeln('test4 failed'); - i := 0; - longint(i) := $80000000; - writeln(i); - if not testlongint_int64(i,true) then - writeln('test5 failed'); - dec(i); - writeln(i); - if not testlongint_int64(i,false) then - writeln('test6 failed'); - i := 0; - longint(i) := $ffffffff; - writeln(i); - if not testlongint_int64(i,true) then - writeln('test7 failed'); - i := 0; - writeln(i); - if not testlongint_int64(i,false) then - writeln('test8 failed'); - -{ *********************** qword to longint ********************* } - writeln; - writeln('qword to longint'); - q := $ffffffffffffffff; - writeln(q); - if not testlongint_qword(q,true) then - writeln('test1 failed'); - q := q and $ffffffff00000000; - writeln(q); - if not testlongint_qword(q,true) then - writeln('test2 failed'); - inc(q); - writeln(q); - if not testlongint_qword(q,true) then - writeln('test3 failed'); - longint(q) := $80000000; - writeln(q); - if not testlongint_qword(q,true) then - writeln('test4 failed'); - q := 0; - longint(q) := $80000000; - writeln(q); - if not testlongint_qword(q,true) then - writeln('test5 failed'); - dec(q); - writeln(q); - if not testlongint_qword(q,false) then - writeln('test6 failed'); - q := 0; - longint(q) := $ffffffff; - writeln(q); - if not testlongint_qword(q,true) then - writeln('test7 failed'); - q := 0; - writeln(q); - if not testlongint_qword(q,false) then - writeln('test8 failed'); - -{ *********************** int64 to dword ********************* } - writeln; - writeln('int64 to dword'); - i := $ffffffffffffffff; - writeln(i); - if not testdword_int64(i,true) then - writeln('test1 failed'); - i := i and $ffffffff00000000; - writeln(i); - if not testdword_int64(i,true) then - writeln('test2 failed'); - inc(i); - writeln(i); - if not testdword_int64(i,true) then - writeln('test3 failed'); - longint(i) := $80000000; - writeln(i); - if not testdword_int64(i,true) then - writeln('test4 failed'); - i := 0; - longint(i) := $80000000; - writeln(i); - if not testdword_int64(i,false) then - writeln('test5 failed'); - dec(i); - writeln(i); - if not testdword_int64(i,false) then - writeln('test6 failed'); - i := 0; - longint(i) := $ffffffff; - writeln(i); - if not testdword_int64(i,false) then - writeln('test7 failed'); - i := 0; - writeln(i); - if not testdword_int64(i,false) then - writeln('test8 failed'); - -{ *********************** qword to dword ********************* } - writeln; - writeln('qword to dword'); - q := $ffffffffffffffff; - writeln(q); - if not testdword_qword(q,true) then - writeln('test1 failed'); - q := q and $ffffffff00000000; - writeln(q); - if not testdword_qword(q,true) then - writeln('test2 failed'); - inc(q); - writeln(q); - if not testdword_qword(q,true) then - writeln('test3 failed'); - longint(q) := $80000000; - writeln(q); - if not testdword_qword(q,true) then - writeln('test4 failed'); - q := 0; - longint(q) := $80000000; - writeln(q); - if not testdword_qword(q,false) then - writeln('test5 failed'); - dec(q); - writeln(q); - if not testdword_qword(q,false) then - writeln('test6 failed'); - q := 0; - longint(q) := $ffffffff; - writeln(q); - if not testdword_qword(q,false) then - writeln('test7 failed'); - q := 0; - writeln(q); - if not testdword_qword(q,false) then - writeln('test8 failed'); - - if error then - begin - writeln; - writeln('still range check problems!'); - halt(1); - end; -end. diff --git a/tests/test/range2.pp b/tests/test/range2.pp deleted file mode 100644 index 4ae7ee677a..0000000000 --- a/tests/test/range2.pp +++ /dev/null @@ -1,30 +0,0 @@ -{$mode objfpc} -uses sysutils; -{$r+} - -var - l: longint; - c: cardinal; - n: longint; -begin - n := 0; - l := -1; - try - c := l; - except - writeln('caught 1!'); - inc(n); - end; - longint(c) := $ffffffff; - try - l := c; - except - writeln('caught 2!'); - inc(n); - end; - if n <> 2 then - begin - writeln('Still problems with range checking between longint/cardinal'); - halt(1); - end; -end. diff --git a/tests/test/range3.pp b/tests/test/range3.pp deleted file mode 100644 index c8e289dd6d..0000000000 --- a/tests/test/range3.pp +++ /dev/null @@ -1,134 +0,0 @@ -{$mode objfpc} -uses sysutils; - -{$r+} - -var - a1: array[-5..6] of byte; - a2: array[-12..-1] of byte; - a3: array[0..6] of byte; - a4: array[1..12] of byte; - - c: cardinal; - l: longint; - b: byte; - finalerror: boolean; - -function check_longint(l: longint; res1, res2, res3, res4: boolean): boolean; -var - caught, - error: boolean; -begin - result := false; - - caught := false; - try - b := a1[l]; - except - caught := true; - end; - error := caught <> res1; - if error then writeln('long 1 failed for ',l); - result := result or error; - - caught := false; - try - b := a2[l]; - except - caught := true; - end; - error := caught <> res2; - if error then writeln('long 2 failed for ',l); - result := result or error; - - caught := false; - try - b := a3[l]; - except - caught := true; - end; - error := caught <> res3; - if error then writeln('long 3 failed for ',l); - result := result or error; - - caught := false; - try - b := a4[l]; - except - caught := true; - end; - error := caught <> res4; - if error then writeln('long 4 failed for ',l); - result := result or error; - writeln; -end; - -function check_cardinal(l: cardinal; res1, res2, res3, res4: boolean): boolean; -var - caught, - error: boolean; -begin - result := false; - - caught := false; - try - b := a1[l]; - except - caught := true; - end; - error := caught <> res1; - if error then writeln('card 1 failed for ',l); - result := result or error; - - caught := false; - try - b := a2[l]; - except - caught := true; - end; - error := caught <> res2; - if error then writeln('card 2 failed for ',l); - result := result or error; - - caught := false; - try - b := a3[l]; - except - caught := true; - end; - error := caught <> res3; - if error then writeln('card 3 failed for ',l); - result := result or error; - - caught := false; - try - b := a4[l]; - except - caught := true; - end; - error := caught <> res4; - if error then writeln('card 4 failed for ',l); - result := result or error; - writeln; -end; - - -begin - finalerror := - check_longint(-1,false,false,true,true); - finalerror := - check_longint(-6,true,false,true,true) or finalerror; - finalerror := - check_longint(0,false,true,false,true) or finalerror; - finalerror := - check_cardinal(0,false,true,false,true); - finalerror := - check_cardinal(cardinal($ffffffff),true,true,true,true) or finalerror; - finalerror := - check_cardinal(5,false,true,false,false) or finalerror; - if finalerror then - begin - writeln('Still errors in range checking for array indexes'); - halt(1); - end; -end. diff --git a/tests/test/readme.txt b/tests/test/readme.txt deleted file mode 100644 index edd5b30a4f..0000000000 --- a/tests/test/readme.txt +++ /dev/null @@ -1,49 +0,0 @@ -This directory contains tests for several parts of the compiler: -The tests ordered how they should be executed - -Shortstrings .......... teststr.pp compatibility and speed of - string functions - teststr2.pp some misc. tests mainly collected - from bug reports - testcstr.pp Typed Constant string loading from - other constants -Ansistrings ........... testansi.pp - testa2.pp -Classes ............... testdom.pp -Exceptions ............ testexc.pp - testexc2.pp - testexc3.pp -Libraries ............. testlib.pp a very primitive test -Parameter passing -via out ............... testout.pp - -str/write(real_type) .. strreal.pp test correct rounding - strreal2.pp test correct writing of 10 till 1e-24 -input/output .......... inoutres.pp tests inoutres values of invalid - operations -Units ................. testu1.pp tests init. & finalization and halt - testu2.pp in finalization - testu3.pp a type redefining problem - testu4.pp - testu5.pp -case .................. testcase.pp tests case statements with byte and word - sized decision variables - testcas2.pp tests case with sub enum types -Arrays ................ testarr1.pp small test for open arrays with classes -Enumerations .......... testenm1.pp tests assignments of subrange - enumerations -Inline ................ inline01.pp tests recursive inlining, inlining - a procedure multiple times and - inlining procedures in other - inline procedures. -Finalize .............. testfi1.pp tests the procedure system.finalize -TypeInfo .............. testti1.pp test the function system.typeinfo -Resourcestrings ....... testrstr.pp tests a simple resource string -Range checking ........ range.pp range checking when converting int64/ - qword to longint/cardinal - range2.pp range checking when converting - between longint and cardinal - range3.pp range checking for arrays -Implicit units ........ implprog.pp compile the program twice, second time - impluni1.pp there's an error about not being able - impluni2.pp to use a constant diff --git a/tests/test/strreal.pp b/tests/test/strreal.pp deleted file mode 100644 index aba2879e26..0000000000 --- a/tests/test/strreal.pp +++ /dev/null @@ -1,42 +0,0 @@ -const - s: array[0..16] of string[13] = - ('99999.900000', - '99999.990000', - '99999.999000', - '99999.999900', - '99999.999990', - '99999.999999', - '100000.000000', - '100000.000000', - '100000.000000', - '100000.000000', - '100000.000000', - '100000.000000', - '100000.000000', - '100000.000000', - '100000.000000', - '100000.000000', - '100000.000000'); - -var - e,e2,e3: double; - s2: string; - c: longint; - -begin - e := 100000.0; - e2 := 0.1; - c := 0; - repeat - e3 := e-e2; - str(e3:0:6,s2); - writeln(s2); - if s2 <> s[c] then - begin - writeln(' Error, should be ',s[c]); - halt(1); - end; - e2 := e2 /10.0; - inc(c); - until e2 < 1e-17; -end. diff --git a/tests/test/strreal2.pp b/tests/test/strreal2.pp deleted file mode 100644 index 13921c404f..0000000000 --- a/tests/test/strreal2.pp +++ /dev/null @@ -1,43 +0,0 @@ -const - s: array[1..21] of string = - ('10.00000000000000000', - '1.00000000000000000', - '0.10000000000000000', - '0.01000000000000000', - '0.00100000000000000', - '0.00010000000000000', - '0.00001000000000000', - '0.00000100000000000', - '0.00000010000000000', - '0.00000001000000000', - '0.00000000100000000', - '0.00000000010000000', - '0.00000000001000000', - '0.00000000000100000', - '0.00000000000010000', - '0.00000000000001000', - '0.00000000000000100', - '0.00000000000000010', - '0.00000000000000001', - '0.00000000000000000', - '0.00000000000000000'); - -var - e: extended; - c: longint; - s2: string; - -begin - e := 10.0; - for c := 1 to 21 do - begin - str(e:0:17,s2); - writeln(s2); - if s2 <> s[c] then - begin - writeln(' Error, should be ',s[c]); - halt(1); - end; - e := e / 10.0; - end; -end. diff --git a/tests/test/testa2.pp b/tests/test/testa2.pp deleted file mode 100644 index aee5c0c26b..0000000000 --- a/tests/test/testa2.pp +++ /dev/null @@ -1,40 +0,0 @@ -uses - dotest; - -var - a1,a2 : ansistring; - -function f1 : ansistring; - - begin - f1:=''; - end; - -function f2 : ansistring; - - begin - f2:='Hello'; - end; - -begin - a1:=''; - a2:='Hello'; - if a1<>'' then - do_error(1000); - if a2='' then - do_error(1001); - if ''<>a1 then - do_error(1002); - if ''=a2 then - do_error(1003); - - if f1<>'' then - do_error(1004); - if f2='' then - do_error(1005); - if ''<>f1 then - do_error(1006); - if ''=f2 then - do_error(1007); -end. - diff --git a/tests/test/testac.pp b/tests/test/testac.pp deleted file mode 100644 index 9ec2e29490..0000000000 --- a/tests/test/testac.pp +++ /dev/null @@ -1,38 +0,0 @@ -type - to1 = class - constructor create; - procedure afterconstruction;override; - end; - -var - i : longint; - - constructor to1.create; - - begin - inherited create; - if i<>1000 then - halt(1); - i:=2000; - end; - - procedure to1.afterconstruction; - - begin - if i<>2000 then - halt(1); - i:=3000; - end; - -var - o1 : to1; - -begin - i:=1000; - o1:=to1.create; - if i<>3000 then - halt(1); - o1.destroy; - writeln('ok'); -end. - diff --git a/tests/test/testansi.pp b/tests/test/testansi.pp deleted file mode 100644 index 2e8984824d..0000000000 --- a/tests/test/testansi.pp +++ /dev/null @@ -1,492 +0,0 @@ -Program ansitest; - -{$ifdef GO32V2} -uses - dpmiexcp; -{$endif GO32V2} - -{$ifndef fpc} -Function Memavail : Longint; - -begin - Result:=0; -end; -{$endif} - -{ ------------------------------------------------------------------- - General stuff - ------------------------------------------------------------------- } - -Procedure DoMem (Var StartMem : Longint); - -begin - Writeln ('Lost ',StartMem-Memavail,' Bytes.'); - StartMem:=MemAvail; -end; - -Procedure DoRef (P : Pointer); - -Type PLongint = ^Longint; - -begin - If P=Nil then - Writeln ('(Ref : Empty string)') - else -{$ifdef fpc} - Writeln (' (Ref: ',Plongint(Longint(P)-4)^,',Len: ',PLongint(Longint(P)-8)^,')'); -{$else} - Writeln (' (Ref: ',Plongint(Longint(P)-8)^,',Len: ',PLongint(Longint(P)-4)^,')'); -{$endif} -end; - -{ ------------------------------------------------------------------- - Initialize/Finalize test - ------------------------------------------------------------------- } - - -Procedure TestInitFinal; - -Type ARec = record - FirstName, LastName : AnsiString; - end; - AnArray = Array [1..10] of AnsiString; - - -Var - S : AnsiString; - AR : Arec; - AAR : AnArray; - I : longint; - -Begin - S:='This is an ansistring!'; - If Pointer(AR.FirstNAme)<>Nil then - Writeln ('AR.FirstName not OK'); - If Pointer(AR.LastName)<>Nil then - Writeln ('AR.LastName not OK'); - for I:=1 to 10 do - If Pointer(AAR[I])<>Nil then - Writeln ('Array (',I,') NOT ok'); - AR.FirstName:='Napoleon'; - AR.LastName:='Bonaparte'; - For I:=1 to 10 do - AAR[I]:='Yet another AnsiString'; - Writeln ('S : ',S); - Writeln (AR.FirstName, ' ', AR.LastName); - For I:=1 to 10 do - Writeln (I:2,' : ',AAR[i]); -end; - -{ ------------------------------------------------------------------- - Parameter passing test - ------------------------------------------------------------------- } - - -Procedure TestVarParam (Var Sv : AnsiString); - -Var LS : AnsiString; - -begin - Write ('TestVarParam : Got S="',Sv,'"'); - DoRef(Pointer(Sv)); - Sv:='This is a var parameter ansistring'; - Write ('S Changed to : ',Sv); - DoRef (Pointer(Sv)); - Ls:=Sv; - Write ('Assigned to local var: "',ls,'"'); - DoRef (Pointer(Sv)); -end; - -Procedure TestValParam (S : AnsiString); - -Var LS : AnsiString; - -begin - Write ('TestValParam : Got S="',S,'"'); - S:='This is a value parameter ansistring'; - Write ('S Changed to : ',S); - DoRef(Pointer(S)); - Ls:=S; - Write ('Assigned to local var: "',ls,'"'); - DoRef(Pointer(S)); -end; - -Procedure TestConstParam (Const Sc : AnsiString); - -Var LS : AnsiString; - -begin - Write ('TestConstParam : Got S="',Sc,'"'); - DoRef(Pointer(Sc)); - Ls:=Sc; - Write ('Assigned to local var: "',ls,'"'); - DoRef(Pointer(Sc)); -end; - -Procedure TestParams; - -Var S : AnsiString; - Mem : Longint; - -begin - Mem:=MemAvail; - S :='This is another ansistring'; - Writeln ('Calling testvalparam with "',s,'"'); - testvalparam (s); - DoMem(Mem); - Writeln ('Calling testConstparam with "',s,'"'); - testconstparam (s); - DoMem(Mem); - Writeln ('Calling testvarparam with "',s,'"'); - testvarparam (s); - Writeln ('TestVarParam returned with "',S,'"'); - DoMem(Mem); -end; - -{ ------------------------------------------------------------------- - Comparision operators test - ------------------------------------------------------------------- } - -Procedure TestCompare; - -Const S1 : AnsiString = 'Teststring 1'; - S2 : AnsiString = 'Teststring 1'; - S3 : AnsiString = 'Teststring 2'; - S4 : AnsiString = ''; - PC : Pchar = 'Teststring 1'; - -Var S,T : AnsiString; - ss : Shortstring; - -begin - If S1=S2 then writeln ('S1 and S2 are the same'); - If S4='' then Writeln ('S4 is empty. OK'); - If Not(S4='Non-empty') then writeln ('S4 is not non-empty'); - if S3='Teststring 2' then writeln('S3 equals "Teststring 2". OK.'); - Write ('S3<>S2 : '); - If S2<>S3 Then writeln ('OK') else writeln ('NOT OK'); - Write ('S3>S2 : '); - If (S3>S2) Then Writeln ('OK') else writeln ('NOT OK'); - Write ('S1S3 do - begin - INc(i); - If I=10 then s3:='ABCDEF'; - end; - Writeln (' Done'); -end; - -Procedure TestStdFunc; - - -Var S,T : AnsiString; - SS : ShortString; - C : Char; - Ca : Cardinal; - L : longint; - I : Integer; - W : Word; - B : Byte; - R : Real; - D : Double; - E : Extended; - Si : Single; - Co : Comp; - TempMem:Longint; -begin - TempMem:=Memavail; - S:='ABCDEF'; - Write ('S = "',S,'"');Doref(Pointer(S)); - T:=Copy(S,1,3); - Write ('T : "',T,'"');DoRef(Pointer(T)); - T:=Copy(S,3,3); - Write ('T : "',T,'"');DoRef(Pointer(T)); - T:=Copy(S,3,6); - Write ('T : "',T,'"');DoRef(Pointer(T)); - Writeln ('Inserting "123" in S at pos 4'); - Insert ('123',S,4); - Write ('S = "',S,'"');DoRef(Pointer(S)); - Writeln ('Deleting 3 characters From S starting Pos 4'); - Delete (S,4,3); - Write ('S = "',S,'"');Doref(Pointer(S)); - Writeln ('Pos ''DE'' in S is : ',Pos('DE',S)); - Write ('S = "',S,'"');Doref(Pointer(S)); - Writeln ('Setting T to ''DE''.'); - T:='DE'; - //!! Here something weird is happening ? S is lost ??? - Writeln('***'); - Writeln ('Pos T in S is : ',Pos(T,S)); - Write ('S = "',S,'"');Doref(Pointer(S)); - Writeln ('Setting T to ''D''.'); - T:='D'; - Writeln ('Pos T in S is : ',Pos(T,S)); - Write ('S = "',S,'"');Doref(Pointer(S)); - Writeln ('Setting T to ''DA''.'); - T:='DA'; - Writeln ('Pos T in S is : ',Pos(T,S)); - Write ('S = "',S,'"');Doref(Pointer(S)); - Writeln ('SS:=''DE'''); - Writeln('***'); - SS:='DE'; - Writeln ('Pos SS in S is : ',Pos(SS,S)); - Write ('S = "',S,'"');Doref(Pointer(S)); - Writeln ('C:=''D'''); - C:='D'; - Writeln ('Pos C in S is : ',Pos(C,S)); - Write ('S = "',S,'"');Doref(Pointer(S)); - Writeln ('Pos ''D'' in S is : ',Pos('D',S)); - Write ('S = "',S,'"');Doref(Pointer(S)); - Write ('str(Ca,S)= '); - ca:=1; - str(Ca,S); - Writeln (S); - Write ('str(L,S)= '); - L:=2; - str(L,S); - Writeln (S); - Write ('str(I,S)= '); - I:=3; - str(I,S); - Writeln (S); - Write ('str(W,S)= '); - W:=4; - str(W,S); - Writeln (S); - Write ('str(R,S)= '); - R:=1.0; - str(R,S); - Writeln (S); - Write ('str(D,S)= '); - D:=2.0; - str(D,S); - Writeln (S); - Write ('str(E,S)= '); - E:=3.0; - str(E,S); - Writeln (S); - Write ('str(Co,S)= '); - Co:=4.0; - str(Co,S); - Writeln (S); - Write ('str(Si,S)= '); - Si:=5.0; - str(Si,S); - Writeln (S); -end; - -Var GlobalStartMem,StartMem : Longint; - -begin - GlobalStartMem:=MemAvail; - StartMem:=MemAvail; - Writeln ('Testing Initialize/Finalize.'); - TestInitFinal; - Write ('End of Initialize/finalize test : ');DoMem(StartMem); - - Writeln;Writeln ('Testing parameter passing.'); - TestParams; - Write ('End of Parameter passing test : ');DoMem(StartMem); - - Writeln;Writeln ('Testing comparision operators'); - TestCompare; - Write ('End of compare test : ');DoMem(StartMem); - - Writeln;Writeln ('Testing setlength of AnsiStrings'); - TestSetLength; - Write ('End of setlength test : ');DoMem(StartMem); - - Writeln;Writeln ('Testing Adding of AnsiStrings'); - TestAdd; - Write ('End of adding test : ');DoMem(StartMem); - - Writeln;Writeln ('Testing Adding of AnsiStrings in expressions'); - TestAddExpr; - Write ('End of adding in expressions test : ');DoMem(StartMem); - - Writeln;Writeln ('Testing type conversion.'); - TestConversion; - Write ('End of typeconversion test : ');DoMem(StartMem); - - Writeln;Writeln ('Testing indexed access.'); - TestIndex; - Write ('End of index access test : ');DoMem(StartMem); - - Writeln;Writeln ('Testing standard functions.'); - TestStdfunc; - Write ('End of standard functions: ');DoMem(StartMem); - Write ('For the whole program ');DoMem(GlobalStartMem); -end. diff --git a/tests/test/testaoc.pp b/tests/test/testaoc.pp deleted file mode 100644 index 5b5c3821f2..0000000000 --- a/tests/test/testaoc.pp +++ /dev/null @@ -1,111 +0,0 @@ -{$mode objfpc} -Program TestAOC; - -{ Program to test array of const } - -{ All elements of the following record must be tested : - Elements not yet tested are commented out. - - Type - PVarRec = ^TVarRec; - TVarRec = record - case vType: Byte of - vtInteger : (VInteger: Integer; VType:Longint); - vtBoolean : (VBoolean: Boolean); - vtChar : (VChar: Char); - vtExtended : (VExtended: PExtended); - vtString : (VString: PShortString); - vtPointer : (VPointer: Pointer); - vtPChar : (VPChar: PChar); - vtObject : (VObject: TObject); - vtClass : (VClass: TClass); - // vtWideChar : (VWideChar: WideChar); - // vtPWideChar : (VPWideChar: PWideChar); - vtAnsiString : (VAnsiString: Pointer); - // vtCurrency : (VCurrency: PCurrency); - // vtVariant : (VVariant: PVariant); - // vtInterface : (VInterface: Pointer); - // vtWideString : (VWideString: Pointer); - vtInt64 : (VInt64: PInt64); - vtQWord : (VQWord: PQWord); - end; -} - -procedure testit2 (args: array of byte); -begin -end; - -Procedure Testit (Args: Array of const); - -Var I : longint; - -begin - If High(Args)<0 then - begin - Writeln ('No aguments'); - exit; - end; - Writeln ('Got ',High(Args)+1,' arguments :'); - For i:=0 to High(Args) do - begin - write ('Argument ',i,' has type '); - case Args[i].vtype of - vtinteger : Writeln ('Integer, Value :',args[i].vinteger); - vtboolean : Writeln ('Boolean, Value :',args[i].vboolean); - vtchar : Writeln ('Char, value : ',args[i].vchar); - vtextended : Writeln ('Extended, value : ',args[i].VExtended^); - vtString : Writeln ('ShortString, value :',args[i].VString^); - vtPointer : Writeln ('Pointer, value : ',Longint(Args[i].VPointer)); - vtPChar : Writeln ('PCHar, value : ',Args[i].VPChar); - vtObject : Writeln ('Object, name : ',Args[i].VObject.Classname); - vtClass : Writeln ('Class reference, name : ',Args[i].VClass.Classname); - vtAnsiString : Writeln ('AnsiString, value :',AnsiString(Args[I].VAnsiString)); - -{ - vtWideChar : (VWideChar: WideChar); - vtPWideChar : (VPWideChar: PWideChar); - vtCurrency : (VCurrency: PCurrency); - vtVariant : (VVariant: PVariant); - vtInterface : (VInterface: Pointer); - vtWideString : (VWideString: Pointer); -} - vtInt64 : Writeln ('Int64, value : ',args[i].VInt64^); - vtQWord : Writeln ('QWord, value : ',args[i].VQWord^); - else - Writeln ('(Unknown) : ',args[i].vtype); - end; - end; -end; - -Const P1 : Pchar = 'Eerste Pchar'; - p2 : Pchar = 'Tweede pchar'; - -Var ObjA,ObjB : TObject; - ACLass,BClass : TClass; - S,T : AnsiString; - -begin - ObjA:=TObject.Create; - ObjB:=TObject.Create; - AClass:=TObject; - S:='Ansistring 1'; - T:='AnsiString 2'; - writeln ('Size of VarRec : ',Sizeof(TVarRec)); - Testit ([]); - Testit ([1,2]); - Testit (['A','B']); - Testit ([TRUE,FALSE,TRUE]); - Testit (['String','Another string']); - Testit ([S,T]) ; - Testit ([P1,P2]); - Testit ([@testit,Nil]); - Testit ([ObjA,ObjB]); - Testit ([1.234,1.234]); - TestIt ([AClass]); - TestIt ([QWord(1234)]); - TestIt ([Int64(1234)]); - TestIt ([Int64(12341234)*1000000000+Int64(12341234)]); - - TestIt2 ([]); - TestIt2 ([1,2]); -end. diff --git a/tests/test/testarr1.pp b/tests/test/testarr1.pp deleted file mode 100644 index c10befa9f9..0000000000 --- a/tests/test/testarr1.pp +++ /dev/null @@ -1,19 +0,0 @@ -{$mode objfpc} -type - tc1 = class - end; - - tc2 = class(tc1) - end; - - tcoc1 = class of tc1; - tcoc2 = class of tc2; - -procedure p(const a : array of tcoc1); - - begin - end; - -begin - p([tc2]); -end. diff --git a/tests/test/testbd.pp b/tests/test/testbd.pp deleted file mode 100644 index a4befc9fcb..0000000000 --- a/tests/test/testbd.pp +++ /dev/null @@ -1,38 +0,0 @@ -type - to1 = class - destructor destroy;override; - procedure beforedestruction;override; - end; - -var - i : longint; - - destructor to1.destroy; - - begin - if i<>2000 then - halt(1); - i:=3000; - inherited destroy; - end; - - procedure to1.beforedestruction; - - begin - if i<>1000 then - halt(1); - i:=2000; - end; - -var - o1 : to1; - -begin - o1:=to1.create; - i:=1000; - o1.destroy; - if i<>3000 then - halt(1); - writeln('ok'); -end. - diff --git a/tests/test/testcard.pp b/tests/test/testcard.pp deleted file mode 100644 index 4888b5cd8e..0000000000 --- a/tests/test/testcard.pp +++ /dev/null @@ -1,102 +0,0 @@ -Program TestCardinal; - -{ Tests different features of the cardinal type } -{ We must also test range checking thereafter } -Procedure TestEqualAssign; -var - l : longint; - i : cardinal; - j : cardinal; -Begin - l:=$80000000; { longint } - i:=l; { longint -> cardinal } - j:=i; { cardinal -> cardinal } - l:=j; { cardinal -> longint } -end; - - -Procedure TestBiggerAssign; -var - b: byte; - c: char; - s: shortint; - i: integer; - w: word; - j: cardinal; -Begin - b:=0; - c:=#$7f; - s:=120; - i:=16384; - w:=32767; - j:=b; { byte -> cardinal } - { THIS LINE CRASHES THE COMPILER FPC v0.99.5a } -{ j:=c;} { char -> cardinal } - j:=ord(c);{ char -> cardinal } - j:=s; { shortint -> cardinal } - j:=i; { integer -> cardinal } - j:=w; { word -> cardinal } -end; - -Procedure TestSmallerAssign; -var - b: byte; - c: char; - s: shortint; - i: integer; - w: word; - j: cardinal; -Begin - j:=$ffffffff; - b:=byte(j); - c:=char(j); - s:=shortint(j); - i:=integer(j); - w:=word(j); -end; - - -Procedure TestMul; -var - j: cardinal; - k: cardinal; -Begin - j:=1; - k:=$8000000; - j:=j*16384; - j:=j*k -end; - - -Procedure TestDiv; -var - j: cardinal; - k: cardinal; -Begin - j:=1; - k:=$8000000; - j:=j div 16384; - j:=j div k; - k:=k mod 200; -end; - - -Procedure TestAdd; -Begin -end; - - -Procedure TestSub; -Begin -end; - - -Begin - TestEqualAssign; - TestBiggerAssign; - TestSmallerAssign; - TestMul; - TestDiv; -end. - - diff --git a/tests/test/testcas2.pp b/tests/test/testcas2.pp deleted file mode 100644 index 34f014493b..0000000000 --- a/tests/test/testcas2.pp +++ /dev/null @@ -1,21 +0,0 @@ -type - days = (sun,mon,tue,wed,thu,fri,sat); - workdays = mon..fri; - -procedure t(d: workdays); - begin - case d of - mon: writeln('monday'); - thu: writeln('thursday'); - else - writeln('error'); - end; - end; - -var - d: workdays; - -begin - d := thu; - t(d); -end. diff --git a/tests/test/testcase.pp b/tests/test/testcase.pp deleted file mode 100644 index 7ab8ab8854..0000000000 --- a/tests/test/testcase.pp +++ /dev/null @@ -1,56 +0,0 @@ -program test_case; -function case1(Val : byte) : char; -begin - case Val of - 0..25 : case1:=chr(Val + ord('A')); - 26..51: case1:=chr(Val + ord('a') - 26); - 52..61: case1:=chr(Val + ord('0') - 52); - 62 : case1:='+'; - 63 : case1:='/'; - else - case1:='$'; - end; -end; - -function case2(Val : integer) : integer; -begin - case Val of - -1 : case2:=1; - 32765.. - 32767 : case2:=2; - else - case2:=-1; - end; -end; - -function case3(Val : integer) : integer; -begin - case Val of - -32768.. - -32766 : case3:=1; - 0..10 : case3:=2; - else - case3:=-1; - end; -end; - -var - error: boolean; - -begin - { The correct outputs should be: - F $ - 2 2 - 1 2 2 - } - error := false; - writeln(case1(5), ' ', case1(255),' (should be: F $)'); - error := (case1(5) <> 'F') or (case1(255) <> '$'); - writeln(case2(32765), ' ', case2(32767),' (should be: 2 2)'); - error := error or (case2(32765) <> 2) or (case2(32767) <> 2); - writeln(case3(-32768),' ',case3(0), ' ',case3(5),' (should be: 1 2 2)'); - error := error or (case3(-32768) <> 1) or (case3(0) <> 2) or - (case3(5) <> 2); - if error then - halt(1); -end. \ No newline at end of file diff --git a/tests/test/testchar.pp b/tests/test/testchar.pp deleted file mode 100644 index 086d8b94f2..0000000000 --- a/tests/test/testchar.pp +++ /dev/null @@ -1,157 +0,0 @@ -{$P+} - -type - CharA4 = array [1..4] of char; - CharA6 = array [1..6] of char; - String4 = String[4]; - String5 = String[5]; - String6 = String[6]; - String8 = String[8]; - -const - car4_1 : CharA4 = 'ABCD'; - car4_2 : CharA4 = 'abcd'; - car6_1 : CharA6 = 'EFGHIJ'; - car6_2 : CharA6 = 'efghij'; - cst4_1 : String4 = 'ABCD'; - cst6_2 : string6 = 'EFGHIJ'; - cst8_1 : string8 = 'abcd'; - cst8_2 : string8 = 'efghij'; - -var - ar4_1, ar4_2 : CharA4; - ar6_1, ar6_2 : CharA6; - st4_1, st4_2 : string4; - st5_1, st5_2 : string5; - st6_1, st6_2 : string6; - st8_1, st8_2 : string8; - pc : pchar; - -const - has_errors : boolean = false; - - procedure error(const st : string); - begin - Writeln('Error: ',st); - has_errors:=true; - end; - - procedure testvalueconv(st : string4); - begin - Writeln('st=',st); - Writeln('Length(st)=',Length(st)); - If Length(st)>4 then - Error('string length too big in calling value arg'); - end; - - procedure testconstconv(const st : string4); - begin - Writeln('st=',st); - Writeln('Length(st)=',Length(st)); - If Length(st)>4 then - Error('string length too big in calling const arg'); - end; - - procedure testvarconv(var st : string4); - begin - Writeln('st=',st); - Writeln('Length(st)=',Length(st)); - If Length(st)>4 then - Error('string length too big in calling var arg'); - end; - -{$P-} - procedure testvarconv2(var st : string4); - begin - Writeln('st=',st); - Writeln('Length(st)=',Length(st)); - If Length(st)>4 then - Error('string length too big in calling var arg without openstring'); - end; - -begin - { compare array of char to constant strings } - Writeln('Testing if "',car4_1,'" is equal to "',cst4_1,'"'); - if car4_1<>cst4_1 then - error('Comparison of array of char and string don''t work'); - Writeln('Testing if "',car4_1,'" is equal to "ABCD"'); - if car4_1<>'ABCD' then - error('Comparison of array of char and constat string don''t work'); - Writeln('Testing if "',cst4_1,'" is equal to "ABCD"'); - if 'ABCD'<>cst4_1 then - error('Comparison of string and constant string don''t work'); - car4_1:='AB'#0'D'; - if car4_1='AB' then - Writeln('Anything beyond a #0 is ignored') - else if car4_1='AB'#0'D' then - Writeln('Chars after #0 are not ignored') - else - Error('problems if #0 in array of char'); -{$ifdef FPC this is not allowed in BP !} - car4_1:=cst4_1; -{ if it is allowed then it must also work correctly !! } - Writeln('Testing if "',car4_1,'" is equal to "',cst4_1,'"'); - if car4_1<>cst4_1 then - error('Comparison of array of char and string don''t work'); - if string4(car6_2)<>'efgh' then - error('typcasting to shorter strings leads to problems'); - ar4_2:='Test'; - ar4_1:=cst6_2; - if ar4_2<>'Test' then - error('overwriting beyond char array size'); - ar6_1:='Test'#0'T'; - st6_1:=ar6_1; - if (st6_1<>ar6_1) or (st6_1='Test') then - error('problems with #0'); - ar6_1:='AB'; - if ar6_1='AB'#0't'#0'T' then - Error('assigning strings to array of char does not zero end of array if string is shorter'); - if ar6_1='AB'#0#0#0#0 then - writeln('assigning shorter strings to array of char does zero fo tserarray') - else - error('assigning "AB" to ar6_1 gives '+ar6_1); -{$endif} - cst8_1:=car4_1; -{ if it is allowed then it must also work correctly !! } - Writeln('Testing if "',car4_1,'" is equal to "',cst8_1,'"'); - if car4_1<>cst8_1 then - error('Comparison of array of char and string don''t work'); - st4_2:='Test'; - st4_1:=car6_1; - if (st4_2<>'Test') or (st4_1<>'EFGH') then - error('problems when copying long char array to shorter string'); - testvalueconv('AB'); - testvalueconv('ABCDEFG'); - testvalueconv(car4_1); - testvalueconv(car6_1); - getmem(pc,256); - pc:='Long Test'; -{$ifdef FPC this is not allowed in BP !} - testvalueconv(pc); -{$endif def FPC this is not allowed in BP !} - testconstconv('AB'); - testconstconv('ABCDEFG'); - testconstconv(st4_1); - testconstconv(cst6_2); -{$ifdef FPC this is not allowed in BP !} - testconstconv(pc); -{$endif def FPC this is not allowed in BP !} - testvarconv(st4_2); - testvarconv(cst4_1); -{$ifdef FPC this is not allowed in BP !} - testvarconv(st6_1); - testvarconv(cst8_1); -{$endif def FPC this is not allowed in BP !} - { testvarconv(pc); this one fails at compilation } - testvarconv2(st4_2); - testvarconv2(cst4_1); -{$ifdef FPC this is not allowed in BP !} - testvarconv2(st6_1); - testvarconv2(cst8_1); -{$endif def FPC this is not allowed in BP !} - if has_errors then - begin - Writeln('There are still problems with arrays of char'); - Halt(1); - end; -end. diff --git a/tests/test/testchr2.pp b/tests/test/testchr2.pp deleted file mode 100644 index b1dd3e3f71..0000000000 --- a/tests/test/testchr2.pp +++ /dev/null @@ -1,142 +0,0 @@ -{$P-} - -type - CharA4 = array [1..4] of char; - CharA6 = array [1..6] of char; - String4 = String[4]; - String5 = String[5]; - String6 = String[6]; - String8 = String[8]; - -const - car4_1 : CharA4 = 'ABCD'; - car4_2 : CharA4 = 'abcd'; - car6_1 : CharA6 = 'EFGHIJ'; - car6_2 : CharA6 = 'efghij'; - cst4_1 : String4 = 'ABCD'; - cst6_2 : string6 = 'EFGHIJ'; - cst8_1 : string8 = 'abcd'; - cst8_2 : string8 = 'efghij'; - -var - ar4_1, ar4_2 : CharA4; - ar6_1, ar6_2 : CharA6; - st4_1, st4_2 : string4; - st5_1, st5_2 : string5; - st6_1, st6_2 : string6; - st8_1, st8_2 : string8; - pc : pchar; - -const - has_errors : boolean = false; - - procedure error(const st : string); - begin - Writeln('Error: ',st); - has_errors:=true; - end; - - procedure testvalueconv(st : string4); - begin - Writeln('st=',st); - Writeln('Length(st)=',Length(st)); - If Length(st)>4 then - Error('string length too big in calling value arg'); - end; - - procedure testconstconv(const st : string4); - begin - Writeln('st=',st); - Writeln('Length(st)=',Length(st)); - If Length(st)>4 then - Error('string length too big in calling const arg'); - end; - - procedure testvarconv(var st : string4); - begin - Writeln('st=',st); - Writeln('Length(st)=',Length(st)); - If Length(st)>4 then - Error('string length too big in calling var arg'); - end; - -begin - { compare array of char to constant strings } - Writeln('Testing if "',car4_1,'" is equal to "',cst4_1,'"'); - if car4_1<>cst4_1 then - error('Comparison of array of char and string don''t work'); - Writeln('Testing if "',car4_1,'" is equal to "ABCD"'); - if car4_1<>'ABCD' then - error('Comparison of array of char and constat string don''t work'); - Writeln('Testing if "',cst4_1,'" is equal to "ABCD"'); - if 'ABCD'<>cst4_1 then - error('Comparison of string and constant string don''t work'); - car4_1:='AB'#0'D'; - if car4_1='AB' then - Writeln('Anything beyond a #0 is ignored') - else if car4_1='AB'#0'D' then - Writeln('Chars after #0 are not ignored') - else - Error('problems if #0 in array of char'); -{$ifdef FPC this is not allowed in BP !} - car4_1:=cst4_1; -{ if it is allowed then it must also work correctly !! } - Writeln('Testing if "',car4_1,'" is equal to "',cst4_1,'"'); - if car4_1<>cst4_1 then - error('Comparison of array of char and string don''t work'); - if string4(car6_2)<>'efgh' then - error('typcasting to shorter strings leads to problems'); - ar4_2:='Test'; - ar4_1:=cst6_2; - if ar4_2<>'Test' then - error('overwriting beyond char array size'); - ar6_1:='Test'#0'T'; - st6_1:=ar6_1; - if (st6_1<>ar6_1) or (st6_1='Test') then - error('problems with #0'); - ar6_1:='AB'; - if ar6_1='AB'#0't'#0'T' then - Error('assigning strings to array of char does not zero end of array if string is shorter'); - if ar6_1='AB'#0#0#0#0 then - writeln('assigning shorter strings to array of char does zero fo tserarray') - else - error('assigning "AB" to ar6_1 gives '+ar6_1); -{$endif} - cst8_1:=car4_1; -{ if it is allowed then it must also work correctly !! } - Writeln('Testing if "',car4_1,'" is equal to "',cst8_1,'"'); - if car4_1<>cst8_1 then - error('Comparison of array of char and string don''t work'); - st4_2:='Test'; - st4_1:=car6_1; - if (st4_2<>'Test') or (st4_1<>'EFGH') then - error('problems when copying long char array to shorter string'); - testvalueconv('AB'); - testvalueconv('ABCDEFG'); - testvalueconv(car4_1); - testvalueconv(car6_1); - getmem(pc,256); - pc:='Long Test'; -{$ifdef FPC this is not allowed in BP !} - testvalueconv(pc); -{$endif def FPC this is not allowed in BP !} - testconstconv('AB'); - testconstconv('ABCDEFG'); - testconstconv(st4_1); - testconstconv(cst6_2); -{$ifdef FPC this is not allowed in BP !} - testconstconv(pc); -{$endif def FPC this is not allowed in BP !} - testvarconv(st4_2); - testvarconv(cst4_1); -{$ifdef FPC this is not allowed in BP !} - testvarconv(st6_1); - testvarconv(cst8_1); -{$endif def FPC this is not allowed in BP !} - { testvarconv(pc); this one fails at compilation } - if has_errors then - begin - Writeln('There are still problems with arrays of char'); - Halt(1); - end; -end. diff --git a/tests/test/testcmov.pp b/tests/test/testcmov.pp deleted file mode 100644 index 8c6d5cbf09..0000000000 --- a/tests/test/testcmov.pp +++ /dev/null @@ -1,29 +0,0 @@ -var - l1,l2 : longint; - w1,w2 : word; - b1,b2 : byte; - b : boolean; - -begin - if b then - w1:=w2; - if b then - w1:=w2; - if b then - begin - w1:=w2; - l1:=l2; - end; - if b then - w1:=w2 - else - w2:=w1; - { - if b then - begin - w1:=w2; - l1:=l2; - b1:=b2; - end; - } -end. \ No newline at end of file diff --git a/tests/test/testcstr.pp b/tests/test/testcstr.pp deleted file mode 100644 index e2798ed89d..0000000000 --- a/tests/test/testcstr.pp +++ /dev/null @@ -1,43 +0,0 @@ -program testcstr; - -{$mode objfpc} - -resourcestring - RsFDivFlawed = 'Res1'; - RsFDivOK = 'Res2'; - -const - c1 = 'A'; - c2 = 'B'; - s1 = 'String1'; - s2 = 'String2'; - - FDIVResStringS : array [0..1] of shortstring = (RsFDivFlawed, RsFDivOK); - FDIVResStringsA : array [0..1] of ansistring = (RsFDivFlawed, RsFDivOK); - FDivChars : array [0..1] of shortstring = (c1,c2); - FDivCharsA : array [0..1] of ansistring = (c1,c2); - FDIVStringS : array [0..1] of shortstring = (s1,s2); - FDIVStringsA : array [0..1] of ansistring = (s1,s2); - -var - error : integer; -begin - error:=0; - if Fdivresstrings[0]<>'Res1' then - inc(error); - if FdivresstringsA[1]<>'Res2' then - inc(error); - if FdivChars[0]<>'A' then - inc(error); - if FdivCharsA[1]<>'B' then - inc(error); - if Fdivstrings[0]<>'String1' then - inc(error); - if FdivstringsA[1]<>'String2' then - inc(error); - if error>0 then - begin - writeln(error,' errors with constant strings'); - halt(1); - end; -end. diff --git a/tests/test/testdiv.pp b/tests/test/testdiv.pp deleted file mode 100644 index 2576092cde..0000000000 --- a/tests/test/testdiv.pp +++ /dev/null @@ -1,74 +0,0 @@ - - - -Procedure TestDiv; -var - bx,by: byte; - ix,iy: integer; - wx,wy: word; - lx,ly: longint; -Begin - { byte test } - bx:=10; - by:=5; - bx:=bx div by; - if bx = 2 then - WriteLn('TEST_DIV(1): PASSED.') - else - WriteLn('TEST_DIV(1): FAILED.'); - bx:=20; - bx:=bx div 10; - if bx = 2 then - WriteLn('TEST_DIV(2): PASSED.') - else - WriteLn('TEST_DIV(2): FAILED.'); - { integer test } - ix:=-10; - iy:=5; - ix:=ix div iy; - if ix = -2 then - WriteLn('TEST_DIV(3): PASSED.') - else - WriteLn('TEST_DIV(3): FAILED.'); - ix:=-20; - ix:=ix div 10; - if ix = -2 then - WriteLn('TEST_DIV(4): PASSED.') - else - WriteLn('TEST_DIV(4): FAILED.'); - { word test } - wx:=64000; - wy:=2; - wx:=wx div wy; - if wx = 32000 then - WriteLn('TEST_DIV(5): PASSED.') - else - WriteLn('TEST_DIV(5): FAILED.'); - wx:=20; - wx:=wx div 10; - if wx = 2 then - WriteLn('TEST_DIV(6): PASSED.') - else - WriteLn('TEST_DIV(6): FAILED.'); - { longint test } - lx:=-1000000; - ly:=2; - lx:=lx div ly; - if lx = -500000 then - WriteLn('TEST_DIV(7): PASSED.') - else - WriteLn('TEST_DIV(7): FAILED.'); - lx:=-1000000; - lx:=lx div 10; - if lx = -100000 then - WriteLn('TEST_DIV(8): PASSED.') - else - WriteLn('TEST_DIV(8): FAILED.') -end; - - - - -Begin - Testdiv; -end. \ No newline at end of file diff --git a/tests/test/testenm1.pp b/tests/test/testenm1.pp deleted file mode 100644 index c77f66a4f3..0000000000 --- a/tests/test/testenm1.pp +++ /dev/null @@ -1,14 +0,0 @@ -type - days = (mon,tue,wed,thu,fri,sat,sun); - weekend = sat..sun; - -procedure t2(day: weekend); -begin - if day = sat then - writeln('ok') - else writeln('error'); -end; - -begin - t2(sat); -end. diff --git a/tests/test/testexc.pp b/tests/test/testexc.pp deleted file mode 100644 index 6ce1518846..0000000000 --- a/tests/test/testexc.pp +++ /dev/null @@ -1,201 +0,0 @@ -program testexceptions; - -{$mode objfpc} - -Type - TAObject = class(TObject) - a : longint; - end; - TBObject = Class(TObject) - b : longint; - end; - -Procedure raiseanexception; - -Var A : TAObject; - -begin - Writeln ('Creating exception object'); - A:=TAObject.Create; - Writeln ('Raising with this object'); - raise A; - Writeln ('This can''t happen'); -end; - -Var MaxLevel : longint; - -Procedure DoTryFinally (Level : Longint; DoRaise : Boolean); - - -Var Raised,Reraised : Boolean; - I : Longint; - -begin - Try - writeln ('Try(',level,') : Checking for exception'); - If Level=MaxLevel then - begin - if DoRaise then - begin - Writeln ('Try(',level,'): Level ',maxlevel,' reached, raising exception.'); - Raiseanexception - end - else - Writeln ('Try(',Level,'): Not raising exception') - end - else - begin - Writeln ('Try(',level,') : jumping to next level'); - DoTryFinally(Level+1,DoRaise); - end; - finally - Writeln ('Finally (',level,'): Starting code.'); - end; - writeln ('Out of try/finally at level (',level,')'); -end; - -Procedure DoTryExcept (Level : Longint; DoRaise : Boolean); - -Var Raised : Boolean; - I : Longint; - Caught : TObject; - -begin - Try - writeln ('Try(',level,') : Checking for exception'); - If Level=MaxLevel then - if DoRaise then - begin - Writeln ('Try(',level,'): Level ',maxlevel,', raising exception.'); - Raiseanexception - end - else - Writeln ('Try(',Level,'): level ',maxlevel,'. Not raising exception') - else - begin - Writeln ('Try(',level,') : jumping to next level'); - DoTryExcept(Level+1,DoRaise); - end; - except - On TAObject do Writeln ('Exception was caught by TAObject'); - On TBobject do Writeln ('Exception was caught by TBObject'); - On E : TObject do Writeln ('Caught object ',E.ClassName); -// writeln ('Except (',level,') : Exception caught by default handler'); - end; - writeln ('Out of try/except at level (',level,')'); -end; - -Procedure DoMix (Level : Longint; DoRaise : Boolean); - -Var Raised : Boolean; - I : Longint; - Caught : TObject; - -begin - Try - Try - writeln ('Try(',level,') : Checking for exception'); - If Level=MaxLevel then - if DoRaise then - begin - Writeln ('Try(',level,'): Level ',maxlevel,', raising exception.'); - Raiseanexception - end - else - Writeln ('Try(',Level,'): level ',maxlevel,'. Not raising exception') - else - begin - Writeln ('Try(',level,') : jumping to next level'); - DoMix(Level+1,DoRaise); - end; - finally - Writeln ('Mix:Finally (',level,'): Starting code.'); - end; - Writeln ('Level (',level,') : Out of try/finally'); - except - On TAObject do Writeln ('Exception was caught by TAObject'); - On TBobject do Writeln ('Exception was caught by TBObject'); - On TObject do writeln ('Except (',level,') : Exception caught by TObject'); -// The following don't work... - On E : TObject do Writeln ('Caught object ',E.ClassName); - else - writeln ('Except (',level,') : Exception caught by default handler'); - end; - writeln ('Out of try/except at level (',level,')'); -end; - -function _dotryfinally : boolean; - -var - problem : boolean; - -begin - result:=false; - try - try - finally - writeln('Raising an exception in finally statement'); - Raiseanexception - end; - except - end; - try - exit; - finally - result:=true; - end; - writeln('Problem with finally and exit !!!!'); - halt(1); -end; - -procedure dotryfinally; - - begin - if not(_dotryfinally) then - begin - writeln('Problem with finally and exit !!!!'); - halt(1); - end; - end; - -Procedure Start(Const Msg : string); - -begin - Writeln (Msg); - Writeln; -end; - -Procedure Finish; - -begin - Writeln; - Write ('Finished.'); - { Press enter to continue.'); - Readln; tests/test/test... must be non interactive !! PM } -end; - - -begin - Maxlevel:=3; - Start ('Testing Try/Finally without raise'); - DoTryFinally (1,False); - Finish; - Start ('Testing Try/except without raise'); - DoTryExcept (1,FAlse); - Finish; - Start ('Testing Mix without raise'); - DoMix (1,False); - Finish; - Start ('Testing Try/except with raise'); - DoTryExcept (1,true); - Finish; - Start ('Testing Mix with raise'); - DoMix (1,true); - Finish; - Start ('Testing Try/Finally with Exit'); - dotryfinally; - Finish; - Writeln ('Testing Try/Finally with raise'); - Start ('This one should end with an error message !!.'); - DoTryFinally (1,True); -end. diff --git a/tests/test/testexc.ree b/tests/test/testexc.ree deleted file mode 100644 index e99fdcc524..0000000000 --- a/tests/test/testexc.ree +++ /dev/null @@ -1 +0,0 @@ -217 \ No newline at end of file diff --git a/tests/test/testexc2.pp b/tests/test/testexc2.pp deleted file mode 100644 index 04c6d8eb38..0000000000 --- a/tests/test/testexc2.pp +++ /dev/null @@ -1,27 +0,0 @@ -{$mode objfpc} -uses - dotest, - sysutils; - -procedure d; - - var - d1 : double; - - begin - d1:=0; - d1:=1/d1; - end; - -var - i : longint; - -begin - for i:=1 to 20 do - try - d; - except - on exception do - ; - end; -end. \ No newline at end of file diff --git a/tests/test/testexc3.pp b/tests/test/testexc3.pp deleted file mode 100644 index e280994aa7..0000000000 --- a/tests/test/testexc3.pp +++ /dev/null @@ -1,776 +0,0 @@ -{$mode objfpc} -uses - dotest,sysutils; - -var - i : longint; - -procedure test1; - - begin - try - i:=0; - exit; - finally - inc(i); - end; - i:=-2; - end; - -procedure test2; - - begin - try - i:=0; - raise exception.create(''); - finally - inc(i); - end; - i:=-2; - end; - -procedure test3; - - begin - try - try - i:=0; - raise exception.create(''); - finally - inc(i); - end; - finally - inc(i); - end; - i:=-2; - end; - -procedure test4; - - begin - try - try - i:=0; - exit; - finally - inc(i); - end; - finally - inc(i); - end; - i:=-2; - end; - -procedure test5; - - var - j : longint; - - begin - for j:=1 to 10 do - begin - try - i:=0; - break; - finally - inc(i); - end; - dec(i); - end; - end; - -procedure test6; - - var - j : longint; - - begin - i:=0; - for j:=1 to 10 do - begin - try - continue; - finally - inc(i); - end; - dec(i); - end; - end; - -procedure test7; - - var - j : longint; - - begin - for j:=1 to 10 do - begin - try - try - i:=0; - break; - finally - inc(i); - end; - dec(i); - finally - inc(i); - end; - end; - end; - -procedure test8; - - var - j : longint; - - begin - i:=0; - for j:=1 to 10 do - begin - try - try - continue; - finally - inc(i); - end; - finally - inc(i); - end; - dec(i); - end; - end; - - -{ some combined test ... } - -procedure test9; - - var - j : longint; - - begin - try - i:=0; - finally - for j:=1 to 10 do - begin - try - if j<2 then - continue - else - break; - finally - inc(i); - end; - dec(i); - end; - end; - end; - -procedure test10; - - var - j : longint; - - begin - try - i:=0; - j:=1; - finally - while j<=10 do - begin - try - if j<2 then - continue - else - break; - finally - inc(i); - inc(j); - end; - dec(i); - end; - end; - end; - -{ the do_raise function is a little bit more complicated } -{ so we also check if memory is lost } -function do_raise : ansistring; - - var - a1,a2 : ansistring; - j : longint; - - begin - for j:=1 to 3 do - begin - a1:=copy('Hello world',1,5); - do_raise:=copy(a2,1,1); - end; - raise exception.create('A string to test memory allocation'); - do_error(99998); - end; - - -{ now test real exceptions } -procedure test100; - - begin - try - i:=0; - do_raise; - except - inc(i); - end; - end; - -procedure test101; - - begin - try - try - i:=0; - do_raise; - except - inc(i); - do_raise; - end; - except - inc(i); - end; - end; - -procedure test102; - - begin - try - try - i:=0; - do_raise; - except - inc(i); - raise; - end; - except - inc(i); - end; - end; - -{ tests continue in try...except...end; statements } -procedure test103; - - var - j,k : longint; - - begin - i:=0; - for j:=1 to 10 do - try - for k:=1 to 10 do - try - inc(i); - if (i mod 10)>5 then - do_raise - else - continue; - except - continue - end; - if i>50 then - do_raise - else - continue; - except - continue; - end; - end; - -procedure test104; - - begin - try - i:=1; - exit; - // we should never get there - do_raise; - except - i:=-1; - end; - i:=-2; - end; - -procedure test105; - - begin - try - i:=0; - do_raise; - // we should never get there - i:=-1; - except - inc(i); - exit; - end; - end; - -procedure test106; - - begin - try - try - i:=1; - exit; - // we should never get there - do_raise; - except - i:=-1; - end; - i:=-2; - except - end; - end; - -procedure test107; - - begin - try - do_raise; - except - try - i:=0; - do_raise; - // we should never get there - i:=-1; - except - inc(i); - exit; - end; - end; - end; - -{ tests break in try...except...end; statements } -procedure test108; - - begin - i:=0; - while true do - try - while true do - try - inc(i); - break; - except - end; - inc(i); - break; - except - end; - end; - -procedure test109; - - begin - i:=0; - while true do - try - repeat - try - do_raise; - i:=-1; - except - inc(i); - break; - end; - until false; - do_raise; - i:=-1; - except - inc(i); - break; - end; - end; - -{ test the on statement } -procedure test110; - - begin - try - i:=0; - do_raise; - except - on e : exception do - inc(i); - end; - end; - -procedure test111; - - begin - try - try - i:=0; - do_raise; - except - on e : exception do - begin - inc(i); - do_raise; - end; - end; - except - on e : exception do - inc(i); - end; - end; - -procedure test112; - - begin - try - try - i:=0; - do_raise; - except - on e : exception do - begin - inc(i); - raise; - end; - end; - except - on e : exception do - inc(i); - end; - end; - -procedure test113; - - var - j,k : longint; - - begin - i:=0; - for j:=1 to 10 do - try - for k:=1 to 10 do - try - inc(i); - if (i mod 10)>5 then - do_raise - else - continue; - except - on e : exception do - continue - end; - if i>50 then - do_raise - else - continue; - except - on e : exception do - continue; - end; - end; - -procedure test114; - - begin - try - i:=1; - exit; - // we should never get there - do_raise; - except - on e : exception do - i:=-1; - end; - i:=-2; - end; - -procedure test115; - - begin - try - i:=0; - do_raise; - // we should never get there - i:=-1; - except - on e : exception do - begin - inc(i); - exit; - end; - end; - end; - -procedure test116; - - begin - try - try - i:=1; - exit; - // we should never get there - do_raise; - except - on e : exception do - i:=-1; - end; - i:=-2; - except - on e : exception do - ; - end; - end; - -procedure test117; - - begin - try - do_raise; - except - try - i:=0; - do_raise; - // we should never get there - i:=-1; - except - on e : exception do - begin - inc(i); - exit; - end; - end; - end; - end; - -{ tests break in try...except...end; statements } -procedure test118; - - begin - i:=0; - while true do - try - while true do - try - inc(i); - break; - except - on e : exception do - ; - end; - inc(i); - break; - except - on e : exception do - ; - end; - end; - -procedure test119; - - begin - i:=0; - while true do - try - repeat - try - do_raise; - i:=-1; - except - on e : exception do - begin - inc(i); - break; - end; - end; - until false; - do_raise; - i:=-1; - except - on e : exception do - begin - inc(i); - break; - end; - end; - end; - -var - startmemavail : longint; - -begin - writeln('Testing exception handling'); - startmemavail:=memavail; - i:=-1; - try - test1; - finally - inc(i); - end; - if i<>2 then - do_error(1001); - - i:=-1; - try - test2; - except - inc(i); - end; - if i<>2 then - do_error(1002); - - i:=-1; - try - test3; - except - inc(i); - end; - if i<>3 then - do_error(1003); - - i:=-1; - test4; - if i<>2 then - do_error(1004); - - i:=-1; - test5; - if i<>1 then - do_error(1005); - - i:=-1; - test6; - if i<>10 then - do_error(1006); - - i:=-1; - test7; - if i<>2 then - do_error(1007); - - i:=-1; - test8; - if i<>20 then - do_error(1008); - - i:=-1; - test9; - if i<>2 then - do_error(1009); - - i:=-1; - test10; - if i<>2 then - do_error(1010); - - i:=-1; - test100; - if i<>1 then - do_error(1100); - - i:=-1; - test101; - if i<>2 then - do_error(1101); - - i:=-1; - test102; - if i<>2 then - do_error(1102); - - i:=-1; - test103; - if i<>100 then - do_error(1103); - - - i:=-1; - test104; - if i<>1 then - do_error(1104); - - i:=-1; - test105; - if i<>1 then - do_error(1105); - - i:=-1; - test106; - if i<>1 then - do_error(1106); - - i:=-1; - test107; - if i<>1 then - do_error(1107); - - i:=-1; - test108; - if i<>2 then - do_error(1108); - - i:=-1; - test109; - if i<>2 then - do_error(1109); - - i:=-1; - test110; - if i<>1 then - do_error(1110); - - i:=-1; - test111; - if i<>2 then - do_error(1111); - - i:=-1; - test112; - if i<>2 then - do_error(1112); - - i:=-1; - test113; - if i<>100 then - do_error(1113); - - - i:=-1; - test114; - if i<>1 then - do_error(1114); - - i:=-1; - test115; - if i<>1 then - do_error(1115); - - i:=-1; - test116; - if i<>1 then - do_error(1116); - - i:=-1; - test117; - if i<>1 then - do_error(1117); - - i:=-1; - test118; - if i<>2 then - do_error(1118); - - i:=-1; - test119; - if i<>2 then - do_error(1119); - - if memavail<>startmemavail then - do_error(99999); - writeln('Test successfully passed'); - halt(0); -end. \ No newline at end of file diff --git a/tests/test/testfail.pp b/tests/test/testfail.pp deleted file mode 100644 index 3ae4fbdb76..0000000000 --- a/tests/test/testfail.pp +++ /dev/null @@ -1,90 +0,0 @@ -{$R+} - -program test_fail; - - type - parrayobj = ^tarrayobj; - tarrayobj = object - ar : array [1..4] of real; - constructor init(do_fail : boolean); - procedure test;virtual; - destructor done;virtual; - end; - pbigarrayobj = ^tbigarrayobj; - tbigarrayobj = object(tarrayobj) - ar2 : array [1..10000] of real; - constructor good_init; - constructor wrong_init; - procedure test;virtual; - end; - var - pa1, pa2 : parrayobj; - ta1, ta2 : tarrayobj; - availmem : longint; - - constructor tarrayobj.init(do_fail : boolean); - begin - ar[1]:=1; - if do_fail then - fail; - ar[2]:=2; - end; - - destructor tarrayobj.done; - begin - end; - - procedure tarrayobj.test; - begin - Writeln('@self = ',longint(@self)); - Writeln('typeof = ',longint(typeof(self))); - if ar[1]=1 then - Writeln('Init called'); - if ar[2]=2 then - Writeln('Init successful'); - end; - - constructor tbigarrayobj.good_init; - begin - inherited init(false); - Writeln('End of tbigarrayobj.good_init'); - end; - - constructor tbigarrayobj.wrong_init; - begin - inherited init(true); - Writeln('End of tbigarrayobj.wrong_init'); - end; - - procedure tbigarrayobj.test; - begin - Writeln('tbigarrayobj.test called'); - Inherited test; - end; - - begin - availmem:=memavail; - new(pa1,init(false)); - writeln('After successful new(pa1,init), memory used = ',availmem - memavail); - new(pa2,init(true)); - writeln('After unsuccessful new(pa2,init), memory used = ',availmem - memavail); - writeln('pa1 = ',longint(pa1),' pa2 = ',longint(pa2)); - writeln('Call to pa1^.test after successful init'); - pa1^.test; - dispose(pa1,done); - writeln('After release of pa1, memory used = ',availmem - memavail); - pa1:=new(pbigarrayobj,good_init); - writeln('After successful pa1:=new(pbigarrayobj,good_init), memory used = ',availmem - memavail); - pa2:=new(pbigarrayobj,wrong_init); - writeln('After unsuccessful pa2:=new(pbigarrayobj,wrong_init), memory used = ',availmem - memavail); - writeln('pa1 = ',longint(pa1),' pa2 = ',longint(pa2)); - writeln('Call to pa1^.test after successful init'); - pa1^.test; - ta1.init(false); - writeln('Call to ta1.test after successful init'); - ta1.test; - ta2.init(true); - writeln('typeof(ta2) = ',longint(typeof(ta2)),' after unsuccessful init'); - Writeln('Trying to call ta2.test (should generate a Run Time Error)'); - ta2.test; - end. diff --git a/tests/test/testfail.ree b/tests/test/testfail.ree deleted file mode 100644 index 55596b29f7..0000000000 --- a/tests/test/testfail.ree +++ /dev/null @@ -1 +0,0 @@ -210 \ No newline at end of file diff --git a/tests/test/testfdi2.pp b/tests/test/testfdi2.pp deleted file mode 100644 index 25e17e2f50..0000000000 --- a/tests/test/testfdi2.pp +++ /dev/null @@ -1,107 +0,0 @@ -{ testfdiv variant with NASM output forced } -{$ifdef go32v2} -{$output_format nasmcoff} -{$endif} -{$ifdef win32} -{$output_format nasmwin32} -{$endif} -{$ifdef linux} -{$output_format nasmelf} -{$endif} -{ This test program deals with the - the delicate problem of - non commutative FPU instruction - where the destination register - is ST(1) to ST(7) - - Whereas Intel interprets - fdiv st(1),st - as - st(1):=st(1) / st - The ATT read - fdiv %st,%st(1) - as - st(1):=st/st(1) - Should be tested with - different output styles : - for go32v2 - -Aas -Acoff and -Anasmcoff - for win32 - -Aas -Apecoff and -Anasmwin32 - for linux - -Aas and -Anasmelf - } - -program test_nasm_div; - - -var - x,y,z : double; - -begin - x:=4; - y:=2; - Writeln('4/2=',x/y:0:2); - if x/y <> 2.0 then - Halt(1); -{$asmmode att} - asm - fldl y - fldl x - fdivp %st,%st(1) - fstpl z - end; - Writeln('ATT result of 4/2=',z:0:2); - if z <> 2.0 then - Halt(1); - asm - fldl y - fldl x - fdiv %st(1),%st - fstpl z - fstp %st - end; - Writeln('ATT result of 4/2=',z:0:2); - if z <> 2.0 then - Halt(1); - asm - fldl y - fldl x - fadd - fstpl z - end; - Writeln('ATT result of 4+2=',z:0:2); - if z <> 6.0 then - Halt(1); -{$asmmode intel} - asm - fld x - fld y - fdivp st(1),st - fstp z - end; - Writeln('Intel result of 4/2=',z:0:2); - if z <> 2.0 then - Halt(1); - asm - fld y - fld x - fdiv st,st(1) - fstp z - fstp st - end; - Writeln('Intel result of 4/2=',z:0:2); - if z <> 2.0 then - Halt(1); - asm - fld y - fld x - fadd - fstp z - end; - Writeln('Intel result of 4+2=',z:0:2); - if z <> 6.0 then - Halt(1); - - Writeln('All tests completed successfully!'); -end. diff --git a/tests/test/testfdi3.pp b/tests/test/testfdi3.pp deleted file mode 100644 index dad60fc729..0000000000 --- a/tests/test/testfdi3.pp +++ /dev/null @@ -1,99 +0,0 @@ -{ testfdiv variant with GNU AS output forced } -{$output_format as} -{ This test program deals with the - the delicate problem of - non commutative FPU instruction - where the destination register - is ST(1) to ST(7) - - Whereas Intel interprets - fdiv st(1),st - as - st(1):=st(1) / st - The ATT read - fdiv %st,%st(1) - as - st(1):=st/st(1) - Should be tested with - different output styles : - for go32v2 - -Aas -Acoff and -Anasmcoff - for win32 - -Aas -Apecoff and -Anasmwin32 - for linux - -Aas and -Anasmelf - } - -program test_nasm_div; - - -var - x,y,z : double; - -begin - x:=4; - y:=2; - Writeln('4/2=',x/y:0:2); - if x/y <> 2.0 then - Halt(1); -{$asmmode att} - asm - fldl y - fldl x - fdivp %st,%st(1) - fstpl z - end; - Writeln('ATT result of 4/2=',z:0:2); - if z <> 2.0 then - Halt(1); - asm - fldl y - fldl x - fdiv %st(1),%st - fstpl z - fstp %st - end; - Writeln('ATT result of 4/2=',z:0:2); - if z <> 2.0 then - Halt(1); - asm - fldl y - fldl x - fadd - fstpl z - end; - Writeln('ATT result of 4+2=',z:0:2); - if z <> 6.0 then - Halt(1); -{$asmmode intel} - asm - fld x - fld y - fdivp st(1),st - fstp z - end; - Writeln('Intel result of 4/2=',z:0:2); - if z <> 2.0 then - Halt(1); - asm - fld y - fld x - fdiv st,st(1) - fstp z - fstp st - end; - Writeln('Intel result of 4/2=',z:0:2); - if z <> 2.0 then - Halt(1); - asm - fld y - fld x - fadd - fstp z - end; - Writeln('Intel result of 4+2=',z:0:2); - if z <> 6.0 then - Halt(1); - - Writeln('All tests completed successfully!'); -end. diff --git a/tests/test/testfdiv.pp b/tests/test/testfdiv.pp deleted file mode 100644 index c27a338f97..0000000000 --- a/tests/test/testfdiv.pp +++ /dev/null @@ -1,98 +0,0 @@ -{ This test program deals with the - the delicate problem of - non commutative FPU instruction - where the destination register - is ST(1) to ST(7) - - Whereas Intel interprets - fdiv st(1),st - as - st(1):=st(1) / st - The ATT read - fdiv %st,%st(1) - as - st(1):=st/st(1) - Should be tested with - different output styles : - for go32v2 - -Aas -Acoff and -Anasmcoff - for win32 - -Aas -Apecoff and -Anasmwin32 - for linux - -Aas and -Anasmelf - } - -program test_nasm_div; - - -var - x,y,z : double; - -begin - x:=4; - y:=2; - Writeln('4/2=',x/y:0:2); - if x/y <> 2.0 then - Halt(1); -{$asmmode att} - asm - fldl y - fldl x - fdivp %st,%st(1) - fstpl z - end; - Writeln('ATT result of 4/2=',z:0:2); - if z <> 2.0 then - Halt(1); - asm - fldl y - fldl x - fdiv %st(1),%st - fstpl z - fstp %st - end; - Writeln('ATT result of 4/2=',z:0:2); - if z <> 2.0 then - Halt(1); - asm - fldl y - fldl x - fadd - fstpl z - end; - Writeln('ATT result of 4+2=',z:0:2); - if z <> 6.0 then - Halt(1); -{$asmmode intel} - asm - fld x - fld y - fdivp st(1),st - fstp z - end; - Writeln('Intel result of 4/2=',z:0:2); - if z <> 2.0 then - Halt(1); - asm - fld y - fld x - fdiv st,st(1) - fstp z - fstp st - end; - Writeln('Intel result of 4/2=',z:0:2); - if z <> 2.0 then - Halt(1); - asm - fld y - fld x - fadd - fstp z - end; - Writeln('Intel result of 4+2=',z:0:2); - if z <> 6.0 then - Halt(1); - - Writeln('All tests completed successfully!'); -end. - diff --git a/tests/test/testfi1.pp b/tests/test/testfi1.pp deleted file mode 100644 index bf5c925d52..0000000000 --- a/tests/test/testfi1.pp +++ /dev/null @@ -1,21 +0,0 @@ -{$mode delphi} -var - a,c1,c2 : ansistring; - aa : array[1..10] of ansistring; - i : longint; - -begin - c1:='Hello '; - c2:=' world'; - a:=c1+c2; - finalize(a); - if length(a)<>0 then - halt(1); - for i:=1 to 10 do - aa[i]:=c1+c2; - finalize(aa[1],10); - for i:=1 to 10 do - if length(aa[i])<>0 then - halt(1); -end. - diff --git a/tests/test/testfpu.pp b/tests/test/testfpu.pp deleted file mode 100644 index 5818857d96..0000000000 --- a/tests/test/testfpu.pp +++ /dev/null @@ -1,125 +0,0 @@ -program test_fp_instructions; - - - function test : extended; - - var - x,y : integer; - statusword,controlword : word; - z,t : longint; - a,b,c : comp; - begin - x:=5; - c:=5; - t:=5; - z:=4; - a:=20; - { test all FPU instructions using 's' and 'l' suffix - for word and dword size PM } -{$asmmode att} - asm - fildl z - fiadds x - fistpq b - fildl z - ficoms x - fistpq b - fildl z - ficomps x - fildl z - fidivs x - fistpq b - fildl z - fidivrs x - fistpq b - fildl z - fisubs x - fistpq b - fildl z - fisubrs x - fistpq b - fildl z - fimuls x - fistpq b - end; - if a<>b then - begin - Writeln('Error in FPU att syntax code generation'); - Halt(1); - end; - asm - fildl z - fiaddl t - fistpq b - fildl z - ficoml t - fistpq b - fildl z - ficompl t - fildl z - fidivl t - fistpq b - fildl z - fidivrl t - fistpq b - fildl z - fisubl t - fistpq b - fildl z - fisubrl t - fistpq b - fildl z - fimull t - fistpq b - end; - if a<>b then - begin - Writeln('Error in FPU att syntax code generation'); - Halt(1); - end; - { test CW and SW instructions } - { FSTSW FNSTSW - FLDCW FSTCW FNSTCW } - asm - fstsw statusword - fstsww statusword - fnstsw statusword - fnstsww statusword - fstcw controlword - fstcww controlword - fnstcw controlword - fnstcww controlword - fldcw controlword - fldcww controlword - end; -{$asmmode intel} - asm - fild dword ptr z - fimul dword ptr t - fistp qword ptr b - fild dword ptr z - fimul word ptr x - fistp qword ptr b - end; - if a<>b then - begin - Writeln('Error in FPU code generation'); - Halt(1); - end; - { test CW and SW instructions } - asm - fstsw word ptr [statusword] - fnstsw word ptr [statusword] - fstcw word ptr [controlword] - fnstcw word ptr[controlword] - fldcw word ptr [controlword] - end; - test:=b; - end; - -var - z : extended; - -begin - z:=test; -end. \ No newline at end of file diff --git a/tests/test/testfpu2.pp b/tests/test/testfpu2.pp deleted file mode 100644 index 27b52c8951..0000000000 --- a/tests/test/testfpu2.pp +++ /dev/null @@ -1,29 +0,0 @@ -{$mode objfpc} -program test_fpu_excpetions; - -uses - sysutils; - - function mysqrt(x : real) : real; - - begin - try - mysqrt:=sqrt(x); - except - on e : exception do - mysqrt:=0; - end; - end; - - var - x, y,z : real; - -begin - x:=6.5; - y:=5.76; - z:=3.1; - Writeln('Testing mysqrt (x) = sqrt(x) if x >= 0'); - Writeln(' = 0 if x < 0'); - Writeln(' 6.5+5.76*mysqrt(3.1) = ',x+y*mysqrt(z):0:6); - Writeln(' 6.5+5.76*mysqrt(-3.1) = ',x+y*mysqrt(-z):0:6); -end. \ No newline at end of file diff --git a/tests/test/testgoto.pp b/tests/test/testgoto.pp deleted file mode 100644 index 735029b0a1..0000000000 --- a/tests/test/testgoto.pp +++ /dev/null @@ -1,27 +0,0 @@ -program testgoto; - -{$goto on} - -function test : longint; - -label l; - - -var - a,b : longint; - -begin - a:=1; - b:=1; - l: - if a>b then - begin - exit(0); - end; - a:=2; - goto l; -end; - -begin - test; -end. diff --git a/tests/test/testheap.pp b/tests/test/testheap.pp deleted file mode 100644 index f39452cae1..0000000000 --- a/tests/test/testheap.pp +++ /dev/null @@ -1,170 +0,0 @@ -{ - $Id$ - - Program to test heap functions, timing doesn't work -} -PROGRAM TestHeap; - -Procedure InitMSTimer; -begin -end; - - - -{Get MS Timer} -Function MSTimer:longint; -begin - MSTimer:=0; -end; - - -VAR Dummy,Start, LoopTime,LoopTime2: LONGINT; - Delta, TotalTime: LONGINT; - L,Choice,K,T: WORD; - BlkPtr: ARRAY [1..10000] OF POINTER; - BlkSize: ARRAY [1..10000] OF WORD; - Permutation: ARRAY [1..10000] OF WORD; - -BEGIN - INitMSTimer; - WriteLn ('Test of TP heap functions'); - WriteLn; - TotalTime := 0; - RandSeed := 997; - WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); - Start :=MSTimer; - FOR L := 1 TO 10000 DO BEGIN - END; - LoopTime := MSTimer-Start; - FOR L := 1 TO 10000 DO BEGIN - BlkSize [L] := Random (512) + 1; - END; - Write ('Allocating 10000 blocks at the end of the heap: '); - Start := MSTImer; - FOR L := 1 TO 10000 DO BEGIN - GetMem (BlkPtr [L], BlkSize [L]); - END; - Delta := MSTimer-Start-LoopTime; - Inc (TotalTime, Delta); - WriteLn (Delta:5, ' ms'); - WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); - Write ('Deallocating same 10000 blocks in reverse order:'); - Start := MSTimer; - FOR L := 1 TO 10000 DO BEGIN - FreeMem (BlkPtr [L], BlkSize [L]); - END; - Delta := MSTimer-Start-LoopTime; - Inc (TotalTime, Delta); - WriteLn (Delta:5, ' ms'); - WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); - Write ('Allocating 10000 blocks at the end of the heap: '); - Start := MSTimer; - FOR L := 1 TO 10000 DO BEGIN - GetMem (BlkPtr [L], BlkSize [L]); - END; - Delta := MSTimer-Start-LoopTime; - Inc (TotalTime, Delta); - WriteLn (Delta:5, ' ms'); - WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); - FOR L := 1 TO 10000 DO BEGIN - Permutation [L] := L; - END; - Start := MSTimer; - FOR L := 10000 DOWNTO 1 DO BEGIN - Choice := Random (L)+1; - K := Permutation [Choice]; - Permutation [Choice] := Permutation [L]; - END; - LoopTime2 := MSTimer - Start; - FOR L := 1 TO 10000 DO BEGIN - Permutation [L] := L; - END; - Write ('Deallocating same 10000 blocks at random: '); - Start := MSTimer; - FOR L := 10000 DOWNTO 1 DO BEGIN - Choice := Random (L)+1; - K := Permutation [Choice]; - Permutation [Choice] := Permutation [L]; - FreeMem (BlkPtr [K], BlkSize [K]); - END; - Delta := MSTimer - Start - LoopTime2; - Inc (TotalTime, Delta); - WriteLn (Delta:5, ' ms'); - WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); - Write ('Allocating 10000 blocks at the end of the heap: '); - Start := MSTimer; - FOR L := 1 TO 10000 DO BEGIN - GetMem (BlkPtr [L], BlkSize [L]); - END; - Delta := MSTimer-Start-LoopTime; - Inc (TotalTime, Delta); - WriteLn (Delta:5, ' ms'); - WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); - FOR L := 1 TO 10000 DO BEGIN - Permutation [L] := L; - END; - Start := MSTimer; - FOR L := 10000 DOWNTO 1 DO BEGIN - Choice := Random (L)+1; - K := Permutation [Choice]; - T:= Permutation [L]; - Permutation [L] := Permutation [Choice]; - Permutation [Choice] := T; - END; - LoopTime2 := MSTimer - Start; - FOR L := 1 TO 10000 DO BEGIN - Permutation [L] := L; - END; - Write ('Deallocating 5000 blocks at random: '); - Start := MSTimer; - FOR L := 10000 DOWNTO 5001 DO BEGIN - Choice := Random (L)+1; - K := Permutation [Choice]; - T:= Permutation [L]; - Permutation [L] := Permutation [Choice]; - Permutation [Choice] := T; - SYSTEM.FreeMem (BlkPtr [K], BlkSize [K]); - END; - Delta := MSTimer-Start-LoopTime2; - Inc (TotalTime, Delta); - WriteLn (Delta:5, ' ms'); - WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); - Start := MSTimer; - FOR L := 1 TO 10000 DO BEGIN - Dummy := MaxAvail; - END; - Delta := MSTimer-Start; - Inc (TotalTime, (Delta + 5) DIV 10); - WriteLn ('10000 calls to MaxAvail: ', Delta:5, ' ms'); - Start := MSTimer; - FOR L := 1 TO 10000 DO BEGIN - Dummy := MemAvail; - END; - Delta := MSTimer - Start; - Inc (TotalTime, (Delta + 5) DIV 10); - WriteLn ('10000 calls to MemAvail: ', Delta:5, ' ms'); - WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); - Write ('Reallocating deallocated 500 blocks at random: '); - Start := MSTimer; - FOR L := 5001 TO 10000 DO BEGIN - GetMem (BlkPtr [Permutation [L]], BlkSize [Permutation [L]]); - END; - Delta := MSTimer-Start-LoopTime; - Inc (TotalTime, Delta); - WriteLn (Delta:5, ' ms'); - WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); - Write ('Deallocating all 10000 blocks at random: '); - Start := MSTimer; - FOR L := 10000 DOWNTO 1 DO BEGIN - FreeMem (BlkPtr [L], BlkSize [L]); - END; - Delta := MSTimer-Start-LoopTime; - Inc (TotalTime, Delta); - WriteLn (Delta:5, ' ms'); - WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); - WriteLn; - WriteLn ('Total time for benchmark: ', TotalTime, ' ms'); -END. - - - diff --git a/tests/test/testi642.pp b/tests/test/testi642.pp deleted file mode 100644 index 8ce8a09337..0000000000 --- a/tests/test/testi642.pp +++ /dev/null @@ -1,1190 +0,0 @@ -{$Q-} { this is necessary to avoid an overflow error below } -{$mode objfpc} -uses - sysutils -{$ifdef go32v2} - ,dpmiexcp -{$endif go32v2} - ; - -type - tqwordrec = packed record - low,high : dword; - end; - -procedure dumpqword(q : qword); - - begin - write('$',hexstr(tqwordrec(q).high,8),' ',hexstr(tqwordrec(q).low,8)); - end; - -procedure dumpqwordln(q : qword); - - begin - dumpqword(q); - writeln; - end; - -procedure assignqword(h,l : dword;var q : qword); - - begin - tqwordrec(q).high:=h; - tqwordrec(q).low:=l; - end; - -procedure do_error(l : longint); - - begin - writeln('Error near number ',l); - halt(1); - end; - -procedure do_error; - - begin - do_error(0); - end; - -procedure simpletestcmpqword; - - var - q1,q2,q3,q4 : qword; - - begin - assignqword(0,5,q1); - assignqword(6,0,q2); - assignqword(6,1,q3); - assignqword(6,5,q4); - { first test the code generation of the operators } - if q1<>q1 then - do_error(0); - if q2<>q2 then - do_error(0); - if q3<>q3 then - do_error(0); - if not(q1=q1) then - do_error(0); - if not(q2=q2) then - do_error(0); - if not(q3=q3) then - do_error(0); - writeln(' <>,= succesfully tested'); - - if q1>q2 then - do_error(1100); - if q2>q3 then - do_error(1101); - if q2 succesfully tested'); - - if q1>=q2 then - do_error(1104); - if q2>=q3 then - do_error(1105); - if q2<=q1 then - do_error(1106); - if q3<=q2 then - do_error(1107); - writeln(' >=,<= succesfully tested'); - - if q1=q2 then - do_error(1108); - if q2=q3 then - do_error(1109); - if q3=q1 then - do_error(1111); - - if q1=q4 then - do_error(1112); - if q2=q4 then - do_error(1113); - if q3=q4 then - do_error(1114); - writeln(' More comparisations successful tested'); - end; - -procedure testaddqword; - - var - q1,q2,q3,q4,q5,q6 : qword; - - begin - { without overflow between 32 bit } - assignqword(0,5,q1); - assignqword(0,6,q2); - assignqword(0,1,q3); - assignqword(0,11,q4); - assignqword(0,1,q5); - if q1+q2<>q4 then - do_error(1200); - if q1+q3+q1<>q4 then - do_error(1201); - if q1+(q3+q1)<>q4 then - do_error(1202); - if (q1+q3)+q1<>q4 then - do_error(1203); - { a more complex expression } - if ((((q5+q3)+(q3+q5))+((q5+q3)+(q3+q5)))+q5+q3+q5)<>q4 then - do_error(1204); - { with overflow between 32 bit } - assignqword(0,$ffffffff,q1); - assignqword(1,3,q2); - assignqword(0,4,q3); - assignqword(1,4,q4); - assignqword(0,1,q5); - assignqword(1,$fffffffe,q6); - if q1+q3<>q2 then - do_error(1205); - if q3+q1<>q2 then - do_error(1206); - if q1+(q3+q5)<>q4 then - do_error(1207); - if (q1+q3)+q5<>q4 then - do_error(1208); - if (q1+q1)<>q6 then - do_error(1209); - end; - -procedure testcmpqword; - - var - q1,q2,q3,q4,q5,q6 : qword; - - begin - assignqword(0,$ffffffff,q1); - assignqword(0,$ffffffff,q2); - assignqword(1,$fffffffe,q3); - assignqword(0,2,q4); - assignqword(1,$fffffffc,q5); - if (q1+q2)<>q3 then - do_error(1300); - if not(q3=(q1+q2)) then - do_error(1301); - if (q1+q2)>q3 then - do_error(1302); - if (q1+q2)=(q1+q2)) then - do_error(1305); - - if (q1+q2)<>(q4+q5) then - do_error(1306); - if not((q4+q5)=(q1+q2)) then - do_error(1307); - if (q1+q2)>(q4+q5) then - do_error(1308); - if (q1+q2)<(q4+q5) then - do_error(1309); - if not((q4+q5)<=(q1+q2)) then - do_error(1310); - if not((q4+q5)>=(q1+q2)) then - do_error(1311); - end; - -procedure testlogqword; - - var - q0,q1,q2,q3,q4,q5,q6 : qword; - - begin - assignqword(0,0,q0); - assignqword($ffffffff,$ffffffff,q1); - assignqword(0,$ffffffff,q2); - assignqword($ffffffff,0,q3); - assignqword($a0a0a0a0,$50505050,q4); - assignqword(0,$50505050,q5); - assignqword($a0a0a0a0,0,q6); - - { here we don't need to test all cases of locations, } - { this is already done by the addtion test } - if (q2 or q3)<>q1 then - do_error(1400); - if (q5 or q6)<>q4 then - do_error(1401); - - if (q2 and q3)<>q0 then - do_error(1402); - if (q5 and q6)<>q0 then - do_error(1403); - - if (q2 xor q3)<>q1 then - do_error(1404); - if (q5 xor q6)<>q4 then - do_error(1405); - { the test before could be also passed by the or operator! } - if (q4 xor q4)<>q0 then - do_error(1406); - end; - -procedure testshlshrqword; - - var - q0,q1,q2,q3,q4,q5 : qword; - l1,l2 : longint; - - begin - assignqword(0,0,q0); - assignqword($ffff,$ffff0000,q1); - assignqword(0,$ffffffff,q2); - assignqword($ffffffff,0,q3); - assignqword(0,1,q4); - assignqword($80000000,0,q5); - - l1:=16; - l2:=0; - if (q1 shl 16)<>q3 then - do_error(1500); - if (q1 shl 48)<>q0 then - do_error(1501); - if (q1 shl 47)<>q5 then - do_error(1501); - if ((q1+q0) shl 16)<>q3 then - do_error(1502); - if ((q1+q0) shl 48)<>q0 then - do_error(1503); - if ((q1+q0) shl 47)<>q5 then - do_error(15031); - - if (q1 shl l1)<>q3 then - do_error(1504); - if (q1 shl (3*l1))<>q0 then - do_error(1505); - if ((q1+q0) shl l1)<>q3 then - do_error(1506); - if ((q1+q0) shl (3*l1))<>q0 then - do_error(1507); - if ((q1+q0) shl (3*l1-1))<>q5 then - do_error(15071); - - if (q1 shl (l1+l2))<>q3 then - do_error(1508); - if ((q1+q0) shl (l1+l2))<>q3 then - do_error(1509); - - if (q1 shr 16)<>q2 then - do_error(1510); - if (q1 shr 48)<>q0 then - do_error(1511); - if (q1 shr 47)<>q4 then - do_error(15111); - - if ((q1+q0) shr 16)<>q2 then - do_error(1512); - if ((q1+q0) shr 48)<>q0 then - do_error(1513); - if (q1 shr l1)<>q2 then - do_error(1514); - if (q1 shr (3*l1))<>q0 then - do_error(1515); - if (q1 shr (3*l1-1))<>q4 then - do_error(15151); - - if ((q1+q0) shr l1)<>q2 then - do_error(1516); - if ((q1+q0) shr (3*l1))<>q0 then - do_error(1517); - if ((q1+q0) shr (3*l1-1))<>q4 then - do_error(15171); - - if (q1 shr (l1+l2))<>q2 then - do_error(1518); - if ((q1+q0) shr (l1+l2))<>q2 then - do_error(1519); - end; - -procedure testsubqword; - - var - q0,q1,q2,q3,q4,q5,q6 : qword; - - begin - { without overflow between 32 bit } - assignqword(0,0,q0); - assignqword(0,6,q1); - assignqword(0,5,q2); - assignqword(0,1,q3); - assignqword(0,11,q4); - assignqword(0,1,q5); - if q1-q2<>q3 then - do_error(1600); - if q1-q0-q1<>q0 then - do_error(1601); - if q1-(q0-q1)<>q1+q1 then - do_error(1602); - if (q1-q0)-q1<>q0 then - do_error(1603); - - { a more complex expression } - if ((((q5-q3)-(q3-q5))-((q5-q3)-(q3-q5))))<>q0 then - do_error(1604); - - { with overflow between 32 bit } - assignqword(1,0,q1); - assignqword(0,$ffffffff,q2); - assignqword(0,1,q3); - assignqword(1,$ffffffff,q4); - - if q1-q2<>q3 then - do_error(1605); - if q1-q0-q2<>q3 then - do_error(1606); - if q1-(q0-q2)<>q4 then - do_error(1607); - if (q1-q0)-q1<>q0 then - do_error(1608); - - assignqword(1,$ffffffff,q5); - assignqword(1,$ffffffff,q4); - - { a more complex expression } - if ((((q5-q3)-(q3-q5))-((q5-q3)-(q3-q5))))<>q0 then - do_error(1609); - end; - -procedure testnotqword; - - var - q0,q1,q2,q3,q4 : qword; - - begin - assignqword($f0f0f0f0,$f0f0f0f0,q1); - assignqword($f0f0f0f,$f0f0f0f,q2); - assignqword($f0f0f0f0,0,q3); - assignqword(0,$f0f0f0f0,q4); - if not(q1)<>q2 then - do_error(1700); - if not(q3 or q4)<>q2 then - do_error(1701); - - { do a more complex expression to stress the register saving } - if not(q3 or q4)<>not(q3 or q4) then - do_error(1702); - end; - -procedure testnegqword; - - var - q0,q1,q2,q3,q4 : qword; - - begin - assignqword($1,$0,q1); - assignqword($0,1234,q2); - if -q1<>(0-q1) then - do_error(2700); - if -q2<>(0-q2) then - do_error(2701); - if -(q1+q2)<>(0-(q1+q2)) then - do_error(2702); - end; - -procedure testmulqword; - - var - q0,q1,q2,q3,q4,q5,q6 : qword; - i : longint; - - begin - assignqword(0,0,q0); - assignqword(0,1,q1); - assignqword(0,4,q2); - assignqword(2,0,q3); - assignqword(8,0,q4); - assignqword(0,1,q5); - assignqword($ffff,$12344321,q6); - { to some trivial tests } - { to test the code generation } - if q1*q2<>q2 then - do_error(1800); - if q1*q2*q3<>q4 then - do_error(1801); - if q1*(q2*q3)<>q4 then - do_error(1802); - if (q1*q2)*q3<>q4 then - do_error(1803); - if (q6*q5)*(q1*q2)<>q1*q2*q5*q6 then - do_error(1804); - - { a more complex expression } - if ((((q1*q5)*(q1*q5))*((q5*q1)*(q1*q5)))*q5*q1*q5)<>q1 then - do_error(1805); - - { now test the multiplication procedure with random bit patterns } - writeln('Doing some random multiplications, takes a few seconds'); - writeln('.....................................100%'); - for i:=1 to 1000000 do - begin - tqwordrec(q1).high:=0; - tqwordrec(q1).low:=random($7ffffffe); - tqwordrec(q2).high:=0; - tqwordrec(q2).low:=random($7ffffffe); - if q1*q2<>q2*q1 then - begin - write('Multiplication of '); - dumpqword(q1); - write(' and '); - dumpqword(q2); - writeln(' failed'); - do_error(1806); - end; - if i mod 50000=0 then - write('.'); - end; - for i:=1 to 1000000 do - begin - tqwordrec(q1).high:=0; - tqwordrec(q1).low:=random($7ffffffe); - q1:=q1 shl 16; - tqwordrec(q2).high:=0; - tqwordrec(q2).low:=random($fffe); - if q1*q2<>q2*q1 then - begin - write('Multiplication of '); - dumpqword(q1); - write(' and '); - dumpqword(q2); - writeln(' failed'); - do_error(1806); - end; - if i mod 50000=0 then - write('.'); - end; - writeln(' OK'); - end; - -procedure testdivqword; - - var - q0,q1,q2,q3,q4,q5,q6 : qword; - i : longint; - - begin - assignqword(0,0,q0); - assignqword(0,1,q1); - assignqword(0,4,q2); - assignqword(2,0,q3); - assignqword(8,0,q4); - assignqword(0,1,q5); - assignqword($ffff,$12344321,q6); - { to some trivial tests } - { to test the code generation } - if q2 div q1<>q2 then - do_error(1900); - if q2 div q1 div q1<>q2 then - do_error(1901); - if q2 div (q4 div q3)<>q1 then - do_error(1902); - if (q4 div q3) div q2<>q1 then - do_error(1903); - - { a more complex expression } - if (q4 div q3) div (q2 div q1)<>(q2 div q1) div (q4 div q3) then - do_error(1904); - - { now test the division procedure with random bit patterns } - writeln('Doing some random divisions, takes a few seconds'); - writeln('.................100%'); - for i:=1 to 100000 do - begin - tqwordrec(q1).high:=random($7ffffffe); - tqwordrec(q1).low:=random($7ffffffe); - tqwordrec(q2).high:=random($7ffffffe); - tqwordrec(q2).low:=random($7ffffffe); - { avoid division by zero } - if (tqwordrec(q2).low or tqwordrec(q2).high)=0 then - tqwordrec(q2).low:=1; - q3:=q1 div q2; - { get a restless division } - q1:=q2*q3; - q3:=q1 div q2; - if q3*q2<>q1 then - begin - write('Division of '); - dumpqword(q1); - write(' by '); - dumpqword(q2); - writeln(' failed'); - do_error(1906); - end; - if i mod 10000=0 then - write('.'); - end; - for i:=1 to 100000 do - begin - tqwordrec(q1).high:=0; - tqwordrec(q1).low:=random($7ffffffe); - tqwordrec(q2).high:=0; - tqwordrec(q2).low:=random($7ffffffe); - { avoid division by zero } - if tqwordrec(q2).low=0 then - tqwordrec(q2).low:=1; - { get a restless division } - q3:=q1*q2; - q3:=q3 div q2; - if q3<>q1 then - begin - write('Division of '); - dumpqword(q1); - write(' by '); - dumpqword(q2); - writeln(' failed'); - do_error(1907); - end; - if i mod 10000=0 then - write('.'); - end; - writeln(' OK'); - end; - -function testf : qword; - - var - q : qword; - - begin - assignqword($ffffffff,$a0a0a0a0,q); - testf:=q; - end; - -procedure testfuncqword; - - var - q : qword; - - begin - assignqword($ffffffff,$a0a0a0a0,q); - if testf<>q then - do_error(1900); - if q<>testf then - do_error(1901); - end; - -procedure testtypecastqword; - - var - s1,s2 : shortint; - b1,b2 : byte; - w1,w2 : word; - i1,i2 : integer; - l1,l2 : longint; - d1,d2 : dword; - q1,q2 : qword; - r1,r2 : double; - - begin - { shortint } - s1:=75; - s2:=0; - q1:=s1; - { mix up the processor a little bit } - q2:=q1; - if q2<>75 then - begin - dumpqword(q2); - do_error(2006); - end; - s2:=q2; - if s1<>s2 then - do_error(2000); - - { byte } - b1:=$ca; - b2:=0; - q1:=b1; - { mix up the processor a little bit } - q2:=q1; - if q2<>$ca then - do_error(2007); - b2:=q2; - if b1<>b2 then - do_error(2001); - - { integer } - i1:=12345; - i2:=0; - q1:=i1; - { mix up the processor a little bit } - q2:=q1; - if q2<>12345 then - do_error(2008); - i2:=q2; - if i1<>i2 then - do_error(2002); - - { word } - w1:=$a0ff; - w2:=0; - q1:=w1; - { mix up the processor a little bit } - q2:=q1; - if q2<>$a0ff then - do_error(2009); - w2:=q2; - if w1<>w2 then - do_error(2003); - - { longint } - l1:=12341234; - l2:=0; - q1:=l1; - { mix up the processor a little bit } - q2:=q1; - if q2<>12341234 then - do_error(2010); - l2:=q2; - if l1<>l2 then - do_error(2004); - - { dword } - d1:=$5bcdef01; - b2:=0; - q1:=d1; - { mix up the processor a little bit } - q2:=q1; - if q2<>$5bcdef01 then - do_error(2011); - d2:=q2; - if d1<>d2 then - do_error(2005); - - { real } - { memory location } - q1:=12; - d1:=q1; - d2:=12; - if d1<>d2 then - do_error(2012); - - { register location } - q1:=12; - d1:=q1+1; - d2:=13; - if d1<>d2 then - do_error(2013); - - // a constant which can't be loaded with fild - q1:=$80000000; - q1:=q1 shl 32; - d1:=q1; - d2:=$80000000; - if d1<>d2*d2*2.0 then - do_error(20); - // register location - d1:=q1+1; - if d1<>d2*d2*2.0+1 then - do_error(2014); - end; - -procedure testioqword; - - var - t : text; - q1,q2 : qword; - i : longint; - - begin - assignqword($ffffffff,$a0a0a0a0,q1); - assign(t,'testi642.tmp'); - rewrite(t); - writeln(t,q1); - close(t); - reset(t); - readln(t,q2); - close(t); - if q1<>q2 then - do_error(2100); - { do some random tests } - for i:=1 to 100 do - begin - tqwordrec(q1).high:=random($7ffffffe); - tqwordrec(q1).low:=random($7ffffffe); - rewrite(t); - writeln(t,q1); - close(t); - reset(t); - readln(t,q2); - close(t); - if q1<>q2 then - begin - write('I/O of ');dumpqword(q1);writeln(' failed'); - do_error(2101); - end; - end; - end; - -procedure teststringqword; - - var - q1,q2 : qword; - s : string; - l : longint; - a : ansistring; - - begin - { testing str: shortstring } - // simple tests - q1:=1; - str(q1,s); - if s<>'1' then - do_error(2200); - // simple tests - q1:=0; - str(q1,s); - if s<>'0' then - do_error(2201); - - // more complex tests - q1:=4321; - str(q1,s); - if s<>'4321' then - do_error(2202); - str(q1:6,s); - if s<>' 4321' then - do_error(2203); - - // create a big qword: - q2:=1234; - l:=1000000000; - q2:=q2*l; - l:=54321; - q2:=q2+l; - str(q2,s); - if s<>'1234000054321' then - do_error(2204); - - { testing str: ansistring } - // more complex tests - q1:=4321; - str(q1,a); - if a<>'4321' then - do_error(2205); - str(q1:6,a); - if a<>' 4321' then - do_error(2206); - - // create a big qword: - q2:=1234; - l:=1000000000; - q2:=q2*l; - l:=54321; - q2:=q2+l; - str(q2,a); - if a<>'1234000054321' then - do_error(2207); - - { testing val } - { !!!!!!! } - end; - -procedure testmodqword; - - var - q0,q1,q2,q3,q4,q5,q6 : qword; - i : longint; - - begin - assignqword(0,0,q0); - assignqword(0,3,q1); - assignqword(0,5,q2); - assignqword(0,2,q3); - assignqword(0,4,q4); - assignqword(0,1,q5); - assignqword($ffff,$12344321,q6); - { to some trivial tests } - { to test the code generation } - if q2 mod q1<>q3 then - do_error(2300); - if q2 mod q1 mod q3<>q0 then - do_error(2301); - if q2 mod (q1 mod q3)<>q0 then - do_error(2302); - if (q1 mod q3) mod q2<>q5 then - do_error(2303); - if q1 mod q2<>q1 then - do_error(2308); - - { a more complex expression } - if (q2 mod q4) mod (q1 mod q3)<>(q1 mod q3) mod (q2 mod q4) then - do_error(2304); - - { now test the modulo division procedure with random bit patterns } - writeln('Doing some random module divisions, takes a few seconds'); - writeln('.................100%'); - for i:=1 to 100000 do - begin - tqwordrec(q1).high:=random($7ffffffe); - tqwordrec(q1).low:=random($7ffffffe); - tqwordrec(q2).high:=random($7ffffffe); - tqwordrec(q2).low:=random($7ffffffe); - { avoid division by zero } - if (tqwordrec(q2).low or tqwordrec(q2).high)=0 then - tqwordrec(q2).low:=1; - q3:=q1 mod q2; - if (q1-q3) mod q2<>q0 then - begin - write('Modulo division of '); - dumpqword(q1); - write(' by '); - dumpqword(q2); - writeln(' failed'); - do_error(2306); - end; - if i mod 10000=0 then - write('.'); - end; - for i:=1 to 100000 do - begin - tqwordrec(q1).high:=random($7ffffffe); - tqwordrec(q1).low:=random($7ffffffe); - tqwordrec(q2).high:=0; - tqwordrec(q2).low:=random($7ffffffe); - { avoid division by zero } - if tqwordrec(q2).low=0 then - tqwordrec(q2).low:=1; - { get a restless division } - q3:=q1 mod q2; - if (q1-q3) mod q2<>q0 then - begin - write('Modulo division of '); - dumpqword(q1); - write(' by '); - dumpqword(q2); - writeln(' failed'); - do_error(2307); - end; - if i mod 10000=0 then - write('.'); - end; - writeln(' OK'); - end; - -const - constqword : qword = 131975; - -procedure testconstassignqword; - - var - q1,q2,q3 : qword; - - begin - // constant assignments - assignqword(0,5,q2); - q1:=5; - if q1<>q2 then - do_error(2400); - - // constants in expressions - q1:=1234; - if q1<>1234 then - do_error(2401); - - // typed constants - assignqword(0,131975,q1); - q2:=131975; - if q1<>q2 then - do_error(2402); - - //!!!!! large constants are still missed - end; - -{$Q+} -procedure testreqword; - - var - q0,q1,q2,q3 : qword; - - begin - q0:=0; - assignqword($ffffffff,$ffffffff,q1); - q2:=1; - - // addition - try - // expect an exception - q3:=q1+q2; - do_error(2500); - except - on eintoverflow do - ; - else - do_error(2501); - end; - // subtraction - try - q3:=q0-q2; - do_error(2502); - except - on eintoverflow do - ; - else - do_error(2503); - end; - - // multiplication - q2:=2; - try - q3:=q2*q1; - do_error(2504); - except - on eintoverflow do - ; - else - do_error(2505); - end; - - // division - try - q3:=q1 div q0; - do_error(2506); - except - on edivbyzero do - ; - else - do_error(2507); - end; - - // modulo division - try - q3:=q1 mod q0; - do_error(2508); - except - on edivbyzero do - ; - else - do_error(2509); - end; -{$Q-} - - // now we do the same operations but without overflow - // checking -> we should get no exceptions - q2:=1; - - // addition - try - q3:=q1+q2; - except - do_error(2510); - end; - // subtraction - try - q3:=q0-q2; - except - do_error(2511); - end; - - // multiplication - q2:=2; - try - q3:=q2*q1; - except - do_error(2512); - end; - - end; - -procedure testintqword; - - var - q1,q2,q3 : qword; - - begin - // lo/hi - assignqword($fafafafa,$03030303,q1); - if lo(q1)<>$03030303 then - do_error(2600); - if hi(q1)<>$fafafafa then - do_error(2601); - if lo(q1+1)<>$03030304 then - do_error(2602); - if hi(q1+$f0000000)<>$fafafafa then - do_error(2603); - - // swap - assignqword($03030303,$fafafafa,q2); - if swap(q1)<>q2 then - do_error(2604); - - // succ/pred - assignqword(0,$1,q1); - q3:=q1; - q1:=succ(q1); - q1:=succ(q1+1); - q2:=pred(q1-1); - q2:=pred(q2); - if q3<>q2 then - do_error(2605); - assignqword(0,$ffffffff,q1); - q3:=q1; - q1:=succ(q1); - q1:=succ(q1+1); - q2:=pred(q1-1); - q2:=pred(q2); - if q3<>q2 then - do_error(2606); - end; - -procedure testcritical; - - var - a : array[0..10,0..10,0..10] of qword; - i,j,k : longint; - d1,d2 : extended; - q1,q2 : qword; - i1,i2 : int64; - - begin - i:=1; - j:=3; - k:=5; - { check if it is handled correct if a register is used } - { in a reference as well as temp. reg } - a[i,j,k]:=1234; - a[i,j,k]:=a[i,j,k]+a[i,j,k]; - if a[i,j,k]<>2468 then - do_error(2700); - if not(not(a[i,j,k]))<>a[i,j,k] then - do_error(2701); - if -(-(a[i,j,k]))<>a[i,j,k] then - do_error(2702); - if (a[i,j,k] shl (i-i))<>a[i,j,k] then - do_error(2703); - q1:=10; - q2:=100; - i1:=1000; - i2:=10000; - d1:=q1/q2; - d2:=i1/i2; - if (d1<>d2) then - do_error(2704); - end; - -var - q : qword; - -begin - randomize; - writeln('------------------------------------------------------'); - writeln(' QWord test '); - writeln('------------------------------------------------------'); - writeln; - - writeln('Testing assignqword and dumpqword ... '); - assignqword($12345678,$9ABCDEF0,q); - dumpqword(q); - writeln; - writeln('The output should be:'); - writeln('$12345678 9ABCDEF0'); - writeln; - - writeln('Testing simple QWord comparisations'); - simpletestcmpqword; - writeln('Testing simple QWord comparisations was successful'); - writeln; - - writeln('Testing QWord additions'); - testaddqword; - writeln('Testing QWord additions was successful'); - writeln; - - writeln('Testing more QWord comparisations'); - testcmpqword; - writeln('Testing more QWord comparisations was successful'); - writeln; - - writeln('Testing QWord subtraction'); - testsubqword; - writeln('Testing QWord subtraction was successful'); - writeln; - - writeln('Testing QWord constants'); - testconstassignqword; - writeln('Testing QWord constants was successful'); - writeln; - - writeln('Testing QWord logical operators (or,xor,and)'); - testlogqword; - writeln('Testing QWord logical operators (or,xor,and) was successful'); - writeln; - - writeln('Testing QWord logical not operator'); - testnotqword; - writeln('Testing QWord logical not operator was successful'); - writeln; - - writeln('Testing QWord logical - operator'); - testnegqword; - writeln('Testing QWord logical - operator was successful'); - writeln; - - writeln('Testing QWord logical shift operators (shr,shr)'); - testshlshrqword; - writeln('Testing QWord logical shift operators (shr,shr) was successful'); - writeln; - - writeln('Testing QWord function results'); - testfuncqword; - writeln('Testing QWord function results was successful'); - writeln; - - writeln('Testing QWord type casts'); - testtypecastqword; - writeln('Testing QWord type casts was successful'); - writeln; - - writeln('Testing QWord internal procedures'); - testintqword; - writeln('Testing QWord internal procedures was successful'); - writeln; - - writeln('Testing QWord multiplications'); - testmulqword; - writeln('Testing QWord multiplications was successful'); - writeln; - - writeln('Testing QWord division'); - testdivqword; - writeln('Testing QWord division was successful'); - writeln; - - writeln('Testing QWord modulo division'); - testmodqword; - writeln('Testing QWord modulo division was successful'); - writeln; - - writeln('Testing QWord runtime errors'); - testreqword; - writeln('Testing QWord runtime errors was successful'); - writeln; - - writeln('Testing QWord string conversion'); - teststringqword; - writeln('Testing QWord string conversion was successful'); - writeln; - - writeln('Testing QWord input/output'); - testioqword; - writeln('Testing QWord input/output was successful'); - writeln; - - writeln('Some extra tests for critical things'); - testcritical; - writeln('Extra tests for critical things were successful'); - - writeln('------------------------------------------------------'); - writeln(' QWord test successful'); - writeln('------------------------------------------------------'); - writeln; - writeln('------------------------------------------------------'); - writeln(' Int64 test '); - writeln('------------------------------------------------------'); - writeln; - - writeln('------------------------------------------------------'); - writeln(' Int64 test successful'); - writeln('------------------------------------------------------'); - halt(0); -end. \ No newline at end of file diff --git a/tests/test/testin64.pp b/tests/test/testin64.pp deleted file mode 100644 index 05a9e1a340..0000000000 --- a/tests/test/testin64.pp +++ /dev/null @@ -1,96 +0,0 @@ -const - q2 : qword = 1234; - i2 : int64 = -1234; - -var - q : qword; - i : int64; - l1,l2 : longint; - s : string; - -procedure p1(q : qword;i : int64); - - begin - end; - -function f1 : qword; - - begin - end; - -function f2 : int64; - - begin - end; - -var - q1,q3,q4 : qword; - -begin - q1:=1; - q3:=1; - q4:=1; - if not((q4 div q3) div (q2 div q1)<>(q2 div q1) div (q4 div q3)) then - writeln('Error :('); - q:=q-q; - q:=q-(q*q); - q:=(q*q)-(q*q); - { first test the comparisation } - if q<>q then - begin - writeln('Error :('); - end; - - if q>q then - begin - writeln('Error :('); - end; - - if i>f2 then - begin - writeln('Error :('); - end; - if l1>l2 then - begin - writeln('Error :('); - end; - p1(q,i); - q:=f1; - i:=f2; - q:=q+q; - i:=((i+i) xor (i+i)) or ((i+i) xor (i+i)); - q:=q shl l1; - q:=q shr l1; - q:=(q shl l1)+(q shl l1); - - q:=not(q); - i:=not(i); - q:=not(q xor q); - i:=not(i or i); - - { unary minus } - q:=-q; - i:=-i; - q:=-(q xor q); - i:=-(i or i); - - { multiplication } - // q:=3; - q:=q*q; - - i:=i*i; - - q:=q*(q*q); - i:=i*(i*i); - - q:=(q*q)*(q*q); - q:=((q*q)*(q*q))*((q*q)*(q*q)); - - writeln(q); - writeln(i); -{ test can't be interactive (PFV) - read(q); - read(i); } - str(q,s); - str(i,s); -end. diff --git a/tests/test/testinh.pp b/tests/test/testinh.pp deleted file mode 100644 index e3def7183b..0000000000 --- a/tests/test/testinh.pp +++ /dev/null @@ -1,30 +0,0 @@ -{$ifdef fpc} - {$mode delphi} -{$endif} -type - TMyComponent = class - public - constructor Create(k1:longint;k2: shortstring); - destructor Destroy;override; - end; - - TMyComponent1 = class(TMyComponent) - public - constructor Create(l1:longint;l2:shortstring); - end; - -constructor TMyComponent.Create(k1:longint;k2:shortstring); -begin -end; - -destructor TMyComponent.Destroy; -begin -end; - -constructor TMyComponent1.Create(l1:longint;l2:shortstring); -begin - inherited; -end; - -begin -end. diff --git a/tests/test/testinl.pp b/tests/test/testinl.pp deleted file mode 100644 index e3efc808a2..0000000000 --- a/tests/test/testinl.pp +++ /dev/null @@ -1,23 +0,0 @@ -{$inline on} -procedure test(var a : longint;b : longint);inline; - -begin - a:=32-b; -end; - -procedure test2(var a : longint;b : longint); - -begin - a:=32-b; -end; - - var - a,b : longint; -begin - test2(a,16); - Writeln('a=',a,' should be 16'); - if (a<>16) then halt(1); - test(a,16); - Writeln('a=',a,' should be 16'); - if (a<>16) then halt(1); -end. \ No newline at end of file diff --git a/tests/test/testintr.pp b/tests/test/testintr.pp deleted file mode 100644 index 7d7d017c2a..0000000000 --- a/tests/test/testintr.pp +++ /dev/null @@ -1,40 +0,0 @@ -program test_interrupt; - - - -procedure test1;interrupt; -begin - Writeln('Test1 interrupt'); -end; - -procedure test2(var a,b : longint);interrupt; -begin - Writeln('Test2 interrupt'); - a:=1; - b:=2; -end; - -function test3 : longint; interrupt; -begin - Writeln('test3 called'); - test3:=55; -end; - - var - x,y : longint; - -begin - x:=-1; - test1; - test2(x,y); - if (x<>1) or (y<>2) then - begin - Writeln('Error with interrupt'); - Halt(1); - end; - if test3<>55 then - begin - Writeln('Error with interrupt function'); - Halt(1); - end; -end. \ No newline at end of file diff --git a/tests/test/testitf1.pp b/tests/test/testitf1.pp deleted file mode 100644 index 3d54b8fb2d..0000000000 --- a/tests/test/testitf1.pp +++ /dev/null @@ -1,31 +0,0 @@ -{$mode objfpc} -type - IInterface = interface(IUnknown) - procedure mydo; - end; - - TMyClass = class(TInterfacedObject, IInterface) - procedure mydo;virtual; - end; - -var - l : longint; - -procedure tmyclass.mydo; - - begin - l:=1; - end; - -var - c: TMyClass; - i: IInterface; - -begin - c := TMyClass.Create; - i := c; - l:=0; - i.mydo; - if l<>1 then - halt(1); -end. diff --git a/tests/test/testitf4.pp b/tests/test/testitf4.pp deleted file mode 100644 index bfe3bb3236..0000000000 --- a/tests/test/testitf4.pp +++ /dev/null @@ -1,47 +0,0 @@ -{ $version >= 1.1} -{$mode objfpc} -type - ITest = interface(IUnknown) - procedure DoSomething; - end; - - - TMyClass = class(TInterfacedObject, ITest) - procedure DoSomething; - end; - -var - i : longint; - -procedure TMyClass.DoSomething; -begin - inc(i); -end; - - -procedure DoTest(const ATest: ITest); -begin - ATest.DoSomething; -end; - - -procedure DoTest2(ATest: ITest); -begin - ATest.DoSomething; -end; - - -var - c: TMyClass; -begin - i:=0; - c := TMyClass.Create; - DoTest(c); - DoTest2(c); - c.Free; - if i<>2 then - begin - writeln('Problem with passing interfaces as parameters'); - halt(1); - end; -end. diff --git a/tests/test/testitf5.pp b/tests/test/testitf5.pp deleted file mode 100644 index b89ef6958e..0000000000 --- a/tests/test/testitf5.pp +++ /dev/null @@ -1,11 +0,0 @@ -{ $version >= 1.1} -{$mode objfpc} -type - IMyInterface = interface - function f : longint; - procedure p(a : longint); - property x : longint read f write p; - end; - -begin -end. diff --git a/tests/test/testlib.pp b/tests/test/testlib.pp deleted file mode 100644 index 2048ae6214..0000000000 --- a/tests/test/testlib.pp +++ /dev/null @@ -1,35 +0,0 @@ -{$ifdef win32} - {$define supported} - {$define supportidx} -{$endif win32} -{$ifdef linux} - {$define supported} -{$endif linux} - -{$ifdef supported} - -library bug; - -const - publicname='TestName'; - publicindex = 1234; - -procedure Test;export; - - begin - end; - -exports - Test name publicname; -{$ifdef supportidx} -exports - Test index publicindex; -{$endif} - -begin -end. -{$else supported} -begin - Writeln('No library for that target'); -end. -{$endif supported} diff --git a/tests/test/testmmx.pp b/tests/test/testmmx.pp deleted file mode 100644 index 6ac2051fe0..0000000000 --- a/tests/test/testmmx.pp +++ /dev/null @@ -1,84 +0,0 @@ -{ this contains currently only a basic test of mmx support } -{ the following instructions are tested: - PSUBW - PSUBUSW - PADDW - PADDUSW -} -uses - mmx; - -procedure do_error(l : longint); - - begin - writeln('Error near number ',l); - halt(1); - end; - -function equal(const v1,v2 : tmmxword) : boolean; - - var - i : integer; - - begin - equal:=false; - for i:=0 to 3 do - if v1[i]<>v2[i] then - exit; - equal:=true; - end; - -procedure testmmxword; - - var t1,t5 : tmmxword; - - const - c0 : tmmxword = (0,0,0,0); - c1 : tmmxword = (1,1,1,1); - c2 : tmmxword = (1234,4321,1111,33333); - c3 : tmmxword = (1234,4321,2222,11111); - c4 : tmmxword = (2468,8642,3333,44444); - c5 : tmmxword = ($ffff,$ffff,$ffff,$ffff); - - begin - {$mmx+} - { Intel: paddw } - t1:=c2+c3; - if not(equal(t1,c4)) then - do_error(1000); - - { Intel: psubw } - t5:=t1-c2; - if not(equal(t5,c3)) then - do_error(1001); - t1:=not(c0); - - { does a not } - if not(equal(t1,c5)) then - do_error(1002); - - { test the saturation } - {$saturation+} - t1:=c5+c2+c3; - if not(equal(t1,c5)) then - do_error(1003); - - t1:=c4-c5-t1; - if not(equal(t1,c0)) then - do_error(1004); - {$saturation-} - end; - -begin - if not(is_mmx_cpu) then - begin - writeln('!!!! Warning: You need a mmx capable CPU to run this test !!!!'); - halt(0); - end; - writeln('Testing basic tmmxword support'); - testmmxword; - writeln('Test succesful'); - writeln; -end. - - diff --git a/tests/test/testobj.pp b/tests/test/testobj.pp deleted file mode 100644 index 2ff9946e9c..0000000000 --- a/tests/test/testobj.pp +++ /dev/null @@ -1,103 +0,0 @@ - - -TYPE - - psimpleobject = ^tsimpleobject; - tsimpleobject = object - x: longint; - z: array[0..34] of byte; - Procedure Init(somez: longint); - Procedure Hello; - end; - - pbase = ^tbase; - tbase = object - numofentries : longint; - constructor init(i : integer); - destructor done; virtual; - procedure showit; virtual; - end; - - pderived = ^tderived; - tderived = object(tbase) - x: longint; - constructor init; - destructor done; virtual; - procedure showit; virtual; - end; - - - Procedure TsimpleObject.init(somez: longint); - var - i: byte; - Begin - for i:=0 to 34 do - z[i]:=i; - x:=somez; - end; - - - Procedure TSimpleObject.hello; - var - i: byte; - Begin - WriteLn('hello world'); - for i:=0 to 34 do - Write(z[i],' '); - WriteLn; - WriteLN(x); - end; - - - constructor tbase.init(i: integer); - Begin - numofentries := i; - end; - - destructor tbase.done; - Begin - end; - - procedure tbase.showit; - Begin - WriteLn('This is the base class'); - end; - - constructor tderived.init; - Begin - inherited init(5); - x:=10; - end; - - procedure tderived.showit; - Begin - WriteLn('This is the derived class'); - WriteLn(numofentries); - WriteLn(x); - end; - - destructor tderived.done; - Begin - end; - - - Procedure CreateObject; - var - obj: pbase; - Begin - obj^.showit; - dispose(obj,done); - end; - -var - myobj: tsimpleobject; - obj: pbase; - devobj: tderived; -Begin - WriteLn(MemAvail); - obj:=new(pbase,init(10)); - obj^.showit; - WriteLn(MemAvail); - dispose(obj,done); - WriteLn(MemAvail); -end. \ No newline at end of file diff --git a/tests/test/testop.pp b/tests/test/testop.pp deleted file mode 100644 index c6890c17bd..0000000000 --- a/tests/test/testop.pp +++ /dev/null @@ -1,15 +0,0 @@ -uses - testop1,testop2; - -var - a,b,c : op1; - d,e,f : op2; - -begin - a.x:=67;a.y:=-45; - b.x:=89;b.y:=23; - c:=a+b; - e.x:=67;e.y:=-45;e.z:=67; - f.x:=89;f.y:=23;f.z:=56; - d:=e+f; -end. \ No newline at end of file diff --git a/tests/test/testop1.pp b/tests/test/testop1.pp deleted file mode 100644 index e71ad921ef..0000000000 --- a/tests/test/testop1.pp +++ /dev/null @@ -1,38 +0,0 @@ -unit testop1; - -interface - -type - op1 = record - x,y : longint; - end; - -operator + (const a,b : op1) c : op1; - -implementation - -uses - testop2; - -operator + (const a,b : op1) c : op1; -begin - c.x:=a.x+b.x; - c.y:=a.y+b.y; -end; - -procedure test_op2; -var - a,b,c : op2; -begin - a.x:=44; - a.y:=67; - b.x:=-34; - b.y:=-57; - c:=a+b; - if (c.x<>10) or (c.y<>10) then - Halt(1); -end; - -begin - test_op2; -end. \ No newline at end of file diff --git a/tests/test/testop2.pp b/tests/test/testop2.pp deleted file mode 100644 index ef752693c0..0000000000 --- a/tests/test/testop2.pp +++ /dev/null @@ -1,66 +0,0 @@ -unit testop2; - -interface - -type - op2 = record - x,y,z : longint; - end; - -operator + (const a,b : op2) c : op2; - -implementation - -uses - testop1,testop3; - -operator + (const a,b : op2) c : op2; -begin - c.x:=a.x+b.x; - c.y:=a.y+b.y; -end; - -procedure test_op3; -var - a,b,c : op3; -begin - a.x:=44.0; - a.y:=67.0; - b.x:=-34.0; - b.y:=-57.0; - c:=a+b; - if (c.x<>10.0) or (c.y<>10.0) then - Halt(1); -end; - -procedure test_op2; -var - a,b,c : op2; -begin - a.x:=44; - a.y:=67; - b.x:=-34; - b.y:=-57; - c:=a+b; - if (c.x<>10) or (c.y<>10) then - Halt(1); -end; - -procedure test_op1; -var - a,b,c : op1; -begin - a.x:=44; - a.y:=67; - b.x:=-34; - b.y:=-57; - c:=a+b; - if (c.x<>10) or (c.y<>10) then - Halt(1); -end; - -begin - test_op1; - test_op2; - test_op3; -end. \ No newline at end of file diff --git a/tests/test/testop3.pp b/tests/test/testop3.pp deleted file mode 100644 index 0746b7d18a..0000000000 --- a/tests/test/testop3.pp +++ /dev/null @@ -1,20 +0,0 @@ -unit testop3; - -interface - -type - op3 = record - x,y : real; - end; - -operator + (const a,b : op3) c : op3; - -implementation - -operator + (const a,b : op3) c : op3; -begin - c.x:=a.x+b.x; - c.y:=a.y+b.y; -end; - -end. \ No newline at end of file diff --git a/tests/test/testout.pp b/tests/test/testout.pp deleted file mode 100644 index 02d6a8c4b9..0000000000 --- a/tests/test/testout.pp +++ /dev/null @@ -1,95 +0,0 @@ -uses - dotest; - -{$ifdef HASOUT} -type - tr1 = record - l1,l2 : longint; - end; - -procedure p1(out b : byte); - - begin - if b<>0 then - do_error(1001); - b:=$aa; - end; - -procedure p2(out w : word); - - begin - if w<>0 then - do_error(1002); - w:=$aaaa; - end; - -procedure p3(out d : dword); - - begin - if d<>0 then - do_error(1003); - d:=$aaaaaaaa; - end; - -procedure p4(out r : tr1); - - begin - if r.l1<>0 then - do_error(1004); - if r.l2<>0 then - do_error(1005); - r.l1:=$aaaaaaaa; - r.l2:=$aaaaaaaa; - end; - -procedure p5(out a : ansistring); - - begin - if a<>'' then - do_error(1000); - a:='Now it''s another ansistring'; - end; - -var - b : byte; - w : word; - d : dword; - r1 : tr1; - a : ansistring; - - -begin - b:=$ff; - w:=$ffff; - d:=$ffffffff; - a:='An ansistring'; - r1.l1:=$ffffffff; - r1.l2:=$ffffffff; - - p1(b); - if b<>$aa then - do_error(1100); - - p2(w); - if w<>$aaaa then - do_error(1101); - - p3(d); - if d<>$aaaaaaaa then - do_error(1102); - - p4(r1); - if r1.l1<>$aaaaaaaa then - do_error(1103); - if r1.l2<>$aaaaaaaa then - do_error(1104); - - p5(a); - if a<>'Now it''s another ansistring' then - do_error(1105); -end. -{$else} -begin - Writeln('No out parameter support'); -end. -{$endif HASOUT} diff --git a/tests/test/testpusw.pp b/tests/test/testpusw.pp deleted file mode 100644 index 7421477ea1..0000000000 --- a/tests/test/testpusw.pp +++ /dev/null @@ -1,75 +0,0 @@ -{$R-} -program test_register_pushing; - -var - before, after : longint; - wpush,lpush : longint; -const - haserror : boolean = false; - -begin -{$ifdef CPUI386} -{$asmmode att} - asm - movl %esp,before - pushw %es - movl %esp,after - popw %es - end; - wpush:=before-after; - if wpush<>2 then - begin - Writeln('Compiler does not push "pushw %es" into 2 bytes'); - haserror:=true; - end; - asm - movl %esp,before - pushl %es - movl %esp,after - popl %es - end; - lpush:=before-after; - - if lpush<>4 then - begin - Writeln('Compiler does not push "pushl %es" into 4 bytes'); - haserror:=true; - end; - - asm - movl %esp,before - pushw %gs - movl %esp,after - popw %gs - end; - wpush:=before-after; - if wpush<>2 then - begin - Writeln('Compiler does not push "pushw %gs" into 2 bytes'); - haserror:=true; - end; - asm - movl %esp,before - pushl %gs - movl %esp,after - popl %gs - end; - lpush:=before-after; - - if lpush<>4 then - begin - Writeln('Compiler does not push "pushl %gs" into 4 bytes'); - haserror:=true; - end; -{$asmmode intel} - asm - mov before,esp - push es - mov after,esp - pop es - end; - Writeln('Intel "push es" uses ',before-after,' bytes'); -{$endif CPUI386} - if haserror then - Halt(1); -end. \ No newline at end of file diff --git a/tests/test/testpva2.pp b/tests/test/testpva2.pp deleted file mode 100644 index b158607521..0000000000 --- a/tests/test/testpva2.pp +++ /dev/null @@ -1,38 +0,0 @@ -{$F+} -{$ifdef fpc} -{$mode tp} -{$endif fpc} - -type - tproc = procedure; - tprocx = procedure(x : longint); - -const - dummy_call_count : longint = 0; - -procedure dummy; -begin - writeln('Dummy called'); - inc(dummy_call_count); -end; - -procedure dummyx(x : longint); -begin - writeln('Dummy called with x=',x); - inc(dummy_call_count); -end; - -var - tp2 : tproc; - tp1x,tp2x : tprocx; -const - tp1 : tproc = dummy; - -begin - move(@tp1,@tp2,sizeof(tproc)); - tp2; - tp1x:=dummyx; - move(@tp1x,@tp2x,sizeof(tproc)); - tp2x(2); - -end. \ No newline at end of file diff --git a/tests/test/testpvar.pp b/tests/test/testpvar.pp deleted file mode 100644 index 781e8590c7..0000000000 --- a/tests/test/testpvar.pp +++ /dev/null @@ -1,165 +0,0 @@ -{ - $Id$ - This program tries to test any aspect of procedure variables and related - stuff in FPC mode -} - -{$ifdef go32v2} -uses - dpmiexcp; -{$endif go32v2} - -Type - TMyRecord = Record - MyProc1,MyProc2 : Procedure(l : longint); - MyVar : longint; - end; - -procedure do_error(i : longint); - - begin - writeln('Error near: ',i); - halt(1); - end; - -var - globalvar : longint; - -type - tpoo_rec = record - procpointer : pointer; - s : pointer; - end; - -procedure callmethodparam(s : pointer;addr : pointer;param : longint); - - var - p : procedure(param : longint) of object; - - begin - tpoo_rec(p).procpointer:=addr; - tpoo_rec(p).s:=s; - p(param); - end; - -type - to1 = object - constructor init; - procedure test1; - procedure test2(l : longint); - procedure test3(l : longint);virtual;abstract; - end; - - to2 = object(to1) - procedure test3(l : longint);virtual; - end; - - constructor to1.init; - - begin - end; - - procedure to1.test1; - var - p:pointer; - begin - // useless only a semantic test - p:=@to1.test1; - // this do we use to do some testing - p:=@to1.test2; - globalvar:=0; - callmethodparam(@self,p,1234); - if globalvar<>1234 then - do_error(1000); - end; - - procedure to1.test2(l : longint); - - begin - globalvar:=l; - end; - - procedure to2.test3(l : longint); - - begin - globalvar:=l; - end; - - procedure testproc(l : longint); - - begin - globalvar:=l; - end; - -const - constmethodaddr : pointer = @to1.test2; - MyRecord : TMyRecord = ( - MyProc1 : TestProc; - MyProc2 : @TestProc; - ); - -var - o1 : to1; - o2 : to2; - p : procedure(l : longint) of object; - -begin - { Simple procedure variables } - writeln('Procedure variables'); - globalvar:=0; - MyRecord.MyProc1(1234); - if globalvar<>1234 then - do_error(2000); - globalvar:=0; - MyRecord.MyProc2(4321); - if globalvar<>4321 then - do_error(2001); - writeln('Ok'); - { } - { Procedures of objects } - { } - o1.init; - o2.init; - writeln('Procedures of objects'); - p:=@o1.test2; - globalvar:=0; - p(12); - if globalvar<>12 then - do_error(1002); - writeln('Ok'); - p:=@o2.test3; - globalvar:=0; - p(12); - if globalvar<>12 then - do_error(1004); - writeln('Ok'); - { } - { Pointers and addresses of procedures } - { } - writeln('Getting an address of a method as pointer'); - o1.test1; - globalvar:=0; - callmethodparam(@o1,constmethodaddr,34); - if globalvar<>34 then - do_error(1001); - writeln('Ok'); -end. -{ - $Log$ - Revision 1.1 2000-07-13 09:22:06 michael - + Initial import - - Revision 1.2 2000/04/02 09:06:55 florian - *** empty log message *** - - Revision 1.1 1999/12/02 17:37:45 peter - * moved *.pp into subdirs - * fpcmaked - - Revision 1.2 1999/11/29 22:55:25 florian - * small update - - Revision 1.1 1999/09/11 19:45:33 florian - * first version, please keep it up-to-date - -} diff --git a/tests/test/testrang.pp b/tests/test/testrang.pp deleted file mode 100644 index bf529f2c94..0000000000 --- a/tests/test/testrang.pp +++ /dev/null @@ -1,24 +0,0 @@ - -var x : byte; - y : longint; - -procedure set_x; -begin - y:=345; - {$R-} - x:=y; - {$R+} - Writeln('x = ',x); - {$R-} - x:=y - {$R+} -end; -{ the bug comes from the fact that as there is no -semicolon after x:=y the parser must read up to end; statement -and thus change the range check mode before -the assign node is created !! } - -begin - set_x; - Writeln('x = ',x); -end. \ No newline at end of file diff --git a/tests/test/testreal.pp b/tests/test/testreal.pp deleted file mode 100644 index a1a886462a..0000000000 --- a/tests/test/testreal.pp +++ /dev/null @@ -1,76 +0,0 @@ -{$E-} - - Procedure TestSub; - var - i : Real; - j : Real; - Begin - i:=99.9; - j:=10.0; - i:=i-j; - Write('RESULT SHOULD BE: 89.9 :'); - WriteLn(i); - i:=j-i; - Write('RESULT SHOULD BE: -79.9 :'); - WriteLn(i); - j:=j-10.0; - Write('RESULT SHOULD BE: 0.0 :'); - WriteLn(j); - end; - - Function TestAdd(i : real): Real; - Begin - i:=i+1.5; - if i > 10.0 then - Begin - Write('RESULT SHOULD BE: 10.5 :'); - WriteLn(i); - exit; - end; - TestAdd:=TestAdd(i); - end; - - Procedure TestDiv; - var - i : Real; - j : Real; - Begin - i:=-99.9; - j:=10.0; - i:=i / j; - Write('RESULT SHOULD BE: -9.9 :'); - WriteLn(i); - i:=j / i; - Write('RESULT SHOULD BE: -1.01 :'); - WriteLn(i); - j:=i / 10.0; - Write('RESULT SHOULD BE: -0.1001 :'); - WriteLn(j); - end; - - - - Procedure TestComplex; - var - i : real; - Begin - Write('RESULT SHOULD BE 2.09 :'); - i := 4.4; - WriteLn(Sqrt(i)); - Write('RESULT SHOULD BE PI :'); - WriteLn(Pi); - Write('RESULT SHOULD BE 4.0 :'); - WriteLn(Round(3.6)); - end; - - -Begin - WriteLn('------------ SUB ---------------'); - TestSub; - WriteLn('------------ ADD ---------------'); - TestAdd(0); - WriteLn('------------ DIV ---------------'); - TestDiv; - WriteLn('------------ COMPLEX ---------------'); - TestComplex; -end. diff --git a/tests/test/testrstr.pp b/tests/test/testrstr.pp deleted file mode 100644 index 5c1b1e98dd..0000000000 --- a/tests/test/testrstr.pp +++ /dev/null @@ -1,8 +0,0 @@ -{$mode objfpc} -resourcestring - s = 'Hello world'; - -begin - if s<>'Hello world' then - halt(1); -end. diff --git a/tests/test/testrtti.pp b/tests/test/testrtti.pp deleted file mode 100644 index b076e0df65..0000000000 --- a/tests/test/testrtti.pp +++ /dev/null @@ -1,570 +0,0 @@ -Program testrtti; - -{$Mode Delphi} -{$M+} - -Uses -{$ifdef go32v2} -dpmiexcp, -{$endif} -Typinfo; - -Const TypeNames : Array [TTYpeKind] of string[15] = - ('Unknown','Integer','Char','Enumeration', - 'Float','Set','Method','ShortString','LongString', - 'AnsiString','WideString','Variant','Array','Record', - 'Interface','Class','Object','WideChar','Bool','Int64','QWord'); - -Const OrdinalTypes = [tkInteger,tkChar,tkENumeration,tkbool]; - -Type - TMyEnum = (meFirst,meSecond,meThird); - TMyTestObject = Class(TObject) - Private - FBoolean : Boolean; - FByte : Byte; - FChar : Char; - FWord : Word; - FInteger : Integer; - Flongint : Longint; - FCardinal : Cardinal; - FReal : Real; - FExtended : Extended; - FMyEnum : TMyEnum; - FAnsiString : AnsiSTring; - FObj : TObject; - FStored : Boolean; - Function GetBoolean : Boolean; - Function GetByte : Byte; - Function GetChar : Char; - Function GetWord : Word; - Function GetInteger : Integer; - Function GetLongint : Longint; - Function GetCardinal : Cardinal; - Function GetReal : Real; - Function GetExtended : Extended; - Function GetAnsiString : AnsiString; - Function GetMyEnum : TMyEnum; - Procedure SetBoolean ( Value : Boolean); - Procedure SetByte ( Value : Byte ); - Procedure SetChar ( Value : Char ); - Procedure SetWord ( Value : Word ); - Procedure SetInteger ( Value : Integer ); - Procedure SetLongint ( Value : Longint ); - Procedure SetCardinal ( Value : Cardinal ); - Procedure SetReal ( Value : Real ); - Procedure SetExtended ( Value : Extended ); - Procedure SetAnsiString ( Value : AnsiString ); - Procedure SetMyEnum ( Value : TMyEnum ); - Function GetVirtualBoolean : Boolean; virtual; - Function GetVirtualByte : Byte; virtual; - Function GetVirtualChar : Char; virtual; - Function GetVirtualWord : Word; virtual; - Function GetVirtualInteger : Integer; virtual; - Function GetVirtualLongint : Longint; virtual; - Function GetVirtualCardinal : Cardinal; virtual; - Function GetVirtualReal : Real; virtual; - Function GetVirtualExtended : Extended; virtual; - Function GetVirtualAnsiString : AnsiString; virtual; - Function GetVirtualMyEnum : TMyEnum; virtual; - Procedure SetVirtualBoolean ( Value : Boolean); virtual; - Procedure SetVirtualByte ( Value : Byte ); virtual; - Procedure SetVirtualChar ( Value : Char ); virtual; - Procedure SetVirtualWord ( Value : Word ); virtual; - Procedure SetVirtualInteger ( Value : Integer ); virtual; - Procedure SetVirtualLongint ( Value : Longint ); virtual; - Procedure SetVirtualCardinal ( Value : Cardinal ); virtual; - Procedure SetVirtualReal ( Value : Real ); virtual; - Procedure SetVirtualExtended ( Value : Extended ); virtual; - Procedure SetVirtualAnsiString ( Value : AnsiString ); virtual; - Procedure SetVirtualMyEnum ( Value : TMyEnum ); virtual; - Function GetStaticStored : Boolean; - Function GetVirtualStored : Boolean;virtual; - Public - Constructor Create; - Destructor Destroy;override; - Published - Property ObjField: TObject read FObj write FObj; - Property BooleanField : Boolean Read FBoolean Write FBoolean; - Property ByteField : Byte Read FByte Write FByte; - Property CharField : Char Read FChar Write FChar; - Property WordField : Word Read FWord Write FWord; - Property IntegerField : Integer Read FInteger Write FInteger; - Property LongintField : Longint Read FLongint Write FLongint; - Property CardinalField : Cardinal Read FCardinal Write FCardinal; - Property RealField : Real Read FReal Write FReal; - Property ExtendedField : Extended Read FExtended Write FExtended; - Property AnsiStringField : AnsiString Read FAnsiString Write FAnsiString; - Property MyEnumField : TMyEnum Read FMyEnum Write FMyEnum; - Property BooleanMethod : Boolean Read GetBoolean Write SetBoolean; - Property ByteMethod : Byte Read GetByte Write SetByte; - Property CharMethod : Char Read GetChar Write SetChar; - Property WordMethod : Word Read GetWord Write SetWord; - Property IntegerMethod : Integer Read GetInteger Write SetInteger; - Property LongintMethod : Longint Read GetLongint Write SetLongint; - Property CardinalMethod : Cardinal Read GetCardinal Write SetCardinal; - Property RealMethod : Real Read GetReal Write SetReal; - Property ExtendedMethod : Extended Read GetExtended Write SetExtended; - Property AnsiStringMethod : AnsiString Read GetAnsiString Write SetAnsiString; - Property MyEnumMethod : TMyEnum Read GetMyEnum Write SetMyEnum; - Property BooleanVirtualMethod : Boolean Read GetVirtualBoolean Write SetVirtualBoolean; - Property ByteVirtualMethod : Byte Read GetVirtualByte Write SetVirtualByte; - Property CharVirtualMethod : Char Read GetVirtualChar Write SetVirtualChar; - Property WordVirtualMethod : Word Read GetVirtualWord Write SetVirtualWord; - Property IntegerVirtualMethod : Integer Read GetVirtualInteger Write SetVirtualInteger; - Property LongintVirtualMethod : Longint Read GetVirtualLongint Write SetVirtualLongint; - Property CardinalVirtualMethod : Cardinal Read GetVirtualCardinal Write SetVirtualCardinal; - Property RealVirtualMethod : Real Read GetVirtualReal Write SetVirtualReal; - Property ExtendedVirtualMethod : Extended Read GetVirtualExtended Write SetVirtualExtended; - Property AnsiStringVirtualMethod : AnsiString Read GetVirtualAnsiString Write SetVirtualAnsiString; - Property MyEnumVirtualMethod : TMyEnum Read GetVirtualMyEnum Write SetVirtualMyEnum; - Property StoredIntegerConstFalse : Longint Read FLongint Stored False; - Property StoredIntegerConstTrue : Longint Read FLongint Stored True; - Property StoredIntegerField : Longint Read FLongint Stored FStored; - Property StoredIntegerMethod : Longint Read Flongint Stored GetStaticStored; - Property StoredIntegerVirtualMethod : Longint Read Flongint Stored GetVirtualStored; - end; - -Constructor TMyTestObject.Create; - -begin - FBoolean:=true; - FByte:=1; { : Byte;} - FChar:='B'; { : Char; } - FWord:=3; {: Word; } - FInteger:=4; {: Integer; } - Flongint:=5; { : Longint; } - FCardinal:=6; {: Cardinal; } - FReal:=7.0; { : Real;} - FExtended :=8.0; { Extended;} - FMyEnum:=methird; { TMyEnum;} - FAnsiString:='this is an AnsiString'; -end; - -Destructor TMyTestObject.Destroy; - -begin - Inherited Destroy; -end; - -Function TMyTestObject.GetBoolean : boolean; - -begin - Result:=FBoolean; -end; - -Function TMyTestObject.GetByte : Byte; - -begin - Result:=FByte; -end; - -Function TMyTestObject.GetChar : Char; -begin - Result:=FChar; -end; - -Function TMyTestObject.GetWord : Word; -begin - Result:=FWord; -end; - -Function TMyTestObject.GetInteger : Integer; -begin - Result:=FInteger; -end; - -Function TMyTestObject.GetLongint : Longint; -begin - Result:=FLongint; -end; - -Function TMyTestObject.GetCardinal : Cardinal; -begin - Result:=FCardinal; -end; - -Function TMyTestObject.GetReal : Real; -begin - Result:=FReal; -end; - -Function TMyTestObject.GetExtended : Extended; -begin - Result:=FExtended; -end; - -Function TMyTestObject.GetAnsiString : AnsiString; -begin - Result:=FAnsiString; -end; - -Function TMyTestObject.GetMyEnum : TMyEnum; -begin - Result:=FMyEnum; -end; - -Procedure TMyTestObject.Setboolean ( Value : boolean ); -begin - Fboolean:=Value; -end; - - -Procedure TMyTestObject.SetByte ( Value : Byte ); -begin - FByte:=Value; -end; - -Procedure TMyTestObject.SetChar ( Value : Char ); -begin - FChar:=Value; -end; - -Procedure TMyTestObject.SetWord ( Value : Word ); -begin - FWord:=Value; -end; - -Procedure TMyTestObject.SetInteger ( Value : Integer ); -begin - FInteger:=Value; -end; - -Procedure TMyTestObject.SetLongint ( Value : Longint ); -begin - FLongint:=Value; -end; - -Procedure TMyTestObject.SetCardinal ( Value : Cardinal ); -begin - FCardinal:=Value; -end; - -Procedure TMyTestObject.SetReal ( Value : Real ); -begin - FReal:=Value; -end; - -Procedure TMyTestObject.SetExtended ( Value : Extended ); -begin - FExtended:=Value; -end; - -Procedure TMyTestObject.SetAnsiString ( Value : AnsiString ); -begin - FAnsiString:=Value; -end; - -Procedure TMyTestObject.SetMyEnum ( Value : TMyEnum ); -begin - FMyEnum:=Value; -end; - -Function TMyTestObject.GetVirtualBoolean : boolean; - -begin - Result:=FBoolean; -end; - -Function TMyTestObject.GetVirtualByte : Byte; - -begin - Result:=FByte; -end; - -Function TMyTestObject.GetVirtualChar : Char; -begin - Result:=FChar; -end; - -Function TMyTestObject.GetVirtualWord : Word; -begin - Result:=FWord; -end; - -Function TMyTestObject.GetVirtualInteger : Integer; -begin - Result:=FInteger; -end; - -Function TMyTestObject.GetVirtualLongint : Longint; -begin - Result:=FLongint; -end; - -Function TMyTestObject.GetVirtualCardinal : Cardinal; -begin - Result:=FCardinal; -end; - -Function TMyTestObject.GetVirtualReal : Real; -begin - Result:=FReal; -end; - -Function TMyTestObject.GetVirtualExtended : Extended; -begin - Result:=FExtended; -end; - -Function TMyTestObject.GetVirtualAnsiString : AnsiString; -begin - Result:=FAnsiString; -end; - -Function TMyTestObject.GetVirtualMyEnum : TMyEnum; -begin - Result:=FMyEnum; -end; - -Procedure TMyTestObject.SetVirtualboolean ( Value : boolean ); -begin - Fboolean:=Value; -end; - - -Procedure TMyTestObject.SetVirtualByte ( Value : Byte ); -begin - FByte:=Value; -end; - -Procedure TMyTestObject.SetVirtualChar ( Value : Char ); -begin - FChar:=Value; -end; - -Procedure TMyTestObject.SetVirtualWord ( Value : Word ); -begin - FWord:=Value; -end; - -Procedure TMyTestObject.SetVirtualInteger ( Value : Integer ); -begin - FInteger:=Value; -end; - -Procedure TMyTestObject.SetVirtualLongint ( Value : Longint ); -begin - FLongint:=Value; -end; - -Procedure TMyTestObject.SetVirtualCardinal ( Value : Cardinal ); -begin - FCardinal:=Value; -end; - -Procedure TMyTestObject.SetVirtualReal ( Value : Real ); -begin - FReal:=Value; -end; - -Procedure TMyTestObject.SetVirtualExtended ( Value : Extended ); -begin - FExtended:=Value; -end; - -Procedure TMyTestObject.SetVirtualAnsiString ( Value : AnsiString ); -begin - FAnsiString:=Value; -end; - -Procedure TMyTestObject.SetVirtualMyEnum ( Value : TMyEnum ); -begin - FMyEnum:=Value; -end; - -Function TMyTestObject.GetStaticStored : Boolean; - -begin - Result:=False; -end; - -Function TMyTestObject.GetVirtualStored : Boolean; - -begin - Result:=False; -end; - -Procedure DumpMem ( PL : PByte ); - -Var I,j : longint; - -begin - For I:=1 to 16 do - begin - Write ((I-1)*16:3,' :'); - For J:=1 to 10 do - begin - If (PL^>31) and (PL^<129) then - Write(' ',CHar(PL^)) - else - Write (PL^:3); - Write (' '); - inc(pl); - end; - writeln; - end; -end; - - -Function ProcType (PP : Byte) : String; - -begin - Case PP and 3 of - ptfield : Result:='from Field'; - ptstatic : Result:='with static method'; - ptVirtual : Result:='with virtual method'; - ptconst : Result:='with Const'; - end; -end; - -Procedure DumpTypeInfo (O : TMyTestObject); - -Var - PT : PTypeData; - PI : PTypeInfo; - I : Longint; - PP : PPropList; - -begin - PI:=O.ClassInfo; - Writeln ('Type kind : ',TypeNames[PI^.Kind]); - Writeln ('Type name : ',PI^.Name); - PT:=GetTypeData(PI); - //DumpMem(PByte(PI)); - If PT^.ParentInfo=Nil then - Writeln ('Object has no parent info') - else - Writeln ('Object has parent info'); - Writeln ('Property Count : ',PT^.PropCount); - Writeln ('Unit name : ',PT^.UnitName); - GetMem (PP,PT^.PropCount*SizeOf(Pointer)); - GetPropInfos(PI,PP); - For I:=0 to PT^.PropCount-1 do - If PP^[i]<>Nil then - With PP^[I]^ do - begin - Writeln ('Property name : ',Name); - Writeln (' Type kind: ',TypeNames[PropType^.Kind]); - Writeln (' Type Name: ',PropType^.Name); - If GetProc=Nil then Write ('No'); - Writeln (' Getproc available'); - If SetProc=Nil then Write ('No'); - Writeln (' Setproc available'); - If StoredProc=Nil then Write ('No'); - Writeln (' Storedproc available'); - Writeln (' Get property ',proctype(Propprocs)); - Writeln (' Set Property ',proctype(propprocs shr 2)); - Writeln (' Stored Property ',proctype(propprocs shr 4)); - Writeln (' Default : ',Default,' Index : ',Index); - Writeln (' NameIndex : ',NameIndex); - end; -end; - -Procedure PrintObject ( Obj: TMyTestObject); - -begin - With Obj do - begin - Writeln ('Field properties :'); - Writeln ('Property booleanField : ',booleanField); - Writeln ('Property ByteField : ',ByteField); - Writeln ('Property CharField : ',CharField); - Writeln ('Property WordField : ',WordField); - Writeln ('Property IntegerField : ',IntegerField); - Writeln ('Property LongintField : ',LongintField); - Writeln ('Property CardinalField : ',CardinalField); - Writeln ('Property RealField : ',RealField); - Writeln ('Property ExtendedField : ',ExtendedFIeld); - Writeln ('Property AnsiStringField : ',AnsiStringField); - Writeln ('Property MyEnumField : ',ord(MyEnumField)); - Writeln ('Method properties :'); - Writeln ('Property booleanMethod : ',BooleanMethod); - Writeln ('Property ByteMethod : ',ByteMethod); - Writeln ('Property CharMethod : ',CharMethod); - Writeln ('Property WordMethod : ',WordMethod); - Writeln ('Property IntegerMethod : ',IntegerMethod); - Writeln ('Property LongintMethod : ',LongintMethod); - Writeln ('Property CardinalMethod : ',CardinalMethod); - Writeln ('Property RealMethod : ',RealMethod); - Writeln ('Property ExtendedMethod : ',ExtendedMethod); - Writeln ('Property AnsiStringMethod : ',AnsiStringMethod); - Writeln ('Property MyEnumMethod : ',ord(MyEnumMethod)); - Writeln ('VirtualMethod properties :'); - Writeln ('Property booleanVirtualMethod : ',BooleanVirtualMethod); - Writeln ('Property ByteVirtualMethod : ',ByteVirtualMethod); - Writeln ('Property CharVirtualMethod : ',CharVirtualMethod); - Writeln ('Property WordVirtualMethod : ',WordVirtualMethod); - Writeln ('Property IntegerVirtualMethod : ',IntegerVirtualMethod); - Writeln ('Property LongintVirtualMethod : ',LongintVirtualMethod); - Writeln ('Property CardinalVirtualMethod : ',CardinalVirtualMethod); - Writeln ('Property RealVirtualMethod : ',RealVirtualMethod); - Writeln ('Property ExtendedVirtualMethod : ',ExtendedVirtualMethod); - Writeln ('Property AnsiStringVirtualMethod : ',AnsiStringVirtualMethod); - Writeln ('Property MyEnumVirtualMethod : ',ord(MyEnumVirtualMethod)); - end; -end; - -Procedure TestGet (O : TMyTestObject); - -Var - PT : PTypeData; - PI : PTypeInfo; - I,J : Longint; - PP : PPropList; - prI : PPropInfo; - -begin - PI:=O.ClassInfo; - Writeln ('Type kind : ',TypeNames[PI^.Kind]); - Writeln ('Type name : ',PI^.Name); - PT:=GetTypeData(PI); - If PT^.ParentInfo=Nil then - Writeln ('Object has no parent info') - else - Writeln ('Object has parent info'); - Writeln ('Property Count : ',PT^.PropCount); - Writeln ('Unit name : ',PT^.UnitName); - GetMem (PP,PT^.PropCount*SizeOf(Pointer)); - GetPropInfos(PI,PP); - For I:=0 to PT^.PropCount-1 do - begin - pri:=PP^[i]; - With Pri^ do - begin - Write ('(Examining ',name,' : Type : ',TypeNames[PropType^.Kind],', '); - If (Proptype^.kind in Ordinaltypes) Then - begin - J:=GetOrdProp(O,pri); - Write ('Value : ',j); - If PropType^.Kind=tkenumeration then - Write ('(=',GetEnumName(Proptype,J),')') - end - else - Case pri^.proptype^.kind of - tkfloat : begin - Write ('Value : '); - Flush(output); - Write(GetFloatProp(O,pri)) - end; - tkAstring : begin - Write ('value : '); - flush (output); - Write(GetStrProp(O,Pri)); - end; - else - Write ('Untested type:',ord(pri^.proptype^.kind)); - end; - Writeln (')'); - end; - end; -end; - -Var O : TMyTestObject; - -begin - O:=TMyTestObject.Create; - DumpTypeInfo(O); - PrintObject(O); - testget(o); -end. diff --git a/tests/test/testsave.pp b/tests/test/testsave.pp deleted file mode 100644 index 7366b41616..0000000000 --- a/tests/test/testsave.pp +++ /dev/null @@ -1,18 +0,0 @@ - - -function x : longint;saveregisters; -begin - x:=34; -end; - -var - y : longint; -begin - asm - movl $15,%eax - end; - y:=x; - Writeln(y); - if y<>34 then - halt(1); -end. \ No newline at end of file diff --git a/tests/test/testset.pp b/tests/test/testset.pp deleted file mode 100644 index 9bd3eededa..0000000000 --- a/tests/test/testset.pp +++ /dev/null @@ -1,175 +0,0 @@ -{ - $Id$ - - Program to test set functions -} - -{$define FPC_HAS_SET_INEQUALITIES} - -program TestSet; - -Procedure InitMSTimer; -begin -end; - - -{Get MS Timer} -Function MSTimer:longint; -begin - MSTimer:=0; -end; - - -const - Lval=2000; -VAR Box1, Box2: ARRAY [0..255] OF BYTE; - OneWOTwo, TwoWOOne, - UnionSet, InterSet, - Set1, Set2, Set3: SET OF BYTE; - K, MaxNr, L, - N, Low, Hi: INTEGER; - Start: LONGINT; - -begin - WriteLn ('Set operators functional and speed test'); - WriteLn; - - RandSeed := 17; - - for L := 0 TO 255 DO begin - Box1 [L] := L; - end; - MaxNr := 255; - for L := 0 TO 255 DO begin - K := Random (MaxNr+1); - Box2 [L] := Box1 [K]; - Box1 [K] := Box1 [MaxNr]; - Dec (MaxNr); - end; - - Start :=MSTimer; - - Set1 := []; - Set2 := []; - for L := 0 TO 255 DO begin - Set1 := Set1 + [Box2 [L]]; - if NOT (Box2 [L] IN Set1) then begin - WriteLn ('error in AddElem or InSet functions'); - Halt; - end; - Set2 := Set2 + [Box2 [L]] + []; - end; - -{$ifdef FPC_HAS_SET_INEQUALITIES } - if (Set1 <> Set2) OR (NOT (Set1 <= Set2)) OR (NOT (Set1 >= Set2)) then begin -{$else FPC_HAS_SET_INEQUALITIES } - if (Set1 <> Set2) then begin -{$endif FPC_HAS_SET_INEQUALITIES } - WriteLn ('error in relational operators 1'); - Halt; - end; - - for L := 0 TO 255 DO begin - Set1 := Set1 - [Box2 [L]]; - if Box2 [L] IN Set1 then begin - WriteLn ('error in set difference 1'); - Halt; - end; - end; - - if Set1 <> [] then begin - WriteLn ('error in set difference 2'); - Halt; - end; - - for L := 1 TO LVal DO begin - REPEAT - Low := Random (256); - Hi := Random (256); - UNTIL Low <= Hi; - - Set1 := []; - Set1 := Set1 + [Low..Hi]; - for K := 0 TO 255 DO begin - if (K IN Set1) AND ((K < Low) OR (K > Hi)) then begin - WriteLn ('wrong set inclusion in add range'); - Halt; - end; - if (NOT (K IN Set1)) AND ((K >= Low) AND (K <= Hi)) then begin - WriteLn ('wrong set exclusion in add range'); - Halt; - end; - end; - end; - - for L := 1 TO LVal DO begin - Set1 := []; - Set2 := []; - - for K := 1 TO 10 DO begin - Low := Random (256); - Hi := Random (256); - Set2:= Set1 + [Low..Hi]; -{$ifdef FPC_HAS_SET_INEQUALITIES } - if (Set1 >= Set2) AND (Set1 <> Set2) then begin -{$else FPC_HAS_SET_INEQUALITIES } - if (Set1 <> Set2) then begin -{$endif FPC_HAS_SET_INEQUALITIES } - WriteLn ('error in relational operators 2'); - Halt; - end; -{$ifdef FPC_HAS_SET_INEQUALITIES } - if NOT (Set1 <= Set2) then begin - WriteLn ('error in relational operators 3'); - Halt; - end; -{$endif FPC_HAS_SET_INEQUALITIES } - Set1 := Set2; - - end; - end; - - for L := 1 TO LVal DO begin - Set1 := []; - for K := 1 TO 10 DO begin - Low := Random (256); - Hi := Random (256); - Set1:= Set1 + [Low..Hi]; - end; - Set2 := []; - for K := 1 TO 10 DO begin - Low := Random (256); - Hi := Random (256); - Set2:= Set2 + [Low..Hi]; - end; - - OneWOTwo := Set1 - Set2; - TwoWOOne := Set2 - Set1; - InterSet := Set1 * Set2; - UnionSet := Set1 + Set2; - - if InterSet <> (Set2 * Set1) then begin - WriteLn ('error in set difference'); - Halt; - end; - - if (InterSet + OneWOTwo) <> Set1 then begin - WriteLn ('error in set difference or intersection'); - Halt; - end; - - if (InterSet + TwoWOOne) <> Set2 then begin - WriteLn ('error in set difference or intersection'); - Halt; - end; - - if (OneWOTwo + TwoWOOne + InterSet) <> UnionSet then begin - WriteLn ('error in set union, intersection or difference'); - Halt; - end; - - end; - Start:=MSTimer-Start; - WriteLn('Set test completes in ',Start,' ms'); -end. - diff --git a/tests/test/testset2.pp b/tests/test/testset2.pp deleted file mode 100644 index eea1536355..0000000000 --- a/tests/test/testset2.pp +++ /dev/null @@ -1,351 +0,0 @@ -(*********************************************************************) -(* Copyright (C) 1998, Carl Eric Codere *) -(*********************************************************************) -(* FPC (Free Pascal compiler) testsuite: SETS *) -(* Tests the following: in, +, -, *, assignments. *) -(* for small sets amd large sets, both with constants *) -(* and variables. *) -(*********************************************************************) - -type - myenum = (dA,dB,dC,dd,dedf,dg,dh,di,dj,dk,dl,dm,dn); - tasmop = (A_ABCD, - A_ADD,A_ADDA,A_ADDI,A_ADDQ,A_ADDX,A_AND,A_ANDI, - A_ASL,A_ASR,A_BCC,A_BCS,A_BEQ,A_BGE,A_BGT,A_BHI, - A_BLE,A_BLS,A_BLT,A_BMI,A_BNE,A_BPL,A_BVC,A_BVS, - A_BCHG,A_BCLR,A_BRA,A_BSET,A_BSR,A_BTST,A_CHK, - A_CLR,A_CMP,A_CMPA,A_CMPI,A_CMPM,A_DBCC,A_DBCS,A_DBEQ,A_DBGE, - A_DBGT,A_DBHI,A_DBLE,A_DBLS,A_DBLT,A_DBMI,A_DBNE,A_DBRA, - A_DBPL,A_DBT,A_DBVC,A_DBVS,A_DBF,A_DIVS,A_DIVU, - A_EOR,A_EORI,A_EXG,A_ILLEGAL,A_EXT,A_JMP,A_JSR, - A_LEA,A_LINK,A_LSL,A_LSR,A_MOVE,A_MOVEA,A_MOVEI,A_MOVEQ, - A_MOVEM,A_MOVEP,A_MULS,A_MULU,A_NBCD,A_NEG,A_NEGX, - A_NOP,A_NOT,A_OR,A_ORI,A_PEA,A_ROL,A_ROR,A_ROXL, - A_ROXR,A_RTR,A_RTS,A_SBCD,A_SCC,A_SCS,A_SEQ,A_SGE, - A_SGT,A_SHI,A_SLE,A_SLS,A_SLT,A_SMI,A_SNE, - A_SPL,A_ST,A_SVC,A_SVS,A_SF,A_SUB,A_SUBA,A_SUBI,A_SUBQ, - A_SUBX,A_SWAP,A_TAS,A_TRAP,A_TRAPV,A_TST,A_UNLK, - A_RTE,A_RESET,A_STOP, - { MC68010 instructions } - A_BKPT,A_MOVEC,A_MOVES,A_RTD, - { MC68020 instructions } - A_BFCHG,A_BFCLR,A_BFEXTS,A_BFEXTU,A_BFFFO, - A_BFINS,A_BFSET,A_BFTST,A_CALLM,A_CAS,A_CAS2, - A_CHK2,A_CMP2,A_DIVSL,A_DIVUL,A_EXTB,A_PACK,A_RTM, - A_TRAPCC,A_TRACS,A_TRAPEQ,A_TRAPF,A_TRAPGE,A_TRAPGT, - A_TRAPHI,A_TRAPLE,A_TRAPLS,A_TRAPLT,A_TRAPMI,A_TRAPNE, - A_TRAPPL,A_TRAPT,A_TRAPVC,A_TRAPVS,A_UNPK, - { FPU Processor instructions - directly supported only. } - { IEEE aware and misc. condition codes not supported } - A_FABS,A_FADD, - A_FBEQ,A_FBNE,A_FBNGT,A_FBGT,A_FBGE,A_FBNGE, - A_FBLT,A_FBNLT,A_FBLE,A_FBGL,A_FBNGL,A_FBGLE,A_FBNGLE, - A_FDBEQ,A_FDBNE,A_FDBGT,A_FDBNGT,A_FDBGE,A_FDBNGE, - A_FDBLT,A_FDBNLT,A_FDBLE,A_FDBGL,A_FDBNGL,A_FDBGLE,A_FBDNGLE, - A_FSEQ,A_FSNE,A_FSGT,A_FSNGT,A_FSGE,A_FSNGE, - A_FSLT,A_FSNLT,A_FSLE,A_FSGL,A_FSNGL,A_FSGLE,A_FSNGLE, - A_FCMP,A_FDIV,A_FMOVE,A_FMOVEM, - A_FMUL,A_FNEG,A_FNOP,A_FSQRT,A_FSUB,A_FSGLDIV, - A_FSFLMUL,A_FTST, - A_FTRAPEQ,A_FTRAPNE,A_FTRAPGT,A_FTRAPNGT,A_FTRAPGE,A_FTRAPNGE, - A_FTRAPLT,A_FTRAPNLT,A_FTRAPLE,A_FTRAPGL,A_FTRAPNGL,A_FTRAPGLE,A_FTRAPNGLE, - { Protected instructions } - A_CPRESTORE,A_CPSAVE, - { FPU Unit protected instructions } - { and 68030/68851 common MMU instructions } - { (this may include 68040 MMU instructions) } - A_FRESTORE,A_FSAVE,A_PFLUSH,A_PFLUSHA,A_PLOAD,A_PMOVE,A_PTEST, - { Useful for assembly langage output } - A_LABEL,A_NONE); - - -Function X(y:myenum): myenum; -Begin - x:=y; -end; - - -Procedure SecondInSets; -{ SET_IN_BYTE TESTS } -var - op : tasmop; - oplist: set of tasmop; -Begin - Write('TESTING SET_IN_BYTE:'); - oplist:=[]; - op:=A_JSR; - if op in oplist then - WriteLn(' FAILED.'); - op:=A_MOVE; - oplist:=oplist+[A_MOVE]; - if op in oplist then - WriteLn(' PASSED.'); -end; - -Procedure SetSetByte; -{ SET_SET_BYTE } -var - op : tasmop; - oplist: set of tasmop; -Begin - Write('TESTING SET_SET_BYTE(1):'); - op:=A_LABEL; - oplist:=[]; - oplist:=oplist+[op]; - if op in oplist then - Begin - WriteLn(' PASSED.'); - end - else - Begin - WriteLn(' FAILED.'); - end; -end; - - -Procedure SetAddSets; -{ SET_ADD_SETS } -var - op2list :set of tasmop; - oplist: set of tasmop; -Begin - op2list:=[]; - oplist:=[]; - oplist:=[A_MOVE]+[A_JSR]; - op2list:=[A_LABEL]; - oplist:=op2list+oplist; - if A_MOVE in oplist then - if A_LABEL in oplist then - if A_JSR in oplist then - WriteLn('TESTING SET_ADD_SETS: PASSED.') - else - WriteLn('TESTING SET_ADD_SETS: FAILED.') - else - WriteLn('TESTING SET_ADD_SETS: FAILED.') - else - WriteLn('TESTING SET_ADD_SETS: FAILED.') -end; - -Procedure SetSubsets; -{ SET_SUB_SETS } -var - op2list :set of tasmop; - oplist: set of tasmop; -Begin - op2list:=[]; - oplist:=[]; - oplist:=[A_MOVE]+[A_JSR]; - op2list:=[A_MOVE]+[A_JSR]; - oplist:=op2list-oplist; - if (A_MOVE in oplist) or (A_LABEL in oplist) or (A_JSR in oplist) then - WriteLn('TESTING SET_SUB_SETS: FAILED.') - else - WriteLn('TESTING SET_SUB_SETS: PASSED.') -end; - -Procedure SetCompSets; -{ SET_COMP_SETS } -var - op2list :set of tasmop; - oplist: set of tasmop; -Begin - op2list:=[]; - oplist:=[]; - oplist:=[A_MOVE]+[A_JSR]; - op2list:=[A_MOVE]+[A_JSR]; - if oplist=op2list then - WriteLn('TESTING SET_COMP_SETS(1): PASSED.') - else - WriteLn('TESTING SET_COMP_SETS(1): FAILED.'); - oplist:=[A_MOVE]; - if oplist=op2list then - WriteLn('TESTING SET_COMP_SETS(2): FAILED.') - else - WriteLn('TESTING SET_COMP_SETS(2): PASSED.'); -end; - -Procedure SetMulSets; -{ SET_COMP_SETS } -var - op2list :set of tasmop; - oplist: set of tasmop; -Begin - op2list:=[]; - oplist:=[]; - oplist:=[A_MOVE]+[A_JSR]; - op2list:=[A_MOVE]; - oplist:=oplist*op2list; - if A_JSR in oplist then - WriteLn('TESTING SET_MUL_SETS(1): FAILED.') - else - WriteLn('TESTING SET_MUL_SETS(1): PASSED.'); - if A_MOVE in oplist then - WriteLn('TESTING SET_MUL_SETS(2): PASSED.') - else - WriteLn('TESTING SET_MUL_SETS(2): FAILED.') -end; - -{------------------------------ TESTS FOR SMALL VALUES ---------------------} -Procedure SmallInSets; -{ SET_IN_BYTE TESTS } -var - op : myenum; - oplist: set of myenum; -Begin - Write('TESTING IN_BYTE:'); - oplist:=[]; - op:=Dn; - if op in oplist then - WriteLn(' FAILED.'); - op:=dm; - oplist:=oplist+[Dm]; - if op in oplist then - WriteLn(' PASSED.'); -end; - -Procedure SmallSetByte; -{ SET_SET_BYTE } -var - op : myenum; - oplist: set of myenum; -Begin - Write('TESTING SET_BYTE(1):'); - op:=DA; - oplist:=[]; - oplist:=oplist+[op]; - if op in oplist then - Begin - WriteLn(' PASSED.'); - end - else - Begin - WriteLn(' FAILED.'); - end; -end; - - -Procedure SmallAddSets; -{ SET_ADD_SETS } -var - op2list :set of myenum; - oplist: set of myenum; -Begin - op2list:=[]; - oplist:=[]; - oplist:=[DA]+[DC]; - op2list:=[DB]; - oplist:=op2list+oplist; - if DA in oplist then - if DC in oplist then - if DB in oplist then - WriteLn('TESTING SET_ADD_SETS: PASSED.') - else - WriteLn('TESTING ADD_SETS: FAILED.') - else - WriteLn('TESTING ADD_SETS: FAILED.') - else - WriteLn('TESTING ADD_SETS: FAILED.') -end; - -Procedure SmallSubsets; -{ SET_SUB_SETS } -var - op2list :set of myenum; - oplist: set of myenum; -Begin - op2list:=[]; - oplist:=[]; - oplist:=[DA]+[DC]; - op2list:=[DA]+[DC]; - oplist:=op2list-oplist; - if (DA in oplist) or (DB in oplist) or (DC in oplist) then - WriteLn('TESTING SUB_SETS: FAILED.') - else - WriteLn('TESTING SUB_SETS: PASSED.') -end; - -Procedure SmallCompSets; -{ SET_COMP_SETS } -var - op2list :set of myenum; - oplist: set of myenum; -Begin - op2list:=[]; - oplist:=[]; - oplist:=[DA]+[DC]; - op2list:=[DA]+[DC]; - if oplist=op2list then - WriteLn('TESTING COMP_SETS(1): PASSED.') - else - WriteLn('TESTING COMP_SETS(1): FAILED.'); - oplist:=[DA]; - if oplist=op2list then - WriteLn('TESTING COMP_SETS(2): FAILED.') - else - WriteLn('TESTING COMP_SETS(2): PASSED.'); -end; - -Procedure SmallMulSets; -{ SET_COMP_SETS } -var - op2list :set of myenum; - oplist: set of myenum; -Begin - op2list:=[]; - oplist:=[]; - oplist:=[DA]+[DC]; - op2list:=[DA]; - oplist:=oplist*op2list; - if DC in oplist then - WriteLn('TESTING MUL_SETS(1): FAILED.') - else - WriteLn('TESTING MUL_SETS(1): PASSED.'); - if DA in oplist then - WriteLn('TESTING MUL_SETS(2): PASSED.') - else - WriteLn('TESTING MUL_SETS(2): FAILED.') -end; - -const - b: myenum = (dA); -var - enum: set of myenum; - oplist: set of tasmop; - l : word; -Begin -{ small sets } - enum:=[]; - { add } - enum:=enum+[da]; - { subtract } - enum:=enum-[da]; - if DA in enum then - WriteLn('Found A_LABEL'); - { very large sets } - { copy loop test } - WRITELN('LARGE SETS:'); - oplist := [A_LABEL]; - { secondin test } - if A_LABEL in oplist then - WriteLn('TESTING SIMPLE SECOND_IN: PASSED.'); - { } - oplist:=[]; - if A_LABEL in oplist then - WriteLn('SECOND IN FAILED.'); - SecondinSets; - SetSetByte; - SetAddSets; - SetSubSets; - SetCompSets; - SetMulSets; - WRITELN('SMALL SETS:'); - SmallInSets; - SmallAddSets; - SmallSubSets; - SmallCompSets; - SmallMulSets; - l:=word(A_CPRESTORE); - if l = word(A_CPRESTORE) then - Begin - end; -end. diff --git a/tests/test/teststr.pp b/tests/test/teststr.pp deleted file mode 100644 index b5433bdf1d..0000000000 --- a/tests/test/teststr.pp +++ /dev/null @@ -1,271 +0,0 @@ -{ $OPT=-Fu../rtl/utils - $Id$ - - Program to test string functions and speed of the functions -} -program TestStr; -{$ifdef timer} -uses Timer; -{$else} -type - TTimer = Object - TotalMSec, - StartMSec : longint; - constructor init; - procedure reset; - procedure start; - procedure stop; - Function MSec:longint; - end; - -procedure TTimer.Reset; -begin -end; - -procedure TTimer.Start; -begin -end; - - -procedure TTimer.Stop; -begin -end; - - -Function TTimer.MSec:longint; -begin - MSec:=0; -end; - -Constructor TTimer.Init; -begin -end; - -{$endif} - -const - TestSize=10; {Use at least 10 for reasonable results} -type - BenType=array[1..8] of longint; -var - Total : longint; - headBen, - LoadBen, - ConcatBen, - DelBen, - InsBen, - CopyBen, - CmpBen, - MixBen : BenType; - t : TTimer; - -function TestOK:boolean; -Const - TestStr: string[22]='HELLO, THIS IS A TEST '; -var - I : INTEGER; - U : STRING[1]; - Q : STRING[100]; - S : STRING[55]; - T : STRING[60]; - V : STRING; -begin - TestOk:=false; - T:='THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG 1234567890'; - Insert (T, T, 1); -{Writeln(T);} - Delete (T, 55, 54); - S:=Copy (T, -5, 2); {'TH'} - U:=Copy (T, 7, 4); {'I'} - S:=S + U; {'THI'} - Q:=Copy (T, 32, 70); {'THE LAZY DOG 1234567890'} - Delete (Q, 2, 1); {'TE LAZY DOG 1234567890'} - Delete (Q, 100, 2); {'TE LAZY DOG 1234567890'} - Delete (Q, 3, -4); {'TE LAZY DOG 1234567890'} - Delete (Q, 3, 10); {'TE1234567890'} -{ writeln('TE1234567890 - ',Q);} - I:=Pos ('S', T); {25} - Insert(Copy(T,I,200),Q,3);{'TES OVER THE LAZY DOG 12345678901234567890'} - Delete (Q, 4, 6); {'TESTHE LAZY DOG 12345678901234567890} - S:=S + T [25]; {'THIS'} - S:=S + Copy (S, 3, -5) + Copy (S, 3, 2); {'THISIS'} - V:=T; {'THE QUICK BROWN FOX JUMPS OVER THE LAZY ..'} - Delete (V, -10, 47); {'AZY DOG 1234567890'} - if (Copy (V, -7, -1)='') and (Pos ('DOG', V)=5) then {TRUE} - Insert (V, S, 200); {'THISISAZY DOG 1234567890'} - U:=Copy (T, 44, 40); {' '} - Insert (U, S, 5); {'THIS ISAZY DOG 1234567890'} - I:=Pos ('ZY', S); {9} - Delete (S, I, -5); {'THIS ISAZY DOG 1234567890'} - Insert (Copy(S,5,1),S,8); {'THIS IS AZY DOG 1234567890'} - Delete (S, 10, 16); {'THIS IS A0'} - if S [Length (S)]='0' then {TRUE} - S:=S + Q; {'THIS IS A0TESTHE LAZY DOG 123456789012345...'} - V:=Copy (S, Length (S) - 19, 10); {'1234567890'} - if V=Copy (S, Length (S) - 9, 10) then {TRUE} - Delete (S, 15, 3 * Length (V)+2); {'THIS IS A0TEST'} - Insert ('', S, 0); {'THIS IS A0TEST'} - Insert(Copy(S,5,1),S,11); {'THIS IS A0 TEST'} - Insert ('HELLO', S, -4); {'HELLOTHIS IS A0 TEST'} - Insert (',', S, 6); {'HELLO,THIS IS A0 TEST'} - Delete (S, Pos ('TEST', S) - 2, 1); {'HELLO,THIS IS A TEST'} - Delete (Q, 0, 32767); {''} - Q:=Q + ' '; {' '} - Insert (Q, S, 7); {'HELLO, THIS IS A TEST'} - Insert (Q, S, 255); {'HELLO, THIS IS A TEST '} - if (S=TestStr) and (Q=' ') and (V='1234567890') and - (T='THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG 1234567890') then - TestOK:=true; -end; - - -procedure TestSpeed(Row,Len:byte); -var - l : longint; - hstr, - OrgStr : string; -begin - HeadBen[Row]:=Len; - OrgStr:=''; - while Length(OrgStr)'Hello') or - (a[j,j]<>'Hello') or - (a[k,k]<>'Hello') or - (a[l,l]<>'Hello') then - do_error(1000); - end; - -begin - writeln('Misc. shortstring tests'); - chararray2stringtest; - writeln('Misc. shortstring tests successfully passed'); - halt(0); -end. diff --git a/tests/test/testti1.pp b/tests/test/testti1.pp deleted file mode 100644 index f3a4366d7c..0000000000 --- a/tests/test/testti1.pp +++ /dev/null @@ -1,8 +0,0 @@ -type - pbyte = ^byte; - -begin - if (pbyte(typeinfo(longint))^<>1 then - halt(1); -end. - diff --git a/tests/test/testu1.pp b/tests/test/testu1.pp deleted file mode 100644 index 773fa30fb7..0000000000 --- a/tests/test/testu1.pp +++ /dev/null @@ -1,7 +0,0 @@ -uses - dotest,testu2; - -begin - if testvar<>1234567 then - do_error(1000); -end. diff --git a/tests/test/testu2.pp b/tests/test/testu2.pp deleted file mode 100644 index eec618b839..0000000000 --- a/tests/test/testu2.pp +++ /dev/null @@ -1,20 +0,0 @@ -unit testu2; - - interface - - var - testvar : longint; - - implementation - - uses - dotest; - -initialization - testvar:=1234567; -finalization - if testvar<>1234567 then - do_error(1001) - else - halt(0); -end. diff --git a/tests/test/testu3.pp b/tests/test/testu3.pp deleted file mode 100644 index ff8b93b4fc..0000000000 --- a/tests/test/testu3.pp +++ /dev/null @@ -1,11 +0,0 @@ -unit testu3; - - interface - - type - tr = record - end; - - implementation - -end. diff --git a/tests/test/testu4.pp b/tests/test/testu4.pp deleted file mode 100644 index c403c658d4..0000000000 --- a/tests/test/testu4.pp +++ /dev/null @@ -1,13 +0,0 @@ -unit testu4; - - interface - - uses - testu3; - - type - tr = testu3.tr; - - implementation - -end. diff --git a/tests/test/testu5.pp b/tests/test/testu5.pp deleted file mode 100644 index 6be51fc6d0..0000000000 --- a/tests/test/testu5.pp +++ /dev/null @@ -1,13 +0,0 @@ -unit testu5; - - interface - - uses - testu4; - - type - pr = ^tr; - - implementation - -end. diff --git a/tests/testopt/readme.txt b/tests/testopt/readme.txt deleted file mode 100644 index 8144730204..0000000000 --- a/tests/testopt/readme.txt +++ /dev/null @@ -1,9 +0,0 @@ -This directory contains some tests which test the optimizer -Register variables: - Enumerations .......................... testreg1.pp - Readln ................................ testreg2.pp - Range checking ........................ testreg3.pp -Common subexpression elimination (assembler) - Multidimensional array index operation. testcse1.pp - CSE and range checking ................ testcse2.pp - web bug 972............................ testcse3.pp \ No newline at end of file diff --git a/tests/testopt/testcse1.pp b/tests/testopt/testcse1.pp deleted file mode 100644 index a3f0847bd3..0000000000 --- a/tests/testopt/testcse1.pp +++ /dev/null @@ -1,27 +0,0 @@ -{ $OPT=-OG2p3} - -procedure t; -var - a: array[1..10,1..10] of string[31]; - i, j: longint; - c: char; - -begin - i := 5; - j := 7; - a[i,j] := '123456789'; - c := '0'; -{ clear the optimizer state } - asm - end; - a[i,j] := a[i,j] + c; - if a[i,j] <> '1234567890' then - begin - writeln('error!'); - halt(1) - end; -end; - -begin - t; -end. diff --git a/tests/testopt/testcse2.pp b/tests/testopt/testcse2.pp deleted file mode 100644 index fbeeab7ab0..0000000000 --- a/tests/testopt/testcse2.pp +++ /dev/null @@ -1,72 +0,0 @@ -{ $OPT=-OG2} -{$r+} - -type - tsubr = 1..100000; - tarr = array[1..100000] of longint; - -function test(b: tsubr): longint; -begin - test := b; -end; - -var - p: ^longint; - l: longint; - a, a2: tarr; - -begin - getmem(p,4); - p^ := 100000; - l := 5; - { clear the optimizer state } - asm - end; -{$r-} - { get p^ in eax, the following statement generates the code } - { movl A,%eax } - { movl (%eax),%eax } - a[p^] := l; -{$r+} - { now, p^ gets rangechecked, this generates the code } - { movl A,%eax (1) } - { movl (%eax),%ecx (1) } - { ... } - { call rangecheck_procedure } - { pushl (%eax) } - { } - { With the bug in the optimizer, the instructions marked with (1) are } - { replaced by } - { movl %eax,%ecx } - { } - { and as such the "pushl (%eax)" pushes a wrong value afterwards } - l := test(p^); - if l <> 100000 then - begin - writeln('Problem 1!'); - halt(1); - end; - p^ := 5; - l := 5; - { clear the optimizer state } - asm - end; -{$r-} - { the following moves p^ in %edx } - a2[l] := a[p^]; -{$r+} - { same test as before, but now the original value comes from edx } - { instead of that it is already in eax (so check that it doesn't } - { replace the } - { movl P,%eax } - { movl (%eax),%ecx } - { with } - { movl %edx,%ecx } - l := test(p^); - if l <> 5 then - begin - writeln('Problem 2!'); - halt(1); - end; - freemem(p,4); -end. diff --git a/tests/testopt/testcse3.pp b/tests/testopt/testcse3.pp deleted file mode 100644 index b89872d766..0000000000 --- a/tests/testopt/testcse3.pp +++ /dev/null @@ -1,40 +0,0 @@ -{ $OPT=-O2} -function forms(s: string; len: word): string; -begin - str(len,forms); - forms := s + ', ' + forms; -end; - -procedure wrt2(s: string); -begin - if s <> 'e 123, 4' then - begin - writeln('bug!'); - halt(1); - end; -end; - -type - pstring = ^string; - ta = array[0..254] of pstring; - tb = array[0..254] of byte; - -procedure t(var sel: ta; var selhigh: tb); -var - ml, i: byte; -begin - i := 5; - ml := 8; - new(sel[i]); - sel[i]^ := 'testje 123'; - selhigh[i] := 5; - wrt2(forms(copy(sel[i]^,selhigh[i]+1,255),ml-selhigh[i]+1)); -end; - -var - a: ta; - b: tb; - -begin - t(a,b); -end. \ No newline at end of file diff --git a/tests/testopt/testreg1.pp b/tests/testopt/testreg1.pp deleted file mode 100644 index 285f41a234..0000000000 --- a/tests/testopt/testreg1.pp +++ /dev/null @@ -1,26 +0,0 @@ -{ $OPT=-Or} -{$minenumsize 1} - -type - tenum = (e1,e2,e3); - -procedure p1(e : tenum);forward; - -procedure p1; - - begin - e:=tenum(byte(e)*byte(e)); - case e of - e1 : ; - else - begin - writeln('error'); - halt(1); - end; - end; - end; - -begin - p1(e1); -end. - diff --git a/tests/testopt/testreg2.dat b/tests/testopt/testreg2.dat deleted file mode 100644 index b3b34eee96..0000000000 --- a/tests/testopt/testreg2.dat +++ /dev/null @@ -1,7 +0,0 @@ -1.0 -2.0 -3.0 -4.0 -5.0 -6.0 - diff --git a/tests/testopt/testreg2.pp b/tests/testopt/testreg2.pp deleted file mode 100644 index 02916454c9..0000000000 --- a/tests/testopt/testreg2.pp +++ /dev/null @@ -1,42 +0,0 @@ -{ $OPT=-Or} -{$maxfpuregisters 3} -uses - dotest; - -var - t : text; - -procedure p; - - var - d : double; - e : extended; - s : single; - - begin - readln(t,d); - if d<>1 then - do_error(1000); - readln(t,d); - if d<>2 then - do_error(1001); - readln(t,e); - if e<>3 then - do_error(1002); - readln(t,e); - if e<>4 then - do_error(1003); - readln(t,s); - if s<>5 then - do_error(1004); - readln(t,s); - if s<>6 then - do_error(1005); - end; - -begin - assign(t,'testreg2.dat'); - reset(t); - p; - close(t); -end. diff --git a/tests/testopt/testreg3.pp b/tests/testopt/testreg3.pp deleted file mode 100644 index 1758e2958a..0000000000 --- a/tests/testopt/testreg3.pp +++ /dev/null @@ -1,33 +0,0 @@ -{ $OPT=-Or} -program rangecse; - -{$r+} - -type - pa = ^ta; - ta = array[0..100] of longint; - -procedure t; -var - i, j: longint; - p: pa; -begin - new(p); - fillchar(p^,101*sizeof(longint),0); - p^[100] := 5; - j := 5; - for i:=1 to 101 do - if j=p^[i-1] then - begin - writeln('found!'); - dispose(p); - exit; - end; - writeln('failed..'); - dispose(p); - halt(1); -end; - -begin - t; -end. \ No newline at end of file diff --git a/tests/tf/tf000001.pp b/tests/tf/tf000001.pp deleted file mode 100644 index 227e351a77..0000000000 --- a/tests/tf/tf000001.pp +++ /dev/null @@ -1,11 +0,0 @@ - -type - r=record - a :longint; - end; -var - w : ^r; -begin - if w^<>$1111 then - writeln; -end. \ No newline at end of file diff --git a/tests/tf/tf000002.pp b/tests/tf/tf000002.pp deleted file mode 100644 index bc881bbccd..0000000000 --- a/tests/tf/tf000002.pp +++ /dev/null @@ -1,8 +0,0 @@ - -var - i,j : longint; -begin - i:=longint; - j:=i*word+j*shortint; - j:= 15 +5*i +(i*i)+sqr(word); -end. \ No newline at end of file diff --git a/tests/tf/tf000003.pp b/tests/tf/tf000003.pp deleted file mode 100644 index aa9e56898b..0000000000 --- a/tests/tf/tf000003.pp +++ /dev/null @@ -1,10 +0,0 @@ -{$mode objfpc} -label l; - -begin - try - goto l; - finally - end; - l: -end. diff --git a/tests/tf/tf000004.pp b/tests/tf/tf000004.pp deleted file mode 100644 index e73b2a460e..0000000000 --- a/tests/tf/tf000004.pp +++ /dev/null @@ -1,10 +0,0 @@ -{$mode objfpc} -label l; - -begin - try - finally - l: - end; - goto l; -end. diff --git a/tests/tf/tf000005.pp b/tests/tf/tf000005.pp deleted file mode 100644 index d07c380d99..0000000000 --- a/tests/tf/tf000005.pp +++ /dev/null @@ -1,10 +0,0 @@ -{$mode objfpc} -label l; - -begin - try - except - goto l; - end; - l: -end. diff --git a/tests/tf/tf000006.pp b/tests/tf/tf000006.pp deleted file mode 100644 index 1b7798f94c..0000000000 --- a/tests/tf/tf000006.pp +++ /dev/null @@ -1,14 +0,0 @@ -{$mode objfpc} -uses - sysutils; - -label l; - -begin - try - except - on e : exception do - goto l; - end; - l: -end. diff --git a/tests/tf/tf000007.pp b/tests/tf/tf000007.pp deleted file mode 100644 index a541df99d8..0000000000 --- a/tests/tf/tf000007.pp +++ /dev/null @@ -1,20 +0,0 @@ -{$mode objfpc} -type - tc1 = class - l : longint; - property p : longint read l; - end; - - tc2 = class(tc1) - { in Delphi mode } - { parameters can have the same name as properties } - procedure p1(p : longint); - end; - -procedure tc2.p1(p : longint); - - begin - end; - -begin -end. diff --git a/tests/tf/tf000008.pp b/tests/tf/tf000008.pp deleted file mode 100644 index cce0e21c91..0000000000 --- a/tests/tf/tf000008.pp +++ /dev/null @@ -1,20 +0,0 @@ - - -type - obj = object - procedure method1; - procedure method2; - end; - - procedure obj.method1; - - procedure obj.method2; - - begin - end; - - begin - end; - - begin - end. \ No newline at end of file diff --git a/tests/to/to000000.pp b/tests/to/to000000.pp deleted file mode 100644 index 1cdd27feea..0000000000 --- a/tests/to/to000000.pp +++ /dev/null @@ -1,53 +0,0 @@ -Program UnsureOptsFail; -{This program shows how unsure optimizations can cause wrong code if you - program Silly Things (TM) - - The principle is always the same: - - you have a normal variable (local or global) and a pointer to it in one way - or another (be it a normal pointer or a var parameter). - - a) you first cause the value from the memeory location to be loaded in a - register (e.g. by using the normal variable as an array index) - b) next you assign a new value to the memory location (e.g. through the - pointer) - c) finally, you compare the two values - - Of course you can also use the pointer as an array index and assign a new - value to the normal variuable, that doesn't change anything). - - The problem is that the value of the first load is still in a register, so - it isn't loaded from memory again, so you compare the old value with the - new one. - - Note: this code doesn4t function correctly only when compiled with uncertain - optimizations on. All other forms of optimization are completely safe. - } - -var l: longint; - p: ^longint; - a: Array[1..10] of byte; - -Procedure ChangeIt(var t: longint); -{The same principle as in the main program, only here we have a var parameter - instead of a "normal" pointer. If l is passed to this procedure, it doesn't - function right.} -Begin - t := 1; - If t = l Then {t gets loaded in a register (eax)} - Begin - l := 2; - If t <> l then - Writeln('She can''t take any more or she''ll blow, captain!'); - End; -End; - -begin - p := @l; {p points to l} - l := 1; - a[p^] := 2; {load p^ in a register (eax in this case)} - l := 2; {change the value of l} - If p^ <> l - Then Writeln('Houston, we have a problem!'); - ChangeIt(l); -End. diff --git a/tests/ts/th010018.pp b/tests/ts/th010018.pp deleted file mode 100644 index aa00b2ac20..0000000000 --- a/tests/ts/th010018.pp +++ /dev/null @@ -1,14 +0,0 @@ -unit th010018; - -interface -type - rec=object - i : longint; - nrs : (one,two,three); - end; -var - brec : rec; - -implementation - -end. \ No newline at end of file diff --git a/tests/ts/ts010000.pp b/tests/ts/ts010000.pp deleted file mode 100644 index 6e37ea2a3c..0000000000 --- a/tests/ts/ts010000.pp +++ /dev/null @@ -1,36 +0,0 @@ -{$mode objfpc} -type - tobject1 = class - readl : longint; - function readl2 : longint; - procedure writel(ll : longint); - procedure writel2(ll : longint); - property l : longint read readl write writel; - property l2 : longint read readl2 write writel2; - end; - -procedure tobject1.writel(ll : longint); - - begin - end; - -procedure tobject1.writel2(ll : longint); - - begin - end; - -function tobject1.readl2 : longint; - - begin - end; - -var - object1 : tobject1; - i : longint; - -begin - object1:=tobject1.create; - i:=object1.l; - i:=object1.l2; - object1.l:=123; -end. \ No newline at end of file diff --git a/tests/ts/ts010001.pp b/tests/ts/ts010001.pp deleted file mode 100644 index c33fb55f27..0000000000 --- a/tests/ts/ts010001.pp +++ /dev/null @@ -1,46 +0,0 @@ -{ $OPT=-S2 -} -type - tmyclass = class of tmyobject; - - tmyobject = class - end; - -{ only a stupid test routine } -function getanchestor(c : tclass) : tclass; - - var - l : longint; - - begin - getanchestor:=tobject; - l:=l+1; - end; - -var - classref : tclass; - myclassref : tmyclass; - -const - constclassref1 : tclass = tobject; - constclassref2 : tclass = nil; - constclassref3 : tclass = tobject; - -begin - { simple test } - classref:=classref; - { more difficult } - classref:=myclassref; - classref:=tobject; - myclassref:=tmyobject; - - classref:=getanchestor(myclassref); - if (constclassref1.classname<>'TOBJECT') or - (constclassref2<>nil) or - (myclassref.classname<>'TMYOBJECT') or - (classref.classname<>'TOBJECT') then - begin - writeln('Error'); - halt(1); - end; -end. diff --git a/tests/ts/ts010002.pp b/tests/ts/ts010002.pp deleted file mode 100644 index 4ebb39970d..0000000000 --- a/tests/ts/ts010002.pp +++ /dev/null @@ -1,217 +0,0 @@ -{$Mode objfpc} - -{ - $Id$ - This file is part of the Free Pascal run time library. - Copyright (c) 1993,97 by the Free Pascal development team. - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - **********************************************************************} -{ - This unit introduces some basic classes as they are defined in Delphi. - These classes should be source compatible to their Delphi counterparts: - TPersistent - TComponent -} - -Unit ts010002; - -{$M+} - -Interface - -Type - -{ --------------------------------------------------------------------- - Forward Declarations. - ---------------------------------------------------------------------} - - TComponent = Class; - TFiler = Class; - TPersistent = Class; - -{ --------------------------------------------------------------------- - TFiler - ---------------------------------------------------------------------} - - TFiler = Class (TObject) - Protected - FAncestor : TComponent; - FIgnoreChildren : Boolean; - FRoot : TComponent; - Private - Public - Published - { Methods } - Constructor Create {(Stream : TStream; BufSize : Longint) }; - Destructor Destroy; override; - Procedure FlushBuffer; virtual; abstract; - { Properties } - Property Root : TComponent Read FRoot Write FRoot; - Property Ancestor : TComponent Read FAncestor Write FAncestor; - Property IgnoreChildren : Boolean Read FIgnoreChildren Write FIgnoreChildren; - end; - -{ --------------------------------------------------------------------- - TPersistent - ---------------------------------------------------------------------} - - TPersistent = Class (TObject) - Private - Procedure AssignError (Source : TPersistent); - Protected - Procedure AssignTo (Dest : TPersistent); - Procedure DefineProperties (Filer : TFiler); Virtual; - Public - { Methods } - Destructor Destroy; Override; - Procedure Assign (Source : TPersistent); virtual; - Published - end; - -{ --------------------------------------------------------------------- - TComponent - ---------------------------------------------------------------------} - - TComponentState = Set of ( csLoading, csReading, CsWriting, csDestroying, - csDesigning, csAncestor, csUpdating, csFixups ); - TComponentStyle = set of ( csInheritable,csCheckPropAvail ); - TComponentName = String; - - TComponent = Class (TPersistent) - Protected - FComponentState : TComponentState; - FComponentStyle : TComponentStyle; - FName : TComponentName; - - FOwner : TComponent; - Function GetComponent (Index : Longint) : TComponent; - Function GetComponentCount : Longint; - Function GetComponentIndex : Longint; - Procedure SetComponentIndex (Value : Longint); - Procedure Setname (Value : TComponentName); - Private - Public - { Methods } - { Properties } - Property ComponentCount : Longint Read GetComponentCount; { RO } - Property ComponentIndex : Longint Read GetComponentIndex write SetComponentIndex; { R/W } - // Property Components [Index : LongInt] : TComponent Read GetComponent; { R0 } - Property ComponentState : TComponentState Read FComponentState; { RO } - Property ComponentStyle : TcomponentStyle Read FComponentStyle; { RO } - Property Owner : TComponent Read Fowner; { RO } - Published - Property Name : TComponentName Read FName Write Setname; - end; - - - - -Implementation - -{ --------------------------------------------------------------------- - TComponent - ---------------------------------------------------------------------} - -Function TComponent.GetComponent (Index : Longint) : TComponent; - -begin -end; - - - -Function TComponent.GetComponentCount : Longint; - -begin -end; - - - -Function TComponent.GetComponentIndex : Longint; - -begin -end; - - - -Procedure TComponent.SetComponentIndex (Value : Longint); - -begin -end; - - - - -Procedure TComponent.Setname (Value : TComponentName); - -begin -end; - - - -{ --------------------------------------------------------------------- - TFiler - ---------------------------------------------------------------------} - -Constructor TFiler.Create {(Stream : TStream; BufSize : Longint) }; - -begin -end; - - - - -Destructor TFiler.Destroy; - -begin -end; - - - - -{ --------------------------------------------------------------------- - TPersistent - ---------------------------------------------------------------------} - -Procedure TPersistent.AssignError (Source : TPersistent); - -begin -end; - - - -Procedure TPersistent.AssignTo (Dest : TPersistent); - -begin -end; - - - -Procedure TPersistent.DefineProperties (Filer : TFiler); - -begin -end; - - - -Destructor TPersistent.Destroy; - -begin -end; - - - -Procedure TPersistent.Assign (Source : TPersistent); - -begin -end; - - - -end. diff --git a/tests/ts/ts010003.pp b/tests/ts/ts010003.pp deleted file mode 100644 index 48c05b5e4c..0000000000 --- a/tests/ts/ts010003.pp +++ /dev/null @@ -1,55 +0,0 @@ -uses - crt; - -begin - textcolor(blue); - writeln('blue'); - - textcolor(green); - writeln('green'); - - textcolor(cyan); - writeln('cyan'); - - textcolor(red); - writeln('red'); - - textcolor(magenta); - writeln('magenta'); - - textcolor(brown); - writeln('brown'); - - textcolor(lightgray); - writeln('lightgray'); - - textcolor(darkgray); - writeln('darkgray'); - - textcolor(lightblue); - writeln('lightblue'); - - textcolor(lightgreen); - writeln('lightgreen'); - - textcolor(lightcyan); - writeln('lightcyan'); - - textcolor(lightred); - writeln('lightred'); - - textcolor(lightmagenta); - writeln('lightmagenta'); - - textcolor(yellow); - writeln('yellow'); - - textcolor(white); - writeln('white'); - - textcolor(white+blink); - writeln('white blinking'); - - textcolor(lightgray); - writeln; -end. diff --git a/tests/ts/ts010004.pp b/tests/ts/ts010004.pp deleted file mode 100644 index 73b43a5a26..0000000000 --- a/tests/ts/ts010004.pp +++ /dev/null @@ -1,23 +0,0 @@ -{$mode objfpc} - -{ tests forward class types } - -type - tclass1 = class; - - tclass2 = class - class1 : tclass1; - end; - -var - c : tclass1; - -type - tclass1 = class(tclass2) - i : longint; - end; - -begin - c:=tclass1.create; - c.i:=12; -end. diff --git a/tests/ts/ts010005.pp b/tests/ts/ts010005.pp deleted file mode 100644 index ed66bd12c5..0000000000 --- a/tests/ts/ts010005.pp +++ /dev/null @@ -1,43 +0,0 @@ -{$mode objfpc} - -type - tclass1 = class - procedure a;virtual; - procedure b;virtual; - end; - - tclass2 = class(tclass1) - procedure a;override; - procedure b;override; - procedure c;virtual; - end; - - - procedure tclass1.a; - - begin - end; - - procedure tclass1.b; - - begin - end; - - procedure tclass2.a; - - begin - end; - - procedure tclass2.b; - - begin - end; - - - procedure tclass2.c; - - begin - end; - -begin -end. \ No newline at end of file diff --git a/tests/ts/ts010006.pp b/tests/ts/ts010006.pp deleted file mode 100644 index 49f2d38979..0000000000 --- a/tests/ts/ts010006.pp +++ /dev/null @@ -1,13 +0,0 @@ -{$ifdef win32} -library test; - - procedure exporttest;export; - - begin - end; - - exports exporttest; -{$endif} - -begin -end. diff --git a/tests/ts/ts010007.pp b/tests/ts/ts010007.pp deleted file mode 100644 index 9151c6833e..0000000000 --- a/tests/ts/ts010007.pp +++ /dev/null @@ -1,52 +0,0 @@ -{ $OPT=-S2 } -{ classes need objpas !! } -{ needed to intercept GPF (PM) } -{$ifdef go32v2} - uses dpmiexcp; -{$endif go32v2} - -type - tobject2 = class - i : longint; - procedure y; - constructor create; - class procedure x; - class procedure v;virtual; - end; - - procedure tobject2.y; - - begin - Writeln('Procedure y called'); - end; - - class procedure tobject2.v; - - begin - end; - - class procedure tobject2.x; - - begin - v; - end; - - constructor tobject2.create; - - begin - end; - - type - tclass2 = class of tobject2; - - var - a : class of tobject2; - object2 : tobject2; - -begin - a:=tobject2; - a.x; - tobject2.x; - object2:=tobject2.create; - object2:=a.create; -end. \ No newline at end of file diff --git a/tests/ts/ts010008.pp b/tests/ts/ts010008.pp deleted file mode 100644 index 59fedb48b5..0000000000 --- a/tests/ts/ts010008.pp +++ /dev/null @@ -1,41 +0,0 @@ -{ $OPT=-S2 } - -type - tobject2 = class - constructor create; - function rname : string; - procedure wname(const s : string); - property name : string read rname write wname; - end; - - tclass2 = class of tobject2; - -var - o2 : tobject2; - c2 : tclass2; - -constructor tobject2.create; - - begin - inherited create; - end; - -procedure tobject2.wname(const s : string); - - begin - end; - -function tobject2.rname : string; - - begin - end; - -begin - o2:=tobject2.create; - o2.name:='1234'; - writeln(o2.name); - o2.destroy; - c2:=tobject2; - o2:=c2.create; - o2.destroy; -end. diff --git a/tests/ts/ts010009.pp b/tests/ts/ts010009.pp deleted file mode 100644 index fc12dc1b75..0000000000 --- a/tests/ts/ts010009.pp +++ /dev/null @@ -1,13 +0,0 @@ -unit ts010009; - - interface - - type - tr = record - case a : (x,y,z) of - x : (l : longint); - end; - - implementation - -end. diff --git a/tests/ts/ts010010.pp b/tests/ts/ts010010.pp deleted file mode 100644 index ec5f3da522..0000000000 --- a/tests/ts/ts010010.pp +++ /dev/null @@ -1,15 +0,0 @@ -uses - ts010009; - - var - r : tr; - - begin - r.a:=x; - if r.a=x then - begin - with r do - if a=y then - ; - end; - end. diff --git a/tests/ts/ts010014.pp b/tests/ts/ts010014.pp deleted file mode 100644 index e3dd5788bd..0000000000 --- a/tests/ts/ts010014.pp +++ /dev/null @@ -1,58 +0,0 @@ -{$R+} -type - ta = object - constructor init; - destructor done; - procedure p;virtual; - end; - - pa = ^ta; - -constructor ta.init; - - begin - end; - -destructor ta.done; - - begin - end; - -procedure ta.p; - - begin - end; - -type - plongint = ^longint; - -var - p : pa; - data : array[0..4] of longint; - saveexit : pointer; - - procedure testerror; - begin - exitproc:=saveexit; - if errorcode=210 then - begin - errorcode:=0; - writeln('Object valid VMT check works'); - runerror(0); - end - else - halt(1); - end; - -begin - saveexit:=exitproc; - exitproc:=@testerror; - fillchar(data,sizeof(data),12); - p:=new(pa,init); - p^.p; - { the vmt pointer gets an invalid value: } - plongint(p)^:=longint(@data); - { causes runerror } - p^.p; - halt(1); -end. diff --git a/tests/ts/ts010015.pp b/tests/ts/ts010015.pp deleted file mode 100644 index e0e010c267..0000000000 --- a/tests/ts/ts010015.pp +++ /dev/null @@ -1,74 +0,0 @@ -program ttyped; - -Type - TRec = record - X,Y : longint; - end; - - TRecFile = File of TRec; - -var TF : TRecFile; - LF : File of longint; - i,j,k,l : longint; - t : Trec; - -begin - Write ('Writing files...'); - assign (LF,'longint.dat'); - rewrite (LF); - for i:=1 to 10 do - write (LF,i); - close (LF); - Assign (TF,'TRec.dat'); - rewrite (TF); - for i:=1 to 10 do - for j:=1 to 10 do - begin - t.x:=i; - t.y:=j; - write (TF,T); - end; - close (TF); - writeln ('Done'); - reset (LF); - reset (TF); - Write ('Sequential read test...'); - for i:=1 to 10 do - begin - read (LF,J); - if j<>i then writeln ('Read of longint failed at :',i); - end; - for i:=1 to 10 do - for j:=1 to 10 do - begin - read (tf,t); - if (t.x<>i) or (t.y<>j) then - writeln ('Read of record failed at :',i,',',j); - end; - writeln ('Done.'); - Write ('Random access read test...'); - For i:=1 to 10 do - begin - k:=random(10); - seek (lf,k); - read (lf,j); - if j<>k+1 then - Writeln ('Failed random read of longint at pos ',k,' : ',j); - end; - For i:=1 to 10 do - for j:=1 to 10 do - begin - k:=random(10); - l:=random(10); - seek (tf,k*10+l); - read (tf,t); - if (t.x<>k+1) or (t.y<>l+1) then - Writeln ('Failed random read of longint at pos ',k,',',l,' : ',t.x,',',t.y); - end; - Writeln ('Done.'); - close (lf); - close (TF); - erase (lf); - erase (tf); - -end. \ No newline at end of file diff --git a/tests/ts/ts010016.pp b/tests/ts/ts010016.pp deleted file mode 100644 index 7aec067fc1..0000000000 --- a/tests/ts/ts010016.pp +++ /dev/null @@ -1,37 +0,0 @@ -{ problem of conversion between - smallsets and long sets } -type - -{ Command sets } - - PCommandSet = ^TCommandSet; - TCommandSet = set of Byte; - -Const - cmValid = 0; - cmQuit = 1; - cmError = 2; - cmMenu = 3; - cmClose = 4; - cmZoom = 5; - cmResize = 6; - cmNext = 7; - cmPrev = 8; - cmHelp = 9; - -{ Application command codes } - - cmCut = 20; - cmCopy = 21; - cmPaste = 22; - cmUndo = 23; - cmClear = 24; - cmTile = 25; - cmCascade = 26; - - CurCommandSet: TCommandSet = - [0..255] - [cmZoom, cmClose, cmResize, cmNext, cmPrev]; - - - begin - end. diff --git a/tests/ts/ts010017.pp b/tests/ts/ts010017.pp deleted file mode 100644 index 8c99967d9e..0000000000 --- a/tests/ts/ts010017.pp +++ /dev/null @@ -1,33 +0,0 @@ -{ show a problem with IOCHECK !! - inside reset(file) - we call reset(file,longint) - but we also emit a call to iocheck after and this is wrong !! PM } - -program getret; - - uses dos; - - var - ppfile : file; - -begin - assign(ppfile,'this_file_probably_does_not_exist&~"#'); -{$I-} - reset(ppfile,1); - if ioresult=0 then - begin -{$I+} - close(ppfile); - end - else - writeln('the file does not exist') ; -{$I-} - reset(ppfile); - if ioresult=0 then - begin -{$I+} - close(ppfile); - end - else - writeln('the file does not exist') ; -end. diff --git a/tests/ts/ts010018.pp b/tests/ts/ts010018.pp deleted file mode 100644 index d0e1fb1446..0000000000 --- a/tests/ts/ts010018.pp +++ /dev/null @@ -1,13 +0,0 @@ -uses th010018; - -var - arec : rec; - -begin - arec.nrs:=one; - if arec.nrs<>one then - begin - Writeln('Error with enums inside objects'); - Halt(1); - end; -end. \ No newline at end of file diff --git a/tests/ts/ts010019.pp b/tests/ts/ts010019.pp deleted file mode 100644 index 7f33a31637..0000000000 --- a/tests/ts/ts010019.pp +++ /dev/null @@ -1,39 +0,0 @@ - -{ this program shows a possible problem - of name mangling in FPC (PM) } - procedure test; - - function a : longint; - begin - a:=1; - end; - - begin - writeln('a = ',a); - end; - - procedure test(b : byte); - - function a : longint; - begin - a:=2; - end; - - begin - writeln('b = ',b); - writeln('a = ',a); - end; - - type a = word; - - function test_(b : a) : longint; - begin - test_:=b; - end; - -begin - test(1); - test; - test(4); -end. - diff --git a/tests/ts/ts010020.pp b/tests/ts/ts010020.pp deleted file mode 100644 index ff1c7a83af..0000000000 --- a/tests/ts/ts010020.pp +++ /dev/null @@ -1,10 +0,0 @@ -{ test for const string that is a char } - -const - C ='D'; - D = 'AD'; - PP : string[length(D)] = D; - P : String[length(c)] = C; - -begin -end. diff --git a/tests/ts/ts010021.pp b/tests/ts/ts010021.pp deleted file mode 100644 index 2f053c346f..0000000000 --- a/tests/ts/ts010021.pp +++ /dev/null @@ -1,19 +0,0 @@ -{ $OPT=-g } -{ the debug info created problems for very long mangled names - because the manglednames where shorten differently (PM) - fixed in v 0.99.9 } -program ts010021; - -var i : longint; - - type very_very_very_long_integer = longint; - - function ugly(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p : - very_very_very_long_integer) : longint; - - begin - ugly:=0; - end; - -begin -end. diff --git a/tests/ts/ts010022.pp b/tests/ts/ts010022.pp deleted file mode 100644 index fc1ef924df..0000000000 --- a/tests/ts/ts010022.pp +++ /dev/null @@ -1,46 +0,0 @@ -program ts010022; - -const - EXCEPTIONCOUNT = 18; - exception_names : array[0..EXCEPTIONCOUNT-1] of pchar = ( - 'Division by Zero', - 'Debug', - 'NMI', - 'Breakpoint', - 'Overflow', - 'Bounds Check', - 'Invalid Opcode', - 'Coprocessor not available', - 'Double Fault', - 'Coprocessor overrun', - 'Invalid TSS', - 'Segment Not Present', - 'Stack Fault', - 'General Protection Fault', - 'Page fault', - ' ', - 'Coprocessor Error', - 'Alignment Check'); - - single_pchar : pchar = 'Alone test'; - -const filename = 'ts010022.tmp'; - -var en : pchar; - f : text; - st : string; -begin - assign(f,filename); - rewrite(f); - en:=single_pchar; - Writeln(f,en); - en:=exception_names[6]; - writeln(f,en); - close(f); - reset(f); - readln(f,st); - if st<>'Alone test' then halt(1); - readln(f,st); - if st<>'Invalid Opcode' then halt(1); - close(f); -end. \ No newline at end of file diff --git a/tests/ts/ts010023.pp b/tests/ts/ts010023.pp deleted file mode 100644 index 9394da828f..0000000000 --- a/tests/ts/ts010023.pp +++ /dev/null @@ -1,14 +0,0 @@ -const - nl=#10; -type - cs=set of char; - -function p(c:cs):boolean; -begin - p:=(#10 in c); -end; - -begin - if p([#1..#255]-[nl]) then - halt(1); -end. \ No newline at end of file diff --git a/tests/ts/ts010024.pp b/tests/ts/ts010024.pp deleted file mode 100644 index ce82589859..0000000000 --- a/tests/ts/ts010024.pp +++ /dev/null @@ -1,34 +0,0 @@ -{$asmmode att} - -const - Count=100; - -type - trec=record - a,b,c : longint; - end; - - -var - r : trec; -begin - asm - leal r,%edi - leal r,%esi - movl %es:46(%edi),%eax - movl 2+trec.b(%esi),%eax - movl $1,%ebx - movl trec.b(%esi,%ebx,(2*4)),%eax - movl r(,%ebx,(2*4)),%eax - xorl %esi,%esi - movl r.c(,%esi,(2*4)),%eax - movl Count,%eax - movl Count*100,%eax - movl trec.b+2,%eax - leal r,%esi - movl trec.b+2(%esi),%eax -{$ifdef go32v2} - movl %fs:(0x46c),%eax -{$endif} - end; -end. \ No newline at end of file diff --git a/tests/ts/ts010025.pp b/tests/ts/ts010025.pp deleted file mode 100644 index 26cf01ea76..0000000000 --- a/tests/ts/ts010025.pp +++ /dev/null @@ -1,29 +0,0 @@ -{$asmmode intel} - -const - Count=100; - -type - trec=record - a,b : longint; - end; - -var - r : trec; -begin - asm - xor esi,esi - mov [esi+r],eax - lea esi,r - mov [esi+2+trec.b],eax - mov trec[esi].b,eax - mov eax,trec.b+2 - mov trec[esi].b+2,eax - mov eax,Count - mov eax,Count*100 -{$ifdef go32v2} - mov fs:[0468+trec.b],eax - mov fs:[046ch],eax -{$endif} - end; -end. \ No newline at end of file diff --git a/tests/ts/ts010026.pp b/tests/ts/ts010026.pp deleted file mode 100644 index 04136f33d8..0000000000 --- a/tests/ts/ts010026.pp +++ /dev/null @@ -1,45 +0,0 @@ -{ this test program test allocation of large pieces of stack } -{ this is especially necessary for win32 } - -procedure p1(a : array of byte); - - var - i : longint; - - begin - for i:=0 to high(a) do - a[i]:=0; - end; - -procedure p2; - - var - a : array[0..20000] of byte; - i : longint; - - begin - for i:=0 to high(a) do - a[i]:=0; - end; - -procedure p3; - - var - a : array[0..200000] of byte; - i : longint; - - begin - for i:=0 to high(a) do - a[i]:=0; - end; - - -var - a : array[0..10000] of byte; - -begin - p1(a); - p2; - p3; -end. - diff --git a/tests/ts/ts010027.pp b/tests/ts/ts010027.pp deleted file mode 100644 index c89308f006..0000000000 --- a/tests/ts/ts010027.pp +++ /dev/null @@ -1,25 +0,0 @@ -{$IFDEF FPC} -{$ASMMODE INTEL} -{$ENDIF} -{$N+} - -FUNCTION Floor(M2:Comp):LONGINT;assembler; - -VAR X : COMP; - X2 : LONGINT; - X3 : Double; - s : single; - -ASM - FLD QWord Ptr X // Here S_IL must be changed to - // S_FL, i.e. the compiler must generate - // fldl "X" instead of fldq "X" which is wrong - fld X2 // No mem64, so no problem - FLD QWord Ptr X3 // This one goes wrong under AS - FilD QWord Ptr X // This one translates to fildq and is accepted? - fild X2 // No mem64, so no problem - FiLD QWord Ptr X3 // This one translates to fildq and is accepted? -end; - -BEGIN -END. diff --git a/tests/ts/ts010028.pp b/tests/ts/ts010028.pp deleted file mode 100644 index c853d5e5b5..0000000000 --- a/tests/ts/ts010028.pp +++ /dev/null @@ -1,13 +0,0 @@ -// checks type cast of nil in const statement - type - THandle = longint; - WSAEVENT = THandle; - const - WSA_INVALID_EVENT = WSAEVENT(nil); - - var - l : longint; - -begin - l:=WSA_INVALID_EVENT*1; -end. diff --git a/tests/ts/ts010029.pp b/tests/ts/ts010029.pp deleted file mode 100644 index 04136f33d8..0000000000 --- a/tests/ts/ts010029.pp +++ /dev/null @@ -1,45 +0,0 @@ -{ this test program test allocation of large pieces of stack } -{ this is especially necessary for win32 } - -procedure p1(a : array of byte); - - var - i : longint; - - begin - for i:=0 to high(a) do - a[i]:=0; - end; - -procedure p2; - - var - a : array[0..20000] of byte; - i : longint; - - begin - for i:=0 to high(a) do - a[i]:=0; - end; - -procedure p3; - - var - a : array[0..200000] of byte; - i : longint; - - begin - for i:=0 to high(a) do - a[i]:=0; - end; - - -var - a : array[0..10000] of byte; - -begin - p1(a); - p2; - p3; -end. - diff --git a/tests/ts/ts010030.pp b/tests/ts/ts010030.pp deleted file mode 100644 index fede1db11d..0000000000 --- a/tests/ts/ts010030.pp +++ /dev/null @@ -1,20 +0,0 @@ -{$mode delphi} -type - tc1 = class - l : longint; - property p : longint read l; - end; - - tc2 = class(tc1) - { in Delphi mode } - { parameters can have the same name as properties } - procedure p1(p : longint); - end; - -procedure tc2.p1(p : longint); - - begin - end; - -begin -end. diff --git a/tests/ts/ts010031.pp b/tests/ts/ts010031.pp deleted file mode 100644 index a12f135f39..0000000000 --- a/tests/ts/ts010031.pp +++ /dev/null @@ -1,15 +0,0 @@ -var - d1,d2 :double; - i1,i2 : int64; - c1,c2 : dword; - -begin - c1:=10; - c2:=100; - i1:=1000; - i2:=10000; - d1:=c1/c2; - d2:=i1/i2; - if d1<>d2 then - halt(1); -end. diff --git a/tests/ts/ts010032.pp b/tests/ts/ts010032.pp deleted file mode 100644 index 7a39833f6b..0000000000 --- a/tests/ts/ts010032.pp +++ /dev/null @@ -1,12 +0,0 @@ -type ta = array[1..1,1..100] of integer; - -procedure t(a: ta); -begin -end; - -var a: ta; - -begin - t(a); -end. - diff --git a/tests/ts/ts010033.pp b/tests/ts/ts010033.pp deleted file mode 100644 index 2db5627f30..0000000000 --- a/tests/ts/ts010033.pp +++ /dev/null @@ -1,76 +0,0 @@ -{$OPT -Or} -{ test for full boolean eval and register usage with b+ } - -{$b+} - -var - funcscalled: byte; - ok: boolean; - -function function1: boolean; -begin - writeln('function1 called!'); - inc(funcscalled); - function1 := false; -end; - -function function2: boolean; -begin - writeln('function2 called!'); - inc(funcscalled); - function2 := false; -end; - -function function3: boolean; -begin - writeln('function3 called!'); - inc(funcscalled); - function3 := false; -end; - -function function4: boolean; -begin - writeln('function4 called!'); - inc(funcscalled); - function4 := false; -end; - -function test2: boolean; -var j, k, l, m: longint; -begin - test2 := true; - m := 0; -{ get as much regvars occupied as possible } - for j := 1 to 1000 do - for k := 1 to 1000 do - for l := k downto 0 do - inc(m,j - k + l); - if (j = 5) and (k = 0) and (l = 100) and function1 then - begin - test2 := false; - writeln('bug'); - end; -end; - -begin - ok := true; - funcscalled := 0; - if function1 and function2 and function3 and function4 then - begin - writeln('bug!'); - end; - ok := funcscalled = 4; - if ok then - writeln('all functions called!') - else - writeln('not all functions called'); - ok := test2 and (funcscalled = 5); - if ok then - writeln('test2 passed') - else writeln('test2 not passed'); - if not ok then - begin - writeln('full boolean evaluation is not working!'); - halt(1); - end; -end. diff --git a/tests/ts/ts010100.pp b/tests/ts/ts010100.pp deleted file mode 100644 index 750e8b7f34..0000000000 --- a/tests/ts/ts010100.pp +++ /dev/null @@ -1,9 +0,0 @@ -{ $OPT= -S2 -} -var - o : tobject; - -begin - if assigned(o) then - halt(1); -end. diff --git a/tests/ts/ts010101.pp b/tests/ts/ts010101.pp deleted file mode 100644 index eef7424f0c..0000000000 --- a/tests/ts/ts010101.pp +++ /dev/null @@ -1,13 +0,0 @@ -{ $OPT=-S2 -} -{ tests assignements and compare } - -var - o1,o2 : tobject; - -begin - o1:=nil; - o2:=o1; - if o2<>nil then - halt(1); -end. diff --git a/tests/units/Makefile b/tests/units/Makefile deleted file mode 100644 index d6b0cd8c26..0000000000 --- a/tests/units/Makefile +++ /dev/null @@ -1,1192 +0,0 @@ -# -# Makefile generated by fpcmake v1.00 [2000/10/27] -# - -defaultrule: current - -##################################################################### -# Autodetect OS (Linux or Dos or Windows NT) -# define inUnix when running under Unix (Linux,FreeBSD) -# define inWinNT when running under WinNT -##################################################################### - -# We need only / in the path -override PATH:=$(subst \,/,$(PATH)) - -# Search for PWD and determine also if we are under linux -PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(subst ;, ,$(PATH))))) -ifeq ($(PWD),) -PWD:=$(strip $(wildcard $(addsuffix /pwd,$(subst :, ,$(PATH))))) -ifeq ($(PWD),) -nopwd: - @echo You need the GNU utils package to use this Makefile! - @echo Get ftp://ftp.freepascal.org/pub/fpc/dist/go32v2/utilgo32.zip - @exit -else -inUnix=1 -endif -else -PWD:=$(firstword $(PWD)) -endif - -# Detect NT - NT sets OS to Windows_NT -# Detect OS/2 - OS/2 has OS2_SHELL defined -ifndef inUnix -ifeq ($(OS),Windows_NT) -inWinNT=1 -else -ifdef OS2_SHELL -inOS2=1 -endif -endif -endif - -# The extension of executables -ifdef inUnix -SRCEXEEXT= -else -SRCEXEEXT=.exe -endif - -# The path which is searched separated by spaces -ifdef inUnix -SEARCHPATH=$(subst :, ,$(PATH)) -else -SEARCHPATH=$(subst ;, ,$(PATH)) -endif - -# Base dir -ifdef PWD -BASEDIR:=$(shell $(PWD)) -else -BASEDIR=. -endif - -##################################################################### -# FPC version/target Detection -##################################################################### - -# What compiler to use ? -ifndef FPC -# Compatibility with old makefiles -ifdef PP -FPC=$(PP) -else -FPC=ppc386 -endif -endif -override FPC:=$(subst $(SRCEXEEXT),,$(FPC)) -override FPC:=$(subst \,/,$(FPC))$(SRCEXEEXT) - -# Target OS -ifndef OS_TARGET -OS_TARGET:=$(shell $(FPC) -iTO) -endif - -# Source OS -ifndef OS_SOURCE -OS_SOURCE:=$(shell $(FPC) -iSO) -endif - -# Target CPU -ifndef CPU_TARGET -CPU_TARGET:=$(shell $(FPC) -iTP) -endif - -# Source CPU -ifndef CPU_SOURCE -CPU_SOURCE:=$(shell $(FPC) -iSP) -endif - -# FPC version -ifndef FPC_VERSION -FPC_VERSION:=$(shell $(FPC) -iV) -endif - -export FPC OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FPC_VERSION - -##################################################################### -# FPCDIR Setting -##################################################################### - -# Test FPCDIR to look if the RTL dir exists -ifdef FPCDIR -override FPCDIR:=$(subst \,/,$(FPCDIR)) -ifeq ($(wildcard $(FPCDIR)/rtl),) -ifeq ($(wildcard $(FPCDIR)/units),) -override FPCDIR=wrong -endif -endif -else -override FPCDIR=wrong -endif - -# Detect FPCDIR -ifeq ($(FPCDIR),wrong) -ifdef inUnix -override FPCDIR=/usr/local/lib/fpc/$(FPC_VERSION) -ifeq ($(wildcard $(FPCDIR)/units),) -override FPCDIR=/usr/lib/fpc/$(FPC_VERSION) -endif -else -override FPCDIR:=$(subst /$(FPC),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC),$(SEARCHPATH)))))) -override FPCDIR:=$(FPCDIR)/.. -ifeq ($(wildcard $(FPCDIR)/rtl),) -ifeq ($(wildcard $(FPCDIR)/units),) -override FPCDIR:=$(FPCDIR)/.. -ifeq ($(wildcard $(FPCDIR)/rtl),) -ifeq ($(wildcard $(FPCDIR)/units),) -override FPCDIR=c:/pp -endif -endif -endif -endif -endif -endif - -##################################################################### -# User Settings -##################################################################### - - -# Targets - - -# Clean - - -# Install - -ZIPTARGET=install - -# Defaults - - -# Directories - - -# Packages - - -# Libraries - - -# Info - -INFOTARGET=fpc_infocfg fpc_infoobjects fpc_infoinstall - -##################################################################### -# Shell tools -##################################################################### - -# echo -ifndef ECHO -ECHO:=$(strip $(wildcard $(addsuffix /gecho$(EXEEXT),$(SEARCHPATH)))) -ifeq ($(ECHO),) -ECHO:=$(strip $(wildcard $(addsuffix /echo$(SRCEXEEXT),$(SEARCHPATH)))) -ifeq ($(ECHO),) -ECHO:=echo -ECHOE:=echo -else -ECHO:=$(firstword $(ECHO)) -ECHOE=$(ECHO) -E -endif -else -ECHO:=$(firstword $(ECHO)) -ECHOE=$(ECHO) -E -endif -endif - -# To copy pograms -ifndef COPY -COPY:=cp -fp -endif - -# Copy a whole tree -ifndef COPYTREE -COPYTREE:=cp -rfp -endif - -# To move pograms -ifndef MOVE -MOVE:=mv -f -endif - -# Check delete program -ifndef DEL -DEL:=rm -f -endif - -# Check deltree program -ifndef DELTREE -DELTREE:=rm -rf -endif - -# To install files -ifndef INSTALL -ifdef inUnix -INSTALL:=install -c -m 644 -else -INSTALL:=$(COPY) -endif -endif - -# To install programs -ifndef INSTALLEXE -ifdef inUnix -INSTALLEXE:=install -c -m 755 -else -INSTALLEXE:=$(COPY) -endif -endif - -# To make a directory. -ifndef MKDIR -ifdef inUnix -MKDIR:=install -m 755 -d -else -MKDIR:=ginstall -m 755 -d -endif -endif - -export ECHO ECHOE COPY COPYTREE MOVE DEL DELTREE INSTALL INSTALLEXE MKDIR - -##################################################################### -# Default Tools -##################################################################### - -# assembler, redefine it if cross compiling -ifndef AS -AS=as -endif - -# linker, but probably not used -ifndef LD -LD=ld -endif - -# ppas.bat / ppas.sh -ifdef inUnix -PPAS=ppas.sh -else -ifdef inOS2 -PPAS=ppas.cmd -else -PPAS=ppas.bat -endif -endif - -# ldconfig to rebuild .so cache -ifdef inUnix -LDCONFIG=ldconfig -else -LDCONFIG= -endif - -# ppumove -ifndef PPUMOVE -PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(SRCEXEEXT),$(SEARCHPATH)))) -ifeq ($(PPUMOVE),) -PPUMOVE= -else -PPUMOVE:=$(firstword $(PPUMOVE)) -endif -endif -export PPUMOVE - -# ppufiles -ifndef PPUFILES -PPUFILES:=$(strip $(wildcard $(addsuffix /ppufiles$(SRCEXEEXT),$(SEARCHPATH)))) -ifeq ($(PPUFILES),) -PPUFILES= -else -PPUFILES:=$(firstword $(PPUFILES)) -endif -endif -export PPUFILES - -# Look if UPX is found for go32v2 and win32. We can't use $UPX becuase -# upx uses that one itself (PFV) -ifndef UPXPROG -ifeq ($(OS_TARGET),go32v2) -UPXPROG:=1 -endif -ifeq ($(OS_TARGET),win32) -UPXPROG:=1 -endif -ifdef UPXPROG -UPXPROG:=$(strip $(wildcard $(addsuffix /upx$(SRCEXEEXT),$(SEARCHPATH)))) -ifeq ($(UPXPROG),) -UPXPROG= -else -UPXPROG:=$(firstword $(UPXPROG)) -endif -else -UPXPROG= -endif -endif -export UPXPROG - -# ZipProg, you can't use Zip as the var name (PFV) -ifndef ZIPPROG -ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(SRCEXEEXT),$(SEARCHPATH)))) -ifeq ($(ZIPPROG),) -ZIPPROG= -else -ZIPPROG:=$(firstword $(ZIPPROG)) -endif -endif -export ZIPPROG - -ZIPOPT=-9 -ZIPEXT=.zip - -# Tar -ifndef TARPROG -TARPROG:=$(strip $(wildcard $(addsuffix /tar$(SRCEXEEXT),$(SEARCHPATH)))) -ifeq ($(TARPROG),) -TARPROG= -else -TARPROG:=$(firstword $(TARPROG)) -endif -endif -export TARPROG - -ifeq ($(USETAR),bz2) -TAROPT=vI -TAREXT=.tar.bz2 -else -TAROPT=vz -TAREXT=.tar.gz -endif - -##################################################################### -# Default extensions -##################################################################### - -# Default needed extensions (Go32v2,Linux) -LOADEREXT=.as -EXEEXT=.exe -PPLEXT=.ppl -PPUEXT=.ppu -OEXT=.o -ASMEXT=.s -SMARTEXT=.sl -STATICLIBEXT=.a -SHAREDLIBEXT=.so -RSTEXT=.rst -FPCMADE=fpcmade - -# Go32v1 -ifeq ($(OS_TARGET),go32v1) -PPUEXT=.pp1 -OEXT=.o1 -ASMEXT=.s1 -SMARTEXT=.sl1 -STATICLIBEXT=.a1 -SHAREDLIBEXT=.so1 -FPCMADE=fpcmade.v1 -endif - -# Go32v2 -ifeq ($(OS_TARGET),go32v2) -FPCMADE=fpcmade.dos -endif - -# Linux -ifeq ($(OS_TARGET),linux) -EXEEXT= -HASSHAREDLIB=1 -FPCMADE=fpcmade.lnx -endif - -# Linux -ifeq ($(OS_TARGET),freebsd) -EXEEXT= -HASSHAREDLIB=1 -FPCMADE=fpcmade.freebsd -endif - -# Win32 -ifeq ($(OS_TARGET),win32) -PPUEXT=.ppw -OEXT=.ow -ASMEXT=.sw -SMARTEXT=.slw -STATICLIBEXT=.aw -SHAREDLIBEXT=.dll -FPCMADE=fpcmade.w32 -endif - -# OS/2 -ifeq ($(OS_TARGET),os2) -PPUEXT=.ppo -ASMEXT=.so2 -OEXT=.oo2 -SMARTEXT=.so -STATICLIBEXT=.ao2 -SHAREDLIBEXT=.dll -FPCMADE=fpcmade.os2 -endif - -# library prefix -LIBPREFIX=lib -ifeq ($(OS_TARGET),go32v2) -LIBPREFIX= -endif -ifeq ($(OS_TARGET),go32v1) -LIBPREFIX= -endif - -# determine which .pas extension is used -ifndef PASEXT -ifdef EXEOBJECTS -override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(EXEOBJECTS))))) -else -override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(UNITOBJECTS))))) -endif -ifeq ($(TESTPAS),) -PASEXT=.pp -else -PASEXT=.pas -endif -endif - - - -##################################################################### -# Default Directories -##################################################################### - -# Linux and freebsd use unix dirs with /usr/bin, /usr/lib -# When zipping use the target as default, when normal install then -# use the source os as default -ifdef ZIPNAME -# Zipinstall -ifeq ($(OS_TARGET),linux) -UNIXINSTALLDIR=1 -endif -ifeq ($(OS_TARGET),freebsd) -UNIXINSTALLDIR=1 -endif -else -# Normal install -ifeq ($(OS_SOURCE),linux) -UNIXINSTALLDIR=1 -endif -ifeq ($(OS_SOURCE),freebsd) -UNIXINSTALLDIR=1 -endif -endif - -# set the prefix directory where to install everything -ifndef PREFIXINSTALLDIR -ifdef UNIXINSTALLDIR -PREFIXINSTALLDIR=/usr -else -PREFIXINSTALLDIR=/pp -endif -endif -export PREFIXINSTALLDIR - -# Where to place the resulting zip files -ifndef DESTZIPDIR -DESTZIPDIR:=$(BASEDIR) -endif -export DESTZIPDIR - -##################################################################### -# Install Directories -##################################################################### - -# set the base directory where to install everything -ifndef BASEINSTALLDIR -ifdef UNIXINSTALLDIR -BASEINSTALLDIR=$(PREFIXINSTALLDIR)/lib/fpc/$(FPC_VERSION) -else -BASEINSTALLDIR=$(PREFIXINSTALLDIR) -endif -endif - -# set the directory where to install the binaries -ifndef BININSTALLDIR -ifdef UNIXINSTALLDIR -BININSTALLDIR=$(PREFIXINSTALLDIR)/bin -else -BININSTALLDIR=$(BASEINSTALLDIR)/bin/$(OS_TARGET) -endif -endif - -# set the directory where to install the units. -ifndef UNITINSTALLDIR -UNITINSTALLDIR=$(BASEINSTALLDIR)/units/$(OS_TARGET) -ifdef UNITSUBDIR -UNITINSTALLDIR:=$(UNITINSTALLDIR)/$(UNITSUBDIR) -endif -endif - -# Where to install shared libraries -ifndef LIBINSTALLDIR -ifdef UNIXINSTALLDIR -LIBINSTALLDIR=$(PREFIXINSTALLDIR)/lib -else -LIBINSTALLDIR=$(UNITINSTALLDIR) -endif -endif - -# Where the source files will be stored -ifndef SOURCEINSTALLDIR -ifdef UNIXINSTALLDIR -SOURCEINSTALLDIR=$(PREFIXINSTALLDIR)/src/fpc-$(FPC_VERSION) -else -SOURCEINSTALLDIR=$(BASEINSTALLDIR)/source -endif -ifdef SOURCESUBDIR -SOURCEINSTALLDIR:=$(SOURCEINSTALLDIR)/$(SOURCESUBDIR) -endif -endif - -# Where the doc files will be stored -ifndef DOCINSTALLDIR -ifdef UNIXINSTALLDIR -DOCINSTALLDIR=$(PREFIXINSTALLDIR)/doc/fpc-$(FPC_VERSION) -else -DOCINSTALLDIR=$(BASEINSTALLDIR)/doc -endif -endif - -# Where to install the examples, under linux we use the doc dir -# because the copytree command will create a subdir itself -ifndef EXAMPLEINSTALLDIR -ifdef UNIXINSTALLDIR -EXAMPLEINSTALLDIR=$(DOCINSTALLDIR)/examples -else -EXAMPLEINSTALLDIR=$(BASEINSTALLDIR)/examples -endif -ifdef EXAMPLESUBDIR -EXAMPLEINSTALLDIR:=$(EXAMPLEINSTALLDIR)/$(EXAMPLESUBDIR) -endif -endif - -# Where the some extra (data)files will be stored -ifndef DATAINSTALLDIR -DATAINSTALLDIR=$(BASEINSTALLDIR) -endif - -##################################################################### -# Redirection -##################################################################### - -ifndef REDIRFILE -REDIRFILE=log -endif - -ifdef REDIR -ifndef inUnix -override FPC=redir -eo $(FPC) -endif -# set the verbosity to max -override FPCOPT+=-va -override REDIR:= >> $(REDIRFILE) -endif - - -##################################################################### -# Compiler Command Line -##################################################################### - -# Load commandline OPTDEF and add FPC_CPU define -override FPCOPTDEF:=-d$(CPU_TARGET) - -# Load commandline OPT and add target and unit dir to be sure -ifneq ($(OS_TARGET),$(OS_SOURCE)) -override FPCOPT+=-T$(OS_TARGET) -endif - -# User dirs should be first, so they are looked at first -ifdef UNITDIR -override FPCOPT+=$(addprefix -Fu,$(UNITDIR)) -endif -ifdef LIBDIR -override FPCOPT+=$(addprefix -Fl,$(LIBDIR)) -endif -ifdef OBJDIR -override FPCOPT+=$(addprefix -Fo,$(OBJDIR)) -endif -ifdef INCDIR -override FPCOPT+=$(addprefix -Fi,$(INCDIR)) -endif - -# Smartlinking -ifdef LINKSMART -override FPCOPT+=-XX -endif - -# Smartlinking creation -ifdef CREATESMART -override FPCOPT+=-CX -endif - -# Debug -ifdef DEBUG -override FPCOPT+=-gl -dDEBUG -endif - -# Release mode (strip, optimize and don't load ppc386.cfg) -# 0.99.12b has a bug in the optimizer so don't use it by default -ifdef RELEASE -ifeq ($(FPC_VERSION),0.99.12) -override FPCOPT+=-Xs -OGp3 -n -else -override FPCOPT+=-Xs -OG2p3 -n -endif -endif - -# Strip -ifdef STRIP -override FPCOPT+=-Xs -endif - -# Optimizer -ifdef OPTIMIZE -override FPCOPT+=-OG2p3 -endif - -# Verbose settings (warning,note,info) -ifdef VERBOSE -override FPCOPT+=-vwni -endif - -ifdef UNITSDIR -override FPCOPT+=-Fu$(UNITSDIR) -endif - -# Target dirs and the prefix to use for clean/install -ifdef TARGETDIR -override FPCOPT+=-FE$(TARGETDIR) -ifeq ($(TARGETDIR),.) -override TARGETDIRPREFIX= -else -override TARGETDIRPREFIX=$(TARGETDIR)/ -endif -endif -ifdef UNITTARGETDIR -override FPCOPT+=-FU$(UNITTARGETDIR) -ifeq ($(UNITTARGETDIR),.) -override UNITTARGETDIRPREFIX= -else -override UNITTARGETDIRPREFIX=$(TARGETDIR)/ -endif -else -ifdef TARGETDIR -override UNITTARGETDIR=$(TARGETDIR) -override UNITTARGETDIRPREFIX=$(TARGETDIRPREFIX) -endif -endif - -# Add commandline options last so they can override -ifdef OPT -override FPCOPT+=$(OPT) -endif - -# Add defines from FPCOPTDEF to FPCOPT -ifdef FPCOPTDEF -override FPCOPT+=$(FPCOPTDEF) -endif - -# Error file ? -ifdef ERRORFILE -override FPCOPT+=-Fr$(ERRORFILE) -endif - -# Was a config file specified ? -ifdef CFGFILE -override FPCOPT+=@$(CFGFILE) -endif - -# For win32 the options are passed using the environment FPCEXTCMD -ifeq ($(OS_SOURCE),win32) -override FPCEXTCMD:=$(FPCOPT) -override FPCOPT:=!FPCEXTCMD -export FPCEXTCMD -endif - -# Compiler commandline -override COMPILER:=$(FPC) $(FPCOPT) - -# also call ppas if with command option -s -# but only if the OS_SOURCE and OS_TARGE are equal -ifeq (,$(findstring -s ,$(COMPILER))) -EXECPPAS= -else -ifeq ($(OS_SOURCE),$(OS_TARGET)) -EXECPPAS:=@$(PPAS) -endif -endif - -##################################################################### -# Standard rules -##################################################################### - -all: fpc_all - -debug: fpc_debug - -smart: fpc_smart - -shared: fpc_shared - -showinstall: fpc_showinstall - -install: fpc_install - -sourceinstall: fpc_sourceinstall - -exampleinstall: fpc_exampleinstall - -zipinstall: fpc_zipinstall - -zipsourceinstall: fpc_zipsourceinstall - -zipexampleinstall: fpc_zipexampleinstall - -distclean: fpc_distclean - -cleanall: fpc_cleanall - -info: fpc_info - -.PHONY: all debug smart shared showinstall install sourceinstall exampleinstall zipinstall zipsourceinstall zipexampleinstall distclean cleanall info - -##################################################################### -# General compile rules -##################################################################### - -.PHONY: fpc_packages fpc_all fpc_debug - -$(FPCMADE): $(ALLTARGET) - @$(ECHO) Compiled > $(FPCMADE) - -fpc_packages: $(COMPILEPACKAGES) - -fpc_all: fpc_packages $(FPCMADE) - -fpc_debug: - $(MAKE) all DEBUG=1 - -# Search paths for .ppu if targetdir is set -ifdef UNITTARGETDIR -vpath %$(PPUEXT) $(UNITTARGETDIR) -endif - -# General compile rules, available for both possible PASEXT - -.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .pp - -%$(PPUEXT): %.pp - $(COMPILER) $< $(REDIR) - $(EXECPPAS) - -%$(PPUEXT): %.pas - $(COMPILER) $< $(REDIR) - $(EXECPPAS) - -%$(EXEEXT): %.pp - $(COMPILER) $< $(REDIR) - $(EXECPPAS) - -%$(EXEEXT): %.pas - $(COMPILER) $< $(REDIR) - $(EXECPPAS) - -##################################################################### -# Library -##################################################################### - -.PHONY: fpc_smart fpc_shared - -ifdef LIBVERSION -LIBFULLNAME=$(LIBNAME).$(LIBVERSION) -else -LIBFULLNAME=$(LIBNAME) -endif - -# Default sharedlib units are all unit objects -ifndef SHAREDLIBUNITOBJECTS -SHAREDLIBUNITOBJECTS:=$(UNITOBJECTS) -endif - -fpc_smart: - $(MAKE) all LINKSMART=1 CREATESMART=1 - -fpc_shared: all -ifdef HASSHAREDLIB -ifndef LIBNAME - @$(ECHO) "LIBNAME not set" -else - $(PPUMOVE) $(SHAREDLIBUNITOBJECTS) -o$(LIBFULLNAME) -endif -else - @$(ECHO) "Shared Libraries not supported" -endif - -##################################################################### -# Install rules -##################################################################### - -.PHONY: fpc_showinstall fpc_install - -ifdef EXTRAINSTALLUNITS -override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRAINSTALLUNITS)) -endif - -ifdef INSTALLPPUFILES -override INSTALLPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(INSTALLPPUFILES)) -ifdef PPUFILES -INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES)) -else -INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES)))) -endif -override INSTALLPPULINKFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(INSTALLPPULINKFILES)) -endif - -ifdef INSTALLEXEFILES -override INSTALLEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(INSTALLEXEFILES)) -endif - -fpc_showinstall: $(SHOWINSTALLTARGET) -ifdef INSTALLEXEFILES - @$(ECHO) -e $(addprefix "\n"$(BININSTALLDIR)/,$(INSTALLEXEFILES)) -endif -ifdef INSTALLPPUFILES - @$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPUFILES)) -ifneq ($(INSTALLPPULINKFILES),) - @$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPULINKFILES)) -endif -ifneq ($(wildcard $(LIBFULLNAME)),) - @$(ECHO) $(LIBINSTALLDIR)/$(LIBFULLNAME) -ifdef HASSHAREDLIB - @$(ECHO) $(LIBINSTALLDIR)/$(LIBNAME) -endif -endif -endif -ifdef EXTRAINSTALLFILES - @$(ECHO) -e $(addprefix "\n"$(DATAINSTALLDIR)/,$(EXTRAINSTALLFILES)) -endif - -fpc_install: $(INSTALLTARGET) -# Create UnitInstallFiles -ifdef INSTALLEXEFILES - $(MKDIR) $(BININSTALLDIR) -# Compress the exes if upx is defined -ifdef UPXPROG - -$(UPXPROG) $(INSTALLEXEFILES) -endif - $(INSTALLEXE) $(INSTALLEXEFILES) $(BININSTALLDIR) -endif -ifdef INSTALLPPUFILES - $(MKDIR) $(UNITINSTALLDIR) - $(INSTALL) $(INSTALLPPUFILES) $(UNITINSTALLDIR) -ifneq ($(INSTALLPPULINKFILES),) - $(INSTALL) $(INSTALLPPULINKFILES) $(UNITINSTALLDIR) -endif -ifneq ($(wildcard $(LIBFULLNAME)),) - $(MKDIR) $(LIBINSTALLDIR) - $(INSTALL) $(LIBFULLNAME) $(LIBINSTALLDIR) -ifdef inUnix - ln -sf $(LIBFULLNAME) $(LIBINSTALLDIR)/$(LIBNAME) -endif -endif -endif -ifdef EXTRAINSTALLFILES - $(MKDIR) $(DATAINSTALLDIR) - $(INSTALL) $(EXTRAINSTALLFILES) $(DATAINSTALLDIR) -endif - -##################################################################### -# SourceInstall rules -##################################################################### - -.PHONY: fpc_sourceinstall - -ifndef SOURCETOPDIR -SOURCETOPDIR=$(BASEDIR) -endif - -fpc_sourceinstall: clean - $(MKDIR) $(SOURCEINSTALLDIR) - $(COPYTREE) $(SOURCETOPDIR) $(SOURCEINSTALLDIR) - -##################################################################### -# exampleinstall rules -##################################################################### - -.PHONY: fpc_exampleinstall - -fpc_exampleinstall: $(addsuffix _clean,$(EXAMPLEDIROBJECTS)) -ifdef EXAMPLESOURCEFILES - $(MKDIR) $(EXAMPLEINSTALLDIR) - $(COPY) $(EXAMPLESOURCEFILES) $(EXAMPLEINSTALLDIR) -endif -ifdef EXAMPLEDIROBJECTS -ifndef EXAMPLESOURCEFILES - $(MKDIR) $(EXAMPLEINSTALLDIR) -endif - $(COPYTREE) $(addsuffix /*,$(EXAMPLEDIROBJECTS)) $(EXAMPLEINSTALLDIR) -endif - -##################################################################### -# Zip -##################################################################### - -.PHONY: fpc_zipinstall - -# Create suffix to add -ifndef PACKAGESUFFIX -PACKAGESUFFIX=$(OS_TARGET) -ifeq ($(OS_TARGET),go32v2) -PACKAGESUFFIX=go32 -endif -ifeq ($(OS_TARGET),win32) -PACKAGESUFFIX=w32 -endif -endif - -# Temporary path to pack a file -ifndef PACKDIR -ifndef inUnix -PACKDIR=$(BASEDIR)/pack_tmp -else -PACKDIR=/tmp/fpc-pack -endif -endif - -# Maybe create default zipname from packagename -ifndef ZIPNAME -ifdef PACKAGENAME -ZIPNAME=$(PACKAGEPREFIX)$(PACKAGENAME)$(PACKAGESUFFIX) -endif -endif - -# Use tar by default under linux -ifndef USEZIP -ifdef inUnix -USETAR=1 -endif -endif - -fpc_zipinstall: -ifndef ZIPNAME - @$(ECHO) "Please specify ZIPNAME!" - @exit 1 -else - $(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR) -ifdef USETAR - $(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT) - cd $(PACKDIR) ; $(TARPROG) cf$(TAROPT) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT) * ; cd $(BASEDIR) -else - $(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT) - cd $(PACKDIR) ; $(ZIPPROG) -Dr $(ZIPOPT) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT) * ; cd $(BASEDIR) -endif - $(DELTREE) $(PACKDIR) -endif - -.PHONY: fpc_zipsourceinstall - -fpc_zipsourceinstall: - $(MAKE) fpc_zipinstall ZIPTARGET=sourceinstall PACKAGESUFFIX=src - -.PHONY: fpc_zipexampleinstall - -fpc_zipexampleinstall: - $(MAKE) fpc_zipinstall ZIPTARGET=exampleinstall PACKAGESUFFIX=exm - -##################################################################### -# Clean rules -##################################################################### - -.PHONY: fpc_clean fpc_cleanall fpc_distclean - -ifdef EXEFILES -override CLEANEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(CLEANEXEFILES)) -endif - -ifdef EXTRACLEANUNITS -override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRACLEANUNITS)) -endif - -ifdef CLEANPPUFILES -override CLEANPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPUFILES)) -# Get the .o and .a files created for the units -ifdef PPUFILES -CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES)) -else -CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES)))) -endif -override CLEANPPULINKFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPULINKFILES)) -endif - -fpc_clean: $(CLEANTARGET) -ifdef CLEANEXEFILES - -$(DEL) $(CLEANEXEFILES) -endif -ifdef CLEANPPUFILES - -$(DEL) $(CLEANPPUFILES) -endif -ifneq ($(CLEANPPULINKFILES),) - -$(DEL) $(CLEANPPULINKFILES) -endif -ifdef CLEANRSTFILES - -$(DEL) $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANRSTFILES)) -endif -ifdef EXTRACLEANFILES - -$(DEL) $(EXTRACLEANFILES) -endif -ifdef LIBNAME - -$(DEL) $(LIBNAME) $(LIBFULLNAME) -endif - -$(DEL) $(FPCMADE) $(PPAS) link.res $(FPCEXTFILE) $(REDIRFILE) - -fpc_distclean: fpc_clean - -# Also run clean first if targetdir is set. Unittargetdir is always -# set if targetdir or unittargetdir is specified -ifdef UNITTARGETDIR -TARGETDIRCLEAN=fpc_clean -endif - -fpc_cleanall: $(CLEANTARGET) $(TARGETDIRCLEAN) -ifdef CLEANEXEFILES - -$(DEL) $(CLEANEXEFILES) -endif - -$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT) - -$(DELTREE) *$(SMARTEXT) - -$(DEL) $(FPCMADE) $(PPAS) link.res $(FPCEXTFILE) $(REDIRFILE) - -##################################################################### -# Info rules -##################################################################### - -.PHONY: fpc_info fpc_cfginfo fpc_objectinfo fpc_toolsinfo fpc_installinfo \ - fpc_dirinfo - -fpc_info: $(INFOTARGET) - -fpc_infocfg: - @$(ECHO) - @$(ECHO) == Configuration info == - @$(ECHO) - @$(ECHO) FPC....... $(FPC) - @$(ECHO) Version... $(FPC_VERSION) - @$(ECHO) CPU....... $(CPU_TARGET) - @$(ECHO) Source.... $(OS_SOURCE) - @$(ECHO) Target.... $(OS_TARGET) - @$(ECHO) - -fpc_infoobjects: - @$(ECHO) - @$(ECHO) == Object info == - @$(ECHO) - @$(ECHO) LoaderObjects..... $(LOADEROBJECTS) - @$(ECHO) UnitObjects....... $(UNITOBJECTS) - @$(ECHO) ExeObjects........ $(EXEOBJECTS) - @$(ECHO) - @$(ECHO) ExtraCleanUnits... $(EXTRACLEANUNITS) - @$(ECHO) ExtraCleanFiles... $(EXTRACLEANFILES) - @$(ECHO) - @$(ECHO) ExtraInstallUnits. $(EXTRAINSTALLUNITS) - @$(ECHO) ExtraInstallFiles. $(EXTRAINSTALLFILES) - @$(ECHO) - -fpc_infoinstall: - @$(ECHO) - @$(ECHO) == Install info == - @$(ECHO) -ifdef DATE - @$(ECHO) DateStr.............. $(DATESTR) -endif -ifdef PACKAGEPREFIX - @$(ECHO) PackagePrefix........ $(PACKAGEPREFIX) -endif -ifdef PACKAGENAME - @$(ECHO) PackageName.......... $(PACKAGENAME) -endif - @$(ECHO) PackageSuffix........ $(PACKAGESUFFIX) - @$(ECHO) - @$(ECHO) BaseInstallDir....... $(BASEINSTALLDIR) - @$(ECHO) BinInstallDir........ $(BININSTALLDIR) - @$(ECHO) LibInstallDir........ $(LIBINSTALLDIR) - @$(ECHO) UnitInstallDir....... $(UNITINSTALLDIR) - @$(ECHO) SourceInstallDir..... $(SOURCEINSTALLDIR) - @$(ECHO) DocInstallDir........ $(DOCINSTALLDIR) - @$(ECHO) DataInstallDir....... $(DATAINSTALLDIR) - @$(ECHO) - @$(ECHO) DestZipDir........... $(DESTZIPDIR) - @$(ECHO) ZipName.............. $(ZIPNAME) - @$(ECHO) - -##################################################################### -# Local Makefile -##################################################################### - -ifneq ($(wildcard fpcmake.loc),) -include fpcmake.loc -endif - -##################################################################### -# Users rules -##################################################################### - - -.PHONY= current go32v2_units linux_units os2_units win32_units clean - -current : $(OS_TARGET)_units - -go32v2_units : - $(MAKE) clean OS_TARGET=go32v2 - $(MAKE) -C ../../rtl/go32v2 clean all OS_TARGET=go32v2 - -$(COPY) ../../rtl/go32v2/*.o . - -$(COPY) ../../rtl/go32v2/*.a . - -$(COPY) ../../rtl/go32v2/*.ppu . - $(MAKE) -C ../../fcl/go32v2 clean all OS_TARGET=go32v2 - -$(COPY) ../../fcl/go32v2/*.o . - -$(COPY) ../../fcl/go32v2/*.a . - -$(COPY) ../../fcl/go32v2/*.ppu . - -linux_units : - $(MAKE) clean OS_TARGET=linux - $(MAKE) -C ../../rtl/linux clean all OS_TARGET=linux - -$(COPY) ../../rtl/linux/*.o . - -$(COPY) ../../rtl/linux/*.a . - -$(COPY) ../../rtl/linux/*.ppu . - $(MAKE) -C ../../fcl/linux clean all OS_TARGET=linux - -$(COPY) ../../fcl/linux/*.o . - -$(COPY) ../../fcl/linux/*.a . - -$(COPY) ../../fcl/linux/*.ppu . - -os2_units : - $(MAKE) clean OS_TARGET=os2 - $(MAKE) -C ../../rtl/os2 clean all OS_TARGET=os2 - -$(COPY) ../../rtl/os2/*.oo2 . - -$(COPY) ../../rtl/os2/*.ao2 . - -$(COPY) ../../rtl/os2/*.ppo . - $(MAKE) -C ../../fcl/os2 clean all OS_TARGET=os2 - -$(COPY) ../../fcl/os2/*.oo2 . - -$(COPY) ../../fcl/os2/*.ao2 . - -$(COPY) ../../fcl/os2/*.ppo . - -win32_units : - $(MAKE) clean OS_TARGET=win32 - $(MAKE) -C ../../rtl/win32 clean all OS_TARGET=win32 - -$(COPY) ../../rtl/win32/*.ow . - -$(COPY) ../../rtl/win32/*.aw . - -$(COPY) ../../rtl/win32/*.ppw . - $(MAKE) -C ../../fcl/win32 clean all OS_TARGET=win32 - -$(COPY) ../../fcl/win32/*.ow . - -$(COPY) ../../fcl/win32/*.aw . - -$(COPY) ../../fcl/win32/*.ppw . - -clean : - -$(RM) *$(OEXT) - -$(RM) *$(PPUEXT) - -$(RM) *$(STATICLIBEXT) diff --git a/tests/units/Makefile.fpc b/tests/units/Makefile.fpc deleted file mode 100644 index 5f9c31ab84..0000000000 --- a/tests/units/Makefile.fpc +++ /dev/null @@ -1,63 +0,0 @@ -# -# Makefile.fpc to create and group units needed for -# tests for all targets -# - -[defaults] - -defaultrule=current - -[rules] - -.PHONY= current go32v2_units linux_units os2_units win32_units clean - -current : $(OS_TARGET)_units - -go32v2_units : - $(MAKE) clean OS_TARGET=go32v2 - $(MAKE) -C ../../rtl/go32v2 clean all OS_TARGET=go32v2 - -$(COPY) ../../rtl/go32v2/*.o . - -$(COPY) ../../rtl/go32v2/*.a . - -$(COPY) ../../rtl/go32v2/*.ppu . - $(MAKE) -C ../../fcl/go32v2 clean all OS_TARGET=go32v2 - -$(COPY) ../../fcl/go32v2/*.o . - -$(COPY) ../../fcl/go32v2/*.a . - -$(COPY) ../../fcl/go32v2/*.ppu . - -linux_units : - $(MAKE) clean OS_TARGET=linux - $(MAKE) -C ../../rtl/linux clean all OS_TARGET=linux - -$(COPY) ../../rtl/linux/*.o . - -$(COPY) ../../rtl/linux/*.a . - -$(COPY) ../../rtl/linux/*.ppu . - $(MAKE) -C ../../fcl/linux clean all OS_TARGET=linux - -$(COPY) ../../fcl/linux/*.o . - -$(COPY) ../../fcl/linux/*.a . - -$(COPY) ../../fcl/linux/*.ppu . - -os2_units : - $(MAKE) clean OS_TARGET=os2 - $(MAKE) -C ../../rtl/os2 clean all OS_TARGET=os2 - -$(COPY) ../../rtl/os2/*.oo2 . - -$(COPY) ../../rtl/os2/*.ao2 . - -$(COPY) ../../rtl/os2/*.ppo . - $(MAKE) -C ../../fcl/os2 clean all OS_TARGET=os2 - -$(COPY) ../../fcl/os2/*.oo2 . - -$(COPY) ../../fcl/os2/*.ao2 . - -$(COPY) ../../fcl/os2/*.ppo . - -win32_units : - $(MAKE) clean OS_TARGET=win32 - $(MAKE) -C ../../rtl/win32 clean all OS_TARGET=win32 - -$(COPY) ../../rtl/win32/*.ow . - -$(COPY) ../../rtl/win32/*.aw . - -$(COPY) ../../rtl/win32/*.ppw . - $(MAKE) -C ../../fcl/win32 clean all OS_TARGET=win32 - -$(COPY) ../../fcl/win32/*.ow . - -$(COPY) ../../fcl/win32/*.aw . - -$(COPY) ../../fcl/win32/*.ppw . - -clean : - -$(RM) *$(OEXT) - -$(RM) *$(PPUEXT) - -$(RM) *$(STATICLIBEXT) \ No newline at end of file diff --git a/tests/webtbf/bug856u.pp b/tests/webtbf/bug856u.pp deleted file mode 100644 index b6e81489fb..0000000000 --- a/tests/webtbf/bug856u.pp +++ /dev/null @@ -1,16 +0,0 @@ -{$MODE objfpc} -unit bug856u; -interface -type - TMyClass = class - protected - constructor Create(x: Integer); - end; - -implementation - -constructor TMyClass.Create(x: Integer); -begin -end; - -end. \ No newline at end of file diff --git a/tests/webtbf/tb1157a.pp b/tests/webtbf/tb1157a.pp deleted file mode 100644 index 3472ecc147..0000000000 --- a/tests/webtbf/tb1157a.pp +++ /dev/null @@ -1,41 +0,0 @@ -{ Source provided for Free Pascal Bug Report 1157 } -{ Submitted by "Colin Goldie" on 2000-10-06 } -{ e-mail: Colin_G@Positek.com.au } - -{$mode tp} - -{$asmmode intel} - -{ @Result in assembler functions where - the function result is not on stack - should be refused in Turbo Pascal mode } - -Function GetBLUEfromRGB( color : word ) : byte; assembler; -asm - mov cx,color - and cx,0000000000011111b - mov @Result,cl -end; - -{ -Does something weird .. to the stack im guessing ... error 206 and 103 -errors occur 'File not open' ... - -However, if instead of using @Result , i chuck my return value into the -accumulator register , everything thing works hunky dory. -} - -Function GetBLUEfromRGB2( color : word ) : byte; assembler; -asm - mov cx,color - and cx,0000000000011111b - mov al,cl -end; - -begin - if GetBlueFromRGB2($fff)<>GetBlueFromRGB($fff) then - begin - Writeln('Error in assembler statement'); - Halt(1); - end; -end. diff --git a/tests/webtbf/tbug1157.pp b/tests/webtbf/tbug1157.pp deleted file mode 100644 index cc63909463..0000000000 --- a/tests/webtbf/tbug1157.pp +++ /dev/null @@ -1,41 +0,0 @@ -{ Source provided for Free Pascal Bug Report 1157 } -{ Submitted by "Colin Goldie" on 2000-10-06 } -{ e-mail: Colin_G@Positek.com.au } - -{$mode delphi} - -{$asmmode intel} - -{ @Result in assembler functions where - the function result is not on stack - should be refused in Delphi mode } - -Function GetBLUEfromRGB( color : word ) : byte; assembler; -asm - mov cx,color - and cx,0000000000011111b - mov @Result,cl -end; - -{ -Does something weird .. to the stack im guessing ... error 206 and 103 -errors occur 'File not open' ... - -However, if instead of using @Result , i chuck my return value into the -accumulator register , everything thing works hunky dory. -} - -Function GetBLUEfromRGB2( color : word ) : byte; assembler; -asm - mov cx,color - and cx,0000000000011111b - mov al,cl -end; - -begin - if GetBlueFromRGB2($fff)<>GetBlueFromRGB($fff) then - begin - Writeln('Error in assembler statement'); - Halt(1); - end; -end. diff --git a/tests/webtbf/tbug1238.pp b/tests/webtbf/tbug1238.pp deleted file mode 100644 index 7e948d32a6..0000000000 --- a/tests/webtbf/tbug1238.pp +++ /dev/null @@ -1,23 +0,0 @@ -{ Source provided for Free Pascal Bug Report 1238 } -{ Submitted by "Mazen NEIFER" on 2000-11-14 } -{ e-mail: mazen_neifer@ayna.com } -PROGRAM Concat; -VAR - InputFile,OutputFile:File; - c:Char; - Buffer:Array[DWord]OF Byte; - ReadCount,WriteCount:DWord; -BEGIN - Assign(OutputFile,'Maple.tar.gz'); - ReWrite(OutputFile,1); - FOR c:='a' TO 'n' DO - BEGIN - Assign(InputFile,'xa'+c); - Reset(InputFile,1); - BlockRead(InputFile,Buffer,SizeOf(Buffer),ReadCount); - BlockWrite(OutputFile,Buffer,SizeOf(Buffer),WriteCount); - Close(InputFile); - END; - Close(OutputFile); -END. - diff --git a/tests/webtbf/tbug744.pp b/tests/webtbf/tbug744.pp deleted file mode 100644 index 62af7cc84b..0000000000 --- a/tests/webtbf/tbug744.pp +++ /dev/null @@ -1,9 +0,0 @@ -Unit tbug744; - -Interface - -Uses tbug744a; - -Implementation - -end. diff --git a/tests/webtbf/tbug744a.pp b/tests/webtbf/tbug744a.pp deleted file mode 100644 index ae38115e7f..0000000000 --- a/tests/webtbf/tbug744a.pp +++ /dev/null @@ -1,10 +0,0 @@ -Unit tbug744a; - -Interface - -Uses tbug744; - -Implementation - -end. - diff --git a/tests/webtbf/tbug784.pp b/tests/webtbf/tbug784.pp deleted file mode 100644 index ba6f9d61cf..0000000000 --- a/tests/webtbf/tbug784.pp +++ /dev/null @@ -1,27 +0,0 @@ -{$R+} -{ should not compile if range check on } -program BigRange; - -const - Limit = 100000000; { Hundred millions } - One = 1; - -var - Huge: longint; - -begin - Huge := Limit + One; - - writeln(One, ' is the lower bound'); - writeln(Limit, ' is the upper bound'); - - if Limit in [One .. Limit] then - writeln(Limit, ' is within the range') - else - writeln(Limit, ' is out of the range'); - - if Huge in [One .. Limit] then - writeln(Huge, ' is within the range') - else - writeln(Huge, ' is out of the range') -end. diff --git a/tests/webtbf/tbug807.pp b/tests/webtbf/tbug807.pp deleted file mode 100644 index e0d3cdc10b..0000000000 --- a/tests/webtbf/tbug807.pp +++ /dev/null @@ -1,52 +0,0 @@ -{$mode objfpc} - -Program test; - -uses crt; - -type - TMatrix = class - Constructor Create; - private - Elements : array [1..10,1..10] of real; - end; - -Constructor TMatrix.Create; - -begin -end; - -OPERATOR :=(r:Real):TMatrix; - BEGIN - WITH RESULT DO - BEGIN -{ Do something } - END; - writeln ('Call to overloaded operator :=, real operand'); - END; -operator :=(m : TMatrix):TMatrix; - BEGIN - WITH RESULT DO - BEGIN -{ Do something } - END; - writeln ('Call to overloaded operator :=, matrix operand'); - END; - -var - m : TMatrix; - m2 : TMatrix; - -begin - clrscr; - writeln ('Performing calculations...'); - m:=TMatrix.Create; - m2:=TMatrix.Create; - writeln ('Assigning real to matrix...'); -{ This one works } - m:=1; - writeln ('Assigning matrix to matrix...'); -{ This one does not work } - m:=m2; - writeln ('Done.'); -end. \ No newline at end of file diff --git a/tests/webtbf/tbug856.pp b/tests/webtbf/tbug856.pp deleted file mode 100644 index 02429eff72..0000000000 --- a/tests/webtbf/tbug856.pp +++ /dev/null @@ -1,7 +0,0 @@ -{$MODE objfpc} -uses - bug856u; - -begin - TMyClass.Create(1); -end. \ No newline at end of file diff --git a/tests/webtbf/tbug890.pp b/tests/webtbf/tbug890.pp deleted file mode 100644 index 0de365d363..0000000000 --- a/tests/webtbf/tbug890.pp +++ /dev/null @@ -1,19 +0,0 @@ -{$ifdef FPC} - {$MODE TP} -{$endif FPC} - -unit tbug890; - -INTERFACE - -procedure GetScreenLine(const x: Integer); - -IMPLEMENTATION - - -procedure GetScreenLine(x: Integer); -begin -end; - -begin -end. \ No newline at end of file diff --git a/tests/webtbf/tbug896.pp b/tests/webtbf/tbug896.pp deleted file mode 100644 index 95a8bdb285..0000000000 --- a/tests/webtbf/tbug896.pp +++ /dev/null @@ -1,16 +0,0 @@ - -var - dat : file; - j : longint; - Buffer : Array[0..2047] of byte; - -begin - for j:=0 to 2047 do - Buffer[j]:=j and $ff; - Assign(dat,'tbug896.txt'); - Rewrite(dat,1); - for j:= 0 to 2047 do - { write should not be allowed for untyped files } - write (dat,Buffer[j]); - Close(dat); -end. \ No newline at end of file diff --git a/tests/webtbf/tbug896a.pp b/tests/webtbf/tbug896a.pp deleted file mode 100644 index 602e63086e..0000000000 --- a/tests/webtbf/tbug896a.pp +++ /dev/null @@ -1,16 +0,0 @@ - -var - dat : file of byte; - j : longint; - Buffer : Array[0..2047] of byte; - -begin - for j:=0 to 2047 do - Buffer[j]:=j and $ff; - Assign(dat,'tbug896.txt'); - Rewrite(dat,1); - for j:= 0 to 2047 do - { writeln should not be allowed for typed files } - writeln (dat,Buffer[j]); - Close(dat); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug1021.pp b/tests/webtbs/tbug1021.pp deleted file mode 100644 index d598abe6f2..0000000000 --- a/tests/webtbs/tbug1021.pp +++ /dev/null @@ -1,55 +0,0 @@ -{ Source provided for Free Pascal Bug Report 1021 } -{ Submitted by "Oliver Puetz" on 2000-07-03 } -{ e-mail: Oliver.Puetz@gmx.de } -{ - Free Pascal Compiler version 0.99.15 [2000/03/30] for i386 - Copyright (c) 1993-2000 by Florian Klaempfl - Win NT 4.0 Fixpak 2 - - With TFloat = EXTENDED Writeln resumes 0.0 0.0 1 - With TFloat = DOUBLE Writeln resumes 0.0 1.0 1 - - Thus only the write-command seems not to transfer the extended a equals 1 - to a string like '1' -} - -type tfloat = extended; - -var a, b : tfloat; - i : INTEGER; - f : text; -begin - case sizeof(tfloat) of - 4: writeln('single'); - 8: writeln('double'); - 10: writeln('extended'); - else writeln(sizeof(tfloat)); - end; - a := 0; - b := 1 - a; - i := Round(b); - writeln(a:30:20, b:30:20, i:10); - assign(f,'tbug1021.txt'); - rewrite(f); - writeln(f,a:30:20,' ',b:30:20,' ',i:10); - close(f); - reset(f); - read(f,a); - read(f,b); - read(f,i); - if (a<>0.0) then - begin - Writeln('Error reading A value, should be zero'); - Halt(1); - end; - if (b<>1.0) then - begin - Writeln('Error reading B value, should be one'); - Halt(1); - end; - if (i<>1) then - begin - Writeln('Error reading I value, should be one'); - Halt(1); - end; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug1023.pp b/tests/webtbs/tbug1023.pp deleted file mode 100644 index 8d41755c3e..0000000000 --- a/tests/webtbs/tbug1023.pp +++ /dev/null @@ -1,29 +0,0 @@ -{ Source provided for Free Pascal Bug Report 1023 } -{ Submitted by "Denis Yarkovoy" on 2000-07-03 } -{ e-mail: gunky9@geocities.com } - {$goto on} - {$i386_intel} - label l1; - -var - pp : pointer; - - procedure p1; assembler; asm - mov eax, offset l1 - lea edi,pp - mov dword ptr [edi],eax - end; - - procedure p; assembler; asm - l1: - clc - end; - -begin - pp:=nil; - p1; - if pp=nil then - halt(1) - else - Writeln('Bug 1023 fixed'); -end. diff --git a/tests/webtbs/tbug1041.pp b/tests/webtbs/tbug1041.pp deleted file mode 100644 index 49148609fd..0000000000 --- a/tests/webtbs/tbug1041.pp +++ /dev/null @@ -1,14 +0,0 @@ -uses - sysutils,dos; - -begin -Writeln('Dos DiskSize = ',Dos.DiskSize(0)); -Writeln('Sysutils DiskSize = ',SysUtils.DiskSize(0)); -Writeln('Dos DiskFree = ',Dos.DiskFree(0)); -Writeln('Sysutils DiskFree = ',SysUtils.DiskFree(0)); -if Dos.DiskSize(0)<>SysUtils.DiskSize(0) then - Begin - Writeln('Error with DiskSize'); - Halt(1); - End; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug1046.pp b/tests/webtbs/tbug1046.pp deleted file mode 100644 index 0f83838ee5..0000000000 --- a/tests/webtbs/tbug1046.pp +++ /dev/null @@ -1,8 +0,0 @@ -procedure test2(self : longint); -begin - writeln(self); -end; - -begin - test2(1); -end. diff --git a/tests/webtbs/tbug1061.pp b/tests/webtbs/tbug1061.pp deleted file mode 100644 index 14b225848e..0000000000 --- a/tests/webtbs/tbug1061.pp +++ /dev/null @@ -1,12 +0,0 @@ -var vlCnt:longint; -begin - vlCnt := 10; - case vlCnt of - 7: writeln(7); - 12,13: begin - writeln('Case codegeneration error!'); - halt(1); - end; - 11:writeln(11); - end; -end. diff --git a/tests/webtbs/tbug1066a.pp b/tests/webtbs/tbug1066a.pp deleted file mode 100644 index 03ab923fab..0000000000 --- a/tests/webtbs/tbug1066a.pp +++ /dev/null @@ -1,119 +0,0 @@ -{ Source provided for Free Pascal Bug Report 1066 } -{ Submitted by "Fernando Oscar Schmitt" on 2000-07-24 } -{ e-mail: pulp@cpovo.net } - -var - somevar:longint; - -{$asmmode intel} -{$inline on} - -procedure putpixel(x,y,color:longint);assembler;inline; -asm -mov edi,x -mov eax,y -cmp edi,0 -jl @@putpixelend -cmp eax,0 -jl @@putpixelend -cmp edi,1023 -jg @@putpixelend -cmp eax,767 -jg @@putpixelend -shl eax,12 -mov ebx,color -add eax,somevar -mov [eax+edi*4],ebx -@@putpixelend: -end ['eax','ebx','edi']; - - -procedure pixelrow(y,x1,x2,color:longint);assembler;inline; -asm -mov edi,x1 -mov ecx,x2 -mov eax,y -cmp edi,ecx -jle @@pixelrowdirok -xchg edi,ecx -@@pixelrowdirok: -cmp eax,0 -jl @@endpixelrow -cmp eax,767 -jg @@endpixelrow -cmp ecx,0 -jl @@endpixelrow -cmp edi,1023 -jg @@endpixelrow -cmp edi,0 -jge @@pixelrowx1ok -mov edi,0 -@@pixelrowx1ok: -cmp ecx,1023 -jle @@pixelrowx2ok -mov ecx,1023 -@@pixelrowx2ok: -sub ecx,edi -shl eax,12 -inc ecx -add eax,somevar -cld -lea edi,[eax+4*edi] -mov eax,color -rep stosd -@@endpixelrow: -end ['eax','ecx','edi']; - - -function str(w:word):string; -var tmp:string; -begin -system.str(w,tmp); -str:=tmp; -end; - -function str(l:longint):string; -var tmp:string; -begin -system.str(l,tmp); -str:=tmp; -end; - - -procedure circle(x0,y0,r,color:longint); -var x,y:longint; -begin -for x:=0 to trunc(r*(sqrt(2)/2))+1 do - begin - y:=round(sqrt(r*r-x*x)); - putpixel(x0+x,y0+y,color); - putpixel(x0-x,y0+y,color); - putpixel(x0+x,y0-y,color); - putpixel(x0-x,y0-y,color); - putpixel(x0+y,y0+x,color); - putpixel(x0-y,y0+x,color); - putpixel(x0+y,y0-x,color); - putpixel(x0-y,y0-x,color); - end; -end; - - -procedure circlefill(x0,y0,r,color:longint); -var x,y:longint; -begin -for x:=0 to trunc(r*(sqrt(2)/2))+1 do - begin - y:=round(sqrt(r*r-x*x)); - pixelrow(y0+y,x0-x,x0+x,color); - pixelrow(y0-y,x0-x,x0+x,color); - pixelrow(y0+x,x0-y,x0+y,color); - pixelrow(y0-x,x0-y,x0+y,color); - end; -end; - - -begin - -end. - - diff --git a/tests/webtbs/tbug1066b.pp b/tests/webtbs/tbug1066b.pp deleted file mode 100644 index 6bc1e83fa5..0000000000 --- a/tests/webtbs/tbug1066b.pp +++ /dev/null @@ -1,117 +0,0 @@ -{----------------cut here----------------} - -{$asmmode intel} -{$inline on} - -var - somevar:longint; - - -procedure wastememory(x,y,color:longint);assembler;inline; -asm -mov edi,x -mov eax,y -cmp edi,0 -jl @@wastememoryend -cmp eax,0 -jl @@wastememoryend -cmp edi,1023 -jg @@wastememoryend -cmp eax,767 -jg @@wastememoryend -shl eax,12 -mov ebx,color -add eax,somevar -mov [eax+edi*4],ebx -@@wastememoryend: -end ['eax','ebx','edi']; - - -procedure wastememory2(y,x1,x2,color:longint);assembler;inline; -asm -mov edi,x1 -mov ecx,x2 -mov eax,y -cmp edi,ecx -jle @@wastememory2dirok -xchg edi,ecx -@@wastememory2dirok: -cmp eax,0 -jl @@endwastememory2 -cmp eax,767 -jg @@endwastememory2 -cmp ecx,0 -jl @@endwastememory2 -cmp edi,1023 -jg @@endwastememory2 -cmp edi,0 -jge @@wastememory2x1ok -mov edi,0 -@@wastememory2x1ok: -cmp ecx,1023 -jle @@wastememory2x2ok -mov ecx,1023 -@@wastememory2x2ok: -sub ecx,edi -shl eax,12 -inc ecx -add eax,somevar -cld -lea edi,[eax+4*edi] -mov eax,color -rep stosd -@@endwastememory2: -end ['eax','ecx','edi']; - - -function str(w:word):string; -var tmp:string; -begin -system.str(w,tmp); -str:=tmp; -end; - -function str(l:longint):string; -var tmp:string; -begin -system.str(l,tmp); -str:=tmp; -end; - - -procedure testcompiler(x0,y0,r,color:longint); -var x,y:longint; -begin -for x:=0 to trunc(r*(sqrt(2)/2))+1 do - begin - y:=round(sqrt(r*r-x*x)); - wastememory(x0+x,y0+y,color); - wastememory(x0-x,y0+y,color); - wastememory(x0+x,y0-y,color); - wastememory(x0-x,y0-y,color); - wastememory(x0+y,y0+x,color); - wastememory(x0-y,y0+x,color); - wastememory(x0+y,y0-x,color); - wastememory(x0-y,y0-x,color); - end; -end; - - -procedure testcompiler2(x0,y0,r,color:longint); -var x,y:longint; -begin -for x:=0 to trunc(r*(sqrt(2)/2))+1 do - begin - y:=round(sqrt(r*r-x*x)); - wastememory2(y0+y,x0-x,x0+x,color); - wastememory2(y0-y,x0-x,x0+x,color); - wastememory2(y0+x,x0-y,x0+y,color); - wastememory2(y0-x,x0-y,x0+y,color); - end; -end; - - -begin - -end. - diff --git a/tests/webtbs/tbug1068.pp b/tests/webtbs/tbug1068.pp deleted file mode 100644 index 01c6c16fea..0000000000 --- a/tests/webtbs/tbug1068.pp +++ /dev/null @@ -1,14 +0,0 @@ -PROGRAM bug1068; -VAR i: INT64; - s : string; -BEGIN - i:=2147483648; - str(i,s); - if s<>'2147483648' then - begin - writeln(s); - halt(1); - end - else - halt(0); -END. diff --git a/tests/webtbs/tbug1071.pp b/tests/webtbs/tbug1071.pp deleted file mode 100644 index 5eb1584f43..0000000000 --- a/tests/webtbs/tbug1071.pp +++ /dev/null @@ -1,38 +0,0 @@ -var i: int64; - il: longint; - -begin - for il:=-20 to 20 do - begin - i:=il; - case i of - -3: - if (i<>-3) then - halt(1); - -7..-5: - if (i<-7) or (i>-5) then - halt(1); - -9..-8: - if (i<-9) or (i>-8) then - halt(1); - 0: - if (i<>0) then - halt(1); - 1: - if (i<>1) then - halt(1); - 2: - if (i<>2) then - halt(1); - 3..6: - if (i<3) or (i>6) then - halt(1); - 8..10: - if (i<8) or (i>10) then - halt(1); - end; - end; - halt(0); -end. - - diff --git a/tests/webtbs/tbug1073.pp b/tests/webtbs/tbug1073.pp deleted file mode 100644 index a873c891a5..0000000000 --- a/tests/webtbs/tbug1073.pp +++ /dev/null @@ -1,43 +0,0 @@ - -type Char4=array[1..4] of char; - T1=packed record - A1:Char4; - A2:Char4; - A3:Char4; - end; - PT2=^T2; - T2=record - B1:T1; - B2:Char4; - B3:longint; - end; - T3=record - C1:Char4; - end; - -var S1,S2:String; - -procedure trifich(P1,P2,P3:string; P4:boolean); -begin - if P4 then WriteLn(P2+P3+'IN '+P1); -end; - -var V1:PT2; - V2:T3; -begin - new(V1); - s1 := 'abc'; - s2 := 'def'; - with v1^ do - begin - b1.a1 := '1234'; - b1.a2 := '5678'; - b1.a3 := 'ghij'; - b2 := '0000'; - b3 := longint(char4('9999')); - end; - v2.c1 := 'wxyz'; - TriFich(S1+S2, - V1^.B1.A1+V1^.B1.A2+V1^.B1.A3+V1^.B2+Char4(V1^.B3)+#13#10, - V1^.B1.A1+V1^.B1.A2+V1^.B1.A3+V2.C1+Char4(V1^.B3)+#13#10,true); -end. diff --git a/tests/webtbs/tbug1081.pp b/tests/webtbs/tbug1081.pp deleted file mode 100644 index fb1b4f0cee..0000000000 --- a/tests/webtbs/tbug1081.pp +++ /dev/null @@ -1,41 +0,0 @@ -uses dos; -var dirinfo:searchrec; - -function IntToStr(I: Longint): String; -{ Convert any integer type to a string } -var - S: string[11]; -begin - Str(I, S); - IntToStr := S; -end; - -procedure write_error(errorstring:string); -var -h,m,s,j,mo,ta,dummy:word; -stri:string; -begin - gettime(h,m,s,dummy); - getdate(j,mo,ta,dummy); - stri:=inttostr(j)+':'+inttostr(mo)+':'+inttostr(ta)+' '+inttostr(h)+':'+inttostr(m)+':'+inttostr(s); - writeln(stri,' ',errorstring); -end; - -procedure readprgfiles; -var i:word; -begin - FindFirst('*.pp',anyfile, DirInfo); - while doserror = 0 do - begin - inc(i); - writeln(dirinfo.name); - write_error(dirinfo.name); {without this function the program works} - FindNext(DirInfo); - end; - write_error('fertig'); -end; - - -BEGIN -readprgfiles; -END. diff --git a/tests/webtbs/tbug1090.pp b/tests/webtbs/tbug1090.pp deleted file mode 100644 index 8f6978e72f..0000000000 --- a/tests/webtbs/tbug1090.pp +++ /dev/null @@ -1,17 +0,0 @@ -{$asmmode intel} -const - Number = $7FFFFFF; - Shift = 7; -var - l : longint; -begin - ASM - MOV EAX,(Number shr (Shift+3)) - mov l,eax - End; - if l<>131071 then - begin - writeln('error in constant eval in intel reader'); - halt(1); - end; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug1092.pp b/tests/webtbs/tbug1092.pp deleted file mode 100644 index 455c8254d6..0000000000 --- a/tests/webtbs/tbug1092.pp +++ /dev/null @@ -1,21 +0,0 @@ -PROGRAM tbug1092; -USES Dos; -const -{$Ifdef linux} - path='/etc'; -{$else} - path='c:\'; -{$endif} -var - t : text; -BEGIN - { create a file } - assign(t,'tbug1092.txt'); - rewrite(t); - close(t); - if FSearch('tbug1092.txt',path)<>'tbug1092.txt' then - begin - writeln('FSearch didn''t find file in the current dir!'); - halt(1); - end; -END. diff --git a/tests/webtbs/tbug1096.pp b/tests/webtbs/tbug1096.pp deleted file mode 100644 index 206c783bae..0000000000 --- a/tests/webtbs/tbug1096.pp +++ /dev/null @@ -1,24 +0,0 @@ -Program Test; -{$X-} - -Function TestFunc : Boolean; -var b : Boolean; -begin - TestFunc := True; - b := True; - if b then - begin - exit; - end; -end; - -begin - writeln(3 xor 1); - if TestFunc then - begin - writeln('Yo'); - end; -end. - - - diff --git a/tests/webtbs/tbug1097.pp b/tests/webtbs/tbug1097.pp deleted file mode 100644 index bd1cbd99bf..0000000000 --- a/tests/webtbs/tbug1097.pp +++ /dev/null @@ -1,26 +0,0 @@ -{$H+} - -type - Tsome = Record - One,Two,Three:String; - end; - -Procedure passhere(Some:TSome;onemore:String); -Begin -end; - -procedure fromhere; -Var - me:Tsome; -Begin - me.one:='blah'; - me.two:=''; - me.three:=''; - passhere(Me,'text some'); -end; - -begin - fromhere; -end. - - diff --git a/tests/webtbs/tbug1103.pp b/tests/webtbs/tbug1103.pp deleted file mode 100644 index e84690a7f3..0000000000 --- a/tests/webtbs/tbug1103.pp +++ /dev/null @@ -1,23 +0,0 @@ -{$MODE OBJFPC } -type - TestRec = record - fString : AnsiString; - fInt1 : Longint; - fInt2 : Longint; - fRetAddr : Longint; - end; - -function GetGroupInfo: TestRec; -begin - fillchar(Result, Sizeof(Result), 0); - Result.fRetAddr := 0; -end; - -function SelectGroup: TestRec; -begin - Result := GetGroupInfo; -end; - -begin - SelectGroup; -end. diff --git a/tests/webtbs/tbug1104.pp b/tests/webtbs/tbug1104.pp deleted file mode 100644 index 38c490bfe0..0000000000 --- a/tests/webtbs/tbug1104.pp +++ /dev/null @@ -1,14 +0,0 @@ -var - r1,r2 : extended; - code : integer; -begin - val('.',r1,code); - if r1<>0.0 then - writeln('error with val(".")'); - val('.E',r2,code); - if r2<>0.0 then - writeln('error with val(".E")'); - if (r1<>0.0) or (r2<>0.0) then - halt(1); -end. - diff --git a/tests/webtbs/tbug1111.pp b/tests/webtbs/tbug1111.pp deleted file mode 100644 index 223352f3fd..0000000000 --- a/tests/webtbs/tbug1111.pp +++ /dev/null @@ -1,7 +0,0 @@ -var - v : 0..5; - sMin, sMax : 0..5; // if top of range is less than 32, get compiler Panic -begin - if v in [sMin..sMax] then ; -end. - diff --git a/tests/webtbs/tbug1117.pp b/tests/webtbs/tbug1117.pp deleted file mode 100644 index 9c441b4823..0000000000 --- a/tests/webtbs/tbug1117.pp +++ /dev/null @@ -1,27 +0,0 @@ -{$asmmode intel} -var - l1,l2 : longint; - -procedure DrawSprite1( spr : longint ); assembler; -asm - mov eax,spr - mov l1, eax -end; - -procedure DrawSprite2( spr : longint ); -begin -asm - mov eax,spr - mov l2,eax -end; -end; - -begin - DrawSprite1(1); - DrawSprite2(1); - if l1<>l2 then - begin - Writeln('Error!'); - halt(1); - end; -end. diff --git a/tests/webtbs/tbug1123.pp b/tests/webtbs/tbug1123.pp deleted file mode 100644 index 8f7bce0d16..0000000000 --- a/tests/webtbs/tbug1123.pp +++ /dev/null @@ -1,30 +0,0 @@ -TYPE PObj = ^TObj; - TObj = OBJECT - ii : INTEGER; - CONSTRUCTOR Init(i :INTEGER); - DESTRUCTOR Done; - END; - -CONSTRUCTOR TObj.Init(i :INTEGER); -BEGIN - ii := i; -END; - -DESTRUCTOR TObj.Done; -BEGIN -END; - -VAR Obj : ARRAY[1..2] OF TObj; - -BEGIN - Obj[1].Init(10); - WITH Obj[2] DO Init(Obj[1].ii + 1); (* equal Init(0+1) = wrong *) - - Writeln; - Writeln(Obj[1].ii:10); - Writeln(Obj[2].ii:10); - if Obj[2].ii<>11 then - halt(1); - -(* this should report 10 and 11, when ok *) -END. diff --git a/tests/webtbs/tbug1124.pp b/tests/webtbs/tbug1124.pp deleted file mode 100644 index bd2385775e..0000000000 --- a/tests/webtbs/tbug1124.pp +++ /dev/null @@ -1,18 +0,0 @@ - Type - t1 = record - dummy:integer; - end; - t2 = record - dummy:string; - end; - -operator = (i1,i2:t1) r:boolean; -begin -end; - -operator = (i1,i2:t2) r:boolean; -begin -end; - -begin -end. diff --git a/tests/webtbs/tbug1132.pp b/tests/webtbs/tbug1132.pp deleted file mode 100644 index caa7df20ee..0000000000 --- a/tests/webtbs/tbug1132.pp +++ /dev/null @@ -1,28 +0,0 @@ -program BugDemo2; - -type - MyRecordType = - record - RecordElement1 : word; - RecordElement2 : word; - end; - -var - MyRecord : MyRecordType; - MyPointer1,MyPointer2 : pointer; - -begin - with MyRecord do - begin - { next statement crashes the compiler } - MyPointer1 := addr(RecordElement2); - - { next statement is OK } - MyPointer2 := addr(MyRecord.RecordElement2); - end; - if MyPointer1<>MyPointer2 then - begin - Writeln('Error with addr() and with statement'); - halt(1); - end; -end. diff --git a/tests/webtbs/tbug1133.pp b/tests/webtbs/tbug1133.pp deleted file mode 100644 index defc1df3a3..0000000000 --- a/tests/webtbs/tbug1133.pp +++ /dev/null @@ -1,34 +0,0 @@ -{ $OPT=-O2 } -type - float = double; - - -function ConvertRealToPixel(Axis : integer; - HelpReal : real) : real; - - begin { function ConvertRealToPixel } - ConvertRealToPixel := HelpReal; - end; { function ConvertRealToPixel } - - -var - HelpFloat1,HelpFloat2,HelpFloat3 : float; - SegmentStartPos : float; - SegmentLength : float; - - -begin - SegmentStartPos := 0.5; - SegmentLength := 0.5; - HelpFloat1 := SegmentStartPos - SegmentLength / 2; - HelpFloat2 := ConvertRealToPixel(1,HelpFloat1); - writeln('Function result = ',HelpFloat2,' This is OK'); - - HelpFloat3 := ConvertRealToPixel(1,SegmentStartPos - SegmentLength / 2); - writeln('Function result = ',HelpFloat3,' THIS IS WRONG !'); - if HelpFloat2<>HelpFloat3 then - begin - Writeln('ERROR!'); - Halt(1); - end; -end. diff --git a/tests/webtbs/tbug1152.pp b/tests/webtbs/tbug1152.pp deleted file mode 100644 index c9c3df79aa..0000000000 --- a/tests/webtbs/tbug1152.pp +++ /dev/null @@ -1,39 +0,0 @@ -{ Source provided for Free Pascal Bug Report 1152 } -{ Submitted by "Dirk Verwiebe" on 2000-09-30 } -{ e-mail: dirk@verwiebe.de } - -{$mode objfpc} - -program exception; -uses sysutils,crt; -var - saveexit : pointer; - finally_called : boolean; - -procedure my_exit; - begin - exitproc:=saveexit; - if not finally_called then - begin - Writeln('Problem with exception handling if crt unit is used'); - RunError(1); - end - else - begin - Writeln('Exception handling works'); - exitcode:=0; - end; - end; - - -BEGIN - saveexit:=exitproc; - exitproc:=@my_exit; - finally_called:=false; -try - mem[$ffffffff]:=0; -finally - finally_called:=true; - writeln('Error !!!'); -end; -END. \ No newline at end of file diff --git a/tests/webtbs/tbug1157.pp b/tests/webtbs/tbug1157.pp deleted file mode 100644 index 64ed35b450..0000000000 --- a/tests/webtbs/tbug1157.pp +++ /dev/null @@ -1,35 +0,0 @@ -{ Source provided for Free Pascal Bug Report 1157 } -{ Submitted by "Colin Goldie" on 2000-10-06 } -{ e-mail: Colin_G@Positek.com.au } - -{$asmmode intel} - -Function GetBLUEfromRGB( color : word ) : byte; assembler; -asm - mov cx,color - and cx,0000000000011111b - mov @Result,cl -end; - -{ -Does something weird .. to the stack im guessing ... error 206 and 103 -errors occur 'File not open' ... - -However, if instead of using @Result , i chuck my return value into the -accumulator register , everything thing works hunky dory. -} - -Function GetBLUEfromRGB2( color : word ) : byte; assembler; -asm - mov cx,color - and cx,0000000000011111b - mov al,cl -end; - -begin - if GetBlueFromRGB2($fff)<>GetBlueFromRGB($fff) then - begin - Writeln('Error in assembler statement'); - Halt(1); - end; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug1203.pp b/tests/webtbs/tbug1203.pp deleted file mode 100644 index 5298e4981a..0000000000 --- a/tests/webtbs/tbug1203.pp +++ /dev/null @@ -1,22 +0,0 @@ -{ Source provided for Free Pascal Bug Report 1203 } -{ Submitted by "Marco van de Voort" on 2000-10-29 } -{ e-mail: marco@freepascal.org } -{$mode Delphi} -type - someprocedureofobjectype=procedure (sender:tobject) OF -OBJECT; - - a=class - protected - fondisplay : someprocedureofobjectype; - end; - - b=class(A) - protected - fondisplay : someprocedureofobjectype; - end; - -begin -end. - - diff --git a/tests/webtbs/tbug1204.pas b/tests/webtbs/tbug1204.pas deleted file mode 100644 index 46a20525da..0000000000 --- a/tests/webtbs/tbug1204.pas +++ /dev/null @@ -1,73 +0,0 @@ -{ Source provided for Free Pascal Bug Report 1204 } -{ Submitted by "Marco van de Voort" on 2000-10-29 } -{ e-mail: marco@freepascal.org } - -Uses Windows,Sysutils,Classes; - -type - TICMPDisplay = procedure(Sender: TObject; Msg : String) of object; - TICMPReply = procedure(Sender: TObject; Error : Integer) of -object; - - // The object wich encapsulate the ICMP.DLL - TICMP = class(TObject) - private - FOnDisplay : TICMPDisplay; // Event handler to -display - public - constructor Create; virtual; - destructor Destroy; override; - property OnDisplay : TICMPDisplay read FOnDisplay write -FOnDisplay; - end; - - TPingDisplay = procedure(Sender: TObject; Icmp: TObject; Msg : -String) of object; - - - TPing = class(TComponent) - private - FIcmp : TICMP; - FOnDisplay : TPingDisplay; - protected - procedure IcmpDisplay(Sender: TObject; Msg: String); - - public - constructor Create(Owner : TComponent); override; - destructor Destroy; override; - property OnDisplay : TPingDisplay read FOnDisplay - write FOnDisplay; - - end; - -constructor TICMP.Create; -begin -end; - -destructor TICMP.Destroy; -begin -end; - -constructor TPing.Create(Owner : TComponent); -begin - Inherited Create(Owner); - FIcmp := TICMP.Create; - FIcmp.OnDisplay := IcmpDisplay; -end; - - -{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -* * *} -destructor TPing.Destroy; -begin -end; - -procedure TPing.IcmpDisplay(Sender: TObject; Msg: String); -begin - if Assigned(FOnDisplay) then - FOnDisplay(Self, Sender, Msg); -end; - -begin -end. - diff --git a/tests/webtbs/tbug555.pp b/tests/webtbs/tbug555.pp deleted file mode 100644 index 6b3d5553b5..0000000000 --- a/tests/webtbs/tbug555.pp +++ /dev/null @@ -1,50 +0,0 @@ -{ FPC behaves interestingly once encountered virtual method - declared as - procedure TWhateverObject.Method1; assembler; asm ... end; - if you ever try to overload such method _in another unit_, - than compile _second unit_, and than try to compile it again (???)- - you will end up with the message "Function header does not match - forward declaration of TNewObject.Method1" although in reality - it does match perfectly. - sometimes i encounter the same message even on non-assembler methods, - but i have not been able to reproduce them cleanly nor find the - reason for such behavior.} - - unit tbug555; - - - interface - uses - tbug555a; - - type - TBugObjChild = Object(TBugObj) - procedure Method1; - procedure Method2;virtual; - procedure Method3; - procedure Method4;virtual; - end; - - implementation - - procedure TBugObjChild.Method1; - begin - end; - - procedure TBugObjChild.Method2; - begin - end; - -{$ASMMODE ATT} - procedure TBugObjChild.Method3;assembler; - asm - movl $1,%eax - end; - - procedure TBugObjChild.Method4;assembler; - asm - movl $1,%eax - end; - - -end. diff --git a/tests/webtbs/tbug555a.pp b/tests/webtbs/tbug555a.pp deleted file mode 100644 index 1ee2a0c520..0000000000 --- a/tests/webtbs/tbug555a.pp +++ /dev/null @@ -1,57 +0,0 @@ -{ FPC behaves interestingly once encountered virtual method - declared as - procedure TWhateverObject.Method1; assembler; asm ... end; - if you ever try to overload such method _in another unit_, - than compile _second unit_, and than try to compile it again (???)- - you will end up with the message "Function header does not match - forward declaration of TNewObject.Method1" although in reality - it does match perfectly. - sometimes i encounter the same message even on non-assembler methods, - but i have not been able to reproduce them cleanly nor find the - reason for such behavior.} - - unit tbug555a; - - interface - - type - - TBugObj = Object - constructor Init; - procedure Method1; - procedure Method2;virtual; - procedure Method3; - procedure Method4;virtual; - destructor Done;virtual; - end; - - implementation - - Constructor TBugObj.Init; - begin - end; - -{$ASMMODE ATT} - procedure TBugObj.Method1;assembler; - asm - movl $1,%eax - end; - - procedure TBugObj.Method2;assembler; - asm - movl $1,%eax - end; - - procedure TBugObj.Method3; - begin - end; - - procedure TBugObj.Method4; - begin - end; - - Destructor TBugObj.Done; - begin - end; - -end. diff --git a/tests/webtbs/tbug630.pp b/tests/webtbs/tbug630.pp deleted file mode 100644 index 61d2214b33..0000000000 --- a/tests/webtbs/tbug630.pp +++ /dev/null @@ -1,34 +0,0 @@ -{ Program 1 : memory waste - dummy test } - -USES SysUtils; - -procedure test_it; -var - sRec : TSearchRec; -begin - writeln(memAvail); - findFirst('c:\*.*',faVolumeId,sRec); - findClose(sRec); - writeln(sRec.name); - writeln(memAvail); { 288 bytes waste ! } -end; - -begin - Writeln('Before call ',MemAvail); - test_it; - Writeln('After call : ',MemAvail); -end. -(*{ Program 2 : correct } - -USES Dos; - -var - sRec : searchRec; -begin - writeln(memAvail); - findFirst('c:\*.*',volumeid,sRec); - findClose(sRec); - writeln(sRec.name); - writeln(memAvail); { no memory waste ! } -end. *) diff --git a/tests/webtbs/tbug701a.pp b/tests/webtbs/tbug701a.pp deleted file mode 100644 index ce4b214a9b..0000000000 --- a/tests/webtbs/tbug701a.pp +++ /dev/null @@ -1,18 +0,0 @@ -var - s : string; - - procedure UseString(const as : string); - begin - s:=as; - end; - - procedure MyExit; - begin - Writeln('Last call to UseString was with as = ',s); - end; - -begin - exitproc:=@MyExit; - UseString('Dummy test'); -end. - diff --git a/tests/webtbs/tbug701b.pp b/tests/webtbs/tbug701b.pp deleted file mode 100644 index 55d2b0de59..0000000000 --- a/tests/webtbs/tbug701b.pp +++ /dev/null @@ -1,6 +0,0 @@ -program memhole; -uses tbug701d,tbug701e,tbug701c; -begin - // the tbug701c is to be on the save side - tbug701c.TestProc('test'); -end. diff --git a/tests/webtbs/tbug701c.pp b/tests/webtbs/tbug701c.pp deleted file mode 100644 index 2b3c898843..0000000000 --- a/tests/webtbs/tbug701c.pp +++ /dev/null @@ -1,22 +0,0 @@ -unit tbug701c; - - interface - procedure TestProc(arg: AnsiString); - - var - s1: array[0..9] of AnsiString; - implementation - - var - s2: array[0..9] of AnsiString; - - procedure TestProc(arg: AnsiString); - - begin - s1[0] := arg + '!s10'; - s1[3] := arg + '!s13'; - s2[4] := arg + '!s24'; - s2[7] := arg + '!s27'; - end; - -end. diff --git a/tests/webtbs/tbug701d.pp b/tests/webtbs/tbug701d.pp deleted file mode 100644 index 76916f468f..0000000000 --- a/tests/webtbs/tbug701d.pp +++ /dev/null @@ -1,18 +0,0 @@ -unit tbug701d; - - interface - - implementation - -var - startmem : longint; - -initialization - startmem:=memavail; -finalization - if startmem<>memavail then - begin - writeln('Problem with ansistrings in units'); - halt(1); - end; -end. diff --git a/tests/webtbs/tbug701e.pp b/tests/webtbs/tbug701e.pp deleted file mode 100644 index e747a4340b..0000000000 --- a/tests/webtbs/tbug701e.pp +++ /dev/null @@ -1,25 +0,0 @@ -unit tbug701e; - - interface - - procedure TestProc(arg: AnsiString); - - var - s1: array[0..9] of AnsiString; - - implementation - - var - s2: array[0..9] of AnsiString; - - procedure TestProc(arg: AnsiString); - - begin - s1[0] := arg + '!s10'; - s1[3] := arg + '!s13'; - s2[4] := arg + '!s24'; - s2[7] := arg + '!s27'; - end; -initialization -finalization -end. diff --git a/tests/webtbs/tbug711.pp b/tests/webtbs/tbug711.pp deleted file mode 100644 index bd20cc090b..0000000000 --- a/tests/webtbs/tbug711.pp +++ /dev/null @@ -1,78 +0,0 @@ -program TestGetPutim; {Compiled with the 0.99.13 version under GO32V2!} - - - -uses -{$ifdef go32v2} - dpmiexcp, -{$endif go32v2} - graph; - - - - - -var graphdriver,graphmode :integer; - - imsize:longint; - - im:pointer; - - - -begin -{$ifdef win32} - graphdriver:=VGA; - graphmode:=detect; -{$else not win32} - graphdriver:=VESA; - graphmode:=$103; -{$endif} - Initgraph(graphdriver,graphmode,''); - - {************} -(* - setcolor(6); - - moveto(0,0); {Some drawing} - - lineto(500,500); - - circle(95,95,80); - -{************} - - - -{!!!!!!!!!!!!} - - imsize:= imagesize(0,0,300,300); {This is the part we have problem with.} - - getmem(im,imsize); {The result we get after PutImage is} - - getimage(0,0,300,300,im^); {chaotic independently from the graphmode!} - - putimage(50,50,im^,0); {We tested this on a S3Trio 3D videcard,} - - {which is VESA compatible.} - -{!!!!!!!!!!!!} - - - -readln; - {repeat until keypressed;} - *) - closegraph; - -end. - -{ - - I. Groma - - groma@metal.elte.hu - - Budapest 11/24/1999 - -} diff --git a/tests/webtbs/tbug719.pp b/tests/webtbs/tbug719.pp deleted file mode 100644 index 259864ecf1..0000000000 --- a/tests/webtbs/tbug719.pp +++ /dev/null @@ -1,17 +0,0 @@ -uses - sysutils; - -var - S : string; - SR : TSearchRec; - r : longint; -begin -r:=FindFirst('*.*',faAnyFile,SR); -while r=0 do - begin - S:=DateTimeToStr(FileDateToDateTime(FileAge(SR.Name))); - Writeln(SR.Name,' has Date ',S); - r:=FindNext(SR); - end; -FindClose(SR); -end. diff --git a/tests/webtbs/tbug735.pp b/tests/webtbs/tbug735.pp deleted file mode 100644 index 67583dfb00..0000000000 --- a/tests/webtbs/tbug735.pp +++ /dev/null @@ -1,25 +0,0 @@ -{$asmmode intel} -{$inline on} - -procedure DoIt; -begin - Writeln('DoIt was called'); -end; - -const - CB : word = 5; - -procedure A(B: word); assembler; inline; -asm - MOV AX,B - CMP AX,[CB] - JZ @OK - MOV [CB],AX - CALL DoIt -@OK: { <-- creates labels with same name } -end; - -begin - A(5); - A(8); -end. diff --git a/tests/webtbs/tbug736.pp b/tests/webtbs/tbug736.pp deleted file mode 100644 index 8b8f7bb2fe..0000000000 --- a/tests/webtbs/tbug736.pp +++ /dev/null @@ -1,130 +0,0 @@ -{$ifdef FPC} -{$ASMMODE INTEL} -{$INLINE ON} -{$endif FPC} - -program test; - -type - tobj = object - x : word; - constructor init; - procedure test;virtual; - procedure testx; - end; - -constructor tobj.init; -begin - x:=1; -end; - -procedure tobj.testx; -begin - asm - mov ax,3 - mov word ptr[x],ax - end; -end; - -procedure tobj.test; -var - pattern: word; - dummyval : word; - - function rotate: boolean; assembler; {$ifdef FPC}inline;{$endif FPC} - asm - mov al,0 - rol word ptr [pattern],1 - rcl al,1 - end; - -{ this does still not work because - it can only work as inline not as normal sub function - because dummyval and pattern are not reachable !! PM - function rotateb(dummy : byte) : boolean; assembler; inline; - asm - movzx byte ptr [dummy],ax - mov ax,word ptr [dummyval] - mov al,0 - rol word ptr [pattern],1 - rcl al,1 - end; } - -var - i : byte; - -begin - pattern:= $a0a0; - for i:=1 to 16 do - begin - Write('obj pattern = ', - {$ifdef FPC} - hexstr(pattern,4),' '); - {$else} - pattern,' '); - {$endif} - if rotate then - Writeln('bit found') - else - Writeln('no bit found'); - end; -end; - -procedure changepattern; -var - pattern: word; - dummyval : word; - - function rotate: boolean; assembler; {$ifdef FPC}inline;{$endif FPC} - asm - mov al,0 - rol word ptr [pattern],1 - rcl al,1 - end; - -{ this does still not work because - it can only work as inline not as normal sub function - because dummyval and pattern are not reachable !! PM - function rotateb(dummy : byte) : boolean; assembler; inline; - asm - movzx byte ptr [dummy],ax - mov ax,word ptr [dummyval] - mov al,0 - rol word ptr [pattern],1 - rcl al,1 - end; } - -var - i : byte; - -begin - pattern:= $a0a0; - for i:=1 to 16 do - begin - Write('pattern = ', - {$ifdef FPC} - hexstr(pattern,4),' '); - {$else} - pattern,' '); - {$endif} - if rotate then - Writeln('bit found') - else - Writeln('no bit found'); - end; -end; - -var - - t : tobj; -begin - changepattern; - t.init; - t.test; - t.testx; - if t.x<>3 then - begin - Writeln('Unable to access object fields in assembler'); - Halt(1); - end; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug738.pp b/tests/webtbs/tbug738.pp deleted file mode 100644 index 727dc18cf9..0000000000 --- a/tests/webtbs/tbug738.pp +++ /dev/null @@ -1,15 +0,0 @@ -{$mode delphi} - -type - (* - {$IFDEF FPK} - SomeClass = class; { this line shouldn't be necessary } - {$ENDIF} - *) - - SomeClass = class - SomeMember:SomeClass; - end; - -begin -end. diff --git a/tests/webtbs/tbug739.pp b/tests/webtbs/tbug739.pp deleted file mode 100644 index fe8d1663bb..0000000000 --- a/tests/webtbs/tbug739.pp +++ /dev/null @@ -1,13 +0,0 @@ -{$mode delphi} - -type -(* {$IFDEF FPK} - y = class; { shouldn't be necessary } -{$ENDIF} *) - x = class of y; - y = class - z:Boolean; - end; - -begin -end. diff --git a/tests/webtbs/tbug748.pp b/tests/webtbs/tbug748.pp deleted file mode 100644 index 041c43f531..0000000000 --- a/tests/webtbs/tbug748.pp +++ /dev/null @@ -1,4 +0,0 @@ -begin - writeln('Hello World'); -end. -{this comment produces Unexpected end of file} diff --git a/tests/webtbs/tbug751.pp b/tests/webtbs/tbug751.pp deleted file mode 100644 index 32eccc6d1d..0000000000 --- a/tests/webtbs/tbug751.pp +++ /dev/null @@ -1,6 +0,0 @@ -var x,y:integer; -begin - -y:=5; -for x:=0 to 10 do if x0 then - begin - val(paramstr(1),count,error); - if error = 0 then - Max:=count; - count:=0; - end; - - for i:=1 to Max do - begin - str(i,s); - s:='file'+s+'.tmp'; - assign(f[i],s); - rewrite(f[i]); - count:=i; - Writeln(f[i],'This is file ',i); - Writeln(i,' files open'); - { no closing so they are finally all open } - end; - - for i:=Max downto 1 do - begin - close(f[i]); - erase(f[i]); - end; -end. diff --git a/tests/webtbs/tbug755.pp b/tests/webtbs/tbug755.pp deleted file mode 100644 index b7eedf81e8..0000000000 --- a/tests/webtbs/tbug755.pp +++ /dev/null @@ -1,40 +0,0 @@ -type - de10_eqn_vector = array [1..10] of double; - de10_func = function : double; - de10func = de10_func; - DE10_PHI_ARRAY = array[1..10] of double; - DE10phiarray = DE10_PHI_ARRAY; - de10eqnvec = de10_eqn_vector; - de10_12_vector = array [10..12] of double; - de10_13_vector = array [10..13] of double; - de1012vec = de10_12_vector; - de1013vec = de10_13_vector; - -PROCEDURE Step10( VAR X : double; VAR Y : - DE10_EQN_VECTOR; F10 : DE10_FUNC; VAR NEQN : INTEGER; VAR H : double; VAR - EPS : double; VAR WT : DE10_EQN_VECTOR; VAR START : BOOLEAN; VAR HOLD : - double; VAR K : INTEGER; VAR KOLD : INTEGER; VAR CRASH : BOOLEAN; VAR PHI : - DE10_PHI_ARRAY; VAR P : DE10_EQN_VECTOR; VAR YP : DE10_EQN_VECTOR; - VAR PSI : DE10_12_VECTOR; VAR ALPHA : DE10_12_VECTOR; VAR BETA : - DE10_12_VECTOR; VAR SIG : DE10_13_VECTOR; VAR V : DE10_12_VECTOR; VAR W - : DE10_12_VECTOR; VAR G : DE10_13_VECTOR; VAR PHASE1 : BOOLEAN; VAR NS : - INTEGER; VAR NORND : BOOLEAN ); - begin - end; - -PROCEDURE Step11( VAR X : double; VAR Y : DE10EQNVEC; F10 : DE10FUNC; VAR - NEQN : INTEGER; VAR H : double; VAR EPS : double; VAR WT : DE10EQNVEC; VAR - START : BOOLEAN; VAR HOLD : double; VAR K : INTEGER; VAR KOLD : INTEGER; - VAR CRASH : BOOLEAN; VAR PHI : DE10PHIARRAY; VAR P : DE10EQNVEC; VAR YP - : DE10EQNVEC; VAR PSI : DE1012VEC; VAR ALPHA : DE1012VEC; VAR BETA : - DE1012VEC; VAR SIG : DE1013VEC; VAR V : DE1012VEC; VAR W : DE1012VEC; VAR - G : DE1013VEC; VAR PHASE1 : BOOLEAN; VAR NS : INTEGER; VAR NORND : - BOOLEAN ); - - begin - end; - - - -begin -end. diff --git a/tests/webtbs/tbug760.pp b/tests/webtbs/tbug760.pp deleted file mode 100644 index e58913f651..0000000000 --- a/tests/webtbs/tbug760.pp +++ /dev/null @@ -1,32 +0,0 @@ -type TElement = object - constructor Init; - {something} - destructor Free; virtual; - destructor Done; virtual; - end; - -constructor TElement.Init; -begin - Writeln('Init called'); -end; - -destructor TElement.free; -begin - Writeln('Free used'); -end; - -destructor TElement.Done; -begin - Writeln('Done used'); -end; - -var - E : TElement; - PE : ^TElement; - -begin - E.init; - E.Free; - new(PE,init); - dispose(PE,Done); -end. diff --git a/tests/webtbs/tbug761.pp b/tests/webtbs/tbug761.pp deleted file mode 100644 index 1adf5d608d..0000000000 --- a/tests/webtbs/tbug761.pp +++ /dev/null @@ -1,14 +0,0 @@ -{$asmmode intel} -Type TFather = Object A : Integer; end; - TSon = Object (TFather) B : Integer; end; - -Var Son : TSon; - -begin - Asm - mov ax, Son.A - mov ax, Son.B - end; -end. - - diff --git a/tests/webtbs/tbug769.pp b/tests/webtbs/tbug769.pp deleted file mode 100644 index 6cadf19112..0000000000 --- a/tests/webtbs/tbug769.pp +++ /dev/null @@ -1,9 +0,0 @@ - -Program test; - -var x,y:integer; - -begin -y:=5; -for x:=0 to 10 do if x4 then - Halt(1); - close(t); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug776.pp b/tests/webtbs/tbug776.pp deleted file mode 100644 index fe918a1102..0000000000 --- a/tests/webtbs/tbug776.pp +++ /dev/null @@ -1,16 +0,0 @@ -{$mode objfpc} -uses sysutils; - var i:integer; - j : record - x,y : longint; - end; -begin - i:=0; - format('%d', [i]); - with j do - begin - x:=2; - y:=4; - Writeln('j.x=',x,' j.y=',y); - end; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug784.pp b/tests/webtbs/tbug784.pp deleted file mode 100644 index f1fe396511..0000000000 --- a/tests/webtbs/tbug784.pp +++ /dev/null @@ -1,27 +0,0 @@ -{$R-} -{ should compile if no range check on } -program BigRange; - -const - Limit = 100000000; { Hundred millions } - One = 1; - -var - Huge: longint; - -begin - Huge := Limit + One; - - writeln(One, ' is the lower bound'); - writeln(Limit, ' is the upper bound'); - - if Limit in [One .. Limit] then - writeln(Limit, ' is within the range') - else - writeln(Limit, ' is out of the range'); - - if Huge in [One .. Limit] then - writeln(Huge, ' is within the range') - else - writeln(Huge, ' is out of the range') -end. diff --git a/tests/webtbs/tbug788.pp b/tests/webtbs/tbug788.pp deleted file mode 100644 index 7616f08efa..0000000000 --- a/tests/webtbs/tbug788.pp +++ /dev/null @@ -1,68 +0,0 @@ -{$ifdef FPC} -Uses Math; - -{$else not FPC} -function degtorad(deg : extended) : extended; - - begin - degtorad:=deg*(pi/180.0); - end; - -function radtodeg(rad : extended) : extended; - - begin - radtodeg:=rad*(180.0/pi); - end; - - function ArcSin(x : extended) : extended; - begin - if abs(x)=1.0 then - arcsin:=Pi/2 - else - arcsin:=ArcTan(x/sqrt(1-x*x)); - end; - function ArcTan2(x,y : extended) : extended; - begin - ArcTan2:=ArcTan(x/y); - end; -{$endif not FPC} - -Var - I : Integer; - RI,RRI,R0 : extended; - -Begin - For I := -179 To 179 Do - Begin - RI:=I; - WriteLn( RadToDeg(ArcSin(Sin(DegToRad(RI)))):3:18); - End; - For I := -89 To 89 Do - Begin - RI:=I; - RRI:=RadToDeg(ArcSin( Sin(DegToRad(RI)))); - WriteLn(RI:3:18,' ',RRI:3:18); - If RI<>RRI then - begin - Writeln('Not exact ',RRI-RI:3:18); - if I<>0 then - begin - Writeln('Percentage error = ',Abs(RRI -RI) *100 / I:3:18); - if abs((RRI -RI) *100 / I)>0.0001 then - Begin - Writeln('Error too big '); - Halt(1); - end; - end; - end; - End; - RI:=3; - RRI:=1; - R0:=1; - Writeln( ArcTan2(ArcTan2(1,1),R0):3:18 , ' should be 0.66577375...'); - if ArcTan2(ArcTan2(1,1),R0)<>ArcTan(ArcTan(1)/R0) then - begin - Writeln('There is still a bug in ArcTan2 !'); - Halt(1); - end; -End. \ No newline at end of file diff --git a/tests/webtbs/tbug789.pp b/tests/webtbs/tbug789.pp deleted file mode 100644 index 19aba4225d..0000000000 --- a/tests/webtbs/tbug789.pp +++ /dev/null @@ -1,14 +0,0 @@ -{$MODE DELPHI} - -uses sysutils; - -procedure tt (params : array of const); -begin -// this call generate Access violation - writeln (Format ('Params test %d', params)); -end; - -begin - writeln (Format ('First test %d', [1])); - tt ([1]); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug793.pp b/tests/webtbs/tbug793.pp deleted file mode 100644 index cdabffc839..0000000000 --- a/tests/webtbs/tbug793.pp +++ /dev/null @@ -1,29 +0,0 @@ -{$MODE Delphi} - -program bug; -type - -TMyObject = class - public - constructor Create; virtual; - constructor Init; -end; - -var - M: TMyObject; - - -constructor TMyObject.Create; -begin - Writeln('Now executing TmyObject.Create'); -end; - -constructor TMyObject.Init; -begin - Create; - Writeln('Now finishing the INIT constructor.'); -end; - -begin - M := TMyObject.Init; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug797.pp b/tests/webtbs/tbug797.pp deleted file mode 100644 index 251ba8b215..0000000000 --- a/tests/webtbs/tbug797.pp +++ /dev/null @@ -1,30 +0,0 @@ -program test; -{$INLINE ON} - -var - s2 : string; - j : longint; - - procedure Tst(s: ShortString;var j : longint); inline; - var - i : longint; - begin - s:=s + ' Yes'; - i:=5; - j:=j+i; - WriteLn(s); - s2:=s; - end; -begin - s2:='Before inline'; - j:=5; - Tst('Hello Hello Hello',j); - if (s2<>'Hello Hello Hello Yes') or (j<>10) then - begin - if (s2<>'Hello Hello Hello Yes') then - writeln('s2 = ',s2); - if (j<>10) then - writeln('j = ',s2); - halt(1); - end; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug797a.pp b/tests/webtbs/tbug797a.pp deleted file mode 100644 index 464dd5466f..0000000000 --- a/tests/webtbs/tbug797a.pp +++ /dev/null @@ -1,26 +0,0 @@ -program test; -{$INLINE ON} -{$ASMMODE ATT} - -var - j : longint; - - procedure Tst(var j : longint); assembler;inline; - var - i : longint; - asm - movl j,%ebx - movl (%ebx),%eax - movl $5,i - addl i,%eax - movl %eax,(%ebx) - end; - -begin - j:=5; - Tst(j); - if (j<>10) then - begin - halt(1); - end; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug801.pp b/tests/webtbs/tbug801.pp deleted file mode 100644 index f5b8ba4e4e..0000000000 --- a/tests/webtbs/tbug801.pp +++ /dev/null @@ -1,12 +0,0 @@ -program WrongHint; -type - PRecord = ^TRecord; - TRecord = record - end; -var - x: PRecord; -begin - - New(x); - Dispose(x); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug802.pp b/tests/webtbs/tbug802.pp deleted file mode 100644 index e409ef0cf4..0000000000 --- a/tests/webtbs/tbug802.pp +++ /dev/null @@ -1,9 +0,0 @@ -program test; - function testf (a:byte;b:integer;c:char):char; - begin - testf:=c; - end; -begin - writeln('"',testf(0,-1,'A'),'"'); -end. - diff --git a/tests/webtbs/tbug803.pp b/tests/webtbs/tbug803.pp deleted file mode 100644 index 90a9ca1a43..0000000000 --- a/tests/webtbs/tbug803.pp +++ /dev/null @@ -1,17 +0,0 @@ -{$MODE objfpc} -program FileExc; -uses SysUtils, Classes; -var - f: TFileStream; -begin - try - f := TFileStream.Create('a nonexistent file', fmOpenRead); - except - on e: Exception do begin - f.Free; - halt(0); - end; - end; - writeln('Error'); - halt(1); -end. diff --git a/tests/webtbs/tbug809.pp b/tests/webtbs/tbug809.pp deleted file mode 100644 index 70df392bd9..0000000000 --- a/tests/webtbs/tbug809.pp +++ /dev/null @@ -1,7 +0,0 @@ -PROGRAM Test; - -USES Tbug809a; - -BEGIN - Schreib('Test'); -END. \ No newline at end of file diff --git a/tests/webtbs/tbug809a.pp b/tests/webtbs/tbug809a.pp deleted file mode 100644 index 24890cfcd4..0000000000 --- a/tests/webtbs/tbug809a.pp +++ /dev/null @@ -1,14 +0,0 @@ -UNIT tbug809a; - -INTERFACE - - PROCEDURE Schreib(st : STRING); - -IMPLEMENTATION - -PROCEDURE Schreib(st : STRING); -BEGIN - WriteLn(st); -END; - -END. \ No newline at end of file diff --git a/tests/webtbs/tbug810.pp b/tests/webtbs/tbug810.pp deleted file mode 100644 index c64c972128..0000000000 --- a/tests/webtbs/tbug810.pp +++ /dev/null @@ -1,13 +0,0 @@ -program bug; -var i:byte; - e:extended; - s:string; -begin -e:=103; (*1003,100003,1000003*) -for i:=0 to 17 do - begin - str(e:0:i,s); - writeln(s); - end; - -end. \ No newline at end of file diff --git a/tests/webtbs/tbug812.pp b/tests/webtbs/tbug812.pp deleted file mode 100644 index 3013983254..0000000000 --- a/tests/webtbs/tbug812.pp +++ /dev/null @@ -1,26 +0,0 @@ -program TestVm2; - -{$IFDEF WIN32}{$APPTYPE CONSOLE}{$ENDIF} - -procedure Test; -var - P: Pointer; -begin - P:=nil; - ReAllocMem(P, 8); - ReAllocMem(P, 0); -end; - -var MemBefore : longint; -begin - writeln(MemAvail); - MemBefore:=MemAvail; - Test; - writeln(MemAvail); - if MemBefore<>MemAvail then - begin - Writeln('ReAllocMem creates emory leaks'); - Writeln('Bug 812 is not yet fixed'); - Halt(1); - end; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug813.pp b/tests/webtbs/tbug813.pp deleted file mode 100644 index 78bf249b90..0000000000 --- a/tests/webtbs/tbug813.pp +++ /dev/null @@ -1,31 +0,0 @@ -program TestVm2; - -{$IFDEF WIN32}{$APPTYPE CONSOLE}{$ENDIF} - -procedure Test; -var - P: Pointer; -begin - P:=nil; - ReAllocMem(P, 8); - ReAllocMem(P, 0); - if P<>nil then - begin - Writeln('ReAllocMem wtih zero size does not set pointer to nil'); - Writeln('Bug 813 is not yet fixed'); - Halt(1); - end; -end; - -var MemBefore : longint; -begin - writeln(MemAvail); - MemBefore:=MemAvail; - Test; - writeln(MemAvail); - if MemBefore<>MemAvail then - begin - Writeln('ReAllocMem creates emory leaks'); - Writeln('Bug 812 is not yet fixed'); - end; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug814.pp b/tests/webtbs/tbug814.pp deleted file mode 100644 index 2b42a75ea1..0000000000 --- a/tests/webtbs/tbug814.pp +++ /dev/null @@ -1,5 +0,0 @@ -const - MaxFloat80 = 1.1E+4932; -begin - Writeln(MaxFloat80); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug815.pp b/tests/webtbs/tbug815.pp deleted file mode 100644 index ad1aee05ef..0000000000 --- a/tests/webtbs/tbug815.pp +++ /dev/null @@ -1,10 +0,0 @@ -{$mode delphi} - -function T: Integer; -begin - for Result:=0 to 10 do ; -end; - -begin - T; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug816.pp b/tests/webtbs/tbug816.pp deleted file mode 100644 index a950bacf98..0000000000 --- a/tests/webtbs/tbug816.pp +++ /dev/null @@ -1,24 +0,0 @@ -uses graph; -var - gd,gm:integer; - testimage:array[1..50000] of byte; {this is plenty big} -begin - gd:=VESA; - gm:=$100; { 640 x 400 x 256 } - initgraph(gd,gm,''); - if graphresult<>grOk then - begin - Writeln('Unable to open driver ',gd,' in mode ',gm); - Halt(1); - end; - line(0,0,639,399); - getimage(190,49,257,125,testimage); - { a simple statement, and yet - it throws a General Protection fault, but only with certain - numbers for getimage. The numbers i have here do not produce - too big an image for the array testimage, and yet it faults. - Is this a bug in getimage, or is there something i am - missing here? - } - closegraph; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug819.pp b/tests/webtbs/tbug819.pp deleted file mode 100644 index 4116232ece..0000000000 --- a/tests/webtbs/tbug819.pp +++ /dev/null @@ -1,27 +0,0 @@ -{$mode objfpc} -type - T1 = class - function Get(I: Integer): Integer; virtual; abstract; - property T[I: Integer]: Integer read Get; default; - end; - - T2 = class(T1) - function Get(I: Integer): Integer; override; - property T[I: Integer]: Integer read Get; default; - end; - -function T2.Get(I: Integer): Integer; -begin - Result:=I; -end; - -var - c2 : t2; - -begin - c2:=t2.create; - if c2[9]<>9 then - halt(1) - else - halt(0); -end. diff --git a/tests/webtbs/tbug825.pp b/tests/webtbs/tbug825.pp deleted file mode 100644 index 5499e320d7..0000000000 --- a/tests/webtbs/tbug825.pp +++ /dev/null @@ -1,39 +0,0 @@ -{$mode tp} -{ args for destructors - are allowed in TP mode for compatibility only PM } - -program test_destructor_with_args; - -var - z : longint; - - type - tt = object - constructor dummy; - destructor done(x : longint);virtual; - end; - - constructor tt.dummy; - begin - end; - - destructor tt.done; - begin - Writeln('x in tt.done is ',x); - z:=x; - end; - - var - pt : ^tt; - -begin - Writeln('ln(5)=',ln(5)); - new(pt,dummy); - pt^.done(4); - if z<>4 then - Halt(1); - pt^.dummy; - dispose(pt,done(5)); - if z<>5 then - Halt(1); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug839.pp b/tests/webtbs/tbug839.pp deleted file mode 100644 index 6b51019d9f..0000000000 --- a/tests/webtbs/tbug839.pp +++ /dev/null @@ -1,18 +0,0 @@ -{$mode tp} -program notcom; - -type demo=object - constructor init; - destructor done(x:longint); - end; - -constructor demo.init; -begin -end; - -destructor demo.done(x:longint); -begin -end; - -begin -end. \ No newline at end of file diff --git a/tests/webtbs/tbug840.pp b/tests/webtbs/tbug840.pp deleted file mode 100644 index 35f7eb6319..0000000000 --- a/tests/webtbs/tbug840.pp +++ /dev/null @@ -1,24 +0,0 @@ -{$mode TP} - -program tbug840; - -uses tbug840a; - -begin -tbug840b.i:=1; -end. - ------------------------------ cut here ---------------------------------------- -unit ua; - -interface -uses ub; -implementation -end. ------------------------------ cut here ---------------------------------------- -unit ub; - -interface -var i:longint; -implementation -end. \ No newline at end of file diff --git a/tests/webtbs/tbug840a.pp b/tests/webtbs/tbug840a.pp deleted file mode 100644 index 83180d1905..0000000000 --- a/tests/webtbs/tbug840a.pp +++ /dev/null @@ -1,6 +0,0 @@ -unit tbug840a; - -interface -uses tbug840b; -implementation -end. diff --git a/tests/webtbs/tbug840b.pp b/tests/webtbs/tbug840b.pp deleted file mode 100644 index eaf502988c..0000000000 --- a/tests/webtbs/tbug840b.pp +++ /dev/null @@ -1,6 +0,0 @@ -unit tbug840b; - -interface -var i:longint; -implementation -end. \ No newline at end of file diff --git a/tests/webtbs/tbug848.pp b/tests/webtbs/tbug848.pp deleted file mode 100644 index 378fe7fa99..0000000000 --- a/tests/webtbs/tbug848.pp +++ /dev/null @@ -1,28 +0,0 @@ -{$ASMMODE INTEL} - -PROCEDURE a; -VAR v,v2,v3:integer; - - PROCEDURE b;assembler; - ASM - MOV AX,v - mov v2,AX - mov EDI,0 - MOV AX,[EDI+v] - MOV AX,[EBP+OFFSET v] - MOV v3,AX - END; - -BEGIN - v:=5; - v2:=4; - v3:=0; - b; - if (v2<>v) or (v3<>v) then - Halt(1); -END; - -begin - a; - Writeln('Program works'); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug852.pp b/tests/webtbs/tbug852.pp deleted file mode 100644 index 07fa3d2e27..0000000000 --- a/tests/webtbs/tbug852.pp +++ /dev/null @@ -1,13 +0,0 @@ -type - TFloat80Array = array [0..1000000] of Extended; - -procedure AddFloat80Proc(var Vector1; const Vector2; Count: Integer); -var - I: Integer; -begin - for I:=0 to Count - 1 do - TFloat80Array(Vector1)[I]:=TFloat80Array(Vector1)[I] + TFloat80Array(Vector2)[I]; -end; - -begin -end. diff --git a/tests/webtbs/tbug855.pp b/tests/webtbs/tbug855.pp deleted file mode 100644 index 181f0ca417..0000000000 --- a/tests/webtbs/tbug855.pp +++ /dev/null @@ -1,16 +0,0 @@ -{$MODE objfpc} -{$R+} -type - TMyRec = record - x: Integer; - end; - TMyArray = array[LongWord] of TMyRec; - PMyArray = ^TMyArray; -var - a: PMyArray; - i: Integer; -begin - GetMem(a, SizeOf(TMyRec)); - i := 0; - a^[i].x := 1; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug859.pp b/tests/webtbs/tbug859.pp deleted file mode 100644 index a219da2159..0000000000 --- a/tests/webtbs/tbug859.pp +++ /dev/null @@ -1,31 +0,0 @@ -type - TBoolArray = array [0..1048576] of Boolean; - -procedure OrBoolProc(var Vector1; const Vector2; Count: Integer); -var - I: Integer; -begin - for I:=0 to Count - 1 do - TBoolArray(Vector1)[I]:=TBoolArray(Vector1)[I] or TBoolArray(Vector2)[I]; -end; - -var - A, B: array [0..10] of Boolean; - I: Integer; -const - error : boolean = false; -begin - for I:=0 to High(A) do A[I]:=False; - for I:=0 to High(B) do B[I]:=True; - OrBoolProc(A, B, SizeOf(A)); - for I:=0 to High(A) do - begin - write(A[I], ' '); - if not A[i] then - error:=true; - end; - writeln; - if error then - Halt(1); - -end. \ No newline at end of file diff --git a/tests/webtbs/tbug866.pp b/tests/webtbs/tbug866.pp deleted file mode 100644 index 09f98e2a75..0000000000 --- a/tests/webtbs/tbug866.pp +++ /dev/null @@ -1,17 +0,0 @@ -{$mode objfpc} -Type - ts = set of (tse); - ts2 = set of (t1,t2); - enum3 = (tm1:=-1,t0,tp1); - ts3 = set of t0 .. tp1; - var - f:ts; - f2 : ts2; - f3 : ts3; - -begin - f2:=f2+[t2]; - f2:=f2+[t1]; - f:=f+[tse]; // compiler says that set elements are not compatible - { f3:=[tm1];} -end. \ No newline at end of file diff --git a/tests/webtbs/tbug868.pp b/tests/webtbs/tbug868.pp deleted file mode 100644 index dd7949daa2..0000000000 --- a/tests/webtbs/tbug868.pp +++ /dev/null @@ -1,51 +0,0 @@ -{$mode objfpc} -{$H+} -type - TTreeData = record - Key: String; - Data: Integer; - end; - - TNode = class - data: TTreeData; - end; - - TStrIntDic = class - FNode: TNode; - destructor Destroy; override; - procedure Add(const Key: String; Data: Integer); - end; - -destructor TStrIntDic.Destroy; -begin - FNode.Free; - inherited Destroy; -end; - -procedure TStrIntDic.Add(const Key: String; Data: Integer); -var - T: TTreeData; -begin - T.Key:=Key; - T.Data:=Data; - FNode:=TNode.Create; - FNode.data:=T; -end; - -procedure Test; -var - SD: TStrIntDic; -begin - SD:=TStrIntDic.Create; - try - SD.Add('asdf', 2); - finally - SD.Free; - end; -end; - -begin - Test; - write('Test for bug 868 completed.'); - {readln;} -end. \ No newline at end of file diff --git a/tests/webtbs/tbug869.pp b/tests/webtbs/tbug869.pp deleted file mode 100644 index 6700374792..0000000000 --- a/tests/webtbs/tbug869.pp +++ /dev/null @@ -1,24 +0,0 @@ -program prueba; -uses crt; -var - resultado,exponente:integer; -begin - exponente := 3; - resultado := -1 ** exponente; - writeln (resultado); - if resultado<>-1 then - Halt(1); - exponente := 4; - resultado := -(1 ** exponente); - writeln (resultado); - if resultado<>-1 then - Halt(1); - resultado := (-1) ** exponente; - writeln (resultado); - if resultado<>1 then - Halt(1); - resultado := -1 ** exponente; - writeln (resultado); - if resultado<>-1 then - Halt(1); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug870.pp b/tests/webtbs/tbug870.pp deleted file mode 100644 index d62a1aac2e..0000000000 --- a/tests/webtbs/tbug870.pp +++ /dev/null @@ -1,21 +0,0 @@ -{$mode objfpc} -uses sysUtils; - - type - t = object - f:integer; - function m: AnsiString; - end; - - function t.m: AnsiString; - begin - result:=IntToStr(f); - end; - - var ti:t; - -begin - ti.f:=1; // no vmt for t - constructor call is not needed - writeln(format('%s', [ti.m])); // this works - writeln(format('%s, %s', [ti.m, ti.m])); // this does not - the same story with classes -end. \ No newline at end of file diff --git a/tests/webtbs/tbug873.pp b/tests/webtbs/tbug873.pp deleted file mode 100644 index 20937840ee..0000000000 --- a/tests/webtbs/tbug873.pp +++ /dev/null @@ -1,41 +0,0 @@ -{$mode objfpc} -program Teste; - -// Compile it using the Delphi extensions -// directive. - -type - TObject = class - private - procedure SetValue(v: integer); - public - fx: integer; - Constructor Create; - Destructor Destroy; - property x: integer read fx write SetValue; - end; - -var - Obj: TObject; - -Constructor TObject.Create; -begin - fx := 0; -end; - -Destructor TObject.Destroy; -begin -end; - -procedure TObject.SetValue(v: integer); -begin - fx := v + 2; -end; - -begin - writeln('This will be printed'); - Obj := TObject.Create; - writeln('This won''t.'); -end. - - diff --git a/tests/webtbs/tbug873a.pp b/tests/webtbs/tbug873a.pp deleted file mode 100644 index 3a1fc61a70..0000000000 --- a/tests/webtbs/tbug873a.pp +++ /dev/null @@ -1,40 +0,0 @@ -{$mode objfpc} -program Teste; - -// Compile it using the Delphi extensions -// directive. - -type - TObjectB = class - private - procedure SetValue(v: integer); - public - fx: integer; - Constructor Create; - Destructor Destroy; - property x: integer read fx write SetValue; - end; - -var - Obj: TObjectB; - -Constructor TObjectB.Create; -begin - fx := 0; -end; - -Destructor TObjectB.Destroy; -begin -end; - -procedure TObjectB.SetValue(v: integer); -begin - fx := v + 2; -end; - -begin - writeln('This will be printed'); - Obj := TObjectB.Create; - writeln('This won''t.'); -end. - diff --git a/tests/webtbs/tbug876.pp b/tests/webtbs/tbug876.pp deleted file mode 100644 index 46bb9ccc25..0000000000 --- a/tests/webtbs/tbug876.pp +++ /dev/null @@ -1,30 +0,0 @@ -{$OPT=-pg} - -program test1; -var - i,j:longint; - l : longint; - a,b:double; - -procedure test; -begin - b:=1.0; - i:=2; - a:=b+3; - j:=i div 2; -end; - -procedure test2; -begin - test; - Writeln('i=',i,' l=',l); -end; - -begin - for l:=1 to 10000 do - begin - test; - test2; - test; - end; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug877.pp b/tests/webtbs/tbug877.pp deleted file mode 100644 index 75f6935d0d..0000000000 --- a/tests/webtbs/tbug877.pp +++ /dev/null @@ -1,26 +0,0 @@ -{$mode objfpc} - -program testlist; -uses - Sysutils, - Classes; -var - l: TList; - IsCaught: boolean; - -begin - L:= TList.Create; - IsCaught:=false; - Try - WriteLn(LongInt(L[0]));{L[0] not exist, ==> access violation} - L.Free; - Except - on eListError do - IsCaught:=true; - end; - If not IsCaught then - begin - Writeln('Error in TList'); - Halt(1); - end; -end. diff --git a/tests/webtbs/tbug879.pp b/tests/webtbs/tbug879.pp deleted file mode 100644 index 50f88c8891..0000000000 --- a/tests/webtbs/tbug879.pp +++ /dev/null @@ -1,13 +0,0 @@ -PROGRAM TEST; -TYPE - ta = ARRAY[3..8] OF word; -VAR - aa : ^ta; - i : word; -BEGIN - NEW(aa); - FOR i:=LOW(aa^) TO HIGH(aa^) DO - aa^[i]:=0; -END. - - diff --git a/tests/webtbs/tbug881.pp b/tests/webtbs/tbug881.pp deleted file mode 100644 index aa5d789e8c..0000000000 --- a/tests/webtbs/tbug881.pp +++ /dev/null @@ -1,14 +0,0 @@ -PROGRAM TEST; -TYPE - byteSet = SET OF 0..7; - booleanArray = ARRAY[0..HIGH(word) DIV 8] OF byteSet; - booleanArrayPointer = ^booleanArray; - -PROCEDURE SetBooleanArray( CONST p : booleanArrayPointer; - CONST index : word ); -BEGIN - INCLUDE(p^[index DIV 8],index MOD 8) -END; - -BEGIN -END. diff --git a/tests/webtbs/tbug882.pp b/tests/webtbs/tbug882.pp deleted file mode 100644 index b26b45db7c..0000000000 --- a/tests/webtbs/tbug882.pp +++ /dev/null @@ -1,30 +0,0 @@ -{$D+,E-,I+,L+,P-,Q+,R+,S+,T+,V+,X+,Y+} -{$M 8192,0,655360} -PROGRAM TEST; -CONST - maxBlockSize = 1 SHL 13; -TYPE - byteBlock = ARRAY[0..PRED(maxBlockSize)] OF byte; -VAR - bb0 : ^byteBlock; -TYPE - rec = RECORD i1, len : word END; -VAR - mr : rec; - bw : word; -BEGIN - NEW(bb0); - mr.i1:=0; mr.len:=0; - bb0^[0] := 1; - bb0^[1] := 2; - {$T+} - bw:=word(Addr(bb0^[mr.i1])^); - if bw <> 1 then - halt(1); - {$T-} - bw:=word(Addr(bb0^[mr.i1])^); - if bw <> (2 shl 8 + 1) then - halt(1); -END -. - diff --git a/tests/webtbs/tbug890.pp b/tests/webtbs/tbug890.pp deleted file mode 100644 index 495d328e13..0000000000 --- a/tests/webtbs/tbug890.pp +++ /dev/null @@ -1,43 +0,0 @@ -{$ifdef FPC} - {$MODE TP} -{$endif FPC} - -unit tbug890; - -INTERFACE - -procedure GetScreenLine(const x: Integer); - -function dummy(const x : integer) : integer; -function dummy2(var x : integer) : integer; -function dummystr(x : integer) : string; - -IMPLEMENTATION - - -procedure GetScreenLine; -begin -end; - -function dummy2; -begin - dummy2:=x; - x:=0; -end; - -function dummystr; -var - s : string; -begin - str(x,s); - dummystr:=s; -end; - -{ this one is refused by BP :( } -function dummy : integer; -begin - dummy:=x; -end; - -begin -end. \ No newline at end of file diff --git a/tests/webtbs/tbug891.pp b/tests/webtbs/tbug891.pp deleted file mode 100644 index 6c2bb4883c..0000000000 --- a/tests/webtbs/tbug891.pp +++ /dev/null @@ -1,39 +0,0 @@ -{ this declaration: ;} -{$ifdef FPC} - {$mode TP} -{$endif} - var - name_a : packed array[0..255] of char; - -const - name_b : PChar = 't'; - -begin - { the FPC compiler (0.99.14a) will refuse to compile - the line ; } - name_a[0]:='x'; - name_a[1]:=#0; - if (name_b <> name_a) then - begin - writeln(' a and b are different'); - end - else - writeln('address of name_a and name_b are equal'); - { while it works under Turbo Pascal (TP). ;} - name_b:=@name_a; - if name_a<>name_b then - begin - Writeln('Wrong result'); - Halt(1); - end; -{$ifdef FPC} - if (name_b <> PChar(name_a)) then - writeln(' a and b are different'); - { is a legal FPC line, but illegal in TP.} -{$endif} - { I used ; } - if (name_b <> PChar(@name_a)) then - writeln(' a and b are different'); - {because it seems to work for both compiler.} - -end. \ No newline at end of file diff --git a/tests/webtbs/tbug892.pp b/tests/webtbs/tbug892.pp deleted file mode 100644 index cf83496232..0000000000 --- a/tests/webtbs/tbug892.pp +++ /dev/null @@ -1,18 +0,0 @@ - - -{$asmmode intel} - -var - i,j : longint; - -begin - i:=56; - { this should work as ss and ds have the same selector value } - asm - segss - mov eax,dword ptr [i] - mov dword ptr [j],eax - end; - if i<>j then - Halt(1); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug893.pp b/tests/webtbs/tbug893.pp deleted file mode 100644 index aedcd10ffa..0000000000 --- a/tests/webtbs/tbug893.pp +++ /dev/null @@ -1,17 +0,0 @@ -{$asmmode intel} -type - BugObject = object - Fld: word; - procedure WontCompile; - end; - -procedure BugObject.WontCompile; -begin - asm - xor ax, ax - mov fld, ax - end; -end; - -begin -end. diff --git a/tests/webtbs/tbug895.pp b/tests/webtbs/tbug895.pp deleted file mode 100644 index 7d096b022a..0000000000 --- a/tests/webtbs/tbug895.pp +++ /dev/null @@ -1,14 +0,0 @@ -program bug; - -begin - {$I-} - mkdir('test895'); - InOutRes:=0; - {$I+} - writeln('This is a test'); - {$I-} - mkdir('test895'); - InOutRes:=0; - {$I+} - writeln('This is a test'); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug896.pp b/tests/webtbs/tbug896.pp deleted file mode 100644 index 86552230c6..0000000000 --- a/tests/webtbs/tbug896.pp +++ /dev/null @@ -1,34 +0,0 @@ - -var - dat,dat2 : file of byte; - j : longint; - Buffer,Buffer2 : Array[0..2047] of byte; - -begin - for j:=0 to 2047 do - Buffer[j]:=j and $ff; - Assign(dat,'tbug896.txt'); - Rewrite(dat,1); - for j:= 0 to 2047 do - write (dat,Buffer[j]); - Close(dat); - Assign(dat2,'tbug896a.txt'); - Rewrite(dat2); - for j:= 0 to 2047 do - write (dat2,Buffer[j]); - Close(dat2); - Reset(dat); - Reset(dat2,1); - for j:=0 to 2047 do - begin - read(dat,Buffer[j]); - read(dat2,Buffer2[j]); - if Buffer[j]<>Buffer2[j] then - begin - Writeln('Error in typed file handling'); - Halt(1); - end; - end; - Close(dat); - close(dat2); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug900.pp b/tests/webtbs/tbug900.pp deleted file mode 100644 index 8a5fb3cc9f..0000000000 --- a/tests/webtbs/tbug900.pp +++ /dev/null @@ -1,14 +0,0 @@ -program Test; - -uses strings; - -var Str1 : PChar; - -begin - GetMem(Str1,256); - StrPCopy (Str1, ParamStr(0)); - writeln ('Arg 0 is "',Str1,'"'); - StrPCopy (Str1, ParamStr(1)); - writeln ('Arg 1 is "',Str1,'"'); - FreeMem(Str1,256); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug902.pp b/tests/webtbs/tbug902.pp deleted file mode 100644 index 86cecdda98..0000000000 --- a/tests/webtbs/tbug902.pp +++ /dev/null @@ -1,12 +0,0 @@ -uses - dos; -begin - writeln; - writeln(fsearch('c:\command.com', '')); - { here you get the full path in BP7, but nothing in FPC } - writeln(fsearch('c:\command.com', 'c:\a')); - { I really would not consider this as a bug !! } - { this use of fsearch is not document in BP PM } - if fsearch('c:\command.com', '')<>fsearch('c:\command.com', 'c:\a') then - Writeln('fsearch result is not BP compatible'); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug909.pp b/tests/webtbs/tbug909.pp deleted file mode 100644 index 9aa3aa9d70..0000000000 --- a/tests/webtbs/tbug909.pp +++ /dev/null @@ -1,7 +0,0 @@ -uses sysutils; - var r:array[0..3] of real; -begin - r[0]:=1; r[1]:=2; r[2]:=3; r[3]:=4; - // the following is supposed to print "1, 2, 3, 4", instead it prints "4, 4, 4, 4" - writeln(format('%g, %g, %g, %g',[r[0],r[1],r[2],r[3]])); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug911.pp b/tests/webtbs/tbug911.pp deleted file mode 100644 index 19f1d46b8e..0000000000 --- a/tests/webtbs/tbug911.pp +++ /dev/null @@ -1,8 +0,0 @@ -Function Log(const b,r:real):real; -begin - log:=ln(r)/ln(b); -end; - -begin - log(2,5); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug912.pp b/tests/webtbs/tbug912.pp deleted file mode 100644 index db5ef30c78..0000000000 --- a/tests/webtbs/tbug912.pp +++ /dev/null @@ -1,44 +0,0 @@ -const - BufSize = 2048; - -var - f : file; - res : longint; - buf : array [0..BufSize-1] of byte; - result : word; -begin -assign(f,paramstr(0)); -{$I-} -reset(f,1); -res:=IOResult; -{$I+} -if res=0 then - Writeln('It is possible to open the executable in Read/Write mode') -else - begin - filemode:=0; - {$I-} - reset(f,1); - res:=IOResult; - {$I+} - if res=0 then - Writeln('It is only possible to open the executable in Read mode') - else - Writeln('It is not possible to open the executable in Read mode'); - end; -if res=0 then - begin -{$I-} - blockread(f,buf,sizeof(buf),result); - res:=IOResult; -{$I+} - if res<>0 then - Writeln('Problem reading executable'); - if res=0 then - close(f) - else - RunError(res); - end -else - RunError(res); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug918.pp b/tests/webtbs/tbug918.pp deleted file mode 100644 index 6baf4796ef..0000000000 --- a/tests/webtbs/tbug918.pp +++ /dev/null @@ -1,15 +0,0 @@ -program test; - -procedure Test1; -var - a: Integer; - - procedure Test2; - begin - a:= 0; - end; -begin -end; - -begin -end. diff --git a/tests/webtbs/tbug919.pp b/tests/webtbs/tbug919.pp deleted file mode 100644 index 0576469d61..0000000000 --- a/tests/webtbs/tbug919.pp +++ /dev/null @@ -1,15 +0,0 @@ - var i:integer; -{$i386_intel} -{ "mov i,1" - is like - "mov word ptr [i],1" - or - movw i,$1 in ATT syntax } - -begin - asm - mov i, 1 - end; - if i <> 1 then - halt(1); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug922.pp b/tests/webtbs/tbug922.pp deleted file mode 100644 index 681aee0ea9..0000000000 --- a/tests/webtbs/tbug922.pp +++ /dev/null @@ -1,24 +0,0 @@ -program test; - -{$ifdef win32} -uses - windows; -{$endif } - -procedure write1( var charbuf:string); -begin - Writeln(Charbuf); -end; - -procedure write2( var charbuf:string; attrbuf:array of word); -begin - Writeln(Charbuf); -end; - -var chars : String[82]; - attrs : array [1..162] of word; -begin - Chars := 'Das ist ein Test, den ich gerade schreibe'; - write1(chars); - write2(chars,attrs); -end. diff --git a/tests/webtbs/tbug925.pp b/tests/webtbs/tbug925.pp deleted file mode 100644 index 58ec24a714..0000000000 --- a/tests/webtbs/tbug925.pp +++ /dev/null @@ -1,23 +0,0 @@ -{$asmmode intel} - -{$ifdef go32v2} - PROCEDURE Cursor(Form: word);assembler; - asm - mov cx,word ptr[Form] - and cx,1F1Fh - mov ah,1 - int 10h - end; -{$else not go32v2} - { no interrupt call on other targets } - procedure cursor(form : word);assembler; - asm - mov cx,word ptr[Form] - and cx,1F1Fh - mov ah,1 - end; -{$endif go32v2} - -begin - Cursor($11F); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug932.pp b/tests/webtbs/tbug932.pp deleted file mode 100644 index ca1a389d59..0000000000 --- a/tests/webtbs/tbug932.pp +++ /dev/null @@ -1,16 +0,0 @@ -program test; - -{$ASMMODE Intel } - -procedure TestProc; -const - TestConst: String = 'Test'; -begin - asm - mov edi, offset TestConst - end; -end; - -begin - TestProc; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug934.pp b/tests/webtbs/tbug934.pp deleted file mode 100644 index 3e80af99fe..0000000000 --- a/tests/webtbs/tbug934.pp +++ /dev/null @@ -1,19 +0,0 @@ -{ $OPT=-Or } -{$mode objfpc} - Type - t = class(TObject) - f1,f2:dword; - constructor Init(p1, p2:dword); - end; - - constructor t.Init(p1, p2:dword); - begin - f1:=p1; f2:=p2; - end; - var ti:t; -begin - ti:=t.Init(1,2); - writeln(ti.f1, ', ', ti.f2); // prints garbage instead of t2 - if ti.f2<>2 then - Halt(1); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug935.pp b/tests/webtbs/tbug935.pp deleted file mode 100644 index fbf479644e..0000000000 --- a/tests/webtbs/tbug935.pp +++ /dev/null @@ -1,23 +0,0 @@ -{$inline on} - -procedure test(v:boolean); - - procedure notice(s:string);inline; - begin - writeln(s); - end; - -begin -if v then notice('this string vanishes.'); -writeln('"test" main body executed.'); -end; - - - -begin -writeln('testing with True...'); -test(true); -writeln; -writeln('testing with False...'); -test(false); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug937.pp b/tests/webtbs/tbug937.pp deleted file mode 100644 index ed6dc37ad1..0000000000 --- a/tests/webtbs/tbug937.pp +++ /dev/null @@ -1,17 +0,0 @@ -program test_0_to_power_6; - -uses - crt; -var - result,number,exponent : integer; -begin - number := 0; - exponent := 6; - result := number ** exponent; - write (result); - if result<>0 then - begin - Writeln(' 0 ** 6 should be equal to 0'); - Halt(1); - end; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug938.pp b/tests/webtbs/tbug938.pp deleted file mode 100644 index bb00434211..0000000000 --- a/tests/webtbs/tbug938.pp +++ /dev/null @@ -1,74 +0,0 @@ -Program test_operator; -type - Vector = record - X,Y,Z : extended; - end; - Matrix = array [1..4,1..4] of extended; - -Const - IDENTITYMATRIX : Matrix = - ( (1,0,0,0), - (0,1,0,0), - (0,0,1,0), - (0,0,0,1)); -{...} - -function NewVector (ax,ay,az : extended) : Vector; -begin - NewVector.X:=ax; - NewVector.Y:=ay; - NewVector.Z:=az; -end; - -operator * (V : Vector;Value : extended) Result : Vector; - begin - Result.X:=Result.X*Value; - Result.Y:=Result.Y*Value; - Result.Z:=Result.Z*Value; - end; -{...} -operator * (Value : extended;V : Vector) Result : Vector; - begin - Result.X:=Result.X*Value; - Result.Y:=Result.Y*Value; - Result.Z:=Result.Z*Value; - end; -{...} - - -operator * (M : Matrix;Value : extended) Result : Matrix; - var i,j : longint; - begin - for i:=1 to 4 do - for j:=1 to 4 do - Result[i,j]:=M[i,j]*Value; - end; -{...} -operator * (Value : extended;M : Matrix) Result : Matrix; - var i,j : longint; - begin - for i:=1 to 4 do - for j:=1 to 4 do - Result[i,j]:=M[i,j]*Value; - end; -{...} - -var - V1, V2 : Vector; - M1, M2 : Matrix; - -begin - V1 := NewVector (1,1,1); - V2 := V1 * 2; - { Everything ok } - - - M2 := IDENTITYMATRIX; - M1 := M2 * 2; - M1 := IDENTITYMATRIX * 2; - M2 := IDENTITYMATRIX * 4; - { Error: Incompatible types: got "E3MATRIX" expected "LONGINT" in both rows. This doesn't happen if I use 2.0 and 4.0 values. } - - - {...} -end. diff --git a/tests/webtbs/tbug944.pp b/tests/webtbs/tbug944.pp deleted file mode 100644 index 33f1d15426..0000000000 --- a/tests/webtbs/tbug944.pp +++ /dev/null @@ -1,26 +0,0 @@ -{$ifdef TP} -{$N+} -{$endif TP} -PROGRAM fadd_bug; -VAR x,y,z,t: double; -BEGIN -x:=4.5; -y:=5.5; -{$ifndef TP} -{$asmmode intel} -{$endif TP} -asm - fld x - fld y - fadd - fstp z -end; -t:=x+y; -if (z<>10.0) or (z<>t) then - begin - Writeln('Error in FADD handling'); - Halt(1); - end -else - Writeln('FADD assembler instruction works'); -END. \ No newline at end of file diff --git a/tests/webtbs/tbug947.pp b/tests/webtbs/tbug947.pp deleted file mode 100644 index 4b59eca603..0000000000 --- a/tests/webtbs/tbug947.pp +++ /dev/null @@ -1,59 +0,0 @@ -{$mode objfpc} - -var - last,lastt2 : integer; - -type - T1 = class - procedure SomeMethod(Param: Integer); virtual; - end; - - T2 = class(T1) - procedure SomeMethod(Param: Integer); override; - procedure InheritedMethod(Param: Integer); - destructor Destroy; override; - end; - -procedure T1.SomeMethod(Param: Integer); -begin - last:=Param; - writeln('T1 ', Param); -end; - -procedure T2.InheritedMethod(Param: Integer); -begin - inherited SomeMethod(Param); -end; - -procedure T2.SomeMethod(Param: Integer); -begin - lastt2:=param; - writeln('T2 ', Param); -end; - -destructor T2.Destroy; -begin - SomeMethod(3); - inherited SomeMethod(2); - inherited Destroy; -end; - -var - A: T2; -begin - Last:=0; - lastt2:=0; - A:=T2.Create; - A.SomeMethod(1); { Ok } - if lastt2<>1 then - Halt(1); - A.InheritedMethod(4); { Ok } - if last<>4 then - Halt(1); - A.Free; { error } - if last<>2 then - Halt(1); - if lastt2<>3 then - Halt(1); - Writeln('Bug with calling inherited in destructors solved'); -end. \ No newline at end of file diff --git a/tests/webtbs/tbug961.pp b/tests/webtbs/tbug961.pp deleted file mode 100644 index 5c04a530b6..0000000000 --- a/tests/webtbs/tbug961.pp +++ /dev/null @@ -1,32 +0,0 @@ -{ older ppc386 only define cpu86 } -{$ifdef cpu86} -{$define cpui386} -{$endif cpu86} -var - x,y : byte; - z : longint; -{$asmmode intel} - -procedure test(var x : byte); -begin - x:=5; -{$ifdef cpui386} - asm - mov edi,$12345678 - mov edi,x - mov dword ptr [edi],78 - end; -{$else cpui386} - x:=$78; -{$endif cpui386} -end; - -begin - x:=34; - test(x); - if x<>78 then - begin - Writeln('Problem !!'); - Halt(1); - end; -end. \ No newline at end of file diff --git a/tests/webtbs/tbug966.pp b/tests/webtbs/tbug966.pp deleted file mode 100644 index 18d6af4644..0000000000 --- a/tests/webtbs/tbug966.pp +++ /dev/null @@ -1,81 +0,0 @@ -{ Source provided for Free Pascal Bug Report 966 } -{$i-} -{$ifdef linux} -{$define has_sockets} -{$endif linux} -{$ifdef win32} -{$define has_sockets} -{$endif win32} - -{$ifdef has_sockets} -uses -{$ifdef linux} - linux, -{$else} - crt, -{$endif} - Sockets; -Var - S : Longint ; Sin,Sout: Text; - Temp, Temp2 : Char; - i : longint; - -const - isocket: TInetSockAddr= ( - Family:AF_INET; - Port:$1500; - Addr:((93*256+36)*256+161)*256+130); - {*** ftp 130.161.36.93 i.e. ftp.freepascal.org } - { FIXME: it would be much better to have the number - through a name server but I don't know how to do this ! PM } - - procedure perror(const S: string); - begin - writeln(S,SocketError); - halt(100) ; - end; - - procedure read_to_eof; - var - temp2 : char; - begin -{$ifdef linux} - while selecttext(sin,1)>0 do - begin - read(Sin,Temp2); - write(Temp2); - end; -{$else} - repeat until not eof(sin); - while not eof(sin) do - begin - read(Sin,Temp2); - write(Temp2); - delay(1); - end; -{$endif} - end; - -begin - S:=Socket(AF_INET,SOCK_STREAM,0); - if SocketError<>0 then Perror('Client : Socket : '); - WriteLn('*1'); - if not Connect(s,isocket,sin,sout)then Perror('Client : Socket : '); - WriteLn('*2'); - ReWrite(Sout); Reset(Sin); - WriteLn('*3'); - read_to_eof; - Writeln('Sending "USER anonymous#10"'); - Write(Sout,'USER anonymous'#10); - read_to_eof; - Writeln('Sending "PASS core@freepascal.org#10"'); - Write(Sout,'PASS core@freepascal.org'#10); - read_to_eof; - Writeln('Sending "QUIT#10"'); - Write(Sout,'QUIT'#10); - read_to_eof; - shutdown(s,2); close(sin); close(sout); -{$else : not has_sockets} - Writeln('No sockets unit for this target'); -{$endif has_sockets} -end. \ No newline at end of file diff --git a/tests/webtbs/tbug976.pp b/tests/webtbs/tbug976.pp deleted file mode 100644 index 107bd76f0f..0000000000 --- a/tests/webtbs/tbug976.pp +++ /dev/null @@ -1,41 +0,0 @@ -{ Source provided for Free Pascal Bug Report 976 } -{ Submitted by } -{ e-mail: } -Program Test_Me; - -type PDouble = ^Double; -var A, B: PDouble; - x: Double; - -Operator + (x: Double; A: PDouble) B: Double; - - begin - B := x + A^; - end; - -{ This was wrong because B value is not initialized !! -Operator + (x: Single; A: PDouble) B: PDouble; - - begin - B^ := x + A^; - end; } - -begin -new (A); -new (B); -x := 0.5; -A^ := x; - -{--- Addition "Double + Double": OK} -B^ := x + A^; -writeln (B^:4:2); -if B^<>1.0 then - Halt(1); -{---Identical error messages for addition "PDouble + Double" and "Double + PDouble"} -{---in spite of overloaded + operator} -// B := A + x; -B^ := x + A; -writeln (B^:4:2); -if B^<>1.0 then - Halt(1); -end. \ No newline at end of file diff --git a/tests/win95test.bat b/tests/win95test.bat deleted file mode 100644 index 1e6c939007..0000000000 --- a/tests/win95test.bat +++ /dev/null @@ -1,175 +0,0 @@ -@echo off -set CONT= -set FPC= -rem if arg1 or arg2 is cont then -rem do not erase old files -rem Create DATE env -rem to be able to save a version with the current date -make setdate -call setdate.bat -if "%1"=="cont" goto setcont -if "%2"=="cont" goto setcont -if "%1"=="diffs" goto setdiffs -if "%2"=="diffs" goto setdiffs -set CONT= -goto nocont -:setcont -set CONT=1 -if "%1"=="cont" goto doshift -goto nocont -:doshift -shift -:nocont -if "%1"=="" goto go32v2test -if "%1"=="go32v2" goto go32v2test -if "%1"=="win32" goto win32test -echo This batch file allows to test all test sources of the entire directory -echo Use "win95test go32v2" to run the test with ppc386 -echo Use "win95test win32" to run the test with ppwin32 (native win32 version) -echo or use "win95test" to run the test first with ppc386 and again with ppwin32 -echo "cont" arg can be used to continue a test suite -echo "diffs" can be used to generate diffs to last report -goto end -:go32v2test -set FPC=ppc386 -set LONGLOG=go32v2.longlog -if "%CONT%"=="1" goto go32v2cont -echo Test of FPC for > %LONGLOG% -%FPC% -l -iSO >> %LONGLOG% -echo Test of FPC for > log -%FPC% -l -iSO >> log -Echo Stderr output of Make > Make.err -make clean -if not exist units\makefile goto go32v2cont -make -C units OS_TARGET=go32v2 -:go32v2cont -set CONT= -set FPC=ppc386 -set OPT=-n -Fuunits -gl -Croi -make alltbf -make alltbf -make tbs0to99 -make tbs0to99 -make tbs100to199 -make tbs100to199 -make tbs200to299 -make tbs200to299 -make tbs300to399 -make tbs300to399 -make allts alltf allto -make allts alltf allto -make alltest -make alltest -make allwebtbf allwebtbs -make allwebtbf allwebtbs -make tbsexec0to99 -make tbsexec0to99 -make tbsexec100to199 -make tbsexec100to199 -make tbsexec200to299 -make tbsexec200to299 -make tbsexec300to399 -make tbsexec300to399 -make allwebtbsexec -make allwebtbsexec -make alltsexec -make alltsexec -make alltestexec -make alltestexec - -cp log go32v2.log -cp go32v2.log go32v2.%DATE%.log -cp go32v2.longlog go32v2.%DATE%.longlog -cp make.err go32v2.%DATE%.make.err -echo Go32v2 fail list of %DATE% > go32v2.%DATE%.fail -cat faillist >> go32v2.%DATE%.fail -:setdiffs -if "%1=="win32" goto setwin32diffs -if exist go32v2.lastfail goto go32diff -goto go32end -:go32diff -if not "%LASTDATE%"=="" goto go32lastset -call getlastgo32v2date.bat -:go32lastset -echo Go32v2 diffs from %LASTDATE% to %DATE% > go32v2.diff_to_last -diff -u faillist go32v2.lastfail >> go32v2.diff_to_last -cp go32v2.diff_to_last go32v2.%DATE%.diff - -:go32end -echo set LASTDATE=%DATE% > getlastgo32v2date.bat -cp faillist go32v2.lastfail - -rem should we pass the win32 test ? - -if "%1"=="go32v2" goto end - -rem Start of win32 part of test - -:win32test -set FPC=ppwin32 -set LONGLOG=win32.longlog -if "%CONT%"=="1" goto win32cont -Echo Stderr output of Make > Make.err -make clean -if not exist units\makefile goto win32nounits -make -C units OS_TARGET=win32 -:win32nounits -echo Test of FPC for > %LONGLOG% -%FPC% -l -iSO >> %LONGLOG% -echo Test of FPC for > log -%FPC% -l -iSO >> log -:win32cont -set CONT= -set FPC=ppwin32 -set OPT=-n -Fuunits -gl -Croi -make alltbf -make alltbf -make tbs0to99 -make tbs0to99 -make tbs100to199 -make tbs100to199 -make tbs200to299 -make tbs200to299 -make tbs300to399 -make tbs300to399 -make allts alltf allto -make allts alltf allto -make alltest -make alltest -make allwebtbf allwebtbs -make allwebtbf allwebtbs -make tbsexec0to99 -make tbsexec0to99 -make tbsexec100to199 -make tbsexec100to199 -make tbsexec200to299 -make tbsexec200to299 -make tbsexec300to399 -make tbsexec300to399 -make allwebtbsexec -make allwebtbsexec -make alltsexec -make alltsexec -make alltestexec -make alltestexec -cp log win32.log -cp win32.log win32.%DATE%.log -cp win32.longlog win32.%DATE%.longlog -cp faillist win32.%DATE%.fail -cp make.err win32.%DATE%.make.err - -:setwin32diffs -if exist win32.lastfail goto win32diff -goto win32end -:win32diff -if not "%LASTDATE%"=="" goto win32lastset -call getlastwin32date.bat -:win32lastset -echo Win32 diffs from %LASTDATE% to %DATE% > win32.diff_to_last -diff -u faillist win32.lastfail >> win32.diff_to_last -cp win32.diff_to_last win2.%DATE%.diff - -:win32end -echo set LASTDATE=%DATE% > getlastwin32date.bat -cp faillist win32.lastfail -:end