Post Reply 
Social Buttons
 
Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
angros47qb interprweter -FB
04-17-2018, 08:21 PM
Post: #1
angros47qb interprweter -FB
in FB

Code:
' Basic Interpreter Engine written by Angelo Rosina, 2003 - 2005
DECLARE SUB GetSubVar (Var$, SubVar$)
DECLARE SUB CreateArray (Var$)
DECLARE SUB SetSubVar (Var$, Valore$)
DECLARE SUB BuildCallSymbol ()
DECLARE FUNCTION GetArgs (Arg$)

TYPE SubFunction
  Name AS STRING * 20
  Typ AS INTEGER    '0=SUB             1=Function
  Args(30) AS INTEGER
  Lines AS INTEGER

END TYPE


DECLARE FUNCTION GetOpType (Text$)
DECLARE SUB Show.Error (Number%)
DECLARE FUNCTION CND.IF (Cond$)
DECLARE FUNCTION GetCommands (Line1$, Num)
DECLARE SUB Main (Start)
DECLARE FUNCTION GetNum (Arg$)
DECLARE FUNCTION GetPar$ (Arg$)
DECLARE FUNCTION GetString$ (Arg$)
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(200, 10)
DIM SHARED VStrings(200, 10) AS STRING
DIM SHARED Variable$(200, 10)
DIM SHARED CurVar(10), Lines
DIM SHARED SubRoutines(100) AS SubFunction
DIM SHARED CountSubs, InsideSub
DIM SHARED Params
DIM SHARED Args$(30)


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"
Lines = Riga

BuildCallSymbol

Main 0



DATA "a = 1 + 0"
DATA "Select case a"
DATA "case 1"
DATA "print 1"
DATA "case 2"
DATA "print 2"
DATA "end select"
DATA "END"


SUB BuildCallSymbol
  FOR a = 0 TO Lines
    IF UCASE$(LEFT$(RTRIM$(LTRIM$(Prog$(a))), 3)) = "SUB" OR UCASE$(LEFT$(RTRIM$(LTRIM$(Prog$(a))), 8)) = "FUNCTION" THEN
      Riga$ = UCASE$(RTRIM$(LTRIM$(Prog$(a)))) + " "
      Nome$ = (LTRIM$(MID$(Riga$, INSTR(Riga$, " ") + 1)))
      Arg$ = LTRIM$(RTRIM$(MID$(Nome$, INSTR(Nome$, " "))))
      Nome$ = RTRIM$(LEFT$(Nome$, INSTR(Nome$, " ")))


      SubRoutines(CountSubs).Name = Nome$
      SubRoutines(CountSubs).Typ = 0
      SubRoutines(CountSubs).Lines = a
                        
      Arg$ = GetPar$(Arg$)
      IF LTRIM$(Arg$) <> "" THEN
        Tot = GetArgs(Arg$)
        FOR I = 0 TO Tot
          SubRoutines(CountSubs).Args(I) = GetType(Args$(I))
        NEXT

      ELSE
        SubRoutines(CountSubs).Args(0) = 0
      END IF
      CountSubs = CountSubs + 1
    END IF
  NEXT

END SUB

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 = GetNum(P1$)
        P2 = GetNum(P2$)
        IF P1 = P2 THEN R = -1 ELSE R = 0
      END IF
      IF RTRIM$(LTRIM$(Comp$)) = ">" THEN
        P1 = GetNum(P1$)
        P2 = GetNum(P2$)
        IF P1 > P2 THEN R = -1 ELSE R = 0
      END IF
      IF RTRIM$(LTRIM$(Comp$)) = "<" THEN
        P1 = GetNum(P1$)
        P2 = GetNum(P2$)
        IF P1 < P2 THEN R = -1 ELSE R = 0
      END IF
      IF RTRIM$(LTRIM$(Comp$)) = ">=" THEN
        P1 = GetNum(P1$)
        P2 = GetNum(P2$)
        IF P1 >= P2 THEN R = -1 ELSE R = 0
      END IF
      IF RTRIM$(LTRIM$(Comp$)) = "<=" THEN
        P1 = GetNum(P1$)
        P2 = GetNum(P2$)
        IF P1 <= P2 THEN R = -1 ELSE R = 0
      END IF
      IF RTRIM$(LTRIM$(Comp$)) = "<>" THEN
        P1 = GetNum(P1$)
        P2 = GetNum(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$)
        PP2$ = GetString$(P2$)
        IF PP1$ = PP2$ THEN R = -1 ELSE R = 0
      END IF
    END IF

  END IF


NEXT
CND.IF = R

END FUNCTION

SUB CreateArray (Var$)

  IF INSTR(Var$, "(") = 0 THEN SetVar Var$, "": EXIT SUB

  I = CurVar(InsideSub) + 1
  Tipo = GetType(LEFT$(Var$, INSTR(Var$, "(") - 1))
  Variable$(I, InsideSub) = CHR$(Tipo + 64) + LEFT$(Var$, INSTR(Var$, "(") - 1)
  Par$ = GetPar$(Var$)
  CurVar(InsideSub) = CurVar(InsideSub) + GetNum(Par$)

END SUB

FUNCTION GetArgs (Arg$)
  G = 0
  Par = 0: Found = 0: Virgolette = 0:
  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$ = " " AND Par = 0 THEN EXIT FOR
      IF T$ = "(" THEN Par = Par + 1
      IF T$ = "," AND Par = 0 THEN Args$(G) = R$: R$ = "": T$ = "": G = G + 1
    END IF
    R$ = R$ + T$

  NEXT
  Args$(G) = LTRIM$(RTRIM$(R$))
  GetArgs = G


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 (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 AND LTRIM$(Op$) = "" THEN
          Op$ = STR$(GetNum(Par$))
          Par$ = ""
        
        END IF
        IF Par = 0 THEN T$ = " "
      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
          a = 0
          DO UNTIL a = CountSubs
            IF RTRIM$(SubRoutines(a).Name) = UCASE$(Op$) THEN
              InsideSub = InsideSub + 1
              CurVar(InsideSub) = 0
              Params = GetArgs(Par$)
              Main SubRoutines(a).Lines + 1
              Op = GetVar(Op$)

              Params = GetArgs(Par$)
              Riga$ = UCASE$(RTRIM$(LTRIM$(Prog$(SubRoutines(a).Lines)))) + " "
              Nome$ = (LTRIM$(MID$(Riga$, INSTR(Riga$, " ") + 1)))
              Arg$ = LTRIM$(RTRIM$(MID$(Nome$, INSTR(Nome$, " "))))
              REDIM R$(Params)
              FOR a = 0 TO Params
                R$(a) = LTRIM$(Args$(a))
              NEXT
              IF Params > GetArgs(GetPar(Arg$)) THEN Show.Error 1
              FOR a = 0 TO Params
                GetSubVar R$(a), Args$(a)
              NEXT
              InsideSub = InsideSub - 1
              a = CountSubs + 1
              EXIT DO
            END IF
            a = a + 1
          LOOP
          IF Par$ <> "" THEN Op$ = Op$ + "(" + Par$ + ")"
          IF a = CountSubs THEN Op = GetVar(Op$) ' Is a variable?
        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
  GetNum = Res
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

  IF INSTR(First$, "(") THEN First$ = LEFT$(First$, INSTR(First$, "(") - 1)       'Is Array?
    FOR I = 1 TO CurVar(InsideSub)
      IF UCASE$(First$) = UCASE$(MID$(Variable$(I, InsideSub), 2)) THEN
        Tipo = ASC(LEFT$(Variable$(I, InsideSub), 1))
        IF Tipo > 64 THEN Tipo = Tipo - 64
        IF Tipo = tstring THEN GetOpType = 1 ELSE GetOpType = 2
        EXIT FUNCTION
      END IF
    NEXT
  END IF
  IF RIGHT$(First$, 1) = "$" THEN GetOpType = 1 ELSE GetOpType = 2
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 AND Par = 0 THEN R$ = R$ + ", "
        Par = Par + 1: Found = 1
      END IF
    END IF
  NEXT
END FUNCTION

FUNCTION GetString$ (Arg$)
  '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$ = "," AND Par = 0 THEN EXIT DO

        IF MID$(Arg$, I, 4) = "STR$" THEN
          I = I + 3
          X$ = "": T$ = ""
          Text$ = Text$ + LTRIM$(STR$(GetNum(GetPar$(MID$(Arg$, I)))))
          DO
            I = I + 1
            IF MID$(Arg$, I, 1) = "(" THEN Par = Par + 1
            IF MID$(Arg$, I, 1) = ")" THEN Par = Par - 1
          LOOP UNTIL Par = 0
        END IF

        IF MID$(Arg$, I, 4) = "CHR$" THEN
          I = I + 3
          X$ = "": T$ = ""
          Text$ = Text$ + LTRIM$(CHR$(GetNum(GetPar$(MID$(Arg$, I)))))
          DO
            I = I + 1
            IF MID$(Arg$, I, 1) = "(" THEN Par = Par + 1
            IF MID$(Arg$, I, 1) = ")" THEN Par = Par - 1
          LOOP UNTIL Par = 0
        END IF

        IF T$ = " " AND Par = 0 THEN
          IF LTRIM$(X$) <> "" THEN
            IF INSTR(X$, "(") THEN
              Op$ = LEFT$(X$, INSTR(X$, "(") - 1)
              Par$ = MID$(X$, INSTR(X$, "("))
            END IF
            a = 0
            DO UNTIL a = CountSubs
              IF RTRIM$(SubRoutines(a).Name) = UCASE$(Op$) THEN
                InsideSub = InsideSub + 1
                CurVar(InsideSub) = 0
                Params = GetArgs(Par$)
                Main SubRoutines(a).Lines + 1
                Text$ = Text$ + GetStringVar$(Op$)

                Params = GetArgs(GetPar$(Par$))
                Riga$ = UCASE$(RTRIM$(LTRIM$(Prog$(SubRoutines(a).Lines)))) + " "
                Nome$ = (LTRIM$(MID$(Riga$, INSTR(Riga$, " ") + 1)))
                Arg$ = LTRIM$(RTRIM$(MID$(Nome$, INSTR(Nome$, " "))))
                REDIM R$(Params)
                FOR a = 0 TO Params
                  R$(a) = LTRIM$(Args$(a))
                NEXT
                IF Params > GetArgs(GetPar(Arg$)) THEN Show.Error 1
                FOR a = 0 TO Params
                  GetSubVar R$(a), Args$(a)
                NEXT
                InsideSub = InsideSub - 1
                a = CountSubs + 1

                EXIT DO
              END IF
              a = a + 1
            LOOP
            IF a = CountSubs THEN Text$ = Text$ + GetStringVar$(X$)
          END IF
          X$ = "": T$ = ""
        END IF
        IF T$ = "+" AND Par = 0 THEN T$ = ""
        IF T$ = "(" THEN Par = Par + 1: ' T$ = ""
        IF T$ = ")" THEN Par = Par - 1: ' T$ = ""
        X$ = X$ + T$
      END IF
    LOOP UNTIL I >= LEN(Arg$)
'  NEXT
  GetString$ = Text$
END FUNCTION

FUNCTION GetStringVar$ (Var$)
  IF INSTR(Var$, "(") THEN              'Is Array?
    FOR I = 1 TO CurVar(InsideSub)
      IF UCASE$(LEFT$(Var$, INSTR(Var$, "(") - 1)) = UCASE$(MID$(Variable$(I, InsideSub), 2)) THEN EXIT FOR
    NEXT
    IF I = CurVar(InsideSub) + 1 THEN Show.Error 4
    Par$ = GetPar$(Var$)
    I = I + GetNum(Par$)
    GetStringVar$ = VStrings(I, InsideSub)
  ELSE                                  'Is not an array
    FOR I = 1 TO CurVar(InsideSub)
      IF UCASE$(Var$) = UCASE$(MID$(Variable$(I, InsideSub), 2)) THEN EXIT FOR
    NEXT
    IF I = CurVar(InsideSub) + 1 THEN PRINT "Variabile non definita": END
    GetStringVar$ = VStrings(I, InsideSub)
  END IF
END FUNCTION

SUB GetSubVar (Var$, SubVar$)

  IF UCASE$(LEFT$(LTRIM$(SubVar$), 6)) = "BYVAL " THEN EXIT SUB

  IF INSTR(Var$, "(") THEN              'Is Array?
    FOR I = 1 TO CurVar(InsideSub - 1)
      IF UCASE$(LEFT$(Var$, INSTR(Var$, "(") - 1)) = UCASE$(MID$(Variable$(I, InsideSub - 1), 2)) THEN EXIT FOR
    NEXT
    IF I = CurVar(InsideSub - 1) + 1 THEN EXIT SUB
    Par$ = GetPar$(Var$)
    Tipo = ASC(LEFT$(Variable$(I, InsideSub - 1), 1)) - 64
    I = I + GetNum(Par$)
  ELSE                                  'Is not an array
    FOR I = 1 TO CurVar(InsideSub - 1)
      IF UCASE$(Var$) = UCASE$(MID$(Variable$(I, InsideSub - 1), 2)) THEN EXIT FOR
    NEXT
    IF I = CurVar(InsideSub - 1) + 1 THEN EXIT SUB
    Tipo = ASC(LEFT$(Variable$(I, InsideSub - 1), 1))
  END IF

  SELECT CASE Tipo
  CASE tlong
    VVariable(I, InsideSub - 1) = GetVar(SubVar$)
  CASE tstring
    VStrings(I, InsideSub - 1) = GetStringVar$(SubVar$)
  CASE ELSE
  END SELECT


END SUB

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$)
  IF INSTR(Var$, "(") THEN              'Is Array?
    FOR I = 1 TO CurVar(InsideSub)
      IF UCASE$(LEFT$(Var$, INSTR(Var$, "(") - 1)) = UCASE$(MID$(Variable$(I, InsideSub), 2)) THEN EXIT FOR
    NEXT
    IF I = CurVar(InsideSub) + 1 THEN Show.Error 4
    Par$ = GetPar$(Var$)
    I = I + GetNum(Par$)
    GetVar = VVariable(I, InsideSub)
  ELSE                                  'Is not an array
    FOR I = 1 TO CurVar(InsideSub)
      IF UCASE$(Var$) = UCASE$(MID$(Variable$(I, InsideSub), 2)) THEN EXIT FOR
    NEXT
    IF I = CurVar(InsideSub) + 1 THEN PRINT "Variabile non definita": END
    GetVar = VVariable(I, InsideSub)
  END IF
END FUNCTION

SUB Main (Start)
  REDIM Labels(1)
  REDIM Labels$(1)
  REDIM LoopsIndex(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

  IF InsideSub > 0 THEN
    Riga$ = UCASE$(RTRIM$(LTRIM$(Prog$(I - 1)))) + " "
    Nome$ = (LTRIM$(MID$(Riga$, INSTR(Riga$, " ") + 1)))
    Arg$ = LTRIM$(RTRIM$(MID$(Nome$, INSTR(Nome$, " "))))
    REDIM R$(Params)
    FOR a = 0 TO Params
      R$(a) = LTRIM$(Args$(a))
    NEXT
    IF Params > GetArgs(GetPar(Arg$)) THEN Show.Error 1
    FOR a = 0 TO Params
      SetSubVar Args$(a), R$(a) + " "
    NEXT
  END IF

  DO
    Riga$ = RTRIM$(LTRIM$(Prog$(I))) + " "
    Comando$ = RTRIM$(UCASE$(LEFT$(Riga$, INSTR(Riga$, " "))))
    Arg$ = LTRIM$(MID$(Riga$, INSTR(Riga$, " ") + 1))
  
  
    SELECT CASE Comando$

    CASE "DIM"
      CreateArray Arg$


    CASE "CLS"
      CLS
    CASE "INPUT"
      a = GetArgs(Arg$)
      IF a = 1 THEN PRINT Args$(0);
      INPUT tmp$
      SetVar RTRIM$(Args$(a)), CHR$(34) + tmp$ + CHR$(34)
    CASE "PRINT"
      IF GetOpType(Arg$) = 1 THEN PRINT GetString$(Arg$) ELSE PRINT GetNum(Arg$)
    CASE "LOCATE"
      a = GetArgs(Arg$)
      LOCATE GetNum(Args$(0)), GetNum(Args$(1))

    CASE "IF"
      IF RIGHT$(UCASE$(RTRIM$(Arg$)), 4) = "THEN" THEN Arg$ = LEFT$(RTRIM$(Arg$), LEN(RTRIM$(Arg$)) - 4)
      WorkIf = WorkIf + 1: NewWorkIf = WorkIf
      Res = CND.IF(Arg$)
      IF Res = 0 THEN
        DO
          IF UCASE$(Riga$) = "ELSE" AND NewWorkIf = WorkIf THEN EXIT DO
          IF UCASE$(Riga$) = "END IF" THEN NewWorkIf = NewWorkIf - 1: IF NewWorkIf < WorkIf THEN WorkIf = WorkIf - 1: EXIT DO
          I = I + 1
          IF I > Lines THEN Show.Error 2
          Riga$ = RTRIM$(LTRIM$(Prog$(I)))
          Comando$ = RTRIM$(UCASE$(LEFT$(Riga$, INSTR(Riga$, " "))))
          IF Comando$ = "IF" THEN NewWorkIf = NewWorkIf + 1
        LOOP
      END IF
    CASE "ELSE"
      IF WorkIf > 0 THEN
        NewWorkIf = WorkIf
        DO
          'IF UCASE$(Riga$) = "ELSE" AND NewWorkIf = WorkIf THEN EXIT DO
          IF UCASE$(Riga$) = "END IF" THEN NewWorkIf = NewWorkIf - 1: IF NewWorkIf < WorkIf THEN WorkIf = WorkIf - 1: EXIT DO
          I = I + 1
          IF I > Lines THEN Show.Error 2
          Riga$ = RTRIM$(LTRIM$(Prog$(I)))
          Comando$ = RTRIM$(UCASE$(LEFT$(Riga$, INSTR(Riga$, " "))))
          IF Comando$ = "IF" THEN NewWorkIf = NewWorkIf + 1
        LOOP
      ELSE
        Show.Error 3
      END IF
    CASE "SELECT"
      IF UCASE$(LEFT$(LTRIM$(Arg$), 4)) <> "CASE" THEN Show.Error 13 ELSE Arg$ = MID$(LTRIM$(Arg$), 6)
    
      DO
          IF LEFT$(UCASE$(Riga$), 4) = "CASE" THEN
            IF CND.IF(MID$(Riga$, 6) + " = " + Arg$) THEN EXIT DO
          END IF
          IF UCASE$(Riga$) = "END SELECT" THEN EXIT DO

          I = I + 1
          IF I > Lines THEN Show.Error 14
          Riga$ = RTRIM$(LTRIM$(Prog$(I)))
          Comando$ = RTRIM$(UCASE$(LEFT$(Riga$, INSTR(Riga$, " "))))
      LOOP
    CASE "CASE"
      DO
          IF UCASE$(Riga$) = "END SELECT" THEN EXIT DO
          I = I + 1
          IF I > Lines THEN Show.Error 14
          Riga$ = RTRIM$(LTRIM$(Prog$(I)))
          Comando$ = RTRIM$(UCASE$(LEFT$(Riga$, INSTR(Riga$, " "))))
      LOOP

    CASE "GOTO"
      WorkIf = 0
      FOR a = 0 TO curlabel
        IF Labels$(a) = RTRIM$(Arg$) THEN I = Labels(a)
      NEXT

    CASE "DO"
      LoopsStack = LoopsStack + 1
      REDIM PRESERVE LoopsIndex(LoopsStack)
      LoopsIndex(LoopsStack) = I
    CASE "LOOP"
      IF LoopsStack = 0 THEN Show.Error 10
      I = LoopsIndex(LoopsStack)

    CASE "FOR"
      LoopsStack = LoopsStack + 1
      REDIM PRESERVE LoopsIndex(LoopsStack)
      LoopsIndex(LoopsStack) = I
      ForLoop$ = LEFT$(Arg$, INSTR(UCASE$(Arg$), " TO "))

      Comando$ = RTRIM$(UCASE$(LEFT$(ForLoop$, INSTR(ForLoop$, " "))))
      Arg$ = LTRIM$(MID$(ForLoop$, INSTR(ForLoop$, "=") + 1))
      SetVar Comando$, Arg$
    CASE "NEXT"
      IF LoopsStack = 0 THEN Show.Error 12
      'I = LoopsIndex(LoopsStack)

      Riga$ = UCASE$(RTRIM$(LTRIM$(Prog$(LoopsIndex(LoopsStack)))))

      Comando$ = MID$(Riga$, INSTR(Riga$, " ") + 1)
      Comando$ = RTRIM$(LTRIM$(LEFT$(Comando$, INSTR(Comando$, "=") - 1)))
      Arg$ = RTRIM$(LTRIM$(MID$(Riga$, INSTR(Riga$, " TO ") + 4)))
      SetVar Comando$, Comando$ + " + 1"
      IF GetNum(Comando$) <= GetNum(Arg$) THEN I = LoopsIndex(LoopsStack) ELSE LoopsStack = LoopsStack - 1


    CASE "SUB", "FUNCTION"
      END
    CASE "END"
      IF UCASE$(RTRIM$(Arg$)) = "SUB" OR UCASE$(RTRIM$(Arg$)) = "FUNCTION" THEN I = Lines + 1
      IF UCASE$(RTRIM$(Arg$)) = "IF" THEN WorkIf = WorkIf - 1

      'END
    CASE ELSE
      IF INSTR(Comando$, "(") THEN
        a = 0
        DO
          a = 1
          IF INSTR(Arg$, ")") THEN
            IF INSTR(Arg$, ")") < INSTR(Arg$, "(") OR INSTR(Arg$, "(") = 0 THEN
              a = 0
              Comando$ = Comando$ + " " + LEFT$(Arg$, INSTR(Arg$, ")"))
              Arg$ = LTRIM$(MID$(Arg$, INSTR(Arg$, ")") + 1))
            END IF
          END IF
        LOOP UNTIL a = 1

      END IF
      IF LEFT$(Arg$, 1) = "=" THEN
        Arg$ = MID$(Arg$, 2)
        SetVar Comando$, Arg$
      ELSE
        a = 0
        DO UNTIL a = CountSubs
          IF RTRIM$(SubRoutines(a).Name) = Comando$ THEN
              InsideSub = InsideSub + 1
              CurVar(InsideSub) = 0
              Params = GetArgs(Arg$)
              Main SubRoutines(a).Lines + 1

              Params = GetArgs(Arg$)
              Riga$ = UCASE$(RTRIM$(LTRIM$(Prog$(SubRoutines(a).Lines)))) + " "
              Nome$ = (LTRIM$(MID$(Riga$, INSTR(Riga$, " ") + 1)))
              Arg$ = LTRIM$(RTRIM$(MID$(Nome$, INSTR(Nome$, " "))))
              REDIM R$(Params)
              FOR a = 0 TO Params
                R$(a) = LTRIM$(Args$(a))
              NEXT
              IF Params > GetArgs(GetPar(Arg$)) THEN Show.Error 1
              FOR a = 0 TO Params
                GetSubVar R$(a), Args$(a)
              NEXT
              a = CountSubs - 1
              InsideSub = InsideSub - 1

          END IF
          a = a + 1
        LOOP
      END IF
    END SELECT
    I = I + 1
  LOOP UNTIL I > Lines
  IF WorkIf > 0 THEN Show.Error 2
  IF LoopsStack > 0 THEN Show.Error 11
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 SetSubVar (Var$, Valore$)
  IF UCASE$(LEFT$(LTRIM$(Var$), 6)) = "BYVAL " THEN Var$ = UCASE$(MID$(LTRIM$(Var$), 7))
  Tipo = GetType(Var$)
  CurVar(InsideSub) = CurVar(InsideSub) + 1
  I = CurVar(InsideSub)
  Variable$(I, InsideSub) = CHR$(Tipo) + Var$

  InsideSub = InsideSub - 1

  SELECT CASE Tipo
  CASE tlong
    VVariable(I, InsideSub + 1) = GetNum(Valore$)
  CASE tstring
    VStrings(I, InsideSub + 1) = GetString(Valore$)
  CASE ELSE
  END SELECT

  InsideSub = InsideSub + 1

END SUB

SUB SetVar (Var$, Valore$)
  IF INSTR(Var$, "(") THEN              'Is Array?
    FOR I = 1 TO CurVar(InsideSub)
      IF UCASE$(LEFT$(Var$, INSTR(Var$, "(") - 1)) = UCASE$(MID$(Variable$(I, InsideSub), 2)) THEN EXIT FOR
    NEXT
    IF I = CurVar(InsideSub) + 1 THEN Show.Error 4
    Tipo = ASC(LEFT$(Variable$(I, InsideSub), 1)) - 64

    Par$ = GetPar$(Var$)
    I = I + GetNum(Par$)
  ELSE                                  'In not an array

    FOR I = 1 TO CurVar(InsideSub)
      IF UCASE$(Var$) = UCASE$(MID$(Variable$(I, InsideSub), 2)) THEN EXIT FOR
    NEXT
    IF I = CurVar(InsideSub) + 1 THEN
      Tipo = GetType(Var$)
      Variable$(I, InsideSub) = CHR$(Tipo) + Var$
      CurVar(InsideSub) = CurVar(InsideSub) + 1
    ELSE
      Tipo = ASC(LEFT$(Variable$(I, InsideSub), 1))
    END IF
  END IF

  SELECT CASE Tipo
  CASE tlong
    VVariable(I, InsideSub) = GetNum(Valore$)
  CASE tstring
    VStrings(I, InsideSub) = GetString(Valore$)
  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 without IF"
  IF Number% = 4 THEN PRINT "Array not defined"
  IF Number% = 10 THEN PRINT "LOOP without DO"
  IF Number% = 11 THEN PRINT "FOR without NEXT"
  IF Number% = 12 THEN PRINT "NEXT without FOR"
  IF Number% = 13 THEN PRINT "CASE expected"
  IF Number% = 14 THEN PRINT "SELECT without END SELECT"

  END
END SUB
Find all posts by this user
Quote this message in a reply
Post Reply 


Forum Jump:


User(s) browsing this thread: