diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt index 974660313e3..8e827dd3fcd 100644 --- a/src/fsharp/FSComp.txt +++ b/src/fsharp/FSComp.txt @@ -475,6 +475,7 @@ parsMultiArgumentGenericTypeFormDeprecated,"The syntax '(typ,...,typ) ident' is 622,parsMismatchedQuotationName,"Mismatched quotation operator name, beginning with '%s'" 623,parsActivePatternCaseMustBeginWithUpperCase,"Active pattern case identifiers must begin with an uppercase letter" 624,parsActivePatternCaseContainsPipe,"The '|' character is not permitted in active pattern case identifiers" +625,parsIllegalDenominatorForMeasureExponent,"Denominator must not be 0 in unit-of-measure exponent" parsNoEqualShouldFollowNamespace,"No '=' symbol should follow a 'namespace' declaration" parsSyntaxModuleStructEndDeprecated,"The syntax 'module ... = struct .. end' is not used in F# code. Consider using 'module ... = begin .. end'" parsSyntaxModuleSigEndDeprecated,"The syntax 'module ... : sig .. end' is not used in F# code. Consider using 'module ... = begin .. end'" diff --git a/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj b/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj index 890139012d3..a4a4cfe2e8c 100644 --- a/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj +++ b/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj @@ -179,6 +179,12 @@ range.fs + + rational.fsi + + + rational.fs + ErrorLogger.fs diff --git a/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj b/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj index 51255bc02fa..41f5c106d69 100644 --- a/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj +++ b/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj @@ -135,6 +135,12 @@ Utilities\TraceCall.fs + + ErrorLogging\rational.fsi + + + ErrorLogging\rational.fs + ErrorLogging\range.fsi @@ -501,6 +507,7 @@ + diff --git a/src/fsharp/FSharp.LanguageService.Compiler/FSharp.LanguageService.Compiler.fsproj b/src/fsharp/FSharp.LanguageService.Compiler/FSharp.LanguageService.Compiler.fsproj index 93b5172b918..3309752329d 100644 --- a/src/fsharp/FSharp.LanguageService.Compiler/FSharp.LanguageService.Compiler.fsproj +++ b/src/fsharp/FSharp.LanguageService.Compiler/FSharp.LanguageService.Compiler.fsproj @@ -197,6 +197,12 @@ range.fs + + rational.fsi + + + rational.fs + ErrorLogger.fs @@ -450,6 +456,7 @@ + diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index b104d8e63e2..1250e20fe4e 100644 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -16,6 +16,7 @@ open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Rational open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Tast @@ -814,14 +815,16 @@ module private PrintTypes = and private layoutMeasure denv unt = let sortVars vs = vs |> List.sortBy (fun (v:Typar,_) -> v.DisplayName) let sortCons cs = cs |> List.sortBy (fun (c:TyconRef,_) -> c.DisplayName) - let negvs,posvs = ListMeasureVarOccsWithNonZeroExponents unt |> sortVars |> List.partition (fun (_,e) -> e<0) - let negcs,poscs = ListMeasureConOccsWithNonZeroExponents denv.g false unt |> sortCons |> List.partition (fun (_,e) -> e<0) + let negvs,posvs = ListMeasureVarOccsWithNonZeroExponents unt |> sortVars |> List.partition (fun (_,e) -> SignRational e < 0) + let negcs,poscs = ListMeasureConOccsWithNonZeroExponents denv.g false unt |> sortCons |> List.partition (fun (_,e) -> SignRational e < 0) let unparL uv = layoutTyparRef denv uv let unconL tc = layoutTyconRef denv tc - let prefix = spaceListL (List.map (fun (v,e) -> if e=1 then unparL v else unparL v -- wordL (sprintf "^ %d" e)) posvs @ - List.map (fun (c,e) -> if e=1 then unconL c else unconL c -- wordL (sprintf "^ %d" e)) poscs) - let postfix = spaceListL (List.map (fun (v,e) -> if e= -1 then unparL v else unparL v -- wordL (sprintf "^ %d" (-e))) negvs @ - List.map (fun (c,e) -> if e= -1 then unconL c else unconL c -- wordL (sprintf "^ %d" (-e))) negcs) + let rationalL e = wordL (RationalToString e) + let measureToPowerL x e = if e = OneRational then x else x -- wordL "^" -- rationalL e + let prefix = spaceListL (List.map (fun (v,e) -> measureToPowerL (unparL v) e) posvs @ + List.map (fun (c,e) -> measureToPowerL (unconL c) e) poscs) + let postfix = spaceListL (List.map (fun (v,e) -> measureToPowerL (unparL v) (NegRational e)) negvs @ + List.map (fun (c,e) -> measureToPowerL (unconL c) (NegRational e)) negcs) match (negvs,negcs) with | [],[] -> (match posvs,poscs with [],[] -> wordL "1" | _ -> prefix) | _ -> prefix ^^ sepL "/" ^^ (if List.length negvs + List.length negcs > 1 then sepL "(" ^^ postfix ^^ sepL ")" else postfix) diff --git a/src/fsharp/ast.fs b/src/fsharp/ast.fs index d8f1b0f9b44..4222e3b6698 100644 --- a/src/fsharp/ast.fs +++ b/src/fsharp/ast.fs @@ -255,11 +255,20 @@ and | Product of SynMeasure * SynMeasure * range | Seq of SynMeasure list * range | Divide of SynMeasure * SynMeasure * range - | Power of SynMeasure * int * range + | Power of SynMeasure * SynRationalConst * range | One | Anon of range | Var of SynTypar * range +and + [] + /// The unchecked abstract syntax tree of F# unit of measure exponents. + SynRationalConst = + | Integer of int32 + | Rational of int32 * int32 * range + | Negate of SynRationalConst + + //------------------------------------------------------------------------ // AST: the grammar of types, expressions, declarations etc. //----------------------------------------------------------------------- @@ -423,8 +432,8 @@ and | HashConstraint of SynType * range /// F# syntax : for units of measure e.g. m / s | MeasureDivide of SynType * SynType * range - /// F# syntax : for units of measure e.g. m^3 - | MeasurePower of SynType * int * range + /// F# syntax : for units of measure e.g. m^3, kg^1/2 + | MeasurePower of SynType * SynRationalConst * range /// F# syntax : 1, "abc" etc, used in parameters to type providers /// For the dimensionless units i.e. 1 , and static parameters to provided types | StaticConstant of SynConst * range diff --git a/src/fsharp/csolve.fs b/src/fsharp/csolve.fs index 92f338e6e8e..bd128892759 100644 --- a/src/fsharp/csolve.fs +++ b/src/fsharp/csolve.fs @@ -39,6 +39,7 @@ open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Rational open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Tast @@ -358,20 +359,20 @@ let PreferUnifyTypar (v1:Typar) (v2:Typar) = -/// Ensure that vs is ordered so that an element with minimum sized exponent -/// is at the head of the list. Also, if possible, this element should have rigidity TyparRigidity.Flexible -let FindMinimumMeasureExponent vs = - let rec findmin vs = +/// Reorder a list of (variable,exponent) pairs so that a variable that is Preferred +/// is at the head of the list, if possible +let FindPreferredTypar vs = + let rec find vs = match vs with | [] -> vs | (v:Typar,e)::vs -> - match findmin vs with + match find vs with | [] -> [(v,e)] - | (v',e')::vs' -> - if abs e < abs e' || (abs e = abs e' && PreferUnifyTypar v v') + | (v',e')::vs' -> + if PreferUnifyTypar v v' then (v, e) :: vs else (v',e') :: (v,e) :: vs' - findmin vs + find vs let SubstMeasure (r:Typar) ms = if r.Rigidity = TyparRigidity.Rigid then error(InternalError("SubstMeasure: rigid",r.Range)); @@ -447,88 +448,53 @@ let SubstMeasureWarnIfRigid (csenv:ConstraintSolverEnv) trace (v:Typar) ms = WarnD(Error(FSComp.SR.csCodeLessGeneric(),v.Range)) else CompleteD) -/// The division operator in Caml/F# rounds towards zero. For our purposes, -/// we want to round towards negative infinity. -let DivRoundDown x y = - let signx=if x<0 then -1 else 1 - let signy=if y<0 then -1 else 1 - - if signx=signy then x / y - else (x-y+signy) / y - /// Imperatively unify the unit-of-measure expression ms against 1. -/// This is a gcd-like algorithm that proceeds as follows: -/// 1. Express ms in the form 'u1^x1 * ... * 'un^xn * c1^y1 * ... * cm^ym -/// where 'u1,...,'un are non-rigid measure variables, c1,...,cm are measure identifiers or rigid measure variables, -/// x1,...,xn and y1,...,yn are non-zero exponents with |x1| <= |xi| for all i. -/// 2. (a) If m=n=0 then we're done (we're unifying 1 against 1) -/// (b) If m=0 but n<>0 then fail (we're unifying a variable-free expression against 1) -/// (c) If xi is divisible by |x1| for all i, and yj is divisible by |x1| for all j, then -/// immediately solve the constraint with the substitution -/// 'u1 := 'u2^(-x2/x1) * ... * 'un^(-xn/x1) * c1^(-y1/x1) * ... * cm^(-ym/x1) -/// (d) Otherwise, if m=1, fail (example: unifying 'u^2 * kg^3) -/// (e) Otherwise, make the substitution -/// 'u1 := 'u * 'u2^(-x2/x1) * ... * 'un^(-xn/x1) * c1^(-y1/x1) * ... * cm^(-ym/x1) -/// where 'u is a fresh measure variable, and iterate. - -let rec UnifyMeasureWithOne (csenv:ConstraintSolverEnv) trace ms = +/// There are three cases +/// - ms is (equivalent to) 1 +/// - ms contains no non-rigid unit variables, and so cannot be unified with 1 +/// - ms has the form v^e * ms' for some non-rigid variable v, non-zero exponent e, and measure expression ms' +/// the most general unifier is then simply v := ms' ^ -(1/e) +let UnifyMeasureWithOne (csenv:ConstraintSolverEnv) trace ms = + // Gather the rigid and non-rigid unit variables in this measure expression together with their exponents let (rigidVars,nonRigidVars) = (ListMeasureVarOccsWithNonZeroExponents ms) |> List.partition (fun (v,_) -> v.Rigidity = TyparRigidity.Rigid) - let expandedCons = ListMeasureConOccsWithNonZeroExponents csenv.g true ms - let unexpandedCons = ListMeasureConOccsWithNonZeroExponents csenv.g false ms - match FindMinimumMeasureExponent nonRigidVars, rigidVars, expandedCons, unexpandedCons with - | [], [], [], _ -> CompleteD - | [], _, _, _ -> localAbortD - | (v,e)::vs, rigidVars, _, _ -> - // don't break up abbreviations if we can help it! - if unexpandedCons |> List.forall (fun (_,e') -> e' % e = 0) && (vs@rigidVars) |> List.forall (fun (_,e') -> e' % e = 0) - then - let newms = ProdMeasures (List.map (fun (c,e') -> MeasurePower (MeasureCon c) (- (DivRoundDown e' e))) unexpandedCons - @ List.map (fun (v,e') -> MeasurePower (MeasureVar v) (- (DivRoundDown e' e))) (vs @ rigidVars)) - SubstMeasureWarnIfRigid csenv trace v newms - else - let newms = ProdMeasures (List.map (fun (c,e') -> MeasurePower (MeasureCon c) (- (DivRoundDown e' e))) expandedCons - @ List.map (fun (v,e') -> MeasurePower (MeasureVar v) (- (DivRoundDown e' e))) (vs @ rigidVars)) - if expandedCons |> List.forall (fun (_,e') -> e' % e = 0) && (vs@rigidVars) |> List.forall (fun (_,e') -> e' % e = 0) - then SubstMeasureWarnIfRigid csenv trace v newms - elif isNil vs - then localAbortD - else - // New variable v' must inherit WarnIfNotRigid from v - let v' = NewAnonTypar (TyparKind.Measure,v.Range,v.Rigidity,v.StaticReq,v.DynamicReq) - SubstMeasure v (MeasureProd(MeasureVar v', newms)); - UnifyMeasureWithOne csenv trace ms + // If there is at least one non-rigid variable v with exponent e, then we can unify + match FindPreferredTypar nonRigidVars with + | (v,e)::vs -> + let unexpandedCons = ListMeasureConOccsWithNonZeroExponents csenv.g false ms + let newms = ProdMeasures (List.map (fun (c,e') -> MeasureRationalPower (MeasureCon c, NegRational (DivRational e' e))) unexpandedCons + @ List.map (fun (v,e') -> MeasureRationalPower (MeasureVar v, NegRational (DivRational e' e))) (vs @ rigidVars)) + + SubstMeasureWarnIfRigid csenv trace v newms + + // Otherwise we require ms to be 1 + | [] -> + if measureEquiv csenv.g ms MeasureOne then CompleteD else localAbortD + /// Imperatively unify unit-of-measure expression ms1 against ms2 let UnifyMeasures (csenv:ConstraintSolverEnv) trace ms1 ms2 = UnifyMeasureWithOne csenv trace (MeasureProd(ms1,MeasureInv ms2)) - /// Simplify a unit-of-measure expression ms that forms part of a type scheme. /// We make substitutions for vars, which are the (remaining) bound variables /// in the scheme that we wish to simplify. let SimplifyMeasure g vars ms = let rec simp vars = - match FindMinimumMeasureExponent (List.filter (fun (_,e) -> e<>0) (List.map (fun v -> (v, MeasureVarExponent v ms)) vars)) with + match FindPreferredTypar (List.filter (fun (_,e) -> SignRational e<>0) (List.map (fun v -> (v, MeasureVarExponent v ms)) vars)) with | [] -> (vars, None) | (v,e)::vs -> - if e < 0 then - let v' = NewAnonTypar (TyparKind.Measure,v.Range,TyparRigidity.Flexible,v.StaticReq,v.DynamicReq) - let vars' = v' :: ListSet.remove typarEq v vars - SubstMeasure v (MeasureInv (MeasureVar v')); - simp vars' - else - let newv = if v.IsCompilerGenerated then NewAnonTypar (TyparKind.Measure,v.Range,TyparRigidity.Flexible,v.StaticReq,v.DynamicReq) - else NewNamedInferenceMeasureVar (v.Range,TyparRigidity.Flexible,v.StaticReq,v.Id) - let remainingvars = ListSet.remove typarEq v vars - let newms = (ProdMeasures (List.map (fun (c,e') -> MeasurePower (MeasureCon c) (- (DivRoundDown e' e))) (ListMeasureConOccsWithNonZeroExponents g false ms) - @ List.map (fun (v',e') -> if typarEq v v' then MeasureVar newv else MeasurePower (MeasureVar v') (- (DivRoundDown e' e))) (ListMeasureVarOccsWithNonZeroExponents ms))); - SubstMeasure v newms; - match vs with - | [] -> (remainingvars, Some newv) - | _ -> simp (newv::remainingvars) - + let newvar = if v.IsCompilerGenerated then NewAnonTypar (TyparKind.Measure,v.Range,TyparRigidity.Flexible,v.StaticReq,v.DynamicReq) + else NewNamedInferenceMeasureVar (v.Range,TyparRigidity.Flexible,v.StaticReq,v.Id) + let remainingvars = ListSet.remove typarEq v vars + let newvarExpr = if SignRational e < 0 then MeasureInv (MeasureVar newvar) else MeasureVar newvar + let newms = (ProdMeasures (List.map (fun (c,e') -> MeasureRationalPower (MeasureCon c, NegRational (DivRational e' e))) (ListMeasureConOccsWithNonZeroExponents g false ms) + @ List.map (fun (v',e') -> if typarEq v v' then newvarExpr else MeasureRationalPower (MeasureVar v', NegRational (DivRational e' e))) (ListMeasureVarOccsWithNonZeroExponents ms))); + SubstMeasure v newms; + match vs with + | [] -> (remainingvars, Some newvar) + | _ -> simp (newvar::remainingvars) simp vars // Normalize a type ty that forms part of a unit-of-measure-polymorphic type scheme. @@ -570,16 +536,46 @@ let rec SimplifyMeasuresInConstraints g param cs = let param' = SimplifyMeasuresInConstraint g param c SimplifyMeasuresInConstraints g param' cs +let rec GetMeasureVarGcdInType v ty = + match stripTyparEqns ty with + | TType_ucase(_,l) + | TType_app (_,l) + | TType_tuple l -> GetMeasureVarGcdInTypes v l + | TType_fun (d,r) -> GcdRational (GetMeasureVarGcdInType v d) (GetMeasureVarGcdInType v r) + | TType_var _ -> ZeroRational + | TType_forall (_,tau) -> GetMeasureVarGcdInType v tau + | TType_measure unt -> MeasureVarExponent v unt + +and GetMeasureVarGcdInTypes v tys = + match tys with + | [] -> ZeroRational + | ty::tys -> GcdRational (GetMeasureVarGcdInType v ty) (GetMeasureVarGcdInTypes v tys) -// We normalize unit-of-measure-polymorphic type schemes as described in Kennedy's thesis. There +// Normalize the exponents on generalizable variables in a type +// by dividing them by their "rational gcd". For example, the type +// float<'u^(2/3)> -> float<'u^(4/3)> would be normalized to produce +// float<'u> -> float<'u^2> by dividing the exponents by 2/3. +let NormalizeExponentsInTypeScheme uvars ty = + uvars |> List.map (fun v -> + let expGcd = AbsRational (GetMeasureVarGcdInType v ty) + if expGcd = OneRational || expGcd = ZeroRational + then v + else + let v' = NewAnonTypar (TyparKind.Measure,v.Range,TyparRigidity.Flexible,v.StaticReq,v.DynamicReq) + SubstMeasure v (MeasureRationalPower (MeasureVar v', DivRational OneRational expGcd)) + v') + + +// We normalize unit-of-measure-polymorphic type schemes. There // are three reasons for doing this: // (1) to present concise and consistent type schemes to the programmer // (2) so that we can compute equivalence of type schemes in signature matching // (3) in order to produce a list of type parameters ordered as they appear in the (normalized) scheme. // -// Representing the normal form as a matrix, with a row for each variable, -// and a column for each unit-of-measure expression in the "skeleton" of the type. Entries are integer exponents. +// Representing the normal form as a matrix, with a row for each variable or base unit, +// and a column for each unit-of-measure expression in the "skeleton" of the type. +// Entries for generalizable variables are integers; other rows may contain non-integer exponents. // // ( 0...0 a1 as1 b1 bs1 c1 cs1 ...) // ( 0...0 0 0...0 b2 bs2 c2 cs2 ...) @@ -593,7 +589,10 @@ let rec SimplifyMeasuresInConstraints g param cs = // // The corner entries a1, b2, c3 are all positive. Entries lying above them (b1, c1, c2, etc) are // non-negative and smaller than the corresponding corner entry. Entries as1, bs1, bs2, etc are arbitrary. -// This is known as a *reduced row echelon* matrix or Hermite matrix. +// +// Essentially this is the *reduced row echelon* matrix from linear algebra, with adjustment to ensure that +// exponents are integers where possible (in the reduced row echelon form, a1, b2, etc. would be 1, possibly +// forcing other entries to be non-integers). let SimplifyMeasuresInTypeScheme g resultFirst (generalizable:Typar list) ty constraints = // Only bother if we're generalizing over at least one unit-of-measure variable let uvars, vars = @@ -602,9 +601,9 @@ let SimplifyMeasuresInTypeScheme g resultFirst (generalizable:Typar list) ty con match uvars with | [] -> generalizable | _::_ -> - let (untouched, generalized) = SimplifyMeasuresInType g resultFirst (SimplifyMeasuresInConstraints g (uvars, []) constraints) ty - - vars @ List.rev generalized @ untouched + let (_, generalized) = SimplifyMeasuresInType g resultFirst (SimplifyMeasuresInConstraints g (uvars, []) constraints) ty + let generalized' = NormalizeExponentsInTypeScheme generalized ty + vars @ List.rev generalized' let freshMeasure () = MeasureVar (NewInferenceMeasurePar ()) diff --git a/src/fsharp/pars.fsy b/src/fsharp/pars.fsy index 0ffdee03baf..390653be97d 100644 --- a/src/fsharp/pars.fsy +++ b/src/fsharp/pars.fsy @@ -2650,6 +2650,38 @@ rawConstant: | stringOrKeywordString { SynConst.String ($1,lhs parseState) } | BYTEARRAY { SynConst.Bytes ($1,lhs parseState) } +rationalConstant: + | INT32 INFIX_STAR_DIV_MOD_OP INT32 + { if $2 <> "/" then reportParseErrorAt (rhs parseState 2) (FSComp.SR.parsUnexpectedOperatorForUnitOfMeasure()); + if fst $3 = 0 then reportParseErrorAt (rhs parseState 3) (FSComp.SR.parsIllegalDenominatorForMeasureExponent()); + if (snd $1) || (snd $3) then errorR(Error(FSComp.SR.lexOutsideThirtyTwoBitSigned(), lhs parseState)); + SynRationalConst.Rational(fst $1, fst $3, lhs parseState) } + + | MINUS INT32 INFIX_STAR_DIV_MOD_OP INT32 + { if $3 <> "/" then reportParseErrorAt (rhs parseState 3) (FSComp.SR.parsUnexpectedOperatorForUnitOfMeasure()); + if fst $4 = 0 then reportParseErrorAt (rhs parseState 4) (FSComp.SR.parsIllegalDenominatorForMeasureExponent()); + if (snd $2) || (snd $4) then errorR(Error(FSComp.SR.lexOutsideThirtyTwoBitSigned(), lhs parseState)); + SynRationalConst.Negate(SynRationalConst.Rational(fst $2, fst $4, lhs parseState)) } + + | INT32 { if snd $1 then errorR(Error(FSComp.SR.lexOutsideThirtyTwoBitSigned(), lhs parseState)); + SynRationalConst.Integer(fst $1) } + + | MINUS INT32 { if snd $2 then errorR(Error(FSComp.SR.lexOutsideThirtyTwoBitSigned(), lhs parseState)); + SynRationalConst.Negate(SynRationalConst.Integer(fst $2)) } + +atomicUnsignedRationalConstant: + | INT32 { if snd $1 then errorR(Error(FSComp.SR.lexOutsideThirtyTwoBitSigned(), lhs parseState)); + SynRationalConst.Integer(fst $1) } + + | LPAREN rationalConstant rparen + { $2 } + +atomicRationalConstant: + | atomicUnsignedRationalConstant { $1 } + + | MINUS atomicUnsignedRationalConstant + { SynRationalConst.Negate($2) } + constant: | rawConstant { $1 } | rawConstant HIGH_PRECEDENCE_TYAPP measureTypeArg { SynConst.Measure($1, $3) } @@ -4228,10 +4260,10 @@ appTypeCon: { SynType.Var($1, lhs parseState) } appTypeConPower: - | appTypeCon INFIX_AT_HAT_OP INT32 + | appTypeCon INFIX_AT_HAT_OP atomicRationalConstant { if $2 <> "^" && $2 <> "^-" then reportParseErrorAt (rhs parseState 2) (FSComp.SR.parsUnexpectedInfixOperator()); - if $2 = "^-" then SynType.MeasurePower($1, -(fst $3), lhs parseState) - else SynType.MeasurePower($1, fst $3, lhs parseState) } + if $2 = "^-" then SynType.MeasurePower($1, SynRationalConst.Negate($3), lhs parseState) + else SynType.MeasurePower($1, $3, lhs parseState) } | appTypeCon { $1 } @@ -4296,14 +4328,10 @@ powerType: | atomType { $1 } - | atomType INFIX_AT_HAT_OP INT32 + | atomType INFIX_AT_HAT_OP atomicRationalConstant { if $2 <> "^" && $2 <> "^-" then reportParseErrorAt (rhs parseState 2) (FSComp.SR.parsUnexpectedInfixOperator()); - if $2 = "^-" then SynType.MeasurePower($1, - (fst $3), lhs parseState) - else SynType.MeasurePower($1, fst $3, lhs parseState) } - - | atomType INFIX_AT_HAT_OP MINUS INT32 - { if $2 <> "^" then reportParseErrorAt (rhs parseState 2) (FSComp.SR.parsUnexpectedInfixOperator()); - SynType.MeasurePower($1, - (fst $4), lhs parseState) } + if $2 = "^-" then SynType.MeasurePower($1, SynRationalConst.Negate($3), lhs parseState) + else SynType.MeasurePower($1, $3, lhs parseState) } /* Like appType but gives a deprecation error when a non-atomic type is used */ appTypeNonAtomicDeprecated: @@ -4343,16 +4371,11 @@ powerTypeNonAtomicDeprecated: | atomType { $1 } - | atomType INFIX_AT_HAT_OP INT32 + | atomType INFIX_AT_HAT_OP atomicRationalConstant { if $2 <> "^" && $2 <> "^-" then reportParseErrorAt (rhs parseState 2) (FSComp.SR.parsUnexpectedInfixOperator()); deprecatedWithError (FSComp.SR.parsNonAtomicType()) (lhs parseState); - if $2 = "^-" then SynType.MeasurePower($1, - (fst $3), lhs parseState) - else SynType.MeasurePower($1, fst $3, lhs parseState) } - - | atomType INFIX_AT_HAT_OP MINUS INT32 - { if $2 <> "^" then reportParseErrorAt (rhs parseState 2) (FSComp.SR.parsUnexpectedInfixOperator()); - deprecatedWithError (FSComp.SR.parsNonAtomicType()) (lhs parseState); - SynType.MeasurePower($1, - (fst $4), lhs parseState) } + if $2 = "^-" then SynType.MeasurePower($1, SynRationalConst.Negate($3), lhs parseState) + else SynType.MeasurePower($1, $3, lhs parseState) } /* Any tokens in this grammar must be added to the lex filter rule 'peekAdjacentTypars' */ @@ -4514,14 +4537,10 @@ measureTypePower: | measureTypeAtom { $1 } - | measureTypeAtom INFIX_AT_HAT_OP INT32 + | measureTypeAtom INFIX_AT_HAT_OP atomicRationalConstant { if $2 <> "^" && $2 <> "^-" then reportParseErrorAt (rhs parseState 2) (FSComp.SR.parsUnexpectedOperatorForUnitOfMeasure()); - if $2 = "^-" then SynMeasure.Power($1, - (fst $3), lhs parseState) - else SynMeasure.Power($1, fst $3, lhs parseState) } - - | measureTypeAtom INFIX_AT_HAT_OP MINUS INT32 - { if $2 <> "^" then reportParseErrorAt (rhs parseState 2) (FSComp.SR.parsUnexpectedOperatorForUnitOfMeasure()); - SynMeasure.Power($1, - (fst $4), lhs parseState) } + if $2 = "^-" then SynMeasure.Power($1, SynRationalConst.Negate($3), lhs parseState) + else SynMeasure.Power($1, $3, lhs parseState) } | INT32 { if fst $1 <> 1 then reportParseErrorAt (rhs parseState 1) (FSComp.SR.parsUnexpectedIntegerLiteralForUnitOfMeasure()); diff --git a/src/fsharp/pickle.fs b/src/fsharp/pickle.fs index c80d4aab636..62a3d2eb31a 100644 --- a/src/fsharp/pickle.fs +++ b/src/fsharp/pickle.fs @@ -16,6 +16,7 @@ open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.Lib.Bits open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Rational open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.ErrorLogger @@ -1394,6 +1395,8 @@ let u_trait st = TTrait (a,b,c,d,e,ref f) #if INCLUDE_METADATA_WRITER +let p_rational q st = p_int32 (GetNumerator q) st; p_int32 (GetDenominator q) st + let rec p_measure_expr unt st = let unt = stripUnitEqnsAux false unt match unt with @@ -1402,8 +1405,12 @@ let rec p_measure_expr unt st = | MeasureProd(x1,x2) -> p_byte 2 st; p_measure_expr x1 st; p_measure_expr x2 st | MeasureVar(v) -> p_byte 3 st; p_tpref v st | MeasureOne -> p_byte 4 st + | MeasureRationalPower(x,q) -> p_byte 5 st; p_measure_expr x st; p_rational q st #endif +let u_rational st = + let a,b = u_tup2 u_int32 u_int32 st in DivRational (intToRational a) (intToRational b) + let rec u_measure_expr st = let tag = u_byte st match tag with @@ -1412,6 +1419,7 @@ let rec u_measure_expr st = | 2 -> let a,b = u_tup2 u_measure_expr u_measure_expr st in MeasureProd (a,b) | 3 -> let a = u_tpref st in MeasureVar a | 4 -> MeasureOne + | 5 -> let a = u_measure_expr st in let b = u_rational st in MeasureRationalPower (a,b) | _ -> ufailwith st "u_measure_expr" #if INCLUDE_METADATA_WRITER diff --git a/src/fsharp/rational.fs b/src/fsharp/rational.fs new file mode 100644 index 00000000000..f41f0d1c366 --- /dev/null +++ b/src/fsharp/rational.fs @@ -0,0 +1,66 @@ +// Copyright (c) Microsoft Open Technologies, Inc. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +/// Rational arithmetic, used for exponents on units-of-measure +module internal Microsoft.FSharp.Compiler.Rational + +open System.Numerics + +type Rational = { + numerator: BigInteger; + denominator: BigInteger +} + +let rec gcd a (b: BigInteger) = + if b = BigInteger.Zero then a else + gcd b (a % b) +let lcm a b = + (a * b) / (gcd a b) + +let mkRational p q = + let p, q = + if q = BigInteger.Zero then raise(System.DivideByZeroException()) + let g = gcd q p in + p/g, q/g + + let p, q = + if q > BigInteger.Zero then p, q else -p, -q + + in + { numerator = p; + denominator = q + } + +let intToRational (p:int) = mkRational (BigInteger(p)) BigInteger.One +let ZeroRational = mkRational BigInteger.Zero BigInteger.One +let OneRational = mkRational BigInteger.One BigInteger.One + +let AddRational m n = + let d = gcd m.denominator n.denominator + let m' = m.denominator / d + let n' = n.denominator / d + mkRational (m.numerator * n' + n.numerator * m') (m.denominator * n') + +let NegRational m = + mkRational (-m.numerator) m.denominator + +let MulRational m n = + mkRational (m.numerator * n.numerator) (m.denominator * n.denominator) + +let DivRational m n = + mkRational (m.numerator * n.denominator) (m.denominator * n.numerator) + +let AbsRational m = + mkRational (abs m.numerator) m.denominator + +let RationalToString m = + if m.denominator = BigInteger.One then m.numerator.ToString() else sprintf "(%A/%A)" m.numerator m.denominator + +let GcdRational m n = mkRational (gcd m.numerator n.numerator) (lcm m.denominator n.denominator) + +let GetNumerator p = int p.numerator +let GetDenominator p = int p.denominator + +let SignRational p = + if p.numerator < BigInteger.Zero then -1 else + if p.numerator > BigInteger.Zero then 1 else 0 + diff --git a/src/fsharp/rational.fsi b/src/fsharp/rational.fsi new file mode 100644 index 00000000000..866826a9662 --- /dev/null +++ b/src/fsharp/rational.fsi @@ -0,0 +1,27 @@ +// Copyright (c) Microsoft Open Technologies, Inc. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +/// Rational arithmetic, used for exponents on units-of-measure +module internal Microsoft.FSharp.Compiler.Rational + +type Rational + +val intToRational : int -> Rational +val AbsRational : Rational -> Rational +val AddRational : Rational -> Rational -> Rational +val MulRational : Rational -> Rational -> Rational +val DivRational : Rational -> Rational -> Rational +val NegRational : Rational -> Rational +val SignRational : Rational -> int +val ZeroRational : Rational +val OneRational : Rational + +// Can be negative +val GetNumerator : Rational -> int + +// Always positive +val GetDenominator : Rational -> int + +// Greatest rational that divides both exactly +val GcdRational : Rational -> Rational -> Rational +val RationalToString : Rational -> string + diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 42f12ae058e..218df10b9d2 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -21,6 +21,7 @@ open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.PrettyNaming open Microsoft.FSharp.Compiler.QuotationPickler open Microsoft.FSharp.Core.Printf +open Microsoft.FSharp.Compiler.Rational #if EXTENSIONTYPING open Microsoft.FSharp.Compiler.ExtensionTyping @@ -2920,6 +2921,9 @@ and MeasureExpr = /// The unit of measure '1', e.g. float = float<1> | MeasureOne + /// Raising a measure to a rational power + | MeasureRationalPower of MeasureExpr * Rational + and [] CcuData = diff --git a/src/fsharp/tastops.fs b/src/fsharp/tastops.fs index 8ae10c845c8..e251c269e66 100644 --- a/src/fsharp/tastops.fs +++ b/src/fsharp/tastops.fs @@ -14,6 +14,7 @@ open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Rational open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Tast @@ -65,7 +66,6 @@ type ValMap<'T>(imap: StampMap<'T>) = member m.IsEmpty = imap.IsEmpty static member OfList vs = (vs, ValMap<'T>.Empty) ||> List.foldBack (fun (x,y) acc -> acc.Add x y) - //-------------------------------------------------------------------------- // renamings //-------------------------------------------------------------------------- @@ -190,6 +190,7 @@ and remapMeasureAux tyenv unt = | Some tcr -> MeasureCon tcr | None -> unt | MeasureProd(u1,u2) -> MeasureProd(remapMeasureAux tyenv u1, remapMeasureAux tyenv u2) + | MeasureRationalPower(u,q) -> MeasureRationalPower(remapMeasureAux tyenv u, q) | MeasureInv u -> MeasureInv(remapMeasureAux tyenv u) | MeasureVar tp as unt -> match tp.Solution with @@ -388,31 +389,33 @@ let stripUnitEqnsFromMeasure m = stripUnitEqnsFromMeasureAux false m // Basic unit stuff //--------------------------------------------------------------------------- - /// What is the contribution of unit-of-measure constant ucref to unit-of-measure expression measure? let rec MeasureConExponent g abbrev ucref unt = match (if abbrev then stripUnitEqnsFromMeasure unt else stripUnitEqns unt) with - | MeasureCon ucref' -> if tyconRefEq g ucref' ucref then 1 else 0 - | MeasureInv unt' -> -(MeasureConExponent g abbrev ucref unt') - | MeasureProd(unt1,unt2) -> MeasureConExponent g abbrev ucref unt1 + MeasureConExponent g abbrev ucref unt2 - | _ -> 0 + | MeasureCon ucref' -> if tyconRefEq g ucref' ucref then OneRational else ZeroRational + | MeasureInv unt' -> NegRational(MeasureConExponent g abbrev ucref unt') + | MeasureProd(unt1,unt2) -> AddRational(MeasureConExponent g abbrev ucref unt1) (MeasureConExponent g abbrev ucref unt2) + | MeasureRationalPower(unt',q) -> MulRational (MeasureConExponent g abbrev ucref unt') q + | _ -> ZeroRational /// What is the contribution of unit-of-measure constant ucref to unit-of-measure expression measure /// after remapping tycons? let rec MeasureConExponentAfterRemapping g r ucref unt = match stripUnitEqnsFromMeasure unt with - | MeasureCon ucref' -> if tyconRefEq g (r ucref') ucref then 1 else 0 - | MeasureInv unt' -> -(MeasureConExponentAfterRemapping g r ucref unt') - | MeasureProd(unt1,unt2) -> MeasureConExponentAfterRemapping g r ucref unt1 + MeasureConExponentAfterRemapping g r ucref unt2 - | _ -> 0 + | MeasureCon ucref' -> if tyconRefEq g (r ucref') ucref then OneRational else ZeroRational + | MeasureInv unt' -> NegRational(MeasureConExponentAfterRemapping g r ucref unt') + | MeasureProd(unt1,unt2) -> AddRational(MeasureConExponentAfterRemapping g r ucref unt1) (MeasureConExponentAfterRemapping g r ucref unt2) + | MeasureRationalPower(unt',q) -> MulRational (MeasureConExponentAfterRemapping g r ucref unt') q + | _ -> ZeroRational /// What is the contribution of unit-of-measure variable tp to unit-of-measure expression unt? let rec MeasureVarExponent tp unt = match stripUnitEqnsFromMeasure unt with - | MeasureVar tp' -> if typarEq tp tp' then 1 else 0 - | MeasureInv unt' -> -(MeasureVarExponent tp unt') - | MeasureProd(unt1,unt2) -> MeasureVarExponent tp unt1 + MeasureVarExponent tp unt2 - | _ -> 0 + | MeasureVar tp' -> if typarEq tp tp' then OneRational else ZeroRational + | MeasureInv unt' -> NegRational(MeasureVarExponent tp unt') + | MeasureProd(unt1,unt2) -> AddRational(MeasureVarExponent tp unt1) (MeasureVarExponent tp unt2) + | MeasureRationalPower(unt',q) -> MulRational (MeasureVarExponent tp unt') q + | _ -> ZeroRational /// List the *literal* occurrences of unit variables in a unit expression, without repeats let ListMeasureVarOccs unt = @@ -420,6 +423,7 @@ let ListMeasureVarOccs unt = match stripUnitEqnsFromMeasure unt with MeasureVar tp -> if List.exists (typarEq tp) acc then acc else tp::acc | MeasureProd(unt1,unt2) -> gather (gather acc unt1) unt2 + | MeasureRationalPower(unt',_) -> gather acc unt' | MeasureInv unt' -> gather acc unt' | _ -> acc gather [] unt @@ -429,9 +433,10 @@ let ListMeasureVarOccsWithNonZeroExponents untexpr = let rec gather acc unt = match stripUnitEqnsFromMeasure unt with MeasureVar tp -> if List.exists (fun (tp', _) -> typarEq tp tp') acc then acc - else let e = MeasureVarExponent tp untexpr in if e=0 then acc else (tp,e)::acc + else let e = MeasureVarExponent tp untexpr in if e = ZeroRational then acc else (tp,e)::acc | MeasureProd(unt1,unt2) -> gather (gather acc unt1) unt2 | MeasureInv unt' -> gather acc unt' + | MeasureRationalPower(unt',_) -> gather acc unt' | _ -> acc gather [] untexpr @@ -440,9 +445,10 @@ let ListMeasureConOccsWithNonZeroExponents g eraseAbbrevs untexpr = let rec gather acc unt = match (if eraseAbbrevs then stripUnitEqnsFromMeasure unt else stripUnitEqns unt) with | MeasureCon c -> if List.exists (fun (c', _) -> tyconRefEq g c c') acc then acc - else let e = MeasureConExponent g eraseAbbrevs c untexpr in if e=0 then acc else (c,e)::acc + else let e = MeasureConExponent g eraseAbbrevs c untexpr in if e = ZeroRational then acc else (c,e)::acc | MeasureProd(unt1,unt2) -> gather (gather acc unt1) unt2 | MeasureInv unt' -> gather acc unt' + | MeasureRationalPower(unt',_) -> gather acc unt' | _ -> acc gather [] untexpr @@ -453,17 +459,17 @@ let ListMeasureConOccsAfterRemapping g r unt = match (stripUnitEqnsFromMeasure unt) with | MeasureCon c -> if List.exists (tyconRefEq g (r c)) acc then acc else r c::acc | MeasureProd(unt1,unt2) -> gather (gather acc unt1) unt2 + | MeasureRationalPower(unt',_) -> gather acc unt' | MeasureInv unt' -> gather acc unt' | _ -> acc gather [] unt /// Construct a measure expression representing the n'th power of a measure -let rec MeasurePower u n = +let MeasurePower u n = if n=0 then MeasureOne elif n=1 then u - elif n<0 then MeasureInv (MeasurePower u (-n)) - else MeasureProd (u, MeasurePower u (n-1)) + else MeasureRationalPower (u, intToRational n) let MeasureProdOpt m1 m2 = match m1, m2 with @@ -486,7 +492,7 @@ let destUnitParMeasure g unt = let vs = ListMeasureVarOccsWithNonZeroExponents unt let cs = ListMeasureConOccsWithNonZeroExponents g true unt match vs, cs with - | [(v,1)], [] -> v + | [(v,e)], [] when e = OneRational -> v | _, _ -> failwith "destUnitParMeasure: not a unit-of-measure parameter" let isUnitParMeasure g unt = @@ -494,7 +500,7 @@ let isUnitParMeasure g unt = let cs = ListMeasureConOccsWithNonZeroExponents g true unt match vs, cs with - | [(_,1)], [] -> true + | [(_,e)], [] when e = OneRational -> true | _, _ -> false let normalizeMeasure g ms = @@ -502,8 +508,8 @@ let normalizeMeasure g ms = let cs = ListMeasureConOccsWithNonZeroExponents g false ms match vs, cs with | [],[] -> MeasureOne - | [(v,1)], [] -> MeasureVar v - | vs, cs -> List.foldBack (fun (v,e) -> fun m -> MeasureProd (MeasurePower (MeasureVar v) e, m)) vs (List.foldBack (fun (c,e) -> fun m -> MeasureProd (MeasurePower (MeasureCon c) e, m)) cs MeasureOne) + | [(v,e)], [] when e = OneRational -> MeasureVar v + | vs, cs -> List.foldBack (fun (v,e) -> fun m -> MeasureProd (MeasureRationalPower (MeasureVar v, e), m)) vs (List.foldBack (fun (c,e) -> fun m -> MeasureProd (MeasureRationalPower (MeasureCon c, e), m)) cs MeasureOne) let tryNormalizeMeasureInType g ty = match ty with @@ -520,6 +526,7 @@ let rec sizeMeasure g ms = | MeasureVar _ -> 1 | MeasureCon _ -> 1 | MeasureProd (ms1,ms2) -> sizeMeasure g ms1 + sizeMeasure g ms2 + | MeasureRationalPower (ms,_) -> sizeMeasure g ms | MeasureInv ms -> sizeMeasure g ms | MeasureOne -> 1 @@ -2848,16 +2855,18 @@ module DebugPrint = begin (match !global_g with | None -> wordL "" | Some g -> - let sortVars (vs:(Typar * int) list) = vs |> List.sortBy (fun (v,_) -> v.DisplayName) - let sortCons (cs:(TyconRef * int) list) = cs |> List.sortBy (fun (c,_) -> c.DisplayName) - let negvs,posvs = ListMeasureVarOccsWithNonZeroExponents unt |> sortVars |> List.partition (fun (_,e) -> e<0) - let negcs,poscs = ListMeasureConOccsWithNonZeroExponents g false unt |> sortCons |> List.partition (fun (_,e) -> e<0) + let sortVars (vs:(Typar * Rational) list) = vs |> List.sortBy (fun (v,_) -> v.DisplayName) + let sortCons (cs:(TyconRef * Rational) list) = cs |> List.sortBy (fun (c,_) -> c.DisplayName) + let negvs,posvs = ListMeasureVarOccsWithNonZeroExponents unt |> sortVars |> List.partition (fun (_,e) -> SignRational e < 0) + let negcs,poscs = ListMeasureConOccsWithNonZeroExponents g false unt |> sortCons |> List.partition (fun (_,e) -> SignRational e < 0) let unparL (uv:Typar) = wordL ("'" ^ uv.DisplayName) let unconL tc = layoutTyconRef tc - let prefix = spaceListL (List.map (fun (v,e) -> if e=1 then unparL v else unparL v -- wordL (sprintf "^ %d" e)) posvs @ - List.map (fun (c,e) -> if e=1 then unconL c else unconL c -- wordL (sprintf "^ %d" e)) poscs) - let postfix = spaceListL (List.map (fun (v,e) -> if e= -1 then unparL v else unparL v -- wordL (sprintf "^ %d" (-e))) negvs @ - List.map (fun (c,e) -> if e= -1 then unconL c else unconL c -- wordL (sprintf "^ %d" (-e))) negcs) + let rationalL e = wordL (RationalToString e) + let measureToPowerL x e = if e = OneRational then x else x -- wordL "^" -- rationalL e + let prefix = spaceListL (List.map (fun (v,e) -> measureToPowerL (unparL v) e) posvs @ + List.map (fun (c,e) -> measureToPowerL (unconL c) e) poscs) + let postfix = spaceListL (List.map (fun (v,e) -> measureToPowerL (unparL v) (NegRational e)) negvs @ + List.map (fun (c,e) -> measureToPowerL (unconL c) (NegRational e)) negcs) match (negvs,negcs) with | [],[] -> prefix | _ -> prefix ^^ sepL "/" ^^ postfix) ^^ diff --git a/src/fsharp/tastops.fsi b/src/fsharp/tastops.fsi index 691df948262..85fac315c41 100644 --- a/src/fsharp/tastops.fsi +++ b/src/fsharp/tastops.fsi @@ -11,6 +11,7 @@ open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Rational open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Tast @@ -532,12 +533,13 @@ val getErasedTypes : TcGlobals -> TType -> TType list //------------------------------------------------------------------------- // Unit operations //------------------------------------------------------------------------- + val MeasurePower : MeasureExpr -> int -> MeasureExpr -val ListMeasureVarOccsWithNonZeroExponents : MeasureExpr -> (Typar * int) list -val ListMeasureConOccsWithNonZeroExponents : TcGlobals -> bool -> MeasureExpr -> (TyconRef * int) list +val ListMeasureVarOccsWithNonZeroExponents : MeasureExpr -> (Typar * Rational) list +val ListMeasureConOccsWithNonZeroExponents : TcGlobals -> bool -> MeasureExpr -> (TyconRef * Rational) list val ProdMeasures : MeasureExpr list -> MeasureExpr -val MeasureVarExponent : Typar -> MeasureExpr -> int -val MeasureConExponent : TcGlobals -> bool -> TyconRef -> MeasureExpr -> int +val MeasureVarExponent : Typar -> MeasureExpr -> Rational +val MeasureConExponent : TcGlobals -> bool -> TyconRef -> MeasureExpr -> Rational //------------------------------------------------------------------------- // Members diff --git a/src/fsharp/tc.fs b/src/fsharp/tc.fs index 027c39ca635..31de2e7151b 100644 --- a/src/fsharp/tc.fs +++ b/src/fsharp/tc.fs @@ -16,6 +16,7 @@ open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Rational open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Tast @@ -755,6 +756,13 @@ type AfterTcOverloadResolution = | AfterTcOverloadResolution.ReplaceWithOverrideAndSendToSink(_,_,IfOverloadResolutionFails f) -> f() +/// Typecheck rational constant terms in units-of-measure exponents +let rec TcSynRationalConst c = + match c with + | SynRationalConst.Integer i -> intToRational i + | SynRationalConst.Negate c' -> NegRational (TcSynRationalConst c') + | SynRationalConst.Rational(p,q,_) -> DivRational (intToRational p) (intToRational q) + /// Typecheck constant terms in expressions and patterns let TcConst cenv ty m env c = let rec tcMeasure ms = @@ -767,7 +775,7 @@ let TcConst cenv ty m env c = | TyparKind.Type -> error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m)) | TyparKind.Measure -> MeasureCon tcref - | SynMeasure.Power(ms, exponent, _) -> MeasurePower (tcMeasure ms) exponent + | SynMeasure.Power(ms, exponent, _) -> MeasureRationalPower (tcMeasure ms, TcSynRationalConst exponent) | SynMeasure.Product(ms1,ms2,_) -> MeasureProd(tcMeasure ms1, tcMeasure ms2) | SynMeasure.Divide(ms1, ((SynMeasure.Seq (_::(_::_), _)) as ms2), m) -> warning(Error(FSComp.SR.tcImplicitMeasureFollowingSlash(),m)) @@ -4229,7 +4237,7 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv:SyntacticUnscoped NewErrorType (), tpenv | _ -> let ms,tpenv = TcMeasure cenv newOk checkCxs occ env tpenv typ m - TType_measure (Tastops.MeasurePower ms exponent), tpenv + TType_measure (MeasureRationalPower (ms, TcSynRationalConst exponent)), tpenv | SynType.MeasureDivide(typ1, typ2, m) -> match optKind with diff --git a/tests/fsharp/core/measures/test.fsx b/tests/fsharp/core/measures/test.fsx index c8161076b2e..ee2d3452dc1 100644 --- a/tests/fsharp/core/measures/test.fsx +++ b/tests/fsharp/core/measures/test.fsx @@ -74,6 +74,8 @@ module FLOAT = let x6 = - (2.0) let x7 = abs (-2.0) let x8 = sqrt (4.0) + let x8a = sqrt (4.0) + let x8b = sqrt (4.0) let x9 = [ 1.0 .. 1.0 .. 4.0 ] let x10 = sign (3.0) let x11 = atan2 4.4 5.4 @@ -147,6 +149,8 @@ module FLOAT = test "x6" (x6 = -2.0) test "x7" (x7 = 2.0) test "x8" (x8 = 2.0) + test "x8a" (x8a = 2.0) + test "x8b" (x8b = 2.0) test "x9" (x9 = [1.0; 2.0; 3.0; 4.0]) test "x10" (x10 = 1) test "x12" (x12 = 5.0) diff --git a/tests/fsharp/typecheck/sigs/neg21.bsl b/tests/fsharp/typecheck/sigs/neg21.bsl index d30e35f5526..60ed9ff9491 100644 --- a/tests/fsharp/typecheck/sigs/neg21.bsl +++ b/tests/fsharp/typecheck/sigs/neg21.bsl @@ -11,8 +11,6 @@ neg21.fs(14,19,14,23): typecheck error FS0001: The type 'float32' does not match neg21.fs(14,17,14,18): typecheck error FS0043: The type 'float32' does not match the type 'float<'u>' -neg21.fs(15,16,15,22): typecheck error FS0001: The unit of measure 'm' does not match the unit of measure ''u ^ 2' - neg21.fs(17,26,17,34): typecheck error FS0001: Type mismatch. Expecting a float but given a diff --git a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Basic/RationalExponents01.fs b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Basic/RationalExponents01.fs new file mode 100644 index 00000000000..79c649e564e --- /dev/null +++ b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Basic/RationalExponents01.fs @@ -0,0 +1,35 @@ +// #Conformance #UnitsOfMeasure +// Rational exponents feature + +[] +type kg + +[] +type s + +[] +type m + +// Simple fractions +let test01() = 1.0 +let test02() = 2.0 +let test03() = sqrt (test01()) + test02() + +// Negative fractions +let test04() = 4.0 +let test05() = 5.0 +let test06() = 1.0 / (test04() * test05()) + 3.0 + +// More complex expressions +let test07() = 2.0 +let test08() = 4.0<(s^6 kg^3)^(1/4)> +let test09() = test07() * test08() + 3.0 + +// Generics +let test10(x:float<'u>) (y:float<'u^(1/2)>) = sqrt x + y +let test11(x:float<'u^-(1/4)>) (y:float<'u^(3/4)>) : float = (x*x*x + 1.0/y) * x +let test12(x:float<'u^(1/2)>) (y:float<'v^2>) :float<'u 'v> = x*x*sqrt y +let test13() = test12 4.0 2.0 + 3.0<(kg s)^(1/2)> + +exit 0 + diff --git a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Basic/env.lst b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Basic/env.lst index 08156bb4172..3658811f482 100644 --- a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Basic/env.lst +++ b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Basic/env.lst @@ -16,6 +16,8 @@ SOURCE=SI.fs COMPILE_ONLY=1 # SI.fs + SOURCE=RationalExponents01.fs COMPILE_ONLY=1 # RationalExponents01.fs + ReqPP SOURCE=Quotation01.fs SCFLAGS="-r:FSharp.PowerPack.Linq.dll" # Quotation01.fs ReqPP SOURCE=Quotation02.fs SCFLAGS="-r:FSharp.PowerPack.Linq.dll" # Quotation02.fs ReqPP SOURCE=Quotation03.fs SCFLAGS="-r:FSharp.PowerPack.Linq.dll" # Quotation03.fs diff --git a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Diagnostics/E_ParsingRationalExponents.fs b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Diagnostics/E_ParsingRationalExponents.fs new file mode 100644 index 00000000000..95fdf4c6c15 --- /dev/null +++ b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Diagnostics/E_ParsingRationalExponents.fs @@ -0,0 +1,13 @@ +// #Regression #Conformance #UnitsOfMeasure #Diagnostics #RatExp +#light +//Unexpected integer literal in unit-of-measure expression +//Unexpected symbol '\)' in binding\. Expected integer literal or other token +//Unexpected infix operator in binding\. Expected integer literal, '-' or other token + +[] type kg +[] type s + +// Parentheses are required +let x2 = 2.0 +let x4 = 2.0 +let x5 = 2.0 diff --git a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Diagnostics/E_ZeroDenominator.fs b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Diagnostics/E_ZeroDenominator.fs new file mode 100644 index 00000000000..1caa21641bb --- /dev/null +++ b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Diagnostics/E_ZeroDenominator.fs @@ -0,0 +1,11 @@ +// #Regression #Conformance #UnitsOfMeasure #Diagnostics #RatExp +//Denominator must not be 0 in unit-of-measure exponent +//Denominator must not be 0 in unit-of-measure exponent +#light + +[] type m + +let e1 = 2.0 +let e2 :float = 2.0<_> + + diff --git a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Diagnostics/env.lst b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Diagnostics/env.lst index 37d45c84e59..10f38bbc83b 100644 --- a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Diagnostics/env.lst +++ b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Diagnostics/env.lst @@ -9,6 +9,8 @@ SOURCE=E_CantBeUsedAsPrefixArgToAType05.fsx SCFLAGS="--test:ErrorRanges" # E_CantBeUsedAsPrefixArgToAType05.fsx SOURCE=E_UnexpectedTypeParameter01.fs SCFLAGS="--test:ErrorRanges" # E_UnexpectedTypeParameter01.fs + SOURCE=E_ZeroDenominator.fs SCFLAGS="--test:ErrorRanges" # E_ZeroDenominator.fs + SOURCE=E_ParsingRationalExponents.fs SCFLAGS="--test:ErrorRanges" # E_ParsingRationalExponents.fs SOURCE=W_UnitOfMeasureCodeLessGeneric01.fs SCFLAGS="--test:ErrorRanges -a" # W_UnitOfMeasureCodeLessGeneric01.fs diff --git a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Parenthesis/E_Error07.fs b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Parenthesis/E_Error07.fs deleted file mode 100644 index d5db1e677be..00000000000 --- a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Parenthesis/E_Error07.fs +++ /dev/null @@ -1,11 +0,0 @@ -// #Regression #Conformance #UnitsOfMeasure -// Regression test for FSHARP1.0:2662 -// Make sure we can use ( and ) in Units of Measure -//Unexpected symbol '\(' in binding\. Expected integer literal, '-' or other token -#light - -[] type Kg -[] type m -[] type s - -let v = 1.0< (s)^(2) > //error FS0010: Unexpected symbol '(' in binding. Expected integer literal, '-' or other token diff --git a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Parenthesis/E_Error08.fs b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Parenthesis/E_Error08.fs deleted file mode 100644 index 5a38d0b6917..00000000000 --- a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Parenthesis/E_Error08.fs +++ /dev/null @@ -1,11 +0,0 @@ -// #Regression #Conformance #UnitsOfMeasure -// Regression test for FSHARP1.0:2662 -// Make sure we can use ( and ) in Units of Measure -//Unexpected symbol '\(' in binding\. Expected integer literal, '-' or other token -#light - -[] type Kg -[] type m -[] type s - -let velocity9 = 1.0 // Error - why? diff --git a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Parenthesis/env.lst b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Parenthesis/env.lst index 3dd4add6cfd..07058de7ec7 100644 --- a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Parenthesis/env.lst +++ b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/Parenthesis/env.lst @@ -7,8 +7,6 @@ SOURCE=E_Error03.fs SCFLAGS="--test:ErrorRanges" # E_Error03.fs SOURCE=E_Error04.fs SCFLAGS="--test:ErrorRanges" # E_Error04.fs SOURCE=E_Error05.fs SCFLAGS="--test:ErrorRanges" # E_Error05.fs SOURCE=E_Error06.fs SCFLAGS="--test:ErrorRanges" # E_Error06.fs -SOURCE=E_Error07.fs SCFLAGS="--test:ErrorRanges" # E_Error07.fs -SOURCE=E_Error08.fs SCFLAGS="--test:ErrorRanges" # E_Error08.fs SOURCE=E_IncompleteParens01.fs SCFLAGS="--test:ErrorRanges" # E_IncompleteParens01.fs SOURCE=E_IncompleteParens02.fs SCFLAGS="--test:ErrorRanges" # E_IncompleteParens02.fs diff --git a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/TypeChecker/W_LessGeneric01.fsx b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/TypeChecker/W_LessGeneric01.fsx index e65f2a314fe..a0e07fc02dd 100644 --- a/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/TypeChecker/W_LessGeneric01.fsx +++ b/tests/fsharpqa/Source/Conformance/UnitsOfMeasure/TypeChecker/W_LessGeneric01.fsx @@ -2,9 +2,9 @@ // Regression test for FSharp1.0:3579 - Problems in Units of Measure -// let avg = \(guess \+ other\) / 2 -// ---------------------\^ -//This construct causes code to be less generic than indicated by the type annotations\. The unit-of-measure variable 'u has been constrained to be measure ''u \^ 2'\.$ +// let fn \(x:float<'u>\) = +// ----------------\^\^ +//This construct causes code to be less generic than indicated by the type annotations\. The unit-of-measure variable 'u has been constrained to be measure '1'\.$ //val loop : f:\('a -> 'a\) -> init:'a -> comp:\('a -> 'a -> bool\) -> 'a //val fn : x:float -> float