The interpreter was, in my opinion, the best debugging instrument I've ever seen. But now, FreeBasic has only the compiler.
About a year ago, I tried to write an interpreter for the Ultrabasic compiler: it's written in QB and is very primitive.
Right now, it supports:
PRINT (to use with numbers, use STR$)
IF....THEN....ELSE
GOTO
SUB (without args...pretty useless)
it supports a decent parsing, integer variables and operator precedence.
I hope it could become a part of a FB-compatible interpreter, one day...but also a scripting engine, if someone need it.
Here is the source, ported to FB
The DATA lines contain a simple test program that will be run by the interpreter.
Code: Select all
DECLARE FUNCTION getoptype (text$)
DECLARE SUB Show.Error (Number%)
DECLARE FUNCTION CND.IF (Cond$)
DECLARE FUNCTION GetCommands (Line1$, Num)
DECLARE SUB Main (Lines, Start)
DECLARE FUNCTION Evaluate (Expression$)
DECLARE FUNCTION GetNum (Arg$, Num)
DECLARE FUNCTION GetPar$ (Arg$)
DECLARE FUNCTION GetString$ (Arg$, Num)
DECLARE FUNCTION GetType (Var$)
DECLARE SUB Precedence (Arg$)
DECLARE SUB SetVar (Var$, Valore$)
DECLARE FUNCTION GetVar (Var$)
DECLARE FUNCTION GetStringVar$ (Var$)
CONST tbyte = 1, tinteger = 2, tlong = 3, tsingle = 4
CONST tdouble = 5, textended = 6, tstring = 7, arraytype = 1, tnullstring = 8
CONST tlongsingle = 9
DIM SHARED codetext$
DIM SHARED VVariable(300)
DIM SHARED VStrings(300) AS STRING
DIM SHARED Variable$(300)
DIM SHARED CurVar
CLS
DIM SHARED Prog$(1000)
DO
READ c$
X = GetCommands(c$, 0)
FOR I = 0 TO X
IF I > 0 THEN X = GetCommands(c$, I)
Prog$(Riga) = codetext$
Riga = Riga + 1
NEXT
LOOP UNTIL Prog$(Riga - 1) = "END"
Main Riga, 0
DATA "a = 0"
DATA "10"
DATA "A = A + 1"
DATA "if A = 15 then print STR$(999) else print STR$(A): GOTO 10"
DATA "END"
FUNCTION CND.IF (Cond$)
R = 0
Op = 0
FOR I = 1 TO LEN(Cond$)
t$ = MID$(Cond$, I, 1)
IF Op = 0 THEN
P1$ = P1$ + t$
ELSEIF Op = 1 THEN
Comp$ = Comp$ + t$
ELSE
P2$ = P2$ + t$
END IF
IF t$ = " " THEN Op = Op + 1
IF Op = 3 THEN 'Comparing....
IF getoptype(P1$) <> getoptype(P2$) THEN STOP
IF getoptype(P1$) = 2 THEN
'For Numbers
IF RTRIM$(LTRIM$(Comp$)) = "=" THEN
P1 = Evaluate(P1$)
P2 = Evaluate(P2$)
IF P1 = P2 THEN R = -1 ELSE R = 0
END IF
END IF
IF getoptype(P1$) = 1 THEN
'For Strings
IF RTRIM$(LTRIM$(Comp$)) = "=" THEN
PP1$ = GetString$(P1$, 1)
PP2$ = GetString$(P2$, 1)
IF PP1$ = PP2$ THEN R = -1 ELSE R = 0
END IF
END IF
END IF
NEXT
CND.IF = R
END FUNCTION
FUNCTION Evaluate (Expression$)
Res = 0
Par$ = ""
E$ = LTRIM$(RTRIM$(Expression$)) + " "
Precedence E$
FOR I = 1 TO LEN(E$) + 1
t$ = MID$(E$, I, 1)
IF Par <> 0 THEN
IF t$ = "(" THEN Par = Par + 1
IF t$ = ")" THEN
Par = Par - 1
IF Par = 0 THEN
Op$ = STR$(Evaluate(Par$))
Par$ = ""
t$ = " "
END IF
END IF
Par$ = Par$ + t$
t$ = ""
END IF
IF t$ = "(" THEN Par = Par + 1: t$ = ""
IF t$ = " " THEN
IF INSTR("+-*/\", Op$) <> 0 THEN
Operat$ = Op$
ELSE
TT = ASC(UCASE$(LEFT$(Op$, 1)))
IF TT > 64 AND TT < 91 THEN
Op = GetVar(Op$)
ELSE
Op = VAL(Op$)
END IF
SELECT CASE Operat$
CASE "+"
Res = Res + Op
CASE "-"
Res = Res - Op
CASE "*"
Res = Res * Op
CASE "/"
Res = Res / Op
CASE ""
Res = Op
END SELECT
END IF
Op$ = ""
ELSE
Op$ = Op$ + t$
END IF
NEXT
Evaluate = Res
END FUNCTION
FUNCTION GetCommands (Line1$, Num)
codetext$ = Line1$
IF Line1$ = "" THEN Number = 0: EXIT FUNCTION
linea$ = LTRIM$(Line1$) + " "
isThen = 0
Parsed$ = "": Apices = 0
first$ = LTRIM$(LEFT$(linea$, INSTR(linea$, " ") - 1))
IF LEFT$(linea$, 1) = "%" THEN EXIT FUNCTION
IF UCASE$(first$) = "SUB" OR UCASE$(first$) = "FUNCTION" OR UCASE$(first$) = "DECLARE" THEN EXIT FUNCTION
IF first$ = LTRIM$(STR$(VAL(first$))) THEN
Parsed$ = first$ + ":" + CHR$(13)
Number = Number + 1
linea$ = MID$(linea$, LEN(first$) + 1)
END IF
IF RIGHT$(first$, 1) = ":" THEN
Parsed$ = first$ + CHR$(13)
Number = Number + 1
linea$ = MID$(linea$, LEN(first$) + 1)
END IF
FOR I = 1 TO LEN(linea$)
m$ = MID$(linea$, I, 1): IF J > 0 THEN J = J - 1: m$ = ""
IF m$ = CHR$(34) THEN Apices = 1 - Apices
IF Apices = 0 THEN
IF m$ = ":" THEN m$ = CHR$(13): Number = Number + 1
IF m$ = "'" THEN EXIT FOR
IF UCASE$(MID$(linea$, I, 6)) = " THEN " THEN
J = 4
m$ = " THEN" + CHR$(13)
isThen = isThen + 1
END IF
IF UCASE$(MID$(linea$, I, 6)) = " ELSE " THEN
J = 4
m$ = CHR$(13) + "ELSE" + CHR$(13)
Number = Number + 2
END IF
END IF
Parsed$ = Parsed$ + m$
NEXT
Parsed$ = RTRIM$(Parsed$)
IF RIGHT$(Parsed$, 1) = CHR$(13) THEN Parsed$ = LEFT$(Parsed$, LEN(Parsed$) - 1)
IF UCASE$(RIGHT$(Parsed$, 4)) = "THEN" THEN isThen = 0
DO WHILE isThen
Parsed$ = Parsed$ + CHR$(13) + "END IF"
isThen = isThen - 1
Number = Number + 2
LOOP
a = 0
codetext$ = ""
FOR I = 1 TO LEN(Parsed$)
m$ = MID$(Parsed$, I, 1)
IF m$ = CHR$(13) THEN a = a + 1: m$ = ""
IF Num = a THEN codetext$ = codetext$ + m$
NEXT
GetCommands = Number' - Num
END FUNCTION
FUNCTION GetNum (Arg$, Num)
I = 1
FOR a = 1 TO Num
text$ = ""
DO
t$ = MID$(Arg$, I, 1)
I = I + 1
text$ = text$ + t$
IF t$ = "," THEN EXIT DO
LOOP UNTIL I > LEN(Arg$)
NEXT
IF text$ = "" THEN text$ = "0"
'Parse Text$
GetNum = Evaluate(text$)
END FUNCTION
FUNCTION getoptype (text$)
t$ = LTRIM$(text$) + " "
first$ = RTRIM$(LEFT$(t$, INSTR(t$, " ") - 1))
IF LEFT$(first$, 1) = CHR$(34) THEN getoptype = 1: EXIT FUNCTION
IF first$ = "0" OR LTRIM$(RTRIM$(first$)) = LTRIM$(RTRIM$(STR$(VAL(first$)))) THEN
getoptype = 2: EXIT FUNCTION
ELSE
FOR I = 1 TO CurVar
IF UCASE$(first$) = UCASE$(MID$(Variable$(I), 2)) THEN
tipo = ASC(LEFT$(Variable$(I), 1))
IF tipo = tstring THEN getoptype = 1 ELSE getoptype = 2
EXIT FUNCTION
END IF
NEXT
END IF
END FUNCTION
FUNCTION GetPar$ (Arg$)
Par = 0: Found = 0: Virgolette = 0: GetPar$ = ""
FOR I = 1 TO LEN(Arg$)
t$ = MID$(Arg$, I, 1)
IF t$ = CHR$(34) THEN Virgolette = 1 - Virgolette
IF Virgolette = 0 THEN
IF t$ = ")" THEN Par = Par - 1
IF Par = 0 AND Found = 1 THEN GetPar$ = R$: 'EXIT FOR
IF Par > 0 THEN R$ = R$ + t$
IF t$ = " " AND Par = 0 THEN EXIT FOR
IF t$ = "(" THEN
IF Found = 1 THEN R$ = R$ + ", "
Par = Par + 1: Found = 1
END IF
END IF
NEXT
END FUNCTION
FUNCTION GetString$ (Arg$, Num)
'I = 1
FOR a = 1 TO Num
text$ = ""
DO
I = I + 1
t$ = MID$(Arg$, I, 1)
IF t$ = CHR$(34) THEN Virgolette = 1 - Virgolette: t$ = "": X$ = ""
IF Virgolette THEN
text$ = text$ + t$
ELSE
IF t$ = "," THEN EXIT DO
IF MID$(Arg$, I, 4) = "STR$" THEN
I = I + 3
X$ = "": t$ = ""
text$ = text$ + LTRIM$(STR$(Evaluate(GetPar$(MID$(Arg$, I)))))
END IF
IF MID$(Arg$, I, 4) = "CHR$" THEN
I = I + 3
X$ = "": t$ = ""
text$ = text$ + LTRIM$(CHR$(Evaluate(GetPar$(MID$(Arg$, I)))))
END IF
IF t$ = " " THEN
IF LTRIM$(X$) <> "" THEN text$ = text$ + GetStringVar$(X$)
X$ = "": t$ = ""
END IF
IF t$ = "+" THEN t$ = ""
IF t$ = "(" THEN Par = Par + 1: t$ = ""
IF t$ = ")" THEN Par = Par - 1: t$ = ""
IF Par = 0 THEN X$ = X$ + t$
END IF
LOOP UNTIL I >= LEN(Arg$)
NEXT
GetString$ = text$
END FUNCTION
FUNCTION GetStringVar$ (Var$)
FOR I = 1 TO CurVar
IF UCASE$(Var$) = UCASE$(MID$(Variable$(I), 2)) THEN EXIT FOR
NEXT
IF I = CurVar + 1 THEN PRINT "Variabile non definita": END
GetStringVar$ = VStrings(I)
END FUNCTION
FUNCTION GetType (Var$)
IF INSTR(Var$, "(") THEN V$ = LEFT$(Var$, INSTR(Var$, "(") - 1) ELSE V$ = Var$
t$ = RIGHT$(V$, 1)
SELECT CASE t$
CASE "$"
GetType = tstring
CASE ELSE
GetType = tlong
END SELECT
END FUNCTION
FUNCTION GetVar (Var$)
FOR I = 1 TO CurVar
IF UCASE$(Var$) = UCASE$(MID$(Variable$(I), 2)) THEN EXIT FOR
NEXT
IF I = CurVar + 1 THEN PRINT "Variabile non definita": END
GetVar = VVariable(I)
END FUNCTION
SUB Main (Lines, Start)
REDIM Labels(1)
REDIM Labels$(1)
I = Start
DO
Riga$ = RTRIM$(LTRIM$(Prog$(I)))
IF RIGHT$(Riga$, 1) = ":" THEN
Labels$(curlabel) = LEFT$(Riga$, LEN(Riga$) - 1)
Labels(curlabel) = I
curlabel = curlabel + 1
REDIM PRESERVE Labels$(curlabel)
REDIM PRESERVE Labels(curlabel)
END IF
I = I + 1
LOOP UNTIL I > Lines
I = Start
DO
Riga$ = RTRIM$(LTRIM$(Prog$(I))) + " "
Comando$ = RTRIM$(UCASE$(LEFT$(Riga$, INSTR(Riga$, " "))))
Arg$ = LTRIM$(MID$(Riga$, INSTR(Riga$, " ") + 1))
SELECT CASE Comando$
CASE "CLS"
CLS
CASE "PRINT"
PRINT GetString$(Arg$, 1)
CASE "IF"
IF RIGHT$(UCASE$(RTRIM$(Arg$)), 4) = "THEN" THEN Arg$ = LEFT$(RTRIM$(Arg$), LEN(RTRIM$(Arg$)) - 4)
WorkIf = WorkIf + 1
Res = CND.IF(Arg$)
IF Res = 0 THEN
DO
IF UCASE$(Riga$) = "ELSE" THEN EXIT DO
IF UCASE$(Riga$) = "END IF" THEN WorkIf = WorkIf + 1: EXIT DO
I = I + 1
IF I > Lines THEN Show.Error 2
Riga$ = RTRIM$(LTRIM$(Prog$(I)))
LOOP
END IF
CASE "ELSE"
IF WorkIf > 0 THEN
DO
IF UCASE$(Riga$) = "ELSE" THEN EXIT DO
IF UCASE$(Riga$) = "END IF" THEN WorkIf = WorkIf + 1: EXIT DO
I = I + 1
IF I > Lines THEN Show.Error 2
Riga$ = RTRIM$(LTRIM$(Prog$(I)))
LOOP
ELSE
Show.Error 3
END IF
CASE "GOTO"
FOR a = 0 TO curlabel
IF Labels$(a) = RTRIM$(Arg$) THEN I = Labels(a)
NEXT
CASE "SUB"
END
CASE "END"
IF UCASE$(RTRIM$(Arg$)) = "SUB" THEN I = Lines + 1
'END
CASE ELSE
IF LEFT$(Arg$, 1) = "=" THEN
Arg$ = MID$(Arg$, 2)
SetVar Comando$, Arg$
ELSE
FOR a = 0 TO Lines
IF UCASE$(LEFT$(RTRIM$(LTRIM$(Prog$(a))), 3)) = "SUB" THEN
Riga$ = UCASE$(RTRIM$(LTRIM$(Prog$(a)))) + " "
IF RTRIM$(LTRIM$(MID$(Riga$, INSTR(Riga$, " ") + 1))) = Comando$ THEN
insidesub = insidesub + 1
Main Lines, a + 1
insidesub = insidesub - 1
END IF
END IF
NEXT
END IF
END SELECT
I = I + 1
LOOP UNTIL I > Lines
END SUB
SUB Precedence (Arg$)
Virgolette = 0
Prec$ = " */+-"
text$ = ""
DIM Op$(30)
'DO
' a$ = getword$(wordtype)
' IF par$ <> "" THEN a$ = a$ + "(" + par$ + ")"
' IF a$ = ":" THEN text$ = MID$(codetext$, getcharpos + 1): EXIT DO
' IF a$ = lineeof THEN EXIT DO
' op$(R) = a$
' R = R + 1
'LOOP
FOR I = 1 TO LEN(Arg$)
t$ = MID$(Arg$, I, 1)
IF t$ = CHR$(34) THEN Virgolette = 1 - Virgolette
IF Virgolette = 0 THEN
IF t$ = "(" THEN Par = Par + 1
IF t$ = ")" THEN Par = Par - 1
a$ = a$ + t$
IF t$ = " " AND Par = 0 THEN
Op$(R) = RTRIM$(a$)
a$ = ""
R = R + 1
END IF
END IF
NEXT
I = 1
Operand = 2
DO
OldOp = Operand
IF Op$(I) = "" THEN EXIT DO
Operand = INT(INSTR(Prec$, Op$(I)) / 2)
IF Operand = 0 THEN Operand = OldOp
'IF i = 1 THEN OldOp = Operand
IF OldOp > Operand THEN
IF I = 1 THEN
skp = 1
ELSE
Op$(I - 1) = "(" + Op$(I - 1)
END IF
ELSEIF OldOp < Operand THEN
IF skp = 0 THEN
Op$(I - 1) = Op$(I - 1) + ")"
ELSE
skp = 0
END IF
END IF
I = I + 2
LOOP UNTIL I > R
Arg$ = ""
FOR I = 0 TO R: Arg$ = Arg$ + Op$(I) + " ": NEXT
Arg$ = RTRIM$(Arg$) + " " + text$
IF Operand = 1 AND skp = 0 THEN Arg$ = Arg$ + ") "
getcharpos = 0
END SUB
SUB SetVar (Var$, Valore$)
FOR I = 1 TO CurVar
IF UCASE$(Var$) = UCASE$(MID$(Variable$(I), 2)) THEN EXIT FOR
NEXT
IF I = CurVar + 1 THEN
tipo = GetType(Var$)
Variable$(I) = CHR$(tipo) + Var$
CurVar = CurVar + 1
ELSE
tipo = ASC(LEFT$(Variable$(I), 1))
END IF
SELECT CASE tipo
CASE tlong
VVariable(I) = GetNum(Valore$, 1)
CASE tstring
VStrings(I) = GetString(Valore$, 1)
CASE ELSE
END SELECT
END SUB
SUB Show.Error (Number%)
IF Number% = 2 THEN PRINT "Block IF whitout END IF"
IF Number% = 3 THEN PRINT "ELSE whitout IF"
END
END SUB