From f9ed4a9957101649f2d9a157e50b10cc6c6d3697 Mon Sep 17 00:00:00 2001 From: Jarl Holta Date: Wed, 18 Mar 2026 07:00:19 +0100 Subject: [PATCH 1/5] Finalize ToStr, with proper print instruction print now takes multiple arguments > print x,y,z and calls tostr on them, with spacing between arguments. `.tostr` now covers existing types. --- compiler/xpr.tree.pas | 49 +++++++--- compiler/xpr.typeintrinsics.pas | 157 +++++++++++++++++++++++++++----- tests/tostr.xpr | 33 +++++++ 3 files changed, 202 insertions(+), 37 deletions(-) create mode 100644 tests/tostr.xpr diff --git a/compiler/xpr.tree.pas b/compiler/xpr.tree.pas index 3427cf9..2702573 100644 --- a/compiler/xpr.tree.pas +++ b/compiler/xpr.tree.pas @@ -5717,26 +5717,51 @@ function XTree_Print.ToString(Offset:string=''): string; *) function XTree_Print.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar; var - arg: TXprVar; + i: Int32; + argType: XType; + argNode, toStrNode, combined: XTree_Node; + combinedVar: TXprVar; begin if (Self.Args = nil) or (Length(Self.Args) = 0) then ctx.RaiseException(eSyntaxError, 'Print statement requires at least one argument', FDocPos); - if Self.Args[0] = nil then - ctx.RaiseException('First argument of print statement is nil', FDocPos); - arg := Self.Args[0].Compile(NullResVar, Flags); - if arg = NullResVar then - ctx.RaiseException('Argument for print statement failed to compile', Self.Args[0].FDocPos); + // Build the full concatenated string expression at compile time. + // Strings pass through directly; everything else gets .ToStr() called on it. + // Args are joined with a space between them. + combined := nil; + for i := 0 to High(Self.Args) do + begin + argNode := Self.Args[i]; + argType := argNode.ResType(); - // Dereference if needed — same as any other expression consumer - if arg.Reference then - arg := arg.DerefToTemp(ctx); + if (argType <> nil) and (argType.BaseType in [xtAnsiString, xtUnicodeString]) then + toStrNode := argNode // already a string, use directly — no quotes + else + begin + toStrNode := XTree_Invoke.Create( + XTree_Identifier.Create('ToStr', ctx, FDocPos), + [], ctx, FDocPos + ); + XTree_Invoke(toStrNode).SelfExpr := argNode; + end; - if arg.VarType = nil then - ctx.RaiseException('Argument for print statement has no resolved type', Self.Args[0].FDocPos); + if combined = nil then + combined := toStrNode + else + combined := XTree_BinaryOp.Create( + op_Add, + XTree_BinaryOp.Create(op_Add, combined, XTree_String.Create(' ', ctx, FDocPos), ctx, FDocPos), + toStrNode, + ctx, FDocPos + ); + end; - Self.Emit(GetInstr(icPRINT, [arg, Immediate(arg.VarType.Size)]), FDocPos); + // Compile the final combined expression and emit a single PRINT + combinedVar := combined.Compile(NullResVar, Flags); + if combinedVar.Reference then + combinedVar := combinedVar.DerefToTemp(ctx); + Self.Emit(GetInstr(icPRINT, [combinedVar, Immediate(combinedVar.VarType.Size)]), FDocPos); Result := NullVar; end; diff --git a/compiler/xpr.typeintrinsics.pas b/compiler/xpr.typeintrinsics.pas index bc115f5..7eaf63a 100644 --- a/compiler/xpr.typeintrinsics.pas +++ b/compiler/xpr.typeintrinsics.pas @@ -356,22 +356,34 @@ function TTypeIntrinsics.GenerateLen(SelfType: XType; Args: array of XType): XTr function TTypeIntrinsics.GenerateToStr(SelfType: XType; Args: array of XType): XTree_Function; var Body: XTree_ExprList; - ReturnNode: XTree_Node; - StringType: XType; + ReturnNode, ConcatNode: XTree_Node; + StringType, IntType: XType; + RecType: XType_Record; + ClassTyp: XType_Class; + i: Int32; + ItemExpr: XTree_Node; begin - if SelfType = nil then - Exit(nil); - - if Length(Args) > 0 then - Exit(nil); + if SelfType = nil then Exit(nil); + if Length(Args) > 0 then Exit(nil); Body := ExprList(); - StringType := FContext.GetType(xtAnsiString); // The function will always return a string. + StringType := FContext.GetType(xtAnsiString); + IntType := FContext.GetType(xtInt); - // The 'self' variable holds the value we need to convert. case SelfType.BaseType of xtAnsiString, xtUnicodeString: - ReturnNode := SelfId(); + // Wrap in single quotes so nested containers look like initializers + // 'hello' -> '''hello''' + ReturnNode := BinOp(op_Add, + StringLiteral(''''), + BinOp(op_Add, SelfId(), StringLiteral('''')) + ); + + xtAnsiChar, xtUnicodeChar: + ReturnNode := BinOp(op_Add, + StringLiteral(''''), + BinOp(op_Add, SelfId(), StringLiteral('''')) + ); xtInt8..xtUInt64: ReturnNode := Call('IntToStr', [SelfId()]); @@ -380,37 +392,132 @@ function TTypeIntrinsics.GenerateToStr(SelfType: XType; Args: array of XType): X ReturnNode := Call('FloatToStr', [SelfId()]); xtBoolean: - // Use a ternary expression: if(self) "true" else "false" ReturnNode := XTree_IfExpr.Create( - SelfId(), - StringLiteral('True'), - StringLiteral('False'), + SelfId(), StringLiteral('True'), StringLiteral('False'), FContext, FDocPos ); xtPointer: - ReturnNode := Call('PtrToStr', [SelfId()]); + ReturnNode := Call('PtrToStr', [SelfId()]); xtArray: - // For now, arrays and records are represented by their address. - // This creates the string: "(TypeName @ " + PtrToStr(Self) + ")" + begin + // Generate: + // if self = nil then return '[]' + // var !r := '[' + // for(var !i := 0; !i <= self.High(); !i := !i + 1) + // if !i > 0 then !r := !r + ', ' + // !r := !r + self[!i].ToStr() + // !r := !r + ']' + // return !r + Body.List += IfStmt( + BinOp(op_EQ, SelfId(), NilPointer()), + ReturnStmt(StringLiteral('[]')), + nil + ); + + Body.List += VarDecl(['!r'], StringType, StringLiteral('[')); + + ItemExpr := XTree_Index.Create(SelfId(), Id('!i'), FContext, FDocPos); + + Body.List += ForLoop( + VarDecl(['!i'], IntType, IntLiteral(0)), + BinOp(op_LTE, Id('!i'), MethodCall(SelfId(), 'High', [])), + Assign(Id('!i'), BinOp(op_ADD, Id('!i'), IntLiteral(1))), + ExprList([ + IfStmt( + BinOp(op_GT, Id('!i'), IntLiteral(0)), + Assign(Id('!r'), BinOp(op_ADD, Id('!r'), StringLiteral(', '))), + nil + ), + Assign(Id('!r'), + BinOp(op_ADD, Id('!r'), + MethodCall(ItemExpr, 'ToStr', []) + ) + ) + ]) + ); + + Body.List += Assign(Id('!r'), BinOp(op_ADD, Id('!r'), StringLiteral(']'))); + Body.List += ReturnStmt(Id('!r')); + + Result := FunctionDef('ToStr', [], nil, [], StringType, Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; + Exit; + end; + + xtRecord: + begin + // Generate: '[' + field1.ToStr() + ', ' + field2.ToStr() + ... + ']' + RecType := SelfType as XType_Record; + + if RecType.FieldNames.Size = 0 then + begin + ReturnNode := StringLiteral('[]'); + end else + begin + ConcatNode := StringLiteral('['); + for i := 0 to RecType.FieldNames.High do + begin + if i > 0 then + ConcatNode := BinOp(op_ADD, ConcatNode, StringLiteral(', ')); + ConcatNode := BinOp(op_ADD, ConcatNode, + MethodCall( + XTree_Field.Create(SelfId(), Id(RecType.FieldNames.Data[i]), FContext, FDocPos), + 'ToStr', [] + ) + ); + end; + ConcatNode := BinOp(op_ADD, ConcatNode, StringLiteral(']')); + ReturnNode := ConcatNode; + end; + end; + + xtClass: + begin + // Same as record but prefixed with type name for clarity + // e.g. TPoint[x: 10, y: 20] + ClassTyp := SelfType as XType_Class; + + Body.List += IfStmt( + BinOp(op_EQ, SelfId(), NilPointer()), + ReturnStmt(StringLiteral(ClassTyp.Name + '[nil]')), + nil + ); + + if ClassTyp.FieldNames.Size = 0 then + begin + ReturnNode := StringLiteral(ClassTyp.Name + '[]'); + end else begin - ReturnNode := BinOp(op_Add, StringLiteral('(' + SelfType.ToString() + ' @ '), - BinOp(op_Add, Call('PtrToStr', [SelfId()]), StringLiteral(')')) - ); + ConcatNode := StringLiteral(ClassTyp.Name + '['); + for i := 0 to ClassTyp.FieldNames.High do + begin + if i > 0 then + ConcatNode := BinOp(op_ADD, ConcatNode, StringLiteral(', ')); + // Include field name for classes: "x: 10" + ConcatNode := BinOp(op_ADD, ConcatNode, StringLiteral(ClassTyp.FieldNames.Data[i] + ': ')); + ConcatNode := BinOp(op_ADD, ConcatNode, + MethodCall( + XTree_Field.Create(SelfId(), Id(ClassTyp.FieldNames.Data[i]), FContext, FDocPos), + 'ToStr', [] + ) + ); + end; + ConcatNode := BinOp(op_ADD, ConcatNode, StringLiteral(']')); + ReturnNode := ConcatNode; end; + end; else - // Default for unknown types - ReturnNode := StringLiteral(''); + ReturnNode := StringLiteral('<' + SelfType.ToString() + '>'); end; - // The function body is just a single return statement. Body.List += ReturnStmt(ReturnNode); - Result := FunctionDef('ToStr', [], nil, [], StringType, Body); Result.SelfType := SelfType; - Result.InternalFlags:=[]; + Result.InternalFlags := []; end; diff --git a/tests/tostr.xpr b/tests/tostr.xpr new file mode 100644 index 0000000..571f8d8 --- /dev/null +++ b/tests/tostr.xpr @@ -0,0 +1,33 @@ +var p:(x,y: int); +p := [100,50] +print p.tostr() + +var arr: array of int = [1,2,3,4,5,6,7,8] +print arr.tostr() + +var arr2d: array of array of int = [[1,2,3], [4,5,6], [7,8,9]]; +print arr2d.tostr() + +type + TClass = class + var x,y,z: int + + func create(x,y,z:int) + (self.x,self.y,self.z) := [x,y,z] + +var inst := new TClass(1,2,3); + +print inst.tostr() + + + +type + TPerson = class + var name: String + var age: Int + +var p := new TPerson() +p.name := 'frank' +p.age := 40 + +print p \ No newline at end of file From 17788408c9f91a0880599ba772904489872010f4 Mon Sep 17 00:00:00 2001 From: Jarl Holta Date: Wed, 18 Mar 2026 07:34:16 +0100 Subject: [PATCH 2/5] print -> tostr needs addressable var Creates temporary for tostr in the print node. --- compiler/xpr.parser.pas | 4 ++-- compiler/xpr.tree.pas | 20 +++++++++++++------- tests/tostr.xpr | 37 +++++++++++++++++-------------------- 3 files changed, 32 insertions(+), 29 deletions(-) diff --git a/compiler/xpr.parser.pas b/compiler/xpr.parser.pas index 59ac190..c7370f5 100644 --- a/compiler/xpr.parser.pas +++ b/compiler/xpr.parser.pas @@ -1475,11 +1475,11 @@ function TParser.ParseTypeDecl(): XTree_Node; Consume(tkEQ, PostInc); if Current.Token = tkKW_CLASS then - Result := ParseClassDecl(Name, declIndent) + Result := ParseClassDecl(Name, myIndent) else begin SetInsesitive(); - Typ := ParseAddType('', True, False, declIndent); + Typ := ParseAddType('', True, False, myIndent); ResetInsesitive(); Result := XTree_TypeDecl.Create(Name, Typ, FContext, DocPos); end; diff --git a/compiler/xpr.tree.pas b/compiler/xpr.tree.pas index 2702573..1f7db43 100644 --- a/compiler/xpr.tree.pas +++ b/compiler/xpr.tree.pas @@ -5720,14 +5720,12 @@ function XTree_Print.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar; i: Int32; argType: XType; argNode, toStrNode, combined: XTree_Node; + argVar: TXprVar; combinedVar: TXprVar; begin if (Self.Args = nil) or (Length(Self.Args) = 0) then ctx.RaiseException(eSyntaxError, 'Print statement requires at least one argument', FDocPos); - // Build the full concatenated string expression at compile time. - // Strings pass through directly; everything else gets .ToStr() called on it. - // Args are joined with a space between them. combined := nil; for i := 0 to High(Self.Args) do begin @@ -5735,14 +5733,22 @@ function XTree_Print.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar; argType := argNode.ResType(); if (argType <> nil) and (argType.BaseType in [xtAnsiString, xtUnicodeString]) then - toStrNode := argNode // already a string, use directly — no quotes + begin + // String - no ToStr needed + toStrNode := argNode; + end else begin + // Compile to a stable var first so SelfExpr has an addressable target + argVar := argNode.Compile(NullResVar, Flags); + argVar := argVar.IfRefDeref(ctx); + toStrNode := XTree_Invoke.Create( XTree_Identifier.Create('ToStr', ctx, FDocPos), [], ctx, FDocPos ); - XTree_Invoke(toStrNode).SelfExpr := argNode; + XTree_Invoke(toStrNode).SelfExpr := + XTree_VarStub.Create(argVar, ctx, FDocPos); end; if combined = nil then @@ -5750,13 +5756,13 @@ function XTree_Print.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar; else combined := XTree_BinaryOp.Create( op_Add, - XTree_BinaryOp.Create(op_Add, combined, XTree_String.Create(' ', ctx, FDocPos), ctx, FDocPos), + XTree_BinaryOp.Create(op_Add, combined, + XTree_String.Create(' ', ctx, FDocPos), ctx, FDocPos), toStrNode, ctx, FDocPos ); end; - // Compile the final combined expression and emit a single PRINT combinedVar := combined.Compile(NullResVar, Flags); if combinedVar.Reference then combinedVar := combinedVar.DerefToTemp(ctx); diff --git a/tests/tostr.xpr b/tests/tostr.xpr index 571f8d8..9f63e7a 100644 --- a/tests/tostr.xpr +++ b/tests/tostr.xpr @@ -1,30 +1,27 @@ -var p:(x,y: int); -p := [100,50] -print p.tostr() +print 'hello world' +print [1,2,3,4] +print 999 + +var p:(x,y: int) = [100,50]; +print p var arr: array of int = [1,2,3,4,5,6,7,8] -print arr.tostr() +print arr var arr2d: array of array of int = [[1,2,3], [4,5,6], [7,8,9]]; -print arr2d.tostr() - -type - TClass = class - var x,y,z: int - - func create(x,y,z:int) - (self.x,self.y,self.z) := [x,y,z] - -var inst := new TClass(1,2,3); - -print inst.tostr() +print arr2d +type TClass = class + var x,y,z: int + func create(x,y,z:int) + (self.x,self.y,self.z) := [x,y,z] +var inst := new TClass(1,2,3); +print inst -type - TPerson = class - var name: String - var age: Int +type TPerson = class + var name: String + var age: Int var p := new TPerson() p.name := 'frank' From 9ba97d00de87df7f0d98729f164c976ffe1ecf41 Mon Sep 17 00:00:00 2001 From: Jarl Holta Date: Wed, 18 Mar 2026 08:10:26 +0100 Subject: [PATCH 3/5] n-dimensional setlen --- compiler/xpr.typeintrinsics.pas | 109 ++++++++++++++++++++++++-------- tests/tostr.xpr | 3 + 2 files changed, 87 insertions(+), 25 deletions(-) diff --git a/compiler/xpr.typeintrinsics.pas b/compiler/xpr.typeintrinsics.pas index 7eaf63a..d8147fe 100644 --- a/compiler/xpr.typeintrinsics.pas +++ b/compiler/xpr.typeintrinsics.pas @@ -70,6 +70,7 @@ TTypeIntrinsics = class(TIntrinsics) function GenerateCollect(SelfType: XType; Args: array of XType): XTree_Function; function GenerateDefault(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateSetLen1D(SelfType: XType; ArgName: string): XTree_Function; function GenerateSetLen(SelfType: XType; Args: array of XType): XTree_Function; end; @@ -684,19 +685,15 @@ function TTypeIntrinsics.GenerateDefault(SelfType: XType; Args: array of XType): Result.InternalFlags:=[]; //allow full free end; -function TTypeIntrinsics.GenerateSetLen(SelfType: XType; Args: array of XType): XTree_Function; +function TTypeIntrinsics.GenerateSetLen1D(SelfType: XType; ArgName: string): XTree_Function; var Body: XTree_ExprList; - ItemType: XType; - PItemType: XType; + ItemType, PItemType: XType; TDisposalProto: XType_Method; TCopyProto: XType_method; begin - if SelfType = nil then - Exit(nil); - - if (Length(Args) <> 1) or not (SelfType is XType_Array) then - Exit(nil); + if SelfType = nil then Exit(nil); + if not (SelfType is XType_Array) then Exit(nil); Body := ExprList(); @@ -704,49 +701,111 @@ function TTypeIntrinsics.GenerateSetLen(SelfType: XType; Args: array of XType): begin Body.List += XTree_Invoke.Create( Id('_AnsiSetLength'), - [Id('self'), Id('NewLength')], + [Id('self'), Id(ArgName)], FContext, FDocPos ); end else begin - ItemType := (SelfType as XType_Array).ItemType; + ItemType := (SelfType as XType_Array).ItemType; PItemType := XType_Pointer.Create(ItemType); FContext.AddManagedType(PItemType); TDisposalProto := XType_Method.Create('_TDisposalMethod', [PItemType], [pbCopy], nil, False); FContext.AddManagedType(TDisposalProto); - TCopyProto := XType_Method.Create('_TCopyMethod', [PItemType,PItemType], [pbRef, pbRef], nil, False); + TCopyProto := XType_Method.Create('_TCopyMethod', [PItemType, PItemType], [pbRef, pbRef], nil, False); FContext.AddManagedType(TCopyProto); Body.List += VarDecl(['dispose'], TDisposalProto); - Body.List += VarDecl(['copy'], TCopyProto); + Body.List += VarDecl(['copy'], TCopyProto); - // --- Step 2: Determine the correct Dispose/Copy intrinsic functions --- if ItemType.IsManagedType(FContext) then begin - Body.List += FContext.GenerateIntrinsics('__pdispose__', [PItemType], nil, '__pdispose__'+TDisposalProto.Hash()); - Body.List += FContext.GenerateIntrinsics('__passign__', [PItemType, PItemType], nil, '__passign__' +TCopyProto.Hash()); + FContext.GenerateIntrinsics('__pdispose__', [PItemType], nil, '__pdispose__' + TDisposalProto.Hash()); + FContext.GenerateIntrinsics('__passign__', [PItemType, PItemType], nil, '__passign__' + TCopyProto.Hash()); - Body.List += Assign(Id('dispose'), Id('__pdispose__'+TDisposalProto.Hash())); - Body.List += Assign(Id('copy'), Id('__passign__' +TCopyProto.Hash())); + Body.List += Assign(Id('dispose'), Id('__pdispose__' + TDisposalProto.Hash())); + Body.List += Assign(Id('copy'), Id('__passign__' + TCopyProto.Hash())); end; Body.List += VarDecl(['raw'], FContext.GetType(xtPointer), SelfAsPtr()); Body.List += Assign(SelfId(), XTree_Invoke.Create( Id('__internal::_ArraySetLength'), - [ // The arguments list: - Id('raw'), - Id('NewLength'), - IntLiteral(ItemType.Size), - Id('dispose'), - Id('copy') - ], + [Id('raw'), Id(ArgName), IntLiteral(ItemType.Size), + Id('dispose'), Id('copy')], FContext, FDocPos )); end; - Result := FunctionDef('SetLen', ['NewLength'], [pbCopy], [FContext.GetType(xtInt)], nil, Body); + + Result := FunctionDef('SetLen', [ArgName], [pbCopy], [FContext.GetType(xtInt)], nil, Body); + Result.SelfType := SelfType; +end; + +// Public entry point - n-dimensional orchestrator +function TTypeIntrinsics.GenerateSetLen(SelfType: XType; Args: array of XType): XTree_Function; +var + Body: XTree_ExprList; + IntType: XType; + NumDims, i: Int32; + ArgNames: TStringArray; + ArgPass: TPassArgsBy; + ArgTypes: XTypeArray; + InnerCallArgs: XNodeArray; + LoopBody: XTree_ExprList; +begin + if SelfType = nil then Exit(nil); + if not (SelfType is XType_Array) then Exit(nil); + + NumDims := Length(Args); + if NumDims = 0 then Exit(nil); + + for i := 0 to NumDims - 1 do + if not (Args[i].BaseType in XprIntTypes) then Exit(nil); + + // Single dimension - delegate entirely to 1D + if NumDims = 1 then + Exit(GenerateSetLen1D(SelfType, 'NewLength')); + + // Multi-dimension - build wrapper that calls 1D then loops inner + IntType := FContext.GetType(xtInt); + + SetLength(ArgNames, NumDims); + SetLength(ArgPass, NumDims); + SetLength(ArgTypes, NumDims); + for i := 0 to NumDims - 1 do + begin + ArgNames[i] := 'Dim' + IntToStr(i); + ArgPass[i] := pbCopy; + ArgTypes[i] := IntType; + end; + + Body := ExprList(); + + // Step 1 — resize outer dimension via 1D core + Body.List += MethodCall(SelfId(), 'SetLen', [Id('Dim0')]); + + // Step 2 — loop over outer, call SetLen(Dim1, Dim2...) on each inner array + SetLength(InnerCallArgs, NumDims - 1); + for i := 1 to NumDims - 1 do + InnerCallArgs[i - 1] := Id('Dim' + IntToStr(i)); + + LoopBody := ExprList([ + MethodCall( + XTree_Index.Create(SelfId(), Id('!sli'), FContext, FDocPos), + 'SetLen', + InnerCallArgs + ) + ]); + + Body.List += ForLoop( + VarDecl(['!sli'], IntType, IntLiteral(0)), + BinOp(op_LTE, Id('!sli'), MethodCall(SelfId(), 'High', [])), + Assign(Id('!sli'), BinOp(op_ADD, Id('!sli'), IntLiteral(1))), + LoopBody + ); + + Result := FunctionDef('SetLen', ArgNames, ArgPass, ArgTypes, nil, Body); Result.SelfType := SelfType; end; diff --git a/tests/tostr.xpr b/tests/tostr.xpr index 9f63e7a..9580e96 100644 --- a/tests/tostr.xpr +++ b/tests/tostr.xpr @@ -11,6 +11,9 @@ print arr var arr2d: array of array of int = [[1,2,3], [4,5,6], [7,8,9]]; print arr2d +arr2d.setlen(2,2) +print arr2d + type TClass = class var x,y,z: int func create(x,y,z:int) From 1cc7a9fd9b5bf3a4c4462e5b707292a746d59e06 Mon Sep 17 00:00:00 2001 From: Jarl Holta Date: Wed, 18 Mar 2026 15:08:15 +0100 Subject: [PATCH 4/5] Many more type methods [jit fix + parsefix] - Fixes a move mistake in x64 machinecode. - Fixes call chaining a.b().c() Adds many many methods for arrays. Mostly experimental stuff. --- compiler/backends/JIT_x64.pas | 10 +- compiler/includes/interpreter.jitcode.inc | 4 +- compiler/xpr.compilercontext.pas | 51 +- compiler/xpr.parser.pas | 30 +- compiler/xpr.tokenizer.pas | 5 +- compiler/xpr.tree.pas | 105 ++- compiler/xpr.typeintrinsics.pas | 861 ++++++++++++++++------ compiler/xpr.types.pas | 2 + system/exception - Copy.xpr | 18 - system/internals - Copy.xpr | 120 --- tests/test_arraymethods.xpr | 311 ++++++++ tests/tostr.xpr | 18 +- 12 files changed, 1124 insertions(+), 411 deletions(-) delete mode 100644 system/exception - Copy.xpr delete mode 100644 system/internals - Copy.xpr create mode 100644 tests/test_arraymethods.xpr diff --git a/compiler/backends/JIT_x64.pas b/compiler/backends/JIT_x64.pas index 9681f65..6c8d00d 100644 --- a/compiler/backends/JIT_x64.pas +++ b/compiler/backends/JIT_x64.pas @@ -81,6 +81,7 @@ TJitEmitter = record procedure MOVZX_Reg_Mem_i16(Reg: EReg; BaseReg: EReg; Offset: Int64); procedure MOV_Reg_Mem_i32(Reg: EReg; BaseReg: EReg; Offset: Int64); procedure MOV_Reg_Mem_i64(Reg: EReg; BaseReg: EReg; Offset: Int64); + procedure MOVSXD_Reg_Mem_i32(Reg: EReg; BaseReg: EReg; Offset: Int64); procedure MOV_Mem_Reg_i8(BaseReg: EReg; Offset: Int64; Reg: EReg); procedure MOV_Mem_Reg_i16(BaseReg: EReg; Offset: Int64; Reg: EReg); procedure MOV_Mem_Reg_i32(BaseReg: EReg; Offset: Int64; Reg: EReg); @@ -533,6 +534,13 @@ procedure TJitEmitter.MOV_Reg_Mem_i64(Reg: EReg; BaseReg: EReg; Offset: Int64); WriteBytes(@Offset, 4); end; +procedure TJitEmitter.MOVSXD_Reg_Mem_i32(Reg: EReg; BaseReg: EReg; Offset: Int64); +begin + // MOVSXD r64, r/m32 — opcode: 48 63 /r (REX.W + 63) + WriteBytes([$48, $63, $80 + (Ord(Reg) * 8) + Ord(BaseReg)]); + WriteBytes(@Offset, 4); +end; + procedure TJitEmitter.MOV_Mem_Reg_i8(BaseReg: EReg; Offset: Int64; Reg: EReg); begin WriteBytes([$88, $80 + (Ord(Reg) * 8) + Ord(BaseReg)]); @@ -977,7 +985,7 @@ procedure TJitEmitter.Load_Int_Operand(const arg: TOperand; Reg: EReg); case BaseJITType(arg.BaseType) of xtInt8: MOVZX_Reg_Mem_i8(Reg, rbx, arg.Data.Addr); xtInt16: MOVZX_Reg_Mem_i16(Reg, rbx, arg.Data.Addr); - xtInt32: MOV_Reg_Mem_i32(Reg, rbx, arg.Data.Addr); + xtInt32: MOVSXD_Reg_Mem_i32(Reg, rbx, arg.Data.Addr); xtInt64: MOV_Reg_Mem_i64(Reg, rbx, arg.Data.Addr); end else diff --git a/compiler/includes/interpreter.jitcode.inc b/compiler/includes/interpreter.jitcode.inc index 770d85d..853aa7c 100644 --- a/compiler/includes/interpreter.jitcode.inc +++ b/compiler/includes/interpreter.jitcode.inc @@ -739,13 +739,13 @@ begin while i <= BC.Code.High do begin // Check if current opcode is eligible for fusion - if CanJITSuper(BC.Code.Data[i]) and (BC.Settings.Data[i].JIT in [1,3]) then + if CanJITSuper(BC.Code.Data[i]) and (BC.Settings.Data[i].JIT in [1,{$IFNDEF CPUX86_64}2,{$ENDIF}3]) then begin n := i; // Find how many eligible opcodes follow while (i <= BC.Code.High) and CanJITSuper(BC.Code.Data[i]) and - (BC.Settings.Data[i].JIT in [1,3]) do + (BC.Settings.Data[i].JIT in [1,{$IFNDEF CPUX86_64}2,{$ENDIF}3]) do Inc(i); // control flow, so what comes before is likely cmp operation diff --git a/compiler/xpr.compilercontext.pas b/compiler/xpr.compilercontext.pas index 84e52b0..d64d124 100644 --- a/compiler/xpr.compilercontext.pas +++ b/compiler/xpr.compilercontext.pas @@ -1698,26 +1698,51 @@ function TCompilerContext.GenerateIntrinsics(Name: string; Arguments: array of X Result := nil; TTypeIntrinsics(TypeIntrinsics).FContext := Self; case Lowercase(Name) of - '_refcnt': Result := (TypeIntrinsics as TTypeIntrinsics).GenerateRefcount(SelfType, Arguments); - 'high' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateHigh(SelfType, Arguments); - 'len' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateLen(SelfType, Arguments); - 'setlen' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateSetLen(SelfType, Arguments); - 'collect': Result := (TypeIntrinsics as TTypeIntrinsics).GenerateCollect(SelfType, Arguments); - 'tostr' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateToStr(SelfType, Arguments); - 'default': Result := (TypeIntrinsics as TTypeIntrinsics).GenerateDefault(SelfType, Arguments); - - '__passign__' : Result := (TypeIntrinsics as TTypeIntrinsics).GeneratePtrAssign(SelfType, Arguments, CompileAs); - '__pdispose__': Result := (TypeIntrinsics as TTypeIntrinsics).GeneratePtrDispose(SelfType, Arguments, CompileAs); + // Core + '_refcnt' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateRefcount(SelfType, Arguments); + 'high' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateHigh(SelfType, Arguments); + 'len' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateLen(SelfType, Arguments); + 'setlen' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateSetLen(SelfType, Arguments); + 'collect' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateCollect(SelfType, Arguments); + 'tostr' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateToStr(SelfType, Arguments); + 'default' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateDefault(SelfType, Arguments); + '__passign__' : Result := (TypeIntrinsics as TTypeIntrinsics).GeneratePtrAssign(SelfType, Arguments, CompileAs); + '__pdispose__' : Result := (TypeIntrinsics as TTypeIntrinsics).GeneratePtrDispose(SelfType, Arguments, CompileAs); + '__eq__' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateEq(SelfType, Arguments); + '__neq__' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateNeq(SelfType, Arguments); + + // Tier 1 + 'push' : Result := (TypeIntrinsics as TTypeIntrinsics).GeneratePush(SelfType, Arguments); + 'pop' : Result := (TypeIntrinsics as TTypeIntrinsics).GeneratePop(SelfType, Arguments); + 'slice' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateSlice(SelfType, Arguments); + 'copy' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateCopy(SelfType, Arguments); + 'contains' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateContains(SelfType, Arguments); + 'indexof' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateIndexOf(SelfType, Arguments); + 'delete' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateDelete(SelfType, Arguments); + 'insert' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateInsert(SelfType, Arguments); + 'remove' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateRemove(SelfType, Arguments); + // Tier 2 + 'reverse' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateReverse(SelfType, Arguments); + 'sort' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateSort(SelfType, Arguments); + 'concat' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateConcat(SelfType, Arguments); + // Tier 3 — numeric + 'sum' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateSum(SelfType, Arguments); + 'min' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateMin(SelfType, Arguments); + 'max' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateMax(SelfType, Arguments); + 'mean' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateMean(SelfType, Arguments); + 'variance' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateVariance(SelfType, Arguments); + 'stddev' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateStdDev(SelfType, Arguments); + 'median' : Result := (TypeIntrinsics as TTypeIntrinsics).GenerateMedian(SelfType, Arguments); end; if (Result <> nil) then begin - CURRENT_SCOPE := Result.FContext.Scope; - Result.FContext.Scope:=GLOBAL_SCOPE; + CURRENT_SCOPE := Result.FContext.Scope; + Result.FContext.Scope := GLOBAL_SCOPE; Self.DelayedNodes += Result; Result.Compile(NullResVar, []); XTree_Function(Result).PreCompiled := True; - Result.FContext.Scope:=CURRENT_SCOPE; + Result.FContext.Scope := CURRENT_SCOPE; end; end; diff --git a/compiler/xpr.parser.pas b/compiler/xpr.parser.pas index c7370f5..47298a4 100644 --- a/compiler/xpr.parser.pas +++ b/compiler/xpr.parser.pas @@ -1762,8 +1762,19 @@ function TParser.RHSExpr(Left: XTree_Node; leftPrecedence: Int8=0): XTree_Node; if AsOperator(op.Token) = op_Invoke then begin - Result := XTree_Invoke.Create( - Left, ParseExpressionList(True, True), FContext, Left.FDocPos); + if Left is XTree_Field then + begin + // a.Method() or a.Len().ToStr() - extract SelfExpr from the field node + // so the object side goes through PushArgsToStack's temp-spill path + Result := XTree_Invoke.Create( + XTree_Field(Left).Right, // method name identifier + ParseExpressionList(True, True), FContext, Left.FDocPos); + XTree_Invoke(Result).SelfExpr := XTree_Field(Left).Left; // the object + end + else + Result := XTree_Invoke.Create( + Left, ParseExpressionList(True, True), FContext, Left.FDocPos); + Consume(tkRPARENTHESES); if NextIf(tkCOLON) then begin @@ -1778,11 +1789,16 @@ function TParser.RHSExpr(Left: XTree_Node; leftPrecedence: Int8=0): XTree_Node; Right := ParsePrimary(); if Right = nil then FContext.RaiseException(eInvalidExpression, DocPos); - nextPrecedence := OperatorPrecedence(); - if precedence < nextPrecedence then - Right := RHSExpr(Right, precedence + 1) - else if precedence = nextPrecedence then - Right := RHSExpr(Right, precedence + OperatorAssoc()); + // Dot operator never recurses right - each segment is just one identifier. + // The outer loop handles a.B().C() by converting Field+Invoke repeatedly. + if AsOperator(op.Token) <> op_Dot then + begin + nextPrecedence := OperatorPrecedence(); + if precedence < nextPrecedence then + Right := RHSExpr(Right, precedence + 1) + else if precedence = nextPrecedence then + Right := RHSExpr(Right, precedence + OperatorAssoc()); + end; Left := Merge(AsOperator(op.Token), Left, Right); end; diff --git a/compiler/xpr.tokenizer.pas b/compiler/xpr.tokenizer.pas index d0e3e03..85a37ee 100644 --- a/compiler/xpr.tokenizer.pas +++ b/compiler/xpr.tokenizer.pas @@ -497,10 +497,7 @@ procedure TTokenizer.AddString(); Inc(pos); while (Current <> data[i]) and (Current <> #0) do Next_CheckNewline; str := Copy(data, i+1, pos-i-1); - if Length(str) <= 1 then - Self.Append(tkCHAR, str) - else - Self.Append(tkSTRING, str); + Self.Append(tkSTRING, str); Inc(pos); end; diff --git a/compiler/xpr.tree.pas b/compiler/xpr.tree.pas index 1f7db43..348e263 100644 --- a/compiler/xpr.tree.pas +++ b/compiler/xpr.tree.pas @@ -693,6 +693,13 @@ function CompileAST(astnode: XTree_Node; writeTree: Boolean = False; doFree: Boo i: Int32; managed: TXprVarList; begin + if writeTree then + begin + WriteLn('----| TREE STRUCTURE |--------------------------------------------'); + WriteFancy(astnode.ToString()); + WriteLn('------------------------------------------------------------------'+#13#10); + end; + astnode.Compile(NullResVar, []); // Finalize globals explicitly - EmitFinalizeVar skips globals by default, @@ -714,13 +721,6 @@ function CompileAST(astnode: XTree_Node; writeTree: Boolean = False; doFree: Boo astnode.DelayedCompile(NullResVar); end; - if writeTree then - begin - WriteLn('----| TREE STRUCTURE |--------------------------------------------'); - WriteFancy(astnode.ToString()); - WriteLn('------------------------------------------------------------------'+#13#10); - end; - Result := astnode.ctx.Intermediate; end; @@ -3034,6 +3034,7 @@ function XTree_Field.ResType(): XType; end else begin + WriteFancy(Right.ToString()); ctx.RaiseException('Unsupported right side in field access expression', FDocPos); end; @@ -3124,6 +3125,7 @@ function XTree_Field.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar; Result := Invoke.Compile(Dest, Flags); end else begin + WriteFancy(Right.ToString()); ctx.RaiseException('Unsupported right side in field access expression', FDocPos); end; end; @@ -3199,7 +3201,15 @@ function XTree_Field.CompileLValue(Dest: TXprVar): TXprVar; end else ctx.RaiseExceptionFmt('Cannot access fields on non-record/class type `%s`', [Self.Left.ResType().ToString], Self.Left.FDocPos); - end else + end + else if Self.Right is XTree_Invoke then + begin + // Method call result - not directly addressable. + // Return NullResVar so PushArgsToStack falls back to the spill path, + // which will call Compile (not CompileLValue) and get the value correctly. + Result := NullResVar; + end + else Result := Inherited; // Will raise "Cannot be written to" end; @@ -3350,7 +3360,7 @@ function XTree_Invoke.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar; procedure PushArgsToStack(); var i, paramIndex, impliedArgs: Int32; - initialArg, finalArg: TXprVar; + initialArg, finalArg, tempVal: TXprVar; expectedType: XType; begin // XXX: If nested then self arg is illegal! @@ -3363,7 +3373,17 @@ function XTree_Invoke.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar; impliedArgs := 1; SelfVar := SelfExpr.CompileLValue(NullVar); if SelfVar = NullResVar then - ctx.RaiseException('Self expression compiled to NullResVar', SelfExpr.FDocPos); + begin + // Not addressable - spill to temp + tempVal := SelfExpr.Compile(NullResVar, Flags); + tempVal := tempVal.IfRefDeref(ctx); + with XTree_VarStub.Create(tempVal, ctx, SelfExpr.FDocPos) do + try + SelfVar := CompileLValue(NullResVar); + finally + Free; + end; + end; if SelfVar.Reference then Self.Emit(GetInstr(icPUSHREF, [SelfVar]), FDocPos) else Self.Emit(GetInstr(icPUSH, [SelfVar]), FDocPos); @@ -3614,7 +3634,8 @@ function XTree_Invoke.CompileLValue(Dest: TXprVar): TXprVar; Exit; end; - ctx.RaiseException('Functions can not be written to', FDocPos); + // Not addressable - return NullResVar so PushArgsToStack can spill to temp + Result := NullResVar; end; @@ -5269,6 +5290,68 @@ function XTree_BinaryOp.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar; Assert(LeftVar.VarType <> nil); Assert(RightVar.VarType <> nil); + // String/Char concatenation — promote chars to strings before adding + if (OP = op_ADD) and + (Left.ResType().BaseType in XprStringTypes + XprCharTypes) and + (Right.ResType().BaseType in XprStringTypes + XprCharTypes) then + begin + // Determine target string type — unicode wins over ansi + if (Left.ResType().BaseType = xtUnicodeString) or + (Right.ResType().BaseType = xtUnicodeString) or + (Left.ResType().BaseType = xtUnicodeChar) or + (Right.ResType().BaseType = xtUnicodeChar) then + CommonTypeVar := ctx.GetType(xtUnicodeString) + else + CommonTypeVar := ctx.GetType(xtAnsiString); + + LeftVar := Left.Compile(NullResVar, Flags).IfRefDeref(ctx); + RightVar := Right.Compile(NullResVar, Flags).IfRefDeref(ctx); + + // Upcast chars to string if needed + LeftVar := ctx.EmitUpcastIfNeeded(LeftVar, CommonTypeVar, False); + RightVar := ctx.EmitUpcastIfNeeded(RightVar, CommonTypeVar, False); + + Result := Dest; + if Result = NullResVar then + Result := ctx.GetTempVar(CommonTypeVar); + + Instr := LeftVar.VarType.EvalCode(op_ADD, RightVar.VarType); + if Instr = icNOOP then + ctx.RaiseExceptionFmt(eNotCompatible3, + [OperatorToStr(OP), BT2S(Left.ResType.BaseType), BT2S(Right.ResType.BaseType)], FDocPos); + + Self.Emit(GetInstr(Instr, [LeftVar, RightVar, Result]), FDocPos); + Exit; + end; + + // array = array, and array != array + // this includes strings, fall back to internal method + if (OP in [op_EQ, op_NEQ]) and + (Left.ResType().BaseType in [xtAnsiString, xtUnicodeString, xtArray]) and + (Right.ResType().BaseType = Left.ResType().BaseType) then + begin + WriteLn('Using EQ method!'); + with XTree_Invoke.Create( + XTree_Identifier.Create('__eq__', ctx, FDocPos), + [Right], ctx, FDocPos) do + try + SelfExpr := Left; + Result := Compile(Dest, Flags); + if OP = op_NEQ then begin // wrap in NOT + with XTree_UnaryOp.Create(op_NOT, + XTree_VarStub.Create(Result, ctx, FDocPos), ctx, FDocPos) do + try + Result := Compile(Dest, Flags); + finally + Free; + end; + end; + finally + Free; + end; + Exit(); + end; + // Emit the binary operation. This logic remains the same. Instr := LeftVar.VarType.EvalCode(OP, RightVar.VarType); if Instr <> icNOOP then diff --git a/compiler/xpr.typeintrinsics.pas b/compiler/xpr.typeintrinsics.pas index d8147fe..a189241 100644 --- a/compiler/xpr.typeintrinsics.pas +++ b/compiler/xpr.typeintrinsics.pas @@ -3,11 +3,11 @@ Author: Jarl K. Holta License: GNU Lesser GPL (http://www.gnu.org/licenses/lgpl.html) - This unit provides functions to generate Abstract Syntax Tree (AST) branches - for intrinsic array operations like Length and SetLength. - These operations are implemented by synthesizing calls to low-level - memory management functions and direct manipulation of the array's - internal [refcount, length, dataptr] structure. + Generates AST branches for intrinsic type methods. + + Generators that need compile-time type information (sizes, field names, + disposal function hashes) use the AST builder helpers. Generators whose + bodies are pure Express logic use Parse() - much cleaner. } {$I header.inc} {$hints off} @@ -23,11 +23,153 @@ interface xpr.Errors, xpr.CompilerContext; +const + // Pure Express source strings for Parse-based generators. + // Variable names must match the FunctionDef arg names below. + + SRC_CONTAINS = + 'var h := self.High()' + LineEnding + + '@opt(''jit:off; rangechecks: on'')' + LineEnding + + 'for(var i := 0; i <= h; i += 1) do' + LineEnding + + ' if(self[i] = Value)then' + LineEnding + + ' return True' + LineEnding + + 'return False' + LineEnding; + + SRC_INDEXOF = + 'var h := self.High()' + LineEnding + + '@opt(''jit:off; rangechecks: on'')' + LineEnding + + 'for(var i := 0; i <= h; i += 1) do' + LineEnding + + ' if(self[i] = Value)then' + LineEnding + + ' return i' + LineEnding + + 'return -1' + LineEnding; + + SRC_DELETE = + 'if(self = nil) then return' + LineEnding + + 'var h := self.High()' + LineEnding + + '@opt(''jit:off; rangechecks: on'')' + LineEnding + + 'for(var j := Index; j < h; j += 1) do' + LineEnding + + ' self[j] := self[j + 1]' + LineEnding + + 'self.SetLen(self.Len() - 1)' + LineEnding; + + SRC_INSERT = + 'if(self = nil) then return' + LineEnding + + 'self.SetLen(self.Len() + 1)' + LineEnding + + 'var h := self.High()' + LineEnding + + '@opt(''jit:off; rangechecks: on'')' + LineEnding + + 'for(var j := h; j > Index; j -= 1) do' + LineEnding + + ' self[j] := self[j - 1]' + LineEnding + + 'self[Index] := Value' + LineEnding; + + SRC_REMOVE = + 'var i := self.IndexOf(Value)' + LineEnding + + 'if(i >= 0) then' + LineEnding + + ' self.Delete(i)' + LineEnding; + + SRC_REVERSE = + 'if(self = nil) then return' + LineEnding + + 'var l := self.Len()' + LineEnding + + '@opt(''jit:off; rangechecks: on'')' + LineEnding + + 'for(var lo := 0; lo < l / 2; lo += 1) do' + LineEnding + + ' var hi := (l-1) - lo' + LineEnding + + ' var tmp := self[lo]' + LineEnding + + ' self[lo] := self[hi]' + LineEnding + + ' self[hi] := tmp' + LineEnding; + + SRC_SORT = + 'if(self = nil) then return' + LineEnding + + 'var gaps: array of Int32' + LineEnding + + 'gaps := [3735498,1769455,835387,392925,184011,85764,39744,18298,8359,3785,1695,749,326,138,57,23,9,4,1]' + LineEnding + + 'for(var gi := 0; gi <= gaps.High(); gi += 1) do' + LineEnding + + ' var gap := gaps[gi]' + LineEnding + + ' if(gap >= self.Len()) then continue' + LineEnding + + ' var h := self.High()' + LineEnding + + ' @opt(''jit:off; rangechecks: on'')' + LineEnding + + ' for(var i := gap; i <= h; i += 1) do' + LineEnding + + ' var key := self[i]' + LineEnding + + ' var j := i - gap' + LineEnding + + ' while(j >= 0 and self[j] > key) do' + LineEnding + + ' self[j + gap] := self[j]' + LineEnding + + ' j -= gap' + LineEnding + + ' self[j + gap] := key' + LineEnding + + 'gaps.SetLen(0)'; + + SRC_CONCAT = + 'if(self = nil) then return Other.Copy()' + LineEnding + + 'if(Other = nil) then return self.Copy()' + LineEnding + + 'var lenA := self.Len()' + LineEnding + + 'var lenB := Other.Len()' + LineEnding + + 'result := self.Copy()' + LineEnding + + 'result.SetLen(lenA + lenB)' + LineEnding + + '@opt(''jit:off; rangechecks: on'')' + LineEnding + + 'for(var j := 0; j < lenB; j += 1) do' + LineEnding + + ' result[lenA + j] := Other[j]' + LineEnding + + 'return result' + LineEnding; + + SRC_SUM = + 'if(self = nil) then return 0' + LineEnding + + 'var s := self[0]' + LineEnding + + 'var h := self.High()' + LineEnding + + '@opt(''jit:off; rangechecks: on'')' + LineEnding + + 'for(var i := 1; i <= h; i += 1) do' + LineEnding + + ' s += self[i]' + LineEnding + + 'return s' + LineEnding; + + SRC_MIN = + 'if(self = nil) then return 0' + LineEnding + + 'Result := self[0]' + LineEnding + + 'var h := self.High()' + LineEnding + + '@opt(''jit:off; rangechecks: on'')' + LineEnding + + 'for(var i := 1; i <= h; i += 1) do' + LineEnding + + ' if(self[i] < Result) then' + LineEnding + + ' Result := self[i]' + LineEnding + + 'return Result' + LineEnding; + + SRC_MAX = + 'if(self = nil) then return 0' + LineEnding + + 'Result := self[0]' + LineEnding + + 'var h := self.High()' + LineEnding + + '@opt(''jit:off; rangechecks: on'')' + LineEnding + + 'for(var i := 1; i <= h; i += 1) do' + LineEnding + + ' if(self[i] > Result) then' + LineEnding + + ' Result := self[i]' + LineEnding + + 'return Result' + LineEnding; + + SRC_MEAN = + 'if(self = nil) then return 0.0' + LineEnding + + 'if(self.Len() = 0) then return 0.0' + LineEnding + + 'return Double(self.Sum()) / Double(self.Len())' + LineEnding; + + SRC_VARIANCE = + 'if(self = nil) then return 0.0' + LineEnding + + 'if(self.Len() = 0) then return 0.0' + LineEnding + + 'var mean := self.Mean()' + LineEnding + + 'var sum := 0.0' + LineEnding + + 'var h := self.High()' + LineEnding + + '@opt(''jit:off; rangechecks: on'')' + LineEnding + + 'for(var i := 0; i <= h; i += 1) do' + LineEnding + + ' var d := Double(self[i]) - mean' + LineEnding + + ' sum += d * d' + LineEnding + + 'return sum / Double(self.Len())' + LineEnding; + + SRC_STDDEV = + 'return Sqrt(self.Variance())' + LineEnding; + + SRC_MEDIAN = + 'if(self = nil) then return 0.0' + LineEnding + + 'if(self.Len() = 0) then return 0.0' + LineEnding + + 'var tmp := self.Copy()' + LineEnding + + 'tmp.Sort()' + LineEnding + + 'var mid := tmp.Len() / 2' + LineEnding + + 'if(tmp.Len() % 2 = 0) then' + LineEnding + + ' return (Double(tmp[mid - 1]) + Double(tmp[mid])) / 2.0' + LineEnding + + 'return Double(tmp[mid])' + LineEnding; + type TTypeIntrinsics = class(TIntrinsics) public {** AST Node Factory Helpers **} function IntLiteral(Value: Int64): XTree_Int; + function FloatLiteral(Value: Double): XTree_Float; function StringLiteral(const Value: string): XTree_String; function NilPointer: XTree_Int; function Id(const Name: string): XTree_Identifier; @@ -39,14 +181,16 @@ TTypeIntrinsics = class(TIntrinsics) function Assign(LHS, RHS: XTree_Node): XTree_Assign; function Call(FuncName: string; Args: XNodeArray): XTree_Invoke; function MethodCall(Target: XTree_Node; FuncName: string; Args: XNodeArray): XTree_Invoke; + function Index(ArrExpr, IdxExpr: XTree_Node): XTree_Index; function ReturnStmt(Expr: XTree_Node = nil): XTree_Return; function ExprList(Nodes: XNodeArray = nil): XTree_ExprList; function VarDecl(Names: TStringArray; VarType: XType; AExpr: XTree_Node=nil): XTree_VarDecl; function IfStmt(ACond: XTree_Node; AThenBody, AElseBody: XTree_Node): XTree_If; function ForLoop(Init, Cond, Inc: XTree_Node; Body: XTree_ExprList): XTree_For; + function WhileLoop(Cond: XTree_Node; Body: XTree_ExprList): XTree_While; {** Common Action Helpers **} - function ArrayHeaderField(ArrayExpr: XTree_Node; Index: Integer): XTree_Index; + function ArrayHeaderField(ArrayExpr: XTree_Node; Idx: Integer): XTree_Index; function ArrayRefcount(ArrayExpr: XTree_Node): XTree_Index; function ArrayHighIndex(ArrayExpr: XTree_Node): XTree_Index; function ArrayLength(ArrayExpr: XTree_Node): XTree_BinaryOp; @@ -59,19 +203,40 @@ TTypeIntrinsics = class(TIntrinsics) constructor Create(AContext: TCompilerContext; ADocPos: TDocPos); - + // AST-built (require compile-time type data) function GenerateRefcount(SelfType: XType; Args: array of XType): XTree_Function; function GenerateHigh(SelfType: XType; Args: array of XType): XTree_Function; function GenerateLen(SelfType: XType; Args: array of XType): XTree_Function; function GenerateToStr(SelfType: XType; Args: array of XType): XTree_Function; - function GeneratePtrAssign(SelfType: XType; Args: array of XType; FuncName: string = ''): XTree_Function; function GeneratePtrDispose(SelfType: XType; Args: array of XType; FuncName: string = ''): XTree_Function; - function GenerateCollect(SelfType: XType; Args: array of XType): XTree_Function; function GenerateDefault(SelfType: XType; Args: array of XType): XTree_Function; function GenerateSetLen1D(SelfType: XType; ArgName: string): XTree_Function; function GenerateSetLen(SelfType: XType; Args: array of XType): XTree_Function; + function GeneratePush(SelfType: XType; Args: array of XType): XTree_Function; + function GeneratePop(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateSlice(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateCopy(SelfType: XType; Args: array of XType): XTree_Function; + + // Parse-based (pure Express logic) + function GenerateEq(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateNeq(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateContains(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateIndexOf(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateDelete(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateInsert(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateRemove(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateReverse(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateSort(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateConcat(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateSum(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateMin(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateMax(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateMean(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateVariance(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateStdDev(SelfType: XType; Args: array of XType): XTree_Function; + function GenerateMedian(SelfType: XType; Args: array of XType): XTree_Function; end; implementation @@ -83,16 +248,16 @@ implementation const ARRAY_HEADER_SIZE: Int32 = 2 * SizeOf(SizeInt); -{ TTypeIntrinsics - Constructor } - constructor TTypeIntrinsics.Create(AContext: TCompilerContext; ADocPos: TDocPos); begin inherited Create; FContext := AContext; - FDocPos := ADocPos; + FDocPos := ADocPos; end; -{ TTypeIntrinsics - AST Node Factory Helpers } +{ ============================================================ } +{ AST Node Factory Helpers } +{ ============================================================ } function TTypeIntrinsics.IntLiteral(Value: Int64): XTree_Int; begin @@ -101,6 +266,13 @@ function TTypeIntrinsics.IntLiteral(Value: Int64): XTree_Int; Result.Value := Value; end; +function TTypeIntrinsics.FloatLiteral(Value: Double): XTree_Float; +begin + Result := XTree_Float.Create(FloatToStr(Value), FContext, FDocPos); + Result.FResType := FContext.GetType(xtDouble); + Result.Value := Value; +end; + function TTypeIntrinsics.StringLiteral(const Value: string): XTree_String; begin Result := XTree_String.Create(Value, FContext, FDocPos); @@ -125,8 +297,8 @@ function TTypeIntrinsics.SelfId: XTree_Identifier; function TTypeIntrinsics.SelfAsPtr: XTree_Identifier; begin - Result := Id('Self'); - Result.FResType := FContext.GetType(xtPointer); + Result := Id('Self'); + Result.FResType := FContext.GetType(xtPointer); end; function TTypeIntrinsics.AddrOf(ANode: XTree_Node): XTree_UnaryOp; @@ -142,7 +314,6 @@ function TTypeIntrinsics.Deref(APointerExpr: XTree_Node; AType: XType=nil): XTre Result.FResType := AType; end; - function TTypeIntrinsics.BinOp(Op: EOperator; Left, Right: XTree_Node): XTree_BinaryOp; begin Result := XTree_BinaryOp.Create(Op, Left, Right, FContext, FDocPos); @@ -167,6 +338,11 @@ function TTypeIntrinsics.MethodCall(Target: XTree_Node; FuncName: string; Args: Result := InvokeNode; end; +function TTypeIntrinsics.Index(ArrExpr, IdxExpr: XTree_Node): XTree_Index; +begin + Result := XTree_Index.Create(ArrExpr, IdxExpr, FContext, FDocPos); +end; + function TTypeIntrinsics.ReturnStmt(Expr: XTree_Node = nil): XTree_Return; begin Result := XTree_Return.Create(Expr, FContext, FDocPos); @@ -200,9 +376,9 @@ function TTypeIntrinsics.IfStmt(ACond: XTree_Node; AThenBody, AElseBody: XTree_N Conds[0] := ACond; if (AThenBody <> nil) and (AThenBody is XTree_ExprList) then - ThenList := XTree_ExprList(AThenBody) + ThenList := XTree_ExprList(AThenBody) else - ThenList := ExprList([AThenBody]); + ThenList := ExprList([AThenBody]); SetLength(Bodys, 1); Bodys[0] := ThenList; @@ -224,13 +400,18 @@ function TTypeIntrinsics.ForLoop(Init, Cond, Inc: XTree_Node; Body: XTree_ExprLi Result := XTree_For.Create(Init, Cond, Inc, Body, FContext, FDocPos); end; +function TTypeIntrinsics.WhileLoop(Cond: XTree_Node; Body: XTree_ExprList): XTree_While; +begin + Result := XTree_While.Create(Cond, Body, FContext, FDocPos); +end; +{ ============================================================ } +{ Common Action Helpers } +{ ============================================================ } -{ TTypeIntrinsics - Common Action Helpers } - -function TTypeIntrinsics.ArrayHeaderField(ArrayExpr: XTree_Node; Index: Integer): XTree_Index; +function TTypeIntrinsics.ArrayHeaderField(ArrayExpr: XTree_Node; Idx: Integer): XTree_Index; begin - Result := XTree_Index.Create(ArrayExpr, IntLiteral(Index), FContext, FDocPos); + Result := XTree_Index.Create(ArrayExpr, IntLiteral(Idx), FContext, FDocPos); Result.FResType := FContext.GetType(xtInt); Result.ForceTypeSize := SizeOf(SizeInt); end; @@ -256,36 +437,29 @@ function TTypeIntrinsics.ReturnIfNil(PtrExpr: XTree_Node): XTree_If; Result := IfStmt(BinOp(op_EQ, PtrExpr, NilPointer), ReturnStmt(), nil); end; -// internal methods default to no collecting / finalizing var (no free) -function TTypeIntrinsics.FunctionDef(FuncName: string; ArgNames: TStringArray; ByRef: TPassArgsBy; ArgTypes: XTypeArray; ReturnType: XType; Body: XTree_ExprList): XTree_Function; +function TTypeIntrinsics.FunctionDef(FuncName: string; ArgNames: TStringArray; ByRef: TPassArgsBy; + ArgTypes: XTypeArray; ReturnType: XType; Body: XTree_ExprList): XTree_Function; begin Result := XTree_Function.Create(FuncName, ArgNames, ByRef, ArgTypes, ReturnType, Body, FContext, FDocPos); Result.InternalFlags += [cfNoCollect]; end; - - -{ TTypeIntrinsics - Intrinsic Function Generators } +{ ============================================================ } +{ AST-built generators } +{ ============================================================ } function TTypeIntrinsics.GenerateRefcount(SelfType: XType; Args: array of XType): XTree_Function; var Body: XTree_ExprList; - ReturnValueNode: XTree_Node; begin - if SelfType = nil then - Exit(nil); - - if (Length(Args) > 0) or (not (SelfType.BaseType in XprRefcountedTypes)) then - Exit(nil); - - ReturnValueNode := Self.ArrayRefcount(SelfId); + if SelfType = nil then Exit(nil); + if (Length(Args) > 0) or not (SelfType.BaseType in XprRefcountedTypes) then Exit(nil); Body := ExprList([ IfStmt( BinOp(op_NEQ, SelfId, NilPointer), - ReturnStmt(ReturnValueNode), - ReturnStmt(IntLiteral(0)) - ) + ReturnStmt(ArrayRefcount(SelfId)), + ReturnStmt(IntLiteral(0))) ]); Result := FunctionDef('_refcnt', [], nil, [], FContext.GetType(xtInt), Body); @@ -297,13 +471,10 @@ function TTypeIntrinsics.GenerateHigh(SelfType: XType; Args: array of XType): XT Body: XTree_ExprList; ReturnValueNode: XTree_Node; begin - if SelfType = nil then - Exit(nil); - - if (Length(Args) > 0) or not ((SelfType is XType_Array) or (SelfType is XType_String)) then - Exit(nil); + if SelfType = nil then Exit(nil); + if (Length(Args) > 0) or not ((SelfType is XType_Array) or (SelfType is XType_String)) then Exit(nil); - if (SelfType is XType_String) then + if SelfType is XType_String then ReturnValueNode := BinOp(op_Sub, ArrayHighIndex(SelfId), IntLiteral(1)) else ReturnValueNode := ArrayHighIndex(SelfId); @@ -312,8 +483,7 @@ function TTypeIntrinsics.GenerateHigh(SelfType: XType; Args: array of XType): XT IfStmt( BinOp(op_NEQ, SelfId, NilPointer), ReturnStmt(ReturnValueNode), - ReturnStmt(IntLiteral(-1)) - ) + ReturnStmt(IntLiteral(-1))) ]); Result := FunctionDef('High', [], nil, [], FContext.GetType(xtInt), Body); @@ -323,19 +493,12 @@ function TTypeIntrinsics.GenerateHigh(SelfType: XType; Args: array of XType): XT function TTypeIntrinsics.GenerateLen(SelfType: XType; Args: array of XType): XTree_Function; var Body: XTree_ExprList; - ResultVar: XTree_Identifier; LengthValueNode: XTree_Node; begin - if SelfType = nil then - Exit(nil); - - if (Length(Args) > 0) or not ((SelfType is XType_Array) or (SelfType is XType_String)) then - Exit(nil); - - ResultVar := Id('Result'); + if SelfType = nil then Exit(nil); + if (Length(Args) > 0) or not ((SelfType is XType_Array) or (SelfType is XType_String)) then Exit(nil); - // pascal strings are tricky.. They store LENGTH unlike arrays. - if SelfType is XType_string then + if SelfType is XType_String then LengthValueNode := ArrayHighIndex(SelfId) else LengthValueNode := ArrayLength(SelfId); @@ -343,26 +506,23 @@ function TTypeIntrinsics.GenerateLen(SelfType: XType; Args: array of XType): XTr Body := ExprList([ IfStmt( BinOp(op_NEQ, SelfId, NilPointer), - Assign(ResultVar, LengthValueNode), - Assign(ResultVar, IntLiteral(0)) - ), - ReturnStmt(ResultVar) + Assign(Id('Result'), LengthValueNode), + Assign(Id('Result'), IntLiteral(0))), + ReturnStmt(Id('Result')) ]); Result := FunctionDef('Len', [], nil, [], FContext.GetType(xtInt), Body); Result.SelfType := SelfType; end; - function TTypeIntrinsics.GenerateToStr(SelfType: XType; Args: array of XType): XTree_Function; var Body: XTree_ExprList; ReturnNode, ConcatNode: XTree_Node; StringType, IntType: XType; RecType: XType_Record; - ClassTyp: XType_Class; + ClassT: XType_Class; i: Int32; - ItemExpr: XTree_Node; begin if SelfType = nil then Exit(nil); if Length(Args) > 0 then Exit(nil); @@ -373,18 +533,12 @@ function TTypeIntrinsics.GenerateToStr(SelfType: XType; Args: array of XType): X case SelfType.BaseType of xtAnsiString, xtUnicodeString: - // Wrap in single quotes so nested containers look like initializers - // 'hello' -> '''hello''' - ReturnNode := BinOp(op_Add, - StringLiteral(''''), - BinOp(op_Add, SelfId(), StringLiteral('''')) - ); + ReturnNode := BinOp(op_Add, StringLiteral(''''), + BinOp(op_Add, SelfId(), StringLiteral(''''))); xtAnsiChar, xtUnicodeChar: - ReturnNode := BinOp(op_Add, - StringLiteral(''''), - BinOp(op_Add, SelfId(), StringLiteral('''')) - ); + ReturnNode := BinOp(op_Add, StringLiteral(''''), + BinOp(op_Add, SelfId(), StringLiteral(''''))); xtInt8..xtUInt64: ReturnNode := Call('IntToStr', [SelfId()]); @@ -395,53 +549,30 @@ function TTypeIntrinsics.GenerateToStr(SelfType: XType; Args: array of XType): X xtBoolean: ReturnNode := XTree_IfExpr.Create( SelfId(), StringLiteral('True'), StringLiteral('False'), - FContext, FDocPos - ); + FContext, FDocPos); xtPointer: ReturnNode := Call('PtrToStr', [SelfId()]); xtArray: begin - // Generate: - // if self = nil then return '[]' - // var !r := '[' - // for(var !i := 0; !i <= self.High(); !i := !i + 1) - // if !i > 0 then !r := !r + ', ' - // !r := !r + self[!i].ToStr() - // !r := !r + ']' - // return !r - Body.List += IfStmt( - BinOp(op_EQ, SelfId(), NilPointer()), - ReturnStmt(StringLiteral('[]')), - nil - ); - + Body.List += IfStmt(BinOp(op_EQ, SelfId(), NilPointer()), + ReturnStmt(StringLiteral('[]')), nil); Body.List += VarDecl(['!r'], StringType, StringLiteral('[')); - - ItemExpr := XTree_Index.Create(SelfId(), Id('!i'), FContext, FDocPos); - Body.List += ForLoop( VarDecl(['!i'], IntType, IntLiteral(0)), BinOp(op_LTE, Id('!i'), MethodCall(SelfId(), 'High', [])), Assign(Id('!i'), BinOp(op_ADD, Id('!i'), IntLiteral(1))), ExprList([ - IfStmt( - BinOp(op_GT, Id('!i'), IntLiteral(0)), + IfStmt(BinOp(op_GT, Id('!i'), IntLiteral(0)), Assign(Id('!r'), BinOp(op_ADD, Id('!r'), StringLiteral(', '))), - nil - ), - Assign(Id('!r'), - BinOp(op_ADD, Id('!r'), - MethodCall(ItemExpr, 'ToStr', []) - ) - ) + nil), + Assign(Id('!r'), BinOp(op_ADD, Id('!r'), + MethodCall(Index(SelfId(), Id('!i')), 'ToStr', []))) ]) ); - Body.List += Assign(Id('!r'), BinOp(op_ADD, Id('!r'), StringLiteral(']'))); Body.List += ReturnStmt(Id('!r')); - Result := FunctionDef('ToStr', [], nil, [], StringType, Body); Result.SelfType := SelfType; Result.InternalFlags := []; @@ -450,13 +581,10 @@ function TTypeIntrinsics.GenerateToStr(SelfType: XType; Args: array of XType): X xtRecord: begin - // Generate: '[' + field1.ToStr() + ', ' + field2.ToStr() + ... + ']' RecType := SelfType as XType_Record; - if RecType.FieldNames.Size = 0 then - begin - ReturnNode := StringLiteral('[]'); - end else + ReturnNode := StringLiteral('[]') + else begin ConcatNode := StringLiteral('['); for i := 0 to RecType.FieldNames.High do @@ -466,48 +594,34 @@ function TTypeIntrinsics.GenerateToStr(SelfType: XType; Args: array of XType): X ConcatNode := BinOp(op_ADD, ConcatNode, MethodCall( XTree_Field.Create(SelfId(), Id(RecType.FieldNames.Data[i]), FContext, FDocPos), - 'ToStr', [] - ) - ); + 'ToStr', [])); end; - ConcatNode := BinOp(op_ADD, ConcatNode, StringLiteral(']')); - ReturnNode := ConcatNode; + ReturnNode := BinOp(op_ADD, ConcatNode, StringLiteral(']')); end; end; xtClass: begin - // Same as record but prefixed with type name for clarity - // e.g. TPoint[x: 10, y: 20] - ClassTyp := SelfType as XType_Class; - - Body.List += IfStmt( - BinOp(op_EQ, SelfId(), NilPointer()), - ReturnStmt(StringLiteral(ClassTyp.Name + '[nil]')), - nil - ); - - if ClassTyp.FieldNames.Size = 0 then + ClassT := SelfType as XType_Class; + Body.List += IfStmt(BinOp(op_EQ, SelfId(), NilPointer()), + ReturnStmt(StringLiteral(ClassT.Name + '[nil]')), nil); + if ClassT.FieldNames.Size = 0 then + ReturnNode := StringLiteral(ClassT.Name + '[]') + else begin - ReturnNode := StringLiteral(ClassTyp.Name + '[]'); - end else - begin - ConcatNode := StringLiteral(ClassTyp.Name + '['); - for i := 0 to ClassTyp.FieldNames.High do + ConcatNode := StringLiteral(ClassT.Name + '['); + for i := 0 to ClassT.FieldNames.High do begin if i > 0 then ConcatNode := BinOp(op_ADD, ConcatNode, StringLiteral(', ')); - // Include field name for classes: "x: 10" - ConcatNode := BinOp(op_ADD, ConcatNode, StringLiteral(ClassTyp.FieldNames.Data[i] + ': ')); + ConcatNode := BinOp(op_ADD, ConcatNode, + StringLiteral(ClassT.FieldNames.Data[i] + ': ')); ConcatNode := BinOp(op_ADD, ConcatNode, MethodCall( - XTree_Field.Create(SelfId(), Id(ClassTyp.FieldNames.Data[i]), FContext, FDocPos), - 'ToStr', [] - ) - ); + XTree_Field.Create(SelfId(), Id(ClassT.FieldNames.Data[i]), FContext, FDocPos), + 'ToStr', [])); end; - ConcatNode := BinOp(op_ADD, ConcatNode, StringLiteral(']')); - ReturnNode := ConcatNode; + ReturnNode := BinOp(op_ADD, ConcatNode, StringLiteral(']')); end; end; @@ -521,24 +635,18 @@ function TTypeIntrinsics.GenerateToStr(SelfType: XType; Args: array of XType): X Result.InternalFlags := []; end; - function TTypeIntrinsics.GeneratePtrAssign(SelfType: XType; Args: array of XType; FuncName: string = ''): XTree_Function; var Body: XTree_ExprList; PType: XType_Pointer; begin - // This intrinsic is the universal entry point for finalizing any managed type. - if (SelfType <> nil) or (Length(Args) <> 2) then - Exit(nil); - + if (SelfType <> nil) or (Length(Args) <> 2) then Exit(nil); PType := Args[0] as XType_Pointer; - Body := ExprList(); Body.List += Parse('__main__', FContext, - 'if(right^ != nil)then' + LineEnding + - ' left^ := right^;' + LineEnding// + - //'end;' + 'if(right^ != nil)then' + LineEnding + + ' left^ := right^;' + LineEnding ); if FuncName = '' then @@ -547,15 +655,12 @@ function TTypeIntrinsics.GeneratePtrAssign(SelfType: XType; Args: array of XType Result := FunctionDef(FuncName, ['left','right'], [pbRef,pbRef], [PType,PType], nil, Body); end; -function TTypeIntrinsics.GeneratePtrDispose(SelfType: XType; Args: array of XType; FuncName:string=''): XTree_Function; +function TTypeIntrinsics.GeneratePtrDispose(SelfType: XType; Args: array of XType; FuncName: string = ''): XTree_Function; var Body: XTree_ExprList; PType: XType_Pointer; begin - // This intrinsic is the universal entry point for finalizing any managed type. - if (SelfType <> nil) or (Length(Args) <> 1) then - Exit(nil); - + if (SelfType <> nil) or (Length(Args) <> 1) then Exit(nil); PType := Args[0] as XType_Pointer; Body := ExprList(); @@ -563,14 +668,7 @@ function TTypeIntrinsics.GeneratePtrDispose(SelfType: XType; Args: array of XTyp xtPointer: Body.List += Call('freemem', [Deref(Id('ptr'))]); else - // Default will set everything to nil, casuing a reaction in XTree_Assign - // XTree_Assign will trigger collect. Collection machanism depends on type. - - // xtArray: An array will trigger SetLen(0) which means full release of data, or reduction in refcount. - - // xtClass: Setting to nil will simply trigger it's built in .Free, which currently - // directly releases it's data, as refcounting is ToDo. - Body.List += XTree_Default.Create(nil,[Deref(Id('ptr'))],FContext,FDocPos); + Body.List += XTree_Default.Create(nil, [Deref(Id('ptr'))], FContext, FDocPos); end; if FuncName = '' then @@ -580,7 +678,6 @@ function TTypeIntrinsics.GeneratePtrDispose(SelfType: XType; Args: array of XTyp Result.InternalFlags -= [cfNoCollect]; end; - function TTypeIntrinsics.GenerateCollect(SelfType: XType; Args: array of XType): XTree_Function; var Body: XTree_ExprList; @@ -588,75 +685,41 @@ function TTypeIntrinsics.GenerateCollect(SelfType: XType; Args: array of XType): RecType: XType_Record; i: Int32; begin - if SelfType = nil then - Exit(nil); - - // This intrinsic is the universal entry point for finalizing any managed type. - //if not SelfType.IsManaged(FContext) then - // Exit(nil); + if SelfType = nil then Exit(nil); Body := ExprList(); SelfIdent := SelfId(); - // The Collect method acts as a dispatcher, calling the correct - // finalization intrinsic based on the object's top-level type. case SelfType.BaseType of xtRecord: begin - // OLD (wrong): calls Default which wipes class fields regardless of refcount - // Body.List += MethodCall(SelfIdent, 'Default', []); - - // Collect each managed field individually - // Collect(field) properly decrements refcount and only destructs when rc=0. - // It does NOT wipe the class instance if other references exist. - RecType := SelfType as XType_Record; + RecType := SelfType as XType_Record; for i := 0 to RecType.FieldTypes.High do - begin if RecType.FieldTypes.Data[i].IsManagedType(FContext) then - begin Body.List += MethodCall( XTree_Field.Create(SelfId(), Id(RecType.FieldNames.Data[i]), FContext, FDocPos), - 'Collect', [] - ); - end; - end; + 'Collect', []); end; - xtArray, xtAnsiString, xtUnicodeString: // This also correctly handles XType_String - begin - // --- For an array or string --- - // 'Collect' is called when the variable's lifetime ends. - // This means we must decrement its refcount. SetLen(0) will handle - // the rest (checking if the count is zero and finalizing children). - // Generated code: Self.SetLen(0) + xtArray, xtAnsiString, xtUnicodeString: Body.List += MethodCall(SelfIdent, 'SetLen', [IntLiteral(0)]); - end; xtClass: begin Body.List += ReturnIfNil(SelfIdent); Body.List += VarDecl(['HeaderSize'], FContext.GetType(xtInt), IntLiteral(2 * SizeOf(SizeInt))); - Body.List += VarDecl(['raw'], FContext.GetType(xtPointer), BinOp(op_sub, SelfAsPtr, Id('HeaderSize'))); - - // rc=0 guard — re-entrant call from Default(). Return immediately. + Body.List += VarDecl(['raw'], FContext.GetType(xtPointer), + BinOp(op_sub, SelfAsPtr, Id('HeaderSize'))); Body.List += IfStmt( BinOp(op_EQ, Deref(Id('raw'), FContext.GetType(xtInt)), IntLiteral(0)), - ReturnStmt(), nil - ); - + ReturnStmt(), nil); Body.List += IfStmt( BinOp(op_EQ, Deref(Id('raw'), FContext.GetType(xtInt)), IntLiteral(1)), ExprList([ - // 1. Stomp rc=0 BEFORE Default runs, so any re-entrant Collect returns early. Assign(Deref(Id('raw'), FContext.GetType(xtInt)), IntLiteral(0)), - // 2. Zero managed fields while memory is still valid. MethodCall(SelfIdent, 'Default', []), - // 3. Compute block_start as a typed xtPointer local — avoids BinOp - // resolving pointer-int arithmetic to i32. - // block_start = raw - SizeOf(SizeInt) (one word back from rc word) VarDecl(['block_start'], FContext.GetType(xtPointer), BinOp(op_sub, Id('raw'), IntLiteral(SizeOf(SizeInt)))), - // 4. Now freemem receives xtPointer, not i32. Call('freemem', [Id('block_start')]) ]), Assign( @@ -675,22 +738,18 @@ function TTypeIntrinsics.GenerateDefault(SelfType: XType; Args: array of XType): var Body: XTree_ExprList; begin - if SelfType = nil then - Exit(nil); - - Body := ExprList([XTree_Default.Create(nil,[SelfId()],FContext,FDocPos)]); - + if SelfType = nil then Exit(nil); + Body := ExprList([XTree_Default.Create(nil, [SelfId()], FContext, FDocPos)]); Result := FunctionDef('Default', [], nil, [], nil, Body); Result.SelfType := SelfType; - Result.InternalFlags:=[]; //allow full free + Result.InternalFlags := []; end; function TTypeIntrinsics.GenerateSetLen1D(SelfType: XType; ArgName: string): XTree_Function; var Body: XTree_ExprList; ItemType, PItemType: XType; - TDisposalProto: XType_Method; - TCopyProto: XType_method; + TDisposalProto, TCopyProto: XType_Method; begin if SelfType = nil then Exit(nil); if not (SelfType is XType_Array) then Exit(nil); @@ -700,10 +759,7 @@ function TTypeIntrinsics.GenerateSetLen1D(SelfType: XType; ArgName: string): XTr if SelfType is XType_String then begin Body.List += XTree_Invoke.Create( - Id('_AnsiSetLength'), - [Id('self'), Id(ArgName)], - FContext, FDocPos - ); + Id('_AnsiSetLength'), [Id('self'), Id(ArgName)], FContext, FDocPos); end else begin ItemType := (SelfType as XType_Array).ItemType; @@ -717,32 +773,27 @@ function TTypeIntrinsics.GenerateSetLen1D(SelfType: XType; ArgName: string): XTr FContext.AddManagedType(TCopyProto); Body.List += VarDecl(['dispose'], TDisposalProto); - Body.List += VarDecl(['copy'], TCopyProto); + Body.List += VarDecl(['copy'], TCopyProto); if ItemType.IsManagedType(FContext) then begin FContext.GenerateIntrinsics('__pdispose__', [PItemType], nil, '__pdispose__' + TDisposalProto.Hash()); - FContext.GenerateIntrinsics('__passign__', [PItemType, PItemType], nil, '__passign__' + TCopyProto.Hash()); - + FContext.GenerateIntrinsics('__passign__', [PItemType, PItemType], nil, '__passign__' + TCopyProto.Hash()); Body.List += Assign(Id('dispose'), Id('__pdispose__' + TDisposalProto.Hash())); Body.List += Assign(Id('copy'), Id('__passign__' + TCopyProto.Hash())); end; Body.List += VarDecl(['raw'], FContext.GetType(xtPointer), SelfAsPtr()); - Body.List += Assign(SelfId(), XTree_Invoke.Create( Id('__internal::_ArraySetLength'), - [Id('raw'), Id(ArgName), IntLiteral(ItemType.Size), - Id('dispose'), Id('copy')], - FContext, FDocPos - )); + [Id('raw'), Id(ArgName), IntLiteral(ItemType.Size), Id('dispose'), Id('copy')], + FContext, FDocPos)); end; Result := FunctionDef('SetLen', [ArgName], [pbCopy], [FContext.GetType(xtInt)], nil, Body); Result.SelfType := SelfType; end; -// Public entry point - n-dimensional orchestrator function TTypeIntrinsics.GenerateSetLen(SelfType: XType; Args: array of XType): XTree_Function; var Body: XTree_ExprList; @@ -759,17 +810,13 @@ function TTypeIntrinsics.GenerateSetLen(SelfType: XType; Args: array of XType): NumDims := Length(Args); if NumDims = 0 then Exit(nil); - for i := 0 to NumDims - 1 do if not (Args[i].BaseType in XprIntTypes) then Exit(nil); - // Single dimension - delegate entirely to 1D if NumDims = 1 then Exit(GenerateSetLen1D(SelfType, 'NewLength')); - // Multi-dimension - build wrapper that calls 1D then loops inner IntType := FContext.GetType(xtInt); - SetLength(ArgNames, NumDims); SetLength(ArgPass, NumDims); SetLength(ArgTypes, NumDims); @@ -781,21 +828,14 @@ function TTypeIntrinsics.GenerateSetLen(SelfType: XType; Args: array of XType): end; Body := ExprList(); - - // Step 1 — resize outer dimension via 1D core Body.List += MethodCall(SelfId(), 'SetLen', [Id('Dim0')]); - // Step 2 — loop over outer, call SetLen(Dim1, Dim2...) on each inner array SetLength(InnerCallArgs, NumDims - 1); for i := 1 to NumDims - 1 do InnerCallArgs[i - 1] := Id('Dim' + IntToStr(i)); LoopBody := ExprList([ - MethodCall( - XTree_Index.Create(SelfId(), Id('!sli'), FContext, FDocPos), - 'SetLen', - InnerCallArgs - ) + MethodCall(Index(SelfId(), Id('!sli')), 'SetLen', InnerCallArgs) ]); Body.List += ForLoop( @@ -809,5 +849,358 @@ function TTypeIntrinsics.GenerateSetLen(SelfType: XType; Args: array of XType): Result.SelfType := SelfType; end; +// Push/Pop/Slice/Copy: signature needs ItemType from Pascal but body uses Parse + +function TTypeIntrinsics.GeneratePush(SelfType: XType; Args: array of XType): XTree_Function; +var + Body: XTree_ExprList; + ItemType: XType; +begin + if SelfType = nil then Exit(nil); + if not (SelfType is XType_Array) or (SelfType is XType_String) then Exit(nil); + if Length(Args) <> 1 then Exit(nil); + + ItemType := (SelfType as XType_Array).ItemType; + Body := ExprList(); + Body.List += Parse('__internal__', FContext, + 'self.SetLen(self.Len() + 1)' + LineEnding + + 'self[self.High()] := Value' + LineEnding); + + Result := FunctionDef('Push', ['Value'], [pbCopy], [ItemType], nil, Body); + Result.SelfType := SelfType; +end; + +function TTypeIntrinsics.GeneratePop(SelfType: XType; Args: array of XType): XTree_Function; +var + Body: XTree_ExprList; + ItemType: XType; +begin + if SelfType = nil then Exit(nil); + if not (SelfType is XType_Array) or (SelfType is XType_String) then Exit(nil); + if Length(Args) <> 0 then Exit(nil); + + ItemType := (SelfType as XType_Array).ItemType; + Body := ExprList(); + Body.List += Parse('__internal__', FContext, + 'Result := self[self.High()]' + LineEnding + + 'self.SetLen(self.Len() - 1)' + LineEnding + + 'return Result' + LineEnding); + + Result := FunctionDef('Pop', [], nil, [], ItemType, Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; + +function TTypeIntrinsics.GenerateSlice(SelfType: XType; Args: array of XType): XTree_Function; +var + Body: XTree_ExprList; + IntType: XType; + ArgNames: TStringArray; + ArgPass: TPassArgsBy; + ArgTypes: XTypeArray; + ToLine: string; + a: XType; +begin + if SelfType = nil then Exit(nil); + if not (SelfType is XType_Array) or (SelfType is XType_String) then Exit(nil); + if not (Length(Args) in [1, 2]) then Exit(nil); + for a in Args do + if not (a.BaseType in XprIntTypes) then Exit(nil); + + IntType := FContext.GetType(xtInt); + + if Length(Args) = 1 then + begin + ArgNames := ['From']; + ArgPass := [pbCopy]; + ArgTypes := [IntType]; + ToLine := 'var len := self.Len() - From'; + end else + begin + ArgNames := ['From', 'To']; + ArgPass := [pbCopy, pbCopy]; + ArgTypes := [IntType, IntType]; + ToLine := 'var len := To - From'; + end; + + Body := ExprList(); + Body.List += Parse('__internal__', FContext, + 'if(self = nil) then return nil' + LineEnding + + ToLine + LineEnding + + 'result := self' + LineEnding + + 'result.SetLen(0)' + LineEnding + + 'result.SetLen(len)' + LineEnding + + '@opt(''jit:off; rangechecks:off'')' + LineEnding + + 'for(var i := 0; i < len; i += 1) do' + LineEnding + + ' result[i] := self[From + i]' + LineEnding + + 'return result' + LineEnding); + + Result := FunctionDef('Slice', ArgNames, ArgPass, ArgTypes, SelfType, Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; + +function TTypeIntrinsics.GenerateCopy(SelfType: XType; Args: array of XType): XTree_Function; +var + Body: XTree_ExprList; +begin + if SelfType = nil then Exit(nil); + if not (SelfType is XType_Array) or (SelfType is XType_String) then Exit(nil); + if Length(Args) <> 0 then Exit(nil); + + Body := ExprList(); + Body.List += Parse('__internal__', FContext, + 'if(self = nil) then return nil' + LineEnding + + 'result := self' + LineEnding + + 'result.SetLen(0)' + LineEnding + + 'result.SetLen(self.Len())' + LineEnding + + 'var h := self.High()' + LineEnding + + '@opt(''jit:off; rangechecks: on'')' + LineEnding + + 'for(var i := 0; i <= h; i += 1) do' + LineEnding + + ' result[i] := self[i]' + LineEnding + + 'return result' + LineEnding); + + Result := FunctionDef('Copy', [], nil, [], SelfType, Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; + +{ ============================================================ } +{ Parse-based generators - pure Express logic } +{ ============================================================ } + +function IsNumericArray(SelfType: XType): Boolean; +begin + Result := (SelfType is XType_Array) and + not (SelfType is XType_String) and + ((SelfType as XType_Array).ItemType.BaseType in XprNumericTypes); +end; + +function IsPlainArray(SelfType: XType; const Args: array of XType; ArgCount: Int32): Boolean; +begin + Result := (SelfType <> nil) and + (SelfType is XType_Array) and + not (SelfType is XType_String) and + (Length(Args) = ArgCount); +end; + +function TTypeIntrinsics.GenerateEq(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; +begin + if SelfType = nil then Exit(nil); + if Length(Args) <> 1 then Exit(nil); + if not (SelfType is XType_Array) then Exit(nil); + + Body := ExprList(); + Body.List += Parse('__internal__', FContext, + 'if(self.Len() != Other.Len()) then return False' + LineEnding + + 'var h := self.High()' + LineEnding + + '@opt(''jit:off; rangechecks: on'')' + LineEnding + + 'for(var i:=0; i<=h; i += 1) do' + LineEnding + + ' if(self[i] != Other[i]) then' + LineEnding + + ' return False' + LineEnding + + 'return True' + LineEnding); + + Result := FunctionDef('__eq__', ['Other'], [pbCopy], [SelfType], + FContext.GetType(xtBoolean), Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; + +function TTypeIntrinsics.GenerateNeq(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; +begin + if SelfType = nil then Exit(nil); + if Length(Args) <> 1 then Exit(nil); + if not (SelfType is XType_Array) then Exit(nil); + + Body := ExprList(); + Body.List += Parse('__internal__', FContext, + 'return not self.__eq__(Other)' + LineEnding); + + Result := FunctionDef('__neq__', ['Other'], [pbCopy], [SelfType], + FContext.GetType(xtBoolean), Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; + +function TTypeIntrinsics.GenerateContains(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; ItemType: XType; +begin + if not IsPlainArray(SelfType, Args, 1) then Exit(nil); + ItemType := (SelfType as XType_Array).ItemType; + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_CONTAINS); + Result := FunctionDef('Contains', ['Value'], [pbCopy], [ItemType], + FContext.GetType(xtBoolean), Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; + +function TTypeIntrinsics.GenerateIndexOf(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; ItemType: XType; +begin + if not IsPlainArray(SelfType, Args, 1) then Exit(nil); + ItemType := (SelfType as XType_Array).ItemType; + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_INDEXOF); + Result := FunctionDef('IndexOf', ['Value'], [pbCopy], [ItemType], + FContext.GetType(xtInt), Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; + +function TTypeIntrinsics.GenerateDelete(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; +begin + if not IsPlainArray(SelfType, Args, 1) then Exit(nil); + if not (Args[0].BaseType in XprIntTypes) then Exit(nil); + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_DELETE); + Result := FunctionDef('Delete', ['Index'], [pbCopy], [FContext.GetType(xtInt)], nil, Body); + Result.SelfType := SelfType; +end; + +function TTypeIntrinsics.GenerateInsert(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; ItemType: XType; +begin + if not IsPlainArray(SelfType, Args, 2) then Exit(nil); + if not (Args[0].BaseType in XprIntTypes) then Exit(nil); + ItemType := (SelfType as XType_Array).ItemType; + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_INSERT); + Result := FunctionDef('Insert', ['Index', 'Value'], [pbCopy, pbCopy], + [FContext.GetType(xtInt), ItemType], nil, Body); + Result.SelfType := SelfType; +end; + +function TTypeIntrinsics.GenerateRemove(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; ItemType: XType; +begin + if not IsPlainArray(SelfType, Args, 1) then Exit(nil); + ItemType := (SelfType as XType_Array).ItemType; + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_REMOVE); + Result := FunctionDef('Remove', ['Value'], [pbCopy], [ItemType], nil, Body); + Result.SelfType := SelfType; +end; + +function TTypeIntrinsics.GenerateReverse(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; +begin + if not IsPlainArray(SelfType, Args, 0) then Exit(nil); + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_REVERSE); + Result := FunctionDef('Reverse', [], nil, [], nil, Body); + Result.SelfType := SelfType; +end; + +function TTypeIntrinsics.GenerateSort(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; +begin + if not IsPlainArray(SelfType, Args, 0) then Exit(nil); + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_SORT); + Result := FunctionDef('Sort', [], nil, [], nil, Body); + Result.SelfType := SelfType; +end; + +function TTypeIntrinsics.GenerateConcat(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; +begin + if not IsPlainArray(SelfType, Args, 1) then Exit(nil); + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_CONCAT); + Result := FunctionDef('Concat', ['Other'], [pbCopy], [SelfType], SelfType, Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; + +function TTypeIntrinsics.GenerateSum(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; ItemType: XType; +begin + if not IsNumericArray(SelfType) then Exit(nil); + if Length(Args) <> 0 then Exit(nil); + ItemType := (SelfType as XType_Array).ItemType; + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_SUM); + Result := FunctionDef('Sum', [], nil, [], ItemType, Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; + +function TTypeIntrinsics.GenerateMin(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; ItemType: XType; +begin + if not IsNumericArray(SelfType) then Exit(nil); + if Length(Args) <> 0 then Exit(nil); + ItemType := (SelfType as XType_Array).ItemType; + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_MIN); + Result := FunctionDef('Min', [], nil, [], ItemType, Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; + +function TTypeIntrinsics.GenerateMax(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; ItemType: XType; +begin + if not IsNumericArray(SelfType) then Exit(nil); + if Length(Args) <> 0 then Exit(nil); + ItemType := (SelfType as XType_Array).ItemType; + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_MAX); + Result := FunctionDef('Max', [], nil, [], ItemType, Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; + +function TTypeIntrinsics.GenerateMean(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; +begin + if not IsNumericArray(SelfType) then Exit(nil); + if Length(Args) <> 0 then Exit(nil); + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_MEAN); + Result := FunctionDef('Mean', [], nil, [], FContext.GetType(xtDouble), Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; + +function TTypeIntrinsics.GenerateVariance(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; +begin + if not IsNumericArray(SelfType) then Exit(nil); + if Length(Args) <> 0 then Exit(nil); + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_VARIANCE); + Result := FunctionDef('Variance', [], nil, [], FContext.GetType(xtDouble), Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; + +function TTypeIntrinsics.GenerateStdDev(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; +begin + if not IsNumericArray(SelfType) then Exit(nil); + if Length(Args) <> 0 then Exit(nil); + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_STDDEV); + Result := FunctionDef('StdDev', [], nil, [], FContext.GetType(xtDouble), Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; + +function TTypeIntrinsics.GenerateMedian(SelfType: XType; Args: array of XType): XTree_Function; +var Body: XTree_ExprList; +begin + if not IsNumericArray(SelfType) then Exit(nil); + if Length(Args) <> 0 then Exit(nil); + Body := ExprList(); + Body.List += Parse('__internal__', FContext, SRC_MEDIAN); + Result := FunctionDef('Median', [], nil, [], FContext.GetType(xtDouble), Body); + Result.SelfType := SelfType; + Result.InternalFlags := []; +end; end. diff --git a/compiler/xpr.types.pas b/compiler/xpr.types.pas index 995a29c..8a6f752 100644 --- a/compiler/xpr.types.pas +++ b/compiler/xpr.types.pas @@ -365,6 +365,7 @@ function CommonArithmeticCast(Left, Right:EExpressBaseType): EExpressBaseType; begin Result := xtUnknown; + (* // early exit for string building if (Left In XprStringTypes+XprCharTypes) and (Right In XprStringTypes+XprCharTypes) then begin @@ -374,6 +375,7 @@ function CommonArithmeticCast(Left, Right:EExpressBaseType): EExpressBaseType; if (Result in XprCharTypes) and (Result = xtUnicodeChar) then Result := xtUnicodeString; Exit; end; + *) // maybe already equal if Left = Right then diff --git a/system/exception - Copy.xpr b/system/exception - Copy.xpr deleted file mode 100644 index 22a51db..0000000 --- a/system/exception - Copy.xpr +++ /dev/null @@ -1,18 +0,0 @@ -type Exception = class - const Message: String; - func Create(aMessage: String) - self.Message := aMessage; - end; -end; - -type ENativeError = class(Exception) - // ... -end; - -type ERangeError = class(Exception) - // ... -end; - -// This is a magic compiler variable, and must never be free'd. -var __G_NativeExceptionTemplate := new ENativeError('A native VM error occurred'); -var __G_RangeExceptionTemplate := new ERangeError('Index out of range'); \ No newline at end of file diff --git a/system/internals - Copy.xpr b/system/internals - Copy.xpr deleted file mode 100644 index 0813757..0000000 --- a/system/internals - Copy.xpr +++ /dev/null @@ -1,120 +0,0 @@ -(* - This file should contain nothing that is refcounted! - Refcounted objects will cause circular import error. - - This is deep core language methods. -*) -type _TDisposeFunc = func(Pointer) -type _TAssignFunc = func(ref Pointer, ref Pointer) - -type PUnicodeString = ^UnicodeString; -type PAnsiString = ^AnsiString; -type PInt = ^Int -type PPointer = ^Pointer - -(* - ArraySetLength from Lape. Direct translation of implementation. - - Author: Niels A.D - Project: Lape (https://github.com/nielsAD/lape) - License: GNU Lesser GPL (http://www.gnu.org/licenses/lgpl.html) -*) -func _ArraySetLength(p: Pointer; NewLen, ElSize: Int; Dispose: _TDisposeFunc; Assign: _TAssignFunc): Pointer - var HeaderSize := 2 * SizeOf(Int) - var DoFree := NewLen <= 0 - - // --- Path 1: Handle a nil input array --- - if (p = nil) then - if(DoFree) - return nil // Setting a nil array to length 0 is a no-op - - // Allocate a new array from scratch - var NewSize := NewLen * ElSize + HeaderSize - p := AllocMem(NewSize) - - //FillByte(p, NewSize, 0) - - // Set header: RefCount = 1, HighIndex = NewLen - 1 - PInt(p)^ := 1 - p += SizeOf(int) - PInt(p)^ := NewLen - 1 - p += SizeOf(int) - return p - end - - // --- Path 2: Handle an existing array --- - p -= sizeof(int) // Get the true start of the memory block - var OldLen := PInt(p)^ + 1 // Get old length from high_index - p -= sizeof(int) - - // --- SUB-PATH 2A: LAST OWNER (Refcount <= 1) --- - if (PInt(p)^ <= 1) then - if(NewLen = OldLen) then - p += HeaderSize - return p// Length is unchanged, nothing to do - end - - // Finalize any elements we are abandoning - if((NewLen < OldLen) and (Dispose != nil)) then - p += HeaderSize - for (var i := NewLen; i < OldLen; i += 1) do - var varptr : Pointer = p + i * ElSize; - Dispose(varptr) - end; - p -= HeaderSize - end - - // If the new length is 0, free the memory - if(DoFree) then - FreeMem(p) - p := nil - return p - end - - // Reallocate the block and update the header - var NewSize := NewLen * ElSize + HeaderSize - p := ReallocMem(p, NewSize) - - PInt(p)^ := 1 - p += SizeOf(int) - PInt(p)^ := NewLen - 1 - p += SizeOf(int) - - // Zero-out the newly grown part of the array - if (NewLen > OldLen) then - FillByte(Pointer(p + OldLen * ElSize), (NewLen - OldLen) * ElSize, 0) - end - - return p - // --- SUB-PATH 2B: COPY-ON-WRITE (Refcount > 1) --- - else - // Decrement the old block's refcount - PInt(p)^ -= 1 - - // Create a brand new array by calling ourself recursively - var NewP: Pointer = _ArraySetLength(nil, NewLen, ElSize, Dispose, Assign) - - // Copy the data from the old array to our new one - var CopyLen := if (NewLen < OldLen) NewLen else OldLen - - if (CopyLen > 0) then - if (Assign = nil) then - // If no special copy func, do a simple memory move - Move(p+HeaderSize, NewP, CopyLen * ElSize) - else - p += HeaderSize - // Otherwise, use the provided assign(ref l^, ref r^) func per element - for (var i := CopyLen-1; i >= 0; i -= 1) do - var left : Pointer = NewP+i*ElSize - var right: Pointer = p+i*ElSize; - Assign(left,right) - end - p -= HeaderSize - end - end - - // Our variable now points to the new, unique copy - p += HeaderSize - return NewP - end -end diff --git a/tests/test_arraymethods.xpr b/tests/test_arraymethods.xpr new file mode 100644 index 0000000..be05a02 --- /dev/null +++ b/tests/test_arraymethods.xpr @@ -0,0 +1,311 @@ +type TIntArray = array of Int +type TFloatArray = array of Double +type TStrArray = array of String + +func Assert(cond: Boolean; msg: String) + if(not cond) then + raise Exception('Assertion failed: ' + msg) + +func AssertEx(actual, expected: String; msg: String) + if(actual != expected) then + raise Exception('Assertion failed: ' + msg + ', got: "' + actual + '", expected: "' + expected+'"') + + +// ============================================================ +// Push / Pop +// ============================================================ +print 'Push / Pop' + +var a: TIntArray +a.Push(10) +a.Push(20) +a.Push(30) + +AssertEx(a.Len().ToStr(), '3', 'Push: len after 3 pushes') +AssertEx(a[0].ToStr(), '10', 'Push: first element') +AssertEx(a[2].ToStr(), '30', 'Push: last element') + +print a +var popped := a.Pop() +print a +AssertEx(popped.ToStr(), '30', 'Pop: returned value') +AssertEx(a.Len().ToStr(), '2', 'Pop: len after pop') +AssertEx(a[1].ToStr(), '20', 'Pop: remaining last element') + +// ============================================================ +// Slice +// ============================================================ +print 'Slice' + +var b: TIntArray +b.Push(1) +b.Push(2) +b.Push(3) +b.Push(4) +b.Push(5) + +var s1 := b.Slice(2) +AssertEx(s1.ToStr(), '[3, 4, 5]', 'Slice(from): tail') + +var s2 := b.Slice(1, 4) +AssertEx(s2.ToStr(), '[2, 3, 4]', 'Slice(from, to): middle') + +var s3 := b.Slice(0, 2) +AssertEx(s3.ToStr(), '[1, 2]', 'Slice(0, 2): head') + +// ============================================================ +// Copy +// ============================================================ +print 'Copy' + +var c := b.Copy() +AssertEx(c.ToStr(), b.ToStr(), 'Copy: same contents') + +c[0] := 99 +AssertEx(b[0].ToStr(), '1', 'Copy: independent from original') + +// ============================================================ +// Contains / IndexOf +// ============================================================ +print 'Contains / IndexOf' + +Assert(b.Contains(3), 'Contains: existing element') +Assert(not b.Contains(99), 'Contains: missing element') + +AssertEx(b.IndexOf(3).ToStr(), '2', 'IndexOf: existing element') +AssertEx(b.IndexOf(99).ToStr(), '-1', 'IndexOf: missing element') + +// ============================================================ +// Delete +// ============================================================ +print 'Delete' + +var d: TIntArray +d.Push(10) +d.Push(20) +d.Push(30) +d.Push(40) + +d.Delete(1) +AssertEx(d.ToStr(), '[10, 30, 40]', 'Delete: middle element') +AssertEx(d.Len().ToStr(), '3', 'Delete: len after delete') + +d.Delete(0) +AssertEx(d.ToStr(), '[30, 40]', 'Delete: first element') + +d.Delete(d.High()) +AssertEx(d.ToStr(), '[30]', 'Delete: last element') + +// ============================================================ +// Insert +// ============================================================ +print 'Insert' + +var ins: TIntArray +ins.Push(1) +ins.Push(3) +ins.Push(5) + +ins.Insert(1, 2) +AssertEx(ins.ToStr(), '[1, 2, 3, 5]', 'Insert: middle') + +ins.Insert(0, 0) +AssertEx(ins.ToStr(), '[0, 1, 2, 3, 5]', 'Insert: front') + +ins.Insert(ins.Len(), 6) +AssertEx(ins.ToStr(), '[0, 1, 2, 3, 5, 6]', 'Insert: end') + +// ============================================================ +// Remove +// ============================================================ +print 'Remove' + +var r: TIntArray +r.Push(10) +r.Push(20) +r.Push(30) +r.Push(20) + +r.Remove(20) +AssertEx(r.ToStr(), '[10, 30, 20]', 'Remove: removes first occurrence') + +r.Remove(99) +AssertEx(r.ToStr(), '[10, 30, 20]', 'Remove: no-op for missing value') + +// ============================================================ +// Reverse +// ============================================================ +print 'Reverse' + +var rev: TIntArray +rev.Push(1) +rev.Push(2) +rev.Push(3) +rev.Push(4) +rev.Push(5) + +rev.Reverse() +AssertEx(rev.ToStr(), '[5, 4, 3, 2, 1]', 'Reverse: odd length') + +var rev2: TIntArray +rev2.Push(1) +rev2.Push(2) +rev2.Push(3) +rev2.Push(4) + +rev2.Reverse() +AssertEx(rev2.ToStr(), '[4, 3, 2, 1]', 'Reverse: even length') + +// ============================================================ +// Sort +// ============================================================ +print 'Sort' + +var unsorted: TIntArray +unsorted.Push(5) +unsorted.Push(2) +unsorted.Push(8) +unsorted.Push(1) +unsorted.Push(9) +unsorted.Push(3) + +unsorted.Sort() +AssertEx(unsorted.ToStr(), '[1, 2, 3, 5, 8, 9]', 'Sort: basic sort') + +var already: TIntArray +already.Push(1) +already.Push(2) +already.Push(3) +already.Sort() +AssertEx(already.ToStr(), '[1, 2, 3]', 'Sort: already sorted') + +var reverse_sorted: TIntArray +reverse_sorted.Push(5) +reverse_sorted.Push(4) +reverse_sorted.Push(3) +reverse_sorted.Push(2) +reverse_sorted.Push(1) +reverse_sorted.Sort() +AssertEx(reverse_sorted.ToStr(), '[1, 2, 3, 4, 5]', 'Sort: reverse input') + +var dups: TIntArray +dups.Push(3) +dups.Push(1) +dups.Push(2) +dups.Push(1) +dups.Push(3) +dups.Sort() +AssertEx(dups.ToStr(), '[1, 1, 2, 3, 3]', 'Sort: duplicates') + +// ============================================================ +// Concat +// ============================================================ +print 'Concat' + +var ca: TIntArray +ca.Push(1) +ca.Push(2) +ca.Push(3) + +var cb: TIntArray +cb.Push(4) +cb.Push(5) + +var cc := ca.Concat(cb) +AssertEx(cc.ToStr(), '[1, 2, 3, 4, 5]', 'Concat: basic') +AssertEx(ca.ToStr(), '[1, 2, 3]', 'Concat: self unchanged') +AssertEx(cb.ToStr(), '[4, 5]', 'Concat: other unchanged') + +// ============================================================ +// Numeric: Sum / Min / Max +// ============================================================ +print 'Sum / Min / Max' + +var nums: TIntArray +nums.Push(3) +nums.Push(1) +nums.Push(4) +nums.Push(1) +nums.Push(5) +nums.Push(9) +nums.Push(2) +nums.Push(6) + +AssertEx(nums.Sum().ToStr(), '31', 'Sum') +AssertEx(nums.Min().ToStr(), '1', 'Min') +AssertEx(nums.Max().ToStr(), '9', 'Max') + +// ============================================================ +// Numeric: Mean / Variance / StdDev / Median +// ============================================================ +print 'Mean / Variance / StdDev / Median' + +var stats: TFloatArray +stats.Push(2.0) +stats.Push(4.0) +stats.Push(4.0) +stats.Push(4.0) +stats.Push(5.0) +stats.Push(5.0) +stats.Push(7.0) +stats.Push(9.0) + +// Mean = 40/8 = 5.0 +AssertEx(stats.Mean().ToStr(), '5.0', 'Mean') + +// Variance = 4.0 (population) +AssertEx(stats.Variance().ToStr(), '4.0', 'Variance') + +// StdDev = 2.0 +AssertEx(stats.StdDev().ToStr(), '2.0', 'StdDev') + +// Median of [2,4,4,4,5,5,7,9] = (4+5)/2 = 4.5 +AssertEx(stats.Median().ToStr(), '4.5', 'Median: even length') + +var odd_stats: TFloatArray +odd_stats.Push(1.0) +odd_stats.Push(3.0) +odd_stats.Push(5.0) + +AssertEx(odd_stats.Median().ToStr(), '3.0', 'Median: odd length') + +// ============================================================ +// String arrays +// ============================================================ +print 'String arrays' + +var words: TStrArray +words.Push('hello') +words.Push('world') +words.Push('foo') + +AssertEx(words.Len().ToStr(), '3', 'String array: Push/Len') +Assert(words.Contains('world'), 'String array: Contains') +Assert(not words.Contains('bar'), 'String array: Contains missing') +AssertEx(words.IndexOf('foo').ToStr(), '2', 'String array: IndexOf') + +words.Remove('world') +AssertEx(words.ToStr(), "['hello', 'foo']", 'String array: Remove') + +words.Reverse() +AssertEx(words.ToStr(), "['foo', 'hello']", 'String array: Reverse') + +// ============================================================ +// Edge cases +// ============================================================ +print 'Edge cases' + +var empty: TIntArray +AssertEx(empty.Len().ToStr(), '0', 'Empty: Len') +AssertEx(empty.High().ToStr(), '-1', 'Empty: High') +Assert(not empty.Contains(1), 'Empty: Contains') +AssertEx(empty.IndexOf(1).ToStr(), '-1', 'Empty: IndexOf') + +var one: TIntArray +one.Push(42) +one.Sort() +AssertEx(one.ToStr(), '[42]', 'Single element: Sort') +one.Reverse() +AssertEx(one.ToStr(), '[42]', 'Single element: Reverse') + +print 'All tests done' diff --git a/tests/tostr.xpr b/tests/tostr.xpr index 9580e96..3a08fdb 100644 --- a/tests/tostr.xpr +++ b/tests/tostr.xpr @@ -30,4 +30,20 @@ var p := new TPerson() p.name := 'frank' p.age := 40 -print p \ No newline at end of file +print p + + +arr.reverse() +print arr + +func main() + var arrx : array of int32 = [] + arrx.setlen(300000) + for(var i:=0; i < 300000; i+=1) do + arrx[i] := round(random()*30000) + + var t:=gettickcount() + arrx.sort() + print gettickcount()-t,'ms' + +main() From 034f168d114d15883514449ff1ed84384e6d4f14 Mon Sep 17 00:00:00 2001 From: Jarl Holta Date: Thu, 19 Mar 2026 01:32:54 +0100 Subject: [PATCH 5/5] Fix array eq/neq & string add --- compiler/xpr.tree.pas | 111 ++++++++++++++------------------ compiler/xpr.typeintrinsics.pas | 59 ++++++++++------- examples/dotprod.xpr | 1 - tests/quicksort.xpr | 30 ++++----- tests/test_arraymethods.xpr | 26 +++++++- 5 files changed, 121 insertions(+), 106 deletions(-) diff --git a/compiler/xpr.tree.pas b/compiler/xpr.tree.pas index 348e263..35e6d09 100644 --- a/compiler/xpr.tree.pas +++ b/compiler/xpr.tree.pas @@ -5217,7 +5217,8 @@ function XTree_BinaryOp.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar; ctx.PatchJump(PatchPos); Result := TmpBool; end; - +var + funcstr: string; begin Assert(not(OP in AssignOps), 'Assignment does not belong here, dont come again!'); @@ -5234,6 +5235,27 @@ function XTree_BinaryOp.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar; if OP in [op_AND, op_OR] then Exit(DoShortCircuitOp()); + // array = array, and array != array + // this includes strings, fall back to internal method + if (OP in [op_EQ, op_NEQ]) and + (Left.ResType().BaseType in [xtAnsiString, xtUnicodeString, xtArray]) and + (Right.ResType().BaseType = Left.ResType().BaseType) then + begin + if OP = op_EQ then funcstr := '__eq__' + else funcstr := '__neq__'; + + with XTree_Invoke.Create( + XTree_Identifier.Create(funcstr, ctx, FDocPos), + [Right], ctx, FDocPos) do + try + SelfExpr := Left; + Result := Compile(Dest, Flags); + finally + Free; + end; + Exit(); + end; + // Determine the result variable. Result := Dest; if Dest = NullResVar then @@ -5251,6 +5273,31 @@ function XTree_BinaryOp.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar; if Right.ResType() = nil then ctx.RaiseException('Cannot infer type from Right operand', FDocPos); + // String/Char concatenation - promote chars to strings before adding + if (OP = op_ADD) and + (Left.ResType().BaseType in XprStringTypes + XprCharTypes) and + (Right.ResType().BaseType in XprStringTypes + XprCharTypes) then + begin + if (Left.ResType().BaseType = xtUnicodeString) or + (Right.ResType().BaseType = xtUnicodeString) then + CommonTypeVar := ctx.GetType(xtUnicodeString) + else + CommonTypeVar := ctx.GetType(xtAnsiString); + + LeftVar := Left.Compile(NullResVar, Flags).IfRefDeref(ctx); + RightVar := Right.Compile(NullResVar, Flags).IfRefDeref(ctx); + LeftVar := ctx.EmitUpcastIfNeeded(LeftVar, CommonTypeVar, False); + RightVar := ctx.EmitUpcastIfNeeded(RightVar, CommonTypeVar, False); + + Instr := LeftVar.VarType.EvalCode(op_ADD, RightVar.VarType); + if Instr = icNOOP then + ctx.RaiseExceptionFmt(eNotCompatible3, + [OperatorToStr(OP), BT2S(Left.ResType.BaseType), BT2S(Right.ResType.BaseType)], FDocPos); + + Self.Emit(GetInstr(Instr, [LeftVar, RightVar, Result]), FDocPos); + Exit; + end; + // Handle arithmetic operations with type promotion if OP in ArithOps+LogicalOps then begin @@ -5290,68 +5337,6 @@ function XTree_BinaryOp.Compile(Dest: TXprVar; Flags: TCompilerFlags): TXprVar; Assert(LeftVar.VarType <> nil); Assert(RightVar.VarType <> nil); - // String/Char concatenation — promote chars to strings before adding - if (OP = op_ADD) and - (Left.ResType().BaseType in XprStringTypes + XprCharTypes) and - (Right.ResType().BaseType in XprStringTypes + XprCharTypes) then - begin - // Determine target string type — unicode wins over ansi - if (Left.ResType().BaseType = xtUnicodeString) or - (Right.ResType().BaseType = xtUnicodeString) or - (Left.ResType().BaseType = xtUnicodeChar) or - (Right.ResType().BaseType = xtUnicodeChar) then - CommonTypeVar := ctx.GetType(xtUnicodeString) - else - CommonTypeVar := ctx.GetType(xtAnsiString); - - LeftVar := Left.Compile(NullResVar, Flags).IfRefDeref(ctx); - RightVar := Right.Compile(NullResVar, Flags).IfRefDeref(ctx); - - // Upcast chars to string if needed - LeftVar := ctx.EmitUpcastIfNeeded(LeftVar, CommonTypeVar, False); - RightVar := ctx.EmitUpcastIfNeeded(RightVar, CommonTypeVar, False); - - Result := Dest; - if Result = NullResVar then - Result := ctx.GetTempVar(CommonTypeVar); - - Instr := LeftVar.VarType.EvalCode(op_ADD, RightVar.VarType); - if Instr = icNOOP then - ctx.RaiseExceptionFmt(eNotCompatible3, - [OperatorToStr(OP), BT2S(Left.ResType.BaseType), BT2S(Right.ResType.BaseType)], FDocPos); - - Self.Emit(GetInstr(Instr, [LeftVar, RightVar, Result]), FDocPos); - Exit; - end; - - // array = array, and array != array - // this includes strings, fall back to internal method - if (OP in [op_EQ, op_NEQ]) and - (Left.ResType().BaseType in [xtAnsiString, xtUnicodeString, xtArray]) and - (Right.ResType().BaseType = Left.ResType().BaseType) then - begin - WriteLn('Using EQ method!'); - with XTree_Invoke.Create( - XTree_Identifier.Create('__eq__', ctx, FDocPos), - [Right], ctx, FDocPos) do - try - SelfExpr := Left; - Result := Compile(Dest, Flags); - if OP = op_NEQ then begin // wrap in NOT - with XTree_UnaryOp.Create(op_NOT, - XTree_VarStub.Create(Result, ctx, FDocPos), ctx, FDocPos) do - try - Result := Compile(Dest, Flags); - finally - Free; - end; - end; - finally - Free; - end; - Exit(); - end; - // Emit the binary operation. This logic remains the same. Instr := LeftVar.VarType.EvalCode(OP, RightVar.VarType); if Instr <> icNOOP then diff --git a/compiler/xpr.typeintrinsics.pas b/compiler/xpr.typeintrinsics.pas index a189241..81adc02 100644 --- a/compiler/xpr.typeintrinsics.pas +++ b/compiler/xpr.typeintrinsics.pas @@ -23,13 +23,16 @@ interface xpr.Errors, xpr.CompilerContext; +const + JIT_RC_STATE = '@opt(''jit:max; rangechecks:off'')'; + const // Pure Express source strings for Parse-based generators. // Variable names must match the FunctionDef arg names below. SRC_CONTAINS = 'var h := self.High()' + LineEnding + - '@opt(''jit:off; rangechecks: on'')' + LineEnding + + JIT_RC_STATE + LineEnding + 'for(var i := 0; i <= h; i += 1) do' + LineEnding + ' if(self[i] = Value)then' + LineEnding + ' return True' + LineEnding + @@ -37,7 +40,7 @@ interface SRC_INDEXOF = 'var h := self.High()' + LineEnding + - '@opt(''jit:off; rangechecks: on'')' + LineEnding + + JIT_RC_STATE + LineEnding + 'for(var i := 0; i <= h; i += 1) do' + LineEnding + ' if(self[i] = Value)then' + LineEnding + ' return i' + LineEnding + @@ -46,7 +49,7 @@ interface SRC_DELETE = 'if(self = nil) then return' + LineEnding + 'var h := self.High()' + LineEnding + - '@opt(''jit:off; rangechecks: on'')' + LineEnding + + JIT_RC_STATE + LineEnding + 'for(var j := Index; j < h; j += 1) do' + LineEnding + ' self[j] := self[j + 1]' + LineEnding + 'self.SetLen(self.Len() - 1)' + LineEnding; @@ -55,7 +58,7 @@ interface 'if(self = nil) then return' + LineEnding + 'self.SetLen(self.Len() + 1)' + LineEnding + 'var h := self.High()' + LineEnding + - '@opt(''jit:off; rangechecks: on'')' + LineEnding + + JIT_RC_STATE + LineEnding + 'for(var j := h; j > Index; j -= 1) do' + LineEnding + ' self[j] := self[j - 1]' + LineEnding + 'self[Index] := Value' + LineEnding; @@ -68,7 +71,7 @@ interface SRC_REVERSE = 'if(self = nil) then return' + LineEnding + 'var l := self.Len()' + LineEnding + - '@opt(''jit:off; rangechecks: on'')' + LineEnding + + JIT_RC_STATE + LineEnding + 'for(var lo := 0; lo < l / 2; lo += 1) do' + LineEnding + ' var hi := (l-1) - lo' + LineEnding + ' var tmp := self[lo]' + LineEnding + @@ -83,7 +86,7 @@ interface ' var gap := gaps[gi]' + LineEnding + ' if(gap >= self.Len()) then continue' + LineEnding + ' var h := self.High()' + LineEnding + - ' @opt(''jit:off; rangechecks: on'')' + LineEnding + + ' '+JIT_RC_STATE + LineEnding + ' for(var i := gap; i <= h; i += 1) do' + LineEnding + ' var key := self[i]' + LineEnding + ' var j := i - gap' + LineEnding + @@ -100,7 +103,7 @@ interface 'var lenB := Other.Len()' + LineEnding + 'result := self.Copy()' + LineEnding + 'result.SetLen(lenA + lenB)' + LineEnding + - '@opt(''jit:off; rangechecks: on'')' + LineEnding + + JIT_RC_STATE + LineEnding + 'for(var j := 0; j < lenB; j += 1) do' + LineEnding + ' result[lenA + j] := Other[j]' + LineEnding + 'return result' + LineEnding; @@ -109,7 +112,7 @@ interface 'if(self = nil) then return 0' + LineEnding + 'var s := self[0]' + LineEnding + 'var h := self.High()' + LineEnding + - '@opt(''jit:off; rangechecks: on'')' + LineEnding + + JIT_RC_STATE + LineEnding + 'for(var i := 1; i <= h; i += 1) do' + LineEnding + ' s += self[i]' + LineEnding + 'return s' + LineEnding; @@ -118,7 +121,7 @@ interface 'if(self = nil) then return 0' + LineEnding + 'Result := self[0]' + LineEnding + 'var h := self.High()' + LineEnding + - '@opt(''jit:off; rangechecks: on'')' + LineEnding + + JIT_RC_STATE + LineEnding + 'for(var i := 1; i <= h; i += 1) do' + LineEnding + ' if(self[i] < Result) then' + LineEnding + ' Result := self[i]' + LineEnding + @@ -128,14 +131,14 @@ interface 'if(self = nil) then return 0' + LineEnding + 'Result := self[0]' + LineEnding + 'var h := self.High()' + LineEnding + - '@opt(''jit:off; rangechecks: on'')' + LineEnding + + JIT_RC_STATE + LineEnding + 'for(var i := 1; i <= h; i += 1) do' + LineEnding + ' if(self[i] > Result) then' + LineEnding + ' Result := self[i]' + LineEnding + 'return Result' + LineEnding; SRC_MEAN = - 'if(self = nil) then return 0.0' + LineEnding + + 'if(self = nil) then return 0.0' + LineEnding + 'if(self.Len() = 0) then return 0.0' + LineEnding + 'return Double(self.Sum()) / Double(self.Len())' + LineEnding; @@ -145,24 +148,24 @@ interface 'var mean := self.Mean()' + LineEnding + 'var sum := 0.0' + LineEnding + 'var h := self.High()' + LineEnding + - '@opt(''jit:off; rangechecks: on'')' + LineEnding + + JIT_RC_STATE + LineEnding + 'for(var i := 0; i <= h; i += 1) do' + LineEnding + ' var d := Double(self[i]) - mean' + LineEnding + ' sum += d * d' + LineEnding + 'return sum / Double(self.Len())' + LineEnding; SRC_STDDEV = - 'return Sqrt(self.Variance())' + LineEnding; + 'return Sqrt(self.Variance())' + LineEnding; SRC_MEDIAN = - 'if(self = nil) then return 0.0' + LineEnding + - 'if(self.Len() = 0) then return 0.0' + LineEnding + - 'var tmp := self.Copy()' + LineEnding + - 'tmp.Sort()' + LineEnding + - 'var mid := tmp.Len() / 2' + LineEnding + - 'if(tmp.Len() % 2 = 0) then' + LineEnding + - ' return (Double(tmp[mid - 1]) + Double(tmp[mid])) / 2.0' + LineEnding + - 'return Double(tmp[mid])' + LineEnding; + 'if(self = nil) then return 0.0' + LineEnding + + 'if(self.Len() = 0) then return 0.0' + LineEnding + + 'var tmp := self.Copy()' + LineEnding + + 'tmp.Sort()' + LineEnding + + 'var mid := tmp.Len() / 2' + LineEnding + + 'if(tmp.Len() % 2 = 0) then' + LineEnding + + ' return (Double(tmp[mid - 1]) + Double(tmp[mid])) / 2.0' + LineEnding + + 'return Double(tmp[mid])' + LineEnding; type TTypeIntrinsics = class(TIntrinsics) @@ -930,7 +933,7 @@ function TTypeIntrinsics.GenerateSlice(SelfType: XType; Args: array of XType): X 'result := self' + LineEnding + 'result.SetLen(0)' + LineEnding + 'result.SetLen(len)' + LineEnding + - '@opt(''jit:off; rangechecks:off'')' + LineEnding + + JIT_RC_STATE + LineEnding + 'for(var i := 0; i < len; i += 1) do' + LineEnding + ' result[i] := self[From + i]' + LineEnding + 'return result' + LineEnding); @@ -955,7 +958,7 @@ function TTypeIntrinsics.GenerateCopy(SelfType: XType; Args: array of XType): XT 'result.SetLen(0)' + LineEnding + 'result.SetLen(self.Len())' + LineEnding + 'var h := self.High()' + LineEnding + - '@opt(''jit:off; rangechecks: on'')' + LineEnding + + JIT_RC_STATE + LineEnding + 'for(var i := 0; i <= h; i += 1) do' + LineEnding + ' result[i] := self[i]' + LineEnding + 'return result' + LineEnding); @@ -995,7 +998,7 @@ function TTypeIntrinsics.GenerateEq(SelfType: XType; Args: array of XType): XTre Body.List += Parse('__internal__', FContext, 'if(self.Len() != Other.Len()) then return False' + LineEnding + 'var h := self.High()' + LineEnding + - '@opt(''jit:off; rangechecks: on'')' + LineEnding + + JIT_RC_STATE + LineEnding + 'for(var i:=0; i<=h; i += 1) do' + LineEnding + ' if(self[i] != Other[i]) then' + LineEnding + ' return False' + LineEnding + @@ -1016,7 +1019,13 @@ function TTypeIntrinsics.GenerateNeq(SelfType: XType; Args: array of XType): XTr Body := ExprList(); Body.List += Parse('__internal__', FContext, - 'return not self.__eq__(Other)' + LineEnding); + 'if(self.Len() != Other.Len()) then return False' + LineEnding + + 'var h := self.High()' + LineEnding + + JIT_RC_STATE + LineEnding + + 'for(var i:=0; i<=h; i += 1) do' + LineEnding + + ' if(self[i] != Other[i]) then' + LineEnding + + ' return True' + LineEnding + + 'return False' + LineEnding); Result := FunctionDef('__neq__', ['Other'], [pbCopy], [SelfType], FContext.GetType(xtBoolean), Body); diff --git a/examples/dotprod.xpr b/examples/dotprod.xpr index 67370b2..b8a444a 100644 --- a/examples/dotprod.xpr +++ b/examples/dotprod.xpr @@ -8,7 +8,6 @@ func dotproduct() a.SetLen(n) b.SetLen(n) - n := a.len() var start := GetTickCount() for(var i:= 0; i < n; i += 1) do diff --git a/tests/quicksort.xpr b/tests/quicksort.xpr index 354f6c4..ac09249 100644 --- a/tests/quicksort.xpr +++ b/tests/quicksort.xpr @@ -1,36 +1,36 @@ -type TIntArray = array of Int32; +type TIntArray = array of Int32 -func TIntArray.QuickSort(left, right: Int32); - if(left >= right) return; +@opt('jit:full; rangechecks:off') +func TIntArray.quicksort(left, right: Int32) + if(left >= right) return var pivot := self[(left + right) / 2] var i := left var j := right while(i <= j) do - while(self[i] < pivot) i += 1 - while(self[j] > pivot) j -= 1 + while(self[i] < pivot) do i += 1 + while(self[j] > pivot) do j -= 1 if(i <= j) then (self[i], self[j]) := [self[j], self[i]] i += 1 j -= 1 - if(left < j) self.QuickSort(left, j); - if(i < right) self.QuickSort(i, right); + if(left < j) then self.quicksort(left, j) + if(i < right)then self.quicksort(i, right) func main(); var arr: TIntArray; - arr.SetLen(1000000) - - var n:= arr.High() + 1 + arr.setlen(300000) + + for(ref elmt in arr) + elmt := randint(0, $ffffff) - for(var i:=0; i