Allow decimal constants

docs/release-notes/.FSharp.Compiler.Service/9.0.200.md

@@ -8,6 +8,7 @@
 
 ### Added
 
+* Support literal attribute on decimals ([PR #17769](https://github.com/dotnet/fsharp/pull/17769))
 
 ### Changed
 

src/Compiler/Checking/PostInferenceChecks.fs

@@ -1958,7 +1958,8 @@ and CheckAttribArgExpr cenv env expr =
         | Const.Single _
         | Const.Char _
         | Const.Zero
-        | Const.String _  -> ()
+        | Const.String _  
+        | Const.Decimal _ -> ()
         | _ ->
             if cenv.reportErrors then
                 errorR (Error (FSComp.SR.tastNotAConstantExpression(), m))

src/Compiler/CodeGen/IlxGen.fs

@@ -8563,10 +8563,15 @@ and GenBindingAfterDebugPoint cenv cgbuf eenv bind isStateVar startMarkOpt =
 
             let ilFieldDef = mkILStaticField (fspec.Name, fty, None, None, access)
 
+            let isDecimalConstant =
+                match vref.LiteralValue with
+                | Some(Const.Decimal _) -> true
+                | _ -> false
+
             let ilFieldDef =
                 match vref.LiteralValue with
-                | Some konst -> ilFieldDef.WithLiteralDefaultValue(Some(GenFieldInit m konst))
-                | None -> ilFieldDef
+                | Some konst when not isDecimalConstant -> ilFieldDef.WithLiteralDefaultValue(Some(GenFieldInit m konst))
+                | _ -> ilFieldDef
 
             let ilFieldDef =
                 let isClassInitializer = (cgbuf.MethodName = ".cctor")
@@ -8578,6 +8583,7 @@ and GenBindingAfterDebugPoint cenv cgbuf eenv bind isStateVar startMarkOpt =
                         || not isClassInitializer
                         || hasLiteralAttr
                     )
+                    || isDecimalConstant
                 )
 
             let ilAttribs =
@@ -8590,6 +8596,64 @@ and GenBindingAfterDebugPoint cenv cgbuf eenv bind isStateVar startMarkOpt =
 
             let ilAttribs = GenAdditionalAttributesForTy g vspec.Type @ ilAttribs
 
+            let ilAttribs =
+                if isDecimalConstant then
+                    match vref.LiteralValue with
+                    | Some(Const.Decimal d) ->
+                        match System.Decimal.GetBits d with
+                        | [| lo; med; hi; signExp |] ->
+                            let scale = (min (((signExp &&& 0xFF0000) >>> 16) &&& 0xFF) 28) |> byte
+                            let sign = if (signExp &&& 0x80000000) <> 0 then 1uy else 0uy
+
+                            let attrib =
+                                mkILCustomAttribute (
+                                    g.attrib_DecimalConstantAttribute.TypeRef,
+                                    [
+                                        g.ilg.typ_Byte
+                                        g.ilg.typ_Byte
+                                        g.ilg.typ_Int32
+                                        g.ilg.typ_Int32
+                                        g.ilg.typ_Int32
+                                    ],
+                                    [
+                                        ILAttribElem.Byte scale
+                                        ILAttribElem.Byte sign
+                                        ILAttribElem.UInt32(uint32 hi)
+                                        ILAttribElem.UInt32(uint32 med)
+                                        ILAttribElem.UInt32(uint32 lo)
+                                    ],
+                                    []
+                                )
+
+                            let ilInstrs =
+                                [
+                                    mkLdcInt32 lo
+                                    mkLdcInt32 med
+                                    mkLdcInt32 hi
+                                    mkLdcInt32 (int32 sign)
+                                    mkLdcInt32 (int32 scale)
+                                    mkNormalNewobj (
+                                        mkILCtorMethSpecForTy (
+                                            fspec.ActualType,
+                                            [
+                                                g.ilg.typ_Int32
+                                                g.ilg.typ_Int32
+                                                g.ilg.typ_Int32
+                                                g.ilg.typ_Bool
+                                                g.ilg.typ_Byte
+                                            ]
+                                        )
+                                    )
+                                    mkNormalStsfld fspec
+                                ]
+
+                            CG.EmitInstrs cgbuf (pop 0) (Push0) ilInstrs
+                            [ attrib ]
+                        | _ -> failwith "unreachable"
+                    | _ -> failwith "unreachable"
+                else
+                    ilAttribs
+
             let ilFieldDef =
                 ilFieldDef.With(customAttrs = mkILCustomAttrs (ilAttribs @ [ g.DebuggerBrowsableNeverAttribute ]))
 

src/Compiler/TypedTree/TcGlobals.fs

@@ -1490,6 +1490,7 @@ type TcGlobals(
   member val attrib_CallerFilePathAttribute = findSysAttrib "System.Runtime.CompilerServices.CallerFilePathAttribute"
   member val attrib_CallerMemberNameAttribute = findSysAttrib "System.Runtime.CompilerServices.CallerMemberNameAttribute"
   member val attrib_SkipLocalsInitAttribute  = findSysAttrib "System.Runtime.CompilerServices.SkipLocalsInitAttribute"
+  member val attrib_DecimalConstantAttribute = findSysAttrib "System.Runtime.CompilerServices.DecimalConstantAttribute"
   member val attribs_Unsupported = v_attribs_Unsupported
 
   member val attrib_ProjectionParameterAttribute           = mk_MFCore_attrib "ProjectionParameterAttribute"

src/Compiler/TypedTree/TcGlobals.fsi

@@ -474,6 +474,8 @@ type internal TcGlobals =
 
     member attrib_SkipLocalsInitAttribute: BuiltinAttribInfo
 
+    member attrib_DecimalConstantAttribute: BuiltinAttribInfo
+
     member attrib_StructAttribute: BuiltinAttribInfo
 
     member attrib_StructLayoutAttribute: BuiltinAttribInfo

src/Compiler/TypedTree/TypedTreeOps.fs

@@ -10020,7 +10020,7 @@ let EvalArithUnOp (opInt8, opInt16, opInt32, opInt64, opUInt8, opUInt16, opUInt3
         | _ -> error (Error ( FSComp.SR.tastNotAConstantExpression(), m))
     with :? System.OverflowException -> error (Error ( FSComp.SR.tastConstantExpressionOverflow(), m))
 
-let EvalArithBinOp (opInt8, opInt16, opInt32, opInt64, opUInt8, opUInt16, opUInt32, opUInt64, opSingle, opDouble) (arg1: Expr) (arg2: Expr) =
+let EvalArithBinOp (opInt8, opInt16, opInt32, opInt64, opUInt8, opUInt16, opUInt32, opUInt64, opSingle, opDouble, opDecimal) (arg1: Expr) (arg2: Expr) =
     // At compile-time we check arithmetic
     let m = unionRanges arg1.Range arg2.Range
     try
@@ -10035,6 +10035,7 @@ let EvalArithBinOp (opInt8, opInt16, opInt32, opInt64, opUInt8, opUInt16, opUInt
         | Expr.Const (Const.UInt64 x1, _, ty), Expr.Const (Const.UInt64 x2, _, _) -> Expr.Const (Const.UInt64 (opUInt64 x1 x2), m, ty)
         | Expr.Const (Const.Single x1, _, ty), Expr.Const (Const.Single x2, _, _) -> Expr.Const (Const.Single (opSingle x1 x2), m, ty)
         | Expr.Const (Const.Double x1, _, ty), Expr.Const (Const.Double x2, _, _) -> Expr.Const (Const.Double (opDouble x1 x2), m, ty)
+        | Expr.Const (Const.Decimal x1, _, ty), Expr.Const (Const.Decimal x2, _, _) -> Expr.Const (Const.Decimal (opDecimal x1 x2), m, ty)
         | _ -> error (Error ( FSComp.SR.tastNotAConstantExpression(), m))
     with :? System.OverflowException -> error (Error ( FSComp.SR.tastConstantExpressionOverflow(), m))
 
@@ -10066,9 +10067,10 @@ let rec EvalAttribArgExpr suppressLangFeatureCheck (g: TcGlobals) (x: Expr) =
         | Const.Single _
         | Const.Char _
         | Const.Zero
-        | Const.String _ -> 
+        | Const.String _
+        | Const.Decimal _ ->
             x
-        | Const.Decimal _ | Const.IntPtr _ | Const.UIntPtr _ | Const.Unit ->
+        | Const.IntPtr _ | Const.UIntPtr _ | Const.Unit ->
             errorR (Error ( FSComp.SR.tastNotAConstantExpression(), m))
             x
 
@@ -10084,7 +10086,7 @@ let rec EvalAttribArgExpr suppressLangFeatureCheck (g: TcGlobals) (x: Expr) =
 
         match v1 with
         | IntegerConstExpr ->
-            EvalArithBinOp ((|||), (|||), (|||), (|||), (|||), (|||), (|||), (|||), ignore2, ignore2) v1 (EvalAttribArgExpr suppressLangFeatureCheck g arg2) 
+            EvalArithBinOp ((|||), (|||), (|||), (|||), (|||), (|||), (|||), (|||), ignore2, ignore2, ignore2) v1 (EvalAttribArgExpr suppressLangFeatureCheck g arg2) 
         | _ ->
             errorR (Error ( FSComp.SR.tastNotAConstantExpression(), x.Range))
             x
@@ -10099,7 +10101,7 @@ let rec EvalAttribArgExpr suppressLangFeatureCheck (g: TcGlobals) (x: Expr) =
             Expr.Const (Const.Char (x1 + x2), m, ty)
         | _ ->
             checkFeature()
-            EvalArithBinOp (Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+)) v1 v2
+            EvalArithBinOp (Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+)) v1 v2
     | SpecificBinopExpr g g.unchecked_subtraction_vref (arg1, arg2) ->
         checkFeature()
         let v1, v2 = EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1, EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2
@@ -10108,16 +10110,16 @@ let rec EvalAttribArgExpr suppressLangFeatureCheck (g: TcGlobals) (x: Expr) =
         | Expr.Const (Const.Char x1, m, ty), Expr.Const (Const.Char x2, _, _) ->
             Expr.Const (Const.Char (x1 - x2), m, ty)
         | _ ->
-            EvalArithBinOp (Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-)) v1 v2
+            EvalArithBinOp (Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-)) v1 v2
     | SpecificBinopExpr g g.unchecked_multiply_vref (arg1, arg2) ->
         checkFeature()
-        EvalArithBinOp (Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*)) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2)
+        EvalArithBinOp (Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*)) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2)
     | SpecificBinopExpr g g.unchecked_division_vref (arg1, arg2) ->
         checkFeature()
-        EvalArithBinOp ((/), (/), (/), (/), (/), (/), (/), (/), (/), (/)) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2)
+        EvalArithBinOp ((/), (/), (/), (/), (/), (/), (/), (/), (/), (/), (/)) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2)
     | SpecificBinopExpr g g.unchecked_modulus_vref (arg1, arg2) ->
         checkFeature()
-        EvalArithBinOp ((%), (%), (%), (%), (%), (%), (%), (%), (%), (%)) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2)
+        EvalArithBinOp ((%), (%), (%), (%), (%), (%), (%), (%), (%), (%), (%)) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2)
     | SpecificBinopExpr g g.bitwise_shift_left_vref (arg1, arg2) ->
         checkFeature()
         EvalArithShiftOp ((<<<), (<<<), (<<<), (<<<), (<<<), (<<<), (<<<), (<<<)) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2)
@@ -10130,7 +10132,7 @@ let rec EvalAttribArgExpr suppressLangFeatureCheck (g: TcGlobals) (x: Expr) =
 
         match v1 with
         | IntegerConstExpr ->
-            EvalArithBinOp ((&&&), (&&&), (&&&), (&&&), (&&&), (&&&), (&&&), (&&&), ignore2, ignore2) v1 (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2)
+            EvalArithBinOp ((&&&), (&&&), (&&&), (&&&), (&&&), (&&&), (&&&), (&&&), ignore2, ignore2, ignore2) v1 (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2)
         | _ ->
             errorR (Error ( FSComp.SR.tastNotAConstantExpression(), x.Range))
             x
@@ -10140,7 +10142,7 @@ let rec EvalAttribArgExpr suppressLangFeatureCheck (g: TcGlobals) (x: Expr) =
 
         match v1 with
         | IntegerConstExpr ->
-            EvalArithBinOp ((^^^), (^^^), (^^^), (^^^), (^^^), (^^^), (^^^), (^^^), ignore2, ignore2) v1 (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2)
+            EvalArithBinOp ((^^^), (^^^), (^^^), (^^^), (^^^), (^^^), (^^^), (^^^), ignore2, ignore2, ignore2) v1 (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2)
         | _ ->
             errorR (Error (FSComp.SR.tastNotAConstantExpression(), x.Range))
             x
@@ -10150,7 +10152,7 @@ let rec EvalAttribArgExpr suppressLangFeatureCheck (g: TcGlobals) (x: Expr) =
 
         match v1 with
         | FloatConstExpr ->
-            EvalArithBinOp (ignore2, ignore2, ignore2, ignore2, ignore2, ignore2, ignore2, ignore2, ( ** ), ( ** )) v1 (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2)
+            EvalArithBinOp (ignore2, ignore2, ignore2, ignore2, ignore2, ignore2, ignore2, ignore2, ( ** ), ( ** ), ignore2) v1 (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2)
         | _ ->
             errorR (Error (FSComp.SR.tastNotAConstantExpression(), x.Range))
             x

tests/FSharp.Compiler.ComponentTests/Conformance/BasicGrammarElements/LetBindings/Basic/Basic.fs

@@ -144,13 +144,12 @@ module LetBindings_Basic =
         |> verifyCompile
         |> shouldFail
         |> withDiagnostics [
-            (Error 267, Line 11, Col 18, Line 11, Col 19, "This is not a valid constant expression or custom attribute value")
-            (Error 837, Line 11, Col 13, Line 11, Col 31, "This is not a valid constant expression")
-            (Error 267, Line 14, Col 13, Line 14, Col 17, "This is not a valid constant expression or custom attribute value")
-            (Error 267, Line 17, Col 13, Line 17, Col 15, "This is not a valid constant expression or custom attribute value")
-            (Error 267, Line 20, Col 13, Line 20, Col 17, "This is not a valid constant expression or custom attribute value")
-            (Error 267, Line 23, Col 13, Line 23, Col 18, "This is not a valid constant expression or custom attribute value")
-            (Warning 3178, Line 26, Col 13, Line 26, Col 26, "This is not valid literal expression. The [<Literal>] attribute will be ignored.")
+            (Error 267, Line 10, Col 18, Line 10, Col 19, "This is not a valid constant expression or custom attribute value")
+            (Error 837, Line 10, Col 13, Line 10, Col 31, "This is not a valid constant expression")
+            (Error 267, Line 16, Col 13, Line 16, Col 15, "This is not a valid constant expression or custom attribute value")
+            (Error 267, Line 19, Col 13, Line 19, Col 17, "This is not a valid constant expression or custom attribute value")
+            (Error 267, Line 22, Col 13, Line 22, Col 18, "This is not a valid constant expression or custom attribute value")
+            (Warning 3178, Line 25, Col 13, Line 25, Col 26, "This is not valid literal expression. The [<Literal>] attribute will be ignored.")
         ]
 
     // SOURCE=E_Pathological01.fs SCFLAGS=--test:ErrorRanges                   # E_Pathological01.fs
@@ -303,4 +302,4 @@ type C() =
         |> withDiagnostics [
             (Warning 3582, Line 4, Col 5, Line 4, Col 12, "This is a function definition that shadows a union case. If this is what you want, ignore or suppress this warning. If you want it to be a union case deconstruction, add parentheses.")
             (Warning 3582, Line 5, Col 5, Line 5, Col 11, "This is a function definition that shadows a union case. If this is what you want, ignore or suppress this warning. If you want it to be a union case deconstruction, add parentheses.")
-        ]
+        ]

tests/FSharp.Compiler.ComponentTests/Conformance/BasicGrammarElements/LetBindings/Basic/E_Literals04.fs

@@ -1,11 +1,10 @@
 // #Regression #Conformance #DeclarationElements #LetBindings 
-//<Expects status="error" span="(11,18)" id="FS0267">This is not a valid constant expression or custom attribute value$</Expects>
-//<Expects status="error" span="(11,13)" id="FS0837">This is not a valid constant expression$</Expects>
-//<Expects status="error" span="(14,13)" id="FS0267">This is not a valid constant expression or custom attribute value$</Expects>
-//<Expects status="error" span="(17,13)" id="FS0267">This is not a valid constant expression or custom attribute value$</Expects>
-//<Expects status="error" span="(20,13)" id="FS0267">This is not a valid constant expression or custom attribute value$</Expects>
-//<Expects status="error" span="(23,13)" id="FS0267">This is not a valid constant expression or custom attribute value$</Expects>
-//<Expects status="warning" span="(26,13)" id="FS3178">This is not valid literal expression. The \[<Literal>\] attribute will be ignored\.$</Expects>
+//<Expects status="error" span="(10,18)" id="FS0267">This is not a valid constant expression or custom attribute value$</Expects>
+//<Expects status="error" span="(10,13)" id="FS0837">This is not a valid constant expression$</Expects>
+//<Expects status="error" span="(16,13)" id="FS0267">This is not a valid constant expression or custom attribute value$</Expects>
+//<Expects status="error" span="(19,13)" id="FS0267">This is not a valid constant expression or custom attribute value$</Expects>
+//<Expects status="error" span="(22,13)" id="FS0267">This is not a valid constant expression or custom attribute value$</Expects>
+//<Expects status="warning" span="(25,13)" id="FS3178">This is not valid literal expression. The \[<Literal>\] attribute will be ignored\.$</Expects>
 
 [<Literal>]
 let lit01 = (let x = "2" in x)

tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Decimal/Decimal.fs

@@ -0,0 +1,26 @@
+// Copyright (c) Microsoft Corporation.  All Rights Reserved.  See License.txt in the project root for license information.
+
+namespace Conformance.PatternMatching
+
+open Xunit
+open FSharp.Test
+open FSharp.Test.Compiler
+
+module Decimal =
+
+    [<Theory; Directory(__SOURCE_DIRECTORY__, Includes=[|"literal01.fs"|])>]
+    let ``Decimal - literal01.fs - --test:ErrorRanges`` compilation =
+        compilation
+        |> asFsx
+        |> withOptions ["--test:ErrorRanges";]
+        |> compile
+        |> shouldSucceed
+
+    [<Theory; Directory(__SOURCE_DIRECTORY__, Includes = [|"incompleteMatchesLiteral01.fs"|])>]
+    let ``Decimal - incompleteMatchesLiteral01.fs - --test:ErrorRanges`` compilation =
+        compilation
+        |> asFs
+        |> withOptions ["--test:ErrorRanges"]
+        |> typecheck
+        |> shouldFail
+        |> withSingleDiagnostic (Warning 25, Line 7, Col 11, Line 7, Col 13, "Incomplete pattern matches on this expression. For example, the value '3M' may indicate a case not covered by the pattern(s).")

tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Decimal/incompleteMatchesLiteral01.fs

@@ -0,0 +1,11 @@
+[<Literal>]
+let One = 1m
+[<Literal>]
+let Two = 2m
+
+let test() = 
+    match 3m with
+    | 0m -> false
+    | One | Two -> false
+
+exit 0

tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Decimal/literal01.fs

@@ -0,0 +1,26 @@
+// #Conformance #PatternMatching 
+#light
+
+// Pattern match decimal literals
+
+[<Literal>]
+let Decimal1 = 5m
+
+[<Literal>]
+let Decimal2 = 42.42m
+
+let testDecimal x =
+    match x with
+    | Decimal1 -> 1
+    | Decimal2 -> 2
+    | _ -> 0
+
+if testDecimal 1m <> 0 then exit 1
+
+if testDecimal Decimal1 <> 1 then exit 1
+if testDecimal 5m <> 1 then exit 1
+
+if testDecimal Decimal2 <> 2 then exit 1
+if testDecimal 42.42m <> 2 then exit 1
+
+exit 0