Home » 2018 » August » 12 » JimK3
2:38 AM
JimK3
'------------------------------------------------------
'Small Basic by Jim Klutho based on examples by H.Schildt & various sources
'use at own risk    for PBCC
'this is a core of simple basic-like language
'mod for Oxygen Basic by Aurel 7/2018
'compilation require : Oxygen Basic A041 , awinh.inc ,RTL32.inc
'#lookahead
'o2 specific...............................................
$ Filename "JimK3.exe" ' o2
include "RTL32.inc"
include "awinh.inc"
NumberFormat 4,1,0,0,0,0
INT win, b1ID = 100, b2ID = 101
INT startp=10
'..........................................................

% SB_NUM_LAB=100
% SB_NUM_CMDS=20
% SB_NUM_ERRS=19
% SB_LAB_LEN=25
% SB_FOR_NEST=25
% SB_SUB_NEST=25
% SB_TABSTOP=8
'---------TOKEN TYPES-------------
% SB_UNDEFTOK=0
% SB_DELIMITER=1
% SB_NUMBER=2
% SB_VARIABLE=3
% SB_COMMAND=4
% SB_STRING=5
% SB_QUOTE=6
% SB_VARISTR=7
% SB_LABEL=8
'-----------COMMAND TOKENS - Tok --
% SB_UNKNCOM=0
% SB_PRINT=1
% SB_INPUT=2
% SB_IF=3
% SB_THEN=4
% SB_FOR=5
% SB_NEXT=6
% SB_TO=7
% SB_GOTO=8
% SB_GOSUB=9
% SB_RETURN=10
% SB_EOL=11
% SB_FORMAT=12
% SB_FINISHED=13
% SB_END=14
'--------------RELATIONAL OPS---------
% SB_GE=1
% SB_NE=2
% SB_LE=3
'-------------ERROR TYPES--------------
% SB_SERROR=1  'syntax error
% SB_PARENS=2  'parren error
% SB_NOEXP=3
% SB_DIV_ZERO=4
% SB_EQUAL_EXP=5
% SB_NOT_VAR=6
% SB_LAB_TAB_FULL=7
% SB_DUP_LAB=8
% SB_UNDEF_LAB=9
% SB_THEN_EXP=10
% SB_TO_EXP=11
% SB_TOO_MNY_FOR=12
% SB_NEXT_WO_FOR=13
% SB_TOO_MNY_GOSUB=14
% SB_RET_WO_GOSUB=15
% SB_MISS_QUOTE=16
% SB_BAD_FILE=17
% SB_STR_EXP=18
% SB_UNKNOWN_KEYWORD=19
'----------------TYPES---------
TYPE TAB_TYPE
   Command AS STRING
   Tok AS LONG
End TYPE

TYPE LAB_TYPE
   Lname AS STRING
   p AS LONG
End TYPE

TYPE FOR_STACK_TYPE
   vari AS LONG
   Target AS LONG
   Location AS LONG
End TYPE
'-------------------DECLARE VARIABLES------------
Dim Variables[256] AS FLOAT
Dim VarStrings[256] AS STRING
Dim ProgPtr AS LONG  'THIS IS THE POINTER
Dim Token AS STRING
Dim Token_Type AS LONG
Dim Tok  AS INT
Dim Ftos AS LONG
Dim Gtos AS LONG
Dim Relops AS STRING
Dim MyProg AS STRING
Dim Table[256] AS TAB_TYPE
Dim Label_Table[256] AS LAB_TYPE
Dim FStack[256] AS INT
Dim GStack[256] AS LONG
Dim gLineCount AS LONG
Dim ErrorFlag AS LONG
Dim gSB_Format AS STRING
STRING CRLF = chr(13)+chr(10)

'----------------DECLARE FUNCTIONS--------------
Declare FUNCTION Main()
'Declare Function WndProc (sys hwnd,wmsg,wparam,lparam) as sys

Declare SUB Exec_PRINT()
Declare SUB Exec_GOTO()
Declare SUB Exec_IF()
Declare SUB Exec_FOR()
Declare SUB Exec_NEXT()
Declare SUB Exec_INPUT()
Declare SUB Exec_GOSUB()
Declare SUB Exec_RETURN()
Declare SUB Exec_FORMAT()
Declare FUNCTION Exec_RUN(s AS STRING,op AS LONG) AS LONG

Declare SUB gpush(L AS LONG)
Declare FUNCTION gpop() AS LONG
Declare SUB fpush(byval i INT)
Declare SUB fPop(i AS INT)

Declare SUB FindEOL()
Declare FUNCTION GetNextLabel(s AS STRING) AS LONG
Declare FUNCTION FindLabel(s AS STRING) AS LONG
Declare SUB Assignment()
Declare SUB ScanLabels()
'----------
Declare SUB Eval_Exp(Result AS FLOAT)
Declare SUB Eval_Exp1(Result AS FLOAT) 'as float
Declare SUB Eval_Exp2(Result AS FLOAT) 'as float
Declare SUB Eval_Exp3(Result AS FLOAT)
Declare SUB Eval_Exp4(Result AS FLOAT)
Declare SUB Eval_Exp5(Result AS FLOAT)
Declare SUB Eval_Exp6(Result AS FLOAT)
Declare SUB Atom(Result AS FLOAT)
Declare SUB Putback()
Declare SUB SError(Gerror AS INT)
Declare FUNCTION GetToken() AS LONG
Declare FUNCTION LookUp(S AS STRING) AS INT
Declare FUNCTION IsDelim(S AS STRING) AS INT
Declare FUNCTION isdigit(S AS STRING) AS INT
Declare FUNCTION isalpha(S AS STRING) AS INT
Declare FUNCTION Is_Space_Tab(S AS STRING) AS INT
Declare FUNCTION Find_Var(S AS STRING) AS FLOAT
Declare SUB Eval_StrExp(TempStr AS STRING)
DECLARE FUNCTION Trim(s AS STRING) AS STRING ' with AWINH.INC comment this line
DECLARE FUNCTION Asci(s AS STRING,pos AS INT) AS INT ' return ASC of substring from position
'HDC declared subs -------------------------------------------------------------------------
DECLARE SUB TextColor (wID as INT,byval frontColor as INT,byval  backColor as INT )
DECLARE SUB TextOn(wID as INT,tx as INT,ty as INT,txt as string)
'-------------------------------------------------------------------------------------------

FUNCTION TRIM(ins as string) as string
string nstr : nstr = LTRIM(RTRIM(ins))
Return nstr :END FUNCTION

FUNCTION Asci(string s,int pos) as int
string substring
substring = mid(s, pos, 1)
Return ASC(substring)
END FUNCTION

Macro RIGHTS(s,i)
Mid(s,(-i))
End Macro

'>>>>>>>>>>>    [ EXECUTE MAIN ]   >>>>>>>>>>>>>>>>>
'Main()
'exitProgram:
'print " E X I T - End of Program!"


'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

'---------------FUNCTIONS-------------------------
'FUNCTION MAIN
Dim linenum AS LONG
Dim s AS STRING
Dim thefile AS STRING
Dim doneflag AS LONG
Dim counter AS LONG
Dim result AS DOUBLE
' ReDim Variables(26) AS DOUBLE
' VarStrings(26) AS STRING
'ReDim Table(20) AS TAB_TYPE
'ReDim Label_Table(%SB_NUM_LAB) AS LAB_TYPE
'ReDim FStack(%SB_FOR_NEST) AS FOR_STACK_TYPE
'ReDim GStack(%SB_SUB_NEST) AS LONG
'-------------INTIALIZE VARIABLES-----------------
For Counter = 1 TO 256
  Variables[Counter] = 0
  VarStrings[Counter] = ""
Next Counter

Table[1].Command  ="PRINT"    :Table[1].Tok = SB_PRINT
Table[2].Command  ="INPUT"    :Table[2].Tok = SB_INPUT
Table[3].Command  ="IF"       :Table[3].Tok = SB_IF
Table[4].Command  ="THEN"     :Table[4].Tok = SB_THEN
Table[5].Command  ="GOTO"     :Table[5].Tok = SB_GOTO
Table[6].Command  ="FOR"      :Table[6].Tok = SB_FOR
Table[7].Command  ="NEXT"     :Table[7].Tok = SB_NEXT
Table[8].Command  ="TO"       :Table[8].Tok = SB_TO
Table[9].Command  ="GOSUB"    :Table[9].Tok = SB_GOSUB
Table[10].Command ="RETURN"   :Table[10].Tok = SB_RETURN
Table[11].Command ="FORMAT"   :Table[11].Tok = SB_FORMAT
Table[12].Command ="END"      :Table[12].Tok = SB_END
Table[13].Command ="*"        :Table[13].Tok = SB_END

Relops= ">=" + "<>" + "<=" + "<" + ">" + "=" + ""
'gSB_Format="#.00"

'------------------------------------------------
'CLS
doneflag=0
ProgPtr=1
MyProg=" "
'PRINT "Type 'Exit' to exit program"

'While doneflag=0
   ErrorFlag=0

'************************************************************
'HERE is opened MAIN DISPLAY WINDOW -->
'...................................................................
win = SetWindow("JimK3:", 200, 200, 640, 480, 0, WS_MINMAXSIZE )
'init hdc drawing
InitDrawing(win)
'DECLARE SUB WindowColor(wID as INT,wr as INT,wg as INT,wb as INT)
WindowColor(win, 80, 80, 120)
'set text frontColor,backColor
TextColor (win, RGB(210,210,220), RGB(80,80,120) )
'add init text -> "JimK3 - OK!"
startp=startp+10
TextOn(win, 10, startp, "JimK3 - OK!" )



'>>>>>>>> HERE ENTER YOUR PROGRAM >>>>>>>>>>>>>>>>>>>>>>>>>

   MyProg = "PRINT " + "30, 30, 2"  ' test3
'string quoted = "PRINT " + chr(34) + "QUOTED LITERAL" + chr(34)+ " " ' test2
'myprog = quoted
   s=TRIM(MyProg)
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

  ' Load source to string - - >
   MyProg = MyProg+CHR(13)+CHR(10) 'CRLF

   ProgPtr=1
   'If LEFT(s,3)="RUN" THEN
     ' thefile=TRIM(MID(s,4))
    '  s=LEFT(s,3)
   'End If
  'Select Case s
         'Case "RUN"
          '    Counter=Exec_Run(thefile,1)
         'Case "EXIT"
          '    doneflag=1
         'Case Else
              Exec_Run(MyProg,0)
exitProgram:
If ErrorFlag = 1
     print "PROGRAM TERMINATED!"
ELSE
    print "END OF PROGRAM."
End if
  'End Select
'Wend
'

'>>>>>>>>>>>>>>>>>>>>>>>>>>>
'message loop
Wait()
'<<<<<<<<<<<<<<<<<<<<<<<<<<
'func main
Function WndProc (sys hwnd,wmsg,wparam,lparam) as sys callback
SELECT hwnd
    CASE win
        Select wmsg

            CASE WM_PAINT
             BitBlt(hDC, 0, 0, ww, wh, hdcMem, 0, 0, SRCCOPY)
             InvalidateRect(win, 0, 0)
                
            CASE WM_CLOSE
                CloseWindow(win)
                EndProgram
                  ExitProcess 0

            CASE WM_COMMAND
                controlID = LoWord(wParam) 'get control ID
                notifyCode = HiWord(wParam) 'get notification message

                select controlID
                    case b1ID  'open file
                       if notifycode=0
                       'doOpen()
                    end if

                    case b2ID 'scan >>>
                       if notifycode=0
                       'doScan()
                    end if

                  end select
        End Select
END SELECT
RETURN Default
END FUNCTION

'=============================================================
FUNCTION Is_Space_Tab(S AS STRING) AS INT
   If S=CHR(32) THEN Return 1
   If S=CHR(9) THEN Return 1
   Return 0
END FUNCTION

SUB SError(Gerror AS INTEGER)
     Dim SErrorS[19] AS STRING
     Dim TempPtr AS LONG
     Dim TempStr AS STRING
     Dim chars AS STRING
     Dim MyLine AS LONG


     SErrorS[1]="Syntax Error"
     SErrorS[2]="Unbalanced Parentheses"
     SErrorS[3]="No Expression Present"
     SErrorS[4]="Division by Zero"
     SErrorS[5]="Equal Sign Expected"
     SErrorS[6]="Not a Variable"
     SErrorS[7]="Label Table Full"
     SErrorS[8]="Duplicate Label"
     SErrorS[9]="Undefined Label"
     SErrorS[10]="THEN Expected"
     SErrorS[11]="TO Expected"
     SErrorS[12]="Too Many Nested GOSUBs"
     SErrorS[13]="NEXT Without FOR"
     SErrorS[14]="Too Many GOSUBs"
     SErrorS[15]="Return Without GOSUB"
     SErrorS[16]="Missing Quote"
     SErrorS[17]="Bad File Name"
     SErrorS[18]="String Expected"
     SErrorS[19]="Unknown Keyword"

'print "ERROR TYPE: " + SErrorS[Gerror]

     TempPtr=ProgPtr
     TempStr=""
     chars =" "
     ProgPtr=1
     MyLine=1
/*
     While ProgPtr < TempPtr And chars <> CHR(0)
       chars =mid(MyProg,ProgPtr,1)
       If chars = CHR(13) And mid(MyProg,ProgPtr+1,1)=CHR(10)
          ProgPtr=ProgPtr+1
          MyLine=MyLine+1
       End If
       ProgPtr++
     Wend
*/
     print "ERROR: " + SErrorS[Gerror] + " in line " + str(MyLine-1)
     ProgPtr=TempPtr
     Errorflag=1
    ' goto exitProgram
End SUB

SUB Assignment
    Local var AS LONG
    Local MyStr AS STRING
    Local TempStr AS STRING
    Local Result AS FLOAT

    GetToken()
    If isalpha(Token)=0 THEN
       Serror(SB_NOT_VAR)
       EXIT SUB
    End If
    MyStr=UCASE(LEFT(Token,1))
    TempStr=Token

    GetToken()
    If Token <>"=" THEN
       Serror(SB_EQUAL_EXP)
       EXIT SUB
    End If

    If RIGHTS(TempStr,1)<>"$" THEN
      Eval_exp(Result)
      Variables(Asc(MyStr)-65 + 1)=Result
    Else
      Eval_StrExp(TempStr)
      VarStrings(Asc(MyStr)-65 + 1)=TempStr
    End If
End SUB

FUNCTION LookUp(S AS STRING) AS INT
      Dim  Counter,OUT AS INT
      Dim  MyStr AS STRING
      MyStr=S
      Counter=1
      MyStr=UCASE(MyStr)
      FUNCTION = SB_UNKNCOM  'DEFAULT VALUE
      While MID(Table[Counter].Command,1,1) <> "*"  And Counter < SB_NUM_CMDS
         If TRIM(Table[Counter].Command) = TRIM(MyStr) THEN
           OUT = Table[Counter].Tok
           Counter = SB_NUM_CMDS
         End If
         Counter=Counter+1
      Wend
    Return OUT
END FUNCTION

FUNCTION IsDelim(S AS STRING) AS INT
  Dim Temp AS INT
      Temp=Instr(1," ;,+-<>^=(*)/",S)
      'print "is Delimiter->" + str temp
      If Temp > 0 THEN Return 1    'else
      If S=CHR(9) THEN Return 1    'tab
      If S=CHR(13) THEN Return 1   'CR
      If S=CHR(10) THEN Return 1   'LF
      If S=CHR(0) THEN Return 1    'empty
      Return 0
END FUNCTION

FUNCTION isdigit(S AS STRING) AS INT
     If (asc(S)>47 And asc(S)<58) Or asc(S)=46
     Return 1
     End if
     Return 0
END FUNCTION

FUNCTION isalpha(S AS STRING) AS INT
     If asc(UCASE(MID(S,1,1))) > 64 And asc(UCASE(MID(S,1,1))) < 91
       'print "isAlpha:" + S
     Return 1
     End if
     Return 0
END FUNCTION

SUB Putback()
Dim Mylen AS LONG
   Mylen = Len(Token)
   ProgPtr = ProgPtr - Mylen
   If Token_Type = SB_QUOTE THEN ProgPtr = ProgPtr - 2
  ' print "Put back OK!"
END SUB

FUNCTION Find_Var(S AS STRING) AS FLOAT
  Dim  MyStr AS STRING
  MyStr = LEFT(S,1)
  If isalpha(MyStr)=0 THEN
     Return 0   'Find_Var()=0
    ' EXIT FUNCTION
  End If
  MyStr = UCASE(MyStr)
  If Token_Type = SB_VARISTR THEN   'Result is returned in parameter for strings
     S = VarStrings(Asc(MyStr)-65 + 1)
    Return -2      'Find_Var=-2
   Else
    Return Variables(Asc(MyStr)-65 + 1) 'Find_Var=Variables(Asc(MyStr)-65 + 1)  'Result is returned by function for doubles
  End If
End FUNCTION

'===============================================
SUB Eval_StrExp(TempStr AS STRING)
   Dim Result AS LONG
   Dim myStr AS STRING
   Dim NResult AS FLOAT

   TempStr = ""
While token = "+"  OR token <> "" ' DO/LOOP WHILE mod
   GetToken()

   If Token_Type = SB_VARISTR
     MyStr = Token
     Result = Find_Var(MyStr)
     TempStr = TempStr + MyStr
     GetToken()

    ElseIf Token_Type = SB_QUOTE
     '0print "EVAL_STR_EXPR-SB_QUOTE"
     TempStr = TempStr + Token
     GetToken()

    ElseIf Token_Type=SB_VARIABLE Or Token_Type=SB_NUMBER
     PutBack()
     Eval_Exp(NResult)
     TempStr = TempStr + STR(NResult) ',gSB_Format)
     GetToken()
  
    ELSE
     print "EvalSTR-Error=TOKEN->" + token
     Serror(SB_SERROR)
     EXIT SUB
   End If
   'While token = "+"
WEND

End SUB

'----------------------------------------------------
       ' Entrance to Parser
SUB Eval_Exp(Result AS FLOAT)   'ENTRY
     GetToken()
     If Token = "EOF" THEN
         SError(SB_NOEXP)
         EXIT SUB
      Else
      ' print "EXPR_1:" + str(result)
       Eval_Exp1(result)
       Putback()
     End If
END SUB

SUB Eval_Exp1(Result AS FLOAT)   'RELATIONAL
   Dim  Temp  AS FLOAT
   Dim  Op    AS STRING
   Dim  which AS LONG
   Dim  temp2 AS FLOAT

   'GetToken()
   Eval_Exp2(result)
'print "TEMP2:" + str(temp2)
   op=token
   which = Instr(1,Relops,op)
'print "WHICH:" + str(which) '0
   If which > 0 THEN
      GetToken()
      Eval_Exp1(Temp)
int *p = strptr op ' o2 SELECT -Not work properly with strings so i use pointer for test(OK-work)
      Select  p
          Case "<"
            Result=(Result < Temp)
          Case "<="  'CHR(SB_LE)
            Result=(Result <= Temp)
          Case ">"
            Result=(Result > Temp)
          Case ">="  'CHR(SB_GE)
            Result=(Result >= Temp)
          Case "="
            Result=(Result = Temp)
          Case "<>"  'CHR(SB_NE) NOT
            Result=(Result <> Temp)
      End Select
   End If
End SUB

SUB Eval_Exp2(Result AS FLOAT)   'ADD OR SUBTRACT
   Dim Temp AS FLOAT
   Dim Op AS STRING

  Eval_Exp3(result)
    Op=token
    While (op="+" Or op="-") And op <> CHR(0)
      GetToken()
        Eval_Exp3(Temp)
int *p = strptr op 'pointer select
      Select p
         Case "-"
           Result=(Result-Temp)
         Case "+"
           Result=(Result+Temp)
      End Select
      OP=token
    Wend
End SUB

SUB Eval_Exp3(Result AS FLOAT)   'DIVIDE OR MULTIPLY
   Dim Temp AS FLOAT
   Dim Op AS STRING

   Eval_Exp4(result)
    OP=token
    While (op="*" Or op="/") And op <> CHR(0)
      GetToken()
         Eval_Exp4(Temp)
int *p = strptr op 'pointer select
      Select p
         Case "*"
           Result=(Result*Temp)
         Case "/"
           If Temp = 0 THEN
              SError(SB_DIV_ZERO)
              EXIT SUB
           End If
           Result=(Result/Temp)
      End Select
      Op=token
    Wend
End SUB

SUB Eval_Exp4(Result AS FLOAT)  'PROCESS EXPONENT
    Dim  Temp AS FLOAT
    Dim  Count AS LONG
    Dim  Ex AS FLOAT
       Eval_Exp5(result)
    If token ="^" THEN
      GetToken()
          Eval_Exp4(Temp)
      If Temp=0 THEN
          Result=1
          EXIT SUB
      End If
      Result=Result^Temp
    End If
End SUB

SUB Eval_Exp5(Result AS FLOAT) 'UNARY + OR -
   Dim Op AS STRING
   Op=""
   If Token_Type = SB_DELIMITER And (Token="+" Or Token="-") THEN
       Op=Token
       GetToken()
   End If
       Eval_Exp6(result)
   If op ="-" THEN Result= -Result
End SUB

SUB Eval_Exp6(Result AS FLOAT)  'PARENS
  If Token="(" THEN
     GetToken()
     Eval_Exp2(result)
     If Token <>")" THEN SError(SB_PARENS)
     GetToken()
   Else
      Atom(result)
End If
End SUB

SUB Atom(Result AS FLOAT)       'PRIMITIVE
     Select Token_Type
         Case SB_VARIABLE
            Result = Find_Var(Token)
            GetToken()
         Case SB_NUMBER
            Result = Val(Token)
            GetToken()
         Case Else
            SError(SB_SERROR)
     End Select
End SUB

'-----------------END OF PARSER---------------------------
FUNCTION GetToken() AS LONG
Dim MyStr AS STRING
Dim i AS LONG

Token_Type = SB_UNDEFTOK
Tok = SB_UNDEFTOK
Token = ""
'....................
MyStr = MID(Myprog,ProgPtr,1)
'print "ProgPtr:" + str(Progptr) + "-MYSTR:" + MyStr

'....................
If Asci(MyProg,ProgPtr)=0 THEN   'END OF PROG?
'print "is end of program"
  ' Token="EOF"  'CHR$(0)
   Tok = SB_FINISHED
   Token_Type = SB_DELIMITER
   Return Token_Type  
End If

While Is_Space_Tab(MID(MyProg,ProgPtr,1)) = 1               'GO PAST WHITE SPACES
   ' print "is Space OR Tab:"
   ProgPtr=ProgPtr+1
Wend

If Asc(MyProg,ProgPtr)=39 THEN   '  "'"  We have a comment
     FindEOL()
End If

If Asc(MyStr)=13 AND Asci(MyProg,ProgPtr+1)=10 THEN   'END OF LINE?
   ProgPtr=ProgPtr+2
   Tok= SB_EOL
   Token="EL" 'CHR$(13)
   gLineCount=gLineCount+1
   Token_Type = SB_DELIMITER
   FUNCTION = SB_DELIMITER
   EXIT FUNCTION
End If

If Asci(MyProg,ProgPtr)=Asc("<") Or Asci(MyProg,ProgPtr) =  Asc(">")  THEN  'DOUBLE OPS
   If Asci(MyProg,ProgPtr) = Asc("<") THEN
     Token="<"
     ProgPtr=ProgPtr+1
     If Asci(MyProg,ProgPtr+1) = Asc(">") THEN
        Token= "<>" ' SB_NE
        ProgPtr=ProgPtr+1
     End If
     If Asci(MyProg,ProgPtr+1) = Asc("=") THEN
        Token="<="     'CHR(SB_LE)
        ProgPtr=ProgPtr+1
     End If
   End If

   If Asci(MyProg,ProgPtr)=Asc(">") THEN
     Token=">"
     ProgPtr++
     If Asci(MyProg,ProgPtr+1) = Asc("=") THEN
        Token = ">="     'CHR(SB_GE)
        ProgPtr=ProgPtr+1
     End If
   End If
   Token_Type = SB_DELIMITER
   Return SB_DELIMITER
End If

If mid(MyProg,ProgPtr,1) = chr(34) THEN    'QUOTE
      ' print " is quoted string.."
       ProgPtr=ProgPtr+1
       While Asci(MyProg,ProgPtr)<> 34  And Asci(MyProg,ProgPtr)<> 13
         Token = Token + MID(MyProg,ProgPtr,1)
         ProgPtr=ProgPtr+1
       Wend
       If asc(mid(MyProg,ProgPtr,1))= 13
         ' print "erorr mq"
          SError(SB_MISS_QUOTE)
         Exit function
       End If
   ProgPtr++        'get by last quote
   Token_Type = SB_QUOTE
   Function=Token_Type
   Exit Function
End If

If Instr(1," ;,+-<>^=(*)/",MID(MyProg,ProgPtr,1)) <> 0 THEN
   Token = MID(MyProg,ProgPtr,1)
   ProgPtr++
   Token_Type = SB_DELIMITER
   'print "DELIMITER[" + token + "]"
   function = SB_DELIMITER
   Exit Function
End If

If isdigit(MID(MyProg,ProgPtr,1)) = 1 THEN
    While IsDelim(MID(MyProg,ProgPtr,1)) = 0
      Token = Token + MID(MyProg,ProgPtr,1)
      ProgPtr++
    Wend
      Token_Type = SB_NUMBER
     ' print "DIGIT" + token + ""
      function = SB_NUMBER
      Exit Function
End If

If isalpha(MID(MyProg,ProgPtr,1)) = 1  THEN
   While IsDelim(MID(MyProg,ProgPtr,1)) = 0
      Token = Token + MID(MyProg,ProgPtr,1)
      ProgPtr++
      Token_Type = SB_STRING
      Function = SB_STRING
   Wend
End If

If Token_Type = SB_STRING THEN   'IS COMMAND OR VARIABLE
   Tok = LookUp(Token)
   'print "Tok=LookUp:" +str(Tok)
   If Tok = SB_UNDEFTOK THEN
      If RIGHTS(Token,1) = "$" THEN
           Token_Type = SB_VARISTR
         ElseIf RIGHTS(Token,1) = ":" THEN
            Token_Type = SB_LABEL
           ' Tok=%SB_LABEL
            i=Len(token)
            token = MID(token,1,i-1) 'strip ":"
           'print "COM or VAR" + token
         Else
           Token_Type = SB_VARIABLE
       End If
     Else
       Token_Type = SB_COMMAND
   End If
   'print "GetToken()-TOKEN:" + token
   Return Token_Type   'GetToken=Token_Type
End If
'print "GetToken-TOKEN:" + token
exitGetToken:

END FUNCTION 'GetToken
'--------------------------------------------------------------------

FUNCTION EXEC_RUN(s AS STRING,op AS LONG) AS LONG
  Dim MyFile AS STRING
  Dim TempStr AS STRING
  Dim count AS LONG
  'op = 1 run from file  op<>1 then run from command line

If op=1 THEN
' MyFile=DIR(s) 'need to open file
  If Len(MyFile)=0 THEN
    Serror(SB_BAD_FILE)
    FUNCTION = 16
    EXIT FUNCTION
   Else
    MyProg=""
    'OPEN s For INPUT AS #1
      ' While NOT Eof(1)
       ' LINE INPUT #1,TempStr 'temp line to line buffer
       ' If Len(TempStr)>0 THEN MyProg = MyProg+TempStr+CHR(13)+CHR(10)
      ' Wend
     '  MyProg=MyProg+"                    "
   ' CLOSE #1
  End If
  Else
   MyProg=s
End If
'........................................
  Tok=0
  Ftos=0
  GTos=0

  For count = 1 TO SB_NUM_LAB
      Label_Table[count].Lname = ""
      Label_Table[count].p = 0
  Next count

  'ScanLabels()
'print "after scanLabels"
'tok=0
  While Tok <> SB_FINISHED And ErrorFlag=0
    Token_Type = GetToken()
'print "tok: " + str(tok) + " tokenType:" + str(Token_Type)
    If Token_Type = SB_VARIABLE Or Token_Type = SB_VARISTR THEN  'a variable
      PutBack()
      Assignment()
     ElseIf Token_Type = SB_LABEL THEN
        'Do Nothing
     Else 'a command token_type=4
'print "tok:" + str tok
      Select Tok
         Case SB_PRINT
           'print "Exec-Print"
           Exec_PRINT()
           'EXIT Select

         Case SB_INPUT
           Exec_INPUT()
           'EXIT Select
         Case SB_GOTO
           Exec_GOTO()
           'EXIT Select
         Case SB_GOSUB
           Exec_GOSUB()
           'EXIT Select
         Case SB_RETURN
           Exec_RETURN()
           'EXIT Select
         Case SB_FOR
           Exec_FOR()
           'EXIT Select
         Case SB_NEXT
           Exec_NEXT()
           'EXIT Select
         Case SB_IF
           Exec_IF()
           'EXIT Select
         Case SB_FORMAT
           Exec_FORMAT()
           'EXIT Select
         Case SB_END
           Tok=0
           'EXIT Select
         Case SB_EOL ',SB_LABEL, SB_FINISHED
           'do nothing
           'EXIT Select
         Case Else
           Serror(SB_UNKNOWN_KEYWORD)
      End Select
ExitSelect:  'label exit
    End If

   FUNCTION=0 'return value not used yet
  Wend
End FUNCTION
'---------------------------------------------
SUB ScanLabels
   Dim i AS LONG

   ProgPtr=1
   GetToken()
   'print "Token:" + Token

   If Token_Type = SB_LABEL THEN
      Label_Table[1].Lname = Token
      Label_Table[1].p = ProgPtr
   End If


   FindEOL()


   While  Tok <> SB_FINISHED
  ' print "not finished..."
     GetToken()
     'print "Token:" + Token
     If Token_Type = SB_LABEL THEN
        i = GetNextLabel(token)
        If i = -1 THEN SError(SB_LAB_TAB_FULL) :EXIT SUB
        If i = -2 THEN SError(SB_DUP_LAB) :EXIT SUB
        Label_Table[i].LName = token
        Label_Table[i].p = ProgPtr
     End If
     If Tok <> SB_EOL THEN FindEOL()
    ' print "tok:"
   Wend
   ProgPtr=1
   Tok=0
'print "end scanLabels"
END SUB
'-------------------------------------------------
FUNCTION GetNextLabel(s AS STRING) AS LONG
   Dim count AS LONG

   GetNextLabel= -1 'Assume table is full
   For count = 1 TO SB_NUM_LAB
      If Label_Table[count].p = 0 THEN
        Return count
        'EXIT FUNCTION
       ElseIf Label_Table[count].LName = s THEN
        Return -2 'Duplicate
       ' EXIT FUNCTION
      End If
   Next count
End FUNCTION
'--------------------------------------------------
FUNCTION FindLabel(s AS STRING) AS LONG
   Dim count AS LONG
   Dim mystr AS STRING '* SB_LAB_LEN
   mystr = s

   FUNCTION = 0 'Assume Failure
   For count = 1 TO SB_NUM_LAB
      If Label_Table[count].LName = mystr THEN
        FUNCTION = Label_Table[count].p 'Found it
        EXIT FUNCTION
      End If
   Next count
End FUNCTION
'---------------------------------------------------
SUB FindEOL
  While MID(MyProg,ProgPtr,1) <> CHR(13) And MID(MyProg,ProgPtr,1) <> CHR(0)   'END OF LINE OR EOF?
    ProgPtr++
   ' print str(ProgPtr)
  Wend
   If MID(MyProg,ProgPtr,1) <> CHR(0) THEN  ProgPtr = ProgPtr+2  'if not EOF then get by CHR(10)
   'print "ENDSUB-FindEOL"
END SUB
'-------------------------------------------
SUB Exec_PRINT
   Dim Result AS FLOAT
   Dim mylen AS LONG
   Dim spaces AS LONG
   Dim lastdelim AS STRING
   Dim TempStr AS STRING

   mylen=0
'print "PRINT::Token=" + token
'WHILE  token <> "," 'OR token <> ""  'DO
  
   GetToken()
  'print "PRINT:Token_Type:" + str token_type + " TOKEN :" + token
   If Tok = SB_EOL Or Tok = SB_FINISHED
       'PRINT "Finished..."
       'EXIT SUB
       Return
   End If

   If Token_Type = SB_QUOTE Or Token_Type = SB_VARISTR
     'print "is SB_QUOTE"
     PutBack()
     Eval_StrExp(TempStr)
    ' if errorflag=1 then print "ERRORFLAG_1" 'exit while
     PRINT "TempStr: " + TempStr
     mylen = mylen + Len(TempStr)

   Else   'expression ..............................
     if errorflag=1 then exit sub
    ' print "is Expression (+,-,*,/)"
     PutBack()
     Eval_exp(result)
     GetToken()
     TempStr = STR(Result)

'::::: EXECUTE PRINT HERE ::::::::::::::::::::
     PRINT "EXPR: " + TempStr
    startp = startp + 20
    TextOn(win, 10, startp, TempStr )
':::::::::::::::::::::::::::::::::::::::::::::::::
     mylen = mylen + Len(TempStr)
   End If

   lastdelim = token

   If token = ","
     ' spaces = SB_TABSTOP - (mylen MOD SB_TABSTOP)
      'mylen = mylen + spaces
      PRINT "SB_COMMA"   'print nothing ?
   ' ElseIf token=";" THEN
     ' mylen = mylen + 1
      'PRINT " "
    ElseIf tok <> SB_EOL And tok <> SB_FINISHED
    ' print "PRINT:tok<>EOL-Error"
      'SError(SB_SERROR)
   End If

   'LOOP While token="," Or token=";"
'WEND

   If tok = SB_EOL Or tok = SB_FINISHED THEN
      'If lastdelim <> ";" And lastdelim <> "," THEN PRINT "EOL"
       EXIT SUB
    Else
     'print "PRINT:END-Error"
      SError(SB_SERROR)
   End If
END SUB
'----------------------------------------------------------------

SUB Exec_GOTO
   Dim NewProgPtr AS LONG
   GetToken()
   NewProgPtr = FindLabel(Token)
   If NewProgPtr = 0 THEN
      Serror(SB_UNDEF_LAB)
     Else
      ProgPtr = NewProgPtr
   End If
End SUB

SUB Exec_GOSUB
   Dim Location AS LONG

   GetToken()
   Location = FindLabel(Token)
   If Location=0 THEN
      Serror(SB_UNDEF_LAB)
    Else
      gPush(ProgPtr)
      ProgPtr = Location
   End If
End SUB

SUB Exec_RETURN
   ProgPtr = gPop
   'PRINT "the return is: "+ str(ProgPtr) 'test
End SUB

SUB gPush(Location AS LONG)

   gtos++
   If gtos = SB_SUB_NEST THEN
      Serror( SB_TOO_MNY_GOSUB)
     Else
      gStack(gtos) = Location
   End If

End SUB

FUNCTION gPop() AS LONG

   If gtos=0 THEN
      Serror(SB_RET_WO_GOSUB)
     Else
      FUNCTION = gStack[gtos]
      gtos = gtos - 1
   End If
End FUNCTION

SUB Exec_FOR
   Dim i AS FOR_STACK_TYPE
   Dim Result AS FLOAT

   GetToken()
   If RIGHTS(Token,1) = "$" THEN
      Serror(SB_Serror)
      EXIT SUB
   End If

   If isalpha(Token) = 0 THEN
      Serror(SB_NOT_VAR)
      EXIT SUB
     Else
      i.vari = Asc(UCASE(MID(Token,1,1)))-64
   End If

   GetToken()
   If Token <> "=" THEN
      Serror(SB_EQUAL_EXP)
      EXIT SUB
   End If

   Eval_exp(Result)
   Variables(i.vari) = Int(Result)

   GetToken()
   If Token <> "TO" THEN
      Serror(SB_TO_EXP)
      EXIT SUB
   End If

   Eval_exp(Result)
   i.Target = Int(Result)

   If Result >= Variables[i.vari] THEN
     i.location = ProgPtr
     fpush(i)
    Else
      While tok <> SB_NEXT
        GetToken()
      Wend
   End If
End SUB

SUB Exec_NEXT
   Dim i AS FOR_STACK_TYPE
   Dim Result AS FLOAT
   STATIC counter AS LONG

   fpop(i)
   Variables[i.vari] = Variables[i.vari]+1
   If Variables[i.vari] > i.target THEN
        EXIT SUB
      Else
        fpush(i)
        ProgPtr = i.Location
   End If
END SUB

SUB Exec_FORMAT
   GetToken()
   If Token_Type <> SB_QUOTE THEN
       Serror(SB_STR_EXP)
    Else
       gSB_Format = Token
   End If

End SUB

SUB Exec_IF
  Dim x AS FLOAT

  Eval_Exp(x)

  If x = -1 THEN
    GetToken()
    If Tok <> SB_THEN THEN Serror(SB_THEN)
   Else
     FindEOL()
  End If
END SUB

SUB Exec_INPUT
    Dim s AS STRING
    Dim i AS LONG

    GetToken()
    If Token_Type = SB_QUOTE THEN
        PRINT Token + "  ";
        GetToken()
        If Token <> "," THEN Serror(SB_SError):EXIT SUB
        GetToken()
      Else
         PRINT "? WHAT... "
    End If
    i = Asc(UCASE(MID(Token,1,1)))-64
    'LINE INPUT ""; s
    If Token_Type = SB_VARIABLE THEN
       Variables[i] = Val(s)
      Else
       VarStrings[i] = s
    End If
END SUB

SUB fPush(i AS INT)
   If ftos > SB_FOR_NEST THEN
       Serror(SB_TOO_MNY_FOR)
     Else
        FStack[ftos] = i
        ftos++
   End If
END SUB

SUB fPop(i AS INT)
   ftos = ftos - 1
   If ftos < 0 THEN
       Serror(SB_NEXT_WO_FOR)
     Else
       i = FStack[ftos]
   End If
END SUB

'------------------------------------------------------
'print PBMain()

'Example for Small Basic  - by Jim Klutho
'PRINT "This is my first program"
'INPUT "Input your Name",A$
'PRINT
'PRINT "Hello "+A$
'j=56.4567890
'c$=j
'PRINT "Number to 2 Decimals (Default) ",c$
'Format "0.0000"    'Change the decimals
'c$=j
'PRINT
'PRINT "Number Changed to 4 Decimals ",c$
'INPUT "Input a number from 1 to 3",mynumber
'IF mynumber > 2 THEN PRINT "Greater than 2"
'IF mynumber < 2 THEN PRINT "Less than 2"
'IF mynumber = 2 THEN GOTO theend
'FOR x= 1 TO 5
'    PRINT "Test  ",x
'NEXT
'PRINT 3^3.45/6+2
'theend:
'END

'::::  HDC DRAWING FUNCTIONS ::::::::::::::::::::::::::::
'##############################################################################
SUB TextColor (wID as INT,byval frontColor as INT,byval  backColor as INT )
hdc = GetDC(wID)
SetTextColor( hDC, frontColor)
SetBkColor( hDC, backColor)

BitBlt(hDCmem, 0, 0, ww, wh, hdc, 0, 0, SRCCOPY)

ReleaseDC( wID, hdc)
END SUB
'#############################################################################

SUB TextOn(wID as INT,tx as INT,ty as INT,txt as string)
hdc = GetDC(wID)
'draw text to screen DC
TextOut hdc,tx,ty,txt,Len(txt)

'blit screen DC to memDC
BitBlt(hDCmem, 0, 0, ww, wh, hdc, 0, 0, SRCCOPY)

ReleaseDC( wID, hdc)
END SUB
'############################################################################
Views: 5 | Added by: Zlatko | Rating: 0.0/0
Total comments: 0
Name *:
Email *:
Code *: