' numBA.vbs -- preprocessor / translator
'
' Convert un-numbered, structured basic script to numbered source
' suitable for vintage interpreters
'
' Supports several constructs of modern BASIC such as:
'   No Line Numbers Required
'   LABEL <labelname>
'   GOTO/GOSUB <labelname>
'   WHILE/WEND
'   DO WHILE/LOOP
'   REPEAT/UNTIL
'   DO/LOOP UNTIL
'   Mulit-line IF/THEN/ELSEIF/ELSE/ENDIF
'   SUB Name(A1, S$)/ENDSUB
'   CALL <SubName> [parameters, ...]
'   Recursion
'   Long Variable Names
'   MACRO definitions
'   DEF FN, CONST simulated as macros
'   INCLUDE files
'   FUNCTIONS
'   Local variables
'
' primes.do is Sample Source
' primes.ba is Sample Output
'
' TODO:
'   Bugs in single line IF/THEN/ELSE (partial)
'   SELECT/CASE/ENDSELECT (partial)
'   EXIT, LEAVE, BREAK, CONTINUE (loop exiting/skipping)
'   Join Lines Option (partial)
'   Compress Spaces Option
'   Kludge: compiler attempt to compute label destinations in comments
'   Better Variable Translation
'   Conditional Compilation / System Variables
'   Map VBScript Functions/Keywords to M100 Basic (Macro Include File)
'   Bug: Translator may overwrite users 2 char variable names
'   String Stack Manipulation may require garbage collection
'   Bug: nested user function calls, problem with stack frame
'   Language Specific Translation Macros
'   Better output options, specify outfile, save symbols
'
'   Compile the Compiler
'
' The reference BASIC's were VBScript (src) to TRS-80 Model 100 Basic (dst)
' May work with other BASIC languages, for instance: QBasic to GW-Basic
'
' CHANGES:
'   2010-04-12  Fixed ELSEIF Bug
'   2010-04-13  Fixed "[" in quotes bug
'   2010-04-13  CALL/SUB/ENDSUB with parameters
'   2010-04-14  Fixed WEND Bug
'   2010-04-16  Now handles single-line IF/THEN/ELSE better
'   2010-06-17  Release as v0.600
'   2010-06-20  Fixed END SUB w/ zero parameters v0.601
'   2010-09-04  added MACRO; DEF FN & CONST (simulated as macro)
'   2010-09-08  fixed bug in error display for cmdline args
'   2010-09-09  added REM INCLUDE "filename"
'   2010-09-09  added [+]<num> option to OPT LINE for synching line numbers to an arithmetic pattern
'   2010-09-10  improved handling of nested expresssions
'   2010-09-11  prescan for SUB/FUNC names
'               Smart call checking, no CALL keyword required
'               fixed "On Error GoTo 0" bug: workaround - LABEL 0 always translates to line 0
'   2010-09-17  User Functions (partial)
'               Local Variables
'   2010-09-18  Release as v0.700

Option Explicit

Const Alpha     = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
Const Digit     = "0123456789"

' Operator Characters in VBScript but not in Model-100 Basic
Const opsVBS          = "&."

Const KeyList   = " LABEL WHILE WEND REPEAT UNTIL DO LOOP EXIT GOSUB RETURN GOTO ON IF THEN ELSE ELSEIF ENDIF FOR NEXT REM DATA RESTORE CALL SUB ENDSUB FUNC FUNCTION ENDFUNC END SELECT CASE PRINT INPUT DIM DATA TO STEP SOUND POKE CLS PRINT@ MENU LINE PSET PRESET POKE LINEINPUT BEEP OUT INP SYSCALL CLOSE RESUME OPEN AS DEF FN ON READ "

Const VBKeyList = " SET OPTION EXPLICIT ECHO QUIT EXIT BYREF "

Const FunList   = " ABS INT SIN COS TAN SQR LEFT$ RIGHT$ MID$ VAL TIME$ DATE$ DAY$ PEEK INKEY$ ASC CHR$ RND STRING LEN INSTR CINT CSTR CDBL MAXFILES VARPTR"

Const VBFunList = " WSCRIPT CREATEOBJECT LEFT RIGHT MID "

Const OpList    = " + - * / \ ^ MOD < > = <> >= <= AND OR XOR EQV IMP NOT "
Const VBOplist  = " . & "

Dim AlphaNum
AlphaNum        = Alpha & Digit

Const forReading = 1, forWriting = 2, forAppending = 8

Dim optSource   : optSource    = 1  ' Include original source as comments: 0=None, 1=Partial, 2=Full
Dim optIndent   : optIndent    = 2  ' Indent number of spaces
Dim optComments : optComments  = 1  ' Retain original comments
Dim optVBscript : optVBScript  = 1  ' Translate VBScript operators: & .
Dim optBlankLns : optBlankLns  = 0  ' Preserve Blank Lines
Dim optTranVars : optTranVars  = 1  ' Translate Variables
Dim optLineNums : optLineNums  = 0  ' Convert leading line numbers to labels
Dim optReqSpaces: optReqSpaces = 1  ' Require spaces after keywords
Dim optPass1    : optPass1     = 0  ' Show Compiler Pass1: 0=Hide 1=Show, 2=Stop
Dim optSrcOpts  : optSrcOpts   = 1  ' Allow Opts in source comments
Dim optIntegers : optIntegers  = 0  ' Don't recognize FP numbers
Dim optJoin     : optJoin      = 0  ' Join Lines with colons
Dim optSplitIF  : optSplitIF   = 0  ' By default don't split lines after IF
Dim optSimDef   : optSimDef    = 1  ' simulate DEF FN with macros
Dim optErrThr   : optErrThr    = -1 ' Number of errors before stopping (-1 = no stop)

Dim linenum, lineinc, linetmp, linelst
linenum = 1000: lineinc = 10: linelst = 0

Dim ctrlstk(20), ctrllin(20), ctrlptr
ctrlptr = 0: ctrlstk(0) = "BOTTOM"

Dim tokens(40), toktyp(40), tkcount
Dim llabel(500), labdst(500), labcount
Dim vars(250), vartran(250), vartbl(36), varcount
Dim locals(20), locidx(20), loccount, parScnt, parNcnt, locScnt, locNcnt

' Current Func/Sub Name
Dim curproc, insub

Dim nfs, nfn    ' tracks function count in expression: string, numeric
Dim fcd         ' function call depth
nfs = 0: nfn = 0: fcd = 0

Dim dMacros
Set dMacros = CreateObject("Scripting.Dictionary")
dMacros.CompareMode = vbTextCompare

Dim dFuncs
Set dFuncs = CreateObject("Scripting.Dictionary")
dFuncs.CompareMode = vbTextCompare

Dim dSubs
Set dSubs = CreateObject("Scripting.Dictionary")
dSubs.CompareMode = vbTextCompare

Dim aFiles, aFileH
Set aFiles = CreateObject("System.Collections.ArrayList")
Set aFileH = CreateObject("System.Collections.ArrayList")

Dim buffer, buflvl

Dim oFS, oInput, sFName, pass1
Set oFS = CreateObject("Scripting.FileSystemObject")

If Wscript.Arguments.Count > 1 Then
    iCurLine = 0
    tkcount = tokenize("REM OPT " & WScript.Arguments(1), 1, tokens)
    do_opt
End If

Set pass1 = CreateObject("System.Collections.Arraylist")

IncludeFile WScript.Arguments(0)

Dim sLine, iCurLine, i
Dim errcount

errcount = 0

' Pass 1

iCurLine = 0
Do While aFiles.Count > 0
    Do While Not oInput.AtEndOfStream
        i = 1
        sLine = ""
        Do
            iCurLine = iCurLine + 1
            If Right(sLine, 1) = "_" Then
                sLine = Left(sLine, Len(sLine) - 1) & " " & oInput.ReadLine
            Else
                sLine = oInput.ReadLine
            End If
        Loop Until Right(sLine, 1) <> "_" Or oInput.AtEndOfStream
        If sLine = "" And optBlankLns Then Output "'"
        Do While i <= Len(sLine)
            tkcount = Tokenize(sLine, i, tokens)
            ProcessTokens
        Loop
    Loop
    oInput.Close
    aFileH.RemoveAt(aFileH.Count - 1)
    aFiles.RemoveAt(aFiles.Count - 1)
    If optSource > 0 And optComments And aFiles.Count > 0 Then OutPut "REM -- ENDFILE """ & sFName & """"
    If aFiles.Count > 0 Then
        sFName = aFiles(aFiles.Count - 1)
        Set oInput = aFileH(aFileH.Count - 1)
    End If
Loop

Do While ctrlptr > 0
    errmsg "Incomplete " & ctrlstk(ctrlptr)
    ctrlptr = ctrlptr - 1
Loop

If optPass1 Then
    WScript.Echo
    WScript.Echo "--- End of Pass 1 ---"
    WScript.Echo
    If optPass1 > 1 Then WScript.Quit
End If

' Pass 2
For i = 0 to pass1.count - 1
    iCurLine = i + 1
    WScript.Echo Pass2Line(pass1(i))
Next

' Place holder for branch past end of program
' possible if no code is required for end of control structure
If labcount > 0 Then
    If labdst(labcount - 1) >= linenum Then
        WScript.Echo linenum & " REM END"
    End If
End If

' End of Main Routine
WScript.Quit

' Pass0 Quick Search for Func/Sub Defs
Sub ScanRoutines(fnam)
    Dim fhdl, src, re, mats, x
   
    Set fhdl = oFS.OpenTextFile(fnam)
    src = fhdl.ReadAll
    fhdl.Close
   
    Set re = New RegExp
   
    re.IgnoreCase = True
    re.Global = True
    re.MultiLine = False

    re.Pattern = "(?:^|\n)\s*\bFunc(?:tion)?\b\s+(\w+\$?)([^\n]*)"
    Set mats = re.Execute(src)
   
    For Each x in mats
        ' WScript.Echo ">>> Func: " & x.submatches(0) & " >>> " & x.SubMatches(1)
        If Not dSubs.Exists(x.SubMatches(0)) Then
            dFuncs.Add x.SubMatches(0), x.SubMatches(1)
        Else
            errmsg "Function redefined: " & x.SubMatches(0)
        End If
    Next
   
    re.Pattern = "(?:^|\n)\s*\bSub?\b\s+(\w+)([^\n]*)"
    Set mats = re.Execute(src)
    For Each x in mats
        ' WScript.Echo ">>> Sub: " & x.submatches(0) & " >>> " & x.SubMatches(1)
        If Not dSubs.Exists(x.SubMatches(0)) Then
            dSubs.Add x.SubMatches(0), x.SubMatches(1)
        Else
            errmsg "Subroutine redefined: " & x.SubMatches(0)
        End If
    Next   
End Sub

' Pass2 Line Scan Function
Function Pass2Line(text)
    Dim i, s, lbl, idx, ch
   
    If reTest(text, "^\d+\s+('|REM )") Then
        Pass2Line = text
        Exit Function
    End If
    i = 1: s = ""
    Do While i <= Len(text)
        s = s & ScanChars(text, """[", i, -1, True)
        ch = Mid(text, i, 1)
        If ch = """" Then
            i = i + 1
            lbl = scanChars(text, """", i, -1, True)
            i = i + 1
            s = s & """" & lbl & """"
        End If
        If ch = "[" Then
            lbl = scanChars(text, "]", i, -1, True) & "]"
            idx = LabelIdx(lbl)
            If idx <> -1 Then
                s = s & labdst(idx)
            Else
                s = s & lbl
                errpos text, i + 2 - Len(lbl)
                errmsg "Unknown Label: " & lbl
            End If
            i = i + 1
        End If
        If ch <> """" and ch <> "[" Then
            s = s & Mid(text, i, 1)
        End If
    Loop
    Pass2Line = s
End Function

Sub IncludeFile(fnam)
    Dim fhdl
 
    ScanRoutines fnam

    On Error Resume Next 
 
    Set fhdl = oFS.OpenTextFile(fnam)
 
    If err <> 0 Then
        errmsg "Could not Include file: """ & fnam & """"
    Else
        aFiles.Add fnam
        aFileH.Add fhdl
        sFName = fnam
        Set oInput = fhdl
    End If
     
    On Error GoTo 0
 
    Set fhdl = Nothing
 
End Sub

' Parsing Routines

Sub ProcessTokens()
    If tkcount > 0 Then
        Select Case tokens(0)
            Case "LABEL"   :    do_LABEL
            Case "WHILE"   :    do_WHILE
            Case "WEND"    :    do_WEND
            Case "REPEAT"  :    do_REPEAT
            Case "UNTIL"   :    do_UNTIL
            Case "DO"      :    do_DO
            Case "LOOP"    :    do_LOOP
            Case "EXIT"    :    do_EXIT
            Case "GOSUB"   :    do_GOSUB
            Case "GOTO"    :    do_GOTO
            Case "ON"      :    do_ON
            Case "IF"      :    do_IF
            Case "ELSE"    :    do_ELSE
            Case "ELSEIF"  :    do_ELSEIF
            Case "ENDIF"   :    do_ENDIF
            Case "FOR"     :    do_FOR
            Case "NEXT"    :    do_NEXT
            Case "REM"     :    do_REM
            Case "DIM"     :    do_DIM
            Case "DATA"    :    do_DATA
            Case "RESTORE" :    do_RESTORE
            Case "CALL"    :    do_CALL
            Case "SUB"     :    do_SUB
            Case "ENDSUB"  :    do_ENDSUB
            Case "FUNC"    :    do_FUNC
            Case "FUNCTION":    do_FUNC
            Case "ENDFUNC" :    do_ENDFUNC
            Case "END"     :    do_END
            Case "SELECT"  :    do_SELECT
            Case "CASE"    :    do_CASE
            Case "RETURN"  :    do_RETURN
            Case "DEF"     :    do_MACRO
            Case "MACRO"   :    do_MACRO
            Case "CONST"   :    do_MACRO
        Case Else
            If Left(tokens(0), 1) = """" Then
                Output Dumptokens()
            ElseIf Left(tokens(0), 1) = "'" Then
                If optComments Then Output Dumptokens()
            ElseIf dSubs.Exists(tokens(0)) Then
                do_CALL
            Else
                If optJoin Then
                    If buffer <> "" Then
                        buffer = buffer & ":"
                    Else
                        buflvl = ctrlptr
                    End If
                    buffer = buffer & AllExpressions(0, "")
                    If labcount > 0 And buffer <> "" Then
                        If labdst(labcount - 1) >= linenum Then
                            Output ""
                        End If
                    End If
                Else
                    Output AllExpressions(0, "")
                End If
            End If
        End Select
    Else
        If optBlankLns Then Output "'"
    End If
End Sub

' Parse a line of basic
Function Tokenize(text, byRef i, byRef a)
 
    Dim l, ch, tok, tmp, typ, stk, n, mark
    Dim ltxt, stxt, rtxt, svi
 
    ' typ = token type: 0 = ???, 1 = ident, 2 = num, 3 = stringlit , 4 = oper, 5 = comment, 6 = label, 7 = function/array, 8 = Other

 
    n = 0: a(n) = "__NULL__"
    tok = "": typ = 0: stk = "": n = 0: l = Len(text)
    Do While i <= l
        mark = i: ch = Mid(text, i, 1)
        If ch = " " Or ch = Chr(9) Then
            i = i + 1
            ScanChars text, " " + Chr(9), i, -1, False
            mark = i
        ElseIf InStr(Alpha & "_", ch) Then
            ' Build Identifier or Literal
            i = i + 1
            If optReqSpaces Then
                tok = ch & ScanChars(text, AlphaNum & "_", i, -1, False)
            Else
                tok = ScanKeyChars(text, AlphaNum & "_", i, -1, False)
            End If
            tmp = ScanChars(text, "$%#!@", i, 1, False)
            tok = tok & tmp
            typ = 1
        
            If isOperator(UCase(tok)) Then typ = 4
            If isFunction(UCase(tok)) or dFuncs.Exists(tok) Then typ = 7
            ' If Mid(text,i,1) = "(" Then typ = 7
        
        ElseIf InStr(Digit, ch) Then
            ' Build a Number

            If tok = "-" or tok = "+" Then
                ' possibly prefix sign operator
            End If

            i = i + 1
            tok = ch & ScanChars(text, Digit, i, -1, False)    ' digits

            ' Allow Numbered Source
            If n = 0 Then
                If n = 0 And optLineNums = False Then
                    ErrPos text, Len(tok) + 1
                    ErrMsg "Line Numbers not supported without ""OPT LINENUM"""
                Else
                    a(n) = "LABEL"
                    a(n + 1) = tok
                    n = n + 2
                    ' linenum = CInt(tok)
                    ' tok = ""
                    Exit Do
                End If
            End If
   
            If Not optIntegers Then
                tmp = ScanChars(text, ".", i, 1, False)            ' decimal
                If tmp = "." Then tok = tok & "."
                tmp = ScanChars(text, Digit, i, -1, False)         ' fraction
                tok = tok & tmp
      
                tmp = ScanChars(text, "EeDd", i, 1, False)         ' exponent single/double
                If tmp <> "" Then
                    tok = tok + tmp
      
                    tmp = ScanChars(text, "+-", i, 1, False)       ' exponent sign
                    tok = tok & tmp
  
                    tmp = ScanChars(text, Digit, i, -1, False)     ' exponent digits
                    tok = tok & tmp
                End If
            End If
            typ = 2
        ElseIf ch = "#" Then
            ' scan file handle tokens #1, #10 etc.
            i = i + 1
            tok = ch & ScanChars(text, Digit, i, -1, False)
            typ = 8
        ElseIf ch = "(" Then
            i = i + 1
            stk = stk & ch
            tok = ch
            ' if no space between previous identifier then
            ' function call or array
            typ = 8
        ElseIf ch = ")" Then
            i = i + 1
            tok = ch
            If Right(stk, 1) = "(" Then
                stk = Left(stk,Len(stk) - 1)
            Else
                ErrPos text, i
                ErrMsg "Mismatched Parentheses"
            End If
        ElseIf  ch = "," Then
            ' introduce expression list
            i = i + 1
            tok = ch
            typ = 8
        ElseIf  ch = ";" Then
            tok = ch
            i = i + 1
            If stk <> "" Then
                ErrPos text, i
                ErrMsg "Semicolon not valid in expression"
            End If
            typ = 8
        ElseIf InStr("+-*/\^|" & opsVBS, ch) > 0 Then
            ' Simple Operator
            tok = ch
            typ = 4
            i = i + 1
        ElseIf ch = ">" or ch = "<" Then
            i = i + 1
            tok = ch & ScanChars(text, "=", i, 1, False)
            typ = 4
        ElseIf ch = "=" Then
            i = i + 1
            tok = "="
            typ = 4
            ' Assignment or Operator
        ElseIf ch = Chr(34) Then
            ' Double Quote String
            i = i + 1
            tok = Chr(34) & ScanChars(text, Chr(34), i, -1, True) & Chr(34) 'accept anything but a quote
            If i > l Then
                ErrPos text, i
                ErrMsg "Unterminated Literal String"
            Else
                i = i + 1
            End If
            typ = 3
        ElseIf ch = "'" Then
            i = i + 1
            tok = "'" & ScanChars(text, "", i, -1, True)  ' accept anything
            typ = 5
        ElseIf ch = ":" Then
            If stk <> "" Then
                ErrPos text, i
                ErrMsg "Expression incomplete. Expected "","" or "")"""
            Else
                i = i + 1
                If a(0) = "IF" Then
                    If optSplitIF Then
                        ErrPos text, i + 1
                        ErrMsg "Warning: ':' following IF/THEN"
                        Exit Do
                    Else
                        tok = ":"
                        typ = 8
                    End If
                Else
                    Exit Do
                End If
            End If
        Else
            i = i + 1
            ErrPos text, i
            ErrMsg "Unexpected Character"
        End If
 
        If tok <> "" Then
       
            ' This code should probably go to Expressions/AllExpression
            If typ = 2 or (typ = 1 and i > l) Then
                If n > 0 Then
                    If InStr(" THEN ELSE GOTO GOSUB RESUME RESTORE ", " " & tokens(n - 1 & " ")) > 0 Then
                        ' ErrPos text, i - Len(tok) + 1
                        ' WSCript.Echo ">>> Label Identified"
                        If tok <> "0" Then tok = "[" & tok & "]"
                        typ = 6
                    End If
                End If
            End If
        
            ' Identify Macro and perform substitutions
            If dMacros.Exists(tok) and InStr(" REM ' ", " " & tokens(0) & " ") = 0 Then
                ' Macro identified: Scan Past Parameters, adjust the "stream" and resume
            
                'ltxt = Left(text, i - Len(tok) - 1)
                ltxt = Left(text, mark - 1)
                stxt = MacroSub(text, i, tok)
                rtxt = Mid(text, i)
                text = ltxt & stxt & rtxt
                i = Len(ltxt) + 1: l = Len(text)
            Else
                If InStr("""'", Left(tok, 1)) = 0 Then
                    a(n) = UCase(tok)
                Else
                    a(n) = tok
                End If
                toktyp(n) = typ
 
                n = n + 1
            End If
            tok = ""
            typ = 0

        End If
   
    Loop

    If tok <> "" Then
        a(n) = tok
        toktyp(n) = typ
        n = n + 1
        a(n) = "__NULL__"
    End If
 
    If stk <> "" Then
        ErrPos text, i
        ErrMsg "Mismatched Parentheses"
    End If

    Tokenize = n
End Function

Function MacroSub(text, byref i, mname)
    Dim ch, subtxt, l, stk, param, n
 
    subtxt = dMacros(mname)
    If Mid(text,i,1) = "(" Then
        'Handle Parameters
        l = Len(text): i = i + 1: stk = 0: n = 1 : param = ""
        Do While i <= l
            param = param & ScanChars(text, "(),", i, -1,True)
            If i <= l Then
                ch = Mid(text, i, 1)
                If stk > 0 Then
                    param = param & ch
                    If ch = ")" Then stk = stk - 1
                    If ch = "(" Then stk = stk + 1
                Else
                    If ch = "(" Then
                        stk = stk + 1
                        param = param + ch
                    End If
                    If ch = "," or ch = ")" Then
                        subtxt = replace(subtxt, "_PARAM_" & n & "_", param)
                        param = ""
                        n = n + 1
                    End If
                    If ch = ")" Then
                        i = i + 1
                        Exit Do
                    End If
                End If
                i = i + 1
            Else
                errmsg "Mismatched Parentheses" & ":" & ch
            End If
        Loop     
    End If
    MacroSub = subtxt
End Function

Function ScanChars(stmt, byRef allow, byRef i, mx, rev)
' Return characters scanned with legal chars in allow
' stmt  = string to scan
' allow = list of legal chars
' i     = start pos (altered)
' mx    = mx chars to return
' rev   = reverses sense of allowed chars to disallowed

    Dim c, l, p, result
 
    result = ""
    l = Len(stmt)
    Do While i <= l And (Len(Result) < mx Or mx < 0)
        c = Mid(stmt, i, 1)
        p = InStr(allow, c)
        If (p = 0) Xor rev Then Exit Do
        i = i + 1
        result = result & c
    Loop
    ScanChars = Result
End Function

Function ScanKeyChars(stmt, byRef allow, byRef i, mx, rev)

    Dim c, l, p, result
 
    result = ""
    i = i - 1 ' back up to include lead char
    l = Len(stmt)
    Do While i <= l And (Len(Result) < mx Or mx < 0)
        c = Mid(stmt, i, 1)
        p = InStr(allow, c)
        If (p = 0) Xor rev Then Exit Do
        i = i + 1
        result = result & c
        If IsKeyWord(result) Then Exit Do
        If IsFunction(result) Then Exit Do
    Loop
    ScanKeyChars = Result
End Function

' Parse a set of Expressions from token i to term
Function AllExpressions(i, term)
    Dim s, e, t
    s = "": nfn = 0: nfs = 0
    Do While i < tkcount And tokens(i) <> term
        e = Expression(i)
        If e = "" Then
            If i < tkcount Then
                e = tokens(i)
                i = i + 1
            End If
        End If
        If e <> "" Then
            If s <> "" and e <> "," Then s = s & " "
            s = s & e
        End If
    Loop
    AllExpressions = s
End Function

Function Expression(byref i)
    Dim s, stk, tok, tt, nn, ns, params, e, pop, off
   
    s = "": tt = 0: ns = 0: nn = 0
    stk = 0
    Do While i < tkcount
        tok = tokens(i)
        If IsKeyWord(tok) Then Exit Do
        If tok = "(" Then stk = stk + 1
        If tok = ")" Then
            If stk = 0 Then Exit Do
            stk = stk - 1
        End If
        If tok = "," And stk < 1 Then Exit Do
      
        ' typ = token type: 0 = ???, 1 = ident, 2 = num, 3 = stringlit , 4 = oper, 5 = comment, 6 = label, 7 = function/array, 8 = Other

       
        Select Case toktyp(i)
            Case 1
                ' Identifier
                If optTranVars And Not isFunction(tok) And Not dFuncs.Exists(tok) Then
                    If tt = 1 Then s = s & " "
                    s = s & TransVar(tok)
                Else
                    s = s & tok
                End If
            Case 4
                ' Operator
                If InStr(Alpha, Left(tok,1)) > 0 Then
                    If s <> "" And Right(s, 1) <> " " Then s = s & " "
                    s = s & tok & " "
                Else
                    s = s & tok
                End If
            Case 5
                ' Comment
                s = s & tok
                i = i + 1
                Exit Do
                ' errmsg "Expect expression term - Found: " & tok
            Case 7
                ' Function / Array (allow "," at this stk level)
                If dFuncs.Exists(tok) Then
                   
                    i = i + 1
                    If Right(tok, 1) = "$" Then
                        nfs = nfs + 1
                    Else
                        nfn = nfn + 1
                    End If
                    params = ""
                    fcd = fcd + 1
                    If tokens(i) = "(" Then
                        ns = 0: nn = 0
                        Do
                            i = i + 1
                            If tokens(i) <> ")" Then
                                If params <> "" Then params = params & ":"
                                e = Expression(i)
                                If InStr(e, """") > 0 Or InStr(e, "$") > 0 Then
                                    ns = ns + 1
                                    params = params & "ZS$(ZQ+" & ns & ")=" & e
                                Else
                                    nn = nn + 1
                                    params = params & "ZS(ZP+" & nn & ")=" & e
                                End If
                                If tokens(i) <> "," And tokens(i) <> ")" Then errmsg "Expected: Parameter List - Found: " & tokens(i)
                            End If
                        Loop Until tokens(i) = ")"
                    End If
                    fcd = fcd - 1

                    If params <> "" Then params = params & ":"
                    If Right(tok, 1) <> "$" Then
                        Output params & "ZP=ZP+" & nn + 1 & ":GOSUB [" & tok & "]"
                    Else
                        Output params &  "ZQ=ZQ+" & ns + 1 & ":GOSUB [" & tok & "]"
                    End If
                   
                    If Right(tok, 1) = "$" Then
                        off = nfs - 1
                        s = s & "ZS$(ZQ+" & off & ")"
                    Else
                        off = nfn - 1
                        s = s & "ZS(ZP+" & off & ")"
                    End If
                Else
                    If optTranVars And Not isFunction(tok) Then
                        s = s & TransVar(tok)
                    Else
                        s = s & " " & tok
                    End If
                End If
        Case Else
            s = s & tok
        End Select
        If stk < 0 Then
            errmsg "Expression - Mismatched Parentheses: " & s & " " & stk
            ' stk = stk + 1
        End If
        tt = toktyp(i)
        i = i + 1
    Loop
   
    If nfn + nfs > 0 And (stk < 0 Or i >= tkcount) Then
        pop = ""
        If nfn > 0 Then pop = "ZP=ZP-" & nfn
        If nfs > 0 Then
            If pop <> "" Then pop = pop & ":"
            pop = pop & "ZQ=ZQ-" & nfs
        End If
        If Left(pop,1) = ":" Then pop = Mid(pop,2)
        Output pop
        nfn = 0: nfs = 0
    End If
    Expression = s
End Function

' Parse an Expression starting at token n
Function OldExpression(byref n)
    Dim s
    s = ""
    Do While n < tkcount
        If isKeyword(tokens(n)) Then
            ' End of Expression
            Exit Do
        ElseIf tokens(n) = "," Then
            Exit Do
        ElseIf isFunction(tokens(n)) Then
            s = s & tokens(n)
            n = n + 1
        ElseIf isOperator(tokens(n)) Then
            If Len(tokens(n)) > 2 Then
                s = s & " " & tokens(n) & " "
            Else
                s = s & tokens(n)
            End If
            n = n + 1
        ElseIf optVBScript And isVBKeyword(tokens(n)) Then
            s = s & tokens(n)
            n = n + 1
        ElseIf InStr("()", tokens(n)) Then
            s = s & tokens(n)
            n = n + 1
        ElseIf toktyp(n) = 2 Then
            s = s & tokens(n)
            n = n + 1
        ElseIf toktyp(n) = 1 Then
            If optTranVars Then
                s = s & TransVar(tokens(n))
            Else
                s = s & tokens(n)
            End If
            n = n + 1
        Else
            s = s & tokens(n)
            n = n + 1
        End If
    Loop
    OldExpression = s
End Function

Function isOperator(tk)
    If optVBScript Then
        isOperator = (InStr(" & ." & OpList, " " & tk & " ") > 0)
    Else
        isOperator = (InStr(OpList, " " & tk & " ") > 0)
    End If
End Function

Function isKeyword(tk)
    If optVBScript Then
        isKeyword = (InStr(VBKeylist & " " &KeyList, " " & tk & " ") > 0)
    Else
        isKeyword = (InStr(KeyList, " " & tk & " ") > 0)
    End If
End Function

Function isVBKeyword(tk)
    isVBKeyword = (InStr(VBKeyList, " " & tk & " ") > 0)
End Function

Function isFunction(tk)
    If optVBScript Then
        isFunction = (InStr(FunList & VBFunList, " " & tk & " ") > 0)
    Else
        isFunction = (InStr(FunList, " " & tk & " ") > 0)
    End If
End Function

' General Functions / Subroutine

Sub Output(sText)
    Dim tmpctrl, sWork, f

    f = 0
    Do While f = 0
        If ctrlptr < 0 Then
            errmsg "Control Stack Underflow - fatal error"
            WScript.Quit
        End If
   
        tmpctrl = ctrlptr
        If buffer <> "" Then
            sWork = buffer
            buffer = ""
            ctrlptr = buflvl
        Else
            If sText = "" Then Exit Do
            sWork = sText
            f = 1
        End If
   
        If Left(ctrlstk(ctrlptr), 6) = "ELSEIF" Then ctrlptr = ctrlptr - 1
   
        If optIndent Then
            If optPass1 Then WScript.Echo linenum, String(ctrlPtr * optIndent, " ") & sWork
            pass1.Add linenum & " " & String(ctrlPtr * optIndent, " ") & sWork
        Else
            If optPass1 Then WScript.Echo linenum, sWork
            pass1.Add linenum & " " & sWork
        End If
        ctrlptr = tmpctrl
        linelst = linenum
        linenum = linenum + lineinc
    Loop
End Sub

Sub Flush
    If buffer <> "" Then Output("")
End Sub

Function DumpTokens
    Dim i, s
    s = ""
    For i = 0 to tkcount - 1
        s = s & tokens(i) & " "
    Next
    DumpTokens = s
End Function

Function Dump(a, b)
    Dim i, s
    s = ""
    i = a
    Do While i <= tkcount - 1 And tokens(i) <> b
        s = s & tokens(i) & " "
        i = i + 1
    Loop
    Dump = s
End Function

' Do_<Keyword> Subroutines - Code Production

Sub do_OPT
    Dim i, tmp: i = 2
    Do While i < tkcount
        Select Case tokens(i)
            Case "LINE"
                Stop
                If tokens(i+1) = "+" Then
                    i = i + 1
                    tmp = 0 + ((linenum + tokens(i + 1)) \ tokens(i + 1)) * tokens(i + 1)
                Else
                    tmp = 0 + tokens(i + 1)
                End If
                If tmp <= linelst Then
                    errmsg "Warning - New line number < previous"
                End If
                linenum = tmp
                i = i + 1
            Case "INC"
                lineinc = 0 + tokens(i + 1)
                i = i + 1
            Case "SOURCE"
                optSource = 0 + tokens(i + 1)
                i = i + 1
            Case "NOSOURCE"
                optSource = 0
            Case "COMMENTS"
                optComments = True
            Case "NOCOMMENTS"
                optComments = False
            Case "VBSCRIPT"
                optVBScript = True
            Case "NOVBSCRIPT"
                optVBScript = False
            Case "BLANKLINES"
                optBlankLns = True
            Case "NOBLANKLINES"
                optBlankLns = False
            Case "TRANS"
                optTranVars = True
            Case "NOTRANS"
                optTranVars = False
            Case "INDENT"
                optIndent = 0 + tokens(i + 1)
                i = i + 1
            Case "NOINDENT"
                optIndent = 0
            Case "REQSPACES"
                optReqSpaces = True
            Case "NOREQSPACES"
                optReqSpaces = False
            Case "PASS1"
                i = i + 1
                If tokens(i) = "SHOW" Then
                    optpass1 = 1
                ElseIf tokens(i) = "STOP" Then
                    optpass1 = 2
                ElseIf tokens(i) = "HIDE" Then
                    optpass1 = 0
                Else
                    optPass1 = 0 + tokens(i + 1)
                End If
            Case "SRCOPTS"
                optSrcOpts = True
            Case "NOSRCOPTS"
                optSrcOpts = False
            Case "INTEGER"
                optIntegers = True
            Case "FLOAT"
                optIntegers = False
            Case "JOIN"
                optJoin = True
            Case "NOJOIN"
                optJoin = False
            Case "SPLITIF"
                optSplitIF = True
            Case "NOSPLITIF"
                optSplitIF = False
            Case "LINENUM"
                optLineNums = True
            Case "NOLINENUM"
                optLineNums = False
        Case Else
            ErrMsg "Unknown OPT -- """ & tokens(i) & """"
        End Select
        i = i + 1
    Loop
End Sub

Sub do_LABEL
    Flush
    ' add to symbol table
    If optSource > 0 Then Output "REM LABEL " & Tokens(1)
    LabelSet "[" & tokens(1) & "]", linenum
End Sub

Sub do_DO
    Flush
    If tkcount >= 2 and tokens(1) = "WHILE" Then
        do_WHILE
    ElseIf tkcount = 1 Then
        do_REPEAT
    Else
        errmsg "Unknown DO construct"
    End If
End Sub

Sub do_LOOP
    If tkcount >= 2 and tokens(1) = "UNTIL" Then
        do_UNTIL
    ElseIf tkcount = 1 Then
        do_WEND
    End If
End Sub

Sub do_WHILE
    Flush
    If optSource Then Output "REM " & DumpTokens()
    linetmp = linenum
    If tokens(1) = "WHILE" Then
        output "IF NOT " & Expression(2) & " THEN [_WEND" & linenum & "]"
    Else
        output "IF NOT " & Expression(1) & " THEN [_WEND" & linenum & "]"
    End If
    ctrlPush "WHILE", linetmp
End Sub

Sub do_WEND
    Flush
    If ctrlstk(ctrlptr) <> "WHILE" Then Errmsg "Unexpected WEND: " & dumpCtrlStk()
    ' check ctrl stack and get back ref
    CtrlPop
    If optSource > 1 Then Output "REM " & DumpTokens()
    Output "GOTO " & ctrllin(ctrlptr + 1)
    LabelSet "[_WEND" & ctrllin(ctrlptr + 1) & "]", linenum
End Sub

Sub do_REPEAT
    Flush
    ' add to symbol table / ctrl stack
    If optSource Then Output "REM " & DumpTokens()
    ctrlPush "REPEAT", linenum
End Sub

Sub do_UNTIL
    Flush
    ' check ctrl stack and get back ref
    If ctrlstk(ctrlptr) <> "REPEAT" Then Errmsg "Unexpected WEND"
    CtrlPop
    If optSource > 1 Then Output "REM " & DumpTokens()
    If tokens(1) = "UNTIL" Then
        Output "IF NOT " & Expression(2) & " THEN " & ctrllin(ctrlptr + 1)
    Else
        Output "IF NOT " & Expression(1) & " THEN " & ctrllin(ctrlptr + 1)
    End If
End Sub

Sub do_EXIT
    Output DumpTokens()
End Sub

Sub do_GOSUB
    If tkcount > 2 Then errmsg "Expected End of Statement - Found: " & tokens(2)
    If optSource > 1 Then Output "REM " & Dumptokens()
    If toktyp(tkcount - 1) <> 6 Then
        Output "GOSUB " & "[" & tokens(tkcount - 1) & "]"
    Else
        Output "GOSUB " & tokens(tkcount - 1)
    End If
End Sub

Sub do_GOTO
    If optSource > 1 Then Output "REM " & Dumptokens()
    If toktyp(1) <> 6 Then
        Output "GOTO " & "[" & tokens(1) & "]"
    Else
        Output "GOTO " & tokens(1)
    End If
End Sub

Sub do_ON
    ' ON N GOTO/GOSUB
    ' For each symbol in list: lookup
    Output Dumptokens()
End Sub

Sub do_IF
    Dim n, e, r1, r2
    If tokens(tkcount - 1) = "THEN" Then
        Flush
        If optSource > 1 Then Output "REM " & Dumptokens()
        linetmp = linenum
        ' Output "IF NOT " & Expression(1) & " THEN [_NOTIF" & linenum & "]"
        Output "IF NOT " & AllExpressions(1, "THEN") & " THEN [_NOTIF" & linenum & "]"
        ctrlPush "IF", linetmp
    Else
        n = 1
        e = AllExpressions(n, "THEN")
        r1 = AllExpressions(n, "ELSE")
        r2 = AllExpressions(n, "")
        Output "IF " & e & " " & r1 & " " & r2
        ' Output AllExpressions(0, "")
    End If
End Sub

Sub do_ELSE
    Flush
    If ctrlstk(ctrlptr) <> "IF" And ctrlstk(ctrlptr) <> "ELSEIF" Then
        errmsg "Unexpected " & tokens(0) & ": " & DumpCtrlStk()
    End If

    Output "GOTO [_ENDIF" & ctrllin(ctrlptr) & "]"
    ctrlstk(ctrlptr) = ctrlstk(ctrlptr) & "*ELSE"
    ctrlptr = ctrlptr - 1
    If optSource Then Output "REM " & Dumptokens()
    LabelSet "[_NOTIF" & ctrllin(ctrlptr + 1) & "]", linenum
    ctrlptr = ctrlptr + 1

    If ctrlstk(ctrlptr) = "ELSEIF" Then
        CtrlPop
        LabelSet "[_ENDIF" & ctrllin(ctrlptr + 1) & "]", linenum
    End If
End Sub

Sub do_ELSEIF
    Dim tmp
 
    Flush
    If ctrlstk(ctrlptr) <> "IF" And ctrlstk(ctrlptr) <> "ELSEIF" Then
        errmsg "Unexpected " & tokens(0) & ": " & DumpCtrlStk()
    End If
  
    ' do_ELSE
    tmp = ctrllin(ctrlptr)
 
    If ctrlstk(ctrlptr) = "IF" Then
        ctrlPush "ELSEIF", linenum
    Else
        ctrllin(ctrlptr) = linenum
    End If
 
    Output "GOTO [_ENDIF" & ctrllin(ctrlptr - 1) & "]"
    ctrlptr = ctrlptr - 2
 
    If optSource Then Output "REM " & Dumptokens()
 
    ' LabelSet "[_NOTIF" & ctrllin(ctrlptr) & "]", linenum
    LabelSet "[_NOTIF" & tmp & "]", linenum

    ' do_IF
    ctrllin(ctrlptr + 2) = linenum
 
    Output "IF NOT " & Expression(1) & " THEN [_NOTIF" & linenum & "]"

    ctrlptr = ctrlptr + 2
End Sub

Sub do_ENDIF
    Flush
    If Not InStr(" IF ELSEIF IF*ELSE ELSEIF*ELSE ", " " & ctrlStk(ctrlPtr) & " " ) > 0  Then
        errmsg "Unexpected ENDIF: " & DumpCtrlStk()
    End If
    If Left(ctrlstk(ctrlptr), 6)  = "ELSEIF" Then
        CtrlPop
        LabelSet "[_ENDIF" & ctrllin(ctrlptr + 1) & "]", linenum
        If Right(ctrlstk(ctrlptr + 1), 5) <> "*ELSE" Then
            LabelSet "[_NOTIF" & ctrllin(ctrlptr + 1) & "]", linenum 
        End If
        ctrlstk(ctrlptr) = ctrlstk(ctrlptr) & "*ELSE"
    End If
    CtrlPop
    If optSource Then Output "REM ENDIF"
    If Right(ctrlstk(ctrlptr + 1),5) <> "*ELSE" Then
        LabelSet "[_NOTIF" & ctrllin(ctrlptr + 1) & "]", linenum
    End If
    LabelSet "[_ENDIF" & ctrllin(ctrlptr + 1) & "]", linenum
End Sub

Sub do_FOR
    Output "FOR " & AllExpressions(1, "")
    ctrlPush "FOR", linenum
End Sub

Sub do_NEXT
    If ctrlstk(ctrlptr) <> "FOR" Then
        errmsg "Unexpected NEXT"
        ctrlPush "FOR", -1
    End If
    ' test for multiple ctrl variables
    CtrlPop
    Output "NEXT " & AllExpressions(1, "")
End Sub

Sub do_REM
    Flush
    If tokens(1) = "OPT" And optSrcOpts Then
        do_Opt
    ElseIf tokens(1) = "INCLUDE" Then
        If toktyp(2) <> 3 Then
            errmsg "Filename must be string literal - Found:" & tokens(2)
        Else
            IncludeFile Mid(tokens(2), 2, Len(tokens(2)) - 2)
        End If
    End If
    If optComments Then Output Dumptokens()
End Sub

Sub do_DIM
    Dim i, s
    If insub > 0 Then
        If ctrlstk(ctrlptr) <> "SUB" And ctrlstk(ctrlptr) <> "FUNC" Then
            errmsg "DIM must appear at start of SUB/FUNCTION"
        End If
        Flush
        If optSource > 0 Then Output "REM " & DumpTokens()   
        AddLocalVars 1, ""
    Else
        For i = 1 to tkcount - 1
            If InStr(",()", tokens(i)) > 0 Or toktyp(i) = 2 Or toktyp(i) = 5 Then
                s = s & tokens(i)
            Else
                If toktyp(i) <> 1 Then
                    WScript.Echo Dumptokens()
                    errmsg "Expected Identifier list - found: " & tokens(i)
                Else
                    If not isFunction(tokens(i)) And Not isKeyword(tokens(i)) And Not isVBKeyword(tokens(i)) Then
                        s = s & Transvar(tokens(i))
                    End If
                End If
            End If
        Next
        Output "DIM " & s
    End If
End Sub

Sub do_DATA
    Flush
    Output Dumptokens()
End Sub

Sub do_RESTORE
    If tkcount > 1 Then
        If toktyp(1) <> 6 Then
            Output "RESTORE " & " [" & tokens(1) & "]"
        Else
            Output "RESTORE " & tokens(1)       
        End If
    Else
        Output "RESTORE"
    End If
End Sub

Sub do_RESUME
    If tkcount > 1 Then
        If toktyp(1) <> 6 Then
            Output "RESUME " & "[" & tokens(1) & "]"
        Else
            Output "RESUME " & tokens(1)       
        End If
    Else
        Output "RESTORE"
    End If
End Sub

Sub do_CALL
' Data Stack is ZS() and ZS()$
' with stack pointers ZP and ZQ
    Dim nam, i, e, s, n0, n1, p, s0
    ' handle params
    If (tkcount = 2 And tokens(0) = "CALL") OR (tkcount = 1 AND tokens(0) <> "CALL") Then
        do_GOSUB
    Else
        If UCase(tokens(0)) = "CALL" Then i = 2 Else i = 1
        nam = tokens(i - 1)
        If tokens(i) = "(" Then
            errmsg "do not use parentheses in Subroutine CALL"
        End If
        s = "": n0 = 0: n1 = 0
        Do While i < tkcount
            e = AllExpressions(i, ",")
            p = InStr(e, """") + InStr(e, "$")
            If p = 0 Then s0 = "ZS(ZP+" Else s0 = "ZS$(ZQ+"
            If InStr("(),", e) = 0 Then
                If s <> "" Then s = s & ":"
                If p = 0 Then
                    s = s & s0 & n0 & ")=" & e
                Else
                    s = s & s0 & n1 & ")=" & e
                End If
                If p = 0 Then n0 = n0 + 1 Else n1 = n1 + 1
                i = i + 1
            End If
        Loop
        s = s & ":ZP=ZP+" & n0
        If n1 > 0 Then s = s & ":ZQ=ZQ+" & n1
        Output s & ":GOSUB [" & nam & "]"
    End If
End Sub

Sub do_SUB
    Flush

    If ctrlptr <> 0 Then
        errmsg "SUB cannot be nested: " & DumpCtrlStk()
        ctrlptr = 0
    End If
    If optSource Then Output "REM " & DumpTokens()
    LabelSet "[" & tokens(1) & "]", linenum
    ctrlPush "SUB", linenum

    locNcnt = 0: locScnt = 0: parNcnt = 0: parScnt = 0
    If tkcount > 2 Then
        If tokens(2) = "(" Then
            AddLocalVars 3, ")"
        Else
            errmsg "Expected '('"
        End If
    End If
    insub = 1
    curproc = tokens(1)
End Sub

Sub AddLocalVars(i, tag)
    Dim v, n, b, stk, dv, oldlc, oln, ols

    oldlc = loccount: oln = locNcnt: ols = locScnt
    dv = "": stk = 0
    Do While i < tkcount
        If tokens(i) <> tag Then
            v = tokens(i)
            
            If stk > 0 Then
                dv = dv & v
                If v = ")" Then stk = stk - 1
            Else
                If toktyp(i) <> 1 Then
                    If v <> "," Then
                        If stk = 0 Then
                            errmsg "Expected Identifier - Found: " & v
                        Else
                            dv = dv & tokens(i)
                        End If
                    End If
                Else
                    If IsFunction(v) Or isKeyword(v) Then
                        errmsg "Warning - reserved word in DIM: " & v
                    Else
                        If i < tkcount - 1 and tokens(i + 1) = "(" Then
                            ' errmsg "Warning - Cannot dimension array as local: " & tokens(i)
                            dv = dv & tokens(i) & "("
                            'dv = dv & transvar(tokens(i)) & "("
                            i = i + 1
                            stk = stk + 1
                        Else
                            If LocalIdx(v) <> -1 Then
                                errmsg "Local variable redefined: """ & v & """"
                            End If
                            locals(loccount) = v
                            If Right(v, 1) <> "$" Then
                                locidx(loccount) = parNcnt + locNcnt
                                If insub > 0 Then
                                    locNcnt = locNcnt + 1
                                Else
                                    parNcnt = parNcnt + 1
                                End If
                            Else
                                locidx(loccount) = parScnt + locScnt
                                If insub > 0 Then
                                    locScnt = locScnt + 1
                                Else
                                    parScnt = parScnt + 1
                                End If
                            End If
                            loccount = loccount + 1
                        End If
                    End If
                End If
            End If
            i = i + 1
        Else
            Exit Do
        End If
    Loop
    If stk <> 0 Then
        WScript.Echo Dump(0,"")
        WScript.Echo String(Len(Dump(0,"")) - Len(Dump(i,"")), " ") & "^"
        errmsg "Mismatched Parentheses - " & stk
    End If

    If dv <> "" Then dv = ":DIM " & dv
    If oldlc <> loccount Then
        If locScnt - ols > 0 Then dv = ":ZQ=ZQ+" & locScnt - ols & dv
        If locNcnt - oln > 0 Then dv = ":ZP=ZP+" & locNcnt - oln & dv
    End If
    If Left(dv,1) = ":" Then dv = Mid(dv,2)
    If dv <> "" Then Output dv
End Sub

Sub do_ENDSUB
    Dim s
 
    If ctrlstk(ctrlptr) <> "SUB" Then errmsg "Unexpected ENDSUB"
    CtrlPop
    If optSource > 1 Then Output "REM ENDSUB"
    If parNcnt + locNcnt > 0 Then s = "ZP=ZP-" & parNcnt + locNcnt & ":"
    If parScnt + locScnt > 0 Then s = s & "ZQ=ZQ-" & parScnt + locScnt & ":"
    Output s & "RETURN"
    loccount = 0
    insub = 0
    curproc = ""
End Sub

Sub do_FUNC
    If ctrlptr <> 0 Then
        errmsg "FUNC cannot be nested: " & dumpCtrlStk
        ctrlptr = 0
    End If
   
    curproc = tokens(1)
    If optSource Then Output "REM " & Dumptokens()

    LabelSet "[" & tokens(1) & "]", linenum
    ctrlPush "FUNC", linenum

    parNcnt = 0: parScnt = 0: locNcnt = 0: locSCnt = 0
    AddLocalVars 3, ")"
    insub = 2
End Sub

Sub do_ENDFUNC
    Dim s
    If ctrlstk(ctrlptr) <> "FUNC" Then errmsg "Unexpected ENDFUNC"
    CtrlPop
    If optSource > 1 Then Output "REM ENDFUNC"
    ' Output "RETURN"
 
    LabelSet "[" & "_ENDFUNC_" & curproc & "]", linenum

 
    If locNcnt + parNcnt > 0 Then s = "ZP=ZP-" & (locNcnt + parNcnt)
    If s <> "" And parScnt + locScnt <> 0 Then s = s & ":"
    If parScnt + locScnt > 0 Then s = s & "ZQ=ZQ-" & (parScnt + locScnt)
    If s <> "" Then s = s & ":"
    Output s & "RETURN"
    loccount = 0
    insub = 0
    curproc = ""
End Sub

Sub do_END
    If tokens(1) = "SUB" Then
        do_ENDSUB
    ElseIf tokens(1) = "FUNC" or tokens(1) = "FUNCTION" Then
        do_ENDFUNC
    ElseIf tokens(1) = "IF" Then
        do_ENDIF
    ElseIf tokens(1) = "SELECT" Then
        Do_ENDSELECT
    Else
        Output Dumptokens()
    End If
End Sub

Sub do_SELECT
    If optSource Then Output "REM " & Dumptokens()
    ctrlPush "SELECT", linenum
End Sub

Sub Do_CASE
    ' If optSource > 1 Then Output "REM " & Dumptokens()
    If ctrlstk(ctrlptr) <> "SELECT" And ctrlstk(ctrlptr) <> "CASE" Then errmsg "Unexpected CASE"
    If ctrlstk(ctrlptr) = "CASE" Then
        ctrllin(ctrlptr) = linenum
    Else
        CtrlPush "CASE", linenum
    End If
    Output DumpTokens()
End Sub

Sub do_ENDSELECT
    If ctrlstk(ctrlptr) <> "SELECT" And ctrlstk(ctrlptr) <> "CASE" Then errmsg "Unexpected ENDSELECT"
    If ctrlstk(ctrlptr) = "CASE" Then CtrlPop
    CtrlPop
    Output Dumptokens()
End Sub

Sub do_RETURN
    Dim e, i
   
    If tkcount = 1 Then
        Output Dumptokens()
    Else
        i = 1
        e = AllExpressions(i, "")
        If Right(curproc, 1) = "$" Then
            Output "ZS$(ZQ-" & locScnt + parScnt + 1 & ") = " & e & ": GOTO [_ENDFUNC_" & curproc & "]"
        Else
            Output "ZS(ZP-" & locNcnt + parNcnt + 1 & ") = " & e & ": GOTO [_ENDFUNC_" & curproc & "]"
        End If
    End If
End Sub

Sub do_MACRO
    Dim src, mname, mparams, mbody, pname, i, t, tmptr

    t = 1
    mname = tokens(1)
    If Tokens(0) = "DEF" Then
        If tokens(1) = "FN" Then
            mname = "FN" & tokens(2)
            t = 2
        End If
        If t = 2 And Left(mname, 2) <> "FN" Then errmsg "Expected ""FN"" Identifier - Found: " & mname
    End If    

    If isKeyWord(mname) Or isFunction(mname) or toktyp(t) <> 1 Then
        errmsg "Expected Identifier, Found: " & tokens(t)
    End If
    
    If optSource > 1 Then
        Output "REM " & Dumptokens()
    End If
 
    mparams = Array()
    If Tokens(t + 1) = "(" Then
        i = t + 2
        Do While Tokens(i) <> ")" And i < tkcount
            If Tokens(i) <> "," Then
                If toktyp(i) <> 1 or isKeyWord(tokens(i)) Or isFunction(tokens(i)) Then
                    errmsg "Expected Parameter Identifier, Found: """ & Tokens(i) & """"
                End If
                ReDim Preserve mparams(UBound(mParams) + 1)
                mparams(UBound(mParams)) = TransVar(Tokens(i))
            End If
            i = i + 1
        Loop
        If i < tkcount Then i = i + 1
    Else
        If Tokens(t + 1) <> "=" Then errmsg "Expected: Parameter List or ""="""
        i = t + 1
    End If
    
    If Tokens(i) <> "=" Then
        errmsg "Expected: ""="", Found: """ & tokens(i) & """"
    Else
        i = i + 1
        tmptr = optTranVars
        optTranVars = False
        mbody = AllExpressions(i, "")
        optTranVars = tmptr
    End If

    If tokens(0) <> "CONST" Then
        For i = 0 to UBound(mparams)
            ' WScript.Echo "PARAM: " & mparams(i)
            pname = "_PARAM_" & CStr(i + 1) & "_"
            mbody = ReReplace(mbody, "\b" & mparams(i) & "\b" , pname)
        Next
    Else
        If UBound(mparams) <> -1 Then errmsg "CONST: Parameters ignored"
    End If
 
    If tokens(0) = "DEF" And optSimDef = 0 Then
        ' when destination supports DEF FN pass through
        Output Dumptokens()
    Else
        ' MACRO or simulate DEF FN as macro
        If dMacros.Exists(mname) Then errmsg "Warning - Macro Re-Defined: " & mname
        dMacros(mname) = Replace(mbody,"||","")
    End If
 
    ' WScript.Echo "MACRO: ", mname , "(", join(mparams, ","), ")=", mbody
End Sub

' Short syntax for using regular expression replace
Function reReplace(sSrc, sPat, sTxt)
    Dim re
 
    Set re = New RegExp
 
    re.Pattern = sPat
    re.IgnoreCase = True
    re.Global = True
 
    On Error Resume Next
    reReplace = re.Replace(sSrc, sTxt)
 
    If Err.Number <> 0 Then
        WScript.Echo "*** Error -- Format Replace Reg Exp Error: " & sPat
        WScript.Echo
        WScript.Quit
    End If
 
    On Error GoTo 0
End Function

' Short syntax for using regular expression test
Function reTest(sSrc, sPat)
    Dim re
 
    Set re = New RegExp
 
    re.Pattern = sPat
    re.IgnoreCase = True
    re.Global = True
 
    On Error Resume Next
    reTest = re.Test(sSrc)
 
    If Err.Number <> 0 Then
        WScript.Echo "*** Error -- Reg Exp Test Error: " & sPat
        WScript.Echo err.number, err.description
        WScript.Echo
        WScript.Quit
    End If
 
    On Error GoTo 0
End Function

' Stacks / Symbol Tables

Sub CtrlPush(tok, lin)
    ctrlptr = ctrlptr + 1
    ctrlstk(ctrlptr) = tok
    ctrllin(ctrlptr) = lin
    ' WScript.Echo ":PUSH", DumpCtrlStk()
End Sub

Sub CtrlPop
    ctrlptr = ctrlptr - 1
    ' WScript.Echo ":POP", DumpCtrlStk()
End Sub

Function DumpCtrlStk
    Dim s, i
    For i = 1 to ctrlptr
        If s <> "" Then s = s & " "
        s = s & ctrlstk(i)
    Next
    DumpCtrlStk = s
End Function

Sub LabelAdd(sName, iDst)
    llabel(labcount) = sName
    labdst(labcount) = iDst
    labcount = labcount + 1
End Sub

Function LabelIdx(sName)
    Dim i
    LabelIdx = -1
    i = 0
    Do While i < labcount
        If llabel(i) = sName Then
            LabelIdx = i
            Exit Do
        End If
        i = i + 1
    Loop
End Function

Sub LabelSet(sName, iDst)
    Dim idx
    idx = LabelIdx(sName)
    If idx = -1 Then
        LabelAdd sName, iDst
    Else
        llabel(idx) = sName
        labdst(idx) = iDst
    End If
    ' WScript.Echo sName, iDst
End Sub

Sub VarAdd(sName, sTran)
    vars(varcount) = sName
    vartran(varcount) = sTran
    varcount = varcount + 1
End Sub

Function VarIdx(sName)
    Dim i
    VarIdx = -1
    i = 0
    Do While i < varcount
        If vars(i) = sName Then
            VarIdx = i
            Exit Do
        End If
        i = i + 1
    Loop
End Function

Function LocalIdx(sName)
    Dim i
    LocalIdx = -1
    i = 0
    Do While i < loccount
        If locals(i) = sName Then
            LocalIdx = i
            Exit Do
        End If
        i = i + 1
    Loop
End Function

Function TransVar(sName)
    Dim sIdent, sType, sCont, f, c1, c2, a, v, lv, idx, pORl

    sIdent = sName
    sType = ""
    ' Preserve Type Specifier if used
    If InStr("$#%!", Right(sName, 1)) > 0 Then
        sIdent = Left(sName, Len(sName) - 1)
        sType = Right(sName, 1)
    End If
    ' Check for Global variable
    lv = -1
    If insub <> 0 Then lv = LocalIdx(sName)
    If insub <> 0 And lv <> -1 Then
        If Right(sName, 1) =  "$" Then
            idx = parScnt + locScnt - locidx(lv)
            TransVar = "ZS$(ZQ-" & idx & ")"
        Else
            idx = parNcnt + locNcnt - locidx(lv)
            TransVar = "ZS(ZP-" & idx & ")"
        End If
    Else
        f = VarIdx(sName)
        If f <> -1 Then
            TransVar = vartran(f)
        Else
            If Len(sIdent) <= 2 Then
                TransVar = sIdent & sType
                VarAdd sName, sIdent & sType
            Else
                ' use first letter and then 0-9 and A-Z in sequence
                c1 = Left(sName, 1)
                a = Asc(c1) - 65
                c2 = Chr(48 + vartbl(a) - 7 * (vartbl(a) > 9))
                If c2 <= "Z" And c1 <> "Z" Then
                    v = c1 & c2
                    If isKeyword(v) Then
                        ' 2 letter combination is reserved word (DO IF ON etc ...)
                        vartbl(a) = vartbl(a) + 1 'skip
                        a = Asc("Z") - 65
                        v = "ZV" & sType & "(" & 0 + vartbl(a) & ")"
                        vartbl(a) = vartbl(a) + 1
                    Else
                        vartbl(a) = vartbl(a) + 1
                        v = v & sType
                    End If
                Else
                    a = Asc("Z") - 65
                    v = "ZV" & sType & "(" & 0 + vartbl(a) & ")"
                    vartbl(a) = vartbl(a) + 1
                End If
                VarAdd sName, v
                TransVar = v
            End If
        End If
    End If
End Function

' Error Routines
Sub ErrPos(code, p)
    WScript.Echo
    WScript.Echo code
    WScript.Echo String(p - 2, " ") & "^"
End Sub

Sub ErrMsg( text )
    WScript.Echo "*** Error Line " & iCurLine & " - " & text
    errcount = errcount + 1
    If errcount >= optErrThr And optErrThr > -1 Then
        WScript.Quit
    End If
    ' WScript.Quit
End Sub