Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Script.bi Script als Type
| Uploader: |  XOR |
| Datum/Zeit: | 20.05.2011 21:50:56 |
#Include "Tabelle.bi"
#Ifndef BR
#Define BR Chr(13,10)
#EndIf
Type SCRIPT_VARIANT
Declare Destructor ()
Declare Operator Let ( ByRef As SCRIPT_VARIANT )
Declare Operator Let ( ByVal As String )
Declare Operator Let ( ByVal As Double )
Declare Operator Cast () As String
Declare Operator Cast () As Double
Declare Function WitchType () As Integer
Declare Function GetPtr () As Any ptr
Private:
PType As Integer
Union
PAny As Any Ptr
PInt As Double Ptr
PStri As ZString Ptr
End Union
End Type
Destructor SCRIPT_VARIANT ()
If This.PAny Then DeAllocate( This.PAny )
End Destructor
Operator SCRIPT_VARIANT.Let ( ByRef In As SCRIPT_VARIANT )
If In.GetPtr = 0 Then
This.PType = In.WitchType
This.PAny = 0
Exit Operator
EndIf
Select Case In.WitchType
Case 0
This = *Cast(Double Ptr,In.GetPtr)
Case Else
This = *Cast(ZString Ptr,In.GetPtr)
End Select
End Operator
Operator SCRIPT_VARIANT.Let ( ByVal S As String )
If This.PAny Then DeAllocate(This.PAny)
This.PType = 1
This.PStri = Allocate(Len(S)+1)
*This.PStri = S
End Operator
Operator SCRIPT_VARIANT.Let ( ByVal I As Double )
If This.PAny Then DeAllocate(This.PAny)
This.PType = 0
This.PInt = Allocate(SizeOf(Double))
*This.PInt = I
End Operator
Operator SCRIPT_VARIANT.Cast () As String
If This.PAny = 0 Then Return ""
Select Case This.PType
Case 0
Return Str(*This.PInt)
Case 1
Return *This.PStri
Case Else
Return ""
End Select
End Operator
Operator SCRIPT_VARIANT.Cast () As Double
If This.PAny = 0 Then Return 0
Select Case This.PType
Case 0
Return *This.PInt
Case 1
Return Val(*This.PStri)
Case Else
Return 0
End Select
End Operator
Function SCRIPT_VARIANT.WitchType () As Integer
Return This.PType
End Function
Function SCRIPT_VARIANT.GetPtr () As Any Ptr
Return This.PAny
End Function
Operator + ( ByVal V1 As SCRIPT_VARIANT, ByVal V2 As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Select Case V1.WitchType()
Case 0
Dim I As Double
I = V1
Return I + V2
Case 1
Dim S As String
S = V1
Return S + V2
Case Else
Return ""
End Select
End Operator
Operator - ( ByVal V1 As SCRIPT_VARIANT, ByVal V2 As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Dim I As Double
I = V1
Return I - V2
End Operator
Operator - ( ByVal V1 As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Dim I As Double
I = V1
Return -I
End Operator
Operator * ( ByVal V1 As SCRIPT_VARIANT, ByVal V2 As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Dim I As Double
I = V1
Return I * V2
End Operator
Operator / ( ByVal V1 As SCRIPT_VARIANT, ByVal V2 As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Dim I As Double
I = V1
Return I / V2
End Operator
Operator ^ ( ByVal V1 As SCRIPT_VARIANT, ByVal V2 As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Dim I As Double
I = V1
Return I ^ V2
End Operator
Operator Or ( ByVal V1 As SCRIPT_VARIANT, ByVal V2 As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Dim I As Double
I = V1
Return I Or V2
End Operator
Operator And ( ByVal V1 As SCRIPT_VARIANT, ByVal V2 As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Dim I As Double
I = V1
Return I And V2
End Operator
Operator Xor ( ByVal V1 As SCRIPT_VARIANT, ByVal V2 As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Dim I As Double
I = V1
Return I Xor V2
End Operator
Operator Shl ( ByVal V1 As SCRIPT_VARIANT, ByVal V2 As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Dim I As Double
I = V1
Return I Shl V2
End Operator
Operator Shr ( ByVal V1 As SCRIPT_VARIANT, ByVal V2 As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Dim I As Double
I = V1
Return I Shr V2
End Operator
Operator Not ( ByVal V1 As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Dim I As Double
I = V1
Return Not(I)
End Operator
Type Sctipt_Block
Text As ZString Ptr
Next As Sctipt_Block Ptr
Oder As Sctipt_Block Ptr
End Type
Type SCRIPT
Declare Function Create () As Integer
Declare Function Register ( ByVal As String, ByVal As Integer, ByVal As Integer, ByVal As Any Ptr ) As Integer
Declare Property GlobalVar ( ByVal As String, ByVal As SCRIPT_VARIANT )
Declare Property GlobalVar ( ByVal As String ) As SCRIPT_VARIANT
Declare Function CompileFromString ( ByVal As String ) As Integer
Declare Function CompileFromFile ( ByVal As String ) As Integer
Declare Function CallFunc Cdecl ( ByVal As String, ByVal As String, ... ) As SCRIPT_VARIANT
Declare Sub CallSub Cdecl ( ByVal As String, ByVal As String, ... )
Declare Sub Destroy ()
Declare Sub Undef ( ByVal As String )
Declare Function GetErrors () As String
Private:
Declare Function GetNextBlock ( ByVal As String, ByVal As Integer Ptr ) As String
Declare Function RegisterStringFunction ( ByVal As String, ByVal As String, ByVal As Sctipt_Block Ptr ) As Integer
Declare Function Compile_Block ( ByVal As String, ByVal As Integer Ptr ) As Sctipt_Block Ptr
Declare Function CallFunctionWithStringParam ( ByVal As String, ByVal As String, ByVal As TABELLE ) As SCRIPT_VARIANT
Declare Function CallFunction ( ByVal As String, ByVal As SCRIPT_VARIANT Ptr ) As SCRIPT_VARIANT
Declare Function FirstName ( ByVal As String ) As String
Declare Function Calc ( ByVal As String, ByVal As TABELLE ) As SCRIPT_VARIANT
Declare Sub RunBlock ( byval as TABELLE ptr, byval As Sctipt_Block Ptr )
Declare Function RunScript ( ByVal As String, ByVal As SCRIPT_VARIANT Ptr ) As SCRIPT_VARIANT
Declare Sub Delete_Function ( ByVal As Sctipt_Block Ptr )
Declare Sub Error ( ByVal As String )
__script_defines__ As TABELLE
Er As ZString Ptr
End Type
Dim Shared LIfFailed As Integer
Function Script_If ( ByVal In As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Select Case In.WitchType
Case 0
If In Then
LIfFailed = 0
Return -1
Else
LIfFailed = -1
Return 0
EndIf
Case Else
If In = "" Then
LIfFailed = -1
Return 0
Else
LIfFailed = 0
Return -1
EndIf
End Select
End Function
Function Script_Else () As SCRIPT_VARIANT
If LIfFailed Then
LIfFailed = 0
Return -1
Else
LIfFailed = 0
Return 0
EndIf
End Function
Function Script_ElseIf ( ByVal In As SCRIPT_VARIANT ) As SCRIPT_VARIANT
If LIfFailed Then
Select Case In.WitchType
Case 0
If In Then
LIfFailed = 0
Return -1
Else
LIfFailed = -1
Return 0
EndIf
Case Else
If In = "" Then
LIfFailed = -1
Return 0
Else
LIfFailed = 0
Return -1
EndIf
End Select
Else
LIfFailed = 0
Return 0
EndIf
End Function
Function Script_Do ( ByVal In As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Select Case In.WitchType
Case 0
If In Then
Return 0
Else
Return -1
EndIf
Case Else
If In = "" Then
Return -1
Else
Return 0
EndIf
End Select
End Function
Function Script_While ( ByVal In As SCRIPT_VARIANT ) As SCRIPT_VARIANT
Select Case In.WitchType
Case 0
If In Then
Return -1
Else
Return 0
EndIf
Case Else
If In = "" Then
Return 0
Else
Return -1
EndIf
End Select
End Function
Function SCRIPT.Create () As Integer
__script_defines__ = TABELLE()
This.Er = Allocate(Len("Script Errors:")+1)
*This.Er = "Script Errors:"
Register ( "if" , 1 , 1 , @Script_If )
Register ( "else" , 0 , 1 , @Script_Else )
Register ( "elseif" , 1 , 1 , @Script_ElseIf )
Register ( "do" , 1 , 1 , @Script_Do )
Register ( "while" , 1 , 1 , @Script_While )
Return -1
End Function
Function SCRIPT.Register ( ByVal N As String, ByVal P As Integer, ByVal R As Integer, ByVal Z As Any Ptr ) As Integer
If __script_defines__.ExistItem(N) Then
This.Error("Duplicated definition of "+Chr(34)+N+Chr(34))
Return 0
EndIf
__script_defines__.ItemS(N+".type") = "out_function"
__script_defines__.ItemI(N+".Param") = P
__script_defines__.ItemI(N+".Ret") = R
__script_defines__.ItemP(N+".func") = Z
End Function
Property SCRIPT.GlobalVar ( ByVal N As String, ByVal A As SCRIPT_VARIANT )
If __script_defines__.ExistItem(N) Then
If __script_defines__.ItemS(N+".type") <> "var" Then
This.Error("Duplicated definition of "+Chr(34)+N+Chr(34))
Exit Property
EndIf
EndIf
__script_defines__.ItemS(N+".type") = "var"
Select Case A.WitchType
Case 0
__script_defines__.ItemD(N+".val") = A
Case 1
__script_defines__.ItemS(N+".val") = A
End Select
End Property
Property SCRIPT.GlobalVar ( ByVal N As String ) As SCRIPT_VARIANT
If __script_defines__.ExistItem(N) Then
If __script_defines__.ItemS(N+".type") = "var" Then
Select Case __script_defines__.ItemType(N+".val")
Case ITEM_STRING
Return __script_defines__.ItemS(N+".val")
Case Else
Return __script_defines__.ItemD(N+".val")
End Select
EndIf
EndIf
This.Error(Chr(34)+N+Chr(34)+" ist'n a global variable")
Return ""
End Property
Function SCRIPT.CompileFromString ( ByVal S As String ) As Integer
Dim Posi As Integer
Dim H As Integer
Dim Block As String
Dim B As String
Dim BB As String
Dim P As Integer
Do
B = GetNextBlock ( S , @Posi )
If Posi = 0 Then Exit Do
P = InStr(B,"=")
If P = 0 Then
P = Posi
BB = GetNextBlock ( S , @Posi )
If BB = "{" Then
P = InStr(B,"(")
If P = 0 Then
RegisterStringFunction ( B,"",Compile_Block ( S, @Posi ))
Else
RegisterStringFunction ( Mid(B,1,P-1),Mid(B,P+1,InStr(B,")")-P-1),Compile_Block ( S, @Posi ))
EndIf
Else
P = InStr(B,"(")
If P = 0 Then
RegisterStringFunction ( B,"",Compile_Block ( BB+";}", @Posi ))
Else
RegisterStringFunction ( Mid(B,1,P-1),Mid(B,P+1,InStr(B,")")-P-1),Compile_Block ( BB+";}", @Posi ))
EndIf
EndIf
Else
Dim V As SCRIPT_VARIANT
V = Calc(Mid(B,P+1),TABELLE)
GlobalVar(Mid(B,1,P-1))=V
EndIf
Loop
Return -1
End Function
Function SCRIPT.CompileFromFile ( ByVal S As String ) As Integer
Dim FF As Integer
Dim As String D,L
FF = FreeFile
If Open (S For Input As #FF) <> 0 Then
This.Error("File "+Chr(34)+S+Chr(34)+" not found")
Return 0
EndIf
Do
Line Input #FF,L
D += L
Loop Until Eof(FF)
Close(FF)
Return CompileFromString ( D )
End Function
Function SCRIPT.CallFunc Cdecl ( ByVal N As String, ByVal I As String , ... ) As SCRIPT_VARIANT
If __script_defines__.ItemS(N+".type") <> "in_function" and __script_defines__.ItemS(N+".type") <> "out_function" Then
This.Error(Chr(34)+N+Chr(34)+" isn't a function")
Return 0
EndIf
Dim P As String
Dim Posi As Integer
Dim num As Integer
Dim ANum As Integer
Dim arg As Any Ptr = va_first
Num = __script_defines__.ItemI(N+".Param")
Dim V As SCRIPT_VARIANT Ptr
If Num = 0 Then
Return CallFunction ( N , 0 )
EndIf
V = Allocate(SizeOf(SCRIPT_VARIANT)*Num)
For i As Integer = 0 To SizeOf(SCRIPT_VARIANT)*Num-1
Cast(UByte Ptr,V)[i] = 0
Next
Do
Posi = InStr(I,"%")
If Posi = 0 Then Exit Do
If ANum = num Then Exit Do
P = Mid(I,Posi+1,1)
Select Case LCase(P)
Case "i"
V[ANum] = va_arg(arg,Integer)
arg = va_next(arg,Integer)
Case "d"
V[ANum] = va_arg(arg,Double)
arg = va_next(arg,Double)
Case "s"
V[ANum] = *Cast(ZString Ptr,va_arg(arg,ZString Ptr))
arg = va_next(arg,ZString Ptr)
End Select
ANum += 1
Loop
Function = CallFunction ( N , V )
For i As Integer = 0 To Num-1
V[i].Destructor()
Next
DeAllocate(V)
End Function
Sub SCRIPT.CallSub Cdecl ( ByVal N As String, ByVal I As String, ... )
If __script_defines__.ItemS(N+".type") <> "in_function" and __script_defines__.ItemS(N+".type") <> "out_function" Then
This.Error(Chr(34)+N+Chr(34)+" isn't a function")
Exit Sub
EndIf
Dim T As SCRIPT_VARIANT
Dim P As String
Dim Posi As Integer
Dim num As Integer
Dim ANum As Integer
Dim arg As Any Ptr = va_first
Num = __script_defines__.ItemI(N+".Param")
Dim V As SCRIPT_VARIANT Ptr
If Num = 0 Then
T = CallFunction ( N , V )
Exit Sub
EndIf
V = Allocate(SizeOf(SCRIPT_VARIANT)*Num)
For i As Integer = 0 To SizeOf(SCRIPT_VARIANT)*Num-1
Cast(UByte Ptr,V)[i] = 0
Next
Do
Posi = InStr(I,"%")
If Posi = 0 Then Exit Do
If ANum = num Then Exit Do
P = Mid(I,Posi+1,1)
Select Case LCase(P)
Case "i"
V[ANum] = va_arg(arg,Integer)
arg = va_next(arg,Integer)
Case "d"
V[ANum] = va_arg(arg,Double)
arg = va_next(arg,Double)
Case "s"
V[ANum] = *Cast(ZString Ptr,va_arg(arg,ZString Ptr))
arg = va_next(arg,ZString Ptr)
End Select
ANum += 1
Loop
T = CallFunction ( N , V )
For i As Integer = 0 To Num-1
V[i].Destructor()
Next
DeAllocate(V)
End Sub
Sub SCRIPT.Destroy ()
Dim i As Integer
Do
i += 1
Dim Item As _TABELLENITEM Ptr
Item = __script_defines__.GetItem(i)
If Item = 0 Then Exit Do
Select Case Item->GetValTP->ItemS("type")
Case "in_function"
Delete_Function ( Item->GetValTP->ItemP("func"))
End Select
Loop
__script_defines__.Destroy()
End Sub
Sub SCRIPT.Undef ( ByVal N As String )
If __script_defines__.ItemS(N+".type") = "in_function" Then
Delete_Function ( __script_defines__.ItemP(N+".func") )
EndIf
__script_defines__.DestroyItem(N)
End Sub
Function SCRIPT.GetErrors () As String
Return *This.Er
If This.Er Then DeAllocate(This.Er)
This.Er = Allocate(Len("Script Errors:")+1)
*This.Er = "Script Errors:"
End Function
Function SCRIPT.GetNextBlock ( ByVal S As String, ByVal P As Integer Ptr ) As String
Dim R As String
Dim L As Integer
Dim InS As Integer
Dim H As Integer
For i As Integer = *P+1 To Len(S)
Select Case S[i-1]
Case Asc("A") To Asc("Z"),Asc("a") To Asc("z"),Asc("0") To Asc("9"),Asc("_")
R += Chr(S[i-1])
L = 1
Case Asc(" "),Asc(" ")
If InS Then
R += Chr(S[i-1])
Else
Select Case Mid(S,i+1,1)
Case "A" To "Z","a" To "z","0" To "9","_"
If L = 1 Then
R += " "
EndIf
End Select
EndIf
Case Asc(";")
If InS Then
R += Chr(S[i-1])
Else
*P = i
Return R
EndIf
L = 2
Case Asc("{")
H += 1
If L = 0 Then
*P = i
Return "{"
EndIf
If InS Then
R += Chr(S[i-1])
Else
*P = i-1
Return R
EndIf
L = 2
Case Asc("}")
If L = 0 Then
*P = i
Return "}"
EndIf
If InS Then
R += Chr(S[i-1])
Else
*P = i-1
Return R
EndIf
L = 2
Case 34
R += Chr(S[i-1])
InS Xor= -1
Case Else
R += Chr(S[i-1])
L = 2
End Select
Next
*P = 0
Return ""
End Function
Function SCRIPT.RegisterStringFunction ( ByVal N As String, ByVal P As String, ByVal T As Sctipt_Block Ptr ) As Integer
If __script_defines__.ExistItem(N) Then
This.Error("Duplicated definition of "+Chr(34)+N+Chr(34))
Return 0
EndIf
__script_defines__.ItemS(N+".type") = "in_function"
Dim num As Integer
If P = "" Then
num = 0
Else
Dim Posi As Integer
Do
Posi = InStr(Posi+1,P,",")
If Posi = 0 Then Exit Do
num += 1
Loop
num += 1
EndIf
__script_defines__.ItemI(N+".Param") = num
__script_defines__.ItemS(N+".ParamName") = P
__script_defines__.ItemP(N+".func") = T
End Function
Function SCRIPT.Compile_Block ( ByVal S As String, ByVal P As Integer Ptr ) As Sctipt_Block Ptr
Dim B As String
Dim H As Integer
Dim C As Sctipt_Block Ptr
Dim L As Sctipt_Block Ptr
C = Allocate(SizeOf(Sctipt_Block))
Function = C
Do
B = GetNextBlock ( S, P )
Select Case B
Case "{"
C->Oder = Compile_Block ( S, P )
Case "}"
L->Next = 0
DeAllocate(C)
Exit Function
Case Else
C->Text = Allocate(Len(B)+1)
*C->Text = B
End Select
C->Next = Allocate(SizeOf(Sctipt_Block))
L = C
C = C->Next
C->Next = 0
C->Oder = 0
C->Text = 0
Loop
End Function
Function SCRIPT.CallFunctionWithStringParam ( ByVal N As String, ByVal P As String, ByVal T As TABELLE ) As SCRIPT_VARIANT
Dim As Integer H,Num,Nu,InS,Posi
Dim As SCRIPT_VARIANT Ptr V
If __script_defines__.ItemS(N+".type") <> "in_function" and __script_defines__.ItemS(N+".type") <> "out_function" Then
Return 0
EndIf
Num = __script_defines__.ItemI(N+".Param")
If Num = 0 Then
Return CallFunction ( N , 0 )
EndIf
V = Allocate(SizeOf(SCRIPT_VARIANT)*Num)
For i As Integer = 0 To SizeOf(SCRIPT_VARIANT)*Num-1
Cast(UByte Ptr,V)[i] = 0
Next
Nu = 0
For i As Integer = 1 To Len(P)
Select Case P[i-1]
Case Asc(",")
If InS = 0 And H = 0 Then
V[nu] = Calc(Mid(P,Posi+1,i-Posi-1),T)
Posi = i
Nu += 1
If Nu = Num Then
Exit For
EndIf
EndIf
Case Asc("(")
If InS = 0 Then H += 1
If i = 1 Then
H = 0
Posi = 1
EndIf
Case Asc(")")
If InS = 0 Then H -= 1
If H <= 0 Then
V[nu] = Calc(Mid(P,Posi+1,i-Posi-1),T)
Exit For
EndIf
Case 34
InS Xor = -1
End Select
If i = Len(P) Then
V[nu] = Calc(Mid(P,Posi+1),T)
EndIf
Next
Function = CallFunction ( N , V )
For i As Integer = 0 To Num-1
V[i].Destructor()
Next
DeAllocate(V)
End Function
Function SCRIPT.CallFunction ( ByVal N As String, ByVal P As SCRIPT_VARIANT Ptr ) As SCRIPT_VARIANT
Dim num As Integer
Dim i As Integer
Dim Inte As Integer
Num = __script_defines__.ItemI(N+".Param")
Select Case __script_defines__.ItemS(N+".type")
Case "in_function"
Return RunScript ( N , P )
Case "out_function"
Dim F As Any Ptr
Dim R As SCRIPT_VARIANT
Dim RP As SCRIPT_VARIANT Ptr
F = __script_defines__.ItemP(N+".Func")
For i = Num-1 To 0 Step -1
RP = @P[i]
Asm
push [RP]
End Asm
Next
RP = @R
If __script_defines__.ItemI(N+".Ret") Then
Asm
push [RP]
End Asm
EndIf
Asm
Call [F]
End Asm
Return R
End Select
Return ""
End Function
Function SCRIPT.FirstName ( ByVal S As String ) As String
Dim Ret As String
For i As Integer = 1 To Len(S)
Select Case S[i-1]
Case Asc("A") To Asc("Z"),Asc("a") To Asc("z"),Asc("0") To Asc("9"),Asc("_")
Ret += Chr(S[i-1])
Case Else
Return Ret
End Select
Next
Return Ret
End Function
Function SCRIPT.Calc ( ByVal Si As String, ByVal T As TABELLE ) As SCRIPT_VARIANT
Dim S As String
Dim H As Integer
Dim InS As Integer
S = Si
For i As Integer = 1 To Len(S)
Select Case S[i-1]
Case Asc("0") To Asc("9"),Asc(".")
Case Else
Exit For
End Select
If i = Len(S) Then
Return Val(S)
EndIf
Next
If S[0] = 34 Then
For i As Integer = 2 To Len(S)
Select Case S[i-1]
Case 34
If i = Len(S) Then
Return Mid(S,2,Len(S)-2)
Else
Exit For
EndIf
End Select
If i = Len(S) Then
Return Mid(S,2)
EndIf
Next
EndIf
H = 0
InS = 0
If S[0] = Asc("(") Then
For i As Integer = 1 To Len(S)
Select Case S[i-1]
Case 34
InS Xor = -1
Case Asc("(")
If Ins = 0 Then H += 1
Case Asc(")")
If Ins = 0 Then H -= 1
If H = 0 Then
If i = Len(S) Then
Return Calc ( Mid(S,2,Len(S)-2),T)
EndIf
EndIf
End Select
If H > 0 And i = Len(S) Then
Return Calc ( Mid(S,2),T)
EndIf
Next
EndIf
H = 0
InS = 0
For i As Integer = Len(S) To 1 Step -1
Select Case S[i-1]
Case 34
InS Xor = -1
Case Asc("(")
If Ins = 0 Then H += 1
Case Asc(")")
If Ins = 0 Then H -= 1
Case Asc(">")
If H = 0 And Ins = 0 Then
If Mid(S,i-1,1) = ">" Then
Dim As Long T1,T2
T1 = Calc (Mid(S,1,i-2),T)
T2 = Calc (Mid(S,i+1),T)
Return T1 Shr T2
EndIf
EndIf
Case Asc("<")
If H = 0 And Ins = 0 Then
If Mid(S,i-1,1) = "<" Then
Dim As Long T1,T2
T1 = Calc (Mid(S,1,i-2),T)
T2 = Calc (Mid(S,i+1),T)
Return T1 Shl T2
EndIf
EndIf
Case Asc("&")
If H = 0 And Ins = 0 Then
If Mid(S,i-1,1) = "&" Then
Dim As Long T1,T2
T1 = Calc (Mid(S,1,i-2),T)
T2 = Calc (Mid(S,i+1),T)
Return T1 AndAlso T2
EndIf
Return Calc (Mid(S,1,i-1),T) And Calc (Mid(S,i+1),T)
EndIf
Case Asc("|")
If H = 0 And Ins = 0 Then
If Mid(S,i-1,1) = "|" Then
Dim As Long T1,T2
T1 = Calc (Mid(S,1,i-2),T)
T2 = Calc (Mid(S,i+1),T)
Return T1 OrElse T2
EndIf
Return Calc (Mid(S,1,i-1),T) Or Calc (Mid(S,i+1),T)
EndIf
End Select
Next
H = 0
InS = 0
For i As Integer = Len(S) To 1 Step -1
Select Case S[i-1]
Case 34
InS Xor = -1
Case Asc("(")
If Ins = 0 Then H += 1
Case Asc(")")
If Ins = 0 Then H -= 1
Case Asc("=")
If H = 0 And Ins = 0 Then
Select Case Mid(S,i-1,1)
Case "<"
Return Calc (Mid(S,1,i-2),T)<=Calc (Mid(S,i+1),T)
Case ">"
Return Calc (Mid(S,1,i-2),T)>=Calc (Mid(S,i+1),T)
Case "!"
Return Calc (Mid(S,1,i-2),T)<>Calc (Mid(S,i+1),T)
Case Else
Return Calc (Mid(S,1,i-1),T)=Calc (Mid(S,i+1),T)
End Select
EndIf
Case Asc("<")
If H = 0 And Ins = 0 Then
Return Calc (Mid(S,1,i-1),T)<Calc (Mid(S,i+1),T)
EndIf
Case Asc(">")
If H = 0 And Ins = 0 Then
Return Calc (Mid(S,1,i-1),T)>Calc (Mid(S,i+1),T)
EndIf
End Select
Next
H = 0
InS = 0
For i As Integer = Len(S) To 1 Step -1
Select Case S[i-1]
Case 34
InS Xor = -1
Case Asc("(")
If Ins = 0 Then H += 1
Case Asc(")")
If Ins = 0 Then H -= 1
Case Asc("+")
If H = 0 And Ins = 0 Then
Return Calc(Mid(S,1,i-1),T)+Calc(Mid(S,i+1),T)
EndIf
Case Asc("-")
If H = 0 And Ins = 0 Then
Select Case Mid(S,i-1,1)
Case "A" To "Z","a" To "z","0" To "9",".","_"
Return Calc (Mid(S,1,i-1),T)-Calc (Mid(S,i+1),T)
End Select
EndIf
End Select
Next
H = 0
InS = 0
For i As Integer = Len(S) To 1 Step -1
Select Case S[i-1]
Case 34
InS Xor = -1
Case Asc("(")
If Ins = 0 Then H += 1
Case Asc(")")
If Ins = 0 Then H -= 1
Case Asc("*")
If H = 0 And Ins = 0 Then
Return Calc (Mid(S,1,i-1),T)*Calc (Mid(S,i+1),T)
EndIf
Case Asc("/")
If H = 0 And Ins = 0 Then
Return Calc (Mid(S,1,i-1),T)/Calc (Mid(S,i+1),T)
EndIf
End Select
Next
H = 0
InS = 0
For i As Integer = Len(S) To 1 Step -1
Select Case S[i-1]
Case 34
InS Xor = -1
Case Asc("(")
If Ins = 0 Then H += 1
Case Asc(")")
If Ins = 0 Then H -= 1
Case Asc("^")
If H = 0 And Ins = 0 Then
Return Calc (Mid(S,1,i-1),T)^Calc (Mid(S,i+1),T)
EndIf
End Select
Next
If S[0] = Asc("-") Then
Return -Calc (Mid(S,2),T)
EndIf
If S[0] = Asc("!") Then
Return Not (Calc (Mid(S,2),T))
EndIf
Select Case __script_defines__.ItemS(FirstName(S)+".type")
Case "var"
Select Case __script_defines__.ItemType(FirstName(S)+".val")
Case ITEM_STRING
Return __script_defines__.ItemS(FirstName(S)+".val")
Case Else
Return __script_defines__.ItemD(FirstName(S)+".val")
End Select
Case "out_function","in_function"
Return CallFunctionWithStringParam ( FirstName(S) , Mid(S,Len(FirstName(S))+1), T)
Case Else
Select Case T.ItemType(FirstName(S))
Case ITEM_STRING
Return T.ItemS(FirstName(S))
Case Else
Return T.ItemD(FirstName(S))
End Select
End Select
End Function
Sub SCRIPT.RunBlock ( byval Vars as TABELLE ptr, byval S As Sctipt_Block Ptr )
Dim A As Sctipt_Block Ptr
Dim L As String
Dim V As SCRIPT_VARIANT
A = S
Do Until A = 0
If A->Text = 0 Then
If V <> 0 Then
Dim D As Sctipt_Block Ptr
D = A
RunBlock ( Vars, D->Oder )
EndIf
EndIf
V = 0
If A->Text <> 0 Then
L = *A->Text
Select Case LCase(FirstName (l))
Case "do"
Do
V = CallFunctionWithStringParam ( "do" , Mid(l,Len(FirstName (l))+1),*Vars)
If V Then
RunBlock ( Vars, A->Next->Oder )
Else
Exit Do
EndIf
Loop
V = 0
Case "while"
Do
V = CallFunctionWithStringParam ( "while" , Mid(l,Len(FirstName (l))+1),*Vars)
If V Then
RunBlock ( Vars, A->Next->Oder )
Else
Exit Do
EndIf
Loop
V = 0
Case "for"
Dim As String Param1,Param2,Param3
Dim As Integer Posi,H,S,N
For i As Integer = 1 To Len(L)
Select Case Mid(L,i,1)
Case "("
If S = 0 Then
H += 1
If H = 1 Then
Posi = i
EndIf
EndIf
Case ")"
If S = 0 Then
H -= 1
If H = 0 Then
If N = 2 Then
Param3 = Mid(L,Posi+1,i-Posi-1)
Exit For
EndIf
EndIf
EndIf
Case Chr(34)
S Xor = -1
Case ","
If S = 0 And H = 1 Then
If N = 1 Then
Param2 = Mid(L,Posi+1,i-Posi-1)
N = 2
EndIf
If N = 0 Then
Param1 = Mid(L,Posi+1,i-Posi-1)
N = 1
EndIf
Posi = i
EndIf
End Select
Next
V = Calc ( Mid(Param1,InStr(Param1,"=")+1),*Vars )
Select Case V.WitchType
Case 0
Vars->ItemD(FirstName(Param1)) = V
Case Else
Vars->ItemS(FirstName(Param1)) = V
End Select
Do
V = CallFunctionWithStringParam ( "do" , Param2,*Vars)
If V Then
RunBlock ( Vars, A->Next->Oder )
V = Calc ( Mid(Param3,InStr(Param3,"=")+1),*Vars )
Select Case V.WitchType
Case 0
Vars->ItemD(FirstName(Param3)) = V
Case Else
Vars->ItemS(FirstName(Param3)) = V
End Select
Else
Exit Do
EndIf
Loop
V = 0
Case Else
Select Case __script_defines__.ItemS(FirstName (l)+".type")
Case "var"
V = Calc ( Mid(l,InStr(l,"=")+1),*Vars )
Select Case V.WitchType
Case 0
GlobalVar(FirstName(l))=V
Case Else
GlobalVar(FirstName(l))=V
End Select
Case "out_function","in_function"
V = CallFunctionWithStringParam ( FirstName (l) , Mid(l,Len(FirstName (l))+1),*Vars)
Case Else
V = Calc ( Mid(l,InStr(l,"=")+1),*Vars )
Select Case V.WitchType
Case 0
Vars->ItemD(FirstName(l)) = V
Case Else
Vars->ItemS(FirstName(l)) = V
End Select
End Select
End Select
EndIf
A = A->Next
Loop
LIfFailed = 0
End Sub
Function SCRIPT.RunScript ( ByVal N As String, ByVal P As SCRIPT_VARIANT Ptr ) As SCRIPT_VARIANT
Dim Vars As TABELLE
Dim Na As String
Dim Posi As Integer
Dim Posialt As Integer
For i As Integer = 0 To __script_defines__.ItemI(N+".Param")-1
Posialt = Posi
Posi = InStr(Posi+1,__script_defines__.ItemS(N+".ParamName"),",")
Na = Mid(__script_defines__.ItemS(N+".ParamName"),Posialt+1,Posi-Posialt-1)
Select Case P[i].WitchType
Case 0
Vars.ItemD(Na) = P[i]
Case Else
Vars.ItemS(Na) = P[i]
End Select
Next
RunBlock ( @Vars, __script_defines__.ItemP(N+".Func"))
Select Case Vars.ItemType("return")
Case ITEM_STRING
Function = Vars.ItemS("return")
Case Else
Function = Vars.ItemD("return")
End Select
Vars.Destroy()
End Function
Sub SCRIPT.Delete_Function ( ByVal B As Sctipt_Block Ptr )
Dim As Sctipt_Block Ptr N,T
T = B
Do Until T = 0
N = T->Next
If T->Text Then DeAllocate(T->Text)
If T->Oder Then Delete_Function ( T->Oder )
DeAllocate(T)
T = N
Loop
End Sub
Sub SCRIPT.Error ( ByVal E As String )
Dim T As String
If This.Er Then
T = *This.Er
DeAllocate(This.Er)
EndIf
T += BR+E
This.Er = Allocate(Len(T)+1)
*This.Er = T
End Sub