├── src ├── units │ └── dummy.txt ├── compiler │ ├── units │ │ └── dummy.txt │ ├── mlc.pas │ ├── mbc.pas │ └── __mla__system.mla ├── interpreter │ ├── units │ │ └── dummy.txt │ ├── mli.pas │ └── mainmodule.mfm ├── test │ ├── base │ │ ├── program.mla │ │ ├── test1.mla │ │ ├── test_unit.mla │ │ ├── control │ │ │ ├── halt3.mla │ │ │ ├── halt1.mla │ │ │ ├── uhalt1.pas │ │ │ ├── halt2.mla │ │ │ ├── goto │ │ │ │ ├── goto2.mla │ │ │ │ ├── goto1.mla │ │ │ │ └── goto3.mla │ │ │ ├── while1.mla │ │ │ ├── repeat1.mla │ │ │ ├── forto16.mla │ │ │ ├── breakrepeat.mla │ │ │ ├── breakwhile.mla │ │ │ ├── continuewhile.mla │ │ │ ├── exit.mla │ │ │ ├── continuerepeat.mla │ │ │ ├── forto.mla │ │ │ ├── nestedwhile.mla │ │ │ ├── fordownto.mla │ │ │ ├── iftest.mla │ │ │ ├── forto2.mla │ │ │ ├── recifindi.mla │ │ │ └── forto3.mla │ │ ├── minprog.mla │ │ ├── io │ │ │ ├── writelnint.mla │ │ │ └── writelnstr.mla │ │ ├── arith │ │ │ ├── not1.mla │ │ │ ├── neg1.mla │ │ │ ├── incval1.mla │ │ │ ├── shl1.mla │ │ │ ├── shr1.mla │ │ │ ├── divop.mla │ │ │ ├── bool │ │ │ │ ├── and1.mla │ │ │ │ ├── or1.mla │ │ │ │ ├── not1.mla │ │ │ │ ├── booleval2.mla │ │ │ │ ├── and2.mla │ │ │ │ └── booleval1.mla │ │ │ ├── incdec.mla │ │ │ ├── addsubint.mla │ │ │ ├── updatesize.mla │ │ │ ├── inc1.mla │ │ │ ├── incdecindpo.mla │ │ │ ├── incvalpo1.mla │ │ │ ├── pointer │ │ │ │ ├── pointeradd.mla │ │ │ │ ├── pointerdiff.mla │ │ │ │ ├── pointerdiff1.mla │ │ │ │ ├── pointerrecadd.mla │ │ │ │ ├── pointerindex.mla │ │ │ │ └── pointeradd1.mla │ │ │ ├── float │ │ │ │ ├── sin1.mla │ │ │ │ ├── floatassign.mla │ │ │ │ └── floatconst.mla │ │ │ ├── andorxor1.mla │ │ │ ├── divisionop.mla │ │ │ ├── cmp │ │ │ │ ├── cmpstring8.mla │ │ │ │ ├── cmpenum.mla │ │ │ │ └── cmppointer.mla │ │ │ ├── incdecind.mla │ │ │ ├── set │ │ │ │ ├── index1.mla │ │ │ │ ├── index2.mla │ │ │ │ ├── inclexcl2.mla │ │ │ │ ├── inclexcl3.mla │ │ │ │ ├── inclexcl.mla │ │ │ │ └── largeset1.mla │ │ │ ├── abs.mla │ │ │ └── bitexp1.mla │ │ ├── compilerunit.mla │ │ ├── string │ │ │ ├── stringtest.mla │ │ │ ├── chartostring.mla │ │ │ ├── conversion │ │ │ │ └── bytes.mla │ │ │ ├── string1.mla │ │ │ ├── stringconcat2.mla │ │ │ ├── resourcestring │ │ │ │ └── resourcestr.mla │ │ │ ├── stringconcat.mla │ │ │ ├── stringconcat1.mla │ │ │ └── stringconsttochar.mla │ │ ├── mem │ │ │ ├── memcpy.mla │ │ │ ├── setmem.mla │ │ │ └── getmem.mla │ │ ├── conversions │ │ │ ├── potoint32.mla │ │ │ ├── anytopo.mla │ │ │ ├── sizeconvert1.mla │ │ │ ├── recordconversion.mla │ │ │ ├── stringtopo.mla │ │ │ ├── convchain1.mla │ │ │ ├── objtoobj.mla │ │ │ ├── aggregate1.mla │ │ │ ├── leftsidecast.mla │ │ │ ├── ord.mla │ │ │ ├── pointercast.mla │ │ │ ├── stringconv.mla │ │ │ └── leftsidecast1.mla │ │ ├── caseins.mla │ │ ├── array │ │ │ ├── arrayhigh.mla │ │ │ ├── arraylength.mla │ │ │ ├── arraysizeof.mla │ │ │ ├── array1.mla │ │ │ └── chararrayindex.mla │ │ ├── var │ │ │ └── commasep.mla │ │ ├── const │ │ │ ├── unit1.mla │ │ │ ├── typedconst2.mla │ │ │ ├── stringconst.mla │ │ │ └── typedconst1.mla │ │ ├── indirect │ │ │ ├── varpar.mla │ │ │ ├── indirectpar.mla │ │ │ ├── varparload.mla │ │ │ ├── recindi.mla │ │ │ ├── varparrec.mla │ │ │ ├── indirectloc.mla │ │ │ ├── parrecindi.mla │ │ │ ├── recderef.mla │ │ │ ├── varparrecload.mla │ │ │ ├── pointerrec.mla │ │ │ └── pointerrec1.mla │ │ ├── address │ │ │ ├── addressassign.mla │ │ │ ├── address.mla │ │ │ └── arrayitemaddress.mla │ │ ├── types │ │ │ ├── typeequ2.mla │ │ │ ├── typeequ1.mla │ │ │ ├── forwardpointer.mla │ │ │ ├── classtype.mla │ │ │ ├── anonenum.mla │ │ │ └── set1.mla │ │ ├── sub │ │ │ ├── param │ │ │ │ ├── constpar.mla │ │ │ │ ├── constpar1.mla │ │ │ │ ├── defaultemptyset.mla │ │ │ │ ├── varparpointer.mla │ │ │ │ ├── arrayofconst.mla │ │ │ │ ├── varparrec.mla │ │ │ │ └── classparam.mla │ │ │ ├── function1.mla │ │ │ ├── pofunc.mla │ │ │ ├── external1.mla │ │ │ ├── recsubres.mla │ │ │ ├── openarray │ │ │ │ ├── openarray3.mla │ │ │ │ ├── openarray3a.mla │ │ │ │ ├── openarray5.mla │ │ │ │ ├── openarray5a.mla │ │ │ │ ├── openarray4.mla │ │ │ │ ├── openarray4a.mla │ │ │ │ ├── openarray7.mla │ │ │ │ ├── openarray7a.mla │ │ │ │ ├── openarray6.mla │ │ │ │ ├── openarray6a.mla │ │ │ │ ├── openarray2.mla │ │ │ │ ├── openarray2a.mla │ │ │ │ ├── openarray1.mla │ │ │ │ └── openarray1a.mla │ │ │ ├── subresfield.mla │ │ │ ├── constref1.mla │ │ │ ├── pppar.mla │ │ │ ├── nestedsub1.mla │ │ │ ├── varppar.mla │ │ │ ├── forward1.mla │ │ │ ├── ppar.mla │ │ │ ├── nestedsub2.mla │ │ │ ├── constref.mla │ │ │ ├── setparam.mla │ │ │ ├── external.mla │ │ │ ├── subvar │ │ │ │ ├── subaddress.mla │ │ │ │ ├── subvar1.mla │ │ │ │ ├── subvar.mla │ │ │ │ ├── factsubcall.mla │ │ │ │ ├── subvar2.mla │ │ │ │ └── subvar3.mla │ │ │ ├── objectfieldresult.mla │ │ │ ├── managed │ │ │ │ ├── subvarres3.mla │ │ │ │ ├── subvarres2.mla │ │ │ │ ├── subres1.mla │ │ │ │ └── subvarres1.mla │ │ │ ├── defaultpar1.mla │ │ │ ├── recparpo.mla │ │ │ ├── recparsubres.mla │ │ │ ├── nested │ │ │ │ ├── nestedaccess.mla │ │ │ │ └── nestedaccess1.mla │ │ │ ├── overload2.mla │ │ │ ├── overload1.mla │ │ │ └── defaultpar2.mla │ │ ├── enum │ │ │ ├── enum2.mla │ │ │ ├── enum3.mla │ │ │ └── enum1.mla │ │ ├── record │ │ │ ├── recordfield.mla │ │ │ ├── recordfieldind.mla │ │ │ ├── pointerinrec.mla │ │ │ ├── recordfieldind2.mla │ │ │ ├── case2.mla │ │ │ ├── recordcopy.mla │ │ │ ├── case4.mla │ │ │ ├── case.mla │ │ │ ├── case3.mla │ │ │ └── case1.mla │ │ ├── exception │ │ │ ├── except1.mla │ │ │ ├── raise1.mla │ │ │ ├── raise3.mla │ │ │ ├── raise2.mla │ │ │ ├── unhandled.mla │ │ │ ├── except2.mla │ │ │ ├── except3.mla │ │ │ ├── finally1.mla │ │ │ ├── except7.mla │ │ │ └── except4.mla │ │ ├── set │ │ │ ├── setconstructor1.mla │ │ │ ├── xorset1.mla │ │ │ ├── set2.mla │ │ │ ├── setcomp1.mla │ │ │ ├── setops1.mla │ │ │ ├── inset1.mla │ │ │ ├── bigset4.mla │ │ │ ├── bigset2.mla │ │ │ └── bigset3.mla │ │ ├── with │ │ │ ├── with1.mla │ │ │ ├── withpo.mla │ │ │ ├── with4.mla │ │ │ ├── with2.mla │ │ │ ├── withpo2.mla │ │ │ ├── with3.mla │ │ │ ├── withpo1.mla │ │ │ ├── withqualified1.mla │ │ │ └── withderef.mla │ │ ├── dynarray │ │ │ ├── copy.mla │ │ │ ├── setlength.mla │ │ │ ├── setlength2.mla │ │ │ ├── length.mla │ │ │ ├── nestedloc.mla │ │ │ ├── unique.mla │ │ │ └── setlength1.mla │ │ ├── managed │ │ │ ├── managedparam.mla │ │ │ ├── managedresult.mla │ │ │ ├── finistringar.mla │ │ │ ├── globrecassign.mla │ │ │ ├── arrayofstring1.mla │ │ │ ├── checkuniquestring.mla │ │ │ ├── arrayofarray1.mla │ │ │ ├── arrayofstring2.mla │ │ │ └── assign1.mla │ │ ├── pointer │ │ │ └── addresstype.mla │ │ └── condition │ │ │ └── condition1.mla │ ├── units │ │ ├── tempvar.mla │ │ ├── unit1.mla │ │ ├── finalization1.mla │ │ ├── unituses1.mla │ │ ├── unituses2.mla │ │ ├── unit2.mla │ │ ├── unit3.mla │ │ └── unit4.mla │ ├── syntax │ │ └── errorcheck │ │ │ ├── missingendok.mla │ │ │ ├── missingend.mla │ │ │ ├── conversions │ │ │ ├── pointertostring1.mla │ │ │ ├── pointertostring2.mla │ │ │ ├── pointertostring3.mla │ │ │ └── constparam.mla │ │ │ ├── procedure │ │ │ ├── bodyattachment.mla │ │ │ └── impldupplicate.mla │ │ │ ├── params │ │ │ ├── constpar2.mla │ │ │ ├── constpar1.mla │ │ │ ├── missingpar.mla │ │ │ └── constpar.mla │ │ │ ├── visibility │ │ │ └── classfield1.mla │ │ │ ├── statements │ │ │ └── subresfield.mla │ │ │ ├── sets │ │ │ ├── setrange.mla │ │ │ ├── set1.mla │ │ │ └── set2.mla │ │ │ ├── address │ │ │ └── deref1.mla │ │ │ ├── control │ │ │ ├── caseerror2.mla │ │ │ └── caseerror1.mla │ │ │ ├── pointer │ │ │ └── assignment1.mla │ │ │ └── objects │ │ │ └── doubleprop.mla │ ├── syssubs │ │ └── writeln │ │ │ ├── writechar.mla │ │ │ └── writeinsub.mla │ ├── rtl │ │ ├── stream │ │ │ └── stream1.mla │ │ ├── variants │ │ │ ├── variant1.mla │ │ │ ├── variant2.mla │ │ │ ├── variantstring.mla │ │ │ ├── tostring.mla │ │ │ └── variantstring1.mla │ │ ├── streaming │ │ │ └── streaming1.mla │ │ ├── string │ │ │ ├── stringicomp1.mla │ │ │ ├── inttostrtest.mla │ │ │ └── format1.mla │ │ ├── tobject │ │ │ ├── tobject1.mla │ │ │ ├── ini.mla │ │ │ └── classtype.mla │ │ ├── system │ │ │ └── errno.mla │ │ └── typeinfo │ │ │ └── property1.mla │ ├── intrinsics │ │ ├── managed │ │ │ ├── copyar1.mla │ │ │ ├── copystring1.mla │ │ │ ├── copyar2.mla │ │ │ ├── copystring3.mla │ │ │ ├── copyar3.mla │ │ │ ├── unique3.mla │ │ │ ├── initialize.mla │ │ │ ├── incdecref.mla │ │ │ ├── initclass1.mla │ │ │ ├── initclass.mla │ │ │ └── initclass2.mla │ │ ├── typeinfo │ │ │ ├── typeinfo1.mla │ │ │ ├── typeofclass.mla │ │ │ ├── typeofclass2.mla │ │ │ ├── typeofclass1.mla │ │ │ └── classrtti.mla │ │ └── numeric │ │ │ └── decnested.mla │ ├── object │ │ ├── methods │ │ │ ├── objparam.mla │ │ │ ├── objfield1.mla │ │ │ ├── paramname.mla │ │ │ ├── methodvarresult.mla │ │ │ ├── method1.mla │ │ │ └── methodparams.mla │ │ ├── objvariant.mla │ │ ├── operators │ │ │ ├── operator2.mla │ │ │ ├── operator3.mla │ │ │ ├── operator6.mla │ │ │ ├── operator5.mla │ │ │ ├── assignop1.mla │ │ │ ├── assignop2.mla │ │ │ ├── operator1.mla │ │ │ └── operator4.mla │ │ ├── objectintf.mla │ │ ├── object1.mla │ │ ├── object2.mla │ │ ├── object3.mla │ │ ├── objvariant1.mla │ │ ├── object8.mla │ │ ├── object6.mla │ │ ├── object5.mla │ │ ├── object4.mla │ │ └── object7.mla │ ├── helloworld │ │ └── hellomselang.pas │ └── class │ │ ├── classstringfield.mla │ │ ├── forwardclass.mla │ │ ├── methods │ │ ├── method1.mla │ │ ├── method3.mla │ │ ├── method4.mla │ │ ├── method2.mla │ │ ├── method5.mla │ │ └── method6.mla │ │ ├── constructor1.mla │ │ ├── classparam.mla │ │ ├── properties │ │ ├── classprop1.mla │ │ ├── procwrite.mla │ │ ├── funcread.mla │ │ ├── classprop3.mla │ │ ├── samename.mla │ │ ├── classprop2.mla │ │ ├── funcread2.mla │ │ ├── arrayparamsetind1.mla │ │ ├── arrayparamsetind2.mla │ │ ├── classprop4.mla │ │ ├── arrayparamget.mla │ │ ├── int64getterass.mla │ │ ├── int64getterass2.mla │ │ ├── selftest.mla │ │ └── arrayparam1.mla │ │ ├── objectclass1.mla │ │ ├── constructor4.mla │ │ ├── classminimal.mla │ │ ├── sizeof │ │ ├── sizeofclass1.mla │ │ └── sizeofclass2.mla │ │ ├── constructor2.mla │ │ ├── field1.mla │ │ ├── destructor1.mla │ │ ├── callinherited.mla │ │ ├── classvirtual.mla │ │ ├── constructor3.mla │ │ ├── classis.mla │ │ ├── calls │ │ └── inheritedfunc.mla │ │ ├── classis1.mla │ │ ├── classof │ │ ├── classmethod2.mla │ │ ├── classmethod.mla │ │ ├── classmethod1.mla │ │ ├── classmethod3.mla │ │ └── classmethod4.mla │ │ ├── interface │ │ └── classinterface.mla │ │ └── classfield.mla ├── writeln.mla ├── unit3.mla ├── image │ ├── mselang_24.png │ ├── mselang_32.png │ ├── mselang_48.png │ └── mselang_64.png ├── units.mla ├── unit0.mla ├── testprocx.mla ├── compound.mla ├── unitc1.mla ├── enum.mla ├── classinh1.mla ├── differences.txt ├── testproc.mla ├── set.mla ├── compmoduledebug.mfm ├── string.mla ├── typex.mla ├── testproc1.mla ├── unit2.mla ├── bcwriter │ ├── bcwritertest.pas │ ├── createabbrev │ │ ├── createabbrev.pas │ │ ├── test.abr │ │ ├── type.abr │ │ ├── func.abr │ │ ├── const.abr │ │ ├── symtab.abr │ │ └── bcwriter.abr │ └── main.mfm ├── benchmark │ └── mctest │ │ └── viewer │ │ └── mctestview.pas ├── record.mla ├── test.mla ├── try1.mla ├── var.mla ├── type.mla ├── try.mla ├── tools │ └── linux_extra │ │ └── mselang.desktop ├── classinh.mla ├── interface.mla └── rtl │ └── classes │ └── rtl_classutils.mla └── .gitignore /src/units/dummy.txt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/compiler/units/dummy.txt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/interpreter/units/dummy.txt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/test/base/program.mla: -------------------------------------------------------------------------------- 1 | program program; 2 | begin 3 | end. -------------------------------------------------------------------------------- /src/test/base/test1.mla: -------------------------------------------------------------------------------- 1 | program test1; 2 | begin 3 | end. 4 | -------------------------------------------------------------------------------- /src/test/base/test_unit.mla: -------------------------------------------------------------------------------- 1 | unit test_unit; 2 | implementation 3 | end. -------------------------------------------------------------------------------- /src/test/base/control/halt3.mla: -------------------------------------------------------------------------------- 1 | program halt3; 2 | begin 3 | halt(123); 4 | end. -------------------------------------------------------------------------------- /src/test/base/minprog.mla: -------------------------------------------------------------------------------- 1 | program minprog; 2 | begin 3 | exitcode:= 123; 4 | end. -------------------------------------------------------------------------------- /src/test/units/tempvar.mla: -------------------------------------------------------------------------------- 1 | program tempvar; 2 | uses 3 | unit4; 4 | begin 5 | end. -------------------------------------------------------------------------------- /src/test/base/io/writelnint.mla: -------------------------------------------------------------------------------- 1 | program writelnint; 2 | begin 3 | writeln(123); 4 | end. -------------------------------------------------------------------------------- /src/test/base/io/writelnstr.mla: -------------------------------------------------------------------------------- 1 | program writelnstr; 2 | begin 3 | writeln('abc'); 4 | end. -------------------------------------------------------------------------------- /src/writeln.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | implementation 3 | begin 4 | writeln('abc'); 5 | end. 6 | -------------------------------------------------------------------------------- /src/unit3.mla: -------------------------------------------------------------------------------- 1 | unit unit3; 2 | interface 3 | type 4 | uni3ty = int32; 5 | implementation 6 | end. -------------------------------------------------------------------------------- /src/image/mselang_24.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mse-org/mselang/HEAD/src/image/mselang_24.png -------------------------------------------------------------------------------- /src/image/mselang_32.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mse-org/mselang/HEAD/src/image/mselang_32.png -------------------------------------------------------------------------------- /src/image/mselang_48.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mse-org/mselang/HEAD/src/image/mselang_48.png -------------------------------------------------------------------------------- /src/image/mselang_64.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mse-org/mselang/HEAD/src/image/mselang_64.png -------------------------------------------------------------------------------- /src/test/base/arith/not1.mla: -------------------------------------------------------------------------------- 1 | program not1; 2 | begin 3 | exitcode:= not exitcode + 1 + 123; 4 | end. -------------------------------------------------------------------------------- /src/test/units/unit1.mla: -------------------------------------------------------------------------------- 1 | unit unit1; 2 | implementation 3 | finalization 4 | exitcode:= 123; 5 | end. -------------------------------------------------------------------------------- /src/units.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | uses 3 | unit1; 4 | begin 5 | writeln('main'); 6 | tt1(123); 7 | end. -------------------------------------------------------------------------------- /src/test/units/finalization1.mla: -------------------------------------------------------------------------------- 1 | program finalization1; 2 | uses 3 | unit1; 4 | 5 | begin 6 | end. 7 | -------------------------------------------------------------------------------- /src/test/units/unituses1.mla: -------------------------------------------------------------------------------- 1 | program unituses1; 2 | uses 3 | unit1; 4 | begin 5 | exitcode:= 22; 6 | end. -------------------------------------------------------------------------------- /src/test/base/arith/neg1.mla: -------------------------------------------------------------------------------- 1 | program neg1; 2 | begin 3 | exitcode:= -123; 4 | exitcode:= -exitcode; 5 | end. -------------------------------------------------------------------------------- /src/test/base/compilerunit.mla: -------------------------------------------------------------------------------- 1 | unit __mla__compilerunit compiler; 2 | interface 3 | implementation 4 | end. 5 | -------------------------------------------------------------------------------- /src/test/base/string/stringtest.mla: -------------------------------------------------------------------------------- 1 | program stringtest; 2 | var 3 | str1: string8; 4 | begin 5 | 6 | end. 7 | -------------------------------------------------------------------------------- /src/test/base/control/halt1.mla: -------------------------------------------------------------------------------- 1 | program halt1; 2 | begin 3 | exitcode:= 123; 4 | halt(); 5 | exitcode:= 11; 6 | end. -------------------------------------------------------------------------------- /src/test/base/arith/incval1.mla: -------------------------------------------------------------------------------- 1 | program incval1; 2 | var 3 | i1: int32; 4 | begin 5 | i1:= 123; 6 | inc(exitcode,i1); 7 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/missingendok.mla: -------------------------------------------------------------------------------- 1 | program missingendok; 2 | begin 3 | if exitcode = 1 then 4 | end; 5 | end. 6 | -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/missingend.mla: -------------------------------------------------------------------------------- 1 | program missingend; 2 | begin 3 | if exitcode = 1 then begin 4 | // end; 5 | 6 | end. 7 | -------------------------------------------------------------------------------- /src/unit0.mla: -------------------------------------------------------------------------------- 1 | unit unit0; 2 | implementation 3 | 4 | initialization 5 | writeln(123); 6 | finalization 7 | writeln(456); 8 | end. -------------------------------------------------------------------------------- /src/test/base/arith/shl1.mla: -------------------------------------------------------------------------------- 1 | program shl1; 2 | 3 | begin 4 | exitcode:= 11; 5 | exitcode:= ((exitcode shl 2) + (123 - 44)); 6 | end. -------------------------------------------------------------------------------- /src/test/base/arith/shr1.mla: -------------------------------------------------------------------------------- 1 | program shr1; 2 | 3 | begin 4 | exitcode:= 11*4; 5 | exitcode:= ((exitcode shr 2) + (123 - 11)); 6 | end. -------------------------------------------------------------------------------- /src/test/base/control/uhalt1.pas: -------------------------------------------------------------------------------- 1 | unit uhalt1; 2 | interface 3 | implementation 4 | finalization 5 | exitcode:= exitcode+23; 6 | end. 7 | -------------------------------------------------------------------------------- /src/test/base/arith/divop.mla: -------------------------------------------------------------------------------- 1 | program divop; 2 | var 3 | i1: int32; 4 | begin 5 | i1:= 123 * 4 div 2; 6 | exitcode:= i1 div 2; 7 | end. 8 | -------------------------------------------------------------------------------- /src/test/base/mem/memcpy.mla: -------------------------------------------------------------------------------- 1 | program memcpy; 2 | var 3 | i1: int32; 4 | begin 5 | i1:= 123; 6 | system.memcpy(@exitcode,@i1,4); 7 | end. 8 | -------------------------------------------------------------------------------- /src/test/base/arith/bool/and1.mla: -------------------------------------------------------------------------------- 1 | program and1; 2 | 3 | var 4 | i1: int32; 5 | begin 6 | i1:= $fe; 7 | exitcode:= i1 and $f + (123-14); 8 | end. -------------------------------------------------------------------------------- /src/test/base/arith/bool/or1.mla: -------------------------------------------------------------------------------- 1 | program or1; 2 | 3 | var 4 | i1: int32; 5 | begin 6 | i1:= $1000; 7 | exitcode:= i1 or 123;// - $1000; 8 | end. -------------------------------------------------------------------------------- /src/test/base/conversions/potoint32.mla: -------------------------------------------------------------------------------- 1 | program potoint32; 2 | var 3 | p1: pointer; 4 | begin 5 | inc(p1); 6 | exitcode:= int32(p1); 7 | end. 8 | -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/conversions/pointertostring1.mla: -------------------------------------------------------------------------------- 1 | program pointertostring1; 2 | var 3 | s1: string8; 4 | begin 5 | s1:= nil; 6 | end. -------------------------------------------------------------------------------- /src/test/base/arith/incdec.mla: -------------------------------------------------------------------------------- 1 | program incdec; 2 | var 3 | i1: int32; 4 | begin 5 | i1:= 124; 6 | inc(i1); 7 | dec(i1,2); 8 | exitcode:= i1; 9 | end. -------------------------------------------------------------------------------- /src/test/base/caseins.mla: -------------------------------------------------------------------------------- 1 | program caseins; 2 | 3 | var 4 | i1: iNt32; 5 | begin 6 | I1:= 122; 7 | InC(I1); 8 | ExitCode:= I1; 9 | end. 10 | -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/conversions/pointertostring2.mla: -------------------------------------------------------------------------------- 1 | program pointertostring2; 2 | var 3 | s1: string8; 4 | begin 5 | s1:= string8(nil); 6 | end. -------------------------------------------------------------------------------- /src/test/syssubs/writeln/writechar.mla: -------------------------------------------------------------------------------- 1 | program writechar; 2 | var 3 | str1: string8; 4 | begin 5 | str1:= 'abc'; 6 | writeln(str1[2]); 7 | end. 8 | -------------------------------------------------------------------------------- /src/testprocx.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | 3 | 4 | implementation 5 | 6 | var 7 | i1: int32; 8 | begin 9 | i1:= 123; 10 | writeln(i1); 11 | end. -------------------------------------------------------------------------------- /src/test/base/arith/addsubint.mla: -------------------------------------------------------------------------------- 1 | program addsubint; 2 | var 3 | i1,i2: int32; 4 | begin 5 | i1:= 2; 6 | i2:= 125; 7 | exitcode:= i2+i2-i1-i2; 8 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/procedure/bodyattachment.mla: -------------------------------------------------------------------------------- 1 | program bodyattachment; 2 | 3 | procedure t() [forward]; 4 | begin 5 | end; 6 | 7 | begin 8 | end. -------------------------------------------------------------------------------- /src/test/base/control/halt2.mla: -------------------------------------------------------------------------------- 1 | program halt2; 2 | uses 3 | uhalt1; //with finalization 4 | begin 5 | exitcode:= 100; 6 | halt(); 7 | exitcode:= 11; 8 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/conversions/pointertostring3.mla: -------------------------------------------------------------------------------- 1 | program pointertostring3; 2 | var 3 | s1: string8; 4 | p1: pointer; 5 | begin 6 | s1:= p1; 7 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/params/constpar2.mla: -------------------------------------------------------------------------------- 1 | program constpar2; 2 | 3 | procedure test(const a: int32); 4 | begin 5 | a:= 123; 6 | end; 7 | 8 | begin 9 | end. -------------------------------------------------------------------------------- /src/compound.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | 3 | implementation 4 | 5 | begin 6 | begin 7 | writeln(1); 8 | writeln(2); 9 | end; 10 | writeln(3); 11 | end. 12 | -------------------------------------------------------------------------------- /src/test/base/array/arrayhigh.mla: -------------------------------------------------------------------------------- 1 | program arrayhigh; 2 | var 3 | ar1: array[0..3][0..99] of card16; 4 | begin 5 | exitcode:= high(ar1)+high(ar1[0])+21; 6 | end. 7 | -------------------------------------------------------------------------------- /src/test/base/control/goto/goto2.mla: -------------------------------------------------------------------------------- 1 | program goto2; 2 | label 3 | lab1; 4 | begin 5 | goto lab1; 6 | exitcode:= 1; 7 | lab1: 8 | exitcode:= exitcode + 123; 9 | end. -------------------------------------------------------------------------------- /src/test/base/var/commasep.mla: -------------------------------------------------------------------------------- 1 | program commasep; 2 | 3 | var 4 | i1,i2: int32; 5 | 6 | begin 7 | i1:= 122; 8 | i2:= 1; 9 | exitcode:= i1+i2; 10 | end. -------------------------------------------------------------------------------- /src/unitc1.mla: -------------------------------------------------------------------------------- 1 | unit unitc1; 2 | //interface 3 | type 4 | c1 = class 5 | private 6 | public 7 | f1: int32; 8 | end; 9 | implementation 10 | end. 11 | -------------------------------------------------------------------------------- /src/test/base/const/unit1.mla: -------------------------------------------------------------------------------- 1 | unit unit1; 2 | interface 3 | type 4 | { 5 | ttest = class 6 | end; 7 | } 8 | const 9 | c1 = 'abc'; 10 | implementation 11 | end. -------------------------------------------------------------------------------- /src/test/rtl/stream/stream1.mla: -------------------------------------------------------------------------------- 1 | program stream1; 2 | uses 3 | rtl_streams; 4 | var 5 | s1: tfilestream; 6 | begin 7 | s1:= tfilestream.create('qwer.xyz'); 8 | end. 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | * 2 | !*.* 3 | !*/ 4 | *.o 5 | *.ppu 6 | *.a 7 | *.bak 8 | *.bak? 9 | *.rst 10 | *.bc 11 | *.ll 12 | *.mli 13 | *.bin 14 | *.s 15 | *.opt 16 | *.mru 17 | *.mcu -------------------------------------------------------------------------------- /src/test/base/array/arraylength.mla: -------------------------------------------------------------------------------- 1 | program arraylength; 2 | var 3 | ar1: array[0..3][0..99] of card16; 4 | begin 5 | exitcode:= length(ar1)+length(ar1[0])+19; 6 | end. 7 | -------------------------------------------------------------------------------- /src/test/base/indirect/varpar.mla: -------------------------------------------------------------------------------- 1 | program varpar; 2 | 3 | procedure test(var p1: int32); 4 | begin 5 | p1:= 123; 6 | end; 7 | 8 | begin 9 | test(exitcode); 10 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/params/constpar1.mla: -------------------------------------------------------------------------------- 1 | program constpar1; 2 | 3 | procedure test(const a: array of int32); 4 | begin 5 | a[0]:= 123; 6 | end; 7 | 8 | begin 9 | end. -------------------------------------------------------------------------------- /src/test/base/address/addressassign.mla: -------------------------------------------------------------------------------- 1 | program addressassign; 2 | var 3 | i1: int32; 4 | type 5 | pint32 = ^int32; 6 | begin 7 | pint32(@i1)^:= 123; 8 | exitcode:= i1; 9 | end. -------------------------------------------------------------------------------- /src/test/base/arith/updatesize.mla: -------------------------------------------------------------------------------- 1 | program updatesize; 2 | 3 | var 4 | a,b: int32; 5 | 6 | begin 7 | a:= 62; 8 | b:= 92; 9 | exitcode:= 33+a+b-(187-123); 10 | end. 11 | -------------------------------------------------------------------------------- /src/test/base/types/typeequ2.mla: -------------------------------------------------------------------------------- 1 | program typeequ2; 2 | type 3 | e = (a,b,c); 4 | g = e; 5 | f = g; 6 | k = (x,y,z); 7 | var 8 | e1: k; 9 | begin 10 | e1:= b; 11 | end. -------------------------------------------------------------------------------- /src/enum.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | type 3 | enumty = (en_0,en_1,en_2); 4 | var 5 | v1: enumty; 6 | implementation 7 | 8 | begin 9 | v1:= en_1; 10 | writeln(v1); 11 | end. 12 | -------------------------------------------------------------------------------- /src/test/base/arith/bool/not1.mla: -------------------------------------------------------------------------------- 1 | program not1; 2 | var 3 | bo1: bool1; 4 | begin 5 | bo1:= false; 6 | bo1:= not bo1; 7 | if bo1 then 8 | exitcode:= 123; 9 | end; 10 | end. -------------------------------------------------------------------------------- /src/test/base/arith/inc1.mla: -------------------------------------------------------------------------------- 1 | program inc1; 2 | 3 | var 4 | k: longint; 5 | x: smallint; 6 | begin 7 | k:= 120; 8 | x:= 3; 9 | inc(k,x); 10 | exitcode:= k 11 | end. 12 | -------------------------------------------------------------------------------- /src/test/base/indirect/indirectpar.mla: -------------------------------------------------------------------------------- 1 | program indirectpar; 2 | 3 | procedure test(p1: ^int32); 4 | begin 5 | p1^:= 123; 6 | end; 7 | 8 | begin 9 | test(@exitcode); 10 | end. -------------------------------------------------------------------------------- /src/test/base/sub/param/constpar.mla: -------------------------------------------------------------------------------- 1 | program constpar; 2 | 3 | procedure test(const a: ^int32); 4 | begin 5 | a^:= 123; 6 | end; 7 | 8 | begin 9 | test(@exitcode); 10 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/visibility/classfield1.mla: -------------------------------------------------------------------------------- 1 | program classfield1; 2 | uses 3 | rtl_streaming; 4 | var 5 | c1: Tcomponent; 6 | s1: string8; 7 | begin 8 | s1:= c1.fname; 9 | end. -------------------------------------------------------------------------------- /src/test/base/array/arraysizeof.mla: -------------------------------------------------------------------------------- 1 | program arraysizeof; 2 | var 3 | ar1: array[0..3][0..99] of card16; 4 | begin 5 | exitcode:= sizeof(ar1)+sizeof(ar1[1])+123-4*100*2-100*2; 6 | end. 7 | -------------------------------------------------------------------------------- /src/test/base/control/while1.mla: -------------------------------------------------------------------------------- 1 | program while1; 2 | var 3 | i1,i2: int32; 4 | begin 5 | while i1 < 5 do 6 | inc(i1); 7 | i2:= i1+i2; 8 | end; 9 | exitcode:= i2+108; 10 | end. -------------------------------------------------------------------------------- /src/test/base/string/chartostring.mla: -------------------------------------------------------------------------------- 1 | program chartostring; 2 | var 3 | str1: string8; 4 | ch1: char8; 5 | begin 6 | ch1:= 'a'; 7 | str1:= ch1; 8 | writeln(str1); 9 | end. 10 | -------------------------------------------------------------------------------- /src/test/base/arith/incdecindpo.mla: -------------------------------------------------------------------------------- 1 | program incdecindpo; 2 | var 3 | po1: pointer; 4 | po2: ^pointer; 5 | 6 | begin 7 | po2:= @po1; 8 | inc(po2^); 9 | exitcode:= int32(po1); 10 | end. -------------------------------------------------------------------------------- /src/test/base/conversions/anytopo.mla: -------------------------------------------------------------------------------- 1 | program anytopo; 2 | var 3 | po1: pointer; 4 | i1: int32; 5 | begin 6 | i1:= 123; 7 | po1:= pointer(123); 8 | exitcode:= int32(po1); 9 | end. 10 | -------------------------------------------------------------------------------- /src/test/base/mem/setmem.mla: -------------------------------------------------------------------------------- 1 | program setmem; 2 | var 3 | po1: ^int32; 4 | begin 5 | po1:= system.getmem(123); 6 | system.setmem(po1,123,$ff); 7 | writeln(po1^); 8 | system.freemem(po1); 9 | end. -------------------------------------------------------------------------------- /src/classinh1.mla: -------------------------------------------------------------------------------- 1 | unit classinh1; 2 | //interface 3 | type 4 | tc1 = class 5 | public 6 | protected 7 | f0: int32; 8 | private 9 | f1: int32; 10 | end; 11 | implementation 12 | end. -------------------------------------------------------------------------------- /src/test/base/control/repeat1.mla: -------------------------------------------------------------------------------- 1 | program repeat1; 2 | var 3 | i1,i2: int32; 4 | begin 5 | repeat 6 | i2:= i2+i1; 7 | inc(i1); 8 | until i1 = 5; 9 | exitcode:= i2+113; 10 | end. 11 | -------------------------------------------------------------------------------- /src/test/base/enum/enum2.mla: -------------------------------------------------------------------------------- 1 | program enum2; 2 | type 3 | e = (a,b,c); 4 | g = e; 5 | var 6 | e1: g; 7 | begin 8 | e1:= b; 9 | if ord(e1) = 1 then 10 | exitcode:= 123; 11 | end; 12 | end. -------------------------------------------------------------------------------- /src/test/base/mem/getmem.mla: -------------------------------------------------------------------------------- 1 | program getmem; 2 | var 3 | po1: ^int32; 4 | begin 5 | po1:= system.getmem(100); 6 | po1^:= 123; 7 | exitcode:= po1^; 8 | system.freemem(po1); 9 | end. 10 | -------------------------------------------------------------------------------- /src/test/base/record/recordfield.mla: -------------------------------------------------------------------------------- 1 | program recordfield; 2 | 3 | var 4 | r1: record 5 | a: int32; 6 | b: int32; 7 | end; 8 | 9 | begin 10 | r1.b:= 123; 11 | exitcode:= r1.b; 12 | end. -------------------------------------------------------------------------------- /src/test/base/arith/incvalpo1.mla: -------------------------------------------------------------------------------- 1 | program incvalpo1; 2 | var 3 | i1: int32; 4 | po1: ^int32; 5 | begin 6 | i1:= 2; 7 | po1:= @i1; 8 | inc(po1,i1); 9 | exitcode:= (pointer(po1)-@i1)+123-8; 10 | end. -------------------------------------------------------------------------------- /src/test/base/arith/pointer/pointeradd.mla: -------------------------------------------------------------------------------- 1 | program pointeradd; 2 | var 3 | po1: pointer; 4 | i1: int32; 5 | begin 6 | i1:= 125; 7 | po1:= po1+i1; 8 | po1:= po1-2; 9 | exitcode:= int32(po1); 10 | end. -------------------------------------------------------------------------------- /src/test/base/exception/except1.mla: -------------------------------------------------------------------------------- 1 | program except1; 2 | begin 3 | try 4 | exitcode:= 12; 5 | except 6 | exitcode:= 11; 7 | end; 8 | if exitcode = 12 then 9 | exitcode:= 123; 10 | end; 11 | end. -------------------------------------------------------------------------------- /src/test/base/sub/function1.mla: -------------------------------------------------------------------------------- 1 | program function1; 2 | 3 | procedure test(const p1: int32; p2: int32): int32; 4 | begin 5 | result:= p1+p2; 6 | end; 7 | 8 | begin 9 | exitcode:= test(10,113); 10 | end. -------------------------------------------------------------------------------- /src/test/rtl/variants/variant1.mla: -------------------------------------------------------------------------------- 1 | program variant1; 2 | uses 3 | rtl_variants; 4 | var 5 | v1,v2,v3: variantty; 6 | begin 7 | v1:= 100; 8 | v2:= 23; 9 | v3:= v1+v2; 10 | exitcode:= v3; 11 | end. -------------------------------------------------------------------------------- /src/test/base/arith/float/sin1.mla: -------------------------------------------------------------------------------- 1 | program sin1; 2 | 3 | var 4 | f1: flo64; 5 | begin 6 | f1:= 1.570796326794896619; 7 | f1:= sin(f1); 8 | if f1 = 1 then 9 | exitcode:= 123; 10 | end; 11 | end. 12 | -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/conversions/constparam.mla: -------------------------------------------------------------------------------- 1 | program constparam; 2 | 3 | type 4 | enutype = (en_1,en_2); 5 | 6 | procedure ttt(const a); 7 | begin 8 | end; 9 | 10 | begin 11 | ttt(en_2); 12 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/params/missingpar.mla: -------------------------------------------------------------------------------- 1 | program missingpar; 2 | 3 | procedure tt(const s: string8); 4 | begin 5 | writeln(s); 6 | end; 7 | 8 | var 9 | s1: string8; 10 | begin 11 | tt(); 12 | end. -------------------------------------------------------------------------------- /src/test/base/const/typedconst2.mla: -------------------------------------------------------------------------------- 1 | program typedconst2; 2 | 3 | const 4 | c1: array[0..1,0..3] of int8 = ((1,2,3,4),(11,22,33,44)); 5 | begin 6 | exitcode:= c1[0,0]+c1[0,1]+c1[1,1]+c1[1][3]+123-1-2-22-44; 7 | end. 8 | -------------------------------------------------------------------------------- /src/test/base/control/forto16.mla: -------------------------------------------------------------------------------- 1 | program forto16; 2 | var 3 | i1: int16; 4 | i2: int32; 5 | begin 6 | i1:= 2; 7 | for i1:= 0 to i1+1 do 8 | i2:= i2+i1; 9 | end; 10 | exitcode:= i2+123-6; 11 | end. 12 | -------------------------------------------------------------------------------- /src/test/base/set/setconstructor1.mla: -------------------------------------------------------------------------------- 1 | program setconstructor1; 2 | type 3 | e = (a,b,c); 4 | se = set of e; 5 | 6 | var 7 | se1: se; 8 | begin 9 | se1:= [a,c]; 10 | exitcode:= int32(se1) + 123-5; 11 | end. -------------------------------------------------------------------------------- /src/test/syssubs/writeln/writeinsub.mla: -------------------------------------------------------------------------------- 1 | program writeinsub; 2 | 3 | procedure test: int32; 4 | begin 5 | result:= 123; 6 | write(result,' ',result); 7 | end; 8 | 9 | begin 10 | exitcode:= test(); 11 | end. -------------------------------------------------------------------------------- /src/test/units/unituses2.mla: -------------------------------------------------------------------------------- 1 | program unituses2; 2 | uses 3 | unit2,unit3; 4 | var 5 | rec1: recty; 6 | begin 7 | exitcode:= 22; 8 | rec1.a:= 23; 9 | rec1.b:= 100; 10 | test(rec1); 11 | test1(rec1); 12 | end. -------------------------------------------------------------------------------- /src/differences.txt: -------------------------------------------------------------------------------- 1 | MSEpas Differences to Free Pascal 2 | 3 | L = Limitation 4 | M = Modification 5 | E = Extension 6 | 7 | E 2016-05-20 Parameter defaults for multiple params. Ex: 8 | procedure test(a,b,c: int32 = 123); -------------------------------------------------------------------------------- /src/test/base/conversions/sizeconvert1.mla: -------------------------------------------------------------------------------- 1 | program sizeconvert1; 2 | type 3 | pcard8 = ^card8; 4 | 5 | var 6 | i1: int32; 7 | po1: pcard8; 8 | begin 9 | i1:= 123; 10 | po1:= @i1; 11 | exitcode:= po1^; 12 | end. -------------------------------------------------------------------------------- /src/test/base/indirect/varparload.mla: -------------------------------------------------------------------------------- 1 | program varparload; 2 | 3 | procedure test(var p1: int32); 4 | begin 5 | exitcode:= p1; 6 | end; 7 | 8 | var 9 | i1: int32; 10 | begin 11 | i1:= 123; 12 | test(i1); 13 | end. -------------------------------------------------------------------------------- /src/test/rtl/variants/variant2.mla: -------------------------------------------------------------------------------- 1 | program variant2; 2 | uses 3 | rtl_variants; 4 | 5 | var 6 | v1,v2,v3: variantty; 7 | begin 8 | 9 | v1:= 10.5; 10 | v2:= 112.5; 11 | v3:= v1+v2; 12 | exitcode:= v3; 13 | end. -------------------------------------------------------------------------------- /src/testproc.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | implementation 3 | 4 | function f(p1: int32):int32; 5 | procedure fa(); 6 | begin 7 | writeln(p1+p1); 8 | end; 9 | begin 10 | fa(); 11 | end; 12 | begin 13 | f(123); 14 | end. -------------------------------------------------------------------------------- /src/set.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | type 3 | enumty = (en_0,en_1,en_2); 4 | setty = set of enumty; 5 | var 6 | v1: enumty; 7 | v2: setty; 8 | implementation 9 | 10 | begin 11 | v1:= en_1; 12 | writeln(v1); 13 | end. 14 | -------------------------------------------------------------------------------- /src/test/base/control/breakrepeat.mla: -------------------------------------------------------------------------------- 1 | program breakrepeat; 2 | var 3 | i1: int32; 4 | begin 5 | repeat 6 | if i1 = 5 then 7 | break; 8 | end; 9 | inc(i1); 10 | until i1 = 10; 11 | exitcode:= i1+123-5; 12 | end. -------------------------------------------------------------------------------- /src/test/base/control/breakwhile.mla: -------------------------------------------------------------------------------- 1 | program breakwhile; 2 | var 3 | i1: int32; 4 | begin 5 | while i1 < 10 do 6 | if i1 = 5 then 7 | break; 8 | end; 9 | inc(i1); 10 | end; 11 | exitcode:= i1+123-5; 12 | end. -------------------------------------------------------------------------------- /src/test/base/arith/pointer/pointerdiff.mla: -------------------------------------------------------------------------------- 1 | program pointerdiff; 2 | type 3 | recty = record 4 | a: int32; 5 | b: int32; 6 | end; 7 | var 8 | rec1: recty; 9 | begin 10 | exitcode:= 119+(@rec1.b-@rec1.a); 11 | end. 12 | -------------------------------------------------------------------------------- /src/test/base/types/typeequ1.mla: -------------------------------------------------------------------------------- 1 | program typeequ1; 2 | type 3 | e = (a,b,c); 4 | g = e; 5 | f = g; 6 | k = (x,y,z); 7 | var 8 | e1: g; 9 | begin 10 | e1:= b; 11 | if e1 = b then 12 | exitcode:= 123; 13 | end; 14 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/statements/subresfield.mla: -------------------------------------------------------------------------------- 1 | program subresfield; 2 | type 3 | recty = record 4 | c: int32; 5 | end; 6 | 7 | procedure tes(): recty; 8 | begin 9 | end; 10 | 11 | begin 12 | tes().c; 13 | end. 14 | -------------------------------------------------------------------------------- /src/test/base/arith/pointer/pointerdiff1.mla: -------------------------------------------------------------------------------- 1 | program pointerdiff1; 2 | type 3 | pcard16 = ^card16; 4 | 5 | var 6 | p1,p2: pcard16; 7 | begin 8 | inc(p1); 9 | if p1-p2 = 1 then 10 | exitcode:= 123; 11 | end; 12 | end. 13 | -------------------------------------------------------------------------------- /src/test/base/sub/pofunc.mla: -------------------------------------------------------------------------------- 1 | program pofunc; 2 | 3 | procedure test(p: int32): ^card8; 4 | begin 5 | result:= pointer(p); 6 | end; 7 | 8 | var 9 | p1: ^card8; 10 | begin 11 | p1:= test(123); 12 | exitcode:= int32(p1); 13 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/params/constpar.mla: -------------------------------------------------------------------------------- 1 | program constpar; 2 | 3 | type 4 | recty = record 5 | a,b: int32; 6 | end; 7 | 8 | procedure test(const a: recty); 9 | begin 10 | a.a:= 123; 11 | end; 12 | 13 | begin 14 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/sets/setrange.mla: -------------------------------------------------------------------------------- 1 | program setrange; 2 | uses 3 | type 4 | x = 5..1; 5 | set1ty = set of -1..5; 6 | set1ty = set of 1..-5; 7 | set1ty = set of 5..1; 8 | set1ty = set of 5..1000; 9 | 10 | begin 11 | end. -------------------------------------------------------------------------------- /src/compmoduledebug.mfm: -------------------------------------------------------------------------------- 1 | inherited compdebugmo: tcompdebugmo 2 | oneventloopstart = nil 3 | moduleclassname = 'tcompmo' 4 | inherited sysenv: tsysenvmanager 5 | options = [seo_tooutput, seo_toerror, seo_noautoinit] 6 | end 7 | end 8 | -------------------------------------------------------------------------------- /src/test/base/arith/andorxor1.mla: -------------------------------------------------------------------------------- 1 | program andorxor1; 2 | 3 | var 4 | i1,i2,i3: int32; 5 | begin 6 | i1:= $ff; 7 | i2:= $81; 8 | i3:= not $200; 9 | if ((i1 xor i2) or $300) and i3 = $17e then 10 | exitcode:= 123; 11 | end; 12 | end. -------------------------------------------------------------------------------- /src/test/base/sub/external1.mla: -------------------------------------------------------------------------------- 1 | program external1; 2 | const 3 | funcname = 'sin'; 4 | 5 | procedure abc(a: flo64): flo64 [external='llll',name=funcname]; 6 | 7 | begin 8 | if abc(0) = 0 then 9 | exitcode:= 123; 10 | end; 11 | end. -------------------------------------------------------------------------------- /src/test/base/sub/recsubres.mla: -------------------------------------------------------------------------------- 1 | program recsubres; 2 | 3 | type 4 | recty = record 5 | a: int32; 6 | end; 7 | 8 | procedure test(): recty; 9 | begin 10 | result.a:= 123; 11 | end; 12 | 13 | begin 14 | exitcode:= test().a; 15 | end. -------------------------------------------------------------------------------- /src/test/rtl/streaming/streaming1.mla: -------------------------------------------------------------------------------- 1 | program streaming1; 2 | uses 3 | rtl_streaming; 4 | var 5 | v1: tfiler; 6 | begin 7 | v1:= twriter.create(nil); 8 | if v1.iswriter then 9 | exitcode:= 123; 10 | end; 11 | v1.free(); 12 | end. -------------------------------------------------------------------------------- /src/test/base/arith/divisionop.mla: -------------------------------------------------------------------------------- 1 | program divisionop; 2 | var 3 | i1: int32; 4 | f1: flo64; 5 | begin 6 | f1:= 1.2; 7 | f1:= 123 * 1.2 / f1; 8 | f1:= f1 * (2/4); 9 | i1:= 4; 10 | f1:= f1 * (2/i1); 11 | writeln(f1*2*2); 12 | end. 13 | -------------------------------------------------------------------------------- /src/test/base/arith/float/floatassign.mla: -------------------------------------------------------------------------------- 1 | program floatassign; 2 | 3 | var 4 | f1,f2: flo64; 5 | begin 6 | f1:= 1+0.5; 7 | f2:= 0.5+1; 8 | if (f1+f2+120 = 123) and (f1+f2+120 <> 124) then 9 | exitcode:= 123; 10 | end; 11 | end. 12 | -------------------------------------------------------------------------------- /src/test/base/set/xorset1.mla: -------------------------------------------------------------------------------- 1 | program xorset1; 2 | 3 | type 4 | e = (a,b,c); 5 | se = set of e; 6 | var 7 | s1,s2: se; 8 | begin 9 | s1:= [a,b,c]; 10 | s2:= [b]; 11 | if s1 >< s2 = [a,c] then 12 | exitcode:= 123; 13 | end; 14 | end. -------------------------------------------------------------------------------- /src/test/base/sub/openarray/openarray3.mla: -------------------------------------------------------------------------------- 1 | program openarray3; 2 | 3 | procedure test(p: array of int32); 4 | begin 5 | exitcode:= high(p)+p[2]; 6 | end; 7 | 8 | begin 9 | test([1,2,3]); 10 | exitcode:= exitcode + 123 - 2 - 3; 11 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/address/deref1.mla: -------------------------------------------------------------------------------- 1 | program deref1; 2 | type 3 | recty = record 4 | a,b: int32; 5 | end; 6 | precty = ^recty; 7 | var 8 | r1: recty; 9 | p1: precty; 10 | begin 11 | p1:= @r1; 12 | exitcode:= p1.b; 13 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/sets/set1.mla: -------------------------------------------------------------------------------- 1 | program set1; 2 | type 3 | enuty = (e_1); 4 | enusty = set of enuty; 5 | 6 | enu2ty = (e2_1); 7 | const 8 | c1 = [e_1]; 9 | begin 10 | if e2_1 in c1 then 11 | exitcode:= 123; 12 | end; 13 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/sets/set2.mla: -------------------------------------------------------------------------------- 1 | program set2; 2 | type 3 | enuty = (e_1); 4 | enusty = set of enuty; 5 | 6 | enu2ty = (e2_1); 7 | const 8 | c1 = [e_1]; 9 | begin 10 | if e_1 in c1 then 11 | exitcode:= 123; 12 | end; 13 | end. -------------------------------------------------------------------------------- /src/test/base/control/continuewhile.mla: -------------------------------------------------------------------------------- 1 | program continuewhile; 2 | var 3 | i1,i2: int32; 4 | begin 5 | while i1 < 10 do 6 | inc(i1); 7 | if i1 <= 5 then 8 | continue; 9 | end; 10 | inc(i2); 11 | end; 12 | exitcode:= i2+123-5; 13 | end. -------------------------------------------------------------------------------- /src/test/base/control/exit.mla: -------------------------------------------------------------------------------- 1 | program exit; 2 | 3 | procedure test(); 4 | begin 5 | if false then 6 | system.exit; 7 | end; 8 | exitcode:= 123; 9 | system.exit; 10 | exitcode:= 11; 11 | end; 12 | 13 | begin 14 | test(); 15 | end. 16 | -------------------------------------------------------------------------------- /src/test/base/conversions/recordconversion.mla: -------------------------------------------------------------------------------- 1 | program recordconversion; 2 | var 3 | i1: int32; 4 | po1: ^int32; 5 | begin 6 | i1:= 2; 7 | po1:= @i1; 8 | inc(po1,i1); 9 | //{$internaldebug on} 10 | exitcode:= (pointer(po1)-@i1)+123-8; 11 | end. -------------------------------------------------------------------------------- /src/test/base/string/conversion/bytes.mla: -------------------------------------------------------------------------------- 1 | program bytes; 2 | var 3 | s1: bytestring; 4 | s2: string16; 5 | 6 | begin 7 | s1:= 'abc'#130; 8 | s2:= s1; 9 | s1:= s2; 10 | if s1 = 'abc'#130 then 11 | exitcode:= 123; 12 | end; 13 | end. 14 | -------------------------------------------------------------------------------- /src/test/base/sub/openarray/openarray3a.mla: -------------------------------------------------------------------------------- 1 | program openarray3a; 2 | 3 | procedure test(const p: array of int32); 4 | begin 5 | exitcode:= high(p)+p[2]; 6 | end; 7 | 8 | begin 9 | test([1,2,3]); 10 | exitcode:= exitcode + 123 - 2 - 3; 11 | end. -------------------------------------------------------------------------------- /src/test/base/sub/subresfield.mla: -------------------------------------------------------------------------------- 1 | program subresfield; 2 | type 3 | recty = record 4 | a,b,c: int32; 5 | end; 6 | 7 | procedure tes(): recty; 8 | begin 9 | result.c:= 123; 10 | end; 11 | 12 | begin 13 | exitcode:= tes().c; 14 | end. 15 | -------------------------------------------------------------------------------- /src/test/base/with/with1.mla: -------------------------------------------------------------------------------- 1 | program with1; 2 | 3 | type 4 | recty = record 5 | a: int32; 6 | b: int32; 7 | end; 8 | var 9 | r1: recty; 10 | begin 11 | with r1 do 12 | a:= 1; 13 | b:= 122; 14 | end; 15 | exitcode:= r1.a+r1.b; 16 | end. -------------------------------------------------------------------------------- /src/test/rtl/string/stringicomp1.mla: -------------------------------------------------------------------------------- 1 | program stringicomp1; 2 | uses 3 | rtl_strings; 4 | const 5 | s1 = 'abc'; 6 | s2 = 'aBc'; 7 | begin 8 | if (stringicomp(s1,s2) = 0) and (stringcomp(s1,s2) <> 0) then 9 | exitcode:= 123; 10 | end; 11 | end. -------------------------------------------------------------------------------- /src/string.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | var 3 | implementation 4 | 5 | procedure p(var s: string8); 6 | begin 7 | writeln(s); 8 | s:= 'def'; 9 | end; 10 | 11 | var 12 | s: string8; 13 | begin 14 | s:= 'abc'; 15 | p(s); 16 | writeln(s); 17 | end. 18 | -------------------------------------------------------------------------------- /src/test/base/const/stringconst.mla: -------------------------------------------------------------------------------- 1 | program stringconst; 2 | {$internaldebug on} 3 | interface 4 | uses 5 | unit1; 6 | var 7 | s1: string8; 8 | begin 9 | s1:= c1; 10 | writeln(s1); 11 | if s1 = 'abc' then 12 | exitcode:= 123; 13 | end; 14 | end. -------------------------------------------------------------------------------- /src/test/base/control/continuerepeat.mla: -------------------------------------------------------------------------------- 1 | program continuerepeat; 2 | var 3 | i1,i2: int32; 4 | begin 5 | repeat 6 | inc(i1); 7 | if i1 <= 5 then 8 | continue; 9 | end; 10 | inc(i2); 11 | until i1 = 10; 12 | exitcode:= i2+123-5; 13 | end. -------------------------------------------------------------------------------- /src/test/base/conversions/stringtopo.mla: -------------------------------------------------------------------------------- 1 | program stringtopo; 2 | 3 | var 4 | s1: string8; 5 | p1,p2: pointer; 6 | begin 7 | s1:= 'abcöä'; 8 | p1:= pointer(s1); 9 | p2:= @s1[1]; 10 | if p1 = p2 then 11 | exitcode:= 123; 12 | end; 13 | end. 14 | -------------------------------------------------------------------------------- /src/test/base/sub/openarray/openarray5.mla: -------------------------------------------------------------------------------- 1 | program openarray5; 2 | 3 | procedure test(p: array of int32): int32; 4 | begin 5 | result:= high(p)+p[2]; 6 | end; 7 | var 8 | i1: int32; 9 | begin 10 | exitcode:= test([1,i1,3]) + 123 - 2 - 3; 11 | end. -------------------------------------------------------------------------------- /src/test/base/sub/openarray/openarray5a.mla: -------------------------------------------------------------------------------- 1 | program openarray5a; 2 | 3 | procedure test(p: array of int32): int32; 4 | begin 5 | result:= high(p)+p[2]; 6 | end; 7 | var 8 | i1: int32; 9 | begin 10 | exitcode:= test([1,i1,3]) + 123 - 2 - 3; 11 | end. -------------------------------------------------------------------------------- /src/test/base/arith/bool/booleval2.mla: -------------------------------------------------------------------------------- 1 | program booleval2; 2 | var 3 | precision: int32; 4 | defaultmode: boolean; 5 | begin 6 | defaultmode:= true; 7 | if (precision < 0) or defaultmode and (precision = 0) then 8 | exitcode:= 123; 9 | end; 10 | end. -------------------------------------------------------------------------------- /src/test/base/conversions/convchain1.mla: -------------------------------------------------------------------------------- 1 | program convchain1; 2 | var 3 | s1,s2: string32; 4 | p1: pointer; 5 | 6 | begin 7 | p1:= pointer(string8('Äbc')); 8 | s1:= string32(string8(p1)); 9 | if s1[1] = 'Ä' then 10 | exitcode:= 123; 11 | end; 12 | end. -------------------------------------------------------------------------------- /src/test/base/enum/enum3.mla: -------------------------------------------------------------------------------- 1 | program enum3; 2 | type 3 | enu = (a=21,b=5,c); 4 | ar = array[enu] of int32; 5 | var 6 | en1: enu; 7 | begin 8 | exitcode:= ord(low(enu)) + ord(high(enu)) + 123 - 5 - 21; 9 | writeln(low(enu),' ',high(enu)); 10 | end. 11 | -------------------------------------------------------------------------------- /src/test/base/string/string1.mla: -------------------------------------------------------------------------------- 1 | program string1; 2 | 3 | procedure flo64tostring1( precision: integer): string16; 4 | var 5 | s1: string8; 6 | begin 7 | s1:= result; 8 | exitcode:= 123; 9 | end; 10 | 11 | begin 12 | flo64tostring1(123); 13 | end. 14 | -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/control/caseerror2.mla: -------------------------------------------------------------------------------- 1 | program caseerror2; 2 | 3 | type 4 | enuty = (en_1,en_2); 5 | 6 | var 7 | e1: enuty; 8 | i1: int32; 9 | begin 10 | case e1 of 11 | en_2: 12 | end; 13 | case i1 of 14 | en_2: 15 | end; 16 | end. -------------------------------------------------------------------------------- /src/test/base/string/stringconcat2.mla: -------------------------------------------------------------------------------- 1 | program stringconcat2; 2 | var 3 | testv0,testv1,testv2: string8; 4 | s1: string8; 5 | 6 | begin 7 | testv0:= '00'; 8 | s1:= testv0+'aa'+'bb'; 9 | if s1 = '00aabb' then 10 | exitcode:= 123; 11 | end; 12 | end. 13 | -------------------------------------------------------------------------------- /src/test/base/sub/constref1.mla: -------------------------------------------------------------------------------- 1 | program constref1; 2 | 3 | procedure test1(constref p0,p1,p2: int32): int32; 4 | begin 5 | result:= p0+p1+p2; 6 | end; 7 | 8 | var 9 | i1: int32; 10 | 11 | begin 12 | i1:= 3; 13 | exitcode:= test1(100,20,i1); 14 | end. 15 | -------------------------------------------------------------------------------- /src/test/intrinsics/managed/copyar1.mla: -------------------------------------------------------------------------------- 1 | program copyar1; 2 | var 3 | ar1,ar2: array of int32; 4 | begin 5 | setlength(ar1,3); 6 | ar2:= copy(ar1); 7 | ar2[1]:= 11; 8 | ar1[1]:= 123; 9 | if ar2[1] = 11 then 10 | exitcode:= ar1[1]; 11 | end; 12 | end. 13 | -------------------------------------------------------------------------------- /src/typex.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | type 3 | t1 = array[0..1,0..1] of int32; 4 | var 5 | v1: t1; 6 | v2: int32; 7 | implementation 8 | begin 9 | v1.c:= 0; 10 | v1.b[v1.c+0]:= 123; 11 | v1.b[v1.c+1]:= 111; 12 | writeln(v1.b[1]); 13 | writeln(v1.b[0]); 14 | end. -------------------------------------------------------------------------------- /src/test/base/arith/cmp/cmpstring8.mla: -------------------------------------------------------------------------------- 1 | program cmpstring8; 2 | var 3 | s1: string8; 4 | s2: string8; 5 | begin 6 | s1:= 'abc'; 7 | s2:= 'abc1'; 8 | if (s1 < s2) and (s1 = 'abc') and (s2 <> s1) and ('z' > s1) then 9 | exitcode:= 123; 10 | end; 11 | end. 12 | -------------------------------------------------------------------------------- /src/test/base/control/forto.mla: -------------------------------------------------------------------------------- 1 | program forto; 2 | 3 | var 4 | i1,i2,i3: int32; 5 | 6 | begin 7 | i2:= 0; 8 | i3:= 0; 9 | for i1:= 2 to 5 do 10 | inc(i2); 11 | i3:= i3+i1; 12 | end; 13 | if i2 = 4 then 14 | exitcode:= 123 + i3 - 14; 15 | end; 16 | end. -------------------------------------------------------------------------------- /src/test/base/control/goto/goto1.mla: -------------------------------------------------------------------------------- 1 | program goto1; 2 | 3 | label 4 | a,b,c; 5 | 6 | begin 7 | a: 8 | inc(exitcode); 9 | if exitcode = 2 then goto b; end; 10 | if exitcode < 3 then 11 | goto a; 12 | end; 13 | b: 14 | exitcode:= exitcode + 123 - 2; 15 | end. -------------------------------------------------------------------------------- /src/test/base/sub/pppar.mla: -------------------------------------------------------------------------------- 1 | program pppar; 2 | type 3 | ppointer = ^pointer; 4 | 5 | procedure test(const ref: ppointer); 6 | begin 7 | inc(ref^); 8 | end; 9 | 10 | var 11 | p1: pointer; 12 | begin 13 | test(@p1); 14 | exitcode:= int32(p1)+122; 15 | end. 16 | -------------------------------------------------------------------------------- /src/test/base/types/forwardpointer.mla: -------------------------------------------------------------------------------- 1 | program forwardpointer; 2 | type 3 | precty = ^recty; 4 | recty = record 5 | po: precty; 6 | a: int32; 7 | end; 8 | var 9 | r1: recty; 10 | begin 11 | r1.a:= 123; 12 | r1.po:= @r1; 13 | exitcode:= r1.po^.a; 14 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/procedure/impldupplicate.mla: -------------------------------------------------------------------------------- 1 | program impldupplicate; 2 | 3 | type 4 | tcla = class 5 | method tt(); 6 | end; 7 | 8 | method tcla.tt(); 9 | begin 10 | end; 11 | 12 | method tcla.tt(); 13 | begin 14 | end; 15 | 16 | begin 17 | end. 18 | -------------------------------------------------------------------------------- /src/testproc1.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | implementation 3 | 4 | function f(p1:int32):int32; 5 | procedure p; 6 | begin 7 | result:= p1+1; 8 | end; 9 | 10 | begin 11 | p; 12 | end; 13 | var 14 | i1: int32; 15 | begin 16 | i1:= f(123); 17 | writeln(i1); 18 | end. -------------------------------------------------------------------------------- /src/test/base/control/nestedwhile.mla: -------------------------------------------------------------------------------- 1 | program nestedwhile; 2 | var 3 | i1,i2: int32; 4 | begin 5 | repeat 6 | i2:= 0; 7 | while i2 < 3 do 8 | inc(exitcode); 9 | inc(i2); 10 | end; 11 | inc(i1); 12 | until i1 > 10; 13 | exitcode:= exitcode + 123 - 33; 14 | end. -------------------------------------------------------------------------------- /src/test/intrinsics/managed/copystring1.mla: -------------------------------------------------------------------------------- 1 | program copystring1; 2 | var 3 | s1,s2: string8; 4 | begin 5 | setlength(s1,3); 6 | s1[1]:= 'a'; 7 | s1[2]:= 'b'; 8 | s1[3]:= 'c'; 9 | s2:= copy(s1,2,1); 10 | if s2 = 'b' then 11 | exitcode:= 123; 12 | end; 13 | end. 14 | -------------------------------------------------------------------------------- /src/test/base/control/fordownto.mla: -------------------------------------------------------------------------------- 1 | program fordownto; 2 | 3 | var 4 | i1,i2,i3: int32; 5 | 6 | begin 7 | i2:= 0; 8 | i3:= 0; 9 | for i1:= -2 downto -5 do 10 | inc(i2); 11 | i3:= i3+i1; 12 | end; 13 | if i2 = 4 then 14 | exitcode:= 123 + i3 - -14; 15 | end; 16 | end. -------------------------------------------------------------------------------- /src/test/base/indirect/recindi.mla: -------------------------------------------------------------------------------- 1 | program recindi; 2 | 3 | type 4 | recty = record 5 | a: int32; 6 | b: int32; 7 | end; 8 | var 9 | rec1: recty; 10 | po1: ^recty; 11 | begin 12 | rec1.a:= 1; 13 | po1:= @rec1; 14 | po1^.b:= 122; 15 | exitcode:= po1^.b+rec1.a; 16 | end. -------------------------------------------------------------------------------- /src/test/base/sub/openarray/openarray4.mla: -------------------------------------------------------------------------------- 1 | program openarray4; 2 | 3 | procedure test(p: array of int32); 4 | begin 5 | exitcode:= high(p)+p[2]; 6 | end; 7 | 8 | var 9 | i1: int32; 10 | begin 11 | i1:= 2; 12 | test([1,i1,3]); 13 | exitcode:= exitcode + 123 - 2 - 3; 14 | end. -------------------------------------------------------------------------------- /src/test/rtl/variants/variantstring.mla: -------------------------------------------------------------------------------- 1 | program variantstring; 2 | uses 3 | rtl_variants; 4 | var 5 | v1,v2: variantty; 6 | s1,s2: system.string8; 7 | begin 8 | v1:= 'abc'; 9 | v2:= v1; 10 | s2:= string8(v2); 11 | write(string8(v2),string8(v1)); 12 | writeln(s2); 13 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/pointer/assignment1.mla: -------------------------------------------------------------------------------- 1 | program assignment1; 2 | type 3 | Ctest = class 4 | end; 5 | ppointer = ^pointer; 6 | ptest = ^Ctest; 7 | var 8 | p1: ptest; 9 | p2: ppointer; 10 | begin 11 | pointer(p1):= p2; 12 | p1:= pointer(p2); 13 | p1:= p2; 14 | end. -------------------------------------------------------------------------------- /src/test/base/record/recordfieldind.mla: -------------------------------------------------------------------------------- 1 | program recordfieldind; 2 | type 3 | recty = record 4 | a: int32; 5 | b: int32; 6 | end; 7 | precty = ^recty; 8 | var 9 | r1: recty; 10 | po1: precty; 11 | 12 | begin 13 | po1:= @r1; 14 | po1^.b:= 123; 15 | exitcode:= po1^.b; 16 | end. -------------------------------------------------------------------------------- /src/test/base/set/set2.mla: -------------------------------------------------------------------------------- 1 | program set2; 2 | 3 | type 4 | enty = (en_0,en_1,en_2,en_3); 5 | sety = set of enty; 6 | var 7 | s1: sety; 8 | e2,e3: enty; 9 | 10 | begin 11 | e2:= en_2; 12 | e3:= en_3; 13 | s1:= [en_1,e2,en_0,e3]; 14 | exitcode:= 123+int32(s1)-15; 15 | end. 16 | -------------------------------------------------------------------------------- /src/test/base/sub/openarray/openarray4a.mla: -------------------------------------------------------------------------------- 1 | program openarray4a; 2 | 3 | procedure test(const p: array of int32); 4 | begin 5 | exitcode:= high(p)+p[2]; 6 | end; 7 | 8 | var 9 | i1: int32; 10 | begin 11 | i1:= 2; 12 | test([1,i1,3]); 13 | exitcode:= exitcode + 123 - 2 - 3; 14 | end. -------------------------------------------------------------------------------- /src/test/base/types/classtype.mla: -------------------------------------------------------------------------------- 1 | program classtype; 2 | type 3 | ttest = class 4 | end; 5 | ctest = class of ttest; 6 | var 7 | cc1: ctest; 8 | cc2: class of ttest; 9 | begin 10 | cc1:= ttest; 11 | cc2:= ttest; 12 | if cc1 = cc2 then 13 | exitcode:= 123; 14 | end; 15 | end. -------------------------------------------------------------------------------- /src/test/base/arith/pointer/pointerrecadd.mla: -------------------------------------------------------------------------------- 1 | program pointerrecadd; 2 | type 3 | recty = record 4 | a: int32; 5 | b: int32; 6 | end; 7 | var 8 | po1: ^recty; 9 | i1: int32; 10 | begin 11 | i1:= 10; 12 | po1:= po1+i1; 13 | po1:= po1-2; 14 | exitcode:= int32(po1)+123-64; 15 | end. -------------------------------------------------------------------------------- /src/test/base/dynarray/copy.mla: -------------------------------------------------------------------------------- 1 | program copy; 2 | type 3 | intarty = array of int32; 4 | var 5 | ar3: array[2..5] of intarty; 6 | begin 7 | setlength(ar3[3],4); 8 | ar3[3,1]:= 11; 9 | ar3[3,2]:= 123-22; 10 | ar3[2]:= ar3[3]; 11 | exitcode:= ar3[2,1] + ar3[3,1] + ar3[3,2]; 12 | end. 13 | -------------------------------------------------------------------------------- /src/test/base/sub/nestedsub1.mla: -------------------------------------------------------------------------------- 1 | program nestedsub1; 2 | 3 | procedure test(); 4 | 5 | var 6 | i1: int32; 7 | procedure test1(); 8 | begin 9 | i1:= i1+23; 10 | end; 11 | 12 | begin 13 | i1:= 100; 14 | test1(); 15 | exitcode:= i1; 16 | end; 17 | 18 | begin 19 | test(); 20 | end. -------------------------------------------------------------------------------- /src/test/base/types/anonenum.mla: -------------------------------------------------------------------------------- 1 | program anonenum; 2 | type 3 | enuty = (e_0,e_1,e2); 4 | var 5 | enu0: enuty; 6 | enu1: (en_0,en_1,en_2); 7 | 8 | begin 9 | enu0:= e_1; 10 | enu1:= en_1; 11 | if (ord(enu0) = 1) and (ord(enu1) = 1) then 12 | exitcode:= 123; 13 | end; 14 | end. 15 | -------------------------------------------------------------------------------- /src/test/intrinsics/managed/copyar2.mla: -------------------------------------------------------------------------------- 1 | program copyar2; 2 | var 3 | ar1,ar2: array of int32; 4 | begin 5 | setlength(ar1,3); 6 | ar1[0]:= 11; 7 | ar1[1]:= 123; 8 | ar1[2]:= 33; 9 | ar2:= copy(ar1,1,1); 10 | if (length(ar2) = 1) then 11 | exitcode:= ar2[0]; 12 | end; 13 | end. 14 | -------------------------------------------------------------------------------- /src/test/base/array/array1.mla: -------------------------------------------------------------------------------- 1 | program array1; 2 | type 3 | enuty = (en_1,en_2,en_3); 4 | 5 | var 6 | ar1: array[enuty] of int32; 7 | v1: enuty; 8 | begin 9 | ar1[en_1]:= 100; 10 | v1:= en_2; 11 | ar1[v1]:= 20; 12 | ar1[en_3]:= 3; 13 | exitcode:= ar1[en_1]+ar1[en_2]+ar1[en_3]; 14 | end. -------------------------------------------------------------------------------- /src/test/base/record/pointerinrec.mla: -------------------------------------------------------------------------------- 1 | program pointerinrec; 2 | type 3 | pint32 = ^int32; 4 | recty = record 5 | a: int32; 6 | po: pint32; 7 | end; 8 | var 9 | r1: recty; 10 | i1: int32; 11 | begin 12 | r1.a:= 10; 13 | r1.po:= @i1; 14 | i1:= 113; 15 | exitcode:= r1.po^+r1.a; 16 | end. -------------------------------------------------------------------------------- /src/test/base/sub/varppar.mla: -------------------------------------------------------------------------------- 1 | program varppar; 2 | 3 | procedure test(var ares: int32); 4 | 5 | procedure tt(var a: int32); 6 | begin 7 | exitcode:= a; 8 | end; 9 | 10 | begin 11 | tt(ares); 12 | end; 13 | 14 | var 15 | i1: int32; 16 | begin 17 | i1:= 123; 18 | test(i1); 19 | end. 20 | -------------------------------------------------------------------------------- /src/test/rtl/variants/tostring.mla: -------------------------------------------------------------------------------- 1 | program tostring; 2 | uses 3 | rtl_variants; 4 | var 5 | v1,v2: variantty; 6 | s1,s2: string8; 7 | begin 8 | v1:= 'abc'; 9 | s2:= string8(v1); 10 | v2:= v1; 11 | s1:= v1; 12 | if (s1 = 'abc') and (s2 = 'abc') then 13 | exitcode:= 123; 14 | end; 15 | end. -------------------------------------------------------------------------------- /src/test/units/unit2.mla: -------------------------------------------------------------------------------- 1 | unit unit2; 2 | interface 3 | uses 4 | unit3; 5 | type 6 | rec1ty = record 7 | a: int32; 8 | end; 9 | 10 | procedure test(const p: recty); 11 | 12 | implementation 13 | 14 | procedure test(const p: recty); 15 | begin 16 | exitcode:= p.b; 17 | end; 18 | 19 | end. -------------------------------------------------------------------------------- /src/test/base/dynarray/setlength.mla: -------------------------------------------------------------------------------- 1 | program setlength; 2 | type 3 | intarty = array of int32; 4 | var 5 | ar1,ar2: intarty; 6 | begin 7 | system.setlength(ar1,5); 8 | ar1[1]:= 123-11; 9 | ar2:= ar1; 10 | system.setlength(ar1,2); 11 | ar1[1]:= 11; 12 | exitcode:= ar1[1]+ar2[1]; 13 | end. 14 | -------------------------------------------------------------------------------- /src/test/base/sub/forward1.mla: -------------------------------------------------------------------------------- 1 | program forward1; 2 | 3 | procedure test2() [forward]; 4 | 5 | procedure tt(); 6 | begin 7 | test2(); 8 | end; 9 | 10 | procedure test2(); 11 | begin 12 | exitcode:= exitcode + 10; 13 | end; 14 | 15 | begin 16 | exitcode:= 103; 17 | tt(); 18 | test2(); 19 | end. -------------------------------------------------------------------------------- /src/test/base/sub/param/constpar1.mla: -------------------------------------------------------------------------------- 1 | program constpar1; 2 | 3 | var 4 | s1: string8; 5 | p1: pointer; 6 | 7 | procedure tt(const p); 8 | begin 9 | if @p = p1 then 10 | exitcode:= 123; 11 | end; 12 | end; 13 | 14 | begin 15 | s1:= 'ABC'; 16 | p1:= pointer(s1); 17 | tt(p1^); 18 | end. 19 | -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/control/caseerror1.mla: -------------------------------------------------------------------------------- 1 | program caseerror1; 2 | var 3 | i1: int32; 4 | label 5 | a; 6 | begin 7 | i1:= 22; 8 | case i1 of 9 | 22: begin 10 | goto a; 11 | exitcode:= 2; 12 | a: 13 | exitcode:= 123; 14 | end; 15 | else 16 | exitcode:= 3; 17 | end; 18 | end. -------------------------------------------------------------------------------- /src/test/base/arith/float/floatconst.mla: -------------------------------------------------------------------------------- 1 | program floatconst; 2 | const 3 | lsbrounding = exp(51*ln(2)); 4 | 5 | var 6 | f1,f2,f3,f4: flo64; 7 | begin 8 | f1:= 51; 9 | f2:= 2; 10 | f3:= exp(f1*ln(f2)); 11 | f4:= f3 - lsbrounding; 12 | if abs(f4) < 100 then 13 | exitcode:= 123; 14 | end; 15 | end. -------------------------------------------------------------------------------- /src/test/base/arith/pointer/pointerindex.mla: -------------------------------------------------------------------------------- 1 | program pointerindex; 2 | type 3 | pcard16 = ^card16; 4 | var 5 | ar1: array[0..3] of card16; 6 | p1: pcard16; 7 | c1: card16; 8 | begin 9 | p1:= @ar1; 10 | p1[0]:= 100; 11 | p1[1]:= 20; 12 | p1[2]:= 3; 13 | exitcode:= ar1[0]+ar1[1]+ar1[2] 14 | end. 15 | -------------------------------------------------------------------------------- /src/test/base/sub/ppar.mla: -------------------------------------------------------------------------------- 1 | program ppar; 2 | type 3 | pcard32 = ^card32; 4 | 5 | procedure test(const a: card32); 6 | begin 7 | exitcode:= a; 8 | end; 9 | 10 | var 11 | p1: pcard32; 12 | c1: card32; 13 | begin 14 | c1:= 123; 15 | p1:= @c1; 16 | //{$internaldebug on} 17 | test(p1^); 18 | end. 19 | -------------------------------------------------------------------------------- /src/test/base/types/set1.mla: -------------------------------------------------------------------------------- 1 | program set1; 2 | type 3 | enuty = (en_0,en_1,en2); 4 | setty = set of enuty; 5 | var 6 | se1: setty; 7 | const 8 | setconst = [en_0,en_1]; 9 | begin 10 | se1:= setconst; 11 | if (se1 = [en_0,en_1]) and (se1 = setconst) then 12 | exitcode:= 123; 13 | end; 14 | end. 15 | -------------------------------------------------------------------------------- /src/test/intrinsics/typeinfo/typeinfo1.mla: -------------------------------------------------------------------------------- 1 | program typeinfo1; 2 | uses 3 | __mla__internaltypes; 4 | var 5 | p1,p2: prttity; 6 | i1: int32; 7 | begin 8 | p1:= typeinfo(i1); 9 | p2:= typeinfo(int32); 10 | if (string8(p1^.typename) = 'int32') and (p1 = p2) then 11 | exitcode:= 123; 12 | end; 13 | end. -------------------------------------------------------------------------------- /src/test/base/arith/incdecind.mla: -------------------------------------------------------------------------------- 1 | program incdecind; 2 | type 3 | recty = record 4 | a: int32; 5 | b: int32; 6 | end; 7 | precty = ^recty; 8 | var 9 | r1: recty; 10 | po1: precty; 11 | 12 | begin 13 | po1:= @r1; 14 | po1^.b:= 121; 15 | inc(r1.b); 16 | inc(po1^.b); 17 | exitcode:= po1^.b; 18 | end. -------------------------------------------------------------------------------- /src/test/base/array/chararrayindex.mla: -------------------------------------------------------------------------------- 1 | program chararrayindex; 2 | var 3 | ar1: array[char8] of card8; 4 | v1: int32; 5 | ar2: array['a'..'c'] of card8; 6 | begin 7 | ar1['a']:= 90; 8 | ar2['a']:= 10; 9 | ar2['b']:= 20; 10 | ar2['c']:= 3; 11 | exitcode:= ar1['a'] + ar2['a']+ar2['b']+ar2['c']; 12 | end. -------------------------------------------------------------------------------- /src/test/base/dynarray/setlength2.mla: -------------------------------------------------------------------------------- 1 | program setlength2; 2 | var 3 | c1: card8; 4 | ar1: array of int32; 5 | begin 6 | c1:= 3; 7 | setlength(ar1,c1); //test conversion card8 -> int32 8 | ar1[0]:= 100; 9 | ar1[1]:= 20-3; 10 | ar1[2]:= 3; 11 | exitcode:= ar1[0]+ar1[1]+ar1[2]+length(ar1); 12 | end. 13 | -------------------------------------------------------------------------------- /src/test/base/managed/managedparam.mla: -------------------------------------------------------------------------------- 1 | program managedparam; 2 | type 3 | intarty = array of int32; 4 | 5 | procedure test(par1: intarty); 6 | begin 7 | exitcode:= par1[2]; 8 | end; 9 | 10 | var 11 | ar1: intarty; 12 | 13 | begin 14 | setlength(ar1,5); 15 | ar1[2]:= 123; 16 | test(ar1); 17 | end. 18 | -------------------------------------------------------------------------------- /src/test/base/sub/nestedsub2.mla: -------------------------------------------------------------------------------- 1 | program nestedsub2; 2 | 3 | procedure test(); 4 | 5 | var 6 | i1: int32; 7 | procedure test1(): int32; 8 | begin 9 | i1:= i1+13; 10 | result:= 10; 11 | end; 12 | 13 | begin 14 | i1:= 100; 15 | exitcode:= test1()+i1; 16 | end; 17 | 18 | begin 19 | test(); 20 | end. -------------------------------------------------------------------------------- /src/test/base/with/withpo.mla: -------------------------------------------------------------------------------- 1 | program withpo; 2 | 3 | type 4 | recty = record 5 | a: int32; 6 | b: int32; 7 | end; 8 | precty = ^recty; 9 | var 10 | r1: recty; 11 | po1: precty; 12 | begin 13 | po1:= @r1; 14 | with po1^ do 15 | a:= 1; 16 | b:= 122; 17 | end; 18 | exitcode:= r1.a+r1.b; 19 | end. -------------------------------------------------------------------------------- /src/test/base/arith/set/index1.mla: -------------------------------------------------------------------------------- 1 | program index1; 2 | uses 3 | type 4 | enuty = (en_0,en_1,en_2); 5 | enusty = set of enuty; 6 | 7 | var 8 | set1,set2: enusty; 9 | b1: boolean; 10 | begin 11 | set1:= [en_1]; 12 | b1:= set1[en_1]; 13 | if b1 and not set2[en_1] then 14 | exitcode:= 123; 15 | end; 16 | end. -------------------------------------------------------------------------------- /src/test/base/indirect/varparrec.mla: -------------------------------------------------------------------------------- 1 | program varparrec; 2 | type 3 | recty = record 4 | a: int32; 5 | b: int32; 6 | end; 7 | 8 | procedure test(var p1: recty); 9 | begin 10 | p1.b:= 122; 11 | end; 12 | 13 | var 14 | r1: recty; 15 | begin 16 | r1.a:= 1; 17 | test(r1); 18 | exitcode:= r1.a+r1.b; 19 | end. -------------------------------------------------------------------------------- /src/test/base/managed/managedresult.mla: -------------------------------------------------------------------------------- 1 | program managedresult; 2 | type 3 | intarty = array of int32; 4 | 5 | function test(): intarty; 6 | begin 7 | setlength(result,5); 8 | result[2]:= 123; 9 | end; 10 | 11 | var 12 | ar1: intarty; 13 | 14 | begin 15 | ar1:= test(); 16 | exitcode:= ar1[2]; 17 | end. 18 | -------------------------------------------------------------------------------- /src/test/base/set/setcomp1.mla: -------------------------------------------------------------------------------- 1 | program setcomp1; 2 | type 3 | e = (a,b,c); 4 | se = set of e; 5 | var 6 | va,vb: se; 7 | begin 8 | if ([a] <= [a,b]) and not ([a,b] <= [b]) then 9 | va:= [a]; 10 | vb:= [a,b]; 11 | if (va <= vb) and not (vb <= va) then 12 | exitcode:= 123; 13 | end; 14 | end; 15 | end. -------------------------------------------------------------------------------- /src/unit2.mla: -------------------------------------------------------------------------------- 1 | unit unit2; 2 | interface 3 | type 4 | unit2recty = record 5 | a,b: int32; 6 | end; 7 | tt = int32; 8 | var 9 | unit2rec: unit2recty; 10 | //{$dumpelements} 11 | implementation 12 | { 13 | procedure test(); 14 | type 15 | tt = int32; 16 | var 17 | tt1: tt; 18 | begin 19 | end; 20 | } 21 | end. -------------------------------------------------------------------------------- /src/test/base/arith/cmp/cmpenum.mla: -------------------------------------------------------------------------------- 1 | program cmpenum; 2 | type 3 | e = (a,b,c); 4 | s = set of e; 5 | var 6 | e1,e2: e; 7 | begin 8 | e1:= a; 9 | e2:= b; 10 | if (a = a) and (a <> b) and (e1 = e1) and (e1 <> e2) and (b > a) and (a < b) and 11 | (e2 > e1) and (e1 < e2) then 12 | exitcode:= 123; 13 | end; 14 | end. -------------------------------------------------------------------------------- /src/test/base/indirect/indirectloc.mla: -------------------------------------------------------------------------------- 1 | program indirectloc; 2 | type 3 | recty = record 4 | a: int32; 5 | b: int32; 6 | end; 7 | precty = ^recty; 8 | var 9 | r1: recty; 10 | po1: precty; 11 | po2: ^precty; 12 | 13 | begin 14 | po1:= @r1; 15 | po2:= @po1; 16 | po2^^.b:= 123; 17 | exitcode:= po2^^.b; 18 | end. -------------------------------------------------------------------------------- /src/test/base/control/iftest.mla: -------------------------------------------------------------------------------- 1 | program iftest; 2 | var 3 | i1: int32; 4 | begin 5 | i1:= 123; 6 | if i1 = 123 then 7 | exitcode:= 1; 8 | else 9 | exitcode:= 2; 10 | end; 11 | if exitcode = 1 then 12 | if i1 <> 123 then 13 | exitcode:= 3; 14 | else 15 | exitcode:= 99; 16 | end; 17 | end; 18 | end. 19 | -------------------------------------------------------------------------------- /src/test/base/managed/finistringar.mla: -------------------------------------------------------------------------------- 1 | program finistringar; 2 | 3 | procedure test1(); 4 | var 5 | ar1: array of string8; 6 | i1,i2: int32; 7 | begin 8 | setlength(ar1,2); 9 | for i1:= 0 to high(ar1) do 10 | setlength(ar1[i1],10); 11 | end; 12 | end; 13 | 14 | begin 15 | test1(); 16 | exitcode:= 123; 17 | end. 18 | -------------------------------------------------------------------------------- /src/test/base/sub/constref.mla: -------------------------------------------------------------------------------- 1 | program constref; 2 | var 3 | i1,i2: int32; 4 | 5 | procedure test1(constref l,r: int32): int32; 6 | begin 7 | if @l = @i1 then 8 | result:= l+r; 9 | else 10 | result:= 1; 11 | end; 12 | end; 13 | 14 | begin 15 | i1:= 100; 16 | i2:= 23; 17 | exitcode:= test1(i1,i2); 18 | end. 19 | -------------------------------------------------------------------------------- /src/test/base/sub/param/defaultemptyset.mla: -------------------------------------------------------------------------------- 1 | program defaultemptyset; 2 | type 3 | enu1ty = (en_0,en_1,en2); 4 | set1ty = set of enu1ty; 5 | 6 | procedure tt(p1: int32; p2: set1ty = []; p3: int32 = 100); 7 | begin 8 | if p2 = [] then 9 | exitcode:= p1+p3; 10 | end; 11 | end; 12 | 13 | begin 14 | tt(23); 15 | end. 16 | -------------------------------------------------------------------------------- /src/test/intrinsics/managed/copystring3.mla: -------------------------------------------------------------------------------- 1 | program copystring3; 2 | var 3 | s1,s2: string8; 4 | i1,i2: int32; 5 | begin 6 | setlength(s1,3); 7 | s1[1]:= 'a'; 8 | s1[2]:= 'b'; 9 | s1[3]:= 'c'; 10 | i1:= 1; 11 | i2:= 2; 12 | s2:= copy(s1,i1,i2); 13 | if s2 = 'ab' then 14 | exitcode:= 123; 15 | end; 16 | end. 17 | -------------------------------------------------------------------------------- /src/test/base/address/address.mla: -------------------------------------------------------------------------------- 1 | program address; 2 | 3 | type 4 | recty = record 5 | a: int32; 6 | b: int32; 7 | end; 8 | precty = ^recty; 9 | var 10 | r1: recty; 11 | po1: precty; 12 | begin 13 | po1:= @r1; 14 | if po1 = @r1 then 15 | po1^.a:= 1; 16 | po1^.b:= 122; 17 | end; 18 | exitcode:= r1.a+r1.b; 19 | end. -------------------------------------------------------------------------------- /src/test/base/arith/bool/and2.mla: -------------------------------------------------------------------------------- 1 | program and2; 2 | 3 | procedure tt(out msbcarry: boolean); 4 | var 5 | b1,b2: boolean; 6 | begin 7 | b1:= false; 8 | b2:= true; 9 | msbcarry:= b1 and b2; 10 | end; 11 | 12 | var 13 | b1: boolean; 14 | begin 15 | tt(b1); 16 | if not b1 then 17 | exitcode:= 123; 18 | end; 19 | end. 20 | -------------------------------------------------------------------------------- /src/test/base/record/recordfieldind2.mla: -------------------------------------------------------------------------------- 1 | program recordfieldind2; 2 | type 3 | recty = record 4 | a: int32; 5 | b: int32; 6 | end; 7 | precty = ^recty; 8 | var 9 | r1: recty; 10 | po1: precty; 11 | po2: ^precty; 12 | 13 | begin 14 | po1:= @r1; 15 | po2:= @po1; 16 | po2^^.b:= 123; 17 | exitcode:= po2^^.b; 18 | end. -------------------------------------------------------------------------------- /src/test/base/sub/openarray/openarray7.mla: -------------------------------------------------------------------------------- 1 | program openarray7; 2 | 3 | procedure test1(p: array of int32): int32; 4 | begin 5 | result:= p[0]+p[1]+length(p); 6 | end; 7 | 8 | procedure test2(const p: int32): int32; 9 | begin 10 | result:= 2*p; 11 | end; 12 | 13 | begin 14 | exitcode:= test2(test1([1,2]))+123-10; 15 | end. 16 | -------------------------------------------------------------------------------- /src/test/base/sub/setparam.mla: -------------------------------------------------------------------------------- 1 | program setparam; 2 | 3 | type 4 | enuty = (en_0,en_1,en_2); 5 | setty = set of enuty; 6 | 7 | procedure test(p: setty): int32; 8 | begin 9 | result:= int32(p); 10 | end; 11 | 12 | var 13 | e: enuty; 14 | s: setty; 15 | begin 16 | e:= en_0; 17 | exitcode:= 123 + test([e,en_2]) - 5; 18 | end. -------------------------------------------------------------------------------- /src/test/base/control/forto2.mla: -------------------------------------------------------------------------------- 1 | program forto2; 2 | 3 | var 4 | i1,i2,i3: int32; 5 | 6 | begin 7 | i2:= 0; 8 | i3:= 0; 9 | for i1:= 2 to 7 do 10 | if i1 = 3 then continue end; 11 | inc(i2); 12 | i3:= i3+i1; 13 | if i1 = 6 then break end; 14 | end; 15 | if i2 = 4 then 16 | exitcode:= 123 + i3 - 17; 17 | end; 18 | end. -------------------------------------------------------------------------------- /src/test/base/indirect/parrecindi.mla: -------------------------------------------------------------------------------- 1 | program parrecindi; 2 | 3 | type 4 | recty = record 5 | a: int32; 6 | b: int32; 7 | end; 8 | 9 | procedure test(p1: ^recty); 10 | begin 11 | exitcode:= p1^.a + p1^.b; 12 | end; 13 | 14 | var 15 | rec1: recty; 16 | begin 17 | rec1.a:= 1; 18 | rec1.b:= 122; 19 | test(@rec1); 20 | end. -------------------------------------------------------------------------------- /src/test/base/sub/openarray/openarray7a.mla: -------------------------------------------------------------------------------- 1 | program openarray7a; 2 | 3 | procedure test1(p: array of int32): int32; 4 | begin 5 | result:= p[0]+p[1]+length(p); 6 | end; 7 | 8 | procedure test2(const p: int32): int32; 9 | begin 10 | result:= 2*p; 11 | end; 12 | 13 | begin 14 | exitcode:= test2(test1([1,2]))+123-10; 15 | end. 16 | -------------------------------------------------------------------------------- /src/compiler/mlc.pas: -------------------------------------------------------------------------------- 1 | program mlc; 2 | {$ifdef FPC}{$mode objfpc}{$h+}{$endif} 3 | {$ifdef mswindows}{$apptype console}{$endif} 4 | uses 5 | {$ifdef FPC}{$ifdef unix}cthreads,cwstring,{$endif}{$endif} 6 | sysutils,msenogui,compmodule; 7 | 8 | begin 9 | application.createdatamodule(tcompmo,compmo); 10 | application.run(); 11 | end. 12 | -------------------------------------------------------------------------------- /src/interpreter/mli.pas: -------------------------------------------------------------------------------- 1 | program mli; 2 | {$ifdef FPC}{$mode objfpc}{$h+}{$endif} 3 | {$ifdef mswindows}{$apptype console}{$endif} 4 | uses 5 | {$ifdef FPC}{$ifdef unix}cthreads,cwstring,{$endif}{$endif} 6 | sysutils,msenogui,mainmodule; 7 | 8 | begin 9 | application.createdatamodule(tmainmo,mainmo); 10 | application.run(); 11 | end. 12 | -------------------------------------------------------------------------------- /src/test/base/sub/external.mla: -------------------------------------------------------------------------------- 1 | program external; 2 | 3 | interface 4 | uses 5 | __mla__compilerunit; 6 | 7 | procedure sin(x: flo64): flo64 [external]; 8 | 9 | implementation 10 | 11 | procedure test(); 12 | begin 13 | exitcode:= 123; 14 | end; 15 | 16 | begin 17 | if sin(0) = 0 then 18 | exitcode:= 123; 19 | end; 20 | end. 21 | -------------------------------------------------------------------------------- /src/test/base/with/with4.mla: -------------------------------------------------------------------------------- 1 | program with4; 2 | 3 | type 4 | precty = ^recty; 5 | recty = record 6 | a: int32; 7 | b: precty; 8 | c: int32; 9 | end; 10 | 11 | var 12 | r1,r2: recty; 13 | p1: precty; 14 | begin 15 | 16 | p1:= @r1; 17 | r1.b:= @r2; 18 | with p1^.b^ do 19 | c:= 123; 20 | end; 21 | exitcode:= r2.c; 22 | end. -------------------------------------------------------------------------------- /src/test/intrinsics/managed/copyar3.mla: -------------------------------------------------------------------------------- 1 | program copyar3; 2 | var 3 | ar1,ar2: array of int32; 4 | i1,i2: int32; 5 | begin 6 | setlength(ar1,3); 7 | ar1[0]:= 11; 8 | ar1[1]:= 123; 9 | ar1[2]:= 33; 10 | i1:= 1; 11 | i2:= 2; 12 | ar2:= copy(ar1,i1,i2); 13 | if (length(ar2) = 2) then 14 | exitcode:= ar2[0]; 15 | end; 16 | end. 17 | -------------------------------------------------------------------------------- /src/bcwriter/bcwritertest.pas: -------------------------------------------------------------------------------- 1 | program bcwritertest; 2 | {$ifdef FPC}{$mode objfpc}{$h+}{$endif} 3 | {$ifdef FPC} 4 | {$ifdef mswindows}{$apptype gui}{$endif} 5 | {$endif} 6 | uses 7 | {$ifdef FPC}{$ifdef unix}cthreads,{$endif}{$endif} 8 | msegui,main; 9 | begin 10 | application.createform(tmainfo,mainfo); 11 | application.run; 12 | end. 13 | -------------------------------------------------------------------------------- /src/test/object/methods/objparam.mla: -------------------------------------------------------------------------------- 1 | program objparam; 2 | type 3 | objty = object 4 | f1,f2: int32; 5 | method test(a: objty); 6 | end; 7 | 8 | method objty.test(a: objty); 9 | begin 10 | exitcode:= a.f1+a.f2; 11 | end; 12 | 13 | var 14 | obj1: objty; 15 | begin 16 | obj1.f1:= 100; 17 | obj1.f2:= 23; 18 | obj1.test(obj1); 19 | end. -------------------------------------------------------------------------------- /src/test/base/dynarray/length.mla: -------------------------------------------------------------------------------- 1 | program length; 2 | type 3 | intarty = array of int32; 4 | arty = array[4..6] of int32; 5 | var 6 | str1: string8; 7 | ar1: intarty; 8 | 9 | begin 10 | str1:= 'abcdefg'; 11 | setlength(ar1,20); 12 | exitcode:= system.length(ar1)+system.length(str1)+system.length(arty)+system.length('abc')+90; 13 | end. 14 | -------------------------------------------------------------------------------- /src/test/base/record/case2.mla: -------------------------------------------------------------------------------- 1 | program case2; 2 | type 3 | recty = record 4 | a: int32; 5 | b: int32; 6 | (c: int32; w:int32); 7 | (d: int32); 8 | end; 9 | var 10 | r1: recty; 11 | begin 12 | r1.b:= 100; 13 | r1.c:= 20; 14 | r1.w:= 3; 15 | exitcode:= r1.b+r1.d+r1.w; 16 | if sizeof(r1) <> 16 then 17 | exitcode:= 1; 18 | end; 19 | end. -------------------------------------------------------------------------------- /src/test/base/control/goto/goto3.mla: -------------------------------------------------------------------------------- 1 | program goto3; 2 | var 3 | i1: int32; 4 | label 5 | lab1; 6 | begin 7 | i1:= 1; 8 | exitcode:= 3; 9 | case i1 of 10 | 1: begin 11 | goto lab1; 12 | exitcode:= 1; 13 | lab1: 14 | exitcode:= exitcode + 120; 15 | end; 16 | 2: 17 | exitcode:= 2; 18 | else: 19 | exitcode:= 0; 20 | end; 21 | end. -------------------------------------------------------------------------------- /src/test/base/indirect/recderef.mla: -------------------------------------------------------------------------------- 1 | program recderef; 2 | type 3 | recty = record 4 | a: int32; 5 | b: int32; 6 | end; 7 | precty = ^recty; 8 | rec1ty = record 9 | e: int32; 10 | f: int32; 11 | p: precty; 12 | end; 13 | 14 | var 15 | r: recty; 16 | r1: rec1ty; 17 | begin 18 | r1.p:= @r; 19 | r.b:= 123; 20 | exitcode:= r1.p^.b; 21 | end. -------------------------------------------------------------------------------- /src/test/base/managed/globrecassign.mla: -------------------------------------------------------------------------------- 1 | program globrecassign; 2 | 3 | type 4 | intarty = array of int32; 5 | recty = record 6 | a,b: int32; 7 | c: intarty; 8 | end; 9 | var 10 | r1,r2: recty; 11 | begin 12 | r1.b:= 100; 13 | setlength(r1.c,5); 14 | r1.c[2]:= 23; 15 | r2:= r1; 16 | exitcode:= r2.c[2]; 17 | exitcode:= r2.b+r2.c[2]; 18 | end. -------------------------------------------------------------------------------- /src/test/base/set/setops1.mla: -------------------------------------------------------------------------------- 1 | program setops1; 2 | type 3 | e = (a,b,c); 4 | se = set of e; 5 | 6 | var 7 | se1: se; 8 | begin 9 | se1:= se1 + [a,c]+[b]; 10 | if se1 = [a,b,c] then 11 | se1:= se1*[a,b]; 12 | if se1 = [a,b] then 13 | se1:= se1 - [a]; 14 | if se1 = [b] then 15 | exitcode:= 123; 16 | end; 17 | end; 18 | end; 19 | end. -------------------------------------------------------------------------------- /src/bcwriter/createabbrev/createabbrev.pas: -------------------------------------------------------------------------------- 1 | program createabbrev; 2 | {$ifdef FPC}{$mode objfpc}{$h+}{$endif} 3 | {$ifdef FPC} 4 | {$ifdef mswindows}{$apptype gui}{$endif} 5 | {$endif} 6 | uses 7 | {$ifdef FPC}{$ifdef unix}cthreads,{$endif}{$endif} 8 | msegui,main; 9 | begin 10 | application.createform(tmainfo,mainfo); 11 | application.run; 12 | end. 13 | -------------------------------------------------------------------------------- /src/benchmark/mctest/viewer/mctestview.pas: -------------------------------------------------------------------------------- 1 | program mctestview; 2 | {$ifdef FPC}{$mode objfpc}{$h+}{$endif} 3 | {$ifdef FPC} 4 | {$ifdef mswindows}{$apptype gui}{$endif} 5 | {$endif} 6 | uses 7 | {$ifdef FPC}{$ifdef unix}cthreads,{$endif}{$endif} 8 | msegui,main; 9 | begin 10 | application.createform(tmainfo,mainfo); 11 | application.run; 12 | end. 13 | -------------------------------------------------------------------------------- /src/test/base/indirect/varparrecload.mla: -------------------------------------------------------------------------------- 1 | program varparrecload; 2 | type 3 | recty = record 4 | a: int32; 5 | b: int32; 6 | c: int32; 7 | end; 8 | 9 | procedure test(var p1: recty); 10 | begin 11 | p1.c:= 10; 12 | exitcode:= p1.a+p1.b+p1.c; 13 | end; 14 | 15 | var 16 | r1: recty; 17 | begin 18 | r1.a:= 1; 19 | r1.b:= 112; 20 | test(r1); 21 | end. -------------------------------------------------------------------------------- /src/test/base/with/with2.mla: -------------------------------------------------------------------------------- 1 | program with2; 2 | 3 | type 4 | rec1ty = record 5 | e: int32; 6 | f: int32; 7 | end; 8 | recty = record 9 | a: int32; 10 | b: int32; 11 | c: rec1ty; 12 | end; 13 | precty = ^recty; 14 | var 15 | r1: recty; 16 | begin 17 | with r1.c do 18 | e:= 1; 19 | f:= 122; 20 | end; 21 | exitcode:= r1.c.e+r1.c.f; 22 | end. -------------------------------------------------------------------------------- /src/test/units/unit3.mla: -------------------------------------------------------------------------------- 1 | unit unit3; 2 | interface 3 | type 4 | recty = record 5 | a: int32; 6 | b: int32; 7 | end; 8 | 9 | procedure test1(var p: recty); 10 | 11 | implementation 12 | uses 13 | unit2; 14 | var 15 | r1: rec1ty; 16 | 17 | procedure test1(var p: recty); 18 | begin 19 | r1.a:= p.b+p.a; 20 | exitcode:= r1.a; 21 | end; 22 | 23 | end. -------------------------------------------------------------------------------- /src/compiler/mbc.pas: -------------------------------------------------------------------------------- 1 | program mbc; 2 | {$ifdef FPC}{$mode objfpc}{$h+}{$endif} 3 | {$ifdef mswindows}{$apptype console}{$endif} 4 | 5 | uses 6 | {$ifdef FPC}{$ifdef unix}cthreads,cwstring,{$endif}{$endif} 7 | sysutils,msenogui,compmodule; 8 | 9 | begin 10 | bcout := true; 11 | application.createdatamodule(tcompmo,compmo); 12 | application.run(); 13 | end. 14 | -------------------------------------------------------------------------------- /src/test/base/managed/arrayofstring1.mla: -------------------------------------------------------------------------------- 1 | program arrayofstring1; 2 | var 3 | ar1,ar2: array of string8; 4 | begin 5 | setlength(ar1,3); 6 | setlength(ar1[1],3); 7 | ar1[1][1]:= 'a'; 8 | ar1[1][2]:= 'b'; 9 | ar1[1][3]:= 'c'; 10 | ar2:= ar1; 11 | ar1[1,2]:= 'B'; 12 | if (ar1[1] = 'aBc') and (ar2[1] = 'aBc') then 13 | exitcode:= 123; 14 | end; 15 | end. 16 | -------------------------------------------------------------------------------- /src/test/base/set/inset1.mla: -------------------------------------------------------------------------------- 1 | program inset1; 2 | 3 | type 4 | e = (a,b,c); 5 | se = set of e; 6 | var 7 | e1,e3: e; 8 | se2: se; 9 | i1: int32; 10 | 11 | begin 12 | if (a in [a,b]) and not (c in [a,b]) then 13 | e1:= a; 14 | se2:= [a,b]; 15 | e3:= c; 16 | if (e1 in se2) and not (e3 in se2) then 17 | exitcode:= 123; 18 | end; 19 | end; 20 | end. -------------------------------------------------------------------------------- /src/test/base/sub/subvar/subaddress.mla: -------------------------------------------------------------------------------- 1 | program subaddress; 2 | 3 | procedure tt(); 4 | begin 5 | exitcode:= 123; 6 | end; 7 | 8 | type 9 | procty = procedure(); 10 | arty = array[0..2] of procty; 11 | var 12 | ar1: arty; 13 | p1: pointer; 14 | begin 15 | ar1[1]:= @tt; 16 | p1:= pointer(ar1[1]); 17 | if ar1[1] = p1 then 18 | ar1[1](); 19 | end; 20 | end. -------------------------------------------------------------------------------- /src/test/object/objvariant.mla: -------------------------------------------------------------------------------- 1 | program objvariant; 2 | type 3 | objty = object 4 | f1: int32; 5 | (f2: int32; f3: int32); 6 | (f4: int32); 7 | end; 8 | var 9 | obj1: objty; 10 | begin 11 | obj1.f1:= 100; 12 | obj1.f4:= 20; 13 | obj1.f3:= 3; 14 | exitcode:= obj1.f1+obj1.f2+obj1.f3; 15 | if sizeof(obj1) <> 12 then 16 | exitcode:= 1; 17 | end; 18 | end. -------------------------------------------------------------------------------- /src/test/base/enum/enum1.mla: -------------------------------------------------------------------------------- 1 | program enum1; 2 | type 3 | e = (a,b,c); 4 | 5 | var 6 | e1,e2: e; 7 | begin 8 | e1:= b; 9 | e2:= c; 10 | if e1 = e2 then 11 | exitcode:= 22; 12 | else 13 | if (e1 = b) and (e2 = c) then 14 | e1:= c; 15 | if (e1 = e2) then 16 | exitcode:= 123; 17 | end; 18 | else 19 | exitcode:= 33; 20 | end; 21 | end; 22 | end. -------------------------------------------------------------------------------- /src/test/base/sub/objectfieldresult.mla: -------------------------------------------------------------------------------- 1 | program objectfieldresult; 2 | type 3 | objty = object [nozeroinit] 4 | a,b,c: int32; 5 | end; 6 | 7 | var 8 | o1: objty; 9 | o2: objty; 10 | 11 | procedure test(): objty; 12 | begin 13 | result:= o1; 14 | end; 15 | 16 | begin 17 | o1.c:= 100; 18 | o1.b:= 23; 19 | o2:= test(); 20 | exitcode:= test().c+o2.b; 21 | end. -------------------------------------------------------------------------------- /src/test/base/sub/openarray/openarray6.mla: -------------------------------------------------------------------------------- 1 | program openarray6; 2 | 3 | procedure test(p1: int32;p: array of int32;p2: int32; p3: array of int32): int32; 4 | begin 5 | result:= p1 + high(p) + p[1] + high(p3) + p3[3] + p2; 6 | end; 7 | var 8 | i1: int32; 9 | begin 10 | i1:= 15; 11 | exitcode:= test(11,[1,i1,3],22,[1,22,3,i1]) + 123 - 11 - 2 - 15 - 3 - 15 - 22; 12 | end. -------------------------------------------------------------------------------- /src/test/base/arith/abs.mla: -------------------------------------------------------------------------------- 1 | program abs; 2 | var 3 | i1,i2: int32; 4 | f1,f2: flo64; 5 | begin 6 | i1:= system.abs(-100); 7 | exitcode:= i1; 8 | f1:= system.abs(-30.5); 9 | if f1 = 30.5 then 10 | i1:= -23; 11 | i2:= system.abs(i1); 12 | f1:= -40.5; 13 | f2:= system.abs(f1); 14 | if f2 = 40.5 then 15 | exitcode:= exitcode+i2; 16 | end; 17 | end; 18 | end. -------------------------------------------------------------------------------- /src/test/base/dynarray/nestedloc.mla: -------------------------------------------------------------------------------- 1 | program nestedloc; 2 | type 3 | intarty = array of int32; 4 | 5 | procedure test1(); 6 | var 7 | ar1,ar2: intarty; 8 | 9 | procedure test(); 10 | begin 11 | setlength(ar1,5); 12 | ar1[2]:= 123; 13 | ar2:= ar1; 14 | exitcode:= ar2[2]; 15 | end; 16 | 17 | begin 18 | test(); 19 | end; 20 | 21 | begin 22 | test1(); 23 | end. 24 | -------------------------------------------------------------------------------- /src/test/base/managed/checkuniquestring.mla: -------------------------------------------------------------------------------- 1 | program checkuniquestring; 2 | 3 | procedure test(var achar: char8); 4 | begin 5 | achar:= 'Y'; 6 | end; 7 | 8 | var 9 | str1,str2,str3: string8; 10 | begin 11 | str1:= 'abc'; 12 | str2:= str1; 13 | str1[1]:= 'Z'; 14 | str3:= str2; 15 | test(str3[2]); 16 | write(str1); 17 | write(str2); 18 | writeln(str3); 19 | end. 20 | -------------------------------------------------------------------------------- /src/test/base/sub/openarray/openarray6a.mla: -------------------------------------------------------------------------------- 1 | program openarray6a; 2 | 3 | procedure test(p1: int32;p: array of int32;p2: int32; p3: array of int32): int32; 4 | begin 5 | result:= p1 + high(p) + p[1] + high(p3) + p3[3] + p2; 6 | end; 7 | var 8 | i1: int32; 9 | begin 10 | i1:= 15; 11 | exitcode:= test(11,[1,i1,3],22,[1,22,3,i1]) + 123 - 11 - 2 - 15 - 3 - 15 - 22; 12 | end. -------------------------------------------------------------------------------- /src/test/base/with/withpo2.mla: -------------------------------------------------------------------------------- 1 | program withpo2; 2 | type 3 | rec1ty = record 4 | a: int32; 5 | b: pointer; 6 | end; 7 | recty = record 8 | c: rec1ty; 9 | d: int32; 10 | end; 11 | var 12 | po1: ^recty; 13 | r1: recty; 14 | begin 15 | po1:= @r1; 16 | r1.d:= 13; 17 | with po1^.c do 18 | b:= nil; 19 | a:= 110; 20 | end; 21 | exitcode:= r1.c.a+r1.d; 22 | end. -------------------------------------------------------------------------------- /src/test/helloworld/hellomselang.pas: -------------------------------------------------------------------------------- 1 | program hellomselang; 2 | uses 3 | rtl_stringconv; 4 | var 5 | x, y : integer; 6 | tex : string16; 7 | begin 8 | x := 1; 9 | y := 3; 10 | tex := 'Hello MSElang world!' ; 11 | writeln(tex); 12 | writeln( 'x = ' + inttostring16(x)); 13 | writeln( 'y = ' + inttostring16(y)); 14 | writeln( 'x + y = ' + inttostring16(x+y)); 15 | 16 | end. 17 | -------------------------------------------------------------------------------- /src/test/intrinsics/managed/unique3.mla: -------------------------------------------------------------------------------- 1 | program unique3; 2 | var 3 | ar1,ar2: array of string8; 4 | begin 5 | setlength(ar1,3); 6 | setlength(ar1[1],3); 7 | ar1[1,1]:= 'a'; 8 | ar1[1,2]:= 'b'; 9 | ar1[1,3]:= 'c'; 10 | ar2:= ar1; 11 | unique(ar2); 12 | ar1[1]:= 'ABC'; 13 | if (ar1[1] = 'ABC') and (ar2[1] = 'abc') then 14 | exitcode:= 123; 15 | end; 16 | end. 17 | -------------------------------------------------------------------------------- /src/test/base/dynarray/unique.mla: -------------------------------------------------------------------------------- 1 | program unique; 2 | type 3 | intarty = array of int32; 4 | var 5 | ar1,ar2: intarty; 6 | str1,str2: string8; 7 | begin 8 | setlength(str1,10); 9 | str2:= str1; 10 | system.unique(str1); 11 | setlength(ar1,10); 12 | ar1[2]:= 100; 13 | ar2:= ar1; 14 | system.unique(ar2); 15 | ar2[2]:= 23; 16 | exitcode:= ar1[2] + ar2[2]; 17 | end. 18 | -------------------------------------------------------------------------------- /src/test/base/indirect/pointerrec.mla: -------------------------------------------------------------------------------- 1 | program pointerrec; 2 | type 3 | headerty = record 4 | a: int32; 5 | b: int32; 6 | end; 7 | recty = record 8 | header: headerty; 9 | end; 10 | 11 | var 12 | rec1: recty; 13 | po1: ^recty; 14 | 15 | begin 16 | rec1.header.a:= 11; 17 | rec1.header.b:= 112; 18 | po1:= @rec1; 19 | exitcode:= po1^.header.b+po1^.header.a; 20 | end. -------------------------------------------------------------------------------- /src/test/rtl/tobject/tobject1.mla: -------------------------------------------------------------------------------- 1 | program tobject1; 2 | uses 3 | rtl_fpccompatibility; 4 | type 5 | ttest = class(tobject) 6 | method afterconstruction() [override]; 7 | end; 8 | 9 | method ttest.afterconstruction(); 10 | begin 11 | exitcode:= 123; 12 | inherited; 13 | end; 14 | 15 | var 16 | t1: ttest; 17 | begin 18 | t1:= ttest.create(); 19 | t1.destroy(); 20 | end. -------------------------------------------------------------------------------- /src/test/base/conversions/objtoobj.mla: -------------------------------------------------------------------------------- 1 | program objtoobj; 2 | type 3 | obj1ty = object 4 | a,b: int32; 5 | end; 6 | pobj1ty = ^obj1ty; 7 | 8 | obj2ty = object(obj1ty) 9 | c: int32; 10 | end; 11 | pobj2ty = ^obj2ty; 12 | 13 | var 14 | o1: obj2ty; 15 | p1: pobj1ty; 16 | begin 17 | p1:= @o1; 18 | with pobj2ty(p1)^ do 19 | c:= 123; 20 | end; 21 | exitcode:= o1.c; 22 | end. -------------------------------------------------------------------------------- /src/test/base/sub/openarray/openarray2.mla: -------------------------------------------------------------------------------- 1 | program openarray2; 2 | 3 | procedure test(p: array of int32); 4 | begin 5 | if (p[1] = 2) and (high(p) = 2) and (length(p) = 3) then 6 | exitcode:= 123; 7 | end; 8 | end; 9 | 10 | var 11 | ar1: array of int32; 12 | 13 | begin 14 | setlength(ar1,3); 15 | ar1[0]:= 1; 16 | ar1[1]:= 2; 17 | ar1[2]:= 3; 18 | test(ar1); 19 | end. 20 | -------------------------------------------------------------------------------- /src/test/base/with/with3.mla: -------------------------------------------------------------------------------- 1 | program with3; 2 | type 3 | recty = record 4 | a: int32; 5 | b: int32; 6 | end; 7 | var 8 | r1,r2: recty; 9 | 10 | procedure test(); 11 | begin 12 | with r1 do 13 | a:= 1; 14 | with r2 do 15 | a:= 10; 16 | b:= 20; 17 | end; 18 | b:= 2; 19 | end; 20 | end; 21 | 22 | begin 23 | test(); 24 | exitcode:= r1.a+r1.b+r2.a+r2.b+90; 25 | end. -------------------------------------------------------------------------------- /src/test/base/exception/raise1.mla: -------------------------------------------------------------------------------- 1 | program raise1; 2 | 3 | type 4 | t1 = class[virtual,except] 5 | public 6 | constructor create(); 7 | destructor destroy()[default]; 8 | end; 9 | 10 | constructor t1.create(); 11 | begin 12 | end; 13 | 14 | destructor t1.destroy(); 15 | begin 16 | end; 17 | 18 | begin 19 | exitcode:= 123; 20 | raise t1.create(); 21 | exitcode:= 11; 22 | end. -------------------------------------------------------------------------------- /src/test/base/string/resourcestring/resourcestr.mla: -------------------------------------------------------------------------------- 1 | program resourcestr; 2 | uses 3 | unit1; 4 | resourcestring 5 | a = 'AAAA'; 6 | type 7 | pstring8 = ^string8; 8 | begin 9 | if (a = 'AAAA') and (b = 'BBBB') then 10 | exitcode:= 123; 11 | end; 12 | pstring8(@a)^:= 'abc'; 13 | pstring8(@b)^:= 'def'; 14 | if (a <> 'abc') or (b <> 'def') then 15 | exitcode:= 1; 16 | end; 17 | end. -------------------------------------------------------------------------------- /src/test/intrinsics/managed/initialize.mla: -------------------------------------------------------------------------------- 1 | program initialize; 2 | 3 | type 4 | recty = record 5 | a,b: int32; 6 | s: string8; 7 | end; 8 | 9 | var 10 | a: recty; 11 | 12 | begin 13 | exitcode:= 1; 14 | pointer(a.s):= pointer(123); 15 | if pointer(a.s) = pointer(123) then 16 | system.initialize(a); 17 | if a.s = '' then 18 | exitcode:= 123; 19 | end; 20 | end; 21 | end. -------------------------------------------------------------------------------- /src/test/object/operators/operator2.mla: -------------------------------------------------------------------------------- 1 | program operator2; 2 | 3 | type 4 | objty = object [nozeroinit,virtual] 5 | fa,fb: int32; 6 | method neg() [operator='-']; 7 | end; 8 | 9 | method objty.neg(); 10 | begin 11 | fa:= -fa; 12 | fb:= -fb; 13 | end; 14 | 15 | var 16 | a,c: objty; 17 | begin 18 | a.fa:= 23; 19 | a.fb:= 100; 20 | c:= -a; 21 | exitcode:= -c.fa + -c.fb; 22 | end. -------------------------------------------------------------------------------- /src/record.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | type 3 | tr1 = record 4 | f1: int32; 5 | f2: int32; 6 | f3: ^int32; 7 | end; 8 | var 9 | v1: tr1; 10 | v2: ^tr1; 11 | v3: ^int32; 12 | v4: int32; 13 | {$dumpelements} 14 | implementation 15 | 16 | begin 17 | v1.f2:= 123; 18 | v2:= @v1; 19 | v4:= v2^.f2; 20 | writeln(v4); 21 | writeln(v2^.f2); 22 | v2^.f2:= 222; 23 | writeln(v1.f2); 24 | end. -------------------------------------------------------------------------------- /src/test/base/exception/raise3.mla: -------------------------------------------------------------------------------- 1 | program raise3; 2 | 3 | type 4 | tc = class[virtual,except] 5 | public 6 | constructor create(); 7 | destructor destroy()[default]; 8 | end; 9 | 10 | constructor tc.create(); 11 | begin 12 | end; 13 | destructor tc.destroy(); 14 | begin 15 | end; 16 | begin 17 | try 18 | raise tc.create(); 19 | except 20 | exitcode:= 123; 21 | end; 22 | end. -------------------------------------------------------------------------------- /src/test/base/sub/openarray/openarray2a.mla: -------------------------------------------------------------------------------- 1 | program openarray2a; 2 | 3 | procedure test(const p: array of int32); 4 | begin 5 | if (p[1] = 2) and (high(p) = 2) and (length(p) = 3) then 6 | exitcode:= 123; 7 | end; 8 | end; 9 | 10 | var 11 | ar1: array of int32; 12 | 13 | begin 14 | setlength(ar1,3); 15 | ar1[0]:= 1; 16 | ar1[1]:= 2; 17 | ar1[2]:= 3; 18 | test(ar1); 19 | end. 20 | -------------------------------------------------------------------------------- /src/test/object/methods/objfield1.mla: -------------------------------------------------------------------------------- 1 | program objfield1; 2 | type 3 | objty = object 4 | f1: int32; 5 | method test(a: objty; b: int32); 6 | f2: int32; 7 | end; 8 | 9 | method objty.test(a: objty; b: int32); 10 | begin 11 | exitcode:= a.f1+a.f2+b; 12 | end; 13 | 14 | var 15 | obj1,obj2: objty; 16 | 17 | begin 18 | obj1.f1:= 100; 19 | obj1.f2:= 20; 20 | obj2.test(obj1,3); 21 | end. -------------------------------------------------------------------------------- /src/test/base/conversions/aggregate1.mla: -------------------------------------------------------------------------------- 1 | program aggregate1; 2 | type 3 | flo64recty = packed record //little endian 4 | (by0,by1,by2,by3,by4,by5,by6,by7: byte); 5 | (wo0,wo1,wo2,wo3: word); 6 | (lwo0,lwo1: longword); 7 | (qwo0: qword); 8 | end; 9 | 10 | var 11 | b1: card8; 12 | f1: flo64; 13 | begin 14 | flo64recty(f1).by7:= 123; 15 | exitcode:= flo64recty(f1).by7; 16 | end. 17 | -------------------------------------------------------------------------------- /src/test/base/conversions/leftsidecast.mla: -------------------------------------------------------------------------------- 1 | program leftsidecast; 2 | 3 | procedure test(const p: pointer); 4 | begin 5 | end; 6 | 7 | procedure test(var p: int32); 8 | begin 9 | exitcode:= p; 10 | end; 11 | 12 | var 13 | po1: pointer; 14 | i1: int32; 15 | begin 16 | int32(po1):= 100; 17 | test(int32(po1)); 18 | int32(card32(po1)):= 23; 19 | exitcode:= exitcode + int32(po1); 20 | end. 21 | -------------------------------------------------------------------------------- /src/test/base/conversions/ord.mla: -------------------------------------------------------------------------------- 1 | program ord; 2 | type 3 | enuty = (en_0,en_1,en_2); 4 | var 5 | en1: enuty; 6 | ch1: char8; 7 | bo1: bool1; 8 | begin 9 | exitcode:= system.ord(en_2) + system.ord('0')+system.ord(5)+system.ord(true); //56 10 | en1:= en_1; //1 11 | ch1:= '1'; //49 12 | bo1:= true; //1 13 | exitcode:= exitcode+system.ord(en1)+system.ord(ch1)+system.ord(bo1)+123-56-51; 14 | end. -------------------------------------------------------------------------------- /src/test/base/sub/openarray/openarray1.mla: -------------------------------------------------------------------------------- 1 | program openarray1; 2 | 3 | type 4 | arty = array[0..2] of int32; 5 | 6 | procedure test(p: array of int32); 7 | begin 8 | if (p[1] = 2) and (high(p) = 2) and (length(p) = 3) then 9 | exitcode:= 123; 10 | end; 11 | end; 12 | 13 | var 14 | ar1: arty; 15 | 16 | begin 17 | ar1[0]:= 1; 18 | ar1[1]:= 2; 19 | ar1[2]:= 3; 20 | test(ar1); 21 | end. 22 | -------------------------------------------------------------------------------- /src/test/base/sub/param/varparpointer.mla: -------------------------------------------------------------------------------- 1 | program varparpointer; 2 | type 3 | pint32 = ^int32; 4 | 5 | recty = record 6 | a: int32; 7 | b: pint32; 8 | end; 9 | 10 | procedure test(var a: recty); 11 | begin 12 | a.b^:= 100 + a.b^; 13 | exitcode:= a.b^; 14 | end; 15 | 16 | var 17 | r: recty; 18 | i: int32; 19 | begin 20 | i:= 23; 21 | r.a:= 100; 22 | r.b:= @i; 23 | test(r); 24 | end. -------------------------------------------------------------------------------- /src/test/object/operators/operator3.mla: -------------------------------------------------------------------------------- 1 | program operator3; 2 | 3 | type 4 | objty = object [nozeroinit] 5 | fa,fb: int32; 6 | method add(b: int32) [operator='+']; 7 | end; 8 | 9 | method objty.add(b: int32); 10 | begin 11 | fb:= fb+b; 12 | end; 13 | 14 | var 15 | a,c: objty; 16 | begin 17 | a.fa:= 9; 18 | a.fb:= 100; 19 | c:= a + int32(123-9-100); 20 | exitcode:= c.fa + c.fb; 21 | end. -------------------------------------------------------------------------------- /src/test/base/dynarray/setlength1.mla: -------------------------------------------------------------------------------- 1 | program setlength1; 2 | type 3 | intarty = array of int32; 4 | var 5 | ar1: intarty; 6 | i1,i2: int32; 7 | str1: string8; 8 | begin 9 | setlength(str1,13); 10 | setlength(ar1,20); 11 | i1:= high(ar1); 12 | i2:= high(str1); 13 | ar1:= nil; 14 | str1:= ''; 15 | exitcode:= length(ar1) + i1 + 123 - 19 + i2 - 12 - low(str1) - low(ar1) + length(str1); 16 | end. 17 | -------------------------------------------------------------------------------- /src/test/base/sub/openarray/openarray1a.mla: -------------------------------------------------------------------------------- 1 | program openarray1a; 2 | 3 | type 4 | arty = array[0..2] of int32; 5 | 6 | procedure test(const p: array of int32); 7 | begin 8 | if (p[1] = 2) and (high(p) = 2) and (length(p) = 3) then 9 | exitcode:= 123; 10 | end; 11 | end; 12 | 13 | var 14 | ar1: arty; 15 | 16 | begin 17 | ar1[0]:= 1; 18 | ar1[1]:= 2; 19 | ar1[2]:= 3; 20 | test(ar1); 21 | end. 22 | -------------------------------------------------------------------------------- /src/test/base/sub/subvar/subvar1.mla: -------------------------------------------------------------------------------- 1 | program subvar1; 2 | interface 3 | type 4 | procty = procedure(a: int32); 5 | recty = record 6 | p: procty; 7 | a: int32; 8 | end; 9 | implementation 10 | 11 | var 12 | r1: recty; 13 | p: procty; 14 | 15 | procedure test(a: int32); 16 | begin 17 | exitcode:= a+r1.a; 18 | end; 19 | 20 | begin 21 | r1.a:= 3; 22 | r1.p:= @test; 23 | r1.p(120); 24 | end. 25 | -------------------------------------------------------------------------------- /src/test/base/record/recordcopy.mla: -------------------------------------------------------------------------------- 1 | program recordcopy; 2 | 3 | type 4 | recty = record 5 | a,b: int32; 6 | end; 7 | var 8 | rec1,rec2: recty; 9 | 10 | procedure test(); 11 | var 12 | r1,r2: recty; 13 | begin 14 | r1.a:= 20; 15 | r1.b:= 3; 16 | r2:= r1; 17 | exitcode:= rec2.b + rec2.a + r2.a + r2.b; 18 | end; 19 | 20 | begin 21 | rec1.a:= 40; 22 | rec1.b:= 60; 23 | rec2:= rec1; 24 | test(); 25 | end. -------------------------------------------------------------------------------- /src/test/rtl/string/inttostrtest.mla: -------------------------------------------------------------------------------- 1 | program inttostrtest; 2 | uses 3 | rtl_stringconv; 4 | var 5 | s1,s2: string8; 6 | s1a,s2a: string16; 7 | begin 8 | s1:= inttostring8(123); 9 | s2:= inttostring8(-123); 10 | s1a:= inttostring16(123); 11 | s2a:= inttostring16(-123); 12 | if (s1 = '123') and (s2 = '-123') and 13 | (s1a = '123') and (s2a = '-123') then 14 | exitcode:= 123; 15 | end; 16 | end. 17 | -------------------------------------------------------------------------------- /src/test.mla: -------------------------------------------------------------------------------- 1 | program test; 2 | uses 3 | // rtl_streaming; 4 | type 5 | Ctest = class[virtual] 6 | method test() [virtual,abstract]; 7 | end; 8 | 9 | const 10 | {$internaldebug on} 11 | var 12 | set1: set of char8; 13 | s1: string8; 14 | ch1: char8; 15 | // co1: Tcomponent; 16 | begin 17 | { 18 | co1:= Tcomponent.create(nil); 19 | co1.name:= 'abc'; 20 | writeln(co1.name); 21 | co1.destroy(); 22 | } 23 | end. -------------------------------------------------------------------------------- /src/test/base/arith/bitexp1.mla: -------------------------------------------------------------------------------- 1 | program bitexp1; 2 | const 3 | val = 300; 4 | var 5 | vval,v7f,v80,v7,v8: int32; 6 | begin 7 | vval:= val; 8 | v7f:= $7f; 9 | v80:= $80; 10 | v7:= 7; 11 | v8:= 8; 12 | exitcode:= (vval and v7f or v80) or (((vval shr v7) and v7f) shl v8)-684+123; //684 13 | if exitcode = 123 then 14 | exitcode:= (val and $7f or $80) or (((val shr 7) and $7f) shl 8)-684+123; //684 15 | end; 16 | end. -------------------------------------------------------------------------------- /src/try1.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | type 3 | tt = class 4 | public 5 | constructor create(); 6 | end; 7 | 8 | implementation 9 | 10 | constructor tt.create(); 11 | begin 12 | end; 13 | 14 | begin 15 | try 16 | raise tt.create(); 17 | writeln(100); 18 | except 19 | try 20 | writeln(200); 21 | raise tt.create(); 22 | finally 23 | writeln(201); 24 | end; 25 | end; 26 | writeln(300); 27 | end. 28 | -------------------------------------------------------------------------------- /src/test/base/pointer/addresstype.mla: -------------------------------------------------------------------------------- 1 | program addresstype; 2 | type 3 | recty = record 4 | a,b: int32; 5 | end; 6 | precty = ^recty; 7 | 8 | rec1ty = record 9 | a1,a2: int32; 10 | r: recty; 11 | end; 12 | prec1ty = ^rec1ty; 13 | 14 | pint32 = ^int32; 15 | 16 | var 17 | r1: rec1ty; 18 | p1: pint32; 19 | p2: prec1ty; 20 | begin 21 | p2:= @r1; 22 | p1:= @p2^.r; 23 | p1^:= 123; 24 | exitcode:= r1.r.a; 25 | end. -------------------------------------------------------------------------------- /src/test/base/sub/subvar/subvar.mla: -------------------------------------------------------------------------------- 1 | program subvar; 2 | interface 3 | type 4 | procty = procedure(a: int32); 5 | recty = record 6 | p: procty; 7 | a: int32; 8 | end; 9 | implementation 10 | var 11 | r1: recty; 12 | p: procty; 13 | begin 14 | r1.a:= 123; 15 | r1.p:= pointer(111); 16 | if pointer(111) = r1.p then 17 | r1.p:= nil; 18 | if r1.p = nil then 19 | exitcode:= r1.a; 20 | end; 21 | end; 22 | end. 23 | -------------------------------------------------------------------------------- /src/test/base/sub/managed/subvarres3.mla: -------------------------------------------------------------------------------- 1 | program subvarres3; 2 | type 3 | recty = record 4 | s: string8; 5 | a,b,c: int32; 6 | end; 7 | 8 | procedure test(): recty; 9 | begin 10 | if result.s = '' then 11 | exitcode:= 123; 12 | end; 13 | setlength(result.s,3); 14 | end; 15 | 16 | var 17 | r1: recty; 18 | 19 | procedure test1(f: flo64); 20 | begin 21 | test(); 22 | end; 23 | 24 | 25 | begin 26 | test1(1.2); 27 | end. -------------------------------------------------------------------------------- /src/test/base/conversions/pointercast.mla: -------------------------------------------------------------------------------- 1 | program pointercast; 2 | 3 | type 4 | pint32 = ^int32; 5 | ppint32 = ^pint32; 6 | ppointer = ^pointer; 7 | recty = record 8 | a,b: int32; 9 | end; 10 | precty = ^recty; 11 | pprecty = ^precty; 12 | var 13 | r1: recty; 14 | po1: pointer; 15 | po2: ppointer; 16 | i2: int32; 17 | begin 18 | r1.b:= 123; 19 | po1:= @r1; 20 | po2:= @po1; 21 | exitcode:= precty(po2^)^.b; 22 | end. 23 | -------------------------------------------------------------------------------- /src/test/base/record/case4.mla: -------------------------------------------------------------------------------- 1 | program case4; 2 | type 3 | recty = record 4 | a: int32; 5 | (b2: int32; 6 | (d3: int32); 7 | (d4,e4: int32); 8 | ); 9 | (c2,d2,e2: int32); 10 | end; 11 | var 12 | r1: recty; 13 | begin 14 | r1.a:= 1; 15 | r1.b2:= 2; 16 | r1.d3:= 3; 17 | r1.e4:= 4; 18 | with r1 do 19 | exitcode:= a+c2+d2+e2 + 123-1-2-3-4; 20 | end; 21 | if sizeof(recty) <> 16 then 22 | exitcode:= 1; 23 | end; 24 | end. -------------------------------------------------------------------------------- /src/test/base/with/withpo1.mla: -------------------------------------------------------------------------------- 1 | program withpo1; 2 | 3 | type 4 | rec1ty = record 5 | e: int32; 6 | f: int32; 7 | end; 8 | recty = record 9 | a: int32; 10 | b: int32; 11 | c: rec1ty; 12 | end; 13 | precty = ^recty; 14 | var 15 | r1: recty; 16 | po1: precty; 17 | begin 18 | po1:= @r1; 19 | r1.a:= 1; 20 | r1.b:= 2; 21 | with po1^.c do 22 | e:= 10; 23 | f:= 110; 24 | end; 25 | exitcode:= r1.a+r1.b+r1.c.e+r1.c.f; 26 | end. -------------------------------------------------------------------------------- /src/test/object/methods/paramname.mla: -------------------------------------------------------------------------------- 1 | program paramname; 2 | uses 3 | rtl_streaming,rtl_streams,rtl_system; 4 | type 5 | otest = object 6 | property i: int32 read fi write fi; 7 | private 8 | fi: int32; 9 | protected 10 | method xx(i: int32); 11 | end; 12 | 13 | method otest.xx(i: int32); 14 | begin 15 | exitcode:= i + self.i; 16 | end; 17 | 18 | var 19 | t: otest; 20 | begin 21 | t.fi:= 120; 22 | t.xx(3); 23 | end. 24 | -------------------------------------------------------------------------------- /src/test/base/arith/bool/booleval1.mla: -------------------------------------------------------------------------------- 1 | program booleval1; 2 | 3 | procedure andfu(): bool1; 4 | begin 5 | result:= true; 6 | exitcode:= 123; 7 | end; 8 | //{$internaldebug on} 9 | var 10 | bo1: bool1; 11 | begin 12 | bo1:= false and false and andfu() or true; 13 | if bo1 and (exitcode = 0) then 14 | {$booleval on} 15 | bo1:= false and false and andfu() or true; 16 | if not bo1 then 17 | exitcode:= 111; 18 | end; 19 | end; 20 | end. -------------------------------------------------------------------------------- /src/test/base/arith/pointer/pointeradd1.mla: -------------------------------------------------------------------------------- 1 | program pointeradd1; 2 | type 3 | dynarrayheaderty = record 4 | a: int32; 5 | data: record 6 | end; 7 | end; 8 | pdynarrayheaderty = ^dynarrayheaderty; 9 | 10 | var 11 | ar1{,ar2}: array of string; //array of int32; 12 | p1: pdynarrayheaderty; 13 | p2,p3: pointer; 14 | i1: int32; 15 | begin 16 | p3:= @p1^.data+123; 17 | exitcode:= pointer(p3) - pointer(p1) - sizeof(p1^.a); 18 | end. 19 | -------------------------------------------------------------------------------- /src/test/object/objectintf.mla: -------------------------------------------------------------------------------- 1 | program objectintf; 2 | 3 | type 4 | itest = interface 5 | method test(); 6 | end; 7 | 8 | objaty = object 9 | a: int32; 10 | end; 11 | objty = object(objaty,itest) [virtual] 12 | method test(); 13 | end; 14 | 15 | method objty.test(); 16 | begin 17 | exitcode:= a; 18 | end; 19 | 20 | var 21 | obj1: objty; 22 | i1: itest; 23 | begin 24 | obj1.a:= 123; 25 | i1:= itest(obj1); 26 | i1.test(); 27 | end. -------------------------------------------------------------------------------- /src/test/units/unit4.mla: -------------------------------------------------------------------------------- 1 | unit unit4; 2 | interface 3 | type 4 | recty = record 5 | a,b,c: int32; 6 | end; 7 | 8 | implementation 9 | procedure test(): recty; 10 | begin 11 | result.a:= 100; 12 | result.b:= 20; 13 | result.c:= 2; 14 | end; 15 | var 16 | r1: recty; 17 | 18 | initialization 19 | r1:= test(); 20 | exitcode:= r1.a+r1.b+r1.c; 21 | finalization 22 | r1:= test(); 23 | exitcode:= ((exitcode + r1.a+r1.b+r1.c)+2) div 2; 24 | end. -------------------------------------------------------------------------------- /src/bcwriter/createabbrev/test.abr: -------------------------------------------------------------------------------- 1 | [mainfo.prefix] 2 | value=mab 3 | [mainfo.abbrevidstart] 4 | value=4 5 | [mainfo.grid] 6 | propcolwidthref=143 7 | values0=3 8 | ar 9 | 10 | 11 | sortdescend0=0 12 | values1=3 13 | 2 14 | 3 15 | 1 16 | values1_ci=-1 17 | sortdescend1=0 18 | values2=3 19 | 6 20 | 0 21 | 8 22 | values2_ci=-1 23 | sortdescend2=0 24 | values3=3 25 | id 26 | data 27 | 28 | sortdescend3=0 29 | [mainfo.idsize] 30 | value=3 31 | -------------------------------------------------------------------------------- /src/test/object/operators/operator6.mla: -------------------------------------------------------------------------------- 1 | program operator6; 2 | 3 | type 4 | objty = object[nozeroinit] 5 | fa,fb: int32; 6 | method assigni32(): int32 [operator='()']; 7 | method ini() [ini]; 8 | end; 9 | 10 | method objty.assigni32(): int32; 11 | begin 12 | result:= fb+fa; 13 | end; 14 | 15 | 16 | method objty.ini(); 17 | begin 18 | fa:= 100; 19 | end; 20 | 21 | var 22 | a: objty; 23 | begin 24 | a.fb:= 23; 25 | exitcode:= a; 26 | end. -------------------------------------------------------------------------------- /src/test/rtl/system/errno.mla: -------------------------------------------------------------------------------- 1 | program errno; 2 | uses 3 | rtl_streams,rtl_sysexceptions,rtl_system; 4 | var 5 | s1: tfilestream; 6 | e: esys; 7 | begin 8 | try 9 | s1:= tfilestream.create('test.abc'); 10 | except 11 | if getexceptobj(e) then 12 | if (e.error = sye_lasterror) and (e.lasterror = 2) and 13 | (e.message = 'No such file or directory.') then 14 | exitcode:= 123; 15 | end; 16 | end; 17 | end; 18 | end. 19 | -------------------------------------------------------------------------------- /src/var.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | type 3 | t1 = record 4 | a: int32; 5 | b: int32; 6 | end; 7 | var 8 | v1: t1; 9 | v2: record 10 | a: int32; 11 | b: int32; 12 | end; 13 | v3: int32; 14 | 15 | implementation 16 | begin 17 | v1.a:= 123; 18 | v1.b:= 456; 19 | v2.a:= 222; 20 | v2.b:= 333; 21 | v3:= 444; 22 | writeln(v1.a); 23 | writeln(v1.b); 24 | writeln(v2.a); 25 | writeln(v2.b); 26 | writeln(v3); 27 | end. -------------------------------------------------------------------------------- /src/bcwriter/main.mfm: -------------------------------------------------------------------------------- 1 | object mainfo: tmainfo 2 | bounds_x = 291 3 | bounds_y = 247 4 | bounds_cx = 403 5 | bounds_cy = 280 6 | container.bounds = ( 7 | 0 8 | 0 9 | 403 10 | 280 11 | ) 12 | moduleclassname = 'tmainform' 13 | object tbutton1: tbutton 14 | bounds_x = 40 15 | bounds_y = 24 16 | bounds_cx = 50 17 | bounds_cy = 20 18 | state = [as_localonexecute] 19 | onexecute = exe 20 | end 21 | end 22 | -------------------------------------------------------------------------------- /src/test/base/exception/raise2.mla: -------------------------------------------------------------------------------- 1 | program raise2; 2 | 3 | type 4 | tc = class[virtual,except] 5 | public 6 | constructor create(); 7 | destructor destroy()[default]; 8 | end; 9 | 10 | constructor tc.create(); 11 | begin 12 | end; 13 | destructor tc.destroy(); 14 | begin 15 | end; 16 | procedure test(); 17 | begin 18 | raise tc.create(); 19 | end; 20 | 21 | begin 22 | try 23 | test(); 24 | except 25 | exitcode:= 123; 26 | end; 27 | end. -------------------------------------------------------------------------------- /src/test/base/managed/arrayofarray1.mla: -------------------------------------------------------------------------------- 1 | program arrayofarray1; 2 | var 3 | ar1,ar2: array of array of int32; 4 | begin 5 | setlength(ar1,3); 6 | setlength(ar1[1],3); 7 | ar1[1][0]:= 11; 8 | ar1[1][1]:= 22; 9 | ar1[1][2]:= 33; 10 | ar2:= ar1; 11 | ar1[1,1]:= 222; 12 | if (ar1[1,0] = 11) and (ar1[1,1] = 222) and (ar1[1,2] = 33) and 13 | (ar2[1,0] = 11) and (ar2[1,1] = 222) and (ar2[1,2] = 33) then 14 | exitcode:= 123; 15 | end; 16 | end. 17 | -------------------------------------------------------------------------------- /src/test/base/string/stringconcat.mla: -------------------------------------------------------------------------------- 1 | program stringconcat; 2 | var 3 | s1,s2: string8; 4 | s1a,s2a: string16; 5 | s1b,s2b: string32; 6 | bo1: boolean; 7 | begin 8 | s1:= 'abc'; 9 | s1a:= 'abc'; 10 | s1b:= 'abc'; 11 | bo1:= 'abcabc' = s1+s2+s1; 12 | if bo1 then 13 | bo1:= 'abcabc' = s1a+s2a+s1a; 14 | if bo1 then 15 | bo1:= 'abcabc' = s1b+s2b+s1b; 16 | if bo1 then 17 | exitcode:= 123; 18 | end; 19 | end; 20 | end; 21 | end. 22 | -------------------------------------------------------------------------------- /src/test/intrinsics/managed/incdecref.mla: -------------------------------------------------------------------------------- 1 | program incdecref; 2 | type 3 | recty = record 4 | a,b: int32; 5 | s: string8; 6 | end; 7 | 8 | var 9 | a: recty; 10 | begin 11 | setlength(a.s,4); 12 | 13 | incref(a); 14 | incref(a.s); 15 | decref(a); 16 | decref(a.s); 17 | 18 | finalize(a.s); 19 | 20 | if a.s = '' then 21 | setlength(a.s,4); 22 | finalize(a); 23 | if a.s = '' then 24 | exitcode:= 123; 25 | end; 26 | end; 27 | 28 | end. -------------------------------------------------------------------------------- /src/test/base/sub/subvar/factsubcall.mla: -------------------------------------------------------------------------------- 1 | program factsubcall; 2 | type 3 | enuty = (en_1,en_2,en_3); 4 | procty = procedure(a: int32); 5 | 6 | procedure test(a: int32); 7 | begin 8 | exitcode:= exitcode+a; 9 | end; 10 | 11 | procedure fu(): procty; 12 | begin 13 | result:= @test; 14 | end; 15 | 16 | var 17 | ar1: array[enuty] of procty; 18 | v1: enuty; 19 | p1: procty; 20 | begin 21 | fu()(100); 22 | ar1[en_2]:= @test; 23 | ar1[en_2](23); 24 | end. -------------------------------------------------------------------------------- /src/test/object/methods/methodvarresult.mla: -------------------------------------------------------------------------------- 1 | program methodvarresult; 2 | type 3 | recty = record 4 | a,b,c: int32; 5 | end; 6 | 7 | ctest = object 8 | fa,fb: int32; 9 | method test: recty; 10 | end; 11 | 12 | method ctest.test(): recty; 13 | begin 14 | result.a:= fa; 15 | result.b:= fb; 16 | end; 17 | 18 | var 19 | o1: ctest; 20 | r1: recty; 21 | begin 22 | o1.fa:= 100; 23 | o1.fb:= 23; 24 | r1:= o1.test(); 25 | exitcode:= r1.a + r1.b; 26 | end. -------------------------------------------------------------------------------- /src/test/object/object1.mla: -------------------------------------------------------------------------------- 1 | program object1; 2 | type 3 | obj1ty = object() 4 | private 5 | f2: int32; 6 | public 7 | f1: int32; 8 | method sub1(par: int32): int32; 9 | property p2: int32 read f2 write f2; 10 | end; 11 | 12 | var 13 | obj1: obj1ty; 14 | 15 | method obj1ty.sub1(par: int32): int32; 16 | begin 17 | result:= f1+p2+par; 18 | end; 19 | 20 | begin 21 | obj1.f1:= 100; 22 | obj1.p2:= 20; 23 | exitcode:= obj1.sub1(3); 24 | end. 25 | -------------------------------------------------------------------------------- /src/test/object/operators/operator5.mla: -------------------------------------------------------------------------------- 1 | program operator5; 2 | 3 | type 4 | objty = object[nozeroinit] 5 | fa,fb: int32; 6 | method assigni32(const a: int32) [operator='()']; 7 | method ini() [ini]; 8 | end; 9 | 10 | method objty.assigni32(const a: int32); 11 | begin 12 | fb:= a+fa; 13 | end; 14 | 15 | method objty.ini(); 16 | begin 17 | fa:= 100; 18 | end; 19 | 20 | var 21 | a: objty; 22 | begin 23 | a:= int32(23); 24 | exitcode:= a.fb; 25 | end. -------------------------------------------------------------------------------- /src/test/base/indirect/pointerrec1.mla: -------------------------------------------------------------------------------- 1 | program pointerrec1; 2 | type 3 | headerty = record 4 | a: int32; 5 | b: int32; 6 | end; 7 | recty = record 8 | aa: int32; 9 | bb: int32; 10 | header: headerty; 11 | end; 12 | 13 | var 14 | rec1: recty; 15 | po1: ^headerty; 16 | 17 | begin 18 | rec1.aa:= 1; 19 | rec1.bb:= 2; 20 | rec1.header.a:= 10; 21 | rec1.header.b:= 110; 22 | po1:= @rec1.header; 23 | exitcode:= po1^.b+po1^.a+rec1.aa+rec1.bb; 24 | end. -------------------------------------------------------------------------------- /src/test/intrinsics/numeric/decnested.mla: -------------------------------------------------------------------------------- 1 | program decnested; 2 | uses 3 | __mla__internaltypes; 4 | 5 | procedure format(): string8; 6 | var 7 | p1: pchar8; 8 | procedure pushbufferreverse(); 9 | begin 10 | dec(p1); 11 | end; //pushbufferreverse() 12 | var 13 | p2: pointer; 14 | begin 15 | p1:= nil; 16 | pushbufferreverse(); 17 | p2:= nil; 18 | dec(p2); 19 | if p1 = p2 then 20 | exitcode:= 123; 21 | end; 22 | end; 23 | 24 | begin 25 | format(); 26 | end. -------------------------------------------------------------------------------- /src/test/class/classstringfield.mla: -------------------------------------------------------------------------------- 1 | program classstringfield; 2 | type 3 | ttest = class 4 | public 5 | field: string8; 6 | constructor create(); 7 | destructor destroy(); 8 | end; 9 | 10 | { ttest } 11 | 12 | constructor ttest.create(); 13 | begin 14 | field:= 'abc'; 15 | end; 16 | 17 | destructor ttest.destroy(); 18 | begin 19 | end; 20 | 21 | var 22 | t1: ttest; 23 | begin 24 | t1:= ttest.create(); 25 | writeln(t1.field); 26 | t1.destroy(); 27 | end. 28 | -------------------------------------------------------------------------------- /src/test/object/operators/assignop1.mla: -------------------------------------------------------------------------------- 1 | program assignop1; 2 | 3 | type 4 | objty = object[nozeroinit] 5 | fa,fb: int32; 6 | method store(var dest: objty) [operator=':=']; 7 | end; 8 | 9 | method objty.store(var dest: objty); 10 | begin 11 | dest.fa:= fa; 12 | dest.fb:= fb; 13 | end; 14 | 15 | var 16 | a,b: objty; 17 | begin 18 | a.fa:= 11; 19 | b.fa:= 22; 20 | a.fb:= 1; 21 | b.fb:= 2; 22 | a:= b; 23 | exitcode:= 123 + a.fa + a.fb + b.fa + b.fb - 2*(22+2); 24 | end. -------------------------------------------------------------------------------- /src/test/rtl/variants/variantstring1.mla: -------------------------------------------------------------------------------- 1 | program variantstring1; 2 | uses 3 | rtl_variants; 4 | 5 | procedure test(); 6 | var 7 | v1,v2: variantty; 8 | s1,s3: system.string8; 9 | s2: string16; 10 | begin 11 | v1:= 'abc'; 12 | v2:= v1; 13 | s1:= string8(string16(v2)); 14 | s2:= v1; 15 | s1:= 'abc'; 16 | s3:= string8(string16(s1)); 17 | if (s1 = 'abc') and (s2 = 'abc') and (s3 = 'abc') then 18 | exitcode:= 123; 19 | end; 20 | end; 21 | 22 | begin 23 | test(); 24 | end. -------------------------------------------------------------------------------- /src/test/base/arith/set/index2.mla: -------------------------------------------------------------------------------- 1 | program index2; 2 | uses 3 | type 4 | enuty = (en_0,en_1,en_2); 5 | enusty = set of enuty; 6 | penusty = ^enusty; 7 | 8 | var 9 | set1,set2: enusty; 10 | b1: boolean; 11 | ar1: array[enuty] of int32; 12 | i1: int32; 13 | begin 14 | set1[en_2]:= true; 15 | set1[en_1]:= true; 16 | set2:= set1; 17 | set2[en_1]:= false; 18 | b1:= set1[en_1]; 19 | if b1 and (int32(set1) = 6) and (int32(set2) = 4) then 20 | exitcode:= 123; 21 | end; 22 | end. -------------------------------------------------------------------------------- /src/test/base/exception/unhandled.mla: -------------------------------------------------------------------------------- 1 | program unhandled; 2 | uses 3 | rtl_stringconv; 4 | 5 | type 6 | ttest = class() [except,virtual] 7 | fa,fb: int32; 8 | constructor create(); 9 | destructor destroy() [default]; 10 | end; 11 | 12 | constructor ttest.create(); 13 | begin 14 | end; 15 | 16 | destructor ttest.destroy(); 17 | begin 18 | end; 19 | 20 | 21 | var 22 | c1: ttest; 23 | s1: string8; 24 | begin 25 | s1:= inttostring8(123); 26 | raise ttest.create(); 27 | end. -------------------------------------------------------------------------------- /src/test/base/set/bigset4.mla: -------------------------------------------------------------------------------- 1 | program bigset4; 2 | uses 3 | const 4 | startchars = ['ä','_','A'..'Z','a'..'z','ü']; 5 | allowedchars = startchars + ['0'..'9']; 6 | var 7 | ch1: char8; 8 | s1: set of char8; 9 | begin 10 | s1:= s1+allowedchars; 11 | for ch1:= #0 to #255 do 12 | if ch1 in s1 then 13 | write(string8(ch1)); 14 | end; 15 | end; 16 | writeln; 17 | for ch1:= #0 to #255 do 18 | if ch1 in startchars then 19 | write(string8(ch1)); 20 | end; 21 | end; 22 | end. -------------------------------------------------------------------------------- /src/test/intrinsics/typeinfo/typeofclass.mla: -------------------------------------------------------------------------------- 1 | program typeofclass; 2 | uses 3 | __mla__internaltypes; 4 | type 5 | ttest = class[rtti] 6 | end; 7 | var 8 | p1,p3: prttity; 9 | p2: pclassdefty; 10 | c1: class of ttest; 11 | i1: int32; 12 | h1: classdefheaderty; 13 | begin 14 | p1:= typeinfo(ttest); 15 | c1:= classof(ttest); 16 | p2:= pclassdefty(c1); 17 | p3:= p2^.header.rtti; 18 | if (string8(p1^.typename) = 'ttest') and (p1 = p3) then 19 | exitcode:= 123; 20 | end; 21 | end. -------------------------------------------------------------------------------- /src/test/base/exception/except2.mla: -------------------------------------------------------------------------------- 1 | program except2; 2 | type 3 | e = class()[virtual,except] 4 | constructor create(); 5 | destructor destroy() [default]; 6 | end; 7 | e1 = class(e) 8 | end; 9 | 10 | constructor e.create(); 11 | begin 12 | end; 13 | 14 | destructor e.destroy(); 15 | begin 16 | exitcode:= exitcode + 3; 17 | end; 18 | 19 | begin 20 | try 21 | raise e.create(); 22 | except 23 | e1: 24 | exitcode:= 100; 25 | e: 26 | exitcode:= 120; 27 | end; 28 | end. -------------------------------------------------------------------------------- /src/test/base/sub/defaultpar1.mla: -------------------------------------------------------------------------------- 1 | program defaultpar1; 2 | 3 | procedure testpro(a,b,c: int32 = 42): int32; 4 | begin 5 | result:= a+b-c; 6 | end; 7 | 8 | var 9 | i1: int32; 10 | begin 11 | i1:= testpro(); 12 | if i1 = 42 then 13 | i1:= testpro(10,6,89); 14 | if i1 = 10 + 6 - 89 then 15 | i1:= testpro(32,67); 16 | if i1 = 32 + 67 -42 then 17 | i1:= testpro(33); 18 | if i1 = 33 then 19 | exitcode:= 123; 20 | end; 21 | end; 22 | end; 23 | end 24 | end. 25 | -------------------------------------------------------------------------------- /src/test/base/with/withqualified1.mla: -------------------------------------------------------------------------------- 1 | program withqualified1; 2 | type 3 | rec1ty = object 4 | a,b: int32; 5 | end; 6 | 7 | recty = object 8 | a,b: int32; 9 | c: rec1ty; 10 | end; 11 | 12 | procedure test(const a,b: recty); 13 | begin 14 | exitcode:= a.a + a.b + b.b + a.c.b; 15 | end; 16 | 17 | var 18 | r1,r2: recty; 19 | b: int32; 20 | begin 21 | with r1:d, r2:e, d.c:f do 22 | d.a:= 70; 23 | d.b:= 20; 24 | e.b:= 3; 25 | f.b:= 30; 26 | test(d,e); 27 | end; 28 | end. -------------------------------------------------------------------------------- /src/test/rtl/tobject/ini.mla: -------------------------------------------------------------------------------- 1 | program ini; 2 | uses 3 | rtl_fpccompatibility; 4 | 5 | type 6 | ttest = class(tobject) 7 | f1,f2: int32; 8 | end; 9 | 10 | ttest1 = class(ttest) 11 | f3: int32; 12 | constructor create(); 13 | end; 14 | 15 | constructor ttest1.create(); 16 | begin 17 | exitcode:= sizeof(self^); 18 | f3:= 123-(4+8+4); 19 | end; 20 | 21 | var 22 | c2: ttest; 23 | begin 24 | c2:= ttest1.create(); 25 | exitcode:= exitcode+ttest1(c2).f3; 26 | c2.destroy(); 27 | end. -------------------------------------------------------------------------------- /src/test/syntax/errorcheck/objects/doubleprop.mla: -------------------------------------------------------------------------------- 1 | program doubleprop; 2 | type 3 | tt= class 4 | constructor create(); 5 | destructor destroy(); 6 | // property i: int32 read fi write fi [{default='123'}]; 7 | property i: int32 read fi write fi [default=123]; 8 | property i: int32 read fi write fi; 9 | private 10 | fi: int32; 11 | end; 12 | 13 | constructor tt.create(); 14 | begin 15 | end; 16 | 17 | destructor tt.destroy(); 18 | begin 19 | end; 20 | 21 | begin 22 | end. 23 | -------------------------------------------------------------------------------- /src/test/base/sub/param/arrayofconst.mla: -------------------------------------------------------------------------------- 1 | program arrayofconst; 2 | 3 | procedure tt1(const p: array of const); 4 | begin 5 | exitcode:= exitcode + p[0].vint32; 6 | end; 7 | 8 | procedure tt(const p: array of const); 9 | begin 10 | tt1(p); 11 | end; 12 | 13 | procedure tt1a(p: array of const); 14 | begin 15 | exitcode:= exitcode + p[0].vint32; 16 | end; 17 | 18 | procedure tta(p: array of const); 19 | begin 20 | tt1(p); 21 | end; 22 | 23 | begin 24 | tt([100]); 25 | tta([23]); 26 | end. -------------------------------------------------------------------------------- /src/test/base/arith/set/inclexcl2.mla: -------------------------------------------------------------------------------- 1 | program inclexcl2; 2 | uses 3 | type 4 | enuty = 0..2; 5 | enusty = set of enuty; 6 | penusty = ^enusty; 7 | enu2ty = (en2_0,en2_1); 8 | 9 | var 10 | set1,set2: enusty; 11 | b1: boolean; 12 | ar1: array[enuty] of int32; 13 | i1: int32; 14 | begin 15 | include(set1,2); 16 | include(set1,1); 17 | set2:= set1; 18 | exclude(set2,1); 19 | b1:= 1 in set1; 20 | if b1 and (int32(set1) = 6) and (int32(set2) = 4) then 21 | exitcode:= 123; 22 | end; 23 | end. -------------------------------------------------------------------------------- /src/test/base/arith/set/inclexcl3.mla: -------------------------------------------------------------------------------- 1 | program inclexcl3; 2 | uses 3 | type 4 | enuty = 0..2; 5 | enusty = set of enuty; 6 | penusty = ^enusty; 7 | enu2ty = (en2_0,en2_1); 8 | 9 | var 10 | set1,set2: enusty; 11 | b1: boolean; 12 | ar1: array[enuty] of int32; 13 | i1: int32; 14 | begin 15 | set1[2]:= true; 16 | set1[1]:= true; 17 | set2:= set1; 18 | set2[1]:= false; 19 | b1:= 1 in set1; 20 | if b1 and (int32(set1) = 6) and (int32(set2) = 4) then 21 | exitcode:= 123; 22 | end; 23 | end. -------------------------------------------------------------------------------- /src/test/base/sub/param/varparrec.mla: -------------------------------------------------------------------------------- 1 | program varparrec; 2 | type 3 | convertinfoty = record 4 | width,precision: int32; 5 | minus: bool1; 6 | s: pointer; //string8, string16 or string32 7 | end; 8 | 9 | procedure pushstring8(var info: convertinfoty); 10 | var 11 | s1: string8; 12 | begin 13 | s1:= string8(info.s); 14 | if s1 = 'abc' then 15 | exitcode:= 123; 16 | end; 17 | end; 18 | 19 | var 20 | inf1: convertinfoty; 21 | begin 22 | inf1.s:= pointer('abc'); 23 | pushstring8(inf1); 24 | end. -------------------------------------------------------------------------------- /src/test/base/sub/recparpo.mla: -------------------------------------------------------------------------------- 1 | program recparpo; 2 | type 3 | rec1ty = record 4 | a: int32; 5 | b: int32; 6 | end; 7 | prec1ty = ^rec1ty; 8 | recty = record 9 | h: rec1ty; 10 | c: int32; 11 | end; 12 | precty = ^recty; 13 | 14 | procedure test(p: prec1ty): int32; 15 | begin 16 | p^.b:= 110; 17 | end; 18 | 19 | var 20 | r1: recty; 21 | po1: precty; 22 | po2: prec1ty; 23 | begin 24 | r1.h.a:= 13; 25 | po1:= @r1; 26 | po2:= @po1^.h; 27 | test(po2); 28 | exitcode:= r1.h.a+r1.h.b; 29 | end. -------------------------------------------------------------------------------- /src/test/class/forwardclass.mla: -------------------------------------------------------------------------------- 1 | program forwardclass; 2 | type 3 | poty = ^tt; 4 | tc = class; 5 | tc = class 6 | f1: int32; 7 | constructor create(); 8 | destructor destroy(); 9 | end; 10 | tc1 = class(tc) 11 | end; 12 | tt = int32; 13 | 14 | constructor tc.create(); 15 | begin 16 | f1:= 123; 17 | end; 18 | 19 | destructor tc.destroy(); 20 | begin 21 | end; 22 | 23 | var 24 | po1: poty; 25 | c1: tc; 26 | begin 27 | c1:= tc.create(); 28 | exitcode:= c1.f1; 29 | c1.destroy(); 30 | end. -------------------------------------------------------------------------------- /src/test/class/methods/method1.mla: -------------------------------------------------------------------------------- 1 | program method1; 2 | uses 3 | __mla__internaltypes; 4 | type 5 | 6 | meth1ty = method (a,b: int32); 7 | 8 | var 9 | meth1: meth1ty; 10 | meth2: meth1ty; 11 | 12 | begin 13 | with methodty(meth1) do 14 | code:= pointer(100); 15 | data:= pointer(23); 16 | end; 17 | meth2:= meth1; 18 | meth1:= nil; 19 | exitcode:= ptrint(methodty(meth2).code)+ptrint(methodty(meth2).data)+ 20 | ptrint(methodty(meth1).code)+ptrint(methodty(meth1).data); 21 | end. 22 | -------------------------------------------------------------------------------- /src/test/base/managed/arrayofstring2.mla: -------------------------------------------------------------------------------- 1 | program arrayofstring2; 2 | var 3 | ar1,ar2: array of string; //array of int32; 4 | begin 5 | setlength(ar1,3); 6 | setlength(ar1[1],3); 7 | ar1[1,1]:= 'a'; 8 | ar1[1,2]:= 'b'; 9 | ar1[1,3]:= 'c'; 10 | ar2:= ar1; 11 | setlength(ar1,4); 12 | ar2[1]:= 'ABC'; 13 | if (ar1[1] = 'abc') and (ar2[1] = 'ABC') then 14 | ar1:= ar2; 15 | if (ar1[1] = 'ABC') and (ar2[1] = 'ABC') then 16 | exitcode:= 123; 17 | end; 18 | setlength(ar2,1); 19 | end; 20 | end. 21 | -------------------------------------------------------------------------------- /src/test/base/record/case.mla: -------------------------------------------------------------------------------- 1 | program case; 2 | type 3 | recty = record 4 | aa: int32; 5 | bb: int32; 6 | i: int32; 7 | (a: int32;b:int32;d:record a,b: int32 end); 8 | (e: int32;c: flo64;); 9 | (f: record 10 | z: int32; 11 | (ww: int32;); 12 | (rr,uu: int32;) 13 | end 14 | ); 15 | end; 16 | 17 | var 18 | r1: recty; 19 | begin 20 | r1.i:= 1; 21 | r1.a:= 22; 22 | r1.d.b:= 100; 23 | exitcode:= r1.i+r1.e+r1.d.b; 24 | if sizeof(r1) <> 28 then 25 | exitcode:= 1; 26 | end; 27 | end. -------------------------------------------------------------------------------- /src/test/base/arith/set/inclexcl.mla: -------------------------------------------------------------------------------- 1 | program inclexcl; 2 | uses 3 | type 4 | enuty = (en_0,en_1,en_2); 5 | enusty = set of enuty; 6 | penusty = ^enusty; 7 | enu2ty = (en2_0,en2_1); 8 | 9 | var 10 | set1,set2: enusty; 11 | b1: boolean; 12 | ar1: array[enuty] of int32; 13 | i1: int32; 14 | begin 15 | include(set1,en_2); 16 | include(set1,en_1); 17 | set2:= set1; 18 | exclude(set2,en_1); 19 | b1:= en_1 in set1; 20 | if b1 and (int32(set1) = 6) and (int32(set2) = 4) then 21 | exitcode:= 123; 22 | end; 23 | end. -------------------------------------------------------------------------------- /src/test/base/record/case3.mla: -------------------------------------------------------------------------------- 1 | program case3; 2 | type 3 | recty = record 4 | a: int32; 5 | case b: int32 of 6 | 0:(c,d,e,f: int32); 7 | 1:(c1: int32; d1: int32; 8 | case x: int32 of 9 | 0: (c2: int32); 10 | 1: (c3: int32; d3: int32); 11 | ); 12 | end; 13 | var 14 | r1: recty; 15 | begin 16 | with r1 do 17 | a:= 1; 18 | b:= 2; 19 | e:= 3; 20 | f:= 4; 21 | exitcode:= a+b+x+c2+(123-1-2-3-4); 22 | end; 23 | if sizeof(recty) <> 28 then 24 | exitcode:= 1; 25 | end; 26 | end. -------------------------------------------------------------------------------- /src/test/object/object2.mla: -------------------------------------------------------------------------------- 1 | program object2; 2 | type 3 | obj1ty = object 4 | public 5 | f1: int32; 6 | end; 7 | 8 | obj2ty = object(obj1ty) 9 | private 10 | f2: int32; 11 | public 12 | method sub1(par: int32): int32; 13 | property p2: int32 read f2 write f2; 14 | end; 15 | 16 | var 17 | obj1: obj2ty; 18 | 19 | method obj2ty.sub1(par: int32): int32; 20 | begin 21 | result:= f1+p2+par; 22 | end; 23 | 24 | begin 25 | obj1.f1:= 100; 26 | obj1.p2:= 20; 27 | exitcode:= obj1.sub1(3); 28 | end. 29 | -------------------------------------------------------------------------------- /src/test/object/object3.mla: -------------------------------------------------------------------------------- 1 | program object3; 2 | type 3 | obj1ty = object() 4 | public 5 | f1: string8; 6 | i1: int32; 7 | end; 8 | obj2ty = object(obj1ty) 9 | public 10 | f2: string8; 11 | end; 12 | var 13 | obj1,obj2: obj2ty; 14 | obj3: obj1ty; 15 | s1: string16; 16 | s2: string8; 17 | begin 18 | 19 | s1:= 'abc'; 20 | s2:= s1; 21 | obj1.f1:= s2; 22 | obj1.f2:= 'def'; 23 | obj1.i1:= 123; 24 | obj2:= obj1; 25 | obj3:= obj1; 26 | writeln(obj3.f1,obj1.f2); 27 | exitcode:= obj3.i1; 28 | end. 29 | -------------------------------------------------------------------------------- /src/test/base/condition/condition1.mla: -------------------------------------------------------------------------------- 1 | program condition1; 2 | const 3 | val = 11; 4 | begin 5 | {$if defined(test)} 6 | exitcode:= 10; 7 | {$else} 8 | exitcode:= 100; 9 | {$endif} 10 | {$define test} 11 | {$if defined(test)} 12 | exitcode:= exitcode+20; 13 | {$else} 14 | exitcode:= 10; 15 | {$endif} 16 | {$define valu = val} 17 | {$if valu = val} 18 | exitcode:= exitcode+2; 19 | {$else} 20 | exitcode:= 10; 21 | {$endif} 22 | {$if valu = 0} 23 | exitcode:= 10; 24 | {$else} 25 | exitcode:= exitcode + 1; 26 | {$endif} 27 | end. -------------------------------------------------------------------------------- /src/test/base/set/bigset2.mla: -------------------------------------------------------------------------------- 1 | program bigset2; 2 | uses 3 | type 4 | set5ty = set of 0..129; 5 | ar5ty = array[0..sizeof(set5ty)-1] of card8; 6 | var 7 | s5: set5ty; 8 | ar5: ar5ty; 9 | i2: int32; 10 | begin 11 | s5:= [7..8,127..128,120]; 12 | ar5:= ar5ty(s5); 13 | if (ar5[0] = $80) and (ar5[15] = $81) and (ar5[16] = 1) and 14 | (8 in s5) and (7 in s5) and (128 in s5) and not (30 in s5) then 15 | exitcode:= 123; 16 | end; 17 | { 18 | for i2:= 0 to high(ar5) do 19 | write(ar5[i2],' '); 20 | end; 21 | } 22 | end. -------------------------------------------------------------------------------- /src/test/class/constructor1.mla: -------------------------------------------------------------------------------- 1 | program constructor1; 2 | 3 | type 4 | ttest = class 5 | private 6 | public 7 | constructor create(const p: int32); 8 | destructor destroy(p: int32); 9 | end; 10 | 11 | { ttest } 12 | 13 | constructor ttest.create(const p: int32;); 14 | begin 15 | exitcode:= p+123; 16 | end; 17 | 18 | destructor ttest.destroy(p: int32); 19 | begin 20 | exitcode:= exitcode-p; 21 | end; 22 | 23 | var 24 | t1: ttest; 25 | 26 | begin 27 | t1:= ttest.create(10); 28 | t1.destroy(10); 29 | end. 30 | -------------------------------------------------------------------------------- /src/test/object/methods/method1.mla: -------------------------------------------------------------------------------- 1 | program method1; 2 | 3 | type 4 | methty = method (a: int32): int32; 5 | 6 | objty = object 7 | a: int32; 8 | method test(p: int32): int32; 9 | end; 10 | 11 | method objty.test(p: int32): int32; 12 | begin 13 | result:= a+p; 14 | end; 15 | 16 | sub test(a: int32): int32; 17 | begin 18 | result:= a; 19 | end; 20 | 21 | var 22 | obj1: objty; 23 | meth1: methty; 24 | begin 25 | obj1.a:= 60; 26 | meth1:= @obj1.test; 27 | exitcode:= meth1(40); 28 | exitcode:= exitcode + test(23); 29 | end. -------------------------------------------------------------------------------- /src/test/base/sub/param/classparam.mla: -------------------------------------------------------------------------------- 1 | program classparam; 2 | uses 3 | rtl_base; 4 | type 5 | t1 = class (Cbase) 6 | f1: int32; 7 | constructor create(); 8 | end; 9 | 10 | constructor t1.create(); 11 | begin 12 | f1:= 123; 13 | end; 14 | 15 | procedure getpropinfox(const instance: Cbase): int32; 16 | begin 17 | result:= t1(instance).f1; 18 | // result:= getpropinfo(typeinfo(instance),propname); 19 | end; 20 | 21 | var 22 | c1: t1; 23 | begin 24 | c1:= t1.create(); 25 | exitcode:= getpropinfox(c1); 26 | c1.destroy(); 27 | end. -------------------------------------------------------------------------------- /src/test/object/methods/methodparams.mla: -------------------------------------------------------------------------------- 1 | program methodparams; 2 | type 3 | testty = object 4 | f1: card8; 5 | method test(const a,b: testty;c:flo64); 6 | method test1(const b: testty); 7 | f2: flo64; 8 | f3: int32; 9 | end; 10 | 11 | method testty.test(const a,b: testty;c:flo64); 12 | begin 13 | exitcode:= a.f3+f1; 14 | end; 15 | 16 | method testty.test1(const b: testty); 17 | begin 18 | test(b,b,0); 19 | end; 20 | 21 | var 22 | o1,o2: testty; 23 | begin 24 | o1.f1:= 100; 25 | o2.f3:= 23; 26 | o1.test1(o2); 27 | end. 28 | -------------------------------------------------------------------------------- /src/test/object/objvariant1.mla: -------------------------------------------------------------------------------- 1 | program objvariant1; 2 | 3 | type 4 | objty = object 5 | a: int32; 6 | (b2: int32; 7 | (d3: int32); 8 | (d4,e4: int32); 9 | ); 10 | method test(); 11 | (c2,d2,e2: int32); 12 | end; 13 | 14 | method objty.test(); 15 | begin 16 | end; 17 | 18 | var 19 | r1: objty; 20 | 21 | begin 22 | r1.a:= 1; 23 | r1.b2:= 2; 24 | r1.d3:= 3; 25 | r1.e4:= 4; 26 | with r1 do 27 | exitcode:= a+c2+d2+e2 + 123-1-2-3-4; 28 | end; 29 | if sizeof(objty) <> 16 then 30 | exitcode:= 1; 31 | end; 32 | end. -------------------------------------------------------------------------------- /src/test/base/sub/managed/subvarres2.mla: -------------------------------------------------------------------------------- 1 | program subvarres2; 2 | type 3 | recty = record 4 | s: string8; 5 | a,b,c: int32; 6 | end; 7 | 8 | procedure test(): recty; 9 | begin 10 | 11 | result.a:= 100; 12 | result.b:= 20; 13 | result.c:= 3; 14 | 15 | setlength(result.s,3); 16 | 17 | result.s[1]:= 'a'; 18 | result.s[2]:= 'b'; 19 | result.s[3]:= 'c'; 20 | 21 | end; 22 | 23 | var 24 | r1: recty; 25 | 26 | begin 27 | r1:= test(); 28 | exitcode:= r1.a+r1.b+r1.c; 29 | if r1.s <> 'abc' then 30 | exitcode:= 1; 31 | end; 32 | end. -------------------------------------------------------------------------------- /src/test/class/classparam.mla: -------------------------------------------------------------------------------- 1 | program classparam; 2 | 3 | type 4 | tbase = class() [virtual] 5 | constructor create(); 6 | destructor destroy() [virtual]; 7 | f1: int32; 8 | end; 9 | 10 | constructor tbase.create(); 11 | begin 12 | f1:= 123; 13 | end; 14 | 15 | destructor tbase.destroy(); 16 | begin 17 | end; 18 | 19 | procedure getpropreadad(instance: tbase); 20 | begin 21 | exitcode:= instance.f1; 22 | end; 23 | 24 | var 25 | c1: tbase; 26 | begin 27 | c1:= tbase.create(); 28 | getpropreadad(c1); 29 | c1.destroy(); 30 | end. -------------------------------------------------------------------------------- /src/bcwriter/createabbrev/type.abr: -------------------------------------------------------------------------------- 1 | [mainfo.prefix] 2 | value=mabtype 3 | [mainfo.abbrevidstart] 4 | value=4 5 | [mainfo.grid] 6 | propcolwidthref=143 7 | values0=5 8 | subtype 9 | 10 | 11 | 12 | 13 | sortdescend0=0 14 | values1=5 15 | 0 16 | 1 17 | 2 18 | 3 19 | 2 20 | values1_ci=-1 21 | sortdescend1=0 22 | values2=5 23 | 21 24 | 1 25 | 6 26 | 0 27 | 6 28 | values2_ci=-1 29 | sortdescend2=0 30 | values3=5 31 | TYPE_CODE_FUNCTION 32 | vararg 33 | retty 34 | paramty 35 | 36 | sortdescend3=0 37 | [mainfo.idsize] 38 | value=3 39 | -------------------------------------------------------------------------------- /src/test/base/string/stringconcat1.mla: -------------------------------------------------------------------------------- 1 | program stringconcat1; 2 | 3 | procedure test(p1: int32; const p: string8; p2: int32); 4 | begin 5 | if (p = 'abcdefabc') and (p1 = 1) and (p2 = 2) then 6 | exitcode:= 120+p1+p2; 7 | end; 8 | end; 9 | 10 | var 11 | s2,s3,s4: string8; 12 | b1: bool1; 13 | begin 14 | //{$internaldebug on} 15 | s2:= 'abc'; 16 | s3:= 'defabc'; 17 | s4:= 'def'+s2; 18 | b1:= 'def'+s2 = 'defabc'; 19 | if b1 and (s3 = 'def'+s2) and ('def'+s2 = 'def'+s2) and (s3 = s4) then 20 | test(1,s2+'def'+s2,2); 21 | end; 22 | end. 23 | -------------------------------------------------------------------------------- /src/test/base/arith/cmp/cmppointer.mla: -------------------------------------------------------------------------------- 1 | program cmppointer; 2 | 3 | var 4 | po1,po2: pointer; 5 | 6 | begin 7 | inc(po1); 8 | if po1 > po2 then 9 | exitcode:= 1; 10 | end; 11 | dec(po2); 12 | if po1 > po2 then 13 | exitcode:= 1; 14 | else 15 | exitcode:= exitcode+122; 16 | end; 17 | po1:= nil; 18 | po2:= nil; 19 | if exitcode = 123 then 20 | inc(po2); 21 | if po1 < po2 then 22 | exitcode:= 1; 23 | end; 24 | dec(po1); 25 | if po1 < po2 then 26 | exitcode:= 1; 27 | else 28 | exitcode:= exitcode+122; 29 | end; 30 | end; 31 | end. -------------------------------------------------------------------------------- /src/test/base/record/case1.mla: -------------------------------------------------------------------------------- 1 | program case1; 2 | type 3 | recty = record 4 | aa: int32; 5 | bb: int32; 6 | case int32 of 7 | 1,2: (a: int32;b:int32;d:record a,b: int32 end); 8 | 1: (e: int32;c: flo64;); 9 | 5: (f: record 10 | case z: int32 of 11 | 1: (ww: int32;); 12 | 2: (rr,uu: int32;) 13 | end;) 14 | end; 15 | 16 | var 17 | r1: recty; 18 | begin 19 | r1.aa:= 1; 20 | r1.a:= 22; 21 | r1.d.b:= 100; 22 | exitcode:= r1.aa+r1.e+r1.d.b; 23 | if sizeof(r1) <> 24 then 24 | exitcode:= 1; 25 | end; 26 | end. -------------------------------------------------------------------------------- /src/test/intrinsics/managed/initclass1.mla: -------------------------------------------------------------------------------- 1 | program initclass1; 2 | type 3 | ttest = class()[virtual] 4 | fa,fb: int32; 5 | constructor create(); 6 | destructor destroy(); 7 | end; 8 | 9 | constructor ttest.create(); 10 | begin 11 | end; 12 | 13 | destructor ttest.destroy(); 14 | begin 15 | end; 16 | 17 | var 18 | c1: ttest; 19 | begin 20 | c1:= ttest.create(); 21 | c1.fa:= 11; 22 | c1.fb:= 22; 23 | if c1.fa+c1.fb = 33 then 24 | initialize(c1,ttest); 25 | if c1.fa+c1.fb = 0 then 26 | exitcode:= 123; 27 | end; 28 | end; 29 | c1.destroy(); 30 | end. -------------------------------------------------------------------------------- /src/interpreter/mainmodule.mfm: -------------------------------------------------------------------------------- 1 | object mainmo: tmainmo 2 | bounds_cx = 248 3 | bounds_cy = 200 4 | oncreate = createexe 5 | oneventloopstart = eventloopexe 6 | onterminated = terminatedexe 7 | left = 290 8 | top = 348 9 | moduleclassname = 'tmsedatamodule' 10 | object sysenv: tsysenvmanager 11 | left = 80 12 | top = 56 13 | defs = ( 14 | ( 15 | ak_arg 16 | '' 17 | ( ) 18 | [] 19 | '' 20 | '' 21 | '' 22 | '' 23 | '' 24 | ) 25 | ) 26 | end 27 | end 28 | -------------------------------------------------------------------------------- /src/test/object/object8.mla: -------------------------------------------------------------------------------- 1 | program object8; 2 | 3 | type 4 | objty = object [nozeroinit,virtual] 5 | f1: int32; 6 | method test(p: int32) [virtual]; 7 | end; 8 | obj1ty = object(objty) [zeroinit] 9 | f2: int32; 10 | s1: string8; 11 | method test(p: int32) [override]; 12 | end; 13 | 14 | method objty.test(p: int32); 15 | begin 16 | end; 17 | 18 | method obj1ty.test(p: int32); 19 | begin 20 | exitcode:= f1+f2+p; 21 | end; 22 | 23 | procedure test(); 24 | var 25 | ob1: obj1ty; 26 | begin 27 | ob1.test(123); 28 | end; 29 | 30 | begin 31 | test(); 32 | end. -------------------------------------------------------------------------------- /src/type.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | {$include test.inc} 3 | type 4 | t1 = record 5 | a: int32; 6 | b: int32; 7 | end; 8 | t2 = record 9 | c: int32; 10 | d: int32; 11 | end; 12 | var 13 | v1: array[0..1] of t1; 14 | v2: int32; 15 | v3: t2; 16 | 17 | implementation 18 | 19 | begin 20 | with v1[0],v1[1],v3 do begin 21 | a:= 111; 22 | b:= 123; 23 | c:= 222; 24 | d:= 456; 25 | end; 26 | writeln(v1[0].a); 27 | writeln(v1[0].b); 28 | writeln(v1[1].a); 29 | writeln(v1[1].b); 30 | writeln(v3.c); 31 | writeln(v3.d); 32 | v4:= 444; 33 | writeln(v4); 34 | end. -------------------------------------------------------------------------------- /src/test/base/control/recifindi.mla: -------------------------------------------------------------------------------- 1 | program recifindi; 2 | type 3 | recty = record 4 | a: int32; 5 | b: int32; 6 | end; 7 | precty = ^recty; 8 | var 9 | rec1: recty; 10 | po1: precty; 11 | begin 12 | rec1.b:= 1; 13 | po1:= @rec1; 14 | if po1^.b > 0 then 15 | exitcode:= 1; 16 | else 17 | exitcode:= 2; 18 | end; 19 | if exitcode = 1 then 20 | if rec1.b < 2 then 21 | exitcode:= 3; 22 | end; 23 | if exitcode = 3 then 24 | if rec1.b >= 1 then 25 | if po1^.b <= 1 then 26 | exitcode:= 99; 27 | end; 28 | end; 29 | end; 30 | end; 31 | end. -------------------------------------------------------------------------------- /src/test/base/sub/subvar/subvar2.mla: -------------------------------------------------------------------------------- 1 | program subvar2; 2 | 3 | procedure test(a: int32); 4 | begin 5 | exitcode:= exitcode + a; 6 | end; 7 | 8 | procedure tefu(a: int32): int32; 9 | begin 10 | result:= 10*a; 11 | end; 12 | 13 | type 14 | procty = procedure(a: int32); 15 | functy = procedure(a: int32): int32; 16 | 17 | var 18 | proc: procty; 19 | proc1: procedure(a: int32); 20 | fu: functy; 21 | fu1: procedure(a: int32): int32; 22 | begin 23 | proc:= @test; 24 | proc1:= @test; 25 | fu:= @tefu; 26 | fu1:= @tefu; 27 | proc(fu(10)); 28 | proc1(fu1(2)+3); 29 | end. 30 | -------------------------------------------------------------------------------- /src/test/object/operators/assignop2.mla: -------------------------------------------------------------------------------- 1 | program assignop2; 2 | 3 | type 4 | objty = object[nozeroinit] 5 | fa,fb: int32; 6 | method store(var dest: objty) [operator=':=']; 7 | end; 8 | 9 | method objty.store(var dest: objty); 10 | begin 11 | dest.fa:= fa; 12 | dest.fb:= fb; 13 | end; 14 | 15 | var 16 | a,b: objty; 17 | 18 | procedure test(): objty; 19 | begin 20 | result:= b; 21 | end; 22 | 23 | begin 24 | 25 | a.fa:= 11; 26 | b.fa:= 22; 27 | a.fb:= 1; 28 | b.fb:= 2; 29 | a:= test(); 30 | exitcode:= 123 + a.fa + a.fb + b.fa + b.fb - 2*(22+2); 31 | 32 | end. -------------------------------------------------------------------------------- /src/test/base/sub/recparsubres.mla: -------------------------------------------------------------------------------- 1 | program recparsubres; 2 | type 3 | recty = record 4 | a,b: int32; 5 | end; 6 | 7 | var 8 | rec1,rec2: recty; 9 | p1: ^recty; 10 | 11 | procedure test(): ^^recty; 12 | begin 13 | result:= @p1; 14 | end; 15 | 16 | procedure testa(): recty; 17 | begin 18 | result:= rec2; 19 | end; 20 | 21 | procedure test1(const a: recty); 22 | begin 23 | exitcode:= exitcode + a.a + a.b; 24 | end; 25 | 26 | begin 27 | rec1.a:= 40; 28 | rec1.b:= 60; 29 | rec2.a:= 20; 30 | rec2.b:= 3; 31 | p1:= @rec1; 32 | test1(test()^^); 33 | test1(testa()); 34 | end. -------------------------------------------------------------------------------- /src/test/base/sub/subvar/subvar3.mla: -------------------------------------------------------------------------------- 1 | program subvar3; 2 | 3 | type 4 | ppointer = ^pointer; 5 | arraysortcomparety = procedure (const l,r: ppointer): int32; 6 | ppint32 = ^^int32; 7 | procedure comparestring(const l,r: ppointer): int32; 8 | begin 9 | exitcode:= ppint32(l)^^+ppint32(r)^^ 10 | end; 11 | 12 | procedure sortarray(const compare: arraysortcomparety); 13 | var 14 | p1,p2: pointer; 15 | i1,i2: int32; 16 | begin 17 | i1:= 100; 18 | i2:= 23; 19 | p1:= @i1; 20 | p2:= @i2; 21 | compare(@p1,@p2) 22 | end; 23 | 24 | begin 25 | sortarray(@comparestring); 26 | end. 27 | -------------------------------------------------------------------------------- /src/test/base/set/bigset3.mla: -------------------------------------------------------------------------------- 1 | program bigset3; 2 | uses 3 | type 4 | set5ty = set of 0..129; 5 | ar5ty = array[0..sizeof(set5ty)-1] of card8; 6 | var 7 | s5,s6,s7: set5ty; 8 | ar5: ar5ty; 9 | i2: int32; 10 | begin 11 | s7:= ([1]+[7..8,127..128,120,121]) * [7..8,127..128,120]; 12 | s5:= [7..8]+[127..128]+[120]; 13 | s6:= [1]+[7..8,127..128,120]-[1]; 14 | ar5:= ar5ty(s7); 15 | if (ar5[0] = $80) and (ar5[15] = $81) and (ar5[16] = 1) and 16 | (8 in s5) and (7 in s5) and (128 in s5) and not (30 in s5) and (s5 = s6) and (s5 = s7) then 17 | exitcode:= 123; 18 | end; 19 | end. -------------------------------------------------------------------------------- /src/test/base/const/typedconst1.mla: -------------------------------------------------------------------------------- 1 | program typedconst1; 2 | 3 | const 4 | c1: int8 = 1; 5 | c2: int16 = 2; 6 | c3: int32 = 3; 7 | c4: int64 = 4; 8 | c5: card8 = 5; 9 | c6: card16 = 6; 10 | c7: card32 = 7; 11 | c8: card64 = 8; 12 | c9: boolean = true; 13 | c10: flo32 = 10.5; 14 | c11: flo64 = 11.5; 15 | c12: string8 = 'abc'; 16 | 17 | begin 18 | if (c1 = 1) and (c2 = 2) and (c3 = 3) and (c4 = 4) and 19 | (c5 = 5) and (c6 = 6) and (c7 = 7) and (c8 = 8) and c9 and 20 | (c10 = 10.5) and (c11 = 11.5) and (c12 = 'abc') 21 | then 22 | exitcode:= 123; 23 | end; 24 | end. 25 | -------------------------------------------------------------------------------- /src/test/rtl/string/format1.mla: -------------------------------------------------------------------------------- 1 | program format1; 2 | uses 3 | rtl_format; 4 | begin 5 | writeln(format('abc%1:Ddefg',[11,123,33])); 6 | writeln(format('abc%:Ddefg',[1234,123,33])); 7 | writeln(format('abc%:.8Ddefg',[1234,123,33])); 8 | writeln(format('abc%:10.8Ddefg',[1234,123,33])); 9 | writeln(format('abc%:-10.8Ddefg',[1234,123,33])); 10 | writeln(format('abc%:-10.3sdef',['ÄBCDEFGHI'])); 11 | writeln(format('abc %.3f def',[8.25e13])); 12 | writeln(format('abc %.3n def',[8.25e13])); 13 | writeln(format('abc %.3e def',[8.255e13])); 14 | writeln(format('abc %g def',[8.25e13])); 15 | end. -------------------------------------------------------------------------------- /src/test/class/properties/classprop1.mla: -------------------------------------------------------------------------------- 1 | program classprop1; 2 | 3 | type 4 | tcla1 = class 5 | private 6 | fb: int32; 7 | fa: int32; 8 | public 9 | constructor create(); 10 | destructor destroy(); 11 | end; 12 | 13 | tcla = class(tcla1) 14 | private 15 | public 16 | property a: int32 read fa [default=1+3]; 17 | end; 18 | 19 | constructor tcla1.create(); 20 | begin 21 | fa:= 123; 22 | end; 23 | 24 | destructor tcla1.destroy(); 25 | begin 26 | end; 27 | 28 | var 29 | cla: tcla; 30 | begin 31 | cla:= tcla.create(); 32 | exitcode:= cla.a; 33 | cla.destroy(); 34 | end. 35 | -------------------------------------------------------------------------------- /src/bcwriter/createabbrev/func.abr: -------------------------------------------------------------------------------- 1 | [mainfo.prefix] 2 | value=mabfunc 3 | [mainfo.abbrevidstart] 4 | value=4 5 | [mainfo.grid] 6 | propcolwidthref=143 7 | values0=6 8 | inst0 9 | inst1 10 | 11 | inst2 12 | 13 | 14 | sortdescend0=0 15 | values1=6 16 | 1 17 | 1 18 | 2 19 | 1 20 | 2 21 | 2 22 | values1_ci=-1 23 | sortdescend1=0 24 | values2=6 25 | 6 26 | 6 27 | 6 28 | 6 29 | 6 30 | 6 31 | values2_ci=-1 32 | sortdescend2=0 33 | values3=6 34 | instruction code 35 | instruction code 36 | par1 37 | instruction code 38 | par1 39 | par2 40 | sortdescend3=0 41 | [mainfo.idsize] 42 | value=3 43 | -------------------------------------------------------------------------------- /src/compiler/__mla__system.mla: -------------------------------------------------------------------------------- 1 | //__mla__system 2 | { MSElang Copyright (c) 2014-2016 by Martin Schreiber 3 | 4 | See the file COPYING.MSE, included in this distribution, 5 | for details about the copyright. 6 | 7 | This program is distributed in the hope that it will be useful, 8 | but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | } 11 | unit __mla__system; 12 | //{$internaldebug on} 13 | interface 14 | type 15 | filenamety = string16; 16 | var 17 | exitcode: int32; 18 | 19 | implementation 20 | 21 | end. 22 | -------------------------------------------------------------------------------- /src/test/base/with/withderef.mla: -------------------------------------------------------------------------------- 1 | program withderef; 2 | 3 | procedure format(const fmt: string8; const args: array of const): string8; 4 | type 5 | pchar8 = ^char8; 6 | convertinfoty = record 7 | ps,pe,pd: pchar8; 8 | value: int32; 9 | end; 10 | var 11 | info: convertinfoty; 12 | begin 13 | setlength(result,3); 14 | info.pd:= pointer(result); 15 | with info do 16 | pd^:= 'A'; 17 | pd[1]:= 'B'; 18 | pd[2]:= 'C'; 19 | end; 20 | end; 21 | 22 | var 23 | s1: string8; 24 | var 25 | i1: int32; 26 | begin 27 | s1:= format('abc',[]); 28 | if s1 = 'ABC' then 29 | exitcode:= 123; 30 | end; 31 | end. -------------------------------------------------------------------------------- /src/test/base/address/arrayitemaddress.mla: -------------------------------------------------------------------------------- 1 | program arrayitemaddress; 2 | 3 | type 4 | pointerarty = array of pointer; 5 | recarty = array of record a,b: int32 end; 6 | var 7 | ar1: pointerarty; 8 | p0,p1,p2: pointer; 9 | ar2: recarty; 10 | begin 11 | setlength(ar1,3); 12 | p0:= pointer(ar1); 13 | p1:= @ar1[0]; 14 | p2:= @ar1[1]; 15 | if (p2-p1 = sizeof(ar1[0])) and (sizeof(ar1[0]) = sizeof(pointer)) then 16 | setlength(ar2,3); 17 | p0:= pointer(ar2); 18 | p1:= @ar2[0]; 19 | p2:= @ar2[1]; 20 | if (p2-p1 = sizeof(ar2[0])) and (sizeof(ar2[0]) = 2 * 4) then 21 | exitcode:= 123; 22 | end; 23 | end; 24 | end. -------------------------------------------------------------------------------- /src/test/base/conversions/stringconv.mla: -------------------------------------------------------------------------------- 1 | program stringconv; 2 | 3 | var 4 | s8a,s8b: string8; 5 | s16,s16b: string16; 6 | s32,s32b: string32; 7 | 8 | begin 9 | s8a:= 'abcöä'#$1234#$12345#102345; 10 | s16:= s8a; 11 | s32:= s16; 12 | s16:= s32; 13 | s8b:= s16; 14 | if s8b = s8a then 15 | s16:= s32; 16 | s8b:= s16; 17 | if s8b = s8a then 18 | s8b:= s32; 19 | if s8b = s8a then 20 | s32:= s8a; 21 | s8b:= s32; 22 | s16b:= s8a; 23 | s32b:= s8a; 24 | if (s8b = s8a) and (s16b = s16) and (s32b = s32) then 25 | exitcode:= 123; 26 | end; 27 | end; 28 | end; 29 | end; 30 | end. 31 | -------------------------------------------------------------------------------- /src/bcwriter/createabbrev/const.abr: -------------------------------------------------------------------------------- 1 | [mainfo.prefix] 2 | value=mabconst 3 | [mainfo.abbrevidstart] 4 | value=4 5 | [mainfo.grid] 6 | propcolwidthref=208 7 | values0=8 8 | int 9 | 10 | bigint 11 | 12 | 13 | data 14 | 15 | 16 | sortdescend0=0 17 | values1=8 18 | 2 19 | 2 20 | 2 21 | 3 22 | 2 23 | 2 24 | 3 25 | 2 26 | values1_ci=-1 27 | sortdescend1=0 28 | values2=8 29 | 6 30 | 6 31 | 6 32 | 0 33 | 9 34 | 6 35 | 0 36 | 8 37 | values2_ci=-1 38 | sortdescend2=0 39 | values3=8 40 | id 41 | value 42 | id 43 | array 44 | value 45 | id 46 | array 47 | data 48 | sortdescend3=0 49 | [mainfo.idsize] 50 | value=3 51 | -------------------------------------------------------------------------------- /src/test/class/objectclass1.mla: -------------------------------------------------------------------------------- 1 | program objectclass1; 2 | type 3 | classobjectty = object 4 | f1: int32; 5 | constructor create(); 6 | destructor destroy(); 7 | end; 8 | 9 | tobjectclass = class(classobjectty) 10 | end; 11 | 12 | constructor classobjectty.create(); 13 | begin 14 | end; 15 | 16 | destructor classobjectty.destroy(); 17 | begin 18 | end; 19 | 20 | var 21 | obj: ^classobjectty; 22 | cla: tobjectclass; 23 | begin 24 | obj:= classobjectty.create(); 25 | obj^.f1:= 100; 26 | 27 | cla:= tobjectclass.create(); 28 | cla.f1:= 23; 29 | exitcode:= obj^.f1+cla.f1; 30 | cla.destroy(); 31 | obj.destroy(); 32 | 33 | end. -------------------------------------------------------------------------------- /src/test/object/object6.mla: -------------------------------------------------------------------------------- 1 | program object6; 2 | 3 | type 4 | objty = object [zeroinit] 5 | f1: int32; 6 | f2: int32; 7 | s1: string8; 8 | constructor create(a: int32); 9 | destructor destroy(); 10 | end; 11 | 12 | recty = record 13 | f1: int32; 14 | s1: string8; 15 | end; 16 | 17 | constructor objty.create(a: int32); 18 | begin 19 | f1:= a; 20 | end; 21 | 22 | destructor objty.destroy(); 23 | begin 24 | exitcode:= f1+f2; 25 | writeln(s1); 26 | end; 27 | 28 | var 29 | s1: string8; 30 | var 31 | obja: objty; 32 | begin 33 | s1:= 'abc'+s1; 34 | obja.s1:= s1; 35 | obja.create(123); 36 | obja.destroy(); 37 | end. 38 | -------------------------------------------------------------------------------- /src/test/base/sub/managed/subres1.mla: -------------------------------------------------------------------------------- 1 | program subres1; 2 | type 3 | recty = record 4 | s: string8; 5 | a,b,c: int32; 6 | end; 7 | 8 | procedure test(): recty; 9 | begin 10 | 11 | result.a:= 100; 12 | result.b:= 20; 13 | result.c:= 3; 14 | 15 | setlength(result.s,3); 16 | 17 | result.s[1]:= 'a'; 18 | result.s[2]:= 'b'; 19 | result.s[3]:= 'c'; 20 | 21 | end; 22 | 23 | var 24 | r1: recty; 25 | 26 | procedure test1(f: flo64); 27 | var 28 | i1: int32; 29 | begin 30 | r1:= test(); 31 | end; 32 | 33 | 34 | begin 35 | test1(1.2); 36 | exitcode:= r1.a+r1.b+r1.c; 37 | if r1.s <> 'abc' then 38 | exitcode:= 1; 39 | end; 40 | end. -------------------------------------------------------------------------------- /src/test/class/methods/method3.mla: -------------------------------------------------------------------------------- 1 | program method3; 2 | type 3 | 4 | meth1ty = method (a,b: int32); 5 | 6 | tcla = class 7 | private 8 | f: int32; 9 | public 10 | constructor create(); 11 | destructor destroy(); 12 | method test(a,b: int32); 13 | end; 14 | 15 | constructor tcla.create(); 16 | begin 17 | f:= 3; 18 | end; 19 | 20 | destructor tcla.destroy(); 21 | begin 22 | end; 23 | 24 | method tcla.test(a,b: int32); 25 | begin 26 | exitcode:= a+b+f; 27 | end; 28 | 29 | var 30 | meth1: meth1ty; 31 | c1: tcla; 32 | begin 33 | c1:= tcla.create(); 34 | meth1:= @c1.test; 35 | meth1(100,20); 36 | c1.destroy(); 37 | end. 38 | -------------------------------------------------------------------------------- /src/test/base/arith/set/largeset1.mla: -------------------------------------------------------------------------------- 1 | program largeset1; 2 | uses 3 | {$internaldebug on} 4 | type 5 | setty = set of 0..32; 6 | ar5ty = array[0..4] of card8; 7 | 8 | var 9 | set1: setty; 10 | ar1: ar5ty; 11 | begin 12 | include(set1,32); 13 | include(set1,1); 14 | include(set1,0); 15 | include(set1,8); 16 | include(set1,9); 17 | exclude(set1,8); 18 | exclude(set1,0); 19 | ar1:= ar5ty(set1); 20 | // writeln(sizeof(set1),': ',ar1[0],' ',ar1[1],' ',ar1[2],' ',ar1[3],' ',ar1[4]); 21 | if (sizeof(set1) = 5) and (ar1[0] = 2) and (ar1[1] = 2) and (ar1[2] = 0) and 22 | (ar1[3] = 0) and (ar1[4] = 1) then 23 | exitcode:= 123; 24 | end; 25 | end. -------------------------------------------------------------------------------- /src/test/base/sub/nested/nestedaccess.mla: -------------------------------------------------------------------------------- 1 | program nestedaccess; 2 | 3 | procedure format(a: int32): string8; 4 | 5 | procedure formaterror(); 6 | begin 7 | end; //formaterror() 8 | 9 | procedure getnum(): bool1; 10 | begin 11 | formaterror(); 12 | end; //getnum() 13 | 14 | begin 15 | getnum(); 16 | end; 17 | 18 | procedure format2(a: int32): string8; 19 | 20 | procedure formaterror(); 21 | begin 22 | exitcode:= a; 23 | end; //formaterror() 24 | 25 | procedure getnum(): bool1; 26 | begin 27 | formaterror(); 28 | end; //getnum() 29 | 30 | begin 31 | getnum(); 32 | end; 33 | 34 | begin 35 | format(111); 36 | format2(123); 37 | end. -------------------------------------------------------------------------------- /src/try.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | type 3 | tt = class 4 | public 5 | constructor create(); 6 | end; 7 | 8 | implementation 9 | 10 | constructor tt.create(); 11 | begin 12 | end; 13 | 14 | procedure p(); 15 | begin 16 | writeln(111); 17 | try 18 | writeln(112); 19 | raise tt.create(); 20 | writeln(113); 21 | finally 22 | writeln(114); 23 | end; 24 | end; 25 | 26 | begin 27 | try 28 | try 29 | // raise tt.create(); 30 | p(); 31 | writeln(100); 32 | finally 33 | raise tt.create(); 34 | writeln(101); 35 | end; 36 | writeln(102); 37 | except 38 | // finally 39 | writeln(200); 40 | end; 41 | writeln(300); 42 | end. 43 | -------------------------------------------------------------------------------- /src/bcwriter/createabbrev/symtab.abr: -------------------------------------------------------------------------------- 1 | [mainfo.prefix] 2 | value=mabsym 3 | [mainfo.abbrevidstart] 4 | value=4 5 | [mainfo.grid] 6 | propcolwidthref=143 7 | values0=8 8 | entry 9 | 10 | 11 | 12 | bbentry 13 | 14 | 15 | 16 | sortdescend0=0 17 | values1=8 18 | 0 19 | 2 20 | 3 21 | 4 22 | 0 23 | 2 24 | 3 25 | 4 26 | values1_ci=-1 27 | sortdescend1=0 28 | values2=8 29 | 1 30 | 6 31 | 0 32 | 0 33 | 2 34 | 6 35 | 0 36 | 0 37 | values2_ci=-1 38 | sortdescend2=0 39 | values3=8 40 | VST_CODE_ENTRY 41 | valid 42 | namechar 43 | 44 | VST_CODE_BBENTRY 45 | valid 46 | namechar 47 | 48 | sortdescend3=0 49 | [mainfo.idsize] 50 | value=3 51 | -------------------------------------------------------------------------------- /src/test/class/constructor4.mla: -------------------------------------------------------------------------------- 1 | program constructor4; 2 | type 3 | ttest = class 4 | constructor create(const p1: string8); 5 | constructor create1(const p1: string8; const p2: array of const); 6 | destructor destroy(); 7 | private 8 | f1: int32; 9 | end; 10 | 11 | constructor ttest.create(const p1: string8); 12 | begin 13 | create1(p1,[]); 14 | end; 15 | 16 | constructor ttest.create1(const p1: string8; const p2: array of const); 17 | begin 18 | f1:= 123; 19 | end; 20 | 21 | destructor ttest.destroy(); 22 | begin 23 | exitcode:= f1; 24 | end; 25 | 26 | var 27 | t1: ttest; 28 | begin 29 | t1:= ttest.create('abc'); 30 | t1.destroy(); 31 | end. -------------------------------------------------------------------------------- /src/test/object/operators/operator1.mla: -------------------------------------------------------------------------------- 1 | program operator1; 2 | 3 | type 4 | objty = object [nozeroinit,virtual] 5 | fa,fb: int32; 6 | method add(b: objty) [operator='+',virtual]; 7 | end; 8 | 9 | obj1ty = object(objty) 10 | method add(b: objty) [override]; 11 | end; 12 | 13 | method objty.add(b: objty); 14 | begin 15 | fa:= fa+b.fa; 16 | fb:= fb+b.fb; 17 | end; 18 | 19 | method obj1ty.add(b: objty); 20 | begin 21 | inherited add(b); 22 | fa:= fa * 10; 23 | end; 24 | 25 | var 26 | a: obj1ty; 27 | b,c: objty; 28 | begin 29 | a.fa:= 9; 30 | a.fb:= 100; 31 | b.fa:= 3; 32 | b.fb:= 11; 33 | c:= a+b; 34 | exitcode:= c.fa div 10 + c.fb; 35 | end. -------------------------------------------------------------------------------- /src/test/object/operators/operator4.mla: -------------------------------------------------------------------------------- 1 | program operator4; 2 | 3 | type 4 | recty = record 5 | a,b,c: int32; 6 | end; 7 | 8 | objty = object [nozeroinit] 9 | fa,fb: int32; 10 | method add(const a: int32) [operator='+',operatorright='+']; 11 | method add1(const a: recty) [operator='+',operatorright='+']; 12 | end; 13 | 14 | method objty.add(const a: int32); 15 | begin 16 | fb:= fb+a; 17 | end; 18 | 19 | method objty.add1(const a: recty); 20 | begin 21 | fb:= fb+a.b; 22 | end; 23 | 24 | var 25 | a,c: objty; 26 | r: recty; 27 | i1: int32; 28 | begin 29 | a.fb:= 22; 30 | r.b:= 100; 31 | i1:= 1; 32 | c:= r+(a+i1); 33 | exitcode:= c.fb; 34 | end. -------------------------------------------------------------------------------- /src/tools/linux_extra/mselang.desktop: -------------------------------------------------------------------------------- 1 | [Desktop Entry] 2 | Name=MSElang 3 | GenericName=Pascal compiler of LLVM 4 | Comment=GUI for Pascal compiler of LLVM 5 | Type=Application 6 | Exec=mselang 7 | Icon=mselang 8 | Terminal=false 9 | Categories=IDE;Development; 10 | Keywords=fpc;compiler;mse;pascal;llvm; 11 | 12 | 13 | # Translations 14 | Comment[ru]=ГУИ для компилятора Pascal через LLVM 15 | GenericName[ru]=Компилятор Pascal через LLVM 16 | Comment[uk]=Графічний інтерфейс компілятора Pascal LLVM 17 | GenericName[uk]=Компілятор Pascal LLVM 18 | Comment[fr]=Interface graphique pour le compilateur Pascal de LLVM 19 | GenericName[fr]=Compilateur Pascal de LLVM 20 | -------------------------------------------------------------------------------- /src/test/class/classminimal.mla: -------------------------------------------------------------------------------- 1 | program classminimal; 2 | 3 | type 4 | recty = record 5 | a: int32; 6 | b: int32; 7 | end; 8 | 9 | ttest = class 10 | public 11 | ff: recty; 12 | constructor create(); 13 | destructor destroy(); 14 | method test(); 15 | 16 | end; 17 | 18 | var 19 | i1: int32; 20 | c1: ttest; 21 | 22 | constructor ttest.create(); 23 | begin 24 | ff.a:= 1; 25 | ff.b:= 121; 26 | end; 27 | 28 | destructor ttest.destroy(); 29 | begin 30 | exitcode:= ff.a+ff.b; 31 | end; 32 | 33 | method ttest.test(); 34 | begin 35 | ff.b:= ff.a+ff.b; 36 | end; 37 | 38 | begin 39 | c1:= ttest.create(); 40 | c1.test(); 41 | c1.destroy(); 42 | end. -------------------------------------------------------------------------------- /src/test/object/object5.mla: -------------------------------------------------------------------------------- 1 | program object5; 2 | //{$internaldebug on} 3 | type 4 | objty = object [zeroinit] 5 | f1: int32; 6 | f2: int32; 7 | s1: string8; 8 | constructor create(a: int32); 9 | destructor destroy(); 10 | end; 11 | 12 | recty = record 13 | f1: int32; 14 | s1: string8; 15 | end; 16 | 17 | constructor objty.create(a: int32); 18 | begin 19 | f1:= a; 20 | end; 21 | 22 | destructor objty.destroy(); 23 | begin 24 | exitcode:= f1+f2; 25 | writeln(s1); 26 | end; 27 | 28 | var 29 | s1: string8; 30 | 31 | var 32 | obja: ^objty; 33 | begin 34 | s1:= 'abc'+s1; 35 | obja:= objty.create(123); 36 | obja^.s1:= s1; 37 | obja.destroy; 38 | end. 39 | -------------------------------------------------------------------------------- /src/test/base/sub/managed/subvarres1.mla: -------------------------------------------------------------------------------- 1 | program subvarres1; 2 | type 3 | recty = record 4 | s: string8; 5 | a,b,c: int32; 6 | end; 7 | 8 | procedure test(): recty; 9 | begin 10 | 11 | result.a:= 100; 12 | result.b:= 20; 13 | result.c:= 3; 14 | 15 | setlength(result.s,3); 16 | 17 | result.s[1]:= 'a'; 18 | result.s[2]:= 'b'; 19 | result.s[3]:= 'c'; 20 | 21 | end; 22 | 23 | var 24 | r1: recty; 25 | 26 | procedure test1(f: flo64); 27 | var 28 | i1: int32; 29 | r2: recty; 30 | begin 31 | r2:= test(); 32 | r1:= r2; 33 | end; 34 | 35 | 36 | begin 37 | test1(1.2); 38 | exitcode:= r1.a+r1.b+r1.c; 39 | if r1.s <> 'abc' then 40 | exitcode:= 1; 41 | end; 42 | end. -------------------------------------------------------------------------------- /src/test/base/string/stringconsttochar.mla: -------------------------------------------------------------------------------- 1 | program stringconsttochar; 2 | //uses 3 | // rtl_format; 4 | type 5 | floatstringmodety = (fsm_default,fsm_fix,fsm_sci,fsm_engfix,fsm_engflo, 6 | fsm_engsymfix,fsm_engsymflo); 7 | 8 | procedure flo64tostring16(const value: flo64; const precision: integer = 0; 9 | const mode: floatstringmodety = fsm_default; 10 | const decimalsep: char16 = '.'; 11 | const thousandsep: char16 = #0): string16; 12 | begin 13 | if decimalsep = 'ä' then 14 | exitcode:= 123; 15 | end; 16 | end; 17 | 18 | const 19 | decimalsep = 'ä'; 20 | var 21 | f1: flo64; 22 | begin 23 | flo64tostring16(f1,0,fsm_sci,decimalsep); 24 | end. -------------------------------------------------------------------------------- /src/test/object/object4.mla: -------------------------------------------------------------------------------- 1 | program object4; 2 | 3 | type 4 | objty = object 5 | f1: int32; 6 | constructor create(a: int32); 7 | destructor destroy(); 8 | method test(const a: int32); 9 | end; 10 | 11 | constructor objty.create(a: int32); 12 | begin 13 | f1:= a; 14 | end; 15 | 16 | destructor objty.destroy(); 17 | begin 18 | write('abc'); 19 | end; 20 | 21 | method objty.test(const a: int32); 22 | begin 23 | f1:= f1 * a; 24 | end; 25 | 26 | var 27 | obj1: ^objty; 28 | obja: objty; 29 | begin 30 | obja.destroy(); 31 | obj1:= objty.create(113); 32 | obja.create(10); 33 | obj1^.test(10); 34 | exitcode:= obj1^.f1 div 10 + obja.f1; 35 | obj1.destroy(); 36 | end. 37 | -------------------------------------------------------------------------------- /src/test/class/methods/method4.mla: -------------------------------------------------------------------------------- 1 | program method4; 2 | type 3 | 4 | meth1ty = method (a,b: int32): int32; 5 | 6 | tcla = class[virtual] 7 | private 8 | f: int32; 9 | public 10 | constructor create(); 11 | destructor destroy(); 12 | method test(a,b: int32): int32 [virtual]; 13 | end; 14 | 15 | constructor tcla.create(); 16 | begin 17 | f:= 3; 18 | end; 19 | 20 | destructor tcla.destroy(); 21 | begin 22 | end; 23 | 24 | method tcla.test(a,b: int32): int32; 25 | begin 26 | result:= a+b+f; 27 | end; 28 | 29 | var 30 | meth1: meth1ty; 31 | c1: tcla; 32 | begin 33 | c1:= tcla.create(); 34 | meth1:= @c1.test; 35 | exitcode:= meth1(100,20); 36 | c1.destroy(); 37 | end. 38 | -------------------------------------------------------------------------------- /src/classinh.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | uses 3 | classinh1; 4 | 5 | type 6 | tc2 = class(tc1) 7 | public 8 | f1: int32; 9 | procedure test(); 10 | procedure test(p1: int32); 11 | constructor create(f3: int32); 12 | destructor destroy(); 13 | end; 14 | implementation 15 | 16 | constructor tc2.create(f3: int32); 17 | var 18 | f2: int32; 19 | begin 20 | end; 21 | 22 | destructor tc2.destroy(); 23 | begin 24 | {$dumpelements} 25 | writeln(f0); 26 | writeln(f1); 27 | end; 28 | 29 | procedure tc2.test(); 30 | begin 31 | end; 32 | 33 | procedure tc2.test(p1: int32); 34 | begin 35 | end; 36 | 37 | var 38 | v1: tc2; 39 | begin 40 | v1:= tc2.create(222); 41 | v1.test(); 42 | v1.destroy(); 43 | end. -------------------------------------------------------------------------------- /src/test/class/properties/procwrite.mla: -------------------------------------------------------------------------------- 1 | program procwrite; 2 | 3 | type 4 | ttest = class 5 | private 6 | ffield: int32; 7 | method setfield(avalue: int32); 8 | public 9 | constructor create(); 10 | destructor destroy(); 11 | property field: int32 read ffield write setfield; 12 | end; 13 | 14 | { ttest } 15 | 16 | constructor ttest.create(); 17 | begin 18 | ffield:= 11; 19 | end; 20 | 21 | destructor ttest.destroy(); 22 | begin 23 | exitcode:= ffield; 24 | end; 25 | 26 | method ttest.setfield(avalue: int32); 27 | begin 28 | ffield:= avalue+field; 29 | end; 30 | 31 | var 32 | t1: ttest; 33 | 34 | begin 35 | t1:= ttest.create(); 36 | t1.field:= 112; 37 | t1.destroy(); 38 | end. 39 | -------------------------------------------------------------------------------- /src/test/object/object7.mla: -------------------------------------------------------------------------------- 1 | program object7; 2 | 3 | type 4 | objty = object [zeroinit] 5 | f1: int32; 6 | f2: int32; 7 | s1: string8; 8 | constructor create(a: int32); 9 | destructor destroy(); 10 | end; 11 | 12 | recty = record 13 | f1: int32; 14 | s1: string8; 15 | end; 16 | 17 | constructor objty.create(a: int32); 18 | begin 19 | f1:= a; 20 | end; 21 | 22 | destructor objty.destroy(); 23 | begin 24 | exitcode:= f1+f2; 25 | writeln(s1); 26 | end; 27 | 28 | var 29 | s1: string8; 30 | 31 | procedure test(); 32 | var 33 | obj1: objty; 34 | begin 35 | obj1.create(123); 36 | obj1.s1:= s1; 37 | obj1.destroy(); 38 | end; 39 | 40 | begin 41 | s1:= 'abc'+s1; 42 | test(); 43 | end. 44 | -------------------------------------------------------------------------------- /src/test/base/control/forto3.mla: -------------------------------------------------------------------------------- 1 | program forto3; 2 | 3 | var 4 | start: card16; 5 | i1: int32; 6 | i2: int16; 7 | i3: int8; 8 | c1: card32; 9 | c2: card16; 10 | c3: card8; 11 | begin 12 | start:= 3; 13 | for i1:= start downto 1 do 14 | exitcode:= exitcode + i1; 15 | end; 16 | for i2:= start downto 1 do 17 | exitcode:= exitcode + i2; 18 | end; 19 | for i3:= start downto 1 do 20 | exitcode:= exitcode + i3; 21 | end; 22 | for c1:= start downto 1 do 23 | exitcode:= exitcode + c1; 24 | end; 25 | for c2:= start downto 1 do 26 | exitcode:= exitcode + c2; 27 | end; 28 | for c3:= start downto 1 do 29 | exitcode:= exitcode + c3; 30 | end; 31 | exitcode:= exitcode - 6*(3+2+1)+ 123; 32 | end. 33 | -------------------------------------------------------------------------------- /src/test/class/sizeof/sizeofclass1.mla: -------------------------------------------------------------------------------- 1 | program sizofclass1; 2 | type 3 | ctest = class[virtual] 4 | f1,f2: int32; 5 | constructor create(); 6 | destructor destroy(); 7 | method test(); 8 | end; 9 | ctest1 = class(ctest) 10 | f3: int32; 11 | end; 12 | 13 | constructor ctest.create(); 14 | begin 15 | end; 16 | 17 | destructor ctest.destroy(); 18 | begin 19 | end; 20 | 21 | method ctest.test(); 22 | begin 23 | exitcode:= exitcode+sizeof(self^); 24 | end; 25 | 26 | var 27 | c1,c2: ctest; 28 | begin 29 | c1:= ctest.create(); 30 | c2:= ctest1.create(); 31 | c1.test(); 32 | c2.test(); 33 | c1.destroy(); 34 | c2.destroy(); 35 | exitcode:= exitcode+(123-sizeof(ctest^)-sizeof(ctest1^)); 36 | end. 37 | -------------------------------------------------------------------------------- /src/test/intrinsics/managed/initclass.mla: -------------------------------------------------------------------------------- 1 | program initclass; 2 | uses 3 | rtl_fpccompatibility; 4 | type 5 | ttest = class() 6 | fa,fb: int32; 7 | constructor create(); 8 | destructor destroy(); 9 | end; 10 | 11 | constructor ttest.create(); 12 | begin 13 | end; 14 | 15 | destructor ttest.destroy(); 16 | begin 17 | end; 18 | 19 | var 20 | c1: ttest; 21 | begin 22 | 23 | c1:= pointer(123); 24 | initialize(c1); 25 | if c1 = nil then 26 | c1:= ttest.create(); 27 | with c1 do 28 | fa:= 11; 29 | fb:= 22; 30 | if fa+fb = 33 then 31 | initialize(c1^); 32 | if (fa = 0) and (fb = 0) then 33 | exitcode:= 123; 34 | end; 35 | end; 36 | destroy(); 37 | end; 38 | end; 39 | end. -------------------------------------------------------------------------------- /src/test/class/properties/funcread.mla: -------------------------------------------------------------------------------- 1 | program funcread; 2 | 3 | type 4 | ttest = class 5 | private 6 | ffield: int32; 7 | method getfield: int32; 8 | public 9 | constructor create(); 10 | destructor destroy(); 11 | property field: int32 read getfield write ffield; 12 | end; 13 | 14 | { ttest } 15 | 16 | constructor ttest.create(); 17 | begin 18 | ffield:= 122; 19 | end; 20 | 21 | destructor ttest.destroy(); 22 | begin 23 | exitcode:= exitcode + ffield - 122; 24 | end; 25 | 26 | 27 | method ttest.getfield(): int32; 28 | begin 29 | result:= ffield+1; 30 | end; 31 | 32 | var 33 | t1: ttest; 34 | 35 | begin 36 | t1:= ttest.create(); 37 | exitcode:= t1.field; 38 | t1.destroy(); 39 | end. 40 | -------------------------------------------------------------------------------- /src/test/class/constructor2.mla: -------------------------------------------------------------------------------- 1 | program constructor2; 2 | 3 | type 4 | ttest = class 5 | private 6 | ffield: int32; 7 | public 8 | constructor create(p: int32); 9 | constructor create1(const p: int32); 10 | destructor destroy(p: int32); 11 | end; 12 | 13 | { ttest } 14 | 15 | constructor ttest.create(p: int32); 16 | begin 17 | ffield:= p; 18 | end; 19 | 20 | constructor ttest.create1(p: int32); 21 | begin 22 | ffield:= ffield + 20; 23 | end; 24 | 25 | destructor ttest.destroy(p: int32); 26 | begin 27 | exitcode:= 123+ffield-2*p; 28 | end; 29 | 30 | var 31 | t1: ttest; 32 | 33 | begin 34 | t1:= ttest.create(10); 35 | t1.create1(20); 36 | t1.destroy(5); 37 | exitcode:= exitcode-20; 38 | end. 39 | -------------------------------------------------------------------------------- /src/test/class/properties/classprop3.mla: -------------------------------------------------------------------------------- 1 | program classprop3; 2 | 3 | type 4 | 5 | recty = record 6 | a,b: int32; 7 | end; 8 | tcla1 = class 9 | private 10 | fb: int32; 11 | fa: recty; 12 | public 13 | end; 14 | 15 | tcla = class(tcla1) 16 | private 17 | public 18 | constructor create(); 19 | destructor destroy(); 20 | property a: int32 read fa.b write fa.b [default=1+3]; 21 | property b: int32 read fb write fb; 22 | end; 23 | 24 | constructor tcla.create(); 25 | begin 26 | b:= 100; 27 | a:= 23; 28 | end; 29 | 30 | destructor tcla.destroy(); 31 | begin 32 | exitcode:= b+a; 33 | end; 34 | 35 | var 36 | cla: tcla; 37 | begin 38 | cla:= tcla.create(); 39 | cla.destroy(); 40 | end. 41 | -------------------------------------------------------------------------------- /src/test/base/conversions/leftsidecast1.mla: -------------------------------------------------------------------------------- 1 | program leftsidecast1; 2 | type 3 | pint32 = ^int32; 4 | pcard32 = ^card32; 5 | ppointer = ^pointer; 6 | pcard8 = ^card8; 7 | recty = record 8 | a,b: flo64; 9 | end; 10 | precty = ^recty; 11 | var 12 | i1: int32; 13 | ca1: card16; 14 | po1: precty; 15 | po2: pint32; 16 | po3: ppointer; 17 | begin 18 | po1:= @i1; 19 | pint32(pcard32(po1))^:= 15; 20 | exitcode:= i1; 21 | card32(i1):= 90; 22 | exitcode:= exitcode + i1; 23 | po1:= @po2; 24 | ppointer(po1)^:= pointer(3); 25 | exitcode:= exitcode + int32(po2); 26 | po1:= @i1; 27 | i1:= 10; 28 | exitcode:= exitcode + pcard8(po1)^; 29 | po1:= @ca1; 30 | (pcard8(po1)+1)^:= 5; 31 | exitcode:= exitcode+ ca1 div 256; 32 | end. -------------------------------------------------------------------------------- /src/test/class/field1.mla: -------------------------------------------------------------------------------- 1 | program field1; 2 | 3 | type 4 | 5 | Ctest1 = class 6 | constructor create(); 7 | destructor destroy(); 8 | f1,f2: int32; 9 | end; 10 | 11 | Ctest = class 12 | constructor create(); 13 | destructor destroy(); 14 | f1,f2: int32; 15 | f3: Ctest1; 16 | end; 17 | 18 | constructor ctest1.create(); 19 | begin 20 | f2:= 123; 21 | end; 22 | 23 | destructor ctest1.destroy(); 24 | begin 25 | end; 26 | 27 | constructor Ctest.create(); 28 | begin 29 | f3:= Ctest1.create(); 30 | end; 31 | 32 | destructor Ctest.destroy(); 33 | begin 34 | f3.destroy(); 35 | end; 36 | 37 | var 38 | c1: Ctest; 39 | 40 | begin 41 | c1:= Ctest.create(); 42 | exitcode:= c1.f3.f2; 43 | c1.destroy(); 44 | end. -------------------------------------------------------------------------------- /src/test/class/properties/samename.mla: -------------------------------------------------------------------------------- 1 | program samename; 2 | type 3 | ttest = class() 4 | constructor create(); 5 | destructor destroy(); 6 | property t: int32 read ft write ft; 7 | property t0: int32 read ft write ft; 8 | private 9 | ft: int32; 10 | end; 11 | 12 | ttest1 = class(ttest) 13 | property t1: int32 read ft1 write ft1; 14 | property t: int32 read ft1 write ft1; 15 | private 16 | ft1: int32; 17 | end; 18 | 19 | constructor ttest.create(); 20 | begin 21 | end; 22 | 23 | destructor ttest.destroy(); 24 | begin 25 | end; 26 | 27 | var 28 | t1: ttest1; 29 | begin 30 | t1:= ttest1.create(); 31 | t1.t:= 100; 32 | ttest(t1).t:= 23; 33 | exitcode:= t1.t0+t1.t1; 34 | t1.destroy(); 35 | end. 36 | -------------------------------------------------------------------------------- /src/test/intrinsics/managed/initclass2.mla: -------------------------------------------------------------------------------- 1 | program initclass2; 2 | type 3 | ttest = class()[virtual] 4 | f1,f2: int32; 5 | destructor destroy(); 6 | method ini1() [ini,virtual]; 7 | end; 8 | 9 | ttest1 = class(ttest) [virtual] 10 | f3: int32; 11 | method ini1() [override]; 12 | end; 13 | 14 | var 15 | i1: int32; 16 | 17 | method ttest.ini1(); 18 | begin 19 | i1:= sizeof(self^); 20 | end; 21 | 22 | method ttest1.ini1(); 23 | begin 24 | inherited ini1(); 25 | f3:= 123 - (4+8+4) + i1; 26 | end; 27 | 28 | destructor ttest.destroy(); 29 | begin 30 | end; 31 | 32 | var 33 | c2: ttest; 34 | begin 35 | c2:= getmem(sizeof(ttest1^)); 36 | initialize(c2,ttest1); 37 | exitcode:= ttest1(c2).f3; 38 | c2.destroy(); 39 | end. -------------------------------------------------------------------------------- /src/test/class/destructor1.mla: -------------------------------------------------------------------------------- 1 | program destructor1; 2 | 3 | type 4 | ttest = class[virtual] 5 | private 6 | ffield: int32; 7 | public 8 | constructor create(); 9 | destructor destroy()[virtual]; 10 | end; 11 | 12 | ttest1 = class(ttest) 13 | public 14 | destructor destroy()[override]; 15 | end; 16 | 17 | { ttest } 18 | 19 | constructor ttest.create(); 20 | begin 21 | ffield:= 100; 22 | end; 23 | 24 | destructor ttest.destroy(); 25 | begin 26 | ffield:= 13; 27 | end; 28 | 29 | { ttest1 } 30 | 31 | destructor ttest1.destroy(); 32 | begin 33 | inherited destroy(); 34 | exitcode:= ffield + 110; 35 | end; 36 | 37 | var 38 | t1: ttest1; 39 | 40 | begin 41 | t1:= ttest1.create(); 42 | t1.destroy(); 43 | end. 44 | -------------------------------------------------------------------------------- /src/test/intrinsics/typeinfo/typeofclass2.mla: -------------------------------------------------------------------------------- 1 | program typeofclass2; 2 | uses 3 | __mla__internaltypes; 4 | type 5 | ttest = class[rtti] 6 | end; 7 | ttest1 = class(ttest)[nortti] 8 | end; 9 | ttest2 = class(ttest1)[rtti] 10 | end; 11 | var 12 | p1,p3: prttity; 13 | p2: pclassdefty; 14 | c1: class of ttest; 15 | i1: int32; 16 | h1: classdefheaderty; 17 | begin 18 | p1:= typeinfo(ttest); 19 | c1:= classof(ttest); 20 | p2:= pclassdefty(c1); 21 | p3:= p2^.header.rtti; 22 | if (string8(p1^.typename) = 'ttest') and (p1 = p3) and 23 | (pclassdefty(classof(ttest1))^.header.rtti = nil) and 24 | (string8(pclassdefty(classof(ttest2))^.header.rtti^.typename) = 'ttest2') then 25 | exitcode:= 123; 26 | end; 27 | end. -------------------------------------------------------------------------------- /src/test/base/sub/nested/nestedaccess1.mla: -------------------------------------------------------------------------------- 1 | program nestedaccess1; 2 | 3 | procedure format(a: int32); 4 | 5 | procedure formaterror(); 6 | begin 7 | // exitcode:= a; 8 | end; //formaterror() 9 | 10 | //{$internaldebug on} 11 | procedure getnum(v: int32); 12 | begin 13 | formaterror(); 14 | exitcode:= a; 15 | end; //getnum() 16 | begin 17 | getnum(1); 18 | end; 19 | 20 | procedure format1(a: int32); 21 | 22 | procedure formaterror(); 23 | begin 24 | exitcode:= a; 25 | end; //formaterror() 26 | 27 | //{$internaldebug on} 28 | procedure getnum(v: int32); 29 | begin 30 | formaterror(); 31 | exitcode:= a; 32 | end; //getnum() 33 | begin 34 | getnum(1); 35 | end; 36 | 37 | begin 38 | format(111); 39 | format1(123); 40 | end. -------------------------------------------------------------------------------- /src/test/class/callinherited.mla: -------------------------------------------------------------------------------- 1 | program callinherited; 2 | type 3 | tc1 = class[virtual] 4 | public 5 | constructor create(); 6 | destructor destroy(); 7 | method test()[virtual]; 8 | end; 9 | 10 | tc2 = class(tc1) 11 | public 12 | method test()[override]; 13 | end; 14 | 15 | constructor tc1.create(); 16 | begin 17 | end; 18 | 19 | destructor tc1.destroy(); 20 | begin 21 | end; 22 | 23 | method tc1.test(); 24 | begin 25 | exitcode:= 112; 26 | end; 27 | 28 | method tc2.test(); 29 | begin 30 | inherited test(); 31 | exitcode:= exitcode+11; 32 | end; 33 | 34 | type 35 | ppointer = ^pointer; 36 | var 37 | c1: tc2; 38 | po1: ppointer; 39 | 40 | begin 41 | c1:= tc2.create(); 42 | c1.test(); 43 | c1.destroy(); 44 | end. 45 | -------------------------------------------------------------------------------- /src/test/class/classvirtual.mla: -------------------------------------------------------------------------------- 1 | program classvirtual; 2 | type 3 | tc1 = class[virtual] 4 | public 5 | constructor create(); 6 | destructor destroy(); 7 | method test()[virtual]; 8 | end; 9 | 10 | tc2 = class(tc1) 11 | public 12 | method test()[override]; 13 | end; 14 | 15 | constructor tc1.create(); 16 | begin 17 | end; 18 | 19 | destructor tc1.destroy(); 20 | begin 21 | end; 22 | 23 | method tc1.test(); 24 | begin 25 | exitcode:= 112; 26 | end; 27 | 28 | method tc2.test(); 29 | begin 30 | inherited test(); 31 | exitcode:= exitcode+11; 32 | end; 33 | 34 | type 35 | ppointer = ^pointer; 36 | var 37 | c1: tc1; 38 | po1: ppointer; 39 | 40 | begin 41 | c1:= tc2.create(); 42 | c1.test(); 43 | c1.destroy(); 44 | end. 45 | -------------------------------------------------------------------------------- /src/test/class/constructor3.mla: -------------------------------------------------------------------------------- 1 | program constructor3; 2 | 3 | type 4 | ttest = class[virtual] 5 | private 6 | ffield: int32; 7 | public 8 | constructor create()[virtual]; 9 | destructor destroy(); 10 | end; 11 | 12 | ttest1 = class(ttest) 13 | public 14 | constructor create()[override]; 15 | end; 16 | 17 | { ttest } 18 | 19 | constructor ttest.create(); 20 | begin 21 | ffield:= 100; 22 | end; 23 | 24 | destructor ttest.destroy(); 25 | begin 26 | exitcode:= ffield+13; 27 | end; 28 | 29 | { ttest1 } 30 | 31 | constructor ttest1.create(); 32 | begin 33 | inherited create(); 34 | ffield:= ffield + 10; 35 | end; 36 | 37 | var 38 | t1: ttest1; 39 | 40 | begin 41 | t1:= ttest1.create(); 42 | t1.destroy(); 43 | end. 44 | -------------------------------------------------------------------------------- /src/test/class/methods/method2.mla: -------------------------------------------------------------------------------- 1 | program method2; 2 | uses 3 | __mla__internaltypes; 4 | type 5 | 6 | meth1ty = method (a,b: int32); 7 | 8 | tcla = class 9 | public 10 | constructor create(); 11 | destructor destroy(); 12 | method test(a,b: int32); 13 | end; 14 | 15 | constructor tcla.create(); 16 | begin 17 | end; 18 | 19 | destructor tcla.destroy(); 20 | begin 21 | end; 22 | 23 | method tcla.test(a,b: int32); 24 | begin 25 | exitcode:= a+b; 26 | end; 27 | 28 | var 29 | meth1: meth1ty; 30 | c1: tcla; 31 | begin 32 | c1:= tcla.create(); 33 | meth1:= @c1.test; 34 | meth1(60,40); 35 | with methodty(meth1) do 36 | if (data = c1) then 37 | exitcode:= exitcode + 23; 38 | end; 39 | end; 40 | c1.destroy(); 41 | end. 42 | -------------------------------------------------------------------------------- /src/test/class/properties/classprop2.mla: -------------------------------------------------------------------------------- 1 | program classprop2; 2 | 3 | type 4 | recty = record 5 | a,b: int32; 6 | end; 7 | tcla1 = class 8 | private 9 | fb: int32; 10 | fa: recty; 11 | public 12 | constructor create(); 13 | destructor destroy(); 14 | end; 15 | 16 | tcla = class(tcla1) 17 | private 18 | public 19 | //{$internaldebug on} 20 | property a: int32 read fa.b write fa.a [default=1+3]; 21 | property b: int32 read fb write fb; 22 | end; 23 | 24 | constructor tcla1.create(); 25 | begin 26 | fa.b:= 100; 27 | end; 28 | 29 | destructor tcla1.destroy(); 30 | begin 31 | end; 32 | 33 | var 34 | cla: tcla; 35 | begin 36 | cla:= tcla.create(); 37 | cla.a:= 23; 38 | exitcode:= cla.a + cla.fa.a; 39 | cla.destroy(); 40 | end. 41 | -------------------------------------------------------------------------------- /src/test/class/properties/funcread2.mla: -------------------------------------------------------------------------------- 1 | program funcread2; 2 | 3 | type 4 | ttest = class 5 | private 6 | ffield: int32; 7 | method getfield(): int32; 8 | public 9 | constructor create(); 10 | destructor destroy(); 11 | property field: int32 read getfield write ffield; 12 | method test(); 13 | end; 14 | 15 | { ttest } 16 | 17 | constructor ttest.create(); 18 | begin 19 | ffield:= 123; 20 | end; 21 | 22 | destructor ttest.destroy(); 23 | begin 24 | end; 25 | 26 | method ttest.getfield(): int32; 27 | begin 28 | result:= ffield; 29 | end; 30 | 31 | method ttest.test(); 32 | begin 33 | exitcode:= field; 34 | end; 35 | 36 | var 37 | t1: ttest; 38 | 39 | begin 40 | t1:= ttest.create(); 41 | t1.test(); 42 | t1.destroy(); 43 | end. 44 | -------------------------------------------------------------------------------- /src/test/class/classis.mla: -------------------------------------------------------------------------------- 1 | program classis; 2 | type 3 | 4 | ctest = class() [virtual] 5 | constructor create(); 6 | destructor destroy(); 7 | end; 8 | ctest1 = class(ctest) 9 | end; 10 | 11 | ctest2 = class() 12 | end; 13 | 14 | pctest = ^ctest; 15 | testobjty = ^object 16 | end; 17 | 18 | constructor ctest.create(); 19 | begin 20 | end; 21 | 22 | destructor ctest.destroy(); 23 | begin 24 | end; 25 | 26 | var 27 | c1: ctest; 28 | c2: ctest; 29 | begin 30 | c1:= ctest.create(); 31 | c2:= ctest1.create(); 32 | if (c2 is c1) and not (c1 is c2) and (c1 is ctest) and (c2 is ctest) and (c2 is ctest1) and 33 | not (c1 is ctest1) then 34 | exitcode:= 123; 35 | else 36 | exitcode:= 1; 37 | end; 38 | c1.destroy(); 39 | c2.destroy(); 40 | end. -------------------------------------------------------------------------------- /src/test/class/properties/arrayparamsetind1.mla: -------------------------------------------------------------------------------- 1 | program arrayparamsetind1; 2 | 3 | type 4 | ttest = class 5 | private 6 | ffield: int32; 7 | method setfield(i2: int32;i3:int32;avalue: int32); 8 | public 9 | constructor create(); 10 | destructor destroy(); 11 | property field(i2: int32;i3:int32): int32 write setfield; 12 | end; 13 | 14 | { ttest } 15 | 16 | constructor ttest.create(); 17 | begin 18 | end; 19 | 20 | destructor ttest.destroy(); 21 | begin 22 | end; 23 | 24 | method ttest.setfield(i2: int32;i3:int32;avalue: int32); 25 | begin 26 | self.ffield:= avalue*i2+i3; 27 | end; 28 | 29 | var 30 | t1: ttest; 31 | 32 | begin 33 | t1:= ttest.create(); 34 | t1.field[10,3]:= 12; 35 | exitcode:= t1.ffield; 36 | t1.destroy(); 37 | end. 38 | -------------------------------------------------------------------------------- /src/test/base/exception/except3.mla: -------------------------------------------------------------------------------- 1 | program except3; 2 | type 3 | e = class()[virtual,except] 4 | constructor create(); 5 | destructor destroy() [default]; 6 | end; 7 | e1 = class(e) 8 | end; 9 | e2 = class(e1) 10 | end; 11 | 12 | f = class()[virtual,except] 13 | constructor create(); 14 | destructor destroy() [default]; 15 | end; 16 | 17 | constructor e.create(); 18 | begin 19 | end; 20 | 21 | destructor e.destroy(); 22 | begin 23 | exitcode:= exitcode + 3; 24 | end; 25 | 26 | constructor f.create(); 27 | begin 28 | end; 29 | 30 | destructor f.destroy(); 31 | begin 32 | exitcode:= exitcode + 4; 33 | end; 34 | 35 | begin 36 | try 37 | raise e1.create(); 38 | except 39 | f,e1: 40 | exitcode:= 120; 41 | e,f: 42 | exitcode:= 100; 43 | end; 44 | end. -------------------------------------------------------------------------------- /src/test/rtl/tobject/classtype.mla: -------------------------------------------------------------------------------- 1 | program classtype; 2 | uses 3 | rtl_fpccompatibility,__mla__internaltypes; 4 | type 5 | 6 | ctest = class(tobject)[rtti] 7 | f1: int32; 8 | constructor create(); 9 | destructor destroy(); 10 | end; 11 | cty = class of ctest; 12 | 13 | constructor ctest.create(); 14 | begin 15 | end; 16 | 17 | destructor ctest.destroy(); 18 | begin 19 | end; 20 | 21 | var 22 | cc1: cty; 23 | p1: pclassdefheaderty; 24 | p2: pobjectrttity; 25 | c1: ctest; 26 | begin 27 | cc1:= ctest; 28 | p1:= pointer(cc1); 29 | p2:= pointer(p1^.rtti); 30 | c1:= ctest.create(); 31 | if (pointer(cc1) = c1.classtype) and (p2 = c1.classinfo) and (p2^.kind = rtk_object) and (c1.classname = 'ctest') then 32 | exitcode:= 123; 33 | end; 34 | c1.destroy(); 35 | end. -------------------------------------------------------------------------------- /src/bcwriter/createabbrev/bcwriter.abr: -------------------------------------------------------------------------------- 1 | [mainfo.abbrevidstart] 2 | value=4 3 | [mainfo.grid] 4 | propcolwidthref=246 5 | values0=11 6 | subtype 7 | 8 | 9 | 10 | 11 | 12 | int 13 | 14 | data 15 | 16 | 17 | width0=103 18 | sortdescend0=0 19 | values1=11 20 | 0 21 | 1 22 | 0 23 | 2 24 | 3 25 | 2 26 | 2 27 | 2 28 | 2 29 | 3 30 | 1 31 | values1_ci=-1 32 | width1=98 33 | sortdescend1=0 34 | values2=11 35 | 21 36 | 1 37 | 0 38 | 6 39 | 0 40 | 6 41 | 6 42 | 6 43 | 6 44 | 0 45 | 8 46 | values2_ci=-1 47 | width2=23 48 | sortdescend2=0 49 | values3=11 50 | TYPE_CODE_FUNCTION 51 | vararg 52 | ignored 53 | retty 54 | paramty 55 | 56 | id 57 | value 58 | id 59 | array 60 | data 61 | width3=237 62 | sortdescend3=0 63 | [mainfo.idsize] 64 | value=3 65 | -------------------------------------------------------------------------------- /src/test/base/exception/finally1.mla: -------------------------------------------------------------------------------- 1 | program finally1; 2 | type 3 | ex = class[virtual,except] 4 | constructor create(); 5 | destructor destroy() [default]; 6 | private 7 | f: int32; 8 | end; 9 | 10 | constructor ex.create(); 11 | begin 12 | end; 13 | 14 | destructor ex.destroy(); 15 | begin 16 | end; 17 | 18 | procedure tt(); 19 | begin 20 | raise ex.create(); 21 | end; 22 | 23 | var 24 | e,f: ex; 25 | 26 | begin 27 | try 28 | try 29 | tt(); 30 | exitcode:= 100; 31 | finally 32 | exitcode:= exitcode + 23; 33 | if true then 34 | if getexceptobj(e) then 35 | e.f:= 90; 36 | end; 37 | raise; 38 | end; 39 | end; 40 | except 41 | if getexceptobj(f) then 42 | exitcode:= f.f + exitcode + 10; 43 | end; 44 | end; 45 | end. 46 | -------------------------------------------------------------------------------- /src/test/intrinsics/typeinfo/typeofclass1.mla: -------------------------------------------------------------------------------- 1 | program typeofclass1; 2 | uses 3 | __mla__internaltypes; 4 | type 5 | ttest = class[virtual] 6 | constructor create(); 7 | destructor destroy(); 8 | end; 9 | ttest1 = class(ttest)[rtti] 10 | end; 11 | 12 | constructor ttest.create(); 13 | begin 14 | end; 15 | 16 | destructor ttest.destroy(); 17 | begin 18 | end; 19 | 20 | var 21 | p1,p3: prttity; 22 | p2: pclassdefty; 23 | c1: class of ttest; 24 | i1: int32; 25 | h1: classdefheaderty; 26 | t1: ttest; 27 | begin 28 | p1:= typeinfo(ttest1); 29 | c1:= classof(ttest); 30 | t1:= ttest1.create(); 31 | p2:= pclassdefty(classof(t1)); 32 | p3:= p2^.header.rtti; 33 | if (string8(p1^.typename) = 'ttest1') and (p1 = p3) then 34 | exitcode:= 123; 35 | end; 36 | t1.destroy(); 37 | end. -------------------------------------------------------------------------------- /src/test/base/exception/except7.mla: -------------------------------------------------------------------------------- 1 | program except7; 2 | type 3 | ex = class[virtual,except] 4 | constructor create(); 5 | destructor destroy() [default]; 6 | private 7 | f: int32; 8 | end; 9 | 10 | constructor ex.create(); 11 | begin 12 | end; 13 | 14 | destructor ex.destroy(); 15 | begin 16 | end; 17 | 18 | procedure tt(); 19 | begin 20 | raise ex.create(); 21 | end; 22 | 23 | var 24 | e,f: ex; 25 | 26 | begin 27 | try 28 | try 29 | tt(); 30 | exitcode:= 100; 31 | except 32 | exitcode:= exitcode + 23; 33 | getexceptobj(e); 34 | if true then 35 | if getexceptobj(e) then 36 | e.f:= 90; 37 | end; 38 | raise; 39 | end; 40 | end; 41 | except 42 | if getexceptobj(f) then 43 | exitcode:= f.f + exitcode + 10; 44 | end; 45 | end; 46 | end. 47 | -------------------------------------------------------------------------------- /src/test/class/sizeof/sizeofclass2.mla: -------------------------------------------------------------------------------- 1 | program sizofclass2; 2 | type 3 | ctest = class[virtual] 4 | f1,f2: int32; 5 | constructor create(); 6 | destructor destroy(); 7 | class method test(); 8 | method test1(); 9 | end; 10 | ctest1 = class(ctest) 11 | f3: int32; 12 | end; 13 | 14 | constructor ctest.create(); 15 | begin 16 | end; 17 | 18 | destructor ctest.destroy(); 19 | begin 20 | end; 21 | 22 | method ctest.test1(); 23 | begin 24 | end; 25 | 26 | class method ctest.test(); 27 | begin 28 | exitcode:= exitcode+sizeof(self^); 29 | end; 30 | 31 | var 32 | c1,c2: ctest; 33 | begin 34 | c1:= ctest.create(); 35 | c2:= ctest1.create(); 36 | c1.test(); 37 | c2.test(); 38 | c1.destroy(); 39 | c2.destroy(); 40 | exitcode:= exitcode+(123-sizeof(ctest^)-sizeof(ctest1^)); 41 | end. 42 | -------------------------------------------------------------------------------- /src/test/intrinsics/typeinfo/classrtti.mla: -------------------------------------------------------------------------------- 1 | program classrtti; 2 | uses 3 | __mla__internaltypes; 4 | 5 | type 6 | ttest = class[rtti] 7 | f1: int32; 8 | f2: int16; 9 | property p1: int32 read f1; 10 | property p2: int16 read f2; 11 | end; 12 | var 13 | p1,p1a: pobjectrttity; 14 | p2,pe: ppropertyrttity; 15 | p3,p4: pclassdefty; 16 | begin 17 | p1:= pointer(typeinfo(ttest)); 18 | p3:= pclassdefty(classof(ttest)); 19 | p1a:= pointer(p3^.header.rtti); 20 | p4:= p1a^.classdef; 21 | if (p1 = p1a) and (p3 = p4) and (string8(p1a^.typename) = 'ttest') then 22 | p2:= (@p1^.properties.items); 23 | pe:= pointer(p2) + p1^.properties.size; 24 | while p2 < pe do 25 | writeln(p2^.proptype^.kind,' ',p2^.proptype^.datasize); 26 | inc(p2); 27 | end; 28 | exitcode:= 123; 29 | end; 30 | end. -------------------------------------------------------------------------------- /src/test/rtl/typeinfo/property1.mla: -------------------------------------------------------------------------------- 1 | program property1; 2 | uses 3 | __mla__internaltypes,rtl_base,rtl_rttiutils; 4 | 5 | type 6 | t1 = class (Cbase)[rtti] 7 | f1: int32; 8 | constructor create(); 9 | destructor destroy(); 10 | property p1: int32 read f1 write f1; 11 | property p2: int32 read f1 write f1; 12 | end; 13 | 14 | t2 = class(t1)[] 15 | f3: int32; 16 | property p3: int32 read f3 write f3; 17 | end; 18 | 19 | constructor t1.create(); 20 | begin 21 | end; 22 | 23 | destructor t1.destroy(); 24 | begin 25 | end; 26 | 27 | var 28 | c1: t1; 29 | p1,p2: ppropertyrttity; 30 | begin 31 | c1:= t2.create(); 32 | p1:= getpropinfo(c1,'p3'); 33 | p2:= getpropinfo(c1,'P2'); 34 | if (string8(p1^.name) = 'p3') and (string8(p2^.name) = 'p2') then 35 | exitcode:= 123; 36 | end; 37 | c1.destroy(); 38 | end. -------------------------------------------------------------------------------- /src/test/class/calls/inheritedfunc.mla: -------------------------------------------------------------------------------- 1 | program inheritedfunc; 2 | 3 | type 4 | tcla = class[virtual] 5 | private 6 | f: int32; 7 | public 8 | constructor create(); 9 | destructor destroy(); 10 | method test1(a,b: int32): int32[virtual]; 11 | end; 12 | 13 | tcla2 = class(tcla) 14 | public 15 | method test1(a,b: int32): int32[override]; 16 | end; 17 | 18 | constructor tcla.create(); 19 | begin 20 | f:= 3; 21 | end; 22 | 23 | destructor tcla.destroy(); 24 | begin 25 | end; 26 | 27 | method tcla.test1(a,b: int32): int32; 28 | begin 29 | result:= f+a+b; 30 | end; 31 | 32 | method tcla2.test1(a,b: int32): int32; 33 | begin 34 | result:= inherited test1(a,b)-3; 35 | end; 36 | 37 | var 38 | c1: tcla; 39 | begin 40 | c1:= tcla2.create(); 41 | exitcode:= c1.test1(100,23); 42 | c1.destroy(); 43 | end. 44 | -------------------------------------------------------------------------------- /src/test/class/properties/arrayparamsetind2.mla: -------------------------------------------------------------------------------- 1 | program arrayparamsetind2; 2 | 3 | type 4 | ttest = class 5 | private 6 | ffield: int32; 7 | method setfield(i2: int32;i3:int32;avalue: int32); 8 | public 9 | constructor create(); 10 | destructor destroy(); 11 | method test(); 12 | property field(i2: int32;i3:int32): int32 write setfield; 13 | end; 14 | 15 | { ttest } 16 | 17 | constructor ttest.create(); 18 | begin 19 | end; 20 | 21 | destructor ttest.destroy(); 22 | begin 23 | end; 24 | 25 | method ttest.setfield(i2: int32;i3:int32;avalue: int32); 26 | begin 27 | self.ffield:= avalue*i2+i3; 28 | end; 29 | 30 | method ttest.test(); 31 | begin 32 | field[10,3]:= 12; 33 | end; 34 | 35 | var 36 | t1: ttest; 37 | 38 | begin 39 | t1:= ttest.create(); 40 | t1.test(); 41 | exitcode:= t1.ffield; 42 | t1.destroy(); 43 | end. 44 | -------------------------------------------------------------------------------- /src/test/class/methods/method5.mla: -------------------------------------------------------------------------------- 1 | program method5; 2 | 3 | type 4 | meth1ty = method (a,b: int32); 5 | 6 | tcla = class[virtual] 7 | private 8 | f: int32; 9 | public 10 | constructor create(); 11 | destructor destroy(); 12 | method test(a,b: int32) [virtual]; 13 | end; 14 | 15 | tcla2 = class(tcla) 16 | public 17 | method test(a,b: int32) [override]; 18 | end; 19 | 20 | constructor tcla.create(); 21 | begin 22 | f:= 3; 23 | end; 24 | 25 | destructor tcla.destroy(); 26 | begin 27 | end; 28 | 29 | method tcla.test(a,b: int32); 30 | begin 31 | exitcode:= 11; 32 | end; 33 | 34 | method tcla2.test(a,b: int32); 35 | begin 36 | exitcode:= a+b+f;//inherited test(a,b); 37 | end; 38 | 39 | var 40 | meth1: meth1ty; 41 | c1: tcla; 42 | begin 43 | c1:= tcla2.create(); 44 | meth1:= @c1.test; 45 | meth1(100,20); 46 | c1.destroy(); 47 | end. 48 | -------------------------------------------------------------------------------- /src/test/base/managed/assign1.mla: -------------------------------------------------------------------------------- 1 | program assign1; 2 | uses 3 | rtl_base,__mla__internaltypes; 4 | 5 | type 6 | 7 | Tcomponent = class(Cbase) 8 | property name: string8 read fname write setname; 9 | private 10 | fname: string8; 11 | method setname(const avalue: string8); 12 | method getname1(): string8; 13 | public 14 | property name1: string8 read getname1; 15 | end; 16 | 17 | method Tcomponent.setname(const avalue: string8); 18 | begin 19 | fname:= avalue; 20 | end; 21 | 22 | method Tcomponent.getname1(): string8; 23 | begin 24 | result:= fname+'123'; 25 | end; 26 | 27 | var 28 | c1,c2: Tcomponent; 29 | s1: string8; 30 | s2: string8; 31 | begin 32 | c1:= Tcomponent.create(); 33 | c1.fname:= 'abc'; 34 | s1:= c1.name; 35 | s2:= c1.name1; 36 | c1.destroy(); 37 | if (s1 = 'abc') and (s2 = 'abc123') then 38 | exitcode:= 123; 39 | end; 40 | end. -------------------------------------------------------------------------------- /src/test/class/classis1.mla: -------------------------------------------------------------------------------- 1 | program classis1; 2 | type 3 | testclassty = class of ctest; 4 | ctest = class() 5 | v1: int32; 6 | class procedure test(): boolean; 7 | class procedure test1(aclass: testclassty): boolean; 8 | end; 9 | 10 | ctest1 = class(ctest) 11 | end; 12 | 13 | class procedure ctest.test1(aclass: testclassty): boolean; 14 | begin 15 | result:= self is aclass; 16 | end; 17 | 18 | class procedure ctest.test(): boolean; 19 | begin 20 | result:= self is ctest1; 21 | end; 22 | 23 | var 24 | cc1,cc2: testclassty; 25 | begin 26 | cc1:= ctest; 27 | cc2:= ctest1; 28 | if ctest1.test1(ctest1) and not ctest.test1(ctest1) and ctest.test1(ctest) and 29 | not ctest.test() and ctest1.test() and 30 | ctest.test1(cc1) and not ctest.test1(cc2) and ctest.test1(cc1) and ctest1.test1(cc1) then 31 | exitcode:= 123; 32 | end; 33 | end. -------------------------------------------------------------------------------- /src/test/base/sub/overload2.mla: -------------------------------------------------------------------------------- 1 | program overload2; 2 | 3 | var 4 | testv: int32; 5 | flo1: flo64; 6 | str1: string8; 7 | { 8 | procedure testpro(a: int32); 9 | begin 10 | writeln(a); 11 | testv:= 1; 12 | end; 13 | } 14 | { 15 | procedure testpro(a: int8); 16 | begin 17 | writeln(a); 18 | testv:= 2; 19 | end; 20 | 21 | procedure testpro(a: card32); 22 | begin 23 | writeln(a); 24 | testv:= 3; 25 | end; 26 | } 27 | procedure testpro(a: flo64); 28 | begin 29 | testv:= 4; 30 | flo1:= a; 31 | end; 32 | 33 | procedure testpro(a: string8); 34 | begin 35 | testv:= 5; 36 | str1:= a; 37 | end; 38 | 39 | var 40 | i1: int8; 41 | i2: int32; 42 | s1: string8; 43 | begin 44 | i1:= 123; 45 | testpro(i1); 46 | if (testv = 4) and (flo1 = 123) then 47 | s1:= 'abc'; 48 | testpro(s1); 49 | if (testv = 5) then 50 | exitcode:= 123; 51 | writeln(str1); 52 | end; 53 | end; 54 | end. 55 | -------------------------------------------------------------------------------- /src/test/class/classof/classmethod2.mla: -------------------------------------------------------------------------------- 1 | program classmethod2; 2 | type 3 | ttest = class; 4 | tclass = class of ttest; 5 | ttest = class()[virtual] 6 | constructor create(); 7 | destructor destroy(); 8 | class method test(a: int32) [virtual]; 9 | class method classtype: tclass; 10 | end; 11 | 12 | ttest1 = class(ttest) 13 | class method test(a: int32) [override]; 14 | end; 15 | 16 | constructor ttest.create(); 17 | begin 18 | end; 19 | 20 | destructor ttest.destroy(); 21 | begin 22 | end; 23 | 24 | class method ttest.test(a: int32); 25 | begin 26 | exitcode:= a; 27 | end; 28 | 29 | class method ttest.classtype: tclass; 30 | begin 31 | result:= tclass(self); 32 | end; 33 | 34 | class method ttest1.test(a: int32); 35 | begin 36 | inherited; 37 | exitcode:= exitcode + 23; 38 | end; 39 | 40 | var 41 | c2: ttest; 42 | v1: tclass; 43 | begin 44 | v1:= ttest1; 45 | v1.test(100); 46 | end. -------------------------------------------------------------------------------- /src/test/base/sub/overload1.mla: -------------------------------------------------------------------------------- 1 | program overload1; 2 | 3 | var 4 | testv: int32; 5 | 6 | procedure testpro(a: int32); 7 | begin 8 | testv:= 1; 9 | end; 10 | procedure testpro(a: int8); 11 | begin 12 | testv:= 2; 13 | end; 14 | 15 | procedure testpro(a: card32); 16 | begin 17 | testv:= 3; 18 | end; 19 | 20 | procedure testpro(p: flo64); 21 | begin 22 | testv:= 4; 23 | end; 24 | 25 | procedure testpro(a: string8); 26 | begin 27 | testv:= 5; 28 | end; 29 | 30 | 31 | begin 32 | testpro(int32(32)); 33 | if testv = 1 then 34 | testpro(8); 35 | if testv = 2 then 36 | testpro(card16(8)); 37 | if testv = 3 then 38 | testpro(card32(33)); 39 | if testv = 3 then 40 | testpro(123.8); 41 | if testv = 4 then 42 | testpro('abc'); 43 | if testv = 5 then 44 | exitcode:= 123; 45 | end; 46 | end; 47 | end; 48 | end; 49 | end; 50 | end; 51 | end. 52 | -------------------------------------------------------------------------------- /src/test/class/methods/method6.mla: -------------------------------------------------------------------------------- 1 | program method6; 2 | 3 | type 4 | meth1ty = method (a,b: int32): int32; 5 | 6 | tcla = class[virtual] 7 | private 8 | f: int32; 9 | public 10 | constructor create(); 11 | destructor destroy(); 12 | method test(a,b: int32): int32 [virtual]; 13 | end; 14 | 15 | tcla2 = class(tcla) 16 | public 17 | method test(a,b: int32): int32 [override]; 18 | end; 19 | 20 | constructor tcla.create(); 21 | begin 22 | f:= 3; 23 | end; 24 | 25 | destructor tcla.destroy(); 26 | begin 27 | end; 28 | 29 | method tcla.test(a,b: int32): int32; 30 | begin 31 | result:= 11; 32 | end; 33 | 34 | method tcla2.test(a,b: int32): int32; 35 | begin 36 | result:= a+b+f;//inherited test(a,b); 37 | end; 38 | 39 | var 40 | meth1: meth1ty; 41 | c1: tcla; 42 | begin 43 | c1:= tcla2.create(); 44 | meth1:= @c1.test; 45 | exitcode:= meth1(100,20); 46 | c1.destroy(); 47 | end. 48 | -------------------------------------------------------------------------------- /src/interface.mla: -------------------------------------------------------------------------------- 1 | unit program; 2 | type 3 | itest = interface 4 | procedure test(); 5 | end; 6 | 7 | tobject = class 8 | public 9 | constructor create(); 10 | destructor destroy(); 11 | procedure test(); virtual; 12 | end; 13 | tc = class(tobject,itest) 14 | procedure test(); override; 15 | end; 16 | tc3 = class(tobject,itest) 17 | procedure test(); override; 18 | end; 19 | 20 | implementation 21 | 22 | constructor tobject.create(); 23 | begin 24 | end; 25 | 26 | destructor tobject.destroy(); 27 | begin 28 | end; 29 | 30 | procedure tobject.test(); 31 | begin 32 | writeln(111); 33 | end; 34 | 35 | procedure tc.test(); 36 | begin 37 | writeln(222); 38 | end; 39 | 40 | procedure tc3.test(); 41 | begin 42 | writeln(333); 43 | end; 44 | 45 | var 46 | i: itest; 47 | c: tc; 48 | 49 | begin 50 | c:= tc3.create(); 51 | i:= itest(c); 52 | i.test(); 53 | c.destroy(); 54 | end. 55 | -------------------------------------------------------------------------------- /src/test/base/sub/defaultpar2.mla: -------------------------------------------------------------------------------- 1 | program defaultpar2; 2 | 3 | var 4 | i2: int32; 5 | 6 | procedure testpro(a: int32): int32; 7 | begin 8 | i2:= 2; 9 | result:= a; 10 | end; 11 | 12 | procedure testpro(a: int32; b,c: int32 = 42): int32; 13 | begin 14 | i2:= 1; 15 | result:= a+b-c; 16 | end; 17 | 18 | procedure testpro(a: flo64; b,c: int32 = 42): flo64; 19 | begin 20 | i2:= 2; 21 | result:= a+b-c; 22 | end; 23 | 24 | var 25 | i1: int32; 26 | f1: flo64; 27 | 28 | begin 29 | i1:= testpro(1,2,3); 30 | if (i2 = 1) and (i1 = 1+(2-3)) then 31 | i1:= testpro(1,2); 32 | if (i2 = 1) and (i1 = 1+2-42) then 33 | i1:= testpro(1); 34 | if (i2 = 2) and (i1 = 1) then 35 | f1:= testpro(1.0,2); 36 | if (i2 = 2) and (f1 = 1+2-42) then 37 | f1:= testpro(1.0,2,3); 38 | if (i2 = 2) and (f1 = 1+2-3) then 39 | exitcode:= 123; 40 | end; 41 | end; 42 | end; 43 | end; 44 | end; 45 | end. 46 | -------------------------------------------------------------------------------- /src/test/class/properties/classprop4.mla: -------------------------------------------------------------------------------- 1 | program classprop4; 2 | 3 | type 4 | ttest = class 5 | private 6 | ffield: int32; 7 | method getfield(): int32; 8 | method setfield(avalue: int32); 9 | public 10 | constructor create(); 11 | destructor destroy(); 12 | property field: int32 read getfield write setfield; 13 | method test(); 14 | end; 15 | 16 | { ttest } 17 | 18 | constructor ttest.create(); 19 | begin 20 | ffield:= 122; 21 | end; 22 | 23 | destructor ttest.destroy(); 24 | begin 25 | end; 26 | 27 | method ttest.getfield(): int32; 28 | begin 29 | result:= ffield; 30 | end; 31 | 32 | method ttest.setfield(avalue: int32); 33 | begin 34 | ffield:= avalue; 35 | end; 36 | 37 | method ttest.test(); 38 | begin 39 | field:= ffield + 1; 40 | exitcode:= field; 41 | end; 42 | 43 | var 44 | t1: ttest; 45 | 46 | begin 47 | t1:= ttest.create(); 48 | t1.test(); 49 | t1.destroy(); 50 | end. 51 | -------------------------------------------------------------------------------- /src/test/class/properties/arrayparamget.mla: -------------------------------------------------------------------------------- 1 | program arrayparamget; 2 | 3 | type 4 | ttest = class 5 | private 6 | ffield: int32; 7 | method getfield(i2: int32;i3:int32): int32; 8 | method setfield(avalue: int32;i2: int32;i3:int32); 9 | public 10 | constructor create(); 11 | destructor destroy(); 12 | property field(i2: int32;i3:int32): int32 read getfield write setfield; 13 | end; 14 | 15 | { ttest } 16 | 17 | constructor ttest.create(); 18 | begin 19 | self.ffield:= 12; 20 | end; 21 | 22 | destructor ttest.destroy(); 23 | begin 24 | end; 25 | 26 | method ttest.getfield(i2: int32;i3: int32): int32; 27 | begin 28 | result:= ffield * i2+i3; 29 | end; 30 | 31 | method ttest.setfield(avalue: int32; i2: int32;i3:int32); 32 | begin 33 | self.ffield:= avalue; 34 | end; 35 | 36 | var 37 | t1: ttest; 38 | 39 | begin 40 | t1:= ttest.create(); 41 | exitcode:= t1.field[10,3]; 42 | t1.destroy(); 43 | end. 44 | -------------------------------------------------------------------------------- /src/test/class/properties/int64getterass.mla: -------------------------------------------------------------------------------- 1 | program int64getterass; 2 | uses 3 | 4 | type 5 | tstream = class()[virtual] 6 | constructor create(); 7 | destructor destroy(); 8 | property position: int64 read getposition write setposition; 9 | private 10 | f1: int64; 11 | method getposition(): int64;// [virtual]; 12 | method setposition(const avalue: int64);// [virtual]; 13 | end; 14 | 15 | constructor tstream.create(); 16 | begin 17 | end; 18 | 19 | destructor tstream.destroy(); 20 | begin 21 | end; 22 | 23 | method tstream.getposition(): int64; 24 | begin 25 | result:= f1; 26 | end; 27 | 28 | method tstream.setposition(const avalue: int64); 29 | begin 30 | f1:= avalue; 31 | end; 32 | 33 | var 34 | stream1: tstream; 35 | i1: int64; 36 | begin 37 | stream1:= tstream.create(); 38 | stream1.position:= 123; 39 | i1:= stream1.position; 40 | if i1 = 123 then 41 | exitcode:= i1; 42 | end; 43 | stream1.destroy(); 44 | end. -------------------------------------------------------------------------------- /src/test/class/properties/int64getterass2.mla: -------------------------------------------------------------------------------- 1 | program int64getterass2; 2 | uses 3 | 4 | type 5 | tstream = class()[virtual] 6 | constructor create(); 7 | destructor destroy(); 8 | property position: int64 read getposition write setposition; 9 | private 10 | f1: int64; 11 | method getposition(): int64 [virtual]; 12 | method setposition(const avalue: int64) [virtual]; 13 | end; 14 | 15 | constructor tstream.create(); 16 | begin 17 | end; 18 | 19 | destructor tstream.destroy(); 20 | begin 21 | end; 22 | 23 | method tstream.getposition(): int64; 24 | begin 25 | result:= f1; 26 | end; 27 | 28 | method tstream.setposition(const avalue: int64); 29 | begin 30 | f1:= avalue; 31 | end; 32 | 33 | var 34 | stream1: tstream; 35 | i1: int64; 36 | begin 37 | stream1:= tstream.create(); 38 | stream1.position:= 123; 39 | i1:= stream1.position; 40 | if i1 = 123 then 41 | exitcode:= i1; 42 | end; 43 | stream1.destroy(); 44 | end. -------------------------------------------------------------------------------- /src/test/class/interface/classinterface.mla: -------------------------------------------------------------------------------- 1 | program classinterface; 2 | type 3 | itest = interface 4 | method test(); 5 | method test1(); 6 | end; 7 | itest1 = interface 8 | method test(); 9 | end; 10 | 11 | tc1 = class[virtual] 12 | private 13 | f: int32; 14 | public 15 | constructor create(); 16 | destructor destroy(); 17 | end; 18 | 19 | tc2 = class(tc1,itest,itest1) 20 | public 21 | method test(); 22 | method test1(); 23 | end; 24 | 25 | constructor tc1.create(); 26 | begin 27 | end; 28 | 29 | destructor tc1.destroy(); 30 | begin 31 | exitcode:= f+11; 32 | end; 33 | 34 | method tc2.test(); 35 | begin 36 | f:= 112; 37 | end; 38 | 39 | method tc2.test1(); 40 | begin 41 | exitcode:= 100; 42 | end; 43 | 44 | var 45 | i1: itest; 46 | c1: tc2; 47 | 48 | type 49 | ppointer = ^pointer; 50 | 51 | begin 52 | 53 | c1:= tc2.create(); 54 | i1:= itest(c1); 55 | i1.test(); 56 | c1.destroy(); 57 | 58 | end. 59 | -------------------------------------------------------------------------------- /src/test/class/properties/selftest.mla: -------------------------------------------------------------------------------- 1 | program selftest; 2 | 3 | type 4 | ttest = class 5 | private 6 | ffield: int32; 7 | method getfield(): int32; 8 | method setfield(avalue: int32); 9 | public 10 | constructor create(); 11 | destructor destroy(); 12 | property field: int32 read getfield write setfield; 13 | method test(); 14 | end; 15 | 16 | { ttest } 17 | 18 | constructor ttest.create(); 19 | begin 20 | self.ffield:= 122; 21 | end; 22 | 23 | destructor ttest.destroy(); 24 | begin 25 | end; 26 | 27 | method ttest.getfield(): int32; 28 | begin 29 | result:= self.ffield; 30 | end; 31 | 32 | method ttest.setfield(avalue: int32); 33 | begin 34 | self.ffield:= avalue; 35 | end; 36 | 37 | method ttest.test(); 38 | begin 39 | self.field:= self.ffield + 1; 40 | exitcode:= self.field; 41 | end; 42 | 43 | var 44 | t1: ttest; 45 | 46 | begin 47 | t1:= ttest.create(); 48 | t1.test(); 49 | t1.destroy(); 50 | end. 51 | -------------------------------------------------------------------------------- /src/rtl/classes/rtl_classutils.mla: -------------------------------------------------------------------------------- 1 | //rtl_classutils 2 | { MSElang Copyright (c) 2018 by Martin Schreiber 3 | 4 | See the file COPYING.MSE, included in this distribution, 5 | for details about the copyright. 6 | 7 | This program is distributed in the hope that it will be useful, 8 | but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | } 11 | unit rtl_classutils; 12 | interface 13 | uses 14 | rtl_base,__mla__internaltypes; 15 | 16 | procedure getclassname(const ainstance: Cbase): string8; 17 | 18 | implementation 19 | 20 | procedure getclassname(const ainstance: Cbase): string8; 21 | begin 22 | if ainstance = nil then 23 | result:= 'NIL'; 24 | else 25 | decref(result); 26 | pointer(result):= pointer(prttity(typeinfo(ainstance)^.typename)); 27 | //const, no incref needed 28 | end; 29 | end; 30 | 31 | end. 32 | -------------------------------------------------------------------------------- /src/test/class/classfield.mla: -------------------------------------------------------------------------------- 1 | program classfield; 2 | 3 | type 4 | recty = record 5 | a: int32; 6 | b: int32; 7 | end; 8 | 9 | ttest = class 10 | public 11 | ff: recty; 12 | constructor create(); 13 | destructor destroy(); 14 | method test(); 15 | end; 16 | 17 | var 18 | i1: int32; 19 | c1: ttest; 20 | 21 | constructor ttest.create(); 22 | begin 23 | ff.a:= 1; 24 | ff.b:= 121; 25 | end; 26 | 27 | destructor ttest.destroy(); 28 | begin 29 | exitcode:= ff.a+ff.b; 30 | end; 31 | 32 | method ttest.test(); 33 | begin 34 | ff.b:= ff.a+ff.b; 35 | exitcode:= ff.a+ff.b+5; 36 | end; 37 | var 38 | c2: ^ttest; 39 | begin 40 | c1:= nil; 41 | c1:= ttest.create(); 42 | c2:= @c1; 43 | c2^.test(); 44 | if exitcode = 128 then 45 | c1.ff.a:= 22; 46 | c1.ff.b:= 100; 47 | exitcode:= c1.ff.a+c1.ff.b+2; 48 | if (exitcode = 124) and (c2^.ff.a+c2^.ff.b+2 = 124) then 49 | c1.ff.b:= 101; 50 | end; 51 | end; 52 | c1.destroy(); 53 | end. -------------------------------------------------------------------------------- /src/test/class/classof/classmethod.mla: -------------------------------------------------------------------------------- 1 | program classmethod; 2 | type 3 | ttest = class; 4 | tclass = class of ttest; 5 | ttest = class()[virtual] 6 | constructor create(); 7 | destructor destroy(); 8 | class method test(a: int32) [virtual]; 9 | class method classtype: tclass; 10 | end; 11 | 12 | ttest1 = class(ttest) 13 | class method test(a: int32) [override]; 14 | end; 15 | 16 | constructor ttest.create(); 17 | begin 18 | end; 19 | 20 | destructor ttest.destroy(); 21 | begin 22 | end; 23 | 24 | class method ttest.test(a: int32); 25 | begin 26 | exitcode:= a; 27 | end; 28 | 29 | class method ttest.classtype: tclass; 30 | begin 31 | // result:= tclass(self); 32 | end; 33 | 34 | class method ttest1.test(a: int32); 35 | begin 36 | inherited; 37 | exitcode:= exitcode + 23; 38 | end; 39 | 40 | var 41 | c2: ttest; 42 | v1: tclass; 43 | begin 44 | v1:= ttest1; 45 | v1.test(100); 46 | // c2:= ttest1.create(); 47 | // c2.destroy(); 48 | end. -------------------------------------------------------------------------------- /src/test/class/classof/classmethod1.mla: -------------------------------------------------------------------------------- 1 | program classmethod1; 2 | type 3 | ttest = class; 4 | tclass = class of ttest; 5 | ttest = class()[virtual] 6 | constructor create(); 7 | destructor destroy(); 8 | class method test(a: int32) [virtual]; 9 | class method classtype: tclass; 10 | end; 11 | 12 | ttest1 = class(ttest) 13 | class method test(a: int32) [override]; 14 | end; 15 | 16 | constructor ttest.create(); 17 | begin 18 | end; 19 | 20 | destructor ttest.destroy(); 21 | begin 22 | end; 23 | 24 | class method ttest.test(a: int32); 25 | begin 26 | exitcode:= a; 27 | end; 28 | 29 | class method ttest.classtype: tclass; 30 | begin 31 | result:= tclass(self); 32 | end; 33 | 34 | class method ttest1.test(a: int32); 35 | begin 36 | inherited; 37 | exitcode:= exitcode + 23; 38 | end; 39 | 40 | var 41 | c2: ttest; 42 | v1: tclass; 43 | begin 44 | c2:= ttest1.create(); 45 | v1:= classof(c2); 46 | v1.test(100); 47 | c2.destroy(); 48 | end. -------------------------------------------------------------------------------- /src/test/class/classof/classmethod3.mla: -------------------------------------------------------------------------------- 1 | program classmethod3; 2 | type 3 | ttest = class; 4 | tclass = class of ttest; 5 | ttest = class()[virtual] 6 | constructor create(); 7 | destructor destroy(); 8 | class method test(a: int32) [virtual]; 9 | class method classtype: tclass; 10 | end; 11 | 12 | ttest1 = class(ttest) 13 | class method test(a: int32) [override]; 14 | end; 15 | 16 | constructor ttest.create(); 17 | begin 18 | end; 19 | 20 | destructor ttest.destroy(); 21 | begin 22 | end; 23 | 24 | class method ttest.test(a: int32); 25 | begin 26 | exitcode:= a; 27 | end; 28 | 29 | class method ttest.classtype: tclass; 30 | begin 31 | result:= tclass(self); 32 | end; 33 | 34 | class method ttest1.test(a: int32); 35 | begin 36 | inherited; 37 | exitcode:= exitcode + 23; 38 | end; 39 | 40 | var 41 | c2: ttest; 42 | v1: tclass; 43 | begin 44 | c2:= ttest1.create; 45 | v1:= classof(c2); 46 | v1.test(100); 47 | c2.destroy(); 48 | end. -------------------------------------------------------------------------------- /src/test/class/classof/classmethod4.mla: -------------------------------------------------------------------------------- 1 | program classmethod4; 2 | type 3 | ttest = class; 4 | tclass = class of ttest; 5 | ttest = class()[virtual] 6 | constructor create(); 7 | destructor destroy(); 8 | class method test(a: int32) [virtual]; 9 | class method classtype: tclass; 10 | end; 11 | 12 | ttest1 = class(ttest) 13 | class method test(a: int32) [override]; 14 | end; 15 | 16 | constructor ttest.create(); 17 | begin 18 | end; 19 | 20 | destructor ttest.destroy(); 21 | begin 22 | end; 23 | 24 | class method ttest.test(a: int32); 25 | begin 26 | exitcode:= a; 27 | end; 28 | 29 | class method ttest.classtype: tclass; 30 | begin 31 | result:= tclass(self); 32 | end; 33 | 34 | class method ttest1.test(a: int32); 35 | begin 36 | inherited; 37 | exitcode:= exitcode + 23; 38 | end; 39 | 40 | var 41 | c2: ttest; 42 | v1: tclass; 43 | begin 44 | c2:= ttest1.create; 45 | v1:= c2.classtype; 46 | v1.test(100); 47 | c2.destroy(); 48 | end. -------------------------------------------------------------------------------- /src/test/base/exception/except4.mla: -------------------------------------------------------------------------------- 1 | program except4; 2 | type 3 | e = class()[virtual,except] 4 | f1: int32; 5 | constructor create(); 6 | destructor destroy() [default]; 7 | end; 8 | e1 = class(e) 9 | end; 10 | e2 = class(e1) 11 | end; 12 | 13 | f = class()[virtual,except] 14 | constructor create(); 15 | destructor destroy() [default]; 16 | end; 17 | 18 | constructor e.create(); 19 | begin 20 | f1:= 12; 21 | end; 22 | 23 | destructor e.destroy(); 24 | begin 25 | exitcode:= exitcode + 3; 26 | end; 27 | 28 | constructor f.create(); 29 | begin 30 | end; 31 | 32 | destructor f.destroy(); 33 | begin 34 | exitcode:= exitcode + 4; 35 | end; 36 | 37 | procedure getexceptobj1(var instance: e): bool1; 38 | begin 39 | result:= false; 40 | end; 41 | 42 | var 43 | v1,ve: e; 44 | begin 45 | try 46 | v1:= e1.create(); 47 | raise v1; 48 | except 49 | if getexceptobj(ve) and (v1 = ve) then 50 | exitcode:= 120; 51 | end; 52 | end; 53 | end. -------------------------------------------------------------------------------- /src/test/class/properties/arrayparam1.mla: -------------------------------------------------------------------------------- 1 | program arrayparam1; 2 | 3 | type 4 | ttest = class 5 | 6 | private 7 | ffield: int32; 8 | method getfield(i2: int32;i3:int32): int32; 9 | method setfield(avalue: int32;i2: int32;i3:int32); 10 | public 11 | constructor create(); 12 | destructor destroy(); 13 | property field(i2: int32;i3:int32): int32 read getfield write setfield; 14 | end; 15 | 16 | { ttest } 17 | 18 | constructor ttest.create(); 19 | begin 20 | field[100,11]:= 12; 21 | end; 22 | 23 | destructor ttest.destroy(); 24 | begin 25 | end; 26 | 27 | method ttest.getfield(i2: int32;i3: int32): int32; 28 | begin 29 | result:= ffield * i2 + i3; 30 | end; 31 | 32 | method ttest.setfield(avalue: int32; i2: int32; i3:int32); 33 | begin 34 | self.ffield:= avalue + i2 + i3; 35 | end; 36 | 37 | var 38 | t1: ttest; 39 | begin 40 | t1:= ttest.create(); 41 | exitcode:= 33 + t1.field[10,3] - 33 -9*123 - 3; 42 | t1.destroy(); 43 | end. 44 | --------------------------------------------------------------------------------