diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index 6ef94ef..815e05c 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -702,6 +702,7 @@ var IsFunc: Boolean; RetQType: string; RetTemp: string; + ValTemp: string; Prefix: string; begin FuncName := '$' + ADecl.Name; @@ -756,6 +757,18 @@ begin end; end; + { ARC: addref string value params on entry (callee owns a copy) } + for I := 0 to ADecl.Params.Count - 1 do + begin + Par := TMethodParam(ADecl.Params[I]); + if (not Par.IsVarParam) and (Par.ResolvedType.Kind = tyString) then + begin + ValTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_%s', [ValTemp, Par.ParamName])); + EmitLine(Format(' call $_StringAddRef(l %s)', [ValTemp])); + end; + end; + if IsFunc then begin if RetQType = 'w' then @@ -772,6 +785,18 @@ begin EmitBlock(ADecl.Body); + { ARC: release string value params on exit } + for I := 0 to ADecl.Params.Count - 1 do + begin + Par := TMethodParam(ADecl.Params[I]); + if (not Par.IsVarParam) and (Par.ResolvedType.Kind = tyString) then + begin + ValTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_%s', [ValTemp, Par.ParamName])); + EmitLine(Format(' call $_StringRelease(l %s)', [ValTemp])); + end; + end; + if IsFunc then begin RetTemp := AllocTemp; @@ -1043,6 +1068,15 @@ begin L := EmitExpr(BinExpr.Left); R := EmitExpr(BinExpr.Right); T := AllocTemp; + { String concatenation: delegate to RTL } + if (BinExpr.Op = boAdd) and + (BinExpr.Left.ResolvedType <> nil) and + BinExpr.Left.ResolvedType.IsString then + begin + EmitLine(Format(' %s =l call $_StringConcat(l %s, l %s)', [T, L, R])); + Result := T; + Exit; + end; { Use long (pointer) comparison instructions when operands are class/nil } if (BinExpr.Left.ResolvedType <> nil) and (BinExpr.Left.ResolvedType.Kind in [tyClass, tyNil]) then diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index 3b4f532..72b57f6 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -1143,6 +1143,13 @@ begin end else begin + { String concatenation: s1 + s2 → string } + if (ABin.Op = boAdd) and LType.IsString and RType.IsString then + begin + Result := FTable.TypeString; + Exit; + end; + if not LType.IsNumeric then SemanticError( Format('Left operand of ''%s'' must be numeric, got ''%s''', diff --git a/compiler/src/test/pascal/cp.test.arc.pas b/compiler/src/test/pascal/cp.test.arc.pas index d846f41..3349ff7 100644 --- a/compiler/src/test/pascal/cp.test.arc.pas +++ b/compiler/src/test/pascal/cp.test.arc.pas @@ -32,6 +32,18 @@ type { String variable passed to WriteLn (load + printf) } procedure TestARC_WriteLn_StringVar_Works; + + { String value parameter: addref on entry, release on exit } + procedure TestARC_StringValueParam_AddRefOnEntry; + procedure TestARC_StringValueParam_ReleaseOnExit; + + { String var parameter: no addref, no release } + procedure TestARC_StringVarParam_NoAddRef; + procedure TestARC_StringVarParam_NoRelease; + + { String concatenation: calls RTL concat function } + procedure TestARC_StringConcat_SemanticOK; + procedure TestARC_StringConcat_CallsRTL; end; implementation @@ -198,6 +210,88 @@ begin AssertTrue('printf called', IRContains(IR, 'call $printf')); end; +const + SrcValParam = + 'program P;' + LineEnding + + 'procedure Greet(S: string);' + LineEnding + + 'begin end;' + LineEnding + + 'begin end.'; + + SrcVarParam = + 'program P;' + LineEnding + + 'procedure Greet(var S: string);' + LineEnding + + 'begin end;' + LineEnding + + 'begin end.'; + + SrcConcat = + 'program P;' + LineEnding + + 'var a, b, c: string;' + LineEnding + + 'begin' + LineEnding + + ' c := a + b' + LineEnding + + 'end.'; + +procedure TARCTests.TestARC_StringValueParam_AddRefOnEntry; +var + IR: string; +begin + IR := GenIR(SrcValParam); + AssertTrue('addref for string value param', IRContains(IR, 'call $_StringAddRef')); +end; + +procedure TARCTests.TestARC_StringValueParam_ReleaseOnExit; +var + IR: string; +begin + IR := GenIR(SrcValParam); + AssertTrue('release for string value param', IRContains(IR, 'call $_StringRelease')); +end; + +procedure TARCTests.TestARC_StringVarParam_NoAddRef; +var + IR: string; +begin + IR := GenIR(SrcVarParam); + AssertFalse('no addref for string var param', IRContains(IR, 'call $_StringAddRef')); +end; + +procedure TARCTests.TestARC_StringVarParam_NoRelease; +var + IR: string; +begin + IR := GenIR(SrcVarParam); + AssertFalse('no release for string var param', IRContains(IR, 'call $_StringRelease')); +end; + +procedure TARCTests.TestARC_StringConcat_SemanticOK; +var + L: TLexer; + P: TParser; + Pr: TProgram; + A: TSemanticAnalyser; +begin + L := TLexer.Create(SrcConcat); + P := TParser.Create(L); + Pr := P.Parse; + A := TSemanticAnalyser.Create; + try + A.Analyse(Pr); + AssertTrue('semantic analysis completed without error', True); + finally + A.Free; + Pr.Free; + P.Free; + L.Free; + end; +end; + +procedure TARCTests.TestARC_StringConcat_CallsRTL; +var + IR: string; +begin + IR := GenIR(SrcConcat); + AssertTrue('string concat calls RTL', IRContains(IR, '$_StringConcat')); +end; + initialization RegisterTest(TARCTests);