免费提供一段实现脚本语言源码

it_seeker 2001-08-16 12:48:41

最近准备跳槽，所以将一年前的代码翻了出来，与大家一起分享。

Option Explicit

'提供数据类型 number , string, boolen
Const MAXNUMBER = 500

Public Type ProgrameTabel
FunName As String
Total As Integer
ProSen() As String
End Type
'变量存储数据结构
Public Type VarKeep
name As String '变量名
Varlay As Integer '变量所在函数名
DataKind As String '变量数据类型
value As Variant '变量值
End Type

'函数存储数据结构
Public Type FunKeep
name As String '函数名
FuncLay As Integer '函数所在范围
DataKind As String '函数数据类型
value As String '函数值
End Type
'系统函数堆栈结构
Public Type FunStutes
TopFiger As Integer
Fun(50) As VarKeep
End Type

'系统数据堆栈结构保存变量值
Public Type DataStutes
TopFiger As Integer '栈顶指针
Varites(500) As VarKeep '栈内
End Type

Public Type sc
king As String
value As Variant
End Type
'当前函数的实参堆栈定义
Public Type csStrck
TopFiger As Integer
csvalue(10) As sc
End Type
Dim tems As VarKeep
Dim datadz As DataStutes
Dim marks As DataStutes
Dim scKeeper As csStrck '供传递给函数参数的实参堆栈，第一个是函数返回值
Dim SysGData As DataStutes '系统全局变量堆栈
Dim sysLdata As DataStutes '系统局部变量堆栈
Public NowingFun As FunKeep '当前函数信息
Public FunReTurn As VarKeep
Public SysProgrameTable As ProgrameTabel
Dim SysFunStutues As FunStutes

'出栈
Private Function PoPData(popstutes As DataStutes) As Variant
If popstutes.TopFiger > 0 Then
PoPData = popstutes.Varites(popstutes.TopFiger).value
popstutes.TopFiger = popstutes.TopFiger - 1
Else
PoPData = ""
End If
End Function
Private Function GetPoP(popstutes As DataStutes) As Variant
If popstutes.TopFiger > 0 Then
GetPoP = popstutes.Varites(popstutes.TopFiger).value
Else
GetPoP = ""
End If
End Function

'入栈
Private Function PushData(popstutes As DataStutes, values As Variant) As Boolean
Dim x As Integer
If popstutes.TopFiger < MAXNUMBER Then
popstutes.TopFiger = popstutes.TopFiger + 1
x = popstutes.TopFiger
popstutes.Varites(x).value = values
PushData = True
Else
PushData = False
End If
End Function

'表达式基本计算
Private Function Operate(a As Variant, theta As String, b As Variant) As Variant 'a,b可为值或者变量
Dim a1 As Variant
Dim b1 As Variant
On Error GoTo errs
If Right(a, 1) = Chr(34) And Left(a, 1) = Chr(34) Then '判断是否为“
a1 = Mid(a, 2, Len(a) - 2)
Else
If checkVar(a, NowingFun.FuncLay).name <> "" Then
a1 = checkVar(a, NowingFun.FuncLay).value
Select Case checkVar(a, NowingFun.FuncLay).DataKind
Case "number":
If a1 <> "" Then a1 = CDbl(a1) Else a1 = 0
Case "boolen":
If a1 <> "" Then a1 = CBool(a1) Else a1 = False
Case Else
If a1 <> "" Then a1 = CStr(a1)
End Select
Else:
If a = "funreturn" Then
a1 = FunReTurn.value
Select Case FunReTurn.DataKind
Case "number":
If a1 <> "" Then a1 = CDbl(a1)
Case "boolen":
If a1 <> "" Then a1 = CBool(a1)
Case "string":
If a1 <> "" Then a1 = CStr(a1)
Case Else:
a1 = "0"
End Select
Else:
a1 = a
End If
End If
End If
If Right(b, 1) = Chr(34) And Left(b, 1) = Chr(34) Then '判断是否为“
b1 = Mid(b, 2, Len(b) - 2)
Else
If checkVar(b, NowingFun.FuncLay).name <> "" Then
b1 = checkVar(b, NowingFun.FuncLay).value
Select Case checkVar(b, NowingFun.FuncLay).DataKind
Case "number":
If b1 <> "" Then b1 = CDbl(b1) Else b1 = 0
Case "boolen":
If b1 <> "" Then b1 = CBool(b1) Else b1 = False
Case Else
If b1 <> "" Then b1 = CStr(b1)
End Select
Else:
If b = "funreturn" Then
b1 = FunReTurn.value
Select Case FunReTurn.DataKind
Case "number":
If b1 <> "" Then b1 = CDbl(b1)
Case "boolen":
If b1 <> "" Then b1 = CBool(b1)
Case "string":
If b1 <> "" Then b1 = CStr(b1)
End Select
Else:
Dim numberflags As Boolean
Dim x As Integer
numberflags = True
x = 1
Do While x <= Len(b) And numberflags = True
If Mid(b, x, 1) < "0" Or Mid(b, x, 1) > "9" Then numberflags = False
x = x + 1
Loop
If numberflags = True Then
b1 = CLng(b)
Else
Select Case b
Case "true":
b1 = True
Case "false":
b1 = False
Case Else:
b1 = b
End Select
End If
End If
End If
End If
Select Case theta
Case "&":
Operate = a1 & b1
Case "=":
a1 = b1
If checkVar(a, NowingFun.FuncLay).name <> "" Then EditVar a, a1, NowingFun.FuncLay
Operate = a1
Case "+":
If a1 = "" Then a1 = "0"
If b1 = "" Then b1 = "0"
Operate = CLng(a1) + CLng(b1)
Case "-":
Operate = a1 - b1
Case "*":
Operate = a1 * b1
Case "/":
If b1 <> 0 Then
Operate = a1 / b1
Else
Operate = 0
End If
Case "<>":
If a1 = b1 Then
Operate = False
Else
Operate = True
End If
Case ">=":
If a1 >= b1 Then
Operate = True
Else
Operate = False
End If
Case "<=":
If a1 > b1 Then
Operate = False
Else
Operate = True
End If
Case "==":
If a1 <> b1 Then
Operate = False
Else
Operate = True
End If
Case "and":
If a1 = True And b1 = True Then
Operate = True
Else
Operate = False
End If
Case "or":
If a1 = True Or b1 = True Then
Operate = True
Else
Operate = False
End If
Case ">":
If a1 > b1 Then
Operate = True
Else
Operate = False
End If
Case "<":
If a1 < b1 Then
Operate = True
Else
Operate = False
End If
End Select
GoTo goon:
errs:
MsgBox "表达式 " & a & " " & theta & " " & b & "执行错误,将跳过该表达式。"
goon:
End Function

'计算优先级
Private Function Precede(a As String, b As String) As String
Dim x As Integer
Dim tem As String
Dim flaga As Integer
Dim flagb As Integer
Dim flag As Integer
For x = 1 To 2
If x = 1 Then tem = a Else tem = b
Select Case tem
Case "#":
flag = 20
Case "<", ">", "<=", ">=":
flag = 7
Case "==", "!=":
flag = 8
Case "=":
flag = 15
Case "+":
flag = 5
Case "-":
flag = 5
Case "*":
flag = 4
Case "/":
flag = 4
Case "%":
flag = 4
Case "and":
flag = 12
Case "or":
flag = 13
Case "(":
flag = 1
Case ")":
flag = 15
End Select
If x = 1 Then flaga = flag Else flagb = flag
Next x
If flaga = flagb Then Precede = "="
If flaga > flagb Then Precede = "<"
If flaga < flagb Then Precede = ">"
End Function

'判断是否是运算符
Private Function CheckMarks(str As String) As Boolean
Dim flag As Boolean
flag = False
Select Case str
Case "#", "+", "-", "*", "/", "%", "<", ">", "=", "==", "!=", "<=", ">=", "and", "(", ")", "or":
flag = True
End Select
CheckMarks = flag
End Function

'表达式的计算
Public Function Compute(bds As String) As Variant
Dim tem As String
Dim x As Integer
Dim a As Variant
Dim b As Variant
Dim thetas As String
Dim exitflag As Boolean
bds = bds & " #"
x = 1
PushData marks, "#"
tem = readstr(bds, x)
Do While exitflag = False
If CheckMarks(tem) = False Then
PushData datadz, tem
x = x + 1
tem = readstr(bds, x)
Else
Select Case Precede(GetPoP(marks), tem)
Case ">":
If tem = ")" And GetPoP(marks) = "(" Then
PoPData marks
x = x + 1
tem = readstr(bds, x)
Else
If tem <> ")" And GetPoP(marks) = "(" Then
PushData marks, tem
x = x + 1
tem = readstr(bds, x)

Else
a = PoPData(datadz)
b = PoPData(datadz)
thetas = PoPData(marks)
PushData datadz, Operate(b, thetas, a)
End If
End If
Case "=":
If tem = ")" And GetPoP(marks) = "(" Then
PoPData marks
x = x + 1
tem = readstr(bds, x)
Else
If tem = "#" Then
exitflag = True
Else
a = PoPData(datadz)
b = PoPData(datadz)
thetas = PoPData(marks)
PushData datadz, Operate(a, thetas, b)
End If
End If
Case "<":
PushData marks, tem
x = x + 1
tem = readstr(bds, x)
End Select
End If
Loop
Compute = GetPoP(datadz)
End Function

Public Function checkVar(names As Variant, lays As Integer) As VarKeep '检查变量是否存在并返回值
Dim x As Integer '如无返回name=""
Dim Vartem As VarKeep
Dim flags As Boolean
If sysLdata.TopFiger > 0 Then
x = 1
Do While flags = False And x <= sysLdata.TopFiger
If sysLdata.Varites(x).name = names And sysLdata.Varites(x).Varlay = lays Then
flags = True
checkVar.DataKind = sysLdata.Varites(x).DataKind
checkVar.name = sysLdata.Varites(x).name
checkVar.value = sysLdata.Varites(x).value
checkVar.Varlay = sysLdata.Varites(x).Varlay
End If
x = x + 1
Loop
End If
If flags = False Then
If SysGData.TopFiger > 0 Then
x = 1
Do While flags = False And x <= SysGData.TopFiger
If SysGData.Varites(x).name = names Then
flags = True
checkVar = sysLdata.Varites(x)
End If
x = x + 1
Loop
End If
End If
If flags = False Then checkVar.name = ""
End Function
Private Function SetLVar(names As String, kings As String, values As String, lays As Integer) As Boolean '建立并设置局部变量
sysLdata.TopFiger = sysLdata.TopFiger + 1
sysLdata.Varites(sysLdata.TopFiger).DataKind = kings
sysLdata.Varites(sysLdata.TopFiger).name = names
sysLdata.Varites(sysLdata.TopFiger).value = values
sysLdata.Varites(sysLdata.TopFiger).Varlay = lays
End Function
Private Function SetGVar(names As String, kings As String, values As String, lays As Integer) As Boolean '建立并设置局部变量
SysGData.TopFiger = SysGData.TopFiger + 1
SysGData.Varites(SysGData.TopFiger).DataKind = kings
SysGData.Varites(SysGData.TopFiger).name = names
SysGData.Varites(SysGData.TopFiger).value = values
SysGData.Varites(SysGData.TopFiger).Varlay = lays
End Function
Private Function EditVar(names As Variant, values As Variant, lays As Integer) As Boolean
Dim x As Integer '如无返回name=""
Dim Vartem As VarKeep
Dim flags As Boolean
If sysLdata.TopFiger > 0 Then
x = 1
Do While flags = False And x <= sysLdata.TopFiger
If sysLdata.Varites(x).name = names And sysLdata.Varites(x).Varlay = lays Then
flags = True
sysLdata.Varites(x).value = values
End If
x = x + 1
Loop
End If
If flags = False Then
If SysGData.TopFiger > 0 Then
x = 1
Do While flags = False And x <= SysGData.TopFiger
If SysGData.Varites(x).name = names Then
flags = True
sysLdata.Varites(x).value = values
End If
x = x + 1
Loop
End If
End If
EditVar = flags
End Function

Private Function clearLval(lays As Integer)
Dim x As Integer
x = sysLdata.TopFiger
Do While sysLdata.Varites(x).Varlay = lays
x = x - 1
Loop
sysLdata.TopFiger = x
End Function
Public Function ExpScript(scr As String) As Boolean '解释一句脚本（不负责解释块脚本） '脚本解释
Dim x As Integer
Dim tem1 As String
Dim tem As String
Dim tem2 As String
Dim tem3 As String
If Left(readstr(scr, 1), 1) <> "'" Then
Select Case readstr(scr, 1)
Case "public":
tem = readstr(scr, 2)
tem2 = readstr(scr, 3)
tem3 = readstr(scr, 4)
If checkVar(tem, NowingFun.FuncLay).name = "" And tem2 = "as" And _
(tem3 = "number" Or tem3 = "string" Or tem3 = "boolen") Then
SetGVar tem, tem3, "", NowingFun.FuncLay
End If
Case "dim":
tem = readstr(scr, 2)
tem2 = readstr(scr, 3)
tem3 = readstr(scr, 4)
If checkVar(tem, NowingFun.FuncLay).name = "" And tem2 = "as" And _
(tem3 = "number" Or tem3 = "string" Or tem3 = "boolen") Then
SetLVar tem, tem3, "", NowingFun.FuncLay
End If
Case "end":
If readstr(scr, 2) = "function" Then
FunReTurn = checkVar(NowingFun.name, NowingFun.FuncLay)
Debug.Print NowingFun.FuncLay
clearLval NowingFun.FuncLay
NowingFun.FuncLay = NowingFun.FuncLay - 1
Debug.Print FunReTurn.value
End If
Case "call":
x = 3
Do While readstr(scr, x) <> ""
scKeeper.csvalue(x - 2).value = readstr(scr, x)
x = x + 1
Loop

ExpFun GetFun(readstr(scr, 2), SysProgrameTable)
Case "function":
NowingFun.name = readstr(scr, 2)
NowingFun.FuncLay = NowingFun.FuncLay + 1

tem = readstr(scr, 3)
x = 4
Dim CsNumber As Integer
CsNumber = 1
Do While tem <> ")" And tem <> ""
tem = readstr(scr, x)
tem2 = readstr(scr, x + 1)
tem3 = readstr(scr, x + 2)
If tem <> "" And tem2 = "as" And (tem3 = "number" Or tem3 = "boolen" Or tem3 = "string") Then
SetLVar tem, tem3, CStr(scKeeper.csvalue(CsNumber).value), NowingFun.FuncLay
CsNumber = CsNumber + 1
End If
x = x + 3
Loop
If tem = ")" Then
If readstr(scr, x) = "as" And readstr(scr, x + 1) <> "" Then
NowingFun.DataKind = readstr(scr, x + 1)
End If
End If
SetLVar NowingFun.name, NowingFun.DataKind, "", NowingFun.FuncLay
SysFunStutues.TopFiger = SysFunStutues.TopFiger + 1
SysFunStutues.Fun(SysFunStutues.TopFiger).name = NowingFun.name
SysFunStutues.Fun(SysFunStutues.TopFiger).Varlay = NowingFun.FuncLay
SysFunStutues.Fun(SysFunStutues.TopFiger).value = NowingFun.value
SysFunStutues.Fun(SysFunStutues.TopFiger).DataKind = NowingFun.DataKind
Case "if":
x = 1
tem = readstr(scr, x)
Do While tem <> "" And tem <> "then"
x = x + 1
tem = readstr(scr, x)
Loop
If tem = "then" And readstr(scr, x + 1) <> "" Then
Dim addstrnumber As Integer
addstrnumber = x
tem1 = ""
For x = 2 To addstrnumber - 1
tem1 = tem1 & readstr(scr, x)
Next x
tem2 = readleststr(scr, addstrnumber)
If Compute(tem1) = True Then ExpScript tem2
End If
Case Else
If Left(readstr(scr, 1), 1) <> "#" Then
Compute scr
Else
FrmShow.CommandCenter CMsocket(scr)
End If
End Select
End If
End Function
Public Function ExpFun(FunP As ProgrameTabel) As Variant '运行一函数
Dim PrgFiger As Integer
Dim newfiger As Integer
Dim x As Integer
Dim tem As String
Dim tem1 As String
Dim tem2 As String
Dim tem3 As String
Dim tem4 As String
On Error GoTo errs
PrgFiger = 1
Do While PrgFiger <= FunP.Total
tem4 = readstr(FunP.ProSen(PrgFiger), 1)
If Right(tem4, 1) <> ":" And Left(tem4, 1) <> "'" Then
Select Case tem4
Case "if":
x = 1
tem = readstr(FunP.ProSen(PrgFiger), x)
Do While tem <> "" And tem <> "then"
x = x + 1
tem = readstr(FunP.ProSen(PrgFiger), x)
Loop
If tem = "then" And readstr(FunP.ProSen(PrgFiger), x + 1) = "" Then
Dim addstrnumber As Integer
addstrnumber = x
tem1 = ""
For x = 2 To addstrnumber - 1
tem1 = tem1 & " " & readstr(FunP.ProSen(PrgFiger), x)
Next x
If Compute(tem1) = True Then
ExpFun GetIfTabel(FunP, PrgFiger, newfiger) 'newfiger 为传址参数
PrgFiger = newfiger
Else
GetIfTabel FunP, PrgFiger, newfiger
PrgFiger = newfiger
End If
Else
ExpScript FunP.ProSen(PrgFiger)
PrgFiger = PrgFiger + 1
End If
Case "do":
If readstr(FunP.ProSen(PrgFiger), 2) = "while" And readleststr(FunP.ProSen(PrgFiger), 2) <> "" Then
Dim DoCondition As String
Dim Dotabel As ProgrameTabel
DoCondition = readleststr(FunP.ProSen(PrgFiger), 2)
Do While Compute(DoCondition)
ExpFun GetDoTabel(FunP, PrgFiger, newfiger)
Loop
PrgFiger = newfiger
End If
Case "for":
Case "goto":
tem2 = readstr(FunP.ProSen(PrgFiger), 2)
tem2 = tem2 & ":"
x = 1
Do While x < FunP.Total And readstr(FunP.ProSen(x), 1) <> tem2
x = x + 1
Loop
If FunP.ProSen(x) = tem2 Then PrgFiger = x
Case "end":
tem1 = readstr(FunP.ProSen(PrgFiger), 2)
If tem1 = "function" Then
FunReTurn = checkVar(NowingFun.name, NowingFun.FuncLay)
PrgFiger = FunP.Total + 1
clearLval NowingFun.FuncLay
NowingFun.FuncLay = NowingFun.FuncLay - 1
SysFunStutues.TopFiger = SysFunStutues.TopFiger - 1
NowingFun.name = SysFunStutues.Fun(SysFunStutues.TopFiger).name
NowingFun.value = SysFunStutues.Fun(SysFunStutues.TopFiger).value
NowingFun.DataKind = SysFunStutues.Fun(SysFunStutues.TopFiger).DataKind
Debug.Print FunReTurn.value
End If
If tem1 = "if" Then
PrgFiger = PrgFiger + 1
End If

Case Else:
ExpScript FunP.ProSen(PrgFiger)
PrgFiger = PrgFiger + 1
End Select
End If
Loop
GoTo goon:
errs:
MsgBox "函数执行错误,将停止该函数的执行。"
goon:
End Function
Private Function GetDoTabel(FunP As ProgrameTabel, figers As Integer, newfiger As Integer) As ProgrameTabel
Dim temTabel As ProgrameTabel
Dim tem As String
Dim Donumber As Integer
Dim temFiger As Integer
Dim x As Integer
Dim j As Integer
ReDim GetDoTabel.ProSen(FunP.Total + 1)
Donumber = 1
temFiger = figers + 1
x = 1
tem = readstr(FunP.ProSen(temFiger), 1)
Do While Donumber >= 1 And tem <> "" And temFiger <= FunP.Total
Select Case readstr(FunP.ProSen(temFiger), 1)
Case "Do":
j = 1
tem = readstr(FunP.ProSen(temFiger), j)
Do While tem <> "" And tem <> "while"
j = j + 1
tem = readstr(FunP.ProSen(temFiger), j)
Loop
If tem = "while" And readstr(FunP.ProSen(temFiger), j + 1) = "" Then
Donumber = Donumber + 1
End If
Case "loop":
Donumber = Donumber - 1
End Select
temFiger = temFiger + 1
Loop
newfiger = temFiger
j = 1
For x = figers + 1 To temFiger - 2
GetDoTabel.ProSen(j) = FunP.ProSen(x)
j = j + 1
Next x
GetDoTabel.Total = j - 1
End Function
Private Function GetIfTabel(FunP As ProgrameTabel, figers As Integer, newfiger As Integer) As ProgrameTabel 'figers 为IF 其实地点
Dim temTabel As ProgrameTabel
Dim tem As String
Dim ifnumber As Integer
Dim elsenumber As Integer
Dim temFiger As Integer
Dim x As Integer
Dim j As Integer
ReDim GetIfTabel.ProSen(FunP.Total + 1)
ifnumber = 1
temFiger = figers + 1
x = 1
tem = readstr(FunP.ProSen(temFiger), 1)
Do While ifnumber >= 1 And tem <> "" And temFiger <= FunP.Total
Select Case readstr(FunP.ProSen(temFiger), 1)
Case "if":
j = 1
tem = readstr(FunP.ProSen(temFiger), j)
Do While tem <> "" And tem <> "then"
j = j + 1
tem = readstr(FunP.ProSen(temFiger), j)
Loop
If tem = "then" And readstr(FunP.ProSen(temFiger), j + 1) = "" Then
ifnumber = ifnumber + 1
End If
Case "end":
If readstr(FunP.ProSen(temFiger), 2) = "if" Then ifnumber = ifnumber - 1
End Select
temFiger = temFiger + 1
Loop
newfiger = temFiger
j = 1
For x = figers + 1 To temFiger - 2
GetIfTabel.ProSen(j) = FunP.ProSen(x)
j = j + 1
Next x
GetIfTabel.Total = j - 1
End Function

Public Function GetFun(FunName As String, FunTable As ProgrameTabel) As ProgrameTabel
Dim x As Integer
Dim temtable As ProgrameTabel
Dim temstr As String
Dim flag As Boolean
ReDim temtable.ProSen(FunTable.Total + 1) As String
ReDim GetFun.ProSen(FunTable.Total + 1) As String
x = 1
Do While x < FunTable.Total And Not (readstr(FunTable.ProSen(x), 1) = "function" _
And readstr(FunTable.ProSen(x), 2) = FunName)
x = x + 1
Debug.Print x
Debug.Print FunTable.ProSen(x)
Loop
If readstr(FunTable.ProSen(x), 2) = FunName Then
Do While x <= FunTable.Total And flag = False
temstr = FunTable.ProSen(x)
Debug.Print temstr
If readstr(temstr, 1) = "end" And readstr(temstr, 2) = "function" Then
flag = True
End If
temtable.Total = temtable.Total + 1
temtable.ProSen(temtable.Total) = temstr
x = x + 1
Loop
End If
GetFun.FunName = FunName
GetFun.Total = temtable.Total

For x = 1 To GetFun.Total
GetFun.ProSen(x) = temtable.ProSen(x)
Next x

End Function
Public Function CMsocket(sstring As String) As String
Dim cs() As String
Dim LastString() As String
Dim x As Integer
Dim max As Integer
Dim tem As String
Dim TemSocket As String
x = 1
Do While readstr(sstring, x + 1) <> ""
x = x + 1
Loop
ReDim cs(x) As String
ReDim LastString(x) As String
x = 1
Do While readstr(sstring, x + 1) <> ""
tem = readstr(sstring, x + 1)
cs(x) = tem
x = x + 1
Loop
max = x - 1
x = 1
TemSocket = readstr(sstring, 1)
Do While cs(x) <> "" And x <= max
If Right(cs(x), 1) = Chr(34) And Left(cs(x), 1) = Chr(34) Then
LastString(x) = Mid(cs(x), 2, Len(cs(x)) - 2)
TemSocket = TemSocket & " " & LastString(x)
Else
If checkVar(cs(x), NowingFun.FuncLay).name <> "" Then
LastString(x) = CStr(checkVar(cs(x), NowingFun.FuncLay).value)
If Right(LastString(x), 1) = Chr(34) And Left(LastString(x), 1) = Chr(34) Then
LastString(x) = Mid(LastString(x), 2, Len(LastString(x)) - 2)
End If
TemSocket = TemSocket & " " & LastString(x)
Else
LastString(x) = cs(x)
TemSocket = TemSocket & " " & LastString(x)
End If
End If
x = x + 1
Loop
CMsocket = TemSocket
End Function
里面一些注释有可能不准确，不要深究。
以上代码是脚本语言实现的一部分。

...全文