Une petite calculatrice

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
Option Explicit
Private Declare Function RtlMoveMemory Lib "kernel32" (ByVal Dest As Long, _
          ByVal Source As Long, ByVal iCount As Long) As Long
Private Declare Function GetLocaleInfoA Lib "kernel32" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As Long, ByVal cchData As Long) As Long
Private Declare Function GetThreadLocale Lib "kernel32" () As Long
Const LOCALE_SDECIMAL = &HE
Public Enum TokenType
   tkInvalid = 1000
   tkNone = 0
   tkWhite = 1
   tkNumber = 2
   tkIdent = 3
   tkOpPow = 4
   tkOpenExp = 5
   tkCloseExp = 6
   tkOpenBra = 7
   tkCloseBra = 8
   tkOpNot = 9
   OpTermBegin = 100
     tkOpOr = 101
     tkOpXor = 102
     tkOpPlus = 103
     tkOpMinus = 104
   OpTermEnd = 105
   OpFacBegin = 200
     tkOpMul = 201
     tkOpMod = 202
     tkOpDivF = 203
     tkOpDiv = 204
     tkOpAnd = 205
     tkOpShl = 206
     tkOpShr = 207
   OpFacEnd = 208
End Enum

Private DecimalSep As Long
Private fCode As String
Private fPtr As Long
Private fLen As Long
Private fPos As Long
Private fCopyStart As Long
Private Char As Long
Public CurrToken As TokenType

Private Sub Class_Initialize()
   'Récupère le séparateur décimal
   If GetLocaleInfoA(GetThreadLocale, LOCALE_SDECIMAL, VarPtr(DecimalSep), 4) = 0 Then
        DecimalSep = 44
   End If
End Sub

Private Function GetChar(ByVal Idx As Long) As Long
   If (Idx < fLen) And (Idx >= 0) Then
     RtlMoveMemory VarPtr(GetChar), fPtr + Idx * 2, 1
   End If
   Char = GetChar
End Function

Private Function IdentType(ByVal AIdent As String) As TokenType
      Select Case AIdent
         Case "MOD": IdentType = tkOpMod
         Case "DIV": IdentType = tkOpDiv
         Case "AND": IdentType = tkOpAnd
         Case "OR":  IdentType = tkOpOr
         Case "XOR": IdentType = tkOpXor
         Case "NOT": IdentType = tkOpNot
         Case "SHL": IdentType = tkOpShl
         Case "SHR": IdentType = tkOpShr
      Case Else
         IdentType = tkIdent
      End Select
End Function

Private Function CharType(ByVal Char As Long) As TokenType
   Select Case Char
        Case 97 To 122, 65 To 90  ' a..z,A..Z alpha
           CharType = tkIdent
        Case 1 To 32: CharType = tkWhite   'blanc
        Case 48 To 57: CharType = tkNumber '0..9
        Case 45: CharType = tkOpMinus '-
        Case 43: CharType = tkOpPlus  '+
        Case 42: CharType = tkOpMul   '*
        Case 47: CharType = tkOpDivF  '/
        Case 94: CharType = tkOpPow   '^
        Case 40: CharType = tkOpenExp  '(
        Case 41: CharType = tkCloseExp ')
        Case 91: CharType = tkOpenBra  '[
        Case 93: CharType = tkCloseBra ']
        Case 0:  CharType = tkNone     '#0
        Case Else
           CharType = tkInvalid
   End Select
End Function

Private Sub LoadCharSet(ByVal AG As TokenType)
    While CharType(GetChar(fPos + 1)) = AG
       fPos = fPos + 1
    Wend
End Sub

Private Function NextChar() As Integer
     fPos = fPos + 1
     NextChar = GetChar(fPos)
End Function

Public Function NextToken() As TokenType
   While CharType(GetChar(fPos)) = tkWhite
     fPos = fPos + 1
   Wend
   fCopyStart = fPos
   CurrToken = CharType(Char)
   Select Case CurrToken
     Case tkIdent
         LoadCharSet tkIdent
     Case tkNumber
     '[0-9]+ (.[0-9]+)? (E|e(-|+)? [0-9]+)?
         LoadCharSet tkNumber
         If Char = DecimalSep Then  ', or .
            NextChar
            LoadCharSet tkNumber
         End If
         If (Char = 69) Or (Char = 101) Then 'E e
            NextChar
            If (GetChar(fPos + 1) = 43) Or (Char = 45) Then ' - +
                NextChar
            End If
            LoadCharSet tkNumber
         End If
   End Select
   If fPos < fLen Then
      fPos = fPos + 1
   End If
   If CurrToken = tkIdent Then
      CurrToken = IdentType(Token)
   End If
   NextToken = CurrToken
End Function

Public Property Let Text(ACode As String)
   fCode = ACode
   fPtr = StrPtr(fCode)
   fLen = Len(fCode)
   fPos = 0
   fCopyStart = 0
End Property

Public Property Get Token() As String
Dim L As Long
   L = fPos - fCopyStart
   If (L <= fLen) And (L >= 0) Then
    Token = Space(L)
    RtlMoveMemory StrPtr(Token), fPtr + fCopyStart * 2, L * 2
    Token = UCase$(Token)
   End If
End Property

Public Property Get Position() As String
    Position = fPos
End Property

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
Option Explicit

Private fLexer As New CLexer

Private Property Get CurrentToken() As TokenType
     CurrentToken = fLexer.CurrToken
End Property

Private Function NextToken() As TokenType
     NextToken = fLexer.NextToken
     SynErr fLexer.CurrToken = tkInvalid
End Function

Private Function IsUnairyOp(ByVal AOP As TokenType) As Boolean
   Select Case AOP
        Case tkOpNot, tkOpPlus, tkOpMinus
             IsUnairyOp = True
   End Select
End Function

Private Function IsFacOperator(ByVal AOP As TokenType) As Boolean
   IsFacOperator = ((AOP > OpFacBegin) And (AOP < OpFacEnd))
End Function

Private Function IsTermOperator(ByVal AOP As TokenType) As Boolean
   IsTermOperator = ((AOP > OpTermBegin) And (AOP < OpTermEnd))
End Function
'<Factor> ::= (+|-)<Expression>| NUMBER | <Simple Call> | CONSTANT |'('<Expression>')' | '['']' | NULL
Private Function GetFactor() As Double
Dim UOP As TokenType
Dim Ret As Double
Dim Ident As String
    If IsUnairyOp(NextToken) Then
       UOP = CurrentToken
       Ret = GetExpression()
       UnairyOperation UOP, Ret
    Else
      Select Case CurrentToken
        Case tkNumber
              Ret = CDbl(fLexer.Token)
        Case tkIdent
              Ident = fLexer.Token
              If Not GetConstValue(Ret, Ident) Then
                 SynErr NextToken <> tkOpenExp
                 Ret = Simple_Call(GetExpression, Ident)
                 SynErr CurrentToken <> tkCloseExp
              End If
        Case tkOpenExp
              Ret = GetExpression
              SynErr CurrentToken <> tkCloseExp
        Case tkOpenBra
              Ret = GetExpression
              SynErr CurrentToken <> tkCloseBra
        Case tkNone
              Ret = 0
        Case Else
              SynErr
      End Select
      NextToken
    End If
    GetFactor = Ret
End Function
'<Exp> ::= <Factor>(^<Factor>)*
Private Function GetExp() As Double
     GetExp = GetFactor
     While CurrentToken = tkOpPow
           BinaryOperation CurrentToken, GetExp, GetFactor
     Wend
End Function
'<Term> ::= <Exp> (DIV | * | / | MOD ... <Exp>)*
Private Function GetTerm() As Double
     GetTerm = GetExp
     While IsFacOperator(CurrentToken)
           BinaryOperation CurrentToken, GetTerm, GetExp
     Wend
End Function
'<Expression>  ::= <Term> (+|- ... <Term>)*
Private Function GetExpression() As Double
     GetExpression = GetTerm
     While IsTermOperator(CurrentToken)
           BinaryOperation CurrentToken, GetExpression, GetTerm
     Wend
End Function
'<Simple Call> ::= (SIN|COS|SQR|EXP|LOG ...)
Private Function Simple_Call(Value As Double, ByVal AFuncName As String) As Double
    Select Case AFuncName
        Case "SIN": Simple_Call = Sin(Value)
        Case "COS": Simple_Call = Cos(Value)
        Case "SQR": Simple_Call = Sqr(Value)
        Case "EXP": Simple_Call = Exp(Value)
        Case "LOG": Simple_Call = Log(Value)
        Case Else
                SynErr
     End Select
End Function
'<Const>  ::= (PI|...)
Private Function GetConstValue(Value As Double, ByVal AConstName As String) As Boolean
    GetConstValue = True
    Select Case AConstName
        Case "PI": Value = 3.14159265358979
        Case Else
             GetConstValue = False
    End Select
End Function

Private Sub UnairyOperation(ByVal OP As TokenType, Value As Double)
    Select Case OP
        Case tkOpMinus: Value = -Value
        Case tkOpNot: Value = Not Value
        Case tkOpPlus: Value = Value
        Case Else
                SynErr
     End Select
End Sub

Private Sub BinaryOperation(ByVal OP As TokenType, Value1 As Double, Value2 As Double)
    Select Case OP
        Case tkOpPlus:  Value1 = Value1 + Value2
        Case tkOpMinus:  Value1 = Value1 - Value2
        Case tkOpMul:  Value1 = Value1 * Value2
        Case tkOpDivF: Value1 = Value1 / Value2
        Case tkOpDiv:  Value1 = Value1 \ Value2
        Case tkOpMod:  Value1 = Value1 Mod Value2
        Case tkOpOr:   Value1 = Value1 Or Value2
        Case tkOpAnd:  Value1 = Value1 And Value2
        Case tkOpXor:  Value1 = Value1 Xor Value2
        Case tkOpPow:  Value1 = Value1 ^ Value2
        Case tkOpShl:  Value1 = Value1 * (2 * Value2)
        Case tkOpShr:  Value1 = Value1 \ (2 * Value2)
        Case Else
                SynErr
     End Select
End Sub

Public Function EvalExp(ByVal Text As String) As Double
    fLexer.Text = Text
    EvalExp = GetExpression
    SynErr CurrentToken <> tkNone
End Function

Private Sub SynErr(Optional ByVal ARaise As Boolean = True)
     If ARaise Then
       Err.Description = "Erreur d'évaluation à la position " & CStr(fLexer.Position)
       Err.Raise 1001
     End If
End Sub

1
2
Dim D As New CExpression
   MsgBox D.EvalExp("10+20/2")