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 59ac190..47298a4 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; @@ -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 3427cf9..35e6d09 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; @@ -5196,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!'); @@ -5213,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 @@ -5230,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 @@ -5717,26 +5785,57 @@ 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; + 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); - 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); + combined := nil; + for i := 0 to High(Self.Args) do + begin + argNode := Self.Args[i]; + argType := argNode.ResType(); + + if (argType <> nil) and (argType.BaseType in [xtAnsiString, xtUnicodeString]) then + 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); - // Dereference if needed — same as any other expression consumer - if arg.Reference then - arg := arg.DerefToTemp(ctx); + toStrNode := XTree_Invoke.Create( + XTree_Identifier.Create('ToStr', ctx, FDocPos), + [], ctx, FDocPos + ); + XTree_Invoke(toStrNode).SelfExpr := + XTree_VarStub.Create(argVar, ctx, FDocPos); + 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); + 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..81adc02 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,156 @@ 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 + + JIT_RC_STATE + 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 + + JIT_RC_STATE + 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 + + 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; + + SRC_INSERT = + 'if(self = nil) then return' + LineEnding + + 'self.SetLen(self.Len() + 1)' + LineEnding + + 'var h := self.High()' + 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; + + 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 + + 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 + + ' 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 + + ' '+JIT_RC_STATE + 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 + + JIT_RC_STATE + 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 + + JIT_RC_STATE + 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 + + 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_MAX = + 'if(self = nil) then return 0' + LineEnding + + 'Result := self[0]' + LineEnding + + 'var h := self.High()' + 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.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 + + 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; + + 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 +184,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,18 +206,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 @@ -82,16 +251,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 @@ -100,6 +269,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); @@ -124,8 +300,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; @@ -141,7 +317,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); @@ -166,6 +341,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); @@ -199,9 +379,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; @@ -223,13 +403,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; @@ -255,36 +440,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); @@ -296,13 +474,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); @@ -311,8 +486,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); @@ -322,19 +496,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 SelfType = nil then Exit(nil); + if (Length(Args) > 0) or not ((SelfType is XType_Array) or (SelfType is XType_String)) then Exit(nil); - if (Length(Args) > 0) or not ((SelfType is XType_Array) or (SelfType is XType_String)) then - Exit(nil); - - ResultVar := Id('Result'); - - // 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); @@ -342,36 +509,39 @@ 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: XTree_Node; - StringType: XType; + ReturnNode, ConcatNode: XTree_Node; + StringType, IntType: XType; + RecType: XType_Record; + ClassT: XType_Class; + i: Int32; 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(); + 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,57 +550,106 @@ 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'), - FContext, FDocPos - ); + 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 + Body.List += IfStmt(BinOp(op_EQ, SelfId(), NilPointer()), + ReturnStmt(StringLiteral('[]')), nil); + Body.List += VarDecl(['!r'], StringType, StringLiteral('[')); + 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(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 := []; + Exit; + end; + + xtRecord: + begin + RecType := SelfType as XType_Record; + if RecType.FieldNames.Size = 0 then + ReturnNode := StringLiteral('[]') + else begin - ReturnNode := BinOp(op_Add, StringLiteral('(' + SelfType.ToString() + ' @ '), - BinOp(op_Add, Call('PtrToStr', [SelfId()]), StringLiteral(')')) - ); + 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; + ReturnNode := BinOp(op_ADD, ConcatNode, StringLiteral(']')); end; + end; + + xtClass: + begin + 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 + ConcatNode := StringLiteral(ClassT.Name + '['); + for i := 0 to ClassT.FieldNames.High do + begin + if i > 0 then + ConcatNode := BinOp(op_ADD, ConcatNode, StringLiteral(', ')); + ConcatNode := BinOp(op_ADD, ConcatNode, + StringLiteral(ClassT.FieldNames.Data[i] + ': ')); + ConcatNode := BinOp(op_ADD, ConcatNode, + MethodCall( + XTree_Field.Create(SelfId(), Id(ClassT.FieldNames.Data[i]), FContext, FDocPos), + 'ToStr', [])); + end; + ReturnNode := BinOp(op_ADD, ConcatNode, StringLiteral(']')); + 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; - 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 @@ -439,15 +658,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(); @@ -455,14 +671,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 @@ -472,7 +681,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; @@ -480,75 +688,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( @@ -567,81 +741,475 @@ 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.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; - TDisposalProto: XType_Method; - TCopyProto: XType_method; + ItemType, PItemType: XType; + TDisposalProto, 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(); if SelfType is XType_String then begin Body.List += XTree_Invoke.Create( - Id('_AnsiSetLength'), - [Id('self'), Id('NewLength')], - FContext, FDocPos - ); + Id('_AnsiSetLength'), [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); - // --- 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()); - - Body.List += Assign(Id('dispose'), Id('__pdispose__'+TDisposalProto.Hash())); - Body.List += Assign(Id('copy'), Id('__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())); 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') - ], - FContext, FDocPos - )); + [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; +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); + + if NumDims = 1 then + Exit(GenerateSetLen1D(SelfType, 'NewLength')); + + 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(); + Body.List += MethodCall(SelfId(), 'SetLen', [Id('Dim0')]); + + SetLength(InnerCallArgs, NumDims - 1); + for i := 1 to NumDims - 1 do + InnerCallArgs[i - 1] := Id('Dim' + IntToStr(i)); + + LoopBody := ExprList([ + MethodCall(Index(SelfId(), Id('!sli')), '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; + +// 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 + + JIT_RC_STATE + 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 + + JIT_RC_STATE + 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 + + JIT_RC_STATE + 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, + '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); + 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/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/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/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