A Compiler Example (With all stages, from Lexical Analyzer to Virtual Machine)

This code included in info.gsb (in the setup file). There are 4 stages with a fifth alternative, the M2000 transpiler. So there is a simple language, and the source going to Lexical Analyzer, then to Syntax Analyzer, then  to code generator and we have the option to run it in a virtual machine or  translate it to M2000 source and executed (is faster from virtual machine, which also the M2000 run it).

There are less than  1000 lines of code, A 10% hold the examples from the tiny language. This code always used to test new versions/revisions of language. 

Added a comma: t=(line$) now we have to turn it as t=(line$,)  ' see comma

 Module CompilerExample {

    Set Fast !
    Module lexical_analyzer (a$){
        lim=Len(a$)
        LineNo=1
        ColumnNo=1
        Document Output$
        Buffer Scanner as Integer*lim
        Return Scanner, 0:=a$
        offset=0
        buffer1$=""
        flag_rem=true
        Ahead=lambda Scanner (a$, offset)->{
            =false
            Try {
                // second parameter is the offset in buffer units
                // third parameter is length in bytes
                =Eval$(Scanner, offset,2*len(a$))=a$
            }
        }
        Ahead2=lambda Scanner (a$, offset)->{
            =false
            Try {
                =Eval$(Scanner, offset,2) ~ a$
            }
        }
        const nl$=chr$(13)+chr$(10), quo$="""", er$="@", Ansi=3
        Try {
            Do
            If Ahead("/*", offset) Then {
                offset+=2 : ColumnNo+=2
                While not Ahead("*/", offset)
                    If Ahead(nl$, offset) Then
                        lineNo++: ColumnNo=1 : offset+=2
                    Else
                        offset++ : ColumnNo++
                    End If
                    if offset>lim then
                        Error "End-of-file in comment. Closing comment characters not found"+er$
                    End if
                End While
                offset+=2 : ColumnNo+=2
            } Else.if Ahead(nl$, offset) Then{
                LineNo++: ColumnNo=1
                offset+=2
            } Else.if Ahead(quo$, offset) Then {
                Output$=format$("{0::-10}{1::-10} ", LineNo, ColumnNo)
                offset++ : ColumnNo++
                strin=offset
                While not Ahead(quo$, offset)
                    If Ahead("/", offset) Then
                        offset+=2 : ColumnNo+=2
                    else
                        offset++ : ColumnNo++
                    End if
                    checkerror()
                End While
                Output$="String "+quote$(Eval$(Scanner, strin, (offset-strin)*2))+nl$
                offset++ : ColumnNo++
            } Else.if Ahead("'", offset) Then {
                Output$=format$("{0::-10}{1::-10} ", LineNo, ColumnNo)
                offset++ : ColumnNo++
                strin=offset
                While not Ahead("'", offset)
                    If Ahead("/", offset) Then
                        offset+=2 : ColumnNo+=2
                    else
                        offset++ : ColumnNo++
                    End if
                    checkerror()
                End While
                lit$=format$(Eval$(Scanner, strin, (offset-strin)*2))
                select case len(lit$)
                case 1
                    Output$="Integer "+str$(asc(lit$),0)+nl$
                case >1
                    {Error "Multi-character constant."+er$}
                case 0
                    {Error "Empty character constant."+er$}
                end select
                offset++ : ColumnNo++
            } Else.if Ahead2("[a-z]", offset) Then {
                strin=offset
                Output$=format$("{0::-10}{1::-10} ", LineNo, ColumnNo)
                offset++ : ColumnNo++
                While Ahead2("[a-zA-Z0-9_]", offset)
                    offset++ : ColumnNo++
                End While
                Keywords(Eval$(Scanner, strin, (offset-strin)*2))
            } Else.if Ahead2("[0-9]", offset) Then {
                strin=offset
                Output$=format$("{0::-10}{1::-10} Integer ", LineNo, ColumnNo)
                offset++ : ColumnNo++
                While Ahead2("[0-9]", offset)
                    offset++ : ColumnNo++
                End While
                if Ahead2("[a-zA-Z_]", offset) then
                    {Error " Invalid number. Starts like a number, but ends in non-numeric characters."+er$}
                else
                    Output$=Eval$(Scanner, strin, (offset-strin)*2)+nl$
                end if
            } Else {
                Symbols(Eval$(Scanner, Offset, 2))    
                offset++ : ColumnNo++
            }
            Until offset>=lim
        }
        er1$=leftpart$(error$,er$)
        if er1$<>"" then
            Print
            Report "Error:"+er1$
            Output$="(Error)"+nl$+"Error:"+er1$
        else
            Output$=format$("{0::-10}{1::-10}", LineNo, ColumnNo)+" End_of_Input"+nl$
        end if
        Push Output$
        Exit
        Clipboard Output$
        Save.Doc Output$, "lex.t", Ansi
        document lex$
        Load.Doc lex$,"lex.t", Ansi
        Report lex$

        Sub Keywords(a$)
            select case a$
            case "if"
                a$="Keyword_if"
            case "else"
                a$="Keyword_else"
            case "while"
                a$="Keyword_while"
            case "print"
                a$="Keyword_print"
            case "putc"
                a$="Keyword_putc"
            else case
                a$="Identifier "+a$
            end select
            Output$=a$+nl$
        End sub
        Sub Symbols(a$)
            select case a$
            case " ", chr$(9)
                a$=""
            case "("
                a$="LeftParen"
            case ")"
                a$="RightParen"
            case "{"
                a$="LeftBrace"
            case "}"
                a$="RightBrace"
            case ";"
                a$="Semicolon"
            case ","
                a$="Comma"
            case "*"
                a$="Op_multiply"
            case "/"
                a$="Op_divide"
            case "+"
                a$="Op_add"
            case "-"
                a$="Op_subtract"
            case "%"
                a$="Op_mod"
            case "<"
            {    if Ahead("=", offset+1) Then
                    offset++
                    a$="Op_lessequal"
                    ColumnNo++
                else
                    a$="Op_less"
                end if
            }
            case ">"
            {    if Ahead("=", offset+1) Then
                    offset++
                    ColumnNo++
                    a$="Op_greaterequal"
                else
                    a$="Op_greater"
                end if
            }
            case "="
            {    if Ahead("=", offset+1) Then
                    offset++
                    ColumnNo++
                    a$="Op_equal"
                else
                    a$="Op_assign"
                end if
            }
            case "!"
            {    if Ahead("=", offset+1) Then
                    offset++
                    ColumnNo++
                    a$="Op_notequal"
                else
                    a$="Op_not"
                end if
            }
            case "&"
            {    if Ahead("&", offset+1) Then
                    offset++
                    ColumnNo++
                    a$="Op_and"
                else
                    a$=""
                end if
            }
            case "|"
            {    if Ahead("|", offset+1) Then
                    offset++
                    ColumnNo++
                    a$="Op_or"
                else
                    a$=""
                end if
            }
            else case
                {Error "Unrecognized character."+er$}
            end select
            if a$<>"" then
            Output$=format$("{0::-10}{1::-10} ", LineNo, ColumnNo)+a$+nl$
            end if
        End Sub
        Sub checkerror()
            if offset>lim then {
                Error "End-of-line while scanning string literal. Closing string character not found before end-of-line."+er$
            } else.if Ahead(nl$,offset) then {
                Error "End-of-file while scanning string literal. Closing string character not found."+er$
            }
        End Sub
    }
    Module syntax_analyzer (b$){
        enum tokens {
            Op_add, Op_subtract, Op_not=5, Op_multiply=10, Op_divide, Op_mod,
            Op_negate, Op_less, Op_lessequal, Op_greater, Op_greaterequal,
            Op_equal, Op_notequal, Op_and, Op_or, Op_assign=100, Keyword_if=110,
            Keyword_else, Keyword_while, Keyword_print, Keyword_putc, LeftParen, RightParen,
            LeftBrace, RightBrace, Semicolon, Comma, Identifier, Integer, String, End_of_input
        }

        Inventory precedence=Op_multiply:=13, Op_divide:=13, Op_mod:=13, Op_add:=12, Op_subtract:=12
        Append precedence, Op_negate:=14, Op_not:=14, Op_less:=10, Op_lessequal:=10, Op_greater:=10
        Append precedence, Op_greaterequal:=10, Op_equal:=9, Op_notequal:=9, Op_assign:=-1, Op_and:=5
        Append precedence, Op_or:=4

        Inventory symbols=Op_multiply:="Multiply", Op_divide:="Divide", Op_mod:="Mod", Op_add:="Add"
        Append symbols, Op_negate:="Negate", Op_not:="Not", Op_less:="Less", Op_subtract:="Subtract"
        Append symbols, Op_lessequal:="LessEqual", Op_greater:="Greater", Op_greaterequal:="GreaterEqual"
        Append symbols, Op_equal:="Equal", Op_notequal:="NotEqual", Op_and:="And", Op_or:="Or"

        def lineNo, ColumnNo, m, line$, a, lim, cur=-1
        const nl$=chr$(13)+chr$(10), Ansi=3
        Dim lex$()
        lex$()=piece$(b$,chr$(13)+chr$(10))
        lim=dimension(lex$(),1)-1
        op=End_of_input
        flush
        k=0
        Try {
            push (,) ' Null
            getone(&op)
            repeat
            stmt(&op)
            shift 2 ' swap two top items
            push ("Sequence", array, array)
            k++
            until op=End_of_Input
        }
        er$=error$
        if er$<>"" then print er$ : flush: break
        Print "Ast"
        Document Output$
        prt_ast()
        Push Output$
        exit
        clipboard Output$
        Save.Doc Output$, "parse.t", Ansi
        document parse$
        Load.Doc parse$,"parse.t", Ansi
        Report parse$

        sub prt_ast(t)
            if len(t)<1 then
                Output$=";"+nl$
            else.if len(t)=3 then
                Output$=t#val$(0) +nl$
                prt_ast(t#val(1)) : prt_ast(t#val(2))
            else
                Output$=t#val$(0) +nl$
            end if
        end sub
        sub expr(p) ' only a number
            local x=(,), prev=op
            if op>=Identifier then
                x=(line$,)
                getone(&op)
            else.if op=LeftParen then
                paren_exp()
                x=array
            else.if op<10 then
                getone(&op)
                expr(precedence(int(Op_negate)))
                read local y
                if prev=Op_add then
                    x=y
                else
                    if prev=Op_subtract then prev=Op_negate
                    x=(symbols(prev), y,(,))
                End if
            else
                 {error "??? "+eval$(op)}
            end if
            local prec
            while exist(precedence, int(op))
                prev=op : prec=eval(precedence)
                if prec<14 and prec>=p else exit
                getone(&op)
                expr(prec+1) ' all operators are left associative (use prec for right a.)
                x=(symbols(int(prev)), x, array)
            End While
            Push x
        end sub
        sub paren_exp()
            expected(LeftParen)
            getone(&op)
            expr(0)
            expected(RightParen)
            getone(&op)
        end sub
        sub stmt(&op)
            local t=(,)
            if op=Identifier then
                t=(line$,)
                getone(&op)
                expected(Op_assign)
                getone(&op)
                expr(0)
                read local rightnode
                Push ("Assign",t,rightnode)
                expected(Semicolon)
                getone(&op)
            else.if op=Semicolon then
                getone(&op)
                Push (";",)
            else.if op=Keyword_print then
                getone(&op)
                expected(LeftParen)
                repeat
                    getone(&op)
                    if op=String then
                        Push ("Prts",(line$,),(,))
                        getone(&op)
                    else
                        expr(0)
                        Push ("Prti", array,(,))
                    end if
                    t=("Sequence", t, array)
                until op<>Comma
                expected(RightParen)
                getone(&op)
                expected(Semicolon)
                getone(&op)
                push t
            else.if op=Keyword_while then
                getone(&op)
                paren_exp()
                stmt(&op)
                shift 2
                Push ("While",array, array)
            else.if op=Keyword_if then
                getone(&op)
                paren_exp()
                stmt(&op)
                local s2=(,)
                if op=Keyword_else then
                    getone(&op)
                    stmt(&op)
                    read s2
                end if
                shift 2
                Push ("If",array ,("If",array,s2))
            else.if op=Keyword_putc then
                getone(&op)
                paren_exp()
                Push ("Prtc",array,t)
                expected(Semicolon)
                getone(&op)
            else.if op=LeftBrace then
                Brace()
            else
                error "Unkown Op"
            end if
        end sub
        Sub Brace()
                getone(&op)
                while op<>RightBrace and op<>End_of_input
                    stmt(&op)
                    t=("Sequence", t, array)
                end while
                expected(RightBrace)
                getone(&op)
                push t
        End Sub
        Sub expected(what)
            if not op=what then {Error "Expected "+eval$(what)+str$(LineNo)+","+Str$(ColumnNo)}
        End Sub
        sub getone(&op)
            op=End_of_input
            while cur<lim
            cur++
            line$=trim$(lex$(cur))
            if line$<>"" then exit
            end while
            if cur=lim then exit sub
            LineNo=Val(line$,"int",m)
            line$=mid$(line$, m)
            ColumnNo=Val(line$,"int",m)
            line$=trim$(mid$(line$, m))
            Rem : Print LineNo, ColumnNo
            m=instr(line$," ")
            if m>0 then op=Eval("."+leftpart$(line$, " ")) else op=Eval("."+line$)
        end sub
    }
    Module CodeGenerator (s$){
        Function code$(op$) {
            =format$("{0::-6} {1}", pc, op$)
            pc++
        }
        Function code2$(op$, n$) {
            =format$("{0::-6} {1} {2}", pc, op$, n$)
            pc+=5
        }
        Function code3$(op$,pc, st, ed) {
            =format$("{0::-6} {1} ({2}) {3}", pc, op$, ed-st-1, ed)
        }

        Enum tok {
            gneg, gnot, gmul, gdiv, gmod, gadd, gle, gsub, glt
            gle, ggt, gge, geq, gne, gand, gor, gprtc, gprti, gprts,
            gif, gwhile, gAssign, gSeq, gstring, gidentifier, gint, gnone
        }

        // Inventories are lists with keys, or keys/data (key must be unique)
        // there is one type more the Invetory Queue which get same keys.
        // But here not used.
        Inventory symb="Multiply":=gmul, "Divide":=gdiv, "Mod":=gmod, "Add":=gadd
        Append symb, "Negate":=gneg, "Not":=gnot,"Less":=glt,"Subtract":=gsub
        Append symb, "LessEqual":=gle, "Greater":=ggt, "GreaterEqual":=gge, "Sequence":=gSeq
        Append symb, "Equal":=geq, "NotEqual":=gne, "And":=gand, "Or":=gor, "While":=gwhile
        Append symb, "Prtc":=gprtc,"Prti":=gprti,"Prts":=gprts, "Assign":=gAssign, "If":=gif
        Append symb, "String":=gstring, "Identifier":=gidentifier, "Integer":=gint, ";", gnone

        Inventory DataSet
        // We set string as key. key maybe an empty string, a string or a number.
        // so we want eash string to saved one time only.
        Inventory Strings

        Const nl$=chr$(13)+chr$(10), Ansi=3
        Def z$, lim, line$, newvar_ok, i=0
        Document message$=nl$
        Global pc     // functions have own scope, so we make it global, for this module, and childs.

        Dim lines$()
        s$=filter$(s$,chr$(9)) // exclude tabs
        Lines$()=piece$(s$,nl$) // break to lines
        lim=len(Lines$())
        Flush ' empty stack (there is a current stack of values which we use here)

        Load_Ast()
        If not stack.size=1 Then Flush : Error "Ast not loaded"
        AST=array // pop the array from stack
        Document Assembly$, Header$

        // all lines of assembly goes to stack. Maybe not in right order.
        // Push statement push to top, Data statement push to bottom of stack

        CodeGenerator(Ast)
        Data code$("halt") ' append to end of stack
        // So now we get all data (letters) from stack
        While not empty
            Assembly$=letter$+nl$
        end while
        // So now we have to place them in order
        Sort Assembly$

        // Let's make the header
        Header$=format$("Datasize: {0} Strings: {1}", Len(Dataset),Len(strings))
        // we use an iterator object, str^ is the counter, readonly, but Eval$() use it from object.
        str=each(strings)
        While str
            Header$=nl$+Eval$(str)
        End while
        Assembly$=nl$
        // insert to line 1 the Header
        Insert 1 Assembly$=Header$
        // Also we check for warnings
        If len(message$)>2 then Assembly$="Warnings: "+nl$+message$
        // So now we get a report
        // (at each 3/4 of window's lines, the printing stop and wait for user response, any key)
        Push Assembly$
        Exit
        Report Assembly$
        Clipboard Assembly$
        Save.Doc Assembly$, "code.t", Ansi
        End
        // subs have 10000 limit for recursion but can be extended to 1000000 or more.
        Sub CodeGenerator(t)

            If len(t)=3 then
                select case t#val(0)
                Case gSeq
                    CodeGenerator(t#val(1)) : CodeGenerator(t#val(2))
                Case gwhile
                {
                    local spc=pc
                    CodeGenerator(t#val(1))
                    local pc1=pc
                    pc+=5 ' room for jz
                    CodeGenerator(t#val(2))
                    data code3$("jz",pc1, pc1, pc+5)
                    data code3$("jmp",pc, pc, spc)
                    pc+=5 ' room for jmp
                }
                Case gif
                {
                    CodeGenerator(t#val(1))
                    local pc1=pc, pc2
                    pc+=5
                    CodeGenerator(t#val(2)#val(1))
                    If len(t#val(2)#val(2))>0 then
                        pc2=pc
                        pc+=5
                        data code3$("jz",pc1, pc1, pc)
                        CodeGenerator(t#val(2)#val(2))
                        data code3$("jmp",pc2, pc2, pc)
                    else
                        data code3$("jz",pc1, pc1, pc)
                    end If    
                }
                Case gAssign
                {
                    CodeGenerator(t#val(2))
                    local newvar_ok=true
                    CodeGenerator(t#val(1))
                }
                case gneg to gnot, gprtc to gprts
                    CodeGenerator(t#val(1)) : data code$(mid$(eval$(t#val(0)),2))
                case gmul to gor
                {
                    CodeGenerator(t#val(1))
                    CodeGenerator(t#val(2))
                    data code$(mid$(eval$(t#val(0)),2))
                }
                End select
            Else.if len(t)=2 then
                select case t#val(0)
                Case gString
                {
                    local spos
                    If exist(strings,t#val$(1)) then
                        spos=eval(strings!)
                    else
                        append strings, t#val$(1)    
                        spos=len(strings)-1
                    end If
                    Push code2$("push",str$(spos,0))
                }
                Case gInt
                    Push code2$("push",t#val$(1), pc)
                Case gIdentifier
                {
                    local ipos
                    If exist(dataset,t#val$(1)) then
                        ipos=Eval(dataset!) ' return position
                    else.if newvar_ok then
                        Append dataset, t#val$(1)
                        ipos=len(dataset)-1
                    else
                        message$="Variable "+t#val$(1)+" not initialized"+nl$

                    end If
                    If newvar_ok then
                        Push code2$("store","["+str$(ipos, 0)+"]")
                    else
                        Push code2$("fetch","["+str$(ipos, 0)+"]")
                    end If
                }
                end select
            End If
        End Sub
        Sub Load_Ast()
                If i>=lim then Push (,) : exit sub
                do
                line$=Trim$(lines$(i))
                I++
                tok$=piece$(line$," ")(0)
                until line$<>"" or i>=lim
                If tok$="Identifier" then
                    Push (gidentifier,trim$(Mid$(line$,11)))
                else.if tok$="Integer" then
                    long n=Val(Mid$(line$,8)) ' check overflow
                    Push (gint, Trim$(Mid$(line$,8)))
                else.if tok$="String" then
                    Push (gstring,Trim$(Mid$(line$,7)))
                else.if tok$=";" then
                    Push (,)
                Else
                    local otok=symb(tok$)
                    Load_Ast()
                    Load_Ast()
                    Shift 2
                    Push (otok,array, array)
                End If
        End Sub
    }
    Module Virtual_Machine_Interpreter (a$){
        // function to extract string, replacing escape codes.
        Function GetString$(a$) {
            s=instr(a$, chr$(34))
            m=rinstr(a$,chr$(34))-s
            if m>1 then
                // process escape codes
                =format$(mid$(a$, s+1, m-1))
            else
                =""
            end if
        }
        const nl$=chr$(13)+chr$(10)
        // we can set starting value to any number  n where 0<=n<=232
        enum op {    halt_=232, add_, sub_, mul_, div_, mod_, not_, neg_, and_, or_, lt_,
                    gt_, le_, ge_, ne_, eq_, prts_, prti_, prtc_, store_, fetch_, push_,
                jmp_, jz_
            }
             exit_now=false
        Inventory func=halt_:=lambda->{exit_now=true}
        Append func, push_:=lambda->{sp--:return stack_, sp:=eval(code_, pc as long):pc+=4}
        Append func, jz_:=lambda->{
            sp++: if eval(stack_, sp-1)=0 then pc=eval(code_, pc as long) else pc+=4
        }
        Append func, jmp_:=lambda->{pc=eval(code_, pc as long)}
        Append func, fetch_:=lambda->{sp--:Return stack_, sp:=eval(stack_, eval(code_, pc as long)):pc+=4}
        Append func, store_:=lambda->{Return stack_, eval(code_, pc as long):=eval(stack_, sp):sp++:pc+=4}
        Append func, add_:=lambda->{Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))+sint(eval(stack_, sp))):sp++}
        Append func, sub_:=lambda->{Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))-sint(eval(stack_, sp))):sp++}
        Append func, mul_:=lambda->{Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))*sint(eval(stack_, sp))):sp++}
        Append func, div_:=lambda->{Return stack_, sp+1:=uint(div(sint(eval(stack_, sp+1)),sint(eval(stack_, sp)))):sp++}
        Append func, mod_:=lambda->{Return stack_, sp+1:=uint(mod(sint(eval(stack_, sp+1)),sint(eval(stack_, sp)))) :sp++}
        Append func, not_:=lambda->{Return stack_, sp:=if(eval(stack_, sp)=0->uint(-1),0)}
        Append func, neg_:=lambda->{Return stack_, sp:=uint(-sint(eval(stack_, sp)))}
        Append func, and_:=lambda->{Return stack_, sp+1:=binary.and(eval(stack_, sp+1),eval(stack_, sp)):sp++    }
        Append func, or_:=lambda->{Return stack_, sp+1:=binary.or(eval(stack_, sp+1),eval(stack_, sp)):sp++    }
        Append func, lt_:=lambda->{Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))<sint(eval(stack_, sp))->-1, 0)):sp++}
        Append func, gt_:=lambda->{Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))>sint(eval(stack_, sp))->-1, 0)):sp++}
        Append func, le_:=lambda->{Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))<=sint(eval(stack_, sp))->-1, 0)):sp++}
        Append func, ge_:=lambda->{Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))>=sint(eval(stack_, sp))->-1, 0)):sp++}
        Append func, ne_:=lambda->{Return stack_, sp+1:=uint(if(eval(stack_, sp+1)<>eval(stack_, sp)->-1, 0)):sp++}
        Append func, eq_:=lambda->{Return stack_, sp+1:=uint(if(eval(stack_, sp+1)=eval(stack_, sp)->-1, 0)):sp++}
        Append func, prts_:=lambda->{Print #-2, strings$(eval(stack_,sp));: Refresh:sp++}
        Append func, prti_:=lambda->{Print #-2, str$(sint(eval(stack_,sp)),0);: Refresh:sp++}
        Append func, prtc_:=lambda->{Print #-2, chrcode$(eval(stack_,sp));: Refresh:sp++}
        Rem : Form 120, 60 ' change console width X height to run Ascii Mandlebrot example
        // change Report with Print #-2,   (report stop when scrolling 3/4 of height of console, waiting key or mouse key to continue)
        Print #-2, "Virtual Assembly Code:"+{
        }+a$
        Print "Prepare Byte Code"

        // get datasize
        a$=rightpart$(a$, "Datasize:")
        m=0
        data_size=val(a$, "int", m)
        a$=mid$(a$, m)
        // make stack
        if data_size>0 then Buffer Clear stack_ as long*data_size
        // dim or redim buffer append 1000 long as is.
        Buffer stack_ as long*(1000+data_size)
        // get strings
        a$=rightpart$(a$, "Strings:")
        m=0
        strings=val(a$, "int", m)
        a$=rightpart$(a$, nl$)

        if strings>0 then
            Dim strings$(strings)
            for i=0 to strings-1
                strings$(i)=GetString$(leftpart$(a$, nl$))
                a$=rightpart$(a$, nl$)
            Next i
        End if
        buffer clear code_ as byte*1000
        do
            m=0
            offset=val(a$,"int", m)
            if m<0 then exit
            a$=mid$(a$,m)
            line$=trim$(leftpart$(a$,nl$))
            if line$="" then line$=trim$(a$) else a$=trim$(rightpart$(a$, nl$))
            op$=if$(instr(line$," ")>0->leftpart$(line$," "), line$)
            if not valid(eval(op$+"_")) then exit
            opc=eval(op$+"_")
            Return code_, offset:=opc
            if opc>=store_ then
                line$=rightpart$(line$," ")
                select case opc
                case store_, fetch_
                    Return code_, offset+1:=val(rightpart$(leftpart$(line$,"]"),"[")) as long : offset+=4
                case push_
                    Return code_, offset+1:=uint(val(line$)) as long : offset+=4
                case jz_, jmp_
                    Return code_, offset+1:=val(rightpart$(line$,")")) as long : offset+=4
                end select
            end if
        Always
        Print "Press any key" : Push key$ : Drop
        // Prepare VM
        def mod(a,b)=a- sint(uint(a / b))*b
        def div(a,b)=sint(uint(a / b))
        profiler
        let pc=0, sp=len(stack_) div 4
        do
            b=func(eval(code_, pc))
            pc++
            call local b()
        until exit_now
        Print
        Print "", round(Timecount/1000,2),"s"
    }
    Module Transpiler_to_M2000 (code$){
        Print #-2, "Virtual Assembly Code:"+{
        }+code$
        Print "Prepare M2000 Code"
        Flush
        prolog$={Global z
            global mod=lambda (b, a)->{push a- sint(uint(a / b))*b}
            global div=lambda (b,a)->{push sint(uint(a / b))}
            Module Halt {Error "stop"}
            Module neg {push -number}
            Module not {push number=0}
            Module and {push sint(binary.and(uint(number), uint(number)))}
            Module or {push sint(binary.or(uint(number), uint(number)))}
            Module gt {push number<number}
            Module lt {push number>number}
            Module ge {push number<=number}
            Module le {push number>=number}
            Module ne {push number<>number}
            Module eq {push number=number}
            Module mul {push number*number}
            Module div {call div()}
            Module mod {call mod()}
            Module sub {shift 2: push number - number}
            Module add {push number + number}
            Module prtc {Print #-2, chrcode$(number);:Refresh}
            Module prts {Print #-2, format$(var$(number));:Refresh}
            Module prti {Print #-2, str$(number, 0);:Refresh}
            }
        Variable$=lambda$ (many, Name$, glob as boolean=false)->{
            if many else exit
            if glob then
                ="Global "+name$+"(0 to "+str$(many,0)+")"+{
                }
            else
                ="Dim Base 0, "+name$+"("+str$(many,0)+")"+{
                }
            end if
        }
        firstline$=leftpart$(code$,13)
        code$=rightpart$(code$, 10)
        firstline$=rightpart$(firstline$, ": ")
        Vars=val(firstline$)
        firstline$=rightpart$(firstline$, ": ")
        Strings=val(firstline$)
        document feedstrings$
        if Strings Then
        for i=0 to Strings-1
            firstline$=Trim$(leftpart$(code$,13))
            code$=rightpart$(code$, 10)
            feedstrings$="var$("+str$(i,0)+") = "+firstline$+{
            }
        next
        end if
        stack new {
            {
                g$=leftpart$(code$, " (")
                if g$="" or code$="" then
                    data code$ : code$="": exit
                end if
                data g$
                code$=rightpart$(code$, 41)
                loop
            }
            while not empty{
                read g$
                code$+=g$
            }
        }
        code$=replace$("]", ")", code$)
        code$=replace$("fetch [", "fetch(", code$)
        code$=replace$("store [", "store(", code$)
        code$=replace$("jmp ", "goto ", code$)
        code$=replace$("jz", "if number else ", code$)
        Subs$={
            End
            Sub store(x)
                Read var(x)
            End Sub
            Sub fetch(x)
                Push var(x)
            End Sub
        }
        document M2000Code$="Module Run {" +prolog$ + Variable$(Vars,"var")
        M2000Code$=Variable$(Strings,"var$", true) +feedstrings$ +{
        }+"Try {" + {
        } + code$+"}"+{
        }+Subs$+"}"
         // clipboard M2000code$
        // exit
        Inline M2000Code$
        Print "Press any key" : Push key$ : Drop
        profiler
        Run
        Print
        Print round(Timecount/1000,2),"s"
    }
    print "choose example",
    menu "Mandelbrot", "primes","test case 4", "99 Bottles of Beer", "FizzBuzz", "fibonacci of 44 is 701408733", "12 factorial is 479001600"
    if menu then print menu$(menu) else exit
    select case menu
    case 1
        {
            Push {
            {
                /*
                This is an integer ascii Mandelbrot generator
                */
                left_edge= -420;
                right_edge=300;
                top_edge=300;
                bottom_edge = -300;
                x_step=7;
                y_step=15;
                
                max_iter=200;
                
                y0 = top_edge;
                while (y0 > bottom_edge) {
                    x0 = left_edge;
                    while (x0 < right_edge) {
                        y = 0;
                        x = 0;
                        the_char = ' ';
                        i = 0;
                        while (i < max_iter) {
                            x_x = (x * x) / 200;
                            y_y = (y * y) / 200;
                            if (x_x + y_y > 800 ) {
                                the_char = '0' + i;
                                if (i > 9) {
                                    the_char = '@';
                                }
                                i = max_iter;
                            }
                            y = x * y / 100 + y0;
                            x = x_x - y_y + x0;
                            i = i + 1;
                        }
                        putc(the_char);
                        x0 = x0 + x_step;
                    }
                    putc('\n');
                    y0 = y0 - y_step;
                }
            }
            }
        }
    case 2
        {
            push {
            /*
            Simple prime number generator
            */
            count = 1;
            n = 1;
            limit = 100;
            while (n < limit) {
                k=3;
                p=1;
                n=n+2;
                while ((k*k<=n) && (p)) {
                    p=n/k*k!=n;
                    k=k+2;
                }
                if (p) {
                    print(n, " is prime\n");
                    count = count + 1;
                }
            }
            print("Total primes found: ", count, "\n");
            }
        }
    case 3
    {
        push {
        /*** test printing, embedded \n and comments with lots of '*' ***/ print(42); print("\nHello World\nGood Bye\nok\n"); print("Print a slash n - \\n.\n");
        }
    }
    case 4
    {
        push {
         /* 99 bottles */ bottles = 99; while (bottles > 0) {
            print(bottles, " bottles of beer on the wall\n");
            print(bottles, " bottles of beer\n");
            print("Take one down, pass it around\n");
            bottles = bottles - 1;
            print(bottles, " bottles of beer on the wall\n\n");
            }
        }
    }
    case 5
    {
        push {
        /* FizzBuzz */ i = 1; while (i <= 100) {

            if (!(i % 15))
                print("FizzBuzz");
            else if (!(i % 3))
                print("Fizz");
            else if (!(i % 5))
                print("Buzz");
            else
                print(i);
                print("\n");
                i = i + 1;
            }
        }
    }
    case 6
    {
        push {
            /* fibonacci of 44 is 701408733 */
            
            n = 44; i = 1; a = 0; b = 1; while (i < n) {
            
                w = a + b;
                a = b;
                b = w;
                i = i + 1;
            } print(w, "\n");
        }
    }
    case 7
    {
        push {
            /* 12 factorial is 479001600 */
            
            n = 12; result = 1; i = 1; while (i <= n) {
            
            result = result * i;
            i = i + 1;
            } print(result);
        }
    }
    end select
    Form! 104, 60
    Refresh
    Print "Lexical Analyzer" : Refresh
    lexical_analyzer
    if not islet then exitr
    Print "Syntax Analyzer" : Refresh
    syntax_analyzer
    if not islet then exit
    Print "Code Generator" : Refresh
    CodeGenerator
    if not islet then exit
    if ask("Choose execution style", "Info", "Virtual Machine", "*M2000 Transpiler")=1 then
        Virtual_Machine_Interpreter
    else
        Transpiler_to_M2000
    end if
    Print "done"
    Set Fast 'restore speed setting
}
CompilerExample

Vesion 12, Revision 7

 This is the most complete version of M2000. I have to revise the old English Manual, an a not too old Greek one.

Version 12 include:

Arrays with types .Previous versions use variant type internal, and have two interfaces, one with parenthesis and another with a pointer to array.

// Before Version 12 - Still in use in Version 12
Dim Alfa(10, -3 to 3)=100&
// if we paass something else because it is a variant type, take it as is.
Alfa(2, -1)=100%
Print type$(Alfa(2,-1))="Integer", type$(Alfa(9, 3))="Long"

// Version 12
Dim Beta(-2 to 2, -2 to 2) as Long Long
Beta(1,2)=100 ' 100 has the default type Double
// Cannot change type.
Print Type$(Beta(1,2))="Long Long"
// We get overflow if we try to put something which not fit.

Define variables using the type before the name, and we can omit values, (they get the default for their type). Also Variant type included for variables. Before version 12 all variables get the type from the first assignment, and there was a way to define them but only literals allowed for first value.

// old style, we can pass second time from this line, an error raised
// you have to exit the module and then you can use it (like it is a first time)
Def integer a=100, b=200

// Defining local variables when the scope is more wide, like in subs.
// also define Local arrays. We can use it for arrays with types two, look z()
// we can make strings using names without suffix S. Although suffix $ are recommented for clarity.
// Local always make new variables/arrays. So we don't include this in a Loop.
// new same names hide the old same names.

Local a1 as long=100, b1 as boolean=True, kappa(10)=10&, Z(10) as string

// Like Local, Global always make new variables, arrays.

Global K, ZZ(30) as boolean
Print type$(ZZ(2))="Boolean"

// this statement show all defined variables (but maybe not in scope with this code)
List

Variant V="Hello"
Print V+V="HelloHello", "HelloHello"=V+V // true  true
V=10
Print V+V=20, 20=V+V // return true true
V=(1,2,3,4)
Print V#sum()=10
V="Now I am String Again"
Print Mid$(V, 5)="I am String Again"

V$="I am not variable V"

// With the type before, we can redefine a variable. Always Local variables.
Double M=100, N
Print Type$(M)="Double"
// Now M converted to Integer, and stay as Integer, with overflow control.
Integer M
Print Type$(M)="Integer"
Print M=100

// we can use Global and Local before
Global double M1, M2

New type of arrays (one or two dimensions but internal the first dimension is a one dimension of arrays, so each "row" can expand as we wish, and the first column to include more arrays. We can't reduce size. We have pointer and we pass it or pass a copy easy:

// new type of arrays
// this is an array of arrays
// with one type
integer ia[10][10]=100 // has 11x11 items
long lk[3]=3 // 4 items
variant vb[10]
vb[3]=lk[] // we pass a copy of ik
Print vb[3][2]=3
vb[3][2]++
Print vb[3][2]=4
Print lk[2]=3
lk[2]+=100
vb[1]=lk // we pass a pointer (object)
Print vb[1][2]=103
vb[1][2]+=200
Print vb[1][2]=303
Print lk[2]=303 // so now ik[2] has the same value

Epression Evaluator.

Version 12 is more VB6 like, on expression evaluation. This break a little the compatibility with older versions. The differences are two:

The minus sign as unary operator behave different before power, so -2^2=2^2  (same as -2**2-2**2, M2000 has the two operators for power) , now return -8, and the older versions return 0 (because the - sign was unary to 2 so we get (-2)^2-(-2)^2 or 4-4 or 0. But the new one do something else -(2^2)-(2^2), because power operator has higher priority from unary minus.

Here we see that the unary minus change the type of second integer value (in hexadecimal format).

Print 0x8000%, -0x8000%
def typename(x)=type$(x)
Print typename(0x8000%)="Integer", typename(-0x8000%)="Long"
Print 0x8000%^2, -0x8000%^2 // Overflow error

We get overflow error because power for integer (16bit), long (32bit) and Long Long (64bit) always use internal fast multiplication and return same type or overflow. This is different from VB6 which always return a Double value.

Print 0x8000%, -0x8000%
def typename(x)=type$(x)
Print typename(0x8000%)="Integer", typename(-0x8000%)="Long"
//Print 0x8000%^2, -0x8000%^2 // Overflow error

LLz=0x8000_0000_0000_0000&&
clipboard LLz
Print LLz=-9223372036854775808&&
LLz=2&&^63&&
// Long Long return negative number (same bits with unsigned long long)
// at the 2^63
Print LLz=-9223372036854775808

Literals for different type/use:

Print 10% // Integer
Print 10& // Long
Print 10&& // Long Long
Print 10~ // Single (float 4 bytes)
Print 10 // double (8 bytes)
Print 10# // Currency (8 bytes integer X1000 - has 4 decimal digits)
Print 10@ // Decimal 29 digits (96bit) without sign and the position of decimal point

Print True, False // -1 0 (they are double values - from version 1 of M2000)
//we can define boolean, and all comparisons return boolean (Except <=>)
// a non zero value is true.
boolean k=True

def string a1$="Hello there"
string a="hello"

Print 0x100 ' Currency type used as unsigned long
Print 0x100& ' long
Print 0x100% ' Integer
Print 0x100&& ' Long Long
Print 0x0_1000_1000 ' Decimal used for unsigned Long Long
// we can use _ character inside hexadecimal value
Hex 233% ' we have the Hex as Print but for Hexadecimal values.  Return 0x00E9

Print &hFFFF& ' this is long type, using the VB6 &H

Pen #AA88FF // this is a Html Color (has a negative value, 1 to 15 are the standard colors, 0 for black)

We can use  { } for block of codes and for string literals using line breaks, Depending the code Interpreter find where a block is code or string (also the syntax coloring system for M2000 editor, which included in M2000 environment can be colorized the code using the same technic (from the statement before the block).

Enum constants now take string values too.

Many other improvements. The Test form (for executing step by step code) now has list of errors. So when we trap errors we have the list which can be open in the help pad form, and see them in real time.

There is a stop statement which can stop the execution, and writing from console we can alter local variables, define new variables, alter functions etc.

Version 12 can load controls which are register as OCX, on user forms. There are 5 controls including the base for the controls for forms (button, combo, checkbox, textbox, editbox, listbox, Image) which I design and programmed them. These are the UCPieChart, UCChart, NineButtons, ShapeEx, Radial. 

The button can be used as a timer for blinkig, combo used as menu too, textbox as spinbox, editbox for numeric/text one line input with multiple undo, as well for multiple lines, using an internal system for adjusting the coloring code procedure. Image box can be used as a frame to hold other controls, and can be used as console (There is a demo, Ver11 in info file). Listbox can be used as a multicolumn box, but isn't like Flex. Although can be used for virtual list (not included in the control but handle it with interrupt, and feeding it when ask for it. Combo boxes are a textbox with a list, and we can use it with textbox for editing with autocomplete, sorting the drop down list, or as a button with a dropdown list, or just as a list we change the caption of the button, like a split button. All the controls can be used with transparency (and the EditBox), and are unicode.

I am looking for new controls (there are some objects for different tasks, not controls such as for zip files, json files, xml files).

Here is a program to interact with internet, calling remote functions, using WinHttpRequest.    The idea was from a Bulgarian friend. You have to register as user in Microsoft 

global string DEF_ENDPOINT="https://api.cognitive.microsofttranslator.com"
declare Request "WinHttp.WinHttpRequest.5.1"
Module TranslateInit(Req, sKey as string, sRegion as String, sFromLang as String="gr", ToLang as String="en") {
    Method Req, "Open", "POST", DEF_ENDPOINT+"/translate?api-version=3.0&from="+ sFromLang + "&to=" + ToLang
    Method Req,"SetRequestHeader", "Ocp-Apim-Subscription-Key", sKey
    Method Req,"SetRequestHeader", "Ocp-Apim-Subscription-Region", sRegion
    Method Req,"SetRequestHeader", "Content-Type", "application/json"
}
Function TranslateText(Req, vTexts as variant) {
    declare Json JsonArray
    with json, "json" as json.format$()
        if type$(vTexts)="String" then
        method json, "assignpath", "0.text", vTexts
    else.if type$(vTexts)="mArray" then
        k=each(vTexts)
        while k
            method json, "assignpath", str$(k^,0)+".text", array$(k)
        end while
    end if
    /report json.format$(4)
    Method Req, "Send", json.format$(0)
    with Req, "ResponseText" as r$
    method json, "parser", r$ as resp
    =resp
}
TranslateInit Request, "SorryYourPasswordHere", "westeurope", "bg","en"
words_bg_en=("Здравейте", "Лека нощ")
json= TranslateText(Request, words_bg_en)
'json= TranslateText(Request, "Лека нощ")
with json, "json" as json.format$(), "count" as count
with json, "itempath" as json.path(), "itempath" as json.path$()
report json.format$(4)
if count>0 then
    for i=0 to count-1
        Print words_bg_en#val$(i)+" = "+json.path$(str$(i,0)+".translations.0.text")
    next
end if

         [    
        {        
            "translations" : [            
                {                
                    "text" : "Hello",
                    "to" : "en"
                }
            ]
        },
        {        
            "translations" : [            
                {                
                    "text" : "Good night",
                    "to" : "en"
                }
            ]
        }
    ]
    Здравейте = Hello
    Лека нощ = Good night

    

There is an Info file with over 300 modules. Because M2000 use modules in modules, we load all of them and we can use any of them (we can run multiple programs each one with showing or hidden environment (the console).

 

 

Version 12 now is ready (99%) and work nice.

 The new version has these:

New expression evaluator: -2^2-2^2 now return -8 (older versions return 0). So Version 12 on evaluator is not compatible with older versions. Although the difference is small, some programs may need work to used with Version 12.

String variables on older and this version can have suffix $, but for older versions this was mandatory. Now the new evaluator check the types and perform string concatenation if found a string in a series of addition. So new version do that ? 123+"mm" return 123mm as string value.? 

Example 1

a=100

? "["+a+"]"="[100]"

return true

Example 2

Greek

? 123.45

return 123,45  (in code decimal pointer is always dot but print use the current one. We can change it using Greek, Latin or Locale 1033 or other number, so according locale id we get the decimal point to be used for input and print from M2000. console.

Evaluator convert always like code, using dot for decimal point.

a=123.45

? "["+a+"]"="[123.45]"

? "["+str$(a, 1032)+"]"  'ising Str$() to choose locale id for specific conversion.

String internal functions have $ suffix (for compatibility with older versions).

I have to make the new manual, there are plenty of new thing, so stay tuned....

GK

Version 12 Revision 3 (test only)

You can test this pre-release here: https://github.com/M2000Interpreter/Environment/releases/tag/Ver12Rev3

New type of arrays using [ ] 

These arrays are different, they are based on RefArray class, and can be any  type, numeric and string. Can be one dimension or two. But it isn't the same as the normal array. So a 2X3 array has two arrays of 1X3 (Normal arrays are flat inside, 1x6, for the example, and the mArray class handle the indexes according the Dimension definition).

Also the editor fixed for colorize these types. We can use them in classes also, and with pointers to objects. Actually, the V member has no [ ], so we can refer to V as is (without indexes) and that is the raw object, (the RefArray) which have some useful properties, like ArrPtr (which return the memory address of the first item (for each row). Also these arrays can expand easy, by using indexes greater than the last greater index. Also these arrays may expand in both dimensions and maybe some rows have different size. We can use a definition like this:

Long Long LL[99][99] and we take a 100X100 array of Long Long (64 bit, 8 bytes each).

There is no operators like +=, so to increase 1 to 5th element in 3rd row, we use:

LL[0][4]=LL[0][4]+1

We can extract a copy of 3rd row 

M=LL[2]

We can get a copy of 100X100 items

M=LL[]

We can get just a pointer 

M=LL

class alfa {
	string V[4]
}
A->alfa()
A=>v[0]="ok"
? A=>v[0]

Using variant we can change type per item.

class alfa {
	variant V[4]
}
A->alfa()
A=>v[0]="ok"
? A=>v[0]
A=>v[0]=123456789012345678&&
def typ$(x)=type$(x)
? A=>v[0], typ$(A=>v[0])="Long Long"

Using a simple group, we can pass the pointer to sub alfa()

group A {
	string V[4]
}
A.v[0]="ok"
? A.v[0]

alfa(a.v, 0)
? A.v[0]

alfa(a.v, 1)
? A.v[1]

sub alfa(b, x)
	b[x]=b[x]+"..."
end sub

A string array use a 4 byte pointer for each string,. A variant type like the tuple below, use 16 bytes for each item (for string use only  2 bytes  type+ 4 bytes pointer from the 16 bytes). So the above code produce 1/4 for memory which aren't string data. comparing with the default variant size array of M2000.

group A {
	V=("","","","")
}
link A.v to A.v()
A.v(0)="ok"
? A.v(0)

alfa(&a.v(), 0)
? A.v(0)

alfa(&a.v(), 1)
? A.v(1)

sub alfa(&b(), x)
	b(x)=b(x)+"..."
end sub

More tests here

c$="ok!!!"
global string k[10], s=string$(c$,4)
? s
m=k
m[2]="ok"
? k[2]

class alfa {
	// k[] is a copy of array k
	variant z=k[], m
	// k is a pointer to array
	variant z_ponter=k
	Long long k[99]
}
alfa->alfa()
? alfa=>z[2]
alfa=>m=(1,2,3,4,5,6,7,8)
? alfa=>m
alfa=>m=1000
? alfa=>m
m[2]="ok1234"
? alfa=>z[2]<>m[2]
? alfa=>z_ponter[2]=m[2]
pk=alfa=>k
for alfa {
	? len(.k)=100, type$(.k[0])="Long Long"
	.k[0]=1
	.z[2]="ok...this is z[2]"
}
? pk[0]
alfa=>k[0]=alfa=>k[0]+1
? pk[0]
? alfa=>z[2]

The above arrays have always 0 for the first item.

The nArray which handle dimensions (max 10), can combine with refArray so we have these types (which are mArray class, but have a connection with a RefArray class)

The mArray interface and the M2000 Interpreter utilize interesting operators, here we use the *=. The 0% literal is type of Integer (2 bytes). Also there are some function with hashtag, which are get the output (for mArray) and can produce another array (here we use the #REV() function, to get the reverse order, as a copy of  the original one.

This is the example DIMVER12 in Info.gsb (exist in the setup file).

dim base 1, M(10) as integer=10
? M()
Mult=lambda (n as integer)-> {
      //dim base 0, M(n) as integer
      dim M(0 to n-1) as integer
      For i=0% to n-1 : m(i)=(i+1)*n : Next
      =M()
}
? mult(4)

dim p(1 to 5) as long=500
group alfa {
	dim p(1 to 5) as decimal=500  ' try currency, double, single
}
Print alfa.p(1)
z1->(alfa)
Print z1=>p(1)

for z1 {
	for i=1 to 5: .p(i)*=.0005*i: next
}

z=group(z1)
Print z.p()
Print type$(z.p(1))
m=z.p()#REV()
Print m
m+=10
L=m#val(0)
Print type$(L)
Print type$(m)="mArray"
Print m#sum()
list

There are more to discuss about Version 12, but wait the new beta releases, or the first normal release (when all string/numeric functions checked).

Version 12 has enumarations using string also. 

Enumeration Names {
	a="hello"
	b="hello two"
}

m=b
select case m
case a
	? "is a"
case b
	? " is b"
end select
	? "done"
? m

Also now can be any numeric type (this is Decimal type to be used as 64bit unsigned Integer - from literal):

enum alfa {
	onebig=0xFFFF_FFFF_FFFF_FFF0
	otherBig=0x7FFF_FFFF_FFFF_FFFF
}
list

Version 12 (Rev 2)

The first release of version 12. This version has different expression evaluator.  The unary minus has  priority  like in VB6. 

1) Unary minus: -2^2 return -4 (previous versions return 4,  because unary minus processed before exponent (-4)^2.

? -2^-3^-4

-0,991479137495678

2) Previous versions return 0, because the second minus was not unary so we get 4-4 = 0. Now -2^2 return as -(2^2) and the same for the second -(2^2), so we have -4-4=-8

? -2^2-2^2

-8

Also there are more new things. But still the work is in progress

 Download Here