Σάββατο 27 Απριλίου 2019

Dijkstra's algorithm

This is a rosettacode.org task
The graph stored in a jagged array. A tuple in m2000 is an array of one dimension. We can put tuple in a tuple too, so this is a jagged array. When we store an array in an array, we store only the pointer to array (which is an object, so we can read the type if we wish).

So Edges is a pointer to the graph (which we didn't change values). The task want only to find the path from a to e, and the weight. But here we search all the paths from every vertex to every vertex (and if not possible the a "no path" label printed).

I use an inventory list only with keys, because we can delete any of them without cost (this list need unique keys). Because we have the statement Inventory in a loop, the second time the inventory must be empty (or an exception produced), but algorithm end when inventory is empty. (to clear an inventory S we have to use Clear S.

There are two lambda functions inside loop. Because we use closures, and for d and pa we get new pointer in each iteration we have to redefine the lambdas to get new closures (with new pointers). Closures in lambda are copies, and this include pointers.

Also I use some subs, which have same scope as the module where we call them. Functions and Modules are namespaces (this include the lambda functions). There is special call to place the same namespace the Call Local but here not used.

I use this pdf for information about algorithm.


Module Dijkstra`s_algorithm {
        const max_number=1.E+306
        GetArr=lambda (n, val)->{
                dim d(n)=val
                =d()
        }
        term=("",0)
        Edges=(("a", ("b",7),("c",9),("f",14)),("b",("c",10),("d",15)),("c",("d",11),("f",2)),("d",("e",6)),("e",("f", 9)),("f",term))
        Document Doc$="Graph:"+{
        }
        ShowGraph()
        Doc$="Paths"+{
        }
        Print "Paths"
        For from_here=0 to 5
                pa=GetArr(len(Edges), -1)
                d=GetArr(len(Edges), max_number)
                Inventory S=1,2,3,4,5,6
                return d, from_here:=0
                RemoveMin=Lambda S, d, max_number-> {
                        ss=each(S)
                        min=max_number
                        p=0
                        while ss
                                val=d#val(eval(S,ss^)-1)
                                if min>val then let min=val : p=ss^ 
                        end while
                        =s(p!)  ' use p as index not key
                        Delete S, eval(s,p)
                }
                Show_Distance_and_Path$=lambda$ d, pa, from_here, max_number (n) -> {
                        ret1$=chr$(from_here+asc("a"))+" to "+chr$(n+asc("a"))
                        if d#val(n) =max_number then =ret1$+ "No Path" :exit
                        let ret$="", mm=n, m=n
                        repeat
                                n=m
                                ret$+=chr$(asc("a")+n)
                                m=pa#val(n)
                        until  from_here=n 
                        =ret1$+format$("{0::-4} {1}",d#val(mm),strrev$(ret$))
                }
                while len(s)>0 
                        u=RemoveMin()
                        rem Print u, chr$(u-1+asc("a"))
                        Relaxed()
                end while
                For i=0 to len(d)-1
                        line$=Show_Distance_and_Path$(i)
                        Print line$
                        doc$=line$+{
                        }
                next
        next
        Clipboard Doc$
        End
        Sub Relaxed()
                local vertex=Edges#val(u-1), i
                local e=Len(vertex)-1, edge=(,), val
                for i=1 to e
                        edge=vertex#val(i)
                        if edge#val$(0)<>"" then
                                val=Asc(edge#val$(0))-Asc("a")
                                if d#val(val)>edge#val(1)+d#val(u-1) then  return d, val:=edge#val(1)+d#val(u-1) : Return Pa, val:=u-1
                        end if
                next 
        end sub
        Sub ShowGraph()
                Print "Graph"
                local i
                for i=1 to len(Edges)
                        show_edges(i)
                next
        end sub
        Sub show_edges(n)
                n--
                local vertex=Edges#val(n), line$
                local e=each(vertex 2 to end), v2=(,)
                While e 
                        v2=array(e)
                        line$=vertex#val$(0)+if$(v2#val$(0)<>""->"->"+v2#val$(0)+format$(" {0::-2}",v2#val(1)),"")
                        Print line$
                        Doc$=line$+{
                        }
                end while
        end sub
}
Dijkstra`s_algorithm




Graph:
a->b  7
a->c  9
a->f 14
b->c 10
b->d 15
c->d 11
c->f  2
d->e  6
e->f  9
f
Paths
a to a   0 a
a to b   7 ab
a to c   9 ac
a to d  20 acd
a to e  26 acde
a to f  11 acf
b to a     No Path
b to b   0 b
b to c  10 bc
b to d  15 bd
b to e  21 bde
b to f  12 bcf
c to a     No Path
c to b     No Path
c to c   0 c
c to d  11 cd
c to e  17 cde
c to f   2 cf
d to a     No Path
d to b     No Path
d to c     No Path
d to d   0 d
d to e   6 de
d to f  15 def
e to a     No Path
e to b     No Path
e to c     No Path
e to d     No Path
e to e   0 e
e to f   9 ef
f to a     No Path
f to b     No Path
f to c     No Path
f to d     No Path
f to e     No Path
f to f   0 f

Τρίτη 23 Απριλίου 2019

Anonymous Functions

M2000 support anonymous functions with closures
If a closure is a reference type then saved as reference. So here s is a reference to a stack object. When we wish to use it, preserving items, we have to copy it, using stack() function ( stack(s,s) copy two times, in a new stack object)

Here f closure is a lambda function. A lambda function saved as closure as a value type, so each closure in a f is a new copy. So curry (a variable which hold the lambda function) get a function and all other arguments in a second closure, the stack object, and then return a lambda object. We make a new lambda named curried, which hold the anonymous function.

The disp variable hold another lambda, which we use it with a Call (without returning a result). By default if we use a numeric type lambda we get 0 if no return statement exist in function (we use = as statement to return value(s)).
We can store the lambda function (as a copy) to arrays and inventories (And stack objects, and lambda members of objects type of Group)

In M2000 a call to a function or module done without checking for proper arguments at the calling part. We can analyze the input before the use of arguments in code, but most times we use a Read statement, or the syntactic sugar the parameter list in parenthesis (which make a Read statement). Calling a function by Call we place current stack among the arguments, but using a function in an expression we use new stack with arguments only (can be expand, but at the exit from function the stack deleted).

Type checking are in two levels in M2000. First level, or basic level, is the two types, the numeric and the string type, for return type from expressions. So if we want a string type function we have to use $ in the name and for lambda functions we have to use lambda$ (and not lambda). A numeric type can return objects too. Also the string type may return objects too.

alfa$ =lambda$ ->{
        group k$ {
                k=1000
                value {
                        ="ok"
                }
        }
        =Group$(k)
}
Dim K$(10)
K$(3)=alfa$()
Print K$(3)
Link K$() to K()  ' so K() is a reference to K$()
Print K(3).k


Second level type checking is about the type of arguments. If we don;t provide type then type must be numeric/object or string/object depends of the name (like first level).
In sum function we have a loop while stack is not empty and we get  a number. If stack item isn't a number we get error.
change these lines to pass enum type arguments. We use the peek function, stackitem() which return numeric value even we have object, but we have to drop manual, using drop statement, to emulate a pop from stack.

sum=lambda -> {
        s=0   \\ number pop numbers from stack
        while not empty : s+=stackitem(): drop :end while
        =s
}
enum nums {five=5, seven=7, nine=9}
curried=curry(sum, five, seven, nine)


So in the example bellow we want numbers only (so we use Number which pop a number from stack)



\\ Anonymous Functions
curry=lambda (f)->{
        \\ get arguments as a stack object and store reference to s
        \\ f and s are closures to returned anonymous function
        =lambda f, s=[] -> {
                \\ pass arguments [] to f() if any
                \\ pass arguments using a copy of s
                \\ passing done using ! symbol before a stack object
                =f(![], !stack(s))
        }
}
sum=lambda -> {
        s=0   \\ number pop numbers from stack
        while not empty : s+=number:end while
        =s
}
curried=curry(sum, 5,7,9)
Print curried(1,2,3)=5+7+9+1+2+3  ' true
Print curried(10,20,30)=5+7+9+10+20+30 ' true
Print curried()=5+7+9  ' true
curried2=curry(sum)
Print curried2()=0
curried2=curry(sum, 10,20,30,40)
Print curried2(1,2,3,4)=110
\\ make a closure for a lambda function
disp=lambda title$="my title:" (that$) -> {
        Print title$;that$
}
Call disp("Anonymous Function")
Dim A(10)
A(3)=disp
ret=A(3)("Call from array")
Inventory Abc="100":=disp
ret=Abc("100")("Call from inventory")
ret=lambda title$="another tilte1:" (that$)->{Print title$;that$}("call anonymous function")
ret=lambda title$="another tilte2:" (that$)->{
        Print title$;that$
}("call anonymous function")

Σάββατο 13 Απριλίου 2019

Compiler Task (added Transpiler to M2000 code)

This is a program for Rossetacode.org and first published here




Modules have a stack of values, and when we call a module we pass any argument in this stack, but stack is the current stack, from the caller. So from a module we can return results to same stack. So in console we have a current stack, and a Push 10, "ok"  make two items, one at position 1 of stack as "ok" and a second at position 2 as 10 (default type double). To observe the stack we can use the Stack statement with no arguments. Its good first to flush the stack (to make it empty) using the Flush statement:

Flush
Push 10, "ok"
Stack ' show "ok" 1
Read a$, x
Print a$, x, empty=true ' yes is true
Push 10 : Push "ok"
Data 20 ' this goes to end of stack
Stack ' show "ok" 10 20
Data 1,2,"end"
Stack ' show "ok" 10 20 1 2 "end"
Module Consume { Stack : Read x : Drop x}
Consume 3 ' show 3 "ok" 10 20 1 2 "end"
Stack  ' show 1 2 "end"
Print Match("NNS")=True
Drop Stack.Size ' same as Flush
Print Empty=True ' true


When we call a user function in an expression, interpreter give a fresh new stack of values, so any value on stack at the exit of function just removed as stack destroyed.

Stack pass values by value, and reference type by pointer (a reference is something else from a pointer). Reference type is an array, so if we push an array three time we push only three pointers. If we change the array after the push, then when we read the array we get the changed array. We can use Cons() function to make a copy of one or a copy of the merging of two or more arrays), and pass this new pointer as the array to stack, so only one pointer exist, and this only to stack.

So the following program use the stack, to shared by these modules:

lexical_analyzer, syntax_analyzer, CodeGenerator, Virtual_Machine_Interpreter 


Also we use Set Fast ! and Set Fast, one for changing the way which interpreter control screen refresh, the "Extreme" Fast !, and the "Normal" Fast (there is also the Set Slow). We use Set to send the line of code to command line interpreter (global name space). We can use Fast !, Fast and Slow in M2000 console without Set statement.

The example program (783 lines) get a string in stack of values using a Push statement, and a string in curly brackets (including line separator the two characters crlf) with a context of a program written in a simple language, (which draw a Mandelbrot ascii image), and pass it to lexical analyzer, then to syntax analyzer then to code generator and then to virtual machine. All in one program, with one module the CompilerExample. (M2000 identifiers are not case sensitive, ecxept for labels, for using with goto and gosub - the BASIC type statements).

About scope in M2000. Each module and user function has own scope. A local variable always shadow a global one with the same name. We can use closures to lambda functions, passing them as copies. We can alter the value of a closure inside the lambda function. M2000 can use OOP but here not needed for this task. A subroutine is a code private to a module or and a function. In a subroutine we have the same scope as module or function, so we have to use Local to shadow any module's variable with same name, or when we call again (recursion, or mutual recursion happen). Subs have a limit of 10000 calls for private in module return stack, but we can change that to million calls, using the Recursion.Limit statement (or using Recursion.limit 0 for no limit until we get out of memory, including virtual memory), Modules and Functions have three number to indicate the recursion level, which are the three type of calls, in M2000, the simple call of a module using only the name (6354 calls, but no recursion allowed, so we have to use mutual recursion for global modules), the call using the Call statement for functions and modules (also stack of values are the same for each call, so we get about 5422 calls) and functions calls in expressions (we have new stack of values for every call, about 3233 calls). Arguments passed to stack of values when we call something, not to the return stack. When interpreter loaded to execute, check the length of stack, so we can get these values for calls, using Monitor statement from console. So interpreter has one return stack (size defined in M2000.exe), and for each execution object (modules and functions have execution objects) there is also a subroutine stack. Modules also have a pointer to parent stack of values, and functions (if called in expressions) hold own stack of values. Except return stack, all other stacks are kept in heap.

Local Scope. In Virtual_Machine_Interpreter we use a Call Local to call a lambda function. The Call Local place the current scope to the function which we call. We can use this call for modules and normal functions. When we use arguments we have to use new before the first argument to make the Read new arg1, arg2 ... so we can shadow same name variables. In subroutines these happen automatic. So a call local is like a call to subroutine. Calling a lambda function is a kind of indirect call. A lambda function is a value type. So each time we use a copy (see b=func(eval(code_, pc)) where b get a copy from inventory func() when we pass an opcode from buffer code_ at offset pc)


Use of Tuple. M2000 use a kind of array as tuple. So a (,) is the empty tuple (also called auto array). A ((1,2),(3,4)) is a tuple with two tuples as items. A (1,) is a tuple with one item. A (1) is number 1.  A a=("a","b", (1,2), 100#) is a tuple with strings as the two first items amd a tuple as third and a currency type number as fourth item. Print a#val(2)#val(1)=2 because item 2 is the third item which is a tuple, and item 1 is number 2 (if we want the string value we have to use last val as val$). We make, in the compiler task an AST tree as Tuple in Tuple. The variable a is a pointer to tuple. We can push a tuple to stack and pop it or pick it (we can peek a value from stack using Stackitem() for top or item 1, or we can peek from another position, say 3 we use StackItem(3), and we can use Stacktype$(3) to check for type in a more dynamic perspective)


Print (1,2,3,"a","b")#max()=3 'true
Print (1,2,3,"a","b")#max$()="b" ' true


We use some ready made objects, like Invetories (a type of vector), enum types, Buffer (memory block). Also we use Form ! 120, 60  (for TV to use safe area we use this !, but we can use Form 120, 60 without it for a monitor), which give us a console with 120 characters per line, for 60 lines. We want big width for characters in a line to use it for drawing with ascii. M2000 console works for graphics. Using Move 6000,6000 : Circle 3000 we make a circle of 3000 twips, with a center at 6000twips from left side, and 6000twips from upper side. But for the task we use ascii drawing. We didn't use the Print ordinary statement, but a variant which is like to send unicode characters to a file, but we use #-2 to send it to console screen. The ordinary Print not process CR and LF from chars (the print as spaces), because we use @() to move the cursor to print. Also normal Print statement use columns, so Print #-2 bypass columns, and print to the next. Both Print and Print #-2  use the ; for not using a new line as the last action of statement.


2022 November
We can choose from a message box the virtual machine or the M2000 transpiler. The M2000 transpiler get the same input as the virtual machine from code generator, and make a module, then register to M2000 interpreter with name Run and execute it. For each mnemonic we have module inside Run module, except for fetch and store which we have subroutines. We use the stack of values of M2000 for the stack machine. Also we leave the numbers (address for the virtual machine), because M2000 handle these as numeric labels, and we can use Goto for jump, The Jump on zero (jz mnemonic) we use the If number Else XXX where XXX is the numeric label. The read only variable Number just pop a value from stack (if isn't numeric we get an error but here we now it is numeric).

So this code (Courier font) is actual a M2000 program; The module RUN. See the Inline statement which we place the module as local module of Transpiler_to_M2000 module, which is local to CompilerExample which is local to whatever module name you give to module where you copy the code.

Module Run {Global z
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 {shift 2 : push number div number}
Module mod {shift 2 : push number mod number}
Module sub {shift 2 : push number - number}
Module add {push number + number}
Module prtc {Print #-2, chrcode$(number);:Refresh}
Module prts {Print #-2, var$(number);:Refresh}
Module prti {Print #-2, str$(number, 0);:Refresh}
Dim Base 0, var(15)
Try {
     0 push 420
     5 neg
     6 store(0)
    11 push 300
    16 store(1)
    21 push 300
    26 store(2)
    31 push 300
    36 neg
    37 store(3)
    42 push 7
    47 store(4)
    52 push 15
    57 store(5)
    62 push 200
    67 store(6)
    72 fetch(2)
    77 store(7)
    82 fetch(7)
    87 fetch(3)
    92 gt
    93 if number else  423
    98 fetch(0)
   103 store(8)
   108 fetch(8)
   113 fetch(1)
   118 lt
   119 if number else  396
   124 push 0
   129 store(9)
   134 push 0
   139 store(10)
   144 push 32
   149 store(11)
   154 push 0
   159 store(12)
   164 fetch(12)
   169 fetch(6)
   174 lt
   175 if number else  369
   180 fetch(10)
   185 fetch(10)
   190 mul
   191 push 200
   196 div
   197 store(13)
   202 fetch(9)
   207 fetch(9)
   212 mul
   213 push 200
   218 div
   219 store(14)
   224 fetch(13)
   229 fetch(14)
   234 add
   235 push 800
   240 gt
   241 if number else  298
   246 push 48
   251 fetch(12)
   256 add
   257 store(11)
   262 fetch(12)
   267 push 9
   272 gt
   273 if number else  288
   278 push 64
   283 store(11)
   288 fetch(6)
   293 store(12)
   298 fetch(10)
   303 fetch(9)
   308 mul
   309 push 100
   314 div
   315 fetch(7)
   320 add
   321 store(9)
   326 fetch(13)
   331 fetch(14)
   336 sub
   337 fetch(8)
   342 add
   343 store(10)
   348 fetch(12)
   353 push 1
   358 add
   359 store(12)
   364 goto 164
   369 fetch(11)
   374 prtc
   375 fetch(8)
   380 fetch(4)
   385 add
   386 store(8)
   391 goto 108
   396 push 10
   401 prtc
   402 fetch(7)
   407 fetch(5)
   412 sub
   413 store(7)
   418 goto 82
   423 halt
}
End
Sub store(x)
Read var(x)
End Sub
Sub fetch(x)
Push  var(x)
End Sub
}



And this is the program (we have to copy this in a module), 981 lines of code from both languages..




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(sint(eval(stack_, sp+1)) div sint(eval(stack_, sp))):sp++}
Append func, mod_:=lambda->{Return stack_, sp+1:=uint(sint(eval(stack_, sp+1)) mod 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
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
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 {shift 2 : push number div number}
Module mod {shift 2 : push number mod number}
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