diff --git a/packages/fcl-passrc/src/pasresolveeval.pas b/packages/fcl-passrc/src/pasresolveeval.pas index 92091f71e2..8efdda46be 100644 --- a/packages/fcl-passrc/src/pasresolveeval.pas +++ b/packages/fcl-passrc/src/pasresolveeval.pas @@ -169,6 +169,7 @@ const nTypeXIsNotYetCompletelyDefined = 3107; nDuplicateCaseValueXatY = 3108; nMissingFieldsX = 3109; + nCantAssignValuesToConstVariable = 3110; // resourcestring patterns of messages resourcestring @@ -270,6 +271,7 @@ resourcestring sTypeXIsNotYetCompletelyDefined = 'type "%s" is not yet completely defined'; sDuplicateCaseValueXatY = 'Duplicate case value "%s", other at %s'; sMissingFieldsX = 'Missing fields: "%s"'; + sCantAssignValuesToConstVariable = 'Can''t assign values to const variable'; type { TResolveData - base class for data stored in TPasElement.CustomData } diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index f8e582b9b3..7d645fb376 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -148,6 +148,7 @@ Works: - TypedPointer:=@Some - pointer[index], (@i)[index] - dispose(pointerofrecord), new(pointerofrecord) + - $PointerMath on|off - emit hints - platform, deprecated, experimental, library, unimplemented - hiding ancestor method @@ -201,13 +202,12 @@ Works: - eval +, -, *, /, ^^ - float*currency and currency*float computes to currency - type alias type overloads +- $writeableconst off $J- ToDo: - $pop, $push -- $writableconst off $J- - $RTTI inherited|explicit - range checking: - - indexedprop[param] - defaultvalue - fail to write a loop var inside the loop - nested classes @@ -14995,6 +14995,8 @@ begin {$ENDIF} if ResolvedEl.IdentEl is TPasProperty then RaiseMsg(20170216152427,nPropertyNotWritable,sPropertyNotWritable,[],ErrorEl) + else if ResolvedEl.IdentEl is TPasConst then + RaiseMsg(20180430012042,nCantAssignValuesToConstVariable,sCantAssignValuesToConstVariable,[],ErrorEl) else RaiseMsg(20170216152429,nVariableIdentifierExpected,sVariableIdentifierExpected,[],ErrorEl); end; @@ -16485,7 +16487,12 @@ begin writeln('TPasResolver.CheckParamCompatibility NeedWritable: ',GetResolverResultDbg(ExprResolved)); {$ENDIF} if RaiseOnError then - RaiseMsg(20170216152450,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Expr); + begin + if ExprResolved.IdentEl is TPasConst then + RaiseMsg(20180430012609,nCantAssignValuesToConstVariable,sCantAssignValuesToConstVariable,[],Expr) + else + RaiseMsg(20180430012457,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Expr); + end; exit; end; if (ParamResolved.BaseType=ExprResolved.BaseType) then @@ -17871,12 +17878,15 @@ begin // e.g. 'var a:b' -> compute b, use a as IdentEl if TPasConst(El).VarType<>nil then begin - // typed const -> just like a var - if rcConstant in Flags then + // typed const + if (not TPasConst(El).IsConst) and ([rcConstant,rcType]*Flags<>[]) then RaiseConstantExprExp(20170216152739,StartEl); ComputeElement(TPasConst(El).VarType,ResolvedEl,Flags+[rcType],StartEl); ResolvedEl.IdentEl:=El; - ResolvedEl.Flags:=[rrfReadable,rrfWritable]; + if TPasConst(El).IsConst then + ResolvedEl.Flags:=[rrfReadable] + else + ResolvedEl.Flags:=[rrfReadable,rrfWritable]; end else begin diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 1e51f84766..3a576e0e3c 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -3649,6 +3649,8 @@ begin NextToken; if CurToken = tkColon then begin + if not (bsWriteableConst in Scanner.CurrentBoolSwitches) then + Result.IsConst:=true; OldForceCaret:=Scanner.SetForceCaret(True); try Result.VarType := ParseType(Result,CurSourcePos); diff --git a/packages/fcl-passrc/src/pscanner.pp b/packages/fcl-passrc/src/pscanner.pp index ee733d12c8..e670a22c8f 100644 --- a/packages/fcl-passrc/src/pscanner.pp +++ b/packages/fcl-passrc/src/pscanner.pp @@ -337,11 +337,11 @@ const ); bsAll = [low(TBoolSwitch)..high(TBoolSwitch)]; - bsFPCMode: TBoolSwitches = [bsPointerMath]; - bsObjFPCMode: TBoolSwitches = [bsPointerMath]; - bsDelphiMode: TBoolSwitches = []; - bsDelphiUnicodeMode: TBoolSwitches = []; - bsMacPasMode: TBoolSwitches = [bsPointerMath]; + bsFPCMode: TBoolSwitches = [bsPointerMath,bsWriteableConst]; + bsObjFPCMode: TBoolSwitches = [bsPointerMath,bsWriteableConst]; + bsDelphiMode: TBoolSwitches = [bsWriteableConst]; + bsDelphiUnicodeMode: TBoolSwitches = [bsWriteableConst]; + bsMacPasMode: TBoolSwitches = [bsPointerMath,bsWriteableConst]; type TValueSwitch = ( @@ -3150,6 +3150,8 @@ begin Result:=HandleInclude(Param); 'INTERFACES': HandleInterfaces(Param); + 'LONGSTRINGS': + DoBoolDirective(bsLongStrings); 'MACRO': DoBoolDirective(bsMacro); 'MESSAGE': @@ -3162,8 +3164,16 @@ begin DoLog(mtNote,nUserDefined,SUserDefined,[Param]); 'NOTES': DoBoolDirective(bsNotes); + 'OBJECTCHECKS': + DoBoolDirective(bsObjectChecks); + 'POINTERMATH': + DoBoolDirective(bsPointerMath); + 'RANGECHECKS': + DoBoolDirective(bsRangeChecks); 'SCOPEDENUMS': DoBoolDirective(bsScopedEnums); + 'TYPEDADDRESS': + DoBoolDirective(bsTypedAddress); 'TYPEINFO': DoBoolDirective(bsTypeInfo); 'UNDEF': @@ -3172,6 +3182,8 @@ begin DoLog(mtWarning,nUserDefined,SUserDefined,[Param]); 'WARNINGS': DoBoolDirective(bsWarnings); + 'WRITEABLECONST': + DoBoolDirective(bsWriteableConst); else Handled:=false; end; diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 9afea2eb07..fa117ebd17 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -207,6 +207,9 @@ type Procedure TestConstFloatOperators; Procedure TestFloatTypeCast; Procedure TestCurrency; + Procedure TestWritableConst; + Procedure TestWritableConst_AssignFail; + Procedure TestWritableConst_PassVarFail; // boolean Procedure TestBoolTypeCast; @@ -2646,6 +2649,42 @@ begin CheckResolverUnexpectedHints; end; +procedure TTestResolver.TestWritableConst; +begin + StartProgram(false); + Add([ + '{$writeableconst off}', + 'const i: longint = 3;', + 'begin', + '']); + ParseProgram; +end; + +procedure TTestResolver.TestWritableConst_AssignFail; +begin + StartProgram(false); + Add([ + '{$writeableconst off}', + 'const i: longint = 3;', + 'begin', + ' i:=4;', + '']); + CheckResolverException(sCantAssignValuesToConstVariable,nCantAssignValuesToConstVariable); +end; + +procedure TTestResolver.TestWritableConst_PassVarFail; +begin + StartProgram(false); + Add([ + '{$writeableconst off}', + 'const i: longint = 3;', + 'procedure DoIt(var j: longint); external;', + 'begin', + ' DoIt(i);', + '']); + CheckResolverException(sCantAssignValuesToConstVariable,nCantAssignValuesToConstVariable); +end; + procedure TTestResolver.TestBoolTypeCast; begin StartProgram(false); diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index f25ea5d00f..f6e7c74d8b 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -343,7 +343,7 @@ Works: ToDos: - option typecast checking -Ct -- writable const +- $writableconst - 'new', 'Function' -> class var use .prototype - btArrayLit a: array of jsvalue; @@ -391,13 +391,14 @@ Not in Version 1.0: - set operators on literals without temporary arrays, a in [b], [a]*b<>[] - nested procs without var, instead as "function name(){}" - combine multiple var a=0,b=0 + - skip clone record for new record + - SetLength(scope.a,l) -> read scope only once, same for + Include, Exclude, Inc, Dec, +=, -=, *=, /= -O1 insert local/unit vars for global type references: at start of intf var $r1; at end of impl: $r1=path; -O1 insert unit vars for complex literals -O1 no function Result var when assigned only once - - SetLength(scope.a,l) -> read scope only once, same for - Include, Exclude, Inc, Dec, +=, -=, *=, /= -O1 replace constant expression with result -O1 pass array element by ref: when index is constant, use that directly - objects @@ -1031,6 +1032,7 @@ const msAllPas2jsBoolSwitches = [ bsAssertions, bsRangeChecks, + bsWriteableConst, bsTypeInfo, bsOverflowChecks, bsHints, diff --git a/packages/pastojs/src/pas2jscompiler.pp b/packages/pastojs/src/pas2jscompiler.pp index 718e0aad5e..32836ed76d 100644 --- a/packages/pastojs/src/pas2jscompiler.pp +++ b/packages/pastojs/src/pas2jscompiler.pp @@ -767,7 +767,7 @@ function TPas2jsCompilerFile.GetInitialBoolSwitches: TBoolSwitches; var bs: TBoolSwitches; begin - bs:=[]; + bs:=[bsWriteableConst]; if coOverflowChecks in Compiler.Options then Include(bs,bsOverflowChecks); if coRangeChecks in Compiler.Options then diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index 19632bbdc9..e82640b4b1 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -1038,7 +1038,7 @@ begin aScanner.CurrentModeSwitches:=OBJFPCModeSwitches*msAllPas2jsModeSwitches+msAllPas2jsModeSwitchesReadOnly; aScanner.AllowedBoolSwitches:=msAllPas2jsBoolSwitches; - aScanner.CurrentBoolSwitches:=[bsHints,bsNotes,bsWarnings]; + aScanner.CurrentBoolSwitches:=[bsHints,bsNotes,bsWarnings,bsWriteableConst]; end; procedure TCustomTestModule.TearDown;