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

### Dijkstra's algorithm

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

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
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

pre.cjk { font-family: "Courier New", monospace; }p { margin-bottom: 0.25cm; line-height: 115%; }
```
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.

```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
=false
Try {
\\ second parameter is the offset in buffer units
\\ third parameter is length in bytes
=Eval\$(Scanner, offset,2*len(a\$))=a\$
}
}
=false
Try {
=Eval\$(Scanner, offset,2) ~ a\$
}
}
const nl\$=chr\$(13)+chr\$(10), quo\$="""", er\$="@", Ansi=3
Try {
Do
offset+=2 :     ColumnNo+=2
lineNo++: ColumnNo=1 : offset+=2
Else
offset++ : ColumnNo++
End If
if offset>lim then
End if
End While
offset+=2 : ColumnNo+=2
LineNo++: ColumnNo=1
offset+=2
} Else.if Ahead(quo\$, offset) Then {
Output\$=format\$("{0::-10}{1::-10} ", LineNo, ColumnNo)
offset++ : ColumnNo++
strin=offset
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
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++
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++
offset++ : ColumnNo++
End While
{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\$
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 "+"
case "-"
a\$="Op_subtract"
case "%"
a\$="Op_mod"
case "<"
offset++
a\$="Op_lessequal"
ColumnNo++
else
a\$="Op_less"
end if
}
case ">"
offset++
ColumnNo++
a\$="Op_greaterequal"
else
a\$="Op_greater"
end if
}
case "="
offset++
ColumnNo++
a\$="Op_equal"
else
a\$="Op_assign"
end if
}
case "!"
offset++
ColumnNo++
a\$="Op_notequal"
else
a\$="Op_not"
end if
}
case "&"
offset++
ColumnNo++
a\$="Op_and"
else
a\$=""
end if
}
case "|"
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\$
}
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

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\$
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)))
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)
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)
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.
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)

If not stack.size=1 Then Flush : Error "Ast not loaded"
AST=array   \\ pop the array from stack

\\ 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\$

\\ we use an iterator object, str^ is the counter, readonly, but Eval\$() use it from object.
str=each(strings)
While str
End while
Assembly\$=nl\$
\\ insert to line 1 the 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
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\$)
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 numbern 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
let pc=0, sp=len(stack_) div 4
do
b=func(eval(code_, pc))
pc++
call local b()
until exit_now
Print "done"
}
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;
}
}
}

Form ! 120, 60
Refresh
Print "Lexical Analyzer" : Refresh
lexical_analyzer
Print "Syntax Analyzer" : Refresh
syntax_analyzer
Print "Code Generator" : Refresh
CodeGenerator
Virtual_Machine_Interpreter
Set Fast 'restore speed setting
}
CompilerExample```