fcl-passrc: $Writeableconst

git-svn-id: trunk@38872 -

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 }

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

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);

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;

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);

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,

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

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;