 |
theNerd
Adept
Joined: 01 Mar 2005
Posts: 277
|
 Posted: Mon Oct 10, 2005 7:41 pm
16 Bit DOS Compiler In zApp
|
Here is a simple Open Source DOS Compiler (originally written by Kinex in VB) that I converted over to zApp for the fun of it. It works but has many bugs that I need to fix. I can only work on this during my lunches so as I fix and improve it I will post the zApp source here.
What needs to be done:
* Bug fixing
* Syntax Coloring
* Converting some VBScript code (ex. FileSystemObject) to zApp's code (ex. File .Stream)
* Right now it defaults to compiling to "c:\test.exe". This will be user definable rather than hard coded.
* Add example code it can compile
* Eventually adding new commands.
| Code: |
<?xml version='1.0' encoding='ISO-8859-1' ?>
<!DOCTYPE zapp [
<!ENTITY AppTitle "16 Bit DOS Compiler">
<!ENTITY OrigAuthor "Kinex">
<!ENTITY AppAuthor "Steven C Picard">
<!ENTITY AppVersion "0.09">
<!ENTITY AppURL "http://www.kidev.com/devres/?page=home">
]>
<zapp>
<action name='MemoNew' action='_MemoNew'>
MemoNew.Format = "Text"
NewTab
MemoNew.Target = CurrentMemo.Name
</action>
<action name='MemoOpen' action='_MemoOpen'>
NewTab
MemoOpen.Target = CurrentMemo.Name
</action>
<action name='OnStart' Caption='Start' image='play'>
StartCompile
</action>
<toolbar name='mainmenu' Fullsize='true'>
<menu caption='&File'>
<item action='MemoNew'/>
<item action='MemoOpen'/>
<itemsep/>
<item action='_MemoSave'/>
<item action='_MemoSaveAs'/>
<itemsep/>
<item action='_MemoPageSetup'/>
<item action='_MemoPrintPreview'/>
<item action='_MemoPrint'/>
<itemsep/>
<item action='_FileExit'/>
</menu>
<menu caption='&Edit'>
<item action='_MemoUndo'/>
<item action='_MemoRedo'/>
<itemsep/>
<item action='_EditCut'/>
<item action='_EditCopy'/>
<item action='_EditPaste'/>
<itemsep/>
<item action='_MemoFind'/>
<item action='_MemoFindNext'/>
<item action='_MemoReplace'/>
<itemsep/>
<item action='_MemoCharCase'/>
<itemsep/>
<item action='_EditSelectAll'/>
</menu>
<menu caption='&Run'>
<item caption='Start' action='OnStart'/>
</menu>
<menu caption='&View'>
<item caption='Normal' script='core.themeindex = -1'/>
<item caption='Standard' script='core.theme = "standard"'/>
<item caption='Flat' script='core.theme = "flat"'/>
<item caption='UltraFlat' script='core.theme = "ultraflat"'/>
<item caption='Office11' script='core.theme = "office11"'/>
<item caption='Aqua' script='core.theme = "aqua"'/>
<item caption='Watercolor' script='core.theme = "watercolor"'/>
<item caption='Plex' script='core.theme = "plex"'/>
<item action='_ThemeSelect'/>
</menu>
<menu caption='&Help'>
<item caption='&About' script='core.execwindow( "About")'/>
</menu>
</toolbar>
<toolbar name='maintoolbar'>
<item action='MemoOpen'/>
<item action='_MemoSave'/>
<item action='_MemoQuickPrint'/>
<item action='OnStart'/>
</toolbar>
<window name='main' caption='&AppTitle;' width="640" height="480" focus='Memo'>
<toolbar name='mainmenu'/>
<toolbar name='maintoolbar' row='1'/>
<ruler align='top'/>
<var name='OnChange'>
EditPages.ActivePage.Color = "mistyrose"
</var>
<var name='OnFileChange'>
if not(IsNull(zEvent.Sender.Tab)) then
zEvent.Sender.Tab.Caption = str.ExtractFilename( zEvent.Filename)
zEvent.Sender.Tab.Color = "Window"
end if
</var>
<script>
TabNum = 0
sub NewTab
TabNum = TabNum + 1
Set CurrentTab = core.AddControl( "tab", "tab" & TabNum, "EditPages")
Set CurrentMemo = core.AddControl( "memo", "memo" & TabNum, "tab" & TabNum)
CurrentMemo.Align = "client"
CurrentMemo.Spellcheck = true
CurrentMemo.ConfirmSave = true
CurrentMemo.OnChange = OnChange.Value
CurrentMemo.OnFileChange = OnFileChange.Value
CurrentTab.Caption = "untitled" & TabNum
EditPages.ActivePageName = CurrentTab.Name
end sub
</script>
<pages name='EditPages' align='client' showclosebutton='true'>
<tab name='MainTab' caption='untitled'>
<memo name='Memo' align='client' fontname='Arial' fontsize='12' spellcheck='true' confirmsave='true'
onChange='=OnChange' onFileChange='=OnFileChange'/>
</tab>
</pages>
<script>
Set CurrentMemo = core.FindControl("Memo")
if (core.OptionCount > 0) then
fName = core.OptionValue(1)
CurrentMemo.LoadFromFile fName
MainTab.caption = fName
end if
</script>
<statusbar name='Status'/>
<script>
Dim Code
' mod Compiler Variables
Dim CodeSection() ' As Integer
' mod Errors Variables
Dim pError ' As Boolean
Dim Errors ' As String
' mod Parser
Dim Source ' As String
Dim SourcePos ' As Long
' mod Resources
Dim DataSection() ' As Integer
' mod Symbols
' SYMBOL_TYPE (Replaces Enum)
Const RES_STRING = 1
Const RES_LABEL = 2
Const RES_PROC = 3
Const RES_WORD = 4
Class SYMBOL_ITEM
Public Name ' As String
Public Offset ' As Long
Public SYMBOL_TYPE ' As SYMBOL_TYPE
End Class
Dim uID ' As Long
Dim UniqueID ' As Long
Dim Symbols() ' As SYMBOL_ITEM
' mod Fixups
Class FIXUP_ITEM
Public Name ' As String
Public Value ' As Integer
Public Offset ' As Long
End Class
Dim Fixups() ' As FIXUP_ITEM
' mod Linker
Const GENERIC_WRITE = &H40000000
Const GENERIC_READ = &H80000000
Const FILE_ATTRIBUTE_NORMAL = &H80
Const CREATE_ALWAYS = 2
Const OPEN_ALWAYS = 4
Const INVALID_HANDLE_VALUE = -1
Dim HeadSection() ' As Integer
function StartCompile()
if len(Trim(memo.text)) = 0 then
msgbox "Please enter some code to run."
exit function
end if
Code = memo.text
Compile "c:\text.exe"
File.Launch "c:\text.exe", "", "", 5
end function
' ==============================================================
' mod Compiler Routines
Sub InitCompiler()
ReDim CodeSection(0) ' As Integer
End Sub
Sub Compile(sFile)
InitErrors
InitParser
InitFixups
InitSymbols
InitCompiler
InitResources
'Reserve the first two Bytes for jump to 'main' entry
AddCodeByte Array(&HEB, &H0)
AddFixup "main", UBound(CodeSection)
Parse
DoFixups
If pError = True Then
InfMessage Errors: Exit Sub
End If
Link sFile
End Sub
Sub AddCodeWord(Words) ' Was ParamArray
Dim i ' As Integer
For i = 0 To UBound(Words)
AddCodeByte Array(LoByte(CInt(Words(i))), HiByte(CInt(Words(i))))
Next ' i
End Sub
Sub AddCodeByte(Bytes) ' ParamArray
Dim i ' As Integer
For i = 0 To UBound(Bytes)
ReDim Preserve CodeSection(UBound(CodeSection) + 1) ' As Integer
CodeSection(UBound(CodeSection)) = CByte(Bytes(i))
Next ' i
End Sub
' mod Errors Routines
Sub InitErrors()
Errors = ""
End Sub
Sub ErrMessage(Text) ' As String
Errors = Errors & Text & " [" & SourcePos & "]" & vbCrLf
pError = True
End Sub
Sub InfMessage(Text) ' As String
MsgBox Text, vbInformation, "LeDev Compiler"
pError = False
End Sub
' mod Expressions
Function IsVariableExpression() ' As Boolean
If (UCase(Mid(Source, SourcePos, 1)) >= "A" And UCase(Mid(Source, SourcePos, 1)) <= "Z") Then
IsVariableExpression = True
End If
End Function
Function IsStringExpression() ' As Boolean
If Mid(Source, SourcePos, 1) = Chr(34) Then
IsStringExpression = True
End If
End Function
Function IsNumberExpression() ' As Boolean
If IsNumeric(Mid(Source, SourcePos, 1)) Or Mid(Source, SourcePos, 1) = "-" Then
IsNumberExpression = True
End If
End Function
Function NumberExpression() ' As Integer
SkipBlank
While IsNumeric(Mid(Source, SourcePos, 1))
NumberExpression = NumberExpression & Mid(Source, SourcePos, 1)
Skip 0
Wend
End Function
Function VariableExpression() ' As String
VariableExpression = Identifier
End Function
Function StringExpression() ' As String
SkipBlank
Symbol Chr(34)
While Mid(Source, SourcePos, 1) <> Chr(34)
StringExpression = StringExpression & Mid(Source, SourcePos, 1)
If Mid(Source, SourcePos, 1) = vbCr Or Mid(Source, SourcePos, 1) = "" Then
ErrMessage "unterminated string": Exit Function
End If
Skip 0
Wend
Symbol Chr(34)
End Function
' mod Math
Function HiByte(ByVal iWord ) ' As Byte
HiByte = (iWord And &HFF00&) \ &H100
End Function
Function LoByte(ByVal iWord) ' As Byte
LoByte = iWord And &HFF
End Function
' mod Resources
Sub InitResources()
ReDim DataSection(0) ' As Integer
End Sub
Sub AddResourceWord(Name, Value) ' As String, As Integer
AddSymbol Name, UBound(DataSection) + 2, RES_WORD
AddDataWord Value
End Sub
Sub AddResourceSpace(Value) ' As Integer
Dim i ' As Integer
For i = 0 To Value
AddDataByte Asc("$")
Next ' i
End Sub
Sub AddResourceString(Name, Value) ' As String As String
Dim i ' As Integer
AddSymbol Name, UBound(DataSection) + 2, RES_STRING
For i = 1 To Len(Value)
AddDataByte Asc(Mid(Value, i, 1))
Next ' i
AddDataByte Asc("$")
End Sub
Sub AddDataWord(Value) ' As Integer
AddDataByte LoByte(Value)
AddDataByte HiByte(Value)
End Sub
Sub AddDataByte(Value) ' As Byte
ReDim Preserve DataSection(UBound(DataSection) + 1) ' As Integer
DataSection(UBound(DataSection)) = Value
End Sub
' mod Syntax
Sub Statement_Exit()
Symbol "("
Symbol ")"
Terminator
AddCodeByte Array(&HB8, &H0, &H4C, &HCD, &H21)
CodeBlock
End Sub
Sub Statement_Wait()
Symbol "("
Symbol ")"
Terminator
AddCodeByte Array(&H31, &HC0, &HCD, &H16)
CodeBlock
End Sub
Sub Statement_Print(Ln) ' As Boolean
Dim SymbolName ' As String
Symbol "("
If IsSymbol(Chr(34)) Then
uID = uID + 1
AddResourceString "Unique" & uID, StringExpression ' & Switch((Ln = True), vbCrLf, Null)
AddCodeByte Array(&HBA, &H0)
AddFixup "Unique" & uID, 0
AddCodeByte Array(&H0, &HB4, &H9, &HCD, &H21)
Else
SymbolName = Identifier
AddCodeByte Array(&HBA, &H0)
AddFixup SymbolName, 0
AddCodeByte Array(&H0, &HB4, &H9, &HCD, &H21)
End If
Symbol ")"
Terminator
CodeBlock
End Sub
Sub Statement_PosXY()
Dim x ' As Byte
Dim y ' As Byte
Symbol "("
x = NumberExpression
Symbol ","
y = NumberExpression
Symbol ")"
Terminator
AddCodeByte Array(&HB4, &H2, &HB6)
AddCodeByte x
AddCodeByte Array(&HB2)
AddCodeByte y
AddCodeByte Array(&HB7, &H0, &HCD, &H10)
CodeBlock
End Sub
Sub Statement_Cls()
Symbol "("
Symbol ")"
Terminator
AddCodeByte Array(&HB4, &H6, &HB5, &H0, &HB1, &H0, &HB6, &H18, &HB2, &H4F, &HB7, &H7, &HB0, &H0, &HCD, &H10, &HB4, &H2, &HB6, &H0, &HB2, &H0, &HB7, &H0, &HCD, &H10)
CodeBlock
End Sub
Sub Statement_Jump()
Dim Ident ' As String
Symbol "("
Ident = Identifier
Symbol ")"
Terminator
AddCodeByte Array(&HEB)
AddCodeByte Array(&H0)
AddFixup Ident, UBound(CodeSection)
CodeBlock
End Sub
Sub Statement_Call()
Dim Ident ' As String
Symbol "("
Ident = Identifier
Symbol ")"
Terminator
AddCodeByte Array(&HEB)
AddCodeByte Array(&H0)
AddFixup Ident, UBound(CodeSection)
CodeBlock
End Sub
Sub Statement_CallProc(Ident) ' As String
Symbol "("
Symbol ")"
Terminator
AddCodeByte Array(&HEB)
AddCodeByte Array(&H0)
AddFixup Ident, UBound(CodeSection)
CodeBlock
End Sub
Sub Statement_Read()
Dim Length ' As Integer
Symbol "("
uID = uID + 1
Length = NumberExpression
AddResourceWord "Length", Length
AddResourceString "read", ""
AddResourceSpace Length
AddCodeByte Array(&HBA, &H0)
AddFixup "Length", 0
AddCodeByte Array(&H0, &HB4, &HA, &HCD, &H21)
AddCodeByte Array(&H1E, &H7, &HBF, &H0)
AddFixup "read", 0
AddCodeByte Array(&H0, &HB0, &HD, &HF2, &HAE, &HC6, &H45, &HFF, &H24)
AddCodeByte Array(&HB4, &H2, &HB2, &HA, &HCD, &H21)
Symbol ")"
Terminator
CodeBlock
End Sub
Sub Declare_Proc()
AddSymbol Identifier, UBound(CodeSection), RES_PROC
Symbol "("
Symbol ")"
Terminator
CodeBlock
End Sub
Sub Statement_End()
Terminator
CodeBlock
End Sub
Sub Statement_If()
Dim Expr(1) ' As String
Dim ExprIsVariable(1) ' As Boolean
Dim Ident ' As String
Dim Operator ' As String
Dim iID ' As Long
iID = iID + UniqueID: UniqueID = UniqueID + 1
Symbol "("
If IsNumberExpression Then
Expr(0) = NumberExpression
ExprIsVariable(0) = False
ElseIf IsVariableExpression Then
Expr(0) = VariableExpression
ExprIsVariable(0) = True
End If
If IsSymbol("=") Then
Operator = "=": Skip 0
ElseIf IsSymbol("<") Then
Operator = "<": Skip 0
ElseIf IsSymbol(">") Then
Operator = ">": Skip 0
ElseIf IsSymbol("!") Then
Operator = "!": Skip 0
Else: ErrMessage "expected operator = < > or !": Exit Sub
End If
If IsNumberExpression Then
Expr(1) = NumberExpression
ExprIsVariable(1) = False
ElseIf IsVariableExpression Then
Expr(1) = VariableExpression
ExprIsVariable(1) = True
End If
Symbol ")"
If ExprIsVariable(0) = False Then
'mov bx,expr
AddCodeByte Array(&HBB)
AddCodeWord Expr(1)
Else
'mov bx,[variable]
AddCodeByte Array(&H8B, &H1E, &H0)
AddFixup Expr(0), 0
AddCodeByte Array(&H0)
End If
If ExprIsVariable(1) = False Then
'mov dx,expr
AddCodeByte Array(&HBA)
AddCodeWord Expr(1)
Else
'mov dx,[variable]
AddCodeByte Array(&H8B, &H16, &H0)
AddFixup Expr(1), 0
AddCodeByte Array(&H0)
End If
'cmp bx, dx
AddCodeByte Array(&H39, &HD3)
If Operator = "=" Then
AddCodeByte Array(&H74, &H0)
AddFixup "then" & iID, UBound(CodeSection)
AddCodeByte Array(&H75, &H0)
AddFixup "else" & iID, UBound(CodeSection)
End If
If Operator = "<" Then
AddCodeByte Array(&H7C, &H0)
AddFixup "then" & iID, UBound(CodeSection)
AddCodeByte Array(&H7D, &H0)
AddFixup "else" & iID, UBound(CodeSection)
End If
If Operator = ">" Then
AddCodeByte Array(&H7F, &H0)
AddFixup "then" & iID, UBound(CodeSection)
AddCodeByte Array(&H7E, &H0)
AddFixup "else" & iID, UBound(CodeSection)
End If
If Operator = "!" Then
AddCodeByte Array(&H75, &H0)
AddFixup "then" & iID, UBound(CodeSection)
AddCodeByte Array(&H74, &H0)
AddFixup "else" & iID, UBound(CodeSection)
End If
'Parse
Symbol "{":
AddSymbol "then" & iID, UBound(CodeSection), RES_LABEL
CodeBlock
AddCodeByte Array(&HEB, &H0)
AddFixup "endif" & iID, UBound(CodeSection)
Symbol "}"
SkipBlank
AddSymbol "else" & iID, UBound(CodeSection), RES_LABEL
If IsIdent("else") Then
Skip 4
Symbol "{"
CodeBlock
Symbol "}"
End If
AddSymbol "endif" & iID, UBound(CodeSection), RES_LABEL
CodeBlock
End Sub
Sub Statement_While()
Dim Expr(1) ' As String
Dim ExprIsVariable(1) ' As Boolean
Dim Ident ' As String
Dim Operator ' As String
Dim wID ' As Long
wID = UniqueID: UniqueID = UniqueID + 1
Symbol "("
If IsNumberExpression Then
Expr(0) = NumberExpression
ExprIsVariable(0) = False
ElseIf IsVariableExpression Then
Expr(0) = VariableExpression
ExprIsVariable(0) = True
End If
If IsSymbol("=") Then
Operator = "=": Skip 0
ElseIf IsSymbol("<") Then
Operator = "<": Skip 0
ElseIf IsSymbol(">") Then
Operator = ">": Skip 0
ElseIf IsSymbol("!") Then
Operator = "!": Skip 0
Else: ErrMessage "expected operator = < > or !": Exit Sub
End If
If IsNumberExpression Then
Expr(1) = NumberExpression
ExprIsVariable(1) = False
ElseIf IsVariableExpression Then
Expr(1) = VariableExpression
ExprIsVariable(1) = True
End If
Symbol ")"
AddSymbol "while" & wID, UBound(CodeSection), RES_LABEL
If ExprIsVariable(0) = False Then
'mov bx,expr
AddCodeByte &HBB
AddCodeWord Expr(1)
Else
'mov bx,[variable]
AddCodeByte &H8B, &H1E, &H0
AddFixup Expr(0),0
AddCodeByte &H0
End If
If ExprIsVariable(1) = False Then
'mov dx,expr
AddCodeByte &HBA
AddCodeWord Expr(1),0
Else
'mov dx,[variable]
AddCodeByte &H8B, &H16, &H0
AddFixup Expr(1),0
AddCodeByte &H0
End If
'cmp bx, dx
AddCodeByte &H39, &HD3
If Operator = "=" Then
AddCodeByte &H75, &H0
AddFixup "endwhile" & wID, UBound(CodeSection)
End If
If Operator = "<" Then
AddCodeByte &H7D, &H0
AddFixup "endwhile" & wID, UBound(CodeSection)
End If
If Operator = ">" Then
AddCodeByte &H7E, &H0
AddFixup "endwhile" & wID, UBound(CodeSection)
End If
If Operator = "!" Then
AddCodeByte &H74, &H0
AddFixup "endwhile" & wID, UBound(CodeSection)
End If
'Parse
Symbol "{":
CodeBlock
AddCodeByte &HEB, &H0
AddFixup "while" & wID, UBound(CodeSection)
Symbol "}"
SkipBlank
AddSymbol "endwhile" & wID, UBound(CodeSection), RES_LABEL
CodeBlock
End Sub
Sub Declare_Label()
Symbol "("
AddSymbol Identifier, UBound(CodeSection), RES_LABEL
Symbol ")"
Terminator
CodeBlock
End Sub
Sub Declare_Word()
Dim IdentName ' As String
Dim ResWord ' As Integer
Symbol "("
IdentName = Identifier
Symbol ","
ResWord = NumberExpression
Symbol ")"
Terminator
AddResourceWord IdentName, ResWord
CodeBlock
End Sub
Sub Evaluate_Variable(Ident) ' As String
SkipBlank
If IsSymbol("+=") Then
Symbol ("+"): Symbol ("=")
AddCodeByte &H81, &H6, &H0
AddFixup Ident, 0
AddCodeByte &H0
AddCodeWord NumberExpression
End If
If IsSymbol("-=") Then
Symbol ("-"): Symbol ("=")
AddCodeByte &H81, &H2E, &H0
AddFixup Ident, 0
AddCodeByte &H0
AddCodeWord NumberExpression
End If
If IsSymbol("=") Then
Symbol ("=")
AddCodeByte &HC7, &H6, &H0
AddFixup Ident, 0
AddCodeByte &H0
AddCodeWord NumberExpression
End If
Terminator
CodeBlock
End Sub
Sub Declare_String()
Dim IdentName ' As String
Dim ResString ' As String
Symbol "("
IdentName = Identifier
Symbol ","
ResString = StringExpression
Symbol ")"
Terminator
AddResourceString IdentName, ResString
CodeBlock
End Sub
' mod Symbols
Sub InitSymbols()
uID = 0
UniqueID = 0
ReDim Symbols(0) ' As SYMBOL_ITEM
Set Symbols(0) = New SYMBOL_ITEM
End Sub
Sub AddSymbol(Name, Offset, TypeOfSymbol) ' As String, As Long, As SYMBOL_TYPE
ReDim Preserve Symbols(UBound(Symbols) + 1) ' As SYMBOL_ITEM
Set Symbols(UBound(Symbols)) = New SYMBOL_ITEM
Symbols(UBound(Symbols)).Name = Name
Symbols(UBound(Symbols)).Offset = Offset
Symbols(UBound(Symbols)).SYMBOL_TYPE = TypeOfSymbol
End Sub
' mod Fixups
Sub InitFixups()
ReDim Fixups(0) ' As FIXUP_ITEM
Set FixUps(0) = New FIXUP_ITEM
End Sub
Sub AddFixup(Name, Value) ' As String, Optional Value As Integer
ReDim Preserve Fixups(UBound(Fixups) + 1) ' As FIXUP_ITEM
Set Fixups(UBound(Fixups)) = New FIXUP_ITEM
Fixups(UBound(Fixups)).Name = Name
Fixups(UBound(Fixups)).Value = Value
Fixups(UBound(Fixups)).Offset = UBound(CodeSection)
End Sub
Sub DoFixups()
Dim i ' As Integer
Dim ii ' As Integer
Dim Found ' As Boolean
Found = False
For i = 1 To UBound(Fixups)
For ii = 1 To UBound(Symbols)
If LCase(Symbols(ii).Name) = LCase(Fixups(i).Name) Then
If Symbols(ii).SYMBOL_TYPE = RES_STRING Then
CodeSection(Fixups(i).Offset) = UBound(CodeSection) + Symbols(ii).Offset
ElseIf Symbols(ii).SYMBOL_TYPE = RES_WORD Then
CodeSection(Fixups(i).Offset) = UBound(CodeSection) + Symbols(ii).Offset
ElseIf Symbols(ii).SYMBOL_TYPE = RES_LABEL Then
CodeSection(Fixups(i).Offset) = Symbols(ii).Offset - Fixups(i).Value
ElseIf Symbols(ii).SYMBOL_TYPE = RES_PROC Then
CodeSection(Fixups(i).Offset) = Symbols(ii).Offset - Fixups(i).Value
End If
Found = True
End If
Next ' ii
If Found = False Then ErrMessage "'" & Fixups(i).Name & "' is undefined!" Else Found = False
Next ' i
End Sub
' mod Linker
Public Sub InitHeader()
ReDim HeadSection(0) ' As Integer
AddHeadBytes Array(&H4D, &H5A, 34 + UBound(CodeSection) + UBound(DataSection), &H0, _
&H1, &H0, &H0, &H0, &H2, &H0, &H0, &H1, &HFF, &HFF, &H7, &H0, _
&H0, &H10, &H0, &H0, &H0, &H0, &H0, &H0, &H1C, &H0, &H0, &H0, _
&H0, &H0, &H0, &H0, &HE, &H1F)
End Sub
Sub AddHeadBytes(Bytes)
Dim i ' As Integer
For i = 0 To UBound(Bytes)
ReDim Preserve HeadSection(UBound(HeadSection) + 1) ' As Integer
HeadSection(UBound(HeadSection)) = Bytes(i)
Next ' i
End Sub
Sub Link(sFile) ' As String
Dim i
Dim oFS ' As FileSystemObject
Set oFS = CreateObject("Scripting.FileSystemObject")
Dim oTS ' As TextStream
If oFS.FileExists(sFile) Then
oFS.DeleteFile sFile, True
End If
Set oTS = oFS.CreateTextFile(sFile, True)
InitHeader
For i = 1 To UBound(HeadSection)
oTS.Write Chr(HeadSection(i))
Next ' i
For i = 1 To UBound(CodeSection)
oTS.Write Chr(CodeSection(i))
Next ' i
For i = 1 To UBound(DataSection)
oTS.Write Chr(DataSection(i))
Next ' i
oTS.Close
Set oTS = Nothing
Set oFS = Nothing
InfMessage "compilation process complete." & vbCrLf & sFile & vbCrLf & _
UBound(HeadSection) + _
UBound(CodeSection) + _
UBound(DataSection) & _
" bytes written."
'ShellExecute 0, "open", sFile, "", "C:\", 1
End Sub
' mod Parser
Sub InitParser()
pError = False
Source = Code
End Sub
Sub Parse()
SourcePos = 1
CodeBlock
End Sub
Sub CodeBlock()
Dim Ident ' As String
Ident = Identifier
If Ident = "" Then Exit Sub: If pError = True Then Exit Sub
Select Case LCase(Ident)
Case "string": Declare_String
Case "int": Declare_Word
Case "wait": Statement_Wait
Case "posxy": Statement_PosXY
Case "cls": Statement_Cls
Case "read": Statement_Read
Case "print": Statement_Print False
Case "println": Statement_Print True
Case "label": Declare_Label
Case "proc": Declare_Proc
Case "end": Statement_End
Case "jump": Statement_Jump
Case "call": Statement_Call
Case "if": Statement_If
Case "while": Statement_While
Case "exit": Statement_Exit
Case Else
If IsVariable(Ident) Then
Evaluate_Variable Ident
ElseIf IsProc(Ident) Then
Statement_CallProc Ident
Else
ErrMessage "unknown Identifier '" & Ident & "'"
End If
End Select
End Sub
Function Identifier() ' As String
SkipBlank
While (UCase(Mid(Source, SourcePos, 1)) >= "A" And _
UCase(Mid(Source, SourcePos, 1)) <= "Z")
Identifier = Identifier & Mid(Source, SourcePos, 1)
Skip 0
Wend
End Function
Sub Skip(NumberOfChars)
SourcePos = SourcePos + 1 + NumberOfChars
End Sub
Sub SkipBlank()
While Mid(Source, SourcePos, 1) = " " Or _
Mid(Source, SourcePos, 1) = vbCr Or _
Mid(Source, SourcePos, 1) = vbLf Or _
Mid(Source, SourcePos, 1) = vbTab
Skip 0
Wend
End Sub
Sub Symbol(Value)
SkipBlank
If Mid(Source, SourcePos, 1) = Value Then
Skip 0
Else
ErrMessage "expected symbol '" & Value & "' but found '" & Mid(Source, SourcePos, 1) & "'"
End If
End Sub
Function IsVariable(Ident) ' As Boolean
Dim i ' As Integer
For i = 1 To UBound(Symbols)
If Symbols(i).SYMBOL_TYPE = RES_WORD Then
If Symbols(i).Name = Ident Then
IsVariable = True
Exit Function
End If
End If
Next ' i
End Function
Function IsProc(Ident) ' As Boolean
Dim i ' As Integer
For i = 1 To UBound(Symbols)
If Symbols(i).SYMBOL_TYPE = RES_PROC Then
If Symbols(i).Name = Ident Then
IsProc = True
Exit Function
End If
End If
Next ' i
End Function
Function IsIdent(Word) ' As Boolean
If LCase(Mid(Source, SourcePos, Len(Word))) = LCase(Word) Then IsIdent = True
End Function
Function IsSymbol(Value) ' As Boolean
If Mid(Source, SourcePos, Len(Value)) = Value Then IsSymbol = True
End Function
Sub Terminator()
If Mid(Source, SourcePos, 1) = ";" Then
Skip 0
Else
ErrMessage "expected terminator (;) but found '" & Mid(Source, SourcePos, 1)
End If
End Sub
Sub Switch(vExp,vTrue,vFalse)
If CBool(vExp) Then
Switch = vTrue
Else
Switch = vFalse
End If
End Sub
</script>
</window>
<window caption='About' name='about' width='400' height='300' borderstyle='dialog' nosave='true' position='screencenter' color='#C4D2ED'>
<panel align='bottom' height='28'>
<label left='0' top='0' fullwidth='true' fullheight='true' color='#C4D2ED' transparent='false'/>
<button kind='OK' autocenter='true' top='0'/>
</panel>
<panel borderouter='lowered' align='client'>
<label align='Client'><![CDATA[<p align="center"><br><b>&AppTitle;</b><br><br>
Version &AppVersion;<br><br>
<br>Original Open Source Author: <b>&OrigAuthor;</b><BR><a href="&AppURL;">&AppURL;</a><br><br>
Converted To zAPP By: <b>&AppAuthor;</b>
</p>]]></label>
</panel>
</window>
</zapp>
|
Here is some sample code to run:
| Code: |
string(given,"21");
proc main();
print("Enter the value 21 and then press ENTER to continue: ");
read(3);
if(read=given) {
print("You got it right!");
}
else {
print("Wrong entry!");
}
wait();
exit();
end;
|
|
|
Last edited by theNerd on Mon Oct 10, 2005 7:59 pm; edited 1 time in total |
 |
|
|
theNerd
Adept
Joined: 01 Mar 2005
Posts: 277
|
Posted: Mon Oct 10, 2005 7:53 pm
|
I am hoping to try and kickstart some interest in zApp. During my lunches (that I am actually at work) I will try to write quick little zApps that are fun.
Some ideas that I will pull from:
* Log viewer (I have some big ideas for this)
* Adventure creator
* Simple custom programming language that converts to zApp code
* Address book (good example for newbies)
* Form designer for zApp |
|
|
|
|
theNerd
Adept
Joined: 01 Mar 2005
Posts: 277
|
Posted: Tue Dec 13, 2005 9:39 pm
|
Just in case there was even 1 person out there wondering why I never continued posting updates and other bits of stuff here, I stopped because my time is very limited (like all of ours, I'm sure) and it is best spent on other things. I saw zero interest so I saw no reason to continue pursuing any effort in developing good sample applications.
Maybe a time will come when Zugg can spend more time on zApp but right now he has more important things. As he stated in another post, there are like 12 people interested in zApp (and I’m still sure he counted me twice.) It actually pains me to see this. Zugg put countless hours into the development of a *very* awesome tool. To me, he has proven that he is a master programmer as well as an ingenious developer. However, it seems that there is less time in the day, anymore, and we have to make decisions on how we are to spend that limited time. I believe he has chosen wisely under the current circumstances.
My best of wishes to Zugg and his business and the zMUD community. One day I hope to see zApp become a thriving community but until then, my best wishes to all. |
|
|
|
|
|
|
|
|
You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum
You cannot vote in polls in this forum
|
|
