' 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
' 
' primes.do is Sample Source
' primes.ba is Sample Output
' 
' TODO:
'   Bugs in single line IF/THEN/ELSE (partial)
'   Better recognition of keywords and functions and subroutines
'   SELECT/CASE/ENDSELECT (partial)
'   LEAVE, BREAK, CONTINUE (loop exiting)
'   Join Lines Option (partial)
'   Local Variables (data stack)
'   Compress Spaces Option
'   Functions (data stack)
' 
'   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
'

Option Explicit

Const Alpha     = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
Const Digit     = "0123456789"
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 "

Const VBKeyList = " WSCRIPT ECHO CONST SET OPTION EXPLICIT LEFT RIGHT MID "
Const FunList   = " ABS INT SIN COS TAN LEFT$ RIGHT$ MID$ VAL TIME$ DATE$ DAY$ PEEK INKEY$ ASC CHR$ RND STRING LEN INSTR CINT CSTR CDBL MAXFILES "

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

' Operators in VBScript but not in Model-100 Basic
Dim opsVBS
opsVBS          = "&."

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  = 1 ' 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 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(250), labdst(250), labcount
Dim vars(200), vartran(200), vartbl(36), varcount
Dim locals(20), locidx(20), loccount, parScnt, parNcnt, locScnt, locNcnt, insub

Dim buffer, buflvl

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

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

sFName = WScript.Arguments(0)
Set oInput = oFS.OpenTextFile(sFName)

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

Dim sLine, iCurLine, i

' Pass 1
iCurLine = 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

If ctrlptr > 0 Then errmsg "Incomplete " & ctrlstk(ctrlptr)

oInput.Close

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

' Pass2 Line Scan Function
Function Pass2Line(text)
    Dim i, s, lbl, idx, ch
    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

' 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 Else
            If Left(tokens(0), 1) = """" Then
                Output Dumptokens()
            ElseIf Left(tokens(0), 1) = "'" Then
                If optComments Then Output Dumptokens()
            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
 
    ' typ = token type: 0 = ???, 1 = ident, 2 = num, 3 = stringlit , 4 = oper, 5 = comment, 6 = label, 7 = Other
 
    n = 0:
    tok = "": typ = 0: stk = "": n = 0: l = Len(text)
    Do While i <= l
        ch = Mid(text, i, 1)
        If ch = " " Or ch = Chr(9) Then
            i = i + 1
            ScanChars text, " " + Chr(9), i, -1, False
        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
        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 And optLineNums Then
                a(n) = "LABEL"
                a(n + 1) = tok
                n = n + 2
                ' linenum = CInt(tok)
                ' tok = ""
                Exit Do
            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 = 7
        ElseIf ch = "(" Then
            i = i + 1
            stk = stk & ch
            tok = ch
            ' if no space between previous identifier then probably function call
        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
        ElseIf  ch = ";" Then
            tok = ch
            i = i + 1
            If stk <> "" Then
                ErrPos text, i
                ErrMsg "Semicolon not valid in expression"
            End If
        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 = 7
                    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"
                        tok = "[" & tok & "]"
                        typ = 6
                    End If
                End If
            End If

            If InStr(Left(tok, 1), """'") = 0 Then
                a(n) = UCase(tok)
            Else
                a(n) = tok
            End If
            toktyp(n) = typ

            n = n + 1
            tok = ""
            typ = 0
        End If
       
    Loop

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

    Tokenize = n
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
    s = ""
    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 <> "" Then s = s & " "
            s = s & e
        End If
    Loop
    AllExpressions = s
End Function

' Parse an Expression starting at token n
Function Expression(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
    Expression = 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)
    isKeyword = (InStr(KeyList, " " & tk & " ") > 0)
End Function

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

Function isFunction(tk)
    isFunction = (InStr(FunList, " " & tk & " ") > 0)
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

' Do_<Keyword> Subroutines - Code Production

Sub do_OPT
    Dim i: i = 2
    Do While i < tkcount
        Select Case tokens(i)
            Case "LINE"
                If tokens(i + 1) <= linelst Then
                    errmsg "Warning - Line set to before previous"
                End If
                linenum = 0 + tokens(i + 1)
                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 Else
            ErrMsg "Unknown OPT -- """ & tokens(i) & """"
        End Select
        i = i + 1
    Loop
End Sub

Sub do_LABEL
    Flush
    ' add to symbol table
    If optSource > 1 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 optSource > 1 Then Output "REM " & Dumptokens()
    If toktyp(1) <> 6 Then
        Output "GOSUB " & "[" & tokens(1) & "]"
    Else
        Output "GOSUB " & tokens(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 & "]"
        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()
    End If
    If optComments Then Output Dumptokens()
End Sub

Sub do_DIM
    Flush
    Dim i, e
    Output "REM " & DumpTokens()
    ' AddLocalVars 2, ""
    Output "DIM " & AllExpressions(1, "")
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 i, e, s, n0, n1, p, s0
    ' handle params
    If tkcount <= 2 Then
        do_GOSUB
    Else
        i = 2: 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 [" & tokens(1) & "]"
    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

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

Sub AddLocalVars(i, tag)
' offset compensates for locals already on the stack
    Dim e, idxN, idxS
   
    idxN = parNcnt
    idxS = parScnt
    ' i = 3: locNcnt = 0: locScnt = 0
    Do While tokens(i) <> tag
        e = tokens(i)
        If InStr("(),", e) = 0 Then
            locals(loccount) = e
            If Right(e, 1) <> "$" Then
                locidx(loccount) = parNcnt
                parNcnt = parNcnt + 1
            Else
                locidx(loccount) = parScnt
                parScnt = parScnt + 1
            End If
            loccount = loccount + 1
        End If
        i = i + 1
    Loop
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 > 0 Then s = "ZP=ZP-" & parNcnt
    If s <> "" And parScnt <> 0 Then s = s & ":"
    If parScnt > 0 Then s = s & "ZQ=ZQ-" & parScnt
    If s <> "" Then s = s & ":"
    Output s & "RETURN"
    loccount = 0
    insub = 0
End Sub

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

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

Sub do_ENDFUNC
    If ctrlstk(ctrlptr) <> "FUNC" Then errmsg "Unexpected ENDFUNC"
    CtrlPop
    If optSource > 1 Then Output "REM ENDFUNC"
    Output "RETURN"
  
    If parNcnt > 0 Then s = "ZP=ZP-" & parNcnt
    If s <> "" And parScnt <> 0 Then s = s & ":"
    If parScnt > 0 Then s = s & "ZQ=ZQ-" & parScnt
    If s <> "" Then s = s & ":"
    Output s & "RETURN"
    loccount = 0
    insub = 0
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
    Output Dumptokens()
End Sub

' 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, f, c1, c2, a, v, lv

    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
    If insub <> 0 Then lv = LocalIdx(sName)
    If insub <> 0 And lv <> -1 Then
        If Right(sName, 1) =  "$" Then
            TransVar = "ZS$(ZQ-" & parScnt - locidx(lv) & ")"
        Else
            TransVar = "ZS(ZP-" & parNcnt - locidx(lv) & ")"
        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
    ' WScript.Quit
End Sub