Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Script.bi
| Uploader: |  XOR |
| Datum/Zeit: | 16.05.2011 23:47:35 |
#Include "Tabelle.bi"
Type SIVariant
Declare Destructor ()
Declare Operator Let ( ByRef As SIVariant )
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 SIVariant ()
If This.PAny Then DeAllocate( This.PAny )
End Destructor
Operator SIVariant.Let ( ByRef In As SIVariant )
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 SIVariant.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 SIVariant.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 SIVariant.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 SIVariant.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 SIVariant.WitchType () As Integer
Return This.PType
End Function
Function SIVariant.GetPtr () As Any Ptr
Return This.PAny
End Function
Operator + ( ByVal V1 As SIVariant, ByVal V2 As SIVariant ) As SIVariant
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 SIVariant, ByVal V2 As SIVariant ) As SIVariant
Dim I As Double
I = V1
Return I - V2
End Operator
Operator - ( ByVal V1 As SIVariant ) As SIVariant
Dim I As Double
I = V1
Return -I
End Operator
Operator * ( ByVal V1 As SIVariant, ByVal V2 As SIVariant ) As SIVariant
Dim I As Double
I = V1
Return I * V2
End Operator
Operator / ( ByVal V1 As SIVariant, ByVal V2 As SIVariant ) As SIVariant
Dim I As Double
I = V1
Return I / V2
End Operator
Type Sctipt_Block
Text As ZString Ptr
Next As Sctipt_Block Ptr
Oder As Sctipt_Block Ptr
End Type
Dim Shared __script_defines__ As TABELLE
Declare Function Register ( ByVal As String, ByVal As Integer, ByVal As Integer, ByVal As Any Ptr ) As Integer
Declare Sub SetVar ( ByVal As String, ByVal As SIVariant )
Declare Function GetVar ( ByVal As String ) As SIVariant
Declare Function GetNextBlock ( ByVal As String, ByVal As Integer Ptr ) As String
Declare Function Compile ( ByVal As String ) As Integer
Declare Function CallFunc Cdecl ( ByVal As String, ByVal As String, ... ) As SIVariant
Declare Function CallFunction ( ByVal As String, ByVal As SIVariant Ptr ) As SIVariant
Declare Function RunScript ( ByVal As String, ByVal As SIVariant Ptr ) As SIVariant
Declare Function Calc ( ByVal S As String, ByVal T As TABELLE ) As SIVariant
Function 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 Return 0
__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
Sub SetVar ( ByVal N As String, ByVal A As SIVariant )
If __script_defines__.ExistItem(N) Then
If __script_defines__.ItemS(N+".type") <> "var" Then Exit Sub
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 Sub
Function GetVar ( ByVal N As String ) As SIVariant
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
Return ""
End Function
Function 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 Mid(S,i,1)
Case "A" To "Z","a" To "z","0" To "9","_"
R += Mid(S,i,1)
L = 1
Case " "," "
If InS Then
R += Mid(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 ";"
If InS Then
R += Mid(S,i,1)
Else
*P = i
Return R
EndIf
L = 2
Case "{"
H += 1
If L = 0 Then
*P = i
Return "{"
EndIf
If InS Then
R += Mid(S,i,1)
Else
*P = i-1
Return R
EndIf
L = 2
Case "}"
If L = 0 Then
*P = i
Return "}"
EndIf
If InS Then
R += Mid(S,i,1)
Else
*P = i-1
Return R
EndIf
L = 2
Case Chr(34)
R += Mid(S,i,1)
InS Xor= -1
Case Else
R += Mid(S,i,1)
L = 2
End Select
Next
*P = 0
Return ""
End Function
Function RegisterStringFunction ( ByVal N As String, ByVal P As String, ByVal T As Sctipt_Block Ptr ) As Integer
If __script_defines__.ExistItem(N) Then Return 0
__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 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 Compile ( 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 SIVariant
V = Calc(Mid(B,P+1),TABELLE)
SetVar(Mid(B,1,P-1),V)
EndIf
Loop
Return -1
End Function
Function CallFunc Cdecl ( ByVal N As String, ByVal I As String , ... ) As SIVariant
If __script_defines__.ItemS(N+".type") <> "in_function" and __script_defines__.ItemS(N+".type") <> "out_function" Then
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 SIVariant Ptr
If Num = 0 Then
Return CallFunction ( N , 0 )
EndIf
V = Allocate(SizeOf(SIVariant)*Num)
For i As Integer = 0 To SizeOf(SIVariant)*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
Function CallFunctionWithStringParam ( ByVal N As String, ByVal P As String, ByVal T As TABELLE ) As SIVariant
Dim As Integer H,Num,Nu,InS,Posi
Dim As SIVariant 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(SIVariant)*Num)
For i As Integer = 0 To SizeOf(SIVariant)*Num-1
Cast(UByte Ptr,V)[i] = 0
Next
Nu = 0
For i As Integer = 1 To Len(P)
Select Case Mid(P,i,1)
Case ","
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 "("
If InS = 0 Then H += 1
If i = 1 Then
H = 0
Posi = 1
EndIf
Case ")"
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 Chr(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 CallFunction ( ByVal N As String, ByVal P As SIVariant Ptr ) As SIVariant
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 SIVariant
Dim RP As SIVariant 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 FirstName ( ByVal S As String ) As String
Dim Ret As String
For i As Integer = 1 To Len(S)
Select Case Mid(S,i,1)
Case "A" To "Z","a" To "z","0" To "9","_"
Ret += Mid(S,i,1)
Case Else
Return Ret
End Select
Next
Return Ret
End Function
Function Calc ( ByVal S As String, ByVal T As TABELLE ) As SIVariant
Dim H As Integer
Dim InS As Integer
For i As Integer = 1 To Len(S)
Select Case Mid(S,i,1)
Case "0" To "9","."
Case "-"
If i <> 1 Then Exit For
Case Else
Exit For
End Select
If i = Len(S) Then
Return Val(S)
EndIf
Next
If Mid(S,1,1) = Chr(34) Then
For i As Integer = 2 To Len(S)
Select Case Mid(S,i,1)
Case Chr(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 Mid(S,1,1) = "(" Then
For i As Integer = 1 To Len(S)
Select Case Mid(S,i,1)
Case Chr(34)
InS Xor = -1
Case "("
If Ins = 0 Then H += 1
Case ")"
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 Mid(S,i,1)
Case Chr(34)
InS Xor = -1
Case "("
If Ins = 0 Then H += 1
Case ")"
If Ins = 0 Then H -= 1
Case "="
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 "<"
If H = 0 And Ins = 0 Then
Return Calc (Mid(S,1,i-1),T)<Calc (Mid(S,i+1),T)
EndIf
Case ">"
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 Mid(S,i,1)
Case Chr(34)
InS Xor = -1
Case "("
If Ins = 0 Then H += 1
Case ")"
If Ins = 0 Then H -= 1
Case "+"
If H = 0 And Ins = 0 Then
Return Calc (Mid(S,1,i-1),T)+Calc (Mid(S,i+1),T)
EndIf
Case "-"
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 Mid(S,i,1)
Case Chr(34)
InS Xor = -1
Case "("
If Ins = 0 Then H += 1
Case ")"
If Ins = 0 Then H -= 1
Case "*"
If H = 0 And Ins = 0 Then
Return Calc (Mid(S,1,i-1),T)*Calc (Mid(S,i+1),T)
EndIf
Case "/"
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 Mid(S,i,1)
Case Chr(34)
InS Xor = -1
Case "("
If Ins = 0 Then H += 1
Case ")"
If Ins = 0 Then H -= 1
Case "^"
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
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 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 SIVariant
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"
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
SetVar(FirstName(l),V)
Case Else
SetVar(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
End Sub
Function RunScript ( ByVal N As String, ByVal P As SIVariant Ptr ) As SIVariant
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 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 Close_Script ()
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
Dim Shared LIfFailed As Integer
Function Script_If ( ByVal In As SIVariant ) As SIVariant
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 SIVariant
If LIfFailed Then
LIfFailed = 0
Return -1
Else
LIfFailed = 0
Return 0
EndIf
End Function
Function Script_ElseIf ( ByVal In As SIVariant ) As SIVariant
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 SIVariant ) As SIVariant
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
Register ( "if" , 1 , 1 , @Script_If )
Register ( "else" , 0 , 1 , @Script_Else )
Register ( "elseif" , 1 , 1 , @Script_ElseIf )
Register ( "do" , 1 , 1 , @Script_Do )