This is the code for Karel Programming Language.
See Part2 for test pictures,
update 1. A local definition for oldi variable in Sub Control(). Subs are static parts of modules, they have same scope as the module, but any new variable (and other identifier) erased at the exit. A local definition make a shadow to same names. Perhaps was not fault for oldi to not to be a local variable. Because in advance stages the i variable can be for another time oldi=i which means we have no statement. The checkEnd() sub has local oldi, so between block of begin end there are separate oldi variable.
When you copy this code in M2000 editor (edit a then press enter in M2000 console), use Shift F2 or Shift F3 to open inputbox for searching names. Also use F6, F7, F8 to bookmark cursor position at specific paragraph. Use F1 to change from Wrap to Unwrap word (one line per paragraph). Use Esc to exit the editor, then write the name of module and press enter. You can save using save and a name like save Karel1 then next time from console ctrl+A save again (send Save commnad$ to keyboard buffer).
You can use Test nameofmodule to run step by step the code. You can put Assert and Stop statements (stop statement enter in stop mode which we can continue writing Exit, in this mode we can create and alter variables, we can use List and Modules ? commands)
M2000 is an interpreter without using lexical and syntax analyser before execution. Also there is no a tokenize form of code. Code consuming as executed. There are copies of code used in loops. M2000 Interpreter is a big function, although using objects can use threads, events, different output layers. Code of M2000 Environment is pure machine code without array checks, writing in Visual Basic 6. With modern cpu, code executed in high speed memory cache, and VB6 modules (chunk of code) are always in 64k pages utilizing short jumps, which are the faster from anything else. So M2000 has a slow interpreter executed in fast machine code.
Scope of M2000 is to be used in Education. It is an open source project. See the git link in the right column. Also check here https://rosettacode.org/wiki/Category:M2000_Interpreter
flush
Window 12, 0
Form 80, 60
Const NoPrintLexar=True
const BEGINNING_OF_PROGRAM$="BEGINNING-OF-PROGRAM"
const END_OF_PROGRAM$="END-OF-PROGRAM"
const BEGINNING_OF_EXECUTION$="BEGINNING-OF-EXECUTION"
const END_OF_EXECUTION$="END-OF-EXECUTION"
const BEGIN_BLOCK$="BEGIN"
const END_BLOCK$="END"
const DEFINE_NEW_INSTRUCTION$="DEFINE"
const DEFINE_CONTINUE$="AS"
const ITERATE$="ITERATE"
const ITERATE_CONTINUE$="TIMES"
const IF$="IF"
const IF_THEN$="THEN"
const IF_ELSE$="ELSE"
const LOOP_CHECK$="WHILE"
const LOOP_CONTINUE$="DO" ' - expected one statement or a BLOCK
Enum Condition {
FRONT.IS.CLEAR=-10000, FRONT.IS.BLOCKED, LEFT.IS.CLEAR
LEFT.IS.BLOCKED, RIGHT.IS.CLEAR, RIGHT.IS.BLOCKED
BACK.IS.CLEAR, BACK.IS.BLOCKED, NEXT.TO.A.BEEPER
NOT.NEXT.TO.A.BEEPER, ANY.BEEPERS.IN.BEEPER.BAG, NO.BEEPERS.IN.BEEPER.BAG
FACING.NORTH, NOT.FACING.NORTH, FACING.SOUTH, NOT.FACING.SOUTH
FACING.EAST, NOT.FACING.EAST, FACING.WEST, NOT.FACING.WEST
}
Const Block_=-1000
Enum ControlStatements {
Iterate_=-2000, If_, While_, Base_ ' need for computed On Goto
}
Enum Instruction { MOVE=-1510, TURNLEFT, PICKBEEPER, PUTBEEPER,TURNOFF}
Identifiers=Queue:="MOVE":=MOVE, "TURNLEFT":=TURNLEFT,"PICKBEEPER":=PICKBEEPER
Append Identifiers, BEGINNING_OF_PROGRAM$:=-3000, END_OF_PROGRAM$:=-3000
Append Identifiers, BEGINNING_OF_EXECUTION$:=-3000, END_OF_EXECUTION$:=-1000
Append Identifiers, "PUTBEEPER":=PUTBEEPER,"TURNOFF":=TURNOFF
Append Identifiers, BEGIN_BLOCK$:=Block_, END_BLOCK$:=-1000
Append Identifiers, ITERATE$:=Iterate_, ITERATE_CONTINUE$:=-3
Append Identifiers, IF$:=If_, IF_THEN$:=-3000, IF_ELSE$:=-3000, LOOP_CHECK$:=While_, LOOP_CONTINUE$:=-3000
Append Identifiers,"FRONT-IS-CLEAR":=FRONT.IS.CLEAR, "FRONT-IS-BLOCKED":=FRONT.IS.BLOCKED
Append Identifiers, "LEFT-IS-CLEAR":=LEFT.IS.CLEAR, "LEFT-IS-BLOCKED":=LEFT.IS.BLOCKED
Append Identifiers,"RIGHT-IS-CLEAR":=RIGHT.IS.CLEAR, "RIGHT-IS-BLOCKED":=RIGHT.IS.BLOCKED
Append Identifiers,"BACK-IS-CLEAR":=BACK.IS.CLEAR, "BACK-IS-BLOCKED":=BACK.IS.BLOCKED
Append Identifiers,"NEXT-TO-A-BEEPER":=NEXT.TO.A.BEEPER, "NOT-NEXT-TO-A-BEEPER":=NOT.NEXT.TO.A.BEEPER
Append Identifiers,"ANY-BEEPERS-IN-BEEPER-BAG":=ANY.BEEPERS.IN.BEEPER.BAG
Append Identifiers,"NO-BEEPERS-IN-BEEPER-BAG":=NO.BEEPERS.IN.BEEPER.BAG, "FACING-NORTH":=FACING.NORTH
Append Identifiers,"NOT-FACING-NORTH":=NOT.FACING.NORTH, "FACING-SOUTH":=FACING.SOUTH
Append Identifiers,"NOT-FACING-SOUTH":=NOT.FACING.SOUTH, "FACING-EAST":=FACING.EAST
Append Identifiers,"NOT-FACING-EAST":=NOT.FACING.EAST, "FACING-WEST":=FACING.WEST
Append Identifiers,"NOT-FACING-WEST":=NOT.FACING.WEST
Append Identifiers, DEFINE_NEW_INSTRUCTION$:=-3000, DEFINE_CONTINUE$:=-3000
Starting_Identifiers=Len(Identifiers)
Enum CodeFields { Where=0, Numeric=1, Identifier=1, TypeOf=2}
Global SOURCE$
Document SOURCE$<={Programm here
}
S_DIGIT$="[0-9]"
S_LETTER1$="[A-Z-]"
S_LETTER2$="[A-Z0-9-]"
S_NUMBER=lambda S_DIGIT$ (where) ->{
i=where
while mid$(SOURCE$, i,1) ~ S_DIGIT$: i++: end while
if i>where then
=true, val(mid$(SOURCE$,where,i-where)), i
else
=false, 0, i, "Missing Number"
end if
}
S_NAME=lambda S_LETTER1$, S_LETTER2$ (where) ->{
i=where
while mid$(SOURCE$, i,1) ~ S_LETTER1$: i++: end while
if i>where then
while mid$(SOURCE$, i,1) ~ S_LETTER2$: i++: end while
=true, mid$(SOURCE$,where,i-where), i
else
=false, "", i, "Missing Name"
end if
}
// ALSO WE DEFINE LEADING ZERO AS WHITE SPACE
// ITERATION 0 NOT ALLOWED
S_ADVANCE1=lambda (max)->{
WhiteSpace$=chr$(9)+" "+chr$(10)+chr$(13)+"0"+";"+chrcode$(160)
toline=1 : toPos=0 : oldwhere=1 : cr$=chr$(10)
=lambda WhiteSpace$, max, StopErr, toline, toPos, cr$, oldwhere (where, &where$) ->{
i=where
toPos+=i-oldwhere
where$=format$("Line: {0}, Pos: {1}", toLine, toPos)
if StopErr then
Gosub 1000
else.if i<=max then
while instr(WhiteSpace$, mid$(SOURCE$,i,1))>0
i++
if mid$(SOURCE$,i,1)=cr$ then toline++ : toPos=-1 else toPos++
if i=max then Gosub 1000: Break
End While
where$=format$("Line: {0}, Pos: {1}", toLine, toPos+1)
oldwhere=i
=true, 0, i
else
Gosub 1000
end if
exit
1000 =false, 0, max+1, "End of Source" :StopErr=True:Return
}
}
Clear SOURCE$
Rem {
Init_SOURCE$={BEGINNING-OF-PROGRAM
DEFINE turnright AS
BEGIN
Iterate 4 times turnleft
FINDPASS
END
DEFINE FINDPASS AS
BEGIN
WHILE FRONT-IS-BLOCKED DO
turnleft
END
BEGINNING-OF-EXECUTION
IF RIGHT-IS-BLOCKED THEN
ITERATE 3 TIMES
BEGIN Begin begin
turnright TURNLEFT
End end WHILE FRONT-IS-BLOCKED DO
FINDPASS
END else turnoff
END-OF-EXECUTION
END-OF-PROGRAM
}
}
Init_SOURCE$={BEGINNING-OF-PROGRAM
DEFINE turnright AS
BEGIN
Iterate 4 times turnleft FINDPASS END
DEFINE FINDPASS AS
BEGIN WHILE FRONT-IS-BLOCKED DO turnleft
END
BEGINNING-OF-EXECUTION
IF RIGHT-IS-BLOCKED THEN bEGIN
ITERATE 3 TIMES BEGIN Begin begin turnright TURNLEFT End
begin MOVE end end WHILE FRONT-IS-BLOCKED DO FINDPASS
END END else BEGIN turnoff end
END-OF-EXECUTION
END-OF-PROGRAM
}
SOURCE$<=UCASE$(Init_SOURCE$)
S_ADVANCE=S_ADVANCE1(Doc.Len(SOURCE$))
Enum Place {OK=0, RetValue, NewPc, ErrMessage}
pc=1
resp=(true,)
Report 6, "Start of Source"
For This {
// BLOCK FOR TEMPORARY DEFINITIONS
if Init_SOURCE$="" then exit
local lines$(), nl$=chr$(13)+chr$(10) ' crlf
lines$()=Piece$(Init_SOURCE$, nl$)
dim lines$(1 to len(lines$()))
if len(lines$())<2 then break ' EXIT FROM PROGRAM
local i
for i=0 to 59
Print @(i+10, row);(i+1) mod 10,
next
for i=1 to len(lines$())-1
Print Part $(0), str$(i, " 0000 "), ~(11), @(10), lines$(i)
next
}
Report 6, "End of Source"
Print Over $(6), "Lexar Analyser"
Code=List
CodePc=1
const IsName$="NAME", IsNumber$="NUMBER"
There$=""
NoMoreNewNames=false
While resp#val(OK)
resp=S_ADVANCE(pc, &There$)
pc=resp#val(NewPc)
Print $(4), ' proportional output
if resp#val(OK) Then
resp=S_NUMBER(pc)
pc=resp#val(NewPc)
if resp#val(OK) Then
if NoPrintLexar Else PrinCode2(4, resp#val$(RetValue), 24, IsNumber$, 48, There$)
Append Code, CodePc:=(There$,resp#val(RetValue), IsNumber$)
CodePc++
pc=resp#val(NewPc)
else
resp=S_NAME(pc)
pc=resp#val(NewPc)
if resp#val(OK) Then
if Not Exist(identifiers, resp#val$(RetValue)) then
if NoMoreNewNames then resp=(false, 0, 0, "Undefined Name:"+resp#val$(RetValue) ) : exit
Append identifiers, resp#val$(RetValue):= 1
Append Code, CodePc:=(There$,resp#val$(RetValue), IsName$)
else.if Type$(Identifiers, resp#val$(RetValue))="Condition" then
Append Code, CodePc:=(There$,identifiers(resp#val$(RetValue)),resp#val$(RetValue))
else
if not NoMoreNewNames then
if "BEGINNING-OF-EXECUTION"=resp#val$(RetValue) then
NoMoreNewNames=True
end if
end if
Append Code, CodePc:=(There$,resp#val$(RetValue), IsName$)
end if
if NoPrintLexar Else PrinCode2(4, resp#val$(RetValue), 24,Code(CodePc)#val$(TypeOf),48, There$)
CodePc++
pc=resp#val(NewPc)
end if
end if
end if
End While
if "End of Source"=resp#val$(ErrMessage) then
Print Over $(6), "Success OK"
else
if resp#val(OK) Else Print Over $(6),"Last Error:"+resp#val$(ErrMessage)+" at "+There$ : Print : Exit
end if
Print Over $(6), "Syntax Analyser"
if codePc=1 then Print "Nothing to Analyse": Exit
i=1
Ruller=lambda Add=0 (x=1, opcode=0)->{
select case opcode
case <0
Add+=4*opcode:if Add<0 then Add=0
case >0
Add+=4*opcode
end select
select case x
case <=1
=0+ADD
case 2
=12+ADD
case <4
=12+(x-2)*4+ADD
else case
=(X-1)*4
end select
}
HaveErr=false
R=Ruller(0,0)
if @Check(1, BEGINNING_OF_PROGRAM$, false) then
PrinCode(BEGINNING_OF_PROGRAM$+" ",i)
R=Ruller(1,1)
if @Check(codePc-1, END_OF_PROGRAM$, false) then
i=2
while @Check(i, DEFINE_NEW_INSTRUCTION$, true)
HaveErr=True
if @CheckNewName(i+1) then
if @Check(i+2, DEFINE_CONTINUE$, false) then
PrinCode("DEFINITION "+code(i+1)#val$(Identifier)+" ",i)
R=Ruller(1, 1)
i+=3
checkBlock(false)
R=Ruller(1, -1)
if HaveErr then exit
end if
else
exit
end if
end while
if HaveErr then break
' CHECK FOR NAME undefined
IF Starting_Identifiers<Len(Identifiers) then
s$=""
for j=Starting_Identifiers to Len(Identifiers)-1
// key, value by index
if Identifiers(j!)=1 then s$+=" "+Eval$(Identifiers, j): HaveErr=True
next
end if
if HaveErr then Print "Look Definitions, You Have Undefined Names:"+s$ : break
if @Check(i, BEGINNING_OF_EXECUTION$, false) then
if @Check(codePc-2, END_OF_EXECUTION$, false) then
PrinCode(BEGINNING_OF_EXECUTION$+" ",i)
R=Ruller(1,1)
codePc--
i++
Execute(false)
end if
if HaveErr Then Exit
R=Ruller(1,-1)
if codePc-1=i then
PrinCode(END_OF_EXECUTION$+" ",i)
R=Ruller(1,-1)
end if
i++
if codePc=i then
PrinCode(END_OF_PROGRAM$+" ",i)
Else
Print "Syntax Error at", code(i)#val$(Where) :HaveErr=true
end if
end if
end if
end if
Push Key$ : Drop
END
Function Check(i, what$, NoErr)
if i>=codePc then
Print "Missing "+what$+", unexpected end of source"
else.if code(i)#val$(identifier)<>what$ then
If NoErr Else Print "Missing "+what$+" at "+code(i)#val$(Where) :HaveErr=true
else
=true
end if
End Function
Function CheckByType(i, what$)
if i>=codePc then
Print "Missing Type "+what$+", unexpected end of source"
else.if code(i)#val$(TypeOf)<>what$ then
Print "Missing TypeOf "+what$+" at "+code(i)#val$(Where) :HaveErr=true
else
=true
end if
End Function
Function CheckActualType(i, what$)
if i>=codePc then
Print "Missing Type "+what$+", unexpected end of source"
else
if type$(code,i,identifier)<>what$ then
Print "Missing type of "+what$+" at "+code(i)#val$(Where) :HaveErr=true
else
=true
end if
end if
End Function
Function CheckNewName(i)
if i>=codePc then
Print "type of "+IsName$+", unexpected end of source"
else.if code(i)#val$(TypeOf)<>IsName$ then
Print "Missing type of "+IsName$+" at "+code(i)#val$(Where)
HaveErr=true
else.if Exist(Identifiers, code(i)#val$(Identifier)) then
if Identifiers(code(i)#val$(Identifier))=1 then
Return Identifiers, code(i)#val$(Identifier):=i+3
=true
else
Print "This Identifier "+ code(i)#val$(Identifier)+" exist, error at "+code(i)#val$(Where)
HaveErr=true
end if
else
Append Identifiers, code(i)#val$(Identifier):=i+3
=true
end if
End Function
Sub checkBlock(Skip)
HaveErr=false
if @Check(i, BEGIN_BLOCK$, Skip) then
PrinCode("CODE BLOCK("+BEGIN_BLOCK$+")",i)
R=Ruller(1,1)
i++
HaveErr=True
local mine=true
checkEnd()
if mine and HaveErr then
Print "Missing "+END_BLOCK$+", error at "+code(i)#val$(Where)
end if
else.if not skip then
HeveErr=true
end if
End Sub
Sub checkEnd()
Local oldi
100 mine=true
if @Check(i, END_BLOCK$, true) then 101
if i>=codePc then Exit Sub
If @Terminal() Then
HaveErr=True
Exit sub
End If
oldi=i
Execute(true)
if HaveErr then mine=false: exit sub
if i=oldi then
if CodePc-1<=i then
HaveErr=True
mine=true
End if
exit sub
end if
goto 100
101 R=Ruller(1,-1)
PrinCode("CODE BLOCK("+END_BLOCK$+")",i)
i++
end Sub
Sub Execute(One as boolean)
local tp$
110 if i>=codePc then Exit Sub
checkBlock(true)
if HaveErr then exit sub
if code(i)#val$(TypeOf)=IsName$ then
tp$=type$(identifiers, code(i)#val$(Identifier))
if tp$="Instruction" then
instruction()
else.if tp$="ControlStatements" then
control(identifiers(code(i)#val$(Identifier)))
else.if identifiers(code(i)#val$(Identifier))>0 then
PrinCode("CALL("+code(i)#val$(Identifier)+")",i)
else.if identifiers(code(i)#val$(Identifier))=-1000 then
// MARKERS LIKE END BLOCK
exit sub
else
Print "Syntax Error at", code(i)#val$(Where) :HaveErr=true
end if
else
Print "Syntax Error at", code(i)#val$(Where) :HaveErr=true
end if
if HaveErr then exit sub
i++
if one else goto 110
end Sub
sub instruction()
PrinCode("INSTRUCTION("+code(i)#val$(Identifier)+")",i)
end sub
sub control(m as ControlStatements)
local N, oldi
on Base_-m goto whileStat, ifStat , iterateStat
whileStat:
if not @CheckActualType(i+1, "Condition") then exit sub
i++
N=code(i)#val(identifier)
if not @Check(i+1, LOOP_CONTINUE$, false) then Exit Sub
PrinCode("FLOW CONTROL("+Ucase$(filter$(eval$(m),"_"))+" "+code(i)#val$(TypeOf)+" "+LOOP_CONTINUE$+")",i-1)
i+=2
HaveErr=false
oldi=i
checkBlock(true)
if oldi=i then
R=Ruller(1,4)
Execute(True)
R=Ruller(1,-4)
End if
if not HaveErr then if oldi=i then HaveErr=True : NoStatement() : exit sub
i--
exit sub
ifStat: ' IF$
if not @CheckActualType(i+1, "Condition") then exit sub
i++
N=code(i)#val(identifier)
if not @Check(i+1, IF_THEN$, false) then Exit Sub
PrinCode("FLOW CONTROL("+Ucase$(filter$(eval$(m),"_"))+" "+code(i)#val$(TypeOf)+" "+IF_THEN$+")",i-1)
i+=2
HaveErr=false
oldi=i
checkBlock(true)
if oldi=i then
R=Ruller(1,4)
Execute(True)
R=Ruller(1,-4)
End if
if not HaveErr then if oldi=i then HaveErr=True : NoStatement() : exit sub
if not @Check(i, IF_ELSE$, true) then i--: Exit Sub
PrinCode("FLOW CONTROL("+IF_ELSE$+")",i)
i++
HaveErr=false
oldi=i
checkBlock(true)
if oldi=i then
R=Ruller(1,4)
Execute(True)
R=Ruller(1,-4)
End if
if not HaveErr then if oldi=i then HaveErr=True : NoStatement() : exit sub
i--
exit sub
iterateStat:
if not @CheckByType(i+1, IsNumber$) then exit sub
i++
N=code(i)#val(Numeric)
if not @Check(i+1, ITERATE_CONTINUE$, false) then Exit Sub
PrinCode("FLOW CONTROL("+Ucase$(filter$(eval$(m),"_"))+" "+code(i)#val$(numeric)+" "+ITERATE_CONTINUE$+")", i-1)
i+=2
HaveErr=false
oldi=i
checkBlock(true)
if oldi=i then
R=Ruller(1,4)
Execute(True)
R=Ruller(1,-4)
End if
if not HaveErr then if oldi=i then HaveErr=True : NoStatement() : exit sub
i--
end sub
Function Terminal()
=false ' optional, by default return 0 (false)
if Not code(i)#val$(TypeOf)=IsNumber$ Then
if exist(Identifiers, code(i)#val$(identifier)) then
=eval(identifiers)=-3000
end if
end if
End Function
Sub NoStatement()
Print "Expected a statement at "+code(i)#val$(Where)
End Sub
// help subs
Sub PrinCode(What$, p)
if p mod 2=1 Then Print Over ~(pen, 1,1), ""
Print part @(Ruller()), ~(15),what$,@(width-10), ~(#FFCCFF), code(p)#val$(Where)
refresh
end sub
Sub PrinCode2(n, one$, n1, two$, n2, three$)
Print @(n), two$, @(n1), one$, @(n2), three$
refresh
End Sub
Δεν υπάρχουν σχόλια:
Δημοσίευση σχολίου
You can feel free to write any suggestion, or idea on the subject.