Evaluate() ist ein Parser für mathematische Ausdrücke, so daß
man zur Laufzeit beispielsweise Benutzereingaben ausrechnen
lassen kann.
Die Funktionsweise:
Ergebnis.s = Evaluate(Ausdruck.s)
Unterstützt werden folgende Operatoren:
+, -, *, /, % (modulo), ^ (power of), <<, >>, =, <>, <, >, <=, =<, >=, =>, ( ) , &, |, !, ~, NOT, OR, AND, XOR
Neuigkeiten:
Download: EvaluateExpression.zipDanilo hat geschrieben:7.Mai 2011
- Erste Version
9.Mai 2011
- Habe zum besseren Verständniss mal die Scanner-Variable '*start.Character' global gemacht und
Pseudo-ASM-Generierung für eine virtuelle Stackmaschine hinzugefügt, so daß interessierte Menschen
den internen Ablauf für Lernzwecke besser nachverfolgen und verstehen können.
Das Ergebnis befindet sich am Ende auf dem Stack der virtuellen Maschine.
- Fehlerausgabe hinzugefügt.
- Boolsche Vergleichsoperationen hinzugefügt: '=' '<>' '<' '>' '<=' '>=' '=<' '=>'
- Binäre (bitweise) Operationen hinzugefügt:Diese binären Operationen funktionieren nur mit Integern, deshalb wurden
- '~' = binäres NOT
- '|' = binäres OR
- '&' = binäres AND
- '!' = binäres XOR
unterschiedliche Überprüfungen und Unterscheidungen zwischen Integer und Floats
hinzugefügt.
Ist es nicht möglich die Operation durchzuführen (z.b. "1.34 | 5"), wird ein entsprechender
Fehler ausgegeben.
Allerdings werden Floats ohne Nachkommastelle ("x.0000") als Integer behandelt,
so daß "1.0 | 4.0" wie "1 | 4" behandelt wird.
- Bei Eingaben und Variablen können nun auch:verwendet werden.
- Hex-Format ($FFFF, $abc)
- Bin-Format (%01010101)
- Binäres '<<' (Shift Left) und '>>' (Shift Right) hinzugefügt.
- Logische Operatoren hinzugefügt: 'Or', 'And', 'Xor', 'Not'
10.Mai 2011
- Fehlerbehandlung überarbeitet: Der Benutzer der Include kann eine eigene Fehlerfunktion setzen (siehe Beispiel)
- Pseudo-Asm-Ausgabe über benutzerdefinierte Funktion
- GUI-Beispiel für Live-Editieren erstellt.
- Fehlerbehandlung #evalError_MissingDecimalPlace und #evalError_TokenCantStartExpression hinzugefügt
12.Mai 2011
- Expotenzialschreibweise für Floats hinzugefügt (1E5, 123.5e-20 etc.)
- Fehlerbehandlung #evalError_WrongFloatNumberFormat hinzugefügt
- #GENERATE_STACKMASCHINE_ASM in #GENERATE_STACKMACHINE_ASM umbenannt
- kleinen Fehler mit ~ und NOT behoben
- kleinen Fehler mit Expotenzialschreibweise für Floats behoben
- kleinen Fehler mit mehrfachem Vorzeichen '-' behoben ("---1")
25.September 2011
- #GENERATE_STACKMACHINE_ASM muß nicht mehr gesetzt werden, wenn nicht benötigt
Die Include Evaluate.pbi:
Code: Alles auswählen
;-[ INCLUDE: Evaluate.pbi ]-------------------------------------------------------------------------
;
;
; by Danilo, May 2011
;
; german forum: http://forums.purebasic.com/german/viewtopic.php?f=8&t=24256
;
;
;>-[ Virtual Stack Machine Info ]--------------------
;
; PUSH value - push a value onto the stack
; NEG - negate top stack value
; NOT - binary NOT top stack value
;
;
; MATH OPERATIONS with 2 operands: lhs OP rhs
;
; the following commands each take the 2 topmost
; values off the stack and push the result of the
; operation onto the stack:
;
; ADD, SUB, MUL, DIV, MOD, POW, OR, AND, XOR, SHL, SHR
;
;
; BOOL COMPARE with 2 operands: lhs CMP rhs
;
; the following compare commands each take the 2 topmost
; values off the stack and push the bool result of the
; compare operation onto the stack:
;
; CMP.Equal
; CMP.NotEqual
; CMP.GreaterThan
; CMP.GreaterEqual
; CMP.SmallerThan
; CMP.SmallerEqual
;
;
; LOGICAL BOOLEAN OPERATIONS with 2 operands: lhs LOGICAL rhs
;
; the following commands each take the 2 topmost
; values off the stack and push the bool result of the
; operation onto the stack:
;
; LOGICAL.OR
; LOGICAL.AND
; LOGICAL.XOR
;
; LOGICAL BOOLEAN OPERATIONS with 1 operand: LOGICAL rhs
;
; LOGICAL.NOT
;
;>---------------------------------------------------
;
;
;>-----------------------------------
; order of operator precedence ;
;>------------------------------------ high
; ;
; () ~ NOT - (unary minus) ;- __parseFactor()
; ;
; & | ! ;- __parseExpression6()
; ;
; << >> ;- __parseExpression5()
; ;
; * / % ^ ;- __parseExpression4()
; ;
; + - ;- __parseExpression3()
; ;
; < > <= =< >= => ;- __parseExpression2()
; ;
; = <> ;- __parseExpression1()
; ;
; OR AND XOR ;- __parseExpression()
; ;
;>------------------------------------ low
EnableExplicit
Enumeration
#__firstToken
#tkError
#tkEndOfInput
#tkIdentifier
#tkInteger
#tkFloat
#tkLParenthesis ; '('
#tkRParenthesis ; ')'
#tkDollar ; '$'
#tkLogicalNot ; 'NOT'
#tkBinaryNot ; '~'
#__firstOperator
#tkAdd ; '+'
#tkSub ; '-'
#tkMul ; '*'
#tkDiv ; '/'
#tkMod ; '%'
#tkPow ; '^'
#tkShiftLeft ; '<<'
#tkShiftRight ; '>>'
#tkBinaryAnd ; '&'
#tkBinaryOr ; '|'
#tkBinaryXor ; '!'
#tkLogicalOr ; 'OR'
#tkLogicalAnd ; 'AND'
#tkLogicalXor ; 'XOR'
#tkEqual ; '='
#tkNotEqual ; '<>'
#tkGreaterThan ; '>'
#tkSmallerThan ; '<'
#tkGreaterEqual ; '>=' '=>'
#tkSmallerEqual ; '<=' '=<'
#__lastOperator
#__lastToken
EndEnumeration
Enumeration
#evalError_Unknown
#evalError_HexNumExpected
#evalError_BinNumExpected
#evalError_IllegalInput
#evalError_MissingOperand
#evalError_MissingOperator
#evalError_MissingExpression
#evalError_MissingRParenthesis
#evalError_MissingDecimalPlace
#evalError_BinaryNotWithFloats
#evalError_DivisionWithNull
#evalError_ModuloWithNull
#evalError_TokenCantStartExpression
#evalError_WrongFloatNumberFormat
EndEnumeration
#evalNumFloatDecimal = 1000
Structure Token
spelling.s
type.l
EndStructure
Prototype.l EvaluateErrorHandler(Error.l,arg1.s="")
Prototype.l EvaluateAsmHandler(asmOutput.s)
Global NewMap EvaluateVariables.s()
Global *evaluateStart.Character
Global evaluateErrorHandler.EvaluateErrorHandler = 0
Global evaluateAsmOutput.EvaluateAsmHandler = 0
Procedure __error(error.l,arg1.s="")
; call user defined error procedure
If evaluateErrorHandler
ProcedureReturn evaluateErrorHandler(error,arg1)
EndIf
EndProcedure
Procedure __emitReal(output.s)
; call user defined AsmOutput procedure
If evaluateAsmOutput
ProcedureReturn evaluateAsmOutput(output)
EndIf
EndProcedure
Macro __emit(output) ; output pseudo-asm
; if #GENERATE_STACKMASCHINE_ASM is true, call __emitReal()
; otherwise insert no code
CompilerIf Defined(GENERATE_STACKMACHINE_ASM,#PB_Constant)
CompilerIf #GENERATE_STACKMACHINE_ASM
__emitReal(output)
CompilerEndIf
CompilerEndIf
EndMacro
Procedure.s __getEvaluateVariable(name.s)
If FindMapElement(EvaluateVariables(),name)
ProcedureReturn Trim(EvaluateVariables())
EndIf
ProcedureReturn "0"
EndProcedure
Procedure.l __germanUmlaut(char.c)
If char='ä' Or char='ö' Or char='ü' Or char='Ä' Or char='Ö' Or char='Ü' Or char='ß'
ProcedureReturn #True
EndIf
ProcedureReturn #False
EndProcedure
Procedure __removeWhiteSpace()
; remove spaces and tabs
While *evaluateStart\c = ' ' Or *evaluateStart\c = #TAB
*evaluateStart + SizeOf(Character)
Wend
EndProcedure
Procedure.s __removeFloatEnding(input.s)
; remove ending Null (.00000) from floats
If FindString(UCase(input),"E",1)=0
If FindString(input,".",1)
input = RTrim(input,"0")
EndIf
EndIf
input = RTrim(input,".")
ProcedureReturn input
EndProcedure
Procedure __checkKeywords(identifier.s)
; switch keywords
; faster with a sorted string table
; or a hash table for many keywords,
; but ok here
Select UCase(identifier)
Case "AND" : ProcedureReturn #tkLogicalAnd
Case "NOT" : ProcedureReturn #tkLogicalNot
Case "OR" : ProcedureReturn #tkLogicalOr
Case "XOR" : ProcedureReturn #tkLogicalXor
EndSelect
ProcedureReturn #tkIdentifier
EndProcedure
Procedure __getToken(*tk.Token, lookUpOnly.l=0)
Protected *oldStart.Character = *evaluateStart
Protected e=0
If *evaluateStart And *tk
*tk\spelling = ""
*tk\type = 0
__removeWhiteSpace()
Select *evaluateStart\c
Case '0' To '9' ; numbers 0-9
While *evaluateStart\c >= '0' And *evaluateStart\c <= '9'
*tk\spelling + Chr(*evaluateStart\c)
*evaluateStart + SizeOf(Character)
Wend
If (*evaluateStart\c = '.') Or (*evaluateStart\c = 'E') Or (*evaluateStart\c = 'e') ; float numbers .[0-9] or E[0-9]
*tk\spelling + Chr(*evaluateStart\c)
If *evaluateStart\c='E' Or *evaluateStart\c='e'
*evaluateStart + SizeOf(Character)
If *evaluateStart\c = '-'
*tk\spelling + Chr(*evaluateStart\c)
*evaluateStart + SizeOf(Character)
EndIf
e=1
Else
*evaluateStart + SizeOf(Character)
EndIf
While *evaluateStart\c >= '0' And *evaluateStart\c <= '9'
*tk\spelling + Chr(*evaluateStart\c)
*evaluateStart + SizeOf(Character)
Wend
If Not e
If *evaluateStart\c = 'E' Or *evaluateStart\c = 'e' ; float numbers .[0-9] E - [0-9]
e=1
*tk\spelling + Chr(*evaluateStart\c)
*evaluateStart + SizeOf(Character)
If *evaluateStart\c = '-'
*tk\spelling + Chr(*evaluateStart\c)
*evaluateStart + SizeOf(Character)
EndIf
While *evaluateStart\c >= '0' And *evaluateStart\c <= '9'
*tk\spelling + Chr(*evaluateStart\c)
*evaluateStart + SizeOf(Character)
Wend
EndIf
EndIf
If Right(*tk\spelling,1)="."
*tk\spelling = "ERROR"
*tk\type = #tkError
__error(#evalError_MissingDecimalPlace)
ProcedureReturn 0
ElseIf UCase(Right(*tk\spelling,1))="E" Or Right(*tk\spelling,1)="-" Or *evaluateStart\c = '.'
*tk\spelling = "ERROR"
*tk\type = #tkError
__error(#evalError_WrongFloatNumberFormat)
ProcedureReturn 0
EndIf
*tk\type = #tkFloat
Else
*tk\type = #tkInteger
EndIf
Case 'a' To 'z' , 'A' To 'Z' , '_','ä','ö','ü','Ä','Ö','Ü','ß' ; identifiers
While (*evaluateStart\c >= 'a' And *evaluateStart\c <= 'z') Or (*evaluateStart\c >= 'A' And *evaluateStart\c <= 'Z') Or (*evaluateStart\c >= '0' And *evaluateStart\c <= '9') Or *evaluateStart\c = '_' Or __germanUmlaut(*evaluateStart\c)
*tk\spelling + Chr(*evaluateStart\c)
*evaluateStart + SizeOf(Character)
Wend
*tk\type = __checkKeywords(*tk\spelling)
Case '$' ; '$' hexnumbers
*tk\spelling + Chr(*evaluateStart\c)
*evaluateStart + SizeOf(Character)
__removeWhiteSpace()
While (*evaluateStart\c >= '0' And *evaluateStart\c <= '9') Or (*evaluateStart\c >= 'a' And *evaluateStart\c <= 'f') Or (*evaluateStart\c >= 'A' And *evaluateStart\c <= 'F')
*tk\spelling + Chr(*evaluateStart\c)
*evaluateStart + SizeOf(Character)
Wend
If Len(*tk\spelling)<2
*tk\spelling = "ERROR"
*tk\type = #tkError
__error(#evalError_HexNumExpected)
ProcedureReturn 0
EndIf
*tk\spelling = Str(Val(*tk\spelling))
*tk\type = #tkInteger
Case '+' ; '+'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkAdd
*evaluateStart + SizeOf(Character)
Case '-' ; '-'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkSub
*evaluateStart + SizeOf(Character)
Case '*' ; '*'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkMul
*evaluateStart + SizeOf(Character)
Case '/' ; '/'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkDiv
*evaluateStart + SizeOf(Character)
Case '%' ; '%'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkMod
*evaluateStart + SizeOf(Character)
Case '^' ; '^'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkPow
*evaluateStart + SizeOf(Character)
Case '&' ; '&'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkBinaryAnd
*evaluateStart + SizeOf(Character)
Case '|' ; '|'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkBinaryOr
*evaluateStart + SizeOf(Character)
Case '!' ; '!'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkBinaryXor
*evaluateStart + SizeOf(Character)
Case '~' ; '~'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkBinaryNot
*evaluateStart + SizeOf(Character)
Case '(' ; '('
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkLParenthesis
*evaluateStart + SizeOf(Character)
Case ')' ; ')'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkRParenthesis
*evaluateStart + SizeOf(Character)
Case '=' ; '='
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkEqual
*evaluateStart + SizeOf(Character)
__removeWhiteSpace()
If *evaluateStart\c = '>' ; '=>'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkGreaterEqual
*evaluateStart + SizeOf(Character)
ElseIf *evaluateStart\c = '<' ; '=<'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkSmallerEqual
*evaluateStart + SizeOf(Character)
EndIf
Case '<' ; '<'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkSmallerThan
*evaluateStart + SizeOf(Character)
__removeWhiteSpace()
If *evaluateStart\c = '>' ; '<>'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkNotEqual
*evaluateStart + SizeOf(Character)
ElseIf *evaluateStart\c = '=' ; '<='
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkSmallerEqual
*evaluateStart + SizeOf(Character)
ElseIf *evaluateStart\c = '<' ; '<<'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkShiftLeft
*evaluateStart + SizeOf(Character)
EndIf
Case '>' ; '>'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkGreaterThan
*evaluateStart + SizeOf(Character)
__removeWhiteSpace()
If *evaluateStart\c = '=' ; '>='
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkGreaterEqual
*evaluateStart + SizeOf(Character)
ElseIf *evaluateStart\c = '>' ; '>>'
*tk\spelling + Chr(*evaluateStart\c)
*tk\type = #tkShiftRight
*evaluateStart + SizeOf(Character)
EndIf
Case 0 ; 0 = end of input
*tk\type = #tkEndOfInput
ProcedureReturn 0
Default ; ERROR, unsupported input
*tk\spelling = "ERROR"
*tk\type = #tkError
__error(#evalError_IllegalInput,Chr(*evaluateStart\c))
*evaluateStart + SizeOf(Character)
ProcedureReturn 0
EndSelect
If lookUpOnly
*evaluateStart = *oldStart
EndIf
ProcedureReturn *tk\type
EndIf
ProcedureReturn 0
EndProcedure
Declare __parseExpression(*tk.Token)
Procedure __parseFactor(*tk.Token)
Protected tk.Token
*tk\spelling = ""
*tk\type = 0
If __getToken(*tk)
Select *tk\type
Case #tkInteger ; integer number
__emit(" PUSH "+*tk\spelling)
ProcedureReturn #True
Case #tkFloat ; float number
__emit(" PUSH "+*tk\spelling)
*tk\spelling = __removeFloatEnding(*tk\spelling)
If FindString(*tk\spelling,".",1) Or FindString(UCase(*tk\spelling),"E",1)
If FindString(UCase(*tk\spelling),"E",1)
*tk\spelling = StrD(ValD(*tk\spelling),#evalNumFloatDecimal)
EndIf
*tk\type = #tkFloat
Else
*tk\type = #tkInteger
EndIf
ProcedureReturn #True
Case #tkIdentifier ; identifier
__removeWhiteSpace()
If *evaluateStart\c = '(' ; identifier = function
*tk\spelling = "ERROR"
__error(0,"functions not supported yet")
ProcedureReturn 0
Else ; identifier = variable
__emit(" PUSH "+*tk\spelling)
*tk\spelling = __getEvaluateVariable(*tk\spelling)
If Left(*tk\spelling,1)="$" ; hex number
*tk\spelling = Str(Val(*tk\spelling))
*tk\type = #tkInteger
ElseIf Left(*tk\spelling,1)="%" ; binary number
*tk\spelling = Str(Val(*tk\spelling))
*tk\type = #tkInteger
Else
If FindString(*tk\spelling,".",1) Or FindString(UCase(*tk\spelling),"E",1)
If FindString(UCase(*tk\spelling),"E",1)
*tk\spelling = StrD(ValD(*tk\spelling),#evalNumFloatDecimal)
EndIf
*tk\spelling = __removeFloatEnding(*tk\spelling)
*tk\type = #tkFloat
Else
*tk\type = #tkInteger
EndIf
EndIf
ProcedureReturn #True
EndIf
Case #tkSub ; unary minus
If __parseFactor(*tk)
If *tk\type = #tkInteger Or *tk\type = #tkFloat
;__emit(" PUSH "+*tk\spelling)
__emit(" NEG")
If Left(*tk\spelling,1)="-" ; remove minus ( '--' = '+' )
*tk\spelling = Right(*tk\spelling,Len(*tk\spelling)-1)
Else
*tk\spelling = "-"+*tk\spelling ; add minus
EndIf
ProcedureReturn #True
EndIf
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingOperand, "- (unary minus)")
ProcedureReturn 0
EndIf
Case #tkBinaryNot ; '~' binary NOT
If __parseFactor(*tk)
If *tk\type = #tkInteger
__emit(" NOT")
*tk\spelling = Str(~Val(*tk\spelling))
ProcedureReturn #True
Else
*tk\spelling = "ERROR"
__error(#evalError_BinaryNotWithFloats,"NOT")
ProcedureReturn 0
EndIf
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingOperand, "~ (binary NOT)")
ProcedureReturn 0
EndIf
Case #tkLogicalNot ; 'NOT' LOGICAL.NOT
If __parseFactor(*tk)
__emit(" LOGICAL.NOT")
If ValD(*tk\spelling)
*tk\spelling = "0"
Else
*tk\spelling = "1"
EndIf
*tk\type = #tkInteger
ProcedureReturn #True
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression, "NOT")
ProcedureReturn 0
EndIf
Case #tkMod ;'%' binary number
__removeWhiteSpace()
If *evaluateStart\c = '0' Or *evaluateStart\c = '1'
While *evaluateStart\c = '0' Or *evaluateStart\c = '1'
*tk\spelling + Chr(*evaluateStart\c)
*evaluateStart + SizeOf(Character)
Wend
*tk\spelling = Str(Val(*tk\spelling))
*tk\type = #tkInteger
__emit(" PUSH "+*tk\spelling)
ProcedureReturn #True
Else
*tk\spelling = "ERROR"
*tk\type = #tkError
__error(#evalError_BinNumExpected)
ProcedureReturn 0
EndIf
Case #tkLParenthesis ; ( Expression )
If __parseExpression(*tk)
If __getToken(@tk,#True) And tk\type = #tkRParenthesis
__getToken(@tk)
ProcedureReturn #True
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingRParenthesis)
ProcedureReturn 0
EndIf
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"(")
ProcedureReturn 0
EndIf
Default
__error(#evalError_TokenCantStartExpression,*tk\spelling)
*tk\spelling = "ERROR"
ProcedureReturn 0
EndSelect
EndIf
ProcedureReturn 0
EndProcedure
Procedure __parseExpression6(*tk.Token)
Protected tk.Token
If __parseFactor(*tk)
Repeat
If __getToken(@tk,#True)
Select tk\type
Case #tkBinaryOr ; '|' binary OR
__getToken(@tk)
If __parseFactor(@tk)
__emit(" OR")
If *tk\type = #tkInteger And tk\type = #tkInteger
*tk\spelling = Str( Val(*tk\spelling) | Val(tk\spelling) )
*tk\type = #tkInteger
Else
*tk\spelling = "ERROR"
__error(#evalError_BinaryNotWithFloats,"OR")
ProcedureReturn 0
EndIf
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"|")
ProcedureReturn 0
EndIf
Case #tkBinaryAnd ; '&' binary AND
__getToken(@tk)
If __parseFactor(@tk)
__emit(" AND")
If *tk\type = #tkInteger And tk\type = #tkInteger
*tk\spelling = Str( Val(*tk\spelling) & Val(tk\spelling) )
*tk\type = #tkInteger
Else
*tk\spelling = "ERROR"
__error(#evalError_BinaryNotWithFloats,"AND")
ProcedureReturn 0
EndIf
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"&")
ProcedureReturn 0
EndIf
Case #tkBinaryXor ; '!' binary XOR
__getToken(@tk)
If __parseFactor(@tk)
__emit(" XOR")
If *tk\type = #tkInteger And tk\type = #tkInteger
*tk\spelling = Str( Val(*tk\spelling) ! Val(tk\spelling) )
*tk\type = #tkInteger
Else
*tk\spelling = "ERROR"
__error(#evalError_BinaryNotWithFloats,"XOR")
ProcedureReturn 0
EndIf
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"!")
ProcedureReturn 0
EndIf
Default
Break
EndSelect
Else
Break
EndIf
ForEver
Else
ProcedureReturn 0
EndIf
ProcedureReturn #True
EndProcedure
Procedure __parseExpression5(*tk.Token)
Protected tk.Token
If __parseExpression6(*tk)
Repeat
If __getToken(@tk,#True)
Select tk\type
Case #tkShiftLeft ; '<<' SHIFT LEFT
__getToken(@tk)
If __parseExpression6(@tk)
__emit(" SHL")
If *tk\type = #tkInteger And tk\type = #tkInteger
*tk\spelling = Str( Val(*tk\spelling) << Val(tk\spelling) )
*tk\type = #tkInteger
Else
*tk\spelling = "ERROR"
__error(#evalError_BinaryNotWithFloats,"<<")
ProcedureReturn 0
EndIf
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"<<")
ProcedureReturn 0
EndIf
Case #tkShiftRight ; '>>' SHIFT RIGHT
__getToken(@tk)
If __parseExpression6(@tk)
__emit(" SHR")
If *tk\type = #tkInteger And tk\type = #tkInteger
*tk\spelling = Str( Val(*tk\spelling) >> Val(tk\spelling) )
*tk\type = #tkInteger
Else
*tk\spelling = "ERROR"
__error(#evalError_BinaryNotWithFloats,">>")
ProcedureReturn 0
EndIf
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,">>")
ProcedureReturn 0
EndIf
Default
Break
EndSelect
Else
Break
EndIf
ForEver
Else
ProcedureReturn 0
EndIf
ProcedureReturn #True
EndProcedure
Procedure __parseExpression4(*tk.Token)
Protected tk.Token
If __parseExpression5(*tk)
Repeat
If __getToken(@tk,#True)
Select tk\type
Case #tkMul ; '*' MUL
__getToken(@tk)
If __parseExpression5(@tk)
__emit(" MUL")
If *tk\type = #tkInteger And tk\type = #tkInteger
*tk\spelling = Str( Val(*tk\spelling) * Val(tk\spelling) )
*tk\type = #tkInteger
Else
*tk\spelling = StrD( ValD(*tk\spelling) * ValD(tk\spelling) ,#evalNumFloatDecimal)
*tk\type = #tkFloat
EndIf
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"*")
ProcedureReturn 0
EndIf
Case #tkDiv ; '/' DIV
__getToken(@tk)
If __parseExpression5(@tk)
Protected f2.f = ValD(tk\spelling)
If f2
__emit(" DIV")
*tk\spelling = StrD( ValD(*tk\spelling) / f2 ,#evalNumFloatDecimal)
*tk\spelling = __removeFloatEnding(*tk\spelling)
If FindString(*tk\spelling,".",1)
*tk\type = #tkFloat
Else
*tk\type = #tkInteger
EndIf
Else
*tk\spelling = "ERROR"
*tk\type = #tkFloat
__error(#evalError_DivisionWithNull)
ProcedureReturn 0
EndIf
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"/")
ProcedureReturn 0
EndIf
Case #tkMod ; '%' MOD
__getToken(@tk)
If __parseExpression5(@tk)
Protected q2.q = IntQ(ValD(tk\spelling))
If q2=0
*tk\spelling = "ERROR" ; ERROR, Modulo with 0...
*tk\type = #tkFloat
__error(#evalError_ModuloWithNull)
ProcedureReturn 0
Else
If *tk\type = #tkInteger And tk\type = #tkInteger
__emit(" MOD")
*tk\spelling = Str( Val(*tk\spelling) % Val(tk\spelling) )
*tk\type = #tkInteger
Else
*tk\spelling = "ERROR"
__error(#evalError_BinaryNotWithFloats, "%")
ProcedureReturn 0
EndIf
EndIf
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"%")
ProcedureReturn 0
EndIf
Case #tkPow ; '^' POW
__getToken(@tk)
If __parseExpression5(@tk)
__emit(" POW")
*tk\spelling = StrD( Pow( ValD(*tk\spelling) , ValD(tk\spelling) ) ,#evalNumFloatDecimal)
*tk\spelling = __removeFloatEnding(*tk\spelling)
If FindString(*tk\spelling,".",1)
*tk\type = #tkFloat
Else
*tk\type = #tkInteger
EndIf
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"^")
ProcedureReturn 0
EndIf
Default
Break
EndSelect
Else
Break
EndIf
ForEver
Else
ProcedureReturn 0
EndIf
ProcedureReturn #True
EndProcedure
Procedure __parseExpression3(*tk.Token)
Protected tk.Token
If __parseExpression4(*tk)
Repeat
If __getToken(@tk,#True)
Select tk\type
Case #tkAdd ; '+' ADD
__getToken(@tk)
If __parseExpression4(@tk)
__emit(" ADD")
If *tk\type = #tkInteger And tk\type = #tkInteger
*tk\spelling = Str( Val(*tk\spelling) + Val(tk\spelling) )
*tk\type = #tkInteger
Else
*tk\spelling = StrD( ValD(*tk\spelling) + ValD(tk\spelling) ,#evalNumFloatDecimal)
*tk\spelling = __removeFloatEnding(*tk\spelling)
If FindString(*tk\spelling,".",1)
*tk\type = #tkFloat
Else
*tk\type = #tkInteger
EndIf
EndIf
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"+")
ProcedureReturn 0
EndIf
Case #tkSub ; '-' SUB
__getToken(@tk)
If __parseExpression4(@tk)
__emit(" SUB")
If *tk\type = #tkInteger And tk\type = #tkInteger
*tk\spelling = Str( Val(*tk\spelling) - Val(tk\spelling) )
*tk\type = #tkInteger
Else
*tk\spelling = StrD( ValD(*tk\spelling) - ValD(tk\spelling) ,#evalNumFloatDecimal)
*tk\spelling = __removeFloatEnding(*tk\spelling)
If FindString(*tk\spelling,".",1)
*tk\type = #tkFloat
Else
*tk\type = #tkInteger
EndIf
EndIf
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"-")
ProcedureReturn 0
EndIf
Default
Break
EndSelect
Else
Break
EndIf
ForEver
Else
ProcedureReturn 0
EndIf
ProcedureReturn #True
EndProcedure
Procedure __parseExpression2(*tk.Token)
Protected tk.Token
If __parseExpression3(*tk)
Repeat
If __getToken(@tk,#True)
Select tk\type
Case #tkGreaterThan ; '>' CMP.GreaterThan
__getToken(@tk)
If __parseExpression3(@tk)
__emit(" CMP.GreaterThan")
If ValD(*tk\spelling) > ValD(tk\spelling)
*tk\spelling = "1"
Else
*tk\spelling = "0"
EndIf
*tk\type = #tkInteger
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,">")
ProcedureReturn 0
EndIf
Case #tkSmallerThan ; '<' CMP.SmallerThan
__getToken(@tk)
If __parseExpression3(@tk)
__emit(" CMP.SmallerThan")
If ValD(*tk\spelling) < ValD(tk\spelling)
*tk\spelling = "1"
Else
*tk\spelling = "0"
EndIf
*tk\type = #tkInteger
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"<")
ProcedureReturn 0
EndIf
Case #tkGreaterEqual ; '>=' '=>' CMP.GreaterEqual
__getToken(@tk)
If __parseExpression3(@tk)
__emit(" CMP.GreaterEqual")
If ValD(*tk\spelling) >= ValD(tk\spelling)
*tk\spelling = "1"
Else
*tk\spelling = "0"
EndIf
*tk\type = #tkInteger
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,">=")
ProcedureReturn 0
EndIf
Case #tkSmallerEqual ; '<=' '=<' CMP.SmallerEqual
__getToken(@tk)
If __parseExpression3(@tk)
__emit(" CMP.SmallerEqual")
If ValD(*tk\spelling) <= ValD(tk\spelling)
*tk\spelling = "1"
Else
*tk\spelling = "0"
EndIf
*tk\type = #tkInteger
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"<=")
ProcedureReturn 0
EndIf
Default
Break
EndSelect
Else
Break
EndIf
ForEver
Else
ProcedureReturn 0
EndIf
ProcedureReturn #True
EndProcedure
Procedure __parseExpression1(*tk.Token)
Protected tk.Token
If __parseExpression2(*tk)
Repeat
If __getToken(@tk,#True)
Select tk\type
Case #tkEqual ; '=' CMP.Equal
__getToken(@tk)
If __parseExpression2(@tk)
__emit(" CMP.Equal")
*tk\spelling = __removeFloatEnding(*tk\spelling)
tk\spelling = __removeFloatEnding( tk\spelling)
If *tk\spelling = tk\spelling
*tk\spelling = "1"
Else
*tk\spelling = "0"
EndIf
*tk\type = #tkInteger
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"=")
ProcedureReturn 0
EndIf
Case #tkNotEqual ; '<>' CMP.NotEqual
__getToken(@tk)
If __parseExpression2(@tk)
__emit(" CMP.NotEqual")
*tk\spelling = __removeFloatEnding(*tk\spelling)
tk\spelling = __removeFloatEnding( tk\spelling)
If *tk\spelling = tk\spelling
*tk\spelling = "0"
Else
*tk\spelling = "1"
EndIf
*tk\type = #tkInteger
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"<>")
ProcedureReturn 0
EndIf
Default
Break
EndSelect
Else
Break
EndIf
ForEver
Else
ProcedureReturn 0
EndIf
ProcedureReturn #True
EndProcedure
Procedure __parseExpression(*tk.Token)
Protected tk.Token
If __parseExpression1(*tk)
Repeat
If __getToken(@tk,#True)
Select tk\type
Case #tkLogicalOr ; 'OR' LOGICAL.OR
__getToken(@tk)
If __parseExpression1(@tk)
__emit(" LOGICAL.OR")
If ValD(*tk\spelling) Or ValD(tk\spelling)
*tk\spelling = "1"
Else
*tk\spelling = "0"
EndIf
*tk\type = #tkInteger
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"OR")
ProcedureReturn 0
EndIf
Case #tkLogicalAnd ; 'AND' LOGICAL.AND
__getToken(@tk)
If __parseExpression1(@tk)
__emit(" LOGICAL.AND")
If ValD(*tk\spelling) And ValD(tk\spelling)
*tk\spelling = "1"
Else
*tk\spelling = "0"
EndIf
*tk\type = #tkInteger
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"AND")
ProcedureReturn 0
EndIf
Case #tkLogicalXor ; 'XOR' LOGICAL.XOR
__getToken(@tk)
If __parseExpression1(@tk)
__emit(" LOGICAL.XOR")
If ValD(*tk\spelling) XOr ValD(tk\spelling)
*tk\spelling = "1"
Else
*tk\spelling = "0"
EndIf
*tk\type = #tkInteger
Continue
Else
*tk\spelling = "ERROR"
__error(#evalError_MissingExpression,"XOR")
ProcedureReturn 0
EndIf
Default
Break
EndSelect
Else
Break
EndIf
ForEver
Else
ProcedureReturn 0
EndIf
ProcedureReturn #True
EndProcedure
Procedure.s Evaluate(expression.s)
Protected tk1.Token, tk2.Token
Protected temp.s
*evaluateStart.Character = @expression
Repeat
If __parseExpression(@tk1) And tk1\spelling <> "ERROR"
If __getToken(@tk2)
If tk2\type > #__firstOperator And tk2\type < #__lastOperator ; Expression operator Expression ...
temp = tk1\spelling + PeekS(*evaluateStart)
*evaluateStart = @temp
Continue
ElseIf tk2\type <> #tkError And tk2\type <> #tkEndOfInput
tk1\spelling = "ERROR"
__error(#evalError_MissingOperator)
Break
EndIf
EndIf
EndIf
Break
ForEver
temp = __removeFloatEnding(tk1\spelling)
If temp = ""
temp = "0"
EndIf
ProcedureReturn temp
EndProcedure
Procedure SetEvaluateErrorHandler(proc.EvaluateErrorHandler)
evaluateErrorHandler = proc
EndProcedure
Procedure SetEvaluateAsmOutputHandler(proc.EvaluateAsmHandler)
evaluateAsmOutput = proc
EndProcedure
;-[ END INCLUDE: Evaluate.pbi ]---------------------------------------------------------------------Code: Alles auswählen
XIncludeFile "Evaluate.pbi"
Debug Evaluate("10 + 4 * 2")Code: Alles auswählen
EnableExplicit
#GENERATE_STACKMACHINE_ASM = 1
XIncludeFile "Evaluate.pbi"
Define mainWindow
Define inputGadget, resultGadget, newVar, addVar
Define gadgetFont, eventType
Define t1,t2,t3,t4,t5
Global errorOut, asmOut, variablesView
Procedure myErrorHandler(error.l,arg1.s)
Define msg.s
Select error
Case #evalError_HexNumExpected
msg="ERROR: expected a HEX number after $"
Case #evalError_BinNumExpected
msg="ERROR: expected a binary number after %"
Case #evalError_IllegalInput
msg="ERROR: illegal input detected: '" + arg1 +"' - (Chr: "+Str(Asc(arg1))+")"
Case #evalError_MissingOperator
msg="ERROR: operator expected"
Case #evalError_MissingOperand
msg="ERROR: missing operand after: " +arg1
Case #evalError_MissingExpression
msg="ERROR: expression expected after " + arg1
Case #evalError_MissingRParenthesis
msg="ERROR: missing ')'"
Case #evalError_MissingDecimalPlace
msg="ERROR: missing decimal place after ."
Case #evalError_BinaryNotWithFloats
msg="ERROR: binary "+arg1+" with floating point values not supported, use integer"
Case #evalError_DivisionWithNull
msg="ERROR: division with 0"
Case #evalError_ModuloWithNull
msg="ERROR: modulo (%) with 0"
Case #evalError_WrongFloatNumberFormat
msg="ERROR: wrong floating point number format"
Case #evalError_TokenCantStartExpression
msg="ERROR: "+arg1+" can't start an expression"
Default
msg="ERROR: unknown error: "+arg1
EndSelect
AddGadgetItem(errorOut,-1,msg)
EndProcedure
Procedure myAsmHandler(txt.s)
AddGadgetItem(asmOut,-1,txt)
EndProcedure
Procedure updateVariablesView()
ClearGadgetItems(variablesView)
ForEach EvaluateVariables()
AddGadgetItem(variablesView,-1,MapKey(EvaluateVariables())+Chr(10)+EvaluateVariables() )
Next
EndProcedure
SetEvaluateErrorHandler(@myErrorHandler())
SetEvaluateAsmOutputHandler(@myAsmHandler())
gadgetFont = LoadFont(#PB_Any,"Lucida Console",12)
mainWindow = OpenWindow(#PB_Any,0,0,1024,600,"Evaluate()",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)
If mainWindow
SetWindowColor(mainWindow,RGB($50,$50,$50))
inputGadget = EditorGadget(#PB_Any,300,20,724,100)
SetGadgetColor(inputGadget,#PB_Gadget_BackColor ,RGB($30,$30,$30))
SetGadgetColor(inputGadget,#PB_Gadget_FrontColor,RGB($AA,$AA,$AA))
SetGadgetFont(inputGadget,FontID(gadgetFont))
resultGadget = StringGadget(#PB_Any,300,140,724,30,"",#PB_String_ReadOnly)
SetGadgetColor(resultGadget,#PB_Gadget_BackColor ,RGB($30,$30,$30))
SetGadgetColor(resultGadget,#PB_Gadget_FrontColor,RGB($AA,$AA,$AA))
SetGadgetFont(resultGadget,FontID(gadgetFont))
errorOut = EditorGadget(#PB_Any,300,190,724,100,#PB_Editor_ReadOnly)
SetGadgetColor(errorOut,#PB_Gadget_BackColor ,RGB($00,$00,$00))
SetGadgetColor(errorOut,#PB_Gadget_FrontColor,RGB($FF,$00,$00))
SetGadgetFont(errorOut,FontID(gadgetFont))
asmOut = ListViewGadget(#PB_Any,300,310,724,290)
SetGadgetColor(asmOut,#PB_Gadget_BackColor ,RGB($00,$00,$00))
SetGadgetColor(asmOut,#PB_Gadget_FrontColor,RGB($00,$FF,$80))
SetGadgetFont(asmOut,FontID(gadgetFont))
variablesView = ListIconGadget(#PB_Any,0,20,280,500,"Name",100,#PB_ListIcon_FullRowSelect|#PB_ListIcon_GridLines)
AddGadgetColumn(variablesView,1,"Value",170)
SetGadgetColor(variablesView,#PB_Gadget_BackColor ,RGB($00,$00,$00))
SetGadgetColor(variablesView,#PB_Gadget_FrontColor,RGB($00,$FF,$80))
SetGadgetColor(variablesView,#PB_Gadget_LineColor ,RGB($30,$30,$30))
SetGadgetFont(variablesView,FontID(gadgetFont))
newVar = StringGadget(#PB_Any,0,520,280,35,"n = 1.2345")
SetGadgetColor(newVar,#PB_Gadget_BackColor ,RGB($30,$30,$30))
SetGadgetColor(newVar,#PB_Gadget_FrontColor,RGB($AA,$AA,$AA))
SetGadgetFont(newVar,FontID(gadgetFont))
addVar = ButtonGadget(#PB_Any,0,555,280,35,"Add Variable")
t1=TextGadget(#PB_Any, 0, 0,280,20,"Variables" ,#PB_Text_Center)
SetGadgetColor(t1,#PB_Gadget_BackColor ,RGB($50,$50,$50))
SetGadgetColor(t1,#PB_Gadget_FrontColor,RGB($AA,$AA,$AA))
t2=TextGadget(#PB_Any,300, 0,724,20,"Input" ,#PB_Text_Center)
SetGadgetColor(t2,#PB_Gadget_BackColor ,RGB($50,$50,$50))
SetGadgetColor(t2,#PB_Gadget_FrontColor,RGB($AA,$AA,$AA))
t3=TextGadget(#PB_Any,300,120,724,20,"Result" ,#PB_Text_Center)
SetGadgetColor(t3,#PB_Gadget_BackColor ,RGB($50,$50,$50))
SetGadgetColor(t3,#PB_Gadget_FrontColor,RGB($AA,$AA,$AA))
t4=TextGadget(#PB_Any,300,170,724,20,"Errors" ,#PB_Text_Center)
SetGadgetColor(t4,#PB_Gadget_BackColor ,RGB($50,$50,$50))
SetGadgetColor(t4,#PB_Gadget_FrontColor,RGB($AA,$AA,$AA))
t5=TextGadget(#PB_Any,300,290,724,20,"ASM Output",#PB_Text_Center)
SetGadgetColor(t5,#PB_Gadget_BackColor ,RGB($50,$50,$50))
SetGadgetColor(t5,#PB_Gadget_FrontColor,RGB($AA,$AA,$AA))
EvaluateVariables("pi") = StrD(#PI,1000)
updateVariablesView()
SetGadgetText(inputGadget,"12 + 54 * 7 /"+#CRLF$+"3 * 0.5 - 0.5 +"+#CRLF$+"12*(1+3*(1+1)) - 123"+#CRLF$)
SetActiveGadget(inputGadget)
Repeat
Select WaitWindowEvent()
Case #PB_Event_Gadget
eventType = EventType()
Select EventGadget()
Case inputGadget
Define text.s, i
text=""
ClearGadgetItems(asmOut)
ClearGadgetItems(errorOut)
For i = 0 To CountGadgetItems(inputGadget)
text + GetGadgetItemText(inputGadget,i)
Next
text = Evaluate( text )
SetGadgetText(resultGadget,text)
If text="ERROR"
ClearGadgetItems(asmOut)
EndIf
Case addVar
Define varName.s, varValue.s
varName = Trim(StringField( GetGadgetText(newVar),1,"="))
varValue = Trim(StringField( GetGadgetText(newVar),2,"="))
If FindString(varValue,".",1) Or FindString(UCase(varValue),"E",1)
;varValue = StrD(ValD(varValue),1000)
Else
varValue = Str(Val(varValue))
EndIf
EvaluateVariables(varName)=varValue
updateVariablesView()
EndSelect
Case #PB_Event_CloseWindow
Break
EndSelect
ForEver
EndIf
