diff --git a/.ci/deploy.ps1 b/.ci/deploy.ps1 index 94bc401bc..4981faa98 100644 --- a/.ci/deploy.ps1 +++ b/.ci/deploy.ps1 @@ -7,7 +7,7 @@ Set-Location .. $OldFiles = aws --output json --query Contents[].Key s3api list-objects --bucket $Bucket --prefix win-$Env:PLATFORM | ConvertFrom-Json aws s3 cp $Filename "s3://${Bucket}/win-${Env:PLATFORM}/" Set-Content -Path latest.txt -NoNewline -Value $Filename -aws s3 cp latest.txt "s3://${Bucket}/win-${Env:PLATFORM}/" foreach ($f in $OldFiles) { aws s3 rm "s3://$Bucket/$f" } +aws s3 cp latest.txt "s3://${Bucket}/win-${Env:PLATFORM}/" diff --git a/.ci/deploy.sh b/.ci/deploy.sh index 78ff60817..d9c374069 100755 --- a/.ci/deploy.sh +++ b/.ci/deploy.sh @@ -10,7 +10,7 @@ tar --create --auto-compress --file ${filename} --exclude-from=qb64/.ci/common-e current_files=$(aws --output text --query 'Contents[].Key' s3api list-objects --bucket ${BUCKET} --prefix ${OS}) aws s3 cp ${filename} s3://${BUCKET}/${OS}/ echo -n $(basename "${filename}") > latest.txt -aws s3 cp latest.txt s3://${BUCKET}/${OS}/ for f in $current_files; do aws s3 rm s3://${BUCKET}/$f done +aws s3 cp latest.txt s3://${BUCKET}/${OS}/ diff --git a/source/qb64.bas b/source/qb64.bas index 3d32097fb..a47178ae5 100644 --- a/source/qb64.bas +++ b/source/qb64.bas @@ -1,165 +1,165 @@ 'All variables will be of type LONG unless explicitly defined -DefLng A-Z +DEFLNG A-Z 'All arrays will be dynamically allocated so they can be REDIM-ed '$DYNAMIC 'We need console access to support command-line compilation via the -x command line compile option -$Console +$CONSOLE 'Initially the "SCREEN" will be hidden, if the -x option is used it will never be created -$ScreenHide +$SCREENHIDE '$INCLUDE:'global\version.bas' '$INCLUDE:'global\settings.bas' '$INCLUDE:'global\constants.bas' '$INCLUDE:'subs_functions\extensions\opengl\opengl_global.bas' -DefLng A-Z +DEFLNG A-Z '-------- Optional IDE Component (1/2) -------- '$INCLUDE:'ide\ide_global.bas' -ReDim Shared OName(1000) As String 'Operation Name -ReDim Shared PL(1000) As Integer 'Priority Level -ReDim Shared PP_TypeMod(0) As String, PP_ConvertedMod(0) As String 'Prepass Name Conversion variables. +REDIM SHARED OName(1000) AS STRING 'Operation Name +REDIM SHARED PL(1000) AS INTEGER 'Priority Level +REDIM SHARED PP_TypeMod(0) AS STRING, PP_ConvertedMod(0) AS STRING 'Prepass Name Conversion variables. Set_OrderOfOperations -ReDim EveryCaseSet(100), SelectCaseCounter As _Unsigned Long -ReDim SelectCaseHasCaseBlock(100) -Dim ExecLevel(255), ExecCounter As Integer -ReDim Shared UserDefine(1, 100) As String '0 element is the name, 1 element is the string value -ReDim Shared InValidLine(10000) As _Byte -Dim DefineElse(255) As _Byte -Dim Shared UserDefineCount As Integer +REDIM EveryCaseSet(100), SelectCaseCounter AS _UNSIGNED LONG +REDIM SelectCaseHasCaseBlock(100) +DIM ExecLevel(255), ExecCounter AS INTEGER +REDIM SHARED UserDefine(1, 100) AS STRING '0 element is the name, 1 element is the string value +REDIM SHARED InValidLine(10000) AS _BYTE +DIM DefineElse(255) AS _BYTE +DIM SHARED UserDefineCount AS INTEGER UserDefine(0, 0) = "WINDOWS": UserDefine(0, 1) = "WIN" UserDefine(0, 2) = "LINUX" UserDefine(0, 3) = "MAC": UserDefine(0, 4) = "MACOSX" UserDefine(0, 5) = "32BIT": UserDefine(0, 6) = "64BIT" UserDefine(0, 7) = "VERSION" -If InStr(_OS$, "WIN") Then UserDefine(1, 0) = "-1": UserDefine(1, 1) = "-1" Else UserDefine(1, 0) = "0": UserDefine(1, 1) = "0" -If InStr(_OS$, "LINUX") Then UserDefine(1, 2) = "-1" Else UserDefine(1, 2) = "0" -If InStr(_OS$, "MAC") Then UserDefine(1, 3) = "-1": UserDefine(1, 4) = "-1" Else UserDefine(1, 3) = "0": UserDefine(1, 4) = "0" -If InStr(_OS$, "32BIT") Then UserDefine(1, 5) = "-1": UserDefine(1, 6) = "0" Else UserDefine(1, 5) = "0": UserDefine(1, 6) = "-1" +IF INSTR(_OS$, "WIN") THEN UserDefine(1, 0) = "-1": UserDefine(1, 1) = "-1" ELSE UserDefine(1, 0) = "0": UserDefine(1, 1) = "0" +IF INSTR(_OS$, "LINUX") THEN UserDefine(1, 2) = "-1" ELSE UserDefine(1, 2) = "0" +IF INSTR(_OS$, "MAC") THEN UserDefine(1, 3) = "-1": UserDefine(1, 4) = "-1" ELSE UserDefine(1, 3) = "0": UserDefine(1, 4) = "0" +IF INSTR(_OS$, "32BIT") THEN UserDefine(1, 5) = "-1": UserDefine(1, 6) = "0" ELSE UserDefine(1, 5) = "0": UserDefine(1, 6) = "-1" UserDefine(1, 7) = Version$ -Dim Shared QB64_uptime! +DIM SHARED QB64_uptime! -QB64_uptime! = Timer +QB64_uptime! = TIMER NoInternalFolder: -If _DirExists("internal") = 0 Then - _ScreenShow - Print "QB64 cannot locate the 'internal' folder" - Print - Print "Check that QB64 has been extracted properly." - Print "For MacOSX, launch 'qb64_start.command' or enter './qb64' in Terminal." - Print "For Linux, in the console enter './qb64'." - Do - _Limit 1 - Loop Until InKey$ <> "" - System 1 -End If +IF _DIREXISTS("internal") = 0 THEN + _SCREENSHOW + PRINT "QB64 cannot locate the 'internal' folder" + PRINT + PRINT "Check that QB64 has been extracted properly." + PRINT "For MacOSX, launch 'qb64_start.command' or enter './qb64' in Terminal." + PRINT "For Linux, in the console enter './qb64'." + DO + _LIMIT 1 + LOOP UNTIL INKEY$ <> "" + SYSTEM 1 +END IF -Dim Shared Include_GDB_Debugging_Info 'set using "options.bin" +DIM SHARED Include_GDB_Debugging_Info 'set using "options.bin" -Dim Shared DEPENDENCY_LAST -Const DEPENDENCY_LOADFONT = 1: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 -Const DEPENDENCY_AUDIO_CONVERSION = 2: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 -Const DEPENDENCY_AUDIO_DECODE = 3: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 -Const DEPENDENCY_AUDIO_OUT = 4: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 -Const DEPENDENCY_GL = 5: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 -Const DEPENDENCY_IMAGE_CODEC = 6: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 -Const DEPENDENCY_CONSOLE_ONLY = 7: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 '=2 if via -g switch, =1 if via metacommand $CONSOLE:ONLY -Const DEPENDENCY_SOCKETS = 8: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 -Const DEPENDENCY_PRINTER = 9: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 -Const DEPENDENCY_ICON = 10: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 -Const DEPENDENCY_SCREENIMAGE = 11: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 -Const DEPENDENCY_DEVICEINPUT = 12: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 'removes support for gamepad input if not present -Const DEPENDENCY_ZLIB = 13: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 'ZLIB library linkage, if desired, for compression/decompression. +DIM SHARED DEPENDENCY_LAST +CONST DEPENDENCY_LOADFONT = 1: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 +CONST DEPENDENCY_AUDIO_CONVERSION = 2: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 +CONST DEPENDENCY_AUDIO_DECODE = 3: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 +CONST DEPENDENCY_AUDIO_OUT = 4: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 +CONST DEPENDENCY_GL = 5: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 +CONST DEPENDENCY_IMAGE_CODEC = 6: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 +CONST DEPENDENCY_CONSOLE_ONLY = 7: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 '=2 if via -g switch, =1 if via metacommand $CONSOLE:ONLY +CONST DEPENDENCY_SOCKETS = 8: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 +CONST DEPENDENCY_PRINTER = 9: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 +CONST DEPENDENCY_ICON = 10: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 +CONST DEPENDENCY_SCREENIMAGE = 11: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 +CONST DEPENDENCY_DEVICEINPUT = 12: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 'removes support for gamepad input if not present +CONST DEPENDENCY_ZLIB = 13: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 'ZLIB library linkage, if desired, for compression/decompression. -Dim Shared DEPENDENCY(1 To DEPENDENCY_LAST) +DIM SHARED DEPENDENCY(1 TO DEPENDENCY_LAST) -Dim Shared UseGL 'declared SUB _GL (no params) +DIM SHARED UseGL 'declared SUB _GL (no params) -Dim Shared OS_BITS As Long, WindowTitle As String -OS_BITS = 64: If InStr(_OS$, "[32BIT]") Then OS_BITS = 32 +DIM SHARED OS_BITS AS LONG, WindowTitle AS STRING +OS_BITS = 64: IF INSTR(_OS$, "[32BIT]") THEN OS_BITS = 32 -If OS_BITS = 32 Then WindowTitle = "QB64 x32" Else WindowTitle = "QB64 x64" -_Title WindowTitle +IF OS_BITS = 32 THEN WindowTitle = "QB64 x32" ELSE WindowTitle = "QB64 x64" +_TITLE WindowTitle -Dim Shared ConsoleMode, No_C_Compile_Mode, NoIDEMode -Dim Shared ShowWarnings As _Byte, QuietMode As _Byte, CMDLineFile As String -Dim Shared MonochromeLoggingMode As _Byte +DIM SHARED ConsoleMode, No_C_Compile_Mode, NoIDEMode +DIM SHARED ShowWarnings AS _BYTE, QuietMode AS _BYTE, CMDLineFile AS STRING +DIM SHARED MonochromeLoggingMode AS _BYTE -Type usedVarList - used As _Byte - linenumber As Long - includeLevel As Long - includedLine As Long - includedFile As String - cname As String - name As String -End Type +TYPE usedVarList + used AS _BYTE + linenumber AS LONG + includeLevel AS LONG + includedLine AS LONG + includedFile AS STRING + cname AS STRING + name AS STRING +END TYPE -ReDim Shared usedVariableList(1000) As usedVarList, totalVariablesCreated As Long -Dim Shared bypassNextVariable As _Byte -Dim Shared totalWarnings As Long, warningListItems As Long, lastWarningHeader As String -Dim Shared duplicateConstWarning As _Byte, warningsissued As _Byte -Dim Shared emptySCWarning As _Byte -Dim Shared ExeIconSet As Long, qb64prefix$, qb64prefix_set -Dim Shared VersionInfoSet As _Byte +REDIM SHARED usedVariableList(1000) AS usedVarList, totalVariablesCreated AS LONG +DIM SHARED bypassNextVariable AS _BYTE +DIM SHARED totalWarnings AS LONG, warningListItems AS LONG, lastWarningHeader AS STRING +DIM SHARED duplicateConstWarning AS _BYTE, warningsissued AS _BYTE +DIM SHARED emptySCWarning AS _BYTE +DIM SHARED ExeIconSet AS LONG, qb64prefix$, qb64prefix_set +DIM SHARED VersionInfoSet AS _BYTE 'Variables to handle $VERSIONINFO metacommand: -Dim Shared viFileVersionNum$, viProductVersionNum$, viCompanyName$ -Dim Shared viFileDescription$, viFileVersion$, viInternalName$ -Dim Shared viLegalCopyright$, viLegalTrademarks$, viOriginalFilename$ -Dim Shared viProductName$, viProductVersion$, viComments$, viWeb$ +DIM SHARED viFileVersionNum$, viProductVersionNum$, viCompanyName$ +DIM SHARED viFileDescription$, viFileVersion$, viInternalName$ +DIM SHARED viLegalCopyright$, viLegalTrademarks$, viOriginalFilename$ +DIM SHARED viProductName$, viProductVersion$, viComments$, viWeb$ -Dim Shared NoChecks +DIM SHARED NoChecks -Dim Shared Console -Dim Shared ScreenHide -Dim Shared Asserts -Dim Shared OptMax As Long +DIM SHARED Console +DIM SHARED ScreenHide +DIM SHARED Asserts +DIM SHARED OptMax AS LONG OptMax = 256 -ReDim Shared Opt(1 To OptMax, 1 To 10) As String * 256 +REDIM SHARED Opt(1 TO OptMax, 1 TO 10) AS STRING * 256 ' (1,1)="READ" ' (1,2)="WRITE" ' (1,3)="READ WRITE" -ReDim Shared OptWords(1 To OptMax, 1 To 10) As Integer 'The number of words of each opt () element +REDIM SHARED OptWords(1 TO OptMax, 1 TO 10) AS INTEGER 'The number of words of each opt () element ' (1,1)=1 '"READ" ' (1,2)=1 '"WRITE" ' (1,3)=2 '"READ WRITE" -ReDim Shared T(1 To OptMax) As Integer 'The type of the entry +REDIM SHARED T(1 TO OptMax) AS INTEGER 'The type of the entry ' t is 0 for ? opts ' ---------- 0 means ? , 1+ means a symbol or {}block ---------- ' t is 1 for symbol opts ' t is the number of rhs opt () index enteries for {READ|WRITE|READ WRITE} like opts -ReDim Shared Lev(1 To OptMax) As Integer 'The indwelling level of each opt () element (the lowest is 0) -ReDim Shared EntryLev(1 To OptMax) As Integer 'The level required from which this opt () can be validly be entered/checked-for -ReDim Shared DitchLev(1 To OptMax) As Integer 'The lowest level recorded between the previous Opt and this Opt -ReDim Shared DontPass(1 To OptMax) As Integer 'Set to 1 or 0, with 1 meaning don't pass +REDIM SHARED Lev(1 TO OptMax) AS INTEGER 'The indwelling level of each opt () element (the lowest is 0) +REDIM SHARED EntryLev(1 TO OptMax) AS INTEGER 'The level required from which this opt () can be validly be entered/checked-for +REDIM SHARED DitchLev(1 TO OptMax) AS INTEGER 'The lowest level recorded between the previous Opt and this Opt +REDIM SHARED DontPass(1 TO OptMax) AS INTEGER 'Set to 1 or 0, with 1 meaning don't pass 'Determines whether the opt () entry needs to actually be passed to the C++ sub/function -ReDim Shared TempList(1 To OptMax) As Integer -ReDim Shared PassRule(1 To OptMax) As Long +REDIM SHARED TempList(1 TO OptMax) AS INTEGER +REDIM SHARED PassRule(1 TO OptMax) AS LONG '0 means no pass rule 'negative values refer to an opt () element 'positive values refer to a flag value -ReDim Shared LevelEntered(OptMax) 'up to 64 levels supported -ReDim Shared separgs(OptMax + 1) As String -ReDim Shared separgslayout(OptMax + 1) As String -ReDim Shared separgs2(OptMax + 1) As String -ReDim Shared separgslayout2(OptMax + 1) As String +REDIM SHARED LevelEntered(OptMax) 'up to 64 levels supported +REDIM SHARED separgs(OptMax + 1) AS STRING +REDIM SHARED separgslayout(OptMax + 1) AS STRING +REDIM SHARED separgs2(OptMax + 1) AS STRING +REDIM SHARED separgslayout2(OptMax + 1) AS STRING -Dim Shared E +DIM SHARED E @@ -170,193 +170,193 @@ Dim Shared E -Dim Shared ResolveStaticFunctions -ReDim Shared ResolveStaticFunction_File(1 To 100) As String -ReDim Shared ResolveStaticFunction_Name(1 To 100) As String -ReDim Shared ResolveStaticFunction_Method(1 To 100) As Long +DIM SHARED ResolveStaticFunctions +REDIM SHARED ResolveStaticFunction_File(1 TO 100) AS STRING +REDIM SHARED ResolveStaticFunction_Name(1 TO 100) AS STRING +REDIM SHARED ResolveStaticFunction_Method(1 TO 100) AS LONG -Dim Shared Error_Happened As Long -Dim Shared Error_Message As String +DIM SHARED Error_Happened AS LONG +DIM SHARED Error_Message AS STRING -Dim Shared os As String +DIM SHARED os AS STRING os$ = "WIN" -If InStr(_OS$, "[LINUX]") Then os$ = "LNX" +IF INSTR(_OS$, "[LINUX]") THEN os$ = "LNX" -Dim Shared MacOSX As Long -If InStr(_OS$, "[MACOSX]") Then MacOSX = 1 +DIM SHARED MacOSX AS LONG +IF INSTR(_OS$, "[MACOSX]") THEN MacOSX = 1 -Dim Shared inline_DATA -If MacOSX Then inline_DATA = 1 +DIM SHARED inline_DATA +IF MacOSX THEN inline_DATA = 1 -Dim Shared BATCHFILE_EXTENSION As String +DIM SHARED BATCHFILE_EXTENSION AS STRING BATCHFILE_EXTENSION = ".bat" -If os$ = "LNX" Then BATCHFILE_EXTENSION = ".sh" -If MacOSX Then BATCHFILE_EXTENSION = ".command" +IF os$ = "LNX" THEN BATCHFILE_EXTENSION = ".sh" +IF MacOSX THEN BATCHFILE_EXTENSION = ".command" -Dim inlinedatastr(255) As String -For i = 0 To 255 +DIM inlinedatastr(255) AS STRING +FOR i = 0 TO 255 inlinedatastr(i) = str2$(i) + "," -Next +NEXT -Dim Shared extension As String -Dim Shared path.exe$, path.source$, lastBinaryGenerated$ +DIM SHARED extension AS STRING +DIM SHARED path.exe$, path.source$, lastBinaryGenerated$ extension$ = ".exe" -If os$ = "LNX" Then extension$ = "" 'no extension under Linux +IF os$ = "LNX" THEN extension$ = "" 'no extension under Linux -Dim Shared pathsep As String * 1 +DIM SHARED pathsep AS STRING * 1 pathsep$ = "\" -If os$ = "LNX" Then pathsep$ = "/" +IF os$ = "LNX" THEN pathsep$ = "/" 'note: QB64 handles OS specific path separators automatically except under SHELL calls -On Error GoTo qberror_test +ON ERROR GOTO qberror_test -Dim Shared tmpdir As String, tmpdir2 As String -If os$ = "WIN" Then tmpdir$ = ".\internal\temp\": tmpdir2$ = "..\\temp\\" -If os$ = "LNX" Then tmpdir$ = "./internal/temp/": tmpdir2$ = "../temp/" +DIM SHARED tmpdir AS STRING, tmpdir2 AS STRING +IF os$ = "WIN" THEN tmpdir$ = ".\internal\temp\": tmpdir2$ = "..\\temp\\" +IF os$ = "LNX" THEN tmpdir$ = "./internal/temp/": tmpdir2$ = "../temp/" -If Not _DirExists(tmpdir$) Then MkDir tmpdir$ +IF NOT _DIREXISTS(tmpdir$) THEN MKDIR tmpdir$ -Declare Library - Function getpid& () -End Declare +DECLARE LIBRARY + FUNCTION getpid& () +END DECLARE thisinstancepid = getpid& -Dim Shared tempfolderindex +DIM SHARED tempfolderindex -If InStr(_OS$, "LINUX") Then - fh = FreeFile - Open ".\internal\temp\tempfoldersearch.bin" For Random As #fh Len = Len(tempfolderindex) - tempfolderrecords = LOF(fh) / Len(tempfolderindex) +IF INSTR(_OS$, "LINUX") THEN + fh = FREEFILE + OPEN ".\internal\temp\tempfoldersearch.bin" FOR RANDOM AS #fh LEN = LEN(tempfolderindex) + tempfolderrecords = LOF(fh) / LEN(tempfolderindex) i = 1 - If tempfolderrecords = 0 Then + IF tempfolderrecords = 0 THEN 'first run ever? - Put #fh, 1, thisinstancepid - Else - For i = 1 To tempfolderrecords + PUT #fh, 1, thisinstancepid + ELSE + FOR i = 1 TO tempfolderrecords 'check if any of the temp folders is being used = pid still active - Get #fh, i, tempfoldersearch + GET #fh, i, tempfoldersearch - Shell _Hide "ps -p " + Str$(tempfoldersearch) + " > /dev/null 2>&1; echo $? > internal/temp/checkpid.bin" - fh2 = FreeFile - Open "internal/temp/checkpid.bin" For Binary As #fh2 - Line Input #fh2, checkpid$ - Close #fh2 - If Val(checkpid$) = 1 Then + SHELL _HIDE "ps -p " + STR$(tempfoldersearch) + " > /dev/null 2>&1; echo $? > internal/temp/checkpid.bin" + fh2 = FREEFILE + OPEN "internal/temp/checkpid.bin" FOR BINARY AS #fh2 + LINE INPUT #fh2, checkpid$ + CLOSE #fh2 + IF VAL(checkpid$) = 1 THEN 'This temp folder was locked by an instance that's no longer active, so 'this will be our temp folder - Put #fh, i, thisinstancepid - Exit For - End If - Next - If i > tempfolderrecords Then + PUT #fh, i, thisinstancepid + EXIT FOR + END IF + NEXT + IF i > tempfolderrecords THEN 'All indexes were busy. Let's initiate a new one: - Put #fh, i, thisinstancepid - End If - End If - Close #fh - If i > 1 Then + PUT #fh, i, thisinstancepid + END IF + END IF + CLOSE #fh + IF i > 1 THEN tmpdir$ = "./internal/temp" + str2$(i) + "/": tmpdir2$ = "../temp" + str2$(i) + "/" - If _DirExists(tmpdir$) = 0 Then - MkDir tmpdir$ - End If - End If - Open tmpdir$ + "temp.bin" For Output Lock Write As #26 -Else - On Error GoTo qberror_test + IF _DIREXISTS(tmpdir$) = 0 THEN + MKDIR tmpdir$ + END IF + END IF + OPEN tmpdir$ + "temp.bin" FOR OUTPUT LOCK WRITE AS #26 +ELSE + ON ERROR GOTO qberror_test E = 0 i = 1 - Open tmpdir$ + "temp.bin" For Output Lock Write As #26 - Do While E + OPEN tmpdir$ + "temp.bin" FOR OUTPUT LOCK WRITE AS #26 + DO WHILE E i = i + 1 - If i = 1000 Then Print "Unable to locate the 'internal' folder": End 1 - MkDir ".\internal\temp" + str2$(i) - If os$ = "WIN" Then tmpdir$ = ".\internal\temp" + str2$(i) + "\": tmpdir2$ = "..\\temp" + str2$(i) + "\\" - If os$ = "LNX" Then tmpdir$ = "./internal/temp" + str2$(i) + "/": tmpdir2$ = "../temp" + str2$(i) + "/" + IF i = 1000 THEN PRINT "Unable to locate the 'internal' folder": END 1 + MKDIR ".\internal\temp" + str2$(i) + IF os$ = "WIN" THEN tmpdir$ = ".\internal\temp" + str2$(i) + "\": tmpdir2$ = "..\\temp" + str2$(i) + "\\" + IF os$ = "LNX" THEN tmpdir$ = "./internal/temp" + str2$(i) + "/": tmpdir2$ = "../temp" + str2$(i) + "/" E = 0 - Open tmpdir$ + "temp.bin" For Output Lock Write As #26 - Loop -End If + OPEN tmpdir$ + "temp.bin" FOR OUTPUT LOCK WRITE AS #26 + LOOP +END IF 'temp folder established tempfolderindex = i -If i > 1 Then +IF i > 1 THEN 'create modified version of qbx.cpp - Open ".\internal\c\qbx" + str2$(i) + ".cpp" For Output As #2 - Open ".\internal\c\qbx.cpp" For Binary As #1 - Do Until EOF(1) - Line Input #1, a$ - x = InStr(a$, "..\\temp\\"): If x Then a$ = Left$(a$, x - 1) + "..\\temp" + str2$(i) + "\\" + Right$(a$, Len(a$) - (x + 9)) - x = InStr(a$, "../temp/"): If x Then a$ = Left$(a$, x - 1) + "../temp" + str2$(i) + "/" + Right$(a$, Len(a$) - (x + 7)) - Print #2, a$ - Loop - Close #1, #2 -End If + OPEN ".\internal\c\qbx" + str2$(i) + ".cpp" FOR OUTPUT AS #2 + OPEN ".\internal\c\qbx.cpp" FOR BINARY AS #1 + DO UNTIL EOF(1) + LINE INPUT #1, a$ + x = INSTR(a$, "..\\temp\\"): IF x THEN a$ = LEFT$(a$, x - 1) + "..\\temp" + str2$(i) + "\\" + RIGHT$(a$, LEN(a$) - (x + 9)) + x = INSTR(a$, "../temp/"): IF x THEN a$ = LEFT$(a$, x - 1) + "../temp" + str2$(i) + "/" + RIGHT$(a$, LEN(a$) - (x + 7)) + PRINT #2, a$ + LOOP + CLOSE #1, #2 +END IF -If Debug Then Open tmpdir$ + "debug.txt" For Output As #9 +IF Debug THEN OPEN tmpdir$ + "debug.txt" FOR OUTPUT AS #9 -On Error GoTo qberror +ON ERROR GOTO qberror -Dim Shared tempfolderindexstr As String 'appended to "Untitled" -Dim Shared tempfolderindexstr2 As String -If tempfolderindex <> 1 Then tempfolderindexstr$ = "(" + str2$(tempfolderindex) + ")": tempfolderindexstr2$ = str2$(tempfolderindex) +DIM SHARED tempfolderindexstr AS STRING 'appended to "Untitled" +DIM SHARED tempfolderindexstr2 AS STRING +IF tempfolderindex <> 1 THEN tempfolderindexstr$ = "(" + str2$(tempfolderindex) + ")": tempfolderindexstr2$ = str2$(tempfolderindex) -Dim Shared idedebuginfo -Dim Shared seperateargs_error -Dim Shared seperateargs_error_message As String +DIM SHARED idedebuginfo +DIM SHARED seperateargs_error +DIM SHARED seperateargs_error_message AS STRING -Dim Shared compfailed +DIM SHARED compfailed -Dim Shared reginternalsubfunc -Dim Shared reginternalvariable +DIM SHARED reginternalsubfunc +DIM SHARED reginternalvariable -Dim Shared symboltype_size +DIM SHARED symboltype_size symboltype_size = 0 -Dim Shared use_global_byte_elements +DIM SHARED use_global_byte_elements use_global_byte_elements = 0 'compiler-side IDE data & definitions 'SHARED variables "passed" to/from the compiler & IDE -Dim Shared idecommand As String 'a 1 byte message-type code, followed by optional string data -Dim Shared idereturn As String 'used to pass formatted-lines and return information back to the IDE -Dim Shared ideerror As Long -Dim Shared idecompiled As Long -Dim Shared idemode '1 if using the IDE to compile -Dim Shared ideerrorline As Long 'set by qb64-error(...) to the line number it would have reported, this number +DIM SHARED idecommand AS STRING 'a 1 byte message-type code, followed by optional string data +DIM SHARED idereturn AS STRING 'used to pass formatted-lines and return information back to the IDE +DIM SHARED ideerror AS LONG +DIM SHARED idecompiled AS LONG +DIM SHARED idemode '1 if using the IDE to compile +DIM SHARED ideerrorline AS LONG 'set by qb64-error(...) to the line number it would have reported, this number 'is later passed to the ide in message #8 -Dim Shared idemessage As String 'set by qb64-error(...) to the error message to be reported, this +DIM SHARED idemessage AS STRING 'set by qb64-error(...) to the error message to be reported, this 'is later passed to the ide in message #8 -Dim Shared optionexplicit As _Byte -Dim Shared optionexplicitarray As _Byte -Dim Shared optionexplicit_cmd As _Byte -Dim Shared ideStartAtLine As Long, errorLineInInclude As Long -Dim Shared warningInInclude As Long, warningInIncludeLine As Long -Dim Shared outputfile_cmd$ -Dim Shared compilelog$ +DIM SHARED optionexplicit AS _BYTE +DIM SHARED optionexplicitarray AS _BYTE +DIM SHARED optionexplicit_cmd AS _BYTE +DIM SHARED ideStartAtLine AS LONG, errorLineInInclude AS LONG +DIM SHARED warningInInclude AS LONG, warningInIncludeLine AS LONG +DIM SHARED outputfile_cmd$ +DIM SHARED compilelog$ '$INCLUDE:'global\IDEsettings.bas' CMDLineFile = ParseCMDLineArgs$ -If ConsoleMode Then - _Dest _Console -Else - _Console Off - _ScreenShow - _Icon -End If +IF ConsoleMode THEN + _DEST _CONSOLE +ELSE + _CONSOLE OFF + _SCREENSHOW + _ICON +END IF 'the function ?=ide(?) should always be passed 0, it returns a message code number, any further information 'is passed back in idereturn @@ -404,30 +404,30 @@ End If ' [255] 'hash table data -Type HashListItem - Flags As Long - Reference As Long - NextItem As Long - PrevItem As Long - LastItem As Long 'note: this value is only valid on the first item in the list +TYPE HashListItem + Flags AS LONG + Reference AS LONG + NextItem AS LONG + PrevItem AS LONG + LastItem AS LONG 'note: this value is only valid on the first item in the list 'note: name is stored in a seperate array of strings -End Type -Dim Shared HashFind_NextListItem As Long -Dim Shared HashFind_Reverse As Long -Dim Shared HashFind_SearchFlags As Long -Dim Shared HashFind_Name As String -Dim Shared HashRemove_LastFound As Long -Dim Shared HashListSize As Long -Dim Shared HashListNext As Long -Dim Shared HashListFreeSize As Long -Dim Shared HashListFreeLast As Long +END TYPE +DIM SHARED HashFind_NextListItem AS LONG +DIM SHARED HashFind_Reverse AS LONG +DIM SHARED HashFind_SearchFlags AS LONG +DIM SHARED HashFind_Name AS STRING +DIM SHARED HashRemove_LastFound AS LONG +DIM SHARED HashListSize AS LONG +DIM SHARED HashListNext AS LONG +DIM SHARED HashListFreeSize AS LONG +DIM SHARED HashListFreeLast AS LONG 'hash lookup tables -Dim Shared hash1char(255) As Integer -Dim Shared hash2char(65535) As Integer -For x = 1 To 26 +DIM SHARED hash1char(255) AS INTEGER +DIM SHARED hash2char(65535) AS INTEGER +FOR x = 1 TO 26 hash1char(64 + x) = x hash1char(96 + x) = x -Next +NEXT hash1char(95) = 27 '_ hash1char(48) = 28 '0 hash1char(49) = 29 '1 @@ -439,124 +439,124 @@ hash1char(54) = 20 '6 hash1char(55) = 19 '7 hash1char(56) = 18 '8 hash1char(57) = 17 '9 -For c1 = 0 To 255 - For c2 = 0 To 255 +FOR c1 = 0 TO 255 + FOR c2 = 0 TO 255 hash2char(c1 + c2 * 256) = hash1char(c1) + hash1char(c2) * 32 - Next -Next + NEXT +NEXT 'init HashListSize = 65536 HashListNext = 1 HashListFreeSize = 1024 HashListFreeLast = 0 -ReDim Shared HashList(1 To HashListSize) As HashListItem -ReDim Shared HashListName(1 To HashListSize) As String * 256 -ReDim Shared HashListFree(1 To HashListFreeSize) As Long -ReDim Shared HashTable(16777215) As Long '64MB lookup table with indexes to the hashlist +REDIM SHARED HashList(1 TO HashListSize) AS HashListItem +REDIM SHARED HashListName(1 TO HashListSize) AS STRING * 256 +REDIM SHARED HashListFree(1 TO HashListFreeSize) AS LONG +REDIM SHARED HashTable(16777215) AS LONG '64MB lookup table with indexes to the hashlist -Const HASHFLAG_LABEL = 2 -Const HASHFLAG_TYPE = 4 -Const HASHFLAG_RESERVED = 8 -Const HASHFLAG_OPERATOR = 16 -Const HASHFLAG_CUSTOMSYNTAX = 32 -Const HASHFLAG_SUB = 64 -Const HASHFLAG_FUNCTION = 128 -Const HASHFLAG_UDT = 256 -Const HASHFLAG_UDTELEMENT = 512 -Const HASHFLAG_CONSTANT = 1024 -Const HASHFLAG_VARIABLE = 2048 -Const HASHFLAG_ARRAY = 4096 -Const HASHFLAG_XELEMENTNAME = 8192 -Const HASHFLAG_XTYPENAME = 16384 +CONST HASHFLAG_LABEL = 2 +CONST HASHFLAG_TYPE = 4 +CONST HASHFLAG_RESERVED = 8 +CONST HASHFLAG_OPERATOR = 16 +CONST HASHFLAG_CUSTOMSYNTAX = 32 +CONST HASHFLAG_SUB = 64 +CONST HASHFLAG_FUNCTION = 128 +CONST HASHFLAG_UDT = 256 +CONST HASHFLAG_UDTELEMENT = 512 +CONST HASHFLAG_CONSTANT = 1024 +CONST HASHFLAG_VARIABLE = 2048 +CONST HASHFLAG_ARRAY = 4096 +CONST HASHFLAG_XELEMENTNAME = 8192 +CONST HASHFLAG_XTYPENAME = 16384 -Type Label_Type - State As _Unsigned _Byte '0=label referenced, 1=label created - cn As String * 256 - Scope As Long - Data_Offset As _Integer64 'offset within data - Data_Referenced As _Unsigned _Byte 'set to 1 if data is referenced (data_offset will be used to create the data offset variable) - Error_Line As Long 'the line number to reference on errors - Scope_Restriction As Long 'cannot exist inside this scope (post checked) - SourceLineNumber As Long -End Type -Dim Shared nLabels, Labels_Ubound +TYPE Label_Type + State AS _UNSIGNED _BYTE '0=label referenced, 1=label created + cn AS STRING * 256 + Scope AS LONG + Data_Offset AS _INTEGER64 'offset within data + Data_Referenced AS _UNSIGNED _BYTE 'set to 1 if data is referenced (data_offset will be used to create the data offset variable) + Error_Line AS LONG 'the line number to reference on errors + Scope_Restriction AS LONG 'cannot exist inside this scope (post checked) + SourceLineNumber AS LONG +END TYPE +DIM SHARED nLabels, Labels_Ubound Labels_Ubound = 100 -ReDim Shared Labels(1 To Labels_Ubound) As Label_Type -Dim Shared Empty_Label As Label_Type +REDIM SHARED Labels(1 TO Labels_Ubound) AS Label_Type +DIM SHARED Empty_Label AS Label_Type -Dim Shared PossibleSubNameLabels As String 'format: name+sp+name+sp+name <-ucase$'d -Dim Shared SubNameLabels As String 'format: name+sp+name+sp+name <-ucase$'d -Dim Shared CreatingLabel As Long +DIM SHARED PossibleSubNameLabels AS STRING 'format: name+sp+name+sp+name <-ucase$'d +DIM SHARED SubNameLabels AS STRING 'format: name+sp+name+sp+name <-ucase$'d +DIM SHARED CreatingLabel AS LONG -Dim Shared AllowLocalName As Long +DIM SHARED AllowLocalName AS LONG -Dim Shared DataOffset +DIM SHARED DataOffset -Dim Shared prepass +DIM SHARED prepass -Dim Shared autoarray +DIM SHARED autoarray -Dim Shared ontimerid, onkeyid, onstrigid +DIM SHARED ontimerid, onkeyid, onstrigid -Dim Shared revertmaymusthave(1 To 10000) -Dim Shared revertmaymusthaven +DIM SHARED revertmaymusthave(1 TO 10000) +DIM SHARED revertmaymusthaven -Dim Shared linecontinuation +DIM SHARED linecontinuation -Dim Shared dim2typepassback As String 'passes back correct case sensitive version of type +DIM SHARED dim2typepassback AS STRING 'passes back correct case sensitive version of type -Dim Shared inclevel -Dim Shared incname(100) As String 'must be full path as given -Dim Shared inclinenumber(100) As Long -Dim Shared incerror As String +DIM SHARED inclevel +DIM SHARED incname(100) AS STRING 'must be full path as given +DIM SHARED inclinenumber(100) AS LONG +DIM SHARED incerror AS STRING -Dim Shared fix046 As String +DIM SHARED fix046 AS STRING fix046$ = "__" + "ASCII" + "_" + "CHR" + "_" + "046" + "__" 'broken up to avoid detection for layout reversion -Dim Shared layout As String 'passed to IDE -Dim Shared layoutok As Long 'tracks status of entire line +DIM SHARED layout AS STRING 'passed to IDE +DIM SHARED layoutok AS LONG 'tracks status of entire line -Dim Shared layoutcomment As String +DIM SHARED layoutcomment AS STRING -Dim Shared tlayout As String 'temporary layout string set by supporting functions -Dim Shared layoutdone As Long 'tracks status of single command +DIM SHARED tlayout AS STRING 'temporary layout string set by supporting functions +DIM SHARED layoutdone AS LONG 'tracks status of single command -Dim Shared fooindwel +DIM SHARED fooindwel -Dim Shared alphanumeric(255) -For i = 48 To 57 +DIM SHARED alphanumeric(255) +FOR i = 48 TO 57 alphanumeric(i) = -1 -Next -For i = 65 To 90 +NEXT +FOR i = 65 TO 90 alphanumeric(i) = -1 -Next -For i = 97 To 122 +NEXT +FOR i = 97 TO 122 alphanumeric(i) = -1 -Next +NEXT '_ is treated as an alphabet letter alphanumeric(95) = -1 -Dim Shared isalpha(255) -For i = 65 To 90 +DIM SHARED isalpha(255) +FOR i = 65 TO 90 isalpha(i) = -1 -Next -For i = 97 To 122 +NEXT +FOR i = 97 TO 122 isalpha(i) = -1 -Next +NEXT '_ is treated as an alphabet letter isalpha(95) = -1 -Dim Shared isnumeric(255) -For i = 48 To 57 +DIM SHARED isnumeric(255) +FOR i = 48 TO 57 isnumeric(i) = -1 -Next +NEXT -Dim Shared lfsinglechar(255) +DIM SHARED lfsinglechar(255) lfsinglechar(40) = 1 '( lfsinglechar(41) = 1 ') lfsinglechar(42) = 1 '* @@ -588,117 +588,117 @@ lfsinglechar(95) = 1 '_ -Dim Shared nextrunlineindex As Long +DIM SHARED nextrunlineindex AS LONG -Dim Shared lineinput3buffer As String -Dim Shared lineinput3index As Long +DIM SHARED lineinput3buffer AS STRING +DIM SHARED lineinput3index AS LONG -Dim Shared dimstatic As Long +DIM SHARED dimstatic AS LONG -Dim Shared staticarraylist As String -Dim Shared staticarraylistn As Long -Dim Shared commonarraylist As String -Dim Shared commonarraylistn As Long +DIM SHARED staticarraylist AS STRING +DIM SHARED staticarraylistn AS LONG +DIM SHARED commonarraylist AS STRING +DIM SHARED commonarraylistn AS LONG 'CONST support -Dim Shared constmax As Long +DIM SHARED constmax AS LONG constmax = 100 -Dim Shared constlast As Long +DIM SHARED constlast AS LONG constlast = -1 -ReDim Shared constname(constmax) As String -ReDim Shared constcname(constmax) As String -ReDim Shared constnamesymbol(constmax) As String 'optional name symbol +REDIM SHARED constname(constmax) AS STRING +REDIM SHARED constcname(constmax) AS STRING +REDIM SHARED constnamesymbol(constmax) AS STRING 'optional name symbol ' `1 and `no-number must be handled correctly 'DIM SHARED constlastshared AS LONG 'so any defined inside a sub/function after this index can be "forgotten" when sub/function exits 'constlastshared = -1 -ReDim Shared consttype(constmax) As Long 'variable type number +REDIM SHARED consttype(constmax) AS LONG 'variable type number 'consttype determines storage -ReDim Shared constinteger(constmax) As _Integer64 -ReDim Shared constuinteger(constmax) As _Unsigned _Integer64 -ReDim Shared constfloat(constmax) As _Float -ReDim Shared conststring(constmax) As String -ReDim Shared constsubfunc(constmax) As Long -ReDim Shared constdefined(constmax) As Long +REDIM SHARED constinteger(constmax) AS _INTEGER64 +REDIM SHARED constuinteger(constmax) AS _UNSIGNED _INTEGER64 +REDIM SHARED constfloat(constmax) AS _FLOAT +REDIM SHARED conststring(constmax) AS STRING +REDIM SHARED constsubfunc(constmax) AS LONG +REDIM SHARED constdefined(constmax) AS LONG 'UDT 'names -Dim Shared lasttype As Long -Dim Shared udtxname(1000) As String * 256 -Dim Shared udtxcname(1000) As String * 256 -Dim Shared udtxsize(1000) As Long -Dim Shared udtxbytealign(1000) As Integer 'first element MUST be on a byte alignment & size is a multiple of 8 -Dim Shared udtxnext(1000) As Long -Dim Shared udtxvariable(1000) As Integer 'true if the udt contains variable length elements +DIM SHARED lasttype AS LONG +DIM SHARED udtxname(1000) AS STRING * 256 +DIM SHARED udtxcname(1000) AS STRING * 256 +DIM SHARED udtxsize(1000) AS LONG +DIM SHARED udtxbytealign(1000) AS INTEGER 'first element MUST be on a byte alignment & size is a multiple of 8 +DIM SHARED udtxnext(1000) AS LONG +DIM SHARED udtxvariable(1000) AS INTEGER 'true if the udt contains variable length elements 'elements -Dim Shared lasttypeelement As Long -Dim Shared udtename(1000) As String * 256 -Dim Shared udtecname(1000) As String * 256 -Dim Shared udtebytealign(1000) As Integer -Dim Shared udtesize(1000) As Long -Dim Shared udtetype(1000) As Long -Dim Shared udtetypesize(1000) As Long -Dim Shared udtearrayelements(1000) As Long -Dim Shared udtenext(1000) As Long +DIM SHARED lasttypeelement AS LONG +DIM SHARED udtename(1000) AS STRING * 256 +DIM SHARED udtecname(1000) AS STRING * 256 +DIM SHARED udtebytealign(1000) AS INTEGER +DIM SHARED udtesize(1000) AS LONG +DIM SHARED udtetype(1000) AS LONG +DIM SHARED udtetypesize(1000) AS LONG +DIM SHARED udtearrayelements(1000) AS LONG +DIM SHARED udtenext(1000) AS LONG -Type idstruct +TYPE idstruct - n As String * 256 'name - cn As String * 256 'case sensitive version of n + n AS STRING * 256 'name + cn AS STRING * 256 'case sensitive version of n - arraytype As Long 'similar to t - arrayelements As Integer - staticarray As Integer 'set for arrays declared in the main module with static elements + arraytype AS LONG 'similar to t + arrayelements AS INTEGER + staticarray AS INTEGER 'set for arrays declared in the main module with static elements - mayhave As String * 8 'mayhave and musthave are exclusive of each other - musthave As String * 8 - t As Long 'type + mayhave AS STRING * 8 'mayhave and musthave are exclusive of each other + musthave AS STRING * 8 + t AS LONG 'type - tsize As Long + tsize AS LONG - subfunc As Integer 'if function=1, sub=2 (max 100 arguments) - Dependency As Integer - internal_subfunc As Integer + subfunc AS INTEGER 'if function=1, sub=2 (max 100 arguments) + Dependency AS INTEGER + internal_subfunc AS INTEGER - callname As String * 256 - ccall As Integer - overloaded As _Byte - args As Integer - minargs As Integer - arg As String * 400 'similar to t - argsize As String * 400 'similar to tsize (used for fixed length strings) - specialformat As String * 256 - secondargmustbe As String * 256 - secondargcantbe As String * 256 - ret As Long 'the value it returns if it is a function (again like t) + callname AS STRING * 256 + ccall AS INTEGER + overloaded AS _BYTE + args AS INTEGER + minargs AS INTEGER + arg AS STRING * 400 'similar to t + argsize AS STRING * 400 'similar to tsize (used for fixed length strings) + specialformat AS STRING * 256 + secondargmustbe AS STRING * 256 + secondargcantbe AS STRING * 256 + ret AS LONG 'the value it returns if it is a function (again like t) - insubfunc As String * 256 - insubfuncn As Long + insubfunc AS STRING * 256 + insubfuncn AS LONG - share As Integer - nele As String * 100 - nelereq As String * 100 - linkid As Long - linkarg As Integer - staticscope As Integer + share AS INTEGER + nele AS STRING * 100 + nelereq AS STRING * 100 + linkid AS LONG + linkarg AS INTEGER + staticscope AS INTEGER 'For variables which are arguments passed to a sub/function - sfid As Long 'id number of variable's parent sub/function - sfarg As Integer 'argument/parameter # within call (1=first) -End Type + sfid AS LONG 'id number of variable's parent sub/function + sfarg AS INTEGER 'argument/parameter # within call (1=first) +END TYPE -Dim Shared id As idstruct +DIM SHARED id AS idstruct -Dim Shared idn As Long -Dim Shared ids_max As Long +DIM SHARED idn AS LONG +DIM SHARED ids_max AS LONG ids_max = 1024 -ReDim Shared ids(1 To ids_max) As idstruct -ReDim Shared cmemlist(1 To ids_max + 1) As Integer 'variables that must be in cmem -ReDim Shared sfcmemargs(1 To ids_max + 1) As String * 100 's/f arg that must be in cmem -ReDim Shared arrayelementslist(1 To ids_max + 1) As Integer 'arrayelementslist (like cmemlist) helps to resolve the number of elements in arrays with an unknown number of elements. Note: arrays with an unknown number of elements have .arrayelements=-1 +REDIM SHARED ids(1 TO ids_max) AS idstruct +REDIM SHARED cmemlist(1 TO ids_max + 1) AS INTEGER 'variables that must be in cmem +REDIM SHARED sfcmemargs(1 TO ids_max + 1) AS STRING * 100 's/f arg that must be in cmem +REDIM SHARED arrayelementslist(1 TO ids_max + 1) AS INTEGER 'arrayelementslist (like cmemlist) helps to resolve the number of elements in arrays with an unknown number of elements. Note: arrays with an unknown number of elements have .arrayelements=-1 'create blank id template for idclear to copy (stops strings being set to chr$(0)) -Dim Shared cleariddata As idstruct +DIM SHARED cleariddata AS idstruct cleariddata.cn = "" cleariddata.n = "" cleariddata.mayhave = "" @@ -713,103 +713,103 @@ cleariddata.insubfunc = "" cleariddata.nele = "" cleariddata.nelereq = "" -Dim Shared ISSTRING As Long -Dim Shared ISFLOAT As Long -Dim Shared ISUNSIGNED As Long -Dim Shared ISPOINTER As Long -Dim Shared ISFIXEDLENGTH As Long -Dim Shared ISINCONVENTIONALMEMORY As Long -Dim Shared ISOFFSETINBITS As Long -Dim Shared ISARRAY As Long -Dim Shared ISREFERENCE As Long -Dim Shared ISUDT As Long -Dim Shared ISOFFSET As Long +DIM SHARED ISSTRING AS LONG +DIM SHARED ISFLOAT AS LONG +DIM SHARED ISUNSIGNED AS LONG +DIM SHARED ISPOINTER AS LONG +DIM SHARED ISFIXEDLENGTH AS LONG +DIM SHARED ISINCONVENTIONALMEMORY AS LONG +DIM SHARED ISOFFSETINBITS AS LONG +DIM SHARED ISARRAY AS LONG +DIM SHARED ISREFERENCE AS LONG +DIM SHARED ISUDT AS LONG +DIM SHARED ISOFFSET AS LONG -Dim Shared STRINGTYPE As Long -Dim Shared BITTYPE As Long -Dim Shared UBITTYPE As Long -Dim Shared BYTETYPE As Long -Dim Shared UBYTETYPE As Long -Dim Shared INTEGERTYPE As Long -Dim Shared UINTEGERTYPE As Long -Dim Shared LONGTYPE As Long -Dim Shared ULONGTYPE As Long -Dim Shared INTEGER64TYPE As Long -Dim Shared UINTEGER64TYPE As Long -Dim Shared SINGLETYPE As Long -Dim Shared DOUBLETYPE As Long -Dim Shared FLOATTYPE As Long -Dim Shared OFFSETTYPE As Long -Dim Shared UOFFSETTYPE As Long -Dim Shared UDTTYPE As Long +DIM SHARED STRINGTYPE AS LONG +DIM SHARED BITTYPE AS LONG +DIM SHARED UBITTYPE AS LONG +DIM SHARED BYTETYPE AS LONG +DIM SHARED UBYTETYPE AS LONG +DIM SHARED INTEGERTYPE AS LONG +DIM SHARED UINTEGERTYPE AS LONG +DIM SHARED LONGTYPE AS LONG +DIM SHARED ULONGTYPE AS LONG +DIM SHARED INTEGER64TYPE AS LONG +DIM SHARED UINTEGER64TYPE AS LONG +DIM SHARED SINGLETYPE AS LONG +DIM SHARED DOUBLETYPE AS LONG +DIM SHARED FLOATTYPE AS LONG +DIM SHARED OFFSETTYPE AS LONG +DIM SHARED UOFFSETTYPE AS LONG +DIM SHARED UDTTYPE AS LONG -Dim Shared gosubid As Long -Dim Shared redimoption As Integer -Dim Shared dimoption As Integer -Dim Shared arraydesc As Integer -Dim Shared qberrorhappened As Integer -Dim Shared qberrorcode As Integer -Dim Shared qberrorline As Integer +DIM SHARED gosubid AS LONG +DIM SHARED redimoption AS INTEGER +DIM SHARED dimoption AS INTEGER +DIM SHARED arraydesc AS INTEGER +DIM SHARED qberrorhappened AS INTEGER +DIM SHARED qberrorcode AS INTEGER +DIM SHARED qberrorline AS INTEGER 'COMMON SHARED defineaz() AS STRING 'COMMON SHARED defineextaz() AS STRING -Dim Shared sourcefile As String 'the full path and filename -Dim Shared file As String 'name of the file (without .bas or path) +DIM SHARED sourcefile AS STRING 'the full path and filename +DIM SHARED file AS STRING 'name of the file (without .bas or path) 'COMMON SHARED separgs() AS STRING -Dim Shared constequation As Integer -Dim Shared DynamicMode As Integer -Dim Shared findidsecondarg As String -Dim Shared findanotherid As Integer -Dim Shared findidinternal As Long -Dim Shared currentid As Long 'is the index of the last ID accessed -Dim Shared linenumber As Long, reallinenumber As Long, totallinenumber As Long -Dim Shared wholeline As String -Dim Shared linefragment As String +DIM SHARED constequation AS INTEGER +DIM SHARED DynamicMode AS INTEGER +DIM SHARED findidsecondarg AS STRING +DIM SHARED findanotherid AS INTEGER +DIM SHARED findidinternal AS LONG +DIM SHARED currentid AS LONG 'is the index of the last ID accessed +DIM SHARED linenumber AS LONG, reallinenumber AS LONG, totallinenumber AS LONG +DIM SHARED wholeline AS STRING +DIM SHARED linefragment AS STRING 'COMMON SHARED bitmask() AS _INTEGER64 'COMMON SHARED bitmaskinv() AS _INTEGER64 -Dim Shared arrayprocessinghappened As Integer -Dim Shared stringprocessinghappened As Integer -Dim Shared cleanupstringprocessingcall As String -Dim Shared recompile As Integer 'forces recompilation +DIM SHARED arrayprocessinghappened AS INTEGER +DIM SHARED stringprocessinghappened AS INTEGER +DIM SHARED cleanupstringprocessingcall AS STRING +DIM SHARED recompile AS INTEGER 'forces recompilation 'COMMON SHARED cmemlist() AS INTEGER -Dim Shared optionbase As Integer +DIM SHARED optionbase AS INTEGER -Dim Shared addmetastatic As Integer -Dim Shared addmetadynamic As Integer -Dim Shared addmetainclude As String +DIM SHARED addmetastatic AS INTEGER +DIM SHARED addmetadynamic AS INTEGER +DIM SHARED addmetainclude AS STRING -Dim Shared closedmain As Integer -Dim Shared module As String +DIM SHARED closedmain AS INTEGER +DIM SHARED module AS STRING -Dim Shared subfunc As String -Dim Shared subfuncn As Long -Dim Shared subfuncid As Long +DIM SHARED subfunc AS STRING +DIM SHARED subfuncn AS LONG +DIM SHARED subfuncid AS LONG -Dim Shared defdatahandle As Integer -Dim Shared dimsfarray As Integer -Dim Shared dimshared As Integer +DIM SHARED defdatahandle AS INTEGER +DIM SHARED dimsfarray AS INTEGER +DIM SHARED dimshared AS INTEGER 'Allows passing of known elements to recompilation -Dim Shared sflistn As Integer +DIM SHARED sflistn AS INTEGER 'COMMON SHARED sfidlist() AS LONG 'COMMON SHARED sfarglist() AS INTEGER 'COMMON SHARED sfelelist() AS INTEGER -Dim Shared glinkid As Long -Dim Shared glinkarg As Integer -Dim Shared typname2typsize As Long -Dim Shared uniquenumbern As Long +DIM SHARED glinkid AS LONG +DIM SHARED glinkarg AS INTEGER +DIM SHARED typname2typsize AS LONG +DIM SHARED uniquenumbern AS LONG 'CLEAR , , 16384 -Dim Shared bitmask(1 To 56) As _Integer64 -Dim Shared bitmaskinv(1 To 56) As _Integer64 +DIM SHARED bitmask(1 TO 56) AS _INTEGER64 +DIM SHARED bitmaskinv(1 TO 56) AS _INTEGER64 -Dim Shared defineextaz(1 To 27) As String -Dim Shared defineaz(1 To 27) As String '27 is an underscore +DIM SHARED defineextaz(1 TO 27) AS STRING +DIM SHARED defineaz(1 TO 27) AS STRING '27 is an underscore ISSTRING = 1073741824 ISFLOAT = 536870912 @@ -837,8 +837,8 @@ UINTEGER64TYPE = 64& + ISPOINTER + ISUNSIGNED SINGLETYPE = 32& + ISFLOAT + ISPOINTER DOUBLETYPE = 64& + ISFLOAT + ISPOINTER FLOATTYPE = 256& + ISFLOAT + ISPOINTER '8-32 bytes -OFFSETTYPE = 64& + ISOFFSET + ISPOINTER: If OS_BITS = 32 Then OFFSETTYPE = 32& + ISOFFSET + ISPOINTER -UOFFSETTYPE = 64& + ISOFFSET + ISUNSIGNED + ISPOINTER: If OS_BITS = 32 Then UOFFSETTYPE = 32& + ISOFFSET + ISUNSIGNED + ISPOINTER +OFFSETTYPE = 64& + ISOFFSET + ISPOINTER: IF OS_BITS = 32 THEN OFFSETTYPE = 32& + ISOFFSET + ISPOINTER +UOFFSETTYPE = 64& + ISOFFSET + ISUNSIGNED + ISPOINTER: IF OS_BITS = 32 THEN UOFFSETTYPE = 32& + ISOFFSET + ISUNSIGNED + ISPOINTER UDTTYPE = ISUDT + ISPOINTER @@ -846,14 +846,14 @@ UDTTYPE = ISUDT + ISPOINTER -Dim Shared statementn As Long -Dim Shared everycasenewcase As Long +DIM SHARED statementn AS LONG +DIM SHARED everycasenewcase AS LONG -Dim controllevel As Integer '0=not in a control block -Dim controltype(1000) As Integer +DIM controllevel AS INTEGER '0=not in a control block +DIM controltype(1000) AS INTEGER '1=IF (awaiting END IF) '2=FOR (awaiting NEXT) '3=DO (awaiting LOOP [UNTIL|WHILE param]) @@ -871,31 +871,31 @@ Dim controltype(1000) As Integer '18=CASE (awaiting END SELECT/CASE/CASE ELSE) '19=CASE ELSE (awaiting END SELECT) '32=SUB/FUNCTION (awaiting END SUB/FUNCTION) -Dim controlid(1000) As Long -Dim controlvalue(1000) As Long -Dim controlstate(1000) As Integer -Dim controlref(1000) As Long 'the line number the control was created on +DIM controlid(1000) AS LONG +DIM controlvalue(1000) AS LONG +DIM controlstate(1000) AS INTEGER +DIM controlref(1000) AS LONG 'the line number the control was created on -On Error GoTo qberror +ON ERROR GOTO qberror i2&& = 1 -For i&& = 1 To 56 +FOR i&& = 1 TO 56 bitmask(i&&) = i2&& - bitmaskinv(i&&) = Not i2&& + bitmaskinv(i&&) = NOT i2&& i2&& = i2&& + 2 ^ i&& -Next +NEXT -Dim id2 As idstruct +DIM id2 AS idstruct cleanupstringprocessingcall$ = "qbs_cleanup(qbs_tmp_base," -Dim Shared sfidlist(1000) As Long -Dim Shared sfarglist(1000) As Integer -Dim Shared sfelelist(1000) As Integer +DIM SHARED sfidlist(1000) AS LONG +DIM SHARED sfarglist(1000) AS INTEGER +DIM SHARED sfelelist(1000) AS INTEGER @@ -923,203 +923,203 @@ gl_scan_header '-----------------------QB64 COMPILER ONCE ONLY SETUP CODE ENDS HERE--------------------------------------- -If NoIDEMode Then IDE_AutoPosition = 0: GoTo noide -Dim FileDropEnabled As _Byte -If FileDropEnabled = 0 Then FileDropEnabled = -1: _AcceptFileDrop +IF NoIDEMode THEN IDE_AutoPosition = 0: GOTO noide +DIM FileDropEnabled AS _BYTE +IF FileDropEnabled = 0 THEN FileDropEnabled = -1: _ACCEPTFILEDROP -If IDE_AutoPosition And Not IDE_BypassAutoPosition Then _ScreenMove IDE_LeftPosition, IDE_TopPosition +IF IDE_AutoPosition AND NOT IDE_BypassAutoPosition THEN _SCREENMOVE IDE_LeftPosition, IDE_TopPosition idemode = 1 sendc$ = "" 'no initial message -If CMDLineFile <> "" Then sendc$ = Chr$(1) + CMDLineFile +IF CMDLineFile <> "" THEN sendc$ = CHR$(1) + CMDLineFile sendcommand: idecommand$ = sendc$ C = ide(0) ideerror = 0 -If C = 0 Then idemode = 0: GoTo noide +IF C = 0 THEN idemode = 0: GOTO noide c$ = idereturn$ -If C = 2 Then 'begin +IF C = 2 THEN 'begin ideerrorline = 0 'addresses invalid prepass error line numbers being reported idepass = 1 - GoTo fullrecompile + GOTO fullrecompile ideret1: wholeline$ = c$ - GoTo ideprepass + GOTO ideprepass ideret2: - If lastLineReturn Then GoTo lastLineReturn - sendc$ = Chr$(3) 'request next line - GoTo sendcommand -End If + IF lastLineReturn THEN GOTO lastLineReturn + sendc$ = CHR$(3) 'request next line + GOTO sendcommand +END IF -If C = 4 Then 'next line - If idepass = 1 Then +IF C = 4 THEN 'next line + IF idepass = 1 THEN wholeline$ = c$ - GoTo ideprepass + GOTO ideprepass '(returns to ideret2: above) - End If + END IF 'assume idepass>1 a3$ = c$ continuelinefrom = 0 - GoTo ide4 + GOTO ide4 ideret4: - If lastLineReturn Then GoTo lastLineReturn - sendc$ = Chr$(3) 'request next line - GoTo sendcommand -End If + IF lastLineReturn THEN GOTO lastLineReturn + sendc$ = CHR$(3) 'request next line + GOTO sendcommand +END IF -If C = 5 Then 'end of program reached +IF C = 5 THEN 'end of program reached lastLine = 1 lastLineReturn = 1 - If idepass = 1 Then + IF idepass = 1 THEN wholeline$ = "" - GoTo ideprepass + GOTO ideprepass '(returns to ideret2: above, then to lastLinePrepassReturn below) - End If + END IF 'idepass>1 a3$ = "" continuelinefrom = 0 - GoTo ide4 'returns to ideret4, then to lastLinePrepassReturn below + GOTO ide4 'returns to ideret4, then to lastLinePrepassReturn below lastLineReturn: lastLineReturn = 0 lastLine = 0 - If idepass = 1 Then + IF idepass = 1 THEN 'prepass complete idepass = 2 - GoTo ide3 + GOTO ide3 ideret3: - sendc$ = Chr$(7) 'repass request + sendc$ = CHR$(7) 'repass request firstLine = 1 - GoTo sendcommand - End If + GOTO sendcommand + END IF 'assume idepass=2 'finalize program - GoTo ide5 + GOTO ide5 ideret5: 'note: won't return here if a recompile was required! - sendc$ = Chr$(6) 'ready + sendc$ = CHR$(6) 'ready idecompiled = 0 - GoTo sendcommand -End If + GOTO sendcommand +END IF -If C = 9 Then 'run +IF C = 9 THEN 'run - If idecompiled = 0 Then 'exe needs to be compiled + IF idecompiled = 0 THEN 'exe needs to be compiled file$ = c$ 'locate accessible file and truncate f$ = file$ path.exe$ = "" - If SaveExeWithSource Then - If Len(ideprogname) Then path.exe$ = idepath$ + pathsep$ - End If + IF SaveExeWithSource THEN + IF LEN(ideprogname) THEN path.exe$ = idepath$ + pathsep$ + END IF i = 1 nextexeindex: - If _FileExists(path.exe$ + file$ + extension$) Then + IF _FILEEXISTS(path.exe$ + file$ + extension$) THEN E = 0 - On Error GoTo qberror_test - Kill path.exe$ + file$ + extension$ - On Error GoTo qberror - If E = 1 Then + ON ERROR GOTO qberror_test + KILL path.exe$ + file$ + extension$ + ON ERROR GOTO qberror + IF E = 1 THEN i = i + 1 file$ = f$ + "(" + str2$(i) + ")" - GoTo nextexeindex - End If - End If + GOTO nextexeindex + END IF + END IF - If path.exe$ = "" Then - If InStr(_OS$, "WIN") Then path.exe$ = "..\..\" Else path.exe$ = "../../" - End If + IF path.exe$ = "" THEN + IF INSTR(_OS$, "WIN") THEN path.exe$ = "..\..\" ELSE path.exe$ = "../../" + END IF 'inform IDE of name change if necessary (IDE will respond with message 9 and corrected name) - If i <> 1 Then - sendc$ = Chr$(12) + file$ - GoTo sendcommand - End If + IF i <> 1 THEN + sendc$ = CHR$(12) + file$ + GOTO sendcommand + END IF ideerrorline = 0 'addresses C++ comp. error's line number - GoTo ide6 + GOTO ide6 ideret6: idecompiled = 1 - End If + END IF - If iderunmode = 2 Then - sendc$ = Chr$(11) '.EXE file created - GoTo sendcommand - End If + IF iderunmode = 2 THEN + sendc$ = CHR$(11) '.EXE file created + GOTO sendcommand + END IF 'execute program - If iderunmode = 1 Then - If os$ = "WIN" Then Shell _DontWait QuotedFilename$(Chr$(34) + lastBinaryGenerated$ + Chr$(34)) + ModifyCOMMAND$ - If path.exe$ = "" Then path.exe$ = "./" - If os$ = "LNX" Then - If Left$(lastBinaryGenerated$, Len(path.exe$)) = path.exe$ Then - Shell _DontWait QuotedFilename$(lastBinaryGenerated$) + ModifyCOMMAND$ - Else - Shell _DontWait QuotedFilename$(path.exe$ + lastBinaryGenerated$) + ModifyCOMMAND$ - End If - End If - If path.exe$ = "./" Then path.exe$ = "" - Else - If os$ = "WIN" Then Shell QuotedFilename$(Chr$(34) + lastBinaryGenerated$ + Chr$(34)) + ModifyCOMMAND$ - If path.exe$ = "" Then path.exe$ = "./" - If os$ = "LNX" Then - If Left$(lastBinaryGenerated$, Len(path.exe$)) = path.exe$ Then - Shell QuotedFilename$(lastBinaryGenerated$) + ModifyCOMMAND$ - Else - Shell QuotedFilename$(path.exe$ + lastBinaryGenerated$) + ModifyCOMMAND$ - End If - End If - If path.exe$ = "./" Then path.exe$ = "" - Do: Loop Until InKey$ = "" - Do: Loop Until _KeyHit = 0 - End If + IF iderunmode = 1 THEN + IF os$ = "WIN" THEN SHELL _DONTWAIT QuotedFilename$(CHR$(34) + lastBinaryGenerated$ + CHR$(34)) + ModifyCOMMAND$ + IF path.exe$ = "" THEN path.exe$ = "./" + IF os$ = "LNX" THEN + IF LEFT$(lastBinaryGenerated$, LEN(path.exe$)) = path.exe$ THEN + SHELL _DONTWAIT QuotedFilename$(lastBinaryGenerated$) + ModifyCOMMAND$ + ELSE + SHELL _DONTWAIT QuotedFilename$(path.exe$ + lastBinaryGenerated$) + ModifyCOMMAND$ + END IF + END IF + IF path.exe$ = "./" THEN path.exe$ = "" + ELSE + IF os$ = "WIN" THEN SHELL QuotedFilename$(CHR$(34) + lastBinaryGenerated$ + CHR$(34)) + ModifyCOMMAND$ + IF path.exe$ = "" THEN path.exe$ = "./" + IF os$ = "LNX" THEN + IF LEFT$(lastBinaryGenerated$, LEN(path.exe$)) = path.exe$ THEN + SHELL QuotedFilename$(lastBinaryGenerated$) + ModifyCOMMAND$ + ELSE + SHELL QuotedFilename$(path.exe$ + lastBinaryGenerated$) + ModifyCOMMAND$ + END IF + END IF + IF path.exe$ = "./" THEN path.exe$ = "" + DO: LOOP UNTIL INKEY$ = "" + DO: LOOP UNTIL _KEYHIT = 0 + END IF - If idemode Then + IF idemode THEN 'Darken fg/bg colors dummy = DarkenFGBG(0) - End If + END IF - sendc$ = Chr$(6) 'ready - GoTo sendcommand -End If + sendc$ = CHR$(6) 'ready + GOTO sendcommand +END IF -Print "Invalid IDE message": End +PRINT "Invalid IDE message": END ideerror: -If InStr(idemessage$, sp$) Then +IF INSTR(idemessage$, sp$) THEN 'Something went wrong here, so let's give a generic error message to the user. '(No error message should contain sp$ - that is, CHR$(13), when not in Debug mode) - idemessage$ = "Compiler error (check for syntax errors) (" + _ErrorMessage$ + ":" - If Err Then idemessage$ = idemessage$ + str2$(Err) + "-" - If _ErrorLine Then idemessage$ = idemessage$ + str2$(_ErrorLine) - If _InclErrorLine Then idemessage$ = idemessage$ + "-" + _InclErrorFile$ + "-" + str2$(_InclErrorLine) + idemessage$ = "Compiler error (check for syntax errors) (" + _ERRORMESSAGE$ + ":" + IF ERR THEN idemessage$ = idemessage$ + str2$(ERR) + "-" + IF _ERRORLINE THEN idemessage$ = idemessage$ + str2$(_ERRORLINE) + IF _INCLERRORLINE THEN idemessage$ = idemessage$ + "-" + _INCLERRORFILE$ + "-" + str2$(_INCLERRORLINE) idemessage$ = idemessage$ + ")" - If inclevel > 0 Then idemessage$ = idemessage$ + incerror$ -End If + IF inclevel > 0 THEN idemessage$ = idemessage$ + incerror$ +END IF -sendc$ = Chr$(8) + idemessage$ + MKL$(ideerrorline) -GoTo sendcommand +sendc$ = CHR$(8) + idemessage$ + MKL$(ideerrorline) +GOTO sendcommand noide: -If (qb64versionprinted = 0 Or ConsoleMode = 0) And Not QuietMode Then +IF (qb64versionprinted = 0 OR ConsoleMode = 0) AND NOT QuietMode THEN qb64versionprinted = -1 - Print "QB64 Compiler V" + Version$ -End If + PRINT "QB64 Compiler V" + Version$ +END IF -If CMDLineFile = "" Then - Line Input ; "COMPILE (.bas)>", f$ -Else +IF CMDLineFile = "" THEN + LINE INPUT ; "COMPILE (.bas)>", f$ +ELSE f$ = CMDLineFile -End If +END IF -f$ = LTrim$(RTrim$(f$)) +f$ = LTRIM$(RTRIM$(f$)) -If FileHasExtension(f$) = 0 Then f$ = f$ + ".bas" +IF FileHasExtension(f$) = 0 THEN f$ = f$ + ".bas" sourcefile$ = f$ CMDLineFile = sourcefile$ @@ -1129,30 +1129,30 @@ f$ = RemoveFileExtension$(f$) path.exe$ = "" currentdir$ = _CWD$ path.source$ = getfilepath$(sourcefile$) -If Len(path.source$) Then - If _DirExists(path.source$) = 0 Then - Print - Print "Cannot locate source file: " + sourcefile$ - If ConsoleMode Then System 1 - End 1 - End If - ChDir path.source$ +IF LEN(path.source$) THEN + IF _DIREXISTS(path.source$) = 0 THEN + PRINT + PRINT "Cannot locate source file: " + sourcefile$ + IF ConsoleMode THEN SYSTEM 1 + END 1 + END IF + CHDIR path.source$ path.source$ = _CWD$ - If Right$(path.source$, 1) <> pathsep$ Then path.source$ = path.source$ + pathsep$ - ChDir currentdir$ -End If -If SaveExeWithSource Then path.exe$ = path.source$ -If path.exe$ = "" Then - If InStr(_OS$, "WIN") Then path.exe$ = "..\..\" Else path.exe$ = "../../" -End If + IF RIGHT$(path.source$, 1) <> pathsep$ THEN path.source$ = path.source$ + pathsep$ + CHDIR currentdir$ +END IF +IF SaveExeWithSource THEN path.exe$ = path.source$ +IF path.exe$ = "" THEN + IF INSTR(_OS$, "WIN") THEN path.exe$ = "..\..\" ELSE path.exe$ = "../../" +END IF -For x = Len(f$) To 1 Step -1 - a$ = Mid$(f$, x, 1) - If a$ = "/" Or a$ = "\" Then - f$ = Right$(f$, Len(f$) - x) - Exit For - End If -Next +FOR x = LEN(f$) TO 1 STEP -1 + a$ = MID$(f$, x, 1) + IF a$ = "/" OR a$ = "\" THEN + f$ = RIGHT$(f$, LEN(f$) - x) + EXIT FOR + END IF +NEXT file$ = f$ 'if cmemlist(currentid+1)<>0 before calling regid the variable @@ -1161,24 +1161,24 @@ file$ = f$ fullrecompile: BU_DEPENDENCY_CONSOLE_ONLY = DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) -For i = 1 To UBound(Dependency): DEPENDENCY(i) = 0: Next -DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) = BU_DEPENDENCY_CONSOLE_ONLY And 2 'Restore -g switch if used +FOR i = 1 TO UBOUND(Dependency): DEPENDENCY(i) = 0: NEXT +DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) = BU_DEPENDENCY_CONSOLE_ONLY AND 2 'Restore -g switch if used Error_Happened = 0 -For closeall = 1 To 255: Close closeall: Next +FOR closeall = 1 TO 255: CLOSE closeall: NEXT -Open tmpdir$ + "temp.bin" For Output Lock Write As #26 'relock +OPEN tmpdir$ + "temp.bin" FOR OUTPUT LOCK WRITE AS #26 'relock -fh = FreeFile: Open tmpdir$ + "dyninfo.txt" For Output As #fh: Close #fh +fh = FREEFILE: OPEN tmpdir$ + "dyninfo.txt" FOR OUTPUT AS #fh: CLOSE #fh -If Debug Then Close #9: Open tmpdir$ + "debug.txt" For Output As #9 +IF Debug THEN CLOSE #9: OPEN tmpdir$ + "debug.txt" FOR OUTPUT AS #9 -For i = 1 To ids_max + 1 +FOR i = 1 TO ids_max + 1 arrayelementslist(i) = 0 cmemlist(i) = 0 sfcmemargs(i) = "" -Next +NEXT 'erase cmemlist 'erase sfcmemargs @@ -1384,7 +1384,7 @@ addmetastatic = 0 addmetadynamic = 0 DynamicMode = 0 optionbase = 0 -optionexplicit = 0: If optionexplicit_cmd = -1 And NoIDEMode = 1 Then optionexplicit = -1 +optionexplicit = 0: IF optionexplicit_cmd = -1 AND NoIDEMode = 1 THEN optionexplicit = -1 optionexplicitarray = 0 ExeIconSet = 0 VersionInfoSet = 0 @@ -1396,7 +1396,7 @@ DataOffset = 0 statementn = 0 everycasenewcase = 0 qberrorhappened = 0: qberrorcode = 0: qberrorline = 0 -For i = 1 To 27: defineaz(i) = "SINGLE": defineextaz(i) = "!": Next +FOR i = 1 TO 27: defineaz(i) = "SINGLE": defineextaz(i) = "!": NEXT controllevel = 0 findidsecondarg$ = "": findanotherid = 0: findidinternal = 0: currentid = 0 linenumber = 0 @@ -1416,7 +1416,7 @@ duplicateConstWarning = 0 emptySCWarning = 0 warningListItems = 0 lastWarningHeader = "" -ReDim Shared warning$(1000) +REDIM SHARED warning$(1000) uniquenumbern = 0 qb64prefix_set = 0 qb64prefix$ = "_" @@ -1526,54 +1526,54 @@ udtenext(i2) = 0 'begin compilation -For closeall = 1 To 255: Close closeall: Next -Open tmpdir$ + "temp.bin" For Output Lock Write As #26 'relock +FOR closeall = 1 TO 255: CLOSE closeall: NEXT +OPEN tmpdir$ + "temp.bin" FOR OUTPUT LOCK WRITE AS #26 'relock -ff = FreeFile: Open tmpdir$ + "icon.rc" For Output As #ff: Close #ff +ff = FREEFILE: OPEN tmpdir$ + "icon.rc" FOR OUTPUT AS #ff: CLOSE #ff -If Debug Then Close #9: Open tmpdir$ + "debug.txt" For Append As #9 +IF Debug THEN CLOSE #9: OPEN tmpdir$ + "debug.txt" FOR APPEND AS #9 -If idemode = 0 Then +IF idemode = 0 THEN qberrorhappened = -1 - Open sourcefile$ For Input As #1 + OPEN sourcefile$ FOR INPUT AS #1 qberrorhappened1: - If qberrorhappened = 1 Then - Print - Print "Cannot locate source file:" + sourcefile$ - If ConsoleMode Then System 1 - End 1 - Else - Close #1 - End If + IF qberrorhappened = 1 THEN + PRINT + PRINT "Cannot locate source file:" + sourcefile$ + IF ConsoleMode THEN SYSTEM 1 + END 1 + ELSE + CLOSE #1 + END IF qberrorhappened = 0 -End If +END IF reginternal -Open tmpdir$ + "global.txt" For Output As #18 +OPEN tmpdir$ + "global.txt" FOR OUTPUT AS #18 -If iderecompile Then +IF iderecompile THEN iderecompile = 0 idepass = 1 'prepass must be done again - sendc$ = Chr$(7) 'repass request - GoTo sendcommand -End If + sendc$ = CHR$(7) 'repass request + GOTO sendcommand +END IF -If idemode Then GoTo ideret1 +IF idemode THEN GOTO ideret1 -If Not QuietMode Then - Print - Print "Beginning C++ output from QB64 code... " -End If +IF NOT QuietMode THEN + PRINT + PRINT "Beginning C++ output from QB64 code... " +END IF lineinput3load sourcefile$ -Do +DO '### STEVE EDIT FOR CONST EXPANSION 10/11/2013 wholeline$ = lineinput3$ - If wholeline$ = Chr$(13) Then Exit Do + IF wholeline$ = CHR$(13) THEN EXIT DO ideprepass: prepassLastLine: @@ -1589,17 +1589,17 @@ Do linenumber = linenumber + 1 reallinenumber = reallinenumber + 1 - Do Until linenumber < UBound(InValidLine) 'color information flag for each line - ReDim _Preserve InValidLine(UBound(InValidLine) + 1000) As _Byte - Loop + DO UNTIL linenumber < UBOUND(InValidLine) 'color information flag for each line + REDIM _PRESERVE InValidLine(UBOUND(InValidLine) + 1000) AS _BYTE + LOOP InValidLine(linenumber) = 0 ColorPass: - If Len(wholeline$) Then + IF LEN(wholeline$) THEN - If UCase$(_Trim$(wholeline$)) = "$NOPREFIX" Then - If firstLine = 0 Then a$ = "$NOPREFIX must come before any other statements": GoTo errmes + IF UCASE$(_TRIM$(wholeline$)) = "$NOPREFIX" THEN + IF firstLine = 0 THEN a$ = "$NOPREFIX must come before any other statements": GOTO errmes qb64prefix$ = "" qb64prefix_set = 1 @@ -1618,152 +1618,152 @@ Do f = HASHFLAG_RESERVED + HASHFLAG_CUSTOMSYNTAX HashAdd "EXPLICIT", f, 0 - GoTo finishedlinepp - End If + GOTO finishedlinepp + END IF wholeline$ = lineformat(wholeline$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes - temp$ = LTrim$(RTrim$(UCase$(wholestv$))) + temp$ = LTRIM$(RTRIM$(UCASE$(wholestv$))) - If temp$ = "$COLOR:0" Then - addmetainclude$ = getfilepath$(Command$(0)) + "source" + pathsep$ + "utilities" + pathsep$ + "color0.bi" - GoTo finishedlinepp - End If + IF temp$ = "$COLOR:0" THEN + addmetainclude$ = getfilepath$(COMMAND$(0)) + "source" + pathsep$ + "utilities" + pathsep$ + "color0.bi" + GOTO finishedlinepp + END IF - If temp$ = "$COLOR:32" Then - addmetainclude$ = getfilepath$(Command$(0)) + "source" + pathsep$ + "utilities" + pathsep$ + "color32.bi" - GoTo finishedlinepp - End If + IF temp$ = "$COLOR:32" THEN + addmetainclude$ = getfilepath$(COMMAND$(0)) + "source" + pathsep$ + "utilities" + pathsep$ + "color32.bi" + GOTO finishedlinepp + END IF - If Left$(temp$, 4) = "$IF " Then - If Right$(temp$, 5) <> " THEN" Then a$ = "$IF without THEN": GoTo errmes - temp$ = LTrim$(Mid$(temp$, 4)) 'strip off the $IF and extra spaces - temp$ = RTrim$(Left$(temp$, Len(temp$) - 4)) 'and strip off the THEN and extra spaces - temp = InStr(temp$, "=") + IF LEFT$(temp$, 4) = "$IF " THEN + IF RIGHT$(temp$, 5) <> " THEN" THEN a$ = "$IF without THEN": GOTO errmes + temp$ = LTRIM$(MID$(temp$, 4)) 'strip off the $IF and extra spaces + temp$ = RTRIM$(LEFT$(temp$, LEN(temp$) - 4)) 'and strip off the THEN and extra spaces + temp = INSTR(temp$, "=") ExecCounter = ExecCounter + 1 ExecLevel(ExecCounter) = -1 'default to a skip value DefineElse(ExecCounter) = 1 '1 says we have an $IF statement at this level result = EvalPreIF(temp$, a$) - If a$ <> "" Then GoTo errmes - If result <> 0 Then + IF a$ <> "" THEN GOTO errmes + IF result <> 0 THEN ExecLevel(ExecCounter) = ExecLevel(ExecCounter - 1) 'So we inherit the execlevel from above - If ExecLevel(ExecCounter) = 0 Then DefineElse(ExecCounter) = DefineElse(ExecCounter) Or 4 'Else if used and conditon found - End If - GoTo finishedlinepp 'and then we're finished -- and at this point we didn't make a match so we exit with a DONT READ type flag on our code. - End If + IF ExecLevel(ExecCounter) = 0 THEN DefineElse(ExecCounter) = DefineElse(ExecCounter) OR 4 'Else if used and conditon found + END IF + GOTO finishedlinepp 'and then we're finished -- and at this point we didn't make a match so we exit with a DONT READ type flag on our code. + END IF - If temp$ = "$ELSE" Then - If DefineElse(ExecCounter) = 0 Then a$ = "$ELSE without $IF": GoTo errmes - If DefineElse(ExecCounter) And 2 Then a$ = "$IF block already has $ELSE statement in it": GoTo errmes - DefineElse(ExecCounter) = DefineElse(ExecCounter) Or 2 'set the flag to declare an $ELSE already in this block - If DefineElse(ExecCounter) And 4 Then 'If we executed code in a previous IF or ELSE IF statement, we can't do it here + IF temp$ = "$ELSE" THEN + IF DefineElse(ExecCounter) = 0 THEN a$ = "$ELSE without $IF": GOTO errmes + IF DefineElse(ExecCounter) AND 2 THEN a$ = "$IF block already has $ELSE statement in it": GOTO errmes + DefineElse(ExecCounter) = DefineElse(ExecCounter) OR 2 'set the flag to declare an $ELSE already in this block + IF DefineElse(ExecCounter) AND 4 THEN 'If we executed code in a previous IF or ELSE IF statement, we can't do it here ExecLevel(ExecCounter) = -1 'So we inherit the execlevel from above - Else + ELSE ExecLevel(ExecCounter) = ExecLevel(ExecCounter - 1) 'If we were processing code before, code after this segment is going to be SKIPPED - End If - GoTo finishedlinepp - End If + END IF + GOTO finishedlinepp + END IF - If Left$(temp$, 5) = "$ELSE" Then 'looking for $ELSE IF - temp$ = LTrim$(Mid$(temp$, 6)) - If Left$(temp$, 3) = "IF " Then - If DefineElse(ExecCounter) = 0 Then a$ = "$ELSE IF without $IF": GoTo errmes - If DefineElse(ExecCounter) And 2 Then a$ = "$ELSE IF cannot follow $ELSE": GoTo errmes - If Right$(temp$, 5) <> " THEN" Then a$ = "$ELSE IF without THEN": GoTo errmes - If DefineElse(ExecCounter) And 4 Then 'If we executed code in a previous IF or ELSE IF statement, we can't do it here + IF LEFT$(temp$, 5) = "$ELSE" THEN 'looking for $ELSE IF + temp$ = LTRIM$(MID$(temp$, 6)) + IF LEFT$(temp$, 3) = "IF " THEN + IF DefineElse(ExecCounter) = 0 THEN a$ = "$ELSE IF without $IF": GOTO errmes + IF DefineElse(ExecCounter) AND 2 THEN a$ = "$ELSE IF cannot follow $ELSE": GOTO errmes + IF RIGHT$(temp$, 5) <> " THEN" THEN a$ = "$ELSE IF without THEN": GOTO errmes + IF DefineElse(ExecCounter) AND 4 THEN 'If we executed code in a previous IF or ELSE IF statement, we can't do it here ExecLevel(ExecCounter) = -1 - GoTo finishedlinepp - End If - temp$ = LTrim$(Mid$(temp$, 3)) 'strip off the IF and extra spaces - temp$ = RTrim$(Left$(temp$, Len(temp$) - 4)) 'and strip off the THEN and extra spaces + GOTO finishedlinepp + END IF + temp$ = LTRIM$(MID$(temp$, 3)) 'strip off the IF and extra spaces + temp$ = RTRIM$(LEFT$(temp$, LEN(temp$) - 4)) 'and strip off the THEN and extra spaces result = EvalPreIF(temp$, a$) - If a$ <> "" Then GoTo errmes - If result <> 0 Then + IF a$ <> "" THEN GOTO errmes + IF result <> 0 THEN ExecLevel(ExecCounter) = ExecLevel(ExecCounter - 1) 'So we inherit the execlevel from above - If ExecLevel(ExecCounter) = 0 Then DefineElse(ExecCounter) = DefineElse(ExecCounter) Or 4 'Else if used and conditon found - End If - GoTo finishedlinepp 'and then we're finished -- and at this point we didn't make a match so we exit with a DONT READ type flag on our code. - End If - End If + IF ExecLevel(ExecCounter) = 0 THEN DefineElse(ExecCounter) = DefineElse(ExecCounter) OR 4 'Else if used and conditon found + END IF + GOTO finishedlinepp 'and then we're finished -- and at this point we didn't make a match so we exit with a DONT READ type flag on our code. + END IF + END IF - If temp$ = "$END IF" Or temp$ = "$ENDIF" Then - If DefineElse(ExecCounter) = 0 Then a$ = "$END IF without $IF": GoTo errmes + IF temp$ = "$END IF" OR temp$ = "$ENDIF" THEN + IF DefineElse(ExecCounter) = 0 THEN a$ = "$END IF without $IF": GOTO errmes DefineElse(ExecCounter) = 0 'We no longer have an $IF block at this level ExecCounter = ExecCounter - 1 - GoTo finishedlinepp - End If + GOTO finishedlinepp + END IF - If ExecLevel(ExecCounter) Then - Do Until linenumber < UBound(InValidLine) - ReDim _Preserve InValidLine(UBound(InValidLine) + 1000) As _Byte - Loop + IF ExecLevel(ExecCounter) THEN + DO UNTIL linenumber < UBOUND(InValidLine) + REDIM _PRESERVE InValidLine(UBOUND(InValidLine) + 1000) AS _BYTE + LOOP InValidLine(linenumber) = -1 - GoTo finishedlinepp 'we don't check for anything inside lines that we've marked for skipping - End If + GOTO finishedlinepp 'we don't check for anything inside lines that we've marked for skipping + END IF - If Left$(temp$, 7) = "$ERROR " Then - temp$ = LTrim$(Mid$(temp$, 7)) + IF LEFT$(temp$, 7) = "$ERROR " THEN + temp$ = LTRIM$(MID$(temp$, 7)) a$ = "Compilation check failed: " + temp$ - GoTo errmes - End If + GOTO errmes + END IF - If Left$(temp$, 5) = "$LET " Then - temp$ = LTrim$(Mid$(temp$, 5)) 'simply shorten our string to parse + IF LEFT$(temp$, 5) = "$LET " THEN + temp$ = LTRIM$(MID$(temp$, 5)) 'simply shorten our string to parse 'For starters, let's make certain that we have 3 elements to deal with - temp = InStr(temp$, "=") 'without an = in there, we can't get a value from the left and right side - If temp = 0 Then a$ = "Invalid Syntax. $LET = ": GoTo errmes - l$ = RTrim$(Left$(temp$, temp - 1)): r$ = LTrim$(Mid$(temp$, temp + 1)) + temp = INSTR(temp$, "=") 'without an = in there, we can't get a value from the left and right side + IF temp = 0 THEN a$ = "Invalid Syntax. $LET = ": GOTO errmes + l$ = RTRIM$(LEFT$(temp$, temp - 1)): r$ = LTRIM$(MID$(temp$, temp + 1)) 'then validate to make certain the left side looks proper l1$ = "" - For i = 1 To Len(l$) - a = Asc(l$, i) - Select Case a - Case 32 'strip out spaces - Case 46: l1$ = l1$ + Chr$(a) - Case Is < 48, Is > 90: a$ = "Invalid symbol left of equal sign (" + Chr$(a) + ")": GoTo errmes - Case Else: l1$ = l1$ + Chr$(a) - End Select - Next + FOR i = 1 TO LEN(l$) + a = ASC(l$, i) + SELECT CASE a + CASE 32 'strip out spaces + CASE 46: l1$ = l1$ + CHR$(a) + CASE IS < 48, IS > 90: a$ = "Invalid symbol left of equal sign (" + CHR$(a) + ")": GOTO errmes + CASE ELSE: l1$ = l1$ + CHR$(a) + END SELECT + NEXT l$ = l1$ - If Left$(r$, 1) = Chr$(34) Then r$ = LTrim$(Mid$(r$, 2)) - If Right$(r$, 1) = Chr$(34) Then r$ = RTrim$(Left$(r$, Len(r$) - 1)) - If Left$(r$, 1) = "-" Then + IF LEFT$(r$, 1) = CHR$(34) THEN r$ = LTRIM$(MID$(r$, 2)) + IF RIGHT$(r$, 1) = CHR$(34) THEN r$ = RTRIM$(LEFT$(r$, LEN(r$) - 1)) + IF LEFT$(r$, 1) = "-" THEN r1$ = "-" - r$ = LTrim$(Mid$(r$, 2)) - Else + r$ = LTRIM$(MID$(r$, 2)) + ELSE r1$ = "" - End If + END IF 'then validate to make certain the left side looks proper - For i = 1 To Len(r$) - a = Asc(r$, i) - Select Case a - Case 32 - Case 46 'periods are fine. + FOR i = 1 TO LEN(r$) + a = ASC(r$, i) + SELECT CASE a + CASE 32 + CASE 46 'periods are fine. r1$ = r1$ + "." - Case Is < 48, Is > 90 - a$ = "Invalid symbol right of equal sign (" + Chr$(a) + ")": GoTo errmes - Case Else - r1$ = r1$ + Chr$(a) - End Select - Next + CASE IS < 48, IS > 90 + a$ = "Invalid symbol right of equal sign (" + CHR$(a) + ")": GOTO errmes + CASE ELSE + r1$ = r1$ + CHR$(a) + END SELECT + NEXT r$ = r1$ layout$ = SCase$("$Let ") + l$ + " = " + r$ 'First look to see if we have an existing setting like this and if so, update it - For i = 8 To UserDefineCount 'UserDefineCount 1-7 are reserved for automatic OS/BIT detection & version - If UserDefine(0, i) = l$ Then UserDefine(1, i) = r$: GoTo finishedlinepp - Next + FOR i = 8 TO UserDefineCount 'UserDefineCount 1-7 are reserved for automatic OS/BIT detection & version + IF UserDefine(0, i) = l$ THEN UserDefine(1, i) = r$: GOTO finishedlinepp + NEXT 'Otherwise create a new setting and set the initial value for it UserDefineCount = UserDefineCount + 1 - If UserDefineCount > UBound(UserDefine, 2) Then - ReDim _Preserve UserDefine(1, UBound(UserDefine, 2) + 10) 'Add another 10 elements to the array so it'll expand as the user adds to it - End If + IF UserDefineCount > UBOUND(UserDefine, 2) THEN + REDIM _PRESERVE UserDefine(1, UBOUND(UserDefine, 2) + 10) 'Add another 10 elements to the array so it'll expand as the user adds to it + END IF UserDefine(0, UserDefineCount) = l$ UserDefine(1, UserDefineCount) = r$ - GoTo finishedlinepp - End If + GOTO finishedlinepp + END IF cwholeline$ = wholeline$ @@ -1773,43 +1773,43 @@ Do addmetadynamic = 0: addmetastatic = 0 wholelinen = numelements(wholeline$) - If wholelinen Then + IF wholelinen THEN wholelinei = 1 'skip line number? e$ = getelement$(wholeline$, 1) - If (Asc(e$) >= 48 And Asc(e$) <= 59) Or Asc(e$) = 46 Then wholelinei = 2: GoTo ppskpl + IF (ASC(e$) >= 48 AND ASC(e$) <= 59) OR ASC(e$) = 46 THEN wholelinei = 2: GOTO ppskpl 'skip 'POSSIBLE' line label? - If wholelinen >= 2 Then - x2 = InStr(wholeline$, sp + ":" + sp): x3 = x2 + 2 - If x2 = 0 Then - If Right$(wholeline$, 2) = sp + ":" Then x2 = Len(wholeline$) - 1: x3 = x2 + 1 - End If + IF wholelinen >= 2 THEN + x2 = INSTR(wholeline$, sp + ":" + sp): x3 = x2 + 2 + IF x2 = 0 THEN + IF RIGHT$(wholeline$, 2) = sp + ":" THEN x2 = LEN(wholeline$) - 1: x3 = x2 + 1 + END IF - If x2 Then - e$ = Left$(wholeline$, x2 - 1) - If validlabel(e$) Then - wholeline$ = Right$(wholeline$, Len(wholeline$) - x3) - cwholeline$ = Right$(cwholeline$, Len(wholeline$) - x3) + IF x2 THEN + e$ = LEFT$(wholeline$, x2 - 1) + IF validlabel(e$) THEN + wholeline$ = RIGHT$(wholeline$, LEN(wholeline$) - x3) + cwholeline$ = RIGHT$(cwholeline$, LEN(wholeline$) - x3) wholelinen = numelements(wholeline$) - GoTo ppskpl - End If 'valid - End If 'includes ":" - End If 'wholelinen>=2 + GOTO ppskpl + END IF 'valid + END IF 'includes ":" + END IF 'wholelinen>=2 ppskpl: - If wholelinei <= wholelinen Then + IF wholelinei <= wholelinen THEN '---------------------------------------- a$ = "" ca$ = "" ppblda: e$ = getelement$(wholeline$, wholelinei) ce$ = getelement$(cwholeline$, wholelinei) - If e$ = ":" Or e$ = "ELSE" Or e$ = "THEN" Or e$ = "" Then - If Len(a$) Then - If Debug Then Print #9, "PP[" + a$ + "]" + IF e$ = ":" OR e$ = "ELSE" OR e$ = "THEN" OR e$ = "" THEN + IF LEN(a$) THEN + IF Debug THEN PRINT #9, "PP[" + a$ + "]" n = numelements(a$) firstelement$ = getelement(a$, 1) secondelement$ = getelement(a$, 2) @@ -1817,44 +1817,44 @@ Do '======================================== 'declare library - If declaringlibrary Then + IF declaringlibrary THEN - If firstelement$ = "END" Then - If n <> 2 Or secondelement$ <> "DECLARE" Then a$ = "Expected END DECLARE": GoTo errmes + IF firstelement$ = "END" THEN + IF n <> 2 OR secondelement$ <> "DECLARE" THEN a$ = "Expected END DECLARE": GOTO errmes declaringlibrary = 0 - GoTo finishedlinepp - End If 'end declare + GOTO finishedlinepp + END IF 'end declare declaringlibrary = 2 - If firstelement$ = "SUB" Or firstelement$ = "FUNCTION" Then subfuncn = subfuncn - 1: GoTo declaresubfunc + IF firstelement$ = "SUB" OR firstelement$ = "FUNCTION" THEN subfuncn = subfuncn - 1: GOTO declaresubfunc - a$ = "Expected SUB/FUNCTION definition or END DECLARE (#2)": GoTo errmes - End If + a$ = "Expected SUB/FUNCTION definition or END DECLARE (#2)": GOTO errmes + END IF 'UDT TYPE definition - If definingtype Then + IF definingtype THEN i = definingtype - If n >= 1 Then - If firstelement$ = "END" Then - If n <> 2 Or secondelement$ <> "TYPE" Then a$ = "Expected END TYPE": GoTo errmes - If udtxnext(i) = 0 Then a$ = "No elements defined in TYPE": GoTo errmes + IF n >= 1 THEN + IF firstelement$ = "END" THEN + IF n <> 2 OR secondelement$ <> "TYPE" THEN a$ = "Expected END TYPE": GOTO errmes + IF udtxnext(i) = 0 THEN a$ = "No elements defined in TYPE": GOTO errmes definingtype = 0 'create global buffer for SWAP space siz$ = str2$(udtxsize(i) \ 8) - Print #18, "char *g_tmp_udt_" + RTrim$(udtxname(i)) + "=(char*)malloc(" + siz$ + ");" + PRINT #18, "char *g_tmp_udt_" + RTRIM$(udtxname(i)) + "=(char*)malloc(" + siz$ + ");" 'print "END TYPE";udtxsize(i);udtxbytealign(i) - GoTo finishedlinepp - End If - End If + GOTO finishedlinepp + END IF + END IF - If n < 3 Then a$ = "Expected element-name AS type, AS type element-list, or END TYPE": GoTo errmes + IF n < 3 THEN a$ = "Expected element-name AS type, AS type element-list, or END TYPE": GOTO errmes n$ = firstelement$ - If n$ <> "AS" Then + IF n$ <> "AS" THEN 'traditional variable-name AS type syntax, single-element lasttypeelement = lasttypeelement + 1 i2 = lasttypeelement @@ -1864,15 +1864,15 @@ Do udtearrayelements(i2) = 0 - If ii >= n Or getelement$(a$, ii) <> "AS" Then a$ = "Expected element-name AS type, AS type element-list, or END TYPE": GoTo errmes + IF ii >= n OR getelement$(a$, ii) <> "AS" THEN a$ = "Expected element-name AS type, AS type element-list, or END TYPE": GOTO errmes t$ = getelements$(a$, ii + 1, n) typ = typname2typ(t$) - If Error_Happened Then GoTo errmes - If typ = 0 Then a$ = "Undefined type": GoTo errmes + IF Error_Happened THEN GOTO errmes + IF typ = 0 THEN a$ = "Undefined type": GOTO errmes typsize = typname2typsize - If validname(n$) = 0 Then a$ = "Invalid name": GoTo errmes + IF validname(n$) = 0 THEN a$ = "Invalid name": GOTO errmes udtename(i2) = n$ udtecname(i2) = getelement$(ca$, 1) @@ -1885,81 +1885,81 @@ Do 'check for name conflicts (any similar reserved or element from current UDT) hashchkflags = HASHFLAG_RESERVED + HASHFLAG_UDTELEMENT hashres = HashFind(hashname$, hashchkflags, hashresflags, hashresref) - Do While hashres - If hashresflags And HASHFLAG_UDTELEMENT Then - If hashresref = i Then a$ = "Name already in use": GoTo errmes - End If - If hashresflags And HASHFLAG_RESERVED Then - If hashresflags And (HASHFLAG_TYPE + HASHFLAG_CUSTOMSYNTAX + HASHFLAG_OPERATOR + HASHFLAG_XELEMENTNAME) Then a$ = "Name already in use": GoTo errmes - End If - If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0 - Loop + DO WHILE hashres + IF hashresflags AND HASHFLAG_UDTELEMENT THEN + IF hashresref = i THEN a$ = "Name already in use": GOTO errmes + END IF + IF hashresflags AND HASHFLAG_RESERVED THEN + IF hashresflags AND (HASHFLAG_TYPE + HASHFLAG_CUSTOMSYNTAX + HASHFLAG_OPERATOR + HASHFLAG_XELEMENTNAME) THEN a$ = "Name already in use": GOTO errmes + END IF + IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 + LOOP 'add to hash table HashAdd hashname$, HASHFLAG_UDTELEMENT, i 'Calculate element's size - If typ And ISUDT Then - u = typ And 511 + IF typ AND ISUDT THEN + u = typ AND 511 udtesize(i2) = udtxsize(u) - If udtxbytealign(u) Then udtxbytealign(i) = 1: udtebytealign(i2) = 1 - If udtxvariable(u) Then udtxvariable(i) = -1 - Else - If (typ And ISSTRING) Then - If (typ And ISFIXEDLENGTH) = 0 Then - udtesize(i2) = OFFSETTYPE And 511 + IF udtxbytealign(u) THEN udtxbytealign(i) = 1: udtebytealign(i2) = 1 + IF udtxvariable(u) THEN udtxvariable(i) = -1 + ELSE + IF (typ AND ISSTRING) THEN + IF (typ AND ISFIXEDLENGTH) = 0 THEN + udtesize(i2) = OFFSETTYPE AND 511 udtxvariable(i) = -1 - Else + ELSE udtesize(i2) = typsize * 8 - End If + END IF udtxbytealign(i) = 1: udtebytealign(i2) = 1 - Else - udtesize(i2) = typ And 511 - If (typ And ISOFFSETINBITS) = 0 Then udtxbytealign(i) = 1: udtebytealign(i2) = 1 - End If - End If + ELSE + udtesize(i2) = typ AND 511 + IF (typ AND ISOFFSETINBITS) = 0 THEN udtxbytealign(i) = 1: udtebytealign(i2) = 1 + END IF + END IF 'Increase block size - If udtebytealign(i2) Then - If udtxsize(i) Mod 8 Then - udtxsize(i) = udtxsize(i) + (8 - (udtxsize(i) Mod 8)) - End If - End If + IF udtebytealign(i2) THEN + IF udtxsize(i) MOD 8 THEN + udtxsize(i) = udtxsize(i) + (8 - (udtxsize(i) MOD 8)) + END IF + END IF udtxsize(i) = udtxsize(i) + udtesize(i2) 'Link element to previous element - If udtxnext(i) = 0 Then + IF udtxnext(i) = 0 THEN udtxnext(i) = i2 - Else + ELSE udtenext(i2 - 1) = i2 - End If + END IF 'print "+"+rtrim$(udtename(i2));udtetype(i2);udtesize(i2);udtebytealign(i2);udtxsize(i) - If newAsTypeBlockSyntax Then Return - GoTo finishedlinepp - Else + IF newAsTypeBlockSyntax THEN RETURN + GOTO finishedlinepp + ELSE 'new AS type variable-list syntax, multiple elements ii = 2 - If ii >= n Then a$ = "Expected element-name AS type, AS type element-list, or END TYPE": GoTo errmes + IF ii >= n THEN a$ = "Expected element-name AS type, AS type element-list, or END TYPE": GOTO errmes previousElement$ = "" t$ = "" lastElement$ = "" buildTypeName: lastElement$ = getelement$(a$, ii) - If lastElement$ <> "," And lastElement$ <> "" Then + IF lastElement$ <> "," AND lastElement$ <> "" THEN n$ = lastElement$ cn$ = getelement$(ca$, ii) - If Len(previousElement$) Then t$ = t$ + previousElement$ + " " + IF LEN(previousElement$) THEN t$ = t$ + previousElement$ + " " previousElement$ = n$ lastElement$ = "" ii = ii + 1 - GoTo buildTypeName - End If + GOTO buildTypeName + END IF - t$ = RTrim$(t$) + t$ = RTRIM$(t$) typ = typname2typ(t$) - If Error_Happened Then GoTo errmes - If typ = 0 Then a$ = "Undefined type": GoTo errmes + IF Error_Happened THEN GOTO errmes + IF typ = 0 THEN a$ = "Undefined type": GOTO errmes typsize = typname2typsize nexttypeelement: @@ -1971,33 +1971,33 @@ Do udtename(i2) = n$ udtecname(i2) = cn$ - If validname(n$) = 0 Then a$ = "Invalid name": GoTo errmes + IF validname(n$) = 0 THEN a$ = "Invalid name": GOTO errmes newAsTypeBlockSyntax = -1 - GoSub NormalTypeBlock + GOSUB NormalTypeBlock newAsTypeBlockSyntax = 0 getNextElement: ii = ii + 1 lastElement$ = getelement$(a$, ii) - If lastElement$ = "" Then GoTo finishedlinepp - If ii = n And lastElement$ = "," Then a$ = "Expected element-name": GoTo errmes - If lastElement$ = "," Then GoTo getNextElement + IF lastElement$ = "" THEN GOTO finishedlinepp + IF ii = n AND lastElement$ = "," THEN a$ = "Expected element-name": GOTO errmes + IF lastElement$ = "," THEN GOTO getNextElement n$ = lastElement$ cn$ = getelement$(ca$, ii) - GoTo nexttypeelement - End If - End If 'definingtype + GOTO nexttypeelement + END IF + END IF 'definingtype - If definingtype And n >= 1 Then a$ = "Expected END TYPE": GoTo errmes + IF definingtype AND n >= 1 THEN a$ = "Expected END TYPE": GOTO errmes - If n >= 1 Then - If firstelement$ = "TYPE" Then - If n <> 2 Then a$ = "Expected TYPE typename": GoTo errmes + IF n >= 1 THEN + IF firstelement$ = "TYPE" THEN + IF n <> 2 THEN a$ = "Expected TYPE typename": GOTO errmes lasttype = lasttype + 1 definingtype = lasttype i = definingtype - If validname(secondelement$) = 0 Then a$ = "Invalid name": GoTo errmes + IF validname(secondelement$) = 0 THEN a$ = "Invalid name": GOTO errmes udtxname(i) = secondelement$ udtxcname(i) = getelement(ca$, 2) udtxnext(i) = 0 @@ -2009,47 +2009,47 @@ Do 'check for name conflicts (any similar reserved/sub/function/UDT name) hashchkflags = HASHFLAG_RESERVED + HASHFLAG_SUB + HASHFLAG_FUNCTION + HASHFLAG_UDT hashres = HashFind(hashname$, hashchkflags, hashresflags, hashresref) - Do While hashres + DO WHILE hashres allow = 0 - If hashresflags And (HASHFLAG_SUB + HASHFLAG_FUNCTION) Then + IF hashresflags AND (HASHFLAG_SUB + HASHFLAG_FUNCTION) THEN allow = 1 - End If - If hashresflags And HASHFLAG_RESERVED Then - If (hashresflags And (HASHFLAG_TYPE + HASHFLAG_OPERATOR + HASHFLAG_CUSTOMSYNTAX + HASHFLAG_XTYPENAME)) = 0 Then allow = 1 - End If - If allow = 0 Then a$ = "Name already in use": GoTo errmes - If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0 - Loop + END IF + IF hashresflags AND HASHFLAG_RESERVED THEN + IF (hashresflags AND (HASHFLAG_TYPE + HASHFLAG_OPERATOR + HASHFLAG_CUSTOMSYNTAX + HASHFLAG_XTYPENAME)) = 0 THEN allow = 1 + END IF + IF allow = 0 THEN a$ = "Name already in use": GOTO errmes + IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 + LOOP 'add to hash table HashAdd hashname$, hashflags, i - GoTo finishedlinepp - End If - End If + GOTO finishedlinepp + END IF + END IF - If n >= 1 And firstelement$ = "CONST" Then + IF n >= 1 AND firstelement$ = "CONST" THEN 'l$ = "CONST" 'DEF... do not change type, the expression is stored in a suitable type 'based on its value if type isn't forced/specified 'convert periods to _046_ - i2 = InStr(a$, sp + "." + sp) - If i2 Then - Do - a$ = Left$(a$, i2 - 1) + fix046$ + Right$(a$, Len(a$) - i2 - 2) - ca$ = Left$(ca$, i2 - 1) + fix046$ + Right$(ca$, Len(ca$) - i2 - 2) - i2 = InStr(a$, sp + "." + sp) - Loop Until i2 = 0 + i2 = INSTR(a$, sp + "." + sp) + IF i2 THEN + DO + a$ = LEFT$(a$, i2 - 1) + fix046$ + RIGHT$(a$, LEN(a$) - i2 - 2) + ca$ = LEFT$(ca$, i2 - 1) + fix046$ + RIGHT$(ca$, LEN(ca$) - i2 - 2) + i2 = INSTR(a$, sp + "." + sp) + LOOP UNTIL i2 = 0 n = numelements(a$) firstelement$ = getelement(a$, 1): secondelement$ = getelement(a$, 2): thirdelement$ = getelement(a$, 3) - End If + END IF - If n < 3 Then a$ = "Expected CONST name = value/expression": GoTo errmes + IF n < 3 THEN a$ = "Expected CONST name = value/expression": GOTO errmes i = 2 constdefpendingpp: pending = 0 @@ -2057,124 +2057,124 @@ Do n$ = getelement$(ca$, i): i = i + 1 typeoverride = 0 s$ = removesymbol$(n$) - If Error_Happened Then GoTo errmes - If s$ <> "" Then + IF Error_Happened THEN GOTO errmes + IF s$ <> "" THEN typeoverride = typname2typ(s$) - If Error_Happened Then GoTo errmes - If typeoverride And ISFIXEDLENGTH Then a$ = "Invalid constant type": GoTo errmes - If typeoverride = 0 Then a$ = "Invalid constant type": GoTo errmes - End If + IF Error_Happened THEN GOTO errmes + IF typeoverride AND ISFIXEDLENGTH THEN a$ = "Invalid constant type": GOTO errmes + IF typeoverride = 0 THEN a$ = "Invalid constant type": GOTO errmes + END IF - If getelement$(a$, i) <> "=" Then a$ = "Expected =": GoTo errmes + IF getelement$(a$, i) <> "=" THEN a$ = "Expected =": GOTO errmes i = i + 1 'get expression e$ = "" readable_e$ = "" B = 0 - For i2 = i To n + FOR i2 = i TO n e2$ = getelement$(ca$, i2) - If e2$ = "(" Then B = B + 1 - If e2$ = ")" Then B = B - 1 - If e2$ = "," And B = 0 Then + IF e2$ = "(" THEN B = B + 1 + IF e2$ = ")" THEN B = B - 1 + IF e2$ = "," AND B = 0 THEN pending = 1 i = i2 + 1 - If i > n - 2 Then a$ = "Expected CONST ... , name = value/expression": GoTo errmes - Exit For - End If - If Len(e$) = 0 Then e$ = e2$ Else e$ = e$ + sp + e2$ + IF i > n - 2 THEN a$ = "Expected CONST ... , name = value/expression": GOTO errmes + EXIT FOR + END IF + IF LEN(e$) = 0 THEN e$ = e2$ ELSE e$ = e$ + sp + e2$ e3$ = e2$ - If Len(e2$) > 1 Then - If Asc(e2$, 1) = 34 Then - removeComma = _InStrRev(e2$, ",") - e3$ = Left$(e2$, removeComma - 1) - Else - removeComma = InStr(e2$, ",") - e3$ = Mid$(e2$, removeComma + 1) - End If - End If + IF LEN(e2$) > 1 THEN + IF ASC(e2$, 1) = 34 THEN + removeComma = _INSTRREV(e2$, ",") + e3$ = LEFT$(e2$, removeComma - 1) + ELSE + removeComma = INSTR(e2$, ",") + e3$ = MID$(e2$, removeComma + 1) + END IF + END IF - If Len(readable_e$) = 0 Then + IF LEN(readable_e$) = 0 THEN readable_e$ = e3$ - Else + ELSE readable_e$ = readable_e$ + e3$ - End If - Next + END IF + NEXT 'intercept current expression and pass it through Evaluate_Expression$ - temp1$ = _Trim$(Evaluate_Expression$(readable_e$)) - If Left$(temp1$, 5) <> "ERROR" And e$ <> temp1$ Then + temp1$ = _TRIM$(Evaluate_Expression$(readable_e$)) + IF LEFT$(temp1$, 5) <> "ERROR" AND e$ <> temp1$ THEN e$ = lineformat(temp1$) 'retrieve parseable format - Else - If temp1$ = "ERROR - Division By Zero" Then a$ = temp1$: GoTo errmes - End If + ELSE + IF temp1$ = "ERROR - Division By Zero" THEN a$ = temp1$: GOTO errmes + END IF 'Proceed as usual e$ = fixoperationorder(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes e$ = evaluateconst(e$, t) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes - If t And ISSTRING Then 'string type + IF t AND ISSTRING THEN 'string type - If typeoverride Then - If (typeoverride And ISSTRING) = 0 Then a$ = "Type mismatch": GoTo errmes - End If + IF typeoverride THEN + IF (typeoverride AND ISSTRING) = 0 THEN a$ = "Type mismatch": GOTO errmes + END IF - Else 'not a string type + ELSE 'not a string type - If typeoverride Then - If typeoverride And ISSTRING Then a$ = "Type mismatch": GoTo errmes - End If + IF typeoverride THEN + IF typeoverride AND ISSTRING THEN a$ = "Type mismatch": GOTO errmes + END IF - If t And ISFLOAT Then - constval## = _CV(_Float, e$) + IF t AND ISFLOAT THEN + constval## = _CV(_FLOAT, e$) constval&& = constval## constval~&& = constval&& - Else - If (t And ISUNSIGNED) And (t And 511) = 64 Then - constval~&& = _CV(_Unsigned _Integer64, e$) + ELSE + IF (t AND ISUNSIGNED) AND (t AND 511) = 64 THEN + constval~&& = _CV(_UNSIGNED _INTEGER64, e$) constval&& = constval~&& constval## = constval&& - Else - constval&& = _CV(_Integer64, e$) + ELSE + constval&& = _CV(_INTEGER64, e$) constval## = constval&& constval~&& = constval&& - End If - End If + END IF + END IF 'override type? - If typeoverride Then + IF typeoverride THEN 'range check required here (noted in todo) t = typeoverride - End If + END IF - End If 'not a string type + END IF 'not a string type constlast = constlast + 1 - If constlast > constmax Then + IF constlast > constmax THEN constmax = constmax * 2 - ReDim _Preserve constname(constmax) As String - ReDim _Preserve constcname(constmax) As String - ReDim _Preserve constnamesymbol(constmax) As String 'optional name symbol - ReDim _Preserve consttype(constmax) As Long 'variable type number - ReDim _Preserve constinteger(constmax) As _Integer64 - ReDim _Preserve constuinteger(constmax) As _Unsigned _Integer64 - ReDim _Preserve constfloat(constmax) As _Float - ReDim _Preserve conststring(constmax) As String - ReDim _Preserve constsubfunc(constmax) As Long - ReDim _Preserve constdefined(constmax) As Long - End If + REDIM _PRESERVE constname(constmax) AS STRING + REDIM _PRESERVE constcname(constmax) AS STRING + REDIM _PRESERVE constnamesymbol(constmax) AS STRING 'optional name symbol + REDIM _PRESERVE consttype(constmax) AS LONG 'variable type number + REDIM _PRESERVE constinteger(constmax) AS _INTEGER64 + REDIM _PRESERVE constuinteger(constmax) AS _UNSIGNED _INTEGER64 + REDIM _PRESERVE constfloat(constmax) AS _FLOAT + REDIM _PRESERVE conststring(constmax) AS STRING + REDIM _PRESERVE constsubfunc(constmax) AS LONG + REDIM _PRESERVE constdefined(constmax) AS LONG + END IF i2 = constlast constsubfunc(i2) = subfuncn 'IF subfunc = "" THEN constlastshared = i2 - If validname(n$) = 0 Then a$ = "Invalid name": GoTo errmes - constname(i2) = UCase$(n$) + IF validname(n$) = 0 THEN a$ = "Invalid name": GOTO errmes + constname(i2) = UCASE$(n$) hashname$ = n$ 'check for name conflicts (any similar: reserved, sub, function, constant) @@ -2183,44 +2183,44 @@ Do const_recheck: hashchkflags = HASHFLAG_RESERVED + HASHFLAG_SUB + HASHFLAG_FUNCTION + HASHFLAG_CONSTANT hashres = HashFind(hashname$, hashchkflags, hashresflags, hashresref) - Do While hashres - If hashresflags And HASHFLAG_CONSTANT Then - If constsubfunc(hashresref) = subfuncn Then + DO WHILE hashres + IF hashresflags AND HASHFLAG_CONSTANT THEN + IF constsubfunc(hashresref) = subfuncn THEN 'If merely redefining a CONST with same value 'just issue a warning instead of an error issueWarning = 0 - If t And ISSTRING Then - If conststring(hashresref) = e$ Then issueWarning = -1: thisconstval$ = e$ - Else - If t And ISFLOAT Then - If constfloat(hashresref) = constval## Then issueWarning = -1: thisconstval$ = Str$(constval##) - Else - If t And ISUNSIGNED Then - If constuinteger(hashresref) = constval~&& Then issueWarning = -1: thisconstval$ = Str$(constval~&&) - Else - If constinteger(hashresref) = constval&& Then issueWarning = -1: thisconstval$ = Str$(constval&&) - End If - End If - End If - If issueWarning Then - If Not IgnoreWarnings Then + IF t AND ISSTRING THEN + IF conststring(hashresref) = e$ THEN issueWarning = -1: thisconstval$ = e$ + ELSE + IF t AND ISFLOAT THEN + IF constfloat(hashresref) = constval## THEN issueWarning = -1: thisconstval$ = STR$(constval##) + ELSE + IF t AND ISUNSIGNED THEN + IF constuinteger(hashresref) = constval~&& THEN issueWarning = -1: thisconstval$ = STR$(constval~&&) + ELSE + IF constinteger(hashresref) = constval&& THEN issueWarning = -1: thisconstval$ = STR$(constval&&) + END IF + END IF + END IF + IF issueWarning THEN + IF NOT IgnoreWarnings THEN addWarning linenumber, inclevel, inclinenumber(inclevel), incname$(inclevel), "duplicate constant definition", n$ + " =" + thisconstval$ - End If - GoTo constAddDone - Else - a$ = "Name already in use": GoTo errmes - End If - End If - End If - If hashresflags And HASHFLAG_RESERVED Then - a$ = "Name already in use": GoTo errmes - End If - If hashresflags And (HASHFLAG_SUB + HASHFLAG_FUNCTION) Then - If ids(hashresref).internal_subfunc = 0 Or RTrim$(ids(hashresref).musthave) <> "$" Then a$ = "Name already in use": GoTo errmes - If t And ISSTRING Then a$ = "Name already in use": GoTo errmes - End If - If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0 - Loop + END IF + GOTO constAddDone + ELSE + a$ = "Name already in use": GOTO errmes + END IF + END IF + END IF + IF hashresflags AND HASHFLAG_RESERVED THEN + a$ = "Name already in use": GOTO errmes + END IF + IF hashresflags AND (HASHFLAG_SUB + HASHFLAG_FUNCTION) THEN + IF ids(hashresref).internal_subfunc = 0 OR RTRIM$(ids(hashresref).musthave) <> "$" THEN a$ = "Name already in use": GOTO errmes + IF t AND ISSTRING THEN a$ = "Name already in use": GOTO errmes + END IF + IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 + LOOP 'add to hash table HashAdd hashname$, HASHFLAG_CONSTANT, i2 @@ -2232,155 +2232,155 @@ Do constdefined(i2) = 1 constcname(i2) = n$ constnamesymbol(i2) = typevalue2symbol$(t) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes consttype(i2) = t - If t And ISSTRING Then + IF t AND ISSTRING THEN conststring(i2) = e$ - Else - If t And ISFLOAT Then + ELSE + IF t AND ISFLOAT THEN constfloat(i2) = constval## - Else - If t And ISUNSIGNED Then + ELSE + IF t AND ISUNSIGNED THEN constuinteger(i2) = constval~&& - Else + ELSE constinteger(i2) = constval&& - End If - End If - End If + END IF + END IF + END IF constAddDone: - If pending Then + IF pending THEN 'l$ = l$ + sp2 + "," - GoTo constdefpendingpp - End If + GOTO constdefpendingpp + END IF 'layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ - GoTo finishedlinepp - End If + GOTO finishedlinepp + END IF 'DEFINE d = 0 - If firstelement$ = "DEFINT" Then d = 1 - If firstelement$ = "DEFLNG" Then d = 1 - If firstelement$ = "DEFSNG" Then d = 1 - If firstelement$ = "DEFDBL" Then d = 1 - If firstelement$ = "DEFSTR" Then d = 1 - If firstelement$ = "_DEFINE" Or (firstelement$ = "DEFINE" And qb64prefix_set = 1) Then d = 1 - If d Then - predefining = 1: GoTo predefine + IF firstelement$ = "DEFINT" THEN d = 1 + IF firstelement$ = "DEFLNG" THEN d = 1 + IF firstelement$ = "DEFSNG" THEN d = 1 + IF firstelement$ = "DEFDBL" THEN d = 1 + IF firstelement$ = "DEFSTR" THEN d = 1 + IF firstelement$ = "_DEFINE" OR (firstelement$ = "DEFINE" AND qb64prefix_set = 1) THEN d = 1 + IF d THEN + predefining = 1: GOTO predefine predefined: predefining = 0 - GoTo finishedlinepp - End If + GOTO finishedlinepp + END IF 'declare library - If firstelement$ = "DECLARE" Then - If secondelement$ = "LIBRARY" Or secondelement$ = "DYNAMIC" Or secondelement$ = "CUSTOMTYPE" Or secondelement$ = "STATIC" Then + IF firstelement$ = "DECLARE" THEN + IF secondelement$ = "LIBRARY" OR secondelement$ = "DYNAMIC" OR secondelement$ = "CUSTOMTYPE" OR secondelement$ = "STATIC" THEN declaringlibrary = 1 indirectlibrary = 0 - If secondelement$ = "CUSTOMTYPE" Or secondelement$ = "DYNAMIC" Then indirectlibrary = 1 - GoTo finishedlinepp - End If - End If + IF secondelement$ = "CUSTOMTYPE" OR secondelement$ = "DYNAMIC" THEN indirectlibrary = 1 + GOTO finishedlinepp + END IF + END IF 'SUB/FUNCTION dynamiclibrary = 0 declaresubfunc: firstelement$ = getelement$(a$, 1) sf = 0 - If firstelement$ = "FUNCTION" Then sf = 1 - If firstelement$ = "SUB" Then sf = 2 - If sf Then + IF firstelement$ = "FUNCTION" THEN sf = 1 + IF firstelement$ = "SUB" THEN sf = 2 + IF sf THEN subfuncn = subfuncn + 1 - If n = 1 Then a$ = "Expected name after SUB/FUNCTION": GoTo errmes + IF n = 1 THEN a$ = "Expected name after SUB/FUNCTION": GOTO errmes 'convert periods to _046_ - i2 = InStr(a$, sp + "." + sp) - If i2 Then - Do - a$ = Left$(a$, i2 - 1) + fix046$ + Right$(a$, Len(a$) - i2 - 2) - ca$ = Left$(ca$, i2 - 1) + fix046$ + Right$(ca$, Len(ca$) - i2 - 2) - i2 = InStr(a$, sp + "." + sp) - Loop Until i2 = 0 + i2 = INSTR(a$, sp + "." + sp) + IF i2 THEN + DO + a$ = LEFT$(a$, i2 - 1) + fix046$ + RIGHT$(a$, LEN(a$) - i2 - 2) + ca$ = LEFT$(ca$, i2 - 1) + fix046$ + RIGHT$(ca$, LEN(ca$) - i2 - 2) + i2 = INSTR(a$, sp + "." + sp) + LOOP UNTIL i2 = 0 n = numelements(a$) firstelement$ = getelement(a$, 1): secondelement$ = getelement(a$, 2): thirdelement$ = getelement(a$, 3) - End If + END IF n$ = getelement$(ca$, 2) symbol$ = removesymbol$(n$) - If Error_Happened Then GoTo errmes - If sf = 2 And symbol$ <> "" Then a$ = "Type symbols after a SUB name are invalid": GoTo errmes + IF Error_Happened THEN GOTO errmes + IF sf = 2 AND symbol$ <> "" THEN a$ = "Type symbols after a SUB name are invalid": GOTO errmes 'remove STATIC (which is ignored) - e$ = getelement$(a$, n): If e$ = "STATIC" Then a$ = Left$(a$, Len(a$) - 7): ca$ = Left$(ca$, Len(ca$) - 7): n = n - 1 + e$ = getelement$(a$, n): IF e$ = "STATIC" THEN a$ = LEFT$(a$, LEN(a$) - 7): ca$ = LEFT$(ca$, LEN(ca$) - 7): n = n - 1 'check for ALIAS aliasname$ = n$ 'use given name by default - If n > 2 Then + IF n > 2 THEN e$ = getelement$(a$, 3) - If e$ = "ALIAS" Then - If declaringlibrary = 0 Then a$ = "ALIAS can only be used with DECLARE LIBRARY": GoTo errmes - If n = 3 Then a$ = "Expected ALIAS name-in-library": GoTo errmes + IF e$ = "ALIAS" THEN + IF declaringlibrary = 0 THEN a$ = "ALIAS can only be used with DECLARE LIBRARY": GOTO errmes + IF n = 3 THEN a$ = "Expected ALIAS name-in-library": GOTO errmes e$ = getelement$(ca$, 4) 'strip string content (optional) - If Left$(e$, 1) = Chr$(34) Then - e$ = Right$(e$, Len(e$) - 1) - x = InStr(e$, Chr$(34)): If x = 0 Then a$ = "Expected " + Chr$(34): GoTo errmes - e$ = Left$(e$, x - 1) - End If + IF LEFT$(e$, 1) = CHR$(34) THEN + e$ = RIGHT$(e$, LEN(e$) - 1) + x = INSTR(e$, CHR$(34)): IF x = 0 THEN a$ = "Expected " + CHR$(34): GOTO errmes + e$ = LEFT$(e$, x - 1) + END IF 'strip fix046$ (created by unquoted periods) - Do While InStr(e$, fix046$) - x = InStr(e$, fix046$): e$ = Left$(e$, x - 1) + "." + Right$(e$, Len(e$) - x + 1 - Len(fix046$)) - Loop + DO WHILE INSTR(e$, fix046$) + x = INSTR(e$, fix046$): e$ = LEFT$(e$, x - 1) + "." + RIGHT$(e$, LEN(e$) - x + 1 - LEN(fix046$)) + LOOP 'validate alias name - If Len(e$) = 0 Then a$ = "Expected ALIAS name-in-library": GoTo errmes - For x = 1 To Len(e$) - a = Asc(e$, x) - If alphanumeric(a) = 0 And a <> ASC_FULLSTOP And a <> ASC_COLON Then a$ = "Expected ALIAS name-in-library": GoTo errmes - Next + IF LEN(e$) = 0 THEN a$ = "Expected ALIAS name-in-library": GOTO errmes + FOR x = 1 TO LEN(e$) + a = ASC(e$, x) + IF alphanumeric(a) = 0 AND a <> ASC_FULLSTOP AND a <> ASC_COLON THEN a$ = "Expected ALIAS name-in-library": GOTO errmes + NEXT aliasname$ = e$ 'remove ALIAS section from line - If n <= 4 Then a$ = getelements(a$, 1, 2) - If n >= 5 Then a$ = getelements(a$, 1, 2) + sp + getelements(a$, 5, n) - If n <= 4 Then ca$ = getelements(ca$, 1, 2) - If n >= 5 Then ca$ = getelements(ca$, 1, 2) + sp + getelements(ca$, 5, n) + IF n <= 4 THEN a$ = getelements(a$, 1, 2) + IF n >= 5 THEN a$ = getelements(a$, 1, 2) + sp + getelements(a$, 5, n) + IF n <= 4 THEN ca$ = getelements(ca$, 1, 2) + IF n >= 5 THEN ca$ = getelements(ca$, 1, 2) + sp + getelements(ca$, 5, n) n = n - 2 - End If - End If + END IF + END IF - If declaringlibrary Then - If indirectlibrary Then + IF declaringlibrary THEN + IF indirectlibrary THEN aliasname$ = n$ 'override the alias name - End If - End If + END IF + END IF params = 0 params$ = "" paramsize$ = "" nele$ = "" nelereq$ = "" - If n > 2 Then + IF n > 2 THEN e$ = getelement$(a$, 3) - If e$ <> "(" Then a$ = "Expected (": GoTo errmes + IF e$ <> "(" THEN a$ = "Expected (": GOTO errmes e$ = getelement$(a$, n) - If e$ <> ")" Then a$ = "Expected )": GoTo errmes - If n < 4 Then a$ = "Expected ( ... )": GoTo errmes - If n = 4 Then GoTo nosfparams + IF e$ <> ")" THEN a$ = "Expected )": GOTO errmes + IF n < 4 THEN a$ = "Expected ( ... )": GOTO errmes + IF n = 4 THEN GOTO nosfparams B = 0 a2$ = "" - For i = 4 To n - 1 + FOR i = 4 TO n - 1 e$ = getelement$(a$, i) - If e$ = "(" Then B = B + 1 - If e$ = ")" Then B = B - 1 - If e$ = "," And B = 0 Then - If i = n - 1 Then a$ = "Expected , ... )": GoTo errmes + IF e$ = "(" THEN B = B + 1 + IF e$ = ")" THEN B = B - 1 + IF e$ = "," AND B = 0 THEN + IF i = n - 1 THEN a$ = "Expected , ... )": GOTO errmes getlastparam: - If a2$ = "" Then a$ = "Expected ... ,": GoTo errmes - a2$ = Left$(a2$, Len(a2$) - 1) + IF a2$ = "" THEN a$ = "Expected ... ,": GOTO errmes + a2$ = LEFT$(a2$, LEN(a2$) - 1) 'possible format: [BYVAL]a[%][(1)][AS][type] n2 = numelements(a2$) array = 0 @@ -2390,272 +2390,272 @@ Do e$ = getelement$(a2$, i2): i2 = i2 + 1 byvalue = 0 - If e$ = "BYVAL" Then - If declaringlibrary = 0 Then a$ = "BYVAL can currently only be used with DECLARE LIBRARY": GoTo errmes + IF e$ = "BYVAL" THEN + IF declaringlibrary = 0 THEN a$ = "BYVAL can currently only be used with DECLARE LIBRARY": GOTO errmes e$ = getelement$(a2$, i2): i2 = i2 + 1: byvalue = 1 - End If + END IF n2$ = e$ symbol2$ = removesymbol$(n2$) - If validname(n2$) = 0 Then a$ = "Invalid name": GoTo errmes + IF validname(n2$) = 0 THEN a$ = "Invalid name": GOTO errmes - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes m = 0 - For i2 = i2 To n2 + FOR i2 = i2 TO n2 e$ = getelement$(a2$, i2) - If e$ = "(" Then - If m <> 0 Then a$ = "Syntax error": GoTo errmes + IF e$ = "(" THEN + IF m <> 0 THEN a$ = "Syntax error": GOTO errmes m = 1 array = 1 - GoTo gotaa - End If - If e$ = ")" Then - If m <> 1 Then a$ = "Syntax error": GoTo errmes + GOTO gotaa + END IF + IF e$ = ")" THEN + IF m <> 1 THEN a$ = "Syntax error": GOTO errmes m = 2 - GoTo gotaa - End If - If e$ = "AS" Then - If m <> 0 And m <> 2 Then a$ = "Syntax error": GoTo errmes + GOTO gotaa + END IF + IF e$ = "AS" THEN + IF m <> 0 AND m <> 2 THEN a$ = "Syntax error": GOTO errmes m = 3 - GoTo gotaa - End If - If m = 1 Then GoTo gotaa 'ignore contents of bracket - If m <> 3 Then a$ = "Syntax error": GoTo errmes - If t2$ = "" Then t2$ = e$ Else t2$ = t2$ + " " + e$ + GOTO gotaa + END IF + IF m = 1 THEN GOTO gotaa 'ignore contents of bracket + IF m <> 3 THEN a$ = "Syntax error": GOTO errmes + IF t2$ = "" THEN t2$ = e$ ELSE t2$ = t2$ + " " + e$ gotaa: - Next i2 + NEXT i2 - params = params + 1: If params > 100 Then a$ = "SUB/FUNCTION exceeds 100 parameter limit": GoTo errmes + params = params + 1: IF params > 100 THEN a$ = "SUB/FUNCTION exceeds 100 parameter limit": GOTO errmes argnelereq = 0 - If symbol2$ <> "" And t2$ <> "" Then a$ = "Syntax error": GoTo errmes - If t2$ = "" Then t2$ = symbol2$ - If t2$ = "" Then - If Left$(n2$, 1) = "_" Then v = 27 Else v = Asc(UCase$(n2$)) - 64 + IF symbol2$ <> "" AND t2$ <> "" THEN a$ = "Syntax error": GOTO errmes + IF t2$ = "" THEN t2$ = symbol2$ + IF t2$ = "" THEN + IF LEFT$(n2$, 1) = "_" THEN v = 27 ELSE v = ASC(UCASE$(n2$)) - 64 t2$ = defineaz(v) - End If + END IF paramsize = 0 - If array = 1 Then + IF array = 1 THEN t = typname2typ(t2$) - If Error_Happened Then GoTo errmes - If t = 0 Then a$ = "Illegal SUB/FUNCTION parameter": GoTo errmes - If (t And ISFIXEDLENGTH) Then paramsize = typname2typsize + IF Error_Happened THEN GOTO errmes + IF t = 0 THEN a$ = "Illegal SUB/FUNCTION parameter": GOTO errmes + IF (t AND ISFIXEDLENGTH) THEN paramsize = typname2typsize t = t + ISARRAY 'check for recompilation override - For i10 = 0 To sflistn - If sfidlist(i10) = idn + 1 Then - If sfarglist(i10) = params Then + FOR i10 = 0 TO sflistn + IF sfidlist(i10) = idn + 1 THEN + IF sfarglist(i10) = params THEN argnelereq = sfelelist(i10) - End If - End If - Next - Else + END IF + END IF + NEXT + ELSE t = typname2typ(t2$) - If Error_Happened Then GoTo errmes - If t = 0 Then a$ = "Illegal SUB/FUNCTION parameter": GoTo errmes - If (t And ISFIXEDLENGTH) Then paramsize = typname2typsize + IF Error_Happened THEN GOTO errmes + IF t = 0 THEN a$ = "Illegal SUB/FUNCTION parameter": GOTO errmes + IF (t AND ISFIXEDLENGTH) THEN paramsize = typname2typsize - If byvalue Then - If t And ISPOINTER Then t = t - ISPOINTER - End If + IF byvalue THEN + IF t AND ISPOINTER THEN t = t - ISPOINTER + END IF - End If - nelereq$ = nelereq$ + Chr$(argnelereq) + END IF + nelereq$ = nelereq$ + CHR$(argnelereq) 'consider changing 0 in following line too! - nele$ = nele$ + Chr$(0) + nele$ = nele$ + CHR$(0) paramsize$ = paramsize$ + MKL$(paramsize) params$ = params$ + MKL$(t) a2$ = "" - Else + ELSE a2$ = a2$ + e$ + sp - If i = n - 1 Then GoTo getlastparam - End If - Next i - End If 'n>2 + IF i = n - 1 THEN GOTO getlastparam + END IF + NEXT i + END IF 'n>2 nosfparams: - If sf = 1 Then + IF sf = 1 THEN 'function clearid id.n = n$ id.subfunc = 1 - id.callname = "FUNC_" + UCase$(n$) - If declaringlibrary Then + id.callname = "FUNC_" + UCASE$(n$) + IF declaringlibrary THEN id.ccall = 1 - If indirectlibrary = 0 Then id.callname = aliasname$ - End If + IF indirectlibrary = 0 THEN id.callname = aliasname$ + END IF id.args = params id.arg = params$ id.argsize = paramsize$ id.nele = nele$ id.nelereq = nelereq$ - If symbol$ <> "" Then + IF symbol$ <> "" THEN id.ret = typname2typ(symbol$) - If Error_Happened Then GoTo errmes - Else - If Left$(n$, 1) = "_" Then v = 27 Else v = Asc(UCase$(n$)) - 64 + IF Error_Happened THEN GOTO errmes + ELSE + IF LEFT$(n$, 1) = "_" THEN v = 27 ELSE v = ASC(UCASE$(n$)) - 64 symbol$ = defineaz(v) id.ret = typname2typ(symbol$) - If Error_Happened Then GoTo errmes - End If - If id.ret = 0 Then a$ = "Invalid FUNCTION return type": GoTo errmes + IF Error_Happened THEN GOTO errmes + END IF + IF id.ret = 0 THEN a$ = "Invalid FUNCTION return type": GOTO errmes - If declaringlibrary Then + IF declaringlibrary THEN ctype$ = typ2ctyp$(id.ret, "") - If Error_Happened Then GoTo errmes - If ctype$ = "qbs" Then ctype$ = "char*" - id.callname = "( " + ctype$ + " )" + RTrim$(id.callname) + IF Error_Happened THEN GOTO errmes + IF ctype$ = "qbs" THEN ctype$ = "char*" + id.callname = "( " + ctype$ + " )" + RTRIM$(id.callname) - End If + END IF - s$ = Left$(symbol$, 1) - If s$ <> "~" And s$ <> "`" And s$ <> "%" And s$ <> "&" And s$ <> "!" And s$ <> "#" And s$ <> "$" Then + s$ = LEFT$(symbol$, 1) + IF s$ <> "~" AND s$ <> "`" AND s$ <> "%" AND s$ <> "&" AND s$ <> "!" AND s$ <> "#" AND s$ <> "$" THEN symbol$ = type2symbol$(symbol$) - If Error_Happened Then GoTo errmes - End If + IF Error_Happened THEN GOTO errmes + END IF id.mayhave = symbol$ - If id.ret And ISPOINTER Then - If (id.ret And ISSTRING) = 0 Then id.ret = id.ret - ISPOINTER - End If + IF id.ret AND ISPOINTER THEN + IF (id.ret AND ISSTRING) = 0 THEN id.ret = id.ret - ISPOINTER + END IF regid - If Error_Happened Then GoTo errmes - Else + IF Error_Happened THEN GOTO errmes + ELSE 'sub clearid id.n = n$ id.subfunc = 2 - id.callname = "SUB_" + UCase$(n$) - If declaringlibrary Then + id.callname = "SUB_" + UCASE$(n$) + IF declaringlibrary THEN id.ccall = 1 - If indirectlibrary = 0 Then id.callname = aliasname$ - End If + IF indirectlibrary = 0 THEN id.callname = aliasname$ + END IF id.args = params id.arg = params$ id.argsize = paramsize$ id.nele = nele$ id.nelereq = nelereq$ - If UCase$(n$) = "_GL" And params = 0 And UseGL = 0 Then reginternalsubfunc = 1: UseGL = 1: id.n = "_GL": DEPENDENCY(DEPENDENCY_GL) = 1 + IF UCASE$(n$) = "_GL" AND params = 0 AND UseGL = 0 THEN reginternalsubfunc = 1: UseGL = 1: id.n = "_GL": DEPENDENCY(DEPENDENCY_GL) = 1 regid reginternalsubfunc = 0 - If Error_Happened Then GoTo errmes - End If + IF Error_Happened THEN GOTO errmes + END IF - End If + END IF '======================================== finishedlinepp: firstLine = 0 - End If + END IF a$ = "" ca$ = "" - Else - If a$ = "" Then a$ = e$: ca$ = ce$ Else a$ = a$ + sp + e$: ca$ = ca$ + sp + ce$ - End If - If wholelinei <= wholelinen Then wholelinei = wholelinei + 1: GoTo ppblda + ELSE + IF a$ = "" THEN a$ = e$: ca$ = ce$ ELSE a$ = a$ + sp + e$: ca$ = ca$ + sp + ce$ + END IF + IF wholelinei <= wholelinen THEN wholelinei = wholelinei + 1: GOTO ppblda '---------------------------------------- - End If 'wholelinei<=wholelinen - End If 'wholelinen - End If 'len(wholeline$) + END IF 'wholelinei<=wholelinen + END IF 'wholelinen + END IF 'len(wholeline$) 'Include Manager #1 - If Len(addmetainclude$) Then - If Debug Then Print #9, "Pre-pass:INCLUDE$-ing file:'" + addmetainclude$ + "':On line"; linenumber + IF LEN(addmetainclude$) THEN + IF Debug THEN PRINT #9, "Pre-pass:INCLUDE$-ing file:'" + addmetainclude$ + "':On line"; linenumber a$ = addmetainclude$: addmetainclude$ = "" 'read/clear message - If inclevel = 100 Then a$ = "Too many indwelling INCLUDE files": GoTo errmes + IF inclevel = 100 THEN a$ = "Too many indwelling INCLUDE files": GOTO errmes '1. Verify file exists (location is either (a)relative to source file or (b)absolute) fh = 99 + inclevel + 1 firstTryMethod = 1 - For try = firstTryMethod To 2 'if including file from root, do not attempt including from relative location - If try = 1 Then - If inclevel = 0 Then - If idemode Then p$ = idepath$ + pathsep$ Else p$ = getfilepath$(sourcefile$) - Else + FOR try = firstTryMethod TO 2 'if including file from root, do not attempt including from relative location + IF try = 1 THEN + IF inclevel = 0 THEN + IF idemode THEN p$ = idepath$ + pathsep$ ELSE p$ = getfilepath$(sourcefile$) + ELSE p$ = getfilepath$(incname(inclevel)) - End If + END IF f$ = p$ + a$ - End If - If try = 2 Then f$ = a$ - If _FileExists(f$) Then + END IF + IF try = 2 THEN f$ = a$ + IF _FILEEXISTS(f$) THEN qberrorhappened = -3 'We're using the faster LINE INPUT, which requires a BINARY open. - Open f$ For Binary As #fh + OPEN f$ FOR BINARY AS #fh 'And another line below edited qberrorhappened3: - If qberrorhappened = -3 Then Exit For - End If + IF qberrorhappened = -3 THEN EXIT FOR + END IF qberrorhappened = 0 - Next - If qberrorhappened <> -3 Then qberrorhappened = 0: a$ = "File " + a$ + " not found": GoTo errmes + NEXT + IF qberrorhappened <> -3 THEN qberrorhappened = 0: a$ = "File " + a$ + " not found": GOTO errmes inclevel = inclevel + 1: incname$(inclevel) = f$: inclinenumber(inclevel) = 0 - End If 'fall through to next section... + END IF 'fall through to next section... '-------------------- - Do While inclevel + DO WHILE inclevel fh = 99 + inclevel '2. Feed next line - If EOF(fh) = 0 Then - Line Input #fh, x$ + IF EOF(fh) = 0 THEN + LINE INPUT #fh, x$ wholeline$ = x$ inclinenumber(inclevel) = inclinenumber(inclevel) + 1 'create extended error string 'incerror$' errorLineInInclude = inclinenumber(inclevel) e$ = " in line " + str2(inclinenumber(inclevel)) + " of " + incname$(inclevel) + " included" - If inclevel > 1 Then + IF inclevel > 1 THEN e$ = e$ + " (through " - For x = 1 To inclevel - 1 Step 1 + FOR x = 1 TO inclevel - 1 STEP 1 e$ = e$ + incname$(x) - If x < inclevel - 1 Then 'a sep is req - If x = inclevel - 2 Then + IF x < inclevel - 1 THEN 'a sep is req + IF x = inclevel - 2 THEN e$ = e$ + " then " - Else + ELSE e$ = e$ + ", " - End If - End If - Next + END IF + END IF + NEXT e$ = e$ + ")" - End If + END IF incerror$ = e$ linenumber = linenumber - 1 'lower official linenumber to counter later increment - If Debug Then Print #9, "Pre-pass:Feeding INCLUDE$ line:[" + wholeline$ + "]" + IF Debug THEN PRINT #9, "Pre-pass:Feeding INCLUDE$ line:[" + wholeline$ + "]" - If idemode Then sendc$ = Chr$(10) + wholeline$: GoTo sendcommand 'passback - GoTo ideprepass - End If + IF idemode THEN sendc$ = CHR$(10) + wholeline$: GOTO sendcommand 'passback + GOTO ideprepass + END IF '3. Close & return control - Close #fh + CLOSE #fh inclevel = inclevel - 1 - Loop + LOOP '(end manager) - If idemode Then GoTo ideret2 -Loop + IF idemode THEN GOTO ideret2 +LOOP 'add final line -If lastLineReturn = 0 Then +IF lastLineReturn = 0 THEN lastLineReturn = 1 lastLine = 1 wholeline$ = "" - GoTo prepassLastLine -End If + GOTO prepassLastLine +END IF -If definingtype Then definingtype = 0 'ignore this error so that auto-formatting can be performed and catch it again later -If declaringlibrary Then declaringlibrary = 0 'ignore this error so that auto-formatting can be performed and catch it again later +IF definingtype THEN definingtype = 0 'ignore this error so that auto-formatting can be performed and catch it again later +IF declaringlibrary THEN declaringlibrary = 0 'ignore this error so that auto-formatting can be performed and catch it again later totallinenumber = reallinenumber @@ -2679,42 +2679,42 @@ lastLine = 0 firstLine = 1 UserDefineCount = 7 -For i = 0 To constlast: constdefined(i) = 0: Next 'undefine constants +FOR i = 0 TO constlast: constdefined(i) = 0: NEXT 'undefine constants -For i = 1 To 27: defineaz(i) = "SINGLE": defineextaz(i) = "!": Next +FOR i = 1 TO 27: defineaz(i) = "SINGLE": defineextaz(i) = "!": NEXT -Open tmpdir$ + "data.bin" For Output As #16: Close #16 -Open tmpdir$ + "data.bin" For Binary As #16 +OPEN tmpdir$ + "data.bin" FOR OUTPUT AS #16: CLOSE #16 +OPEN tmpdir$ + "data.bin" FOR BINARY AS #16 -Open tmpdir$ + "main.txt" For Output As #12 -Open tmpdir$ + "maindata.txt" For Output As #13 +OPEN tmpdir$ + "main.txt" FOR OUTPUT AS #12 +OPEN tmpdir$ + "maindata.txt" FOR OUTPUT AS #13 -Open tmpdir$ + "regsf.txt" For Output As #17 +OPEN tmpdir$ + "regsf.txt" FOR OUTPUT AS #17 -Open tmpdir$ + "mainfree.txt" For Output As #19 -Open tmpdir$ + "runline.txt" For Output As #21 +OPEN tmpdir$ + "mainfree.txt" FOR OUTPUT AS #19 +OPEN tmpdir$ + "runline.txt" FOR OUTPUT AS #21 -Open tmpdir$ + "mainerr.txt" For Output As #14 'main error handler +OPEN tmpdir$ + "mainerr.txt" FOR OUTPUT AS #14 'main error handler 'i. check the value of error_line 'ii. jump to the appropriate label errorlabels = 0 -Print #14, "if (error_occurred){ error_occurred=0;" +PRINT #14, "if (error_occurred){ error_occurred=0;" -Open tmpdir$ + "chain.txt" For Output As #22: Close #22 'will be appended to as necessary -Open tmpdir$ + "inpchain.txt" For Output As #23: Close #23 'will be appended to as necessary +OPEN tmpdir$ + "chain.txt" FOR OUTPUT AS #22: CLOSE #22 'will be appended to as necessary +OPEN tmpdir$ + "inpchain.txt" FOR OUTPUT AS #23: CLOSE #23 'will be appended to as necessary '*** #22 & #23 are reserved for usage by chain & inpchain *** -Open tmpdir$ + "ontimer.txt" For Output As #24 -Open tmpdir$ + "ontimerj.txt" For Output As #25 +OPEN tmpdir$ + "ontimer.txt" FOR OUTPUT AS #24 +OPEN tmpdir$ + "ontimerj.txt" FOR OUTPUT AS #25 '*****#26 used for locking qb64 -Open tmpdir$ + "onkey.txt" For Output As #27 -Open tmpdir$ + "onkeyj.txt" For Output As #28 +OPEN tmpdir$ + "onkey.txt" FOR OUTPUT AS #27 +OPEN tmpdir$ + "onkeyj.txt" FOR OUTPUT AS #28 -Open tmpdir$ + "onstrig.txt" For Output As #29 -Open tmpdir$ + "onstrigj.txt" For Output As #30 +OPEN tmpdir$ + "onstrig.txt" FOR OUTPUT AS #29 +OPEN tmpdir$ + "onstrigj.txt" FOR OUTPUT AS #30 gosubid = 1 'to be included whenever return without a label is called @@ -2724,15 +2724,15 @@ gosubid = 1 '0=return from main to calling sub/function/proc by return [NULL]; '1... a global number representing a return point after a gosub 'note: RETURN [label] should fail if a "return [NULL];" type return is required -Open tmpdir$ + "ret0.txt" For Output As #15 -Print #15, "if (next_return_point){" -Print #15, "next_return_point--;" -Print #15, "switch(return_point[next_return_point]){" -Print #15, "case 0:" +OPEN tmpdir$ + "ret0.txt" FOR OUTPUT AS #15 +PRINT #15, "if (next_return_point){" +PRINT #15, "next_return_point--;" +PRINT #15, "switch(return_point[next_return_point]){" +PRINT #15, "case 0:" -Print #15, "return;" +PRINT #15, "return;" -Print #15, "break;" +PRINT #15, "break;" continueline = 0 endifs = 0 @@ -2742,15 +2742,15 @@ linenumber = 0 reallinenumber = 0 declaringlibrary = 0 -Print #12, "S_0:;" 'note: REQUIRED by run statement +PRINT #12, "S_0:;" 'note: REQUIRED by run statement -If UseGL Then gl_include_content +IF UseGL THEN gl_include_content 'ide specific -If idemode Then GoTo ideret3 +IF idemode THEN GOTO ideret3 -Do +DO ide4: includeline: mainpassLastLine: @@ -2759,11 +2759,11 @@ Do stringprocessinghappened = 0 - If continuelinefrom Then + IF continuelinefrom THEN start = continuelinefrom continuelinefrom = 0 - GoTo contline - End If + GOTO contline + END IF 'begin a new line @@ -2775,50 +2775,50 @@ Do newif = 0 'apply metacommands from previous line - If addmetadynamic = 1 Then addmetadynamic = 0: DynamicMode = 1 - If addmetastatic = 1 Then addmetastatic = 0: DynamicMode = 0 + IF addmetadynamic = 1 THEN addmetadynamic = 0: DynamicMode = 1 + IF addmetastatic = 1 THEN addmetastatic = 0: DynamicMode = 0 'a3$ is passed in idemode and when using $include - If idemode = 0 And inclevel = 0 Then a3$ = lineinput3$ - If a3$ = Chr$(13) Then Exit Do + IF idemode = 0 AND inclevel = 0 THEN a3$ = lineinput3$ + IF a3$ = CHR$(13) THEN EXIT DO linenumber = linenumber + 1 reallinenumber = reallinenumber + 1 - If linenumber = 1 Then opex_comments = -1 + IF linenumber = 1 THEN opex_comments = -1 - If InValidLine(linenumber) Then + IF InValidLine(linenumber) THEN layoutok = 1 - layout$ = Space$(controllevel) + LTrim$(RTrim$(a3$)) - If idemode GoTo ideret4 Else GoTo skipide4 - End If + layout$ = SPACE$(controllevel) + LTRIM$(RTRIM$(a3$)) + IF idemode GOTO ideret4 ELSE GOTO skipide4 + END IF layout = "" layoutok = 1 - If idemode = 0 And Not QuietMode Then + IF idemode = 0 AND NOT QuietMode THEN 'IF LEN(a3$) THEN ' dotlinecount = dotlinecount + 1: IF dotlinecount >= 100 THEN dotlinecount = 0: PRINT "."; 'END IF maxprogresswidth = 50 'arbitrary - percentage = Int(reallinenumber / totallinenumber * 100) - percentagechars = Int(maxprogresswidth * reallinenumber / totallinenumber) - If percentage <> prevpercentage And percentagechars <> prevpercentagechars Then + percentage = INT(reallinenumber / totallinenumber * 100) + percentagechars = INT(maxprogresswidth * reallinenumber / totallinenumber) + IF percentage <> prevpercentage AND percentagechars <> prevpercentagechars THEN prevpercentage = percentage prevpercentagechars = percentagechars - If ConsoleMode Then - Print "[" + String$(percentagechars, ".") + Space$(maxprogresswidth - percentagechars) + "]" + Str$(percentage) + "%"; - If os$ = "LNX" Then - Print Chr$(27) + "[A" - Else - Print Chr$(13); - End If - Else - Locate , 1 - Print String$(percentagechars, 219) + String$(maxprogresswidth - percentagechars, 176) + Str$(percentage) + "%"; - End If - End If - End If + IF ConsoleMode THEN + PRINT "[" + STRING$(percentagechars, ".") + SPACE$(maxprogresswidth - percentagechars) + "]" + STR$(percentage) + "%"; + IF os$ = "LNX" THEN + PRINT CHR$(27) + "[A" + ELSE + PRINT CHR$(13); + END IF + ELSE + LOCATE , 1 + PRINT STRING$(percentagechars, 219) + STRING$(maxprogresswidth - percentagechars, 176) + STR$(percentage) + "%"; + END IF + END IF + END IF - a3$ = LTrim$(RTrim$(a3$)) + a3$ = LTRIM$(RTRIM$(a3$)) wholeline = a3$ layoutoriginal$ = a3$ @@ -2826,8 +2826,8 @@ Do lhscontrollevel = controllevel linefragment = "[INFORMATION UNAVAILABLE]" - If Len(a3$) = 0 Then GoTo finishednonexec - If Debug Then Print #9, "########" + a3$ + "########" + IF LEN(a3$) = 0 THEN GOTO finishednonexec + IF Debug THEN PRINT #9, "########" + a3$ + "########" layoutdone = 1 'validates layout of any following goto finishednonexec/finishedline @@ -2835,7 +2835,7 @@ Do 'No need to go over those lines again. 'IF InValidLine(linenumber) THEN goto skipide4 'layoutdone = 0: GOTO finishednonexec - a3u$ = UCase$(a3$) + a3u$ = UCASE$(a3$) IF LEFT$(a3u$, 4) = "REM " OR _ (LEFT$(a3u$, 3) = "REM" AND LEN(a3u$) = 3) OR _ @@ -2845,436 +2845,436 @@ Do LEFT$(a3u$, 1) = "$" THEN 'It's a comment, $metacommand, or OPTION _EXPLICIT itself, alright. 'But even being a comment, there could be an $INCLUDE in there, let's check: - If Left$(a3u$, 4) = "REM " Then i = 5 Else i = 2 - If Left$(LTrim$(Mid$(a3u$, i)), 8) = "$INCLUDE" Then opex_comments = 0 - Else + IF LEFT$(a3u$, 4) = "REM " THEN i = 5 ELSE i = 2 + IF LEFT$(LTRIM$(MID$(a3u$, i)), 8) = "$INCLUDE" THEN opex_comments = 0 + ELSE 'As soon as a line isn't a comment anymore, it can't come before OPTION _EXPLICIT opex_comments = 0 - End If + END IF 'QB64 Metacommands - If Asc(a3$) = 36 Then '$ + IF ASC(a3$) = 36 THEN '$ 'precompiler commands should always be executed FIRST. - If a3u$ = "$END IF" Or a3u$ = "$ENDIF" Then - If DefineElse(ExecCounter) = 0 Then a$ = "$END IF without $IF": GoTo errmes + IF a3u$ = "$END IF" OR a3u$ = "$ENDIF" THEN + IF DefineElse(ExecCounter) = 0 THEN a$ = "$END IF without $IF": GOTO errmes DefineElse(ExecCounter) = 0 'We no longer have an $IF block at this level ExecCounter = ExecCounter - 1 layout$ = SCase$("$End If") controltype(controllevel) = 0 controllevel = controllevel - 1 - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If Left$(a3u$, 4) = "$IF " Then + IF LEFT$(a3u$, 4) = "$IF " THEN 'prevents code from being placed before 'CASE condition' in a SELECT CASE block - If SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then - a$ = "Expected CASE expression": GoTo errmes - End If + IF SelectCaseCounter > 0 AND SelectCaseHasCaseBlock(SelectCaseCounter) = 0 THEN + a$ = "Expected CASE expression": GOTO errmes + END IF - temp$ = LTrim$(Mid$(a3u$, 4)) 'strip off the $IF and extra spaces - temp$ = RTrim$(Left$(temp$, Len(temp$) - 4)) 'and strip off the THEN and extra spaces - temp = InStr(temp$, "=") + temp$ = LTRIM$(MID$(a3u$, 4)) 'strip off the $IF and extra spaces + temp$ = RTRIM$(LEFT$(temp$, LEN(temp$) - 4)) 'and strip off the THEN and extra spaces + temp = INSTR(temp$, "=") ExecCounter = ExecCounter + 1 ExecLevel(ExecCounter) = -1 'default to a skip value DefineElse(ExecCounter) = 1 '1 says we have an $IF statement at this level result = EvalPreIF(temp$, a$) - If a$ <> "" Then GoTo errmes - If result <> 0 Then + IF a$ <> "" THEN GOTO errmes + IF result <> 0 THEN ExecLevel(ExecCounter) = ExecLevel(ExecCounter - 1) 'So we inherit the execlevel from above - If ExecLevel(ExecCounter) = 0 Then DefineElse(ExecCounter) = DefineElse(ExecCounter) Or 4 'Else if used and conditon found - End If + IF ExecLevel(ExecCounter) = 0 THEN DefineElse(ExecCounter) = DefineElse(ExecCounter) OR 4 'Else if used and conditon found + END IF controllevel = controllevel + 1 controltype(controllevel) = 6 - If temp = 0 Then layout$ = SCase$("$If ") + temp$ + SCase$(" Then"): GoTo finishednonexec 'no = sign in the $IF statement, so we're going to assume the user is doing something like $IF flag - l$ = RTrim$(Left$(temp$, temp - 1)): r$ = LTrim$(Mid$(temp$, temp + 1)) + IF temp = 0 THEN layout$ = SCase$("$If ") + temp$ + SCase$(" Then"): GOTO finishednonexec 'no = sign in the $IF statement, so we're going to assume the user is doing something like $IF flag + l$ = RTRIM$(LEFT$(temp$, temp - 1)): r$ = LTRIM$(MID$(temp$, temp + 1)) layout$ = SCase$("$If ") + l$ + " = " + r$ + SCase$(" Then") - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If a3u$ = "$ELSE" Then - If DefineElse(ExecCounter) = 0 Then a$ = "$ELSE without $IF": GoTo errmes - If DefineElse(ExecCounter) And 2 Then a$ = "$IF block already has $ELSE statement in it": GoTo errmes - DefineElse(ExecCounter) = DefineElse(ExecCounter) Or 2 'set the flag to declare an $ELSE already in this block - If DefineElse(ExecCounter) And 4 Then 'If we executed code in a previous IF or ELSE IF statement, we can't do it here + IF a3u$ = "$ELSE" THEN + IF DefineElse(ExecCounter) = 0 THEN a$ = "$ELSE without $IF": GOTO errmes + IF DefineElse(ExecCounter) AND 2 THEN a$ = "$IF block already has $ELSE statement in it": GOTO errmes + DefineElse(ExecCounter) = DefineElse(ExecCounter) OR 2 'set the flag to declare an $ELSE already in this block + IF DefineElse(ExecCounter) AND 4 THEN 'If we executed code in a previous IF or ELSE IF statement, we can't do it here ExecLevel(ExecCounter) = -1 'So we inherit the execlevel from above - Else + ELSE ExecLevel(ExecCounter) = ExecLevel(ExecCounter - 1) 'If we were processing code before, code after this segment is going to be SKIPPED - End If + END IF layout$ = SCase$("$Else") lhscontrollevel = lhscontrollevel - 1 - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If Left$(a3u$, 5) = "$ELSE" Then - temp$ = LTrim$(Mid$(a3u$, 6)) - If Left$(temp$, 3) = "IF " Then - If DefineElse(ExecCounter) = 0 Then a$ = "$ELSE IF without $IF": GoTo errmes - If DefineElse(ExecCounter) And 2 Then a$ = "$ELSE IF cannot follow $ELSE": GoTo errmes - If Right$(temp$, 5) <> " THEN" Then a$ = "$ELSE IF without THEN": GoTo errmes - temp$ = LTrim$(Mid$(temp$, 3)) 'strip off the IF and extra spaces - temp$ = RTrim$(Left$(temp$, Len(temp$) - 4)) 'and strip off the THEN and extra spaces - If DefineElse(ExecCounter) And 4 Then 'If we executed code in a previous IF or ELSE IF statement, we can't do it here + IF LEFT$(a3u$, 5) = "$ELSE" THEN + temp$ = LTRIM$(MID$(a3u$, 6)) + IF LEFT$(temp$, 3) = "IF " THEN + IF DefineElse(ExecCounter) = 0 THEN a$ = "$ELSE IF without $IF": GOTO errmes + IF DefineElse(ExecCounter) AND 2 THEN a$ = "$ELSE IF cannot follow $ELSE": GOTO errmes + IF RIGHT$(temp$, 5) <> " THEN" THEN a$ = "$ELSE IF without THEN": GOTO errmes + temp$ = LTRIM$(MID$(temp$, 3)) 'strip off the IF and extra spaces + temp$ = RTRIM$(LEFT$(temp$, LEN(temp$) - 4)) 'and strip off the THEN and extra spaces + IF DefineElse(ExecCounter) AND 4 THEN 'If we executed code in a previous IF or ELSE IF statement, we can't do it here ExecLevel(ExecCounter) = -1 - Else + ELSE result = EvalPreIF(temp$, a$) - If a$ <> "" Then GoTo errmes - If result <> 0 Then + IF a$ <> "" THEN GOTO errmes + IF result <> 0 THEN ExecLevel(ExecCounter) = ExecLevel(ExecCounter - 1) 'So we inherit the execlevel from above - If ExecLevel(ExecCounter) = 0 Then DefineElse(ExecCounter) = DefineElse(ExecCounter) Or 4 'Else if used and conditon found - End If - End If + IF ExecLevel(ExecCounter) = 0 THEN DefineElse(ExecCounter) = DefineElse(ExecCounter) OR 4 'Else if used and conditon found + END IF + END IF lhscontrollevel = lhscontrollevel - 1 - temp = InStr(temp$, "=") - If temp = 0 Then layout$ = SCase$("$ElseIf ") + temp$ + SCase$(" Then"): GoTo finishednonexec 'no = sign in the $IF statement, so we're going to assume the user is doing something like $IF flag - l$ = RTrim$(Left$(temp$, temp - 1)): r$ = LTrim$(Mid$(temp$, temp + 1)) + temp = INSTR(temp$, "=") + IF temp = 0 THEN layout$ = SCase$("$ElseIf ") + temp$ + SCase$(" Then"): GOTO finishednonexec 'no = sign in the $IF statement, so we're going to assume the user is doing something like $IF flag + l$ = RTRIM$(LEFT$(temp$, temp - 1)): r$ = LTRIM$(MID$(temp$, temp + 1)) layout$ = SCase$("$ElseIf ") + l$ + " = " + r$ + SCase$(" Then") - GoTo finishednonexec - End If - End If + GOTO finishednonexec + END IF + END IF - If ExecLevel(ExecCounter) Then 'don't check for any more metacommands except the one's which worth with the precompiler + IF ExecLevel(ExecCounter) THEN 'don't check for any more metacommands except the one's which worth with the precompiler layoutdone = 0 - GoTo finishednonexec 'we don't check for anything inside lines that we've marked for skipping - End If + GOTO finishednonexec 'we don't check for anything inside lines that we've marked for skipping + END IF - If Left$(a3u$, 5) = "$LET " Then + IF LEFT$(a3u$, 5) = "$LET " THEN temp$ = a3u$ - temp$ = LTrim$(Mid$(temp$, 5)) 'simply shorten our string to parse + temp$ = LTRIM$(MID$(temp$, 5)) 'simply shorten our string to parse 'For starters, let's make certain that we have 3 elements to deal with - temp = InStr(temp$, "=") 'without an = in there, we can't get a value from the left and right side - l$ = RTrim$(Left$(temp$, temp - 1)): r$ = LTrim$(Mid$(temp$, temp + 1)) + temp = INSTR(temp$, "=") 'without an = in there, we can't get a value from the left and right side + l$ = RTRIM$(LEFT$(temp$, temp - 1)): r$ = LTRIM$(MID$(temp$, temp + 1)) layout$ = SCase$("$Let ") + l$ + " = " + r$ 'First look to see if we have an existing setting like this and if so, update it - For i = 7 To UserDefineCount 'UserDefineCount 1-7 are reserved for automatic OS/BIT detection & version - If UserDefine(0, i) = l$ Then UserDefine(1, i) = r$: GoTo finishednonexec - Next + FOR i = 7 TO UserDefineCount 'UserDefineCount 1-7 are reserved for automatic OS/BIT detection & version + IF UserDefine(0, i) = l$ THEN UserDefine(1, i) = r$: GOTO finishednonexec + NEXT 'Otherwise create a new setting and set the initial value for it UserDefineCount = UserDefineCount + 1 - If UserDefineCount > UBound(UserDefine, 2) Then - ReDim _Preserve UserDefine(1, UBound(UserDefine, 2) + 10) 'Add another 10 elements to the array so it'll expand as the user adds to it - End If + IF UserDefineCount > UBOUND(UserDefine, 2) THEN + REDIM _PRESERVE UserDefine(1, UBOUND(UserDefine, 2) + 10) 'Add another 10 elements to the array so it'll expand as the user adds to it + END IF UserDefine(0, UserDefineCount) = l$ UserDefine(1, UserDefineCount) = r$ - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If a3u$ = "$COLOR:0" Then + IF a3u$ = "$COLOR:0" THEN layout$ = SCase$("$Color:0") - addmetainclude$ = getfilepath$(Command$(0)) + "source" + pathsep$ + "utilities" + pathsep$ + "color0.bi" + addmetainclude$ = getfilepath$(COMMAND$(0)) + "source" + pathsep$ + "utilities" + pathsep$ + "color0.bi" layoutdone = 1 - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If a3u$ = "$COLOR:32" Then + IF a3u$ = "$COLOR:32" THEN layout$ = SCase$("$Color:32") - addmetainclude$ = getfilepath$(Command$(0)) + "source" + pathsep$ + "utilities" + pathsep$ + "color32.bi" + addmetainclude$ = getfilepath$(COMMAND$(0)) + "source" + pathsep$ + "utilities" + pathsep$ + "color32.bi" layoutdone = 1 - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If a3u$ = "$NOPREFIX" Then + IF a3u$ = "$NOPREFIX" THEN 'already set in prepass layout$ = SCase$("$NoPrefix") - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If a3u$ = "$VIRTUALKEYBOARD:ON" Then + IF a3u$ = "$VIRTUALKEYBOARD:ON" THEN 'Deprecated; does nothing. layout$ = SCase$("$VirtualKeyboard:On") - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If a3u$ = "$VIRTUALKEYBOARD:OFF" Then + IF a3u$ = "$VIRTUALKEYBOARD:OFF" THEN 'Deprecated; does nothing. layout$ = SCase$("$VirtualKeyboard:Off") - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If a3u$ = "$CHECKING:OFF" Then + IF a3u$ = "$CHECKING:OFF" THEN layout$ = SCase$("$Checking:Off") NoChecks = 1 - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If a3u$ = "$CHECKING:ON" Then + IF a3u$ = "$CHECKING:ON" THEN layout$ = SCase$("$Checking:On") NoChecks = 0 - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If a3u$ = "$CONSOLE" Then + IF a3u$ = "$CONSOLE" THEN layout$ = SCase$("$Console") Console = 1 - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If a3u$ = "$CONSOLE:ONLY" Then + IF a3u$ = "$CONSOLE:ONLY" THEN layout$ = SCase$("$Console:Only") - DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) = DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) Or 1 + DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) = DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) OR 1 Console = 1 - If prepass = 0 Then - If NoChecks = 0 Then Print #12, "do{" - Print #12, "sub__dest(func__console());" - GoTo finishedline2 - Else - GoTo finishednonexec - End If - End If + IF prepass = 0 THEN + IF NoChecks = 0 THEN PRINT #12, "do{" + PRINT #12, "sub__dest(func__console());" + GOTO finishedline2 + ELSE + GOTO finishednonexec + END IF + END IF - If a3u$ = "$ASSERTS" Then + IF a3u$ = "$ASSERTS" THEN layout$ = SCase$("$Asserts") Asserts = 1 - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If a3u$ = "$ASSERTS:CONSOLE" Then + IF a3u$ = "$ASSERTS:CONSOLE" THEN layout$ = SCase$("$Asserts:Console") Asserts = 1 Console = 1 - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If a3u$ = "$SCREENHIDE" Then + IF a3u$ = "$SCREENHIDE" THEN layout$ = SCase$("$ScreenHide") ScreenHide = 1 - GoTo finishednonexec - End If - If a3u$ = "$SCREENSHOW" Then + GOTO finishednonexec + END IF + IF a3u$ = "$SCREENSHOW" THEN layout$ = SCase$("$ScreenShow") ScreenHide = 0 - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If a3u$ = "$RESIZE:OFF" Then + IF a3u$ = "$RESIZE:OFF" THEN layout$ = SCase$("$Resize:Off") Resize = 0: Resize_Scale = 0 - GoTo finishednonexec - End If - If a3u$ = "$RESIZE:ON" Then + GOTO finishednonexec + END IF + IF a3u$ = "$RESIZE:ON" THEN layout$ = SCase$("$Resize:On") Resize = 1: Resize_Scale = 0 - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If a3u$ = "$RESIZE:STRETCH" Then + IF a3u$ = "$RESIZE:STRETCH" THEN layout$ = SCase$("$Resize:Stretch") Resize = 1: Resize_Scale = 1 - GoTo finishednonexec - End If - If a3u$ = "$RESIZE:SMOOTH" Then + GOTO finishednonexec + END IF + IF a3u$ = "$RESIZE:SMOOTH" THEN layout$ = SCase$("$Resize:Smooth") Resize = 1: Resize_Scale = 2 - GoTo finishednonexec - End If + GOTO finishednonexec + END IF - If Left$(a3u$, 12) = "$VERSIONINFO" Then + IF LEFT$(a3u$, 12) = "$VERSIONINFO" THEN 'Embed version info into the final binary (Windows only) - FirstDelimiter = InStr(a3u$, ":") - SecondDelimiter = InStr(FirstDelimiter + 1, a3u$, "=") - If FirstDelimiter = 0 Or SecondDelimiter = 0 Or SecondDelimiter = FirstDelimiter + 1 Then - a$ = "Expected $VERSIONINFO:key=value": GoTo errmes - End If + FirstDelimiter = INSTR(a3u$, ":") + SecondDelimiter = INSTR(FirstDelimiter + 1, a3u$, "=") + IF FirstDelimiter = 0 OR SecondDelimiter = 0 OR SecondDelimiter = FirstDelimiter + 1 THEN + a$ = "Expected $VERSIONINFO:key=value": GOTO errmes + END IF - VersionInfoKey$ = LTrim$(RTrim$(Mid$(a3u$, FirstDelimiter + 1, SecondDelimiter - FirstDelimiter - 1))) - VersionInfoValue$ = StrReplace$(LTrim$(RTrim$(Mid$(a3$, SecondDelimiter + 1))), Chr$(34), "'") + VersionInfoKey$ = LTRIM$(RTRIM$(MID$(a3u$, FirstDelimiter + 1, SecondDelimiter - FirstDelimiter - 1))) + VersionInfoValue$ = StrReplace$(LTRIM$(RTRIM$(MID$(a3$, SecondDelimiter + 1))), CHR$(34), "'") - Select Case VersionInfoKey$ - Case "FILEVERSION#" - GoSub ValidateVersion + SELECT CASE VersionInfoKey$ + CASE "FILEVERSION#" + GOSUB ValidateVersion viFileVersionNum$ = VersionInfoValue$ layout$ = SCase$("$VersionInfo:FILEVERSION#=") + VersionInfoValue$ - Case "PRODUCTVERSION#" - GoSub ValidateVersion + CASE "PRODUCTVERSION#" + GOSUB ValidateVersion viProductVersionNum$ = VersionInfoValue$ layout$ = SCase$("$VersionInfo:PRODUCTVERSION#=") + VersionInfoValue$ - Case "COMPANYNAME" + CASE "COMPANYNAME" viCompanyName$ = VersionInfoValue$ layout$ = SCase$("$VersionInfo:") + "CompanyName=" + VersionInfoValue$ - Case "FILEDESCRIPTION" + CASE "FILEDESCRIPTION" viFileDescription$ = VersionInfoValue$ layout$ = SCase$("$VersionInfo:") + "FileDescription=" + VersionInfoValue$ - Case "FILEVERSION" + CASE "FILEVERSION" viFileVersion$ = VersionInfoValue$ layout$ = SCase$("$VersionInfo:") + "FileVersion=" + VersionInfoValue$ - Case "INTERNALNAME" + CASE "INTERNALNAME" viInternalName$ = VersionInfoValue$ layout$ = SCase$("$VersionInfo:") + "InternalName=" + VersionInfoValue$ - Case "LEGALCOPYRIGHT" + CASE "LEGALCOPYRIGHT" viLegalCopyright$ = VersionInfoValue$ layout$ = SCase$("$VersionInfo:") + "LegalCopyright=" + VersionInfoValue$ - Case "LEGALTRADEMARKS" + CASE "LEGALTRADEMARKS" viLegalTrademarks$ = VersionInfoValue$ layout$ = SCase$("$VersionInfo:") + "LegalTrademarks=" + VersionInfoValue$ - Case "ORIGINALFILENAME" + CASE "ORIGINALFILENAME" viOriginalFilename$ = VersionInfoValue$ layout$ = SCase$("$VersionInfo:") + "OriginalFilename=" + VersionInfoValue$ - Case "PRODUCTNAME" + CASE "PRODUCTNAME" viProductName$ = VersionInfoValue$ layout$ = SCase$("$VersionInfo:") + "ProductName=" + VersionInfoValue$ - Case "PRODUCTVERSION" + CASE "PRODUCTVERSION" viProductVersion$ = VersionInfoValue$ layout$ = SCase$("$VersionInfo:") + "ProductVersion=" + VersionInfoValue$ - Case "COMMENTS" + CASE "COMMENTS" viComments$ = VersionInfoValue$ layout$ = SCase$("$VersionInfo:") + "Comments=" + VersionInfoValue$ - Case "WEB" + CASE "WEB" viWeb$ = VersionInfoValue$ layout$ = SCase$("$VersionInfo:") + "Web=" + VersionInfoValue$ - Case Else + CASE ELSE a$ = "Invalid key. (Use FILEVERSION#, PRODUCTVERSION#, CompanyName, FileDescription, FileVersion, InternalName, LegalCopyright, LegalTrademarks, OriginalFilename, ProductName, ProductVersion, Comments or Web)" - GoTo errmes - End Select + GOTO errmes + END SELECT VersionInfoSet = -1 - GoTo finishednonexec + GOTO finishednonexec ValidateVersion: 'Check if only numbers and commas (4 comma-separated values) - If Len(VersionInfoValue$) = 0 Then a$ = "Expected $VERSIONINFO:" + VersionInfoKey$ + "=#,#,#,# (4 comma-separated numeric values: major, minor, revision and build)": GoTo errmes + IF LEN(VersionInfoValue$) = 0 THEN a$ = "Expected $VERSIONINFO:" + VersionInfoKey$ + "=#,#,#,# (4 comma-separated numeric values: major, minor, revision and build)": GOTO errmes viCommas = 0 - For i = 1 To Len(VersionInfoValue$) - If Asc(VersionInfoValue$, i) = 44 Then viCommas = viCommas + 1 - If InStr("0123456789,", Mid$(VersionInfoValue$, i, 1)) = 0 Or (i = Len(VersionInfoValue$) And viCommas <> 3) Or Right$(VersionInfoValue$, 1) = "," Then - a$ = "Expected $VERSIONINFO:" + VersionInfoKey$ + "=#,#,#,# (4 comma-separated numeric values: major, minor, revision and build)": GoTo errmes - End If - Next - Return - End If + FOR i = 1 TO LEN(VersionInfoValue$) + IF ASC(VersionInfoValue$, i) = 44 THEN viCommas = viCommas + 1 + IF INSTR("0123456789,", MID$(VersionInfoValue$, i, 1)) = 0 OR (i = LEN(VersionInfoValue$) AND viCommas <> 3) OR RIGHT$(VersionInfoValue$, 1) = "," THEN + a$ = "Expected $VERSIONINFO:" + VersionInfoKey$ + "=#,#,#,# (4 comma-separated numeric values: major, minor, revision and build)": GOTO errmes + END IF + NEXT + RETURN + END IF - If Left$(a3u$, 8) = "$EXEICON" Then + IF LEFT$(a3u$, 8) = "$EXEICON" THEN 'Basic syntax check. Multi-platform. - If ExeIconSet Then a$ = "$EXEICON already defined": GoTo errmes - FirstDelimiter = InStr(a3u$, "'") - If FirstDelimiter = 0 Then - a$ = "Expected $EXEICON:'filename'": GoTo errmes - Else - SecondDelimiter = InStr(FirstDelimiter + 1, a3u$, "'") - If SecondDelimiter = 0 Then a$ = "Expected $EXEICON:'filename'": GoTo errmes - End If - ExeIconFile$ = RTrim$(LTrim$(Mid$(a3$, FirstDelimiter + 1, SecondDelimiter - FirstDelimiter - 1))) - If Len(ExeIconFile$) = 0 Then a$ = "Expected $EXEICON:'filename'": GoTo errmes - layout$ = SCase$("$ExeIcon:'") + ExeIconFile$ + "'" + Mid$(a3$, SecondDelimiter + 1) + IF ExeIconSet THEN a$ = "$EXEICON already defined": GOTO errmes + FirstDelimiter = INSTR(a3u$, "'") + IF FirstDelimiter = 0 THEN + a$ = "Expected $EXEICON:'filename'": GOTO errmes + ELSE + SecondDelimiter = INSTR(FirstDelimiter + 1, a3u$, "'") + IF SecondDelimiter = 0 THEN a$ = "Expected $EXEICON:'filename'": GOTO errmes + END IF + ExeIconFile$ = RTRIM$(LTRIM$(MID$(a3$, FirstDelimiter + 1, SecondDelimiter - FirstDelimiter - 1))) + IF LEN(ExeIconFile$) = 0 THEN a$ = "Expected $EXEICON:'filename'": GOTO errmes + layout$ = SCase$("$ExeIcon:'") + ExeIconFile$ + "'" + MID$(a3$, SecondDelimiter + 1) - If InStr(_OS$, "WIN") Then + IF INSTR(_OS$, "WIN") THEN 'Actual metacommand processing. Windows only. 'Expand relative path to full path: IconPath$ = "" - If Left$(ExeIconFile$, 2) = "./" Or Left$(ExeIconFile$, 2) = ".\" Then + IF LEFT$(ExeIconFile$, 2) = "./" OR LEFT$(ExeIconFile$, 2) = ".\" THEN 'Relative to source file's folder - If NoIDEMode Then + IF NoIDEMode THEN IconPath$ = path.source$ - If Len(IconPath$) > 0 And Right$(IconPath$, 1) <> pathsep$ Then IconPath$ = IconPath$ + pathsep$ - Else - If Len(ideprogname) Then IconPath$ = idepath$ + pathsep$ - End If - ExeIconFile$ = IconPath$ + Mid$(ExeIconFile$, 3) - ElseIf InStr(ExeIconFile$, "/") Or InStr(ExeIconFile$, "\") Then - For i = Len(ExeIconFile$) To 1 Step -1 - If Mid$(ExeIconFile$, i, 1) = "/" Or Mid$(ExeIconFile$, i, 1) = "\" Then - IconPath$ = Left$(ExeIconFile$, i) - ExeIconFile$ = Mid$(ExeIconFile$, i + 1) - If _DirExists(IconPath$) = 0 Then a$ = "File '" + ExeIconFile$ + "' not found": GoTo errmes + IF LEN(IconPath$) > 0 AND RIGHT$(IconPath$, 1) <> pathsep$ THEN IconPath$ = IconPath$ + pathsep$ + ELSE + IF LEN(ideprogname) THEN IconPath$ = idepath$ + pathsep$ + END IF + ExeIconFile$ = IconPath$ + MID$(ExeIconFile$, 3) + ELSEIF INSTR(ExeIconFile$, "/") OR INSTR(ExeIconFile$, "\") THEN + FOR i = LEN(ExeIconFile$) TO 1 STEP -1 + IF MID$(ExeIconFile$, i, 1) = "/" OR MID$(ExeIconFile$, i, 1) = "\" THEN + IconPath$ = LEFT$(ExeIconFile$, i) + ExeIconFile$ = MID$(ExeIconFile$, i + 1) + IF _DIREXISTS(IconPath$) = 0 THEN a$ = "File '" + ExeIconFile$ + "' not found": GOTO errmes currentdir$ = _CWD$ - ChDir IconPath$ + CHDIR IconPath$ IconPath$ = _CWD$ - ChDir currentdir$ + CHDIR currentdir$ ExeIconFile$ = IconPath$ + pathsep$ + ExeIconFile$ - Exit For - End If - Next - End If + EXIT FOR + END IF + NEXT + END IF - If _FileExists(ExeIconFile$) = 0 Then - If Len(IconPath$) Then - a$ = "File '" + Mid$(ExeIconFile$, Len(IconPath$) + 1) + "' not found": GoTo errmes - Else - a$ = "File '" + ExeIconFile$ + "' not found": GoTo errmes - End If - Else - iconfilehandle = FreeFile + IF _FILEEXISTS(ExeIconFile$) = 0 THEN + IF LEN(IconPath$) THEN + a$ = "File '" + MID$(ExeIconFile$, LEN(IconPath$) + 1) + "' not found": GOTO errmes + ELSE + a$ = "File '" + ExeIconFile$ + "' not found": GOTO errmes + END IF + ELSE + iconfilehandle = FREEFILE E = 0 - On Error GoTo qberror_test - Open tmpdir$ + "icon.rc" For Output As #iconfilehandle - Print #iconfilehandle, "0 ICON " + QuotedFilename$(StrReplace$(ExeIconFile$, "\", "/")) - Close #iconfilehandle - If E = 1 Then a$ = "Error creating icon resource file": GoTo errmes - On Error GoTo qberror - End If - End If + ON ERROR GOTO qberror_test + OPEN tmpdir$ + "icon.rc" FOR OUTPUT AS #iconfilehandle + PRINT #iconfilehandle, "0 ICON " + QuotedFilename$(StrReplace$(ExeIconFile$, "\", "/")) + CLOSE #iconfilehandle + IF E = 1 THEN a$ = "Error creating icon resource file": GOTO errmes + ON ERROR GOTO qberror + END IF + END IF ExeIconSet = linenumber SetDependency DEPENDENCY_ICON - If NoChecks = 0 Then Print #12, "do{" - Print #12, "sub__icon(NULL,NULL,0);" - GoTo finishedline2 - End If + IF NoChecks = 0 THEN PRINT #12, "do{" + PRINT #12, "sub__icon(NULL,NULL,0);" + GOTO finishedline2 + END IF - End If 'QB64 Metacommands + END IF 'QB64 Metacommands - If ExecLevel(ExecCounter) Then + IF ExecLevel(ExecCounter) THEN layoutdone = 0 - GoTo finishednonexec 'we don't check for anything inside lines that we've marked for skipping - End If + GOTO finishednonexec 'we don't check for anything inside lines that we've marked for skipping + END IF linedataoffset = DataOffset - entireline$ = lineformat(a3$): If Len(entireline$) = 0 Then GoTo finishednonexec - If Error_Happened Then GoTo errmes - u$ = UCase$(entireline$) + entireline$ = lineformat(a3$): IF LEN(entireline$) = 0 THEN GOTO finishednonexec + IF Error_Happened THEN GOTO errmes + u$ = UCASE$(entireline$) newif = 0 'Convert "CASE ELSE" to "CASE C-EL" to avoid confusing compiler 'note: CASE does not have to begin on a new line s = 1 - i = InStr(s, u$, "CASE" + sp + "ELSE") - Do While i + i = INSTR(s, u$, "CASE" + sp + "ELSE") + DO WHILE i skip = 0 - If i <> 1 Then - If Mid$(u$, i - 1, 1) <> sp Then skip = 1 - End If - If i <> Len(u$) - 8 Then - If Mid$(u$, i + 9, 1) <> sp Then skip = 1 - End If - If skip = 0 Then - Mid$(entireline$, i) = "CASE" + sp + "C-EL" - u$ = UCase$(entireline$) - End If + IF i <> 1 THEN + IF MID$(u$, i - 1, 1) <> sp THEN skip = 1 + END IF + IF i <> LEN(u$) - 8 THEN + IF MID$(u$, i + 9, 1) <> sp THEN skip = 1 + END IF + IF skip = 0 THEN + MID$(entireline$, i) = "CASE" + sp + "C-EL" + u$ = UCASE$(entireline$) + END IF s = i + 9 - i = InStr(s, u$, "CASE" + sp + "ELSE") - Loop + i = INSTR(s, u$, "CASE" + sp + "ELSE") + LOOP n = numelements(entireline$) 'line number? - a = Asc(entireline$) - If (a >= 48 And a <= 57) Or a = 46 Then 'numeric + a = ASC(entireline$) + IF (a >= 48 AND a <= 57) OR a = 46 THEN 'numeric label$ = getelement(entireline$, 1) - If validlabel(label$) Then + IF validlabel(label$) THEN v = HashFind(label$, HASHFLAG_LABEL, ignore, r) addlabchk100: - If v Then + IF v THEN s = Labels(r).Scope - If s = subfuncn Or s = -1 Then 'same scope? - If s = -1 Then Labels(r).Scope = subfuncn 'acquire scope - If Labels(r).State = 1 Then a$ = "Duplicate label (" + RTrim$(Labels(r).cn) + ")": GoTo errmes + IF s = subfuncn OR s = -1 THEN 'same scope? + IF s = -1 THEN Labels(r).Scope = subfuncn 'acquire scope + IF Labels(r).State = 1 THEN a$ = "Duplicate label (" + RTRIM$(Labels(r).cn) + ")": GOTO errmes 'aquire state 0 types - tlayout$ = RTrim$(Labels(r).cn) - GoTo addlabaq100 - End If 'same scope - If v = 2 Then v = HashFindCont(ignore, r): GoTo addlabchk100 - End If + tlayout$ = RTRIM$(Labels(r).cn) + GOTO addlabaq100 + END IF 'same scope + IF v = 2 THEN v = HashFindCont(ignore, r): GOTO addlabchk100 + END IF 'does not exist - nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type + nLabels = nLabels + 1: IF nLabels > Labels_Ubound THEN Labels_Ubound = Labels_Ubound * 2: REDIM _PRESERVE Labels(1 TO Labels_Ubound) AS Label_Type Labels(nLabels) = Empty_Label HashAdd label$, HASHFLAG_LABEL, nLabels r = nLabels @@ -3285,57 +3285,57 @@ Do Labels(r).Data_Offset = linedataoffset layout$ = tlayout$ - Print #12, "LABEL_" + label$ + ":;" + PRINT #12, "LABEL_" + label$ + ":;" - If InStr(label$, "p") Then Mid$(label$, InStr(label$, "p"), 1) = "." - If Right$(label$, 1) = "d" Or Right$(label$, 1) = "s" Then label$ = Left$(label$, Len(label$) - 1) - Print #12, "last_line=" + label$ + ";" + IF INSTR(label$, "p") THEN MID$(label$, INSTR(label$, "p"), 1) = "." + IF RIGHT$(label$, 1) = "d" OR RIGHT$(label$, 1) = "s" THEN label$ = LEFT$(label$, LEN(label$) - 1) + PRINT #12, "last_line=" + label$ + ";" inclinenump$ = "" - If inclinenumber(inclevel) Then + IF inclinenumber(inclevel) THEN inclinenump$ = "," + str2$(inclinenumber(inclevel)) thisincname$ = getfilepath$(incname$(inclevel)) - thisincname$ = Mid$(incname$(inclevel), Len(thisincname$) + 1) - inclinenump$ = inclinenump$ + "," + Chr$(34) + thisincname$ + Chr$(34) - End If - If NoChecks = 0 Then - Print #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");r=0;}" - End If - If n = 1 Then GoTo finishednonexec - entireline$ = getelements(entireline$, 2, n): u$ = UCase$(entireline$): n = n - 1 + thisincname$ = MID$(incname$(inclevel), LEN(thisincname$) + 1) + inclinenump$ = inclinenump$ + "," + CHR$(34) + thisincname$ + CHR$(34) + END IF + IF NoChecks = 0 THEN + PRINT #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");r=0;}" + END IF + IF n = 1 THEN GOTO finishednonexec + entireline$ = getelements(entireline$, 2, n): u$ = UCASE$(entireline$): n = n - 1 'note: fall through, numeric labels can be followed by alphanumeric label - End If 'validlabel - End If 'numeric + END IF 'validlabel + END IF 'numeric 'it wasn't a line number 'label? 'note: ignores possibility that this could be a single command SUB/FUNCTION (as in QBASIC?) - If n >= 2 Then - x2 = InStr(entireline$, sp + ":") - If x2 Then - If x2 = Len(entireline$) - 1 Then x3 = x2 + 1 Else x3 = x2 + 2 - a$ = Left$(entireline$, x2 - 1) + IF n >= 2 THEN + x2 = INSTR(entireline$, sp + ":") + IF x2 THEN + IF x2 = LEN(entireline$) - 1 THEN x3 = x2 + 1 ELSE x3 = x2 + 2 + a$ = LEFT$(entireline$, x2 - 1) CreatingLabel = 1 - If validlabel(a$) Then + IF validlabel(a$) THEN - If validname(a$) = 0 Then a$ = "Invalid name": GoTo errmes + IF validname(a$) = 0 THEN a$ = "Invalid name": GOTO errmes v = HashFind(a$, HASHFLAG_LABEL, ignore, r) addlabchk: - If v Then + IF v THEN s = Labels(r).Scope - If s = subfuncn Or s = -1 Then 'same scope? - If s = -1 Then Labels(r).Scope = subfuncn 'acquire scope - If Labels(r).State = 1 Then a$ = "Duplicate label (" + RTrim$(Labels(r).cn) + ")": GoTo errmes + IF s = subfuncn OR s = -1 THEN 'same scope? + IF s = -1 THEN Labels(r).Scope = subfuncn 'acquire scope + IF Labels(r).State = 1 THEN a$ = "Duplicate label (" + RTRIM$(Labels(r).cn) + ")": GOTO errmes 'aquire state 0 types - tlayout$ = RTrim$(Labels(r).cn) - GoTo addlabaq - End If 'same scope - If v = 2 Then v = HashFindCont(ignore, r): GoTo addlabchk - End If + tlayout$ = RTRIM$(Labels(r).cn) + GOTO addlabaq + END IF 'same scope + IF v = 2 THEN v = HashFindCont(ignore, r): GOTO addlabchk + END IF 'does not exist - nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type + nLabels = nLabels + 1: IF nLabels > Labels_Ubound THEN Labels_Ubound = Labels_Ubound * 2: REDIM _PRESERVE Labels(1 TO Labels_Ubound) AS Label_Type Labels(nLabels) = Empty_Label HashAdd a$, HASHFLAG_LABEL, nLabels r = nLabels @@ -3346,66 +3346,66 @@ Do Labels(r).Data_Offset = linedataoffset Labels(r).SourceLineNumber = linenumber - If Len(layout$) Then layout$ = layout$ + sp + tlayout$ + ":" Else layout$ = tlayout$ + ":" + IF LEN(layout$) THEN layout$ = layout$ + sp + tlayout$ + ":" ELSE layout$ = tlayout$ + ":" - Print #12, "LABEL_" + a$ + ":;" + PRINT #12, "LABEL_" + a$ + ":;" inclinenump$ = "" - If inclinenumber(inclevel) Then + IF inclinenumber(inclevel) THEN inclinenump$ = "," + str2$(inclinenumber(inclevel)) thisincname$ = getfilepath$(incname$(inclevel)) - thisincname$ = Mid$(incname$(inclevel), Len(thisincname$) + 1) - inclinenump$ = inclinenump$ + "," + Chr$(34) + thisincname$ + Chr$(34) - End If - If NoChecks = 0 Then - Print #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");r=0;}" - End If - entireline$ = Right$(entireline$, Len(entireline$) - x3): u$ = UCase$(entireline$) - n = numelements(entireline$): If n = 0 Then GoTo finishednonexec - End If 'valid - End If 'includes sp+":" - End If 'n>=2 + thisincname$ = MID$(incname$(inclevel), LEN(thisincname$) + 1) + inclinenump$ = inclinenump$ + "," + CHR$(34) + thisincname$ + CHR$(34) + END IF + IF NoChecks = 0 THEN + PRINT #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");r=0;}" + END IF + entireline$ = RIGHT$(entireline$, LEN(entireline$) - x3): u$ = UCASE$(entireline$) + n = numelements(entireline$): IF n = 0 THEN GOTO finishednonexec + END IF 'valid + END IF 'includes sp+":" + END IF 'n>=2 'remove leading ":" - Do While Asc(u$) = 58 '":" - If Len(layout$) Then layout$ = layout$ + sp2 + ":" Else layout$ = ":" - If Len(u$) = 1 Then GoTo finishednonexec - entireline$ = getelements(entireline$, 2, n): u$ = UCase$(entireline$): n = n - 1 - Loop + DO WHILE ASC(u$) = 58 '":" + IF LEN(layout$) THEN layout$ = layout$ + sp2 + ":" ELSE layout$ = ":" + IF LEN(u$) = 1 THEN GOTO finishednonexec + entireline$ = getelements(entireline$, 2, n): u$ = UCASE$(entireline$): n = n - 1 + LOOP 'ELSE at the beginning of a line - If Asc(u$) = 69 Then '"E" + IF ASC(u$) = 69 THEN '"E" e1$ = getelement(u$, 1) - If e1$ = "ELSE" Then + IF e1$ = "ELSE" THEN a$ = "ELSE" - If n > 1 Then continuelinefrom = 2 - GoTo gotcommand - End If + IF n > 1 THEN continuelinefrom = 2 + GOTO gotcommand + END IF - If e1$ = "ELSEIF" Then - If n < 3 Then a$ = "Expected ... THEN": GoTo errmes - If getelement(u$, n) = "THEN" Then a$ = entireline$: GoTo gotcommand - For i = 3 To n - 1 - If getelement(u$, i) = "THEN" Then + IF e1$ = "ELSEIF" THEN + IF n < 3 THEN a$ = "Expected ... THEN": GOTO errmes + IF getelement(u$, n) = "THEN" THEN a$ = entireline$: GOTO gotcommand + FOR i = 3 TO n - 1 + IF getelement(u$, i) = "THEN" THEN a$ = getelements(entireline$, 1, i) continuelinefrom = i + 1 - GoTo gotcommand - End If - Next - a$ = "Expected THEN": GoTo errmes - End If + GOTO gotcommand + END IF + NEXT + a$ = "Expected THEN": GOTO errmes + END IF - End If '"E" + END IF '"E" start = 1 - GoTo skipcontinit + GOTO skipcontinit contline: n = numelements(entireline$) - u$ = UCase$(entireline$) + u$ = UCASE$(entireline$) skipcontinit: @@ -3417,43 +3417,43 @@ Do a$ = "" - For i = start To n + FOR i = start TO n e$ = getelement(u$, i) - If e$ = ":" Then - If i = start Then - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp2 + ":" Else layout$ = ":" - If i <> n Then continuelinefrom = i + 1 - GoTo finishednonexec - End If - If i <> n Then continuelinefrom = i - GoTo gotcommand - End If + IF e$ = ":" THEN + IF i = start THEN + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp2 + ":" ELSE layout$ = ":" + IF i <> n THEN continuelinefrom = i + 1 + GOTO finishednonexec + END IF + IF i <> n THEN continuelinefrom = i + GOTO gotcommand + END IF 'begin scanning an 'IF' statement - If e$ = "IF" And a$ = "" Then newif = 1 + IF e$ = "IF" AND a$ = "" THEN newif = 1 - If e$ = "THEN" Or (e$ = "GOTO" And newif = 1) Then - If newif = 0 Then a$ = "THEN without IF": GoTo errmes + IF e$ = "THEN" OR (e$ = "GOTO" AND newif = 1) THEN + IF newif = 0 THEN a$ = "THEN without IF": GOTO errmes newif = 0 - If lineelseused > 0 Then lineelseused = lineelseused - 1 - If e$ = "GOTO" Then - If i = n Then a$ = "Expected IF expression GOTO label": GoTo errmes + IF lineelseused > 0 THEN lineelseused = lineelseused - 1 + IF e$ = "GOTO" THEN + IF i = n THEN a$ = "Expected IF expression GOTO label": GOTO errmes i = i - 1 - End If + END IF a$ = a$ + sp + e$ '+"THEN"/"GOTO" - If i <> n Then continuelinefrom = i + 1: endifs = endifs + 1 - GoTo gotcommand - End If + IF i <> n THEN continuelinefrom = i + 1: endifs = endifs + 1 + GOTO gotcommand + END IF - If e$ = "ELSE" Then + IF e$ = "ELSE" THEN - If start = i Then - If lineelseused >= 1 Then + IF start = i THEN + IF lineelseused >= 1 THEN 'note: more than one else used (in a row) on this line, so close first if with an 'END IF' first 'note: parses 'END IF' then (after continuelinefrom) parses 'ELSE' 'consider the following: (square brackets make reading easier) @@ -3462,32 +3462,32 @@ Do endifs = endifs - 1 continuelinefrom = i lineelseused = lineelseused - 1 - GoTo gotcommand - End If + GOTO gotcommand + END IF 'follow up previously encountered 'ELSE' by applying 'ELSE' a$ = "ELSE": continuelinefrom = i + 1 lineelseused = lineelseused + 1 - GoTo gotcommand - End If 'start=i + GOTO gotcommand + END IF 'start=i 'apply everything up to (but not including) 'ELSE' continuelinefrom = i - GoTo gotcommand - End If '"ELSE" + GOTO gotcommand + END IF '"ELSE" - e$ = getelement(entireline$, i): If a$ = "" Then a$ = e$ Else a$ = a$ + sp + e$ - Next + e$ = getelement(entireline$, i): IF a$ = "" THEN a$ = e$ ELSE a$ = a$ + sp + e$ + NEXT 'we're reached the end of the line - If endifs > 0 Then + IF endifs > 0 THEN endifs = endifs - 1 impliedendif = 1: entireline$ = entireline$ + sp + ":" + sp + "END" + sp + "IF": n = n + 3 i = i + 1 'skip the ":" (i is now equal to n+2) continuelinefrom = i - GoTo gotcommand - End If + GOTO gotcommand + END IF gotcommand: @@ -3501,56 +3501,56 @@ Do layoutdone = 0 linefragment = a$ - If Debug Then Print #9, a$ + IF Debug THEN PRINT #9, a$ n = numelements(a$) - If n = 0 Then GoTo finishednonexec + IF n = 0 THEN GOTO finishednonexec 'convert non-UDT dimensioned periods to _046_ - If InStr(ca$, sp + "." + sp) Then + IF INSTR(ca$, sp + "." + sp) THEN a3$ = getelement(ca$, 1) except = 0 aa$ = a3$ + sp 'rebuilt a$ (always has a trailing spacer) lastfuse = -1 - For x = 2 To n + FOR x = 2 TO n a2$ = getelement(ca$, x) - If except = 1 Then except = 2: GoTo udtperiod 'skip element name - If a2$ = "." And x <> n Then - If except = 2 Then except = 1: GoTo udtperiod 'sub-element of UDT + IF except = 1 THEN except = 2: GOTO udtperiod 'skip element name + IF a2$ = "." AND x <> n THEN + IF except = 2 THEN except = 1: GOTO udtperiod 'sub-element of UDT - If a3$ = ")" Then + IF a3$ = ")" THEN 'assume it was something like typevar(???).x and treat as a UDT except = 1 - GoTo udtperiod - End If + GOTO udtperiod + END IF 'find an ID of that type - try = findid(UCase$(a3$)) - If Error_Happened Then GoTo errmes - Do While try - If ((id.t And ISUDT) <> 0) Or ((id.arraytype And ISUDT) <> 0) Then + try = findid(UCASE$(a3$)) + IF Error_Happened THEN GOTO errmes + DO WHILE try + IF ((id.t AND ISUDT) <> 0) OR ((id.arraytype AND ISUDT) <> 0) THEN except = 1 - GoTo udtperiod - End If - If try = 2 Then findanotherid = 1: try = findid(UCase$(a3$)) Else try = 0 - If Error_Happened Then GoTo errmes - Loop + GOTO udtperiod + END IF + IF try = 2 THEN findanotherid = 1: try = findid(UCASE$(a3$)) ELSE try = 0 + IF Error_Happened THEN GOTO errmes + LOOP 'not a udt; fuse lhs & rhs with _046_ - If isalpha(Asc(a3$)) = 0 And lastfuse <> x - 2 Then a$ = "Invalid '.'": GoTo errmes - aa$ = Left$(aa$, Len(aa$) - 1) + fix046$ + IF isalpha(ASC(a3$)) = 0 AND lastfuse <> x - 2 THEN a$ = "Invalid '.'": GOTO errmes + aa$ = LEFT$(aa$, LEN(aa$) - 1) + fix046$ lastfuse = x - GoTo periodfused - End If '"." + GOTO periodfused + END IF '"." except = 0 udtperiod: aa$ = aa$ + a2$ + sp periodfused: a3$ = a2$ - Next - a$ = Left$(aa$, Len(aa$) - 1) + NEXT + a$ = LEFT$(aa$, LEN(aa$) - 1) ca$ = a$ a$ = eleucase$(ca$) n = numelements(a$) - End If + END IF arrayprocessinghappened = 0 @@ -3560,148 +3560,148 @@ Do 'non-executable section - If n = 1 Then - If firstelement$ = "'" Then layoutdone = 1: GoTo finishednonexec 'nop - End If + IF n = 1 THEN + IF firstelement$ = "'" THEN layoutdone = 1: GOTO finishednonexec 'nop + END IF - If n <= 2 Then - If firstelement$ = "DATA" Then + IF n <= 2 THEN + IF firstelement$ = "DATA" THEN l$ = SCase$("Data") - If n = 2 Then + IF n = 2 THEN - e$ = Space$((Len(secondelement$) - 1) \ 2) - For x = 1 To Len(e$) - v1 = Asc(secondelement$, x * 2) - v2 = Asc(secondelement$, x * 2 + 1) - If v1 < 65 Then v1 = v1 - 48 Else v1 = v1 - 55 - If v2 < 65 Then v2 = v2 - 48 Else v2 = v2 - 55 - Asc(e$, x) = v1 + v2 * 16 - Next + e$ = SPACE$((LEN(secondelement$) - 1) \ 2) + FOR x = 1 TO LEN(e$) + v1 = ASC(secondelement$, x * 2) + v2 = ASC(secondelement$, x * 2 + 1) + IF v1 < 65 THEN v1 = v1 - 48 ELSE v1 = v1 - 55 + IF v2 < 65 THEN v2 = v2 - 48 ELSE v2 = v2 - 55 + ASC(e$, x) = v1 + v2 * 16 + NEXT l$ = l$ + sp + e$ - End If 'n=2 + END IF 'n=2 - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ - GoTo finishednonexec - End If - End If + GOTO finishednonexec + END IF + END IF 'declare library - If declaringlibrary Then + IF declaringlibrary THEN - If firstelement$ = "END" Then - If n <> 2 Or secondelement$ <> "DECLARE" Then a$ = "Expected END DECLARE": GoTo errmes + IF firstelement$ = "END" THEN + IF n <> 2 OR secondelement$ <> "DECLARE" THEN a$ = "Expected END DECLARE": GOTO errmes declaringlibrary = 0 l$ = SCase$("End" + sp + "Declare") - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishednonexec - End If 'end declare + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishednonexec + END IF 'end declare declaringlibrary = 2 - If firstelement$ = "SUB" Or firstelement$ = "FUNCTION" Then - GoTo declaresubfunc2 - End If + IF firstelement$ = "SUB" OR firstelement$ = "FUNCTION" THEN + GOTO declaresubfunc2 + END IF - a$ = "Expected SUB/FUNCTION definition or END DECLARE": GoTo errmes - End If 'declaringlibrary + a$ = "Expected SUB/FUNCTION definition or END DECLARE": GOTO errmes + END IF 'declaringlibrary 'check TYPE declarations (created on prepass) - If definingtype Then + IF definingtype THEN - If firstelement$ = "END" Then - If n <> 2 Or secondelement$ <> "TYPE" Then a$ = "Expected END TYPE": GoTo errmes + IF firstelement$ = "END" THEN + IF n <> 2 OR secondelement$ <> "TYPE" THEN a$ = "Expected END TYPE": GOTO errmes definingtype = 0 l$ = SCase$("End" + sp + "Type") - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishednonexec - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishednonexec + END IF - If n < 3 Then a$ = "Expected element-name AS type or AS type element-list": GoTo errmes + IF n < 3 THEN a$ = "Expected element-name AS type or AS type element-list": GOTO errmes definingtype = 2 - If firstelement$ = "AS" Then + IF firstelement$ = "AS" THEN l$ = SCase$("As") t$ = "" wordsInTypeName = 0 - Do + DO nextElement$ = getelement$(a$, 2 + wordsInTypeName) - If nextElement$ = "," Then + IF nextElement$ = "," THEN 'element-list wordsInTypeName = wordsInTypeName - 2 - Exit Do - End If + EXIT DO + END IF wordsInTypeName = wordsInTypeName + 1 - If wordsInTypeName = n - 2 Then + IF wordsInTypeName = n - 2 THEN 'single element in line wordsInTypeName = wordsInTypeName - 1 - Exit Do - End If - Loop + EXIT DO + END IF + LOOP t$ = getelements$(a$, 2, 2 + wordsInTypeName) typ = typname2typ(t$) - If Error_Happened Then GoTo errmes - If typ = 0 Then a$ = "Undefined type": GoTo errmes - If typ And ISUDT Then - If UCase$(RTrim$(t$)) = "MEM" And RTrim$(udtxcname(typ And 511)) = "_MEM" And qb64prefix_set = 1 Then - t$ = Mid$(RTrim$(udtxcname(typ And 511)), 2) - Else - t$ = RTrim$(udtxcname(typ And 511)) - End If + IF Error_Happened THEN GOTO errmes + IF typ = 0 THEN a$ = "Undefined type": GOTO errmes + IF typ AND ISUDT THEN + IF UCASE$(RTRIM$(t$)) = "MEM" AND RTRIM$(udtxcname(typ AND 511)) = "_MEM" AND qb64prefix_set = 1 THEN + t$ = MID$(RTRIM$(udtxcname(typ AND 511)), 2) + ELSE + t$ = RTRIM$(udtxcname(typ AND 511)) + END IF l$ = l$ + sp + t$ - Else + ELSE l$ = l$ + sp + SCase2$(t$) - End If + END IF 'Now add each variable: - For i = 3 + wordsInTypeName To n + FOR i = 3 + wordsInTypeName TO n thisElement$ = getelement$(ca$, i) - If thisElement$ = "," Then + IF thisElement$ = "," THEN l$ = l$ + thisElement$ - Else + ELSE l$ = l$ + sp + thisElement$ - End If - Next - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - Else + END IF + NEXT + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + ELSE l$ = getelement(ca$, 1) + sp + SCase$("As") t$ = getelements$(a$, 3, n) typ = typname2typ(t$) - If Error_Happened Then GoTo errmes - If typ = 0 Then a$ = "Undefined type": GoTo errmes - If typ And ISUDT Then - If UCase$(RTrim$(t$)) = "MEM" And RTrim$(udtxcname(typ And 511)) = "_MEM" And qb64prefix_set = 1 Then - t$ = Mid$(RTrim$(udtxcname(typ And 511)), 2) - Else - t$ = RTrim$(udtxcname(typ And 511)) - End If + IF Error_Happened THEN GOTO errmes + IF typ = 0 THEN a$ = "Undefined type": GOTO errmes + IF typ AND ISUDT THEN + IF UCASE$(RTRIM$(t$)) = "MEM" AND RTRIM$(udtxcname(typ AND 511)) = "_MEM" AND qb64prefix_set = 1 THEN + t$ = MID$(RTRIM$(udtxcname(typ AND 511)), 2) + ELSE + t$ = RTRIM$(udtxcname(typ AND 511)) + END IF l$ = l$ + sp + t$ - Else + ELSE l$ = l$ + sp + SCase2$(t$) - End If - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - End If - GoTo finishednonexec + END IF + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + END IF + GOTO finishednonexec - End If 'defining type + END IF 'defining type - If firstelement$ = "TYPE" Then - If n <> 2 Then a$ = "Expected TYPE type-name": GoTo errmes + IF firstelement$ = "TYPE" THEN + IF n <> 2 THEN a$ = "Expected TYPE type-name": GOTO errmes l$ = SCase$("Type") + sp + getelement(ca$, 2) - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ definingtype = 1 definingtypeerror = linenumber - GoTo finishednonexec - End If + GOTO finishednonexec + END IF 'skip DECLARE SUB/FUNCTION - If n >= 1 Then - If firstelement$ = "DECLARE" Then + IF n >= 1 THEN + IF firstelement$ = "DECLARE" THEN - If secondelement$ = "LIBRARY" Or secondelement$ = "DYNAMIC" Or secondelement$ = "CUSTOMTYPE" Or secondelement$ = "STATIC" Then + IF secondelement$ = "LIBRARY" OR secondelement$ = "DYNAMIC" OR secondelement$ = "CUSTOMTYPE" OR secondelement$ = "STATIC" THEN declaringlibrary = 1 dynamiclibrary = 0 @@ -3712,33 +3712,33 @@ Do x = 3 l$ = SCase$("Declare" + sp + "Library") - If secondelement$ = "DYNAMIC" Then - e$ = getelement$(a$, 3): If e$ <> "LIBRARY" Then a$ = "Expected DYNAMIC LIBRARY " + Chr$(34) + "..." + Chr$(34): GoTo errmes + IF secondelement$ = "DYNAMIC" THEN + e$ = getelement$(a$, 3): IF e$ <> "LIBRARY" THEN a$ = "Expected DYNAMIC LIBRARY " + CHR$(34) + "..." + CHR$(34): GOTO errmes dynamiclibrary = 1 x = 4 l$ = SCase$("Declare" + sp + "Dynamic" + sp + "Library") - If n = 3 Then a$ = "Expected DECLARE DYNAMIC LIBRARY " + Chr$(34) + "..." + Chr$(34): GoTo errmes + IF n = 3 THEN a$ = "Expected DECLARE DYNAMIC LIBRARY " + CHR$(34) + "..." + CHR$(34): GOTO errmes indirectlibrary = 1 - End If + END IF - If secondelement$ = "CUSTOMTYPE" Then - e$ = getelement$(a$, 3): If e$ <> "LIBRARY" Then a$ = "Expected CUSTOMTYPE LIBRARY": GoTo errmes + IF secondelement$ = "CUSTOMTYPE" THEN + e$ = getelement$(a$, 3): IF e$ <> "LIBRARY" THEN a$ = "Expected CUSTOMTYPE LIBRARY": GOTO errmes customtypelibrary = 1 x = 4 l$ = SCase$("Declare" + sp + "CustomType" + sp + "Library") indirectlibrary = 1 - End If + END IF - If secondelement$ = "STATIC" Then - e$ = getelement$(a$, 3): If e$ <> "LIBRARY" Then a$ = "Expected STATIC LIBRARY": GoTo errmes + IF secondelement$ = "STATIC" THEN + e$ = getelement$(a$, 3): IF e$ <> "LIBRARY" THEN a$ = "Expected STATIC LIBRARY": GOTO errmes x = 4 l$ = SCase$("Declare" + sp + "Static" + sp + "Library") staticlinkedlibrary = 1 - End If + END IF sfdeclare = 0: sfheader = 0 - If n >= x Then + IF n >= x THEN sfdeclare = 1 @@ -3751,14 +3751,14 @@ Do 'assume library name in double quotes follows 'assume library is in main qb64 folder x$ = getelement$(ca$, x) - If Asc(x$) <> 34 Then a$ = "Expected LIBRARY " + Chr$(34) + "..." + Chr$(34): GoTo errmes - x$ = Right$(x$, Len(x$) - 1) - z = InStr(x$, Chr$(34)) - If z = 0 Then a$ = "Expected LIBRARY " + Chr$(34) + "..." + Chr$(34): GoTo errmes - x$ = Left$(x$, z - 1) + IF ASC(x$) <> 34 THEN a$ = "Expected LIBRARY " + CHR$(34) + "..." + CHR$(34): GOTO errmes + x$ = RIGHT$(x$, LEN(x$) - 1) + z = INSTR(x$, CHR$(34)) + IF z = 0 THEN a$ = "Expected LIBRARY " + CHR$(34) + "..." + CHR$(34): GOTO errmes + x$ = LEFT$(x$, z - 1) - If dynamiclibrary <> 0 And Len(x$) = 0 Then a$ = "Expected DECLARE DYNAMIC LIBRARY " + Chr$(34) + "..." + Chr$(34): GoTo errmes - If customtypelibrary <> 0 And Len(x$) = 0 Then a$ = "Expected DECLARE CUSTOMTYPE LIBRARY " + Chr$(34) + "..." + Chr$(34): GoTo errmes + IF dynamiclibrary <> 0 AND LEN(x$) = 0 THEN a$ = "Expected DECLARE DYNAMIC LIBRARY " + CHR$(34) + "..." + CHR$(34): GOTO errmes + IF customtypelibrary <> 0 AND LEN(x$) = 0 THEN a$ = "Expected DECLARE CUSTOMTYPE LIBRARY " + CHR$(34) + "..." + CHR$(34): GOTO errmes @@ -3773,10 +3773,10 @@ Do 'convert '\\' to '\' - While InStr(x$, "\\") - z = InStr(x$, "\\") - x$ = Left$(x$, z - 1) + Right$(x$, Len(x$) - z) - Wend + WHILE INSTR(x$, "\\") + z = INSTR(x$, "\\") + x$ = LEFT$(x$, z - 1) + RIGHT$(x$, LEN(x$) - z) + WEND autoformat_x$ = x$ 'used for autolayout purposes @@ -3784,986 +3784,986 @@ Do 'Eg. libname:1.0 becomes libname <-> 1.0 which later becomes libname.so.1.0 v$ = "" striplibver: - For z = Len(x$) To 1 Step -1 - a = Asc(x$, z) - If a = ASC_BACKSLASH Or a = ASC_FORWARDSLASH Then Exit For - If a = ASC_FULLSTOP Or a = ASC_COLON Then - If isuinteger(Right$(x$, Len(x$) - z)) Then - If Len(v$) Then v$ = Right$(x$, Len(x$) - z) + "." + v$ Else v$ = Right$(x$, Len(x$) - z) - x$ = Left$(x$, z - 1) - If a = ASC_COLON Then Exit For - GoTo striplibver - Else - Exit For - End If - End If - Next + FOR z = LEN(x$) TO 1 STEP -1 + a = ASC(x$, z) + IF a = ASC_BACKSLASH OR a = ASC_FORWARDSLASH THEN EXIT FOR + IF a = ASC_FULLSTOP OR a = ASC_COLON THEN + IF isuinteger(RIGHT$(x$, LEN(x$) - z)) THEN + IF LEN(v$) THEN v$ = RIGHT$(x$, LEN(x$) - z) + "." + v$ ELSE v$ = RIGHT$(x$, LEN(x$) - z) + x$ = LEFT$(x$, z - 1) + IF a = ASC_COLON THEN EXIT FOR + GOTO striplibver + ELSE + EXIT FOR + END IF + END IF + NEXT libver$ = v$ - If os$ = "WIN" Then + IF os$ = "WIN" THEN 'convert forward-slashes to back-slashes - Do While InStr(x$, "/") - z = InStr(x$, "/") - x$ = Left$(x$, z - 1) + "\" + Right$(x$, Len(x$) - z) - Loop - End If + DO WHILE INSTR(x$, "/") + z = INSTR(x$, "/") + x$ = LEFT$(x$, z - 1) + "\" + RIGHT$(x$, LEN(x$) - z) + LOOP + END IF - If os$ = "LNX" Then + IF os$ = "LNX" THEN 'convert any back-slashes to forward-slashes - Do While InStr(x$, "\") - z = InStr(x$, "\") - x$ = Left$(x$, z - 1) + "/" + Right$(x$, Len(x$) - z) - Loop - End If + DO WHILE INSTR(x$, "\") + z = INSTR(x$, "\") + x$ = LEFT$(x$, z - 1) + "/" + RIGHT$(x$, LEN(x$) - z) + LOOP + END IF 'Separate path from name libpath$ = "" - For z = Len(x$) To 1 Step -1 - a = Asc(x$, z) - If a = 47 Or a = 92 Then '\ or / - libpath$ = Left$(x$, z) - x$ = Right$(x$, Len(x$) - z) - Exit For - End If - Next + FOR z = LEN(x$) TO 1 STEP -1 + a = ASC(x$, z) + IF a = 47 OR a = 92 THEN '\ or / + libpath$ = LEFT$(x$, z) + x$ = RIGHT$(x$, LEN(x$) - z) + EXIT FOR + END IF + NEXT 'Accept ./ and .\ as a reference to the source file 'folder, replacing it with the actual full path, if available - If libpath$ = "./" Or libpath$ = ".\" Then + IF libpath$ = "./" OR libpath$ = ".\" THEN libpath$ = "" - If NoIDEMode Then + IF NoIDEMode THEN libpath$ = path.source$ - If Len(libpath$) > 0 And Right$(libpath$, 1) <> pathsep$ Then libpath$ = libpath$ + pathsep$ - Else - If Len(ideprogname) Then libpath$ = idepath$ + pathsep$ - End If - End If + IF LEN(libpath$) > 0 AND RIGHT$(libpath$, 1) <> pathsep$ THEN libpath$ = libpath$ + pathsep$ + ELSE + IF LEN(ideprogname) THEN libpath$ = idepath$ + pathsep$ + END IF + END IF 'Create a path which can be used for inline code (uses \\ instead of \) libpath_inline$ = "" - For z = 1 To Len(libpath$) - a = Asc(libpath$, z) - libpath_inline$ = libpath_inline$ + Chr$(a) - If a = 92 Then libpath_inline$ = libpath_inline$ + "\" - Next + FOR z = 1 TO LEN(libpath$) + a = ASC(libpath$, z) + libpath_inline$ = libpath_inline$ + CHR$(a) + IF a = 92 THEN libpath_inline$ = libpath_inline$ + "\" + NEXT - If Len(x$) Then - If dynamiclibrary = 0 Then + IF LEN(x$) THEN + IF dynamiclibrary = 0 THEN 'Static library - If os$ = "WIN" Then + IF os$ = "WIN" THEN 'check for .lib - If Len(libname$) = 0 Then - If _FileExists(libpath$ + x$ + ".lib") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(libpath$ + x$ + ".lib") THEN libname$ = libpath$ + x$ + ".lib" inlinelibname$ = libpath_inline$ + x$ + ".lib" - End If - End If + END IF + END IF 'check for .a - If Len(libname$) = 0 Then - If _FileExists(libpath$ + x$ + ".a") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(libpath$ + x$ + ".a") THEN libname$ = libpath$ + x$ + ".a" inlinelibname$ = libpath_inline$ + x$ + ".a" - End If - End If + END IF + END IF 'check for .o - If Len(libname$) = 0 Then - If _FileExists(libpath$ + x$ + ".o") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(libpath$ + x$ + ".o") THEN libname$ = libpath$ + x$ + ".o" inlinelibname$ = libpath_inline$ + x$ + ".o" - End If - End If + END IF + END IF 'check for .lib - If Len(libname$) = 0 Then - If _FileExists(x$ + ".lib") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(x$ + ".lib") THEN libname$ = x$ + ".lib" inlinelibname$ = x$ + ".lib" - End If - End If + END IF + END IF 'check for .a - If Len(libname$) = 0 Then - If _FileExists(x$ + ".a") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(x$ + ".a") THEN libname$ = x$ + ".a" inlinelibname$ = x$ + ".a" - End If - End If + END IF + END IF 'check for .o - If Len(libname$) = 0 Then - If _FileExists(x$ + ".o") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(x$ + ".o") THEN libname$ = x$ + ".o" inlinelibname$ = x$ + ".o" - End If - End If - End If 'Windows + END IF + END IF + END IF 'Windows - If os$ = "LNX" Then - If staticlinkedlibrary = 0 Then + IF os$ = "LNX" THEN + IF staticlinkedlibrary = 0 THEN - If MacOSX Then 'dylib support + IF MacOSX THEN 'dylib support 'check for .dylib (direct) - If Len(libname$) = 0 Then - If _FileExists(libpath$ + "lib" + x$ + "." + libver$ + ".dylib") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(libpath$ + "lib" + x$ + "." + libver$ + ".dylib") THEN libname$ = libpath$ + "lib" + x$ + "." + libver$ + ".dylib" inlinelibname$ = libpath_inline$ + "lib" + x$ + "." + libver$ + ".dylib" - If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath " + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath ./ " - End If - End If - If Len(libname$) = 0 Then - If _FileExists(libpath$ + "lib" + x$ + ".dylib") Then + IF LEN(libpath$) THEN mylibopt$ = mylibopt$ + " -Wl,-rpath " + libpath$ + " " ELSE mylibopt$ = mylibopt$ + " -Wl,-rpath ./ " + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(libpath$ + "lib" + x$ + ".dylib") THEN libname$ = libpath$ + "lib" + x$ + ".dylib" inlinelibname$ = libpath_inline$ + "lib" + x$ + ".dylib" - If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath " + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath ./ " - End If - End If - End If + IF LEN(libpath$) THEN mylibopt$ = mylibopt$ + " -Wl,-rpath " + libpath$ + " " ELSE mylibopt$ = mylibopt$ + " -Wl,-rpath ./ " + END IF + END IF + END IF 'check for .so (direct) - If Len(libname$) = 0 Then - If _FileExists(libpath$ + "lib" + x$ + ".so." + libver$) Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(libpath$ + "lib" + x$ + ".so." + libver$) THEN libname$ = libpath$ + "lib" + x$ + ".so." + libver$ inlinelibname$ = libpath_inline$ + "lib" + x$ + ".so." + libver$ - If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath " + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath ./ " - End If - End If - If Len(libname$) = 0 Then - If _FileExists(libpath$ + "lib" + x$ + ".so") Then + IF LEN(libpath$) THEN mylibopt$ = mylibopt$ + " -Wl,-rpath " + libpath$ + " " ELSE mylibopt$ = mylibopt$ + " -Wl,-rpath ./ " + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(libpath$ + "lib" + x$ + ".so") THEN libname$ = libpath$ + "lib" + x$ + ".so" inlinelibname$ = libpath_inline$ + "lib" + x$ + ".so" - If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath " + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath ./ " - End If - End If - End If + IF LEN(libpath$) THEN mylibopt$ = mylibopt$ + " -Wl,-rpath " + libpath$ + " " ELSE mylibopt$ = mylibopt$ + " -Wl,-rpath ./ " + END IF + END IF + END IF 'check for .a (direct) - If Len(libname$) = 0 Then - If _FileExists(libpath$ + "lib" + x$ + ".a") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(libpath$ + "lib" + x$ + ".a") THEN libname$ = libpath$ + "lib" + x$ + ".a" inlinelibname$ = libpath_inline$ + "lib" + x$ + ".a" - End If - End If + END IF + END IF 'check for .o (direct) - If Len(libname$) = 0 Then - If _FileExists(libpath$ + "lib" + x$ + ".o") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(libpath$ + "lib" + x$ + ".o") THEN libname$ = libpath$ + "lib" + x$ + ".o" inlinelibname$ = libpath_inline$ + "lib" + x$ + ".o" - End If - End If - If staticlinkedlibrary = 0 Then + END IF + END IF + IF staticlinkedlibrary = 0 THEN 'check for .so (usr/lib64) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib64/" + libpath$ + "lib" + x$ + ".so." + libver$) Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib64/" + libpath$ + "lib" + x$ + ".so." + libver$) THEN libname$ = "/usr/lib64/" + libpath$ + "lib" + x$ + ".so." + libver$ inlinelibname$ = "/usr/lib64/" + libpath_inline$ + "lib" + x$ + ".so." + libver$ - If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/" + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/ " - End If - End If - If Len(libname$) = 0 Then - If _FileExists("/usr/lib64/" + libpath$ + "lib" + x$ + ".so") Then + IF LEN(libpath$) THEN mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/" + libpath$ + " " ELSE mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/ " + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib64/" + libpath$ + "lib" + x$ + ".so") THEN libname$ = "/usr/lib64/" + libpath$ + "lib" + x$ + ".so" inlinelibname$ = "/usr/lib64/" + libpath_inline$ + "lib" + x$ + ".so" - If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/" + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/ " - End If - End If - End If + IF LEN(libpath$) THEN mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/" + libpath$ + " " ELSE mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/ " + END IF + END IF + END IF 'check for .a (usr/lib64) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib64/" + libpath$ + "lib" + x$ + ".a") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib64/" + libpath$ + "lib" + x$ + ".a") THEN libname$ = "/usr/lib64/" + libpath$ + "lib" + x$ + ".a" inlinelibname$ = "/usr/lib64/" + libpath_inline$ + "lib" + x$ + ".a" - End If - End If - If staticlinkedlibrary = 0 Then + END IF + END IF + IF staticlinkedlibrary = 0 THEN - If MacOSX Then 'dylib support + IF MacOSX THEN 'dylib support 'check for .dylib (usr/lib) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + "." + libver$ + ".dylib") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + libpath$ + "lib" + x$ + "." + libver$ + ".dylib") THEN libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + "." + libver$ + ".dylib" inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + "." + libver$ + ".dylib" - If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/" + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ " - End If - End If - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + ".dylib") Then + IF LEN(libpath$) THEN mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/" + libpath$ + " " ELSE mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ " + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + libpath$ + "lib" + x$ + ".dylib") THEN libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + ".dylib" inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + ".dylib" - If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/" + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ " - End If - End If - End If + IF LEN(libpath$) THEN mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/" + libpath$ + " " ELSE mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ " + END IF + END IF + END IF 'check for .so (usr/lib) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + ".so." + libver$) Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + libpath$ + "lib" + x$ + ".so." + libver$) THEN libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + ".so." + libver$ inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + ".so." + libver$ - If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/" + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ " - End If - End If - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + ".so") Then + IF LEN(libpath$) THEN mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/" + libpath$ + " " ELSE mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ " + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + libpath$ + "lib" + x$ + ".so") THEN libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + ".so" inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + ".so" - If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/" + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ " - End If - End If - End If + IF LEN(libpath$) THEN mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/" + libpath$ + " " ELSE mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ " + END IF + END IF + END IF 'check for .a (usr/lib) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + ".a") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + libpath$ + "lib" + x$ + ".a") THEN libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + ".a" inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + ".a" - End If - End If + END IF + END IF '--------------------------(without path)------------------------------ - If staticlinkedlibrary = 0 Then + IF staticlinkedlibrary = 0 THEN - If MacOSX Then 'dylib support + IF MacOSX THEN 'dylib support 'check for .dylib (direct) - If Len(libname$) = 0 Then - If _FileExists("lib" + x$ + "." + libver$ + ".dylib") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("lib" + x$ + "." + libver$ + ".dylib") THEN libname$ = "lib" + x$ + "." + libver$ + ".dylib" inlinelibname$ = "lib" + x$ + "." + libver$ + ".dylib" mylibopt$ = mylibopt$ + " -Wl,-rpath ./ " - End If - End If - If Len(libname$) = 0 Then - If _FileExists("lib" + x$ + ".dylib") Then + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("lib" + x$ + ".dylib") THEN libname$ = "lib" + x$ + ".dylib" inlinelibname$ = "lib" + x$ + ".dylib" mylibopt$ = mylibopt$ + " -Wl,-rpath ./ " - End If - End If - End If + END IF + END IF + END IF 'check for .so (direct) - If Len(libname$) = 0 Then - If _FileExists("lib" + x$ + ".so." + libver$) Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("lib" + x$ + ".so." + libver$) THEN libname$ = "lib" + x$ + ".so." + libver$ inlinelibname$ = "lib" + x$ + ".so." + libver$ mylibopt$ = mylibopt$ + " -Wl,-rpath ./ " - End If - End If - If Len(libname$) = 0 Then - If _FileExists("lib" + x$ + ".so") Then + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("lib" + x$ + ".so") THEN libname$ = "lib" + x$ + ".so" inlinelibname$ = "lib" + x$ + ".so" mylibopt$ = mylibopt$ + " -Wl,-rpath ./ " - End If - End If - End If + END IF + END IF + END IF 'check for .a (direct) - If Len(libname$) = 0 Then - If _FileExists("lib" + x$ + ".a") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("lib" + x$ + ".a") THEN libname$ = "lib" + x$ + ".a" inlinelibname$ = "lib" + x$ + ".a" - End If - End If + END IF + END IF 'check for .o (direct) - If Len(libname$) = 0 Then - If _FileExists("lib" + x$ + ".o") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("lib" + x$ + ".o") THEN libname$ = "lib" + x$ + ".o" inlinelibname$ = "lib" + x$ + ".o" - End If - End If - If staticlinkedlibrary = 0 Then + END IF + END IF + IF staticlinkedlibrary = 0 THEN 'check for .so (usr/lib64) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib64/" + "lib" + x$ + ".so." + libver$) Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib64/" + "lib" + x$ + ".so." + libver$) THEN libname$ = "/usr/lib64/" + "lib" + x$ + ".so." + libver$ inlinelibname$ = "/usr/lib64/" + "lib" + x$ + ".so." + libver$ mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/ " - End If - End If - If Len(libname$) = 0 Then - If _FileExists("/usr/lib64/" + "lib" + x$ + ".so") Then + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib64/" + "lib" + x$ + ".so") THEN libname$ = "/usr/lib64/" + "lib" + x$ + ".so" inlinelibname$ = "/usr/lib64/" + "lib" + x$ + ".so" mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/ " - End If - End If - End If + END IF + END IF + END IF 'check for .a (usr/lib64) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib64/" + "lib" + x$ + ".a") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib64/" + "lib" + x$ + ".a") THEN libname$ = "/usr/lib64/" + "lib" + x$ + ".a" inlinelibname$ = "/usr/lib64/" + "lib" + x$ + ".a" - End If - End If - If staticlinkedlibrary = 0 Then + END IF + END IF + IF staticlinkedlibrary = 0 THEN - If MacOSX Then 'dylib support + IF MacOSX THEN 'dylib support 'check for .dylib (usr/lib) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + "lib" + x$ + "." + libver$ + ".dylib") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + "lib" + x$ + "." + libver$ + ".dylib") THEN libname$ = "/usr/lib/" + "lib" + x$ + "." + libver$ + ".dylib" inlinelibname$ = "/usr/lib/" + "lib" + x$ + "." + libver$ + ".dylib" - End If - End If - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + "lib" + x$ + ".dylib") Then + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + "lib" + x$ + ".dylib") THEN libname$ = "/usr/lib/" + "lib" + x$ + ".dylib" inlinelibname$ = "/usr/lib/" + "lib" + x$ + ".dylib" mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ " - End If - End If - End If + END IF + END IF + END IF 'check for .so (usr/lib) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + "lib" + x$ + ".so." + libver$) Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + "lib" + x$ + ".so." + libver$) THEN libname$ = "/usr/lib/" + "lib" + x$ + ".so." + libver$ inlinelibname$ = "/usr/lib/" + "lib" + x$ + ".so." + libver$ - End If - End If - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + "lib" + x$ + ".so") Then + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + "lib" + x$ + ".so") THEN libname$ = "/usr/lib/" + "lib" + x$ + ".so" inlinelibname$ = "/usr/lib/" + "lib" + x$ + ".so" mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ " - End If - End If - End If + END IF + END IF + END IF 'check for .a (usr/lib) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + "lib" + x$ + ".a") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + "lib" + x$ + ".a") THEN libname$ = "/usr/lib/" + "lib" + x$ + ".a" inlinelibname$ = "/usr/lib/" + "lib" + x$ + ".a" mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ " - End If - End If - End If 'Linux + END IF + END IF + END IF 'Linux 'check for header - If Len(headername$) = 0 Then - If os$ = "WIN" Then - If _FileExists(libpath$ + x$ + ".h") Then + IF LEN(headername$) = 0 THEN + IF os$ = "WIN" THEN + IF _FILEEXISTS(libpath$ + x$ + ".h") THEN headername$ = libpath_inline$ + x$ + ".h" - If customtypelibrary = 0 Then sfdeclare = 0 + IF customtypelibrary = 0 THEN sfdeclare = 0 sfheader = 1 - GoTo GotHeader - End If - If _FileExists(libpath$ + x$ + ".hpp") Then + GOTO GotHeader + END IF + IF _FILEEXISTS(libpath$ + x$ + ".hpp") THEN headername$ = libpath_inline$ + x$ + ".hpp" - If customtypelibrary = 0 Then sfdeclare = 0 + IF customtypelibrary = 0 THEN sfdeclare = 0 sfheader = 1 - GoTo GotHeader - End If + GOTO GotHeader + END IF '--------------------------(without path)------------------------------ - If _FileExists(x$ + ".h") Then + IF _FILEEXISTS(x$ + ".h") THEN headername$ = x$ + ".h" - If customtypelibrary = 0 Then sfdeclare = 0 + IF customtypelibrary = 0 THEN sfdeclare = 0 sfheader = 1 - GoTo GotHeader - End If - If _FileExists(x$ + ".hpp") Then + GOTO GotHeader + END IF + IF _FILEEXISTS(x$ + ".hpp") THEN headername$ = x$ + ".hpp" - If customtypelibrary = 0 Then sfdeclare = 0 + IF customtypelibrary = 0 THEN sfdeclare = 0 sfheader = 1 - GoTo GotHeader - End If - End If 'Windows + GOTO GotHeader + END IF + END IF 'Windows - If os$ = "LNX" Then - If _FileExists(libpath$ + x$ + ".h") Then + IF os$ = "LNX" THEN + IF _FILEEXISTS(libpath$ + x$ + ".h") THEN headername$ = libpath_inline$ + x$ + ".h" - If customtypelibrary = 0 Then sfdeclare = 0 + IF customtypelibrary = 0 THEN sfdeclare = 0 sfheader = 1 - GoTo GotHeader - End If - If _FileExists(libpath$ + x$ + ".hpp") Then + GOTO GotHeader + END IF + IF _FILEEXISTS(libpath$ + x$ + ".hpp") THEN headername$ = libpath_inline$ + x$ + ".hpp" - If customtypelibrary = 0 Then sfdeclare = 0 + IF customtypelibrary = 0 THEN sfdeclare = 0 sfheader = 1 - GoTo GotHeader - End If - If _FileExists("/usr/include/" + libpath$ + x$ + ".h") Then + GOTO GotHeader + END IF + IF _FILEEXISTS("/usr/include/" + libpath$ + x$ + ".h") THEN headername$ = "/usr/include/" + libpath_inline$ + x$ + ".h" - If customtypelibrary = 0 Then sfdeclare = 0 + IF customtypelibrary = 0 THEN sfdeclare = 0 sfheader = 1 - GoTo GotHeader - End If - If _FileExists("/usr/include/" + libpath$ + x$ + ".hpp") Then + GOTO GotHeader + END IF + IF _FILEEXISTS("/usr/include/" + libpath$ + x$ + ".hpp") THEN headername$ = "/usr/include/" + libpath_inline$ + x$ + ".hpp" - If customtypelibrary = 0 Then sfdeclare = 0 + IF customtypelibrary = 0 THEN sfdeclare = 0 sfheader = 1 - GoTo GotHeader - End If + GOTO GotHeader + END IF '--------------------------(without path)------------------------------ - If _FileExists(x$ + ".h") Then + IF _FILEEXISTS(x$ + ".h") THEN headername$ = x$ + ".h" - If customtypelibrary = 0 Then sfdeclare = 0 + IF customtypelibrary = 0 THEN sfdeclare = 0 sfheader = 1 - GoTo GotHeader - End If - If _FileExists(x$ + ".hpp") Then + GOTO GotHeader + END IF + IF _FILEEXISTS(x$ + ".hpp") THEN headername$ = x$ + ".hpp" - If customtypelibrary = 0 Then sfdeclare = 0 + IF customtypelibrary = 0 THEN sfdeclare = 0 sfheader = 1 - GoTo GotHeader - End If - If _FileExists("/usr/include/" + x$ + ".h") Then + GOTO GotHeader + END IF + IF _FILEEXISTS("/usr/include/" + x$ + ".h") THEN headername$ = "/usr/include/" + x$ + ".h" - If customtypelibrary = 0 Then sfdeclare = 0 + IF customtypelibrary = 0 THEN sfdeclare = 0 sfheader = 1 - GoTo GotHeader - End If - If _FileExists("/usr/include/" + x$ + ".hpp") Then + GOTO GotHeader + END IF + IF _FILEEXISTS("/usr/include/" + x$ + ".hpp") THEN headername$ = "/usr/include/" + x$ + ".hpp" - If customtypelibrary = 0 Then sfdeclare = 0 + IF customtypelibrary = 0 THEN sfdeclare = 0 sfheader = 1 - GoTo GotHeader - End If - End If 'Linux + GOTO GotHeader + END IF + END IF 'Linux GotHeader: - End If + END IF - Else + ELSE 'dynamic library - If os$ = "WIN" Then + IF os$ = "WIN" THEN 'check for .dll (direct) - If Len(libname$) = 0 Then - If _FileExists(libpath$ + x$ + ".dll") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(libpath$ + x$ + ".dll") THEN libname$ = libpath$ + x$ + ".dll" inlinelibname$ = libpath_inline$ + x$ + ".dll" - End If - End If + END IF + END IF 'check for .dll (system32) - If Len(libname$) = 0 Then - If _FileExists(Environ$("SYSTEMROOT") + "\System32\" + libpath$ + x$ + ".dll") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(ENVIRON$("SYSTEMROOT") + "\System32\" + libpath$ + x$ + ".dll") THEN libname$ = libpath$ + x$ + ".dll" inlinelibname$ = libpath_inline$ + x$ + ".dll" - End If - End If + END IF + END IF '--------------------------(without path)------------------------------ 'check for .dll (direct) - If Len(libname$) = 0 Then - If _FileExists(x$ + ".dll") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(x$ + ".dll") THEN libname$ = x$ + ".dll" inlinelibname$ = x$ + ".dll" - End If - End If + END IF + END IF 'check for .dll (system32) - If Len(libname$) = 0 Then - If _FileExists(Environ$("SYSTEMROOT") + "\System32\" + x$ + ".dll") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(ENVIRON$("SYSTEMROOT") + "\System32\" + x$ + ".dll") THEN libname$ = x$ + ".dll" inlinelibname$ = x$ + ".dll" - End If - End If - End If 'Windows + END IF + END IF + END IF 'Windows - If os$ = "LNX" Then + IF os$ = "LNX" THEN 'Note: STATIC libraries (.a/.o) cannot be loaded as dynamic objects - If MacOSX Then 'dylib support + IF MacOSX THEN 'dylib support 'check for .dylib (direct) - If Len(libname$) = 0 Then - If _FileExists(libpath$ + "lib" + x$ + "." + libver$ + ".dylib") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(libpath$ + "lib" + x$ + "." + libver$ + ".dylib") THEN libname$ = libpath$ + "lib" + x$ + "." + libver$ + ".dylib" inlinelibname$ = libpath_inline$ + "lib" + x$ + "." + libver$ + ".dylib" - If Left$(libpath$, 1) <> "/" Then libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$ - End If - End If - If Len(libname$) = 0 Then - If _FileExists(libpath$ + "lib" + x$ + ".dylib") Then + IF LEFT$(libpath$, 1) <> "/" THEN libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$ + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(libpath$ + "lib" + x$ + ".dylib") THEN libname$ = libpath$ + "lib" + x$ + ".dylib" inlinelibname$ = libpath_inline$ + "lib" + x$ + ".dylib" - If Left$(libpath$, 1) <> "/" Then libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$ - End If - End If - End If + IF LEFT$(libpath$, 1) <> "/" THEN libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$ + END IF + END IF + END IF 'check for .so (direct) - If Len(libname$) = 0 Then - If _FileExists(libpath$ + "lib" + x$ + ".so." + libver$) Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(libpath$ + "lib" + x$ + ".so." + libver$) THEN libname$ = libpath$ + "lib" + x$ + ".so." + libver$ inlinelibname$ = libpath_inline$ + "lib" + x$ + ".so." + libver$ - If Left$(libpath$, 1) <> "/" Then libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$ - End If - End If - If Len(libname$) = 0 Then - If _FileExists(libpath$ + "lib" + x$ + ".so") Then + IF LEFT$(libpath$, 1) <> "/" THEN libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$ + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS(libpath$ + "lib" + x$ + ".so") THEN libname$ = libpath$ + "lib" + x$ + ".so" inlinelibname$ = libpath_inline$ + "lib" + x$ + ".so" - If Left$(libpath$, 1) <> "/" Then libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$ - End If - End If + IF LEFT$(libpath$, 1) <> "/" THEN libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$ + END IF + END IF 'check for .so (usr/lib64) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib64/" + libpath$ + "lib" + x$ + ".so." + libver$) Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib64/" + libpath$ + "lib" + x$ + ".so." + libver$) THEN libname$ = "/usr/lib64/" + libpath$ + "lib" + x$ + ".so." + libver$ inlinelibname$ = "/usr/lib64/" + libpath_inline$ + "lib" + x$ + ".so." + libver$ - End If - End If - If Len(libname$) = 0 Then - If _FileExists("/usr/lib64/" + libpath$ + "lib" + x$ + ".so") Then + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib64/" + libpath$ + "lib" + x$ + ".so") THEN libname$ = "/usr/lib64/" + libpath$ + "lib" + x$ + ".so" inlinelibname$ = "/usr/lib64/" + libpath_inline$ + "lib" + x$ + ".so" - End If - End If + END IF + END IF - If MacOSX Then 'dylib support + IF MacOSX THEN 'dylib support 'check for .dylib (usr/lib) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + "." + libver$ + ".dylib") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + libpath$ + "lib" + x$ + "." + libver$ + ".dylib") THEN libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + "." + libver$ + ".dylib" inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + "." + libver$ + ".dylib" - End If - End If - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + ".dylib") Then + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + libpath$ + "lib" + x$ + ".dylib") THEN libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + ".dylib" inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + ".dylib" - End If - End If - End If + END IF + END IF + END IF 'check for .so (usr/lib) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + ".so." + libver$) Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + libpath$ + "lib" + x$ + ".so." + libver$) THEN libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + ".so." + libver$ inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + ".so." + libver$ - End If - End If - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + ".so") Then + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + libpath$ + "lib" + x$ + ".so") THEN libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + ".so" inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + ".so" - End If - End If + END IF + END IF '--------------------------(without path)------------------------------ - If MacOSX Then 'dylib support + IF MacOSX THEN 'dylib support 'check for .dylib (direct) - If Len(libname$) = 0 Then - If _FileExists("lib" + x$ + "." + libver$ + ".dylib") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("lib" + x$ + "." + libver$ + ".dylib") THEN libname$ = "lib" + x$ + "." + libver$ + ".dylib" inlinelibname$ = "lib" + x$ + "." + libver$ + ".dylib" libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$ - End If - End If - If Len(libname$) = 0 Then - If _FileExists("lib" + x$ + ".dylib") Then + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("lib" + x$ + ".dylib") THEN libname$ = "lib" + x$ + ".dylib" inlinelibname$ = "lib" + x$ + ".dylib" libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$ - End If - End If - End If + END IF + END IF + END IF 'check for .so (direct) - If Len(libname$) = 0 Then - If _FileExists("lib" + x$ + ".so." + libver$) Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("lib" + x$ + ".so." + libver$) THEN libname$ = "lib" + x$ + ".so." + libver$ inlinelibname$ = "lib" + x$ + ".so." + libver$ libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$ - End If - End If - If Len(libname$) = 0 Then - If _FileExists("lib" + x$ + ".so") Then + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("lib" + x$ + ".so") THEN libname$ = "lib" + x$ + ".so" inlinelibname$ = "lib" + x$ + ".so" libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$ - End If - End If + END IF + END IF 'check for .so (usr/lib64) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib64/" + "lib" + x$ + ".so." + libver$) Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib64/" + "lib" + x$ + ".so." + libver$) THEN libname$ = "/usr/lib64/" + "lib" + x$ + ".so." + libver$ inlinelibname$ = "/usr/lib64/" + "lib" + x$ + ".so." + libver$ - End If - End If - If Len(libname$) = 0 Then - If _FileExists("/usr/lib64/" + "lib" + x$ + ".so") Then + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib64/" + "lib" + x$ + ".so") THEN libname$ = "/usr/lib64/" + "lib" + x$ + ".so" inlinelibname$ = "/usr/lib64/" + "lib" + x$ + ".so" - End If - End If + END IF + END IF - If MacOSX Then 'dylib support + IF MacOSX THEN 'dylib support 'check for .dylib (usr/lib) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + "lib" + x$ + "." + libver$ + ".dylib") Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + "lib" + x$ + "." + libver$ + ".dylib") THEN libname$ = "/usr/lib/" + "lib" + x$ + "." + libver$ + ".dylib" inlinelibname$ = "/usr/lib/" + "lib" + x$ + "." + libver$ + ".dylib" - End If - End If - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + "lib" + x$ + ".dylib") Then + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + "lib" + x$ + ".dylib") THEN libname$ = "/usr/lib/" + "lib" + x$ + ".dylib" inlinelibname$ = "/usr/lib/" + "lib" + x$ + ".dylib" - End If - End If - End If + END IF + END IF + END IF 'check for .so (usr/lib) - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + "lib" + x$ + ".so." + libver$) Then + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + "lib" + x$ + ".so." + libver$) THEN libname$ = "/usr/lib/" + "lib" + x$ + ".so." + libver$ inlinelibname$ = "/usr/lib/" + "lib" + x$ + ".so." + libver$ - End If - End If - If Len(libname$) = 0 Then - If _FileExists("/usr/lib/" + "lib" + x$ + ".so") Then + END IF + END IF + IF LEN(libname$) = 0 THEN + IF _FILEEXISTS("/usr/lib/" + "lib" + x$ + ".so") THEN libname$ = "/usr/lib/" + "lib" + x$ + ".so" inlinelibname$ = "/usr/lib/" + "lib" + x$ + ".so" - End If - End If - End If 'Linux + END IF + END IF + END IF 'Linux - End If 'Dynamic + END IF 'Dynamic 'library found? - If dynamiclibrary <> 0 And Len(libname$) = 0 Then a$ = "DYNAMIC LIBRARY not found": GoTo errmes - If Len(libname$) = 0 And Len(headername$) = 0 Then a$ = "LIBRARY not found": GoTo errmes + IF dynamiclibrary <> 0 AND LEN(libname$) = 0 THEN a$ = "DYNAMIC LIBRARY not found": GOTO errmes + IF LEN(libname$) = 0 AND LEN(headername$) = 0 THEN a$ = "LIBRARY not found": GOTO errmes '***actual method should cull redundant header and library entries*** - If dynamiclibrary = 0 Then + IF dynamiclibrary = 0 THEN 'static - If Len(libname$) Then - If os$ = "WIN" Then - If Mid$(libname$, 2, 1) = ":" Or Left$(libname$, 1) = "\" Then + IF LEN(libname$) THEN + IF os$ = "WIN" THEN + IF MID$(libname$, 2, 1) = ":" OR LEFT$(libname$, 1) = "\" THEN mylib$ = mylib$ + " " + libname$ + " " - Else + ELSE mylib$ = mylib$ + " ..\..\" + libname$ + " " - End If - End If - If os$ = "LNX" Then - If Left$(libname$, 1) = "/" Then + END IF + END IF + IF os$ = "LNX" THEN + IF LEFT$(libname$, 1) = "/" THEN mylib$ = mylib$ + " " + libname$ + " " - Else + ELSE mylib$ = mylib$ + " ../../" + libname$ + " " - End If - End If + END IF + END IF - End If + END IF - Else + ELSE 'dynamic - If Len(headername$) = 0 Then 'no header + IF LEN(headername$) = 0 THEN 'no header - If subfuncn Then - f = FreeFile - Open tmpdir$ + "maindata.txt" For Append As #f - Else + IF subfuncn THEN + f = FREEFILE + OPEN tmpdir$ + "maindata.txt" FOR APPEND AS #f + ELSE f = 13 - End If + END IF 'make name a C-appropriate variable name 'by converting everything except numbers and 'letters to underscores x2$ = x$ - For x2 = 1 To Len(x2$) - If Asc(x2$, x2) < 48 Then Asc(x2$, x2) = 95 - If Asc(x2$, x2) > 57 And Asc(x2$, x2) < 65 Then Asc(x2$, x2) = 95 - If Asc(x2$, x2) > 90 And Asc(x2$, x2) < 97 Then Asc(x2$, x2) = 95 - If Asc(x2$, x2) > 122 Then Asc(x2$, x2) = 95 - Next + FOR x2 = 1 TO LEN(x2$) + IF ASC(x2$, x2) < 48 THEN ASC(x2$, x2) = 95 + IF ASC(x2$, x2) > 57 AND ASC(x2$, x2) < 65 THEN ASC(x2$, x2) = 95 + IF ASC(x2$, x2) > 90 AND ASC(x2$, x2) < 97 THEN ASC(x2$, x2) = 95 + IF ASC(x2$, x2) > 122 THEN ASC(x2$, x2) = 95 + NEXT DLLname$ = x2$ - If sfdeclare Then + IF sfdeclare THEN - If os$ = "WIN" Then - Print #17, "HINSTANCE DLL_" + x2$ + "=NULL;" - Print #f, "if (!DLL_" + x2$ + "){" - Print #f, "DLL_" + x2$ + "=LoadLibrary(" + Chr$(34) + inlinelibname$ + Chr$(34) + ");" - Print #f, "if (!DLL_" + x2$ + ") error(259);" - Print #f, "}" - End If + IF os$ = "WIN" THEN + PRINT #17, "HINSTANCE DLL_" + x2$ + "=NULL;" + PRINT #f, "if (!DLL_" + x2$ + "){" + PRINT #f, "DLL_" + x2$ + "=LoadLibrary(" + CHR$(34) + inlinelibname$ + CHR$(34) + ");" + PRINT #f, "if (!DLL_" + x2$ + ") error(259);" + PRINT #f, "}" + END IF - If os$ = "LNX" Then - Print #17, "void *DLL_" + x2$ + "=NULL;" - Print #f, "if (!DLL_" + x2$ + "){" - Print #f, "DLL_" + x2$ + "=dlopen(" + Chr$(34) + inlinelibname$ + Chr$(34) + ",RTLD_LAZY);" - Print #f, "if (!DLL_" + x2$ + ") error(259);" - Print #f, "}" - End If + IF os$ = "LNX" THEN + PRINT #17, "void *DLL_" + x2$ + "=NULL;" + PRINT #f, "if (!DLL_" + x2$ + "){" + PRINT #f, "DLL_" + x2$ + "=dlopen(" + CHR$(34) + inlinelibname$ + CHR$(34) + ",RTLD_LAZY);" + PRINT #f, "if (!DLL_" + x2$ + ") error(259);" + PRINT #f, "}" + END IF - End If + END IF - If subfuncn Then Close #f + IF subfuncn THEN CLOSE #f - End If 'no header + END IF 'no header - End If 'dynamiclibrary + END IF 'dynamiclibrary - If Len(headername$) Then - If os$ = "WIN" Then - If Mid$(headername$, 2, 1) = ":" Or Left$(headername$, 1) = "\" Then - Print #17, "#include " + Chr$(34) + headername$ + Chr$(34) - Else - Print #17, "#include " + Chr$(34) + "..\\..\\" + headername$ + Chr$(34) - End If - End If - If os$ = "LNX" Then + IF LEN(headername$) THEN + IF os$ = "WIN" THEN + IF MID$(headername$, 2, 1) = ":" OR LEFT$(headername$, 1) = "\" THEN + PRINT #17, "#include " + CHR$(34) + headername$ + CHR$(34) + ELSE + PRINT #17, "#include " + CHR$(34) + "..\\..\\" + headername$ + CHR$(34) + END IF + END IF + IF os$ = "LNX" THEN - If Left$(headername$, 1) = "/" Then - Print #17, "#include " + Chr$(34) + headername$ + Chr$(34) - Else - Print #17, "#include " + Chr$(34) + "../../" + headername$ + Chr$(34) - End If + IF LEFT$(headername$, 1) = "/" THEN + PRINT #17, "#include " + CHR$(34) + headername$ + CHR$(34) + ELSE + PRINT #17, "#include " + CHR$(34) + "../../" + headername$ + CHR$(34) + END IF - End If - End If + END IF + END IF - End If + END IF - l$ = l$ + sp + Chr$(34) + autoformat_x$ + Chr$(34) + l$ = l$ + sp + CHR$(34) + autoformat_x$ + CHR$(34) - If n > x Then - If dynamiclibrary Then a$ = "Cannot specify multiple DYNAMIC LIBRARY names in a single DECLARE statement": GoTo errmes - x = x + 1: x2$ = getelement$(a$, x): If x2$ <> "," Then a$ = "Expected ,": GoTo errmes + IF n > x THEN + IF dynamiclibrary THEN a$ = "Cannot specify multiple DYNAMIC LIBRARY names in a single DECLARE statement": GOTO errmes + x = x + 1: x2$ = getelement$(a$, x): IF x2$ <> "," THEN a$ = "Expected ,": GOTO errmes l$ = l$ + sp2 + "," - x = x + 1: If x > n Then a$ = "Expected , ...": GoTo errmes - GoTo addlibrary - End If + x = x + 1: IF x > n THEN a$ = "Expected , ...": GOTO errmes + GOTO addlibrary + END IF - End If 'n>=x + END IF 'n>=x - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishednonexec - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishednonexec + END IF - GoTo finishednonexec 'note: no layout required - End If - End If + GOTO finishednonexec 'note: no layout required + END IF + END IF 'begin SUB/FUNCTION - If n >= 1 Then + IF n >= 1 THEN dynamiclibrary = 0 declaresubfunc2: sf = 0 - If firstelement$ = "FUNCTION" Then sf = 1 - If firstelement$ = "SUB" Then sf = 2 - If sf Then + IF firstelement$ = "FUNCTION" THEN sf = 1 + IF firstelement$ = "SUB" THEN sf = 2 + IF sf THEN - If declaringlibrary = 0 Then - If Len(subfunc) Then a$ = "Expected END SUB/FUNCTION before " + firstelement$: GoTo errmes - End If + IF declaringlibrary = 0 THEN + IF LEN(subfunc) THEN a$ = "Expected END SUB/FUNCTION before " + firstelement$: GOTO errmes + END IF - If n = 1 Then a$ = "Expected name after SUB/FUNCTION": GoTo errmes + IF n = 1 THEN a$ = "Expected name after SUB/FUNCTION": GOTO errmes e$ = getelement$(ca$, 2) symbol$ = removesymbol$(e$) '$,%,etc. - If Error_Happened Then GoTo errmes - If sf = 2 And symbol$ <> "" Then a$ = "Type symbols after a SUB name are invalid": GoTo errmes + IF Error_Happened THEN GOTO errmes + IF sf = 2 AND symbol$ <> "" THEN a$ = "Type symbols after a SUB name are invalid": GOTO errmes try = findid(e$) - If Error_Happened Then GoTo errmes - Do While try - If id.subfunc = sf Then GoTo createsf - If try = 2 Then findanotherid = 1: try = findid(e$) Else try = 0 - If Error_Happened Then GoTo errmes - Loop - a$ = "Unregistered SUB/FUNCTION encountered": GoTo errmes + IF Error_Happened THEN GOTO errmes + DO WHILE try + IF id.subfunc = sf THEN GOTO createsf + IF try = 2 THEN findanotherid = 1: try = findid(e$) ELSE try = 0 + IF Error_Happened THEN GOTO errmes + LOOP + a$ = "Unregistered SUB/FUNCTION encountered": GOTO errmes createsf: - If UCase$(e$) = "_GL" Then e$ = "_GL" - If firstelement$ = "SUB" Then + IF UCASE$(e$) = "_GL" THEN e$ = "_GL" + IF firstelement$ = "SUB" THEN l$ = SCase$("Sub") + sp + e$ + symbol$ - Else + ELSE l$ = SCase$("Function") + sp + e$ + symbol$ - End If + END IF id2 = id targetid = currentid 'check for ALIAS - aliasname$ = RTrim$(id.cn) - If n > 2 Then + aliasname$ = RTRIM$(id.cn) + IF n > 2 THEN ee$ = getelement$(a$, 3) - If ee$ = "ALIAS" Then - If declaringlibrary = 0 Then a$ = "ALIAS can only be used with DECLARE LIBRARY": GoTo errmes - If n = 3 Then a$ = "Expected ALIAS name-in-library": GoTo errmes + IF ee$ = "ALIAS" THEN + IF declaringlibrary = 0 THEN a$ = "ALIAS can only be used with DECLARE LIBRARY": GOTO errmes + IF n = 3 THEN a$ = "Expected ALIAS name-in-library": GOTO errmes ee$ = getelement$(ca$, 4) 'strip string content (optional) - If Left$(ee$, 1) = Chr$(34) Then - ee$ = Right$(ee$, Len(ee$) - 1) - x = InStr(ee$, Chr$(34)): If x = 0 Then a$ = "Expected " + Chr$(34): GoTo errmes - ee$ = Left$(ee$, x - 1) + IF LEFT$(ee$, 1) = CHR$(34) THEN + ee$ = RIGHT$(ee$, LEN(ee$) - 1) + x = INSTR(ee$, CHR$(34)): IF x = 0 THEN a$ = "Expected " + CHR$(34): GOTO errmes + ee$ = LEFT$(ee$, x - 1) l$ = l$ + sp + SCase$("Alias") + sp + CHR_QUOTE + ee$ + CHR_QUOTE - Else + ELSE l$ = l$ + sp + SCase$("Alias") + sp + ee$ - End If + END IF 'strip fix046$ (created by unquoted periods) - Do While InStr(ee$, fix046$) - x = InStr(ee$, fix046$): ee$ = Left$(ee$, x - 1) + "." + Right$(ee$, Len(ee$) - x + 1 - Len(fix046$)) - Loop + DO WHILE INSTR(ee$, fix046$) + x = INSTR(ee$, fix046$): ee$ = LEFT$(ee$, x - 1) + "." + RIGHT$(ee$, LEN(ee$) - x + 1 - LEN(fix046$)) + LOOP aliasname$ = ee$ 'remove ALIAS section from line - If n <= 4 Then a$ = getelements(a$, 1, 2) - If n >= 5 Then a$ = getelements(a$, 1, 2) + sp + getelements(a$, 5, n) - If n <= 4 Then ca$ = getelements(ca$, 1, 2) - If n >= 5 Then ca$ = getelements(ca$, 1, 2) + sp + getelements(ca$, 5, n) + IF n <= 4 THEN a$ = getelements(a$, 1, 2) + IF n >= 5 THEN a$ = getelements(a$, 1, 2) + sp + getelements(a$, 5, n) + IF n <= 4 THEN ca$ = getelements(ca$, 1, 2) + IF n >= 5 THEN ca$ = getelements(ca$, 1, 2) + sp + getelements(ca$, 5, n) n = n - 2 - End If - End If + END IF + END IF - If declaringlibrary Then GoTo declibjmp1 + IF declaringlibrary THEN GOTO declibjmp1 - If closedmain = 0 Then closemain + IF closedmain = 0 THEN closemain 'check for open controls (copy #2) - If controllevel <> 0 And controltype(controllevel) <> 6 Then 'It's OK for subs to be inside $IF blocks + IF controllevel <> 0 AND controltype(controllevel) <> 6 THEN 'It's OK for subs to be inside $IF blocks a$ = "Unidentified open control block" - Select Case controltype(controllevel) - Case 1: a$ = "IF without END IF" - Case 2: a$ = "FOR without NEXT" - Case 3, 4: a$ = "DO without LOOP" - Case 5: a$ = "WHILE without WEND" - Case 10 TO 19: a$ = "SELECT CASE without END SELECT" - End Select + SELECT CASE controltype(controllevel) + CASE 1: a$ = "IF without END IF" + CASE 2: a$ = "FOR without NEXT" + CASE 3, 4: a$ = "DO without LOOP" + CASE 5: a$ = "WHILE without WEND" + CASE 10 TO 19: a$ = "SELECT CASE without END SELECT" + END SELECT linenumber = controlref(controllevel) - GoTo errmes - End If + GOTO errmes + END IF - If ideindentsubs Then + IF ideindentsubs THEN controllevel = controllevel + 1 controltype(controllevel) = 32 controlref(controllevel) = linenumber - End If + END IF - subfunc = RTrim$(id.callname) 'SUB_..." + subfunc = RTRIM$(id.callname) 'SUB_..." subfuncn = subfuncn + 1 subfuncid = targetid subfuncret$ = "" - Close #13: Open tmpdir$ + "data" + str2$(subfuncn) + ".txt" For Output As #13 - Close #19: Open tmpdir$ + "free" + str2$(subfuncn) + ".txt" For Output As #19 - Close #15: Open tmpdir$ + "ret" + str2$(subfuncn) + ".txt" For Output As #15 - Print #15, "if (next_return_point){" - Print #15, "next_return_point--;" - Print #15, "switch(return_point[next_return_point]){" - Print #15, "case 0:" - Print #15, "error(3);" 'return without gosub! - Print #15, "break;" + CLOSE #13: OPEN tmpdir$ + "data" + str2$(subfuncn) + ".txt" FOR OUTPUT AS #13 + CLOSE #19: OPEN tmpdir$ + "free" + str2$(subfuncn) + ".txt" FOR OUTPUT AS #19 + CLOSE #15: OPEN tmpdir$ + "ret" + str2$(subfuncn) + ".txt" FOR OUTPUT AS #15 + PRINT #15, "if (next_return_point){" + PRINT #15, "next_return_point--;" + PRINT #15, "switch(return_point[next_return_point]){" + PRINT #15, "case 0:" + PRINT #15, "error(3);" 'return without gosub! + PRINT #15, "break;" defdatahandle = 13 declibjmp1: - If declaringlibrary Then - If sfdeclare = 0 And indirectlibrary = 0 Then - Close #17 - Open tmpdir$ + "regsf_ignore.txt" For Output As #17 - End If - If sfdeclare = 1 And customtypelibrary = 0 And dynamiclibrary = 0 And indirectlibrary = 0 Then - Print #17, "#include " + Chr$(34) + "externtype" + str2(ResolveStaticFunctions + 1) + ".txt" + Chr$(34) - fh = FreeFile: Open tmpdir$ + "externtype" + str2(ResolveStaticFunctions + 1) + ".txt" For Output As #fh: Close #fh - End If - End If + IF declaringlibrary THEN + IF sfdeclare = 0 AND indirectlibrary = 0 THEN + CLOSE #17 + OPEN tmpdir$ + "regsf_ignore.txt" FOR OUTPUT AS #17 + END IF + IF sfdeclare = 1 AND customtypelibrary = 0 AND dynamiclibrary = 0 AND indirectlibrary = 0 THEN + PRINT #17, "#include " + CHR$(34) + "externtype" + str2(ResolveStaticFunctions + 1) + ".txt" + CHR$(34) + fh = FREEFILE: OPEN tmpdir$ + "externtype" + str2(ResolveStaticFunctions + 1) + ".txt" FOR OUTPUT AS #fh: CLOSE #fh + END IF + END IF - If sf = 1 Then + IF sf = 1 THEN rettyp = id.ret t$ = typ2ctyp$(id.ret, "") - If Error_Happened Then GoTo errmes - If t$ = "qbs" Then t$ = "qbs*" + IF Error_Happened THEN GOTO errmes + IF t$ = "qbs" THEN t$ = "qbs*" - If declaringlibrary Then - If rettyp And ISSTRING Then + IF declaringlibrary THEN + IF rettyp AND ISSTRING THEN t$ = "char*" - End If - End If + END IF + END IF - If declaringlibrary <> 0 And dynamiclibrary <> 0 Then - If os$ = "WIN" Then - Print #17, "typedef " + t$ + " (CALLBACK* DLLCALL_" + removecast$(RTrim$(id.callname)) + ")("; - End If - If os$ = "LNX" Then - Print #17, "typedef " + t$ + " (*DLLCALL_" + removecast$(RTrim$(id.callname)) + ")("; - End If - ElseIf declaringlibrary <> 0 And customtypelibrary <> 0 Then - Print #17, "typedef " + t$ + " CUSTOMCALL_" + removecast$(RTrim$(id.callname)) + "("; - Else - Print #17, t$ + " " + removecast$(RTrim$(id.callname)) + "("; - End If - If declaringlibrary Then GoTo declibjmp2 - Print #12, t$ + " " + removecast$(RTrim$(id.callname)) + "("; + IF declaringlibrary <> 0 AND dynamiclibrary <> 0 THEN + IF os$ = "WIN" THEN + PRINT #17, "typedef " + t$ + " (CALLBACK* DLLCALL_" + removecast$(RTRIM$(id.callname)) + ")("; + END IF + IF os$ = "LNX" THEN + PRINT #17, "typedef " + t$ + " (*DLLCALL_" + removecast$(RTRIM$(id.callname)) + ")("; + END IF + ELSEIF declaringlibrary <> 0 AND customtypelibrary <> 0 THEN + PRINT #17, "typedef " + t$ + " CUSTOMCALL_" + removecast$(RTRIM$(id.callname)) + "("; + ELSE + PRINT #17, t$ + " " + removecast$(RTRIM$(id.callname)) + "("; + END IF + IF declaringlibrary THEN GOTO declibjmp2 + PRINT #12, t$ + " " + removecast$(RTRIM$(id.callname)) + "("; 'create variable to return result 'if type wasn't specified, define it - If symbol$ = "" Then - a = Asc(UCase$(e$)): If a = 95 Then a = 91 + IF symbol$ = "" THEN + a = ASC(UCASE$(e$)): IF a = 95 THEN a = 91 a = a - 64 'so A=1, Z=27 and _=28 symbol$ = defineextaz(a) - End If + END IF reginternalvariable = 1 ignore = dim2(e$, symbol$, 0, "") - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes reginternalvariable = 0 'the following line stops the return variable from being free'd before being returned - Close #19: Open tmpdir$ + "free" + str2$(subfuncn) + ".txt" For Output As #19 + CLOSE #19: OPEN tmpdir$ + "free" + str2$(subfuncn) + ".txt" FOR OUTPUT AS #19 'create return - If (rettyp And ISSTRING) Then + IF (rettyp AND ISSTRING) THEN r$ = refer$(str2$(currentid), id.t, 1) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes subfuncret$ = subfuncret$ + "qbs_maketmp(" + r$ + ");" subfuncret$ = subfuncret$ + "return " + r$ + ";" - Else + ELSE r$ = refer$(str2$(currentid), id.t, 0) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes subfuncret$ = "return " + r$ + ";" - End If - Else + END IF + ELSE - If declaringlibrary <> 0 And dynamiclibrary <> 0 Then - If os$ = "WIN" Then - Print #17, "typedef void (CALLBACK* DLLCALL_" + removecast$(RTrim$(id.callname)) + ")("; - End If - If os$ = "LNX" Then - Print #17, "typedef void (*DLLCALL_" + removecast$(RTrim$(id.callname)) + ")("; - End If - ElseIf declaringlibrary <> 0 And customtypelibrary <> 0 Then - Print #17, "typedef void CUSTOMCALL_" + removecast$(RTrim$(id.callname)) + "("; - Else - Print #17, "void " + removecast$(RTrim$(id.callname)) + "("; - End If - If declaringlibrary Then GoTo declibjmp2 - Print #12, "void " + removecast$(RTrim$(id.callname)) + "("; - End If + IF declaringlibrary <> 0 AND dynamiclibrary <> 0 THEN + IF os$ = "WIN" THEN + PRINT #17, "typedef void (CALLBACK* DLLCALL_" + removecast$(RTRIM$(id.callname)) + ")("; + END IF + IF os$ = "LNX" THEN + PRINT #17, "typedef void (*DLLCALL_" + removecast$(RTRIM$(id.callname)) + ")("; + END IF + ELSEIF declaringlibrary <> 0 AND customtypelibrary <> 0 THEN + PRINT #17, "typedef void CUSTOMCALL_" + removecast$(RTRIM$(id.callname)) + "("; + ELSE + PRINT #17, "void " + removecast$(RTRIM$(id.callname)) + "("; + END IF + IF declaringlibrary THEN GOTO declibjmp2 + PRINT #12, "void " + removecast$(RTRIM$(id.callname)) + "("; + END IF declibjmp2: addstatic2layout = 0 staticsf = 0 e$ = getelement$(a$, n) - If e$ = "STATIC" Then - If declaringlibrary Then a$ = "STATIC cannot be used in a library declaration": GoTo errmes + IF e$ = "STATIC" THEN + IF declaringlibrary THEN a$ = "STATIC cannot be used in a library declaration": GOTO errmes addstatic2layout = 1 staticsf = 2 - a$ = Left$(a$, Len(a$) - 7): n = n - 1 'remove STATIC - End If + a$ = LEFT$(a$, LEN(a$) - 7): n = n - 1 'remove STATIC + END IF 'check items to pass params = 0 AllowLocalName = 1 - If n > 2 Then + IF n > 2 THEN e$ = getelement$(a$, 3) - If e$ <> "(" Then a$ = "Expected (": GoTo errmes + IF e$ <> "(" THEN a$ = "Expected (": GOTO errmes e$ = getelement$(a$, n) - If e$ <> ")" Then a$ = "Expected )": GoTo errmes + IF e$ <> ")" THEN a$ = "Expected )": GOTO errmes l$ = l$ + sp + "(" - If n = 4 Then GoTo nosfparams2 - If n < 4 Then a$ = "Expected ( ... )": GoTo errmes + IF n = 4 THEN GOTO nosfparams2 + IF n < 4 THEN a$ = "Expected ( ... )": GOTO errmes B = 0 a2$ = "" - For i = 4 To n - 1 + FOR i = 4 TO n - 1 e$ = getelement$(ca$, i) - If e$ = "(" Then B = B + 1 - If e$ = ")" Then B = B - 1 - If e$ = "," And B = 0 Then - If i = n - 1 Then a$ = "Expected , ... )": GoTo errmes + IF e$ = "(" THEN B = B + 1 + IF e$ = ")" THEN B = B - 1 + IF e$ = "," AND B = 0 THEN + IF i = n - 1 THEN a$ = "Expected , ... )": GOTO errmes getlastparam2: - If a2$ = "" Then a$ = "Expected ... ,": GoTo errmes - a2$ = Left$(a2$, Len(a2$) - 1) + IF a2$ = "" THEN a$ = "Expected ... ,": GOTO errmes + a2$ = LEFT$(a2$, LEN(a2$) - 1) 'possible format: [BYVAL]a[%][(1)][AS][type] params = params + 1 glinkid = targetid @@ -4771,156 +4771,156 @@ Do - If params > 1 Then - Print #17, ","; + IF params > 1 THEN + PRINT #17, ","; - If declaringlibrary = 0 Then - Print #12, ","; - End If + IF declaringlibrary = 0 THEN + PRINT #12, ","; + END IF - End If + END IF n2 = numelements(a2$) array = 0 t2$ = "" e$ = getelement$(a2$, 1) byvalue = 0 - If UCase$(e$) = "BYVAL" Then - If declaringlibrary = 0 Then a$ = "BYVAL can currently only be used with DECLARE LIBRARY": GoTo errmes - byvalue = 1: a2$ = Right$(a2$, Len(a2$) - 6) - If Right$(l$, 1) = "(" Then l$ = l$ + sp2 + SCase$("ByVal") Else l$ = l$ + sp + SCase$("Byval") + IF UCASE$(e$) = "BYVAL" THEN + IF declaringlibrary = 0 THEN a$ = "BYVAL can currently only be used with DECLARE LIBRARY": GOTO errmes + byvalue = 1: a2$ = RIGHT$(a2$, LEN(a2$) - 6) + IF RIGHT$(l$, 1) = "(" THEN l$ = l$ + sp2 + SCase$("ByVal") ELSE l$ = l$ + sp + SCase$("Byval") n2 = numelements(a2$): e$ = getelement$(a2$, 1) - End If + END IF - If Right$(l$, 1) = "(" Then l$ = l$ + sp2 + e$ Else l$ = l$ + sp + e$ + IF RIGHT$(l$, 1) = "(" THEN l$ = l$ + sp2 + e$ ELSE l$ = l$ + sp + e$ n2$ = e$ dimmethod = 0 symbol2$ = removesymbol$(n2$) - If validname(n2$) = 0 Then a$ = "Invalid name": GoTo errmes + IF validname(n2$) = 0 THEN a$ = "Invalid name": GOTO errmes - If Error_Happened Then GoTo errmes - If symbol2$ <> "" Then dimmethod = 1 + IF Error_Happened THEN GOTO errmes + IF symbol2$ <> "" THEN dimmethod = 1 m = 0 - For i2 = 2 To n2 + FOR i2 = 2 TO n2 e$ = getelement$(a2$, i2) - If e$ = "(" Then - If m <> 0 Then a$ = "Syntax error": GoTo errmes + IF e$ = "(" THEN + IF m <> 0 THEN a$ = "Syntax error": GOTO errmes m = 1 array = 1 l$ = l$ + sp2 + "(" - GoTo gotaa2 - End If - If e$ = ")" Then - If m <> 1 Then a$ = "Syntax error": GoTo errmes + GOTO gotaa2 + END IF + IF e$ = ")" THEN + IF m <> 1 THEN a$ = "Syntax error": GOTO errmes m = 2 l$ = l$ + sp2 + ")" - GoTo gotaa2 - End If - If UCase$(e$) = "AS" Then - If m <> 0 And m <> 2 Then a$ = "Syntax error": GoTo errmes + GOTO gotaa2 + END IF + IF UCASE$(e$) = "AS" THEN + IF m <> 0 AND m <> 2 THEN a$ = "Syntax error": GOTO errmes m = 3 l$ = l$ + sp + SCase$("As") - GoTo gotaa2 - End If - If m = 1 Then l$ = l$ + sp + e$: GoTo gotaa2 'ignore contents of option bracket telling how many dimensions (add to layout as is) - If m <> 3 Then a$ = "Syntax error": GoTo errmes - If t2$ = "" Then t2$ = e$ Else t2$ = t2$ + " " + e$ + GOTO gotaa2 + END IF + IF m = 1 THEN l$ = l$ + sp + e$: GOTO gotaa2 'ignore contents of option bracket telling how many dimensions (add to layout as is) + IF m <> 3 THEN a$ = "Syntax error": GOTO errmes + IF t2$ = "" THEN t2$ = e$ ELSE t2$ = t2$ + " " + e$ gotaa2: - Next i2 - If symbol2$ <> "" And t2$ <> "" Then a$ = "Syntax error": GoTo errmes + NEXT i2 + IF symbol2$ <> "" AND t2$ <> "" THEN a$ = "Syntax error": GOTO errmes - If Len(t2$) Then 'add type-name after AS - t2$ = UCase$(t2$) + IF LEN(t2$) THEN 'add type-name after AS + t2$ = UCASE$(t2$) t3$ = t2$ typ = typname2typ(t3$) - If Error_Happened Then GoTo errmes - If typ = 0 Then a$ = "Undefined type": GoTo errmes - If typ And ISUDT Then - If RTrim$(udtxcname(typ And 511)) = "_MEM" And UCase$(t3$) = "MEM" And qb64prefix_set = 1 Then - t3$ = Mid$(RTrim$(udtxcname(typ And 511)), 2) - End If - t3$ = RTrim$(udtxcname(typ And 511)) + IF Error_Happened THEN GOTO errmes + IF typ = 0 THEN a$ = "Undefined type": GOTO errmes + IF typ AND ISUDT THEN + IF RTRIM$(udtxcname(typ AND 511)) = "_MEM" AND UCASE$(t3$) = "MEM" AND qb64prefix_set = 1 THEN + t3$ = MID$(RTRIM$(udtxcname(typ AND 511)), 2) + END IF + t3$ = RTRIM$(udtxcname(typ AND 511)) l$ = l$ + sp + t3$ - Else - For t3i = 1 To Len(t3$) - If Asc(t3$, t3i) = 32 Then Asc(t3$, t3i) = Asc(sp) - Next + ELSE + FOR t3i = 1 TO LEN(t3$) + IF ASC(t3$, t3i) = 32 THEN ASC(t3$, t3i) = ASC(sp) + NEXT t3$ = SCase2$(t3$) l$ = l$ + sp + t3$ - End If - End If + END IF + END IF - If t2$ = "" Then t2$ = symbol2$ - If t2$ = "" Then - If Left$(n2$, 1) = "_" Then v = 27 Else v = Asc(UCase$(n2$)) - 64 + IF t2$ = "" THEN t2$ = symbol2$ + IF t2$ = "" THEN + IF LEFT$(n2$, 1) = "_" THEN v = 27 ELSE v = ASC(UCASE$(n2$)) - 64 t2$ = defineaz(v) dimmethod = 1 - End If + END IF - If array = 1 Then - If declaringlibrary Then a$ = "Arrays cannot be passed to a library": GoTo errmes + IF array = 1 THEN + IF declaringlibrary THEN a$ = "Arrays cannot be passed to a library": GOTO errmes dimsfarray = 1 'note: id2.nele is currently 0 - nelereq = Asc(Mid$(id2.nelereq, params, 1)) - If nelereq Then + nelereq = ASC(MID$(id2.nelereq, params, 1)) + IF nelereq THEN nele = nelereq - Mid$(id2.nele, params, 1) = Chr$(nele) + MID$(id2.nele, params, 1) = CHR$(nele) ids(targetid) = id2 ignore = dim2(n2$, t2$, dimmethod, str2$(nele)) - If Error_Happened Then GoTo errmes - Else + IF Error_Happened THEN GOTO errmes + ELSE nele = 1 - Mid$(id2.nele, params, 1) = Chr$(nele) + MID$(id2.nele, params, 1) = CHR$(nele) ids(targetid) = id2 ignore = dim2(n2$, t2$, dimmethod, "?") - If Error_Happened Then GoTo errmes - End If + IF Error_Happened THEN GOTO errmes + END IF dimsfarray = 0 r$ = refer$(str2$(currentid), id.t, 1) - If Error_Happened Then GoTo errmes - Print #17, "ptrszint*" + r$; - Print #12, "ptrszint*" + r$; - Else + IF Error_Happened THEN GOTO errmes + PRINT #17, "ptrszint*" + r$; + PRINT #12, "ptrszint*" + r$; + ELSE - If declaringlibrary Then + IF declaringlibrary THEN 'is it a udt? - For xx = 1 To lasttype - If t2$ = RTrim$(udtxname(xx)) Then - Print #17, "void*" - GoTo decudt - ElseIf RTrim$(udtxname(xx)) = "_MEM" And t2$ = "MEM" And qb64prefix_set = 1 Then - Print #17, "void*" - GoTo decudt - End If - Next + FOR xx = 1 TO lasttype + IF t2$ = RTRIM$(udtxname(xx)) THEN + PRINT #17, "void*" + GOTO decudt + ELSEIF RTRIM$(udtxname(xx)) = "_MEM" AND t2$ = "MEM" AND qb64prefix_set = 1 THEN + PRINT #17, "void*" + GOTO decudt + END IF + NEXT t$ = typ2ctyp$(0, t2$) - If Error_Happened Then GoTo errmes - If t$ = "qbs" Then + IF Error_Happened THEN GOTO errmes + IF t$ = "qbs" THEN t$ = "char*" - If byvalue = 1 Then a$ = "STRINGs cannot be passed using BYVAL": GoTo errmes + IF byvalue = 1 THEN a$ = "STRINGs cannot be passed using BYVAL": GOTO errmes byvalue = 1 'use t$ as is - End If - If byvalue Then Print #17, t$; Else Print #17, t$ + "*"; + END IF + IF byvalue THEN PRINT #17, t$; ELSE PRINT #17, t$ + "*"; decudt: - GoTo declibjmp3 - End If + GOTO declibjmp3 + END IF dimsfarray = 1 ignore = dim2(n2$, t2$, dimmethod, "") - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes dimsfarray = 0 @@ -4928,75 +4928,75 @@ Do typ = id.t 'the typ of the ID created by dim2 t$ = typ2ctyp$(typ, "") - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes - If t$ = "" Then a$ = "Cannot find C type to return array data": GoTo errmes + IF t$ = "" THEN a$ = "Cannot find C type to return array data": GOTO errmes 'searchpoint 'get the name of the variable r$ = refer$(str2$(currentid), id.t, 1) - If Error_Happened Then GoTo errmes - Print #17, t$ + "*" + r$; - Print #12, t$ + "*" + r$; - If t$ = "qbs" Then + IF Error_Happened THEN GOTO errmes + PRINT #17, t$ + "*" + r$; + PRINT #12, t$ + "*" + r$; + IF t$ = "qbs" THEN u$ = str2$(uniquenumber) - Print #13, "qbs*oldstr" + u$ + "=NULL;" - Print #13, "if(" + r$ + "->tmp||" + r$ + "->fixed||" + r$ + "->readonly){" - Print #13, "oldstr" + u$ + "=" + r$ + ";" + PRINT #13, "qbs*oldstr" + u$ + "=NULL;" + PRINT #13, "if(" + r$ + "->tmp||" + r$ + "->fixed||" + r$ + "->readonly){" + PRINT #13, "oldstr" + u$ + "=" + r$ + ";" - Print #13, "if (oldstr" + u$ + "->cmem_descriptor){" - Print #13, r$ + "=qbs_new_cmem(oldstr" + u$ + "->len,0);" - Print #13, "}else{" - Print #13, r$ + "=qbs_new(oldstr" + u$ + "->len,0);" - Print #13, "}" + PRINT #13, "if (oldstr" + u$ + "->cmem_descriptor){" + PRINT #13, r$ + "=qbs_new_cmem(oldstr" + u$ + "->len,0);" + PRINT #13, "}else{" + PRINT #13, r$ + "=qbs_new(oldstr" + u$ + "->len,0);" + PRINT #13, "}" - Print #13, "memcpy(" + r$ + "->chr,oldstr" + u$ + "->chr,oldstr" + u$ + "->len);" - Print #13, "}" + PRINT #13, "memcpy(" + r$ + "->chr,oldstr" + u$ + "->chr,oldstr" + u$ + "->len);" + PRINT #13, "}" - Print #19, "if(oldstr" + u$ + "){" - Print #19, "if(oldstr" + u$ + "->fixed)qbs_set(oldstr" + u$ + "," + r$ + ");" - Print #19, "qbs_free(" + r$ + ");" - Print #19, "}" - End If - End If + PRINT #19, "if(oldstr" + u$ + "){" + PRINT #19, "if(oldstr" + u$ + "->fixed)qbs_set(oldstr" + u$ + "," + r$ + ");" + PRINT #19, "qbs_free(" + r$ + ");" + PRINT #19, "}" + END IF + END IF declibjmp3: - If i <> n - 1 Then l$ = l$ + sp2 + "," + IF i <> n - 1 THEN l$ = l$ + sp2 + "," a2$ = "" - Else + ELSE a2$ = a2$ + e$ + sp - If i = n - 1 Then GoTo getlastparam2 - End If - Next i + IF i = n - 1 THEN GOTO getlastparam2 + END IF + NEXT i nosfparams2: l$ = l$ + sp2 + ")" - End If 'n>2 + END IF 'n>2 AllowLocalName = 0 - If addstatic2layout Then l$ = l$ + sp + SCase$("Static") - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + IF addstatic2layout THEN l$ = l$ + sp + SCase$("Static") + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ - Print #17, ");" + PRINT #17, ");" - If declaringlibrary Then GoTo declibjmp4 + IF declaringlibrary THEN GOTO declibjmp4 - Print #12, "){" - Print #12, "qbs *tqbs;" - Print #12, "ptrszint tmp_long;" - Print #12, "int32 tmp_fileno;" - Print #12, "uint32 qbs_tmp_base=qbs_tmp_list_nexti;" - Print #12, "uint8 *tmp_mem_static_pointer=mem_static_pointer;" - Print #12, "uint32 tmp_cmem_sp=cmem_sp;" - Print #12, "#include " + Chr$(34) + "data" + str2$(subfuncn) + ".txt" + Chr$(34) + PRINT #12, "){" + PRINT #12, "qbs *tqbs;" + PRINT #12, "ptrszint tmp_long;" + PRINT #12, "int32 tmp_fileno;" + PRINT #12, "uint32 qbs_tmp_base=qbs_tmp_list_nexti;" + PRINT #12, "uint8 *tmp_mem_static_pointer=mem_static_pointer;" + PRINT #12, "uint32 tmp_cmem_sp=cmem_sp;" + PRINT #12, "#include " + CHR$(34) + "data" + str2$(subfuncn) + ".txt" + CHR$(34) 'create new _MEM lock for this scope - Print #12, "mem_lock *sf_mem_lock;" 'MUST not be static for recursion reasons - Print #12, "new_mem_lock();" - Print #12, "sf_mem_lock=mem_lock_tmp;" - Print #12, "sf_mem_lock->type=3;" + PRINT #12, "mem_lock *sf_mem_lock;" 'MUST not be static for recursion reasons + PRINT #12, "new_mem_lock();" + PRINT #12, "sf_mem_lock=mem_lock_tmp;" + PRINT #12, "sf_mem_lock->type=3;" - Print #12, "if (new_error) goto exit_subfunc;" + PRINT #12, "if (new_error) goto exit_subfunc;" 'statementn = statementn + 1 'if nochecks=0 then PRINT #12, "S_" + str2$(statementn) + ":;" @@ -5005,172 +5005,172 @@ Do declibjmp4: - If declaringlibrary Then + IF declaringlibrary THEN - If customtypelibrary Then + IF customtypelibrary THEN - callname$ = removecast$(RTrim$(id2.callname)) + callname$ = removecast$(RTRIM$(id2.callname)) - Print #17, "CUSTOMCALL_" + callname$ + " *" + callname$ + "=NULL;" + PRINT #17, "CUSTOMCALL_" + callname$ + " *" + callname$ + "=NULL;" - If subfuncn Then - f = FreeFile - Open tmpdir$ + "maindata.txt" For Append As #f - Else + IF subfuncn THEN + f = FREEFILE + OPEN tmpdir$ + "maindata.txt" FOR APPEND AS #f + ELSE f = 13 - End If + END IF - Print #f, callname$ + "=(CUSTOMCALL_" + callname$ + "*)&" + aliasname$ + ";" + PRINT #f, callname$ + "=(CUSTOMCALL_" + callname$ + "*)&" + aliasname$ + ";" - If subfuncn Then Close #f + IF subfuncn THEN CLOSE #f 'if no header exists to make the external function available, the function definition must be found - If sfheader = 0 And sfdeclare <> 0 Then + IF sfheader = 0 AND sfdeclare <> 0 THEN ResolveStaticFunctions = ResolveStaticFunctions + 1 'expand array if necessary - If ResolveStaticFunctions > UBound(ResolveStaticFunction_Name) Then - ReDim _Preserve ResolveStaticFunction_Name(1 To ResolveStaticFunctions + 100) As String - ReDim _Preserve ResolveStaticFunction_File(1 To ResolveStaticFunctions + 100) As String - ReDim _Preserve ResolveStaticFunction_Method(1 To ResolveStaticFunctions + 100) As Long - End If + IF ResolveStaticFunctions > UBOUND(ResolveStaticFunction_Name) THEN + REDIM _PRESERVE ResolveStaticFunction_Name(1 TO ResolveStaticFunctions + 100) AS STRING + REDIM _PRESERVE ResolveStaticFunction_File(1 TO ResolveStaticFunctions + 100) AS STRING + REDIM _PRESERVE ResolveStaticFunction_Method(1 TO ResolveStaticFunctions + 100) AS LONG + END IF ResolveStaticFunction_File(ResolveStaticFunctions) = libname$ ResolveStaticFunction_Name(ResolveStaticFunctions) = aliasname$ ResolveStaticFunction_Method(ResolveStaticFunctions) = 1 - End If 'sfheader=0 + END IF 'sfheader=0 - End If + END IF - If dynamiclibrary Then - If sfdeclare Then + IF dynamiclibrary THEN + IF sfdeclare THEN - Print #17, "DLLCALL_" + removecast$(RTrim$(id2.callname)) + " " + removecast$(RTrim$(id2.callname)) + "=NULL;" + PRINT #17, "DLLCALL_" + removecast$(RTRIM$(id2.callname)) + " " + removecast$(RTRIM$(id2.callname)) + "=NULL;" - If subfuncn Then - f = FreeFile - Open tmpdir$ + "maindata.txt" For Append As #f - Else + IF subfuncn THEN + f = FREEFILE + OPEN tmpdir$ + "maindata.txt" FOR APPEND AS #f + ELSE f = 13 - End If + END IF - Print #f, "if (!" + removecast$(RTrim$(id2.callname)) + "){" - If os$ = "WIN" Then - Print #f, removecast$(RTrim$(id2.callname)) + "=(DLLCALL_" + removecast$(RTrim$(id2.callname)) + ")GetProcAddress(DLL_" + DLLname$ + "," + Chr$(34) + aliasname$ + Chr$(34) + ");" - Print #f, "if (!" + removecast$(RTrim$(id2.callname)) + ") error(260);" - End If - If os$ = "LNX" Then - Print #f, removecast$(RTrim$(id2.callname)) + "=(DLLCALL_" + removecast$(RTrim$(id2.callname)) + ")dlsym(DLL_" + DLLname$ + "," + Chr$(34) + aliasname$ + Chr$(34) + ");" - Print #f, "if (dlerror()) error(260);" - End If - Print #f, "}" + PRINT #f, "if (!" + removecast$(RTRIM$(id2.callname)) + "){" + IF os$ = "WIN" THEN + PRINT #f, removecast$(RTRIM$(id2.callname)) + "=(DLLCALL_" + removecast$(RTRIM$(id2.callname)) + ")GetProcAddress(DLL_" + DLLname$ + "," + CHR$(34) + aliasname$ + CHR$(34) + ");" + PRINT #f, "if (!" + removecast$(RTRIM$(id2.callname)) + ") error(260);" + END IF + IF os$ = "LNX" THEN + PRINT #f, removecast$(RTRIM$(id2.callname)) + "=(DLLCALL_" + removecast$(RTRIM$(id2.callname)) + ")dlsym(DLL_" + DLLname$ + "," + CHR$(34) + aliasname$ + CHR$(34) + ");" + PRINT #f, "if (dlerror()) error(260);" + END IF + PRINT #f, "}" - If subfuncn Then Close #f + IF subfuncn THEN CLOSE #f - End If 'sfdeclare - End If 'dynamic + END IF 'sfdeclare + END IF 'dynamic - If sfdeclare = 1 And customtypelibrary = 0 And dynamiclibrary = 0 And indirectlibrary = 0 Then + IF sfdeclare = 1 AND customtypelibrary = 0 AND dynamiclibrary = 0 AND indirectlibrary = 0 THEN ResolveStaticFunctions = ResolveStaticFunctions + 1 'expand array if necessary - If ResolveStaticFunctions > UBound(ResolveStaticFunction_Name) Then - ReDim _Preserve ResolveStaticFunction_Name(1 To ResolveStaticFunctions + 100) As String - ReDim _Preserve ResolveStaticFunction_File(1 To ResolveStaticFunctions + 100) As String - ReDim _Preserve ResolveStaticFunction_Method(1 To ResolveStaticFunctions + 100) As Long - End If + IF ResolveStaticFunctions > UBOUND(ResolveStaticFunction_Name) THEN + REDIM _PRESERVE ResolveStaticFunction_Name(1 TO ResolveStaticFunctions + 100) AS STRING + REDIM _PRESERVE ResolveStaticFunction_File(1 TO ResolveStaticFunctions + 100) AS STRING + REDIM _PRESERVE ResolveStaticFunction_Method(1 TO ResolveStaticFunctions + 100) AS LONG + END IF ResolveStaticFunction_File(ResolveStaticFunctions) = libname$ ResolveStaticFunction_Name(ResolveStaticFunctions) = aliasname$ ResolveStaticFunction_Method(ResolveStaticFunctions) = 2 - End If + END IF - If sfdeclare = 0 And indirectlibrary = 0 Then - Close #17 - Open tmpdir$ + "regsf.txt" For Append As #17 - End If + IF sfdeclare = 0 AND indirectlibrary = 0 THEN + CLOSE #17 + OPEN tmpdir$ + "regsf.txt" FOR APPEND AS #17 + END IF - End If 'declaring library + END IF 'declaring library - GoTo finishednonexec - End If - End If + GOTO finishednonexec + END IF + END IF 'END SUB/FUNCTION - If n = 2 Then - If firstelement$ = "END" Then + IF n = 2 THEN + IF firstelement$ = "END" THEN sf = 0 - If secondelement$ = "FUNCTION" Then sf = 1 - If secondelement$ = "SUB" Then sf = 2 - If sf Then + IF secondelement$ = "FUNCTION" THEN sf = 1 + IF secondelement$ = "SUB" THEN sf = 2 + IF sf THEN - If Len(subfunc) = 0 Then a$ = "END " + secondelement$ + " without " + secondelement$: GoTo errmes + IF LEN(subfunc) = 0 THEN a$ = "END " + secondelement$ + " without " + secondelement$: GOTO errmes 'check for open controls (copy #3) - If controllevel <> 0 And controltype(controllevel) <> 6 And controltype(controllevel) <> 32 Then 'It's OK for subs to be inside $IF blocks + IF controllevel <> 0 AND controltype(controllevel) <> 6 AND controltype(controllevel) <> 32 THEN 'It's OK for subs to be inside $IF blocks a$ = "Unidentified open control block" - Select Case controltype(controllevel) - Case 1: a$ = "IF without END IF" - Case 2: a$ = "FOR without NEXT" - Case 3, 4: a$ = "DO without LOOP" - Case 5: a$ = "WHILE without WEND" - Case 10 TO 19: a$ = "SELECT CASE without END SELECT" - End Select + SELECT CASE controltype(controllevel) + CASE 1: a$ = "IF without END IF" + CASE 2: a$ = "FOR without NEXT" + CASE 3, 4: a$ = "DO without LOOP" + CASE 5: a$ = "WHILE without WEND" + CASE 10 TO 19: a$ = "SELECT CASE without END SELECT" + END SELECT linenumber = controlref(controllevel) - GoTo errmes - End If + GOTO errmes + END IF - If controltype(controllevel) = 32 And ideindentsubs Then + IF controltype(controllevel) = 32 AND ideindentsubs THEN controltype(controllevel) = 0 controllevel = controllevel - 1 - End If + END IF - If Left$(subfunc, 4) = "SUB_" Then secondelement$ = SCase$("Sub") Else secondelement$ = SCase$("Function") + IF LEFT$(subfunc, 4) = "SUB_" THEN secondelement$ = SCase$("Sub") ELSE secondelement$ = SCase$("Function") l$ = SCase$("End") + sp + secondelement$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ staticarraylist = "": staticarraylistn = 0 'remove previously listed arrays dimstatic = 0 - Print #12, "exit_subfunc:;" + PRINT #12, "exit_subfunc:;" 'release _MEM lock for this scope - Print #12, "free_mem_lock(sf_mem_lock);" + PRINT #12, "free_mem_lock(sf_mem_lock);" - Print #12, "#include " + Chr$(34) + "free" + str2$(subfuncn) + ".txt" + Chr$(34) - Print #12, "if ((tmp_mem_static_pointer>=mem_static)&&(tmp_mem_static_pointer<=mem_static_limit)) mem_static_pointer=tmp_mem_static_pointer; else mem_static_pointer=mem_static;" - Print #12, "cmem_sp=tmp_cmem_sp;" - If subfuncret$ <> "" Then Print #12, subfuncret$ + PRINT #12, "#include " + CHR$(34) + "free" + str2$(subfuncn) + ".txt" + CHR$(34) + PRINT #12, "if ((tmp_mem_static_pointer>=mem_static)&&(tmp_mem_static_pointer<=mem_static_limit)) mem_static_pointer=tmp_mem_static_pointer; else mem_static_pointer=mem_static;" + PRINT #12, "cmem_sp=tmp_cmem_sp;" + IF subfuncret$ <> "" THEN PRINT #12, subfuncret$ - Print #12, "}" 'skeleton sub + PRINT #12, "}" 'skeleton sub 'ret???.txt - Print #15, "}" 'end case - Print #15, "}" - Print #15, "error(3);" 'no valid return possible + PRINT #15, "}" 'end case + PRINT #15, "}" + PRINT #15, "error(3);" 'no valid return possible subfunc = "" 'unshare temp. shared variables - For i = 1 To idn - If ids(i).share And 2 Then ids(i).share = ids(i).share - 2 - Next + FOR i = 1 TO idn + IF ids(i).share AND 2 THEN ids(i).share = ids(i).share - 2 + NEXT - For i = 1 To revertmaymusthaven + FOR i = 1 TO revertmaymusthaven x = revertmaymusthave(i) - Swap ids(x).musthave, ids(x).mayhave - Next + SWAP ids(x).musthave, ids(x).mayhave + NEXT revertmaymusthaven = 0 'undeclare constants in sub/function's scope 'constlast = constlastshared - GoTo finishednonexec + GOTO finishednonexec - End If - End If - End If + END IF + END IF + END IF - If n >= 1 And firstelement$ = "CONST" Then + IF n >= 1 AND firstelement$ = "CONST" THEN l$ = SCase$("Const") 'DEF... do not change type, the expression is stored in a suitable type 'based on its value if type isn't forced/specified - If n < 3 Then a$ = "Expected CONST name = value/expression": GoTo errmes + IF n < 3 THEN a$ = "Expected CONST name = value/expression": GOTO errmes i = 2 constdefpending: @@ -5180,35 +5180,35 @@ Do l$ = l$ + sp + n$ + sp + "=" typeoverride = 0 s$ = removesymbol$(n$) - If Error_Happened Then GoTo errmes - If s$ <> "" Then + IF Error_Happened THEN GOTO errmes + IF s$ <> "" THEN typeoverride = typname2typ(s$) - If Error_Happened Then GoTo errmes - If typeoverride And ISFIXEDLENGTH Then a$ = "Invalid constant type": GoTo errmes - If typeoverride = 0 Then a$ = "Invalid constant type": GoTo errmes - End If + IF Error_Happened THEN GOTO errmes + IF typeoverride AND ISFIXEDLENGTH THEN a$ = "Invalid constant type": GOTO errmes + IF typeoverride = 0 THEN a$ = "Invalid constant type": GOTO errmes + END IF - If getelement$(a$, i) <> "=" Then a$ = "Expected =": GoTo errmes + IF getelement$(a$, i) <> "=" THEN a$ = "Expected =": GOTO errmes i = i + 1 'get expression e$ = "" B = 0 - For i2 = i To n + FOR i2 = i TO n e2$ = getelement$(ca$, i2) - If e2$ = "(" Then B = B + 1 - If e2$ = ")" Then B = B - 1 - If e2$ = "," And B = 0 Then + IF e2$ = "(" THEN B = B + 1 + IF e2$ = ")" THEN B = B - 1 + IF e2$ = "," AND B = 0 THEN pending = 1 i = i2 + 1 - If i > n - 2 Then a$ = "Expected CONST ... , name = value/expression": GoTo errmes - Exit For - End If - If Len(e$) = 0 Then e$ = e2$ Else e$ = e$ + sp + e2$ - Next + IF i > n - 2 THEN a$ = "Expected CONST ... , name = value/expression": GOTO errmes + EXIT FOR + END IF + IF LEN(e$) = 0 THEN e$ = e2$ ELSE e$ = e$ + sp + e2$ + NEXT e$ = fixoperationorder(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp + tlayout$ 'Note: Actual CONST definition handled in prepass @@ -5217,43 +5217,43 @@ Do hashname$ = n$ hashchkflags = HASHFLAG_CONSTANT hashres = HashFind(hashname$, hashchkflags, hashresflags, hashresref) - Do While hashres - If constsubfunc(hashresref) = subfuncn Then constdefined(hashresref) = 1: Exit Do - If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0 - Loop + DO WHILE hashres + IF constsubfunc(hashresref) = subfuncn THEN constdefined(hashresref) = 1: EXIT DO + IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 + LOOP - If pending Then l$ = l$ + sp2 + ",": GoTo constdefpending + IF pending THEN l$ = l$ + sp2 + ",": GOTO constdefpending - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ - GoTo finishednonexec - End If + GOTO finishednonexec + END IF predefine: - If n >= 2 Then + IF n >= 2 THEN asreq = 0 - If firstelement$ = "DEFINT" Then l$ = SCase$("DefInt"): a$ = a$ + sp + "AS" + sp + "INTEGER": n = n + 2: GoTo definetype - If firstelement$ = "DEFLNG" Then l$ = SCase$("DefLng"): a$ = a$ + sp + "AS" + sp + "LONG": n = n + 2: GoTo definetype - If firstelement$ = "DEFSNG" Then l$ = SCase$("DefSng"): a$ = a$ + sp + "AS" + sp + "SINGLE": n = n + 2: GoTo definetype - If firstelement$ = "DEFDBL" Then l$ = SCase$("DefDbl"): a$ = a$ + sp + "AS" + sp + "DOUBLE": n = n + 2: GoTo definetype - If firstelement$ = "DEFSTR" Then l$ = SCase$("DefStr"): a$ = a$ + sp + "AS" + sp + "STRING": n = n + 2: GoTo definetype - If firstelement$ = "_DEFINE" Or (firstelement$ = "DEFINE" And qb64prefix_set = 1) Then + IF firstelement$ = "DEFINT" THEN l$ = SCase$("DefInt"): a$ = a$ + sp + "AS" + sp + "INTEGER": n = n + 2: GOTO definetype + IF firstelement$ = "DEFLNG" THEN l$ = SCase$("DefLng"): a$ = a$ + sp + "AS" + sp + "LONG": n = n + 2: GOTO definetype + IF firstelement$ = "DEFSNG" THEN l$ = SCase$("DefSng"): a$ = a$ + sp + "AS" + sp + "SINGLE": n = n + 2: GOTO definetype + IF firstelement$ = "DEFDBL" THEN l$ = SCase$("DefDbl"): a$ = a$ + sp + "AS" + sp + "DOUBLE": n = n + 2: GOTO definetype + IF firstelement$ = "DEFSTR" THEN l$ = SCase$("DefStr"): a$ = a$ + sp + "AS" + sp + "STRING": n = n + 2: GOTO definetype + IF firstelement$ = "_DEFINE" OR (firstelement$ = "DEFINE" AND qb64prefix_set = 1) THEN asreq = 1 - If firstelement$ = "_DEFINE" Then l$ = SCase$("_Define") Else l$ = SCase$("Define") + IF firstelement$ = "_DEFINE" THEN l$ = SCase$("_Define") ELSE l$ = SCase$("Define") definetype: 'get type from rhs typ$ = "" typ2$ = "" t$ = "" - For i = n To 2 Step -1 + FOR i = n TO 2 STEP -1 t$ = getelement$(a$, i) - If t$ = "AS" Then Exit For + IF t$ = "AS" THEN EXIT FOR typ$ = t$ + " " + typ$ typ2$ = t$ + sp + typ2$ - Next - typ$ = RTrim$(typ$) - If t$ <> "AS" Then a$ = qb64prefix$ + "DEFINE: Expected ... AS ...": GoTo errmes - If i = n Or i = 2 Then a$ = qb64prefix$ + "DEFINE: Expected ... AS ...": GoTo errmes + NEXT + typ$ = RTRIM$(typ$) + IF t$ <> "AS" THEN a$ = qb64prefix$ + "DEFINE: Expected ... AS ...": GOTO errmes + IF i = n OR i = 2 THEN a$ = qb64prefix$ + "DEFINE: Expected ... AS ...": GOTO errmes n = i - 1 @@ -5261,251 +5261,251 @@ Do i = 2 - 1 definenext: 'expects an alphabet letter or underscore - i = i + 1: e$ = getelement$(a$, i): E = Asc(UCase$(e$)) - If Len(e$) > 1 Then a$ = qb64prefix$ + "DEFINE: Expected an alphabet letter or the underscore character (_)": GoTo errmes - If E <> 95 And (E > 90 Or E < 65) Then a$ = qb64prefix$ + "DEFINE: Expected an alphabet letter or the underscore character (_)": GoTo errmes - If E = 95 Then E = 27 Else E = E - 64 + i = i + 1: e$ = getelement$(a$, i): E = ASC(UCASE$(e$)) + IF LEN(e$) > 1 THEN a$ = qb64prefix$ + "DEFINE: Expected an alphabet letter or the underscore character (_)": GOTO errmes + IF E <> 95 AND (E > 90 OR E < 65) THEN a$ = qb64prefix$ + "DEFINE: Expected an alphabet letter or the underscore character (_)": GOTO errmes + IF E = 95 THEN E = 27 ELSE E = E - 64 defineaz(E) = typ$ defineextaz(E) = type2symbol(typ$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes firste = E l$ = l$ + sp + e$ - If i = n Then - If predefining = 1 Then GoTo predefined - If asreq Then l$ = l$ + sp + SCase$("As") + sp + typ2$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishednonexec - End If + IF i = n THEN + IF predefining = 1 THEN GOTO predefined + IF asreq THEN l$ = l$ + sp + SCase$("As") + sp + typ2$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishednonexec + END IF 'expects "-" or "," i = i + 1: e$ = getelement$(a$, i) - If e$ <> "-" And e$ <> "," Then a$ = qb64prefix$ + "DEFINE: Expected - or ,": GoTo errmes - If e$ = "-" Then + IF e$ <> "-" AND e$ <> "," THEN a$ = qb64prefix$ + "DEFINE: Expected - or ,": GOTO errmes + IF e$ = "-" THEN l$ = l$ + sp2 + "-" - If i = n Then a$ = qb64prefix$ + "DEFINE: Syntax incomplete": GoTo errmes + IF i = n THEN a$ = qb64prefix$ + "DEFINE: Syntax incomplete": GOTO errmes 'expects an alphabet letter or underscore - i = i + 1: e$ = getelement$(a$, i): E = Asc(UCase$(e$)) - If Len(e$) > 1 Then a$ = qb64prefix$ + "DEFINE: Expected an alphabet letter or the underscore character (_)": GoTo errmes - If E <> 95 And (E > 90 Or E < 65) Then a$ = qb64prefix$ + "DEFINE: Expected an alphabet letter or the underscore character (_)": GoTo errmes - If E = 95 Then E = 27 Else E = E - 64 - If firste > E Then Swap E, firste - For e2 = firste To E + i = i + 1: e$ = getelement$(a$, i): E = ASC(UCASE$(e$)) + IF LEN(e$) > 1 THEN a$ = qb64prefix$ + "DEFINE: Expected an alphabet letter or the underscore character (_)": GOTO errmes + IF E <> 95 AND (E > 90 OR E < 65) THEN a$ = qb64prefix$ + "DEFINE: Expected an alphabet letter or the underscore character (_)": GOTO errmes + IF E = 95 THEN E = 27 ELSE E = E - 64 + IF firste > E THEN SWAP E, firste + FOR e2 = firste TO E defineaz(e2) = typ$ defineextaz(e2) = type2symbol(typ$) - If Error_Happened Then GoTo errmes - Next + IF Error_Happened THEN GOTO errmes + NEXT l$ = l$ + sp2 + e$ - If i = n Then - If predefining = 1 Then GoTo predefined - If asreq Then l$ = l$ + sp + SCase$("As") + sp + typ2$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishednonexec - End If + IF i = n THEN + IF predefining = 1 THEN GOTO predefined + IF asreq THEN l$ = l$ + sp + SCase$("As") + sp + typ2$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishednonexec + END IF 'expects "," i = i + 1: e$ = getelement$(a$, i) - If e$ <> "," Then a$ = qb64prefix$ + "DEFINE: Expected ,": GoTo errmes - End If + IF e$ <> "," THEN a$ = qb64prefix$ + "DEFINE: Expected ,": GOTO errmes + END IF l$ = l$ + sp2 + "," - GoTo definenext - End If '_DEFINE - End If '2 - If predefining = 1 Then GoTo predefined + GOTO definenext + END IF '_DEFINE + END IF '2 + IF predefining = 1 THEN GOTO predefined - If closedmain <> 0 And subfunc = "" Then a$ = "Statement cannot be placed between SUB/FUNCTIONs": GoTo errmes + IF closedmain <> 0 AND subfunc = "" THEN a$ = "Statement cannot be placed between SUB/FUNCTIONs": GOTO errmes 'executable section: statementn = statementn + 1 - If n >= 1 Then - If firstelement$ = "NEXT" Then + IF n >= 1 THEN + IF firstelement$ = "NEXT" THEN l$ = SCase$("Next") - If n = 1 Then GoTo simplenext + IF n = 1 THEN GOTO simplenext v$ = "" - For i = 2 To n + FOR i = 2 TO n a2$ = getelement(ca$, i) - If a2$ = "," Then + IF a2$ = "," THEN lastnextele: e$ = fixoperationorder(v$) - If Error_Happened Then GoTo errmes - If Len(l$) = 4 Then l$ = l$ + sp + tlayout$ Else l$ = l$ + sp2 + "," + sp + tlayout$ + IF Error_Happened THEN GOTO errmes + IF LEN(l$) = 4 THEN l$ = l$ + sp + tlayout$ ELSE l$ = l$ + sp2 + "," + sp + tlayout$ e$ = evaluate(e$, typ) - If Error_Happened Then GoTo errmes - If (typ And ISREFERENCE) Then - getid Val(e$) - If Error_Happened Then GoTo errmes - If (id.t And ISPOINTER) Then - If (id.t And ISSTRING) = 0 Then - If (id.t And ISOFFSETINBITS) = 0 Then - If (id.t And ISARRAY) = 0 Then - GoTo fornextfoundvar2 - End If - End If - End If - End If - End If - a$ = "Unsupported variable after NEXT": GoTo errmes + IF Error_Happened THEN GOTO errmes + IF (typ AND ISREFERENCE) THEN + getid VAL(e$) + IF Error_Happened THEN GOTO errmes + IF (id.t AND ISPOINTER) THEN + IF (id.t AND ISSTRING) = 0 THEN + IF (id.t AND ISOFFSETINBITS) = 0 THEN + IF (id.t AND ISARRAY) = 0 THEN + GOTO fornextfoundvar2 + END IF + END IF + END IF + END IF + END IF + a$ = "Unsupported variable after NEXT": GOTO errmes fornextfoundvar2: simplenext: - If controltype(controllevel) <> 2 Then a$ = "NEXT without FOR": GoTo errmes - If n <> 1 And controlvalue(controllevel) <> currentid Then a$ = "Incorrect variable after NEXT": GoTo errmes - Print #12, "fornext_continue_" + str2$(controlid(controllevel)) + ":;" - Print #12, "}" - Print #12, "fornext_exit_" + str2$(controlid(controllevel)) + ":;" + IF controltype(controllevel) <> 2 THEN a$ = "NEXT without FOR": GOTO errmes + IF n <> 1 AND controlvalue(controllevel) <> currentid THEN a$ = "Incorrect variable after NEXT": GOTO errmes + PRINT #12, "fornext_continue_" + str2$(controlid(controllevel)) + ":;" + PRINT #12, "}" + PRINT #12, "fornext_exit_" + str2$(controlid(controllevel)) + ":;" controllevel = controllevel - 1 - If n = 1 Then Exit For + IF n = 1 THEN EXIT FOR v$ = "" - Else + ELSE - If Len(v$) Then v$ = v$ + sp + a2$ Else v$ = a2$ - If i = n Then GoTo lastnextele + IF LEN(v$) THEN v$ = v$ + sp + a2$ ELSE v$ = a2$ + IF i = n THEN GOTO lastnextele - End If + END IF - Next + NEXT - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishednonexec '***no error causing code, event checking done by FOR*** - End If - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishednonexec '***no error causing code, event checking done by FOR*** + END IF + END IF - If n >= 1 Then - If firstelement$ = "WHILE" Then - If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1 + IF n >= 1 THEN + IF firstelement$ = "WHILE" THEN + IF NoChecks = 0 THEN PRINT #12, "S_" + str2$(statementn) + ":;": dynscope = 1 'prevents code from being placed before 'CASE condition' in a SELECT CASE block - If SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then - a$ = "Expected CASE expression": GoTo errmes - End If + IF SelectCaseCounter > 0 AND SelectCaseHasCaseBlock(SelectCaseCounter) = 0 THEN + a$ = "Expected CASE expression": GOTO errmes + END IF controllevel = controllevel + 1 controlref(controllevel) = linenumber controltype(controllevel) = 5 controlid(controllevel) = uniquenumber - If n >= 2 Then + IF n >= 2 THEN e$ = fixoperationorder(getelements$(ca$, 2, n)) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = SCase$("While") + sp + tlayout$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ e$ = evaluate(e$, typ) - If Error_Happened Then GoTo errmes - If (typ And ISREFERENCE) Then e$ = refer$(e$, typ, 0) - If Error_Happened Then GoTo errmes - If stringprocessinghappened Then e$ = cleanupstringprocessingcall$ + e$ + ")" - If (typ And ISSTRING) Then a$ = "WHILE ERROR! Cannot accept a STRING type.": GoTo errmes - Print #12, "while((" + e$ + ")||new_error){" - Else - a$ = "WHILE ERROR! Expected expression after WHILE.": GoTo errmes - End If + IF Error_Happened THEN GOTO errmes + IF (typ AND ISREFERENCE) THEN e$ = refer$(e$, typ, 0) + IF Error_Happened THEN GOTO errmes + IF stringprocessinghappened THEN e$ = cleanupstringprocessingcall$ + e$ + ")" + IF (typ AND ISSTRING) THEN a$ = "WHILE ERROR! Cannot accept a STRING type.": GOTO errmes + PRINT #12, "while((" + e$ + ")||new_error){" + ELSE + a$ = "WHILE ERROR! Expected expression after WHILE.": GOTO errmes + END IF - GoTo finishedline - End If - End If + GOTO finishedline + END IF + END IF - If n = 1 Then - If firstelement$ = "WEND" Then + IF n = 1 THEN + IF firstelement$ = "WEND" THEN - If controltype(controllevel) <> 5 Then a$ = "WEND without WHILE": GoTo errmes - Print #12, "ww_continue_" + str2$(controlid(controllevel)) + ":;" - Print #12, "}" - Print #12, "ww_exit_" + str2$(controlid(controllevel)) + ":;" + IF controltype(controllevel) <> 5 THEN a$ = "WEND without WHILE": GOTO errmes + PRINT #12, "ww_continue_" + str2$(controlid(controllevel)) + ":;" + PRINT #12, "}" + PRINT #12, "ww_exit_" + str2$(controlid(controllevel)) + ":;" controllevel = controllevel - 1 l$ = SCase$("Wend") - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishednonexec '***no error causing code, event checking done by WHILE*** - End If - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishednonexec '***no error causing code, event checking done by WHILE*** + END IF + END IF - If n >= 1 Then - If firstelement$ = "DO" Then - If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1 + IF n >= 1 THEN + IF firstelement$ = "DO" THEN + IF NoChecks = 0 THEN PRINT #12, "S_" + str2$(statementn) + ":;": dynscope = 1 'prevents code from being placed before 'CASE condition' in a SELECT CASE block - If SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then - a$ = "Expected CASE expression": GoTo errmes - End If + IF SelectCaseCounter > 0 AND SelectCaseHasCaseBlock(SelectCaseCounter) = 0 THEN + a$ = "Expected CASE expression": GOTO errmes + END IF controllevel = controllevel + 1 controlref(controllevel) = linenumber l$ = SCase$("Do") - If n >= 2 Then + IF n >= 2 THEN whileuntil = 0 - If secondelement$ = "WHILE" Then whileuntil = 1: l$ = l$ + sp + SCase$("While") - If secondelement$ = "UNTIL" Then whileuntil = 2: l$ = l$ + sp + SCase$("Until") - If whileuntil = 0 Then a$ = "DO ERROR! Expected WHILE or UNTIL after DO.": GoTo errmes - If whileuntil > 0 And n = 2 Then a$ = "Condition expected after WHILE/UNTIL": GoTo errmes + IF secondelement$ = "WHILE" THEN whileuntil = 1: l$ = l$ + sp + SCase$("While") + IF secondelement$ = "UNTIL" THEN whileuntil = 2: l$ = l$ + sp + SCase$("Until") + IF whileuntil = 0 THEN a$ = "DO ERROR! Expected WHILE or UNTIL after DO.": GOTO errmes + IF whileuntil > 0 AND n = 2 THEN a$ = "Condition expected after WHILE/UNTIL": GOTO errmes e$ = fixoperationorder(getelements$(ca$, 3, n)) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp + tlayout$ e$ = evaluate(e$, typ) - If Error_Happened Then GoTo errmes - If (typ And ISREFERENCE) Then e$ = refer$(e$, typ, 0) - If Error_Happened Then GoTo errmes - If stringprocessinghappened Then e$ = cleanupstringprocessingcall$ + e$ + ")" - If (typ And ISSTRING) Then a$ = "DO ERROR! Cannot accept a STRING type.": GoTo errmes - If whileuntil = 1 Then Print #12, "while((" + e$ + ")||new_error){" Else Print #12, "while((!(" + e$ + "))||new_error){" + IF Error_Happened THEN GOTO errmes + IF (typ AND ISREFERENCE) THEN e$ = refer$(e$, typ, 0) + IF Error_Happened THEN GOTO errmes + IF stringprocessinghappened THEN e$ = cleanupstringprocessingcall$ + e$ + ")" + IF (typ AND ISSTRING) THEN a$ = "DO ERROR! Cannot accept a STRING type.": GOTO errmes + IF whileuntil = 1 THEN PRINT #12, "while((" + e$ + ")||new_error){" ELSE PRINT #12, "while((!(" + e$ + "))||new_error){" controltype(controllevel) = 4 - Else + ELSE controltype(controllevel) = 3 - Print #12, "do{" - End If + PRINT #12, "do{" + END IF controlid(controllevel) = uniquenumber - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + END IF - If n >= 1 Then - If firstelement$ = "LOOP" Then + IF n >= 1 THEN + IF firstelement$ = "LOOP" THEN l$ = SCase$("Loop") - If controltype(controllevel) <> 3 And controltype(controllevel) <> 4 Then a$ = "PROGRAM FLOW ERROR!": GoTo errmes - If n >= 2 Then - If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1 - If controltype(controllevel) = 4 Then a$ = "PROGRAM FLOW ERROR!": GoTo errmes + IF controltype(controllevel) <> 3 AND controltype(controllevel) <> 4 THEN a$ = "PROGRAM FLOW ERROR!": GOTO errmes + IF n >= 2 THEN + IF NoChecks = 0 THEN PRINT #12, "S_" + str2$(statementn) + ":;": dynscope = 1 + IF controltype(controllevel) = 4 THEN a$ = "PROGRAM FLOW ERROR!": GOTO errmes whileuntil = 0 - If secondelement$ = "WHILE" Then whileuntil = 1: l$ = l$ + sp + SCase$("While") - If secondelement$ = "UNTIL" Then whileuntil = 2: l$ = l$ + sp + SCase$("Until") - If whileuntil = 0 Then a$ = "LOOP ERROR! Expected WHILE or UNTIL after LOOP.": GoTo errmes - If whileuntil > 0 And n = 2 Then a$ = "Condition expected after WHILE/UNTIL": GoTo errmes + IF secondelement$ = "WHILE" THEN whileuntil = 1: l$ = l$ + sp + SCase$("While") + IF secondelement$ = "UNTIL" THEN whileuntil = 2: l$ = l$ + sp + SCase$("Until") + IF whileuntil = 0 THEN a$ = "LOOP ERROR! Expected WHILE or UNTIL after LOOP.": GOTO errmes + IF whileuntil > 0 AND n = 2 THEN a$ = "Condition expected after WHILE/UNTIL": GOTO errmes e$ = fixoperationorder(getelements$(ca$, 3, n)) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp + tlayout$ e$ = evaluate(e$, typ) - If Error_Happened Then GoTo errmes - If (typ And ISREFERENCE) Then e$ = refer$(e$, typ, 0) - If Error_Happened Then GoTo errmes - If stringprocessinghappened Then e$ = cleanupstringprocessingcall$ + e$ + ")" - If (typ And ISSTRING) Then a$ = "LOOP ERROR! Cannot accept a STRING type.": GoTo errmes - Print #12, "dl_continue_" + str2$(controlid(controllevel)) + ":;" - If whileuntil = 1 Then Print #12, "}while((" + e$ + ")&&(!new_error));" Else Print #12, "}while((!(" + e$ + "))&&(!new_error));" - Else - Print #12, "dl_continue_" + str2$(controlid(controllevel)) + ":;" - If controltype(controllevel) = 4 Then - Print #12, "}" - Else - Print #12, "}while(1);" 'infinite loop! - End If - End If - Print #12, "dl_exit_" + str2$(controlid(controllevel)) + ":;" + IF Error_Happened THEN GOTO errmes + IF (typ AND ISREFERENCE) THEN e$ = refer$(e$, typ, 0) + IF Error_Happened THEN GOTO errmes + IF stringprocessinghappened THEN e$ = cleanupstringprocessingcall$ + e$ + ")" + IF (typ AND ISSTRING) THEN a$ = "LOOP ERROR! Cannot accept a STRING type.": GOTO errmes + PRINT #12, "dl_continue_" + str2$(controlid(controllevel)) + ":;" + IF whileuntil = 1 THEN PRINT #12, "}while((" + e$ + ")&&(!new_error));" ELSE PRINT #12, "}while((!(" + e$ + "))&&(!new_error));" + ELSE + PRINT #12, "dl_continue_" + str2$(controlid(controllevel)) + ":;" + IF controltype(controllevel) = 4 THEN + PRINT #12, "}" + ELSE + PRINT #12, "}while(1);" 'infinite loop! + END IF + END IF + PRINT #12, "dl_exit_" + str2$(controlid(controllevel)) + ":;" controllevel = controllevel - 1 - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - If n = 1 Then GoTo finishednonexec '***no error causing code, event checking done by DO*** - GoTo finishedline - End If - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + IF n = 1 THEN GOTO finishednonexec '***no error causing code, event checking done by DO*** + GOTO finishedline + END IF + END IF @@ -5515,16 +5515,16 @@ Do - If n >= 1 Then - If firstelement$ = "FOR" Then - If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1 + IF n >= 1 THEN + IF firstelement$ = "FOR" THEN + IF NoChecks = 0 THEN PRINT #12, "S_" + str2$(statementn) + ":;": dynscope = 1 l$ = SCase$("For") 'prevents code from being placed before 'CASE condition' in a SELECT CASE block - If SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then - a$ = "Expected CASE expression": GoTo errmes - End If + IF SelectCaseCounter > 0 AND SelectCaseHasCaseBlock(SelectCaseCounter) = 0 THEN + a$ = "Expected CASE expression": GOTO errmes + END IF controllevel = controllevel + 1 controlref(controllevel) = linenumber @@ -5537,54 +5537,54 @@ Do p2$ = "" mode = 0 E = 0 - For i = 2 To n + FOR i = 2 TO n e$ = getelement$(a$, i) - If e$ = "=" Then - If mode <> 0 Then E = 1: Exit For + IF e$ = "=" THEN + IF mode <> 0 THEN E = 1: EXIT FOR mode = 1 v$ = getelements$(ca$, 2, i - 1) equpos = i - End If - If e$ = "TO" Then - If mode <> 1 Then E = 1: Exit For + END IF + IF e$ = "TO" THEN + IF mode <> 1 THEN E = 1: EXIT FOR mode = 2 startvalue$ = getelements$(ca$, equpos + 1, i - 1) topos = i - End If - If e$ = "STEP" Then - If mode <> 2 Then E = 1: Exit For + END IF + IF e$ = "STEP" THEN + IF mode <> 2 THEN E = 1: EXIT FOR mode = 3 stepused = 1 p2$ = getelements$(ca$, topos + 1, i - 1) p3$ = getelements$(ca$, i + 1, n) - Exit For - End If - Next - If mode < 2 Then E = 1 - If p2$ = "" Then p2$ = getelements$(ca$, topos + 1, n) - If Len(v$) = 0 Or Len(startvalue$) = 0 Or Len(p2$) = 0 Then E = 1 - If E <> 0 And mode < 3 Then a$ = "Expected FOR name = start TO end": GoTo errmes - If E Then a$ = "Expected FOR name = start TO end STEP increment": GoTo errmes + EXIT FOR + END IF + NEXT + IF mode < 2 THEN E = 1 + IF p2$ = "" THEN p2$ = getelements$(ca$, topos + 1, n) + IF LEN(v$) = 0 OR LEN(startvalue$) = 0 OR LEN(p2$) = 0 THEN E = 1 + IF E <> 0 AND mode < 3 THEN a$ = "Expected FOR name = start TO end": GOTO errmes + IF E THEN a$ = "Expected FOR name = start TO end STEP increment": GOTO errmes e$ = fixoperationorder(v$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp + tlayout$ e$ = evaluate(e$, typ) - If Error_Happened Then GoTo errmes - If (typ And ISREFERENCE) Then - getid Val(e$) - If Error_Happened Then GoTo errmes - If (id.t And ISPOINTER) Then - If (id.t And ISSTRING) = 0 Then - If (id.t And ISOFFSETINBITS) = 0 Then - If (id.t And ISARRAY) = 0 Then - GoTo fornextfoundvar - End If - End If - End If - End If - End If - a$ = "Unsupported variable used in FOR statement": GoTo errmes + IF Error_Happened THEN GOTO errmes + IF (typ AND ISREFERENCE) THEN + getid VAL(e$) + IF Error_Happened THEN GOTO errmes + IF (id.t AND ISPOINTER) THEN + IF (id.t AND ISSTRING) = 0 THEN + IF (id.t AND ISOFFSETINBITS) = 0 THEN + IF (id.t AND ISARRAY) = 0 THEN + GOTO fornextfoundvar + END IF + END IF + END IF + END IF + END IF + a$ = "Unsupported variable used in FOR statement": GOTO errmes fornextfoundvar: controlvalue(controllevel) = currentid v$ = e$ @@ -5593,83 +5593,83 @@ Do 'markup to cater for greater range/accuracy ctype$ = "" ctyp = typ - ISPOINTER - bits = typ And 511 - If (typ And ISFLOAT) Then - If bits = 32 Then ctype$ = "double": ctyp = 64& + ISFLOAT - If bits = 64 Then ctype$ = "long double": ctyp = 256& + ISFLOAT - If bits = 256 Then ctype$ = "long double": ctyp = 256& + ISFLOAT - Else - If bits = 8 Then ctype$ = "int16": ctyp = 16& - If bits = 16 Then ctype$ = "int32": ctyp = 32& - If bits = 32 Then ctype$ = "int64": ctyp = 64& - If bits = 64 Then ctype$ = "int64": ctyp = 64& - End If - If ctype$ = "" Then a$ = "Unsupported variable used in FOR statement": GoTo errmes + bits = typ AND 511 + IF (typ AND ISFLOAT) THEN + IF bits = 32 THEN ctype$ = "double": ctyp = 64& + ISFLOAT + IF bits = 64 THEN ctype$ = "long double": ctyp = 256& + ISFLOAT + IF bits = 256 THEN ctype$ = "long double": ctyp = 256& + ISFLOAT + ELSE + IF bits = 8 THEN ctype$ = "int16": ctyp = 16& + IF bits = 16 THEN ctype$ = "int32": ctyp = 32& + IF bits = 32 THEN ctype$ = "int64": ctyp = 64& + IF bits = 64 THEN ctype$ = "int64": ctyp = 64& + END IF + IF ctype$ = "" THEN a$ = "Unsupported variable used in FOR statement": GOTO errmes u$ = str2(uniquenumber) - If subfunc = "" Then - Print #13, "static " + ctype$ + " fornext_value" + u$ + ";" - Print #13, "static " + ctype$ + " fornext_finalvalue" + u$ + ";" - Print #13, "static " + ctype$ + " fornext_step" + u$ + ";" - Print #13, "static uint8 fornext_step_negative" + u$ + ";" - Else - Print #13, ctype$ + " fornext_value" + u$ + ";" - Print #13, ctype$ + " fornext_finalvalue" + u$ + ";" - Print #13, ctype$ + " fornext_step" + u$ + ";" - Print #13, "uint8 fornext_step_negative" + u$ + ";" - End If + IF subfunc = "" THEN + PRINT #13, "static " + ctype$ + " fornext_value" + u$ + ";" + PRINT #13, "static " + ctype$ + " fornext_finalvalue" + u$ + ";" + PRINT #13, "static " + ctype$ + " fornext_step" + u$ + ";" + PRINT #13, "static uint8 fornext_step_negative" + u$ + ";" + ELSE + PRINT #13, ctype$ + " fornext_value" + u$ + ";" + PRINT #13, ctype$ + " fornext_finalvalue" + u$ + ";" + PRINT #13, ctype$ + " fornext_step" + u$ + ";" + PRINT #13, "uint8 fornext_step_negative" + u$ + ";" + END IF 'calculate start e$ = fixoperationorder$(startvalue$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp + "=" + sp + tlayout$ e$ = evaluatetotyp$(e$, ctyp) - If Error_Happened Then GoTo errmes - Print #12, "fornext_value" + u$ + "=" + e$ + ";" + IF Error_Happened THEN GOTO errmes + PRINT #12, "fornext_value" + u$ + "=" + e$ + ";" 'final e$ = fixoperationorder$(p2$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp + SCase$("To") + sp + tlayout$ e$ = evaluatetotyp(e$, ctyp) - If Error_Happened Then GoTo errmes - Print #12, "fornext_finalvalue" + u$ + "=" + e$ + ";" + IF Error_Happened THEN GOTO errmes + PRINT #12, "fornext_finalvalue" + u$ + "=" + e$ + ";" 'step e$ = fixoperationorder$(p3$) - If Error_Happened Then GoTo errmes - If stepused = 1 Then l$ = l$ + sp + SCase$("Step") + sp + tlayout$ + IF Error_Happened THEN GOTO errmes + IF stepused = 1 THEN l$ = l$ + sp + SCase$("Step") + sp + tlayout$ e$ = evaluatetotyp(e$, ctyp) - If Error_Happened Then GoTo errmes - Print #12, "fornext_step" + u$ + "=" + e$ + ";" - Print #12, "if (fornext_step" + u$ + "<0) fornext_step_negative" + u$ + "=1; else fornext_step_negative" + u$ + "=0;" + IF Error_Happened THEN GOTO errmes + PRINT #12, "fornext_step" + u$ + "=" + e$ + ";" + PRINT #12, "if (fornext_step" + u$ + "<0) fornext_step_negative" + u$ + "=1; else fornext_step_negative" + u$ + "=0;" - Print #12, "if (new_error) goto fornext_error" + u$ + ";" - Print #12, "goto fornext_entrylabel" + u$ + ";" - Print #12, "while(1){" + PRINT #12, "if (new_error) goto fornext_error" + u$ + ";" + PRINT #12, "goto fornext_entrylabel" + u$ + ";" + PRINT #12, "while(1){" typbak = typ - Print #12, "fornext_value" + u$ + "=fornext_step" + u$ + "+(" + refer$(v$, typ, 0) + ");" - If Error_Happened Then GoTo errmes + PRINT #12, "fornext_value" + u$ + "=fornext_step" + u$ + "+(" + refer$(v$, typ, 0) + ");" + IF Error_Happened THEN GOTO errmes typ = typbak - Print #12, "fornext_entrylabel" + u$ + ":" + PRINT #12, "fornext_entrylabel" + u$ + ":" setrefer v$, typ, "fornext_value" + u$, 1 - If Error_Happened Then GoTo errmes - Print #12, "if (fornext_step_negative" + u$ + "){" - Print #12, "if (fornext_value" + u$ + "fornext_finalvalue" + u$ + ") break;" - Print #12, "}" - Print #12, "fornext_error" + u$ + ":;" + IF Error_Happened THEN GOTO errmes + PRINT #12, "if (fornext_step_negative" + u$ + "){" + PRINT #12, "if (fornext_value" + u$ + "fornext_finalvalue" + u$ + ") break;" + PRINT #12, "}" + PRINT #12, "fornext_error" + u$ + ":;" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ - GoTo finishedline - End If - End If + GOTO finishedline + END IF + END IF - If n = 1 Then - If firstelement$ = "ELSE" Then + IF n = 1 THEN + IF firstelement$ = "ELSE" THEN 'Routine to add error checking for ELSE so we'll no longer be able to do things like the following: 'IF x = 1 THEN @@ -5678,99 +5678,99 @@ Do ' END SELECT ELSE y = 2 'END IF 'Notice the ELSE with the SELECT CASE? Before this patch, commands like those were considered valid QB64 code. - temp$ = UCase$(LTrim$(RTrim$(wholeline))) + temp$ = UCASE$(LTRIM$(RTRIM$(wholeline))) 'IF NoIDEMode THEN - Do While InStr(temp$, Chr$(9)) - Asc(temp$, InStr(temp$, Chr$(9))) = 32 - Loop + DO WHILE INSTR(temp$, CHR$(9)) + ASC(temp$, INSTR(temp$, CHR$(9))) = 32 + LOOP 'END IF goodelse = 0 'a check to see if it's a good else - If Left$(temp$, 2) = "IF" Then goodelse = -1: GoTo skipelsecheck 'If we have an IF, the else is probably good - If Left$(temp$, 4) = "ELSE" Then goodelse = -1: GoTo skipelsecheck 'If it's an else by itself,then we'll call it good too at this point and let the rest of the syntax checking check for us - Do - spacelocation = InStr(temp$, " ") - If spacelocation Then temp$ = Left$(temp$, spacelocation - 1) + Mid$(temp$, spacelocation + 1) - Loop Until spacelocation = 0 - If InStr(temp$, ":ELSE") Or InStr(temp$, ":IF") Then goodelse = -1: GoTo skipelsecheck 'I personally don't like the idea of a :ELSE statement, but this checks for that and validates it as well. YUCK! (I suppose this might be useful if there's a label where the ELSE is, like thisline: ELSE + IF LEFT$(temp$, 2) = "IF" THEN goodelse = -1: GOTO skipelsecheck 'If we have an IF, the else is probably good + IF LEFT$(temp$, 4) = "ELSE" THEN goodelse = -1: GOTO skipelsecheck 'If it's an else by itself,then we'll call it good too at this point and let the rest of the syntax checking check for us + DO + spacelocation = INSTR(temp$, " ") + IF spacelocation THEN temp$ = LEFT$(temp$, spacelocation - 1) + MID$(temp$, spacelocation + 1) + LOOP UNTIL spacelocation = 0 + IF INSTR(temp$, ":ELSE") OR INSTR(temp$, ":IF") THEN goodelse = -1: GOTO skipelsecheck 'I personally don't like the idea of a :ELSE statement, but this checks for that and validates it as well. YUCK! (I suppose this might be useful if there's a label where the ELSE is, like thisline: ELSE count = 0 - Do + DO count = count + 1 - Select Case Mid$(temp$, count, 1) - Case Is = "1", "2", "3", "4", "5", "6", "7", "8", "9", "0", ":" - Case Else: Exit Do - End Select - Loop Until count >= Len(temp$) - If Mid$(temp$, count, 4) = "ELSE" Or Mid$(temp$, count, 2) = "IF" Then goodelse = -1 'We only had numbers before our else - If Not goodelse Then a$ = "Invalid Syntax for ELSE": GoTo errmes + SELECT CASE MID$(temp$, count, 1) + CASE IS = "1", "2", "3", "4", "5", "6", "7", "8", "9", "0", ":" + CASE ELSE: EXIT DO + END SELECT + LOOP UNTIL count >= LEN(temp$) + IF MID$(temp$, count, 4) = "ELSE" OR MID$(temp$, count, 2) = "IF" THEN goodelse = -1 'We only had numbers before our else + IF NOT goodelse THEN a$ = "Invalid Syntax for ELSE": GOTO errmes skipelsecheck: 'End of ELSE Error checking - For i = controllevel To 1 Step -1 + FOR i = controllevel TO 1 STEP -1 t = controltype(i) - If t = 1 Then - If controlstate(controllevel) = 2 Then a$ = "IF-THEN already contains an ELSE statement": GoTo errmes - Print #12, "}else{" + IF t = 1 THEN + IF controlstate(controllevel) = 2 THEN a$ = "IF-THEN already contains an ELSE statement": GOTO errmes + PRINT #12, "}else{" controlstate(controllevel) = 2 - If lineelseused = 0 Then lhscontrollevel = lhscontrollevel - 1 + IF lineelseused = 0 THEN lhscontrollevel = lhscontrollevel - 1 l$ = SCase$("Else") - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishednonexec '***no error causing code, event checking done by IF*** - End If - Next - a$ = "ELSE without IF": GoTo errmes - End If - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishednonexec '***no error causing code, event checking done by IF*** + END IF + NEXT + a$ = "ELSE without IF": GOTO errmes + END IF + END IF - If n >= 3 Then - If firstelement$ = "ELSEIF" Then - If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1 + IF n >= 3 THEN + IF firstelement$ = "ELSEIF" THEN + IF NoChecks = 0 THEN PRINT #12, "S_" + str2$(statementn) + ":;": dynscope = 1 - For i = controllevel To 1 Step -1 + FOR i = controllevel TO 1 STEP -1 t = controltype(i) - If t = 1 Then - If controlstate(controllevel) = 2 Then a$ = "ELSEIF invalid after ELSE": GoTo errmes + IF t = 1 THEN + IF controlstate(controllevel) = 2 THEN a$ = "ELSEIF invalid after ELSE": GOTO errmes controlstate(controllevel) = 1 controlvalue(controllevel) = controlvalue(controllevel) + 1 e$ = getelement$(a$, n) - If e$ <> "THEN" Then a$ = "Expected ELSEIF expression THEN": GoTo errmes - Print #12, "}else{" + IF e$ <> "THEN" THEN a$ = "Expected ELSEIF expression THEN": GOTO errmes + PRINT #12, "}else{" e$ = fixoperationorder$(getelements$(ca$, 2, n - 1)) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = SCase$("ElseIf") + sp + tlayout$ + sp + SCase$("Then") - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ e$ = evaluate(e$, typ) - If Error_Happened Then GoTo errmes - If (typ And ISREFERENCE) Then e$ = refer$(e$, typ, 0) - If Error_Happened Then GoTo errmes - If typ And ISSTRING Then - a$ = "Expected ELSEIF LEN(stringexpression) THEN": GoTo errmes - End If - If stringprocessinghappened Then - Print #12, "if (" + cleanupstringprocessingcall$ + e$ + ")){" - Else - Print #12, "if (" + e$ + "){" - End If + IF Error_Happened THEN GOTO errmes + IF (typ AND ISREFERENCE) THEN e$ = refer$(e$, typ, 0) + IF Error_Happened THEN GOTO errmes + IF typ AND ISSTRING THEN + a$ = "Expected ELSEIF LEN(stringexpression) THEN": GOTO errmes + END IF + IF stringprocessinghappened THEN + PRINT #12, "if (" + cleanupstringprocessingcall$ + e$ + ")){" + ELSE + PRINT #12, "if (" + e$ + "){" + END IF lhscontrollevel = lhscontrollevel - 1 - GoTo finishedline - End If - Next - a$ = "ELSEIF without IF": GoTo errmes - End If - End If + GOTO finishedline + END IF + NEXT + a$ = "ELSEIF without IF": GOTO errmes + END IF + END IF - If n >= 3 Then - If firstelement$ = "IF" Then - If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1 + IF n >= 3 THEN + IF firstelement$ = "IF" THEN + IF NoChecks = 0 THEN PRINT #12, "S_" + str2$(statementn) + ":;": dynscope = 1 'prevents code from being placed before 'CASE condition' in a SELECT CASE block - If SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then - a$ = "Expected CASE expression": GoTo errmes - End If + IF SelectCaseCounter > 0 AND SelectCaseHasCaseBlock(SelectCaseCounter) = 0 THEN + a$ = "Expected CASE expression": GOTO errmes + END IF e$ = getelement(a$, n) iftype = 0 - If e$ = "THEN" Then iftype = 1 - If e$ = "GOTO" Then iftype = 2 - If iftype = 0 Then a$ = "Expected IF expression THEN/GOTO": GoTo errmes + IF e$ = "THEN" THEN iftype = 1 + IF e$ = "GOTO" THEN iftype = 2 + IF iftype = 0 THEN a$ = "Expected IF expression THEN/GOTO": GOTO errmes controllevel = controllevel + 1 controlref(controllevel) = linenumber @@ -5779,248 +5779,248 @@ Do controlstate(controllevel) = 0 e$ = fixoperationorder$(getelements(ca$, 2, n - 1)) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = SCase$("If") + sp + tlayout$ e$ = evaluate(e$, typ) - If Error_Happened Then GoTo errmes - If (typ And ISREFERENCE) Then e$ = refer$(e$, typ, 0) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes + IF (typ AND ISREFERENCE) THEN e$ = refer$(e$, typ, 0) + IF Error_Happened THEN GOTO errmes - If typ And ISSTRING Then - a$ = "Expected IF LEN(stringexpression) THEN": GoTo errmes - End If + IF typ AND ISSTRING THEN + a$ = "Expected IF LEN(stringexpression) THEN": GOTO errmes + END IF - If stringprocessinghappened Then - Print #12, "if ((" + cleanupstringprocessingcall$ + e$ + "))||new_error){" - Else - Print #12, "if ((" + e$ + ")||new_error){" - End If + IF stringprocessinghappened THEN + PRINT #12, "if ((" + cleanupstringprocessingcall$ + e$ + "))||new_error){" + ELSE + PRINT #12, "if ((" + e$ + ")||new_error){" + END IF - If iftype = 1 Then l$ = l$ + sp + SCase$("Then") 'note: 'GOTO' will be added when iftype=2 - layoutdone = 1: If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$ + IF iftype = 1 THEN l$ = l$ + sp + SCase$("Then") 'note: 'GOTO' will be added when iftype=2 + layoutdone = 1: IF LEN(layout$) = 0 THEN layout$ = l$ ELSE layout$ = layout$ + sp + l$ - If iftype = 2 Then 'IF ... GOTO - GoTo finishedline - End If + IF iftype = 2 THEN 'IF ... GOTO + GOTO finishedline + END IF THENGOTO = 1 'possible: IF a=1 THEN 10 - GoTo finishedline2 - End If - End If + GOTO finishedline2 + END IF + END IF 'ENDIF - If n = 1 And getelement(a$, 1) = "ENDIF" Then - If controltype(controllevel) <> 1 Then a$ = "END IF without IF": GoTo errmes + IF n = 1 AND getelement(a$, 1) = "ENDIF" THEN + IF controltype(controllevel) <> 1 THEN a$ = "END IF without IF": GOTO errmes layoutdone = 1 - If impliedendif = 0 Then + IF impliedendif = 0 THEN l$ = SCase$("End If") - If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$ - End If + IF LEN(layout$) = 0 THEN layout$ = l$ ELSE layout$ = layout$ + sp + l$ + END IF - Print #12, "}" - For i = 1 To controlvalue(controllevel) - Print #12, "}" - Next + PRINT #12, "}" + FOR i = 1 TO controlvalue(controllevel) + PRINT #12, "}" + NEXT controllevel = controllevel - 1 - GoTo finishednonexec '***no error causing code, event checking done by IF*** - End If + GOTO finishednonexec '***no error causing code, event checking done by IF*** + END IF 'END IF - If n = 2 Then - If getelement(a$, 1) = "END" And getelement(a$, 2) = "IF" Then + IF n = 2 THEN + IF getelement(a$, 1) = "END" AND getelement(a$, 2) = "IF" THEN - If controltype(controllevel) <> 1 Then a$ = "END IF without IF": GoTo errmes + IF controltype(controllevel) <> 1 THEN a$ = "END IF without IF": GOTO errmes layoutdone = 1 - If impliedendif = 0 Then + IF impliedendif = 0 THEN l$ = SCase$("End" + sp + "If") - If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$ - End If + IF LEN(layout$) = 0 THEN layout$ = l$ ELSE layout$ = layout$ + sp + l$ + END IF - Print #12, "}" - For i = 1 To controlvalue(controllevel) - Print #12, "}" - Next + PRINT #12, "}" + FOR i = 1 TO controlvalue(controllevel) + PRINT #12, "}" + NEXT controllevel = controllevel - 1 - GoTo finishednonexec '***no error causing code, event checking done by IF*** - End If - End If + GOTO finishednonexec '***no error causing code, event checking done by IF*** + END IF + END IF 'SELECT CASE - If n >= 1 Then - If firstelement$ = "SELECT" Then - If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1 + IF n >= 1 THEN + IF firstelement$ = "SELECT" THEN + IF NoChecks = 0 THEN PRINT #12, "S_" + str2$(statementn) + ":;": dynscope = 1 'prevents code from being placed before 'CASE condition' in a SELECT CASE block - If SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then - a$ = "Expected CASE expression": GoTo errmes - End If + IF SelectCaseCounter > 0 AND SelectCaseHasCaseBlock(SelectCaseCounter) = 0 THEN + a$ = "Expected CASE expression": GOTO errmes + END IF SelectCaseCounter = SelectCaseCounter + 1 - If UBound(EveryCaseSet) <= SelectCaseCounter Then ReDim _Preserve EveryCaseSet(SelectCaseCounter) - If UBound(SelectCaseHasCaseBlock) <= SelectCaseCounter Then ReDim _Preserve SelectCaseHasCaseBlock(SelectCaseCounter) + IF UBOUND(EveryCaseSet) <= SelectCaseCounter THEN REDIM _PRESERVE EveryCaseSet(SelectCaseCounter) + IF UBOUND(SelectCaseHasCaseBlock) <= SelectCaseCounter THEN REDIM _PRESERVE SelectCaseHasCaseBlock(SelectCaseCounter) SelectCaseHasCaseBlock(SelectCaseCounter) = 0 - If secondelement$ = "EVERYCASE" Then + IF secondelement$ = "EVERYCASE" THEN EveryCaseSet(SelectCaseCounter) = -1 - If n = 2 Then a$ = "Expected SELECT CASE expression": GoTo errmes + IF n = 2 THEN a$ = "Expected SELECT CASE expression": GOTO errmes e$ = fixoperationorder(getelements$(ca$, 3, n)) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = SCase$("Select EveryCase ") + tlayout$ - Else + ELSE EveryCaseSet(SelectCaseCounter) = 0 - If n = 1 Or secondelement$ <> "CASE" Then a$ = "Expected CASE or EVERYCASE": GoTo errmes - If n = 2 Then a$ = "Expected SELECT CASE expression": GoTo errmes + IF n = 1 OR secondelement$ <> "CASE" THEN a$ = "Expected CASE or EVERYCASE": GOTO errmes + IF n = 2 THEN a$ = "Expected SELECT CASE expression": GOTO errmes e$ = fixoperationorder(getelements$(ca$, 3, n)) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = SCase$("Select Case ") + tlayout$ - End If + END IF - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ e$ = evaluate(e$, typ) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes u = uniquenumber controllevel = controllevel + 1 controlvalue(controllevel) = 0 'id t$ = "" - If (typ And ISSTRING) Then + IF (typ AND ISSTRING) THEN t = 0 - If (typ And ISUDT) = 0 And (typ And ISARRAY) = 0 And (typ And ISREFERENCE) <> 0 Then - controlvalue(controllevel) = Val(e$) - Else - If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0) - If Error_Happened Then GoTo errmes - Print #13, "static qbs *sc_" + str2$(u) + "=qbs_new(0,0);" - Print #12, "qbs_set(sc_" + str2$(u) + "," + e$ + ");" - If stringprocessinghappened Then Print #12, cleanupstringprocessingcall$ + "0);" - End If + IF (typ AND ISUDT) = 0 AND (typ AND ISARRAY) = 0 AND (typ AND ISREFERENCE) <> 0 THEN + controlvalue(controllevel) = VAL(e$) + ELSE + IF (typ AND ISREFERENCE) THEN e$ = refer(e$, typ, 0) + IF Error_Happened THEN GOTO errmes + PRINT #13, "static qbs *sc_" + str2$(u) + "=qbs_new(0,0);" + PRINT #12, "qbs_set(sc_" + str2$(u) + "," + e$ + ");" + IF stringprocessinghappened THEN PRINT #12, cleanupstringprocessingcall$ + "0);" + END IF - Else + ELSE - If (typ And ISFLOAT) Then + IF (typ AND ISFLOAT) THEN - If (typ And 511) > 64 Then t = 3: t$ = "long double" - If (typ And 511) = 32 Then t = 4: t$ = "float" - If (typ And 511) = 64 Then t = 5: t$ = "double" - If (typ And ISUDT) = 0 And (typ And ISARRAY) = 0 And (typ And ISREFERENCE) <> 0 Then - controlvalue(controllevel) = Val(e$) - Else - If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0) - If Error_Happened Then GoTo errmes + IF (typ AND 511) > 64 THEN t = 3: t$ = "long double" + IF (typ AND 511) = 32 THEN t = 4: t$ = "float" + IF (typ AND 511) = 64 THEN t = 5: t$ = "double" + IF (typ AND ISUDT) = 0 AND (typ AND ISARRAY) = 0 AND (typ AND ISREFERENCE) <> 0 THEN + controlvalue(controllevel) = VAL(e$) + ELSE + IF (typ AND ISREFERENCE) THEN e$ = refer(e$, typ, 0) + IF Error_Happened THEN GOTO errmes - Print #13, "static " + t$ + " sc_" + str2$(u) + ";" - Print #12, "sc_" + str2$(u) + "=" + e$ + ";" - If stringprocessinghappened Then Print #12, cleanupstringprocessingcall$ + "0);" - End If + PRINT #13, "static " + t$ + " sc_" + str2$(u) + ";" + PRINT #12, "sc_" + str2$(u) + "=" + e$ + ";" + IF stringprocessinghappened THEN PRINT #12, cleanupstringprocessingcall$ + "0);" + END IF - Else + ELSE 'non-float t = 1: t$ = "int64" - If (typ And ISUNSIGNED) Then - If (typ And 511) <= 32 Then t = 7: t$ = "uint32" - If (typ And 511) > 32 Then t = 2: t$ = "uint64" - Else - If (typ And 511) <= 32 Then t = 6: t$ = "int32" - If (typ And 511) > 32 Then t = 1: t$ = "int64" - End If - If (typ And ISUDT) = 0 And (typ And ISARRAY) = 0 And (typ And ISREFERENCE) <> 0 Then - controlvalue(controllevel) = Val(e$) - Else - If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0) - If Error_Happened Then GoTo errmes - Print #13, "static " + t$ + " sc_" + str2$(u) + ";" - Print #12, "sc_" + str2$(u) + "=" + e$ + ";" - If stringprocessinghappened Then Print #12, cleanupstringprocessingcall$ + "0);" - End If + IF (typ AND ISUNSIGNED) THEN + IF (typ AND 511) <= 32 THEN t = 7: t$ = "uint32" + IF (typ AND 511) > 32 THEN t = 2: t$ = "uint64" + ELSE + IF (typ AND 511) <= 32 THEN t = 6: t$ = "int32" + IF (typ AND 511) > 32 THEN t = 1: t$ = "int64" + END IF + IF (typ AND ISUDT) = 0 AND (typ AND ISARRAY) = 0 AND (typ AND ISREFERENCE) <> 0 THEN + controlvalue(controllevel) = VAL(e$) + ELSE + IF (typ AND ISREFERENCE) THEN e$ = refer(e$, typ, 0) + IF Error_Happened THEN GOTO errmes + PRINT #13, "static " + t$ + " sc_" + str2$(u) + ";" + PRINT #12, "sc_" + str2$(u) + "=" + e$ + ";" + IF stringprocessinghappened THEN PRINT #12, cleanupstringprocessingcall$ + "0);" + END IF - End If - End If + END IF + END IF controlref(controllevel) = linenumber controltype(controllevel) = 10 + t controlid(controllevel) = u - If EveryCaseSet(SelectCaseCounter) Then Print #13, "int32 sc_" + str2$(controlid(controllevel)) + "_var;" - If EveryCaseSet(SelectCaseCounter) Then Print #12, "sc_" + str2$(controlid(controllevel)) + "_var=0;" - GoTo finishedline - End If - End If + IF EveryCaseSet(SelectCaseCounter) THEN PRINT #13, "int32 sc_" + str2$(controlid(controllevel)) + "_var;" + IF EveryCaseSet(SelectCaseCounter) THEN PRINT #12, "sc_" + str2$(controlid(controllevel)) + "_var=0;" + GOTO finishedline + END IF + END IF 'END SELECT - If n = 2 Then - If firstelement$ = "END" And secondelement$ = "SELECT" Then + IF n = 2 THEN + IF firstelement$ = "END" AND secondelement$ = "SELECT" THEN 'complete current case if necessary '18=CASE (awaiting END SELECT/CASE/CASE ELSE) '19=CASE ELSE (awaiting END SELECT) - If controltype(controllevel) = 18 Then + IF controltype(controllevel) = 18 THEN everycasenewcase = everycasenewcase + 1 - Print #12, "sc_ec_" + str2$(everycasenewcase) + "_end:;" + PRINT #12, "sc_ec_" + str2$(everycasenewcase) + "_end:;" controllevel = controllevel - 1 - If EveryCaseSet(SelectCaseCounter) = 0 Then Print #12, "goto sc_" + str2$(controlid(controllevel)) + "_end;" - Print #12, "}" - End If - If controltype(controllevel) = 19 Then + IF EveryCaseSet(SelectCaseCounter) = 0 THEN PRINT #12, "goto sc_" + str2$(controlid(controllevel)) + "_end;" + PRINT #12, "}" + END IF + IF controltype(controllevel) = 19 THEN controllevel = controllevel - 1 - If EveryCaseSet(SelectCaseCounter) Then Print #12, "} /* End of SELECT EVERYCASE ELSE */" - End If - Print #12, "sc_" + str2$(controlid(controllevel)) + "_end:;" - If controltype(controllevel) < 10 Or controltype(controllevel) > 17 Then a$ = "END SELECT without SELECT CASE": GoTo errmes + IF EveryCaseSet(SelectCaseCounter) THEN PRINT #12, "} /* End of SELECT EVERYCASE ELSE */" + END IF + PRINT #12, "sc_" + str2$(controlid(controllevel)) + "_end:;" + IF controltype(controllevel) < 10 OR controltype(controllevel) > 17 THEN a$ = "END SELECT without SELECT CASE": GOTO errmes - If SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then + IF SelectCaseCounter > 0 AND SelectCaseHasCaseBlock(SelectCaseCounter) = 0 THEN 'warn user of empty SELECT CASE block - If Not IgnoreWarnings Then + IF NOT IgnoreWarnings THEN addWarning linenumber, inclevel, inclinenumber(inclevel), incname$(inclevel), "empty SELECT CASE block", "" - End If - End If + END IF + END IF controllevel = controllevel - 1 SelectCaseCounter = SelectCaseCounter - 1 l$ = SCase$("End" + sp + "Select") - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishednonexec '***no error causing code, event checking done by SELECT CASE*** - End If - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishednonexec '***no error causing code, event checking done by SELECT CASE*** + END IF + END IF 'prevents code from being placed before 'CASE condition' in a SELECT CASE block - If n >= 1 And firstelement$ <> "CASE" And SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then - a$ = "Expected CASE expression": GoTo errmes - End If + IF n >= 1 AND firstelement$ <> "CASE" AND SelectCaseCounter > 0 AND SelectCaseHasCaseBlock(SelectCaseCounter) = 0 THEN + a$ = "Expected CASE expression": GOTO errmes + END IF 'CASE - If n >= 1 Then - If firstelement$ = "CASE" Then + IF n >= 1 THEN + IF firstelement$ = "CASE" THEN l$ = SCase$("Case") 'complete current case if necessary '18=CASE (awaiting END SELECT/CASE/CASE ELSE) '19=CASE ELSE (awaiting END SELECT) - If controltype(controllevel) = 19 Then a$ = "Expected END SELECT": GoTo errmes - If controltype(controllevel) = 18 Then + IF controltype(controllevel) = 19 THEN a$ = "Expected END SELECT": GOTO errmes + IF controltype(controllevel) = 18 THEN lhscontrollevel = lhscontrollevel - 1 controllevel = controllevel - 1 everycasenewcase = everycasenewcase + 1 - Print #12, "sc_ec_" + str2$(everycasenewcase) + "_end:;" - If EveryCaseSet(SelectCaseCounter) = 0 Then - Print #12, "goto sc_" + str2$(controlid(controllevel)) + "_end;" - Else - Print #12, "sc_" + str2$(controlid(controllevel)) + "_var=-1;" - End If - Print #12, "}" + PRINT #12, "sc_ec_" + str2$(everycasenewcase) + "_end:;" + IF EveryCaseSet(SelectCaseCounter) = 0 THEN + PRINT #12, "goto sc_" + str2$(controlid(controllevel)) + "_end;" + ELSE + PRINT #12, "sc_" + str2$(controlid(controllevel)) + "_var=-1;" + END IF + PRINT #12, "}" 'following line fixes problem related to RESUME after error 'statementn = statementn + 1 'if nochecks=0 then PRINT #12, "S_" + str2$(statementn) + ":;" - End If + END IF - If controltype(controllevel) <> 6 And (controltype(controllevel) < 10 Or controltype(controllevel) > 17) Then a$ = "CASE without SELECT CASE": GoTo errmes - If n = 1 Then a$ = "Expected CASE expression": GoTo errmes + IF controltype(controllevel) <> 6 AND (controltype(controllevel) < 10 OR controltype(controllevel) > 17) THEN a$ = "CASE without SELECT CASE": GOTO errmes + IF n = 1 THEN a$ = "Expected CASE expression": GOTO errmes SelectCaseHasCaseBlock(SelectCaseCounter) = -1 @@ -6057,35 +6057,35 @@ Do t = controltype(controllevel) - 10 'get required type cast, and float options flt = 0 - If t = 0 Then tc$ = "" - If t = 1 Then tc$ = "" - If t = 2 Then tc$ = "" - If t = 3 Then tc$ = "": flt = 1 - If t = 4 Then tc$ = "(float)": flt = 1 - If t = 5 Then tc$ = "(double)": flt = 1 - If t = 6 Then tc$ = "" - If t = 7 Then tc$ = "" + IF t = 0 THEN tc$ = "" + IF t = 1 THEN tc$ = "" + IF t = 2 THEN tc$ = "" + IF t = 3 THEN tc$ = "": flt = 1 + IF t = 4 THEN tc$ = "(float)": flt = 1 + IF t = 5 THEN tc$ = "(double)": flt = 1 + IF t = 6 THEN tc$ = "" + IF t = 7 THEN tc$ = "" n$ = "sc_" + str2$(controlid(controllevel)) cv = controlvalue(controllevel) - If cv Then + IF cv THEN n$ = refer$(str2$(cv), 0, 0) - If Error_Happened Then GoTo errmes - End If + IF Error_Happened THEN GOTO errmes + END IF 'CASE ELSE - If n = 2 Then - If getelement$(a$, 2) = "C-EL" Then - If EveryCaseSet(SelectCaseCounter) Then Print #12, "if (sc_" + str2$(controlid(controllevel)) + "_var==0) {" + IF n = 2 THEN + IF getelement$(a$, 2) = "C-EL" THEN + IF EveryCaseSet(SelectCaseCounter) THEN PRINT #12, "if (sc_" + str2$(controlid(controllevel)) + "_var==0) {" controllevel = controllevel + 1: controltype(controllevel) = 19 controlref(controllevel) = controlref(controllevel - 1) l$ = l$ + sp + SCase$("Else") - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishednonexec '***no error causing code, event checking done by SELECT CASE*** - End If - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishednonexec '***no error causing code, event checking done by SELECT CASE*** + END IF + END IF - If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1 + IF NoChecks = 0 THEN PRINT #12, "S_" + str2$(statementn) + ":;": dynscope = 1 @@ -6094,15 +6094,15 @@ Do nexp = 0 B = 0 e$ = "" - For i = 2 To n + FOR i = 2 TO n e2$ = getelement$(ca$, i) - If e2$ = "(" Then B = B + 1 - If e2$ = ")" Then B = B - 1 - If i = n Then e$ = e$ + sp + e2$ - If i = n Or (e2$ = "," And B = 0) Then - If nexp <> 0 Then l$ = l$ + sp2 + ",": f12$ = f12$ + "||" - If e$ = "" Then a$ = "Expected expression": GoTo errmes - e$ = Right$(e$, Len(e$) - 1) + IF e2$ = "(" THEN B = B + 1 + IF e2$ = ")" THEN B = B - 1 + IF i = n THEN e$ = e$ + sp + e2$ + IF i = n OR (e2$ = "," AND B = 0) THEN + IF nexp <> 0 THEN l$ = l$ + sp2 + ",": f12$ = f12$ + "||" + IF e$ = "" THEN a$ = "Expected expression": GOTO errmes + e$ = RIGHT$(e$, LEN(e$) - 1) @@ -6111,49 +6111,49 @@ Do b2 = 0 el$ = "": er$ = "" usedto = 0 - For i2 = 1 To n2 + FOR i2 = 1 TO n2 e3$ = getelement$(e$, i2) - If e3$ = "(" Then b2 = b2 + 1 - If e3$ = ")" Then b2 = b2 - 1 - If b2 = 0 And UCase$(e3$) = "TO" Then + IF e3$ = "(" THEN b2 = b2 + 1 + IF e3$ = ")" THEN b2 = b2 - 1 + IF b2 = 0 AND UCASE$(e3$) = "TO" THEN usedto = 1 - Else - If usedto = 0 Then el$ = el$ + sp + e3$ Else er$ = er$ + sp + e3$ - End If - Next - If usedto = 1 Then - If el$ = "" Or er$ = "" Then a$ = "Expected expression TO expression": GoTo errmes - el$ = Right$(el$, Len(el$) - 1): er$ = Right$(er$, Len(er$) - 1) + ELSE + IF usedto = 0 THEN el$ = el$ + sp + e3$ ELSE er$ = er$ + sp + e3$ + END IF + NEXT + IF usedto = 1 THEN + IF el$ = "" OR er$ = "" THEN a$ = "Expected expression TO expression": GOTO errmes + el$ = RIGHT$(el$, LEN(el$) - 1): er$ = RIGHT$(er$, LEN(er$) - 1) 'evaluate each side - For i2 = 1 To 2 - If i2 = 1 Then e$ = el$ Else e$ = er$ + FOR i2 = 1 TO 2 + IF i2 = 1 THEN e$ = el$ ELSE e$ = er$ e$ = fixoperationorder(e$) - If Error_Happened Then GoTo errmes - If i2 = 1 Then l$ = l$ + sp + tlayout$ Else l$ = l$ + sp + SCase$("TO") + sp + tlayout$ + IF Error_Happened THEN GOTO errmes + IF i2 = 1 THEN l$ = l$ + sp + tlayout$ ELSE l$ = l$ + sp + SCase$("TO") + sp + tlayout$ e$ = evaluate(e$, typ) - If Error_Happened Then GoTo errmes - If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0) - If Error_Happened Then GoTo errmes - If t = 0 Then - If (typ And ISSTRING) = 0 Then a$ = "Expected string expression": GoTo errmes - If i2 = 1 Then f12$ = f12$ + "(qbs_greaterorequal(" + n$ + "," + e$ + ")&&qbs_lessorequal(" + n$ + "," - If i2 = 2 Then f12$ = f12$ + e$ + "))" - Else - If (typ And ISSTRING) Then a$ = "Expected numeric expression": GoTo errmes + IF Error_Happened THEN GOTO errmes + IF (typ AND ISREFERENCE) THEN e$ = refer(e$, typ, 0) + IF Error_Happened THEN GOTO errmes + IF t = 0 THEN + IF (typ AND ISSTRING) = 0 THEN a$ = "Expected string expression": GOTO errmes + IF i2 = 1 THEN f12$ = f12$ + "(qbs_greaterorequal(" + n$ + "," + e$ + ")&&qbs_lessorequal(" + n$ + "," + IF i2 = 2 THEN f12$ = f12$ + e$ + "))" + ELSE + IF (typ AND ISSTRING) THEN a$ = "Expected numeric expression": GOTO errmes 'round to integer? - If (typ And ISFLOAT) Then - If t = 1 Then e$ = "qbr(" + e$ + ")" - If t = 2 Then e$ = "qbr_longdouble_to_uint64(" + e$ + ")" - If t = 6 Or t = 7 Then e$ = "qbr_double_to_long(" + e$ + ")" - End If + IF (typ AND ISFLOAT) THEN + IF t = 1 THEN e$ = "qbr(" + e$ + ")" + IF t = 2 THEN e$ = "qbr_longdouble_to_uint64(" + e$ + ")" + IF t = 6 OR t = 7 THEN e$ = "qbr_double_to_long(" + e$ + ")" + END IF 'cast result? - If Len(tc$) Then e$ = tc$ + "(" + e$ + ")" - If i2 = 1 Then f12$ = f12$ + "((" + n$ + ">=(" + e$ + "))&&(" + n$ + "<=(" - If i2 = 2 Then f12$ = f12$ + e$ + ")))" - End If - Next - GoTo addedexp - End If + IF LEN(tc$) THEN e$ = tc$ + "(" + e$ + ")" + IF i2 = 1 THEN f12$ = f12$ + "((" + n$ + ">=(" + e$ + "))&&(" + n$ + "<=(" + IF i2 = 2 THEN f12$ = f12$ + e$ + ")))" + END IF + NEXT + GOTO addedexp + END IF '10=SELECT CASE qbs (awaiting END SELECT/CASE) '11=SELECT CASE int64 (awaiting END SELECT/CASE) @@ -6178,83 +6178,83 @@ Do 'TYPE 2? x$ = getelement$(e$, 1) - If isoperator(x$) Then 'non-standard usage correction - If x$ = "=" Or x$ = "<>" Or x$ = ">" Or x$ = "<" Or x$ = ">=" Or x$ = "<=" Then + IF isoperator(x$) THEN 'non-standard usage correction + IF x$ = "=" OR x$ = "<>" OR x$ = ">" OR x$ = "<" OR x$ = ">=" OR x$ = "<=" THEN e$ = "IS" + sp + e$ x$ = "IS" - End If - End If - If UCase$(x$) = "IS" Then + END IF + END IF + IF UCASE$(x$) = "IS" THEN n2 = numelements(e$) - If n2 < 3 Then a$ = "Expected IS =,<>,>,<,>=,<= expression": GoTo errmes + IF n2 < 3 THEN a$ = "Expected IS =,<>,>,<,>=,<= expression": GOTO errmes o$ = getelement$(e$, 2) o2$ = o$ o = 0 - If o$ = "=" Then o$ = "==": o = 1 - If o$ = "<>" Then o$ = "!=": o = 1 - If o$ = ">" Then o = 1 - If o$ = "<" Then o = 1 - If o$ = ">=" Then o = 1 - If o$ = "<=" Then o = 1 - If o <> 1 Then a$ = "Expected IS =,<>,>,<,>=,<= expression": GoTo errmes + IF o$ = "=" THEN o$ = "==": o = 1 + IF o$ = "<>" THEN o$ = "!=": o = 1 + IF o$ = ">" THEN o = 1 + IF o$ = "<" THEN o = 1 + IF o$ = ">=" THEN o = 1 + IF o$ = "<=" THEN o = 1 + IF o <> 1 THEN a$ = "Expected IS =,<>,>,<,>=,<= expression": GOTO errmes l$ = l$ + sp + SCase$("Is") + sp + o2$ e$ = getelements$(e$, 3, n2) 'fall through to type 3 using modified e$ & o$ - End If + END IF 'TYPE 3? simple expression e$ = fixoperationorder(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp + tlayout$ e$ = evaluate(e$, typ) - If Error_Happened Then GoTo errmes - If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0) - If Error_Happened Then GoTo errmes - If t = 0 Then + IF Error_Happened THEN GOTO errmes + IF (typ AND ISREFERENCE) THEN e$ = refer(e$, typ, 0) + IF Error_Happened THEN GOTO errmes + IF t = 0 THEN 'string comparison - If (typ And ISSTRING) = 0 Then a$ = "Expected string expression": GoTo errmes - If o$ = "==" Then o$ = "qbs_equal" - If o$ = "!=" Then o$ = "qbs_notequal" - If o$ = ">" Then o$ = "qbs_greaterthan" - If o$ = "<" Then o$ = "qbs_lessthan" - If o$ = ">=" Then o$ = "qbs_greaterorequal" - If o$ = "<=" Then o$ = "qbs_lessorequal" + IF (typ AND ISSTRING) = 0 THEN a$ = "Expected string expression": GOTO errmes + IF o$ = "==" THEN o$ = "qbs_equal" + IF o$ = "!=" THEN o$ = "qbs_notequal" + IF o$ = ">" THEN o$ = "qbs_greaterthan" + IF o$ = "<" THEN o$ = "qbs_lessthan" + IF o$ = ">=" THEN o$ = "qbs_greaterorequal" + IF o$ = "<=" THEN o$ = "qbs_lessorequal" f12$ = f12$ + o$ + "(" + n$ + "," + e$ + ")" - Else + ELSE 'numeric - If (typ And ISSTRING) Then a$ = "Expected numeric expression": GoTo errmes + IF (typ AND ISSTRING) THEN a$ = "Expected numeric expression": GOTO errmes 'round to integer? - If (typ And ISFLOAT) Then - If t = 1 Then e$ = "qbr(" + e$ + ")" - If t = 2 Then e$ = "qbr_longdouble_to_uint64(" + e$ + ")" - If t = 6 Or t = 7 Then e$ = "qbr_double_to_long(" + e$ + ")" - End If + IF (typ AND ISFLOAT) THEN + IF t = 1 THEN e$ = "qbr(" + e$ + ")" + IF t = 2 THEN e$ = "qbr_longdouble_to_uint64(" + e$ + ")" + IF t = 6 OR t = 7 THEN e$ = "qbr_double_to_long(" + e$ + ")" + END IF 'cast result? - If Len(tc$) Then e$ = tc$ + "(" + e$ + ")" + IF LEN(tc$) THEN e$ = tc$ + "(" + e$ + ")" f12$ = f12$ + "(" + n$ + o$ + "(" + e$ + "))" - End If + END IF addedexp: e$ = "" nexp = nexp + 1 - Else + ELSE e$ = e$ + sp + e2$ - End If - Next + END IF + NEXT - If stringprocessinghappened Then - Print #12, "if ((" + cleanupstringprocessingcall$ + f12$ + "))||new_error){" - Else - Print #12, "if ((" + f12$ + ")||new_error){" - End If + IF stringprocessinghappened THEN + PRINT #12, "if ((" + cleanupstringprocessingcall$ + f12$ + "))||new_error){" + ELSE + PRINT #12, "if ((" + f12$ + ")||new_error){" + END IF - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ controllevel = controllevel + 1 controlref(controllevel) = controlref(controllevel - 1) controltype(controllevel) = 18 - GoTo finishedline - End If - End If + GOTO finishedline + END IF + END IF @@ -6269,208 +6269,208 @@ Do 'static scope commands: - If NoChecks = 0 Then - Print #12, "do{" + IF NoChecks = 0 THEN + PRINT #12, "do{" 'PRINT #12, "S_" + str2$(statementn) + ":;" - End If + END IF - If n > 1 Then - If firstelement$ = "PALETTE" Then - If secondelement$ = "USING" Then + IF n > 1 THEN + IF firstelement$ = "PALETTE" THEN + IF secondelement$ = "USING" THEN l$ = SCase$("Palette" + sp + "Using" + sp) - If n < 3 Then a$ = "Expected PALETTE USING array-name": GoTo errmes + IF n < 3 THEN a$ = "Expected PALETTE USING array-name": GOTO errmes 'check array e$ = getelement$(ca$, 3) - If FindArray(e$) Then - If Error_Happened Then GoTo errmes + IF FindArray(e$) THEN + IF Error_Happened THEN GOTO errmes z = 1 t = id.arraytype - If (t And 511) <> 16 And (t And 511) <> 32 Then z = 0 - If t And ISFLOAT Then z = 0 - If t And ISOFFSETINBITS Then z = 0 - If t And ISSTRING Then z = 0 - If t And ISUDT Then z = 0 - If t And ISUNSIGNED Then z = 0 - If z = 0 Then a$ = "Array must be of type INTEGER or LONG": GoTo errmes - bits = t And 511 - GoTo pu_gotarray - End If - If Error_Happened Then GoTo errmes - a$ = "Expected PALETTE USING array-name": GoTo errmes + IF (t AND 511) <> 16 AND (t AND 511) <> 32 THEN z = 0 + IF t AND ISFLOAT THEN z = 0 + IF t AND ISOFFSETINBITS THEN z = 0 + IF t AND ISSTRING THEN z = 0 + IF t AND ISUDT THEN z = 0 + IF t AND ISUNSIGNED THEN z = 0 + IF z = 0 THEN a$ = "Array must be of type INTEGER or LONG": GOTO errmes + bits = t AND 511 + GOTO pu_gotarray + END IF + IF Error_Happened THEN GOTO errmes + a$ = "Expected PALETTE USING array-name": GOTO errmes pu_gotarray: 'add () if index not specified - If n = 3 Then + IF n = 3 THEN e$ = e$ + sp + "(" + sp + ")" - Else - If n = 4 Or getelement$(a$, 4) <> "(" Or getelement$(a$, n) <> ")" Then a$ = "Expected PALETTE USING array-name(...)": GoTo errmes + ELSE + IF n = 4 OR getelement$(a$, 4) <> "(" OR getelement$(a$, n) <> ")" THEN a$ = "Expected PALETTE USING array-name(...)": GOTO errmes e$ = e$ + sp + getelements$(ca$, 4, n) - End If + END IF e$ = fixoperationorder$(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + tlayout$ e$ = evaluatetotyp(e$, -2) - If Error_Happened Then GoTo errmes - Print #12, "sub_paletteusing(" + e$ + "," + str2(bits) + ");" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If 'using - End If 'palette - End If 'n>1 + IF Error_Happened THEN GOTO errmes + PRINT #12, "sub_paletteusing(" + e$ + "," + str2(bits) + ");" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF 'using + END IF 'palette + END IF 'n>1 - If firstelement$ = "KEY" Then - If n = 1 Then a$ = "Expected KEY ...": GoTo errmes + IF firstelement$ = "KEY" THEN + IF n = 1 THEN a$ = "Expected KEY ...": GOTO errmes l$ = SCase$("KEY") + sp - If secondelement$ = "OFF" Then - If n > 2 Then a$ = "Expected KEY OFF only": GoTo errmes - l$ = l$ + SCase$("Off"): layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - Print #12, "key_off();" - GoTo finishedline - End If - If secondelement$ = "ON" Then - If n > 2 Then a$ = "Expected KEY ON only": GoTo errmes - l$ = l$ + SCase$("On"): layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - Print #12, "key_on();" - GoTo finishedline - End If - If secondelement$ = "LIST" Then - If n > 2 Then a$ = "Expected KEY LIST only": GoTo errmes - l$ = l$ + SCase$("List"): layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - Print #12, "key_list();" - GoTo finishedline - End If + IF secondelement$ = "OFF" THEN + IF n > 2 THEN a$ = "Expected KEY OFF only": GOTO errmes + l$ = l$ + SCase$("Off"): layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + PRINT #12, "key_off();" + GOTO finishedline + END IF + IF secondelement$ = "ON" THEN + IF n > 2 THEN a$ = "Expected KEY ON only": GOTO errmes + l$ = l$ + SCase$("On"): layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + PRINT #12, "key_on();" + GOTO finishedline + END IF + IF secondelement$ = "LIST" THEN + IF n > 2 THEN a$ = "Expected KEY LIST only": GOTO errmes + l$ = l$ + SCase$("List"): layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + PRINT #12, "key_list();" + GOTO finishedline + END IF 'search for comma to indicate assignment B = 0: e$ = "" - For i = 2 To n + FOR i = 2 TO n e2$ = getelement(ca$, i) - If e2$ = "(" Then B = B + 1 - If e2$ = ")" Then B = B - 1 - If e2$ = "," And B = 0 Then - i = i + 1: GoTo key_assignment - End If - If Len(e$) Then e$ = e$ + sp + e2$ Else e$ = e2$ - Next + IF e2$ = "(" THEN B = B + 1 + IF e2$ = ")" THEN B = B - 1 + IF e2$ = "," AND B = 0 THEN + i = i + 1: GOTO key_assignment + END IF + IF LEN(e$) THEN e$ = e$ + sp + e2$ ELSE e$ = e2$ + NEXT 'assume KEY(x) ON/OFF/STOP and handle as a sub - GoTo key_fallthrough + GOTO key_fallthrough key_assignment: 'KEY x, "string" 'index e$ = fixoperationorder(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + tlayout$ + sp2 + "," + sp e$ = evaluatetotyp(e$, 32&) - If Error_Happened Then GoTo errmes - Print #12, "key_assign(" + e$ + ","; + IF Error_Happened THEN GOTO errmes + PRINT #12, "key_assign(" + e$ + ","; 'string e$ = getelements$(ca$, i, n) e$ = fixoperationorder(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + tlayout$ e$ = evaluatetotyp(e$, ISSTRING) - If Error_Happened Then GoTo errmes - Print #12, e$ + ");" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If 'KEY + IF Error_Happened THEN GOTO errmes + PRINT #12, e$ + ");" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF 'KEY key_fallthrough: - If firstelement$ = "FIELD" Then + IF firstelement$ = "FIELD" THEN 'get filenumber B = 0: e$ = "" - For i = 2 To n + FOR i = 2 TO n e2$ = getelement(ca$, i) - If e2$ = "(" Then B = B + 1 - If e2$ = ")" Then B = B - 1 - If e2$ = "," And B = 0 Then - i = i + 1: GoTo fieldgotfn - End If - If Len(e$) Then e$ = e$ + sp + e2$ Else e$ = e2$ - Next - GoTo fielderror + IF e2$ = "(" THEN B = B + 1 + IF e2$ = ")" THEN B = B - 1 + IF e2$ = "," AND B = 0 THEN + i = i + 1: GOTO fieldgotfn + END IF + IF LEN(e$) THEN e$ = e$ + sp + e2$ ELSE e$ = e2$ + NEXT + GOTO fielderror fieldgotfn: - If e$ = "#" Or Len(e$) = 0 Then GoTo fielderror - If Left$(e$, 2) = "#" + sp Then e$ = Right$(e$, Len(e$) - 2): l$ = SCase$("Field") + sp + "#" + sp2 Else l$ = SCase$("Field") + sp + IF e$ = "#" OR LEN(e$) = 0 THEN GOTO fielderror + IF LEFT$(e$, 2) = "#" + sp THEN e$ = RIGHT$(e$, LEN(e$) - 2): l$ = SCase$("Field") + sp + "#" + sp2 ELSE l$ = SCase$("Field") + sp e$ = fixoperationorder(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + tlayout$ + sp2 + "," + sp e$ = evaluatetotyp(e$, 32&) - If Error_Happened Then GoTo errmes - Print #12, "field_new(" + e$ + ");" + IF Error_Happened THEN GOTO errmes + PRINT #12, "field_new(" + e$ + ");" fieldnext: 'get fieldwidth - If i > n Then GoTo fielderror + IF i > n THEN GOTO fielderror B = 0: e$ = "" - For i = i To n + FOR i = i TO n e2$ = getelement(ca$, i) - If e2$ = "(" Then B = B + 1 - If e2$ = ")" Then B = B - 1 - If UCase$(e2$) = "AS" And B = 0 Then - i = i + 1: GoTo fieldgotfw - End If - If Len(e$) Then e$ = e$ + sp + e2$ Else e$ = e2$ - Next - GoTo fielderror + IF e2$ = "(" THEN B = B + 1 + IF e2$ = ")" THEN B = B - 1 + IF UCASE$(e2$) = "AS" AND B = 0 THEN + i = i + 1: GOTO fieldgotfw + END IF + IF LEN(e$) THEN e$ = e$ + sp + e2$ ELSE e$ = e2$ + NEXT + GOTO fielderror fieldgotfw: - If Len(e$) = 0 Then GoTo fielderror + IF LEN(e$) = 0 THEN GOTO fielderror e$ = fixoperationorder(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + tlayout$ + sp + SCase$("As") + sp sizee$ = evaluatetotyp(e$, 32&) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes 'get variable name - If i > n Then GoTo fielderror + IF i > n THEN GOTO fielderror B = 0: e$ = "" - For i = i To n + FOR i = i TO n e2$ = getelement(ca$, i) - If e2$ = "(" Then B = B + 1 - If e2$ = ")" Then B = B - 1 - If (i = n Or e2$ = ",") And B = 0 Then - If e2$ = "," Then i = i - 1 - If i = n Then - If Len(e$) Then e$ = e$ + sp + e2$ Else e$ = e2$ - End If - GoTo fieldgotfname - End If - If Len(e$) Then e$ = e$ + sp + e2$ Else e$ = e2$ - Next - GoTo fielderror + IF e2$ = "(" THEN B = B + 1 + IF e2$ = ")" THEN B = B - 1 + IF (i = n OR e2$ = ",") AND B = 0 THEN + IF e2$ = "," THEN i = i - 1 + IF i = n THEN + IF LEN(e$) THEN e$ = e$ + sp + e2$ ELSE e$ = e2$ + END IF + GOTO fieldgotfname + END IF + IF LEN(e$) THEN e$ = e$ + sp + e2$ ELSE e$ = e2$ + NEXT + GOTO fielderror fieldgotfname: - If Len(e$) = 0 Then GoTo fielderror + IF LEN(e$) = 0 THEN GOTO fielderror 'evaluate it to check it is a STRING e$ = fixoperationorder(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + tlayout$ e$ = evaluate(e$, typ) - If Error_Happened Then GoTo errmes - If (typ And ISSTRING) = 0 Then GoTo fielderror - If typ And ISFIXEDLENGTH Then a$ = "Fixed length strings cannot be used in a FIELD statement": GoTo errmes - If (typ And ISREFERENCE) = 0 Then GoTo fielderror + IF Error_Happened THEN GOTO errmes + IF (typ AND ISSTRING) = 0 THEN GOTO fielderror + IF typ AND ISFIXEDLENGTH THEN a$ = "Fixed length strings cannot be used in a FIELD statement": GOTO errmes + IF (typ AND ISREFERENCE) = 0 THEN GOTO fielderror e$ = refer(e$, typ, 0) - If Error_Happened Then GoTo errmes - Print #12, "field_add(" + e$ + "," + sizee$ + ");" + IF Error_Happened THEN GOTO errmes + PRINT #12, "field_add(" + e$ + "," + sizee$ + ");" - If i < n Then + IF i < n THEN i = i + 1 e$ = getelement(a$, i) - If e$ <> "," Then a$ = "Expected ,": GoTo errmes + IF e$ <> "," THEN a$ = "Expected ,": GOTO errmes l$ = l$ + sp2 + "," + sp i = i + 1 - GoTo fieldnext - End If + GOTO fieldnext + END IF - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline - fielderror: a$ = "Expected FIELD #filenumber, characters AS variable$, ...": GoTo errmes - End If + fielderror: a$ = "Expected FIELD #filenumber, characters AS variable$, ...": GOTO errmes + END IF @@ -6482,87 +6482,87 @@ Do '4=DO WHILE/UNTIL (awaiting LOOP) '5=WHILE (awaiting WEND) - If n = 2 Then - If firstelement$ = "EXIT" Then + IF n = 2 THEN + IF firstelement$ = "EXIT" THEN l$ = SCase$("Exit") + sp - If secondelement$ = "DO" Then + IF secondelement$ = "DO" THEN 'scan backwards until previous control level reached l$ = l$ + SCase$("Do") - For i = controllevel To 1 Step -1 + FOR i = controllevel TO 1 STEP -1 t = controltype(i) - If t = 3 Or t = 4 Then - Print #12, "goto dl_exit_" + str2$(controlid(i)) + ";" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - Next - a$ = "EXIT DO without DO": GoTo errmes - End If + IF t = 3 OR t = 4 THEN + PRINT #12, "goto dl_exit_" + str2$(controlid(i)) + ";" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + NEXT + a$ = "EXIT DO without DO": GOTO errmes + END IF - If secondelement$ = "FOR" Then + IF secondelement$ = "FOR" THEN 'scan backwards until previous control level reached l$ = l$ + SCase$("For") - For i = controllevel To 1 Step -1 + FOR i = controllevel TO 1 STEP -1 t = controltype(i) - If t = 2 Then - Print #12, "goto fornext_exit_" + str2$(controlid(i)) + ";" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - Next - a$ = "EXIT FOR without FOR": GoTo errmes - End If + IF t = 2 THEN + PRINT #12, "goto fornext_exit_" + str2$(controlid(i)) + ";" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + NEXT + a$ = "EXIT FOR without FOR": GOTO errmes + END IF - If secondelement$ = "WHILE" Then + IF secondelement$ = "WHILE" THEN 'scan backwards until previous control level reached l$ = l$ + SCase$("While") - For i = controllevel To 1 Step -1 + FOR i = controllevel TO 1 STEP -1 t = controltype(i) - If t = 5 Then - Print #12, "goto ww_exit_" + str2$(controlid(i)) + ";" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - Next - a$ = "EXIT WHILE without WHILE": GoTo errmes - End If + IF t = 5 THEN + PRINT #12, "goto ww_exit_" + str2$(controlid(i)) + ";" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + NEXT + a$ = "EXIT WHILE without WHILE": GOTO errmes + END IF - If secondelement$ = "SELECT" Then + IF secondelement$ = "SELECT" THEN 'scan backwards until previous control level reached l$ = l$ + SCase$("Select") - For i = controllevel To 1 Step -1 + FOR i = controllevel TO 1 STEP -1 t = controltype(i) - If t = 18 Or t = 19 Then 'CASE/CASE ELSE - Print #12, "goto sc_" + str2$(controlid(i - 1)) + "_end;" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - Next - a$ = "EXIT SELECT without SELECT": GoTo errmes - End If + IF t = 18 OR t = 19 THEN 'CASE/CASE ELSE + PRINT #12, "goto sc_" + str2$(controlid(i - 1)) + "_end;" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + NEXT + a$ = "EXIT SELECT without SELECT": GOTO errmes + END IF - If secondelement$ = "CASE" Then + IF secondelement$ = "CASE" THEN 'scan backwards until previous control level reached l$ = l$ + SCase$("Case") - For i = controllevel To 1 Step -1 + FOR i = controllevel TO 1 STEP -1 t = controltype(i) - If t = 18 Then 'CASE - Print #12, "goto sc_ec_" + str2$(everycasenewcase + 1) + "_end;" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - ElseIf t = 19 Then 'CASE ELSE - Print #12, "goto sc_" + str2$(controlid(i - 1)) + "_end;" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - Next - a$ = "EXIT CASE without CASE": GoTo errmes - End If + IF t = 18 THEN 'CASE + PRINT #12, "goto sc_ec_" + str2$(everycasenewcase + 1) + "_end;" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + ELSEIF t = 19 THEN 'CASE ELSE + PRINT #12, "goto sc_" + str2$(controlid(i - 1)) + "_end;" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + NEXT + a$ = "EXIT CASE without CASE": GOTO errmes + END IF - End If - End If + END IF + END IF @@ -6571,101 +6571,101 @@ Do - If n >= 2 Then - If firstelement$ = "ON" And secondelement$ = "STRIG" Then + IF n >= 2 THEN + IF firstelement$ = "ON" AND secondelement$ = "STRIG" THEN DEPENDENCY(DEPENDENCY_DEVICEINPUT) = 1 i = 3 - If i > n Then a$ = "Expected (": GoTo errmes + IF i > n THEN a$ = "Expected (": GOTO errmes a2$ = getelement$(ca$, i): i = i + 1 - If a2$ <> "(" Then a$ = "Expected (": GoTo errmes + IF a2$ <> "(" THEN a$ = "Expected (": GOTO errmes l$ = SCase$("On" + sp + "Strig" + sp2 + "(") - If i > n Then a$ = "Expected ...": GoTo errmes + IF i > n THEN a$ = "Expected ...": GOTO errmes B = 0 x = 0 e2$ = "" e3$ = "" - For i = i To n + FOR i = i TO n e$ = getelement$(ca$, i) - a = Asc(e$) - If a = 40 Then B = B + 1 - If a = 41 Then B = B - 1 - If B = -1 Then GoTo onstriggotarg - If a = 44 And B = 0 Then + a = ASC(e$) + IF a = 40 THEN B = B + 1 + IF a = 41 THEN B = B - 1 + IF B = -1 THEN GOTO onstriggotarg + IF a = 44 AND B = 0 THEN x = x + 1 - If x > 1 Then a$ = "Expected )": GoTo errmes - If e2$ = "" Then a$ = "Expected ... ,": GoTo errmes + IF x > 1 THEN a$ = "Expected )": GOTO errmes + IF e2$ = "" THEN a$ = "Expected ... ,": GOTO errmes e3$ = e2$ e2$ = "" - Else - If Len(e2$) Then e2$ = e2$ + sp + e$ Else e2$ = e$ - End If - Next - a$ = "Expected )": GoTo errmes + ELSE + IF LEN(e2$) THEN e2$ = e2$ + sp + e$ ELSE e2$ = e$ + END IF + NEXT + a$ = "Expected )": GOTO errmes onstriggotarg: - If e2$ = "" Then a$ = "Expected ... )": GoTo errmes - Print #12, "onstrig_setup("; + IF e2$ = "" THEN a$ = "Expected ... )": GOTO errmes + PRINT #12, "onstrig_setup("; 'sort scanned results - If Len(e3$) Then + IF LEN(e3$) THEN optI$ = e3$ optController$ = e2$ optPassed$ = "1" - Else + ELSE optI$ = e2$ optController$ = "0" optPassed$ = "0" - End If + END IF 'i - e$ = fixoperationorder$(optI$): If Error_Happened Then GoTo errmes + e$ = fixoperationorder$(optI$): IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + tlayout$ - e$ = evaluatetotyp(e$, 32&): If Error_Happened Then GoTo errmes - Print #12, e$ + ","; + e$ = evaluatetotyp(e$, 32&): IF Error_Happened THEN GOTO errmes + PRINT #12, e$ + ","; 'controller , passed - If optPassed$ = "1" Then - e$ = fixoperationorder$(optController$): If Error_Happened Then GoTo errmes + IF optPassed$ = "1" THEN + e$ = fixoperationorder$(optController$): IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ - e$ = evaluatetotyp(e$, 32&): If Error_Happened Then GoTo errmes - Else + e$ = evaluatetotyp(e$, 32&): IF Error_Happened THEN GOTO errmes + ELSE e$ = optController$ - End If - Print #12, e$ + "," + optPassed$ + ","; + END IF + PRINT #12, e$ + "," + optPassed$ + ","; l$ = l$ + sp2 + ")" + sp 'close brackets i = i + 1 - If i > n Then a$ = "Expected GOSUB/sub-name": GoTo errmes + IF i > n THEN a$ = "Expected GOSUB/sub-name": GOTO errmes a2$ = getelement$(a$, i): i = i + 1 onstrigid = onstrigid + 1 - Print #12, str2$(onstrigid) + ","; + PRINT #12, str2$(onstrigid) + ","; - If a2$ = "GOSUB" Then - If i > n Then a$ = "Expected linenumber/label": GoTo errmes + IF a2$ = "GOSUB" THEN + IF i > n THEN a$ = "Expected linenumber/label": GOTO errmes a2$ = getelement$(ca$, i): i = i + 1 - Print #12, "0);" + PRINT #12, "0);" - If validlabel(a2$) = 0 Then a$ = "Invalid label": GoTo errmes + IF validlabel(a2$) = 0 THEN a$ = "Invalid label": GOTO errmes v = HashFind(a2$, HASHFLAG_LABEL, ignore, r) x = 1 labchk60z: - If v Then + IF v THEN s = Labels(r).Scope - If s = 0 Or s = -1 Then 'main scope? - If s = -1 Then Labels(r).Scope = 0 'acquire scope + IF s = 0 OR s = -1 THEN 'main scope? + IF s = -1 THEN Labels(r).Scope = 0 'acquire scope x = 0 'already defined - tlayout$ = RTrim$(Labels(r).cn) + tlayout$ = RTRIM$(Labels(r).cn) Labels(r).Scope_Restriction = subfuncn Labels(r).Error_Line = linenumber - Else - If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk60z - End If - End If - If x Then + ELSE + IF v = 2 THEN v = HashFindCont(ignore, r): GOTO labchk60z + END IF + END IF + IF x THEN 'does not exist - nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type + nLabels = nLabels + 1: IF nLabels > Labels_Ubound THEN Labels_Ubound = Labels_Ubound * 2: REDIM _PRESERVE Labels(1 TO Labels_Ubound) AS Label_Type Labels(nLabels) = Empty_Label HashAdd a2$, HASHFLAG_LABEL, nLabels r = nLabels @@ -6674,83 +6674,83 @@ Do Labels(r).Scope = 0 Labels(r).Error_Line = linenumber Labels(r).Scope_Restriction = subfuncn - End If 'x + END IF 'x l$ = l$ + SCase$("GoSub") + sp + tlayout$ - Print #30, "if(strig_event_id==" + str2$(onstrigid) + ")goto LABEL_" + a2$ + ";" + PRINT #30, "if(strig_event_id==" + str2$(onstrigid) + ")goto LABEL_" + a2$ + ";" - Print #29, "case " + str2$(onstrigid) + ":" - Print #29, "strig_event_occurred++;" - Print #29, "strig_event_id=" + str2$(onstrigid) + ";" - Print #29, "strig_event_occurred++;" - Print #29, "return_point[next_return_point++]=0;" - Print #29, "if (next_return_point>=return_points) more_return_points();" - Print #29, "QBMAIN(NULL);" - Print #29, "break;" + PRINT #29, "case " + str2$(onstrigid) + ":" + PRINT #29, "strig_event_occurred++;" + PRINT #29, "strig_event_id=" + str2$(onstrigid) + ";" + PRINT #29, "strig_event_occurred++;" + PRINT #29, "return_point[next_return_point++]=0;" + PRINT #29, "if (next_return_point>=return_points) more_return_points();" + PRINT #29, "QBMAIN(NULL);" + PRINT #29, "break;" - If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$ + IF LEN(layout$) = 0 THEN layout$ = l$ ELSE layout$ = layout$ + sp + l$ layoutdone = 1 - GoTo finishedline + GOTO finishedline - Else + ELSE 'establish whether sub a2$ exists using try x = 0 try = findid(a2$) - If Error_Happened Then GoTo errmes - Do While try - If id.subfunc = 2 Then x = 1: Exit Do - If try = 2 Then findanotherid = 1: try = findid(a2$) Else try = 0 - If Error_Happened Then GoTo errmes - Loop - If x = 0 Then a$ = "Expected GOSUB/sub": GoTo errmes + IF Error_Happened THEN GOTO errmes + DO WHILE try + IF id.subfunc = 2 THEN x = 1: EXIT DO + IF try = 2 THEN findanotherid = 1: try = findid(a2$) ELSE try = 0 + IF Error_Happened THEN GOTO errmes + LOOP + IF x = 0 THEN a$ = "Expected GOSUB/sub": GOTO errmes - l$ = l$ + RTrim$(id.cn) + l$ = l$ + RTRIM$(id.cn) - Print #29, "case " + str2$(onstrigid) + ":" - Print #29, RTrim$(id.callname) + "("; + PRINT #29, "case " + str2$(onstrigid) + ":" + PRINT #29, RTRIM$(id.callname) + "("; - If id.args > 1 Then a$ = "SUB requires more than one argument": GoTo errmes + IF id.args > 1 THEN a$ = "SUB requires more than one argument": GOTO errmes - If i > n Then + IF i > n THEN - If id.args = 1 Then a$ = "Expected argument after SUB": GoTo errmes - Print #12, "0);" - Print #29, ");" + IF id.args = 1 THEN a$ = "Expected argument after SUB": GOTO errmes + PRINT #12, "0);" + PRINT #29, ");" - Else + ELSE - If id.args = 0 Then a$ = "SUB has no arguments": GoTo errmes + IF id.args = 0 THEN a$ = "SUB has no arguments": GOTO errmes t = CVL(id.arg) - B = t And 511 - If B = 0 Or (t And ISARRAY) <> 0 Or (t And ISFLOAT) <> 0 Or (t And ISSTRING) <> 0 Or (t And ISOFFSETINBITS) <> 0 Then a$ = "Only SUB arguments of integer-type allowed": GoTo errmes - If B = 8 Then ct$ = "int8" - If B = 16 Then ct$ = "int16" - If B = 32 Then ct$ = "int32" - If B = 64 Then ct$ = "int64" - If t And ISOFFSET Then ct$ = "ptrszint" - If t And ISUNSIGNED Then ct$ = "u" + ct$ - Print #29, "(" + ct$ + "*)&i64);" + B = t AND 511 + IF B = 0 OR (t AND ISARRAY) <> 0 OR (t AND ISFLOAT) <> 0 OR (t AND ISSTRING) <> 0 OR (t AND ISOFFSETINBITS) <> 0 THEN a$ = "Only SUB arguments of integer-type allowed": GOTO errmes + IF B = 8 THEN ct$ = "int8" + IF B = 16 THEN ct$ = "int16" + IF B = 32 THEN ct$ = "int32" + IF B = 64 THEN ct$ = "int64" + IF t AND ISOFFSET THEN ct$ = "ptrszint" + IF t AND ISUNSIGNED THEN ct$ = "u" + ct$ + PRINT #29, "(" + ct$ + "*)&i64);" e$ = getelements$(ca$, i, n) e$ = fixoperationorder$(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp + tlayout$ e$ = evaluatetotyp(e$, INTEGER64TYPE - ISPOINTER) - If Error_Happened Then GoTo errmes - Print #12, e$ + ");" + IF Error_Happened THEN GOTO errmes + PRINT #12, e$ + ");" - End If + END IF - Print #29, "break;" - If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$ + PRINT #29, "break;" + IF LEN(layout$) = 0 THEN layout$ = l$ ELSE layout$ = layout$ + sp + l$ layoutdone = 1 - GoTo finishedline - End If + GOTO finishedline + END IF - End If - End If + END IF + END IF @@ -6763,89 +6763,89 @@ Do - If n >= 2 Then - If firstelement$ = "ON" And secondelement$ = "TIMER" Then + IF n >= 2 THEN + IF firstelement$ = "ON" AND secondelement$ = "TIMER" THEN i = 3 - If i > n Then a$ = "Expected (": GoTo errmes + IF i > n THEN a$ = "Expected (": GOTO errmes a2$ = getelement$(ca$, i): i = i + 1 - If a2$ <> "(" Then a$ = "Expected (": GoTo errmes + IF a2$ <> "(" THEN a$ = "Expected (": GOTO errmes l$ = SCase$("On" + sp + "Timer" + sp2 + "(") - If i > n Then a$ = "Expected ...": GoTo errmes + IF i > n THEN a$ = "Expected ...": GOTO errmes B = 0 x = 0 e2$ = "" e3$ = "" - For i = i To n + FOR i = i TO n e$ = getelement$(ca$, i) - a = Asc(e$) - If a = 40 Then B = B + 1 - If a = 41 Then B = B - 1 - If B = -1 Then GoTo ontimgotarg - If a = 44 And B = 0 Then + a = ASC(e$) + IF a = 40 THEN B = B + 1 + IF a = 41 THEN B = B - 1 + IF B = -1 THEN GOTO ontimgotarg + IF a = 44 AND B = 0 THEN x = x + 1 - If x > 1 Then a$ = "Expected )": GoTo errmes - If e2$ = "" Then a$ = "Expected ... ,": GoTo errmes + IF x > 1 THEN a$ = "Expected )": GOTO errmes + IF e2$ = "" THEN a$ = "Expected ... ,": GOTO errmes e3$ = e2$ e2$ = "" - Else - If Len(e2$) Then e2$ = e2$ + sp + e$ Else e2$ = e$ - End If - Next - a$ = "Expected )": GoTo errmes + ELSE + IF LEN(e2$) THEN e2$ = e2$ + sp + e$ ELSE e2$ = e$ + END IF + NEXT + a$ = "Expected )": GOTO errmes ontimgotarg: - If e2$ = "" Then a$ = "Expected ... )": GoTo errmes - Print #12, "ontimer_setup("; + IF e2$ = "" THEN a$ = "Expected ... )": GOTO errmes + PRINT #12, "ontimer_setup("; 'i - If Len(e3$) Then + IF LEN(e3$) THEN e$ = fixoperationorder$(e3$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + tlayout$ + "," + sp e$ = evaluatetotyp(e$, 32&) - If Error_Happened Then GoTo errmes - Print #12, e$ + ","; - Else - Print #12, "0,"; + IF Error_Happened THEN GOTO errmes + PRINT #12, e$ + ","; + ELSE + PRINT #12, "0,"; l$ = l$ + sp2 - End If + END IF 'sec e$ = fixoperationorder$(e2$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + tlayout$ + sp2 + ")" + sp e$ = evaluatetotyp(e$, DOUBLETYPE - ISPOINTER) - If Error_Happened Then GoTo errmes - Print #12, e$ + ","; + IF Error_Happened THEN GOTO errmes + PRINT #12, e$ + ","; i = i + 1 - If i > n Then a$ = "Expected GOSUB/sub-name": GoTo errmes + IF i > n THEN a$ = "Expected GOSUB/sub-name": GOTO errmes a2$ = getelement$(a$, i): i = i + 1 ontimerid = ontimerid + 1 - Print #12, str2$(ontimerid) + ","; + PRINT #12, str2$(ontimerid) + ","; - If a2$ = "GOSUB" Then - If i > n Then a$ = "Expected linenumber/label": GoTo errmes + IF a2$ = "GOSUB" THEN + IF i > n THEN a$ = "Expected linenumber/label": GOTO errmes a2$ = getelement$(ca$, i): i = i + 1 - Print #12, "0);" + PRINT #12, "0);" - If validlabel(a2$) = 0 Then a$ = "Invalid label": GoTo errmes + IF validlabel(a2$) = 0 THEN a$ = "Invalid label": GOTO errmes v = HashFind(a2$, HASHFLAG_LABEL, ignore, r) x = 1 labchk60: - If v Then + IF v THEN s = Labels(r).Scope - If s = 0 Or s = -1 Then 'main scope? - If s = -1 Then Labels(r).Scope = 0 'acquire scope + IF s = 0 OR s = -1 THEN 'main scope? + IF s = -1 THEN Labels(r).Scope = 0 'acquire scope x = 0 'already defined - tlayout$ = RTrim$(Labels(r).cn) + tlayout$ = RTRIM$(Labels(r).cn) Labels(r).Scope_Restriction = subfuncn Labels(r).Error_Line = linenumber - Else - If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk60 - End If - End If - If x Then + ELSE + IF v = 2 THEN v = HashFindCont(ignore, r): GOTO labchk60 + END IF + END IF + IF x THEN 'does not exist - nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type + nLabels = nLabels + 1: IF nLabels > Labels_Ubound THEN Labels_Ubound = Labels_Ubound * 2: REDIM _PRESERVE Labels(1 TO Labels_Ubound) AS Label_Type Labels(nLabels) = Empty_Label HashAdd a2$, HASHFLAG_LABEL, nLabels r = nLabels @@ -6854,19 +6854,19 @@ Do Labels(r).Scope = 0 Labels(r).Error_Line = linenumber Labels(r).Scope_Restriction = subfuncn - End If 'x + END IF 'x l$ = l$ + SCase$("GoSub") + sp + tlayout$ - Print #25, "if(timer_event_id==" + str2$(ontimerid) + ")goto LABEL_" + a2$ + ";" + PRINT #25, "if(timer_event_id==" + str2$(ontimerid) + ")goto LABEL_" + a2$ + ";" - Print #24, "case " + str2$(ontimerid) + ":" - Print #24, "timer_event_occurred++;" - Print #24, "timer_event_id=" + str2$(ontimerid) + ";" - Print #24, "timer_event_occurred++;" - Print #24, "return_point[next_return_point++]=0;" - Print #24, "if (next_return_point>=return_points) more_return_points();" - Print #24, "QBMAIN(NULL);" - Print #24, "break;" + PRINT #24, "case " + str2$(ontimerid) + ":" + PRINT #24, "timer_event_occurred++;" + PRINT #24, "timer_event_id=" + str2$(ontimerid) + ";" + PRINT #24, "timer_event_occurred++;" + PRINT #24, "return_point[next_return_point++]=0;" + PRINT #24, "if (next_return_point>=return_points) more_return_points();" + PRINT #24, "QBMAIN(NULL);" + PRINT #24, "break;" @@ -6876,135 +6876,135 @@ Do 'etc. - If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$ + IF LEN(layout$) = 0 THEN layout$ = l$ ELSE layout$ = layout$ + sp + l$ layoutdone = 1 - GoTo finishedline - Else + GOTO finishedline + ELSE 'establish whether sub a2$ exists using try x = 0 try = findid(a2$) - If Error_Happened Then GoTo errmes - Do While try - If id.subfunc = 2 Then x = 1: Exit Do - If try = 2 Then findanotherid = 1: try = findid(a2$) Else try = 0 - If Error_Happened Then GoTo errmes - Loop - If x = 0 Then a$ = "Expected GOSUB/sub": GoTo errmes + IF Error_Happened THEN GOTO errmes + DO WHILE try + IF id.subfunc = 2 THEN x = 1: EXIT DO + IF try = 2 THEN findanotherid = 1: try = findid(a2$) ELSE try = 0 + IF Error_Happened THEN GOTO errmes + LOOP + IF x = 0 THEN a$ = "Expected GOSUB/sub": GOTO errmes - l$ = l$ + RTrim$(id.cn) + l$ = l$ + RTRIM$(id.cn) - Print #24, "case " + str2$(ontimerid) + ":" - Print #24, RTrim$(id.callname) + "("; + PRINT #24, "case " + str2$(ontimerid) + ":" + PRINT #24, RTRIM$(id.callname) + "("; - If id.args > 1 Then a$ = "SUB requires more than one argument": GoTo errmes + IF id.args > 1 THEN a$ = "SUB requires more than one argument": GOTO errmes - If i > n Then + IF i > n THEN - If id.args = 1 Then a$ = "Expected argument after SUB": GoTo errmes - Print #12, "0);" - Print #24, ");" + IF id.args = 1 THEN a$ = "Expected argument after SUB": GOTO errmes + PRINT #12, "0);" + PRINT #24, ");" - Else + ELSE - If id.args = 0 Then a$ = "SUB has no arguments": GoTo errmes + IF id.args = 0 THEN a$ = "SUB has no arguments": GOTO errmes t = CVL(id.arg) - B = t And 511 - If B = 0 Or (t And ISARRAY) <> 0 Or (t And ISFLOAT) <> 0 Or (t And ISSTRING) <> 0 Or (t And ISOFFSETINBITS) <> 0 Then a$ = "Only SUB arguments of integer-type allowed": GoTo errmes - If B = 8 Then ct$ = "int8" - If B = 16 Then ct$ = "int16" - If B = 32 Then ct$ = "int32" - If B = 64 Then ct$ = "int64" - If t And ISOFFSET Then ct$ = "ptrszint" - If t And ISUNSIGNED Then ct$ = "u" + ct$ - Print #24, "(" + ct$ + "*)&i64);" + B = t AND 511 + IF B = 0 OR (t AND ISARRAY) <> 0 OR (t AND ISFLOAT) <> 0 OR (t AND ISSTRING) <> 0 OR (t AND ISOFFSETINBITS) <> 0 THEN a$ = "Only SUB arguments of integer-type allowed": GOTO errmes + IF B = 8 THEN ct$ = "int8" + IF B = 16 THEN ct$ = "int16" + IF B = 32 THEN ct$ = "int32" + IF B = 64 THEN ct$ = "int64" + IF t AND ISOFFSET THEN ct$ = "ptrszint" + IF t AND ISUNSIGNED THEN ct$ = "u" + ct$ + PRINT #24, "(" + ct$ + "*)&i64);" e$ = getelements$(ca$, i, n) e$ = fixoperationorder$(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp + tlayout$ e$ = evaluatetotyp(e$, INTEGER64TYPE - ISPOINTER) - If Error_Happened Then GoTo errmes - Print #12, e$ + ");" + IF Error_Happened THEN GOTO errmes + PRINT #12, e$ + ");" - End If + END IF - Print #24, "break;" - If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$ + PRINT #24, "break;" + IF LEN(layout$) = 0 THEN layout$ = l$ ELSE layout$ = layout$ + sp + l$ layoutdone = 1 - GoTo finishedline - End If + GOTO finishedline + END IF - End If - End If + END IF + END IF - If n >= 2 Then - If firstelement$ = "ON" And secondelement$ = "KEY" Then + IF n >= 2 THEN + IF firstelement$ = "ON" AND secondelement$ = "KEY" THEN i = 3 - If i > n Then a$ = "Expected (": GoTo errmes + IF i > n THEN a$ = "Expected (": GOTO errmes a2$ = getelement$(ca$, i): i = i + 1 - If a2$ <> "(" Then a$ = "Expected (": GoTo errmes + IF a2$ <> "(" THEN a$ = "Expected (": GOTO errmes l$ = SCase$("On" + sp + "Key" + sp2 + "(") - If i > n Then a$ = "Expected ...": GoTo errmes + IF i > n THEN a$ = "Expected ...": GOTO errmes B = 0 x = 0 e2$ = "" - For i = i To n + FOR i = i TO n e$ = getelement$(ca$, i) - a = Asc(e$) + a = ASC(e$) - If a = 40 Then B = B + 1 - If a = 41 Then B = B - 1 - If B = -1 Then Exit For - If Len(e2$) Then e2$ = e2$ + sp + e$ Else e2$ = e$ - Next - If i = n + 1 Then a$ = "Expected )": GoTo errmes - If e2$ = "" Then a$ = "Expected ... )": GoTo errmes + IF a = 40 THEN B = B + 1 + IF a = 41 THEN B = B - 1 + IF B = -1 THEN EXIT FOR + IF LEN(e2$) THEN e2$ = e2$ + sp + e$ ELSE e2$ = e$ + NEXT + IF i = n + 1 THEN a$ = "Expected )": GOTO errmes + IF e2$ = "" THEN a$ = "Expected ... )": GOTO errmes e$ = fixoperationorder$(e2$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + tlayout$ + sp2 + ")" + sp e$ = evaluatetotyp(e$, DOUBLETYPE - ISPOINTER) - If Error_Happened Then GoTo errmes - Print #12, "onkey_setup(" + e$ + ","; + IF Error_Happened THEN GOTO errmes + PRINT #12, "onkey_setup(" + e$ + ","; i = i + 1 - If i > n Then a$ = "Expected GOSUB/sub-name": GoTo errmes + IF i > n THEN a$ = "Expected GOSUB/sub-name": GOTO errmes a2$ = getelement$(a$, i): i = i + 1 onkeyid = onkeyid + 1 - Print #12, str2$(onkeyid) + ","; + PRINT #12, str2$(onkeyid) + ","; - If a2$ = "GOSUB" Then - If i > n Then a$ = "Expected linenumber/label": GoTo errmes + IF a2$ = "GOSUB" THEN + IF i > n THEN a$ = "Expected linenumber/label": GOTO errmes a2$ = getelement$(ca$, i): i = i + 1 - Print #12, "0);" + PRINT #12, "0);" - If validlabel(a2$) = 0 Then a$ = "Invalid label": GoTo errmes + IF validlabel(a2$) = 0 THEN a$ = "Invalid label": GOTO errmes v = HashFind(a2$, HASHFLAG_LABEL, ignore, r) x = 1 labchk61: - If v Then + IF v THEN s = Labels(r).Scope - If s = 0 Or s = -1 Then 'main scope? - If s = -1 Then Labels(r).Scope = 0 'acquire scope + IF s = 0 OR s = -1 THEN 'main scope? + IF s = -1 THEN Labels(r).Scope = 0 'acquire scope x = 0 'already defined - tlayout$ = RTrim$(Labels(r).cn) + tlayout$ = RTRIM$(Labels(r).cn) Labels(r).Scope_Restriction = subfuncn Labels(r).Error_Line = linenumber - Else - If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk61 - End If - End If - If x Then + ELSE + IF v = 2 THEN v = HashFindCont(ignore, r): GOTO labchk61 + END IF + END IF + IF x THEN 'does not exist - nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type + nLabels = nLabels + 1: IF nLabels > Labels_Ubound THEN Labels_Ubound = Labels_Ubound * 2: REDIM _PRESERVE Labels(1 TO Labels_Ubound) AS Label_Type Labels(nLabels) = Empty_Label HashAdd a2$, HASHFLAG_LABEL, nLabels r = nLabels @@ -7013,82 +7013,82 @@ Do Labels(r).Scope = 0 Labels(r).Error_Line = linenumber Labels(r).Scope_Restriction = subfuncn - End If 'x + END IF 'x l$ = l$ + SCase$("GoSub") + sp + tlayout$ - Print #28, "if(key_event_id==" + str2$(onkeyid) + ")goto LABEL_" + a2$ + ";" + PRINT #28, "if(key_event_id==" + str2$(onkeyid) + ")goto LABEL_" + a2$ + ";" - Print #27, "case " + str2$(onkeyid) + ":" - Print #27, "key_event_occurred++;" - Print #27, "key_event_id=" + str2$(onkeyid) + ";" - Print #27, "key_event_occurred++;" - Print #27, "return_point[next_return_point++]=0;" - Print #27, "if (next_return_point>=return_points) more_return_points();" - Print #27, "QBMAIN(NULL);" - Print #27, "break;" + PRINT #27, "case " + str2$(onkeyid) + ":" + PRINT #27, "key_event_occurred++;" + PRINT #27, "key_event_id=" + str2$(onkeyid) + ";" + PRINT #27, "key_event_occurred++;" + PRINT #27, "return_point[next_return_point++]=0;" + PRINT #27, "if (next_return_point>=return_points) more_return_points();" + PRINT #27, "QBMAIN(NULL);" + PRINT #27, "break;" - If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$ + IF LEN(layout$) = 0 THEN layout$ = l$ ELSE layout$ = layout$ + sp + l$ layoutdone = 1 - GoTo finishedline - Else + GOTO finishedline + ELSE 'establish whether sub a2$ exists using try x = 0 try = findid(a2$) - If Error_Happened Then GoTo errmes - Do While try - If id.subfunc = 2 Then x = 1: Exit Do - If try = 2 Then findanotherid = 1: try = findid(a2$) Else try = 0 - If Error_Happened Then GoTo errmes - Loop - If x = 0 Then a$ = "Expected GOSUB/sub": GoTo errmes + IF Error_Happened THEN GOTO errmes + DO WHILE try + IF id.subfunc = 2 THEN x = 1: EXIT DO + IF try = 2 THEN findanotherid = 1: try = findid(a2$) ELSE try = 0 + IF Error_Happened THEN GOTO errmes + LOOP + IF x = 0 THEN a$ = "Expected GOSUB/sub": GOTO errmes - l$ = l$ + RTrim$(id.cn) + l$ = l$ + RTRIM$(id.cn) - Print #27, "case " + str2$(onkeyid) + ":" - Print #27, RTrim$(id.callname) + "("; + PRINT #27, "case " + str2$(onkeyid) + ":" + PRINT #27, RTRIM$(id.callname) + "("; - If id.args > 1 Then a$ = "SUB requires more than one argument": GoTo errmes + IF id.args > 1 THEN a$ = "SUB requires more than one argument": GOTO errmes - If i > n Then + IF i > n THEN - If id.args = 1 Then a$ = "Expected argument after SUB": GoTo errmes - Print #12, "0);" - Print #27, ");" + IF id.args = 1 THEN a$ = "Expected argument after SUB": GOTO errmes + PRINT #12, "0);" + PRINT #27, ");" - Else + ELSE - If id.args = 0 Then a$ = "SUB has no arguments": GoTo errmes + IF id.args = 0 THEN a$ = "SUB has no arguments": GOTO errmes t = CVL(id.arg) - B = t And 511 - If B = 0 Or (t And ISARRAY) <> 0 Or (t And ISFLOAT) <> 0 Or (t And ISSTRING) <> 0 Or (t And ISOFFSETINBITS) <> 0 Then a$ = "Only SUB arguments of integer-type allowed": GoTo errmes - If B = 8 Then ct$ = "int8" - If B = 16 Then ct$ = "int16" - If B = 32 Then ct$ = "int32" - If B = 64 Then ct$ = "int64" - If t And ISOFFSET Then ct$ = "ptrszint" - If t And ISUNSIGNED Then ct$ = "u" + ct$ - Print #27, "(" + ct$ + "*)&i64);" + B = t AND 511 + IF B = 0 OR (t AND ISARRAY) <> 0 OR (t AND ISFLOAT) <> 0 OR (t AND ISSTRING) <> 0 OR (t AND ISOFFSETINBITS) <> 0 THEN a$ = "Only SUB arguments of integer-type allowed": GOTO errmes + IF B = 8 THEN ct$ = "int8" + IF B = 16 THEN ct$ = "int16" + IF B = 32 THEN ct$ = "int32" + IF B = 64 THEN ct$ = "int64" + IF t AND ISOFFSET THEN ct$ = "ptrszint" + IF t AND ISUNSIGNED THEN ct$ = "u" + ct$ + PRINT #27, "(" + ct$ + "*)&i64);" e$ = getelements$(ca$, i, n) e$ = fixoperationorder$(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp + tlayout$ e$ = evaluatetotyp(e$, INTEGER64TYPE - ISPOINTER) - If Error_Happened Then GoTo errmes - Print #12, e$ + ");" + IF Error_Happened THEN GOTO errmes + PRINT #12, e$ + ");" - End If + END IF - Print #27, "break;" - If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$ + PRINT #27, "break;" + IF LEN(layout$) = 0 THEN layout$ = l$ ELSE layout$ = layout$ + sp + l$ layoutdone = 1 - GoTo finishedline - End If + GOTO finishedline + END IF - End If - End If + END IF + END IF @@ -7117,11 +7117,11 @@ Do 'SHARED (SUB) - If n >= 1 Then - If firstelement$ = "SHARED" Then - If n = 1 Then a$ = "Expected SHARED ...": GoTo errmes + IF n >= 1 THEN + IF firstelement$ = "SHARED" THEN + IF n = 1 THEN a$ = "Expected SHARED ...": GOTO errmes i = 2 - If subfuncn = 0 Then a$ = "SHARED must be used within a SUB/FUNCTION": GoTo errmes + IF subfuncn = 0 THEN a$ = "SHARED must be used within a SUB/FUNCTION": GOTO errmes @@ -7131,22 +7131,22 @@ Do 'get variable name n$ = getelement$(ca$, i): i = i + 1 - If n$ = "" Then a$ = "Expected SHARED variable-name or SHARED AS type variable-list": GoTo errmes + IF n$ = "" THEN a$ = "Expected SHARED variable-name or SHARED AS type variable-list": GOTO errmes - If UCase$(n$) <> "AS" Then + IF UCASE$(n$) <> "AS" THEN 'traditional dim syntax for SHARED s$ = removesymbol(n$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l2$ = s$ 'either symbol or nothing 'array? a = 0 - If getelement$(a$, i) = "(" Then - If getelement$(a$, i + 1) <> ")" Then a$ = "Expected ()": GoTo errmes + IF getelement$(a$, i) = "(" THEN + IF getelement$(a$, i + 1) <> ")" THEN a$ = "Expected ()": GOTO errmes i = i + 2 a = 1 l2$ = l2$ + sp2 + "(" + sp2 + ")" - End If + END IF method = 1 @@ -7154,140 +7154,140 @@ Do t$ = "" ts$ = "" t3$ = "" - If getelement$(a$, i) = "AS" Then + IF getelement$(a$, i) = "AS" THEN l2$ = l2$ + sp + SCase$("As") getshrtyp: i = i + 1 t2$ = getelement$(a$, i) - If t2$ <> "," And t2$ <> "" Then - If t$ = "" Then t$ = t2$ Else t$ = t$ + " " + t2$ - If t3$ = "" Then t3$ = t2$ Else t3$ = t3$ + sp + t2$ - GoTo getshrtyp - End If - If t$ = "" Then a$ = "Expected AS type": GoTo errmes + IF t2$ <> "," AND t2$ <> "" THEN + IF t$ = "" THEN t$ = t2$ ELSE t$ = t$ + " " + t2$ + IF t3$ = "" THEN t3$ = t2$ ELSE t3$ = t3$ + sp + t2$ + GOTO getshrtyp + END IF + IF t$ = "" THEN a$ = "Expected AS type": GOTO errmes t = typname2typ(t$) - If Error_Happened Then GoTo errmes - If t And ISINCONVENTIONALMEMORY Then t = t - ISINCONVENTIONALMEMORY - If t And ISPOINTER Then t = t - ISPOINTER - If t And ISREFERENCE Then t = t - ISREFERENCE + IF Error_Happened THEN GOTO errmes + IF t AND ISINCONVENTIONALMEMORY THEN t = t - ISINCONVENTIONALMEMORY + IF t AND ISPOINTER THEN t = t - ISPOINTER + IF t AND ISREFERENCE THEN t = t - ISREFERENCE tsize = typname2typsize method = 0 - If (t And ISUDT) = 0 Then + IF (t AND ISUDT) = 0 THEN ts$ = type2symbol$(t$) l2$ = l2$ + sp + SCase2$(t3$) - Else - t3$ = RTrim$(udtxcname(t And 511)) - If RTrim$(udtxcname(t And 511)) = "_MEM" And UCase$(t$) = "MEM" And qb64prefix_set = 1 Then - t3$ = Mid$(RTrim$(udtxcname(t And 511)), 2) - End If + ELSE + t3$ = RTRIM$(udtxcname(t AND 511)) + IF RTRIM$(udtxcname(t AND 511)) = "_MEM" AND UCASE$(t$) = "MEM" AND qb64prefix_set = 1 THEN + t3$ = MID$(RTRIM$(udtxcname(t AND 511)), 2) + END IF l2$ = l2$ + sp + t3$ - End If - If Error_Happened Then GoTo errmes + END IF + IF Error_Happened THEN GOTO errmes - End If 'as + END IF 'as - If Len(s$) <> 0 And Len(t$) <> 0 Then a$ = "Expected symbol or AS type after variable name": GoTo errmes + IF LEN(s$) <> 0 AND LEN(t$) <> 0 THEN a$ = "Expected symbol or AS type after variable name": GOTO errmes 'no symbol of type specified, apply default - If s$ = "" And t$ = "" Then - If Left$(n$, 1) = "_" Then v = 27 Else v = Asc(UCase$(n$)) - 64 + IF s$ = "" AND t$ = "" THEN + IF LEFT$(n$, 1) = "_" THEN v = 27 ELSE v = ASC(UCASE$(n$)) - 64 s$ = defineextaz(v) - End If + END IF NormalSharedBlock: 'switch to main module oldsubfunc$ = subfunc$ subfunc$ = "" defdatahandle = 18 - Close #13: Open tmpdir$ + "maindata.txt" For Append As #13 - Close #19: Open tmpdir$ + "mainfree.txt" For Append As #19 + CLOSE #13: OPEN tmpdir$ + "maindata.txt" FOR APPEND AS #13 + CLOSE #19: OPEN tmpdir$ + "mainfree.txt" FOR APPEND AS #19 'use 'try' to locate the variable (if it already exists) n2$ = n$ + s$ + ts$ 'note: either ts$ or s$ will exist unless it is a UDT try = findid(n2$) - If Error_Happened Then GoTo errmes - Do While try - If a Then + IF Error_Happened THEN GOTO errmes + DO WHILE try + IF a THEN 'an array - If id.arraytype Then - If Len(t$) = 0 Then GoTo shrfound + IF id.arraytype THEN + IF LEN(t$) = 0 THEN GOTO shrfound t2 = id.arraytype: t2size = id.tsize - If t2 And ISINCONVENTIONALMEMORY Then t2 = t2 - ISINCONVENTIONALMEMORY - If t2 And ISPOINTER Then t2 = t2 - ISPOINTER - If t2 And ISREFERENCE Then t2 = t2 - ISREFERENCE - If t = t2 And tsize = t2size Then GoTo shrfound - End If + IF t2 AND ISINCONVENTIONALMEMORY THEN t2 = t2 - ISINCONVENTIONALMEMORY + IF t2 AND ISPOINTER THEN t2 = t2 - ISPOINTER + IF t2 AND ISREFERENCE THEN t2 = t2 - ISREFERENCE + IF t = t2 AND tsize = t2size THEN GOTO shrfound + END IF - Else + ELSE 'not an array - If id.t Then - If Len(t$) = 0 Then GoTo shrfound + IF id.t THEN + IF LEN(t$) = 0 THEN GOTO shrfound t2 = id.t: t2size = id.tsize - If t2 And ISINCONVENTIONALMEMORY Then t2 = t2 - ISINCONVENTIONALMEMORY - If t2 And ISPOINTER Then t2 = t2 - ISPOINTER - If t2 And ISREFERENCE Then t2 = t2 - ISREFERENCE + IF t2 AND ISINCONVENTIONALMEMORY THEN t2 = t2 - ISINCONVENTIONALMEMORY + IF t2 AND ISPOINTER THEN t2 = t2 - ISPOINTER + IF t2 AND ISREFERENCE THEN t2 = t2 - ISREFERENCE - If Debug Then Print #9, "SHARED:comparing:"; t; t2, tsize; t2size + IF Debug THEN PRINT #9, "SHARED:comparing:"; t; t2, tsize; t2size - If t = t2 And tsize = t2size Then GoTo shrfound - End If + IF t = t2 AND tsize = t2size THEN GOTO shrfound + END IF - End If + END IF - If try = 2 Then findanotherid = 1: try = findid(n2$) Else try = 0 - If Error_Happened Then GoTo errmes - Loop + IF try = 2 THEN findanotherid = 1: try = findid(n2$) ELSE try = 0 + IF Error_Happened THEN GOTO errmes + LOOP 'unknown variable - If a Then a$ = "Array '" + n$ + "' not defined": GoTo errmes + IF a THEN a$ = "Array '" + n$ + "' not defined": GOTO errmes 'create variable - If Len(s$) Then typ$ = s$ Else typ$ = t$ - If optionexplicit Then a$ = "Variable '" + n$ + "' (" + symbol2fulltypename$(typ$) + ") not defined": GoTo errmes + IF LEN(s$) THEN typ$ = s$ ELSE typ$ = t$ + IF optionexplicit THEN a$ = "Variable '" + n$ + "' (" + symbol2fulltypename$(typ$) + ") not defined": GOTO errmes bypassNextVariable = -1 retval = dim2(n$, typ$, method, "") - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes 'note: variable created! shrfound: - If newSharedSyntax = 0 Then - l$ = l$ + sp + RTrim$(id.cn) + l2$ - Else - If sharedAsLayoutAdded = 0 Then + IF newSharedSyntax = 0 THEN + l$ = l$ + sp + RTRIM$(id.cn) + l2$ + ELSE + IF sharedAsLayoutAdded = 0 THEN sharedAsLayoutAdded = -1 - l$ = l$ + l2$ + sp$ + RTrim$(id.cn) + l3$ - Else - l$ = l$ + sp$ + RTrim$(id.cn) + l3$ - End If - End If + l$ = l$ + l2$ + sp$ + RTRIM$(id.cn) + l3$ + ELSE + l$ = l$ + sp$ + RTRIM$(id.cn) + l3$ + END IF + END IF - ids(currentid).share = ids(currentid).share Or 2 'set as temporarily shared + ids(currentid).share = ids(currentid).share OR 2 'set as temporarily shared 'method must apply to the current sub/function regardless of how the variable was defined in 'main' - lmay = Len(RTrim$(id.mayhave)): lmust = Len(RTrim$(id.musthave)) - If lmay <> 0 Or lmust <> 0 Then - If (method = 1 And lmust = 0) Or (method = 0 And lmay = 0) Then + lmay = LEN(RTRIM$(id.mayhave)): lmust = LEN(RTRIM$(id.musthave)) + IF lmay <> 0 OR lmust <> 0 THEN + IF (method = 1 AND lmust = 0) OR (method = 0 AND lmay = 0) THEN revertmaymusthaven = revertmaymusthaven + 1 revertmaymusthave(revertmaymusthaven) = currentid - Swap ids(currentid).musthave, ids(currentid).mayhave - End If - End If + SWAP ids(currentid).musthave, ids(currentid).mayhave + END IF + END IF 'switch back to sub/func subfunc$ = oldsubfunc$ defdatahandle = 13 - Close #13: Open tmpdir$ + "data" + str2$(subfuncn) + ".txt" For Append As #13 - Close #19: Open tmpdir$ + "free" + str2$(subfuncn) + ".txt" For Append As #19 + CLOSE #13: OPEN tmpdir$ + "data" + str2$(subfuncn) + ".txt" FOR APPEND AS #13 + CLOSE #19: OPEN tmpdir$ + "free" + str2$(subfuncn) + ".txt" FOR APPEND AS #19 - If newSharedSyntax Then Return + IF newSharedSyntax THEN RETURN - If getelement$(a$, i) = "," Then i = i + 1: l$ = l$ + sp2 + ",": GoTo subfuncshr - If getelement$(a$, i) <> "" Then a$ = "Expected ,": GoTo errmes + IF getelement$(a$, i) = "," THEN i = i + 1: l$ = l$ + sp2 + ",": GOTO subfuncshr + IF getelement$(a$, i) <> "" THEN a$ = "Expected ,": GOTO errmes - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - Else + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + ELSE 'new dim syntax for SHARED! i = i - 1 'relocate back to "AS" @@ -7302,108 +7302,108 @@ Do getshrtyp2: i = i + 1 t2$ = getelement$(a$, i) - If t2$ <> "," And t2$ <> "(" And t2$ <> "" Then + IF t2$ <> "," AND t2$ <> "(" AND t2$ <> "" THEN 'get first variable name n$ = getelement$(ca$, i) - If Len(previousElement$) Then - If t$ = "" Then t$ = previousElement$ Else t$ = t$ + " " + previousElement$ - If t3$ = "" Then t3$ = previousElement$ Else t3$ = t3$ + sp + previousElement$ - End If + IF LEN(previousElement$) THEN + IF t$ = "" THEN t$ = previousElement$ ELSE t$ = t$ + " " + previousElement$ + IF t3$ = "" THEN t3$ = previousElement$ ELSE t3$ = t3$ + sp + previousElement$ + END IF previousElement$ = t2$ - GoTo getshrtyp2 - End If - If t$ = "" Then a$ = "Expected SHARED AS type variable-list or SHARED variable-name AS type": GoTo errmes + GOTO getshrtyp2 + END IF + IF t$ = "" THEN a$ = "Expected SHARED AS type variable-list or SHARED variable-name AS type": GOTO errmes t = typname2typ(t$) - If Error_Happened Then GoTo errmes - If t And ISINCONVENTIONALMEMORY Then t = t - ISINCONVENTIONALMEMORY - If t And ISPOINTER Then t = t - ISPOINTER - If t And ISREFERENCE Then t = t - ISREFERENCE + IF Error_Happened THEN GOTO errmes + IF t AND ISINCONVENTIONALMEMORY THEN t = t - ISINCONVENTIONALMEMORY + IF t AND ISPOINTER THEN t = t - ISPOINTER + IF t AND ISREFERENCE THEN t = t - ISREFERENCE tsize = typname2typsize method = 0 - If (t And ISUDT) = 0 Then + IF (t AND ISUDT) = 0 THEN ts$ = type2symbol$(t$) l2$ = l2$ + sp + SCase2$(t3$) - Else - t3$ = RTrim$(udtxcname(t And 511)) - If RTrim$(udtxcname(t And 511)) = "_MEM" And UCase$(t$) = "MEM" And qb64prefix_set = 1 Then - t3$ = Mid$(RTrim$(udtxcname(t And 511)), 2) - End If + ELSE + t3$ = RTRIM$(udtxcname(t AND 511)) + IF RTRIM$(udtxcname(t AND 511)) = "_MEM" AND UCASE$(t$) = "MEM" AND qb64prefix_set = 1 THEN + t3$ = MID$(RTRIM$(udtxcname(t AND 511)), 2) + END IF l2$ = l2$ + sp + t3$ - End If - If Error_Happened Then GoTo errmes + END IF + IF Error_Happened THEN GOTO errmes subfuncshr2: s$ = removesymbol(n$) - If Error_Happened Then GoTo errmes - If s$ <> "" Then + IF Error_Happened THEN GOTO errmes + IF s$ <> "" THEN a$ = "Cannot use type symbol with SHARED AS type variable-list (" + s$ + ")" - GoTo errmes - End If + GOTO errmes + END IF 'array? a = 0 l3$ = "" - If getelement$(a$, i) = "(" Then - If getelement$(a$, i + 1) <> ")" Then a$ = "Expected ()": GoTo errmes + IF getelement$(a$, i) = "(" THEN + IF getelement$(a$, i + 1) <> ")" THEN a$ = "Expected ()": GOTO errmes i = i + 2 a = 1 l3$ = sp2 + "(" + sp2 + ")" - End If + END IF newSharedSyntax = -1 - GoSub NormalSharedBlock + GOSUB NormalSharedBlock newSharedSyntax = 0 - If getelement$(a$, i) = "," Then + IF getelement$(a$, i) = "," THEN i = i + 1 l$ = l$ + sp2 + "," 'get next variable name n$ = getelement$(ca$, i): i = i + 1 - GoTo subfuncshr2 - End If - If getelement$(a$, i) <> "" Then a$ = "Expected ,": GoTo errmes + GOTO subfuncshr2 + END IF + IF getelement$(a$, i) <> "" THEN a$ = "Expected ,": GOTO errmes - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - End If - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + END IF + END IF 'EXIT SUB/FUNCTION - If n = 2 Then - If firstelement$ = "EXIT" Then + IF n = 2 THEN + IF firstelement$ = "EXIT" THEN sf = 0 - If secondelement$ = "FUNCTION" Then sf = 1 - If secondelement$ = "SUB" Then sf = 2 - If sf Then + IF secondelement$ = "FUNCTION" THEN sf = 1 + IF secondelement$ = "SUB" THEN sf = 2 + IF sf THEN - If Len(subfunc) = 0 Then a$ = "EXIT " + secondelement$ + " must be used within a " + secondelement$: GoTo errmes + IF LEN(subfunc) = 0 THEN a$ = "EXIT " + secondelement$ + " must be used within a " + secondelement$: GOTO errmes - Print #12, "goto exit_subfunc;" - If Left$(subfunc, 4) = "SUB_" Then secondelement$ = SCase$("Sub") Else secondelement$ = SCase$("Function") + PRINT #12, "goto exit_subfunc;" + IF LEFT$(subfunc, 4) = "SUB_" THEN secondelement$ = SCase$("Sub") ELSE secondelement$ = SCase$("Function") l$ = SCase$("Exit") + sp + secondelement$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - End If - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + END IF + END IF '_ECHO checking - If firstelement$ = "_ECHO" Or (firstelement$ = "ECHO" And qb64prefix_set = 1) Then - If Console = 0 Then - a$ = qb64prefix$ + "ECHO requires $CONSOLE or $CONSOLE:ONLY to be set first": GoTo errmes - End If - End If + IF firstelement$ = "_ECHO" OR (firstelement$ = "ECHO" AND qb64prefix_set = 1) THEN + IF Console = 0 THEN + a$ = qb64prefix$ + "ECHO requires $CONSOLE or $CONSOLE:ONLY to be set first": GOTO errmes + END IF + END IF 'ASC statement (fully inline) - If n >= 1 Then - If firstelement$ = "ASC" Then - If getelement$(a$, 2) <> "(" Then a$ = "Expected ( after ASC": GoTo errmes + IF n >= 1 THEN + IF firstelement$ = "ASC" THEN + IF getelement$(a$, 2) <> "(" THEN a$ = "Expected ( after ASC": GOTO errmes 'calculate 3 parts useposition = 0 @@ -7413,105 +7413,105 @@ Do stringvariable$ = "" position$ = "" B = 0 - Do + DO - If i > n Then 'got part 3 - If part <> 3 Or Len(a3$) = 0 Then a$ = "Expected ASC ( ... , ... ) = ...": GoTo errmes + IF i > n THEN 'got part 3 + IF part <> 3 OR LEN(a3$) = 0 THEN a$ = "Expected ASC ( ... , ... ) = ...": GOTO errmes expression$ = a3$ - Exit Do - End If + EXIT DO + END IF a2$ = getelement$(ca$, i) - If a2$ = "(" Then B = B + 1 - If a2$ = ")" Then B = B - 1 + IF a2$ = "(" THEN B = B + 1 + IF a2$ = ")" THEN B = B - 1 - If B = -1 Then + IF B = -1 THEN - If part = 1 Then 'eg. ASC(a$)=65 - If getelement$(a$, i + 1) <> "=" Then a$ = "Expected =": GoTo errmes + IF part = 1 THEN 'eg. ASC(a$)=65 + IF getelement$(a$, i + 1) <> "=" THEN a$ = "Expected =": GOTO errmes stringvariable$ = a3$ position$ = "1" - part = 3: a3$ = "": i = i + 1: GoTo ascgotpart - End If + part = 3: a3$ = "": i = i + 1: GOTO ascgotpart + END IF - If part = 2 Then 'eg. ASC(a$,i)=65 - If getelement$(a$, i + 1) <> "=" Then a$ = "Expected =": GoTo errmes + IF part = 2 THEN 'eg. ASC(a$,i)=65 + IF getelement$(a$, i + 1) <> "=" THEN a$ = "Expected =": GOTO errmes useposition = 1 position$ = a3$ - part = 3: a3$ = "": i = i + 1: GoTo ascgotpart - End If + part = 3: a3$ = "": i = i + 1: GOTO ascgotpart + END IF 'fall through, already in part 3 - End If + END IF - If a2$ = "," And B = 0 Then - If part = 1 Then stringvariable$ = a3$: part = 2: a3$ = "": GoTo ascgotpart - End If + IF a2$ = "," AND B = 0 THEN + IF part = 1 THEN stringvariable$ = a3$: part = 2: a3$ = "": GOTO ascgotpart + END IF - If Len(a3$) Then a3$ = a3$ + sp + a2$ Else a3$ = a2$ + IF LEN(a3$) THEN a3$ = a3$ + sp + a2$ ELSE a3$ = a2$ ascgotpart: i = i + 1 - Loop - If Len(stringvariable$) = 0 Or Len(position$) = 0 Then a$ = "Expected ASC ( ... , ... ) = ...": GoTo errmes + LOOP + IF LEN(stringvariable$) = 0 OR LEN(position$) = 0 THEN a$ = "Expected ASC ( ... , ... ) = ...": GOTO errmes 'validate stringvariable$ stringvariable$ = fixoperationorder$(stringvariable$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = SCase$("Asc") + sp2 + "(" + sp2 + tlayout$ e$ = evaluate(stringvariable$, sourcetyp) - If Error_Happened Then GoTo errmes - If (sourcetyp And ISREFERENCE) = 0 Or (sourcetyp And ISSTRING) = 0 Then a$ = "Expected ASC ( string-variable , ...": GoTo errmes + IF Error_Happened THEN GOTO errmes + IF (sourcetyp AND ISREFERENCE) = 0 OR (sourcetyp AND ISSTRING) = 0 THEN a$ = "Expected ASC ( string-variable , ...": GOTO errmes stringvariable$ = evaluatetotyp(stringvariable$, ISSTRING) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes - If position$ = "1" Then - If useposition Then l$ = l$ + sp2 + "," + sp + "1" + sp2 + ")" + sp + "=" Else l$ = l$ + sp2 + ")" + sp + "=" + IF position$ = "1" THEN + IF useposition THEN l$ = l$ + sp2 + "," + sp + "1" + sp2 + ")" + sp + "=" ELSE l$ = l$ + sp2 + ")" + sp + "=" - Print #12, "tqbs=" + stringvariable$ + "; if (!new_error){" + PRINT #12, "tqbs=" + stringvariable$ + "; if (!new_error){" e$ = fixoperationorder$(expression$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp + tlayout$ e$ = evaluatetotyp(e$, 32&) - If Error_Happened Then GoTo errmes - Print #12, "tmp_long=" + e$ + "; if (!new_error){" - Print #12, "if (tqbs->len){tqbs->chr[0]=tmp_long;}else{error(5);}" - Print #12, "}}" + IF Error_Happened THEN GOTO errmes + PRINT #12, "tmp_long=" + e$ + "; if (!new_error){" + PRINT #12, "if (tqbs->len){tqbs->chr[0]=tmp_long;}else{error(5);}" + PRINT #12, "}}" - Else + ELSE - Print #12, "tqbs=" + stringvariable$ + "; if (!new_error){" + PRINT #12, "tqbs=" + stringvariable$ + "; if (!new_error){" e$ = fixoperationorder$(position$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ + sp2 + ")" + sp + "=" e$ = evaluatetotyp(e$, 32&) - If Error_Happened Then GoTo errmes - Print #12, "tmp_fileno=" + e$ + "; if (!new_error){" + IF Error_Happened THEN GOTO errmes + PRINT #12, "tmp_fileno=" + e$ + "; if (!new_error){" e$ = fixoperationorder$(expression$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp + tlayout$ e$ = evaluatetotyp(e$, 32&) - If Error_Happened Then GoTo errmes - Print #12, "tmp_long=" + e$ + "; if (!new_error){" - Print #12, "if ((tmp_fileno>0)&&(tmp_fileno<=tqbs->len)){tqbs->chr[tmp_fileno-1]=tmp_long;}else{error(5);}" - Print #12, "}}}" + IF Error_Happened THEN GOTO errmes + PRINT #12, "tmp_long=" + e$ + "; if (!new_error){" + PRINT #12, "if ((tmp_fileno>0)&&(tmp_fileno<=tqbs->len)){tqbs->chr[tmp_fileno-1]=tmp_long;}else{error(5);}" + PRINT #12, "}}}" - End If - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - End If + END IF + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + END IF 'MID$ statement - If n >= 1 Then - If firstelement$ = "MID$" Then - If getelement$(a$, 2) <> "(" Then a$ = "Expected ( after MID$": GoTo errmes + IF n >= 1 THEN + IF firstelement$ = "MID$" THEN + IF getelement$(a$, 2) <> "(" THEN a$ = "Expected ( after MID$": GOTO errmes 'calculate 4 parts length$ = "" part = 1 @@ -7520,219 +7520,219 @@ Do stringvariable$ = "" start$ = "" B = 0 - Do - If i > n Then - If part <> 4 Or a3$ = "" Then a$ = "Expected MID$(...)=...": GoTo errmes + DO + IF i > n THEN + IF part <> 4 OR a3$ = "" THEN a$ = "Expected MID$(...)=...": GOTO errmes stringexpression$ = a3$ - Exit Do - End If + EXIT DO + END IF a2$ = getelement$(ca$, i) - If a2$ = "(" Then B = B + 1 - If a2$ = ")" Then B = B - 1 - If B = -1 Then - If part = 2 Then - If getelement$(a$, i + 1) <> "=" Then a$ = "Expected = after )": GoTo errmes - start$ = a3$: part = 4: a3$ = "": i = i + 1: GoTo midgotpart - End If - If part = 3 Then - If getelement$(a$, i + 1) <> "=" Then a$ = "Expected = after )": GoTo errmes - If a3$ = "" Then a$ = "Omit , before ) if omitting length in MID$ statement": GoTo errmes - length$ = a3$: part = 4: a3$ = "": i = i + 1: GoTo midgotpart - End If - End If - If a2$ = "," And B = 0 Then - If part = 1 Then stringvariable$ = a3$: part = 2: a3$ = "": GoTo midgotpart - If part = 2 Then start$ = a3$: part = 3: a3$ = "": GoTo midgotpart - End If - If Len(a3$) Then a3$ = a3$ + sp + a2$ Else a3$ = a2$ + IF a2$ = "(" THEN B = B + 1 + IF a2$ = ")" THEN B = B - 1 + IF B = -1 THEN + IF part = 2 THEN + IF getelement$(a$, i + 1) <> "=" THEN a$ = "Expected = after )": GOTO errmes + start$ = a3$: part = 4: a3$ = "": i = i + 1: GOTO midgotpart + END IF + IF part = 3 THEN + IF getelement$(a$, i + 1) <> "=" THEN a$ = "Expected = after )": GOTO errmes + IF a3$ = "" THEN a$ = "Omit , before ) if omitting length in MID$ statement": GOTO errmes + length$ = a3$: part = 4: a3$ = "": i = i + 1: GOTO midgotpart + END IF + END IF + IF a2$ = "," AND B = 0 THEN + IF part = 1 THEN stringvariable$ = a3$: part = 2: a3$ = "": GOTO midgotpart + IF part = 2 THEN start$ = a3$: part = 3: a3$ = "": GOTO midgotpart + END IF + IF LEN(a3$) THEN a3$ = a3$ + sp + a2$ ELSE a3$ = a2$ midgotpart: i = i + 1 - Loop - If stringvariable$ = "" Then a$ = "Syntax error": GoTo errmes - If start$ = "" Then a$ = "Syntax error": GoTo errmes + LOOP + IF stringvariable$ = "" THEN a$ = "Syntax error": GOTO errmes + IF start$ = "" THEN a$ = "Syntax error": GOTO errmes 'check if it is a valid source string stringvariable$ = fixoperationorder$(stringvariable$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = SCase$("Mid$") + sp2 + "(" + sp2 + tlayout$ e$ = evaluate(stringvariable$, sourcetyp) - If Error_Happened Then GoTo errmes - If (sourcetyp And ISREFERENCE) = 0 Or (sourcetyp And ISSTRING) = 0 Then a$ = "MID$ expects a string variable/array-element as its first argument": GoTo errmes + IF Error_Happened THEN GOTO errmes + IF (sourcetyp AND ISREFERENCE) = 0 OR (sourcetyp AND ISSTRING) = 0 THEN a$ = "MID$ expects a string variable/array-element as its first argument": GOTO errmes stringvariable$ = evaluatetotyp(stringvariable$, ISSTRING) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes start$ = fixoperationorder$(start$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ start$ = evaluatetotyp((start$), 32&) stringexpression$ = fixoperationorder$(stringexpression$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l2$ = tlayout$ stringexpression$ = evaluatetotyp(stringexpression$, ISSTRING) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes - If Len(length$) Then + IF LEN(length$) THEN length$ = fixoperationorder$(length$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ length$ = evaluatetotyp(length$, 32&) - If Error_Happened Then GoTo errmes - Print #12, "sub_mid(" + stringvariable$ + "," + start$ + "," + length$ + "," + stringexpression$ + ",1);" - Else - Print #12, "sub_mid(" + stringvariable$ + "," + start$ + ",0," + stringexpression$ + ",0);" - End If + IF Error_Happened THEN GOTO errmes + PRINT #12, "sub_mid(" + stringvariable$ + "," + start$ + "," + length$ + "," + stringexpression$ + ",1);" + ELSE + PRINT #12, "sub_mid(" + stringvariable$ + "," + start$ + ",0," + stringexpression$ + ",0);" + END IF l$ = l$ + sp2 + ")" + sp + "=" + sp + l2$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + END IF - If n >= 2 Then - If firstelement$ = "ERASE" Then + IF n >= 2 THEN + IF firstelement$ = "ERASE" THEN i = 2 l$ = SCase$("Erase") erasenextarray: var$ = getelement$(ca$, i) x$ = var$: ls$ = removesymbol(x$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes - If FindArray(var$) Then - If Error_Happened Then GoTo errmes - l$ = l$ + sp + RTrim$(id.cn) + ls$ + IF FindArray(var$) THEN + IF Error_Happened THEN GOTO errmes + l$ = l$ + sp + RTRIM$(id.cn) + ls$ 'erase the array clearerase: - n$ = RTrim$(id.callname) - bytesperelement$ = str2((id.arraytype And 511) \ 8) - If id.arraytype And ISSTRING Then bytesperelement$ = str2(id.tsize) - If id.arraytype And ISOFFSETINBITS Then bytesperelement$ = str2((id.arraytype And 511)) + "/8+1" - If id.arraytype And ISUDT Then - bytesperelement$ = str2(udtxsize(id.arraytype And 511) \ 8) - End If - Print #12, "if (" + n$ + "[2]&1){" 'array is defined - Print #12, "if (" + n$ + "[2]&2){" 'array is static - If (id.arraytype And ISSTRING) <> 0 And (id.arraytype And ISFIXEDLENGTH) = 0 Then - Print #12, "tmp_long="; - For i2 = 1 To Abs(id.arrayelements) - If i2 <> 1 Then Print #12, "*"; - Print #12, n$ + "[" + str2(i2 * 4 - 4 + 5) + "]"; - Next - Print #12, ";" - Print #12, "while(tmp_long--){" - Print #12, "((qbs*)(((uint64*)(" + n$ + "[0]))[tmp_long]))->len=0;" - Print #12, "}" - Else + n$ = RTRIM$(id.callname) + bytesperelement$ = str2((id.arraytype AND 511) \ 8) + IF id.arraytype AND ISSTRING THEN bytesperelement$ = str2(id.tsize) + IF id.arraytype AND ISOFFSETINBITS THEN bytesperelement$ = str2((id.arraytype AND 511)) + "/8+1" + IF id.arraytype AND ISUDT THEN + bytesperelement$ = str2(udtxsize(id.arraytype AND 511) \ 8) + END IF + PRINT #12, "if (" + n$ + "[2]&1){" 'array is defined + PRINT #12, "if (" + n$ + "[2]&2){" 'array is static + IF (id.arraytype AND ISSTRING) <> 0 AND (id.arraytype AND ISFIXEDLENGTH) = 0 THEN + PRINT #12, "tmp_long="; + FOR i2 = 1 TO ABS(id.arrayelements) + IF i2 <> 1 THEN PRINT #12, "*"; + PRINT #12, n$ + "[" + str2(i2 * 4 - 4 + 5) + "]"; + NEXT + PRINT #12, ";" + PRINT #12, "while(tmp_long--){" + PRINT #12, "((qbs*)(((uint64*)(" + n$ + "[0]))[tmp_long]))->len=0;" + PRINT #12, "}" + ELSE 'numeric 'clear array - Print #12, "memset((void*)(" + n$ + "[0]),0,"; - For i2 = 1 To Abs(id.arrayelements) - If i2 <> 1 Then Print #12, "*"; - Print #12, n$ + "[" + str2(i2 * 4 - 4 + 5) + "]"; - Next - Print #12, "*" + bytesperelement$ + ");" - End If - Print #12, "}else{" 'array is dynamic + PRINT #12, "memset((void*)(" + n$ + "[0]),0,"; + FOR i2 = 1 TO ABS(id.arrayelements) + IF i2 <> 1 THEN PRINT #12, "*"; + PRINT #12, n$ + "[" + str2(i2 * 4 - 4 + 5) + "]"; + NEXT + PRINT #12, "*" + bytesperelement$ + ");" + END IF + PRINT #12, "}else{" 'array is dynamic '1. free memory & any allocated strings - If (id.arraytype And ISSTRING) <> 0 And (id.arraytype And ISFIXEDLENGTH) = 0 Then + IF (id.arraytype AND ISSTRING) <> 0 AND (id.arraytype AND ISFIXEDLENGTH) = 0 THEN 'free strings - Print #12, "tmp_long="; - For i2 = 1 To Abs(id.arrayelements) - If i2 <> 1 Then Print #12, "*"; - Print #12, n$ + "[" + str2(i2 * 4 - 4 + 5) + "]"; - Next - Print #12, ";" - Print #12, "while(tmp_long--){" - Print #12, "qbs_free((qbs*)(((uint64*)(" + n$ + "[0]))[tmp_long]));" - Print #12, "}" + PRINT #12, "tmp_long="; + FOR i2 = 1 TO ABS(id.arrayelements) + IF i2 <> 1 THEN PRINT #12, "*"; + PRINT #12, n$ + "[" + str2(i2 * 4 - 4 + 5) + "]"; + NEXT + PRINT #12, ";" + PRINT #12, "while(tmp_long--){" + PRINT #12, "qbs_free((qbs*)(((uint64*)(" + n$ + "[0]))[tmp_long]));" + PRINT #12, "}" 'free memory - Print #12, "free((void*)(" + n$ + "[0]));" - Else + PRINT #12, "free((void*)(" + n$ + "[0]));" + ELSE 'free memory - Print #12, "if (" + n$ + "[2]&4){" 'cmem array - Print #12, "cmem_dynamic_free((uint8*)(" + n$ + "[0]));" - Print #12, "}else{" 'non-cmem array - Print #12, "free((void*)(" + n$ + "[0]));" - Print #12, "}" - End If + PRINT #12, "if (" + n$ + "[2]&4){" 'cmem array + PRINT #12, "cmem_dynamic_free((uint8*)(" + n$ + "[0]));" + PRINT #12, "}else{" 'non-cmem array + PRINT #12, "free((void*)(" + n$ + "[0]));" + PRINT #12, "}" + END IF '2. set array (and its elements) as undefined - Print #12, n$ + "[2]^=1;" 'remove defined flag, keeping other flags (such as cmem) + PRINT #12, n$ + "[2]^=1;" 'remove defined flag, keeping other flags (such as cmem) 'set dimensions as undefined - For i2 = 1 To Abs(id.arrayelements) + FOR i2 = 1 TO ABS(id.arrayelements) B = i2 * 4 - Print #12, n$ + "[" + str2(B) + "]=2147483647;" 'base - Print #12, n$ + "[" + str2(B + 1) + "]=0;" 'num. index - Print #12, n$ + "[" + str2(B + 2) + "]=0;" 'multiplier - Next - If (id.arraytype And ISSTRING) <> 0 And (id.arraytype And ISFIXEDLENGTH) = 0 Then - Print #12, n$ + "[0]=(ptrszint)¬hingstring;" - Else - Print #12, n$ + "[0]=(ptrszint)nothingvalue;" - End If - Print #12, "}" 'static/dynamic - Print #12, "}" 'array is defined - If clearerasereturn = 1 Then clearerasereturn = 0: GoTo clearerasereturned - GoTo erasedarray - End If - If Error_Happened Then GoTo errmes - a$ = "Undefined array passed to ERASE": GoTo errmes + PRINT #12, n$ + "[" + str2(B) + "]=2147483647;" 'base + PRINT #12, n$ + "[" + str2(B + 1) + "]=0;" 'num. index + PRINT #12, n$ + "[" + str2(B + 2) + "]=0;" 'multiplier + NEXT + IF (id.arraytype AND ISSTRING) <> 0 AND (id.arraytype AND ISFIXEDLENGTH) = 0 THEN + PRINT #12, n$ + "[0]=(ptrszint)¬hingstring;" + ELSE + PRINT #12, n$ + "[0]=(ptrszint)nothingvalue;" + END IF + PRINT #12, "}" 'static/dynamic + PRINT #12, "}" 'array is defined + IF clearerasereturn = 1 THEN clearerasereturn = 0: GOTO clearerasereturned + GOTO erasedarray + END IF + IF Error_Happened THEN GOTO errmes + a$ = "Undefined array passed to ERASE": GOTO errmes erasedarray: - If i < n Then - i = i + 1: n$ = getelement$(a$, i): If n$ <> "," Then a$ = "Expected ,": GoTo errmes + IF i < n THEN + i = i + 1: n$ = getelement$(a$, i): IF n$ <> "," THEN a$ = "Expected ,": GOTO errmes l$ = l$ + sp2 + "," - i = i + 1: If i > n Then a$ = "Expected , ...": GoTo errmes - GoTo erasenextarray - End If + i = i + 1: IF i > n THEN a$ = "Expected , ...": GOTO errmes + GOTO erasenextarray + END IF - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + END IF 'DIM/REDIM/STATIC - If n >= 2 Then + IF n >= 2 THEN dimoption = 0: redimoption = 0: commonoption = 0 - If firstelement$ = "DIM" Then l$ = SCase$("Dim"): dimoption = 1 - If firstelement$ = "REDIM" Then + IF firstelement$ = "DIM" THEN l$ = SCase$("Dim"): dimoption = 1 + IF firstelement$ = "REDIM" THEN l$ = SCase$("ReDim") dimoption = 2: redimoption = 1 - If secondelement$ = "_PRESERVE" Or (secondelement$ = "PRESERVE" And qb64prefix_set = 1) Then + IF secondelement$ = "_PRESERVE" OR (secondelement$ = "PRESERVE" AND qb64prefix_set = 1) THEN redimoption = 2 - If secondelement$ = "_PRESERVE" Then + IF secondelement$ = "_PRESERVE" THEN l$ = l$ + sp + SCase$("_Preserve") - Else + ELSE l$ = l$ + sp + SCase$("Preserve") - End If - If n = 2 Then a$ = "Expected REDIM " + qb64prefix$ + "PRESERVE ...": GoTo errmes - End If - End If - If firstelement$ = "STATIC" Then l$ = SCase$("Static"): dimoption = 3 - If firstelement$ = "COMMON" Then l$ = SCase$("Common"): dimoption = 1: commonoption = 1 - If dimoption Then + END IF + IF n = 2 THEN a$ = "Expected REDIM " + qb64prefix$ + "PRESERVE ...": GOTO errmes + END IF + END IF + IF firstelement$ = "STATIC" THEN l$ = SCase$("Static"): dimoption = 3 + IF firstelement$ = "COMMON" THEN l$ = SCase$("Common"): dimoption = 1: commonoption = 1 + IF dimoption THEN - If dimoption = 3 And subfuncn = 0 Then a$ = "STATIC must be used within a SUB/FUNCTION": GoTo errmes - If commonoption = 1 And subfuncn <> 0 Then a$ = "COMMON cannot be used within a SUB/FUNCTION": GoTo errmes + IF dimoption = 3 AND subfuncn = 0 THEN a$ = "STATIC must be used within a SUB/FUNCTION": GOTO errmes + IF commonoption = 1 AND subfuncn <> 0 THEN a$ = "COMMON cannot be used within a SUB/FUNCTION": GOTO errmes i = 2 - If redimoption = 2 Then i = 3 + IF redimoption = 2 THEN i = 3 - If dimoption <> 3 Then 'shared cannot be static + IF dimoption <> 3 THEN 'shared cannot be static a2$ = getelement(a$, i) - If a2$ = "SHARED" Then - If subfuncn <> 0 Then a$ = "DIM/REDIM SHARED invalid within a SUB/FUNCTION": GoTo errmes + IF a2$ = "SHARED" THEN + IF subfuncn <> 0 THEN a$ = "DIM/REDIM SHARED invalid within a SUB/FUNCTION": GOTO errmes dimshared = 1 i = i + 1 l$ = l$ + sp + SCase$("Shared") - End If - End If + END IF + END IF - If dimoption = 3 Then dimstatic = 1: AllowLocalName = 1 + IF dimoption = 3 THEN dimstatic = 1: AllowLocalName = 1 'look for new dim syntax: DIM AS variabletype var1, var2, etc.... e$ = getelement$(a$, i) - If e$ <> "AS" Then + IF e$ <> "AS" THEN 'no "AS", so this is the traditional dim syntax dimnext: notype = 0 @@ -7743,44 +7743,44 @@ Do 'chaincommonarray=0 varname$ = getelement(ca$, i): i = i + 1 - If varname$ = "" Then a$ = "Expected " + firstelement$ + " variable-name or " + firstelement$ + " AS type variable-list": GoTo errmes + IF varname$ = "" THEN a$ = "Expected " + firstelement$ + " variable-name or " + firstelement$ + " AS type variable-list": GOTO errmes 'get the next element - If i >= n + 1 Then e$ = "" Else e$ = getelement(a$, i): i = i + 1 + IF i >= n + 1 THEN e$ = "" ELSE e$ = getelement(a$, i): i = i + 1 'check if next element is a ( to create an array elements$ = "" - If e$ = "(" Then + IF e$ = "(" THEN B = 1 - For i = i To n + FOR i = i TO n e$ = getelement(ca$, i) - If e$ = "(" Then B = B + 1 - If e$ = ")" Then B = B - 1 - If B = 0 Then Exit For - If Len(elements$) Then elements$ = elements$ + sp + e$ Else elements$ = e$ - Next - If B <> 0 Then a$ = "Expected )": GoTo errmes + IF e$ = "(" THEN B = B + 1 + IF e$ = ")" THEN B = B - 1 + IF B = 0 THEN EXIT FOR + IF LEN(elements$) THEN elements$ = elements$ + sp + e$ ELSE elements$ = e$ + NEXT + IF B <> 0 THEN a$ = "Expected )": GOTO errmes i = i + 1 'set i to point to the next element - If commonoption Then elements$ = "?" + IF commonoption THEN elements$ = "?" - If Debug Then Print #9, "DIM2:array:elements$:[" + elements$ + "]" + IF Debug THEN PRINT #9, "DIM2:array:elements$:[" + elements$ + "]" 'arrayname() means list array to it will automatically be static when it is formally dimensioned later 'note: listed arrays are always created in dynamic memory, but their contents are not erased ' this differs from static arrays from SUB...STATIC and the unique QB64 method -> STATIC arrayname(100) - If dimoption = 3 Then 'STATIC used - If Len(elements$) = 0 Then 'nothing between brackets + IF dimoption = 3 THEN 'STATIC used + IF LEN(elements$) = 0 THEN 'nothing between brackets listarray = 1 'add to static list - End If - End If + END IF + END IF 'last element was ")" 'get next element - If i >= n + 1 Then e$ = "" Else e$ = getelement(a$, i): i = i + 1 - End If 'e$="(" + IF i >= n + 1 THEN e$ = "" ELSE e$ = getelement(a$, i): i = i + 1 + END IF 'e$="(" d$ = e$ dimmethod = 0 @@ -7791,511 +7791,511 @@ Do 'does varname have an appended symbol? s$ = removesymbol$(varname$) - If Error_Happened Then GoTo errmes - If validname(varname$) = 0 Then a$ = "Invalid variable name": GoTo errmes + IF Error_Happened THEN GOTO errmes + IF validname(varname$) = 0 THEN a$ = "Invalid variable name": GOTO errmes - If s$ <> "" Then + IF s$ <> "" THEN typ$ = s$ dimmethod = 1 appendname$ = typ$ - GoTo dimgottyp - End If + GOTO dimgottyp + END IF - If d$ = "AS" Then + IF d$ = "AS" THEN appendtype$ = sp + SCase$("As") typ$ = "" - For i = i To n + FOR i = i TO n d$ = getelement(a$, i) - If d$ = "," Then i = i + 1: Exit For + IF d$ = "," THEN i = i + 1: EXIT FOR typ$ = typ$ + d$ + " " appendtype$ = appendtype$ + sp + d$ d$ = "" - Next + NEXT appendtype$ = SCase2$(appendtype$) 'capitalise default types (udt override this later if necessary) - typ$ = RTrim$(typ$) - GoTo dimgottyp - End If + typ$ = RTRIM$(typ$) + GOTO dimgottyp + END IF 'auto-define type based on name notype = 1 - If Left$(varname$, 1) = "_" Then v = 27 Else v = Asc(UCase$(varname$)) - 64 + IF LEFT$(varname$, 1) = "_" THEN v = 27 ELSE v = ASC(UCASE$(varname$)) - 64 typ$ = defineaz(v) dimmethod = 1 - GoTo dimgottyp + GOTO dimgottyp dimgottyp: - If d$ <> "" And d$ <> "," Then a$ = "DIM: Expected comma!": GoTo errmes + IF d$ <> "" AND d$ <> "," THEN a$ = "DIM: Expected comma!": GOTO errmes 'In QBASIC, if no type info is given it can refer to an expeicit/formally defined array - If notype <> 0 And dimoption <> 3 And dimoption <> 1 Then 'not DIM or STATIC which only create new content - If Len(elements$) Then 'an array - If FindArray(varname$) Then - If Len(RTrim$(id.mayhave)) Then 'explict/formally defined + IF notype <> 0 AND dimoption <> 3 AND dimoption <> 1 THEN 'not DIM or STATIC which only create new content + IF LEN(elements$) THEN 'an array + IF FindArray(varname$) THEN + IF LEN(RTRIM$(id.mayhave)) THEN 'explict/formally defined typ$ = id2fulltypename$ 'adopt type dimmethod = 0 'set as formally defined - End If - End If - End If - End If + END IF + END IF + END IF + END IF NormalDimBlock: - If dimoption = 3 And Len(elements$) Then 'eg. STATIC a(100) + IF dimoption = 3 AND LEN(elements$) THEN 'eg. STATIC a(100) 'does a conflicting array exist? (use findarray) if so again this should lead to duplicate definition typ2$ = symbol2fulltypename$(typ$) t = typname2typ(typ2$): ts = typname2typsize 'try name without any extension - If FindArray(varname$) Then 'name without any symbol - If id.insubfuncn = subfuncn Then 'global cannot conflict with static - If Len(RTrim$(id.musthave)) Then + IF FindArray(varname$) THEN 'name without any symbol + IF id.insubfuncn = subfuncn THEN 'global cannot conflict with static + IF LEN(RTRIM$(id.musthave)) THEN 'if types match then fail - If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then - If ts = id.tsize Then - a$ = "Name already in use": GoTo errmes - End If - End If - Else - If dimmethod = 0 Then - a$ = "Name already in use": GoTo errmes 'explicit over explicit - Else + IF (id.arraytype AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) THEN + IF ts = id.tsize THEN + a$ = "Name already in use": GOTO errmes + END IF + END IF + ELSE + IF dimmethod = 0 THEN + a$ = "Name already in use": GOTO errmes 'explicit over explicit + ELSE 'if types match then fail - If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then - If ts = id.tsize Then - a$ = "Name already in use": GoTo errmes - End If - End If - End If - End If - End If - End If + IF (id.arraytype AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) THEN + IF ts = id.tsize THEN + a$ = "Name already in use": GOTO errmes + END IF + END IF + END IF + END IF + END IF + END IF 'add extension (if possible) - If (t And ISUDT) = 0 Then + IF (t AND ISUDT) = 0 THEN s2$ = type2symbol$(typ2$) - If Error_Happened Then GoTo errmes - If FindArray(varname$ + s2$) Then - If id.insubfuncn = subfuncn Then 'global cannot conflict with static - If Len(RTrim$(id.musthave)) Then + IF Error_Happened THEN GOTO errmes + IF FindArray(varname$ + s2$) THEN + IF id.insubfuncn = subfuncn THEN 'global cannot conflict with static + IF LEN(RTRIM$(id.musthave)) THEN 'if types match then fail - If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then - If ts = id.tsize Then - a$ = "Name already in use": GoTo errmes - End If - End If - Else - If dimmethod = 0 Then - a$ = "Name already in use": GoTo errmes 'explicit over explicit - Else + IF (id.arraytype AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) THEN + IF ts = id.tsize THEN + a$ = "Name already in use": GOTO errmes + END IF + END IF + ELSE + IF dimmethod = 0 THEN + a$ = "Name already in use": GOTO errmes 'explicit over explicit + ELSE 'if types match then fail - If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then - If ts = id.tsize Then - a$ = "Name already in use": GoTo errmes - End If - End If - End If - End If - End If - End If - End If 'not a UDT - End If + IF (id.arraytype AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) THEN + IF ts = id.tsize THEN + a$ = "Name already in use": GOTO errmes + END IF + END IF + END IF + END IF + END IF + END IF + END IF 'not a UDT + END IF - If listarray Then 'eg. STATIC a() + IF listarray THEN 'eg. STATIC a() 'note: list is cleared by END SUB/FUNCTION 'is a conflicting array already listed? if so this should cause a duplicate definition error 'check for conflict within list: xi = 1 - For x = 1 To staticarraylistn + FOR x = 1 TO staticarraylistn varname2$ = getelement$(staticarraylist, xi): xi = xi + 1 typ2$ = getelement$(staticarraylist, xi): xi = xi + 1 - dimmethod2 = Val(getelement$(staticarraylist, xi)): xi = xi + 1 + dimmethod2 = VAL(getelement$(staticarraylist, xi)): xi = xi + 1 'check if they are similar - If UCase$(varname$) = UCase$(varname2$) Then - If dimmethod2 = 1 Then + IF UCASE$(varname$) = UCASE$(varname2$) THEN + IF dimmethod2 = 1 THEN 'old using symbol - If symbol2fulltypename$(typ$) = typ2$ Then a$ = "Name already in use": GoTo errmes - Else + IF symbol2fulltypename$(typ$) = typ2$ THEN a$ = "Name already in use": GOTO errmes + ELSE 'old using AS - If dimmethod = 0 Then - a$ = "Name already in use": GoTo errmes - Else - If symbol2fulltypename$(typ$) = typ2$ Then a$ = "Name already in use": GoTo errmes - End If - End If - End If - Next + IF dimmethod = 0 THEN + a$ = "Name already in use": GOTO errmes + ELSE + IF symbol2fulltypename$(typ$) = typ2$ THEN a$ = "Name already in use": GOTO errmes + END IF + END IF + END IF + NEXT 'does a conflicting array exist? (use findarray) if so again this should lead to duplicate definition typ2$ = symbol2fulltypename$(typ$) t = typname2typ(typ2$): ts = typname2typsize 'try name without any extension - If FindArray(varname$) Then 'name without any symbol - If id.insubfuncn = subfuncn Then 'global cannot conflict with static - If Len(RTrim$(id.musthave)) Then + IF FindArray(varname$) THEN 'name without any symbol + IF id.insubfuncn = subfuncn THEN 'global cannot conflict with static + IF LEN(RTRIM$(id.musthave)) THEN 'if types match then fail - If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then - If ts = id.tsize Then - a$ = "Name already in use": GoTo errmes - End If - End If - Else - If dimmethod = 0 Then - a$ = "Name already in use": GoTo errmes 'explicit over explicit - Else + IF (id.arraytype AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) THEN + IF ts = id.tsize THEN + a$ = "Name already in use": GOTO errmes + END IF + END IF + ELSE + IF dimmethod = 0 THEN + a$ = "Name already in use": GOTO errmes 'explicit over explicit + ELSE 'if types match then fail - If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then - If ts = id.tsize Then - a$ = "Name already in use": GoTo errmes - End If - End If - End If - End If - End If - End If + IF (id.arraytype AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) THEN + IF ts = id.tsize THEN + a$ = "Name already in use": GOTO errmes + END IF + END IF + END IF + END IF + END IF + END IF 'add extension (if possible) - If (t And ISUDT) = 0 Then + IF (t AND ISUDT) = 0 THEN s2$ = type2symbol$(typ2$) - If Error_Happened Then GoTo errmes - If FindArray(varname$ + s2$) Then - If id.insubfuncn = subfuncn Then 'global cannot conflict with static - If Len(RTrim$(id.musthave)) Then + IF Error_Happened THEN GOTO errmes + IF FindArray(varname$ + s2$) THEN + IF id.insubfuncn = subfuncn THEN 'global cannot conflict with static + IF LEN(RTRIM$(id.musthave)) THEN 'if types match then fail - If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then - If ts = id.tsize Then - a$ = "Name already in use": GoTo errmes - End If - End If - Else - If dimmethod = 0 Then - a$ = "Name already in use": GoTo errmes 'explicit over explicit - Else + IF (id.arraytype AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) THEN + IF ts = id.tsize THEN + a$ = "Name already in use": GOTO errmes + END IF + END IF + ELSE + IF dimmethod = 0 THEN + a$ = "Name already in use": GOTO errmes 'explicit over explicit + ELSE 'if types match then fail - If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then - If ts = id.tsize Then - a$ = "Name already in use": GoTo errmes - End If - End If - End If - End If - End If - End If - End If 'not a UDT + IF (id.arraytype AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t AND (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) THEN + IF ts = id.tsize THEN + a$ = "Name already in use": GOTO errmes + END IF + END IF + END IF + END IF + END IF + END IF + END IF 'not a UDT 'note: static list arrays cannot be created until they are formally [or informally] (RE)DIM'd later - If Len(staticarraylist) Then staticarraylist = staticarraylist + sp + IF LEN(staticarraylist) THEN staticarraylist = staticarraylist + sp staticarraylist = staticarraylist + varname$ + sp + symbol2fulltypename$(typ$) + sp + str2(dimmethod) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes staticarraylistn = staticarraylistn + 1 l$ = l$ + sp + varname$ + appendname$ + sp2 + "(" + sp2 + ")" + appendtype$ 'note: none of the following code is run, dim2 call is also skipped - Else + ELSE olddimstatic = dimstatic 'check if varname is on the static list - If Len(elements$) Then 'it's an array - If subfuncn Then 'it's in a sub/function + IF LEN(elements$) THEN 'it's an array + IF subfuncn THEN 'it's in a sub/function xi = 1 - For x = 1 To staticarraylistn + FOR x = 1 TO staticarraylistn varname2$ = getelement$(staticarraylist, xi): xi = xi + 1 typ2$ = getelement$(staticarraylist, xi): xi = xi + 1 - dimmethod2 = Val(getelement$(staticarraylist, xi)): xi = xi + 1 + dimmethod2 = VAL(getelement$(staticarraylist, xi)): xi = xi + 1 'check if they are similar - If UCase$(varname$) = UCase$(varname2$) Then - If symbol2fulltypename$(typ$) = typ2$ Then - If Error_Happened Then GoTo errmes - If dimmethod = dimmethod2 Then + IF UCASE$(varname$) = UCASE$(varname2$) THEN + IF symbol2fulltypename$(typ$) = typ2$ THEN + IF Error_Happened THEN GOTO errmes + IF dimmethod = dimmethod2 THEN 'match found! varname$ = varname2$ dimstatic = 3 - If dimoption = 3 Then a$ = "Array already listed as STATIC": GoTo errmes - End If - End If 'typ - End If 'varname - Next - End If - End If + IF dimoption = 3 THEN a$ = "Array already listed as STATIC": GOTO errmes + END IF + END IF 'typ + END IF 'varname + NEXT + END IF + END IF 'COMMON exception 'note: COMMON alone does not imply SHARED ' if either(or both) COMMON & later DIM have SHARED, variable becomes shared - If commonoption Then - If Len(elements$) Then + IF commonoption THEN + IF LEN(elements$) THEN 'add array to list - If Len(commonarraylist) Then commonarraylist = commonarraylist + sp + IF LEN(commonarraylist) THEN commonarraylist = commonarraylist + sp 'note: dimmethod distinguishes between a%(...) vs a(...) AS INTEGER commonarraylist = commonarraylist + varname$ + sp + symbol2fulltypename$(typ$) + sp + str2(dimmethod) + sp + str2(dimshared) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes commonarraylistn = commonarraylistn + 1 - If Debug Then Print #9, "common listed:" + varname$ + sp + symbol2fulltypename$(typ$) + sp + str2(dimmethod) + sp + str2(dimshared) - If Error_Happened Then GoTo errmes + IF Debug THEN PRINT #9, "common listed:" + varname$ + sp + symbol2fulltypename$(typ$) + sp + str2(dimmethod) + sp + str2(dimshared) + IF Error_Happened THEN GOTO errmes x = 0 v$ = varname$ - If dimmethod = 1 Then v$ = v$ + typ$ + IF dimmethod = 1 THEN v$ = v$ + typ$ try = findid(v$) - If Error_Happened Then GoTo errmes - Do While try - If id.arraytype Then + IF Error_Happened THEN GOTO errmes + DO WHILE try + IF id.arraytype THEN t = typname2typ(typ$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes s = typname2typsize match = 1 'note: dimmethod 2 is already matched - If dimmethod = 0 Then + IF dimmethod = 0 THEN t2 = id.arraytype s2 = id.tsize - If (t And ISFLOAT) <> (t2 And ISFLOAT) Then match = 0 - If (t And ISUNSIGNED) <> (t2 And ISUNSIGNED) Then match = 0 - If (t And ISSTRING) <> (t2 And ISSTRING) Then match = 0 - If (t And ISFIXEDLENGTH) <> (t2 And ISFIXEDLENGTH) Then match = 0 - If (t And ISOFFSETINBITS) <> (t2 And ISOFFSETINBITS) Then match = 0 - If (t And ISUDT) <> (t2 And ISUDT) Then match = 0 - If (t And 511) <> (t2 And 511) Then match = 0 - If s <> s2 Then match = 0 + IF (t AND ISFLOAT) <> (t2 AND ISFLOAT) THEN match = 0 + IF (t AND ISUNSIGNED) <> (t2 AND ISUNSIGNED) THEN match = 0 + IF (t AND ISSTRING) <> (t2 AND ISSTRING) THEN match = 0 + IF (t AND ISFIXEDLENGTH) <> (t2 AND ISFIXEDLENGTH) THEN match = 0 + IF (t AND ISOFFSETINBITS) <> (t2 AND ISOFFSETINBITS) THEN match = 0 + IF (t AND ISUDT) <> (t2 AND ISUDT) THEN match = 0 + IF (t AND 511) <> (t2 AND 511) THEN match = 0 + IF s <> s2 THEN match = 0 'check for implicit/explicit declaration match - oldmethod = 0: If Len(RTrim$(id.musthave)) Then oldmethod = 1 - If oldmethod <> dimmethod Then match = 0 - End If + oldmethod = 0: IF LEN(RTRIM$(id.musthave)) THEN oldmethod = 1 + IF oldmethod <> dimmethod THEN match = 0 + END IF - If match Then + IF match THEN x = currentid - If dimshared Then ids(x).share = 1 'share if necessary - tlayout$ = RTrim$(id.cn) + sp + "(" + sp2 + ")" + IF dimshared THEN ids(x).share = 1 'share if necessary + tlayout$ = RTRIM$(id.cn) + sp + "(" + sp2 + ")" - If dimmethod = 0 Then - If t And ISUDT Then - dim2typepassback$ = RTrim$(udtxcname(t And 511)) - If UCase$(typ$) = "MEM" And qb64prefix_set = 1 And RTrim$(udtxcname(t And 511)) = "_MEM" Then - dim2typepassback$ = Mid$(RTrim$(udtxcname(t And 511)), 2) - End If - Else + IF dimmethod = 0 THEN + IF t AND ISUDT THEN + dim2typepassback$ = RTRIM$(udtxcname(t AND 511)) + IF UCASE$(typ$) = "MEM" AND qb64prefix_set = 1 AND RTRIM$(udtxcname(t AND 511)) = "_MEM" THEN + dim2typepassback$ = MID$(RTRIM$(udtxcname(t AND 511)), 2) + END IF + ELSE dim2typepassback$ = typ$ - Do While InStr(dim2typepassback$, " ") - Asc(dim2typepassback$, InStr(dim2typepassback$, " ")) = Asc(sp) - Loop + DO WHILE INSTR(dim2typepassback$, " ") + ASC(dim2typepassback$, INSTR(dim2typepassback$, " ")) = ASC(sp) + LOOP dim2typepassback$ = SCase2$(dim2typepassback$) - End If - End If 'method 0 + END IF + END IF 'method 0 - Exit Do - End If 'match + EXIT DO + END IF 'match - End If 'arraytype - If try = 2 Then findanotherid = 1: try = findid(v$) Else try = 0 - If Error_Happened Then GoTo errmes - Loop + END IF 'arraytype + IF try = 2 THEN findanotherid = 1: try = findid(v$) ELSE try = 0 + IF Error_Happened THEN GOTO errmes + LOOP - If x = 0 Then x = idn + 1 + IF x = 0 THEN x = idn + 1 'note: the following code only adds include directives, everything else is defered - Open tmpdir$ + "chain.txt" For Append As #22 + OPEN tmpdir$ + "chain.txt" FOR APPEND AS #22 'include directive - Print #22, "#include " + Chr$(34) + "chain" + str2$(x) + ".txt" + Chr$(34) - Close #22 + PRINT #22, "#include " + CHR$(34) + "chain" + str2$(x) + ".txt" + CHR$(34) + CLOSE #22 'create/clear include file - Open tmpdir$ + "chain" + str2$(x) + ".txt" For Output As #22: Close #22 + OPEN tmpdir$ + "chain" + str2$(x) + ".txt" FOR OUTPUT AS #22: CLOSE #22 - Open tmpdir$ + "inpchain.txt" For Append As #22 + OPEN tmpdir$ + "inpchain.txt" FOR APPEND AS #22 'include directive - Print #22, "#include " + Chr$(34) + "inpchain" + str2$(x) + ".txt" + Chr$(34) - Close #22 + PRINT #22, "#include " + CHR$(34) + "inpchain" + str2$(x) + ".txt" + CHR$(34) + CLOSE #22 'create/clear include file - Open tmpdir$ + "inpchain" + str2$(x) + ".txt" For Output As #22: Close #22 + OPEN tmpdir$ + "inpchain" + str2$(x) + ".txt" FOR OUTPUT AS #22: CLOSE #22 'note: elements$="?" - If x <> idn + 1 Then GoTo skipdim 'array already exists - GoTo dimcommonarray + IF x <> idn + 1 THEN GOTO skipdim 'array already exists + GOTO dimcommonarray - End If - End If + END IF + END IF 'is varname on common list? '****** - If Len(elements$) Then 'it's an array - If subfuncn = 0 Then 'not in a sub/function + IF LEN(elements$) THEN 'it's an array + IF subfuncn = 0 THEN 'not in a sub/function - If Debug Then Print #9, "common checking:" + varname$ + IF Debug THEN PRINT #9, "common checking:" + varname$ xi = 1 - For x = 1 To commonarraylistn + FOR x = 1 TO commonarraylistn varname2$ = getelement$(commonarraylist, xi): xi = xi + 1 typ2$ = getelement$(commonarraylist, xi): xi = xi + 1 - dimmethod2 = Val(getelement$(commonarraylist, xi)): xi = xi + 1 - dimshared2 = Val(getelement$(commonarraylist, xi)): xi = xi + 1 - If Debug Then Print #9, "common checking against:" + varname2$ + sp + typ2$ + sp + str2(dimmethod2) + sp + str2(dimshared2) + dimmethod2 = VAL(getelement$(commonarraylist, xi)): xi = xi + 1 + dimshared2 = VAL(getelement$(commonarraylist, xi)): xi = xi + 1 + IF Debug THEN PRINT #9, "common checking against:" + varname2$ + sp + typ2$ + sp + str2(dimmethod2) + sp + str2(dimshared2) 'check if they are similar - If varname$ = varname2$ Then - If symbol2fulltypename$(typ$) = typ2$ Then - If Error_Happened Then GoTo errmes - If dimmethod = dimmethod2 Then + IF varname$ = varname2$ THEN + IF symbol2fulltypename$(typ$) = typ2$ THEN + IF Error_Happened THEN GOTO errmes + IF dimmethod = dimmethod2 THEN 'match found! 'enforce shared status (if necessary) - If dimshared2 Then dimshared = dimshared Or 2 'temp force SHARED + IF dimshared2 THEN dimshared = dimshared OR 2 'temp force SHARED 'old chain code 'chaincommonarray=x - End If 'method - End If 'typ - End If 'varname - Next - End If - End If + END IF 'method + END IF 'typ + END IF 'varname + NEXT + END IF + END IF dimcommonarray: retval = dim2(varname$, typ$, dimmethod, elements$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes skipdim: - If dimshared >= 2 Then dimshared = dimshared - 2 + IF dimshared >= 2 THEN dimshared = dimshared - 2 'non-array COMMON variable - If commonoption <> 0 And Len(elements$) = 0 Then + IF commonoption <> 0 AND LEN(elements$) = 0 THEN 'CHAIN.TXT (save) use_global_byte_elements = 1 'switch output from main.txt to chain.txt - Close #12 - Open tmpdir$ + "chain.txt" For Append As #12 + CLOSE #12 + OPEN tmpdir$ + "chain.txt" FOR APPEND AS #12 l2$ = tlayout$ - Print #12, "int32val=1;" 'simple variable - Print #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" + PRINT #12, "int32val=1;" 'simple variable + PRINT #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" t = id.t - bits = t And 511 - If t And ISUDT Then bits = udtxsize(t And 511) - If t And ISSTRING Then - If t And ISFIXEDLENGTH Then + bits = t AND 511 + IF t AND ISUDT THEN bits = udtxsize(t AND 511) + IF t AND ISSTRING THEN + IF t AND ISFIXEDLENGTH THEN bits = id.tsize * 8 - Else - Print #12, "int64val=__STRING_" + RTrim$(id.n) + "->len*8;" + ELSE + PRINT #12, "int64val=__STRING_" + RTRIM$(id.n) + "->len*8;" bits = 0 - End If - End If + END IF + END IF - If bits Then - Print #12, "int64val=" + str2$(bits) + ";" 'size in bits - End If - Print #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" + IF bits THEN + PRINT #12, "int64val=" + str2$(bits) + ";" 'size in bits + END IF + PRINT #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" 'put the variable - e$ = RTrim$(id.n) + e$ = RTRIM$(id.n) - If (t And ISUDT) = 0 Then - If t And ISFIXEDLENGTH Then + IF (t AND ISUDT) = 0 THEN + IF t AND ISFIXEDLENGTH THEN e$ = e$ + "$" + str2$(id.tsize) - Else + ELSE e$ = e$ + typevalue2symbol$(t) - If Error_Happened Then GoTo errmes - End If - End If + IF Error_Happened THEN GOTO errmes + END IF + END IF e$ = evaluatetotyp(fixoperationorder$(e$), -4) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes - Print #12, "sub_put(FF,NULL," + e$ + ",0);" + PRINT #12, "sub_put(FF,NULL," + e$ + ",0);" tlayout$ = l2$ 'revert output to main.txt - Close #12 - Open tmpdir$ + "main.txt" For Append As #12 + CLOSE #12 + OPEN tmpdir$ + "main.txt" FOR APPEND AS #12 'INPCHAIN.TXT (load) 'switch output from main.txt to chain.txt - Close #12 - Open tmpdir$ + "inpchain.txt" For Append As #12 + CLOSE #12 + OPEN tmpdir$ + "inpchain.txt" FOR APPEND AS #12 l2$ = tlayout$ - Print #12, "if (int32val==1){" + PRINT #12, "if (int32val==1){" 'get the size in bits - Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" '***assume correct size*** - e$ = RTrim$(id.n) + e$ = RTRIM$(id.n) t = id.t - If (t And ISUDT) = 0 Then - If t And ISFIXEDLENGTH Then + IF (t AND ISUDT) = 0 THEN + IF t AND ISFIXEDLENGTH THEN e$ = e$ + "$" + str2$(id.tsize) - Else + ELSE e$ = e$ + typevalue2symbol$(t) - If Error_Happened Then GoTo errmes - End If - End If + IF Error_Happened THEN GOTO errmes + END IF + END IF - If t And ISSTRING Then - If (t And ISFIXEDLENGTH) = 0 Then - Print #12, "tqbs=qbs_new(int64val>>3,1);" - Print #12, "qbs_set(__STRING_" + RTrim$(id.n) + ",tqbs);" + IF t AND ISSTRING THEN + IF (t AND ISFIXEDLENGTH) = 0 THEN + PRINT #12, "tqbs=qbs_new(int64val>>3,1);" + PRINT #12, "qbs_set(__STRING_" + RTRIM$(id.n) + ",tqbs);" 'now that the string is the correct size, the following GET command will work correctly... - End If - End If + END IF + END IF e$ = evaluatetotyp(fixoperationorder$(e$), -4) - If Error_Happened Then GoTo errmes - Print #12, "sub_get(FF,NULL," + e$ + ",0);" + IF Error_Happened THEN GOTO errmes + PRINT #12, "sub_get(FF,NULL," + e$ + ",0);" - Print #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" 'get next command - Print #12, "}" + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" 'get next command + PRINT #12, "}" tlayout$ = l2$ 'revert output to main.txt - Close #12 - Open tmpdir$ + "main.txt" For Append As #12 + CLOSE #12 + OPEN tmpdir$ + "main.txt" FOR APPEND AS #12 use_global_byte_elements = 0 - End If + END IF commonarraylisted: - If Len(appendtype$) And newDimSyntax = -1 Then - If Len(dim2typepassback$) Then appendtype$ = sp + SCase$("As") + sp + dim2typepassback$ - If newDimSyntaxTypePassBack = 0 Then + IF LEN(appendtype$) AND newDimSyntax = -1 THEN + IF LEN(dim2typepassback$) THEN appendtype$ = sp + SCase$("As") + sp + dim2typepassback$ + IF newDimSyntaxTypePassBack = 0 THEN newDimSyntaxTypePassBack = -1 l$ = l$ + appendtype$ - End If - End If + END IF + END IF n2 = numelements(tlayout$) l$ = l$ + sp + getelement$(tlayout$, 1) + appendname$ - If n2 > 1 Then + IF n2 > 1 THEN l$ = l$ + sp2 + getelements$(tlayout$, 2, n2) - End If + END IF - If Len(appendtype$) And newDimSyntax = 0 Then - If Len(dim2typepassback$) Then appendtype$ = sp + SCase$("As") + sp + dim2typepassback$ + IF LEN(appendtype$) AND newDimSyntax = 0 THEN + IF LEN(dim2typepassback$) THEN appendtype$ = sp + SCase$("As") + sp + dim2typepassback$ l$ = l$ + appendtype$ - End If + END IF 'modify first element name to include symbol dimstatic = olddimstatic - End If 'listarray=0 + END IF 'listarray=0 - If newDimSyntax Then Return + IF newDimSyntax THEN RETURN - If d$ = "," Then l$ = l$ + sp2 + ",": GoTo dimnext + IF d$ = "," THEN l$ = l$ + sp2 + ",": GOTO dimnext dimoption = 0 dimshared = 0 redimoption = 0 - If dimstatic = 1 Then dimstatic = 0 + IF dimstatic = 1 THEN dimstatic = 0 AllowLocalName = 0 layoutdone = 1 - If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$ + IF LEN(layout$) = 0 THEN layout$ = l$ ELSE layout$ = layout$ + sp + l$ - GoTo finishedline - Else + GOTO finishedline + ELSE 'yes, this is the new dim syntax. i = i + 1 'skip "AS" newDimSyntaxTypePassBack = 0 @@ -8306,62 +8306,62 @@ Do typ$ = "" varname$ = "" previousElement$ = "" - For i = i To n + FOR i = i TO n d$ = getelement(a$, i) - If d$ = "," Or d$ = "(" Then Exit For + IF d$ = "," OR d$ = "(" THEN EXIT FOR varname$ = getelement(ca$, i) - If Len(previousElement$) Then + IF LEN(previousElement$) THEN typ$ = typ$ + previousElement$ + " " appendtype$ = appendtype$ + sp + previousElement$ - End If + END IF previousElement$ = d$ d$ = "" - Next + NEXT appendtype$ = SCase2$(appendtype$) 'capitalise default types (udt override this later if necessary) - typ$ = RTrim$(typ$) + typ$ = RTRIM$(typ$) dimnext2: notype = 0 listarray = 0 - If typ$ = "" Or varname$ = "" Then a$ = "Expected " + firstelement$ + " AS type variable-list or " + firstelement$ + " variable-name AS type": GoTo errmes + IF typ$ = "" OR varname$ = "" THEN a$ = "Expected " + firstelement$ + " AS type variable-list or " + firstelement$ + " variable-name AS type": GOTO errmes 'get the next element - If i >= n + 1 Then e$ = "" Else e$ = getelement(a$, i): i = i + 1 + IF i >= n + 1 THEN e$ = "" ELSE e$ = getelement(a$, i): i = i + 1 'check if next element is a ( to create an array elements$ = "" - If e$ = "(" Then + IF e$ = "(" THEN B = 1 - For i = i To n + FOR i = i TO n e$ = getelement(ca$, i) - If e$ = "(" Then B = B + 1 - If e$ = ")" Then B = B - 1 - If B = 0 Then Exit For - If Len(elements$) Then elements$ = elements$ + sp + e$ Else elements$ = e$ - Next - If B <> 0 Then a$ = "Expected )": GoTo errmes + IF e$ = "(" THEN B = B + 1 + IF e$ = ")" THEN B = B - 1 + IF B = 0 THEN EXIT FOR + IF LEN(elements$) THEN elements$ = elements$ + sp + e$ ELSE elements$ = e$ + NEXT + IF B <> 0 THEN a$ = "Expected )": GOTO errmes i = i + 1 'set i to point to the next element - If commonoption Then elements$ = "?" + IF commonoption THEN elements$ = "?" - If Debug Then Print #9, "DIM2:array:elements$:[" + elements$ + "]" + IF Debug THEN PRINT #9, "DIM2:array:elements$:[" + elements$ + "]" 'arrayname() means list array to it will automatically be static when it is formally dimensioned later 'note: listed arrays are always created in dynamic memory, but their contents are not erased ' this differs from static arrays from SUB...STATIC and the unique QB64 method -> STATIC arrayname(100) - If dimoption = 3 Then 'STATIC used - If Len(elements$) = 0 Then 'nothing between brackets + IF dimoption = 3 THEN 'STATIC used + IF LEN(elements$) = 0 THEN 'nothing between brackets listarray = 1 'add to static list - End If - End If + END IF + END IF 'last element was ")" 'get next element - If i >= n + 1 Then e$ = "" Else e$ = getelement(a$, i): i = i + 1 - End If 'e$="(" + IF i >= n + 1 THEN e$ = "" ELSE e$ = getelement(a$, i): i = i + 1 + END IF 'e$="(" d$ = e$ dimmethod = 0 @@ -8370,39 +8370,39 @@ Do 'does varname have an appended symbol? s$ = removesymbol$(varname$) - If Error_Happened Then GoTo errmes - If validname(varname$) = 0 Then a$ = "Invalid variable name": GoTo errmes + IF Error_Happened THEN GOTO errmes + IF validname(varname$) = 0 THEN a$ = "Invalid variable name": GOTO errmes - If s$ <> "" Then + IF s$ <> "" THEN a$ = "Cannot use type symbol with " + firstelement$ + " AS type variable-list (" + s$ + ")" - GoTo errmes - End If + GOTO errmes + END IF - If d$ <> "" And d$ <> "," Then a$ = "DIM: Expected comma!": GoTo errmes + IF d$ <> "" AND d$ <> "," THEN a$ = "DIM: Expected comma!": GOTO errmes newDimSyntax = -1 - GoSub NormalDimBlock + GOSUB NormalDimBlock newDimSyntax = 0 - If d$ = "," Then + IF d$ = "," THEN l$ = l$ + sp2 + "," varname$ = getelement(ca$, i): i = i + 1 - GoTo dimnext2 - End If + GOTO dimnext2 + END IF dimoption = 0 dimshared = 0 redimoption = 0 - If dimstatic = 1 Then dimstatic = 0 + IF dimstatic = 1 THEN dimstatic = 0 AllowLocalName = 0 layoutdone = 1 - If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$ + IF LEN(layout$) = 0 THEN layout$ = l$ ELSE layout$ = layout$ + sp + l$ - GoTo finishedline - End If - End If - End If + GOTO finishedline + END IF + END IF + END IF @@ -8415,38 +8415,38 @@ Do 'THEN [GOTO] linenumber? - If THENGOTO = 1 Then - If n = 1 Then + IF THENGOTO = 1 THEN + IF n = 1 THEN l$ = "" - a = Asc(Left$(firstelement$, 1)) - If a = 46 Or (a >= 48 And a <= 57) Then a2$ = ca$: GoTo THENGOTO - End If - End If + a = ASC(LEFT$(firstelement$, 1)) + IF a = 46 OR (a >= 48 AND a <= 57) THEN a2$ = ca$: GOTO THENGOTO + END IF + END IF 'goto - If n = 2 Then - If getelement$(a$, 1) = "GOTO" Then + IF n = 2 THEN + IF getelement$(a$, 1) = "GOTO" THEN l$ = SCase$("GoTo") a2$ = getelement$(ca$, 2) THENGOTO: - If validlabel(a2$) = 0 Then a$ = "Invalid label!": GoTo errmes + IF validlabel(a2$) = 0 THEN a$ = "Invalid label!": GOTO errmes v = HashFind(a2$, HASHFLAG_LABEL, ignore, r) x = 1 labchk2: - If v Then + IF v THEN s = Labels(r).Scope - If s = subfuncn Or s = -1 Then 'same scope? - If s = -1 Then Labels(r).Scope = subfuncn 'acquire scope + IF s = subfuncn OR s = -1 THEN 'same scope? + IF s = -1 THEN Labels(r).Scope = subfuncn 'acquire scope x = 0 'already defined - tlayout$ = RTrim$(Labels(r).cn) - Else - If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk2 - End If - End If - If x Then + tlayout$ = RTRIM$(Labels(r).cn) + ELSE + IF v = 2 THEN v = HashFindCont(ignore, r): GOTO labchk2 + END IF + END IF + IF x THEN 'does not exist - nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type + nLabels = nLabels + 1: IF nLabels > Labels_Ubound THEN Labels_Ubound = Labels_Ubound * 2: REDIM _PRESERVE Labels(1 TO Labels_Ubound) AS Label_Type Labels(nLabels) = Empty_Label HashAdd a2$, HASHFLAG_LABEL, nLabels r = nLabels @@ -8454,81 +8454,81 @@ Do Labels(r).cn = tlayout$ Labels(r).Scope = subfuncn Labels(r).Error_Line = linenumber - End If 'x + END IF 'x - If Len(l$) Then l$ = l$ + sp + tlayout$ Else l$ = tlayout$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - Print #12, "goto LABEL_" + a2$ + ";" - GoTo finishedline - End If - End If + IF LEN(l$) THEN l$ = l$ + sp + tlayout$ ELSE l$ = tlayout$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + PRINT #12, "goto LABEL_" + a2$ + ";" + GOTO finishedline + END IF + END IF - If n = 1 Then - If firstelement$ = "_CONTINUE" Or (firstelement$ = "CONTINUE" And qb64prefix_set = 1) Then - If firstelement$ = "_CONTINUE" Then l$ = SCase$("_Continue") Else l$ = SCase$("Continue") + IF n = 1 THEN + IF firstelement$ = "_CONTINUE" OR (firstelement$ = "CONTINUE" AND qb64prefix_set = 1) THEN + IF firstelement$ = "_CONTINUE" THEN l$ = SCase$("_Continue") ELSE l$ = SCase$("Continue") 'scan backwards until previous control level reached - For i = controllevel To 1 Step -1 + FOR i = controllevel TO 1 STEP -1 t = controltype(i) - If t = 2 Then 'for...next - Print #12, "goto fornext_continue_" + str2$(controlid(i)) + ";" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - ElseIf t = 3 Or t = 4 Then 'do...loop - Print #12, "goto dl_continue_" + str2$(controlid(i)) + ";" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - ElseIf t = 5 Then 'while...wend - Print #12, "goto ww_continue_" + str2$(controlid(i)) + ";" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - Next - a$ = qb64prefix$ + "CONTINUE outside DO..LOOP/FOR..NEXT/WHILE..WEND block": GoTo errmes - End If - End If + IF t = 2 THEN 'for...next + PRINT #12, "goto fornext_continue_" + str2$(controlid(i)) + ";" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + ELSEIF t = 3 OR t = 4 THEN 'do...loop + PRINT #12, "goto dl_continue_" + str2$(controlid(i)) + ";" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + ELSEIF t = 5 THEN 'while...wend + PRINT #12, "goto ww_continue_" + str2$(controlid(i)) + ";" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + NEXT + a$ = qb64prefix$ + "CONTINUE outside DO..LOOP/FOR..NEXT/WHILE..WEND block": GOTO errmes + END IF + END IF - If firstelement$ = "RUN" Then 'RUN + IF firstelement$ = "RUN" THEN 'RUN l$ = SCase$("Run") - If n = 1 Then + IF n = 1 THEN 'no parameters - Print #12, "sub_run_init();" 'note: called first to free up screen-locked image handles - Print #12, "sub_clear(NULL,NULL,NULL,NULL);" 'use functionality of CLEAR - If Len(subfunc$) Then - Print #12, "QBMAIN(NULL);" - Else - Print #12, "goto S_0;" - End If - Else + PRINT #12, "sub_run_init();" 'note: called first to free up screen-locked image handles + PRINT #12, "sub_clear(NULL,NULL,NULL,NULL);" 'use functionality of CLEAR + IF LEN(subfunc$) THEN + PRINT #12, "QBMAIN(NULL);" + ELSE + PRINT #12, "goto S_0;" + END IF + ELSE 'parameter passed e$ = getelements$(ca$, 2, n) e$ = fixoperationorder$(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l2$ = tlayout$ ignore$ = evaluate(e$, typ) - If Error_Happened Then GoTo errmes - If n = 2 And ((typ And ISSTRING) = 0) Then + IF Error_Happened THEN GOTO errmes + IF n = 2 AND ((typ AND ISSTRING) = 0) THEN 'assume it's a label or line number lbl$ = getelement$(ca$, 2) - If validlabel(lbl$) = 0 Then a$ = "Invalid label!": GoTo errmes 'invalid label + IF validlabel(lbl$) = 0 THEN a$ = "Invalid label!": GOTO errmes 'invalid label v = HashFind(lbl$, HASHFLAG_LABEL, ignore, r) x = 1 labchk501: - If v Then + IF v THEN s = Labels(r).Scope - If s = 0 Or s = -1 Then 'main scope? - If s = -1 Then Labels(r).Scope = 0 'acquire scope + IF s = 0 OR s = -1 THEN 'main scope? + IF s = -1 THEN Labels(r).Scope = 0 'acquire scope x = 0 'already defined - tlayout$ = RTrim$(Labels(r).cn) + tlayout$ = RTRIM$(Labels(r).cn) Labels(r).Scope_Restriction = subfuncn Labels(r).Error_Line = linenumber - Else - If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk501 - End If - End If - If x Then + ELSE + IF v = 2 THEN v = HashFindCont(ignore, r): GOTO labchk501 + END IF + END IF + IF x THEN 'does not exist - nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type + nLabels = nLabels + 1: IF nLabels > Labels_Ubound THEN Labels_Ubound = Labels_Ubound * 2: REDIM _PRESERVE Labels(1 TO Labels_Ubound) AS Label_Type Labels(nLabels) = Empty_Label HashAdd lbl$, HASHFLAG_LABEL, nLabels r = nLabels @@ -8537,145 +8537,145 @@ Do Labels(r).Scope = 0 Labels(r).Error_Line = linenumber Labels(r).Scope_Restriction = subfuncn - End If 'x + END IF 'x l$ = l$ + sp + tlayout$ - Print #12, "sub_run_init();" 'note: called first to free up screen-locked image handles - Print #12, "sub_clear(NULL,NULL,NULL,NULL);" 'use functionality of CLEAR - If Len(subfunc$) Then - Print #21, "if (run_from_line==" + str2(nextrunlineindex) + "){run_from_line=0;goto LABEL_" + lbl$ + ";}" - Print #12, "run_from_line=" + str2(nextrunlineindex) + ";" + PRINT #12, "sub_run_init();" 'note: called first to free up screen-locked image handles + PRINT #12, "sub_clear(NULL,NULL,NULL,NULL);" 'use functionality of CLEAR + IF LEN(subfunc$) THEN + PRINT #21, "if (run_from_line==" + str2(nextrunlineindex) + "){run_from_line=0;goto LABEL_" + lbl$ + ";}" + PRINT #12, "run_from_line=" + str2(nextrunlineindex) + ";" nextrunlineindex = nextrunlineindex + 1 - Print #12, "QBMAIN(NULL);" - Else - Print #12, "goto LABEL_" + lbl$ + ";" - End If - Else + PRINT #12, "QBMAIN(NULL);" + ELSE + PRINT #12, "goto LABEL_" + lbl$ + ";" + END IF + ELSE 'assume it's a string containing a filename to execute e$ = evaluatetotyp(e$, ISSTRING) - If Error_Happened Then GoTo errmes - Print #12, "sub_run(" + e$ + ");" + IF Error_Happened THEN GOTO errmes + PRINT #12, "sub_run(" + e$ + ");" l$ = l$ + sp + l2$ - End If 'isstring - End If 'n=1 - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If 'run + END IF 'isstring + END IF 'n=1 + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF 'run - If firstelement$ = "END" Then + IF firstelement$ = "END" THEN l$ = SCase$("End") - If n > 1 Then + IF n > 1 THEN e$ = getelements$(ca$, 2, n) - e$ = fixoperationorder$(e$): If Error_Happened Then GoTo errmes + e$ = fixoperationorder$(e$): IF Error_Happened THEN GOTO errmes l2$ = tlayout$ - e$ = evaluatetotyp(e$, ISINTEGER64): If Error_Happened Then GoTo errmes + e$ = evaluatetotyp(e$, ISINTEGER64): IF Error_Happened THEN GOTO errmes inclinenump$ = "" - If inclinenumber(inclevel) Then + IF inclinenumber(inclevel) THEN inclinenump$ = "," + str2$(inclinenumber(inclevel)) thisincname$ = getfilepath$(incname$(inclevel)) - thisincname$ = Mid$(incname$(inclevel), Len(thisincname$) + 1) - inclinenump$ = inclinenump$ + "," + Chr$(34) + thisincname$ + Chr$(34) - End If - Print #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");}" 'non-resumable error check (cannot exit without handling errors) - Print #12, "exit_code=" + e$ + ";" + thisincname$ = MID$(incname$(inclevel), LEN(thisincname$) + 1) + inclinenump$ = inclinenump$ + "," + CHR$(34) + thisincname$ + CHR$(34) + END IF + PRINT #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");}" 'non-resumable error check (cannot exit without handling errors) + PRINT #12, "exit_code=" + e$ + ";" l$ = l$ + sp + l2$ - End If + END IF xend - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF - If firstelement$ = "SYSTEM" Then + IF firstelement$ = "SYSTEM" THEN l$ = SCase$("System") - If n > 1 Then + IF n > 1 THEN e$ = getelements$(ca$, 2, n) - e$ = fixoperationorder$(e$): If Error_Happened Then GoTo errmes + e$ = fixoperationorder$(e$): IF Error_Happened THEN GOTO errmes l2$ = tlayout$ - e$ = evaluatetotyp(e$, ISINTEGER64): If Error_Happened Then GoTo errmes + e$ = evaluatetotyp(e$, ISINTEGER64): IF Error_Happened THEN GOTO errmes inclinenump$ = "" - If inclinenumber(inclevel) Then + IF inclinenumber(inclevel) THEN inclinenump$ = "," + str2$(inclinenumber(inclevel)) thisincname$ = getfilepath$(incname$(inclevel)) - thisincname$ = Mid$(incname$(inclevel), Len(thisincname$) + 1) - inclinenump$ = inclinenump$ + "," + Chr$(34) + thisincname$ + Chr$(34) - End If - Print #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");}" 'non-resumable error check (cannot exit without handling errors) - Print #12, "exit_code=" + e$ + ";" + thisincname$ = MID$(incname$(inclevel), LEN(thisincname$) + 1) + inclinenump$ = inclinenump$ + "," + CHR$(34) + thisincname$ + CHR$(34) + END IF + PRINT #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");}" 'non-resumable error check (cannot exit without handling errors) + PRINT #12, "exit_code=" + e$ + ";" l$ = l$ + sp + l2$ - End If + END IF - Print #12, "if (sub_gl_called) error(271);" - Print #12, "close_program=1;" - Print #12, "end();" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If + PRINT #12, "if (sub_gl_called) error(271);" + PRINT #12, "close_program=1;" + PRINT #12, "end();" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF - If n >= 1 Then - If firstelement$ = "STOP" Then + IF n >= 1 THEN + IF firstelement$ = "STOP" THEN l$ = SCase$("Stop") - If n > 1 Then + IF n > 1 THEN e$ = getelements$(ca$, 2, n) e$ = fixoperationorder$(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = SCase$("Stop") + sp + tlayout$ e$ = evaluatetotyp(e$, 64) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes 'note: this value is currently ignored but evaluated for checking reasons - End If - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - Print #12, "close_program=1;" - Print #12, "end();" - GoTo finishedline - End If - End If + END IF + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + PRINT #12, "close_program=1;" + PRINT #12, "end();" + GOTO finishedline + END IF + END IF - If n = 2 Then - If firstelement$ = "GOSUB" Then + IF n = 2 THEN + IF firstelement$ = "GOSUB" THEN xgosub ca$ - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes 'note: layout implemented in xgosub - GoTo finishedline - End If - End If + GOTO finishedline + END IF + END IF - If n >= 1 Then - If firstelement$ = "RETURN" Then - If n = 1 Then - Print #12, "#include " + Chr$(34) + "ret" + str2$(subfuncn) + ".txt" + Chr$(34) + IF n >= 1 THEN + IF firstelement$ = "RETURN" THEN + IF n = 1 THEN + PRINT #12, "#include " + CHR$(34) + "ret" + str2$(subfuncn) + ".txt" + CHR$(34) l$ = SCase$("Return") - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - Else + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + ELSE 'label/linenumber follows - If subfuncn <> 0 Then a$ = "RETURN linelabel/linenumber invalid within a SUB/FUNCTION": GoTo errmes - If n > 2 Then a$ = "Expected linelabel/linenumber after RETURN": GoTo errmes - Print #12, "if (!next_return_point) error(3);" 'check return point available - Print #12, "next_return_point--;" 'destroy return point + IF subfuncn <> 0 THEN a$ = "RETURN linelabel/linenumber invalid within a SUB/FUNCTION": GOTO errmes + IF n > 2 THEN a$ = "Expected linelabel/linenumber after RETURN": GOTO errmes + PRINT #12, "if (!next_return_point) error(3);" 'check return point available + PRINT #12, "next_return_point--;" 'destroy return point a2$ = getelement$(ca$, 2) - If validlabel(a2$) = 0 Then a$ = "Invalid label!": GoTo errmes + IF validlabel(a2$) = 0 THEN a$ = "Invalid label!": GOTO errmes v = HashFind(a2$, HASHFLAG_LABEL, ignore, r) x = 1 labchk505: - If v Then + IF v THEN s = Labels(r).Scope - If s = subfuncn Or s = -1 Then 'same scope? - If s = -1 Then Labels(r).Scope = subfuncn 'acquire scope + IF s = subfuncn OR s = -1 THEN 'same scope? + IF s = -1 THEN Labels(r).Scope = subfuncn 'acquire scope x = 0 'already defined - tlayout$ = RTrim$(Labels(r).cn) - Else - If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk505 - End If - End If - If x Then + tlayout$ = RTRIM$(Labels(r).cn) + ELSE + IF v = 2 THEN v = HashFindCont(ignore, r): GOTO labchk505 + END IF + END IF + IF x THEN 'does not exist - nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type + nLabels = nLabels + 1: IF nLabels > Labels_Ubound THEN Labels_Ubound = Labels_Ubound * 2: REDIM _PRESERVE Labels(1 TO Labels_Ubound) AS Label_Type Labels(nLabels) = Empty_Label HashAdd a2$, HASHFLAG_LABEL, nLabels r = nLabels @@ -8683,58 +8683,58 @@ Do Labels(r).cn = tlayout$ Labels(r).Scope = subfuncn Labels(r).Error_Line = linenumber - End If 'x + END IF 'x - Print #12, "goto LABEL_" + a2$ + ";" + PRINT #12, "goto LABEL_" + a2$ + ";" l$ = SCase$("Return") + sp + tlayout$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - End If - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + END IF + END IF - If n >= 1 Then - If firstelement$ = "RESUME" Then + IF n >= 1 THEN + IF firstelement$ = "RESUME" THEN l$ = SCase$("Resume") - If n = 1 Then + IF n = 1 THEN resumeprev: - Print #12, "if (!error_handling){error(20);}else{error_retry=1; qbevent=1; error_handling=0; error_err=0; return;}" + PRINT #12, "if (!error_handling){error(20);}else{error_retry=1; qbevent=1; error_handling=0; error_err=0; return;}" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - If n > 2 Then a$ = "Too many parameters": GoTo errmes + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + IF n > 2 THEN a$ = "Too many parameters": GOTO errmes s$ = getelement$(ca$, 2) - If UCase$(s$) = "NEXT" Then + IF UCASE$(s$) = "NEXT" THEN - Print #12, "if (!error_handling){error(20);}else{error_handling=0; error_err=0; return;}" + PRINT #12, "if (!error_handling){error(20);}else{error_handling=0; error_err=0; return;}" l$ = l$ + sp + SCase$("Next") - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - If s$ = "0" Then l$ = l$ + sp + "0": GoTo resumeprev - If validlabel(s$) = 0 Then a$ = "Invalid label passed to RESUME": GoTo errmes + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + IF s$ = "0" THEN l$ = l$ + sp + "0": GOTO resumeprev + IF validlabel(s$) = 0 THEN a$ = "Invalid label passed to RESUME": GOTO errmes v = HashFind(s$, HASHFLAG_LABEL, ignore, r) x = 1 labchk506: - If v Then + IF v THEN s = Labels(r).Scope - If s = subfuncn Or s = -1 Then 'same scope? - If s = -1 Then Labels(r).Scope = subfuncn 'acquire scope + IF s = subfuncn OR s = -1 THEN 'same scope? + IF s = -1 THEN Labels(r).Scope = subfuncn 'acquire scope x = 0 'already defined - tlayout$ = RTrim$(Labels(r).cn) - Else - If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk506 - End If - End If - If x Then + tlayout$ = RTRIM$(Labels(r).cn) + ELSE + IF v = 2 THEN v = HashFindCont(ignore, r): GOTO labchk506 + END IF + END IF + IF x THEN 'does not exist - nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type + nLabels = nLabels + 1: IF nLabels > Labels_Ubound THEN Labels_Ubound = Labels_Ubound * 2: REDIM _PRESERVE Labels(1 TO Labels_Ubound) AS Label_Type Labels(nLabels) = Empty_Label HashAdd s$, HASHFLAG_LABEL, nLabels r = nLabels @@ -8742,45 +8742,45 @@ Do Labels(r).cn = tlayout$ Labels(r).Scope = subfuncn Labels(r).Error_Line = linenumber - End If 'x + END IF 'x l$ = l$ + sp + tlayout$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - Print #12, "if (!error_handling){error(20);}else{error_handling=0; error_err=0; goto LABEL_" + s$ + ";}" - GoTo finishedline - End If - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + PRINT #12, "if (!error_handling){error(20);}else{error_handling=0; error_err=0; goto LABEL_" + s$ + ";}" + GOTO finishedline + END IF + END IF - If n = 4 Then - If getelements(a$, 1, 3) = "ON" + sp + "ERROR" + sp + "GOTO" Then + IF n = 4 THEN + IF getelements(a$, 1, 3) = "ON" + sp + "ERROR" + sp + "GOTO" THEN l$ = SCase$("On" + sp + "Error" + sp + "GoTo") lbl$ = getelement$(ca$, 4) - If lbl$ = "0" Then - Print #12, "error_goto_line=0;" + IF lbl$ = "0" THEN + PRINT #12, "error_goto_line=0;" l$ = l$ + sp + "0" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - If validlabel(lbl$) = 0 Then a$ = "Invalid label": GoTo errmes + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + IF validlabel(lbl$) = 0 THEN a$ = "Invalid label": GOTO errmes v = HashFind(lbl$, HASHFLAG_LABEL, ignore, r) x = 1 labchk6: - If v Then + IF v THEN s = Labels(r).Scope - If s = 0 Or s = -1 Then 'main scope? - If s = -1 Then Labels(r).Scope = 0 'acquire scope + IF s = 0 OR s = -1 THEN 'main scope? + IF s = -1 THEN Labels(r).Scope = 0 'acquire scope x = 0 'already defined - tlayout$ = RTrim$(Labels(r).cn) + tlayout$ = RTRIM$(Labels(r).cn) Labels(r).Scope_Restriction = subfuncn Labels(r).Error_Line = linenumber - Else - If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk6 - End If - End If - If x Then + ELSE + IF v = 2 THEN v = HashFindCont(ignore, r): GOTO labchk6 + END IF + END IF + IF x THEN 'does not exist - nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type + nLabels = nLabels + 1: IF nLabels > Labels_Ubound THEN Labels_Ubound = Labels_Ubound * 2: REDIM _PRESERVE Labels(1 TO Labels_Ubound) AS Label_Type Labels(nLabels) = Empty_Label HashAdd lbl$, HASHFLAG_LABEL, nLabels r = nLabels @@ -8789,40 +8789,40 @@ Do Labels(r).Scope = 0 Labels(r).Error_Line = linenumber Labels(r).Scope_Restriction = subfuncn - End If 'x + END IF 'x l$ = l$ + sp + tlayout$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ errorlabels = errorlabels + 1 - Print #12, "error_goto_line=" + str2(errorlabels) + ";" - Print #14, "if (error_goto_line==" + str2(errorlabels) + "){error_handling=1; goto LABEL_" + lbl$ + ";}" - GoTo finishedline - End If - End If + PRINT #12, "error_goto_line=" + str2(errorlabels) + ";" + PRINT #14, "if (error_goto_line==" + str2(errorlabels) + "){error_handling=1; goto LABEL_" + lbl$ + ";}" + GOTO finishedline + END IF + END IF - If n >= 1 Then - If firstelement$ = "RESTORE" Then + IF n >= 1 THEN + IF firstelement$ = "RESTORE" THEN l$ = SCase$("Restore") - If n = 1 Then - Print #12, "data_offset=0;" - Else - If n > 2 Then a$ = "Syntax error": GoTo errmes + IF n = 1 THEN + PRINT #12, "data_offset=0;" + ELSE + IF n > 2 THEN a$ = "Syntax error": GOTO errmes lbl$ = getelement$(ca$, 2) - If validlabel(lbl$) = 0 Then a$ = "Invalid label": GoTo errmes + IF validlabel(lbl$) = 0 THEN a$ = "Invalid label": GOTO errmes 'rule: a RESTORE label has no scope, therefore, only one instance of that label may exist 'how: enforced by a post check for duplicates v = HashFind(lbl$, HASHFLAG_LABEL, ignore, r) x = 1 - If v Then 'already defined + IF v THEN 'already defined x = 0 - tlayout$ = RTrim$(Labels(r).cn) + tlayout$ = RTRIM$(Labels(r).cn) Labels(r).Data_Referenced = 1 'make sure the data referenced flag is set - If Labels(r).Error_Line = 0 Then Labels(r).Error_Line = linenumber - End If - If x Then - nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type + IF Labels(r).Error_Line = 0 THEN Labels(r).Error_Line = linenumber + END IF + IF x THEN + nLabels = nLabels + 1: IF nLabels > Labels_Ubound THEN Labels_Ubound = Labels_Ubound * 2: REDIM _PRESERVE Labels(1 TO Labels_Ubound) AS Label_Type Labels(nLabels) = Empty_Label HashAdd lbl$, HASHFLAG_LABEL, nLabels r = nLabels @@ -8831,58 +8831,58 @@ Do Labels(r).Scope = -1 'modifyable scope Labels(r).Error_Line = linenumber Labels(r).Data_Referenced = 1 - End If 'x + END IF 'x l$ = l$ + sp + tlayout$ - Print #12, "data_offset=data_at_LABEL_" + lbl$ + ";" - End If - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - End If + PRINT #12, "data_offset=data_at_LABEL_" + lbl$ + ";" + END IF + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + END IF 'ON ... GOTO/GOSUB - If n >= 1 Then - If firstelement$ = "ON" Then + IF n >= 1 THEN + IF firstelement$ = "ON" THEN xongotogosub a$, ca$, n - If Error_Happened Then GoTo errmes - GoTo finishedline - End If - End If + IF Error_Happened THEN GOTO errmes + GOTO finishedline + END IF + END IF '(_MEM) _MEMPUT _MEMGET - If n >= 1 Then - If firstelement$ = "_MEMGET" Or (firstelement$ = "MEMGET" And qb64prefix_set = 1) Then + IF n >= 1 THEN + IF firstelement$ = "_MEMGET" OR (firstelement$ = "MEMGET" AND qb64prefix_set = 1) THEN 'get expressions e$ = "" B = 0 ne = 0 - For i2 = 2 To n + FOR i2 = 2 TO n e2$ = getelement$(ca$, i2) - If e2$ = "(" Then B = B + 1 - If e2$ = ")" Then B = B - 1 - If e2$ = "," And B = 0 Then + IF e2$ = "(" THEN B = B + 1 + IF e2$ = ")" THEN B = B - 1 + IF e2$ = "," AND B = 0 THEN ne = ne + 1 - If ne = 1 Then blk$ = e$: e$ = "" - If ne = 2 Then offs$ = e$: e$ = "" - If ne = 3 Then a$ = "Syntax error": GoTo errmes - Else - If Len(e$) = 0 Then e$ = e2$ Else e$ = e$ + sp + e2$ - End If - Next + IF ne = 1 THEN blk$ = e$: e$ = "" + IF ne = 2 THEN offs$ = e$: e$ = "" + IF ne = 3 THEN a$ = "Syntax error": GOTO errmes + ELSE + IF LEN(e$) = 0 THEN e$ = e2$ ELSE e$ = e$ + sp + e2$ + END IF + NEXT var$ = e$ - If e$ = "" Or ne <> 2 Then a$ = "Expected " + qb64prefix$ + "MEMGET mem-reference, offset, variable": GoTo errmes + IF e$ = "" OR ne <> 2 THEN a$ = "Expected " + qb64prefix$ + "MEMGET mem-reference, offset, variable": GOTO errmes - If firstelement$ = "_MEMGET" Then l$ = SCase$("_MemGet") + sp Else l$ = SCase$("MemGet") + sp + IF firstelement$ = "_MEMGET" THEN l$ = SCase$("_MemGet") + sp ELSE l$ = SCase$("MemGet") + sp - e$ = fixoperationorder$(blk$): If Error_Happened Then GoTo errmes + e$ = fixoperationorder$(blk$): IF Error_Happened THEN GOTO errmes l$ = l$ + tlayout$ - test$ = evaluate(e$, typ): If Error_Happened Then GoTo errmes - If (typ And ISUDT) = 0 Or (typ And 511) <> 1 Then a$ = "Expected " + qb64prefix$ + "MEM type": GoTo errmes + test$ = evaluate(e$, typ): IF Error_Happened THEN GOTO errmes + IF (typ AND ISUDT) = 0 OR (typ AND 511) <> 1 THEN a$ = "Expected " + qb64prefix$ + "MEM type": GOTO errmes blkoffs$ = evaluatetotyp(e$, -6) ' IF typ AND ISREFERENCE THEN e$ = refer(e$, typ, 0) @@ -8890,16 +8890,16 @@ Do 'PRINT #12, blkoffs$ '??? - e$ = fixoperationorder$(offs$): If Error_Happened Then GoTo errmes + e$ = fixoperationorder$(offs$): IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ - e$ = evaluatetotyp(e$, OFFSETTYPE - ISPOINTER): If Error_Happened Then GoTo errmes + e$ = evaluatetotyp(e$, OFFSETTYPE - ISPOINTER): IF Error_Happened THEN GOTO errmes offs$ = e$ 'PRINT #12, e$ '??? - e$ = fixoperationorder$(var$): If Error_Happened Then GoTo errmes + e$ = fixoperationorder$(var$): IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ - varsize$ = evaluatetotyp(e$, -5): If Error_Happened Then GoTo errmes - varoffs$ = evaluatetotyp(e$, -6): If Error_Happened Then GoTo errmes + varsize$ = evaluatetotyp(e$, -5): IF Error_Happened THEN GOTO errmes + varoffs$ = evaluatetotyp(e$, -6): IF Error_Happened THEN GOTO errmes 'PRINT #12, varoffs$ '??? @@ -8910,283 +8910,283 @@ Do 'known sizes will be handled by designated command casts, otherwise use memmove s = 0 - If varsize$ = "1" Then s = 1: st$ = "int8" - If varsize$ = "2" Then s = 2: st$ = "int16" - If varsize$ = "4" Then s = 4: st$ = "int32" - If varsize$ = "8" Then s = 8: st$ = "int64" + IF varsize$ = "1" THEN s = 1: st$ = "int8" + IF varsize$ = "2" THEN s = 2: st$ = "int16" + IF varsize$ = "4" THEN s = 4: st$ = "int32" + IF varsize$ = "8" THEN s = 8: st$ = "int64" - If NoChecks Then + IF NoChecks THEN 'fast version: - If s Then - Print #12, "*(" + st$ + "*)" + varoffs$ + "=*(" + st$ + "*)(" + offs$ + ");" - Else - Print #12, "memmove(" + varoffs$ + ",(void*)" + offs$ + "," + varsize$ + ");" - End If - Else + IF s THEN + PRINT #12, "*(" + st$ + "*)" + varoffs$ + "=*(" + st$ + "*)(" + offs$ + ");" + ELSE + PRINT #12, "memmove(" + varoffs$ + ",(void*)" + offs$ + "," + varsize$ + ");" + END IF + ELSE 'safe version: - Print #12, "tmp_long=" + offs$ + ";" + PRINT #12, "tmp_long=" + offs$ + ";" 'is mem block init? - Print #12, "if ( ((mem_block*)(" + blkoffs$ + "))->lock_offset ){" + PRINT #12, "if ( ((mem_block*)(" + blkoffs$ + "))->lock_offset ){" 'are region and id valid? - Print #12, "if (" - Print #12, "tmp_long < ((mem_block*)(" + blkoffs$ + "))->offset ||" - Print #12, "(tmp_long+(" + varsize$ + ")) > ( ((mem_block*)(" + blkoffs$ + "))->offset + ((mem_block*)(" + blkoffs$ + "))->size) ||" - Print #12, "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id ){" + PRINT #12, "if (" + PRINT #12, "tmp_long < ((mem_block*)(" + blkoffs$ + "))->offset ||" + PRINT #12, "(tmp_long+(" + varsize$ + ")) > ( ((mem_block*)(" + blkoffs$ + "))->offset + ((mem_block*)(" + blkoffs$ + "))->size) ||" + PRINT #12, "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id ){" 'diagnose error - Print #12, "if (" + "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id" + ") error(308); else error(300);" - Print #12, "}else{" - If s Then - Print #12, "*(" + st$ + "*)" + varoffs$ + "=*(" + st$ + "*)tmp_long;" - Else - Print #12, "memmove(" + varoffs$ + ",(void*)tmp_long," + varsize$ + ");" - End If - Print #12, "}" - Print #12, "}else error(309);" - End If + PRINT #12, "if (" + "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id" + ") error(308); else error(300);" + PRINT #12, "}else{" + IF s THEN + PRINT #12, "*(" + st$ + "*)" + varoffs$ + "=*(" + st$ + "*)tmp_long;" + ELSE + PRINT #12, "memmove(" + varoffs$ + ",(void*)tmp_long," + varsize$ + ");" + END IF + PRINT #12, "}" + PRINT #12, "}else error(309);" + END IF - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline - End If - End If + END IF + END IF - If n >= 1 Then - If firstelement$ = "_MEMPUT" Or (firstelement$ = "MEMPUT" And qb64prefix_set = 1) Then + IF n >= 1 THEN + IF firstelement$ = "_MEMPUT" OR (firstelement$ = "MEMPUT" AND qb64prefix_set = 1) THEN 'get expressions typ$ = "" e$ = "" B = 0 ne = 0 - For i2 = 2 To n + FOR i2 = 2 TO n e2$ = getelement$(ca$, i2) - If e2$ = "(" Then B = B + 1 - If e2$ = ")" Then B = B - 1 - If (e2$ = "," Or UCase$(e2$) = "AS") And B = 0 Then + IF e2$ = "(" THEN B = B + 1 + IF e2$ = ")" THEN B = B - 1 + IF (e2$ = "," OR UCASE$(e2$) = "AS") AND B = 0 THEN ne = ne + 1 - If ne = 1 Then blk$ = e$: e$ = "" - If ne = 2 Then offs$ = e$: e$ = "" - If ne = 3 Then var$ = e$: e$ = "" - If (UCase$(e2$) = "AS" And ne <> 3) Or (ne = 3 And UCase$(e2$) <> "AS") Or ne = 4 Then a$ = "Expected _MEMPUT mem-reference,offset,variable|value[AS type]": GoTo errmes - Else - If Len(e$) = 0 Then e$ = e2$ Else e$ = e$ + sp + e2$ - End If - Next - If ne < 2 Or e$ = "" Then a$ = "Expected " + qb64prefix$ + "MEMPUT mem-reference, offset, variable|value[AS type]": GoTo errmes - If ne = 2 Then var$ = e$ Else typ$ = UCase$(e$) + IF ne = 1 THEN blk$ = e$: e$ = "" + IF ne = 2 THEN offs$ = e$: e$ = "" + IF ne = 3 THEN var$ = e$: e$ = "" + IF (UCASE$(e2$) = "AS" AND ne <> 3) OR (ne = 3 AND UCASE$(e2$) <> "AS") OR ne = 4 THEN a$ = "Expected _MEMPUT mem-reference,offset,variable|value[AS type]": GOTO errmes + ELSE + IF LEN(e$) = 0 THEN e$ = e2$ ELSE e$ = e$ + sp + e2$ + END IF + NEXT + IF ne < 2 OR e$ = "" THEN a$ = "Expected " + qb64prefix$ + "MEMPUT mem-reference, offset, variable|value[AS type]": GOTO errmes + IF ne = 2 THEN var$ = e$ ELSE typ$ = UCASE$(e$) - If firstelement$ = "_MEMPUT" Then l$ = SCase$("_MemPut") + sp Else l$ = SCase$("MemPut") + sp + IF firstelement$ = "_MEMPUT" THEN l$ = SCase$("_MemPut") + sp ELSE l$ = SCase$("MemPut") + sp - e$ = fixoperationorder$(blk$): If Error_Happened Then GoTo errmes + e$ = fixoperationorder$(blk$): IF Error_Happened THEN GOTO errmes l$ = l$ + tlayout$ - test$ = evaluate(e$, typ): If Error_Happened Then GoTo errmes - If (typ And ISUDT) = 0 Or (typ And 511) <> 1 Then a$ = "Expected " + qb64prefix$ + "MEM type": GoTo errmes + test$ = evaluate(e$, typ): IF Error_Happened THEN GOTO errmes + IF (typ AND ISUDT) = 0 OR (typ AND 511) <> 1 THEN a$ = "Expected " + qb64prefix$ + "MEM type": GOTO errmes blkoffs$ = evaluatetotyp(e$, -6) - e$ = fixoperationorder$(offs$): If Error_Happened Then GoTo errmes + e$ = fixoperationorder$(offs$): IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ - e$ = evaluatetotyp(e$, OFFSETTYPE - ISPOINTER): If Error_Happened Then GoTo errmes + e$ = evaluatetotyp(e$, OFFSETTYPE - ISPOINTER): IF Error_Happened THEN GOTO errmes offs$ = e$ - If ne = 2 Then - e$ = fixoperationorder$(var$): If Error_Happened Then GoTo errmes + IF ne = 2 THEN + e$ = fixoperationorder$(var$): IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ - test$ = evaluate(e$, t): If Error_Happened Then GoTo errmes - If (t And ISREFERENCE) = 0 And (t And ISSTRING) Then - Print #12, "g_tmp_str=" + test$ + ";" + test$ = evaluate(e$, t): IF Error_Happened THEN GOTO errmes + IF (t AND ISREFERENCE) = 0 AND (t AND ISSTRING) THEN + PRINT #12, "g_tmp_str=" + test$ + ";" varsize$ = "g_tmp_str->len" varoffs$ = "g_tmp_str->chr" - Else - varsize$ = evaluatetotyp(e$, -5): If Error_Happened Then GoTo errmes - varoffs$ = evaluatetotyp(e$, -6): If Error_Happened Then GoTo errmes - End If + ELSE + varsize$ = evaluatetotyp(e$, -5): IF Error_Happened THEN GOTO errmes + varoffs$ = evaluatetotyp(e$, -6): IF Error_Happened THEN GOTO errmes + END IF 'known sizes will be handled by designated command casts, otherwise use memmove s = 0 - If varsize$ = "1" Then s = 1: st$ = "int8" - If varsize$ = "2" Then s = 2: st$ = "int16" - If varsize$ = "4" Then s = 4: st$ = "int32" - If varsize$ = "8" Then s = 8: st$ = "int64" + IF varsize$ = "1" THEN s = 1: st$ = "int8" + IF varsize$ = "2" THEN s = 2: st$ = "int16" + IF varsize$ = "4" THEN s = 4: st$ = "int32" + IF varsize$ = "8" THEN s = 8: st$ = "int64" - If NoChecks Then + IF NoChecks THEN 'fast version: - If s Then - Print #12, "*(" + st$ + "*)(" + offs$ + ")=*(" + st$ + "*)" + varoffs$ + ";" - Else - Print #12, "memmove((void*)" + offs$ + "," + varoffs$ + "," + varsize$ + ");" - End If - Else + IF s THEN + PRINT #12, "*(" + st$ + "*)(" + offs$ + ")=*(" + st$ + "*)" + varoffs$ + ";" + ELSE + PRINT #12, "memmove((void*)" + offs$ + "," + varoffs$ + "," + varsize$ + ");" + END IF + ELSE 'safe version: - Print #12, "tmp_long=" + offs$ + ";" + PRINT #12, "tmp_long=" + offs$ + ";" 'is mem block init? - Print #12, "if ( ((mem_block*)(" + blkoffs$ + "))->lock_offset ){" + PRINT #12, "if ( ((mem_block*)(" + blkoffs$ + "))->lock_offset ){" 'are region and id valid? - Print #12, "if (" - Print #12, "tmp_long < ((mem_block*)(" + blkoffs$ + "))->offset ||" - Print #12, "(tmp_long+(" + varsize$ + ")) > ( ((mem_block*)(" + blkoffs$ + "))->offset + ((mem_block*)(" + blkoffs$ + "))->size) ||" - Print #12, "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id ){" + PRINT #12, "if (" + PRINT #12, "tmp_long < ((mem_block*)(" + blkoffs$ + "))->offset ||" + PRINT #12, "(tmp_long+(" + varsize$ + ")) > ( ((mem_block*)(" + blkoffs$ + "))->offset + ((mem_block*)(" + blkoffs$ + "))->size) ||" + PRINT #12, "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id ){" 'diagnose error - Print #12, "if (" + "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id" + ") error(308); else error(300);" - Print #12, "}else{" - If s Then - Print #12, "*(" + st$ + "*)tmp_long=*(" + st$ + "*)" + varoffs$ + ";" - Else - Print #12, "memmove((void*)tmp_long," + varoffs$ + "," + varsize$ + ");" - End If - Print #12, "}" - Print #12, "}else error(309);" - End If + PRINT #12, "if (" + "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id" + ") error(308); else error(300);" + PRINT #12, "}else{" + IF s THEN + PRINT #12, "*(" + st$ + "*)tmp_long=*(" + st$ + "*)" + varoffs$ + ";" + ELSE + PRINT #12, "memmove((void*)tmp_long," + varoffs$ + "," + varsize$ + ");" + END IF + PRINT #12, "}" + PRINT #12, "}else error(309);" + END IF - Else + ELSE '... AS type method 'FUNCTION typname2typ& (t2$) 'typname2typsize = 0 'the default t = typname2typ(typ$) - If t = 0 Then a$ = "Invalid type": GoTo errmes - If (t And ISOFFSETINBITS) <> 0 Or (t And ISUDT) <> 0 Or (t And ISSTRING) Then a$ = qb64prefix$ + "MEMPUT requires numeric type": GoTo errmes - If (t And ISPOINTER) Then t = t - ISPOINTER + IF t = 0 THEN a$ = "Invalid type": GOTO errmes + IF (t AND ISOFFSETINBITS) <> 0 OR (t AND ISUDT) <> 0 OR (t AND ISSTRING) THEN a$ = qb64prefix$ + "MEMPUT requires numeric type": GOTO errmes + IF (t AND ISPOINTER) THEN t = t - ISPOINTER 'attempt conversion... - e$ = fixoperationorder$(var$): If Error_Happened Then GoTo errmes + e$ = fixoperationorder$(var$): IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ + sp + SCase$("As") + sp + typ$ - e$ = evaluatetotyp(e$, t): If Error_Happened Then GoTo errmes + e$ = evaluatetotyp(e$, t): IF Error_Happened THEN GOTO errmes st$ = typ2ctyp$(t, "") - varsize$ = str2((t And 511) \ 8) - If NoChecks Then + varsize$ = str2((t AND 511) \ 8) + IF NoChecks THEN 'fast version: - Print #12, "*(" + st$ + "*)(" + offs$ + ")=" + e$ + ";" - Else + PRINT #12, "*(" + st$ + "*)(" + offs$ + ")=" + e$ + ";" + ELSE 'safe version: - Print #12, "tmp_long=" + offs$ + ";" + PRINT #12, "tmp_long=" + offs$ + ";" 'is mem block init? - Print #12, "if ( ((mem_block*)(" + blkoffs$ + "))->lock_offset ){" + PRINT #12, "if ( ((mem_block*)(" + blkoffs$ + "))->lock_offset ){" 'are region and id valid? - Print #12, "if (" - Print #12, "tmp_long < ((mem_block*)(" + blkoffs$ + "))->offset ||" - Print #12, "(tmp_long+(" + varsize$ + ")) > ( ((mem_block*)(" + blkoffs$ + "))->offset + ((mem_block*)(" + blkoffs$ + "))->size) ||" - Print #12, "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id ){" + PRINT #12, "if (" + PRINT #12, "tmp_long < ((mem_block*)(" + blkoffs$ + "))->offset ||" + PRINT #12, "(tmp_long+(" + varsize$ + ")) > ( ((mem_block*)(" + blkoffs$ + "))->offset + ((mem_block*)(" + blkoffs$ + "))->size) ||" + PRINT #12, "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id ){" 'diagnose error - Print #12, "if (" + "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id" + ") error(308); else error(300);" - Print #12, "}else{" - Print #12, "*(" + st$ + "*)tmp_long=" + e$ + ";" - Print #12, "}" - Print #12, "}else error(309);" - End If + PRINT #12, "if (" + "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id" + ") error(308); else error(300);" + PRINT #12, "}else{" + PRINT #12, "*(" + st$ + "*)tmp_long=" + e$ + ";" + PRINT #12, "}" + PRINT #12, "}else error(309);" + END IF - End If + END IF - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline - End If - End If + END IF + END IF - If n >= 1 Then - If firstelement$ = "_MEMFILL" Or (firstelement$ = "MEMFILL" And qb64prefix_set = 1) Then + IF n >= 1 THEN + IF firstelement$ = "_MEMFILL" OR (firstelement$ = "MEMFILL" AND qb64prefix_set = 1) THEN 'get expressions typ$ = "" e$ = "" B = 0 ne = 0 - For i2 = 2 To n + FOR i2 = 2 TO n e2$ = getelement$(ca$, i2) - If e2$ = "(" Then B = B + 1 - If e2$ = ")" Then B = B - 1 - If (e2$ = "," Or UCase$(e2$) = "AS") And B = 0 Then + IF e2$ = "(" THEN B = B + 1 + IF e2$ = ")" THEN B = B - 1 + IF (e2$ = "," OR UCASE$(e2$) = "AS") AND B = 0 THEN ne = ne + 1 - If ne = 1 Then blk$ = e$: e$ = "" - If ne = 2 Then offs$ = e$: e$ = "" - If ne = 3 Then bytes$ = e$: e$ = "" - If ne = 4 Then var$ = e$: e$ = "" - If (UCase$(e2$) = "AS" And ne <> 4) Or (ne = 4 And UCase$(e2$) <> "AS") Or ne = 5 Then a$ = "Expected _MEMFILL mem-reference,offset,bytes,variable|value[AS type]": GoTo errmes - Else - If Len(e$) = 0 Then e$ = e2$ Else e$ = e$ + sp + e2$ - End If - Next - If ne < 3 Or e$ = "" Then a$ = "Expected " + qb64prefix$ + "MEMFILL mem-reference, offset, bytes, variable|value[AS type]": GoTo errmes - If ne = 3 Then var$ = e$ Else typ$ = UCase$(e$) + IF ne = 1 THEN blk$ = e$: e$ = "" + IF ne = 2 THEN offs$ = e$: e$ = "" + IF ne = 3 THEN bytes$ = e$: e$ = "" + IF ne = 4 THEN var$ = e$: e$ = "" + IF (UCASE$(e2$) = "AS" AND ne <> 4) OR (ne = 4 AND UCASE$(e2$) <> "AS") OR ne = 5 THEN a$ = "Expected _MEMFILL mem-reference,offset,bytes,variable|value[AS type]": GOTO errmes + ELSE + IF LEN(e$) = 0 THEN e$ = e2$ ELSE e$ = e$ + sp + e2$ + END IF + NEXT + IF ne < 3 OR e$ = "" THEN a$ = "Expected " + qb64prefix$ + "MEMFILL mem-reference, offset, bytes, variable|value[AS type]": GOTO errmes + IF ne = 3 THEN var$ = e$ ELSE typ$ = UCASE$(e$) - If firstelement$ = "_MEMFILL" Then l$ = SCase$("_MemFill") + sp Else l$ = SCase$("MemFill") + sp + IF firstelement$ = "_MEMFILL" THEN l$ = SCase$("_MemFill") + sp ELSE l$ = SCase$("MemFill") + sp - e$ = fixoperationorder$(blk$): If Error_Happened Then GoTo errmes + e$ = fixoperationorder$(blk$): IF Error_Happened THEN GOTO errmes l$ = l$ + tlayout$ - test$ = evaluate(e$, typ): If Error_Happened Then GoTo errmes - If (typ And ISUDT) = 0 Or (typ And 511) <> 1 Then a$ = "Expected " + qb64prefix$ + "MEM type": GoTo errmes + test$ = evaluate(e$, typ): IF Error_Happened THEN GOTO errmes + IF (typ AND ISUDT) = 0 OR (typ AND 511) <> 1 THEN a$ = "Expected " + qb64prefix$ + "MEM type": GOTO errmes blkoffs$ = evaluatetotyp(e$, -6) - e$ = fixoperationorder$(offs$): If Error_Happened Then GoTo errmes + e$ = fixoperationorder$(offs$): IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ - e$ = evaluatetotyp(e$, OFFSETTYPE - ISPOINTER): If Error_Happened Then GoTo errmes + e$ = evaluatetotyp(e$, OFFSETTYPE - ISPOINTER): IF Error_Happened THEN GOTO errmes offs$ = e$ - e$ = fixoperationorder$(bytes$): If Error_Happened Then GoTo errmes + e$ = fixoperationorder$(bytes$): IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ - e$ = evaluatetotyp(e$, OFFSETTYPE - ISPOINTER): If Error_Happened Then GoTo errmes + e$ = evaluatetotyp(e$, OFFSETTYPE - ISPOINTER): IF Error_Happened THEN GOTO errmes bytes$ = e$ - If ne = 3 Then 'no AS - e$ = fixoperationorder$(var$): If Error_Happened Then GoTo errmes + IF ne = 3 THEN 'no AS + e$ = fixoperationorder$(var$): IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ test$ = evaluate(e$, t) - If (t And ISREFERENCE) = 0 And (t And ISSTRING) Then - Print #12, "tmp_long=(ptrszint)" + test$ + ";" + IF (t AND ISREFERENCE) = 0 AND (t AND ISSTRING) THEN + PRINT #12, "tmp_long=(ptrszint)" + test$ + ";" varsize$ = "((qbs*)tmp_long)->len" varoffs$ = "((qbs*)tmp_long)->chr" - Else - varsize$ = evaluatetotyp(e$, -5): If Error_Happened Then GoTo errmes - varoffs$ = evaluatetotyp(e$, -6): If Error_Happened Then GoTo errmes - End If + ELSE + varsize$ = evaluatetotyp(e$, -5): IF Error_Happened THEN GOTO errmes + varoffs$ = evaluatetotyp(e$, -6): IF Error_Happened THEN GOTO errmes + END IF - If NoChecks Then - Print #12, "sub__memfill_nochecks(" + offs$ + "," + bytes$ + ",(ptrszint)" + varoffs$ + "," + varsize$ + ");" - Else - Print #12, "sub__memfill((mem_block*)" + blkoffs$ + "," + offs$ + "," + bytes$ + ",(ptrszint)" + varoffs$ + "," + varsize$ + ");" - End If + IF NoChecks THEN + PRINT #12, "sub__memfill_nochecks(" + offs$ + "," + bytes$ + ",(ptrszint)" + varoffs$ + "," + varsize$ + ");" + ELSE + PRINT #12, "sub__memfill((mem_block*)" + blkoffs$ + "," + offs$ + "," + bytes$ + ",(ptrszint)" + varoffs$ + "," + varsize$ + ");" + END IF - Else + ELSE '... AS type method t = typname2typ(typ$) - If t = 0 Then a$ = "Invalid type": GoTo errmes - If (t And ISOFFSETINBITS) <> 0 Or (t And ISUDT) <> 0 Or (t And ISSTRING) Then a$ = qb64prefix$ + "MEMFILL requires numeric type": GoTo errmes - If (t And ISPOINTER) Then t = t - ISPOINTER + IF t = 0 THEN a$ = "Invalid type": GOTO errmes + IF (t AND ISOFFSETINBITS) <> 0 OR (t AND ISUDT) <> 0 OR (t AND ISSTRING) THEN a$ = qb64prefix$ + "MEMFILL requires numeric type": GOTO errmes + IF (t AND ISPOINTER) THEN t = t - ISPOINTER 'attempt conversion... - e$ = fixoperationorder$(var$): If Error_Happened Then GoTo errmes + e$ = fixoperationorder$(var$): IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ + sp + SCase$("As") + sp + typ$ - e$ = evaluatetotyp(e$, t): If Error_Happened Then GoTo errmes + e$ = evaluatetotyp(e$, t): IF Error_Happened THEN GOTO errmes c$ = "sub__memfill_" - If NoChecks Then c$ = "sub__memfill_nochecks_" - If t And ISOFFSET Then + IF NoChecks THEN c$ = "sub__memfill_nochecks_" + IF t AND ISOFFSET THEN c$ = c$ + "OFFSET" - Else - If t And ISFLOAT Then - If (t And 511) = 32 Then c$ = c$ + "SINGLE" - If (t And 511) = 64 Then c$ = c$ + "DOUBLE" - If (t And 511) = 256 Then c$ = c$ + "FLOAT" 'padded variable - Else - c$ = c$ + str2((t And 511) \ 8) - End If - End If + ELSE + IF t AND ISFLOAT THEN + IF (t AND 511) = 32 THEN c$ = c$ + "SINGLE" + IF (t AND 511) = 64 THEN c$ = c$ + "DOUBLE" + IF (t AND 511) = 256 THEN c$ = c$ + "FLOAT" 'padded variable + ELSE + c$ = c$ + str2((t AND 511) \ 8) + END IF + END IF c$ = c$ + "(" - If NoChecks = 0 Then c$ = c$ + "(mem_block*)" + blkoffs$ + "," - Print #12, c$ + offs$ + "," + bytes$ + "," + e$ + ");" - End If + IF NoChecks = 0 THEN c$ = c$ + "(mem_block*)" + blkoffs$ + "," + PRINT #12, c$ + offs$ + "," + bytes$ + "," + e$ + ");" + END IF - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline - End If - End If + END IF + END IF @@ -9202,79 +9202,79 @@ Do 'note: ABSOLUTE cannot be used without CALL cispecial = 0 - If n > 1 Then - If firstelement$ = "INTERRUPT" Or firstelement$ = "INTERRUPTX" Then + IF n > 1 THEN + IF firstelement$ = "INTERRUPT" OR firstelement$ = "INTERRUPTX" THEN a$ = "CALL" + sp + firstelement$ + sp + "(" + sp + getelements$(a$, 2, n) + sp + ")" ca$ = "CALL" + sp + firstelement$ + sp + "(" + sp + getelements$(ca$, 2, n) + sp + ")" n = n + 3 firstelement$ = "CALL" cispecial = 1 'fall through - End If - End If + END IF + END IF usecall = 0 - If firstelement$ = "CALL" Then + IF firstelement$ = "CALL" THEN usecall = 1 - If n = 1 Then a$ = "Expected CALL sub-name [(...)]": GoTo errmes - cn$ = getelement$(ca$, 2): n$ = UCase$(cn$) + IF n = 1 THEN a$ = "Expected CALL sub-name [(...)]": GOTO errmes + cn$ = getelement$(ca$, 2): n$ = UCASE$(cn$) - If n > 2 Then + IF n > 2 THEN - If n <= 4 Then a$ = "Expected CALL sub-name (...)": GoTo errmes - If getelement$(a$, 3) <> "(" Or getelement$(a$, n) <> ")" Then a$ = "Expected CALL sub-name (...)": GoTo errmes + IF n <= 4 THEN a$ = "Expected CALL sub-name (...)": GOTO errmes + IF getelement$(a$, 3) <> "(" OR getelement$(a$, n) <> ")" THEN a$ = "Expected CALL sub-name (...)": GOTO errmes a$ = n$ + sp + getelements$(a$, 4, n - 1) ca$ = cn$ + sp + getelements$(ca$, 4, n - 1) - If n$ = "INTERRUPT" Or n$ = "INTERRUPTX" Then 'assume CALL INTERRUPT[X] request + IF n$ = "INTERRUPT" OR n$ = "INTERRUPTX" THEN 'assume CALL INTERRUPT[X] request 'print "CI: call interrupt command reached":sleep 1 - If n$ = "INTERRUPT" Then Print #12, "call_interrupt("; Else Print #12, "call_interruptx("; + IF n$ = "INTERRUPT" THEN PRINT #12, "call_interrupt("; ELSE PRINT #12, "call_interruptx("; argn = 0 n = numelements(a$) B = 0 e$ = "" - For i = 2 To n + FOR i = 2 TO n e2$ = getelement$(ca$, i) - If e2$ = "(" Then B = B + 1 - If e2$ = ")" Then B = B - 1 - If (e2$ = "," And B = 0) Or i = n Then - If i = n Then - If e$ = "" Then e$ = e2$ Else e$ = e$ + sp + e2$ - End If + IF e2$ = "(" THEN B = B + 1 + IF e2$ = ")" THEN B = B - 1 + IF (e2$ = "," AND B = 0) OR i = n THEN + IF i = n THEN + IF e$ = "" THEN e$ = e2$ ELSE e$ = e$ + sp + e2$ + END IF argn = argn + 1 - If argn = 1 Then 'interrupt number + IF argn = 1 THEN 'interrupt number e$ = fixoperationorder$(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = SCase$("Call") + sp + n$ + sp2 + "(" + sp2 + tlayout$ - If cispecial = 1 Then l$ = n$ + sp + tlayout$ + IF cispecial = 1 THEN l$ = n$ + sp + tlayout$ e$ = evaluatetotyp(e$, 64&) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes 'print "CI: evaluated interrupt number as ["+e$+"]":sleep 1 - Print #12, e$; - End If - If argn = 2 Or argn = 3 Then 'inregs, outregs + PRINT #12, e$; + END IF + IF argn = 2 OR argn = 3 THEN 'inregs, outregs e$ = fixoperationorder$(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ e2$ = e$ e$ = evaluatetotyp(e$, -2) 'offset+size - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes 'print "CI: evaluated in/out regs ["+e2$+"] as ["+e$+"]":sleep 1 - Print #12, "," + e$; - End If + PRINT #12, "," + e$; + END IF e$ = "" - Else - If e$ = "" Then e$ = e2$ Else e$ = e$ + sp + e2$ - End If - Next - If argn <> 3 Then a$ = "Expected CALL INTERRUPT (interrupt-no, inregs, outregs)": GoTo errmes - Print #12, ");" - If cispecial = 0 Then l$ = l$ + sp2 + ")" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + ELSE + IF e$ = "" THEN e$ = e2$ ELSE e$ = e$ + sp + e2$ + END IF + NEXT + IF argn <> 3 THEN a$ = "Expected CALL INTERRUPT (interrupt-no, inregs, outregs)": GOTO errmes + PRINT #12, ");" + IF cispecial = 0 THEN l$ = l$ + sp2 + ")" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ 'print "CI: done":sleep 1 - GoTo finishedline - End If 'call interrupt + GOTO finishedline + END IF 'call interrupt @@ -9284,262 +9284,262 @@ Do 'call to CALL ABSOLUTE beyond reasonable doubt - If n$ = "ABSOLUTE" Then + IF n$ = "ABSOLUTE" THEN l$ = SCase$("Call" + sp + "Absolute" + sp2 + "(" + sp2) argn = 0 n = numelements(a$) B = 0 e$ = "" - For i = 2 To n + FOR i = 2 TO n e2$ = getelement$(ca$, i) - If e2$ = "(" Then B = B + 1 - If e2$ = ")" Then B = B - 1 - If (e2$ = "," And B = 0) Or i = n Then - If i < n Then - If e$ = "" Then a$ = "Expected expression before , or )": GoTo errmes + IF e2$ = "(" THEN B = B + 1 + IF e2$ = ")" THEN B = B - 1 + IF (e2$ = "," AND B = 0) OR i = n THEN + IF i < n THEN + IF e$ = "" THEN a$ = "Expected expression before , or )": GOTO errmes '1. variable or value? e$ = fixoperationorder$(e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + tlayout$ + sp2 + "," + sp ignore$ = evaluate(e$, typ) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes - If (typ And ISPOINTER) <> 0 And (typ And ISREFERENCE) <> 0 Then + IF (typ AND ISPOINTER) <> 0 AND (typ AND ISREFERENCE) <> 0 THEN 'assume standard variable 'assume not string/array/udt/etc e$ = "VARPTR" + sp + "(" + sp + e$ + sp + ")" e$ = evaluatetotyp(e$, UINTEGERTYPE - ISPOINTER) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes - Else + ELSE 'assume not string 'single, double or integer64? - If typ And ISFLOAT Then - If (typ And 511) = 32 Then + IF typ AND ISFLOAT THEN + IF (typ AND 511) = 32 THEN e$ = evaluatetotyp(e$, SINGLETYPE - ISPOINTER) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes v$ = "pass" + str2$(uniquenumber) - Print #defdatahandle, "float *" + v$ + "=NULL;" - Print #13, "if(" + v$ + "==NULL){" - Print #13, "cmem_sp-=4;" - Print #13, v$ + "=(float*)(dblock+cmem_sp);" - Print #13, "if (cmem_sp2 + ELSE 'n>2 a$ = n$ ca$ = cn$ usecall = 2 - End If 'n>2 + END IF 'n>2 n = numelements(a$) firstelement$ = getelement$(a$, 1) 'valid SUB name validsub = 0 - findidsecondarg = "": If n >= 2 Then findidsecondarg = getelement$(a$, 2) + findidsecondarg = "": IF n >= 2 THEN findidsecondarg = getelement$(a$, 2) try = findid(firstelement$) - If Error_Happened Then GoTo errmes - Do While try - If id.subfunc = 2 Then validsub = 1: Exit Do - If try = 2 Then - findidsecondarg = "": If n >= 2 Then findidsecondarg = getelement$(a$, 2) + IF Error_Happened THEN GOTO errmes + DO WHILE try + IF id.subfunc = 2 THEN validsub = 1: EXIT DO + IF try = 2 THEN + findidsecondarg = "": IF n >= 2 THEN findidsecondarg = getelement$(a$, 2) findanotherid = 1 try = findid(firstelement$) - If Error_Happened Then GoTo errmes - Else + IF Error_Happened THEN GOTO errmes + ELSE try = 0 - End If - Loop - If validsub = 0 Then a$ = "Expected CALL sub-name [(...)]": GoTo errmes - End If + END IF + LOOP + IF validsub = 0 THEN a$ = "Expected CALL sub-name [(...)]": GOTO errmes + END IF 'sub? - If n >= 1 Then + IF n >= 1 THEN - If firstelement$ = "?" Then firstelement$ = "PRINT" + IF firstelement$ = "?" THEN firstelement$ = "PRINT" - findidsecondarg = "": If n >= 2 Then findidsecondarg = getelement$(a$, 2) + findidsecondarg = "": IF n >= 2 THEN findidsecondarg = getelement$(a$, 2) try = findid(firstelement$) - If Error_Happened Then GoTo errmes - Do While try - If id.subfunc = 2 Then + IF Error_Happened THEN GOTO errmes + DO WHILE try + IF id.subfunc = 2 THEN 'check symbol s$ = removesymbol$(firstelement$ + "") - If Error_Happened Then GoTo errmes - If Asc(id.musthave) = 36 Then '="$" - If s$ <> "$" Then GoTo notsubcall 'missing musthave "$" - Else - If Len(s$) Then GoTo notsubcall 'unrequired symbol added - End If + IF Error_Happened THEN GOTO errmes + IF ASC(id.musthave) = 36 THEN '="$" + IF s$ <> "$" THEN GOTO notsubcall 'missing musthave "$" + ELSE + IF LEN(s$) THEN GOTO notsubcall 'unrequired symbol added + END IF 'check for variable assignment - If n > 1 Then - If Asc(id.specialformat) <> 61 Then '<>"=" - If Asc(getelement$(a$, 2)) = 61 Then GoTo notsubcall 'assignment, not sub call - End If - End If + IF n > 1 THEN + IF ASC(id.specialformat) <> 61 THEN '<>"=" + IF ASC(getelement$(a$, 2)) = 61 THEN GOTO notsubcall 'assignment, not sub call + END IF + END IF 'check for array assignment - If n > 2 Then - If firstelement$ <> "PRINT" And firstelement$ <> "LPRINT" Then - If getelement$(a$, 2) = "(" Then + IF n > 2 THEN + IF firstelement$ <> "PRINT" AND firstelement$ <> "LPRINT" THEN + IF getelement$(a$, 2) = "(" THEN B = 1 - For i = 3 To n + FOR i = 3 TO n e$ = getelement$(a$, i) - If e$ = "(" Then B = B + 1 - If e$ = ")" Then + IF e$ = "(" THEN B = B + 1 + IF e$ = ")" THEN B = B - 1 - If B = 0 Then - If i = n Then Exit For - If getelement$(a$, i + 1) = "=" Then GoTo notsubcall - End If - End If - Next - End If - End If - End If + IF B = 0 THEN + IF i = n THEN EXIT FOR + IF getelement$(a$, i + 1) = "=" THEN GOTO notsubcall + END IF + END IF + NEXT + END IF + END IF + END IF 'generate error on driect _GL call - If firstelement$ = "_GL" Then - a$ = "Cannot call SUB _GL directly": GoTo errmes - End If + IF firstelement$ = "_GL" THEN + a$ = "Cannot call SUB _GL directly": GOTO errmes + END IF - If firstelement$ = "OPEN" Then + IF firstelement$ = "OPEN" THEN 'gwbasic or qbasic version? B = 0 - For x = 2 To n + FOR x = 2 TO n a2$ = getelement$(a$, x) - If a2$ = "(" Then B = B + 1 - If a2$ = ")" Then B = B - 1 - If a2$ = "FOR" Or a2$ = "AS" Then Exit For 'qb style open verified - If B = 0 And a2$ = "," Then 'the gwbasic version includes a comma after the first string expression + IF a2$ = "(" THEN B = B + 1 + IF a2$ = ")" THEN B = B - 1 + IF a2$ = "FOR" OR a2$ = "AS" THEN EXIT FOR 'qb style open verified + IF B = 0 AND a2$ = "," THEN 'the gwbasic version includes a comma after the first string expression findanotherid = 1 try = findid(firstelement$) 'id of sub_open_gwbasic - If Error_Happened Then GoTo errmes - Exit For - End If - Next - End If + IF Error_Happened THEN GOTO errmes + EXIT FOR + END IF + NEXT + END IF 'IF findid(firstelement$) THEN 'IF id.subfunc = 2 THEN - If firstelement$ = "CLOSE" Or firstelement$ = "RESET" Then - If firstelement$ = "RESET" Then - If n > 1 Then a$ = "Syntax error": GoTo errmes + IF firstelement$ = "CLOSE" OR firstelement$ = "RESET" THEN + IF firstelement$ = "RESET" THEN + IF n > 1 THEN a$ = "Syntax error": GOTO errmes l$ = SCase$("Reset") - Else + ELSE l$ = SCase$("Close") - End If + END IF - If n = 1 Then - Print #12, "sub_close(NULL,0);" 'closes all files - Else + IF n = 1 THEN + PRINT #12, "sub_close(NULL,0);" 'closes all files + ELSE l$ = l$ + sp B = 0 s = 0 a3$ = "" - For x = 2 To n + FOR x = 2 TO n a2$ = getelement$(ca$, x) - If a2$ = "(" Then B = B + 1 - If a2$ = ")" Then B = B - 1 - If a2$ = "#" And B = 0 Then - If s = 0 Then s = 1 Else a$ = "Unexpected #": GoTo errmes + IF a2$ = "(" THEN B = B + 1 + IF a2$ = ")" THEN B = B - 1 + IF a2$ = "#" AND B = 0 THEN + IF s = 0 THEN s = 1 ELSE a$ = "Unexpected #": GOTO errmes l$ = l$ + "#" + sp2 - GoTo closenexta - End If + GOTO closenexta + END IF - If a2$ = "," And B = 0 Then - If s = 2 Then + IF a2$ = "," AND B = 0 THEN + IF s = 2 THEN e$ = fixoperationorder$(a3$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + tlayout$ + sp2 + "," + sp e$ = evaluatetotyp(e$, 64&) - If Error_Happened Then GoTo errmes - Print #12, "sub_close(" + e$ + ",1);" + IF Error_Happened THEN GOTO errmes + PRINT #12, "sub_close(" + e$ + ",1);" a3$ = "" s = 0 - GoTo closenexta - Else - a$ = "Expected expression before ,": GoTo errmes - End If - End If + GOTO closenexta + ELSE + a$ = "Expected expression before ,": GOTO errmes + END IF + END IF s = 2 - If a3$ = "" Then a3$ = a2$ Else a3$ = a3$ + sp + a2$ + IF a3$ = "" THEN a3$ = a2$ ELSE a3$ = a3$ + sp + a2$ closenexta: - Next + NEXT - If s = 2 Then + IF s = 2 THEN e$ = fixoperationorder$(a3$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + tlayout$ e$ = evaluatetotyp(e$, 64&) - If Error_Happened Then GoTo errmes - Print #12, "sub_close(" + e$ + ",1);" - Else - l$ = Left$(l$, Len(l$) - 1) - End If + IF Error_Happened THEN GOTO errmes + PRINT #12, "sub_close(" + e$ + ",1);" + ELSE + l$ = LEFT$(l$, LEN(l$) - 1) + END IF - End If - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If 'close + END IF + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF 'close @@ -9557,12 +9557,12 @@ Do 'data, restore, read - If firstelement$ = "READ" Then 'file input + IF firstelement$ = "READ" THEN 'file input xread ca$, n - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes 'note: layout done in xread sub - GoTo finishedline - End If 'read + GOTO finishedline + END IF 'read @@ -9601,195 +9601,195 @@ Do lineinput = 0 - If n >= 2 Then - If firstelement$ = "LINE" And secondelement$ = "INPUT" Then + IF n >= 2 THEN + IF firstelement$ = "LINE" AND secondelement$ = "INPUT" THEN lineinput = 1 - a$ = Right$(a$, Len(a$) - 5): ca$ = Right$(ca$, Len(ca$) - 5): n = n - 1 'remove "LINE" + a$ = RIGHT$(a$, LEN(a$) - 5): ca$ = RIGHT$(ca$, LEN(ca$) - 5): n = n - 1 'remove "LINE" firstelement$ = "INPUT" - End If - End If + END IF + END IF - If firstelement$ = "INPUT" Then 'file input - If n > 1 Then - If getelement$(a$, 2) = "#" Then - l$ = SCase$("Input") + sp + "#": If lineinput Then l$ = SCase$("Line") + sp + l$ + IF firstelement$ = "INPUT" THEN 'file input + IF n > 1 THEN + IF getelement$(a$, 2) = "#" THEN + l$ = SCase$("Input") + sp + "#": IF lineinput THEN l$ = SCase$("Line") + sp + l$ u$ = str2$(uniquenumber) 'which file? - If n = 2 Then a$ = "Expected # ... , ...": GoTo errmes + IF n = 2 THEN a$ = "Expected # ... , ...": GOTO errmes a3$ = "" B = 0 - For i = 3 To n + FOR i = 3 TO n a2$ = getelement$(ca$, i) - If a2$ = "(" Then B = B + 1 - If a2$ = ")" Then B = B - 1 - If a2$ = "," And B = 0 Then - If a3$ = "" Then a$ = "Expected # ... , ...": GoTo errmes - GoTo inputgotfn - End If - If a3$ = "" Then a3$ = a2$ Else a3$ = a3$ + sp + a2$ - Next + IF a2$ = "(" THEN B = B + 1 + IF a2$ = ")" THEN B = B - 1 + IF a2$ = "," AND B = 0 THEN + IF a3$ = "" THEN a$ = "Expected # ... , ...": GOTO errmes + GOTO inputgotfn + END IF + IF a3$ = "" THEN a3$ = a2$ ELSE a3$ = a3$ + sp + a2$ + NEXT inputgotfn: e$ = fixoperationorder$(a3$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + tlayout$ e$ = evaluatetotyp(e$, 64&) - If Error_Happened Then GoTo errmes - Print #12, "tmp_fileno=" + e$ + ";" - Print #12, "if (new_error) goto skip" + u$ + ";" + IF Error_Happened THEN GOTO errmes + PRINT #12, "tmp_fileno=" + e$ + ";" + PRINT #12, "if (new_error) goto skip" + u$ + ";" i = i + 1 - If i > n Then a$ = "Expected , ...": GoTo errmes + IF i > n THEN a$ = "Expected , ...": GOTO errmes a3$ = "" B = 0 - For i = i To n + FOR i = i TO n a2$ = getelement$(ca$, i) - If a2$ = "(" Then B = B + 1 - If a2$ = ")" Then B = B - 1 - If i = n Then - If a3$ = "" Then a3$ = a2$ Else a3$ = a3$ + sp + a2$ + IF a2$ = "(" THEN B = B + 1 + IF a2$ = ")" THEN B = B - 1 + IF i = n THEN + IF a3$ = "" THEN a3$ = a2$ ELSE a3$ = a3$ + sp + a2$ a2$ = ",": B = 0 - End If - If a2$ = "," And B = 0 Then - If a3$ = "" Then a$ = "Expected , ...": GoTo errmes + END IF + IF a2$ = "," AND B = 0 THEN + IF a3$ = "" THEN a$ = "Expected , ...": GOTO errmes e$ = fixoperationorder$(a3$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp2 + "," + sp + tlayout$ e$ = evaluate(e$, t) - If Error_Happened Then GoTo errmes - If (t And ISREFERENCE) = 0 Then a$ = "Expected variable-name": GoTo errmes - If (t And ISSTRING) Then + IF Error_Happened THEN GOTO errmes + IF (t AND ISREFERENCE) = 0 THEN a$ = "Expected variable-name": GOTO errmes + IF (t AND ISSTRING) THEN e$ = refer(e$, t, 0) - If Error_Happened Then GoTo errmes - If lineinput Then - Print #12, "sub_file_line_input_string(tmp_fileno," + e$ + ");" - Print #12, "if (new_error) goto skip" + u$ + ";" - Else - Print #12, "sub_file_input_string(tmp_fileno," + e$ + ");" - Print #12, "if (new_error) goto skip" + u$ + ";" - End If + IF Error_Happened THEN GOTO errmes + IF lineinput THEN + PRINT #12, "sub_file_line_input_string(tmp_fileno," + e$ + ");" + PRINT #12, "if (new_error) goto skip" + u$ + ";" + ELSE + PRINT #12, "sub_file_input_string(tmp_fileno," + e$ + ");" + PRINT #12, "if (new_error) goto skip" + u$ + ";" + END IF stringprocessinghappened = 1 - Else - If lineinput Then a$ = "Expected string-variable": GoTo errmes + ELSE + IF lineinput THEN a$ = "Expected string-variable": GOTO errmes 'numeric variable - If (t And ISFLOAT) <> 0 Or (t And 511) <> 64 Then - If (t And ISOFFSETINBITS) Then + IF (t AND ISFLOAT) <> 0 OR (t AND 511) <> 64 THEN + IF (t AND ISOFFSETINBITS) THEN setrefer e$, t, "((int64)func_file_input_float(tmp_fileno," + str2(t) + "))", 1 - If Error_Happened Then GoTo errmes - Else + IF Error_Happened THEN GOTO errmes + ELSE setrefer e$, t, "func_file_input_float(tmp_fileno," + str2(t) + ")", 1 - If Error_Happened Then GoTo errmes - End If - Else - If t And ISUNSIGNED Then + IF Error_Happened THEN GOTO errmes + END IF + ELSE + IF t AND ISUNSIGNED THEN setrefer e$, t, "func_file_input_uint64(tmp_fileno)", 1 - If Error_Happened Then GoTo errmes - Else + IF Error_Happened THEN GOTO errmes + ELSE setrefer e$, t, "func_file_input_int64(tmp_fileno)", 1 - If Error_Happened Then GoTo errmes - End If - End If + IF Error_Happened THEN GOTO errmes + END IF + END IF - Print #12, "if (new_error) goto skip" + u$ + ";" + PRINT #12, "if (new_error) goto skip" + u$ + ";" - End If - If i = n Then Exit For - If lineinput Then a$ = "Too many variables": GoTo errmes + END IF + IF i = n THEN EXIT FOR + IF lineinput THEN a$ = "Too many variables": GOTO errmes a3$ = "": a2$ = "" - End If - If a3$ = "" Then a3$ = a2$ Else a3$ = a3$ + sp + a2$ - Next - Print #12, "skip" + u$ + ":" - If stringprocessinghappened Then Print #12, cleanupstringprocessingcall$ + "0);" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If - End If - End If 'input# + END IF + IF a3$ = "" THEN a3$ = a2$ ELSE a3$ = a3$ + sp + a2$ + NEXT + PRINT #12, "skip" + u$ + ":" + IF stringprocessinghappened THEN PRINT #12, cleanupstringprocessingcall$ + "0);" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF + END IF + END IF 'input# - If firstelement$ = "INPUT" Then - l$ = SCase$("Input"): If lineinput Then l$ = SCase$("Line") + sp + l$ + IF firstelement$ = "INPUT" THEN + l$ = SCase$("Input"): IF lineinput THEN l$ = SCase$("Line") + sp + l$ commaneeded = 0 i = 2 - newline = 1: If getelement$(a$, i) = ";" Then newline = 0: i = i + 1: l$ = l$ + sp + ";" + newline = 1: IF getelement$(a$, i) = ";" THEN newline = 0: i = i + 1: l$ = l$ + sp + ";" a2$ = getelement$(ca$, i) - If Left$(a2$, 1) = Chr$(34) Then + IF LEFT$(a2$, 1) = CHR$(34) THEN e$ = fixoperationorder$(a2$): l$ = l$ + sp + tlayout$ - If Error_Happened Then GoTo errmes - Print #12, "qbs_print(qbs_new_txt_len(" + a2$ + "),0);" + IF Error_Happened THEN GOTO errmes + PRINT #12, "qbs_print(qbs_new_txt_len(" + a2$ + "),0);" i = i + 1 'MUST be followed by a ; or , a2$ = getelement$(ca$, i) i = i + 1 l$ = l$ + sp2 + a2$ - If a2$ = ";" Then - If lineinput Then GoTo finishedpromptstring - Print #12, "qbs_print(qbs_new_txt(" + Chr$(34) + "? " + Chr$(34) + "),0);" - GoTo finishedpromptstring - End If - If a2$ = "," Then - GoTo finishedpromptstring - End If - a$ = "INPUT STATEMENT: SYNTAX ERROR!": GoTo errmes - End If + IF a2$ = ";" THEN + IF lineinput THEN GOTO finishedpromptstring + PRINT #12, "qbs_print(qbs_new_txt(" + CHR$(34) + "? " + CHR$(34) + "),0);" + GOTO finishedpromptstring + END IF + IF a2$ = "," THEN + GOTO finishedpromptstring + END IF + a$ = "INPUT STATEMENT: SYNTAX ERROR!": GOTO errmes + END IF 'there was no promptstring, so print a ? - If lineinput = 0 Then Print #12, "qbs_print(qbs_new_txt(" + Chr$(34) + "? " + Chr$(34) + "),0);" + IF lineinput = 0 THEN PRINT #12, "qbs_print(qbs_new_txt(" + CHR$(34) + "? " + CHR$(34) + "),0);" finishedpromptstring: numvar = 0 - For i = i To n - If commaneeded = 1 Then + FOR i = i TO n + IF commaneeded = 1 THEN a2$ = getelement$(ca$, i) - If a2$ <> "," Then a$ = "INPUT STATEMENT: SYNTAX ERROR! (COMMA EXPECTED)": GoTo errmes - Else + IF a2$ <> "," THEN a$ = "INPUT STATEMENT: SYNTAX ERROR! (COMMA EXPECTED)": GOTO errmes + ELSE B = 0 e$ = "" - For i2 = i To n + FOR i2 = i TO n e2$ = getelement$(ca$, i2) - If e2$ = "(" Then B = B + 1 - If e2$ = ")" Then B = B - 1 - If e2$ = "," And B = 0 Then i2 = i2 - 1: Exit For + IF e2$ = "(" THEN B = B + 1 + IF e2$ = ")" THEN B = B - 1 + IF e2$ = "," AND B = 0 THEN i2 = i2 - 1: EXIT FOR e$ = e$ + sp + e2$ - Next - i = i2: If i > n Then i = n - If e$ = "" Then a$ = "Expected variable": GoTo errmes - e$ = Right$(e$, Len(e$) - 1) + NEXT + i = i2: IF i > n THEN i = n + IF e$ = "" THEN a$ = "Expected variable": GOTO errmes + e$ = RIGHT$(e$, LEN(e$) - 1) e$ = fixoperationorder$(e$) - If Error_Happened Then GoTo errmes - l$ = l$ + sp + tlayout$: If i <> n Then l$ = l$ + sp2 + "," + IF Error_Happened THEN GOTO errmes + l$ = l$ + sp + tlayout$: IF i <> n THEN l$ = l$ + sp2 + "," e$ = evaluate(e$, t) - If Error_Happened Then GoTo errmes - If (t And ISREFERENCE) = 0 Then a$ = "Expected variable": GoTo errmes + IF Error_Happened THEN GOTO errmes + IF (t AND ISREFERENCE) = 0 THEN a$ = "Expected variable": GOTO errmes - If (t And ISSTRING) Then + IF (t AND ISSTRING) THEN e$ = refer(e$, t, 0) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes numvar = numvar + 1 - If lineinput Then - Print #12, "qbs_input_variabletypes[" + str2(numvar) + "]=ISSTRING+512;" - Else - Print #12, "qbs_input_variabletypes[" + str2(numvar) + "]=ISSTRING;" - End If - Print #12, "qbs_input_variableoffsets[" + str2(numvar) + "]=" + e$ + ";" - GoTo gotinputvar - End If + IF lineinput THEN + PRINT #12, "qbs_input_variabletypes[" + str2(numvar) + "]=ISSTRING+512;" + ELSE + PRINT #12, "qbs_input_variabletypes[" + str2(numvar) + "]=ISSTRING;" + END IF + PRINT #12, "qbs_input_variableoffsets[" + str2(numvar) + "]=" + e$ + ";" + GOTO gotinputvar + END IF - If lineinput Then a$ = "Expected string variable": GoTo errmes - If (t And ISARRAY) Then - If (t And ISOFFSETINBITS) Then - a$ = "INPUT cannot handle BIT array elements yet": GoTo errmes - End If - End If + IF lineinput THEN a$ = "Expected string variable": GOTO errmes + IF (t AND ISARRAY) THEN + IF (t AND ISOFFSETINBITS) THEN + a$ = "INPUT cannot handle BIT array elements yet": GOTO errmes + END IF + END IF e$ = "&(" + refer(e$, t, 0) + ")" - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes 'remove assumed/unnecessary flags - If (t And ISPOINTER) Then t = t - ISPOINTER - If (t And ISINCONVENTIONALMEMORY) Then t = t - ISINCONVENTIONALMEMORY - If (t And ISREFERENCE) Then t = t - ISREFERENCE + IF (t AND ISPOINTER) THEN t = t - ISPOINTER + IF (t AND ISINCONVENTIONALMEMORY) THEN t = t - ISINCONVENTIONALMEMORY + IF (t AND ISREFERENCE) THEN t = t - ISREFERENCE 'IF (t AND ISOFFSETINBITS) THEN 'numvar = numvar + 1 @@ -9801,312 +9801,312 @@ Do 'assume it is a regular variable numvar = numvar + 1 - Print #12, "qbs_input_variabletypes[" + str2(numvar) + "]=" + str2$(t) + ";" - Print #12, "qbs_input_variableoffsets[" + str2(numvar) + "]=" + e$ + ";" - GoTo gotinputvar + PRINT #12, "qbs_input_variabletypes[" + str2(numvar) + "]=" + str2$(t) + ";" + PRINT #12, "qbs_input_variableoffsets[" + str2(numvar) + "]=" + e$ + ";" + GOTO gotinputvar - End If + END IF gotinputvar: - commaneeded = commaneeded + 1: If commaneeded = 2 Then commaneeded = 0 - Next - If numvar = 0 Then a$ = "INPUT STATEMENT: SYNTAX ERROR! (NO VARIABLES LISTED FOR INPUT)": GoTo errmes - If lineinput = 1 And numvar > 1 Then a$ = "Too many variables": GoTo errmes - Print #12, "qbs_input(" + str2(numvar) + "," + str2$(newline) + ");" - Print #12, "if (stop_program) end();" - Print #12, cleanupstringprocessingcall$ + "0);" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If + commaneeded = commaneeded + 1: IF commaneeded = 2 THEN commaneeded = 0 + NEXT + IF numvar = 0 THEN a$ = "INPUT STATEMENT: SYNTAX ERROR! (NO VARIABLES LISTED FOR INPUT)": GOTO errmes + IF lineinput = 1 AND numvar > 1 THEN a$ = "Too many variables": GOTO errmes + PRINT #12, "qbs_input(" + str2(numvar) + "," + str2$(newline) + ");" + PRINT #12, "if (stop_program) end();" + PRINT #12, cleanupstringprocessingcall$ + "0);" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF - If firstelement$ = "WRITE" Then 'file write - If n > 1 Then - If getelement$(a$, 2) = "#" Then + IF firstelement$ = "WRITE" THEN 'file write + IF n > 1 THEN + IF getelement$(a$, 2) = "#" THEN xfilewrite ca$, n - If Error_Happened Then GoTo errmes - GoTo finishedline - End If '# - End If 'n>1 - End If '"write" + IF Error_Happened THEN GOTO errmes + GOTO finishedline + END IF '# + END IF 'n>1 + END IF '"write" - If firstelement$ = "WRITE" Then 'write + IF firstelement$ = "WRITE" THEN 'write xwrite ca$, n - If Error_Happened Then GoTo errmes - GoTo finishedline - End If '"write" + IF Error_Happened THEN GOTO errmes + GOTO finishedline + END IF '"write" - If firstelement$ = "PRINT" Then 'file print - If n > 1 Then - If getelement$(a$, 2) = "#" Then + IF firstelement$ = "PRINT" THEN 'file print + IF n > 1 THEN + IF getelement$(a$, 2) = "#" THEN xfileprint a$, ca$, n - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = tlayout$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If '# - End If 'n>1 - End If '"print" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF '# + END IF 'n>1 + END IF '"print" - If firstelement$ = "PRINT" Or firstelement$ = "LPRINT" Then - If secondelement$ <> "USING" Then 'check to see if we need to auto-add semicolons + IF firstelement$ = "PRINT" OR firstelement$ = "LPRINT" THEN + IF secondelement$ <> "USING" THEN 'check to see if we need to auto-add semicolons elementon = 2 redosemi: - For i = elementon To n - 1 + FOR i = elementon TO n - 1 nextchar$ = getelement$(a$, i + 1) - If nextchar$ <> ";" And nextchar$ <> "," And nextchar$ <> "+" And nextchar$ <> ")" Then + IF nextchar$ <> ";" AND nextchar$ <> "," AND nextchar$ <> "+" AND nextchar$ <> ")" THEN temp1$ = getelement$(a$, i) - beginpoint = InStr(beginpoint, temp1$, Chr$(34)) - endpoint = InStr(beginpoint + 1, temp1$, Chr$(34) + ",") - If beginpoint <> 0 And endpoint <> 0 Then 'if we have both positions + beginpoint = INSTR(beginpoint, temp1$, CHR$(34)) + endpoint = INSTR(beginpoint + 1, temp1$, CHR$(34) + ",") + IF beginpoint <> 0 AND endpoint <> 0 THEN 'if we have both positions 'Quote without semicolon check (like PRINT "abc"123) textlength = endpoint - beginpoint - 1 - textvalue$ = Mid$(temp1$, endpoint + 2, Len(LTrim$(Str$(textlength)))) - If Val(textvalue$) = textlength Then + textvalue$ = MID$(temp1$, endpoint + 2, LEN(LTRIM$(STR$(textlength)))) + IF VAL(textvalue$) = textlength THEN insertelements a$, i, ";" insertelements ca$, i, ";" n = n + 1 elementon = i + 2 'just a easy way to reduce redundant calls to the routine - GoTo redosemi - End If - End If - If temp1$ <> "USING" Then - If Left$(LTrim$(nextchar$), 1) = Chr$(34) Then - If temp1$ <> ";" And temp1$ <> "," And temp1$ <> "+" And temp1$ <> "(" Then + GOTO redosemi + END IF + END IF + IF temp1$ <> "USING" THEN + IF LEFT$(LTRIM$(nextchar$), 1) = CHR$(34) THEN + IF temp1$ <> ";" AND temp1$ <> "," AND temp1$ <> "+" AND temp1$ <> "(" THEN insertelements a$, i, ";" insertelements ca$, i, ";" n = n + 1 elementon = i + 2 'just a easy way to reduce redundant calls to the routine - GoTo redosemi - End If - End If - End If - End If - Next - End If + GOTO redosemi + END IF + END IF + END IF + END IF + NEXT + END IF xprint a$, ca$, n - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = tlayout$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - End If + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + END IF - If firstelement$ = "CLEAR" Then - If subfunc$ <> "" Then a$ = "CLEAR cannot be used inside a SUB/FUNCTION": GoTo errmes - End If + IF firstelement$ = "CLEAR" THEN + IF subfunc$ <> "" THEN a$ = "CLEAR cannot be used inside a SUB/FUNCTION": GOTO errmes + END IF 'LSET/RSET - If firstelement$ = "LSET" Or firstelement$ = "RSET" Then - If n = 1 Then a$ = "Expected " + firstelement$ + " ...": GoTo errmes - If firstelement$ = "LSET" Then l$ = SCase$("LSet") Else l$ = SCase$("RSet") + IF firstelement$ = "LSET" OR firstelement$ = "RSET" THEN + IF n = 1 THEN a$ = "Expected " + firstelement$ + " ...": GOTO errmes + IF firstelement$ = "LSET" THEN l$ = SCase$("LSet") ELSE l$ = SCase$("RSet") dest$ = "" source$ = "" part = 1 i = 2 a3$ = "" B = 0 - Do - If i > n Then - If part <> 2 Or a3$ = "" Then a$ = "Expected LSET/RSET stringvariable=string": GoTo errmes + DO + IF i > n THEN + IF part <> 2 OR a3$ = "" THEN a$ = "Expected LSET/RSET stringvariable=string": GOTO errmes source$ = a3$ - Exit Do - End If + EXIT DO + END IF a2$ = getelement$(ca$, i) - If a2$ = "(" Then B = B + 1 - If a2$ = ")" Then B = B - 1 - If a2$ = "=" And B = 0 Then - If part = 1 Then dest$ = a3$: part = 2: a3$ = "": GoTo lrsetgotpart - End If - If Len(a3$) Then a3$ = a3$ + sp + a2$ Else a3$ = a2$ + IF a2$ = "(" THEN B = B + 1 + IF a2$ = ")" THEN B = B - 1 + IF a2$ = "=" AND B = 0 THEN + IF part = 1 THEN dest$ = a3$: part = 2: a3$ = "": GOTO lrsetgotpart + END IF + IF LEN(a3$) THEN a3$ = a3$ + sp + a2$ ELSE a3$ = a2$ lrsetgotpart: i = i + 1 - Loop - If dest$ = "" Then a$ = "Expected LSET/RSET stringvariable=string": GoTo errmes + LOOP + IF dest$ = "" THEN a$ = "Expected LSET/RSET stringvariable=string": GOTO errmes 'check if it is a valid source string f$ = fixoperationorder$(dest$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp + tlayout$ + sp + "=" e$ = evaluate(f$, sourcetyp) - If Error_Happened Then GoTo errmes - If (sourcetyp And ISREFERENCE) = 0 Or (sourcetyp And ISSTRING) = 0 Then a$ = "LSET/RSET expects a string variable/array-element as its first argument": GoTo errmes + IF Error_Happened THEN GOTO errmes + IF (sourcetyp AND ISREFERENCE) = 0 OR (sourcetyp AND ISSTRING) = 0 THEN a$ = "LSET/RSET expects a string variable/array-element as its first argument": GOTO errmes dest$ = evaluatetotyp(f$, ISSTRING) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes source$ = fixoperationorder$(source$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes l$ = l$ + sp + tlayout$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ source$ = evaluatetotyp(source$, ISSTRING) - If Error_Happened Then GoTo errmes - If firstelement$ = "LSET" Then - Print #12, "sub_lset(" + dest$ + "," + source$ + ");" - Else - Print #12, "sub_rset(" + dest$ + "," + source$ + ");" - End If - GoTo finishedline - End If + IF Error_Happened THEN GOTO errmes + IF firstelement$ = "LSET" THEN + PRINT #12, "sub_lset(" + dest$ + "," + source$ + ");" + ELSE + PRINT #12, "sub_rset(" + dest$ + "," + source$ + ");" + END IF + GOTO finishedline + END IF 'SWAP - If firstelement$ = "SWAP" Then - If n < 4 Then a$ = "Expected SWAP ... , ...": GoTo errmes + IF firstelement$ = "SWAP" THEN + IF n < 4 THEN a$ = "Expected SWAP ... , ...": GOTO errmes B = 0 ele = 1 e1$ = "" e2$ = "" - For i = 2 To n + FOR i = 2 TO n e$ = getelement$(ca$, i) - If e$ = "(" Then B = B + 1 - If e$ = ")" Then B = B - 1 - If e$ = "," And B = 0 Then - If ele = 2 Then a$ = "Expected SWAP ... , ...": GoTo errmes + IF e$ = "(" THEN B = B + 1 + IF e$ = ")" THEN B = B - 1 + IF e$ = "," AND B = 0 THEN + IF ele = 2 THEN a$ = "Expected SWAP ... , ...": GOTO errmes ele = 2 - Else - If ele = 1 Then e1$ = e1$ + sp + e$ Else e2$ = e2$ + sp + e$ - End If - Next - If e2$ = "" Then a$ = "Expected SWAP ... , ...": GoTo errmes - e1$ = Right$(e1$, Len(e1$) - 1): e2$ = Right$(e2$, Len(e2$) - 1) + ELSE + IF ele = 1 THEN e1$ = e1$ + sp + e$ ELSE e2$ = e2$ + sp + e$ + END IF + NEXT + IF e2$ = "" THEN a$ = "Expected SWAP ... , ...": GOTO errmes + e1$ = RIGHT$(e1$, LEN(e1$) - 1): e2$ = RIGHT$(e2$, LEN(e2$) - 1) e1$ = fixoperationorder(e1$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes e1l$ = tlayout$ e2$ = fixoperationorder(e2$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes e2l$ = tlayout$ e1$ = evaluate(e1$, e1typ): e2$ = evaluate(e2$, e2typ) - If Error_Happened Then GoTo errmes - If (e1typ And ISREFERENCE) = 0 Or (e2typ And ISREFERENCE) = 0 Then a$ = "Expected variable": GoTo errmes + IF Error_Happened THEN GOTO errmes + IF (e1typ AND ISREFERENCE) = 0 OR (e2typ AND ISREFERENCE) = 0 THEN a$ = "Expected variable": GOTO errmes layoutdone = 1 l$ = SCase$("Swap") + sp + e1l$ + sp2 + "," + sp + e2l$ - If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$ + IF LEN(layout$) = 0 THEN layout$ = l$ ELSE layout$ = layout$ + sp + l$ 'swap strings? - If (e1typ And ISSTRING) Then - If (e2typ And ISSTRING) = 0 Then a$ = "Type mismatch": GoTo errmes + IF (e1typ AND ISSTRING) THEN + IF (e2typ AND ISSTRING) = 0 THEN a$ = "Type mismatch": GOTO errmes e1$ = refer(e1$, e1typ, 0): e2$ = refer(e2$, e2typ, 0) - If Error_Happened Then GoTo errmes - Print #12, "swap_string(" + e1$ + "," + e2$ + ");" - GoTo finishedline - End If + IF Error_Happened THEN GOTO errmes + PRINT #12, "swap_string(" + e1$ + "," + e2$ + ");" + GOTO finishedline + END IF 'swap UDT? 'note: entire UDTs, unlike thier elements cannot be swapped like standard variables ' as UDT sizes may vary, and to avoid a malloc operation, QB64 should allocate a buffer ' in global.txt for the purpose of swapping each UDT type - If e1typ And ISUDT Then + IF e1typ AND ISUDT THEN a$ = e1$ 'retrieve ID - i = InStr(a$, sp3) - If i Then - idnumber = Val(Left$(a$, i - 1)): a$ = Right$(a$, Len(a$) - i) + i = INSTR(a$, sp3) + IF i THEN + idnumber = VAL(LEFT$(a$, i - 1)): a$ = RIGHT$(a$, LEN(a$) - i) getid idnumber - If Error_Happened Then GoTo errmes - u = Val(a$) - i = InStr(a$, sp3): a$ = Right$(a$, Len(a$) - i): E = Val(a$) - i = InStr(a$, sp3): o$ = Right$(a$, Len(a$) - i) - n$ = "UDT_" + RTrim$(id.n): If id.t = 0 Then n$ = "ARRAY_" + n$ + "[0]" - If E = 0 Then 'not an element of UDT u + IF Error_Happened THEN GOTO errmes + u = VAL(a$) + i = INSTR(a$, sp3): a$ = RIGHT$(a$, LEN(a$) - i): E = VAL(a$) + i = INSTR(a$, sp3): o$ = RIGHT$(a$, LEN(a$) - i) + n$ = "UDT_" + RTRIM$(id.n): IF id.t = 0 THEN n$ = "ARRAY_" + n$ + "[0]" + IF E = 0 THEN 'not an element of UDT u lhsscope$ = scope$ e$ = e2$: t2 = e2typ - If (t2 And ISUDT) = 0 Then a$ = "Expected SWAP with similar user defined type": GoTo errmes - idnumber2 = Val(e$) + IF (t2 AND ISUDT) = 0 THEN a$ = "Expected SWAP with similar user defined type": GOTO errmes + idnumber2 = VAL(e$) getid idnumber2 - If Error_Happened Then GoTo errmes - n2$ = "UDT_" + RTrim$(id.n): If id.t = 0 Then n2$ = "ARRAY_" + n2$ + "[0]" - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i): u2 = Val(e$) - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i): e2 = Val(e$) + IF Error_Happened THEN GOTO errmes + n2$ = "UDT_" + RTRIM$(id.n): IF id.t = 0 THEN n2$ = "ARRAY_" + n2$ + "[0]" + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i): u2 = VAL(e$) + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i): e2 = VAL(e$) - i = InStr(e$, sp3): o2$ = Right$(e$, Len(e$) - i) + i = INSTR(e$, sp3): o2$ = RIGHT$(e$, LEN(e$) - i) 'WARNING: u2 may need minor modifications based on e to see if they are the same - If u <> u2 Or e2 <> 0 Then a$ = "Expected SWAP with similar user defined type": GoTo errmes + IF u <> u2 OR e2 <> 0 THEN a$ = "Expected SWAP with similar user defined type": GOTO errmes dst$ = "(((char*)" + lhsscope$ + n$ + ")+(" + o$ + "))" src$ = "(((char*)" + scope$ + n2$ + ")+(" + o2$ + "))" B = udtxsize(u) \ 8 siz$ = str2$(B) - If B = 1 Then Print #12, "swap_8(" + src$ + "," + dst$ + ");" - If B = 2 Then Print #12, "swap_16(" + src$ + "," + dst$ + ");" - If B = 4 Then Print #12, "swap_32(" + src$ + "," + dst$ + ");" - If B = 8 Then Print #12, "swap_64(" + src$ + "," + dst$ + ");" - If B <> 1 And B <> 2 And B <> 4 And B <> 8 Then Print #12, "swap_block(" + src$ + "," + dst$ + "," + siz$ + ");" - GoTo finishedline - End If 'e=0 - End If 'i - End If 'isudt + IF B = 1 THEN PRINT #12, "swap_8(" + src$ + "," + dst$ + ");" + IF B = 2 THEN PRINT #12, "swap_16(" + src$ + "," + dst$ + ");" + IF B = 4 THEN PRINT #12, "swap_32(" + src$ + "," + dst$ + ");" + IF B = 8 THEN PRINT #12, "swap_64(" + src$ + "," + dst$ + ");" + IF B <> 1 AND B <> 2 AND B <> 4 AND B <> 8 THEN PRINT #12, "swap_block(" + src$ + "," + dst$ + "," + siz$ + ");" + GOTO finishedline + END IF 'e=0 + END IF 'i + END IF 'isudt 'cull irrelavent flags to make comparison possible e1typc = e1typ - If e1typc And ISPOINTER Then e1typc = e1typc - ISPOINTER - If e1typc And ISINCONVENTIONALMEMORY Then e1typc = e1typc - ISINCONVENTIONALMEMORY - If e1typc And ISARRAY Then e1typc = e1typc - ISARRAY - If e1typc And ISUNSIGNED Then e1typc = e1typc - ISUNSIGNED - If e1typc And ISUDT Then e1typc = e1typc - ISUDT + IF e1typc AND ISPOINTER THEN e1typc = e1typc - ISPOINTER + IF e1typc AND ISINCONVENTIONALMEMORY THEN e1typc = e1typc - ISINCONVENTIONALMEMORY + IF e1typc AND ISARRAY THEN e1typc = e1typc - ISARRAY + IF e1typc AND ISUNSIGNED THEN e1typc = e1typc - ISUNSIGNED + IF e1typc AND ISUDT THEN e1typc = e1typc - ISUDT e2typc = e2typ - If e2typc And ISPOINTER Then e2typc = e2typc - ISPOINTER - If e2typc And ISINCONVENTIONALMEMORY Then e2typc = e2typc - ISINCONVENTIONALMEMORY - If e2typc And ISARRAY Then e2typc = e2typc - ISARRAY - If e2typc And ISUNSIGNED Then e2typc = e2typc - ISUNSIGNED - If e2typc And ISUDT Then e2typc = e2typc - ISUDT - If e1typc <> e2typc Then a$ = "Type mismatch": GoTo errmes + IF e2typc AND ISPOINTER THEN e2typc = e2typc - ISPOINTER + IF e2typc AND ISINCONVENTIONALMEMORY THEN e2typc = e2typc - ISINCONVENTIONALMEMORY + IF e2typc AND ISARRAY THEN e2typc = e2typc - ISARRAY + IF e2typc AND ISUNSIGNED THEN e2typc = e2typc - ISUNSIGNED + IF e2typc AND ISUDT THEN e2typc = e2typc - ISUDT + IF e1typc <> e2typc THEN a$ = "Type mismatch": GOTO errmes t = e1typ - If t And ISOFFSETINBITS Then a$ = "Cannot SWAP bit-length variables": GoTo errmes - B = t And 511 - t$ = str2$(B): If B > 64 Then t$ = "longdouble" - Print #12, "swap_" + t$ + "(&" + refer(e1$, e1typ, 0) + ",&" + refer(e2$, e2typ, 0) + ");" - If Error_Happened Then GoTo errmes - GoTo finishedline - End If + IF t AND ISOFFSETINBITS THEN a$ = "Cannot SWAP bit-length variables": GOTO errmes + B = t AND 511 + t$ = str2$(B): IF B > 64 THEN t$ = "longdouble" + PRINT #12, "swap_" + t$ + "(&" + refer(e1$, e1typ, 0) + ",&" + refer(e2$, e2typ, 0) + ");" + IF Error_Happened THEN GOTO errmes + GOTO finishedline + END IF - If firstelement$ = "OPTION" Then - If optionexplicit = 0 Then e$ = " or OPTION " + qb64prefix$ + "EXPLICIT" Else e$ = "" - If optionexplicitarray = 0 Then e$ = e$ + " or OPTION " + qb64prefix$ + "EXPLICITARRAY" - If n = 1 Then a$ = "Expected OPTION BASE" + e$: GoTo errmes + IF firstelement$ = "OPTION" THEN + IF optionexplicit = 0 THEN e$ = " or OPTION " + qb64prefix$ + "EXPLICIT" ELSE e$ = "" + IF optionexplicitarray = 0 THEN e$ = e$ + " or OPTION " + qb64prefix$ + "EXPLICITARRAY" + IF n = 1 THEN a$ = "Expected OPTION BASE" + e$: GOTO errmes e$ = getelement$(a$, 2) - Select Case e$ - Case "BASE" + SELECT CASE e$ + CASE "BASE" l$ = getelement$(a$, 3) - If l$ <> "0" And l$ <> "1" Then a$ = "Expected OPTION BASE 0 or 1": GoTo errmes - If l$ = "1" Then optionbase = 1 Else optionbase = 0 + IF l$ <> "0" AND l$ <> "1" THEN a$ = "Expected OPTION BASE 0 or 1": GOTO errmes + IF l$ = "1" THEN optionbase = 1 ELSE optionbase = 0 l$ = SCase$("Option" + sp + "Base") + sp + l$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - Case "EXPLICIT", "_EXPLICIT" - If e$ = "EXPLICIT" And qb64prefix$ = "_" Then - If optionexplicit = 0 Then e$ = " or OPTION " + qb64prefix$ + "EXPLICIT" Else e$ = "" - If optionexplicitarray = 0 Then e$ = e$ + " or OPTION " + qb64prefix$ + "EXPLICITARRAY" - a$ = "Expected OPTION BASE" + e$: GoTo errmes - End If - If optionexplicit = -1 And NoIDEMode = 0 Then a$ = "Duplicate OPTION " + qb64prefix$ + "EXPLICIT": GoTo errmes - If Len(layout$) Then a$ = "OPTION " + qb64prefix$ + "EXPLICIT must come before any other statement": GoTo errmes - If linenumber > 1 And opex_comments = 0 Then a$ = "OPTION " + qb64prefix$ + "EXPLICIT must come before any other statement": GoTo errmes + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + CASE "EXPLICIT", "_EXPLICIT" + IF e$ = "EXPLICIT" AND qb64prefix$ = "_" THEN + IF optionexplicit = 0 THEN e$ = " or OPTION " + qb64prefix$ + "EXPLICIT" ELSE e$ = "" + IF optionexplicitarray = 0 THEN e$ = e$ + " or OPTION " + qb64prefix$ + "EXPLICITARRAY" + a$ = "Expected OPTION BASE" + e$: GOTO errmes + END IF + IF optionexplicit = -1 AND NoIDEMode = 0 THEN a$ = "Duplicate OPTION " + qb64prefix$ + "EXPLICIT": GOTO errmes + IF LEN(layout$) THEN a$ = "OPTION " + qb64prefix$ + "EXPLICIT must come before any other statement": GOTO errmes + IF linenumber > 1 AND opex_comments = 0 THEN a$ = "OPTION " + qb64prefix$ + "EXPLICIT must come before any other statement": GOTO errmes optionexplicit = -1 l$ = SCase$("Option") + sp - If e$ = "EXPLICIT" Then l$ = l$ + SCase$("Explicit") Else l$ = l$ + SCase$("_Explicit") - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - Case "EXPLICITARRAY", "_EXPLICITARRAY" - If e$ = "EXPLICITARRAY" And qb64prefix$ = "_" Then - If optionexplicit = 0 Then e$ = " or OPTION " + qb64prefix$ + "EXPLICIT" Else e$ = "" - If optionexplicitarray = 0 Then e$ = e$ + " or OPTION " + qb64prefix$ + "EXPLICITARRAY" - a$ = "Expected OPTION BASE" + e$: GoTo errmes - End If - If optionexplicitarray = -1 And NoIDEMode = 0 Then a$ = "Duplicate OPTION " + qb64prefix$ + "EXPLICITARRAY": GoTo errmes - If Len(layout$) Then a$ = "OPTION " + qb64prefix$ + "EXPLICITARRAY must come before any other statement": GoTo errmes - If linenumber > 1 And opex_comments = 0 Then a$ = "OPTION " + qb64prefix$ + "EXPLICITARRAY must come before any other statement": GoTo errmes + IF e$ = "EXPLICIT" THEN l$ = l$ + SCase$("Explicit") ELSE l$ = l$ + SCase$("_Explicit") + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + CASE "EXPLICITARRAY", "_EXPLICITARRAY" + IF e$ = "EXPLICITARRAY" AND qb64prefix$ = "_" THEN + IF optionexplicit = 0 THEN e$ = " or OPTION " + qb64prefix$ + "EXPLICIT" ELSE e$ = "" + IF optionexplicitarray = 0 THEN e$ = e$ + " or OPTION " + qb64prefix$ + "EXPLICITARRAY" + a$ = "Expected OPTION BASE" + e$: GOTO errmes + END IF + IF optionexplicitarray = -1 AND NoIDEMode = 0 THEN a$ = "Duplicate OPTION " + qb64prefix$ + "EXPLICITARRAY": GOTO errmes + IF LEN(layout$) THEN a$ = "OPTION " + qb64prefix$ + "EXPLICITARRAY must come before any other statement": GOTO errmes + IF linenumber > 1 AND opex_comments = 0 THEN a$ = "OPTION " + qb64prefix$ + "EXPLICITARRAY must come before any other statement": GOTO errmes optionexplicitarray = -1 l$ = SCase$("Option") + sp - If e$ = "EXPLICITARRAY" Then l$ = l$ + SCase$("ExplicitArray") Else l$ = l$ + SCase$("_ExplicitArray") - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ - GoTo finishedline - Case Else - If optionexplicit = 0 Then e$ = " or OPTION " + qb64prefix$ + "EXPLICIT" Else e$ = "" - If optionexplicitarray = 0 Then e$ = e$ + " or OPTION " + qb64prefix$ + "EXPLICITARRAY" - a$ = "Expected OPTION BASE" + e$: GoTo errmes - End Select - End If + IF e$ = "EXPLICITARRAY" THEN l$ = l$ + SCase$("ExplicitArray") ELSE l$ = l$ + SCase$("_ExplicitArray") + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + GOTO finishedline + CASE ELSE + IF optionexplicit = 0 THEN e$ = " or OPTION " + qb64prefix$ + "EXPLICIT" ELSE e$ = "" + IF optionexplicitarray = 0 THEN e$ = e$ + " or OPTION " + qb64prefix$ + "EXPLICITARRAY" + a$ = "Expected OPTION BASE" + e$: GOTO errmes + END SELECT + END IF 'any other "unique" subs can be processed above @@ -10114,30 +10114,30 @@ Do targetid = currentid - If RTrim$(id2.callname) = "sub_stub" Then a$ = "Command not implemented": GoTo errmes + IF RTRIM$(id2.callname) = "sub_stub" THEN a$ = "Command not implemented": GOTO errmes - If n > 1 Then - If id2.args = 0 Then a$ = "SUB does not require any arguments": GoTo errmes - End If + IF n > 1 THEN + IF id2.args = 0 THEN a$ = "SUB does not require any arguments": GOTO errmes + END IF SetDependency id2.Dependency seperateargs_error = 0 passedneeded = seperateargs(getelements(a$, 2, n), getelements(ca$, 2, n), passed&) - If seperateargs_error Then a$ = seperateargs_error_message: GoTo errmes + IF seperateargs_error THEN a$ = seperateargs_error_message: GOTO errmes 'backup args to local string array space before calling evaluate - For i = 1 To OptMax: separgs2(i) = "": Next 'save space! - For i = 1 To OptMax + 1: separgslayout2(i) = "": Next - For i = 1 To id2.args: separgs2(i) = separgs(i): Next - For i = 1 To id2.args + 1: separgslayout2(i) = separgslayout(i): Next + FOR i = 1 TO OptMax: separgs2(i) = "": NEXT 'save space! + FOR i = 1 TO OptMax + 1: separgslayout2(i) = "": NEXT + FOR i = 1 TO id2.args: separgs2(i) = separgs(i): NEXT + FOR i = 1 TO id2.args + 1: separgslayout2(i) = separgslayout(i): NEXT - If Debug Then - Print #9, "separgs:": For i = 1 To id2.args: Print #9, i, separgs2(i): Next - Print #9, "separgslayout:": For i = 1 To id2.args + 1: Print #9, i, separgslayout2(i): Next - End If + IF Debug THEN + PRINT #9, "separgs:": FOR i = 1 TO id2.args: PRINT #9, i, separgs2(i): NEXT + PRINT #9, "separgslayout:": FOR i = 1 TO id2.args + 1: PRINT #9, i, separgslayout2(i): NEXT + END IF @@ -10148,80 +10148,80 @@ Do ' the above array stores what layout info (if any) goes BEFORE the arg in question ' it has one extra index which is the arg after - If usecall Then - If id.internal_subfunc Then - If usecall = 1 Then l$ = SCase$("Call") + sp + SCase$(RTrim$(id.cn)) + RTrim$(id.musthave) + sp2 + "(" + sp2 - If usecall = 2 Then l$ = SCase$("Call") + sp + SCase$(RTrim$(id.cn)) + RTrim$(id.musthave) + sp 'sp at end for easy parsing - Else - If usecall = 1 Then l$ = SCase$("Call") + sp + RTrim$(id.cn) + RTrim$(id.musthave) + sp2 + "(" + sp2 - If usecall = 2 Then l$ = SCase$("Call") + sp + RTrim$(id.cn) + RTrim$(id.musthave) + sp 'sp at end for easy parsing - End If - Else - If id.internal_subfunc Then - l$ = SCase$(RTrim$(id.cn)) + RTrim$(id.musthave) + sp - Else - l$ = RTrim$(id.cn) + RTrim$(id.musthave) + sp - End If - End If + IF usecall THEN + IF id.internal_subfunc THEN + IF usecall = 1 THEN l$ = SCase$("Call") + sp + SCase$(RTRIM$(id.cn)) + RTRIM$(id.musthave) + sp2 + "(" + sp2 + IF usecall = 2 THEN l$ = SCase$("Call") + sp + SCase$(RTRIM$(id.cn)) + RTRIM$(id.musthave) + sp 'sp at end for easy parsing + ELSE + IF usecall = 1 THEN l$ = SCase$("Call") + sp + RTRIM$(id.cn) + RTRIM$(id.musthave) + sp2 + "(" + sp2 + IF usecall = 2 THEN l$ = SCase$("Call") + sp + RTRIM$(id.cn) + RTRIM$(id.musthave) + sp 'sp at end for easy parsing + END IF + ELSE + IF id.internal_subfunc THEN + l$ = SCase$(RTRIM$(id.cn)) + RTRIM$(id.musthave) + sp + ELSE + l$ = RTRIM$(id.cn) + RTRIM$(id.musthave) + sp + END IF + END IF - subcall$ = RTrim$(id.callname) + "(" + subcall$ = RTRIM$(id.callname) + "(" addedlayout = 0 fieldcall = 0 'GET/PUT field exception - If RTrim$(id2.callname) = "sub_get" Or RTrim$(id2.callname) = "sub_put" Then - If passed And 2 Then + IF RTRIM$(id2.callname) = "sub_get" OR RTRIM$(id2.callname) = "sub_put" THEN + IF passed AND 2 THEN 'regular GET/PUT call with variable provided passed = passed - 2 'for complience with existing methods, remove 'passed' flag for the passing of a variable - Else + ELSE 'FIELD GET/PUT call with variable omited - If RTrim$(id2.callname) = "sub_get" Then + IF RTRIM$(id2.callname) = "sub_get" THEN fieldcall = 1 subcall$ = "field_get(" - Else + ELSE fieldcall = 2 subcall$ = "field_put(" - End If - End If - End If 'field exception + END IF + END IF + END IF 'field exception - If RTrim$(id2.callname) = "sub_timer" Or RTrim$(id2.callname) = "sub_key" Then 'spacing exception - If usecall = 0 Then - l$ = Left$(l$, Len(l$) - 1) + sp2 - End If - End If + IF RTRIM$(id2.callname) = "sub_timer" OR RTRIM$(id2.callname) = "sub_key" THEN 'spacing exception + IF usecall = 0 THEN + l$ = LEFT$(l$, LEN(l$) - 1) + sp2 + END IF + END IF - For i = 1 To id2.args - targettyp = CVL(Mid$(id2.arg, -3 + i * 4, 4)) - nele = Asc(Mid$(id2.nele, i, 1)) - nelereq = Asc(Mid$(id2.nelereq, i, 1)) + FOR i = 1 TO id2.args + targettyp = CVL(MID$(id2.arg, -3 + i * 4, 4)) + nele = ASC(MID$(id2.nele, i, 1)) + nelereq = ASC(MID$(id2.nelereq, i, 1)) addlayout = 1 'omits option values in layout (eg. BINARY="2") convertspacing = 0 'if an 'equation' is next, it will be preceeded by a space x$ = separgslayout2$(i) - Do While Len(x$) - x = Asc(x$) - If x Then + DO WHILE LEN(x$) + x = ASC(x$) + IF x THEN convertspacing = 0 - x2$ = Mid$(x$, 2, x) - x$ = Right$(x$, Len(x$) - x - 1) + x2$ = MID$(x$, 2, x) + x$ = RIGHT$(x$, LEN(x$) - x - 1) s = 0 an = 0 - x3$ = Right$(l$, 1) - If x3$ = sp Then s = 1 - If x3$ = sp2 Then + x3$ = RIGHT$(l$, 1) + IF x3$ = sp THEN s = 1 + IF x3$ = sp2 THEN s = 2 - If alphanumeric(Asc(Right$(l$, 2))) Then an = 1 - Else - If alphanumeric(Asc(x3$)) Then an = 1 - End If + IF alphanumeric(ASC(RIGHT$(l$, 2))) THEN an = 1 + ELSE + IF alphanumeric(ASC(x3$)) THEN an = 1 + END IF s1 = s - If alphanumeric(Asc(x2$)) Then convertspacing = 1 + IF alphanumeric(ASC(x2$)) THEN convertspacing = 1 - If x2$ = "LPRINT" Then + IF x2$ = "LPRINT" THEN 'x2$="LPRINT" 'x$=CHR$(0) @@ -10240,39 +10240,39 @@ Do 'print #9,x2$ 'end if - End If + END IF - If (an = 1 Or addedlayout = 1) And alphanumeric(Asc(x2$)) <> 0 Then + IF (an = 1 OR addedlayout = 1) AND alphanumeric(ASC(x2$)) <> 0 THEN s = 1 'force space x2$ = x2$ + sp2 - GoTo customlaychar - End If + GOTO customlaychar + END IF - If x2$ = "=" Then + IF x2$ = "=" THEN s = 1 x2$ = x2$ + sp - GoTo customlaychar - End If + GOTO customlaychar + END IF - If x2$ = "#" Then + IF x2$ = "#" THEN s = 1 x2$ = x2$ + sp2 - GoTo customlaychar - End If + GOTO customlaychar + END IF - If x2$ = "," Then x2$ = x2$ + sp: GoTo customlaychar + IF x2$ = "," THEN x2$ = x2$ + sp: GOTO customlaychar - If x$ = Chr$(0) Then 'substitution - If x2$ = "STEP" Then x2$ = x2$ + sp2: GoTo customlaychar - x2$ = x2$ + sp: GoTo customlaychar - End If + IF x$ = CHR$(0) THEN 'substitution + IF x2$ = "STEP" THEN x2$ = x2$ + sp2: GOTO customlaychar + x2$ = x2$ + sp: GOTO customlaychar + END IF 'default solution sp2+?+sp2 x2$ = x2$ + sp2 @@ -10282,27 +10282,27 @@ Do customlaychar: - If s = 0 Then s = 2 - If s <> s1 Then - If s1 Then l$ = Left$(l$, Len(l$) - 1) - If s = 1 Then l$ = l$ + sp - If s = 2 Then l$ = l$ + sp2 - End If + IF s = 0 THEN s = 2 + IF s <> s1 THEN + IF s1 THEN l$ = LEFT$(l$, LEN(l$) - 1) + IF s = 1 THEN l$ = l$ + sp + IF s = 2 THEN l$ = l$ + sp2 + END IF - If (RTrim$(id2.callname) = "sub_timer" Or RTrim$(id2.callname) = "sub_key") And i = id2.args Then 'spacing exception - If x2$ <> ")" + sp2 Then - l$ = Left$(l$, Len(l$) - 1) + sp - End If - End If + IF (RTRIM$(id2.callname) = "sub_timer" OR RTRIM$(id2.callname) = "sub_key") AND i = id2.args THEN 'spacing exception + IF x2$ <> ")" + sp2 THEN + l$ = LEFT$(l$, LEN(l$) - 1) + sp + END IF + END IF l$ = l$ + x2$ - Else + ELSE addlayout = 0 - x$ = Right$(x$, Len(x$) - 1) - End If + x$ = RIGHT$(x$, LEN(x$) - 1) + END IF addedlayout = 0 - Loop + LOOP @@ -10310,909 +10310,909 @@ Do - If targettyp = -3 Then - If separgs2(i) = "N-LL" Then a$ = "Expected array name": GoTo errmes + IF targettyp = -3 THEN + IF separgs2(i) = "N-LL" THEN a$ = "Expected array name": GOTO errmes 'names of numeric arrays have ( ) automatically appended (nothing else) e$ = separgs2(i) - If InStr(e$, sp) = 0 Then 'one element only + IF INSTR(e$, sp) = 0 THEN 'one element only try_string$ = e$ try = findid(try_string$) - If Error_Happened Then GoTo errmes - Do - If try Then - If id.arraytype Then - If (id.arraytype And ISSTRING) = 0 Then + IF Error_Happened THEN GOTO errmes + DO + IF try THEN + IF id.arraytype THEN + IF (id.arraytype AND ISSTRING) = 0 THEN e$ = e$ + sp + "(" + sp + ")" - Exit Do - End If - End If + EXIT DO + END IF + END IF '--- - If try = 2 Then findanotherid = 1: try = findid(try_string$) Else try = 0 - If Error_Happened Then GoTo errmes - End If 'if try - If try = 0 Then 'add symbol? - If Len(removesymbol$(try_string$)) = 0 Then - If Error_Happened Then GoTo errmes - a = Asc(try_string$) - If a >= 97 And a <= 122 Then a = a - 32 - If a = 95 Then a = 91 + IF try = 2 THEN findanotherid = 1: try = findid(try_string$) ELSE try = 0 + IF Error_Happened THEN GOTO errmes + END IF 'if try + IF try = 0 THEN 'add symbol? + IF LEN(removesymbol$(try_string$)) = 0 THEN + IF Error_Happened THEN GOTO errmes + a = ASC(try_string$) + IF a >= 97 AND a <= 122 THEN a = a - 32 + IF a = 95 THEN a = 91 a = a - 64 - If Len(defineextaz(a)) Then try_string$ = try_string$ + defineextaz(a): try = findid(try_string$) - If Error_Happened Then GoTo errmes - End If - End If 'try=0 - Loop Until try = 0 - End If 'one element only + IF LEN(defineextaz(a)) THEN try_string$ = try_string$ + defineextaz(a): try = findid(try_string$) + IF Error_Happened THEN GOTO errmes + END IF + END IF 'try=0 + LOOP UNTIL try = 0 + END IF 'one element only e$ = fixoperationorder$(e$) - If Error_Happened Then GoTo errmes - If convertspacing = 1 And addlayout = 1 Then l$ = Left$(l$, Len(l$) - 1) + sp - If addlayout Then l$ = l$ + tlayout$: addedlayout = 1 + IF Error_Happened THEN GOTO errmes + IF convertspacing = 1 AND addlayout = 1 THEN l$ = LEFT$(l$, LEN(l$) - 1) + sp + IF addlayout THEN l$ = l$ + tlayout$: addedlayout = 1 e$ = evaluatetotyp(e$, -2) - If Error_Happened Then GoTo errmes - GoTo sete - End If '-3 + IF Error_Happened THEN GOTO errmes + GOTO sete + END IF '-3 - If targettyp = -2 Then + IF targettyp = -2 THEN e$ = fixoperationorder$(e$) - If Error_Happened Then GoTo errmes - If convertspacing = 1 And addlayout = 1 Then l$ = Left$(l$, Len(l$) - 1) + sp - If addlayout Then l$ = l$ + tlayout$: addedlayout = 1 + IF Error_Happened THEN GOTO errmes + IF convertspacing = 1 AND addlayout = 1 THEN l$ = LEFT$(l$, LEN(l$) - 1) + sp + IF addlayout THEN l$ = l$ + tlayout$: addedlayout = 1 e$ = evaluatetotyp(e$, -2) - If Error_Happened Then GoTo errmes - GoTo sete - End If '-2 + IF Error_Happened THEN GOTO errmes + GOTO sete + END IF '-2 - If targettyp = -4 Then + IF targettyp = -4 THEN - If fieldcall Then + IF fieldcall THEN i = id2.args + 1 - Exit For - End If + EXIT FOR + END IF - If separgs2(i) = "N-LL" Then a$ = "Expected variable name/array element": GoTo errmes + IF separgs2(i) = "N-LL" THEN a$ = "Expected variable name/array element": GOTO errmes e$ = fixoperationorder$(separgs2(i)) - If Error_Happened Then GoTo errmes - If convertspacing = 1 And addlayout = 1 Then l$ = Left$(l$, Len(l$) - 1) + sp - If addlayout Then l$ = l$ + tlayout$: addedlayout = 1 + IF Error_Happened THEN GOTO errmes + IF convertspacing = 1 AND addlayout = 1 THEN l$ = LEFT$(l$, LEN(l$) - 1) + sp + IF addlayout THEN l$ = l$ + tlayout$: addedlayout = 1 'GET/PUT RANDOM-ACCESS override - If firstelement$ = "GET" Or firstelement$ = "PUT" Then + IF firstelement$ = "GET" OR firstelement$ = "PUT" THEN e2$ = e$ 'backup e$ = evaluate(e$, sourcetyp) - If Error_Happened Then GoTo errmes - If (sourcetyp And ISSTRING) Then - If (sourcetyp And ISFIXEDLENGTH) = 0 Then + IF Error_Happened THEN GOTO errmes + IF (sourcetyp AND ISSTRING) THEN + IF (sourcetyp AND ISFIXEDLENGTH) = 0 THEN 'replace name of sub to call - subcall$ = Right$(subcall$, Len(subcall$) - 7) 'delete original name + subcall$ = RIGHT$(subcall$, LEN(subcall$) - 7) 'delete original name 'note: GET2 & PUT2 take differing input, following code is correct - If firstelement$ = "GET" Then + IF firstelement$ = "GET" THEN subcall$ = "sub_get2" + subcall$ e$ = refer(e$, sourcetyp, 0) 'pass a qbs pointer instead - If Error_Happened Then GoTo errmes - GoTo sete - Else + IF Error_Happened THEN GOTO errmes + GOTO sete + ELSE subcall$ = "sub_put2" + subcall$ 'no goto sete required, fall through - End If - End If - End If + END IF + END IF + END IF e$ = e2$ 'restore - End If 'override + END IF 'override e$ = evaluatetotyp(e$, -4) - If Error_Happened Then GoTo errmes - GoTo sete - End If '-4 + IF Error_Happened THEN GOTO errmes + GOTO sete + END IF '-4 - If separgs2(i) = "N-LL" Then + IF separgs2(i) = "N-LL" THEN e$ = "NULL" - Else + ELSE e2$ = fixoperationorder$(separgs2(i)) - If Error_Happened Then GoTo errmes - If convertspacing = 1 And addlayout = 1 Then l$ = Left$(l$, Len(l$) - 1) + sp - If addlayout Then l$ = l$ + tlayout$: addedlayout = 1 + IF Error_Happened THEN GOTO errmes + IF convertspacing = 1 AND addlayout = 1 THEN l$ = LEFT$(l$, LEN(l$) - 1) + sp + IF addlayout THEN l$ = l$ + tlayout$: addedlayout = 1 e$ = evaluate(e2$, sourcetyp) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes - If sourcetyp And ISOFFSET Then - If (targettyp And ISOFFSET) = 0 Then - If id2.internal_subfunc = 0 Then a$ = "Cannot convert _OFFSET type to other types": GoTo errmes - End If - End If + IF sourcetyp AND ISOFFSET THEN + IF (targettyp AND ISOFFSET) = 0 THEN + IF id2.internal_subfunc = 0 THEN a$ = "Cannot convert _OFFSET type to other types": GOTO errmes + END IF + END IF - If RTrim$(id2.callname) = "sub_paint" Then - If i = 3 Then - If (sourcetyp And ISSTRING) Then + IF RTRIM$(id2.callname) = "sub_paint" THEN + IF i = 3 THEN + IF (sourcetyp AND ISSTRING) THEN targettyp = ISSTRING - End If - End If - End If + END IF + END IF + END IF - If Left$(separgs2(i), 2) = "(" + sp Then dereference = 1 Else dereference = 0 + IF LEFT$(separgs2(i), 2) = "(" + sp THEN dereference = 1 ELSE dereference = 0 'pass by reference - If (targettyp And ISPOINTER) Then - If dereference = 0 Then 'check deferencing wasn't used + IF (targettyp AND ISPOINTER) THEN + IF dereference = 0 THEN 'check deferencing wasn't used 'note: array pointer - If (targettyp And ISARRAY) Then - If (sourcetyp And ISREFERENCE) = 0 Then a$ = "Expected arrayname()": GoTo errmes - If (sourcetyp And ISARRAY) = 0 Then a$ = "Expected arrayname()": GoTo errmes - If Debug Then Print #9, "sub:array reference:[" + e$ + "]" + IF (targettyp AND ISARRAY) THEN + IF (sourcetyp AND ISREFERENCE) = 0 THEN a$ = "Expected arrayname()": GOTO errmes + IF (sourcetyp AND ISARRAY) = 0 THEN a$ = "Expected arrayname()": GOTO errmes + IF Debug THEN PRINT #9, "sub:array reference:[" + e$ + "]" 'check arrays are of same type targettyp2 = targettyp: sourcetyp2 = sourcetyp - targettyp2 = targettyp2 And (511 + ISOFFSETINBITS + ISUDT + ISSTRING + ISFIXEDLENGTH + ISFLOAT) - sourcetyp2 = sourcetyp2 And (511 + ISOFFSETINBITS + ISUDT + ISSTRING + ISFIXEDLENGTH + ISFLOAT) - If sourcetyp2 <> targettyp2 Then a$ = "Incorrect array type passed to sub": GoTo errmes + targettyp2 = targettyp2 AND (511 + ISOFFSETINBITS + ISUDT + ISSTRING + ISFIXEDLENGTH + ISFLOAT) + sourcetyp2 = sourcetyp2 AND (511 + ISOFFSETINBITS + ISUDT + ISSTRING + ISFIXEDLENGTH + ISFLOAT) + IF sourcetyp2 <> targettyp2 THEN a$ = "Incorrect array type passed to sub": GOTO errmes 'check arrayname was followed by '()' - If targettyp And ISUDT Then - If Debug Then Print #9, "sub:array reference:udt reference:[" + e$ + "]" + IF targettyp AND ISUDT THEN + IF Debug THEN PRINT #9, "sub:array reference:udt reference:[" + e$ + "]" 'get UDT info - udtrefid = Val(e$) + udtrefid = VAL(e$) getid udtrefid - If Error_Happened Then GoTo errmes - udtrefi = InStr(e$, sp3) 'end of id - udtrefi2 = InStr(udtrefi + 1, e$, sp3) 'end of u - udtrefu = Val(Mid$(e$, udtrefi + 1, udtrefi2 - udtrefi - 1)) - udtrefi3 = InStr(udtrefi2 + 1, e$, sp3) 'skip e - udtrefe = Val(Mid$(e$, udtrefi2 + 1, udtrefi3 - udtrefi2 - 1)) - o$ = Right$(e$, Len(e$) - udtrefi3) + IF Error_Happened THEN GOTO errmes + udtrefi = INSTR(e$, sp3) 'end of id + udtrefi2 = INSTR(udtrefi + 1, e$, sp3) 'end of u + udtrefu = VAL(MID$(e$, udtrefi + 1, udtrefi2 - udtrefi - 1)) + udtrefi3 = INSTR(udtrefi2 + 1, e$, sp3) 'skip e + udtrefe = VAL(MID$(e$, udtrefi2 + 1, udtrefi3 - udtrefi2 - 1)) + o$ = RIGHT$(e$, LEN(e$) - udtrefi3) 'note: most of the UDT info above is not required - If Left$(o$, 4) <> "(0)*" Then a$ = "Expected arrayname()": GoTo errmes - Else - If Right$(e$, 2) <> sp3 + "0" Then a$ = "Expected arrayname()": GoTo errmes - End If + IF LEFT$(o$, 4) <> "(0)*" THEN a$ = "Expected arrayname()": GOTO errmes + ELSE + IF RIGHT$(e$, 2) <> sp3 + "0" THEN a$ = "Expected arrayname()": GOTO errmes + END IF - idnum = Val(Left$(e$, InStr(e$, sp3) - 1)) + idnum = VAL(LEFT$(e$, INSTR(e$, sp3) - 1)) getid idnum - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes - If targettyp And ISFIXEDLENGTH Then - targettypsize = CVL(Mid$(id2.argsize, i * 4 - 4 + 1, 4)) - If id.tsize <> targettypsize Then a$ = "Incorrect array type passed to sub": GoTo errmes - End If + IF targettyp AND ISFIXEDLENGTH THEN + targettypsize = CVL(MID$(id2.argsize, i * 4 - 4 + 1, 4)) + IF id.tsize <> targettypsize THEN a$ = "Incorrect array type passed to sub": GOTO errmes + END IF - If Mid$(sfcmemargs(targetid), i, 1) = Chr$(1) Then 'cmem required? - If cmemlist(idnum) = 0 Then + IF MID$(sfcmemargs(targetid), i, 1) = CHR$(1) THEN 'cmem required? + IF cmemlist(idnum) = 0 THEN cmemlist(idnum) = 1 recompile = 1 - End If - End If + END IF + END IF - If id.linkid = 0 Then + IF id.linkid = 0 THEN 'if id.linkid is 0, it means the number of array elements is definietly 'known of the array being passed, this is not some "fake"/unknown array. 'using the numer of array elements of a fake array would be dangerous! - If nelereq = 0 Then + IF nelereq = 0 THEN 'only continue if the number of array elements required is unknown 'and it needs to be set - If id.arrayelements > 0 Then '2009 + IF id.arrayelements > 0 THEN '2009 nelereq = id.arrayelements - Mid$(id2.nelereq, i, 1) = Chr$(nelereq) + MID$(id2.nelereq, i, 1) = CHR$(nelereq) - End If + END IF 'print rtrim$(id2.n)+">nelereq=";nelereq ids(targetid) = id2 - Else + ELSE 'the number of array elements required is known AND 'the number of elements in the array to be passed is known - If id.arrayelements <> nelereq Then a$ = "Passing arrays with a differing number of elements to a SUB/FUNCTION is not supported (yet)": GoTo errmes + IF id.arrayelements <> nelereq THEN a$ = "Passing arrays with a differing number of elements to a SUB/FUNCTION is not supported (yet)": GOTO errmes - End If - End If + END IF + END IF e$ = refer(e$, sourcetyp, 1) - If Error_Happened Then GoTo errmes - GoTo sete + IF Error_Happened THEN GOTO errmes + GOTO sete - End If 'target is an array + END IF 'target is an array 'note: not an array... 'target is not an array - If (targettyp And ISSTRING) = 0 Then - If (sourcetyp And ISREFERENCE) Then - idnum = Val(Left$(e$, InStr(e$, sp3) - 1)) 'id# of sourcetyp + IF (targettyp AND ISSTRING) = 0 THEN + IF (sourcetyp AND ISREFERENCE) THEN + idnum = VAL(LEFT$(e$, INSTR(e$, sp3) - 1)) 'id# of sourcetyp targettyp2 = targettyp: sourcetyp2 = sourcetyp 'get info about source/target - arr = 0: If (sourcetyp2 And ISARRAY) Then arr = 1 - passudtelement = 0: If (targettyp2 And ISUDT) = 0 And (sourcetyp2 And ISUDT) <> 0 Then passudtelement = 1: sourcetyp2 = sourcetyp2 - ISUDT + arr = 0: IF (sourcetyp2 AND ISARRAY) THEN arr = 1 + passudtelement = 0: IF (targettyp2 AND ISUDT) = 0 AND (sourcetyp2 AND ISUDT) <> 0 THEN passudtelement = 1: sourcetyp2 = sourcetyp2 - ISUDT 'remove flags irrelevant for comparison... ISPOINTER,ISREFERENCE,ISINCONVENTIONALMEMORY,ISARRAY - targettyp2 = targettyp2 And (511 + ISOFFSETINBITS + ISUDT + ISFLOAT + ISSTRING) - sourcetyp2 = sourcetyp2 And (511 + ISOFFSETINBITS + ISUDT + ISFLOAT + ISSTRING) + targettyp2 = targettyp2 AND (511 + ISOFFSETINBITS + ISUDT + ISFLOAT + ISSTRING) + sourcetyp2 = sourcetyp2 AND (511 + ISOFFSETINBITS + ISUDT + ISFLOAT + ISSTRING) 'compare types - If sourcetyp2 = targettyp2 Then + IF sourcetyp2 = targettyp2 THEN - If sourcetyp And ISUDT Then + IF sourcetyp AND ISUDT THEN 'udt/udt array 'get info - udtrefid = Val(e$) + udtrefid = VAL(e$) getid udtrefid - If Error_Happened Then GoTo errmes - udtrefi = InStr(e$, sp3) 'end of id - udtrefi2 = InStr(udtrefi + 1, e$, sp3) 'end of u - udtrefu = Val(Mid$(e$, udtrefi + 1, udtrefi2 - udtrefi - 1)) - udtrefi3 = InStr(udtrefi2 + 1, e$, sp3) 'skip e - udtrefe = Val(Mid$(e$, udtrefi2 + 1, udtrefi3 - udtrefi2 - 1)) - o$ = Right$(e$, Len(e$) - udtrefi3) + IF Error_Happened THEN GOTO errmes + udtrefi = INSTR(e$, sp3) 'end of id + udtrefi2 = INSTR(udtrefi + 1, e$, sp3) 'end of u + udtrefu = VAL(MID$(e$, udtrefi + 1, udtrefi2 - udtrefi - 1)) + udtrefi3 = INSTR(udtrefi2 + 1, e$, sp3) 'skip e + udtrefe = VAL(MID$(e$, udtrefi2 + 1, udtrefi3 - udtrefi2 - 1)) + o$ = RIGHT$(e$, LEN(e$) - udtrefi3) 'note: most of the UDT info above is not required - If arr Then - n$ = scope$ + "ARRAY_UDT_" + RTrim$(id.n) + "[0]" - Else - n$ = scope$ + "UDT_" + RTrim$(id.n) - End If + IF arr THEN + n$ = scope$ + "ARRAY_UDT_" + RTRIM$(id.n) + "[0]" + ELSE + n$ = scope$ + "UDT_" + RTRIM$(id.n) + END IF e$ = "(void*)( ((char*)(" + n$ + ")) + (" + o$ + ") )" 'convert void* to target type* - If passudtelement Then e$ = "(" + typ2ctyp$(targettyp2 + (targettyp And ISUNSIGNED), "") + "*)" + e$ - If Error_Happened Then GoTo errmes + IF passudtelement THEN e$ = "(" + typ2ctyp$(targettyp2 + (targettyp AND ISUNSIGNED), "") + "*)" + e$ + IF Error_Happened THEN GOTO errmes - Else + ELSE 'not a udt - If arr Then - If (sourcetyp2 And ISOFFSETINBITS) Then a$ = "Cannot pass BIT array offsets yet": GoTo errmes + IF arr THEN + IF (sourcetyp2 AND ISOFFSETINBITS) THEN a$ = "Cannot pass BIT array offsets yet": GOTO errmes e$ = "(&(" + refer(e$, sourcetyp, 0) + "))" - If Error_Happened Then GoTo errmes - Else + IF Error_Happened THEN GOTO errmes + ELSE e$ = refer(e$, sourcetyp, 1) - If Error_Happened Then GoTo errmes - End If + IF Error_Happened THEN GOTO errmes + END IF 'note: signed/unsigned mismatch requires casting - If (sourcetyp And ISUNSIGNED) <> (targettyp And ISUNSIGNED) Then - e$ = "(" + typ2ctyp$(targettyp2 + (targettyp And ISUNSIGNED), "") + "*)" + e$ - If Error_Happened Then GoTo errmes - End If + IF (sourcetyp AND ISUNSIGNED) <> (targettyp AND ISUNSIGNED) THEN + e$ = "(" + typ2ctyp$(targettyp2 + (targettyp AND ISUNSIGNED), "") + "*)" + e$ + IF Error_Happened THEN GOTO errmes + END IF - End If 'udt? + END IF 'udt? - If Mid$(sfcmemargs(targetid), i, 1) = Chr$(1) Then 'cmem required? - If cmemlist(idnum) = 0 Then + IF MID$(sfcmemargs(targetid), i, 1) = CHR$(1) THEN 'cmem required? + IF cmemlist(idnum) = 0 THEN cmemlist(idnum) = 1 recompile = 1 - End If - End If + END IF + END IF - GoTo sete - End If 'similar - End If 'reference - Else 'not a string + GOTO sete + END IF 'similar + END IF 'reference + ELSE 'not a string 'its a string - If (sourcetyp And ISREFERENCE) Then - idnum = Val(Left$(e$, InStr(e$, sp3) - 1)) 'id# of sourcetyp - If Mid$(sfcmemargs(targetid), i, 1) = Chr$(1) Then 'cmem required? - If cmemlist(idnum) = 0 Then + IF (sourcetyp AND ISREFERENCE) THEN + idnum = VAL(LEFT$(e$, INSTR(e$, sp3) - 1)) 'id# of sourcetyp + IF MID$(sfcmemargs(targetid), i, 1) = CHR$(1) THEN 'cmem required? + IF cmemlist(idnum) = 0 THEN cmemlist(idnum) = 1 recompile = 1 - End If - End If - End If 'reference - End If 'its a string + END IF + END IF + END IF 'reference + END IF 'its a string - End If 'dereference check - End If 'target is a pointer + END IF 'dereference check + END IF 'target is a pointer 'note: Target is not a pointer... 'String-numeric mismatch? - If targettyp And ISSTRING Then - If (sourcetyp And ISSTRING) = 0 Then + IF targettyp AND ISSTRING THEN + IF (sourcetyp AND ISSTRING) = 0 THEN nth = i - If ids(targetid).args = 1 Then a$ = "String required for sub": GoTo errmes - a$ = str_nth$(nth) + " sub argument requires a string": GoTo errmes - End If - End If - If (targettyp And ISSTRING) = 0 Then - If sourcetyp And ISSTRING Then + IF ids(targetid).args = 1 THEN a$ = "String required for sub": GOTO errmes + a$ = str_nth$(nth) + " sub argument requires a string": GOTO errmes + END IF + END IF + IF (targettyp AND ISSTRING) = 0 THEN + IF sourcetyp AND ISSTRING THEN nth = i - If ids(targetid).args = 1 Then a$ = "Number required for sub": GoTo errmes - a$ = str_nth$(nth) + " sub argument requires a number": GoTo errmes - End If - End If + IF ids(targetid).args = 1 THEN a$ = "Number required for sub": GOTO errmes + a$ = str_nth$(nth) + " sub argument requires a number": GOTO errmes + END IF + END IF 'change to "non-pointer" value - If (sourcetyp And ISREFERENCE) Then + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then GoTo errmes - End If + IF Error_Happened THEN GOTO errmes + END IF - If explicitreference = 0 Then - If targettyp And ISUDT Then + IF explicitreference = 0 THEN + IF targettyp AND ISUDT THEN nth = i - If qb64prefix_set And udtxcname(targettyp And 511) = "_MEM" Then - x$ = "'" + Mid$(RTrim$(udtxcname(targettyp And 511)), 2) + "'" - Else - x$ = "'" + RTrim$(udtxcname(targettyp And 511)) + "'" - End If - If ids(targetid).args = 1 Then a$ = "TYPE " + x$ + " required for sub": GoTo errmes - a$ = str_nth$(nth) + " sub argument requires TYPE " + x$: GoTo errmes - End If - Else - If sourcetyp And ISUDT Then a$ = "Number required for sub": GoTo errmes - End If + IF qb64prefix_set AND udtxcname(targettyp AND 511) = "_MEM" THEN + x$ = "'" + MID$(RTRIM$(udtxcname(targettyp AND 511)), 2) + "'" + ELSE + x$ = "'" + RTRIM$(udtxcname(targettyp AND 511)) + "'" + END IF + IF ids(targetid).args = 1 THEN a$ = "TYPE " + x$ + " required for sub": GOTO errmes + a$ = str_nth$(nth) + " sub argument requires TYPE " + x$: GOTO errmes + END IF + ELSE + IF sourcetyp AND ISUDT THEN a$ = "Number required for sub": GOTO errmes + END IF 'round to integer if required - If (sourcetyp And ISFLOAT) Then - If (targettyp And ISFLOAT) = 0 Then + IF (sourcetyp AND ISFLOAT) THEN + IF (targettyp AND ISFLOAT) = 0 THEN '**32 rounding fix - bits = targettyp And 511 - If bits <= 16 Then e$ = "qbr_float_to_long(" + e$ + ")" - If bits > 16 And bits < 32 Then e$ = "qbr_double_to_long(" + e$ + ")" - If bits >= 32 Then e$ = "qbr(" + e$ + ")" - End If - End If + bits = targettyp AND 511 + IF bits <= 16 THEN e$ = "qbr_float_to_long(" + e$ + ")" + IF bits > 16 AND bits < 32 THEN e$ = "qbr_double_to_long(" + e$ + ")" + IF bits >= 32 THEN e$ = "qbr(" + e$ + ")" + END IF + END IF - If (targettyp And ISPOINTER) Then 'pointer required - If (targettyp And ISSTRING) Then GoTo sete 'no changes required + IF (targettyp AND ISPOINTER) THEN 'pointer required + IF (targettyp AND ISSTRING) THEN GOTO sete 'no changes required t$ = typ2ctyp$(targettyp, "") - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes v$ = "pass" + str2$(uniquenumber) 'assume numeric type - If Mid$(sfcmemargs(targetid), i, 1) = Chr$(1) Then 'cmem required? - bytesreq = ((targettyp And 511) + 7) \ 8 - Print #defdatahandle, t$ + " *" + v$ + "=NULL;" - Print #13, "if(" + v$ + "==NULL){" - Print #13, "cmem_sp-=" + str2(bytesreq) + ";" - Print #13, v$ + "=(" + t$ + "*)(dblock+cmem_sp);" - Print #13, "if (cmem_spchr" - End If + END IF - If LTrim$(RTrim$(e$)) = "0" Then e$ = "NULL" + IF LTRIM$(RTRIM$(e$)) = "0" THEN e$ = "NULL" - End If + END IF - If i <> 1 Then subcall$ = subcall$ + "," + IF i <> 1 THEN subcall$ = subcall$ + "," subcall$ = subcall$ + e$ - Next + NEXT 'note: i=id.args+1 x$ = separgslayout2$(i) - Do While Len(x$) - x = Asc(x$) - If x Then - x2$ = Mid$(x$, 2, x) - x$ = Right$(x$, Len(x$) - x - 1) + DO WHILE LEN(x$) + x = ASC(x$) + IF x THEN + x2$ = MID$(x$, 2, x) + x$ = RIGHT$(x$, LEN(x$) - x - 1) s = 0 an = 0 - x3$ = Right$(l$, 1) - If x3$ = sp Then s = 1 - If x3$ = sp2 Then + x3$ = RIGHT$(l$, 1) + IF x3$ = sp THEN s = 1 + IF x3$ = sp2 THEN s = 2 - If alphanumeric(Asc(Right$(l$, 2))) Then an = 1 + IF alphanumeric(ASC(RIGHT$(l$, 2))) THEN an = 1 'if asc(right$(l$,2))=34 then an=1 - Else - If alphanumeric(Asc(x3$)) Then an = 1 + ELSE + IF alphanumeric(ASC(x3$)) THEN an = 1 'if asc(x3$)=34 then an=1 - End If + END IF s1 = s - If (an = 1 Or addedlayout = 1) And alphanumeric(Asc(x2$)) <> 0 Then + IF (an = 1 OR addedlayout = 1) AND alphanumeric(ASC(x2$)) <> 0 THEN s = 1 'force space x2$ = x2$ + sp2 - GoTo customlaychar2 - End If + GOTO customlaychar2 + END IF - If x2$ = "=" Then + IF x2$ = "=" THEN s = 1 x2$ = x2$ + sp - GoTo customlaychar2 - End If + GOTO customlaychar2 + END IF - If x2$ = "#" Then + IF x2$ = "#" THEN s = 1 x2$ = x2$ + sp2 - GoTo customlaychar2 - End If + GOTO customlaychar2 + END IF - If x2$ = "," Then x2$ = x2$ + sp: GoTo customlaychar2 + IF x2$ = "," THEN x2$ = x2$ + sp: GOTO customlaychar2 - If x$ = Chr$(0) Then 'substitution - If x2$ = "STEP" Then x2$ = SCase$("Step") + sp2: GoTo customlaychar2 - x2$ = x2$ + sp: GoTo customlaychar2 - End If + IF x$ = CHR$(0) THEN 'substitution + IF x2$ = "STEP" THEN x2$ = SCase$("Step") + sp2: GOTO customlaychar2 + x2$ = x2$ + sp: GOTO customlaychar2 + END IF 'default solution sp2+?+sp2 x2$ = x2$ + sp2 customlaychar2: - If s = 0 Then s = 2 - If s <> s1 Then - If s1 Then l$ = Left$(l$, Len(l$) - 1) - If s = 1 Then l$ = l$ + sp - If s = 2 Then l$ = l$ + sp2 - End If + IF s = 0 THEN s = 2 + IF s <> s1 THEN + IF s1 THEN l$ = LEFT$(l$, LEN(l$) - 1) + IF s = 1 THEN l$ = l$ + sp + IF s = 2 THEN l$ = l$ + sp2 + END IF l$ = l$ + x2$ - Else + ELSE addlayout = 0 - x$ = Right$(x$, Len(x$) - 1) - End If + x$ = RIGHT$(x$, LEN(x$) - 1) + END IF addedlayout = 0 - Loop + LOOP - If passedneeded Then + IF passedneeded THEN subcall$ = subcall$ + "," + str2$(passed&) - End If + END IF subcall$ = subcall$ + ");" - Print #12, subcall$ + PRINT #12, subcall$ subcall$ = "" - If stringprocessinghappened Then Print #12, cleanupstringprocessingcall$ + "0);" + IF stringprocessinghappened THEN PRINT #12, cleanupstringprocessingcall$ + "0);" layoutdone = 1 - x$ = Right$(l$, 1): If x$ = sp Or x$ = sp2 Then l$ = Left$(l$, Len(l$) - 1) - If usecall = 1 Then l$ = l$ + sp2 + ")" - If Debug Then Print #9, "SUB layout:[" + l$ + "]" - If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$ - GoTo finishedline + x$ = RIGHT$(l$, 1): IF x$ = sp OR x$ = sp2 THEN l$ = LEFT$(l$, LEN(l$) - 1) + IF usecall = 1 THEN l$ = l$ + sp2 + ")" + IF Debug THEN PRINT #9, "SUB layout:[" + l$ + "]" + IF LEN(layout$) = 0 THEN layout$ = l$ ELSE layout$ = layout$ + sp + l$ + GOTO finishedline - End If + END IF - If try = 2 Then - findidsecondarg = "": If n >= 2 Then findidsecondarg = getelement$(a$, 2) + IF try = 2 THEN + findidsecondarg = "": IF n >= 2 THEN findidsecondarg = getelement$(a$, 2) findanotherid = 1 try = findid(firstelement$) - If Error_Happened Then GoTo errmes - Else + IF Error_Happened THEN GOTO errmes + ELSE try = 0 - End If - Loop + END IF + LOOP - End If + END IF notsubcall: - If n >= 1 Then - If firstelement$ = "LET" Then - If n = 1 Then a$ = "Syntax error": GoTo errmes - ca$ = Right$(ca$, Len(ca$) - 4) + IF n >= 1 THEN + IF firstelement$ = "LET" THEN + IF n = 1 THEN a$ = "Syntax error": GOTO errmes + ca$ = RIGHT$(ca$, LEN(ca$) - 4) n = n - 1 l$ = SCase$("Let") - If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ 'note: layoutdone=1 will be set later - GoTo letused - End If - End If + GOTO letused + END IF + END IF 'LET ???=??? - If n >= 3 Then - If InStr(a$, sp + "=" + sp) Then + IF n >= 3 THEN + IF INSTR(a$, sp + "=" + sp) THEN letused: assign ca$, n - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes layoutdone = 1 - If Len(layout$) = 0 Then layout$ = tlayout$ Else layout$ = layout$ + sp + tlayout$ - GoTo finishedline - End If - End If '>=3 - If Right$(a$, 2) = sp + "=" Then a$ = "Expected ... = expression": GoTo errmes + IF LEN(layout$) = 0 THEN layout$ = tlayout$ ELSE layout$ = layout$ + sp + tlayout$ + GOTO finishedline + END IF + END IF '>=3 + IF RIGHT$(a$, 2) = sp + "=" THEN a$ = "Expected ... = expression": GOTO errmes 'Syntax error - a$ = "Syntax error": GoTo errmes + a$ = "Syntax error": GOTO errmes finishedline: THENGOTO = 0 finishedline2: - If arrayprocessinghappened = 1 Then arrayprocessinghappened = 0 + IF arrayprocessinghappened = 1 THEN arrayprocessinghappened = 0 inclinenump$ = "" - If inclinenumber(inclevel) Then + IF inclinenumber(inclevel) THEN inclinenump$ = "," + str2$(inclinenumber(inclevel)) thisincname$ = getfilepath$(incname$(inclevel)) - thisincname$ = Mid$(incname$(inclevel), Len(thisincname$) + 1) - inclinenump$ = inclinenump$ + "," + Chr$(34) + thisincname$ + Chr$(34) - End If - If NoChecks = 0 Then - If dynscope Then + thisincname$ = MID$(incname$(inclevel), LEN(thisincname$) + 1) + inclinenump$ = inclinenump$ + "," + CHR$(34) + thisincname$ + CHR$(34) + END IF + IF NoChecks = 0 THEN + IF dynscope THEN dynscope = 0 - Print #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");if(r)goto S_" + str2$(statementn) + ";}" - Else - Print #12, "if(!qbevent)break;evnt(" + str2$(linenumber) + inclinenump$ + ");}while(r);" - End If - End If + PRINT #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");if(r)goto S_" + str2$(statementn) + ";}" + ELSE + PRINT #12, "if(!qbevent)break;evnt(" + str2$(linenumber) + inclinenump$ + ");}while(r);" + END IF + END IF finishednonexec: firstLine = 0 - If layoutdone = 0 Then layoutok = 0 'invalidate layout if not handled + IF layoutdone = 0 THEN layoutok = 0 'invalidate layout if not handled - If continuelinefrom = 0 Then 'note: manager #2 requires this condition + IF continuelinefrom = 0 THEN 'note: manager #2 requires this condition 'Include Manager #2 '*** - If Len(addmetainclude$) Then + IF LEN(addmetainclude$) THEN - If inclevel = 0 Then + IF inclevel = 0 THEN 'backup line formatting layoutcomment_backup$ = layoutcomment$ layoutok_backup = layoutok layout_backup$ = layout$ - End If + END IF a$ = addmetainclude$: addmetainclude$ = "" 'read/clear message - If inclevel = 100 Then a$ = "Too many indwelling INCLUDE files": GoTo errmes + IF inclevel = 100 THEN a$ = "Too many indwelling INCLUDE files": GOTO errmes '1. Verify file exists (location is either (a)relative to source file or (b)absolute) fh = 99 + inclevel + 1 firstTryMethod = 1 - For try = firstTryMethod To 2 'if including file from root, do not attempt including from relative location - If try = 1 Then - If inclevel = 0 Then - If idemode Then p$ = idepath$ + pathsep$ Else p$ = getfilepath$(sourcefile$) - Else + FOR try = firstTryMethod TO 2 'if including file from root, do not attempt including from relative location + IF try = 1 THEN + IF inclevel = 0 THEN + IF idemode THEN p$ = idepath$ + pathsep$ ELSE p$ = getfilepath$(sourcefile$) + ELSE p$ = getfilepath$(incname(inclevel)) - End If + END IF f$ = p$ + a$ - End If - If try = 2 Then f$ = a$ - If _FileExists(f$) Then + END IF + IF try = 2 THEN f$ = a$ + IF _FILEEXISTS(f$) THEN qberrorhappened = -2 '*** - Open f$ For Binary As #fh + OPEN f$ FOR BINARY AS #fh qberrorhappened2: '*** - If qberrorhappened = -2 Then Exit For '*** - End If + IF qberrorhappened = -2 THEN EXIT FOR '*** + END IF qberrorhappened = 0 - Next - If qberrorhappened <> -2 Then qberrorhappened = 0: a$ = "File " + a$ + " not found": GoTo errmes + NEXT + IF qberrorhappened <> -2 THEN qberrorhappened = 0: a$ = "File " + a$ + " not found": GOTO errmes inclevel = inclevel + 1: incname$(inclevel) = f$: inclinenumber(inclevel) = 0 - End If 'fall through to next section... + END IF 'fall through to next section... '-------------------- - Do While inclevel + DO WHILE inclevel fh = 99 + inclevel '2. Feed next line - If EOF(fh) = 0 Then - Line Input #fh, x$ + IF EOF(fh) = 0 THEN + LINE INPUT #fh, x$ a3$ = x$ continuelinefrom = 0 inclinenumber(inclevel) = inclinenumber(inclevel) + 1 'create extended error string 'incerror$' errorLineInInclude = inclinenumber(inclevel) e$ = " in line " + str2(inclinenumber(inclevel)) + " of " + incname$(inclevel) + " included" - If inclevel > 1 Then + IF inclevel > 1 THEN e$ = e$ + " (through " - For x = 1 To inclevel - 1 Step 1 + FOR x = 1 TO inclevel - 1 STEP 1 e$ = e$ + incname$(x) - If x < inclevel - 1 Then 'a sep is req - If x = inclevel - 2 Then + IF x < inclevel - 1 THEN 'a sep is req + IF x = inclevel - 2 THEN e$ = e$ + " then " - Else + ELSE e$ = e$ + ", " - End If - End If - Next + END IF + END IF + NEXT e$ = e$ + ")" - End If + END IF incerror$ = e$ linenumber = linenumber - 1 'lower official linenumber to counter later increment - If idemode Then sendc$ = Chr$(10) + a3$: GoTo sendcommand 'passback - GoTo includeline - End If + IF idemode THEN sendc$ = CHR$(10) + a3$: GOTO sendcommand 'passback + GOTO includeline + END IF '3. Close & return control - Close #fh + CLOSE #fh inclevel = inclevel - 1 - If inclevel = 0 Then + IF inclevel = 0 THEN 'restore line formatting layoutok = layoutok_backup layout$ = layout_backup$ layoutcomment$ = layoutcomment_backup$ - End If - Loop 'fall through to next section... + END IF + LOOP 'fall through to next section... '(end manager) - End If 'continuelinefrom=0 + END IF 'continuelinefrom=0 - If Debug Then - Print #9, "[layout check]" - Print #9, "[" + layoutoriginal$ + "]" - Print #9, "[" + layout$ + "]" - Print #9, layoutok - Print #9, "[end layout check]" - End If + IF Debug THEN + PRINT #9, "[layout check]" + PRINT #9, "[" + layoutoriginal$ + "]" + PRINT #9, "[" + layout$ + "]" + PRINT #9, layoutok + PRINT #9, "[end layout check]" + END IF - If idemode Then - If continuelinefrom <> 0 Then GoTo ide4 'continue processing other commands on line + IF idemode THEN + IF continuelinefrom <> 0 THEN GOTO ide4 'continue processing other commands on line - If Len(layoutcomment$) Then - If Len(layout$) Then layout$ = layout$ + sp + layoutcomment$ Else layout$ = layoutcomment$ - End If + IF LEN(layoutcomment$) THEN + IF LEN(layout$) THEN layout$ = layout$ + sp + layoutcomment$ ELSE layout$ = layoutcomment$ + END IF - If layoutok = 0 Then + IF layoutok = 0 THEN layout$ = layoutoriginal$ - Else + ELSE 'reverse '046' changes present in autolayout 'replace fix046$ with . - i = InStr(layout$, fix046$) - Do While i - layout$ = Left$(layout$, i - 1) + "." + Right$(layout$, Len(layout$) - (i + Len(fix046$) - 1)) - i = InStr(layout$, fix046$) - Loop + i = INSTR(layout$, fix046$) + DO WHILE i + layout$ = LEFT$(layout$, i - 1) + "." + RIGHT$(layout$, LEN(layout$) - (i + LEN(fix046$) - 1)) + i = INSTR(layout$, fix046$) + LOOP - End If - x = lhscontrollevel: If controllevel < lhscontrollevel Then x = controllevel - If definingtype = 2 Then x = x + 1 - If definingtype > 0 Then definingtype = 2 - If declaringlibrary = 2 Then x = x + 1 - If declaringlibrary > 0 Then declaringlibrary = 2 - layout$ = Space$(x) + layout$ - If linecontinuation Then layout$ = "" + END IF + x = lhscontrollevel: IF controllevel < lhscontrollevel THEN x = controllevel + IF definingtype = 2 THEN x = x + 1 + IF definingtype > 0 THEN definingtype = 2 + IF declaringlibrary = 2 THEN x = x + 1 + IF declaringlibrary > 0 THEN declaringlibrary = 2 + layout$ = SPACE$(x) + layout$ + IF linecontinuation THEN layout$ = "" - GoTo ideret4 'return control to IDE - End If + GOTO ideret4 'return control to IDE + END IF 'layout is not currently used by the compiler (as appose to the IDE), if it was it would be used here skipide4: -Loop +LOOP 'add final line -If lastLineReturn = 0 Then +IF lastLineReturn = 0 THEN lastLineReturn = 1 lastLine = 1 wholeline$ = "" - GoTo mainpassLastLine -End If + GOTO mainpassLastLine +END IF ide5: linenumber = 0 -If closedmain = 0 Then closemain +IF closedmain = 0 THEN closemain -If definingtype Then linenumber = definingtypeerror: a$ = "TYPE without END TYPE": GoTo errmes +IF definingtype THEN linenumber = definingtypeerror: a$ = "TYPE without END TYPE": GOTO errmes 'check for open controls (copy #1) -If controllevel Then +IF controllevel THEN a$ = "Unidentified open control block" - Select Case controltype(controllevel) - Case 1: a$ = "IF without END IF" - Case 2: a$ = "FOR without NEXT" - Case 3, 4: a$ = "DO without LOOP" - Case 5: a$ = "WHILE without WEND" - Case 6: a$ = "$IF without $END IF" - Case 10 TO 19: a$ = "SELECT CASE without END SELECT" - Case 32: a$ = "SUB/FUNCTION without END SUB/FUNCTION" - End Select + SELECT CASE controltype(controllevel) + CASE 1: a$ = "IF without END IF" + CASE 2: a$ = "FOR without NEXT" + CASE 3, 4: a$ = "DO without LOOP" + CASE 5: a$ = "WHILE without WEND" + CASE 6: a$ = "$IF without $END IF" + CASE 10 TO 19: a$ = "SELECT CASE without END SELECT" + CASE 32: a$ = "SUB/FUNCTION without END SUB/FUNCTION" + END SELECT linenumber = controlref(controllevel) - GoTo errmes -End If + GOTO errmes +END IF -If ideindentsubs = 0 Then - If Len(subfunc) Then a$ = "SUB/FUNCTION without END SUB/FUNCTION": GoTo errmes -End If +IF ideindentsubs = 0 THEN + IF LEN(subfunc) THEN a$ = "SUB/FUNCTION without END SUB/FUNCTION": GOTO errmes +END IF 'close the error handler (cannot be put in 'closemain' because subs/functions can also add error jumps to this file) -Print #14, "exit(99);" 'in theory this line should never be run! -Print #14, "}" 'close error jump handler +PRINT #14, "exit(99);" 'in theory this line should never be run! +PRINT #14, "}" 'close error jump handler 'create CLEAR method "CLEAR" -Close #12 'close code handle -Open tmpdir$ + "clear.txt" For Output As #12 'direct code to clear.txt +CLOSE #12 'close code handle +OPEN tmpdir$ + "clear.txt" FOR OUTPUT AS #12 'direct code to clear.txt -For i = 1 To idn +FOR i = 1 TO idn - If ids(i).staticscope Then 'static scope? - subfunc = RTrim$(ids(i).insubfunc) 'set static scope - GoTo clearstaticscope - End If + IF ids(i).staticscope THEN 'static scope? + subfunc = RTRIM$(ids(i).insubfunc) 'set static scope + GOTO clearstaticscope + END IF - a = Asc(ids(i).insubfunc) - If a = 0 Or a = 32 Then 'global scope? + a = ASC(ids(i).insubfunc) + IF a = 0 OR a = 32 THEN 'global scope? subfunc = "" 'set global scope clearstaticscope: - If ids(i).arraytype Then 'an array + IF ids(i).arraytype THEN 'an array getid i - If Error_Happened Then GoTo errmes - If id.arrayelements = -1 Then GoTo clearerasereturned 'cannot erase non-existant array - clearerasereturn = 1: GoTo clearerase - End If 'array + IF Error_Happened THEN GOTO errmes + IF id.arrayelements = -1 THEN GOTO clearerasereturned 'cannot erase non-existant array + clearerasereturn = 1: GOTO clearerase + END IF 'array - If ids(i).t Then 'non-array variable + IF ids(i).t THEN 'non-array variable getid i - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes bytes$ = variablesize$(-1) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes 'create a reference typ = id.t + ISREFERENCE - If typ And ISUDT Then - e$ = str2(i) + sp3 + str2(typ And 511) + sp3 + "0" + sp3 + "0" - Else + IF typ AND ISUDT THEN + e$ = str2(i) + sp3 + str2(typ AND 511) + sp3 + "0" + sp3 + "0" + ELSE e$ = str2(i) - End If + END IF e$ = refer$(e$, typ, 1) - If Error_Happened Then GoTo errmes - If typ And ISSTRING Then - If typ And ISFIXEDLENGTH Then - Print #12, "memset((void*)(" + e$ + "->chr),0," + bytes$ + ");" - GoTo cleared - Else - Print #12, e$ + "->len=0;" - GoTo cleared - End If - End If - If typ And ISUDT Then - Print #12, "memset((void*)" + e$ + ",0," + bytes$ + ");" - Else - Print #12, "*" + e$ + "=0;" - End If - GoTo cleared - End If 'non-array variable + IF Error_Happened THEN GOTO errmes + IF typ AND ISSTRING THEN + IF typ AND ISFIXEDLENGTH THEN + PRINT #12, "memset((void*)(" + e$ + "->chr),0," + bytes$ + ");" + GOTO cleared + ELSE + PRINT #12, e$ + "->len=0;" + GOTO cleared + END IF + END IF + IF typ AND ISUDT THEN + PRINT #12, "memset((void*)" + e$ + ",0," + bytes$ + ");" + ELSE + PRINT #12, "*" + e$ + "=0;" + END IF + GOTO cleared + END IF 'non-array variable - End If 'scope + END IF 'scope cleared: clearerasereturned: -Next -Close #12 +NEXT +CLOSE #12 -If Debug Then - Print #9, "finished making program!" - Print #9, "recompile="; recompile -End If +IF Debug THEN + PRINT #9, "finished making program!" + PRINT #9, "recompile="; recompile +END IF 'Set cmem flags for subs/functions requiring data passed in cmem -For i = 1 To idn - If cmemlist(i) Then 'must be in cmem +FOR i = 1 TO idn + IF cmemlist(i) THEN 'must be in cmem getid i - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes - If Debug Then Print #9, "recompiling cmem sf! checking:"; RTrim$(id.n) + IF Debug THEN PRINT #9, "recompiling cmem sf! checking:"; RTRIM$(id.n) - If id.sfid Then 'it is an argument of a sub/function + IF id.sfid THEN 'it is an argument of a sub/function - If Debug Then Print #9, "recompiling cmem sf! It's a sub/func arg!" + IF Debug THEN PRINT #9, "recompiling cmem sf! It's a sub/func arg!" i2 = id.sfid x = id.sfarg - If Debug Then Print #9, "recompiling cmem sf! values:"; i2; x + IF Debug THEN PRINT #9, "recompiling cmem sf! values:"; i2; x 'check if cmem flag is set, if not then set it & force recompile - If Mid$(sfcmemargs(i2), x, 1) <> Chr$(1) Then - Mid$(sfcmemargs(i2), x, 1) = Chr$(1) + IF MID$(sfcmemargs(i2), x, 1) <> CHR$(1) THEN + MID$(sfcmemargs(i2), x, 1) = CHR$(1) - If Debug Then Print #9, "recompiling cmem sf! setting:"; i2; x + IF Debug THEN PRINT #9, "recompiling cmem sf! setting:"; i2; x recompile = 1 - End If - End If - End If -Next i + END IF + END IF + END IF +NEXT i unresolved = 0 -For i = 1 To idn +FOR i = 1 TO idn getid i - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes - If Debug Then Print #9, "checking id named:"; id.n + IF Debug THEN PRINT #9, "checking id named:"; id.n - If id.subfunc Then - For i2 = 1 To id.args - t = CVL(Mid$(id.arg, i2 * 4 - 3, 4)) - If t > 0 Then - If (t And ISPOINTER) Then - If (t And ISARRAY) Then + IF id.subfunc THEN + FOR i2 = 1 TO id.args + t = CVL(MID$(id.arg, i2 * 4 - 3, 4)) + IF t > 0 THEN + IF (t AND ISPOINTER) THEN + IF (t AND ISARRAY) THEN - If Debug Then Print #9, "checking argument "; i2; " of "; id.args + IF Debug THEN PRINT #9, "checking argument "; i2; " of "; id.args - nele = Asc(Mid$(id.nele, i2, 1)) - nelereq = Asc(Mid$(id.nelereq, i2, 1)) + nele = ASC(MID$(id.nele, i2, 1)) + nelereq = ASC(MID$(id.nelereq, i2, 1)) - If Debug Then Print #9, "nele="; nele - If Debug Then Print #9, "nelereq="; nelereq + IF Debug THEN PRINT #9, "nele="; nele + IF Debug THEN PRINT #9, "nelereq="; nelereq - If nele <> nelereq Then + IF nele <> nelereq THEN - If Debug Then Print #9, "mismatch detected!" + IF Debug THEN PRINT #9, "mismatch detected!" unresolved = unresolved + 1 sflistn = sflistn + 1 sfidlist(sflistn) = i sfarglist(sflistn) = i2 sfelelist(sflistn) = nelereq '0 means still unknown - End If - End If - End If - End If - Next - End If -Next + END IF + END IF + END IF + END IF + NEXT + END IF +NEXT 'is recompilation required to resolve this? -If unresolved > 0 Then - If lastunresolved = -1 Then +IF unresolved > 0 THEN + IF lastunresolved = -1 THEN 'first pass recompile = 1 - If Debug Then - Print #9, "recompiling to resolve array elements (first time)" - Print #9, "sflistn="; sflistn - Print #9, "oldsflistn="; oldsflistn - End If - Else + IF Debug THEN + PRINT #9, "recompiling to resolve array elements (first time)" + PRINT #9, "sflistn="; sflistn + PRINT #9, "oldsflistn="; oldsflistn + END IF + ELSE 'not first pass - If unresolved < lastunresolved Then + IF unresolved < lastunresolved THEN recompile = 1 - If Debug Then - Print #9, "recompiling to resolve array elements (not first time)" - Print #9, "sflistn="; sflistn - Print #9, "oldsflistn="; oldsflistn - End If - End If - End If -End If 'unresolved + IF Debug THEN + PRINT #9, "recompiling to resolve array elements (not first time)" + PRINT #9, "sflistn="; sflistn + PRINT #9, "oldsflistn="; oldsflistn + END IF + END IF + END IF +END IF 'unresolved lastunresolved = unresolved 'IDEA! @@ -11239,101 +11239,101 @@ lastunresolved = unresolved 'END IF 'END IF -If Debug Then Print #9, "Beginning COMMON array list check..." +IF Debug THEN PRINT #9, "Beginning COMMON array list check..." xi = 1 -For x = 1 To commonarraylistn +FOR x = 1 TO commonarraylistn varname$ = getelement$(commonarraylist, xi): xi = xi + 1 typ$ = getelement$(commonarraylist, xi): xi = xi + 1 - dimmethod2 = Val(getelement$(commonarraylist, xi)): xi = xi + 1 - dimshared2 = Val(getelement$(commonarraylist, xi)): xi = xi + 1 + dimmethod2 = VAL(getelement$(commonarraylist, xi)): xi = xi + 1 + dimshared2 = VAL(getelement$(commonarraylist, xi)): xi = xi + 1 'find the array ID (try method) t = typname2typ(typ$) - If Error_Happened Then GoTo errmes - If (t And ISUDT) = 0 Then varname$ = varname$ + type2symbol$(typ$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes + IF (t AND ISUDT) = 0 THEN varname$ = varname$ + type2symbol$(typ$) + IF Error_Happened THEN GOTO errmes - If Debug Then Print #9, "Checking for array '" + varname$ + "'..." + IF Debug THEN PRINT #9, "Checking for array '" + varname$ + "'..." try = findid(varname$) - If Error_Happened Then GoTo errmes - Do While try - If id.arraytype Then GoTo foundcommonarray2 - If try = 2 Then findanotherid = 1: try = findid(varname$) Else try = 0 - If Error_Happened Then GoTo errmes - Loop + IF Error_Happened THEN GOTO errmes + DO WHILE try + IF id.arraytype THEN GOTO foundcommonarray2 + IF try = 2 THEN findanotherid = 1: try = findid(varname$) ELSE try = 0 + IF Error_Happened THEN GOTO errmes + LOOP foundcommonarray2: - If Debug Then Print #9, "Found array '" + varname$ + "!" + IF Debug THEN PRINT #9, "Found array '" + varname$ + "!" - If id.arrayelements = -1 Then - If arrayelementslist(currentid) <> 0 Then recompile = 1 - If Debug Then Print #9, "Recompiling to resolve elements of:" + varname$ - End If -Next -If Debug Then Print #9, "Finished COMMON array list check!" + IF id.arrayelements = -1 THEN + IF arrayelementslist(currentid) <> 0 THEN recompile = 1 + IF Debug THEN PRINT #9, "Recompiling to resolve elements of:" + varname$ + END IF +NEXT +IF Debug THEN PRINT #9, "Finished COMMON array list check!" -If recompile Then +IF recompile THEN do_recompile: - If Debug Then Print #9, "Recompile required!" + IF Debug THEN PRINT #9, "Recompile required!" recompile = 0 - If idemode Then iderecompile = 1 - For closeall = 1 To 255: Close closeall: Next - Open tmpdir$ + "temp.bin" For Output Lock Write As #26 'relock - GoTo recompile -End If + IF idemode THEN iderecompile = 1 + FOR closeall = 1 TO 255: CLOSE closeall: NEXT + OPEN tmpdir$ + "temp.bin" FOR OUTPUT LOCK WRITE AS #26 'relock + GOTO recompile +END IF -If Debug Then Print #9, "Beginning label check..." -For r = 1 To nLabels +IF Debug THEN PRINT #9, "Beginning label check..." +FOR r = 1 TO nLabels - If Labels(r).Scope_Restriction Then - a$ = RTrim$(Labels(r).cn) + IF Labels(r).Scope_Restriction THEN + a$ = RTRIM$(Labels(r).cn) ignore = validlabel(a$) v = HashFind(a$, HASHFLAG_LABEL, ignore, r2) addlabchk7: - If v Then - If Labels(r2).Scope = Labels(r).Scope_Restriction Then - linenumber = Labels(r).Error_Line: a$ = "Common label within a SUB/FUNCTION": GoTo errmes - End If - If v = 2 Then v = HashFindCont(ignore, r2): GoTo addlabchk7 - End If 'v - End If 'restriction + IF v THEN + IF Labels(r2).Scope = Labels(r).Scope_Restriction THEN + linenumber = Labels(r).Error_Line: a$ = "Common label within a SUB/FUNCTION": GOTO errmes + END IF + IF v = 2 THEN v = HashFindCont(ignore, r2): GOTO addlabchk7 + END IF 'v + END IF 'restriction 'check for undefined labels - If Labels(r).State = 0 Then + IF Labels(r).State = 0 THEN - If InStr(PossibleSubNameLabels$, sp + UCase$(RTrim$(Labels(r).cn)) + sp) Then - If InStr(SubNameLabels$, sp + UCase$(RTrim$(Labels(r).cn)) + sp) = 0 Then 'not already added - SubNameLabels$ = SubNameLabels$ + UCase$(RTrim$(Labels(r).cn)) + sp - If Debug Then Print #9, "Recompiling to resolve label:"; RTrim$(Labels(r).cn) - GoTo do_recompile - End If - End If + IF INSTR(PossibleSubNameLabels$, sp + UCASE$(RTRIM$(Labels(r).cn)) + sp) THEN + IF INSTR(SubNameLabels$, sp + UCASE$(RTRIM$(Labels(r).cn)) + sp) = 0 THEN 'not already added + SubNameLabels$ = SubNameLabels$ + UCASE$(RTRIM$(Labels(r).cn)) + sp + IF Debug THEN PRINT #9, "Recompiling to resolve label:"; RTRIM$(Labels(r).cn) + GOTO do_recompile + END IF + END IF - linenumber = Labels(r).Error_Line: a$ = "Label '" + RTrim$(Labels(r).cn) + "' not defined": GoTo errmes - End If + linenumber = Labels(r).Error_Line: a$ = "Label '" + RTRIM$(Labels(r).cn) + "' not defined": GOTO errmes + END IF - If Labels(r).Data_Referenced Then + IF Labels(r).Data_Referenced THEN 'check for ambiguous RESTORE reference x = 0 - a$ = RTrim$(Labels(r).cn) + a$ = RTRIM$(Labels(r).cn) ignore = validlabel(a$) v = HashFind(a$, HASHFLAG_LABEL, ignore, r2) addlabchk4: - If v Then + IF v THEN x = x + 1 - If v = 2 Then v = HashFindCont(ignore, r2): GoTo addlabchk4 - End If 'v - If x <> 1 Then linenumber = Labels(r).Error_Line: a$ = "Ambiguous DATA label": GoTo errmes + IF v = 2 THEN v = HashFindCont(ignore, r2): GOTO addlabchk4 + END IF 'v + IF x <> 1 THEN linenumber = Labels(r).Error_Line: a$ = "Ambiguous DATA label": GOTO errmes 'add global data offset variable - Print #18, "ptrszint data_at_LABEL_" + a$ + "=" + str2(Labels(r).Data_Offset) + ";" + PRINT #18, "ptrszint data_at_LABEL_" + a$ + "=" + str2(Labels(r).Data_Offset) + ";" - End If 'data referenced + END IF 'data referenced -Next -If Debug Then Print #9, "Finished check!" +NEXT +IF Debug THEN PRINT #9, "Finished check!" 'if targettyp=-4 or targettyp=-5 then '? -> byte_element(offset,element size in bytes) @@ -11342,136 +11342,136 @@ If Debug Then Print #9, "Finished check!" 'create include files for COMMON arrays -Close #12 +CLOSE #12 'return to 'main' subfunc$ = "" defdatahandle = 18 -Close #13: Open tmpdir$ + "maindata.txt" For Append As #13 -Close #19: Open tmpdir$ + "mainfree.txt" For Append As #19 +CLOSE #13: OPEN tmpdir$ + "maindata.txt" FOR APPEND AS #13 +CLOSE #19: OPEN tmpdir$ + "mainfree.txt" FOR APPEND AS #19 -If Console Then - Print #18, "int32 console=1;" -Else - Print #18, "int32 console=0;" -End If +IF Console THEN + PRINT #18, "int32 console=1;" +ELSE + PRINT #18, "int32 console=0;" +END IF -If ScreenHide Then - Print #18, "int32 screen_hide_startup=1;" -Else - Print #18, "int32 screen_hide_startup=0;" -End If +IF ScreenHide THEN + PRINT #18, "int32 screen_hide_startup=1;" +ELSE + PRINT #18, "int32 screen_hide_startup=0;" +END IF -If Asserts Then - Print #18, "int32 asserts=1;" -Else - Print #18, "int32 asserts=0;" -End If +IF Asserts THEN + PRINT #18, "int32 asserts=1;" +ELSE + PRINT #18, "int32 asserts=0;" +END IF -fh = FreeFile -Open tmpdir$ + "dyninfo.txt" For Append As #fh -If Resize Then - Print #fh, "ScreenResize=1;" -End If -If Resize_Scale Then - Print #fh, "ScreenResizeScale=" + str2(Resize_Scale) + ";" -End If -Close #fh +fh = FREEFILE +OPEN tmpdir$ + "dyninfo.txt" FOR APPEND AS #fh +IF Resize THEN + PRINT #fh, "ScreenResize=1;" +END IF +IF Resize_Scale THEN + PRINT #fh, "ScreenResizeScale=" + str2(Resize_Scale) + ";" +END IF +CLOSE #fh 'DATA_finalize -Print #18, "ptrszint data_size=" + str2(DataOffset) + ";" -If DataOffset = 0 Then +PRINT #18, "ptrszint data_size=" + str2(DataOffset) + ";" +IF DataOffset = 0 THEN - Print #18, "uint8 *data=(uint8*)calloc(1,1);" + PRINT #18, "uint8 *data=(uint8*)calloc(1,1);" -Else +ELSE - If inline_DATA = 0 Then - If os$ = "WIN" Then - If OS_BITS = 32 Then - x$ = Chr$(0): Put #16, , x$ - Print #18, "extern " + Chr$(34) + "C" + Chr$(34) + "{" - Print #18, "extern char *binary_____temp" + tempfolderindexstr2$ + "__data_bin_start;" - Print #18, "}" - Print #18, "uint8 *data=(uint8*)&binary_____temp" + tempfolderindexstr2$ + "__data_bin_start;" - Else - x$ = Chr$(0): Put #16, , x$ - Print #18, "extern " + Chr$(34) + "C" + Chr$(34) + "{" - Print #18, "extern char *_binary_____temp" + tempfolderindexstr2$ + "__data_bin_start;" - Print #18, "}" - Print #18, "uint8 *data=(uint8*)&_binary_____temp" + tempfolderindexstr2$ + "__data_bin_start;" - End If - End If - If os$ = "LNX" Then - x$ = Chr$(0): Put #16, , x$ - Print #18, "extern " + Chr$(34) + "C" + Chr$(34) + "{" - Print #18, "extern char *_binary____temp" + tempfolderindexstr2$ + "_data_bin_start;" - Print #18, "}" - Print #18, "uint8 *data=(uint8*)&_binary____temp" + tempfolderindexstr2$ + "_data_bin_start;" - End If - Else + IF inline_DATA = 0 THEN + IF os$ = "WIN" THEN + IF OS_BITS = 32 THEN + x$ = CHR$(0): PUT #16, , x$ + PRINT #18, "extern " + CHR$(34) + "C" + CHR$(34) + "{" + PRINT #18, "extern char *binary_____temp" + tempfolderindexstr2$ + "__data_bin_start;" + PRINT #18, "}" + PRINT #18, "uint8 *data=(uint8*)&binary_____temp" + tempfolderindexstr2$ + "__data_bin_start;" + ELSE + x$ = CHR$(0): PUT #16, , x$ + PRINT #18, "extern " + CHR$(34) + "C" + CHR$(34) + "{" + PRINT #18, "extern char *_binary_____temp" + tempfolderindexstr2$ + "__data_bin_start;" + PRINT #18, "}" + PRINT #18, "uint8 *data=(uint8*)&_binary_____temp" + tempfolderindexstr2$ + "__data_bin_start;" + END IF + END IF + IF os$ = "LNX" THEN + x$ = CHR$(0): PUT #16, , x$ + PRINT #18, "extern " + CHR$(34) + "C" + CHR$(34) + "{" + PRINT #18, "extern char *_binary____temp" + tempfolderindexstr2$ + "_data_bin_start;" + PRINT #18, "}" + PRINT #18, "uint8 *data=(uint8*)&_binary____temp" + tempfolderindexstr2$ + "_data_bin_start;" + END IF + ELSE 'inline data - Close #16 - ff = FreeFile - Open tmpdir$ + "data.bin" For Binary As #ff - x$ = Space$(LOF(ff)) - Get #ff, , x$ - Close #ff + CLOSE #16 + ff = FREEFILE + OPEN tmpdir$ + "data.bin" FOR BINARY AS #ff + x$ = SPACE$(LOF(ff)) + GET #ff, , x$ + CLOSE #ff x2$ = "uint8 inline_data[]={" - For i = 1 To Len(x$) - x2$ = x2$ + inlinedatastr$(Asc(x$, i)) - Next + FOR i = 1 TO LEN(x$) + x2$ = x2$ + inlinedatastr$(ASC(x$, i)) + NEXT x2$ = x2$ + "0};" - Print #18, x2$ - Print #18, "uint8 *data=&inline_data[0];" + PRINT #18, x2$ + PRINT #18, "uint8 *data=&inline_data[0];" x$ = "": x2$ = "" - End If -End If + END IF +END IF -If Debug Then Print #9, "Beginning generation of code for saving/sharing common array data..." +IF Debug THEN PRINT #9, "Beginning generation of code for saving/sharing common array data..." use_global_byte_elements = 1 ncommontmp = 0 xi = 1 -For x = 1 To commonarraylistn +FOR x = 1 TO commonarraylistn varname$ = getelement$(commonarraylist, xi): xi = xi + 1 typ$ = getelement$(commonarraylist, xi): xi = xi + 1 - dimmethod2 = Val(getelement$(commonarraylist, xi)): xi = xi + 1 - dimshared2 = Val(getelement$(commonarraylist, xi)): xi = xi + 1 + dimmethod2 = VAL(getelement$(commonarraylist, xi)): xi = xi + 1 + dimshared2 = VAL(getelement$(commonarraylist, xi)): xi = xi + 1 'find the array ID (try method) purevarname$ = varname$ t = typname2typ(typ$) - If Error_Happened Then GoTo errmes - If (t And ISUDT) = 0 Then varname$ = varname$ + type2symbol$(typ$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes + IF (t AND ISUDT) = 0 THEN varname$ = varname$ + type2symbol$(typ$) + IF Error_Happened THEN GOTO errmes try = findid(varname$) - If Error_Happened Then GoTo errmes - Do While try - If id.arraytype Then GoTo foundcommonarray - If try = 2 Then findanotherid = 1: try = findid(varname$) Else try = 0 - If Error_Happened Then GoTo errmes - Loop - a$ = "COMMON array unlocatable": GoTo errmes 'should never happen + IF Error_Happened THEN GOTO errmes + DO WHILE try + IF id.arraytype THEN GOTO foundcommonarray + IF try = 2 THEN findanotherid = 1: try = findid(varname$) ELSE try = 0 + IF Error_Happened THEN GOTO errmes + LOOP + a$ = "COMMON array unlocatable": GOTO errmes 'should never happen foundcommonarray: - If Debug Then Print #9, "Found common array '" + varname$ + "'!" + IF Debug THEN PRINT #9, "Found common array '" + varname$ + "'!" i = currentid arraytype = id.arraytype arrayelements = id.arrayelements - e$ = RTrim$(id.n) - If (t And ISUDT) = 0 Then e$ = e$ + typevalue2symbol$(t) - If Error_Happened Then GoTo errmes + e$ = RTRIM$(id.n) + IF (t AND ISUDT) = 0 THEN e$ = e$ + typevalue2symbol$(t) + IF Error_Happened THEN GOTO errmes n$ = e$ - n2$ = RTrim$(id.callname) + n2$ = RTRIM$(id.callname) tsize = id.tsize 'select command command = 3 'fixed length elements - If t And ISSTRING Then - If (t And ISFIXEDLENGTH) = 0 Then + IF t AND ISSTRING THEN + IF (t AND ISFIXEDLENGTH) = 0 THEN command = 4 'var-len elements - End If - End If + END IF + END IF 'if... @@ -11481,253 +11481,253 @@ For x = 1 To commonarraylistn ' array (in whatever state it currently is) should be passed. If it is currently erased ' then it should be passed as a placeholder - If arrayelements = -1 Then + IF arrayelements = -1 THEN 'load array (copies the array, if any, into a buffer for later) - Open tmpdir$ + "inpchain" + str2$(i) + ".txt" For Output As #12 - Print #12, "if (int32val==2){" 'array place-holder + OPEN tmpdir$ + "inpchain" + str2$(i) + ".txt" FOR OUTPUT AS #12 + PRINT #12, "if (int32val==2){" 'array place-holder 'create buffer to store array as-is in global.txt x$ = str2$(uniquenumber) x1$ = "chainarraybuf" + x$ x2$ = "chainarraybufsiz" + x$ - Print #18, "static uint8 *" + x1$ + "=(uint8*)malloc(1);" - Print #18, "static int64 " + x2$ + "=0;" + PRINT #18, "static uint8 *" + x1$ + "=(uint8*)malloc(1);" + PRINT #18, "static int64 " + x2$ + "=0;" 'read next command - Print #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" - If command = 3 Then Print #12, "if (int32val==3){" 'fixed-length-element array - If command = 4 Then Print #12, "if (int32val==4){" 'var-length-element array - Print #12, x2$ + "+=4; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int32*)(" + x1$ + "+" + x2$ + "-4)=int32val;" + IF command = 3 THEN PRINT #12, "if (int32val==3){" 'fixed-length-element array + IF command = 4 THEN PRINT #12, "if (int32val==4){" 'var-length-element array + PRINT #12, x2$ + "+=4; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int32*)(" + x1$ + "+" + x2$ + "-4)=int32val;" - If command = 3 Then + IF command = 3 THEN 'read size in bits of one element, convert it to bytes - Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" - Print #12, x2$ + "+=8; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int64*)(" + x1$ + "+" + x2$ + "-8)=int64val;" - Print #12, "bytes=int64val>>3;" - End If 'com=3 + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" + PRINT #12, x2$ + "+=8; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int64*)(" + x1$ + "+" + x2$ + "-8)=int64val;" + PRINT #12, "bytes=int64val>>3;" + END IF 'com=3 - If command = 4 Then Print #12, "bytes=1;" 'bytes used to calculate number of elements + IF command = 4 THEN PRINT #12, "bytes=1;" 'bytes used to calculate number of elements 'read number of dimensions - Print #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" - Print #12, x2$ + "+=4; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int32*)(" + x1$ + "+" + x2$ + "-4)=int32val;" + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" + PRINT #12, x2$ + "+=4; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int32*)(" + x1$ + "+" + x2$ + "-4)=int32val;" 'read size of dimensions & calculate the size of the array in bytes - Print #12, "while(int32val--){" - Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" 'lbound - Print #12, x2$ + "+=8; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int64*)(" + x1$ + "+" + x2$ + "-8)=int64val;" - Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val2,8," + NewByteElement$ + "),0);" 'ubound - Print #12, x2$ + "+=8; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int64*)(" + x1$ + "+" + x2$ + "-8)=int64val2;" - Print #12, "bytes*=(int64val2-int64val+1);" - Print #12, "}" + PRINT #12, "while(int32val--){" + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" 'lbound + PRINT #12, x2$ + "+=8; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int64*)(" + x1$ + "+" + x2$ + "-8)=int64val;" + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)&int64val2,8," + NewByteElement$ + "),0);" 'ubound + PRINT #12, x2$ + "+=8; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int64*)(" + x1$ + "+" + x2$ + "-8)=int64val2;" + PRINT #12, "bytes*=(int64val2-int64val+1);" + PRINT #12, "}" - If command = 3 Then + IF command = 3 THEN 'read the array data - Print #12, x2$ + "+=bytes; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + ");" - Print #12, "sub_get(FF,NULL,byte_element((uint64)(" + x1$ + "+" + x2$ + "-bytes),bytes," + NewByteElement$ + "),0);" - End If 'com=3 + PRINT #12, x2$ + "+=bytes; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + ");" + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)(" + x1$ + "+" + x2$ + "-bytes),bytes," + NewByteElement$ + "),0);" + END IF 'com=3 - If command = 4 Then - Print #12, "bytei=0;" - Print #12, "while(bytei>3); " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + ");" - Print #12, "sub_get(FF,NULL,byte_element((uint64)(" + x1$ + "+" + x2$ + "-(int64val>>3)),(int64val>>3)," + NewByteElement$ + "),0);" - Print #12, "bytei++;" - Print #12, "}" - End If + IF command = 4 THEN + PRINT #12, "bytei=0;" + PRINT #12, "while(bytei>3); " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + ");" + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)(" + x1$ + "+" + x2$ + "-(int64val>>3)),(int64val>>3)," + NewByteElement$ + "),0);" + PRINT #12, "bytei++;" + PRINT #12, "}" + END IF 'get next command - Print #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" - Print #12, "}" 'command=3 or 4 + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" + PRINT #12, "}" 'command=3 or 4 - Print #12, "}" 'array place-holder - Close #12 + PRINT #12, "}" 'array place-holder + CLOSE #12 'save array (saves the buffered data, if any, for later) - Open tmpdir$ + "chain" + str2$(i) + ".txt" For Output As #12 - Print #12, "int32val=2;" 'placeholder - Print #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" + OPEN tmpdir$ + "chain" + str2$(i) + ".txt" FOR OUTPUT AS #12 + PRINT #12, "int32val=2;" 'placeholder + PRINT #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" - Print #12, "sub_put(FF,NULL,byte_element((uint64)" + x1$ + "," + x2$ + "," + NewByteElement$ + "),0);" - Close #12 + PRINT #12, "sub_put(FF,NULL,byte_element((uint64)" + x1$ + "," + x2$ + "," + NewByteElement$ + "),0);" + CLOSE #12 - Else + ELSE 'note: arrayelements<>-1 'load array - Open tmpdir$ + "inpchain" + str2$(i) + ".txt" For Output As #12 + OPEN tmpdir$ + "inpchain" + str2$(i) + ".txt" FOR OUTPUT AS #12 - Print #12, "if (int32val==2){" 'array place-holder - Print #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" + PRINT #12, "if (int32val==2){" 'array place-holder + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" - If command = 3 Then Print #12, "if (int32val==3){" 'fixed-length-element array - If command = 4 Then Print #12, "if (int32val==4){" 'var-length-element array + IF command = 3 THEN PRINT #12, "if (int32val==3){" 'fixed-length-element array + IF command = 4 THEN PRINT #12, "if (int32val==4){" 'var-length-element array - If command = 3 Then + IF command = 3 THEN 'get size in bits - Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" '***assume correct*** - End If + END IF 'get number of elements - Print #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" '***assume correct*** e$ = "" - If command = 4 Then Print #12, "bytes=1;" 'bytes counts the number of total elements - For x2 = 1 To arrayelements + IF command = 4 THEN PRINT #12, "bytes=1;" 'bytes counts the number of total elements + FOR x2 = 1 TO arrayelements 'create 'secret' variables to assist in passing common arrays - If x2 > ncommontmp Then + IF x2 > ncommontmp THEN ncommontmp = ncommontmp + 1 - If Debug Then Print #9, "Calling DIM2(...)..." - If Error_Happened Then GoTo errmes + IF Debug THEN PRINT #9, "Calling DIM2(...)..." + IF Error_Happened THEN GOTO errmes retval = dim2("___RESERVED_COMMON_LBOUND" + str2$(ncommontmp), "_INTEGER64", 0, "") - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes retval = dim2("___RESERVED_COMMON_UBOUND" + str2$(ncommontmp), "_INTEGER64", 0, "") - If Error_Happened Then GoTo errmes - If Debug Then Print #9, "Finished calling DIM2(...)!" - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes + IF Debug THEN PRINT #9, "Finished calling DIM2(...)!" + IF Error_Happened THEN GOTO errmes - End If + END IF - Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" - Print #12, "*__INTEGER64____RESERVED_COMMON_LBOUND" + str2$(x2) + "=int64val;" - Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val2,8," + NewByteElement$ + "),0);" - Print #12, "*__INTEGER64____RESERVED_COMMON_UBOUND" + str2$(x2) + "=int64val2;" - If command = 4 Then Print #12, "bytes*=(int64val2-int64val+1);" - If x2 > 1 Then e$ = e$ + sp + "," + sp + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" + PRINT #12, "*__INTEGER64____RESERVED_COMMON_LBOUND" + str2$(x2) + "=int64val;" + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)&int64val2,8," + NewByteElement$ + "),0);" + PRINT #12, "*__INTEGER64____RESERVED_COMMON_UBOUND" + str2$(x2) + "=int64val2;" + IF command = 4 THEN PRINT #12, "bytes*=(int64val2-int64val+1);" + IF x2 > 1 THEN e$ = e$ + sp + "," + sp e$ = e$ + "___RESERVED_COMMON_LBOUND" + str2$(x2) + sp + "TO" + sp + "___RESERVED_COMMON_UBOUND" + str2$(x2) - Next + NEXT - If Debug Then Print #9, "Calling DIM2(" + purevarname$ + "," + typ$ + ",0," + e$ + ")..." - If Error_Happened Then GoTo errmes + IF Debug THEN PRINT #9, "Calling DIM2(" + purevarname$ + "," + typ$ + ",0," + e$ + ")..." + IF Error_Happened THEN GOTO errmes 'Note: purevarname$ is simply varname$ without the type symbol after it redimoption = 1 retval = dim2(purevarname$, typ$, 0, e$) - If Error_Happened Then GoTo errmes + IF Error_Happened THEN GOTO errmes redimoption = 0 - If Debug Then Print #9, "Finished calling DIM2(" + purevarname$ + "," + typ$ + ",0," + e$ + ")!" - If Error_Happened Then GoTo errmes + IF Debug THEN PRINT #9, "Finished calling DIM2(" + purevarname$ + "," + typ$ + ",0," + e$ + ")!" + IF Error_Happened THEN GOTO errmes - If command = 3 Then + IF command = 3 THEN 'use get to load in the array data varname$ = varname$ + sp + "(" + sp + ")" e$ = evaluatetotyp(fixoperationorder$(varname$), -4) - If Error_Happened Then GoTo errmes - Print #12, "sub_get(FF,NULL," + e$ + ",0);" - End If + IF Error_Happened THEN GOTO errmes + PRINT #12, "sub_get(FF,NULL," + e$ + ",0);" + END IF - If command = 4 Then - Print #12, "bytei=0;" - Print #12, "while(bytei>3,1));" 'change string size - Print #12, "sub_get(FF,NULL,byte_element((uint64)tqbs->chr,int64val>>3," + NewByteElement$ + "),0);" 'get size - Print #12, "bytei++;" - Print #12, "}" - End If + IF command = 4 THEN + PRINT #12, "bytei=0;" + PRINT #12, "while(bytei>3,1));" 'change string size + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)tqbs->chr,int64val>>3," + NewByteElement$ + "),0);" 'get size + PRINT #12, "bytei++;" + PRINT #12, "}" + END IF 'get next command - Print #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" - Print #12, "}" - Print #12, "}" - Close #12 + PRINT #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" + PRINT #12, "}" + PRINT #12, "}" + CLOSE #12 'save array - Open tmpdir$ + "chain" + str2$(i) + ".txt" For Output As #12 + OPEN tmpdir$ + "chain" + str2$(i) + ".txt" FOR OUTPUT AS #12 - Print #12, "int32val=2;" 'placeholder - Print #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" + PRINT #12, "int32val=2;" 'placeholder + PRINT #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" - Print #12, "if (" + n2$ + "[2]&1){" 'don't add unless defined + PRINT #12, "if (" + n2$ + "[2]&1){" 'don't add unless defined - If command = 3 Then Print #12, "int32val=3;" - If command = 4 Then Print #12, "int32val=4;" - Print #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" + IF command = 3 THEN PRINT #12, "int32val=3;" + IF command = 4 THEN PRINT #12, "int32val=4;" + PRINT #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" - If command = 3 Then + IF command = 3 THEN 'size of each element in bits - bits = t And 511 - If t And ISUDT Then bits = udtxsize(t And 511) - If t And ISSTRING Then bits = tsize * 8 - Print #12, "int64val=" + str2$(bits) + ";" 'size in bits - Print #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" - End If 'com=3 + bits = t AND 511 + IF t AND ISUDT THEN bits = udtxsize(t AND 511) + IF t AND ISSTRING THEN bits = tsize * 8 + PRINT #12, "int64val=" + str2$(bits) + ";" 'size in bits + PRINT #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" + END IF 'com=3 - Print #12, "int32val=" + str2$(arrayelements) + ";" 'number of dimensions - Print #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" + PRINT #12, "int32val=" + str2$(arrayelements) + ";" 'number of dimensions + PRINT #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" - If command = 3 Then + IF command = 3 THEN - For x2 = 1 To arrayelements + FOR x2 = 1 TO arrayelements 'simulate calls to lbound/ubound e$ = "LBOUND" + sp + "(" + sp + n$ + sp + "," + sp + str2$(x2) + sp + ")" e$ = evaluatetotyp(fixoperationorder$(e$), 64) - If Error_Happened Then GoTo errmes - Print #12, "int64val=" + e$ + ";" - Print #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" + IF Error_Happened THEN GOTO errmes + PRINT #12, "int64val=" + e$ + ";" + PRINT #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" e$ = "UBOUND" + sp + "(" + sp + n$ + sp + "," + sp + str2$(x2) + sp + ")" e$ = evaluatetotyp(fixoperationorder$(e$), 64) - If Error_Happened Then GoTo errmes - Print #12, "int64val=" + e$ + ";" - Print #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" - Next + IF Error_Happened THEN GOTO errmes + PRINT #12, "int64val=" + e$ + ";" + PRINT #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" + NEXT 'array data e$ = evaluatetotyp(fixoperationorder$(n$ + sp + "(" + sp + ")"), -4) - If Error_Happened Then GoTo errmes - Print #12, "sub_put(FF,NULL," + e$ + ",0);" + IF Error_Happened THEN GOTO errmes + PRINT #12, "sub_put(FF,NULL," + e$ + ",0);" - End If 'com=3 + END IF 'com=3 - If command = 4 Then + IF command = 4 THEN 'store LBOUND/UBOUND values and calculate number of total elements/strings - Print #12, "bytes=1;" 'note: bytes is actually the total number of elements - For x2 = 1 To arrayelements + PRINT #12, "bytes=1;" 'note: bytes is actually the total number of elements + FOR x2 = 1 TO arrayelements e$ = "LBOUND" + sp + "(" + sp + n$ + sp + "," + sp + str2$(x2) + sp + ")" e$ = evaluatetotyp(fixoperationorder$(e$), 64) - If Error_Happened Then GoTo errmes - Print #12, "int64val=" + e$ + ";" - Print #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" + IF Error_Happened THEN GOTO errmes + PRINT #12, "int64val=" + e$ + ";" + PRINT #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" e$ = "UBOUND" + sp + "(" + sp + n$ + sp + "," + sp + str2$(x2) + sp + ")" e$ = evaluatetotyp(fixoperationorder$(e$), 64) - If Error_Happened Then GoTo errmes - Print #12, "int64val2=" + e$ + ";" - Print #12, "sub_put(FF,NULL,byte_element((uint64)&int64val2,8," + NewByteElement$ + "),0);" - Print #12, "bytes*=(int64val2-int64val+1);" - Next + IF Error_Happened THEN GOTO errmes + PRINT #12, "int64val2=" + e$ + ";" + PRINT #12, "sub_put(FF,NULL,byte_element((uint64)&int64val2,8," + NewByteElement$ + "),0);" + PRINT #12, "bytes*=(int64val2-int64val+1);" + NEXT - Print #12, "bytei=0;" - Print #12, "while(byteilen; int64val<<=3;" - Print #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" 'size of element - Print #12, "sub_put(FF,NULL,byte_element((uint64)tqbs->chr,tqbs->len," + NewByteElement$ + "),0);" 'element data - Print #12, "bytei++;" - Print #12, "}" + PRINT #12, "bytei=0;" + PRINT #12, "while(byteilen; int64val<<=3;" + PRINT #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" 'size of element + PRINT #12, "sub_put(FF,NULL,byte_element((uint64)tqbs->chr,tqbs->len," + NewByteElement$ + "),0);" 'element data + PRINT #12, "bytei++;" + PRINT #12, "}" - End If 'com=4 + END IF 'com=4 - Print #12, "}" 'don't add unless defined + PRINT #12, "}" 'don't add unless defined - Close #12 + CLOSE #12 @@ -11822,340 +11822,340 @@ For x = 1 To commonarraylistn - End If 'id.arrayelements=-1 + END IF 'id.arrayelements=-1 -Next +NEXT use_global_byte_elements = 0 -If Debug Then Print #9, "Finished generation of code for saving/sharing common array data!" +IF Debug THEN PRINT #9, "Finished generation of code for saving/sharing common array data!" -For closeall = 1 To 255: Close closeall: Next -Open tmpdir$ + "temp.bin" For Output Lock Write As #26 'relock +FOR closeall = 1 TO 255: CLOSE closeall: NEXT +OPEN tmpdir$ + "temp.bin" FOR OUTPUT LOCK WRITE AS #26 'relock compilelog$ = tmpdir$ + "compilelog.txt" -Open compilelog$ For Output As #1: Close #1 'Clear log +OPEN compilelog$ FOR OUTPUT AS #1: CLOSE #1 'Clear log -If idemode = 0 And Not QuietMode Then - If ConsoleMode Then - Print "[" + String$(maxprogresswidth, ".") + "] 100%" - Else - Locate , 1 - Print String$(maxprogresswidth, 219) + " 100%" - End If -End If +IF idemode = 0 AND NOT QuietMode THEN + IF ConsoleMode THEN + PRINT "[" + STRING$(maxprogresswidth, ".") + "] 100%" + ELSE + LOCATE , 1 + PRINT STRING$(maxprogresswidth, 219) + " 100%" + END IF +END IF 'OPEN "unusedVariableList.txt" FOR OUTPUT AS #1: CLOSE #1 'OPEN "unusedVariableList.txt" FOR BINARY AS #1 'PUT #1, 1, usedVariableList$ 'warning$(1) 'CLOSE #1 -If Not IgnoreWarnings Then +IF NOT IgnoreWarnings THEN totalUnusedVariables = 0 - For i = 1 To totalVariablesCreated - If usedVariableList(i).used = 0 Then + FOR i = 1 TO totalVariablesCreated + IF usedVariableList(i).used = 0 THEN totalUnusedVariables = totalUnusedVariables + 1 - End If - Next + END IF + NEXT - If totalUnusedVariables > 0 Then + IF totalUnusedVariables > 0 THEN maxVarNameLen = 0 - For i = 1 To totalVariablesCreated - If usedVariableList(i).used = 0 Then - If Len(usedVariableList(i).name) > maxVarNameLen Then maxVarNameLen = Len(usedVariableList(i).name) - End If - Next + FOR i = 1 TO totalVariablesCreated + IF usedVariableList(i).used = 0 THEN + IF LEN(usedVariableList(i).name) > maxVarNameLen THEN maxVarNameLen = LEN(usedVariableList(i).name) + END IF + NEXT header$ = "unused variable" 's (" + LTRIM$(STR$(totalUnusedVariables)) + ")" - For i = 1 To totalVariablesCreated - If usedVariableList(i).used = 0 Then - addWarning usedVariableList(i).linenumber, usedVariableList(i).includeLevel, usedVariableList(i).includedLine, usedVariableList(i).includedFile, header$, usedVariableList(i).name + Space$((maxVarNameLen + 1) - Len(usedVariableList(i).name)) + " (" + usedVariableList(i).cname + ")" - End If - Next - End If -End If + FOR i = 1 TO totalVariablesCreated + IF usedVariableList(i).used = 0 THEN + addWarning usedVariableList(i).linenumber, usedVariableList(i).includeLevel, usedVariableList(i).includedLine, usedVariableList(i).includedFile, header$, usedVariableList(i).name + SPACE$((maxVarNameLen + 1) - LEN(usedVariableList(i).name)) + " (" + usedVariableList(i).cname + ")" + END IF + NEXT + END IF +END IF -If idemode Then GoTo ideret5 +IF idemode THEN GOTO ideret5 ide6: -If idemode = 0 And No_C_Compile_Mode = 0 Then - If Not QuietMode Then - Print - If os$ = "LNX" Then - Print "Compiling C++ code into executable..." - Else - Print "Compiling C++ code into EXE..." - End If - End If - If Len(outputfile_cmd$) Then +IF idemode = 0 AND No_C_Compile_Mode = 0 THEN + IF NOT QuietMode THEN + PRINT + IF os$ = "LNX" THEN + PRINT "Compiling C++ code into executable..." + ELSE + PRINT "Compiling C++ code into EXE..." + END IF + END IF + IF LEN(outputfile_cmd$) THEN 'resolve relative path for output file path.out$ = getfilepath$(outputfile_cmd$) - f$ = Mid$(outputfile_cmd$, Len(path.out$) + 1) + f$ = MID$(outputfile_cmd$, LEN(path.out$) + 1) file$ = RemoveFileExtension$(f$) - If Len(path.out$) Then - If _DirExists(path.out$) = 0 Then - Print - Print "Can't create output executable - path not found: " + path.out$ - If ConsoleMode Then System 1 - End 1 - End If + IF LEN(path.out$) THEN + IF _DIREXISTS(path.out$) = 0 THEN + PRINT + PRINT "Can't create output executable - path not found: " + path.out$ + IF ConsoleMode THEN SYSTEM 1 + END 1 + END IF currentdir$ = _CWD$ - ChDir path.out$ + CHDIR path.out$ path.out$ = _CWD$ - ChDir currentdir$ - If Right$(path.out$, 1) <> pathsep$ Then path.out$ = path.out$ + pathsep$ + CHDIR currentdir$ + IF RIGHT$(path.out$, 1) <> pathsep$ THEN path.out$ = path.out$ + pathsep$ path.exe$ = path.out$ SaveExeWithSource = -1 'Override the global setting if an output file was specified - End If - End If + END IF + END IF t.path.exe$ = path.exe$ - If path.exe$ = "../../" Or path.exe$ = "..\..\" Then path.exe$ = "" - If _FileExists(path.exe$ + file$ + extension$) Then + IF path.exe$ = "../../" OR path.exe$ = "..\..\" THEN path.exe$ = "" + IF _FILEEXISTS(path.exe$ + file$ + extension$) THEN E = 0 - On Error GoTo qberror_test - Kill path.exe$ + file$ + extension$ - On Error GoTo qberror - If E = 1 Then - a$ = "CANNOT CREATE " + Chr$(34) + file$ + extension$ + Chr$(34) + " BECAUSE THE FILE IS ALREADY IN USE!": GoTo errmes - End If - End If + ON ERROR GOTO qberror_test + KILL path.exe$ + file$ + extension$ + ON ERROR GOTO qberror + IF E = 1 THEN + a$ = "CANNOT CREATE " + CHR$(34) + file$ + extension$ + CHR$(34) + " BECAUSE THE FILE IS ALREADY IN USE!": GOTO errmes + END IF + END IF path.exe$ = t.path.exe$ -End If +END IF -If os$ = "WIN" Then +IF os$ = "WIN" THEN 'Prepare to embed icon into .EXE - If ExeIconSet Or VersionInfoSet Then - If _FileExists(tmpdir$ + "icon.o") Then + IF ExeIconSet OR VersionInfoSet THEN + IF _FILEEXISTS(tmpdir$ + "icon.o") THEN E = 0 - On Error GoTo qberror_test - Kill tmpdir$ + "icon.o" - If E = 1 Or _FileExists(tmpdir$ + "icon.o") = -1 Then a$ = "Error creating resource file": GoTo errmes - On Error GoTo qberror - End If - End If + ON ERROR GOTO qberror_test + KILL tmpdir$ + "icon.o" + IF E = 1 OR _FILEEXISTS(tmpdir$ + "icon.o") = -1 THEN a$ = "Error creating resource file": GOTO errmes + ON ERROR GOTO qberror + END IF + END IF - If ExeIconSet Then + IF ExeIconSet THEN linenumber = ExeIconSet 'on error, this allows reporting the linenumber where $EXEICON was used wholeline = " $EXEICON:'" + ExeIconFile$ + "'" - End If + END IF - If VersionInfoSet Then - iconfilehandle = FreeFile - Open tmpdir$ + "icon.rc" For Append As #iconfilehandle - Print #iconfilehandle, "" - Print #iconfilehandle, "1 VERSIONINFO" - If Len(viFileVersionNum$) Then Print #iconfilehandle, "FILEVERSION "; viFileVersionNum$ - If Len(viProductVersionNum$) Then Print #iconfilehandle, "PRODUCTVERSION "; viProductVersionNum$ - Print #iconfilehandle, "BEGIN" - Print #iconfilehandle, " BLOCK " + QuotedFilename$("StringFileInfo") - Print #iconfilehandle, " BEGIN" - Print #iconfilehandle, " BLOCK " + QuotedFilename$("040904E4") - Print #iconfilehandle, " BEGIN" - Print #iconfilehandle, " VALUE " + QuotedFilename$("CompanyName") + "," + QuotedFilename$(viCompanyName$ + "\0") - Print #iconfilehandle, " VALUE " + QuotedFilename$("FileDescription") + "," + QuotedFilename$(viFileDescription$ + "\0") - Print #iconfilehandle, " VALUE " + QuotedFilename$("FileVersion") + "," + QuotedFilename$(viFileVersion$ + "\0") - Print #iconfilehandle, " VALUE " + QuotedFilename$("InternalName") + "," + QuotedFilename$(viInternalName$ + "\0") - Print #iconfilehandle, " VALUE " + QuotedFilename$("LegalCopyright") + "," + QuotedFilename$(viLegalCopyright$ + "\0") - Print #iconfilehandle, " VALUE " + QuotedFilename$("LegalTrademarks") + "," + QuotedFilename$(viLegalTrademarks$ + "\0") - Print #iconfilehandle, " VALUE " + QuotedFilename$("OriginalFilename") + "," + QuotedFilename$(viOriginalFilename$ + "\0") - Print #iconfilehandle, " VALUE " + QuotedFilename$("ProductName") + "," + QuotedFilename$(viProductName$ + "\0") - Print #iconfilehandle, " VALUE " + QuotedFilename$("ProductVersion") + "," + QuotedFilename$(viProductVersion$ + "\0") - Print #iconfilehandle, " VALUE " + QuotedFilename$("Comments") + "," + QuotedFilename$(viComments$ + "\0") - Print #iconfilehandle, " VALUE " + QuotedFilename$("Web") + "," + QuotedFilename$(viWeb$ + "\0") - Print #iconfilehandle, " END" - Print #iconfilehandle, " END" - Print #iconfilehandle, " BLOCK " + QuotedFilename$("VarFileInfo") - Print #iconfilehandle, " BEGIN" - Print #iconfilehandle, " VALUE " + QuotedFilename$("Translation") + ", 0x409, 0x04E4" - Print #iconfilehandle, " END" - Print #iconfilehandle, "END" - Close #iconfilehandle - End If + IF VersionInfoSet THEN + iconfilehandle = FREEFILE + OPEN tmpdir$ + "icon.rc" FOR APPEND AS #iconfilehandle + PRINT #iconfilehandle, "" + PRINT #iconfilehandle, "1 VERSIONINFO" + IF LEN(viFileVersionNum$) THEN PRINT #iconfilehandle, "FILEVERSION "; viFileVersionNum$ + IF LEN(viProductVersionNum$) THEN PRINT #iconfilehandle, "PRODUCTVERSION "; viProductVersionNum$ + PRINT #iconfilehandle, "BEGIN" + PRINT #iconfilehandle, " BLOCK " + QuotedFilename$("StringFileInfo") + PRINT #iconfilehandle, " BEGIN" + PRINT #iconfilehandle, " BLOCK " + QuotedFilename$("040904E4") + PRINT #iconfilehandle, " BEGIN" + PRINT #iconfilehandle, " VALUE " + QuotedFilename$("CompanyName") + "," + QuotedFilename$(viCompanyName$ + "\0") + PRINT #iconfilehandle, " VALUE " + QuotedFilename$("FileDescription") + "," + QuotedFilename$(viFileDescription$ + "\0") + PRINT #iconfilehandle, " VALUE " + QuotedFilename$("FileVersion") + "," + QuotedFilename$(viFileVersion$ + "\0") + PRINT #iconfilehandle, " VALUE " + QuotedFilename$("InternalName") + "," + QuotedFilename$(viInternalName$ + "\0") + PRINT #iconfilehandle, " VALUE " + QuotedFilename$("LegalCopyright") + "," + QuotedFilename$(viLegalCopyright$ + "\0") + PRINT #iconfilehandle, " VALUE " + QuotedFilename$("LegalTrademarks") + "," + QuotedFilename$(viLegalTrademarks$ + "\0") + PRINT #iconfilehandle, " VALUE " + QuotedFilename$("OriginalFilename") + "," + QuotedFilename$(viOriginalFilename$ + "\0") + PRINT #iconfilehandle, " VALUE " + QuotedFilename$("ProductName") + "," + QuotedFilename$(viProductName$ + "\0") + PRINT #iconfilehandle, " VALUE " + QuotedFilename$("ProductVersion") + "," + QuotedFilename$(viProductVersion$ + "\0") + PRINT #iconfilehandle, " VALUE " + QuotedFilename$("Comments") + "," + QuotedFilename$(viComments$ + "\0") + PRINT #iconfilehandle, " VALUE " + QuotedFilename$("Web") + "," + QuotedFilename$(viWeb$ + "\0") + PRINT #iconfilehandle, " END" + PRINT #iconfilehandle, " END" + PRINT #iconfilehandle, " BLOCK " + QuotedFilename$("VarFileInfo") + PRINT #iconfilehandle, " BEGIN" + PRINT #iconfilehandle, " VALUE " + QuotedFilename$("Translation") + ", 0x409, 0x04E4" + PRINT #iconfilehandle, " END" + PRINT #iconfilehandle, "END" + CLOSE #iconfilehandle + END IF - If ExeIconSet Or VersionInfoSet Then - ffh = FreeFile - Open tmpdir$ + "call_windres.bat" For Output As #ffh - Print #ffh, "internal\c\c_compiler\bin\windres.exe -i " + tmpdir$ + "icon.rc -o " + tmpdir$ + "icon.o" - Close #ffh - Shell _Hide tmpdir$ + "call_windres.bat" - If _FileExists(tmpdir$ + "icon.o") = 0 Then + IF ExeIconSet OR VersionInfoSet THEN + ffh = FREEFILE + OPEN tmpdir$ + "call_windres.bat" FOR OUTPUT AS #ffh + PRINT #ffh, "internal\c\c_compiler\bin\windres.exe -i " + tmpdir$ + "icon.rc -o " + tmpdir$ + "icon.o" + CLOSE #ffh + SHELL _HIDE tmpdir$ + "call_windres.bat" + IF _FILEEXISTS(tmpdir$ + "icon.o") = 0 THEN a$ = "Bad icon file" - If VersionInfoSet Then a$ = a$ + " or invalid $VERSIONINFO values" - GoTo errmes - End If - End If -End If + IF VersionInfoSet THEN a$ = a$ + " or invalid $VERSIONINFO values" + GOTO errmes + END IF + END IF +END IF 'Update dependencies -o$ = LCase$(os$) -win = 0: If os$ = "WIN" Then win = 1 -lnx = 0: If os$ = "LNX" Then lnx = 1 -mac = 0: If MacOSX Then mac = 1: o$ = "osx" +o$ = LCASE$(os$) +win = 0: IF os$ = "WIN" THEN win = 1 +lnx = 0: IF os$ = "LNX" THEN lnx = 1 +mac = 0: IF MacOSX THEN mac = 1: o$ = "osx" defines$ = "": defines_header$ = " -D " ver$ = Version$ 'eg. "0.123" -x = InStr(ver$, "."): If x Then Asc(ver$, x) = 95 'change "." to "_" +x = INSTR(ver$, "."): IF x THEN ASC(ver$, x) = 95 'change "." to "_" libs$ = "" -If DEPENDENCY(DEPENDENCY_GL) Then +IF DEPENDENCY(DEPENDENCY_GL) THEN defines$ = defines$ + defines_header$ + "DEPENDENCY_GL" -End If +END IF -If DEPENDENCY(DEPENDENCY_SCREENIMAGE) Then +IF DEPENDENCY(DEPENDENCY_SCREENIMAGE) THEN DEPENDENCY(DEPENDENCY_IMAGE_CODEC) = 1 'used by OSX to read in screen capture files -End If +END IF -If DEPENDENCY(DEPENDENCY_IMAGE_CODEC) Then +IF DEPENDENCY(DEPENDENCY_IMAGE_CODEC) THEN defines$ = defines$ + defines_header$ + "DEPENDENCY_IMAGE_CODEC" -End If +END IF -If DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) Then +IF DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) THEN defines$ = defines$ + defines_header$ + "DEPENDENCY_CONSOLE_ONLY" -End If +END IF -If DEPENDENCY(DEPENDENCY_SOCKETS) Then +IF DEPENDENCY(DEPENDENCY_SOCKETS) THEN defines$ = defines$ + defines_header$ + "DEPENDENCY_SOCKETS" -Else +ELSE defines$ = defines$ + defines_header$ + "DEPENDENCY_NO_SOCKETS" -End If +END IF -If DEPENDENCY(DEPENDENCY_PRINTER) Then +IF DEPENDENCY(DEPENDENCY_PRINTER) THEN defines$ = defines$ + defines_header$ + "DEPENDENCY_PRINTER" -Else +ELSE defines$ = defines$ + defines_header$ + "DEPENDENCY_NO_PRINTER" -End If +END IF -If DEPENDENCY(DEPENDENCY_ICON) Then +IF DEPENDENCY(DEPENDENCY_ICON) THEN defines$ = defines$ + defines_header$ + "DEPENDENCY_ICON" -Else +ELSE defines$ = defines$ + defines_header$ + "DEPENDENCY_NO_ICON" -End If +END IF -If DEPENDENCY(DEPENDENCY_SCREENIMAGE) Then +IF DEPENDENCY(DEPENDENCY_SCREENIMAGE) THEN defines$ = defines$ + defines_header$ + "DEPENDENCY_SCREENIMAGE" -Else +ELSE defines$ = defines$ + defines_header$ + "DEPENDENCY_NO_SCREENIMAGE" -End If +END IF -If DEPENDENCY(DEPENDENCY_LOADFONT) Then +IF DEPENDENCY(DEPENDENCY_LOADFONT) THEN d$ = "internal\c\parts\video\font\ttf\" 'rebuild? - If _FileExists(d$ + "os\" + o$ + "\src.o") = 0 Then + IF _FILEEXISTS(d$ + "os\" + o$ + "\src.o") = 0 THEN Build d$ + "os\" + o$ - End If + END IF defines$ = defines$ + defines_header$ + "DEPENDENCY_LOADFONT" libs$ = libs$ + " " + "parts\video\font\ttf\os\" + o$ + "\src.o" -End If +END IF localpath$ = "internal\c\" -If DEPENDENCY(DEPENDENCY_DEVICEINPUT) Then +IF DEPENDENCY(DEPENDENCY_DEVICEINPUT) THEN defines$ = defines$ + defines_header$ + "DEPENDENCY_DEVICEINPUT" libname$ = "input\game_controller" libpath$ = "parts\" + libname$ + "\os\" + o$ libfile$ = libpath$ + "\src.a" - If _FileExists(localpath$ + libfile$) = 0 Then Build localpath$ + libpath$ 'rebuild? + IF _FILEEXISTS(localpath$ + libfile$) = 0 THEN Build localpath$ + libpath$ 'rebuild? libs$ = libs$ + " " + libfile$ -End If +END IF -If DEPENDENCY(DEPENDENCY_AUDIO_DECODE) Then DEPENDENCY(DEPENDENCY_AUDIO_CONVERSION) = 1 -If DEPENDENCY(DEPENDENCY_AUDIO_CONVERSION) Then DEPENDENCY(DEPENDENCY_AUDIO_OUT) = 1 -If DEPENDENCY(DEPENDENCY_AUDIO_DECODE) Then DEPENDENCY(DEPENDENCY_AUDIO_OUT) = 1 +IF DEPENDENCY(DEPENDENCY_AUDIO_DECODE) THEN DEPENDENCY(DEPENDENCY_AUDIO_CONVERSION) = 1 +IF DEPENDENCY(DEPENDENCY_AUDIO_CONVERSION) THEN DEPENDENCY(DEPENDENCY_AUDIO_OUT) = 1 +IF DEPENDENCY(DEPENDENCY_AUDIO_DECODE) THEN DEPENDENCY(DEPENDENCY_AUDIO_OUT) = 1 -If DEPENDENCY(DEPENDENCY_AUDIO_CONVERSION) Then +IF DEPENDENCY(DEPENDENCY_AUDIO_CONVERSION) THEN defines$ = defines$ + defines_header$ + "DEPENDENCY_AUDIO_CONVERSION" d1$ = "parts\audio\conversion" d2$ = d1$ + "\os\" + o$ d3$ = "internal\c\" + d2$ - If _FileExists(d3$ + "\src.a") = 0 Then 'rebuild? + IF _FILEEXISTS(d3$ + "\src.a") = 0 THEN 'rebuild? Build d3$ - End If + END IF libs$ = libs$ + " " + d2$ + "\src.a" -End If +END IF -If DEPENDENCY(DEPENDENCY_AUDIO_DECODE) Then +IF DEPENDENCY(DEPENDENCY_AUDIO_DECODE) THEN 'General decoder defines$ = defines$ + defines_header$ + "DEPENDENCY_AUDIO_DECODE" 'MINI_MP3 decoder d1$ = "parts\audio\decode\mp3_mini" d2$ = d1$ + "\os\" + o$ d3$ = "internal\c\" + d2$ - If _FileExists(d3$ + "\src.a") = 0 Then 'rebuild? + IF _FILEEXISTS(d3$ + "\src.a") = 0 THEN 'rebuild? Build d3$ - End If + END IF libs$ = libs$ + " " + d2$ + "\src.a" 'OGG decoder d1$ = "parts\audio\decode\ogg" d2$ = d1$ + "\os\" + o$ d3$ = "internal\c\" + d2$ - If _FileExists(d3$ + "\src.o") = 0 Then 'rebuild? + IF _FILEEXISTS(d3$ + "\src.o") = 0 THEN 'rebuild? Build d3$ - End If + END IF libs$ = libs$ + " " + d2$ + "\src.o" 'WAV decoder '(no action required) -End If +END IF -If DEPENDENCY(DEPENDENCY_AUDIO_OUT) Then +IF DEPENDENCY(DEPENDENCY_AUDIO_OUT) THEN defines$ = defines$ + defines_header$ + "DEPENDENCY_AUDIO_OUT" d1$ = "parts\audio\out" d2$ = d1$ + "\os\" + o$ d3$ = "internal\c\" + d2$ - If _FileExists(d3$ + "\src.a") = 0 Then 'rebuild? + IF _FILEEXISTS(d3$ + "\src.a") = 0 THEN 'rebuild? Build d3$ - End If + END IF libs$ = libs$ + " " + d2$ + "\src.a" -End If +END IF -If DEPENDENCY(DEPENDENCY_ZLIB) Then +IF DEPENDENCY(DEPENDENCY_ZLIB) THEN defines$ = defines$ + defines_header$ + "DEPENDENCY_ZLIB" - If MacOSX Then + IF MacOSX THEN libs$ = libs$ + " -lz" - Else + ELSE libs$ = libs$ + " -l:libz.a" - End If -End If + END IF +END IF 'finalize libs$ and defines$ strings -If Len(libs$) Then libs$ = libs$ + " " +IF LEN(libs$) THEN libs$ = libs$ + " " PATH_SLASH_CORRECT libs$ -If Len(defines$) Then defines$ = defines$ + " " +IF LEN(defines$) THEN defines$ = defines$ + " " 'Build core? -If mac = 0 Then 'macosx uses Apple's GLUT not FreeGLUT +IF mac = 0 THEN 'macosx uses Apple's GLUT not FreeGLUT d1$ = "parts\core" d2$ = d1$ + "\os\" + o$ d3$ = "internal\c\" + d2$ - If _FileExists(d3$ + "\src.a") = 0 Then 'rebuild? + IF _FILEEXISTS(d3$ + "\src.a") = 0 THEN 'rebuild? Build d3$ - End If -End If 'mac = 0 + END IF +END IF 'mac = 0 'Build libqb? depstr$ = ver$ + "_" -For i = 1 To DEPENDENCY_LAST - If DEPENDENCY(i) Then depstr$ = depstr$ + "1" Else depstr$ = depstr$ + "0" -Next +FOR i = 1 TO DEPENDENCY_LAST + IF DEPENDENCY(i) THEN depstr$ = depstr$ + "1" ELSE depstr$ = depstr$ + "0" +NEXT libqb$ = " libqb\os\" + o$ + "\libqb_" + depstr$ + ".o " PATH_SLASH_CORRECT libqb$ -If _FileExists("internal\c\" + LTrim$(RTrim$(libqb$))) = 0 Then - ChDir "internal\c" - If os$ = "WIN" Then - Shell _Hide GDB_Fix("cmd /c c_compiler\bin\g++ -c -s -w -Wall libqb.cpp -D FREEGLUT_STATIC " + defines$ + " -o libqb\os\" + o$ + "\libqb_" + depstr$ + ".o") + " 2>> ..\..\" + compilelog$ - Else - If mac Then - Shell _Hide GDB_Fix("g++ -c -s -w -Wall libqb.mm " + defines$ + " -o libqb/os/" + o$ + "/libqb_" + depstr$ + ".o") + " 2>> ../../" + compilelog$ - Else - Shell _Hide GDB_Fix("g++ -c -s -w -Wall libqb.cpp -D FREEGLUT_STATIC " + defines$ + " -o libqb/os/" + o$ + "/libqb_" + depstr$ + ".o") + " 2>> ../../" + compilelog$ - End If - End If - ChDir "..\.." -End If +IF _FILEEXISTS("internal\c\" + LTRIM$(RTRIM$(libqb$))) = 0 THEN + CHDIR "internal\c" + IF os$ = "WIN" THEN + SHELL _HIDE GDB_Fix("cmd /c c_compiler\bin\g++ -c -s -w -Wall libqb.cpp -D FREEGLUT_STATIC " + defines$ + " -o libqb\os\" + o$ + "\libqb_" + depstr$ + ".o") + " 2>> ..\..\" + compilelog$ + ELSE + IF mac THEN + SHELL _HIDE GDB_Fix("g++ -c -s -w -Wall libqb.mm " + defines$ + " -o libqb/os/" + o$ + "/libqb_" + depstr$ + ".o") + " 2>> ../../" + compilelog$ + ELSE + SHELL _HIDE GDB_Fix("g++ -c -s -w -Wall libqb.cpp -D FREEGLUT_STATIC " + defines$ + " -o libqb/os/" + o$ + "/libqb_" + depstr$ + ".o") + " 2>> ../../" + compilelog$ + END IF + END IF + CHDIR "..\.." +END IF 'link-time only defines -If DEPENDENCY(DEPENDENCY_AUDIO_OUT) Then - If mac Then defines$ = defines$ + " -framework AudioUnit -framework AudioToolbox " -End If +IF DEPENDENCY(DEPENDENCY_AUDIO_OUT) THEN + IF mac THEN defines$ = defines$ + " -framework AudioUnit -framework AudioToolbox " +END IF @@ -12181,487 +12181,487 @@ End If -If os$ = "WIN" Then +IF os$ = "WIN" THEN 'resolve static function definitions and add to global.txt - For x = 1 To ResolveStaticFunctions - If Len(ResolveStaticFunction_File(x)) Then + FOR x = 1 TO ResolveStaticFunctions + IF LEN(ResolveStaticFunction_File(x)) THEN n = 0 - Shell _Hide "internal\c\c_compiler\bin\nm.exe " + Chr$(34) + ResolveStaticFunction_File(x) + Chr$(34) + " --demangle -g >internal\temp\nm_output.txt" - fh = FreeFile + SHELL _HIDE "internal\c\c_compiler\bin\nm.exe " + CHR$(34) + ResolveStaticFunction_File(x) + CHR$(34) + " --demangle -g >internal\temp\nm_output.txt" + fh = FREEFILE s$ = " " + ResolveStaticFunction_Name(x) + "(" - Open "internal\temp\nm_output.txt" For Binary As #fh - Do Until EOF(fh) - Line Input #fh, a$ - If Len(a$) Then + OPEN "internal\temp\nm_output.txt" FOR BINARY AS #fh + DO UNTIL EOF(fh) + LINE INPUT #fh, a$ + IF LEN(a$) THEN 'search for SPACE+functionname+LEFTBRACKET - x1 = InStr(a$, s$) - If x1 Then - If ResolveStaticFunction_Method(x) = 1 Then + x1 = INSTR(a$, s$) + IF x1 THEN + IF ResolveStaticFunction_Method(x) = 1 THEN x1 = x1 + 1 - x2 = InStr(x1, a$, ")") - fh2 = FreeFile - Open tmpdir$ + "global.txt" For Append As #fh2 - Print #fh2, "extern void " + Mid$(a$, x1, x2 - x1 + 1) + ";" - Close #fh2 - End If + x2 = INSTR(x1, a$, ")") + fh2 = FREEFILE + OPEN tmpdir$ + "global.txt" FOR APPEND AS #fh2 + PRINT #fh2, "extern void " + MID$(a$, x1, x2 - x1 + 1) + ";" + CLOSE #fh2 + END IF n = n + 1 - End If 'x1 - End If '<>"" - Loop - Close #fh - If n > 1 Then a$ = "Unable to resolve multiple instances of sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GoTo errmes + END IF 'x1 + END IF '<>"" + LOOP + CLOSE #fh + IF n > 1 THEN a$ = "Unable to resolve multiple instances of sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GOTO errmes - If n = 0 Then 'attempt to locate simple function name without brackets - fh = FreeFile + IF n = 0 THEN 'attempt to locate simple function name without brackets + fh = FREEFILE s$ = " " + ResolveStaticFunction_Name(x) - Open "internal\temp\nm_output.txt" For Binary As #fh - Do Until EOF(fh) - Line Input #fh, a$ - If Len(a$) Then + OPEN "internal\temp\nm_output.txt" FOR BINARY AS #fh + DO UNTIL EOF(fh) + LINE INPUT #fh, a$ + IF LEN(a$) THEN 'search for SPACE+functionname - x1 = InStr(a$, s$) - If Right$(a$, Len(s$)) = s$ Then - fh2 = FreeFile - If ResolveStaticFunction_Method(x) = 1 Then - Open tmpdir$ + "global.txt" For Append As #fh2 - Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + "{" - Print #fh2, "extern void " + s$ + "(void);" - Print #fh2, "}" - Else - Open tmpdir$ + "externtype" + str2(x) + ".txt" For Output As #fh2 - Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + " " - End If - Close #fh2 + x1 = INSTR(a$, s$) + IF RIGHT$(a$, LEN(s$)) = s$ THEN + fh2 = FREEFILE + IF ResolveStaticFunction_Method(x) = 1 THEN + OPEN tmpdir$ + "global.txt" FOR APPEND AS #fh2 + PRINT #fh2, "extern " + CHR$(34) + "C" + CHR$(34) + "{" + PRINT #fh2, "extern void " + s$ + "(void);" + PRINT #fh2, "}" + ELSE + OPEN tmpdir$ + "externtype" + str2(x) + ".txt" FOR OUTPUT AS #fh2 + PRINT #fh2, "extern " + CHR$(34) + "C" + CHR$(34) + " " + END IF + CLOSE #fh2 n = n + 1 - Exit Do - End If 'x1 - End If '<>"" - Loop - Close #fh - End If + EXIT DO + END IF 'x1 + END IF '<>"" + LOOP + CLOSE #fh + END IF - If n = 0 Then 'a C++ dynamic object library? - Shell _Hide "internal\c\c_compiler\bin\nm " + Chr$(34) + ResolveStaticFunction_File(x) + Chr$(34) + " -D --demangle -g >.\internal\temp\nm_output_dynamic.txt" - fh = FreeFile + IF n = 0 THEN 'a C++ dynamic object library? + SHELL _HIDE "internal\c\c_compiler\bin\nm " + CHR$(34) + ResolveStaticFunction_File(x) + CHR$(34) + " -D --demangle -g >.\internal\temp\nm_output_dynamic.txt" + fh = FREEFILE s$ = " " + ResolveStaticFunction_Name(x) + "(" - Open "internal\temp\nm_output_dynamic.txt" For Binary As #fh - Do Until EOF(fh) - Line Input #fh, a$ - If Len(a$) Then + OPEN "internal\temp\nm_output_dynamic.txt" FOR BINARY AS #fh + DO UNTIL EOF(fh) + LINE INPUT #fh, a$ + IF LEN(a$) THEN 'search for SPACE+functionname+LEFTBRACKET - x1 = InStr(a$, s$) - If x1 Then - If ResolveStaticFunction_Method(x) = 1 Then + x1 = INSTR(a$, s$) + IF x1 THEN + IF ResolveStaticFunction_Method(x) = 1 THEN x1 = x1 + 1 - x2 = InStr(x1, a$, ")") - fh2 = FreeFile - Open tmpdir$ + "global.txt" For Append As #fh2 - Print #fh2, "extern void " + Mid$(a$, x1, x2 - x1 + 1) + ";" - Close #fh2 - End If + x2 = INSTR(x1, a$, ")") + fh2 = FREEFILE + OPEN tmpdir$ + "global.txt" FOR APPEND AS #fh2 + PRINT #fh2, "extern void " + MID$(a$, x1, x2 - x1 + 1) + ";" + CLOSE #fh2 + END IF n = n + 1 - End If 'x1 - End If '<>"" - Loop - Close #fh - If n > 1 Then a$ = "Unable to resolve multiple instances of sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GoTo errmes - End If + END IF 'x1 + END IF '<>"" + LOOP + CLOSE #fh + IF n > 1 THEN a$ = "Unable to resolve multiple instances of sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GOTO errmes + END IF - If n = 0 Then 'a C dynamic object library? - fh = FreeFile + IF n = 0 THEN 'a C dynamic object library? + fh = FREEFILE s$ = " " + ResolveStaticFunction_Name(x) - Open "internal\temp\nm_output_dynamic.txt" For Binary As #fh - Do Until EOF(fh) - Line Input #fh, a$ - If Len(a$) Then + OPEN "internal\temp\nm_output_dynamic.txt" FOR BINARY AS #fh + DO UNTIL EOF(fh) + LINE INPUT #fh, a$ + IF LEN(a$) THEN 'search for SPACE+functionname - x1 = InStr(a$, s$) - If Right$(a$, Len(s$)) = s$ Then - fh2 = FreeFile - If ResolveStaticFunction_Method(x) = 1 Then - Open tmpdir$ + "global.txt" For Append As #fh2 - Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + "{" - Print #fh2, "extern void " + s$ + "(void);" - Print #fh2, "}" - Else - Open tmpdir$ + "externtype" + str2(x) + ".txt" For Output As #fh2 - Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + " " - End If - Close #fh2 + x1 = INSTR(a$, s$) + IF RIGHT$(a$, LEN(s$)) = s$ THEN + fh2 = FREEFILE + IF ResolveStaticFunction_Method(x) = 1 THEN + OPEN tmpdir$ + "global.txt" FOR APPEND AS #fh2 + PRINT #fh2, "extern " + CHR$(34) + "C" + CHR$(34) + "{" + PRINT #fh2, "extern void " + s$ + "(void);" + PRINT #fh2, "}" + ELSE + OPEN tmpdir$ + "externtype" + str2(x) + ".txt" FOR OUTPUT AS #fh2 + PRINT #fh2, "extern " + CHR$(34) + "C" + CHR$(34) + " " + END IF + CLOSE #fh2 n = n + 1 - Exit Do - End If 'x1 - End If '<>"" - Loop - Close #fh - If n = 0 Then a$ = "Could not find sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GoTo errmes - End If + EXIT DO + END IF 'x1 + END IF '<>"" + LOOP + CLOSE #fh + IF n = 0 THEN a$ = "Could not find sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GOTO errmes + END IF - End If - Next + END IF + NEXT - If inline_DATA = 0 Then - If DataOffset Then - If OS_BITS = 32 Then - Open ".\internal\c\makedat_win32.txt" For Binary As #150: Line Input #150, a$: Close #150 - Else - Open ".\internal\c\makedat_win64.txt" For Binary As #150: Line Input #150, a$: Close #150 - End If + IF inline_DATA = 0 THEN + IF DataOffset THEN + IF OS_BITS = 32 THEN + OPEN ".\internal\c\makedat_win32.txt" FOR BINARY AS #150: LINE INPUT #150, a$: CLOSE #150 + ELSE + OPEN ".\internal\c\makedat_win64.txt" FOR BINARY AS #150: LINE INPUT #150, a$: CLOSE #150 + END IF a$ = a$ + " " + tmpdir2$ + "data.bin " + tmpdir2$ + "data.o" - ChDir ".\internal\c" - Shell _Hide "cmd /c " + a$ + " 2>> ..\..\" + compilelog$ - ChDir "..\.." - End If - End If + CHDIR ".\internal\c" + SHELL _HIDE "cmd /c " + a$ + " 2>> ..\..\" + compilelog$ + CHDIR "..\.." + END IF + END IF - Open ".\internal\c\makeline_win.txt" For Binary As #150 - Line Input #150, a$: a$ = GDB_Fix(a$) - Close #150 - If Right$(a$, 7) = " ..\..\" Then a$ = Left$(a$, Len(a$) - 6) 'makeline.txt patch (line will become unrequired in later versions) + OPEN ".\internal\c\makeline_win.txt" FOR BINARY AS #150 + LINE INPUT #150, a$: a$ = GDB_Fix(a$) + CLOSE #150 + IF RIGHT$(a$, 7) = " ..\..\" THEN a$ = LEFT$(a$, LEN(a$) - 6) 'makeline.txt patch (line will become unrequired in later versions) 'change qbx.cpp to qbx999.cpp? - x = InStr(a$, "qbx.cpp"): If x <> 0 And tempfolderindex <> 1 Then a$ = Left$(a$, x - 1) + "qbx" + str2$(tempfolderindex) + ".cpp" + Right$(a$, Len(a$) - (x + 6)) + x = INSTR(a$, "qbx.cpp"): IF x <> 0 AND tempfolderindex <> 1 THEN a$ = LEFT$(a$, x - 1) + "qbx" + str2$(tempfolderindex) + ".cpp" + RIGHT$(a$, LEN(a$) - (x + 6)) - If Console Then - x = InStr(a$, " -s"): a$ = Left$(a$, x - 1) + " -mconsole" + Right$(a$, Len(a$) - x + 1) - End If + IF Console THEN + x = INSTR(a$, " -s"): a$ = LEFT$(a$, x - 1) + " -mconsole" + RIGHT$(a$, LEN(a$) - x + 1) + END IF - If DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) Then + IF DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) THEN a$ = StrRemove(a$, "-mwindows") a$ = StrRemove(a$, "-lopengl32") a$ = StrRemove(a$, "-lglu32") a$ = StrRemove(a$, "parts\core\os\win\src.a") a$ = StrRemove(a$, "-D FREEGLUT_STATIC") a$ = StrRemove(a$, "-D GLEW_STATIC") - End If + END IF a$ = StrRemove(a$, "-lws2_32") - If DEPENDENCY(DEPENDENCY_SOCKETS) Then - x = InStr(a$, " -o"): a$ = Left$(a$, x - 1) + " -lws2_32" + Right$(a$, Len(a$) - x + 1) - End If + IF DEPENDENCY(DEPENDENCY_SOCKETS) THEN + x = INSTR(a$, " -o"): a$ = LEFT$(a$, x - 1) + " -lws2_32" + RIGHT$(a$, LEN(a$) - x + 1) + END IF a$ = StrRemove(a$, "-lwinspool") - If DEPENDENCY(DEPENDENCY_PRINTER) Then - x = InStr(a$, " -o"): a$ = Left$(a$, x - 1) + " -lwinspool" + Right$(a$, Len(a$) - x + 1) - End If + IF DEPENDENCY(DEPENDENCY_PRINTER) THEN + x = INSTR(a$, " -o"): a$ = LEFT$(a$, x - 1) + " -lwinspool" + RIGHT$(a$, LEN(a$) - x + 1) + END IF a$ = StrRemove(a$, "-lwinmm") - If DEPENDENCY(DEPENDENCY_AUDIO_OUT) <> 0 Or DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) = 0 Then - x = InStr(a$, " -o"): a$ = Left$(a$, x - 1) + " -lwinmm" + Right$(a$, Len(a$) - x + 1) - End If + IF DEPENDENCY(DEPENDENCY_AUDIO_OUT) <> 0 OR DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) = 0 THEN + x = INSTR(a$, " -o"): a$ = LEFT$(a$, x - 1) + " -lwinmm" + RIGHT$(a$, LEN(a$) - x + 1) + END IF a$ = StrRemove(a$, "-lksguid") - If DEPENDENCY(DEPENDENCY_AUDIO_OUT) Then - x = InStr(a$, " -o"): a$ = Left$(a$, x - 1) + " -lksguid" + Right$(a$, Len(a$) - x + 1) - End If + IF DEPENDENCY(DEPENDENCY_AUDIO_OUT) THEN + x = INSTR(a$, " -o"): a$ = LEFT$(a$, x - 1) + " -lksguid" + RIGHT$(a$, LEN(a$) - x + 1) + END IF a$ = StrRemove(a$, "-ldxguid") - If DEPENDENCY(DEPENDENCY_AUDIO_OUT) Then - x = InStr(a$, " -o"): a$ = Left$(a$, x - 1) + " -ldxguid" + Right$(a$, Len(a$) - x + 1) - End If + IF DEPENDENCY(DEPENDENCY_AUDIO_OUT) THEN + x = INSTR(a$, " -o"): a$ = LEFT$(a$, x - 1) + " -ldxguid" + RIGHT$(a$, LEN(a$) - x + 1) + END IF a$ = StrRemove(a$, "-lole32") - If DEPENDENCY(DEPENDENCY_AUDIO_OUT) Then - x = InStr(a$, " -o"): a$ = Left$(a$, x - 1) + " -lole32" + Right$(a$, Len(a$) - x + 1) - End If + IF DEPENDENCY(DEPENDENCY_AUDIO_OUT) THEN + x = INSTR(a$, " -o"): a$ = LEFT$(a$, x - 1) + " -lole32" + RIGHT$(a$, LEN(a$) - x + 1) + END IF a$ = StrRemove(a$, "-lgdi32") - If DEPENDENCY(DEPENDENCY_ICON) <> 0 Or DEPENDENCY(DEPENDENCY_SCREENIMAGE) <> 0 Or DEPENDENCY(DEPENDENCY_PRINTER) <> 0 Then - x = InStr(a$, " -o"): a$ = Left$(a$, x - 1) + " -lgdi32" + Right$(a$, Len(a$) - x + 1) - End If + IF DEPENDENCY(DEPENDENCY_ICON) <> 0 OR DEPENDENCY(DEPENDENCY_SCREENIMAGE) <> 0 OR DEPENDENCY(DEPENDENCY_PRINTER) <> 0 THEN + x = INSTR(a$, " -o"): a$ = LEFT$(a$, x - 1) + " -lgdi32" + RIGHT$(a$, LEN(a$) - x + 1) + END IF - If inline_DATA = 0 Then + IF inline_DATA = 0 THEN 'add data.o? - If DataOffset Then - x = InStr(a$, ".cpp ") - If x Then + IF DataOffset THEN + x = INSTR(a$, ".cpp ") + IF x THEN x = x + 3 - a$ = Left$(a$, x) + " " + tmpdir2$ + "data.o" + " " + Right$(a$, Len(a$) - x) - End If - End If - End If + a$ = LEFT$(a$, x) + " " + tmpdir2$ + "data.o" + " " + RIGHT$(a$, LEN(a$) - x) + END IF + END IF + END IF 'add custom libraries 'mylib$="..\..\"+x$+".lib" - If Len(mylib$) Then - x = InStr(a$, ".cpp ") - If x Then + IF LEN(mylib$) THEN + x = INSTR(a$, ".cpp ") + IF x THEN x = x + 3 - a$ = Left$(a$, x) + " " + mylib$ + " " + Right$(a$, Len(a$) - x) - End If - End If + a$ = LEFT$(a$, x) + " " + mylib$ + " " + RIGHT$(a$, LEN(a$) - x) + END IF + END IF 'add dependent libraries - If Len(libs$) Then - x = InStr(a$, ".cpp ") - If x Then + IF LEN(libs$) THEN + x = INSTR(a$, ".cpp ") + IF x THEN x = x + 5 - a$ = Left$(a$, x - 1) + libs$ + Right$(a$, Len(a$) - x + 1) - End If - End If + a$ = LEFT$(a$, x - 1) + libs$ + RIGHT$(a$, LEN(a$) - x + 1) + END IF + END IF 'add dependency defines - If Len(defines$) Then - x = InStr(a$, ".cpp ") - If x Then + IF LEN(defines$) THEN + x = INSTR(a$, ".cpp ") + IF x THEN x = x + 5 - a$ = Left$(a$, x - 1) + defines$ + Right$(a$, Len(a$) - x + 1) - End If - End If + a$ = LEFT$(a$, x - 1) + defines$ + RIGHT$(a$, LEN(a$) - x + 1) + END IF + END IF 'add libqb - x = InStr(a$, ".cpp ") - If x Then + x = INSTR(a$, ".cpp ") + IF x THEN x = x + 5 - a$ = Left$(a$, x - 1) + libqb$ + Right$(a$, Len(a$) - x + 1) - End If + a$ = LEFT$(a$, x - 1) + libqb$ + RIGHT$(a$, LEN(a$) - x + 1) + END IF 'Add icon.o to the makeline - If ExeIconSet Or VersionInfoSet Then - If x Then 'Use the previous libqb insertion point - a$ = Left$(a$, x + Len(libqb$)) + "..\..\" + tmpdir$ + "icon.o " + Mid$(a$, x + Len(libqb$) + 1) - End If - End If + IF ExeIconSet OR VersionInfoSet THEN + IF x THEN 'Use the previous libqb insertion point + a$ = LEFT$(a$, x + LEN(libqb$)) + "..\..\" + tmpdir$ + "icon.o " + MID$(a$, x + LEN(libqb$) + 1) + END IF + END IF a$ = a$ + QuotedFilename$(path.exe$ + file$ + extension$) - ffh = FreeFile - Open tmpdir$ + "recompile_win.bat" For Output As #ffh - Print #ffh, "@echo off" - Print #ffh, "cd %0\..\" - Print #ffh, "echo Recompiling..." - Print #ffh, "cd ../c" - Print #ffh, a$ - Print #ffh, "pause" - Close ffh + ffh = FREEFILE + OPEN tmpdir$ + "recompile_win.bat" FOR OUTPUT AS #ffh + PRINT #ffh, "@echo off" + PRINT #ffh, "cd %0\..\" + PRINT #ffh, "echo Recompiling..." + PRINT #ffh, "cd ../c" + PRINT #ffh, a$ + PRINT #ffh, "pause" + CLOSE ffh - ffh = FreeFile - Open tmpdir$ + "debug_win.bat" For Output As #ffh - Print #ffh, "@echo off" - Print #ffh, "cd %0\..\" - Print #ffh, "cd ../.." - Print #ffh, "echo C++ Debugging: " + file$ + extension$ + " using gdb.exe" - Print #ffh, "echo Debugger commands:" - Print #ffh, "echo After the debugger launches type 'run' to start your program" - Print #ffh, "echo After your program crashes type 'list' to find where the problem is and fix/report it" - Print #ffh, "echo Type 'quit' to exit" - Print #ffh, "echo (the GDB debugger has many other useful commands, this advice is for beginners)" - Print #ffh, "pause" - Print #ffh, "internal\c\c_compiler\bin\gdb.exe " + Chr$(34) + path.exe$ + file$ + extension$ + Chr$(34) - Print #ffh, "pause" - Close ffh + ffh = FREEFILE + OPEN tmpdir$ + "debug_win.bat" FOR OUTPUT AS #ffh + PRINT #ffh, "@echo off" + PRINT #ffh, "cd %0\..\" + PRINT #ffh, "cd ../.." + PRINT #ffh, "echo C++ Debugging: " + file$ + extension$ + " using gdb.exe" + PRINT #ffh, "echo Debugger commands:" + PRINT #ffh, "echo After the debugger launches type 'run' to start your program" + PRINT #ffh, "echo After your program crashes type 'list' to find where the problem is and fix/report it" + PRINT #ffh, "echo Type 'quit' to exit" + PRINT #ffh, "echo (the GDB debugger has many other useful commands, this advice is for beginners)" + PRINT #ffh, "pause" + PRINT #ffh, "internal\c\c_compiler\bin\gdb.exe " + CHR$(34) + path.exe$ + file$ + extension$ + CHR$(34) + PRINT #ffh, "pause" + CLOSE ffh - If No_C_Compile_Mode = 0 Then - ChDir ".\internal\c" - Shell _Hide "cmd /c " + a$ + " 2>> ..\..\" + compilelog$ - ChDir "..\.." - If idemode Then + IF No_C_Compile_Mode = 0 THEN + CHDIR ".\internal\c" + SHELL _HIDE "cmd /c " + a$ + " 2>> ..\..\" + compilelog$ + CHDIR "..\.." + IF idemode THEN 'Restore fg/bg colors dummy = DarkenFGBG(0) - End If - End If 'No_C_Compile_Mode=0 + END IF + END IF 'No_C_Compile_Mode=0 -End If +END IF -If os$ = "LNX" Then - For x = 1 To ResolveStaticFunctions - If Len(ResolveStaticFunction_File(x)) Then +IF os$ = "LNX" THEN + FOR x = 1 TO ResolveStaticFunctions + IF LEN(ResolveStaticFunction_File(x)) THEN n = 0 - If MacOSX = 0 Then Shell _Hide "nm " + Chr$(34) + ResolveStaticFunction_File(x) + Chr$(34) + " --demangle -g >./internal/temp/nm_output.txt 2>./internal/temp/nm_error.txt" - If MacOSX Then Shell _Hide "nm " + Chr$(34) + ResolveStaticFunction_File(x) + Chr$(34) + " >./internal/temp/nm_output.txt 2>./internal/temp/nm_error.txt" + IF MacOSX = 0 THEN SHELL _HIDE "nm " + CHR$(34) + ResolveStaticFunction_File(x) + CHR$(34) + " --demangle -g >./internal/temp/nm_output.txt 2>./internal/temp/nm_error.txt" + IF MacOSX THEN SHELL _HIDE "nm " + CHR$(34) + ResolveStaticFunction_File(x) + CHR$(34) + " >./internal/temp/nm_output.txt 2>./internal/temp/nm_error.txt" - If MacOSX = 0 Then 'C++ name demangling not supported in MacOSX - fh = FreeFile + IF MacOSX = 0 THEN 'C++ name demangling not supported in MacOSX + fh = FREEFILE s$ = " " + ResolveStaticFunction_Name(x) + "(" - Open "internal\temp\nm_output.txt" For Binary As #fh - Do Until EOF(fh) - Line Input #fh, a$ - If Len(a$) Then + OPEN "internal\temp\nm_output.txt" FOR BINARY AS #fh + DO UNTIL EOF(fh) + LINE INPUT #fh, a$ + IF LEN(a$) THEN 'search for SPACE+functionname+LEFTBRACKET - x1 = InStr(a$, s$) - If x1 Then - If ResolveStaticFunction_Method(x) = 1 Then + x1 = INSTR(a$, s$) + IF x1 THEN + IF ResolveStaticFunction_Method(x) = 1 THEN x1 = x1 + 1 - x2 = InStr(x1, a$, ")") - fh2 = FreeFile - Open tmpdir$ + "global.txt" For Append As #fh2 - Print #fh2, "extern void " + Mid$(a$, x1, x2 - x1 + 1) + ";" - Close #fh2 - End If + x2 = INSTR(x1, a$, ")") + fh2 = FREEFILE + OPEN tmpdir$ + "global.txt" FOR APPEND AS #fh2 + PRINT #fh2, "extern void " + MID$(a$, x1, x2 - x1 + 1) + ";" + CLOSE #fh2 + END IF n = n + 1 - End If 'x1 - End If '<>"" - Loop - Close #fh - If n > 1 Then a$ = "Unable to resolve multiple instances of sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GoTo errmes - End If 'macosx=0 + END IF 'x1 + END IF '<>"" + LOOP + CLOSE #fh + IF n > 1 THEN a$ = "Unable to resolve multiple instances of sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GOTO errmes + END IF 'macosx=0 - If n = 0 Then 'attempt to locate simple function name without brackets - fh = FreeFile + IF n = 0 THEN 'attempt to locate simple function name without brackets + fh = FREEFILE s$ = " " + ResolveStaticFunction_Name(x): s2$ = s$ - If MacOSX Then s$ = " _" + ResolveStaticFunction_Name(x) 'search for C mangled name - Open "internal\temp\nm_output.txt" For Binary As #fh - Do Until EOF(fh) - Line Input #fh, a$ - If Len(a$) Then + IF MacOSX THEN s$ = " _" + ResolveStaticFunction_Name(x) 'search for C mangled name + OPEN "internal\temp\nm_output.txt" FOR BINARY AS #fh + DO UNTIL EOF(fh) + LINE INPUT #fh, a$ + IF LEN(a$) THEN 'search for SPACE+functionname - x1 = InStr(a$, s$) - If Right$(a$, Len(s$)) = s$ Then - fh2 = FreeFile - If ResolveStaticFunction_Method(x) = 1 Then - Open tmpdir$ + "global.txt" For Append As #fh2 - Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + "{" - Print #fh2, "extern void " + s2$ + "(void);" - Print #fh2, "}" - Else - Open tmpdir$ + "externtype" + str2(x) + ".txt" For Output As #fh2 - Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + " " - End If - Close #fh2 + x1 = INSTR(a$, s$) + IF RIGHT$(a$, LEN(s$)) = s$ THEN + fh2 = FREEFILE + IF ResolveStaticFunction_Method(x) = 1 THEN + OPEN tmpdir$ + "global.txt" FOR APPEND AS #fh2 + PRINT #fh2, "extern " + CHR$(34) + "C" + CHR$(34) + "{" + PRINT #fh2, "extern void " + s2$ + "(void);" + PRINT #fh2, "}" + ELSE + OPEN tmpdir$ + "externtype" + str2(x) + ".txt" FOR OUTPUT AS #fh2 + PRINT #fh2, "extern " + CHR$(34) + "C" + CHR$(34) + " " + END IF + CLOSE #fh2 n = n + 1 - Exit Do - End If 'x1 - End If '<>"" - Loop - Close #fh - End If + EXIT DO + END IF 'x1 + END IF '<>"" + LOOP + CLOSE #fh + END IF - If n = 0 Then 'a C++ dynamic object library? - If MacOSX Then GoTo macosx_libfind_failed - Shell _Hide "nm " + Chr$(34) + ResolveStaticFunction_File(x) + Chr$(34) + " -D --demangle -g >./internal/temp/nm_output_dynamic.txt 2>./internal/temp/nm_error.txt" - fh = FreeFile + IF n = 0 THEN 'a C++ dynamic object library? + IF MacOSX THEN GOTO macosx_libfind_failed + SHELL _HIDE "nm " + CHR$(34) + ResolveStaticFunction_File(x) + CHR$(34) + " -D --demangle -g >./internal/temp/nm_output_dynamic.txt 2>./internal/temp/nm_error.txt" + fh = FREEFILE s$ = " " + ResolveStaticFunction_Name(x) + "(" - Open "internal\temp\nm_output_dynamic.txt" For Binary As #fh - Do Until EOF(fh) - Line Input #fh, a$ - If Len(a$) Then + OPEN "internal\temp\nm_output_dynamic.txt" FOR BINARY AS #fh + DO UNTIL EOF(fh) + LINE INPUT #fh, a$ + IF LEN(a$) THEN 'search for SPACE+functionname+LEFTBRACKET - x1 = InStr(a$, s$) - If x1 Then - If ResolveStaticFunction_Method(x) = 1 Then + x1 = INSTR(a$, s$) + IF x1 THEN + IF ResolveStaticFunction_Method(x) = 1 THEN x1 = x1 + 1 - x2 = InStr(x1, a$, ")") - fh2 = FreeFile - Open tmpdir$ + "global.txt" For Append As #fh2 - Print #fh2, "extern void " + Mid$(a$, x1, x2 - x1 + 1) + ";" - Close #fh2 - End If + x2 = INSTR(x1, a$, ")") + fh2 = FREEFILE + OPEN tmpdir$ + "global.txt" FOR APPEND AS #fh2 + PRINT #fh2, "extern void " + MID$(a$, x1, x2 - x1 + 1) + ";" + CLOSE #fh2 + END IF n = n + 1 - End If 'x1 - End If '<>"" - Loop - Close #fh - If n > 1 Then a$ = "Unable to resolve multiple instances of sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GoTo errmes - End If + END IF 'x1 + END IF '<>"" + LOOP + CLOSE #fh + IF n > 1 THEN a$ = "Unable to resolve multiple instances of sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GOTO errmes + END IF - If n = 0 Then 'a C dynamic object library? - fh = FreeFile + IF n = 0 THEN 'a C dynamic object library? + fh = FREEFILE s$ = " " + ResolveStaticFunction_Name(x) - Open "internal\temp\nm_output_dynamic.txt" For Binary As #fh - Do Until EOF(fh) - Line Input #fh, a$ - If Len(a$) Then + OPEN "internal\temp\nm_output_dynamic.txt" FOR BINARY AS #fh + DO UNTIL EOF(fh) + LINE INPUT #fh, a$ + IF LEN(a$) THEN 'search for SPACE+functionname - x1 = InStr(a$, s$) - If Right$(a$, Len(s$)) = s$ Then - fh2 = FreeFile - If ResolveStaticFunction_Method(x) = 1 Then - Open tmpdir$ + "global.txt" For Append As #fh2 - Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + "{" - Print #fh2, "extern void " + s$ + "(void);" - Print #fh2, "}" - Else - Open tmpdir$ + "externtype" + str2(x) + ".txt" For Output As #fh2 - Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + " " - End If - Close #fh2 + x1 = INSTR(a$, s$) + IF RIGHT$(a$, LEN(s$)) = s$ THEN + fh2 = FREEFILE + IF ResolveStaticFunction_Method(x) = 1 THEN + OPEN tmpdir$ + "global.txt" FOR APPEND AS #fh2 + PRINT #fh2, "extern " + CHR$(34) + "C" + CHR$(34) + "{" + PRINT #fh2, "extern void " + s$ + "(void);" + PRINT #fh2, "}" + ELSE + OPEN tmpdir$ + "externtype" + str2(x) + ".txt" FOR OUTPUT AS #fh2 + PRINT #fh2, "extern " + CHR$(34) + "C" + CHR$(34) + " " + END IF + CLOSE #fh2 n = n + 1 - Exit Do - End If 'x1 - End If '<>"" - Loop - Close #fh + EXIT DO + END IF 'x1 + END IF '<>"" + LOOP + CLOSE #fh macosx_libfind_failed: - If n = 0 Then a$ = "Could not find sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GoTo errmes - End If + IF n = 0 THEN a$ = "Could not find sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GOTO errmes + END IF - End If - Next + END IF + NEXT - If inline_DATA = 0 Then - If DataOffset Then - If InStr(_OS$, "[32BIT]") Then b$ = "32" Else b$ = "64" - Open ".\internal\c\makedat_lnx" + b$ + ".txt" For Binary As #150: Line Input #150, a$: Close #150 + IF inline_DATA = 0 THEN + IF DataOffset THEN + IF INSTR(_OS$, "[32BIT]") THEN b$ = "32" ELSE b$ = "64" + OPEN ".\internal\c\makedat_lnx" + b$ + ".txt" FOR BINARY AS #150: LINE INPUT #150, a$: CLOSE #150 a$ = a$ + " " + tmpdir2$ + "data.bin " + tmpdir2$ + "data.o" - ChDir ".\internal\c" - Shell _Hide a$ + " 2>> ../../" + compilelog$ - ChDir "..\.." - End If - End If + CHDIR ".\internal\c" + SHELL _HIDE a$ + " 2>> ../../" + compilelog$ + CHDIR "..\.." + END IF + END IF - If InStr(_OS$, "[MACOSX]") Then - Open "./internal/c/makeline_osx.txt" For Input As #150 - ElseIf DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) Then - Open "./internal/c/makeline_lnx_nogui.txt" For Input As #150 - Else - Open "./internal/c/makeline_lnx.txt" For Input As #150 - End If + IF INSTR(_OS$, "[MACOSX]") THEN + OPEN "./internal/c/makeline_osx.txt" FOR INPUT AS #150 + ELSEIF DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) THEN + OPEN "./internal/c/makeline_lnx_nogui.txt" FOR INPUT AS #150 + ELSE + OPEN "./internal/c/makeline_lnx.txt" FOR INPUT AS #150 + END IF - Line Input #150, a$: a$ = GDB_Fix(a$) - Close #150 + LINE INPUT #150, a$: a$ = GDB_Fix(a$) + CLOSE #150 'change qbx.cpp to qbx999.cpp? - x = InStr(a$, "qbx.cpp"): If x <> 0 And tempfolderindex <> 1 Then a$ = Left$(a$, x - 1) + "qbx" + str2$(tempfolderindex) + ".cpp" + Right$(a$, Len(a$) - (x + 6)) + x = INSTR(a$, "qbx.cpp"): IF x <> 0 AND tempfolderindex <> 1 THEN a$ = LEFT$(a$, x - 1) + "qbx" + str2$(tempfolderindex) + ".cpp" + RIGHT$(a$, LEN(a$) - (x + 6)) - If inline_DATA = 0 Then + IF inline_DATA = 0 THEN 'add data.o? - If DataOffset Then - x = InStr(a$, "-lX11") - If x Then - a$ = Left$(a$, x - 1) + " " + tmpdir2$ + "data.o " + Right$(a$, Len(a$) - x + 1) - End If - End If - End If + IF DataOffset THEN + x = INSTR(a$, "-lX11") + IF x THEN + a$ = LEFT$(a$, x - 1) + " " + tmpdir2$ + "data.o " + RIGHT$(a$, LEN(a$) - x + 1) + END IF + END IF + END IF 'add custom libraries - If Len(mylib$) Then - x = InStr(a$, ".cpp ") - If x Then + IF LEN(mylib$) THEN + x = INSTR(a$, ".cpp ") + IF x THEN x = x + 5 - a$ = Left$(a$, x - 1) + " " + mylibopt$ + " " + mylib$ + " " + Right$(a$, Len(a$) - x + 1) - End If - End If + a$ = LEFT$(a$, x - 1) + " " + mylibopt$ + " " + mylib$ + " " + RIGHT$(a$, LEN(a$) - x + 1) + END IF + END IF 'add dependent libraries - If Len(libs$) Then - x = InStr(a$, ".cpp ") - If x Then + IF LEN(libs$) THEN + x = INSTR(a$, ".cpp ") + IF x THEN x = x + 5 - a$ = Left$(a$, x - 1) + libs$ + Right$(a$, Len(a$) - x + 1) - End If - End If + a$ = LEFT$(a$, x - 1) + libs$ + RIGHT$(a$, LEN(a$) - x + 1) + END IF + END IF 'add dependency defines - If Len(defines$) Then - x = InStr(a$, ".cpp ") - If x Then + IF LEN(defines$) THEN + x = INSTR(a$, ".cpp ") + IF x THEN x = x + 5 - a$ = Left$(a$, x - 1) + defines$ + Right$(a$, Len(a$) - x + 1) - End If - End If + a$ = LEFT$(a$, x - 1) + defines$ + RIGHT$(a$, LEN(a$) - x + 1) + END IF + END IF 'add libqb - x = InStr(a$, ".cpp ") - If x Then + x = INSTR(a$, ".cpp ") + IF x THEN x = x + 5 - a$ = Left$(a$, x - 1) + libqb$ + Right$(a$, Len(a$) - x + 1) - End If + a$ = LEFT$(a$, x - 1) + libqb$ + RIGHT$(a$, LEN(a$) - x + 1) + END IF @@ -12672,131 +12672,131 @@ If os$ = "LNX" Then a$ = a$ + QuotedFilename$(path.exe$ + file$ + extension$) - If InStr(_OS$, "[MACOSX]") Then + IF INSTR(_OS$, "[MACOSX]") THEN - ffh = FreeFile - Open tmpdir$ + "recompile_osx.command" For Output As #ffh - Print #ffh, "cd " + CHR_QUOTE + "$(dirname " + CHR_QUOTE + "$0" + CHR_QUOTE + ")" + CHR_QUOTE + Chr$(10); - Print #ffh, "echo " + CHR_QUOTE + "Recompiling..." + CHR_QUOTE + Chr$(10); - Print #ffh, "cd ../c" + Chr$(10); - Print #ffh, a$ + Chr$(10); - Print #ffh, "read -p " + CHR_QUOTE + "Press ENTER to exit..." + CHR_QUOTE + Chr$(10); - Close ffh - Shell _Hide "chmod +x " + tmpdir$ + "recompile_osx.command" + ffh = FREEFILE + OPEN tmpdir$ + "recompile_osx.command" FOR OUTPUT AS #ffh + PRINT #ffh, "cd " + CHR_QUOTE + "$(dirname " + CHR_QUOTE + "$0" + CHR_QUOTE + ")" + CHR_QUOTE + CHR$(10); + PRINT #ffh, "echo " + CHR_QUOTE + "Recompiling..." + CHR_QUOTE + CHR$(10); + PRINT #ffh, "cd ../c" + CHR$(10); + PRINT #ffh, a$ + CHR$(10); + PRINT #ffh, "read -p " + CHR_QUOTE + "Press ENTER to exit..." + CHR_QUOTE + CHR$(10); + CLOSE ffh + SHELL _HIDE "chmod +x " + tmpdir$ + "recompile_osx.command" - ffh = FreeFile - Open tmpdir$ + "debug_osx.command" For Output As #ffh - Print #ffh, "cd " + CHR_QUOTE + "$(dirname " + CHR_QUOTE + "$0" + CHR_QUOTE + ")" + CHR_QUOTE + Chr$(10); - Print #ffh, "Pause()" + Chr$(10); - Print #ffh, "{" + Chr$(10); - Print #ffh, "OLDCONFIG=`stty -g`" + Chr$(10); - Print #ffh, "stty -icanon -echo min 1 time 0" + Chr$(10); - Print #ffh, "dd count=1 2>/dev/null" + Chr$(10); - Print #ffh, "stty $OLDCONFIG" + Chr$(10); - Print #ffh, "}" + Chr$(10); - Print #ffh, "echo " + CHR_QUOTE + "C++ Debugging: " + file$ + extension$ + " using GDB" + CHR_QUOTE + Chr$(10); - Print #ffh, "echo " + CHR_QUOTE + "Debugger commands:" + CHR_QUOTE + Chr$(10); - Print #ffh, "echo " + CHR_QUOTE + "After the debugger launches type 'run' to start your program" + CHR_QUOTE + Chr$(10); - Print #ffh, "echo " + CHR_QUOTE + "After your program crashes type 'list' to find where the problem is and fix/report it" + CHR_QUOTE + Chr$(10); - Print #ffh, "echo " + CHR_QUOTE + "(the GDB debugger has many other useful commands, this advice is for beginners)" + CHR_QUOTE + Chr$(10); - Print #ffh, "gdb " + Chr$(34) + path.exe$ + file$ + extension$ + Chr$(34) + Chr$(10); - Print #ffh, "Pause" + Chr$(10); - Close ffh - Shell _Hide "chmod +x " + tmpdir$ + "debug_osx.command" + ffh = FREEFILE + OPEN tmpdir$ + "debug_osx.command" FOR OUTPUT AS #ffh + PRINT #ffh, "cd " + CHR_QUOTE + "$(dirname " + CHR_QUOTE + "$0" + CHR_QUOTE + ")" + CHR_QUOTE + CHR$(10); + PRINT #ffh, "Pause()" + CHR$(10); + PRINT #ffh, "{" + CHR$(10); + PRINT #ffh, "OLDCONFIG=`stty -g`" + CHR$(10); + PRINT #ffh, "stty -icanon -echo min 1 time 0" + CHR$(10); + PRINT #ffh, "dd count=1 2>/dev/null" + CHR$(10); + PRINT #ffh, "stty $OLDCONFIG" + CHR$(10); + PRINT #ffh, "}" + CHR$(10); + PRINT #ffh, "echo " + CHR_QUOTE + "C++ Debugging: " + file$ + extension$ + " using GDB" + CHR_QUOTE + CHR$(10); + PRINT #ffh, "echo " + CHR_QUOTE + "Debugger commands:" + CHR_QUOTE + CHR$(10); + PRINT #ffh, "echo " + CHR_QUOTE + "After the debugger launches type 'run' to start your program" + CHR_QUOTE + CHR$(10); + PRINT #ffh, "echo " + CHR_QUOTE + "After your program crashes type 'list' to find where the problem is and fix/report it" + CHR_QUOTE + CHR$(10); + PRINT #ffh, "echo " + CHR_QUOTE + "(the GDB debugger has many other useful commands, this advice is for beginners)" + CHR_QUOTE + CHR$(10); + PRINT #ffh, "gdb " + CHR$(34) + path.exe$ + file$ + extension$ + CHR$(34) + CHR$(10); + PRINT #ffh, "Pause" + CHR$(10); + CLOSE ffh + SHELL _HIDE "chmod +x " + tmpdir$ + "debug_osx.command" - Else + ELSE - ffh = FreeFile - Open tmpdir$ + "recompile_lnx.sh" For Output As #ffh - Print #ffh, "#!/bin/sh" + Chr$(10); - Print #ffh, "Pause()" + Chr$(10); - Print #ffh, "{" + Chr$(10); - Print #ffh, "OLDCONFIG=`stty -g`" + Chr$(10); - Print #ffh, "stty -icanon -echo min 1 time 0" + Chr$(10); - Print #ffh, "dd count=1 2>/dev/null" + Chr$(10); - Print #ffh, "stty $OLDCONFIG" + Chr$(10); - Print #ffh, "}" + Chr$(10); - Print #ffh, "echo " + CHR_QUOTE + "Recompiling..." + CHR_QUOTE + Chr$(10); - Print #ffh, "cd ../c" + Chr$(10); - Print #ffh, a$ + Chr$(10); - Print #ffh, "echo " + CHR_QUOTE + "Press ENTER to exit..." + CHR_QUOTE + Chr$(10); - Print #ffh, "Pause" + Chr$(10); - Close ffh - Shell _Hide "chmod +x " + tmpdir$ + "recompile_lnx.sh" + ffh = FREEFILE + OPEN tmpdir$ + "recompile_lnx.sh" FOR OUTPUT AS #ffh + PRINT #ffh, "#!/bin/sh" + CHR$(10); + PRINT #ffh, "Pause()" + CHR$(10); + PRINT #ffh, "{" + CHR$(10); + PRINT #ffh, "OLDCONFIG=`stty -g`" + CHR$(10); + PRINT #ffh, "stty -icanon -echo min 1 time 0" + CHR$(10); + PRINT #ffh, "dd count=1 2>/dev/null" + CHR$(10); + PRINT #ffh, "stty $OLDCONFIG" + CHR$(10); + PRINT #ffh, "}" + CHR$(10); + PRINT #ffh, "echo " + CHR_QUOTE + "Recompiling..." + CHR_QUOTE + CHR$(10); + PRINT #ffh, "cd ../c" + CHR$(10); + PRINT #ffh, a$ + CHR$(10); + PRINT #ffh, "echo " + CHR_QUOTE + "Press ENTER to exit..." + CHR_QUOTE + CHR$(10); + PRINT #ffh, "Pause" + CHR$(10); + CLOSE ffh + SHELL _HIDE "chmod +x " + tmpdir$ + "recompile_lnx.sh" - ffh = FreeFile - Open tmpdir$ + "debug_lnx.sh" For Output As #ffh - Print #ffh, "#!/bin/sh" + Chr$(10); - Print #ffh, "Pause()" + Chr$(10); - Print #ffh, "{" + Chr$(10); - Print #ffh, "OLDCONFIG=`stty -g`" + Chr$(10); - Print #ffh, "stty -icanon -echo min 1 time 0" + Chr$(10); - Print #ffh, "dd count=1 2>/dev/null" + Chr$(10); - Print #ffh, "stty $OLDCONFIG" + Chr$(10); - Print #ffh, "}" + Chr$(10); - Print #ffh, "echo " + CHR_QUOTE + "C++ Debugging: " + file$ + extension$ + " using GDB" + CHR_QUOTE + Chr$(10); - Print #ffh, "echo " + CHR_QUOTE + "Debugger commands:" + CHR_QUOTE + Chr$(10); - Print #ffh, "echo " + CHR_QUOTE + "After the debugger launches type 'run' to start your program" + CHR_QUOTE + Chr$(10); - Print #ffh, "echo " + CHR_QUOTE + "After your program crashes type 'list' to find where the problem is and fix/report it" + CHR_QUOTE + Chr$(10); - Print #ffh, "echo " + CHR_QUOTE + "(the GDB debugger has many other useful commands, this advice is for beginners)" + CHR_QUOTE + Chr$(10); - Print #ffh, "gdb " + Chr$(34) + path.exe$ + file$ + extension$ + Chr$(34) + Chr$(10); - Print #ffh, "Pause" + Chr$(10); - Close ffh - Shell _Hide "chmod +x " + tmpdir$ + "debug_lnx.sh" + ffh = FREEFILE + OPEN tmpdir$ + "debug_lnx.sh" FOR OUTPUT AS #ffh + PRINT #ffh, "#!/bin/sh" + CHR$(10); + PRINT #ffh, "Pause()" + CHR$(10); + PRINT #ffh, "{" + CHR$(10); + PRINT #ffh, "OLDCONFIG=`stty -g`" + CHR$(10); + PRINT #ffh, "stty -icanon -echo min 1 time 0" + CHR$(10); + PRINT #ffh, "dd count=1 2>/dev/null" + CHR$(10); + PRINT #ffh, "stty $OLDCONFIG" + CHR$(10); + PRINT #ffh, "}" + CHR$(10); + PRINT #ffh, "echo " + CHR_QUOTE + "C++ Debugging: " + file$ + extension$ + " using GDB" + CHR_QUOTE + CHR$(10); + PRINT #ffh, "echo " + CHR_QUOTE + "Debugger commands:" + CHR_QUOTE + CHR$(10); + PRINT #ffh, "echo " + CHR_QUOTE + "After the debugger launches type 'run' to start your program" + CHR_QUOTE + CHR$(10); + PRINT #ffh, "echo " + CHR_QUOTE + "After your program crashes type 'list' to find where the problem is and fix/report it" + CHR_QUOTE + CHR$(10); + PRINT #ffh, "echo " + CHR_QUOTE + "(the GDB debugger has many other useful commands, this advice is for beginners)" + CHR_QUOTE + CHR$(10); + PRINT #ffh, "gdb " + CHR$(34) + path.exe$ + file$ + extension$ + CHR$(34) + CHR$(10); + PRINT #ffh, "Pause" + CHR$(10); + CLOSE ffh + SHELL _HIDE "chmod +x " + tmpdir$ + "debug_lnx.sh" - End If + END IF - If No_C_Compile_Mode = 0 Then - ChDir "./internal/c" - Shell _Hide a$ + " 2>> ../../" + compilelog$ - ChDir "../.." - If idemode Then + IF No_C_Compile_Mode = 0 THEN + CHDIR "./internal/c" + SHELL _HIDE a$ + " 2>> ../../" + compilelog$ + CHDIR "../.." + IF idemode THEN 'Restore fg/bg colors dummy = DarkenFGBG(0) - End If - End If + END IF + END IF - If InStr(_OS$, "[MACOSX]") Then - ff = FreeFile - If path.exe$ = "./" Or path.exe$ = "../../" Or path.exe$ = "..\..\" Then path.exe$ = "" - Open path.exe$ + file$ + extension$ + "_start.command" For Output As #ff - Print #ff, "cd " + Chr$(34) + "$(dirname " + Chr$(34) + "$0" + Chr$(34) + ")" + Chr$(34); - Print #ff, Chr$(10); - Print #ff, "./" + file$ + extension$ + " &"; - Print #ff, Chr$(10); - Print #ff, "osascript -e 'tell application " + Chr$(34) + "Terminal" + Chr$(34) + " to close (every window whose name contains " + Chr$(34) + file$ + extension$ + "_start.command" + Chr$(34) + ")' &"; - Print #ff, Chr$(10); - Print #ff, "osascript -e 'if (count the windows of application " + Chr$(34) + "Terminal" + Chr$(34) + ") is 0 then tell application " + Chr$(34) + "Terminal" + Chr$(34) + " to quit' &"; - Print #ff, Chr$(10); - Print #ff, "exit"; - Print #ff, Chr$(10); - Close #ff - Shell _Hide "chmod +x " + path.exe$ + file$ + extension$ + "_start.command" - End If + IF INSTR(_OS$, "[MACOSX]") THEN + ff = FREEFILE + IF path.exe$ = "./" OR path.exe$ = "../../" OR path.exe$ = "..\..\" THEN path.exe$ = "" + OPEN path.exe$ + file$ + extension$ + "_start.command" FOR OUTPUT AS #ff + PRINT #ff, "cd " + CHR$(34) + "$(dirname " + CHR$(34) + "$0" + CHR$(34) + ")" + CHR$(34); + PRINT #ff, CHR$(10); + PRINT #ff, "./" + file$ + extension$ + " &"; + PRINT #ff, CHR$(10); + PRINT #ff, "osascript -e 'tell application " + CHR$(34) + "Terminal" + CHR$(34) + " to close (every window whose name contains " + CHR$(34) + file$ + extension$ + "_start.command" + CHR$(34) + ")' &"; + PRINT #ff, CHR$(10); + PRINT #ff, "osascript -e 'if (count the windows of application " + CHR$(34) + "Terminal" + CHR$(34) + ") is 0 then tell application " + CHR$(34) + "Terminal" + CHR$(34) + " to quit' &"; + PRINT #ff, CHR$(10); + PRINT #ff, "exit"; + PRINT #ff, CHR$(10); + CLOSE #ff + SHELL _HIDE "chmod +x " + path.exe$ + file$ + extension$ + "_start.command" + END IF -End If +END IF -If No_C_Compile_Mode Then compfailed = 0: GoTo No_C_Compile -If path.exe$ = "../../" Or path.exe$ = "..\..\" Then path.exe$ = "" -If _FileExists(path.exe$ + file$ + extension$) Then +IF No_C_Compile_Mode THEN compfailed = 0: GOTO No_C_Compile +IF path.exe$ = "../../" OR path.exe$ = "..\..\" THEN path.exe$ = "" +IF _FILEEXISTS(path.exe$ + file$ + extension$) THEN compfailed = 0 lastBinaryGenerated$ = path.exe$ + file$ + extension$ -Else +ELSE compfailed = 1 'detect compilation failure -End If +END IF -If compfailed Then - If idemode Then - idemessage$ = "C++ Compilation failed (Check " + Chr$(0) + compilelog$ + Chr$(0) + ")" - GoTo ideerror - End If - If compfailed Then - Print "ERROR: C++ compilation failed." - Print "Check " + compilelog$ + " for details." - End If -Else - If idemode = 0 And Not QuietMode Then Print "Output: "; lastBinaryGenerated$ -End If +IF compfailed THEN + IF idemode THEN + idemessage$ = "C++ Compilation failed (Check " + CHR$(0) + compilelog$ + CHR$(0) + ")" + GOTO ideerror + END IF + IF compfailed THEN + PRINT "ERROR: C++ compilation failed." + PRINT "Check " + compilelog$ + " for details." + END IF +ELSE + IF idemode = 0 AND NOT QuietMode THEN PRINT "Output: "; lastBinaryGenerated$ +END IF @@ -12804,338 +12804,338 @@ Skip_Build: -If idemode Then GoTo ideret6 +IF idemode THEN GOTO ideret6 No_C_Compile: -If (compfailed <> 0 Or warningsissued <> 0) And ConsoleMode = 0 Then End 1 -If compfailed <> 0 Then System 1 -System 0 +IF (compfailed <> 0 OR warningsissued <> 0) AND ConsoleMode = 0 THEN END 1 +IF compfailed <> 0 THEN SYSTEM 1 +SYSTEM 0 qberror_test: E = 1 -Resume Next +RESUME NEXT qberror: -If Debug Then 'A more in-your-face error handler - If ConsoleMode Then - Print - Else - _AutoDisplay - Screen _NewImage(80, 25, 0), , 0, 0 - Color 7, 0 - End If - _ControlChr Off - Print "A QB error has occurred (and you have compiled in debugging support)." - Print "Some key information (qb64.bas):" - Print "Error"; Err - Print "Description: "; _ErrorMessage$ - Print "Line"; _ErrorLine - If _InclErrorLine Then - Print "Included line"; _InclErrorLine - Print "Included file "; _InclErrorFile$ - End If - Print - Print "Loaded source file details:" - Print "ideerror ="; ideerror; "qberrorhappened ="; qberrorhappened; "qberrorhappenedvalue ="; qberrorhappenedvalue; "linenumber ="; linenumber - Print "ca$ = {"; ca$; "}, idecommand$ = {"; idecommand$; "}" - Print "linefragment = {"; linefragment; "}" - End -End If +IF Debug THEN 'A more in-your-face error handler + IF ConsoleMode THEN + PRINT + ELSE + _AUTODISPLAY + SCREEN _NEWIMAGE(80, 25, 0), , 0, 0 + COLOR 7, 0 + END IF + _CONTROLCHR OFF + PRINT "A QB error has occurred (and you have compiled in debugging support)." + PRINT "Some key information (qb64.bas):" + PRINT "Error"; ERR + PRINT "Description: "; _ERRORMESSAGE$ + PRINT "Line"; _ERRORLINE + IF _INCLERRORLINE THEN + PRINT "Included line"; _INCLERRORLINE + PRINT "Included file "; _INCLERRORFILE$ + END IF + PRINT + PRINT "Loaded source file details:" + PRINT "ideerror ="; ideerror; "qberrorhappened ="; qberrorhappened; "qberrorhappenedvalue ="; qberrorhappenedvalue; "linenumber ="; linenumber + PRINT "ca$ = {"; ca$; "}, idecommand$ = {"; idecommand$; "}" + PRINT "linefragment = {"; linefragment; "}" + END +END IF -If ideerror Then 'error happened inside the IDE - fh = FreeFile - Open "internal\temp\ideerror.txt" For Output As #fh - Print #fh, Err - Print #fh, _ErrorMessage$ - Print #fh, _ErrorLine - Print #fh, _InclErrorLine - Print #fh, _InclErrorFile$ - Close #fh - sendc$ = Chr$(255) 'a runtime error has occurred - Resume sendcommand 'allow IDE to handle error recovery -End If +IF ideerror THEN 'error happened inside the IDE + fh = FREEFILE + OPEN "internal\temp\ideerror.txt" FOR OUTPUT AS #fh + PRINT #fh, ERR + PRINT #fh, _ERRORMESSAGE$ + PRINT #fh, _ERRORLINE + PRINT #fh, _INCLERRORLINE + PRINT #fh, _INCLERRORFILE$ + CLOSE #fh + sendc$ = CHR$(255) 'a runtime error has occurred + RESUME sendcommand 'allow IDE to handle error recovery +END IF qberrorhappenedvalue = qberrorhappened qberrorhappened = 1 -If Debug Then Print #9, "QB ERROR!" -If Debug Then Print #9, "ERR="; Err -If Debug Then Print #9, "ERL="; Erl +IF Debug THEN PRINT #9, "QB ERROR!" +IF Debug THEN PRINT #9, "ERR="; ERR +IF Debug THEN PRINT #9, "ERL="; ERL -If idemode And qberrorhappenedvalue >= 0 Then +IF idemode AND qberrorhappenedvalue >= 0 THEN 'real qb error occurred ideerrorline = linenumber - idemessage$ = "Compiler error (check for syntax errors) (" + _ErrorMessage$ + ":" - If Err Then idemessage$ = idemessage$ + str2$(Err) + "-" - If _ErrorLine Then idemessage$ = idemessage$ + str2$(_ErrorLine) - If _InclErrorLine Then idemessage$ = idemessage$ + "-" + _InclErrorFile$ + "-" + str2$(_InclErrorLine) + idemessage$ = "Compiler error (check for syntax errors) (" + _ERRORMESSAGE$ + ":" + IF ERR THEN idemessage$ = idemessage$ + str2$(ERR) + "-" + IF _ERRORLINE THEN idemessage$ = idemessage$ + str2$(_ERRORLINE) + IF _INCLERRORLINE THEN idemessage$ = idemessage$ + "-" + _INCLERRORFILE$ + "-" + str2$(_INCLERRORLINE) idemessage$ = idemessage$ + ")" - If inclevel > 0 Then idemessage$ = idemessage$ + incerror$ - Resume ideerror -End If + IF inclevel > 0 THEN idemessage$ = idemessage$ + incerror$ + RESUME ideerror +END IF -If qberrorhappenedvalue >= 0 Then - a$ = "UNEXPECTED INTERNAL COMPILER ERROR!": GoTo errmes 'internal comiler error -End If +IF qberrorhappenedvalue >= 0 THEN + a$ = "UNEXPECTED INTERNAL COMPILER ERROR!": GOTO errmes 'internal comiler error +END IF -qberrorcode = Err -qberrorline = Erl -If qberrorhappenedvalue = -1 Then Resume qberrorhappened1 -If qberrorhappenedvalue = -2 Then Resume qberrorhappened2 -If qberrorhappenedvalue = -3 Then Resume qberrorhappened3 -End +qberrorcode = ERR +qberrorline = ERL +IF qberrorhappenedvalue = -1 THEN RESUME qberrorhappened1 +IF qberrorhappenedvalue = -2 THEN RESUME qberrorhappened2 +IF qberrorhappenedvalue = -3 THEN RESUME qberrorhappened3 +END errmes: 'set a$ to message -If Error_Happened Then a$ = Error_Message: Error_Happened = 0 +IF Error_Happened THEN a$ = Error_Message: Error_Happened = 0 layout$ = "": layoutok = 0 'invalidate layout -If inclevel > 0 Then a$ = a$ + incerror$ +IF inclevel > 0 THEN a$ = a$ + incerror$ -If idemode Then +IF idemode THEN ideerrorline = linenumber idemessage$ = a$ - GoTo ideerror 'infinitely preferable to RESUME -End If + GOTO ideerror 'infinitely preferable to RESUME +END IF 'non-ide mode output -Print -If Not MonochromeLoggingMode Then Color 4 -Print a$ -If Not MonochromeLoggingMode Then Color 7 -For i = 1 To Len(linefragment) - If Mid$(linefragment, i, 1) = sp$ Then Mid$(linefragment, i, 1) = " " -Next -For i = 1 To Len(wholeline) - If Mid$(wholeline, i, 1) = sp$ Then Mid$(wholeline, i, 1) = " " -Next -Print "Caused by (or after):" + linefragment -If Not MonochromeLoggingMode Then Color 8 -Print "LINE "; -If Not MonochromeLoggingMode Then Color 15 -Print str2(linenumber) + ":"; -If Not MonochromeLoggingMode Then Color 7 -Print wholeline +PRINT +IF NOT MonochromeLoggingMode THEN COLOR 4 +PRINT a$ +IF NOT MonochromeLoggingMode THEN COLOR 7 +FOR i = 1 TO LEN(linefragment) + IF MID$(linefragment, i, 1) = sp$ THEN MID$(linefragment, i, 1) = " " +NEXT +FOR i = 1 TO LEN(wholeline) + IF MID$(wholeline, i, 1) = sp$ THEN MID$(wholeline, i, 1) = " " +NEXT +PRINT "Caused by (or after):" + linefragment +IF NOT MonochromeLoggingMode THEN COLOR 8 +PRINT "LINE "; +IF NOT MonochromeLoggingMode THEN COLOR 15 +PRINT str2(linenumber) + ":"; +IF NOT MonochromeLoggingMode THEN COLOR 7 +PRINT wholeline -If ConsoleMode Then System 1 -End 1 +IF ConsoleMode THEN SYSTEM 1 +END 1 -Function ParseCMDLineArgs$ () +FUNCTION ParseCMDLineArgs$ () 'Recall that COMMAND$ is a concatenation of argv[] elements, so we don't have 'to worry about more than one space between things (unless they used quotes, 'in which case they're simply asking for trouble). - For i = 1 To _CommandCount - token$ = Command$(i) - If LCase$(token$) = "/?" Or LCase$(token$) = "--help" Or LCase$(token$) = "/help" Then token$ = "-?" - Select Case LCase$(Left$(token$, 2)) - Case "-?" 'Command-line help - _Dest _Console - If qb64versionprinted = 0 Then qb64versionprinted = -1: Print "QB64 Compiler V" + Version$ - Print - Print "Usage: qb64 [switches] " - Print - Print "Options:" - Print " Source file to load" ' '80 columns - Print " -c Compile instead of edit" - Print " -o Write output executable to " - Print " -x Compile instead of edit and output the result to the" - Print " console" - Print " -w Show warnings" - Print " -q Quiet mode (does not inhibit warnings or errors)" - Print " -m Do not colorize compiler output (monochrome mode)" - Print " -e Enable OPTION _EXPLICIT, making variable declaration" - Print " mandatory (per-compilation; doesn't affect the" - Print " source file or global settings)" - Print " -s[:switch=true/false] View/edit compiler settings" - Print " -l: Start the IDE at the specified line number" - Print " -p Purge all pre-compiled content first" - Print " -z Generate C code without compiling to executable" - Print - System - Case "-c" 'Compile instead of edit + FOR i = 1 TO _COMMANDCOUNT + token$ = COMMAND$(i) + IF LCASE$(token$) = "/?" OR LCASE$(token$) = "--help" OR LCASE$(token$) = "/help" THEN token$ = "-?" + SELECT CASE LCASE$(LEFT$(token$, 2)) + CASE "-?" 'Command-line help + _DEST _CONSOLE + IF qb64versionprinted = 0 THEN qb64versionprinted = -1: PRINT "QB64 Compiler V" + Version$ + PRINT + PRINT "Usage: qb64 [switches] " + PRINT + PRINT "Options:" + PRINT " Source file to load" ' '80 columns + PRINT " -c Compile instead of edit" + PRINT " -o Write output executable to " + PRINT " -x Compile instead of edit and output the result to the" + PRINT " console" + PRINT " -w Show warnings" + PRINT " -q Quiet mode (does not inhibit warnings or errors)" + PRINT " -m Do not colorize compiler output (monochrome mode)" + PRINT " -e Enable OPTION _EXPLICIT, making variable declaration" + PRINT " mandatory (per-compilation; doesn't affect the" + PRINT " source file or global settings)" + PRINT " -s[:switch=true/false] View/edit compiler settings" + PRINT " -l: Start the IDE at the specified line number" + PRINT " -p Purge all pre-compiled content first" + PRINT " -z Generate C code without compiling to executable" + PRINT + SYSTEM + CASE "-c" 'Compile instead of edit NoIDEMode = 1 cmdlineswitch = -1 - Case "-o" 'Specify an output file - If Len(Command$(i + 1)) > 0 Then outputfile_cmd$ = Command$(i + 1): i = i + 1 + CASE "-o" 'Specify an output file + IF LEN(COMMAND$(i + 1)) > 0 THEN outputfile_cmd$ = COMMAND$(i + 1): i = i + 1 cmdlineswitch = -1 - Case "-x" 'Use the console + CASE "-x" 'Use the console ConsoleMode = 1 NoIDEMode = 1 'Implies -c cmdlineswitch = -1 - Case "-w" 'Show warnings + CASE "-w" 'Show warnings ShowWarnings = -1 cmdlineswitch = -1 - Case "-q" 'Quiet mode + CASE "-q" 'Quiet mode QuietMode = -1 cmdlineswitch = -1 - Case "-m" 'Monochrome mode + CASE "-m" 'Monochrome mode MonochromeLoggingMode = -1 cmdlineswitch = -1 - Case "-e" 'Option Explicit + CASE "-e" 'Option Explicit optionexplicit_cmd = -1 cmdlineswitch = -1 - Case "-s" 'Settings + CASE "-s" 'Settings settingsMode = -1 - _Dest _Console - If qb64versionprinted = 0 Then qb64versionprinted = -1: Print "QB64 Compiler V" + Version$ - Select Case LCase$(Mid$(token$, 3)) - Case "" - Print "debuginfo = "; - If idedebuginfo Then Print "true" Else Print "false" - Print "exewithsource = "; - If SaveExeWithSource Then Print "true" Else Print "false" - System - Case ":exewithsource" - Print "exewithsource = "; - If SaveExeWithSource Then Print "true" Else Print "false" - System - Case ":exewithsource=true" + _DEST _CONSOLE + IF qb64versionprinted = 0 THEN qb64versionprinted = -1: PRINT "QB64 Compiler V" + Version$ + SELECT CASE LCASE$(MID$(token$, 3)) + CASE "" + PRINT "debuginfo = "; + IF idedebuginfo THEN PRINT "true" ELSE PRINT "false" + PRINT "exewithsource = "; + IF SaveExeWithSource THEN PRINT "true" ELSE PRINT "false" + SYSTEM + CASE ":exewithsource" + PRINT "exewithsource = "; + IF SaveExeWithSource THEN PRINT "true" ELSE PRINT "false" + SYSTEM + CASE ":exewithsource=true" WriteConfigSetting "'[GENERAL SETTINGS]", "SaveExeWithSource", "TRUE" - Print "exewithsource = true" + PRINT "exewithsource = true" SaveExeWithSource = -1 - Case ":exewithsource=false" + CASE ":exewithsource=false" WriteConfigSetting "'[GENERAL SETTINGS]", "SaveExeWithSource", "FALSE" - Print "exewithsource = false" + PRINT "exewithsource = false" SaveExeWithSource = 0 - Case ":debuginfo" - Print "debuginfo = "; - If idedebuginfo Then Print "true" Else Print "false" - System - Case ":debuginfo=true" - Print "debuginfo = true" + CASE ":debuginfo" + PRINT "debuginfo = "; + IF idedebuginfo THEN PRINT "true" ELSE PRINT "false" + SYSTEM + CASE ":debuginfo=true" + PRINT "debuginfo = true" WriteConfigSetting "'[GENERAL SETTINGS]", "DebugInfo", "TRUE 'INTERNAL VARIABLE USE ONLY!! DO NOT MANUALLY CHANGE!" idedebuginfo = 1 Include_GDB_Debugging_Info = idedebuginfo - If os$ = "WIN" Then - ChDir "internal\c" - Shell _Hide "cmd /c purge_all_precompiled_content_win.bat" - ChDir "..\.." - End If - If os$ = "LNX" Then - ChDir "./internal/c" + IF os$ = "WIN" THEN + CHDIR "internal\c" + SHELL _HIDE "cmd /c purge_all_precompiled_content_win.bat" + CHDIR "..\.." + END IF + IF os$ = "LNX" THEN + CHDIR "./internal/c" - If InStr(_OS$, "[MACOSX]") Then - Shell _Hide "./purge_all_precompiled_content_osx.command" - Else - Shell _Hide "./purge_all_precompiled_content_lnx.sh" - End If - ChDir "../.." - End If - Case ":debuginfo=false" - Print "debuginfo = false" + IF INSTR(_OS$, "[MACOSX]") THEN + SHELL _HIDE "./purge_all_precompiled_content_osx.command" + ELSE + SHELL _HIDE "./purge_all_precompiled_content_lnx.sh" + END IF + CHDIR "../.." + END IF + CASE ":debuginfo=false" + PRINT "debuginfo = false" WriteConfigSetting "'[GENERAL SETTINGS]", "DebugInfo", "FALSE 'INTERNAL VARIABLE USE ONLY!! DO NOT MANUALLY CHANGE!" idedebuginfo = 0 Include_GDB_Debugging_Info = idedebuginfo - If os$ = "WIN" Then - ChDir "internal\c" - Shell _Hide "cmd /c purge_all_precompiled_content_win.bat" - ChDir "..\.." - End If - If os$ = "LNX" Then - ChDir "./internal/c" + IF os$ = "WIN" THEN + CHDIR "internal\c" + SHELL _HIDE "cmd /c purge_all_precompiled_content_win.bat" + CHDIR "..\.." + END IF + IF os$ = "LNX" THEN + CHDIR "./internal/c" - If InStr(_OS$, "[MACOSX]") Then - Shell _Hide "./purge_all_precompiled_content_osx.command" - Else - Shell _Hide "./purge_all_precompiled_content_lnx.sh" - End If - ChDir "../.." - End If - Case Else - Print "Invalid settings switch: "; token$ - Print - Print "Valid switches:" - Print " -s:debuginfo=true/false (Embed C++ debug info into .EXE)" - Print " -s:exewithsource=true/false (Save .EXE in the source folder)" - System - End Select - _Dest 0 - Case "-l" 'goto line (ide mode only); -l: - If Mid$(token$, 3, 1) = ":" Then ideStartAtLine = Val(Mid$(token$, 4)) + IF INSTR(_OS$, "[MACOSX]") THEN + SHELL _HIDE "./purge_all_precompiled_content_osx.command" + ELSE + SHELL _HIDE "./purge_all_precompiled_content_lnx.sh" + END IF + CHDIR "../.." + END IF + CASE ELSE + PRINT "Invalid settings switch: "; token$ + PRINT + PRINT "Valid switches:" + PRINT " -s:debuginfo=true/false (Embed C++ debug info into .EXE)" + PRINT " -s:exewithsource=true/false (Save .EXE in the source folder)" + SYSTEM + END SELECT + _DEST 0 + CASE "-l" 'goto line (ide mode only); -l: + IF MID$(token$, 3, 1) = ":" THEN ideStartAtLine = VAL(MID$(token$, 4)) cmdlineswitch = -1 - Case "-p" 'Purge - If os$ = "WIN" Then - ChDir "internal\c" - Shell _Hide "cmd /c purge_all_precompiled_content_win.bat" - ChDir "..\.." - End If - If os$ = "LNX" Then - ChDir "./internal/c" + CASE "-p" 'Purge + IF os$ = "WIN" THEN + CHDIR "internal\c" + SHELL _HIDE "cmd /c purge_all_precompiled_content_win.bat" + CHDIR "..\.." + END IF + IF os$ = "LNX" THEN + CHDIR "./internal/c" - If InStr(_OS$, "[MACOSX]") Then - Shell _Hide "./purge_all_precompiled_content_osx.command" - Else - Shell _Hide "./purge_all_precompiled_content_lnx.sh" - End If - ChDir "../.." - End If + IF INSTR(_OS$, "[MACOSX]") THEN + SHELL _HIDE "./purge_all_precompiled_content_osx.command" + ELSE + SHELL _HIDE "./purge_all_precompiled_content_lnx.sh" + END IF + CHDIR "../.." + END IF cmdlineswitch = -1 - Case "-z" 'Not compiling C code + CASE "-z" 'Not compiling C code No_C_Compile_Mode = 1 ConsoleMode = 1 'Implies -x NoIDEMode = 1 'Implies -c cmdlineswitch = -1 - Case Else 'Something we don't recognise, assume it's a filename - If PassedFileName$ = "" Then PassedFileName$ = token$ - End Select - Next i + CASE ELSE 'Something we don't recognise, assume it's a filename + IF PassedFileName$ = "" THEN PassedFileName$ = token$ + END SELECT + NEXT i - If Len(PassedFileName$) Then + IF LEN(PassedFileName$) THEN ParseCMDLineArgs$ = PassedFileName$ - Else - If cmdlineswitch = 0 And settingsMode = -1 Then System - End If -End Function + ELSE + IF cmdlineswitch = 0 AND settingsMode = -1 THEN SYSTEM + END IF +END FUNCTION -Function Type2MemTypeValue (t1) +FUNCTION Type2MemTypeValue (t1) t = 0 - If t1 And ISARRAY Then t = t + 65536 - If t1 And ISUDT Then - If (t1 And 511) = 1 Then + IF t1 AND ISARRAY THEN t = t + 65536 + IF t1 AND ISUDT THEN + IF (t1 AND 511) = 1 THEN t = t + 4096 '_MEM type - Else + ELSE t = t + 32768 - End If - Else - If t1 And ISSTRING Then + END IF + ELSE + IF t1 AND ISSTRING THEN t = t + 512 'string - Else - If t1 And ISFLOAT Then + ELSE + IF t1 AND ISFLOAT THEN t = t + 256 'float - Else + ELSE t = t + 128 'integer - If t1 And ISUNSIGNED Then t = t + 1024 - If t1 And ISOFFSET Then t = t + 8192 'offset type - End If - t1s = (t1 And 511) \ 8 - If t1s = 1 Then t = t + t1s - If t1s = 2 Then t = t + t1s - If t1s = 4 Then t = t + t1s - If t1s = 8 Then t = t + t1s - If t1s = 16 Then t = t + t1s - If t1s = 32 Then t = t + t1s - If t1s = 64 Then t = t + t1s - End If - End If + IF t1 AND ISUNSIGNED THEN t = t + 1024 + IF t1 AND ISOFFSET THEN t = t + 8192 'offset type + END IF + t1s = (t1 AND 511) \ 8 + IF t1s = 1 THEN t = t + t1s + IF t1s = 2 THEN t = t + t1s + IF t1s = 4 THEN t = t + t1s + IF t1s = 8 THEN t = t + t1s + IF t1s = 16 THEN t = t + t1s + IF t1s = 32 THEN t = t + t1s + IF t1s = 64 THEN t = t + t1s + END IF + END IF Type2MemTypeValue = t -End Function +END FUNCTION -Function FileHasExtension (f$) - For i = Len(f$) To 1 Step -1 - a = Asc(f$, i) - If a = 47 Or a = 92 Then Exit For - If a = 46 Then FileHasExtension = -1: EXIT Function - Next -End Function +FUNCTION FileHasExtension (f$) + FOR i = LEN(f$) TO 1 STEP -1 + a = ASC(f$, i) + IF a = 47 OR a = 92 THEN EXIT FOR + IF a = 46 THEN FileHasExtension = -1: EXIT FUNCTION + NEXT +END FUNCTION -Function RemoveFileExtension$ (f$) 'returns f$ without extension - For i = Len(f$) To 1 Step -1 - a = Asc(f$, i) - If a = 47 Or a = 92 Then Exit For - If a = 46 Then RemoveFileExtension$ = Left$(f$, i - 1): EXIT Function - Next +FUNCTION RemoveFileExtension$ (f$) 'returns f$ without extension + FOR i = LEN(f$) TO 1 STEP -1 + a = ASC(f$, i) + IF a = 47 OR a = 92 THEN EXIT FOR + IF a = 46 THEN RemoveFileExtension$ = LEFT$(f$, i - 1): EXIT FUNCTION + NEXT RemoveFileExtension$ = f$ -End Function +END FUNCTION @@ -13143,10 +13143,10 @@ End Function 'udt is non-zero if this is an array of udt's, to allow examining each udt element -Function allocarray (n2$, elements$, elementsize, udt) +FUNCTION allocarray (n2$, elements$, elementsize, udt) dimsharedlast = dimshared: dimshared = 0 - If autoarray = 1 Then autoarray = 0: autoary = 1 'clear global value & set local value + IF autoarray = 1 THEN autoarray = 0: autoary = 1 'clear global value & set local value f12$ = "" @@ -13154,138 +13154,138 @@ Function allocarray (n2$, elements$, elementsize, udt) 'added 4 to [2] to indicate cmem array where appropriate e$ = elements$: n$ = n2$ - If elementsize = -2147483647 Then stringarray = 1: elementsize = 8 + IF elementsize = -2147483647 THEN stringarray = 1: elementsize = 8 - If Asc(e$) = 63 Then '? + IF ASC(e$) = 63 THEN '? l$ = "(" + sp2 + ")" undefined = -1 nume = 1 - If Len(e$) = 1 Then GoTo undefinedarray + IF LEN(e$) = 1 THEN GOTO undefinedarray undefined = 1 - nume = Val(Right$(e$, Len(e$) - 1)) - GoTo undefinedarray - End If + nume = VAL(RIGHT$(e$, LEN(e$) - 1)) + GOTO undefinedarray + END IF 'work out how many elements there are (critical to later calculations) nume = 1 n = numelements(e$) - For i = 1 To n + FOR i = 1 TO n e2$ = getelement(e$, i) - If e2$ = "(" Then b = b + 1 - If b = 0 And e2$ = "," Then nume = nume + 1 - If e2$ = ")" Then b = b - 1 - Next - If Debug Then Print #9, "numelements count:"; nume + IF e2$ = "(" THEN b = b + 1 + IF b = 0 AND e2$ = "," THEN nume = nume + 1 + IF e2$ = ")" THEN b = b - 1 + NEXT + IF Debug THEN PRINT #9, "numelements count:"; nume descstatic = 0 - If arraydesc Then - If id.arrayelements <> nume Then + IF arraydesc THEN + IF id.arrayelements <> nume THEN - If id.arrayelements = -1 Then 'unknown - If arrayelementslist(currentid) <> 0 And nume <> arrayelementslist(currentid) Then Give_Error "Cannot change the number of elements an array has!": EXIT Function - If nume = 1 Then id.arrayelements = 1: ids(currentid).arrayelements = 1 'lucky guess! + IF id.arrayelements = -1 THEN 'unknown + IF arrayelementslist(currentid) <> 0 AND nume <> arrayelementslist(currentid) THEN Give_Error "Cannot change the number of elements an array has!": EXIT FUNCTION + IF nume = 1 THEN id.arrayelements = 1: ids(currentid).arrayelements = 1 'lucky guess! arrayelementslist(currentid) = nume - Else - Give_Error "Cannot change the number of elements an array has!": EXIT Function - End If + ELSE + Give_Error "Cannot change the number of elements an array has!": EXIT FUNCTION + END IF - End If - If id.staticarray Then descstatic = 1 - End If + END IF + IF id.staticarray THEN descstatic = 1 + END IF l$ = "(" + sp2 - cr$ = Chr$(13) + Chr$(10) + cr$ = CHR$(13) + CHR$(10) sd$ = "" constdimensions = 1 ei = 4 + nume * 4 - 4 cure = 1 e3$ = "": e3base$ = "" - For i = 1 To n + FOR i = 1 TO n e2$ = getelement(e$, i) - If e2$ = "(" Then b = b + 1 - If (e2$ = "," And b = 0) Or i = n Then - If i = n Then e3$ = e3$ + sp + e2$ - e3$ = Right$(e3$, Len(e3$) - 1) - If e3base$ <> "" Then e3base$ = Right$(e3base$, Len(e3base$) - 1) + IF e2$ = "(" THEN b = b + 1 + IF (e2$ = "," AND b = 0) OR i = n THEN + IF i = n THEN e3$ = e3$ + sp + e2$ + e3$ = RIGHT$(e3$, LEN(e3$) - 1) + IF e3base$ <> "" THEN e3base$ = RIGHT$(e3base$, LEN(e3base$) - 1) 'PRINT e3base$ + "[TO]" + e3$ 'set the base basegiven = 1 - If e3base$ = "" Then e3base$ = str2$(optionbase + 0): basegiven = 0 + IF e3base$ = "" THEN e3base$ = str2$(optionbase + 0): basegiven = 0 constequation = 1 e3base$ = fixoperationorder$(e3base$) - If Error_Happened Then EXIT Function - If basegiven Then l$ = l$ + tlayout$ + sp + SCase$("To") + sp + IF Error_Happened THEN EXIT FUNCTION + IF basegiven THEN l$ = l$ + tlayout$ + sp + SCase$("To") + sp e3base$ = evaluatetotyp$(e3base$, 64&) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION - If constequation = 0 Then constdimensions = 0 + IF constequation = 0 THEN constdimensions = 0 sd$ = sd$ + n$ + "[" + str2(ei) + "]=" + e3base$ + ";" + cr$ 'set the number of indexes constequation = 1 e3$ = fixoperationorder$(e3$) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION l$ = l$ + tlayout$ + sp2 - If i = n Then l$ = l$ + ")" Else l$ = l$ + "," + sp + IF i = n THEN l$ = l$ + ")" ELSE l$ = l$ + "," + sp e3$ = evaluatetotyp$(e3$, 64&) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION - If constequation = 0 Then constdimensions = 0 + IF constequation = 0 THEN constdimensions = 0 ei = ei + 1 sd$ = sd$ + n$ + "[" + str2(ei) + "]=(" + e3$ + ")-" + n$ + "[" + str2(ei - 1) + "]+1;" + cr$ ei = ei + 1 'calc muliplier - If cure = 1 Then + IF cure = 1 THEN 'set only for the purpose of the calculating correct multipliers sd$ = sd$ + n$ + "[" + str2(ei) + "]=1;" + cr$ - Else + ELSE sd$ = sd$ + n$ + "[" + str2(ei) + "]=" + n$ + "[" + str2(ei + 4) + "]*" + n$ + "[" + str2(ei + 3) + "];" + cr$ - End If + END IF ei = ei + 1 ei = ei + 1 'skip reserved ei = ei - 8 cure = cure + 1 e3$ = "": e3base$ = "" - GoTo aanexte - End If - If e2$ = ")" Then b = b - 1 - If UCase$(e2$) = "TO" And b = 0 Then + GOTO aanexte + END IF + IF e2$ = ")" THEN b = b - 1 + IF UCASE$(e2$) = "TO" AND b = 0 THEN e3base$ = e3$ e3$ = "" - Else + ELSE e3$ = e3$ + sp + e2$ - End If + END IF aanexte: - Next - sd$ = Left$(sd$, Len(sd$) - 2) + NEXT + sd$ = LEFT$(sd$, LEN(sd$) - 2) undefinedarray: 'calc cmem cmem = 0 - If arraydesc = 0 Then - If cmemlist(idn + 1) Then cmem = 1 - Else - If cmemlist(arraydesc) Then cmem = 1 - End If + IF arraydesc = 0 THEN + IF cmemlist(idn + 1) THEN cmem = 1 + ELSE + IF cmemlist(arraydesc) THEN cmem = 1 + END IF staticarray = constdimensions - If subfuncn <> 0 And dimstatic = 0 Then staticarray = 0 'arrays in SUBS/FUNCTIONS are DYNAMIC - If dimstatic = 3 Then staticarray = 0 'STATIC arrayname() listed arrays keep thier values but are dynamic in memory - If DynamicMode Then staticarray = 0 - If redimoption Then staticarray = 0 - If dimoption = 3 Then staticarray = 0 'STATIC a(100) arrays are still dynamic + IF subfuncn <> 0 AND dimstatic = 0 THEN staticarray = 0 'arrays in SUBS/FUNCTIONS are DYNAMIC + IF dimstatic = 3 THEN staticarray = 0 'STATIC arrayname() listed arrays keep thier values but are dynamic in memory + IF DynamicMode THEN staticarray = 0 + IF redimoption THEN staticarray = 0 + IF dimoption = 3 THEN staticarray = 0 'STATIC a(100) arrays are still dynamic - If arraydesc Then - If staticarray = 1 Then - If descstatic Then Give_Error "Cannot redefine a static array!": EXIT Function + IF arraydesc THEN + IF staticarray = 1 THEN + IF descstatic THEN Give_Error "Cannot redefine a static array!": EXIT FUNCTION staticarray = 0 - End If - End If + END IF + END IF @@ -13293,92 +13293,92 @@ Function allocarray (n2$, elements$, elementsize, udt) bytesperelement$ = str2(elementsize) - If elementsize < 0 Then + IF elementsize < 0 THEN elementsize = -elementsize bytesperelement$ = str2(elementsize) + "/8+1" - End If + END IF 'Begin creation of array descriptor (if array has not been defined yet) - If arraydesc = 0 Then - Print #defdatahandle, "ptrszint *" + n$ + "=NULL;" - Print #13, "if (!" + n$ + "){" - Print #13, n$ + "=(ptrszint*)mem_static_malloc(" + str2(4 * nume + 4 + 1) + "*ptrsz);" '+1 is for the lock + IF arraydesc = 0 THEN + PRINT #defdatahandle, "ptrszint *" + n$ + "=NULL;" + PRINT #13, "if (!" + n$ + "){" + PRINT #13, n$ + "=(ptrszint*)mem_static_malloc(" + str2(4 * nume + 4 + 1) + "*ptrsz);" '+1 is for the lock 'create _MEM lock - Print #13, "new_mem_lock();" - Print #13, "mem_lock_tmp->type=4;" - Print #13, "((ptrszint*)" + n$ + ")[" + str2(4 * nume + 4 + 1 - 1) + "]=(ptrszint)mem_lock_tmp;" - End If + PRINT #13, "new_mem_lock();" + PRINT #13, "mem_lock_tmp->type=4;" + PRINT #13, "((ptrszint*)" + n$ + ")[" + str2(4 * nume + 4 + 1 - 1) + "]=(ptrszint)mem_lock_tmp;" + END IF 'generate sizestr$ & elesizestr$ (both are used in various places in following code) sizestr$ = "" - For i = 1 To nume - If i <> 1 Then sizestr$ = sizestr$ + "*" + FOR i = 1 TO nume + IF i <> 1 THEN sizestr$ = sizestr$ + "*" sizestr$ = sizestr$ + n$ + "[" + str2(i * 4 - 4 + 5) + "]" - Next + NEXT elesizestr$ = sizestr$ 'elements in entire array sizestr$ = sizestr$ + "*" + bytesperelement$ 'bytes in entire array '------------------STATIC ARRAY CREATION-------------------------------- - If staticarray Then + IF staticarray THEN 'STATIC memory - Print #13, sd$ 'setup new array dimension ranges + PRINT #13, sd$ 'setup new array dimension ranges 'Example of sd$ for DIM a(10): '__ARRAY_SINGLE_A[4]= 0 ; '__ARRAY_SINGLE_A[5]=( 10 )-__ARRAY_SINGLE_A[4]+1; '__ARRAY_SINGLE_A[6]=1; - If cmem And stringarray = 0 Then + IF cmem AND stringarray = 0 THEN 'Note: A string array's pointers are always stored in 64bit memory '(static)CONVENTINAL memory - Print #13, n$ + "[0]=(ptrszint)cmem_static_pointer;" + PRINT #13, n$ + "[0]=(ptrszint)cmem_static_pointer;" 'alloc mem & check if static memory boundry has oversteped dynamic memory boundry - Print #13, "if ((cmem_static_pointer+=((" + sizestr$ + ")+15)&-16)>cmem_dynamic_base) error(257);" + PRINT #13, "if ((cmem_static_pointer+=((" + sizestr$ + ")+15)&-16)>cmem_dynamic_base) error(257);" '64K check - Print #13, "if ((" + sizestr$ + ")>65536) error(257);" + PRINT #13, "if ((" + sizestr$ + ")>65536) error(257);" 'clear array - Print #13, "memset((void*)(" + n$ + "[0]),0," + sizestr$ + ");" + PRINT #13, "memset((void*)(" + n$ + "[0]),0," + sizestr$ + ");" 'set flags - Print #13, n$ + "[2]=1+2+4;" 'init+static+cmem - Else + PRINT #13, n$ + "[2]=1+2+4;" 'init+static+cmem + ELSE '64BIT MEMORY - Print #13, n$ + "[0]=(ptrszint)mem_static_malloc(" + sizestr$ + ");" - If stringarray Then + PRINT #13, n$ + "[0]=(ptrszint)mem_static_malloc(" + sizestr$ + ");" + IF stringarray THEN 'Init string pointers in the array - Print #13, "tmp_long=" + elesizestr$ + ";" - Print #13, "while(tmp_long--){" - If cmem Then - Print #13, "((uint64*)(" + n$ + "[0]))[tmp_long]=(uint64)qbs_new_cmem(0,0);" - Else - Print #13, "((uint64*)(" + n$ + "[0]))[tmp_long]=(uint64)qbs_new(0,0);" - End If - Print #13, "}" - Else + PRINT #13, "tmp_long=" + elesizestr$ + ";" + PRINT #13, "while(tmp_long--){" + IF cmem THEN + PRINT #13, "((uint64*)(" + n$ + "[0]))[tmp_long]=(uint64)qbs_new_cmem(0,0);" + ELSE + PRINT #13, "((uint64*)(" + n$ + "[0]))[tmp_long]=(uint64)qbs_new(0,0);" + END IF + PRINT #13, "}" + ELSE 'clear array - Print #13, "memset((void*)(" + n$ + "[0]),0," + sizestr$ + ");" - End If - Print #13, n$ + "[2]=1+2;" 'init+static - End If + PRINT #13, "memset((void*)(" + n$ + "[0]),0," + sizestr$ + ");" + END IF + PRINT #13, n$ + "[2]=1+2;" 'init+static + END IF - If udt > 0 And udtxvariable(udt) Then - Print #13, "tmp_long=" + elesizestr$ + ";" - Print #13, "while(tmp_long--){" + IF udt > 0 AND udtxvariable(udt) THEN + PRINT #13, "tmp_long=" + elesizestr$ + ";" + PRINT #13, "while(tmp_long--){" initialise_array_udt_varstrings n$, udt, 0, bytesperelement$, acc$ - Print #13, acc$ - Print #13, "}" - End If + PRINT #13, acc$ + PRINT #13, "}" + END IF 'Close static array desc - Print #13, "}" + PRINT #13, "}" allocarray = nume + 65536 - End If + END IF '------------------END OF STATIC ARRAY CREATION------------------------- '------------------DYNAMIC ARRAY CREATION------------------------------- - If staticarray = 0 Then + IF staticarray = 0 THEN - If undefined = 0 Then + IF undefined = 0 THEN @@ -13390,11 +13390,11 @@ Function allocarray (n2$, elements$, elementsize, udt) 'REDIM (not DIM) must be used to redefine an array - If redimoption = 0 Then + IF redimoption = 0 THEN f12$ = f12$ + CRLF + "if (" + n$ + "[2]&1){" 'array is defined f12$ = f12$ + CRLF + "error(10);" 'cannot redefine an array without using REDIM! f12$ = f12$ + CRLF + "}else{" - Else + ELSE '--------ERASE EXISTING ARRAY IF NECESSARY-------- 'IMPORTANT: If array is not going to be preserved, it should be cleared before @@ -13403,64 +13403,64 @@ Function allocarray (n2$, elements$, elementsize, udt) 'refresh lock ID (_MEM) f12$ = f12$ + CRLF + "((mem_lock*)((ptrszint*)" + n$ + ")[" + str2(4 * nume + 4 + 1 - 1) + "])->id=(++mem_lock_id);" - If redimoption = 2 Then + IF redimoption = 2 THEN f12$ = f12$ + CRLF + "static int32 preserved_elements;" 'must be put here for scope considerations - End If + END IF 'If array is defined, it must be destroyed first f12$ = f12$ + CRLF + "if (" + n$ + "[2]&1){" 'array is defined - If redimoption = 2 Then + IF redimoption = 2 THEN f12$ = f12$ + CRLF + "preserved_elements=" + elesizestr$ + ";" - GoTo skiperase - End If + GOTO skiperase + END IF 'Note: pointers to strings must be freed before array can be freed - If stringarray Then + IF stringarray THEN f12$ = f12$ + CRLF + "tmp_long=" + elesizestr$ + ";" f12$ = f12$ + CRLF + "while(tmp_long--) qbs_free((qbs*)((uint64*)(" + n$ + "[0]))[tmp_long]);" - End If + END IF 'As must any variable length strings in UDT's - If udt > 0 And udtxvariable(udt) Then + IF udt > 0 AND udtxvariable(udt) THEN f12$ = f12$ + CRLF + "tmp_long=" + elesizestr$ + ";" f12$ = f12$ + CRLF + "while(tmp_long--) {" free_array_udt_varstrings n$, udt, 0, bytesperelement$, acc$ f12$ = f12$ + acc$ + "}" - End If + END IF 'Free array's memory - If stringarray Then + IF stringarray THEN 'Note: String arrays are never in cmem f12$ = f12$ + CRLF + "free((void*)(" + n$ + "[0]));" - Else + ELSE 'Note: Array may be in cmem! f12$ = f12$ + CRLF + "if (" + n$ + "[2]&4){" 'array is in cmem f12$ = f12$ + CRLF + "cmem_dynamic_free((uint8*)(" + n$ + "[0]));" f12$ = f12$ + CRLF + "}else{" 'not in cmem f12$ = f12$ + CRLF + "free((void*)(" + n$ + "[0]));" f12$ = f12$ + CRLF + "}" - End If + END IF skiperase: f12$ = f12$ + CRLF + "}" 'array was defined - If redimoption = 2 Then + IF redimoption = 2 THEN f12$ = f12$ + CRLF + "else preserved_elements=0;" 'if array wasn't defined, no elements are preserved - End If + END IF '--------ERASED ARRAY AS NECESSARY-------- - End If 'redim specified + END IF 'redim specified '--------CREATE ARRAY & CLEAN-UP CODE-------- 'Overwrite existing array dimension sizes/ranges f12$ = f12$ + CRLF + sd$ - If stringarray Or ((udt > 0) And udtxvariable(udt)) Then + IF stringarray OR ((udt > 0) AND udtxvariable(udt)) THEN 'Note: String and variable-length udt arrays are always created in 64bit memory - If redimoption = 2 Then + IF redimoption = 2 THEN f12$ = f12$ + CRLF + "if (preserved_elements){" f12$ = f12$ + CRLF + "static ptrszint tmp_long2;" @@ -13469,35 +13469,35 @@ Function allocarray (n2$, elements$, elementsize, udt) f12$ = f12$ + CRLF + "tmp_long2=" + elesizestr$ + ";" f12$ = f12$ + CRLF + "if (tmp_long2 0 And udtxvariable(udt) Then - Print #19, "while(tmp_long--) {" + IF arraydesc = 0 THEN 'only add for first declaration of the array + PRINT #19, "if (" + n$ + "[2]&1){" 'initialized? + PRINT #19, "tmp_long=" + elesizestr$ + ";" + IF udt > 0 AND udtxvariable(udt) THEN + PRINT #19, "while(tmp_long--) {" acc$ = "" free_array_udt_varstrings n$, udt, 0, bytesperelement$, acc$ - Print #19, acc$ + "}" - Else - Print #19, "while(tmp_long--) qbs_free((qbs*)((uint64*)(" + n$ + "[0]))[tmp_long]);" - End If - Print #19, "free((void*)(" + n$ + "[0]));" - Print #19, "}" + PRINT #19, acc$ + "}" + ELSE + PRINT #19, "while(tmp_long--) qbs_free((qbs*)((uint64*)(" + n$ + "[0]))[tmp_long]);" + END IF + PRINT #19, "free((void*)(" + n$ + "[0]));" + PRINT #19, "}" 'free lock (_MEM) - Print #19, "free_mem_lock( (mem_lock*)((ptrszint*)" + n$ + ")[" + str2(4 * nume + 4 + 1 - 1) + "] );" - End If + PRINT #19, "free_mem_lock( (mem_lock*)((ptrszint*)" + n$ + ")[" + str2(4 * nume + 4 + 1 - 1) + "] );" + END IF - Else 'not string/var-udt array + ELSE 'not string/var-udt array '1. Create array f12$ = f12$ + CRLF + "if (" + n$ + "[2]&4){" 'array will be in cmem - If redimoption = 2 Then + IF redimoption = 2 THEN f12$ = f12$ + CRLF + "if (preserved_elements){" 'reallocation method @@ -13563,21 +13563,21 @@ Function allocarray (n2$, elements$, elementsize, udt) f12$ = f12$ + CRLF + "if (preserved_elements 0 And elements <> arrayelementslist(currentid) Then Give_Error "Cannot change the number of elements an array has!": EXIT Function - If elements = 1 Then id2.arrayelements = 1: ids(currentid).arrayelements = 1 'lucky guess + IF id2.arrayelements = -1 THEN + IF arrayelementslist(currentid) <> 0 AND elements <> arrayelementslist(currentid) THEN Give_Error "Cannot change the number of elements an array has!": EXIT FUNCTION + IF elements = 1 THEN id2.arrayelements = 1: ids(currentid).arrayelements = 1 'lucky guess arrayelementslist(currentid) = elements - Else - If elements <> id2.arrayelements Then Give_Error "Cannot change the number of elements an array has!": EXIT Function - End If + ELSE + IF elements <> id2.arrayelements THEN Give_Error "Cannot change the number of elements an array has!": EXIT FUNCTION + END IF curarg = 1 firsti = 1 - For i = 1 To n + FOR i = 1 TO n l$ = getelement(a$, i) - If l$ = "(" Then b = b + 1 - If l$ = ")" Then b = b - 1 - If (l$ = "," And b = 0) Or (i = n) Then - If i = n Then - If l$ = "," Then Give_Error "Array index missing": EXIT Function + IF l$ = "(" THEN b = b + 1 + IF l$ = ")" THEN b = b - 1 + IF (l$ = "," AND b = 0) OR (i = n) THEN + IF i = n THEN + IF l$ = "," THEN Give_Error "Array index missing": EXIT FUNCTION e$ = evaluatetotyp(getelements$(a$, firsti, i), 64&) - If Error_Happened Then EXIT Function - Else + IF Error_Happened THEN EXIT FUNCTION + ELSE e$ = evaluatetotyp(getelements$(a$, firsti, i - 1), 64&) - If Error_Happened Then EXIT Function - End If - If e$ = "" Then Give_Error "Array index missing": EXIT Function + IF Error_Happened THEN EXIT FUNCTION + END IF + IF e$ = "" THEN Give_Error "Array index missing": EXIT FUNCTION argi = (elements - curarg) * 4 + 4 - If curarg = 1 Then - If NoChecks = 0 Then + IF curarg = 1 THEN + IF NoChecks = 0 THEN r$ = r$ + "array_check((" + e$ + ")-" + n$ + "[" + str2(argi) + "]," + n$ + "[" + str2(argi + 1) + "])+" - Else + ELSE r$ = r$ + "(" + e$ + ")-" + n$ + "[" + str2(argi) + "]+" - End If + END IF - Else - If NoChecks = 0 Then + ELSE + IF NoChecks = 0 THEN r$ = r$ + "array_check((" + e$ + ")-" + n$ + "[" + str2(argi) + "]," + n$ + "[" + str2(argi + 1) + "])*" + n$ + "[" + str2(argi + 2) + "]+" - Else + ELSE r$ = r$ + "((" + e$ + ")-" + n$ + "[" + str2(argi) + "])*" + n$ + "[" + str2(argi + 2) + "]+" - End If - End If + END IF + END IF firsti = i + 1 curarg = curarg + 1 - End If - Next - r$ = Left$(r$, Len(r$) - 1) 'remove trailing + + END IF + NEXT + r$ = LEFT$(r$, LEN(r$) - 1) 'remove trailing + gotarrayindex: r$ = idnumber$ + sp3 + r$ arrayreference$ = r$ 'PRINT "arrayreference returning:" + r$ -End Function +END FUNCTION -Sub assign (a$, n) - For i = 1 To n - c = Asc(getelement$(a$, i)) - If c = 40 Then b = b + 1 '( - If c = 41 Then b = b - 1 ') - If c = 61 And b = 0 Then '= - If i = 1 Then Give_Error "Expected ... =": EXIT Sub - If i = n Then Give_Error "Expected = ...": EXIT Sub +SUB assign (a$, n) + FOR i = 1 TO n + c = ASC(getelement$(a$, i)) + IF c = 40 THEN b = b + 1 '( + IF c = 41 THEN b = b - 1 ') + IF c = 61 AND b = 0 THEN '= + IF i = 1 THEN Give_Error "Expected ... =": EXIT SUB + IF i = n THEN Give_Error "Expected = ...": EXIT SUB a2$ = fixoperationorder(getelements$(a$, 1, i - 1)) - If Error_Happened Then EXIT Sub + IF Error_Happened THEN EXIT SUB l$ = tlayout$ + sp + "=" + sp 'note: evaluating a2$ will fail if it is setting a function's return value without this check (as the function, not the return-variable) will be found by evaluate) - If i = 2 Then 'lhs has only 1 element + IF i = 2 THEN 'lhs has only 1 element try = findid(a2$) - If Error_Happened Then EXIT Sub - Do While try - If id.t Then - If subfuncn = id.insubfuncn Then 'avoid global before local - If (id.t And ISUDT) = 0 Then + IF Error_Happened THEN EXIT SUB + DO WHILE try + IF id.t THEN + IF subfuncn = id.insubfuncn THEN 'avoid global before local + IF (id.t AND ISUDT) = 0 THEN makeidrefer a2$, typ - GoTo assignsimplevariable - End If - End If - End If - If try = 2 Then findanotherid = 1: try = findid(a2$) Else try = 0 - If Error_Happened Then EXIT Sub - Loop - End If + GOTO assignsimplevariable + END IF + END IF + END IF + IF try = 2 THEN findanotherid = 1: try = findid(a2$) ELSE try = 0 + IF Error_Happened THEN EXIT SUB + LOOP + END IF - a2$ = evaluate$(a2$, typ): If Error_Happened Then EXIT Sub + a2$ = evaluate$(a2$, typ): IF Error_Happened THEN EXIT SUB assignsimplevariable: - If (typ And ISREFERENCE) = 0 Then Give_Error "Expected variable =": EXIT Sub + IF (typ AND ISREFERENCE) = 0 THEN Give_Error "Expected variable =": EXIT SUB setrefer a2$, typ, getelements$(a$, i + 1, n), 0 - If Error_Happened Then EXIT Sub + IF Error_Happened THEN EXIT SUB tlayout$ = l$ + tlayout$ - EXIT Sub + EXIT SUB - End If '=,b=0 - Next - Give_Error "Expected =": EXIT Sub -End Sub + END IF '=,b=0 + NEXT + Give_Error "Expected =": EXIT SUB +END SUB -Sub clearid +SUB clearid id = cleariddata -End Sub +END SUB -Sub closemain +SUB closemain xend - Print #12, "return;" + PRINT #12, "return;" - Print #12, "}" - Print #15, "}" 'end case - Print #15, "}" - Print #15, "error(3);" 'no valid return possible + PRINT #12, "}" + PRINT #15, "}" 'end case + PRINT #15, "}" + PRINT #15, "error(3);" 'no valid return possible closedmain = 1 -End Sub +END SUB -Function countelements (a$) +FUNCTION countelements (a$) n = numelements(a$) c = 1 - For i = 1 To n + FOR i = 1 TO n e$ = getelement$(a$, i) - If e$ = "(" Then b = b + 1 - If e$ = ")" Then b = b - 1 - If b < 0 Then Give_Error "Unexpected ) encountered": EXIT Function - If e$ = "," And b = 0 Then c = c + 1 - Next + IF e$ = "(" THEN b = b + 1 + IF e$ = ")" THEN b = b - 1 + IF b < 0 THEN Give_Error "Unexpected ) encountered": EXIT FUNCTION + IF e$ = "," AND b = 0 THEN c = c + 1 + NEXT countelements = c -End Function +END FUNCTION -Function dim2 (varname$, typ2$, method, elements$) +FUNCTION dim2 (varname$, typ2$, method, elements$) 'notes: (DO NOT REMOVE THESE IMPORTANT USAGE NOTES) ' @@ -13858,657 +13858,657 @@ Function dim2 (varname$, typ2$, method, elements$) typ$ = typ2$ dim2 = 1 'success - If Debug Then Print #9, "dim2 called", method + IF Debug THEN PRINT #9, "dim2 called", method cvarname$ = varname$ l$ = cvarname$ - varname$ = UCase$(varname$) + varname$ = UCASE$(varname$) - If dimsfarray = 1 Then f = 0 Else f = 1 + IF dimsfarray = 1 THEN f = 0 ELSE f = 1 - If dimstatic <> 0 And dimshared = 0 Then + IF dimstatic <> 0 AND dimshared = 0 THEN 'name will have include the sub/func name in its scope 'variable/array will be created in main on startup defdatahandle = 18 'change from 13 to 18(global.txt) - Close #13: Open tmpdir$ + "maindata.txt" For Append As #13 - Close #19: Open tmpdir$ + "mainfree.txt" For Append As #19 - End If + CLOSE #13: OPEN tmpdir$ + "maindata.txt" FOR APPEND AS #13 + CLOSE #19: OPEN tmpdir$ + "mainfree.txt" FOR APPEND AS #19 + END IF scope2$ = module$ + "_" + subfunc$ + "_" 'Note: when REDIMing a SHARED array in dynamic memory scope2$ must be modified - If Len(typ$) = 0 Then Give_Error "DIM2: No type specified!": EXIT Function + IF LEN(typ$) = 0 THEN Give_Error "DIM2: No type specified!": EXIT FUNCTION 'UDT 'is it a udt? - For i = 1 To lasttype - If typ$ = RTrim$(udtxname(i)) Or (typ$ = "MEM" And RTrim$(udtxname(i)) = "_MEM" And qb64prefix_set = 1) Then - dim2typepassback$ = RTrim$(udtxcname(i)) - If typ$ = "MEM" And RTrim$(udtxname(i)) = "_MEM" Then - dim2typepassback$ = Mid$(RTrim$(udtxcname(i)), 2) - End If + FOR i = 1 TO lasttype + IF typ$ = RTRIM$(udtxname(i)) OR (typ$ = "MEM" AND RTRIM$(udtxname(i)) = "_MEM" AND qb64prefix_set = 1) THEN + dim2typepassback$ = RTRIM$(udtxcname(i)) + IF typ$ = "MEM" AND RTRIM$(udtxname(i)) = "_MEM" THEN + dim2typepassback$ = MID$(RTRIM$(udtxcname(i)), 2) + END IF n$ = "UDT_" + varname$ 'array of UDTs - If elements$ <> "" Then + IF elements$ <> "" THEN arraydesc = 0 - If f = 1 Then + IF f = 1 THEN try = findid(varname$) - If Error_Happened Then EXIT Function - Do While try - If (id.arraytype) Then - l$ = RTrim$(id.cn) + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF (id.arraytype) THEN + l$ = RTRIM$(id.cn) arraydesc = currentid: scope2$ = scope$ - Exit Do - End If - If try = 2 Then findanotherid = 1: try = findid(varname$) Else try = 0 - If Error_Happened Then EXIT Function - Loop - End If + EXIT DO + END IF + IF try = 2 THEN findanotherid = 1: try = findid(varname$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP + END IF n$ = scope2$ + "ARRAY_" + n$ bits = udtxsize(i) - If udtxbytealign(i) Then - If bits Mod 8 Then bits = bits + 8 - (bits Mod 8) - End If + IF udtxbytealign(i) THEN + IF bits MOD 8 THEN bits = bits + 8 - (bits MOD 8) + END IF - If f = 1 Then + IF f = 1 THEN - If Len(elements$) = 1 And Asc(elements$) = 63 Then '"?" - E = arrayelementslist(idn + 1): If E Then elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array - End If + IF LEN(elements$) = 1 AND ASC(elements$) = 63 THEN '"?" + E = arrayelementslist(idn + 1): IF E THEN elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array + END IF nume = allocarray(n$, elements$, -bits, i) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ - If arraydesc Then GoTo dim2exitfunc + IF arraydesc THEN GOTO dim2exitfunc clearid - Else + ELSE clearid - If elements$ = "?" Then + IF elements$ = "?" THEN nume = -1 id.linkid = glinkid id.linkarg = glinkarg - Else - nume = Val(elements$) - End If - End If + ELSE + nume = VAL(elements$) + END IF + END IF id.arraytype = UDTTYPE + i - If cmemlist(idn + 1) Then id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY + IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY id.n = cvarname$ - If nume > 65536 Then nume = nume - 65536: id.staticarray = 1 + IF nume > 65536 THEN nume = nume - 65536: id.staticarray = 1 id.arrayelements = nume id.callname = n$ regid - If Error_Happened Then EXIT Function - GoTo dim2exitfunc - End If + IF Error_Happened THEN EXIT FUNCTION + GOTO dim2exitfunc + END IF 'not an array of UDTs bits = udtxsize(i): bytes = bits \ 8 - If bits Mod 8 Then + IF bits MOD 8 THEN bytes = bytes + 1 - End If + END IF n$ = scope2$ + n$ - If f Then Print #defdatahandle, "void *" + n$ + "=NULL;" + IF f THEN PRINT #defdatahandle, "void *" + n$ + "=NULL;" clearid id.n = cvarname$ id.t = UDTTYPE + i - If cmemlist(idn + 1) Then + IF cmemlist(idn + 1) THEN id.t = id.t + ISINCONVENTIONALMEMORY - If f Then - Print #13, "if(" + n$ + "==NULL){" - Print #13, "cmem_sp-=" + str2(bytes) + ";" - Print #13, "if (cmem_sp 6 Then - If Left$(typ$, 9) <> "STRING * " Then Give_Error "Expected STRING * number/constant": EXIT Function + IF LEN(typ$) > 6 THEN + IF LEFT$(typ$, 9) <> "STRING * " THEN Give_Error "Expected STRING * number/constant": EXIT FUNCTION - c$ = Right$(typ$, Len(typ$) - 9) + c$ = RIGHT$(typ$, LEN(typ$) - 9) 'constant check 2011 hashfound = 0 hashname$ = c$ hashchkflags = HASHFLAG_CONSTANT hashres = HashFindRev(hashname$, hashchkflags, hashresflags, hashresref) - Do While hashres - If constsubfunc(hashresref) = subfuncn Or constsubfunc(hashresref) = 0 Then - If constdefined(hashresref) Then + DO WHILE hashres + IF constsubfunc(hashresref) = subfuncn OR constsubfunc(hashresref) = 0 THEN + IF constdefined(hashresref) THEN hashfound = 1 - Exit Do - End If - End If - If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0 - Loop - If hashfound Then + EXIT DO + END IF + END IF + IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 + LOOP + IF hashfound THEN i2 = hashresref t = consttype(i2) - If t And ISSTRING Then Give_Error "Expected STRING * numeric-constant": EXIT Function + IF t AND ISSTRING THEN Give_Error "Expected STRING * numeric-constant": EXIT FUNCTION 'convert value to general formats - If t And ISFLOAT Then + IF t AND ISFLOAT THEN v## = constfloat(i2) v&& = v## v~&& = v&& - Else - If t And ISUNSIGNED Then + ELSE + IF t AND ISUNSIGNED THEN v~&& = constuinteger(i2) v&& = v~&& v## = v&& - Else + ELSE v&& = constinteger(i2) v## = v&& v~&& = v&& - End If - End If - If v&& < 1 Or v&& > 9999999999 Then Give_Error "STRING * out-of-range constant": EXIT Function + END IF + END IF + IF v&& < 1 OR v&& > 9999999999 THEN Give_Error "STRING * out-of-range constant": EXIT FUNCTION bytes = v&& - GoTo constantlenstr - End If + GOTO constantlenstr + END IF - If isuinteger(c$) = 0 Then Give_Error "Number/Constant expected after *": EXIT Function - If Len(c$) > 10 Then Give_Error "Too many characters in number after *": EXIT Function - bytes = Val(c$) - If bytes = 0 Then Give_Error "Cannot create a fixed string of length 0": EXIT Function + IF isuinteger(c$) = 0 THEN Give_Error "Number/Constant expected after *": EXIT FUNCTION + IF LEN(c$) > 10 THEN Give_Error "Too many characters in number after *": EXIT FUNCTION + bytes = VAL(c$) + IF bytes = 0 THEN Give_Error "Cannot create a fixed string of length 0": EXIT FUNCTION constantlenstr: n$ = "STRING" + str2(bytes) + "_" + varname$ 'array of fixed length strings - If elements$ <> "" Then + IF elements$ <> "" THEN arraydesc = 0 - If f = 1 Then + IF f = 1 THEN try = findid(varname$ + "$") - If Error_Happened Then EXIT Function - Do While try - If (id.arraytype) Then - l$ = RTrim$(id.cn) + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF (id.arraytype) THEN + l$ = RTRIM$(id.cn) arraydesc = currentid: scope2$ = scope$ - Exit Do - End If - If try = 2 Then findanotherid = 1: try = findid(varname$ + "$") Else try = 0 - If Error_Happened Then EXIT Function - Loop - End If + EXIT DO + END IF + IF try = 2 THEN findanotherid = 1: try = findid(varname$ + "$") ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP + END IF n$ = scope2$ + "ARRAY_" + n$ 'nume = allocarray(n$, elements$, bytes) 'IF arraydesc THEN goto dim2exitfunc 'id already exists! 'clearid - If f = 1 Then + IF f = 1 THEN - If Len(elements$) = 1 And Asc(elements$) = 63 Then '"?" - E = arrayelementslist(idn + 1): If E Then elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array - End If + IF LEN(elements$) = 1 AND ASC(elements$) = 63 THEN '"?" + E = arrayelementslist(idn + 1): IF E THEN elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array + END IF nume = allocarray(n$, elements$, bytes, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ - If arraydesc Then GoTo dim2exitfunc + IF arraydesc THEN GOTO dim2exitfunc clearid - Else + ELSE clearid - If elements$ = "?" Then + IF elements$ = "?" THEN nume = -1 id.linkid = glinkid id.linkarg = glinkarg - Else - nume = Val(elements$) - End If - End If + ELSE + nume = VAL(elements$) + END IF + END IF id.arraytype = STRINGTYPE + ISFIXEDLENGTH - If cmemlist(idn + 1) Then id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY + IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY id.n = cvarname$ - If nume > 65536 Then nume = nume - 65536: id.staticarray = 1 + IF nume > 65536 THEN nume = nume - 65536: id.staticarray = 1 id.arrayelements = nume id.callname = n$ id.tsize = bytes - If method = 0 Then + IF method = 0 THEN id.mayhave = "$" + str2(bytes) - End If - If method = 1 Then + END IF + IF method = 1 THEN id.musthave = "$" + str2(bytes) - End If + END IF regid - If Error_Happened Then EXIT Function - GoTo dim2exitfunc - End If + IF Error_Happened THEN EXIT FUNCTION + GOTO dim2exitfunc + END IF 'standard fixed length string n$ = scope2$ + n$ - If f Then Print #defdatahandle, "qbs *" + n$ + "=NULL;" - If f Then Print #19, "qbs_free(" + n$ + ");" 'so descriptor can be freed + IF f THEN PRINT #defdatahandle, "qbs *" + n$ + "=NULL;" + IF f THEN PRINT #19, "qbs_free(" + n$ + ");" 'so descriptor can be freed clearid id.n = cvarname$ id.t = STRINGTYPE + ISFIXEDLENGTH - If cmemlist(idn + 1) Then + IF cmemlist(idn + 1) THEN id.t = id.t + ISINCONVENTIONALMEMORY - If f Then Print #13, "if(" + n$ + "==NULL){" - If f Then Print #13, "cmem_sp-=" + str2(bytes) + ";" - If f Then Print #13, "if (cmem_spchr,0," + str2(bytes) + ");" - If f Then Print #13, "}" - Else - If f Then Print #13, "if(" + n$ + "==NULL){" + IF f THEN PRINT #13, "if(" + n$ + "==NULL){" + IF f THEN PRINT #13, "cmem_sp-=" + str2(bytes) + ";" + IF f THEN PRINT #13, "if (cmem_spchr,0," + str2(bytes) + ");" + IF f THEN PRINT #13, "}" + ELSE + IF f THEN PRINT #13, "if(" + n$ + "==NULL){" o$ = "(uint8*)mem_static_malloc(" + str2$(bytes) + ")" - If f Then Print #13, n$ + "=qbs_new_fixed(" + o$ + "," + str2$(bytes) + ",0);" - If f Then Print #13, "memset(" + n$ + "->chr,0," + str2$(bytes) + ");" - If f Then Print #13, "}" - End If + IF f THEN PRINT #13, n$ + "=qbs_new_fixed(" + o$ + "," + str2$(bytes) + ",0);" + IF f THEN PRINT #13, "memset(" + n$ + "->chr,0," + str2$(bytes) + ");" + IF f THEN PRINT #13, "}" + END IF id.tsize = bytes - If method = 0 Then + IF method = 0 THEN id.mayhave = "$" + str2(bytes) - End If - If method = 1 Then + END IF + IF method = 1 THEN id.musthave = "$" + str2(bytes) - End If + END IF regid - If Error_Happened Then EXIT Function - GoTo dim2exitfunc - End If + IF Error_Happened THEN EXIT FUNCTION + GOTO dim2exitfunc + END IF 'variable length string processing n$ = "STRING_" + varname$ 'array of variable length strings - If elements$ <> "" Then + IF elements$ <> "" THEN arraydesc = 0 - If f = 1 Then + IF f = 1 THEN try = findid(varname$ + "$") - If Error_Happened Then EXIT Function - Do While try - If (id.arraytype) Then - l$ = RTrim$(id.cn) + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF (id.arraytype) THEN + l$ = RTRIM$(id.cn) arraydesc = currentid: scope2$ = scope$ - Exit Do - End If - If try = 2 Then findanotherid = 1: try = findid(varname$ + "$") Else try = 0 - If Error_Happened Then EXIT Function - Loop - End If + EXIT DO + END IF + IF try = 2 THEN findanotherid = 1: try = findid(varname$ + "$") ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP + END IF n$ = scope2$ + "ARRAY_" + n$ 'nume = allocarray(n$, elements$, -2147483647) '-2147483647=STRING 'IF arraydesc THEN goto dim2exitfunc 'id already exists! 'clearid - If f = 1 Then + IF f = 1 THEN - If Len(elements$) = 1 And Asc(elements$) = 63 Then '"?" - E = arrayelementslist(idn + 1): If E Then elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array - End If + IF LEN(elements$) = 1 AND ASC(elements$) = 63 THEN '"?" + E = arrayelementslist(idn + 1): IF E THEN elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array + END IF nume = allocarray(n$, elements$, -2147483647, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ - If arraydesc Then GoTo dim2exitfunc + IF arraydesc THEN GOTO dim2exitfunc clearid - Else + ELSE clearid - If elements$ = "?" Then + IF elements$ = "?" THEN nume = -1 id.linkid = glinkid id.linkarg = glinkarg - Else - nume = Val(elements$) - End If - End If + ELSE + nume = VAL(elements$) + END IF + END IF id.n = cvarname$ id.arraytype = STRINGTYPE - If cmemlist(idn + 1) Then id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY - If nume > 65536 Then nume = nume - 65536: id.staticarray = 1 + IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY + IF nume > 65536 THEN nume = nume - 65536: id.staticarray = 1 id.arrayelements = nume id.callname = n$ - If method = 0 Then + IF method = 0 THEN id.mayhave = "$" - End If - If method = 1 Then + END IF + IF method = 1 THEN id.musthave = "$" - End If + END IF regid - If Error_Happened Then EXIT Function - GoTo dim2exitfunc - End If + IF Error_Happened THEN EXIT FUNCTION + GOTO dim2exitfunc + END IF 'standard variable length string n$ = scope2$ + n$ clearid id.n = cvarname$ id.t = STRINGTYPE - If cmemlist(idn + 1) Then - If f Then Print #defdatahandle, "qbs *" + n$ + "=NULL;" - If f Then Print #13, "if (!" + n$ + ")" + n$ + "=qbs_new_cmem(0,0);" + IF cmemlist(idn + 1) THEN + IF f THEN PRINT #defdatahandle, "qbs *" + n$ + "=NULL;" + IF f THEN PRINT #13, "if (!" + n$ + ")" + n$ + "=qbs_new_cmem(0,0);" id.t = id.t + ISINCONVENTIONALMEMORY - Else - If f Then Print #defdatahandle, "qbs *" + n$ + "=NULL;" - If f Then Print #13, "if (!" + n$ + ")" + n$ + "=qbs_new(0,0);" - End If - If f Then Print #19, "qbs_free(" + n$ + ");" - If method = 0 Then + ELSE + IF f THEN PRINT #defdatahandle, "qbs *" + n$ + "=NULL;" + IF f THEN PRINT #13, "if (!" + n$ + ")" + n$ + "=qbs_new(0,0);" + END IF + IF f THEN PRINT #19, "qbs_free(" + n$ + ");" + IF method = 0 THEN id.mayhave = "$" - End If - If method = 1 Then + END IF + IF method = 1 THEN id.musthave = "$" - End If + END IF regid - If Error_Happened Then EXIT Function - GoTo dim2exitfunc - End If + IF Error_Happened THEN EXIT FUNCTION + GOTO dim2exitfunc + END IF - If Left$(typ$, 4) = "_BIT" Or (Left$(typ$, 3) = "BIT" And qb64prefix_set = 1) Then - If (Left$(typ$, 4) = "_BIT" And Len(typ$) > 4) Or (Left$(typ$, 3) = "BIT" And Len(typ$) > 3) Then - If Left$(typ$, 7) <> "_BIT * " And Left$(typ$, 6) <> "BIT * " Then Give_Error "Expected " + qb64prefix$ + "BIT * number": EXIT Function - c$ = Mid$(typ$, InStr(typ$, " * ") + 3) - If isuinteger(c$) = 0 Then Give_Error "Number expected after *": EXIT Function - If Len(c$) > 2 Then Give_Error "Too many characters in number after *": EXIT Function - bits = Val(c$) - If bits = 0 Then Give_Error "Cannot create a bit variable of size 0 bits": EXIT Function - If bits > 57 Then Give_Error "Cannot create a bit variable of size > 24 bits": EXIT Function - Else + IF LEFT$(typ$, 4) = "_BIT" OR (LEFT$(typ$, 3) = "BIT" AND qb64prefix_set = 1) THEN + IF (LEFT$(typ$, 4) = "_BIT" AND LEN(typ$) > 4) OR (LEFT$(typ$, 3) = "BIT" AND LEN(typ$) > 3) THEN + IF LEFT$(typ$, 7) <> "_BIT * " AND LEFT$(typ$, 6) <> "BIT * " THEN Give_Error "Expected " + qb64prefix$ + "BIT * number": EXIT FUNCTION + c$ = MID$(typ$, INSTR(typ$, " * ") + 3) + IF isuinteger(c$) = 0 THEN Give_Error "Number expected after *": EXIT FUNCTION + IF LEN(c$) > 2 THEN Give_Error "Too many characters in number after *": EXIT FUNCTION + bits = VAL(c$) + IF bits = 0 THEN Give_Error "Cannot create a bit variable of size 0 bits": EXIT FUNCTION + IF bits > 57 THEN Give_Error "Cannot create a bit variable of size > 24 bits": EXIT FUNCTION + ELSE bits = 1 - End If - If bits <= 32 Then ct$ = "int32" Else ct$ = "int64" - If unsgn Then n$ = "U": ct$ = "u" + ct$ + END IF + IF bits <= 32 THEN ct$ = "int32" ELSE ct$ = "int64" + IF unsgn THEN n$ = "U": ct$ = "u" + ct$ n$ = n$ + "BIT" + str2(bits) + "_" + varname$ 'array of bit-length variables - If elements$ <> "" Then + IF elements$ <> "" THEN arraydesc = 0 - cmps$ = varname$: If unsgn Then cmps$ = cmps$ + "~" + cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" cmps$ = cmps$ + "`" + str2(bits) - If f = 1 Then + IF f = 1 THEN try = findid(cmps$) - If Error_Happened Then EXIT Function - Do While try - If (id.arraytype) Then - l$ = RTrim$(id.cn) + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF (id.arraytype) THEN + l$ = RTRIM$(id.cn) arraydesc = currentid: scope2$ = scope$ - Exit Do - End If - If try = 2 Then findanotherid = 1: try = findid(cmps$) Else try = 0 - If Error_Happened Then EXIT Function - Loop - End If + EXIT DO + END IF + IF try = 2 THEN findanotherid = 1: try = findid(cmps$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP + END IF n$ = scope2$ + "ARRAY_" + n$ 'nume = allocarray(n$, elements$, -bits) 'passing a negative element size signifies bits not bytes 'IF arraydesc THEN goto dim2exitfunc 'id already exists! 'clearid - If f = 1 Then + IF f = 1 THEN - If Len(elements$) = 1 And Asc(elements$) = 63 Then '"?" - E = arrayelementslist(idn + 1): If E Then elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array - End If + IF LEN(elements$) = 1 AND ASC(elements$) = 63 THEN '"?" + E = arrayelementslist(idn + 1): IF E THEN elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array + END IF nume = allocarray(n$, elements$, -bits, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ - If arraydesc Then GoTo dim2exitfunc + IF arraydesc THEN GOTO dim2exitfunc clearid - Else + ELSE clearid - If elements$ = "?" Then + IF elements$ = "?" THEN nume = -1 id.linkid = glinkid id.linkarg = glinkarg - Else - nume = Val(elements$) - End If - End If + ELSE + nume = VAL(elements$) + END IF + END IF id.n = cvarname$ id.arraytype = BITTYPE - 1 + bits - If unsgn Then id.arraytype = id.arraytype + ISUNSIGNED - If cmemlist(idn + 1) Then id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY - If nume > 65536 Then nume = nume - 65536: id.staticarray = 1 + IF unsgn THEN id.arraytype = id.arraytype + ISUNSIGNED + IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY + IF nume > 65536 THEN nume = nume - 65536: id.staticarray = 1 id.arrayelements = nume id.callname = n$ - If method = 0 Then - If unsgn Then id.mayhave = "~`" + str2(bits) Else id.mayhave = "`" + str2(bits) - End If - If method = 1 Then - If unsgn Then id.musthave = "~`" + str2(bits) Else id.musthave = "`" + str2(bits) - End If + IF method = 0 THEN + IF unsgn THEN id.mayhave = "~`" + str2(bits) ELSE id.mayhave = "`" + str2(bits) + END IF + IF method = 1 THEN + IF unsgn THEN id.musthave = "~`" + str2(bits) ELSE id.musthave = "`" + str2(bits) + END IF regid - If Error_Happened Then EXIT Function - GoTo dim2exitfunc - End If + IF Error_Happened THEN EXIT FUNCTION + GOTO dim2exitfunc + END IF 'standard bit-length variable n$ = scope2$ + n$ - Print #defdatahandle, ct$ + " *" + n$ + "=NULL;" - Print #13, "if(" + n$ + "==NULL){" - Print #13, "cmem_sp-=4;" - Print #13, "if (cmem_sp "" Then + IF elements$ <> "" THEN arraydesc = 0 - cmps$ = varname$: If unsgn Then cmps$ = cmps$ + "~" + cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" cmps$ = cmps$ + "%%" - If f = 1 Then + IF f = 1 THEN try = findid(cmps$) - If Error_Happened Then EXIT Function - Do While try - If (id.arraytype) Then - l$ = RTrim$(id.cn) + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF (id.arraytype) THEN + l$ = RTRIM$(id.cn) arraydesc = currentid: scope2$ = scope$ - Exit Do - End If - If try = 2 Then findanotherid = 1: try = findid(cmps$) Else try = 0 - If Error_Happened Then EXIT Function - Loop + EXIT DO + END IF + IF try = 2 THEN findanotherid = 1: try = findid(cmps$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP - End If + END IF n$ = scope2$ + "ARRAY_" + n$ 'nume = allocarray(n$, elements$, 1) 'IF arraydesc THEN goto dim2exitfunc 'clearid - If f = 1 Then + IF f = 1 THEN - If Len(elements$) = 1 And Asc(elements$) = 63 Then '"?" - E = arrayelementslist(idn + 1): If E Then elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array - End If + IF LEN(elements$) = 1 AND ASC(elements$) = 63 THEN '"?" + E = arrayelementslist(idn + 1): IF E THEN elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array + END IF nume = allocarray(n$, elements$, 1, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ - If arraydesc Then GoTo dim2exitfunc + IF arraydesc THEN GOTO dim2exitfunc clearid - Else + ELSE clearid - If elements$ = "?" Then + IF elements$ = "?" THEN nume = -1 id.linkid = glinkid id.linkarg = glinkarg - Else - nume = Val(elements$) - End If - End If + ELSE + nume = VAL(elements$) + END IF + END IF - id.arraytype = BYTETYPE: If unsgn Then id.arraytype = id.arraytype + ISUNSIGNED - If cmemlist(idn + 1) Then id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY - If nume > 65536 Then nume = nume - 65536: id.staticarray = 1 + id.arraytype = BYTETYPE: IF unsgn THEN id.arraytype = id.arraytype + ISUNSIGNED + IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY + IF nume > 65536 THEN nume = nume - 65536: id.staticarray = 1 id.arrayelements = nume id.callname = n$ - Else + ELSE n$ = scope2$ + n$ clearid - id.t = BYTETYPE: If unsgn Then id.t = id.t + ISUNSIGNED - If f = 1 Then Print #defdatahandle, ct$ + " *" + n$ + "=NULL;" - If f = 1 Then Print #13, "if(" + n$ + "==NULL){" - If cmemlist(idn + 1) Then + id.t = BYTETYPE: IF unsgn THEN id.t = id.t + ISUNSIGNED + IF f = 1 THEN PRINT #defdatahandle, ct$ + " *" + n$ + "=NULL;" + IF f = 1 THEN PRINT #13, "if(" + n$ + "==NULL){" + IF cmemlist(idn + 1) THEN id.t = id.t + ISINCONVENTIONALMEMORY - If f = 1 Then Print #13, "cmem_sp-=1;" - If f = 1 Then Print #13, n$ + "=(" + ct$ + "*)(dblock+cmem_sp);" - If f = 1 Then Print #13, "if (cmem_sp "" Then + IF elements$ <> "" THEN arraydesc = 0 - cmps$ = varname$: If unsgn Then cmps$ = cmps$ + "~" + cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" cmps$ = cmps$ + "%" - If f = 1 Then + IF f = 1 THEN try = findid(cmps$) - If Error_Happened Then EXIT Function - Do While try - If (id.arraytype) Then - l$ = RTrim$(id.cn) + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF (id.arraytype) THEN + l$ = RTRIM$(id.cn) arraydesc = currentid: scope2$ = scope$ - Exit Do - End If - If try = 2 Then findanotherid = 1: try = findid(cmps$) Else try = 0 - If Error_Happened Then EXIT Function - Loop - End If + EXIT DO + END IF + IF try = 2 THEN findanotherid = 1: try = findid(cmps$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP + END IF n$ = scope2$ + "ARRAY_" + n$ - If f = 1 Then + IF f = 1 THEN - If Len(elements$) = 1 And Asc(elements$) = 63 Then '"?" - E = arrayelementslist(idn + 1): If E Then elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array - End If + IF LEN(elements$) = 1 AND ASC(elements$) = 63 THEN '"?" + E = arrayelementslist(idn + 1): IF E THEN elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array + END IF nume = allocarray(n$, elements$, 2, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ - If arraydesc Then GoTo dim2exitfunc + IF arraydesc THEN GOTO dim2exitfunc clearid - Else + ELSE clearid - If elements$ = "?" Then + IF elements$ = "?" THEN nume = -1 id.linkid = glinkid id.linkarg = glinkarg - Else - nume = Val(elements$) - End If - End If + ELSE + nume = VAL(elements$) + END IF + END IF - id.arraytype = INTEGERTYPE: If unsgn Then id.arraytype = id.arraytype + ISUNSIGNED - If cmemlist(idn + 1) Then id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY - If nume > 65536 Then nume = nume - 65536: id.staticarray = 1 + id.arraytype = INTEGERTYPE: IF unsgn THEN id.arraytype = id.arraytype + ISUNSIGNED + IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY + IF nume > 65536 THEN nume = nume - 65536: id.staticarray = 1 id.arrayelements = nume id.callname = n$ - Else + ELSE n$ = scope2$ + n$ clearid - id.t = INTEGERTYPE: If unsgn Then id.t = id.t + ISUNSIGNED - If f = 1 Then Print #defdatahandle, ct$ + " *" + n$ + "=NULL;" - If f = 1 Then Print #13, "if(" + n$ + "==NULL){" - If cmemlist(idn + 1) Then + id.t = INTEGERTYPE: IF unsgn THEN id.t = id.t + ISUNSIGNED + IF f = 1 THEN PRINT #defdatahandle, ct$ + " *" + n$ + "=NULL;" + IF f = 1 THEN PRINT #13, "if(" + n$ + "==NULL){" + IF cmemlist(idn + 1) THEN id.t = id.t + ISINCONVENTIONALMEMORY - If f = 1 Then Print #13, "cmem_sp-=2;" - If f = 1 Then Print #13, n$ + "=(" + ct$ + "*)(dblock+cmem_sp);" - If f = 1 Then Print #13, "if (cmem_sp "" Then + IF elements$ <> "" THEN arraydesc = 0 - cmps$ = varname$: If unsgn Then cmps$ = cmps$ + "~" + cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" cmps$ = cmps$ + "%&" - If f = 1 Then + IF f = 1 THEN try = findid(cmps$) - If Error_Happened Then EXIT Function - Do While try - If (id.arraytype) Then - l$ = RTrim$(id.cn) + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF (id.arraytype) THEN + l$ = RTRIM$(id.cn) arraydesc = currentid: scope2$ = scope$ - Exit Do - End If - If try = 2 Then findanotherid = 1: try = findid(cmps$) Else try = 0 - If Error_Happened Then EXIT Function - Loop - End If + EXIT DO + END IF + IF try = 2 THEN findanotherid = 1: try = findid(cmps$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP + END IF n$ = scope2$ + "ARRAY_" + n$ - If f = 1 Then + IF f = 1 THEN - If Len(elements$) = 1 And Asc(elements$) = 63 Then '"?" - E = arrayelementslist(idn + 1): If E Then elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array - End If + IF LEN(elements$) = 1 AND ASC(elements$) = 63 THEN '"?" + E = arrayelementslist(idn + 1): IF E THEN elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array + END IF nume = allocarray(n$, elements$, OS_BITS \ 8, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ - If arraydesc Then GoTo dim2exitfunc + IF arraydesc THEN GOTO dim2exitfunc clearid - Else + ELSE clearid - If elements$ = "?" Then + IF elements$ = "?" THEN nume = -1 id.linkid = glinkid id.linkarg = glinkarg - Else - nume = Val(elements$) - End If - End If + ELSE + nume = VAL(elements$) + END IF + END IF - id.arraytype = OFFSETTYPE: If unsgn Then id.arraytype = id.arraytype + ISUNSIGNED - If cmemlist(idn + 1) Then id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY - If nume > 65536 Then nume = nume - 65536: id.staticarray = 1 + id.arraytype = OFFSETTYPE: IF unsgn THEN id.arraytype = id.arraytype + ISUNSIGNED + IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY + IF nume > 65536 THEN nume = nume - 65536: id.staticarray = 1 id.arrayelements = nume id.callname = n$ - Else + ELSE n$ = scope2$ + n$ clearid - id.t = OFFSETTYPE: If unsgn Then id.t = id.t + ISUNSIGNED - If f = 1 Then Print #defdatahandle, ct$ + " *" + n$ + "=NULL;" - If f = 1 Then Print #13, "if(" + n$ + "==NULL){" - If cmemlist(idn + 1) Then + id.t = OFFSETTYPE: IF unsgn THEN id.t = id.t + ISUNSIGNED + IF f = 1 THEN PRINT #defdatahandle, ct$ + " *" + n$ + "=NULL;" + IF f = 1 THEN PRINT #13, "if(" + n$ + "==NULL){" + IF cmemlist(idn + 1) THEN id.t = id.t + ISINCONVENTIONALMEMORY - If f = 1 Then Print #13, "cmem_sp-=" + str2(OS_BITS \ 8) + ";" - If f = 1 Then Print #13, n$ + "=(" + ct$ + "*)(dblock+cmem_sp);" - If f = 1 Then Print #13, "if (cmem_sp "" Then + IF elements$ <> "" THEN arraydesc = 0 - cmps$ = varname$: If unsgn Then cmps$ = cmps$ + "~" + cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" cmps$ = cmps$ + "&" - If f = 1 Then + IF f = 1 THEN try = findid(cmps$) - If Error_Happened Then EXIT Function - Do While try - If (id.arraytype) Then - l$ = RTrim$(id.cn) + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF (id.arraytype) THEN + l$ = RTRIM$(id.cn) arraydesc = currentid: scope2$ = scope$ - Exit Do - End If - If try = 2 Then findanotherid = 1: try = findid(cmps$) Else try = 0 - If Error_Happened Then EXIT Function - Loop - End If + EXIT DO + END IF + IF try = 2 THEN findanotherid = 1: try = findid(cmps$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP + END IF n$ = scope2$ + "ARRAY_" + n$ 'nume = allocarray(n$, elements$, 4) 'IF arraydesc THEN goto dim2exitfunc 'clearid - If f = 1 Then + IF f = 1 THEN - If Len(elements$) = 1 And Asc(elements$) = 63 Then '"?" - E = arrayelementslist(idn + 1): If E Then elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array - End If + IF LEN(elements$) = 1 AND ASC(elements$) = 63 THEN '"?" + E = arrayelementslist(idn + 1): IF E THEN elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array + END IF nume = allocarray(n$, elements$, 4, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ - If arraydesc Then GoTo dim2exitfunc + IF arraydesc THEN GOTO dim2exitfunc clearid - Else + ELSE clearid - If elements$ = "?" Then + IF elements$ = "?" THEN nume = -1 id.linkid = glinkid id.linkarg = glinkarg - Else - nume = Val(elements$) - End If - End If + ELSE + nume = VAL(elements$) + END IF + END IF - id.arraytype = LONGTYPE: If unsgn Then id.arraytype = id.arraytype + ISUNSIGNED - If cmemlist(idn + 1) Then id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY - If nume > 65536 Then nume = nume - 65536: id.staticarray = 1 + id.arraytype = LONGTYPE: IF unsgn THEN id.arraytype = id.arraytype + ISUNSIGNED + IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY + IF nume > 65536 THEN nume = nume - 65536: id.staticarray = 1 id.arrayelements = nume id.callname = n$ - Else + ELSE n$ = scope2$ + n$ clearid - id.t = LONGTYPE: If unsgn Then id.t = id.t + ISUNSIGNED - If f = 1 Then Print #defdatahandle, ct$ + " *" + n$ + "=NULL;" - If f = 1 Then Print #13, "if(" + n$ + "==NULL){" - If cmemlist(idn + 1) Then + id.t = LONGTYPE: IF unsgn THEN id.t = id.t + ISUNSIGNED + IF f = 1 THEN PRINT #defdatahandle, ct$ + " *" + n$ + "=NULL;" + IF f = 1 THEN PRINT #13, "if(" + n$ + "==NULL){" + IF cmemlist(idn + 1) THEN id.t = id.t + ISINCONVENTIONALMEMORY - If f = 1 Then Print #13, "cmem_sp-=4;" - If f = 1 Then Print #13, n$ + "=(" + ct$ + "*)(dblock+cmem_sp);" - If f = 1 Then Print #13, "if (cmem_sp "" Then + IF elements$ <> "" THEN arraydesc = 0 - cmps$ = varname$: If unsgn Then cmps$ = cmps$ + "~" + cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" cmps$ = cmps$ + "&&" - If f = 1 Then + IF f = 1 THEN try = findid(cmps$) - If Error_Happened Then EXIT Function - Do While try - If (id.arraytype) Then - l$ = RTrim$(id.cn) + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF (id.arraytype) THEN + l$ = RTRIM$(id.cn) arraydesc = currentid: scope2$ = scope$ - Exit Do - End If - If try = 2 Then findanotherid = 1: try = findid(cmps$) Else try = 0 - If Error_Happened Then EXIT Function - Loop - End If + EXIT DO + END IF + IF try = 2 THEN findanotherid = 1: try = findid(cmps$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP + END IF n$ = scope2$ + "ARRAY_" + n$ 'nume = allocarray(n$, elements$, 8) 'IF arraydesc THEN goto dim2exitfunc 'clearid - If f = 1 Then + IF f = 1 THEN - If Len(elements$) = 1 And Asc(elements$) = 63 Then '"?" - E = arrayelementslist(idn + 1): If E Then elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array - End If + IF LEN(elements$) = 1 AND ASC(elements$) = 63 THEN '"?" + E = arrayelementslist(idn + 1): IF E THEN elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array + END IF nume = allocarray(n$, elements$, 8, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ - If arraydesc Then GoTo dim2exitfunc + IF arraydesc THEN GOTO dim2exitfunc clearid - Else + ELSE clearid - If elements$ = "?" Then + IF elements$ = "?" THEN nume = -1 id.linkid = glinkid id.linkarg = glinkarg - Else - nume = Val(elements$) - End If - End If + ELSE + nume = VAL(elements$) + END IF + END IF - id.arraytype = INTEGER64TYPE: If unsgn Then id.arraytype = id.arraytype + ISUNSIGNED - If cmemlist(idn + 1) Then id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY - If nume > 65536 Then nume = nume - 65536: id.staticarray = 1 + id.arraytype = INTEGER64TYPE: IF unsgn THEN id.arraytype = id.arraytype + ISUNSIGNED + IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY + IF nume > 65536 THEN nume = nume - 65536: id.staticarray = 1 id.arrayelements = nume id.callname = n$ - Else + ELSE n$ = scope2$ + n$ clearid - id.t = INTEGER64TYPE: If unsgn Then id.t = id.t + ISUNSIGNED - If f = 1 Then Print #defdatahandle, ct$ + " *" + n$ + "=NULL;" - If f = 1 Then Print #13, "if(" + n$ + "==NULL){" - If cmemlist(idn + 1) Then + id.t = INTEGER64TYPE: IF unsgn THEN id.t = id.t + ISUNSIGNED + IF f = 1 THEN PRINT #defdatahandle, ct$ + " *" + n$ + "=NULL;" + IF f = 1 THEN PRINT #13, "if(" + n$ + "==NULL){" + IF cmemlist(idn + 1) THEN id.t = id.t + ISINCONVENTIONALMEMORY - If f = 1 Then Print #13, "cmem_sp-=8;" - If f = 1 Then Print #13, n$ + "=(" + ct$ + "*)(dblock+cmem_sp);" - If f = 1 Then Print #13, "if (cmem_sp "" Then + IF elements$ <> "" THEN arraydesc = 0 cmps$ = varname$ + "!" - If f = 1 Then + IF f = 1 THEN try = findid(cmps$) - If Error_Happened Then EXIT Function - Do While try - If (id.arraytype) Then - l$ = RTrim$(id.cn) + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF (id.arraytype) THEN + l$ = RTRIM$(id.cn) arraydesc = currentid: scope2$ = scope$ - Exit Do - End If - If try = 2 Then findanotherid = 1: try = findid(cmps$) Else try = 0 - If Error_Happened Then EXIT Function - Loop - End If + EXIT DO + END IF + IF try = 2 THEN findanotherid = 1: try = findid(cmps$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP + END IF n$ = scope2$ + "ARRAY_" + n$ 'nume = allocarray(n$, elements$, 4) 'IF arraydesc THEN goto dim2exitfunc 'clearid - If f = 1 Then + IF f = 1 THEN - If Len(elements$) = 1 And Asc(elements$) = 63 Then '"?" - E = arrayelementslist(idn + 1): If E Then elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array - End If + IF LEN(elements$) = 1 AND ASC(elements$) = 63 THEN '"?" + E = arrayelementslist(idn + 1): IF E THEN elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array + END IF nume = allocarray(n$, elements$, 4, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ - If arraydesc Then GoTo dim2exitfunc + IF arraydesc THEN GOTO dim2exitfunc clearid - Else + ELSE clearid - If elements$ = "?" Then + IF elements$ = "?" THEN nume = -1 id.linkid = glinkid id.linkarg = glinkarg - Else - nume = Val(elements$) - End If - End If + ELSE + nume = VAL(elements$) + END IF + END IF id.arraytype = SINGLETYPE - If cmemlist(idn + 1) Then id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY - If nume > 65536 Then nume = nume - 65536: id.staticarray = 1 + IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY + IF nume > 65536 THEN nume = nume - 65536: id.staticarray = 1 id.arrayelements = nume id.callname = n$ - Else + ELSE n$ = scope2$ + n$ clearid id.t = SINGLETYPE - If f = 1 Then Print #defdatahandle, ct$ + " *" + n$ + "=NULL;" - If f = 1 Then Print #13, "if(" + n$ + "==NULL){" - If cmemlist(idn + 1) Then + IF f = 1 THEN PRINT #defdatahandle, ct$ + " *" + n$ + "=NULL;" + IF f = 1 THEN PRINT #13, "if(" + n$ + "==NULL){" + IF cmemlist(idn + 1) THEN id.t = id.t + ISINCONVENTIONALMEMORY - If f = 1 Then Print #13, "cmem_sp-=4;" - If f = 1 Then Print #13, n$ + "=(" + ct$ + "*)(dblock+cmem_sp);" - If f = 1 Then Print #13, "if (cmem_sp "" Then + IF elements$ <> "" THEN arraydesc = 0 cmps$ = varname$ + "#" - If f = 1 Then + IF f = 1 THEN try = findid(cmps$) - If Error_Happened Then EXIT Function - Do While try - If (id.arraytype) Then - l$ = RTrim$(id.cn) + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF (id.arraytype) THEN + l$ = RTRIM$(id.cn) arraydesc = currentid: scope2$ = scope$ - Exit Do - End If - If try = 2 Then findanotherid = 1: try = findid(cmps$) Else try = 0 - If Error_Happened Then EXIT Function - Loop - End If + EXIT DO + END IF + IF try = 2 THEN findanotherid = 1: try = findid(cmps$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP + END IF n$ = scope2$ + "ARRAY_" + n$ 'nume = allocarray(n$, elements$, 8) 'IF arraydesc THEN goto dim2exitfunc 'clearid - If f = 1 Then + IF f = 1 THEN - If Len(elements$) = 1 And Asc(elements$) = 63 Then '"?" - E = arrayelementslist(idn + 1): If E Then elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array - End If + IF LEN(elements$) = 1 AND ASC(elements$) = 63 THEN '"?" + E = arrayelementslist(idn + 1): IF E THEN elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array + END IF nume = allocarray(n$, elements$, 8, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ - If arraydesc Then GoTo dim2exitfunc + IF arraydesc THEN GOTO dim2exitfunc clearid - Else + ELSE clearid - If elements$ = "?" Then + IF elements$ = "?" THEN nume = -1 id.linkid = glinkid id.linkarg = glinkarg - Else - nume = Val(elements$) - End If - End If + ELSE + nume = VAL(elements$) + END IF + END IF id.arraytype = DOUBLETYPE - If cmemlist(idn + 1) Then id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY - If nume > 65536 Then nume = nume - 65536: id.staticarray = 1 + IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY + IF nume > 65536 THEN nume = nume - 65536: id.staticarray = 1 id.arrayelements = nume id.callname = n$ - Else + ELSE n$ = scope2$ + n$ clearid id.t = DOUBLETYPE - If f = 1 Then Print #defdatahandle, ct$ + " *" + n$ + "=NULL;" - If f = 1 Then Print #13, "if(" + n$ + "==NULL){" - If cmemlist(idn + 1) Then + IF f = 1 THEN PRINT #defdatahandle, ct$ + " *" + n$ + "=NULL;" + IF f = 1 THEN PRINT #13, "if(" + n$ + "==NULL){" + IF cmemlist(idn + 1) THEN id.t = id.t + ISINCONVENTIONALMEMORY - If f = 1 Then Print #13, "cmem_sp-=8;" - If f = 1 Then Print #13, n$ + "=(" + ct$ + "*)(dblock+cmem_sp);" - If f = 1 Then Print #13, "if (cmem_sp "" Then + IF elements$ <> "" THEN arraydesc = 0 cmps$ = varname$ + "##" - If f = 1 Then + IF f = 1 THEN try = findid(cmps$) - If Error_Happened Then EXIT Function - Do While try - If (id.arraytype) Then - l$ = RTrim$(id.cn) + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF (id.arraytype) THEN + l$ = RTRIM$(id.cn) arraydesc = currentid: scope2$ = scope$ - Exit Do - End If - If try = 2 Then findanotherid = 1: try = findid(cmps$) Else try = 0 - If Error_Happened Then EXIT Function - Loop - End If + EXIT DO + END IF + IF try = 2 THEN findanotherid = 1: try = findid(cmps$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP + END IF n$ = scope2$ + "ARRAY_" + n$ 'nume = allocarray(n$, elements$, 32) 'IF arraydesc THEN goto dim2exitfunc 'clearid - If f = 1 Then + IF f = 1 THEN - If Len(elements$) = 1 And Asc(elements$) = 63 Then '"?" - E = arrayelementslist(idn + 1): If E Then elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array - End If + IF LEN(elements$) = 1 AND ASC(elements$) = 63 THEN '"?" + E = arrayelementslist(idn + 1): IF E THEN elements$ = elements$ + str2$(E) 'eg. "?3" for a 3 dimensional array + END IF nume = allocarray(n$, elements$, 32, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ - If arraydesc Then GoTo dim2exitfunc + IF arraydesc THEN GOTO dim2exitfunc clearid - Else + ELSE clearid - If elements$ = "?" Then + IF elements$ = "?" THEN nume = -1 id.linkid = glinkid id.linkarg = glinkarg - Else - nume = Val(elements$) - End If - End If + ELSE + nume = VAL(elements$) + END IF + END IF id.arraytype = FLOATTYPE - If cmemlist(idn + 1) Then id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY - If nume > 65536 Then nume = nume - 65536: id.staticarray = 1 + IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY + IF nume > 65536 THEN nume = nume - 65536: id.staticarray = 1 id.arrayelements = nume id.callname = n$ - Else + ELSE n$ = scope2$ + n$ clearid id.t = FLOATTYPE - If f Then Print #defdatahandle, ct$ + " *" + n$ + "=NULL;" - If f Then Print #13, "if(" + n$ + "==NULL){" - If cmemlist(idn + 1) Then + IF f THEN PRINT #defdatahandle, ct$ + " *" + n$ + "=NULL;" + IF f THEN PRINT #13, "if(" + n$ + "==NULL){" + IF cmemlist(idn + 1) THEN id.t = id.t + ISINCONVENTIONALMEMORY - If f Then Print #13, "cmem_sp-=32;" - If f Then Print #13, n$ + "=(" + ct$ + "*)(dblock+cmem_sp);" - If f Then Print #13, "if (cmem_sp 0 And dimshared = 0 Then + IF dimstatic <> 0 AND dimshared = 0 THEN defdatahandle = 13 - Close #13: Open tmpdir$ + "data" + str2$(subfuncn) + ".txt" For Append As #13 - Close #19: Open tmpdir$ + "free" + str2$(subfuncn) + ".txt" For Append As #19 - End If + CLOSE #13: OPEN tmpdir$ + "data" + str2$(subfuncn) + ".txt" FOR APPEND AS #13 + CLOSE #19: OPEN tmpdir$ + "free" + str2$(subfuncn) + ".txt" FOR APPEND AS #19 + END IF tlayout$ = l$ -End Function +END FUNCTION -Function udtreference$ (o$, a$, typ As Long) +FUNCTION udtreference$ (o$, a$, typ AS LONG) 'UDT REFERENCE FORMAT 'idno|udtno|udtelementno|byteoffset ' ^udt of the element, not of the id @@ -15054,81 +15054,81 @@ Function udtreference$ (o$, a$, typ As Long) o = 0 'the fixed/known part of the offset incmem = 0 - If id.t Then - u = id.t And 511 - If id.t And ISINCONVENTIONALMEMORY Then incmem = 1 - Else - u = id.arraytype And 511 - If id.arraytype And ISINCONVENTIONALMEMORY Then incmem = 1 - End If + IF id.t THEN + u = id.t AND 511 + IF id.t AND ISINCONVENTIONALMEMORY THEN incmem = 1 + ELSE + u = id.arraytype AND 511 + IF id.arraytype AND ISINCONVENTIONALMEMORY THEN incmem = 1 + END IF E = 0 n = numelements(a$) - If n = 0 Then GoTo fulludt + IF n = 0 THEN GOTO fulludt i = 1 udtfindelenext: - If getelement$(a$, i) <> "." Then Give_Error "Expected .": EXIT Function + IF getelement$(a$, i) <> "." THEN Give_Error "Expected .": EXIT FUNCTION i = i + 1 n$ = getelement$(a$, i) - nsym$ = removesymbol(n$): If Len(nsym$) Then ntyp = typname2typ(nsym$): ntypsize = typname2typsize - If Error_Happened Then EXIT Function + nsym$ = removesymbol(n$): IF LEN(nsym$) THEN ntyp = typname2typ(nsym$): ntypsize = typname2typsize + IF Error_Happened THEN EXIT FUNCTION - If n$ = "" Then Give_Error "Expected .elementname": EXIT Function + IF n$ = "" THEN Give_Error "Expected .elementname": EXIT FUNCTION udtfindele: - If E = 0 Then E = udtxnext(u) Else E = udtenext(E) - If E = 0 Then Give_Error "Element not defined": EXIT Function - n2$ = RTrim$(udtename(E)) - If udtebytealign(E) Then - If o Mod 8 Then o = o + (8 - (o Mod 8)) - End If + IF E = 0 THEN E = udtxnext(u) ELSE E = udtenext(E) + IF E = 0 THEN Give_Error "Element not defined": EXIT FUNCTION + n2$ = RTRIM$(udtename(E)) + IF udtebytealign(E) THEN + IF o MOD 8 THEN o = o + (8 - (o MOD 8)) + END IF - If n$ <> n2$ Then + IF n$ <> n2$ THEN 'increment fixed offset o = o + udtesize(E) - GoTo udtfindele - End If + GOTO udtfindele + END IF 'check symbol after element's name (if given) is correct - If Len(nsym$) Then + IF LEN(nsym$) THEN - If udtetype(E) And ISUDT Then Give_Error "Invalid symbol after user defined type": EXIT Function - If ntyp <> udtetype(E) Or ntypsize <> udtetypesize(E) Then - If nsym$ = "$" And ((udtetype(E) And ISFIXEDLENGTH) <> 0) Then GoTo correctsymbol - Give_Error "Incorrect symbol after element name": EXIT Function - End If - End If + IF udtetype(E) AND ISUDT THEN Give_Error "Invalid symbol after user defined type": EXIT FUNCTION + IF ntyp <> udtetype(E) OR ntypsize <> udtetypesize(E) THEN + IF nsym$ = "$" AND ((udtetype(E) AND ISFIXEDLENGTH) <> 0) THEN GOTO correctsymbol + Give_Error "Incorrect symbol after element name": EXIT FUNCTION + END IF + END IF correctsymbol: 'Move into another UDT structure? - If i <> n Then - If (udtetype(E) And ISUDT) = 0 Then Give_Error "Expected user defined type": EXIT Function - u = udtetype(E) And 511 + IF i <> n THEN + IF (udtetype(E) AND ISUDT) = 0 THEN Give_Error "Expected user defined type": EXIT FUNCTION + u = udtetype(E) AND 511 E = 0 i = i + 1 - GoTo udtfindelenext - End If + GOTO udtfindelenext + END IF 'Change e reference to u CHR$(179) 0 reference? - If udtetype(E) And ISUDT Then - u = udtetype(E) And 511 + IF udtetype(E) AND ISUDT THEN + u = udtetype(E) AND 511 E = 0 - End If + END IF fulludt: r$ = r$ + str2$(u) + sp3 + str2$(E) + sp3 - If o Mod 8 Then Give_Error "QB64 cannot handle bit offsets within user defined types yet": EXIT Function + IF o MOD 8 THEN Give_Error "QB64 cannot handle bit offsets within user defined types yet": EXIT FUNCTION o = o \ 8 - If o$ <> "" Then - If o <> 0 Then 'dont add an unnecessary 0 + IF o$ <> "" THEN + IF o <> 0 THEN 'dont add an unnecessary 0 o$ = o$ + "+" + str2$(o) - End If - Else + END IF + ELSE o$ = str2$(o) - End If + END IF r$ = r$ + o$ @@ -15136,28 +15136,28 @@ Function udtreference$ (o$, a$, typ As Long) typ = udtetype(E) + ISUDT + ISREFERENCE 'full udt override: - If E = 0 Then + IF E = 0 THEN typ = u + ISUDT + ISREFERENCE - End If + END IF - If obak$ <> "" Then typ = typ + ISARRAY - If incmem Then typ = typ + ISINCONVENTIONALMEMORY + IF obak$ <> "" THEN typ = typ + ISARRAY + IF incmem THEN typ = typ + ISINCONVENTIONALMEMORY 'print "UDTREF:"+r$+","+str2$(typ) -End Function +END FUNCTION -Function evaluate$ (a2$, typ As Long) - Dim block(1000) As String - Dim evaledblock(1000) As Integer - Dim blocktype(1000) As Long +FUNCTION evaluate$ (a2$, typ AS LONG) + DIM block(1000) AS STRING + DIM evaledblock(1000) AS INTEGER + DIM blocktype(1000) AS LONG 'typ IS A RETURN VALUE '''DIM cli(15) AS INTEGER a$ = a2$ typ = -1 - If Debug Then Print #9, "evaluating:[" + a2$ + "]" - If a2$ = "" Then Give_Error "Syntax error": EXIT Function + IF Debug THEN PRINT #9, "evaluating:[" + a2$ + "]" + IF a2$ = "" THEN Give_Error "Syntax error": EXIT FUNCTION @@ -15169,7 +15169,7 @@ Function evaluate$ (a2$, typ As Long) blockn = 0 n = numelements(a$) b = 0 'bracketting level - For i = 1 To n + FOR i = 1 TO n reevaluate: @@ -15179,131 +15179,131 @@ Function evaluate$ (a2$, typ As Long) l$ = getelement(a$, i) - If Debug Then Print #9, "#*#*#* reevaluating:" + l$, i + IF Debug THEN PRINT #9, "#*#*#* reevaluating:" + l$, i - If i <> n Then nextl$ = getelement(a$, i + 1) Else nextl$ = "" + IF i <> n THEN nextl$ = getelement(a$, i + 1) ELSE nextl$ = "" '''getclass cl$, i, cli() - If b = 0 Then 'don't evaluate anything within brackets + IF b = 0 THEN 'don't evaluate anything within brackets - If Debug Then Print #9, l$ + IF Debug THEN PRINT #9, l$ l2$ = l$ 'pure version of l$ - For try_method = 1 To 4 + FOR try_method = 1 TO 4 l$ = l2$ - If try_method = 2 Or try_method = 4 Then - If Error_Happened Then EXIT Function - dtyp$ = removesymbol(l$): If Error_Happened Then dtyp$ = "": Error_Happened = 0 - If Len(dtyp$) = 0 Then - If isoperator(l$) = 0 Then - If isvalidvariable(l$) Then - If Left$(l$, 1) = "_" Then v = 27 Else v = Asc(UCase$(l$)) - 64 + IF try_method = 2 OR try_method = 4 THEN + IF Error_Happened THEN EXIT FUNCTION + dtyp$ = removesymbol(l$): IF Error_Happened THEN dtyp$ = "": Error_Happened = 0 + IF LEN(dtyp$) = 0 THEN + IF isoperator(l$) = 0 THEN + IF isvalidvariable(l$) THEN + IF LEFT$(l$, 1) = "_" THEN v = 27 ELSE v = ASC(UCASE$(l$)) - 64 l$ = l$ + defineextaz(v) - End If - End If - Else + END IF + END IF + ELSE l$ = l2$ - End If - End If + END IF + END IF try = findid(l$) - If Error_Happened Then EXIT Function - Do While try + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try - If Debug Then Print #9, try + IF Debug THEN PRINT #9, try 'is l$ an array? - If nextl$ = "(" Then - If id.arraytype Then - If (subfuncn = id.insubfuncn And try_method <= 2) Or try_method >= 3 Then + IF nextl$ = "(" THEN + IF id.arraytype THEN + IF (subfuncn = id.insubfuncn AND try_method <= 2) OR try_method >= 3 THEN arrayid = currentid constequation = 0 i2 = i + 2 b2 = 0 evalnextele3: l2$ = getelement(a$, i2) - If l2$ = "(" Then b2 = b2 + 1 - If l2$ = ")" Then + IF l2$ = "(" THEN b2 = b2 + 1 + IF l2$ = ")" THEN b2 = b2 - 1 - If b2 = -1 Then + IF b2 = -1 THEN c$ = arrayreference(getelements$(a$, i + 2, i2 - 1), typ2) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION i = i2 'UDT - If typ2 And ISUDT Then + IF typ2 AND ISUDT THEN 'print "arrayref returned:"+c$ getid arrayid - If Error_Happened Then EXIT Function - o$ = Right$(c$, Len(c$) - InStr(c$, sp3)) + IF Error_Happened THEN EXIT FUNCTION + o$ = RIGHT$(c$, LEN(c$) - INSTR(c$, sp3)) 'change o$ to a byte offset if necessary - u = typ2 And 511 + u = typ2 AND 511 s = udtxsize(u) - If udtxbytealign(u) Then - If s Mod 8 Then s = s + (8 - (s Mod 8)) 'round up to nearest byte + IF udtxbytealign(u) THEN + IF s MOD 8 THEN s = s + (8 - (s MOD 8)) 'round up to nearest byte s = s \ 8 - End If + END IF o$ = "(" + o$ + ")*" + str2$(s) 'print "calling evaludt with o$:"+o$ - GoTo evaludt - End If + GOTO evaludt + END IF - GoTo evalednextele3 - End If - End If + GOTO evalednextele3 + END IF + END IF i2 = i2 + 1 - GoTo evalnextele3 + GOTO evalnextele3 evalednextele3: blockn = blockn + 1 block(blockn) = c$ evaledblock(blockn) = 2 blocktype(blockn) = typ2 - If (typ2 And ISSTRING) Then stringprocessinghappened = 1 - GoTo evaled - End If - End If + IF (typ2 AND ISSTRING) THEN stringprocessinghappened = 1 + GOTO evaled + END IF + END IF - Else + ELSE 'not followed by "(" 'is l$ a simple variable? - If id.t <> 0 And (id.t And ISUDT) = 0 Then - If (subfuncn = id.insubfuncn And try_method <= 2) Or try_method >= 3 Then + IF id.t <> 0 AND (id.t AND ISUDT) = 0 THEN + IF (subfuncn = id.insubfuncn AND try_method <= 2) OR try_method >= 3 THEN constequation = 0 blockn = blockn + 1 makeidrefer block(blockn), blocktype(blockn) - If (blocktype(blockn) And ISSTRING) Then stringprocessinghappened = 1 + IF (blocktype(blockn) AND ISSTRING) THEN stringprocessinghappened = 1 evaledblock(blockn) = 2 - GoTo evaled - End If - End If + GOTO evaled + END IF + END IF 'is l$ a UDT? - If id.t And ISUDT Then - If (subfuncn = id.insubfuncn And try_method <= 2) Or try_method >= 3 Then + IF id.t AND ISUDT THEN + IF (subfuncn = id.insubfuncn AND try_method <= 2) OR try_method >= 3 THEN constequation = 0 o$ = "" evaludt: b2 = 0 i3 = i + 1 - For i2 = i3 To n + FOR i2 = i3 TO n e2$ = getelement(a$, i2) - If e2$ = "(" Then b2 = b2 + 1 - If b2 = 0 Then - If e2$ = ")" Or isoperator(e2$) Then + IF e2$ = "(" THEN b2 = b2 + 1 + IF b2 = 0 THEN + IF e2$ = ")" OR isoperator(e2$) THEN i4 = i2 - 1 - GoTo gotudt - End If - End If - If e2$ = ")" Then b2 = b2 - 1 - Next + GOTO gotudt + END IF + END IF + IF e2$ = ")" THEN b2 = b2 - 1 + NEXT i4 = n gotudt: - If i4 < i3 Then e$ = "" Else e$ = getelements$(a$, i3, i4) + IF i4 < i3 THEN e$ = "" ELSE e$ = getelements$(a$, i3, i4) 'PRINT "UDTREFERENCE:";l$; e$ e$ = udtreference(o$, e$, typ2) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION i = i4 blockn = blockn + 1 block(blockn) = e$ @@ -15311,207 +15311,207 @@ Function evaluate$ (a2$, typ As Long) blocktype(blockn) = typ2 'is the following next necessary? 'IF (typ2 AND ISSTRING) THEN stringprocessinghappened = 1 - GoTo evaled - End If - End If + GOTO evaled + END IF + END IF - End If '"(" or no "(" + END IF '"(" or no "(" 'is l$ a function? - If id.subfunc = 1 Then + IF id.subfunc = 1 THEN constequation = 0 - If getelement(a$, i + 1) = "(" Then + IF getelement(a$, i + 1) = "(" THEN i2 = i + 2 b2 = 0 args = 1 evalnextele: l2$ = getelement(a$, i2) - If l2$ = "(" Then b2 = b2 + 1 - If l2$ = ")" Then + IF l2$ = "(" THEN b2 = b2 + 1 + IF l2$ = ")" THEN b2 = b2 - 1 - If b2 = -1 Then - If i2 = i + 2 Then Give_Error "Expected (...)": EXIT Function + IF b2 = -1 THEN + IF i2 = i + 2 THEN Give_Error "Expected (...)": EXIT FUNCTION c$ = evaluatefunc(getelements$(a$, i + 2, i2 - 1), args, typ2) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION i = i2 - GoTo evalednextele - End If - End If - If l2$ = "," And b2 = 0 Then args = args + 1 + GOTO evalednextele + END IF + END IF + IF l2$ = "," AND b2 = 0 THEN args = args + 1 i2 = i2 + 1 - GoTo evalnextele - Else + GOTO evalnextele + ELSE 'no brackets c$ = evaluatefunc("", 0, typ2) - If Error_Happened Then EXIT Function - End If + IF Error_Happened THEN EXIT FUNCTION + END IF evalednextele: blockn = blockn + 1 block(blockn) = c$ evaledblock(blockn) = 2 blocktype(blockn) = typ2 - If (typ2 And ISSTRING) Then stringprocessinghappened = 1 - GoTo evaled - End If + IF (typ2 AND ISSTRING) THEN stringprocessinghappened = 1 + GOTO evaled + END IF - If try = 2 Then findanotherid = 1: try = findid(l$) Else try = 0 - If Error_Happened Then EXIT Function - Loop - Next 'try method (1-4) + IF try = 2 THEN findanotherid = 1: try = findid(l$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP + NEXT 'try method (1-4) 'assume l$ an undefined array? - If i <> n Then - If getelement$(a$, i + 1) = "(" Then - If isoperator(l$) = 0 Then - If isvalidvariable(l$) Then - If Debug Then - Print #9, "**************" - Print #9, "about to auto-create array:" + l$, i - Print #9, "**************" - End If + IF i <> n THEN + IF getelement$(a$, i + 1) = "(" THEN + IF isoperator(l$) = 0 THEN + IF isvalidvariable(l$) THEN + IF Debug THEN + PRINT #9, "**************" + PRINT #9, "about to auto-create array:" + l$, i + PRINT #9, "**************" + END IF dtyp$ = removesymbol(l$) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION 'count the number of elements nume = 1 b2 = 0 - For i2 = i + 2 To n + FOR i2 = i + 2 TO n e$ = getelement(a$, i2) - If e$ = "(" Then b2 = b2 + 1 - If b2 = 0 And e$ = "," Then nume = nume + 1 - If e$ = ")" Then b2 = b2 - 1 - If b2 = -1 Then Exit For - Next - fakee$ = "10": For i2 = 2 To nume: fakee$ = fakee$ + sp + "," + sp + "10": Next - If Debug Then Print #9, "evaluate:creating undefined array using dim2(" + l$ + "," + dtyp$ + ",1," + fakee$ + ")" - If optionexplicit Or optionexplicitarray Then Give_Error "Array '" + l$ + "' (" + symbol2fulltypename$(dtyp$) + ") not defined": EXIT Function - If Error_Happened Then EXIT Function + IF e$ = "(" THEN b2 = b2 + 1 + IF b2 = 0 AND e$ = "," THEN nume = nume + 1 + IF e$ = ")" THEN b2 = b2 - 1 + IF b2 = -1 THEN EXIT FOR + NEXT + fakee$ = "10": FOR i2 = 2 TO nume: fakee$ = fakee$ + sp + "," + sp + "10": NEXT + IF Debug THEN PRINT #9, "evaluate:creating undefined array using dim2(" + l$ + "," + dtyp$ + ",1," + fakee$ + ")" + IF optionexplicit OR optionexplicitarray THEN Give_Error "Array '" + l$ + "' (" + symbol2fulltypename$(dtyp$) + ") not defined": EXIT FUNCTION + IF Error_Happened THEN EXIT FUNCTION olddimstatic = dimstatic method = 1 - If subfuncn Then + IF subfuncn THEN autoarray = 1 'move dimensioning of auto array to data???.txt from inline 'static array declared by STATIC name()? 'check if varname is on the static list xi = 1 - For x = 1 To staticarraylistn + FOR x = 1 TO staticarraylistn varname2$ = getelement$(staticarraylist, xi): xi = xi + 1 typ2$ = getelement$(staticarraylist, xi): xi = xi + 1 - dimmethod2 = Val(getelement$(staticarraylist, xi)): xi = xi + 1 + dimmethod2 = VAL(getelement$(staticarraylist, xi)): xi = xi + 1 'check if they are similar - If UCase$(l$) = UCase$(varname2$) Then + IF UCASE$(l$) = UCASE$(varname2$) THEN l3$ = l2$: s$ = removesymbol(l3$) - If symbol2fulltypename$(dtyp$) = typ2$ Or (dimmethod2 = 0 And s$ = "") Then - If Error_Happened Then EXIT Function + IF symbol2fulltypename$(dtyp$) = typ2$ OR (dimmethod2 = 0 AND s$ = "") THEN + IF Error_Happened THEN EXIT FUNCTION 'adopt properties l$ = varname2$ dtyp$ = typ2$ method = dimmethod2 dimstatic = 3 - End If 'typ - If Error_Happened Then EXIT Function - End If 'varname - Next - End If 'subfuncn + END IF 'typ + IF Error_Happened THEN EXIT FUNCTION + END IF 'varname + NEXT + END IF 'subfuncn bypassNextVariable = -1 ignore = dim2(l$, dtyp$, method, fakee$) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION dimstatic = olddimstatic - If Debug Then Print #9, "#*#*#* dim2 has returned!!!" - GoTo reevaluate - End If - End If - End If - End If + IF Debug THEN PRINT #9, "#*#*#* dim2 has returned!!!" + GOTO reevaluate + END IF + END IF + END IF + END IF l$ = l2$ 'restore l$ - End If 'b=0 + END IF 'b=0 - If l$ = "(" Then - If b = 0 Then i1 = i + 1 + IF l$ = "(" THEN + IF b = 0 THEN i1 = i + 1 b = b + 1 - End If + END IF - If b = 0 Then + IF b = 0 THEN blockn = blockn + 1 block(blockn) = l$ evaledblock(blockn) = 0 - End If + END IF - If l$ = ")" Then + IF l$ = ")" THEN b = b - 1 - If b = 0 Then + IF b = 0 THEN c$ = evaluate(getelements$(a$, i1, i - 1), typ2) - If Error_Happened Then EXIT Function - If (typ2 And ISSTRING) Then stringprocessinghappened = 1 + IF Error_Happened THEN EXIT FUNCTION + IF (typ2 AND ISSTRING) THEN stringprocessinghappened = 1 blockn = blockn + 1 - If (typ2 And ISPOINTER) Then + IF (typ2 AND ISPOINTER) THEN block(blockn) = c$ - Else + ELSE block(blockn) = "(" + c$ + ")" - End If + END IF evaledblock(blockn) = 1 blocktype(blockn) = typ2 - End If - End If + END IF + END IF evaled: - Next + NEXT r$ = "" 'return value - If Debug Then Print #9, "evaluated blocks:"; - For i = 1 To blockn - If i <> blockn Then - If Debug Then Print #9, block(i) + Chr$(219); - Else - If Debug Then Print #9, block(i) - End If - Next + IF Debug THEN PRINT #9, "evaluated blocks:"; + FOR i = 1 TO blockn + IF i <> blockn THEN + IF Debug THEN PRINT #9, block(i) + CHR$(219); + ELSE + IF Debug THEN PRINT #9, block(i) + END IF + NEXT 'identify any referencable values - For i = 1 To blockn - If isoperator(block(i)) = 0 Then - If evaledblock(i) = 0 Then + FOR i = 1 TO blockn + IF isoperator(block(i)) = 0 THEN + IF evaledblock(i) = 0 THEN 'a number? - c = Asc(Left$(block(i), 1)) - If c = 45 Or (c >= 48 And c <= 57) Then + c = ASC(LEFT$(block(i), 1)) + IF c = 45 OR (c >= 48 AND c <= 57) THEN num$ = block(i) 'a float? f = 0 - x = InStr(num$, "E") - If x Then + x = INSTR(num$, "E") + IF x THEN f = 1: blocktype(i) = SINGLETYPE - ISPOINTER - Else - x = InStr(num$, "D") - If x Then + ELSE + x = INSTR(num$, "D") + IF x THEN f = 2: blocktype(i) = DOUBLETYPE - ISPOINTER - Else - x = InStr(num$, "F") - If x Then + ELSE + x = INSTR(num$, "F") + IF x THEN f = 3: blocktype(i) = FLOATTYPE - ISPOINTER - End If - End If - End If - If f Then + END IF + END IF + END IF + IF f THEN 'float - If f = 2 Or f = 3 Then Mid$(num$, x, 1) = "E" 'D,F invalid in C++ - If f = 3 Then num$ = num$ + "L" 'otherwise number is rounded to a double - Else + IF f = 2 OR f = 3 THEN MID$(num$, x, 1) = "E" 'D,F invalid in C++ + IF f = 3 THEN num$ = num$ + "L" 'otherwise number is rounded to a double + ELSE 'integer blocktype(i) = typname2typ(removesymbol$(num$)) - If Error_Happened Then EXIT Function - If blocktype(i) And ISPOINTER Then blocktype(i) = blocktype(i) - ISPOINTER - If (blocktype(i) And 511) > 32 Then - If blocktype(i) And ISUNSIGNED Then num$ = num$ + "ull" Else num$ = num$ + "ll" - End If - End If + IF Error_Happened THEN EXIT FUNCTION + IF blocktype(i) AND ISPOINTER THEN blocktype(i) = blocktype(i) - ISPOINTER + IF (blocktype(i) AND 511) > 32 THEN + IF blocktype(i) AND ISUNSIGNED THEN num$ = num$ + "ull" ELSE num$ = num$ + "ll" + END IF + END IF block(i) = " " + num$ + " " 'pad with spaces to avoid C++ computation errors evaledblock(i) = 1 - GoTo evaledblock - End If + GOTO evaledblock + END IF 'number? 'fc = ASC(LEFT$(block(i), 1)) @@ -15568,93 +15568,93 @@ Function evaluate$ (a2$, typ As Long) 'END IF 'a typed string in "" - If Left$(block(i), 1) = Chr$(34) Then - If Right$(block(i), 1) <> Chr$(34) Then + IF LEFT$(block(i), 1) = CHR$(34) THEN + IF RIGHT$(block(i), 1) <> CHR$(34) THEN block(i) = "qbs_new_txt_len(" + block(i) + ")" - Else + ELSE block(i) = "qbs_new_txt(" + block(i) + ")" - End If + END IF blocktype(i) = ISSTRING evaledblock(i) = 1 stringprocessinghappened = 1 - GoTo evaledblock - End If + GOTO evaledblock + END IF 'create variable - If isvalidvariable(block(i)) Then + IF isvalidvariable(block(i)) THEN x$ = block(i) typ$ = removesymbol$(x$) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION 'add symbol extension if none given - If Len(typ$) = 0 Then - If Left$(x$, 1) = "_" Then v = 27 Else v = Asc(UCase$(x$)) - 64 + IF LEN(typ$) = 0 THEN + IF LEFT$(x$, 1) = "_" THEN v = 27 ELSE v = ASC(UCASE$(x$)) - 64 typ$ = defineextaz(v) - End If + END IF 'check that it hasn't just been created within this loop (a=b+b) try = findid(x$ + typ$) - If Error_Happened Then EXIT Function - Do While try - If Debug Then Print #9, try - If id.t <> 0 And (id.t And ISUDT) = 0 Then 'is x$ a simple variable? - GoTo simplevarfound - End If - If try = 2 Then findanotherid = 1: try = findid(x$ + typ$) Else try = 0 - If Error_Happened Then EXIT Function - Loop + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF Debug THEN PRINT #9, try + IF id.t <> 0 AND (id.t AND ISUDT) = 0 THEN 'is x$ a simple variable? + GOTO simplevarfound + END IF + IF try = 2 THEN findanotherid = 1: try = findid(x$ + typ$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP - If Debug Then Print #9, "CREATING VARIABLE:" + x$ - If optionexplicit Then Give_Error "Variable '" + x$ + "' (" + symbol2fulltypename$(typ$) + ") not defined": EXIT Function + IF Debug THEN PRINT #9, "CREATING VARIABLE:" + x$ + IF optionexplicit THEN Give_Error "Variable '" + x$ + "' (" + symbol2fulltypename$(typ$) + ") not defined": EXIT FUNCTION bypassNextVariable = -1 retval = dim2(x$, typ$, 1, "") - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION simplevarfound: constequation = 0 makeidrefer block(i), blocktype(i) - If (blocktype(i) And ISSTRING) Then stringprocessinghappened = 1 - If blockn = 1 Then - If (blocktype(i) And ISREFERENCE) Then GoTo returnpointer - End If + IF (blocktype(i) AND ISSTRING) THEN stringprocessinghappened = 1 + IF blockn = 1 THEN + IF (blocktype(i) AND ISREFERENCE) THEN GOTO returnpointer + END IF 'reference value - block(i) = refer(block(i), blocktype(i), 0): If Error_Happened Then EXIT Function + block(i) = refer(block(i), blocktype(i), 0): IF Error_Happened THEN EXIT FUNCTION evaledblock(i) = 1 - GoTo evaledblock - End If - Give_Error "Invalid expression": EXIT Function + GOTO evaledblock + END IF + Give_Error "Invalid expression": EXIT FUNCTION - Else - If (blocktype(i) And ISREFERENCE) Then - If blockn = 1 Then GoTo returnpointer + ELSE + IF (blocktype(i) AND ISREFERENCE) THEN + IF blockn = 1 THEN GOTO returnpointer 'if blocktype(i) and ISUDT then PRINT "UDT passed to refer by evaluate" block(i) = refer(block(i), blocktype(i), 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION - End If + END IF - End If - End If + END IF + END IF evaledblock: - Next + NEXT 'return a POINTER if possible - If blockn = 1 Then - If evaledblock(1) Then - If (blocktype(1) And ISREFERENCE) Then + IF blockn = 1 THEN + IF evaledblock(1) THEN + IF (blocktype(1) AND ISREFERENCE) THEN returnpointer: - If (blocktype(1) And ISSTRING) Then stringprocessinghappened = 1 - If Debug Then Print #9, "evaluated reference:" + block(1) + IF (blocktype(1) AND ISSTRING) THEN stringprocessinghappened = 1 + IF Debug THEN PRINT #9, "evaluated reference:" + block(1) typ = blocktype(1) evaluate$ = block(1) - EXIT Function - End If - End If - End If + EXIT FUNCTION + END IF + END IF + END IF 'it cannot be returned as a pointer @@ -15664,24 +15664,24 @@ Function evaluate$ (a2$, typ As Long) - If Debug Then Print #9, "applying operators:"; + IF Debug THEN PRINT #9, "applying operators:"; - If typ = -1 Then + IF typ = -1 THEN typ = blocktype(1) 'init typ with first blocktype - If isoperator(block(1)) Then 'but what if it starts with a UNARY operator? + IF isoperator(block(1)) THEN 'but what if it starts with a UNARY operator? typ = blocktype(2) 'init typ with second blocktype - End If - End If + END IF + END IF nonop = 0 - For i = 1 To blockn + FOR i = 1 TO blockn - If evaledblock(i) = 0 Then + IF evaledblock(i) = 0 THEN isop = isoperator(block(i)) - If isop Then + IF isop THEN nonop = 0 constequation = 0 @@ -15690,14 +15690,14 @@ Function evaluate$ (a2$, typ As Long) o$ = block(i) u = operatorusage(o$, typ, i$, lhstyp, rhstyp, result) - If u <> 5 Then 'not unary + IF u <> 5 THEN 'not unary nonop = 1 - If i = 1 Or evaledblock(i - 1) = 0 Then - If i = 1 And blockn = 1 And o$ = "-" Then Give_Error "Expected variable/value after '" + UCase$(o$) + "'": EXIT Function 'guess - is neg in this case - Give_Error "Expected variable/value before '" + UCase$(o$) + "'": EXIT Function - End If - End If - If i = blockn Or evaledblock(i + 1) = 0 Then Give_Error "Expected variable/value after '" + UCase$(o$) + "'": EXIT Function + IF i = 1 OR evaledblock(i - 1) = 0 THEN + IF i = 1 AND blockn = 1 AND o$ = "-" THEN Give_Error "Expected variable/value after '" + UCASE$(o$) + "'": EXIT FUNCTION 'guess - is neg in this case + Give_Error "Expected variable/value before '" + UCASE$(o$) + "'": EXIT FUNCTION + END IF + END IF + IF i = blockn OR evaledblock(i + 1) = 0 THEN Give_Error "Expected variable/value after '" + UCASE$(o$) + "'": EXIT FUNCTION 'lhstyp & rhstyp bit-field values '1=integeral @@ -15718,96 +15718,96 @@ Function evaluate$ (a2$, typ As Long) 'numeric->string is illegal! - If (typ And ISSTRING) = 0 And (newtyp And ISSTRING) <> 0 Then - Give_Error "Cannot convert number to string": EXIT Function - End If + IF (typ AND ISSTRING) = 0 AND (newtyp AND ISSTRING) <> 0 THEN + Give_Error "Cannot convert number to string": EXIT FUNCTION + END IF 'Offset protection: Override conversion rules for operator as necessary offsetmode = 0 offsetcvi = 0 - If (oldtyp And ISOFFSET) <> 0 Or (newtyp And ISOFFSET) <> 0 Then + IF (oldtyp AND ISOFFSET) <> 0 OR (newtyp AND ISOFFSET) <> 0 THEN offsetmode = 2 - If newtyp And ISOFFSET Then - If (newtyp And ISUNSIGNED) = 0 Then offsetmode = 1 - End If - If oldtyp And ISOFFSET Then - If (oldtyp And ISUNSIGNED) = 0 Then offsetmode = 1 - End If + IF newtyp AND ISOFFSET THEN + IF (newtyp AND ISUNSIGNED) = 0 THEN offsetmode = 1 + END IF + IF oldtyp AND ISOFFSET THEN + IF (oldtyp AND ISUNSIGNED) = 0 THEN offsetmode = 1 + END IF 'depending on the operater we may do things differently 'the default method is convert both sides to integer first 'but these operators are different: * / ^ - If o$ = "*" Or o$ = "/" Or o$ = "^" Then - If o$ = "*" Or o$ = "^" Then + IF o$ = "*" OR o$ = "/" OR o$ = "^" THEN + IF o$ = "*" OR o$ = "^" THEN 'for mult, if either side is a float cast integers to 'long double's first - If (newtyp And ISFLOAT) <> 0 Or (oldtyp And ISFLOAT) <> 0 Then + IF (newtyp AND ISFLOAT) <> 0 OR (oldtyp AND ISFLOAT) <> 0 THEN offsetcvi = 1 - If (oldtyp And ISFLOAT) = 0 Then lhstyp = 2 - If (newtyp And ISFLOAT) = 0 Then rhstyp = 2 - End If - End If - If o$ = "/" Or o$ = "^" Then + IF (oldtyp AND ISFLOAT) = 0 THEN lhstyp = 2 + IF (newtyp AND ISFLOAT) = 0 THEN rhstyp = 2 + END IF + END IF + IF o$ = "/" OR o$ = "^" THEN 'for division or exponentials, to prevent integer division cast integers to 'long double's offsetcvi = 1 - If (oldtyp And ISFLOAT) = 0 Then lhstyp = 2 - If (newtyp And ISFLOAT) = 0 Then rhstyp = 2 - End If - Else - If lhstyp And 2 Then lhstyp = 1 'force lhs and rhs to be integer values - If rhstyp And 2 Then rhstyp = 1 - End If + IF (oldtyp AND ISFLOAT) = 0 THEN lhstyp = 2 + IF (newtyp AND ISFLOAT) = 0 THEN rhstyp = 2 + END IF + ELSE + IF lhstyp AND 2 THEN lhstyp = 1 'force lhs and rhs to be integer values + IF rhstyp AND 2 THEN rhstyp = 1 + END IF - If result = 2 Then result = 1 'force integer result + IF result = 2 THEN result = 1 'force integer result 'note: result=1 just sets typ&=64 if typ is a float - End If + END IF 'STEP 1: convert oldtyp and/or newtyp if required for the operator 'convert lhs - If (oldtyp And ISSTRING) Then - If (lhstyp And 4) = 0 Then Give_Error "Cannot convert string to number": EXIT Function - Else + IF (oldtyp AND ISSTRING) THEN + IF (lhstyp AND 4) = 0 THEN Give_Error "Cannot convert string to number": EXIT FUNCTION + ELSE 'oldtyp is numeric - If lhstyp = 4 Then Give_Error "Cannot convert number to string": EXIT Function - If (oldtyp And ISFLOAT) Then - If (lhstyp And 2) = 0 Then + IF lhstyp = 4 THEN Give_Error "Cannot convert number to string": EXIT FUNCTION + IF (oldtyp AND ISFLOAT) THEN + IF (lhstyp AND 2) = 0 THEN 'convert float to int block(i - 1) = "qbr(" + block(i - 1) + ")" oldtyp = 64& - End If - Else + END IF + ELSE 'oldtyp is an int - If (lhstyp And 1) = 0 Then + IF (lhstyp AND 1) = 0 THEN 'convert int to float block(i - 1) = "((long double)(" + block(i - 1) + "))" oldtyp = 256& + ISFLOAT - End If - End If - End If + END IF + END IF + END IF 'convert rhs - If (newtyp And ISSTRING) Then - If (rhstyp And 4) = 0 Then Give_Error "Cannot convert string to number": EXIT Function - Else + IF (newtyp AND ISSTRING) THEN + IF (rhstyp AND 4) = 0 THEN Give_Error "Cannot convert string to number": EXIT FUNCTION + ELSE 'newtyp is numeric - If rhstyp = 4 Then Give_Error "Cannot convert number to string": EXIT Function - If (newtyp And ISFLOAT) Then - If (rhstyp And 2) = 0 Then + IF rhstyp = 4 THEN Give_Error "Cannot convert number to string": EXIT FUNCTION + IF (newtyp AND ISFLOAT) THEN + IF (rhstyp AND 2) = 0 THEN 'convert float to int block(i + 1) = "qbr(" + block(i + 1) + ")" newtyp = 64& - End If - Else + END IF + ELSE 'newtyp is an int - If (rhstyp And 1) = 0 Then + IF (rhstyp AND 1) = 0 THEN 'convert int to float block(i + 1) = "((long double)(" + block(i + 1) + "))" newtyp = 256& + ISFLOAT - End If - End If - End If + END IF + END IF + END IF 'Reduce floating point values to common base for comparison? - If isop = 7 Then 'comparitive operator + IF isop = 7 THEN 'comparitive operator 'Corrects problems encountered such as: ' S = 2.1 ' IF S = 2.1 THEN PRINT "OK" ELSE PRINT "ERROR S PRINTS AS"; S; "BUT IS SEEN BY QB64 AS..." @@ -15817,19 +15817,19 @@ Function evaluate$ (a2$, typ As Long) 'solution: assess, and only apply to SINGLE variables/arrays '2. Comparison of a double higher/lower than single range may fail 'solution: out of range values convert to +/-1.#INF, making comparison still possible - If (oldtyp And ISFLOAT) <> 0 And (newtyp And ISFLOAT) <> 0 Then 'both floating point - s1 = oldtyp And 511: s2 = newtyp And 511 - If s2 < s1 Then s1 = s2 - If s1 = 32 Then + IF (oldtyp AND ISFLOAT) <> 0 AND (newtyp AND ISFLOAT) <> 0 THEN 'both floating point + s1 = oldtyp AND 511: s2 = newtyp AND 511 + IF s2 < s1 THEN s1 = s2 + IF s1 = 32 THEN block(i - 1) = "((float)(" + block(i - 1) + "))": oldtyp = 32& + ISFLOAT block(i + 1) = "((float)(" + block(i + 1) + "))": newtyp = 32& + ISFLOAT - End If - If s1 = 64 Then + END IF + IF s1 = 64 THEN block(i - 1) = "((double)(" + block(i - 1) + "))": oldtyp = 64& + ISFLOAT block(i + 1) = "((double)(" + block(i + 1) + "))": newtyp = 64& + ISFLOAT - End If - End If 'both floating point - End If 'comparitive operator + END IF + END IF 'both floating point + END IF 'comparitive operator typ = newtyp @@ -15838,310 +15838,310 @@ Function evaluate$ (a2$, typ As Long) ' if either side is integer, markup typ 'Note: A markup is a GUESS of what the return type will be, ' 'result' can override this markup - If (oldtyp And ISSTRING) = 0 And (newtyp And ISSTRING) = 0 Then - If (oldtyp And ISFLOAT) <> 0 Or (newtyp And ISFLOAT) <> 0 Then + IF (oldtyp AND ISSTRING) = 0 AND (newtyp AND ISSTRING) = 0 THEN + IF (oldtyp AND ISFLOAT) <> 0 OR (newtyp AND ISFLOAT) <> 0 THEN 'float - b = 0: If (oldtyp And ISFLOAT) Then b = oldtyp And 511 - If (newtyp And ISFLOAT) Then - b2 = newtyp And 511: If b2 > b Then b = b2 - End If + b = 0: IF (oldtyp AND ISFLOAT) THEN b = oldtyp AND 511 + IF (newtyp AND ISFLOAT) THEN + b2 = newtyp AND 511: IF b2 > b THEN b = b2 + END IF typ = ISFLOAT + b - Else + ELSE 'integer '***THIS IS THE IDEAL MARKUP FOR A 64-BIT SYSTEM*** 'In reality 32-bit C++ only marks-up to 32-bit integers - b = oldtyp And 511: b2 = newtyp And 511: If b2 > b Then b = b2 + b = oldtyp AND 511: b2 = newtyp AND 511: IF b2 > b THEN b = b2 typ = 64& - If b = 64 Then - If (oldtyp And ISUNSIGNED) <> 0 And (newtyp And ISUNSIGNED) <> 0 Then typ = 64& + ISUNSIGNED - End If - End If - End If + IF b = 64 THEN + IF (oldtyp AND ISUNSIGNED) <> 0 AND (newtyp AND ISUNSIGNED) <> 0 THEN typ = 64& + ISUNSIGNED + END IF + END IF + END IF - If result = 1 Then - If (typ And ISFLOAT) <> 0 Or (typ And ISSTRING) <> 0 Then typ = 64 'otherwise keep markuped integer type - End If - If result = 2 Then - If (typ And ISFLOAT) = 0 Then typ = ISFLOAT + 256 - End If - If result = 4 Then + IF result = 1 THEN + IF (typ AND ISFLOAT) <> 0 OR (typ AND ISSTRING) <> 0 THEN typ = 64 'otherwise keep markuped integer type + END IF + IF result = 2 THEN + IF (typ AND ISFLOAT) = 0 THEN typ = ISFLOAT + 256 + END IF + IF result = 4 THEN typ = ISSTRING - End If - If result = 8 Then 'bool + END IF + IF result = 8 THEN 'bool typ = 32 - End If + END IF 'Offset protection: Force result to be an offset type with correct signage - If offsetmode Then - If result <> 8 Then 'boolean comparison results are allowed - typ = OFFSETTYPE - ISPOINTER: If offsetmode = 2 Then typ = typ + ISUNSIGNED - End If - End If + IF offsetmode THEN + IF result <> 8 THEN 'boolean comparison results are allowed + typ = OFFSETTYPE - ISPOINTER: IF offsetmode = 2 THEN typ = typ + ISUNSIGNED + END IF + END IF 'override typ=ISFLOAT+256 to typ=ISFLOAT+64 for ^ operator's result - If u = 2 Then - If i$ = "pow2" Then + IF u = 2 THEN + IF i$ = "pow2" THEN - If offsetmode Then Give_Error "Operator '^' cannot be used with an _OFFSET": EXIT Function + IF offsetmode THEN Give_Error "Operator '^' cannot be used with an _OFFSET": EXIT FUNCTION 'QB-like conversion of math functions returning floating point values 'reassess oldtype & newtype - b = oldtyp And 511 - If oldtyp And ISFLOAT Then + b = oldtyp AND 511 + IF oldtyp AND ISFLOAT THEN 'no change to b - Else - If b > 16 Then b = 64 'larger than INTEGER? return DOUBLE - If b > 32 Then b = 256 'larger than LONG? return FLOAT - If b <= 16 Then b = 32 - End If - b2 = newtyp And 511 - If newtyp And ISFLOAT Then - If b2 > b Then b = b2 - Else + ELSE + IF b > 16 THEN b = 64 'larger than INTEGER? return DOUBLE + IF b > 32 THEN b = 256 'larger than LONG? return FLOAT + IF b <= 16 THEN b = 32 + END IF + b2 = newtyp AND 511 + IF newtyp AND ISFLOAT THEN + IF b2 > b THEN b = b2 + ELSE b3 = 32 - If b2 > 16 Then b3 = 64 'larger than INTEGER? return DOUBLE - If b2 > 32 Then b3 = 256 'larger than LONG? return FLOAT - If b3 > b Then b = b3 - End If + IF b2 > 16 THEN b3 = 64 'larger than INTEGER? return DOUBLE + IF b2 > 32 THEN b3 = 256 'larger than LONG? return FLOAT + IF b3 > b THEN b = b3 + END IF typ = ISFLOAT + b - End If 'pow2 - End If 'u=2 + END IF 'pow2 + END IF 'u=2 'STEP 3: apply operator appropriately - If u = 5 Then + IF u = 5 THEN block(i + 1) = i$ + "(" + block(i + 1) + ")" - block(i) = "": i = i + 1: GoTo operatorapplied - End If + block(i) = "": i = i + 1: GOTO operatorapplied + END IF 'binary operators - If u = 1 Then + IF u = 1 THEN block(i + 1) = block(i - 1) + i$ + block(i + 1) - block(i - 1) = "": block(i) = "": i = i + 1: GoTo operatorapplied - End If + block(i - 1) = "": block(i) = "": i = i + 1: GOTO operatorapplied + END IF - If u = 2 Then + IF u = 2 THEN block(i + 1) = i$ + "(" + block(i - 1) + "," + block(i + 1) + ")" - block(i - 1) = "": block(i) = "": i = i + 1: GoTo operatorapplied - End If + block(i - 1) = "": block(i) = "": i = i + 1: GOTO operatorapplied + END IF - If u = 3 Then + IF u = 3 THEN block(i + 1) = "-(" + block(i - 1) + i$ + block(i + 1) + ")" - block(i - 1) = "": block(i) = "": i = i + 1: GoTo operatorapplied - End If + block(i - 1) = "": block(i) = "": i = i + 1: GOTO operatorapplied + END IF - If u = 4 Then + IF u = 4 THEN block(i + 1) = "~" + block(i - 1) + i$ + block(i + 1) - block(i - 1) = "": block(i) = "": i = i + 1: GoTo operatorapplied - End If + block(i - 1) = "": block(i) = "": i = i + 1: GOTO operatorapplied + END IF '...more?... - Give_Error "ERROR: Operator could not be applied correctly!": EXIT Function '<--should never happen! + Give_Error "ERROR: Operator could not be applied correctly!": EXIT FUNCTION '<--should never happen! operatorapplied: - If offsetcvi Then block(i) = "qbr(" + block(i) + ")": offsetcvi = 0 + IF offsetcvi THEN block(i) = "qbr(" + block(i) + ")": offsetcvi = 0 offsetmode = 0 - Else + ELSE nonop = nonop + 1 - End If - Else + END IF + ELSE nonop = nonop + 1 - End If - If nonop > 1 Then Give_Error "Expected operator in equation": EXIT Function - Next - If Debug Then Print #9, "" + END IF + IF nonop > 1 THEN Give_Error "Expected operator in equation": EXIT FUNCTION + NEXT + IF Debug THEN PRINT #9, "" 'join blocks - For i = 1 To blockn + FOR i = 1 TO blockn r$ = r$ + block(i) - Next + NEXT - If Debug Then - Print #9, "evaluated:" + r$ + " AS TYPE:"; - If (typ And ISSTRING) Then Print #9, "[ISSTRING]"; - If (typ And ISFLOAT) Then Print #9, "[ISFLOAT]"; - If (typ And ISUNSIGNED) Then Print #9, "[ISUNSIGNED]"; - If (typ And ISPOINTER) Then Print #9, "[ISPOINTER]"; - If (typ And ISFIXEDLENGTH) Then Print #9, "[ISFIXEDLENGTH]"; - If (typ And ISINCONVENTIONALMEMORY) Then Print #9, "[ISINCONVENTIONALMEMORY]"; - Print #9, "(size in bits=" + str2$(typ And 511) + ")" - End If + IF Debug THEN + PRINT #9, "evaluated:" + r$ + " AS TYPE:"; + IF (typ AND ISSTRING) THEN PRINT #9, "[ISSTRING]"; + IF (typ AND ISFLOAT) THEN PRINT #9, "[ISFLOAT]"; + IF (typ AND ISUNSIGNED) THEN PRINT #9, "[ISUNSIGNED]"; + IF (typ AND ISPOINTER) THEN PRINT #9, "[ISPOINTER]"; + IF (typ AND ISFIXEDLENGTH) THEN PRINT #9, "[ISFIXEDLENGTH]"; + IF (typ AND ISINCONVENTIONALMEMORY) THEN PRINT #9, "[ISINCONVENTIONALMEMORY]"; + PRINT #9, "(size in bits=" + str2$(typ AND 511) + ")" + END IF evaluate$ = r$ -End Function +END FUNCTION -Function evaluatefunc$ (a2$, args As Long, typ As Long) +FUNCTION evaluatefunc$ (a2$, args AS LONG, typ AS LONG) a$ = a2$ - If Debug Then Print #9, "evaluatingfunction:" + RTrim$(id.n) + ":" + a$ + IF Debug THEN PRINT #9, "evaluatingfunction:" + RTRIM$(id.n) + ":" + a$ - Dim id2 As idstruct + DIM id2 AS idstruct id2 = id - n$ = RTrim$(id2.n) + n$ = RTRIM$(id2.n) typ = id2.ret targetid = currentid - If RTrim$(id2.callname) = "func_stub" Then Give_Error "Command not implemented": EXIT Function + IF RTRIM$(id2.callname) = "func_stub" THEN Give_Error "Command not implemented": EXIT FUNCTION SetDependency id2.Dependency passomit = 0 omitarg_first = 0: omitarg_last = 0 - f$ = RTrim$(id2.specialformat) - If Len(f$) Then 'special format given + f$ = RTRIM$(id2.specialformat) + IF LEN(f$) THEN 'special format given 'count omittable args sqb = 0 a = 0 - For fi = 1 To Len(f$) - fa = Asc(f$, fi) - If fa = ASC_QUESTIONMARK Then + FOR fi = 1 TO LEN(f$) + fa = ASC(f$, fi) + IF fa = ASC_QUESTIONMARK THEN a = a + 1 - If sqb <> 0 And omitarg_first = 0 Then omitarg_first = a - End If - If fa = ASC_LEFTSQUAREBRACKET Then sqb = 1 - If fa = ASC_RIGHTSQUAREBRACKET Then sqb = 0: omitarg_last = a - Next + IF sqb <> 0 AND omitarg_first = 0 THEN omitarg_first = a + END IF + IF fa = ASC_LEFTSQUAREBRACKET THEN sqb = 1 + IF fa = ASC_RIGHTSQUAREBRACKET THEN sqb = 0: omitarg_last = a + NEXT omitargs = omitarg_last - omitarg_first + 1 - If args <> id2.args - omitargs And args <> id2.args Then Give_Error "Incorrect number of arguments passed to function": EXIT Function + IF args <> id2.args - omitargs AND args <> id2.args THEN Give_Error "Incorrect number of arguments passed to function": EXIT FUNCTION passomit = 1 'pass omit flags param to function - If id2.args = args Then omitarg_first = 0: omitarg_last = 0 'all arguments were passed! + IF id2.args = args THEN omitarg_first = 0: omitarg_last = 0 'all arguments were passed! - Else 'no special format given + ELSE 'no special format given - If n$ = "ASC" And args = 2 Then GoTo skipargnumchk - If id2.overloaded = -1 And (args >= id2.minargs And args <= id2.args) Then GoTo skipargnumchk + IF n$ = "ASC" AND args = 2 THEN GOTO skipargnumchk + IF id2.overloaded = -1 AND (args >= id2.minargs AND args <= id2.args) THEN GOTO skipargnumchk - If id2.args <> args Then Give_Error "Incorrect number of arguments passed to function": EXIT Function + IF id2.args <> args THEN Give_Error "Incorrect number of arguments passed to function": EXIT FUNCTION - End If + END IF skipargnumchk: - r$ = RTrim$(id2.callname) + "(" + r$ = RTRIM$(id2.callname) + "(" - If id2.args <> 0 Then + IF id2.args <> 0 THEN curarg = 1 firsti = 1 n = numelements(a$) - If n = 0 Then i = 0: GoTo noargs + IF n = 0 THEN i = 0: GOTO noargs - For i = 1 To n + FOR i = 1 TO n - If curarg >= omitarg_first And curarg <= omitarg_last Then + IF curarg >= omitarg_first AND curarg <= omitarg_last THEN noargs: - targettyp = CVL(Mid$(id2.arg, curarg * 4 - 4 + 1, 4)) + targettyp = CVL(MID$(id2.arg, curarg * 4 - 4 + 1, 4)) 'IF (targettyp AND ISSTRING) THEN Give_Error "QB64 doesn't support optional string arguments for functions yet!": EXIT FUNCTION - For fi = 1 To omitargs - 1: r$ = r$ + "NULL,": Next: r$ = r$ + "NULL" + FOR fi = 1 TO omitargs - 1: r$ = r$ + "NULL,": NEXT: r$ = r$ + "NULL" curarg = curarg + omitargs - If i = n Then Exit For + IF i = n THEN EXIT FOR r$ = r$ + "," - End If + END IF l$ = getelement(a$, i) - If l$ = "(" Then b = b + 1 - If l$ = ")" Then b = b - 1 - If (l$ = "," And b = 0) Or (i = n) Then + IF l$ = "(" THEN b = b + 1 + IF l$ = ")" THEN b = b - 1 + IF (l$ = "," AND b = 0) OR (i = n) THEN - targettyp = CVL(Mid$(id2.arg, curarg * 4 - 4 + 1, 4)) - nele = Asc(Mid$(id2.nele, curarg, 1)) - nelereq = Asc(Mid$(id2.nelereq, curarg, 1)) + targettyp = CVL(MID$(id2.arg, curarg * 4 - 4 + 1, 4)) + nele = ASC(MID$(id2.nele, curarg, 1)) + nelereq = ASC(MID$(id2.nelereq, curarg, 1)) - If i = n Then + IF i = n THEN e$ = getelements$(a$, firsti, i) - Else + ELSE e$ = getelements$(a$, firsti, i - 1) - End If + END IF - If Left$(e$, 2) = "(" + sp Then dereference = 1 Else dereference = 0 + IF LEFT$(e$, 2) = "(" + sp THEN dereference = 1 ELSE dereference = 0 '*special case CVI,CVL,CVS,CVD,_CV (part #1) - If n$ = "_CV" Or (n$ = "CV" And qb64prefix_set = 1) Then - If curarg = 1 Then + IF n$ = "_CV" OR (n$ = "CV" AND qb64prefix_set = 1) THEN + IF curarg = 1 THEN cvtype$ = type2symbol$(e$) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION e$ = "" - GoTo dontevaluate - End If - End If + GOTO dontevaluate + END IF + END IF '*special case MKI,MKL,MKS,MKD,_MK (part #1) - If n$ = "_MK" Or (n$ = "MK" And qb64prefix_set = 1) Then - If RTrim$(id2.musthave) = "$" Then - If curarg = 1 Then + IF n$ = "_MK" OR (n$ = "MK" AND qb64prefix_set = 1) THEN + IF RTRIM$(id2.musthave) = "$" THEN + IF curarg = 1 THEN mktype$ = type2symbol$(e$) - If Error_Happened Then EXIT Function - If Debug Then Print #9, "_MK:[" + e$ + "]:[" + mktype$ + "]" + IF Error_Happened THEN EXIT FUNCTION + IF Debug THEN PRINT #9, "_MK:[" + e$ + "]:[" + mktype$ + "]" e$ = "" - GoTo dontevaluate - End If - End If - End If + GOTO dontevaluate + END IF + END IF + END IF - If n$ = "UBOUND" Or n$ = "LBOUND" Then - If curarg = 1 Then + IF n$ = "UBOUND" OR n$ = "LBOUND" THEN + IF curarg = 1 THEN 'perform a "fake" evaluation of the array e$ = e$ + sp + "(" + sp + ")" e$ = evaluate(e$, sourcetyp) - If Error_Happened Then EXIT Function - If (sourcetyp And ISREFERENCE) = 0 Then Give_Error "Expected array-name": EXIT Function - If (sourcetyp And ISARRAY) = 0 Then Give_Error "Expected array-name": EXIT Function + IF Error_Happened THEN EXIT FUNCTION + IF (sourcetyp AND ISREFERENCE) = 0 THEN Give_Error "Expected array-name": EXIT FUNCTION + IF (sourcetyp AND ISARRAY) = 0 THEN Give_Error "Expected array-name": EXIT FUNCTION 'make a note of the array's index for later ulboundarray$ = e$ ulboundarraytyp = sourcetyp e$ = "" r$ = "" - GoTo dontevaluate - End If - End If + GOTO dontevaluate + END IF + END IF '*special case: INPUT$ function - If n$ = "INPUT" Then - If RTrim$(id2.musthave) = "$" Then - If curarg = 2 Then - If Left$(e$, 2) = "#" + sp Then e$ = Right$(e$, Len(e$) - 2) - End If - End If - End If + IF n$ = "INPUT" THEN + IF RTRIM$(id2.musthave) = "$" THEN + IF curarg = 2 THEN + IF LEFT$(e$, 2) = "#" + sp THEN e$ = RIGHT$(e$, LEN(e$) - 2) + END IF + END IF + END IF '*special case* - If n$ = "ASC" Then - If curarg = 2 Then + IF n$ = "ASC" THEN + IF curarg = 2 THEN e$ = evaluatetotyp$(e$, 32&) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION typ& = LONGTYPE - ISPOINTER r$ = r$ + e$ + ")" - GoTo evalfuncspecial - End If - End If + GOTO evalfuncspecial + END IF + END IF 'PRINT #12, "n$="; n$ @@ -16150,38 +16150,38 @@ Function evaluatefunc$ (a2$, args As Long, typ As Long) 'PRINT #12, "r$="; r$ '*special case* - If n$ = "_MEMGET" Or (n$ = "MEMGET" And qb64prefix_set = 1) Then - If curarg = 1 Then + IF n$ = "_MEMGET" OR (n$ = "MEMGET" AND qb64prefix_set = 1) THEN + IF curarg = 1 THEN memget_blk$ = e$ - End If - If curarg = 2 Then + END IF + IF curarg = 2 THEN memget_offs$ = e$ - End If - If curarg = 3 Then - e$ = UCase$(e$) - If InStr(e$, sp + "*" + sp) Then 'multiplier will have an appended %,& or && symbol - If Right$(e$, 2) = "&&" Then - e$ = Left$(e$, Len(e$) - 2) - Else - If Right$(e$, 1) = "&" Or Right$(e$, 1) = "%" Then e$ = Left$(e$, Len(e$) - 1) - End If - End If + END IF + IF curarg = 3 THEN + e$ = UCASE$(e$) + IF INSTR(e$, sp + "*" + sp) THEN 'multiplier will have an appended %,& or && symbol + IF RIGHT$(e$, 2) = "&&" THEN + e$ = LEFT$(e$, LEN(e$) - 2) + ELSE + IF RIGHT$(e$, 1) = "&" OR RIGHT$(e$, 1) = "%" THEN e$ = LEFT$(e$, LEN(e$) - 1) + END IF + END IF t = typname2typ(e$) - If t = 0 Then Give_Error "Invalid TYPE name": EXIT Function - If t And ISOFFSETINBITS Then Give_Error qb64prefix$ + "BIT TYPE unsupported": EXIT Function + IF t = 0 THEN Give_Error "Invalid TYPE name": EXIT FUNCTION + IF t AND ISOFFSETINBITS THEN Give_Error qb64prefix$ + "BIT TYPE unsupported": EXIT FUNCTION memget_size = typname2typsize - If t And ISSTRING Then - If (t And ISFIXEDLENGTH) = 0 Then Give_Error "Expected STRING * ...": EXIT Function + IF t AND ISSTRING THEN + IF (t AND ISFIXEDLENGTH) = 0 THEN Give_Error "Expected STRING * ...": EXIT FUNCTION memget_ctyp$ = "qbs*" - Else - If t And ISUDT Then - memget_size = udtxsize(t And 511) \ 8 + ELSE + IF t AND ISUDT THEN + memget_size = udtxsize(t AND 511) \ 8 memget_ctyp$ = "void*" - Else - memget_size = (t And 511) \ 8 + ELSE + memget_size = (t AND 511) \ 8 memget_ctyp$ = typ2ctyp$(t, "") - End If - End If + END IF + END IF @@ -16190,21 +16190,21 @@ Function evaluatefunc$ (a2$, args As Long, typ As Long) 'assume checking off offs$ = evaluatetotyp(memget_offs$, OFFSETTYPE - ISPOINTER) blkoffs$ = evaluatetotyp(memget_blk$, -6) - If NoChecks = 0 Then + IF NoChecks = 0 THEN 'change offs$ to be the return of the safe version offs$ = "func__memget((mem_block*)" + blkoffs$ + "," + offs$ + "," + str2(memget_size) + ")" - End If - If t And ISSTRING Then + END IF + IF t AND ISSTRING THEN r$ = "qbs_new_txt_len((char*)" + offs$ + "," + str2(memget_size) + ")" - Else - If t And ISUDT Then + ELSE + IF t AND ISUDT THEN r$ = "((void*)+" + offs$ + ")" - t = ISUDT + ISPOINTER + (t And 511) - Else + t = ISUDT + ISPOINTER + (t AND 511) + ELSE r$ = "*(" + memget_ctyp$ + "*)(" + offs$ + ")" - If t And ISPOINTER Then t = t - ISPOINTER - End If - End If + IF t AND ISPOINTER THEN t = t - ISPOINTER + END IF + END IF @@ -16215,134 +16215,134 @@ Function evaluatefunc$ (a2$, args As Long, typ As Long) typ& = t - GoTo evalfuncspecial - End If - End If + GOTO evalfuncspecial + END IF + END IF '------------------------------------------------------------------------------------------------------------ e2$ = e$ e$ = evaluate(e$, sourcetyp) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION '------------------------------------------------------------------------------------------------------------ '***special case*** - If n$ = "_MEM" Or (n$ = "MEM" And qb64prefix_set = 1) Then - If curarg = 1 Then - If args = 1 Then + IF n$ = "_MEM" OR (n$ = "MEM" AND qb64prefix_set = 1) THEN + IF curarg = 1 THEN + IF args = 1 THEN targettyp = -7 - End If - If args = 2 Then - r$ = RTrim$(id2.callname) + "_at_offset" + Right$(r$, Len(r$) - Len(RTrim$(id2.callname))) - If (sourcetyp And ISOFFSET) = 0 Then Give_Error "Expected _MEM(_OFFSET-value,...)": EXIT Function - End If - End If - End If + END IF + IF args = 2 THEN + r$ = RTRIM$(id2.callname) + "_at_offset" + RIGHT$(r$, LEN(r$) - LEN(RTRIM$(id2.callname))) + IF (sourcetyp AND ISOFFSET) = 0 THEN Give_Error "Expected _MEM(_OFFSET-value,...)": EXIT FUNCTION + END IF + END IF + END IF '*special case* - If n$ = "_OFFSET" Or (n$ = "OFFSET" And qb64prefix_set = 1) Then - If (sourcetyp And ISREFERENCE) = 0 Then - Give_Error qb64prefix$ + "OFFSET expects the name of a variable/array": EXIT Function - End If - If (sourcetyp And ISARRAY) Then - If (sourcetyp And ISOFFSETINBITS) Then Give_Error qb64prefix$ + "OFFSET cannot reference _BIT type arrays": EXIT Function - End If + IF n$ = "_OFFSET" OR (n$ = "OFFSET" AND qb64prefix_set = 1) THEN + IF (sourcetyp AND ISREFERENCE) = 0 THEN + Give_Error qb64prefix$ + "OFFSET expects the name of a variable/array": EXIT FUNCTION + END IF + IF (sourcetyp AND ISARRAY) THEN + IF (sourcetyp AND ISOFFSETINBITS) THEN Give_Error qb64prefix$ + "OFFSET cannot reference _BIT type arrays": EXIT FUNCTION + END IF r$ = "((uptrszint)(" + evaluatetotyp$(e2$, -6) + "))" - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION typ& = UOFFSETTYPE - ISPOINTER - GoTo evalfuncspecial - End If '_OFFSET + GOTO evalfuncspecial + END IF '_OFFSET '*_OFFSET exceptions* - If sourcetyp And ISOFFSET Then - If n$ = "MKSMBF" And RTrim$(id2.musthave) = "$" Then Give_Error "Cannot convert _OFFSET type to other types": EXIT Function - If n$ = "MKDMBF" And RTrim$(id2.musthave) = "$" Then Give_Error "Cannot convert _OFFSET type to other types": EXIT Function - End If + IF sourcetyp AND ISOFFSET THEN + IF n$ = "MKSMBF" AND RTRIM$(id2.musthave) = "$" THEN Give_Error "Cannot convert _OFFSET type to other types": EXIT FUNCTION + IF n$ = "MKDMBF" AND RTRIM$(id2.musthave) = "$" THEN Give_Error "Cannot convert _OFFSET type to other types": EXIT FUNCTION + END IF '*special case* - If n$ = "ENVIRON" Then - If sourcetyp And ISSTRING Then - If sourcetyp And ISREFERENCE Then e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function - GoTo dontevaluate - End If - End If + IF n$ = "ENVIRON" THEN + IF sourcetyp AND ISSTRING THEN + IF sourcetyp AND ISREFERENCE THEN e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION + GOTO dontevaluate + END IF + END IF '*special case* - If n$ = "LEN" Then + IF n$ = "LEN" THEN typ& = LONGTYPE - ISPOINTER - If (sourcetyp And ISREFERENCE) = 0 Then + IF (sourcetyp AND ISREFERENCE) = 0 THEN 'could be a string expression - If sourcetyp And ISSTRING Then + IF sourcetyp AND ISSTRING THEN r$ = "((int32)(" + e$ + ")->len)" - GoTo evalfuncspecial - End If - Give_Error "String expression or variable name required in LEN statement": EXIT Function - End If + GOTO evalfuncspecial + END IF + Give_Error "String expression or variable name required in LEN statement": EXIT FUNCTION + END IF r$ = evaluatetotyp$(e2$, -5) 'use evaluatetotyp to get 'element' size - If Error_Happened Then EXIT Function - GoTo evalfuncspecial - End If + IF Error_Happened THEN EXIT FUNCTION + GOTO evalfuncspecial + END IF '*special case* - If n$ = "OCT" Then - If RTrim$(id2.musthave) = "$" Then - bits = sourcetyp And 511 + IF n$ = "OCT" THEN + IF RTRIM$(id2.musthave) = "$" THEN + bits = sourcetyp AND 511 - If (sourcetyp And ISSTRING) Then Give_Error "Expected numeric value": EXIT Function + IF (sourcetyp AND ISSTRING) THEN Give_Error "Expected numeric value": EXIT FUNCTION wasref = 0 - If (sourcetyp And ISREFERENCE) Then e$ = refer(e$, sourcetyp, 0): wasref = 1 - If Error_Happened Then EXIT Function - bits = sourcetyp And 511 - If (sourcetyp And ISOFFSETINBITS) Then + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0): wasref = 1 + IF Error_Happened THEN EXIT FUNCTION + bits = sourcetyp AND 511 + IF (sourcetyp AND ISOFFSETINBITS) THEN e$ = "func_oct(" + e$ + "," + str2$(bits) + ")" - Else - If (sourcetyp And ISFLOAT) Then + ELSE + IF (sourcetyp AND ISFLOAT) THEN e$ = "func_oct_float(" + e$ + ")" - Else - If bits = 64 Then - If wasref = 0 Then bits = 0 - End If + ELSE + IF bits = 64 THEN + IF wasref = 0 THEN bits = 0 + END IF e$ = "func_oct(" + e$ + "," + str2$(bits) + ")" - End If - End If + END IF + END IF typ& = STRINGTYPE - ISPOINTER r$ = e$ - GoTo evalfuncspecial - End If - End If + GOTO evalfuncspecial + END IF + END IF '*special case* - If n$ = "HEX" Then - If RTrim$(id2.musthave) = "$" Then - bits = sourcetyp And 511 - If (sourcetyp And ISSTRING) Then Give_Error "Expected numeric value": EXIT Function + IF n$ = "HEX" THEN + IF RTRIM$(id2.musthave) = "$" THEN + bits = sourcetyp AND 511 + IF (sourcetyp AND ISSTRING) THEN Give_Error "Expected numeric value": EXIT FUNCTION wasref = 0 - If (sourcetyp And ISREFERENCE) Then e$ = refer(e$, sourcetyp, 0): wasref = 1 - If Error_Happened Then EXIT Function - bits = sourcetyp And 511 - If (sourcetyp And ISOFFSETINBITS) Then + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0): wasref = 1 + IF Error_Happened THEN EXIT FUNCTION + bits = sourcetyp AND 511 + IF (sourcetyp AND ISOFFSETINBITS) THEN chars = (bits + 3) \ 4 e$ = "func_hex(" + e$ + "," + str2$(chars) + ")" - Else - If (sourcetyp And ISFLOAT) Then + ELSE + IF (sourcetyp AND ISFLOAT) THEN e$ = "func_hex_float(" + e$ + ")" - Else - If bits = 8 Then chars = 2 - If bits = 16 Then chars = 4 - If bits = 32 Then chars = 8 - If bits = 64 Then - If wasref = 1 Then chars = 16 Else chars = 0 - End If + ELSE + IF bits = 8 THEN chars = 2 + IF bits = 16 THEN chars = 4 + IF bits = 32 THEN chars = 8 + IF bits = 64 THEN + IF wasref = 1 THEN chars = 16 ELSE chars = 0 + END IF e$ = "func_hex(" + e$ + "," + str2$(chars) + ")" - End If - End If + END IF + END IF typ& = STRINGTYPE - ISPOINTER r$ = e$ - GoTo evalfuncspecial - End If - End If + GOTO evalfuncspecial + END IF + END IF @@ -16353,298 +16353,298 @@ Function evaluatefunc$ (a2$, args As Long, typ As Long) '*special case* - If n$ = "EXP" Then - bits = sourcetyp And 511 - If (sourcetyp And ISSTRING) Then Give_Error "Expected numeric value": EXIT Function - If (sourcetyp And ISREFERENCE) Then e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function - bits = sourcetyp And 511 + IF n$ = "EXP" THEN + bits = sourcetyp AND 511 + IF (sourcetyp AND ISSTRING) THEN Give_Error "Expected numeric value": EXIT FUNCTION + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION + bits = sourcetyp AND 511 typ& = SINGLETYPE - ISPOINTER - If (sourcetyp And ISFLOAT) Then - If bits = 32 Then e$ = "func_exp_single(" + e$ + ")" Else e$ = "func_exp_float(" + e$ + ")": typ& = FLOATTYPE - ISPOINTER - Else - If (sourcetyp And ISOFFSETINBITS) Then + IF (sourcetyp AND ISFLOAT) THEN + IF bits = 32 THEN e$ = "func_exp_single(" + e$ + ")" ELSE e$ = "func_exp_float(" + e$ + ")": typ& = FLOATTYPE - ISPOINTER + ELSE + IF (sourcetyp AND ISOFFSETINBITS) THEN e$ = "func_exp_float(" + e$ + ")": typ& = FLOATTYPE - ISPOINTER - Else - If bits <= 16 Then e$ = "func_exp_single(" + e$ + ")" Else e$ = "func_exp_float(" + e$ + ")": typ& = FLOATTYPE - ISPOINTER - End If - End If + ELSE + IF bits <= 16 THEN e$ = "func_exp_single(" + e$ + ")" ELSE e$ = "func_exp_float(" + e$ + ")": typ& = FLOATTYPE - ISPOINTER + END IF + END IF r$ = e$ - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF '*special case* - If n$ = "INT" Then - If (sourcetyp And ISSTRING) Then Give_Error "Expected numeric value": EXIT Function - If (sourcetyp And ISREFERENCE) Then e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF n$ = "INT" THEN + IF (sourcetyp AND ISSTRING) THEN Give_Error "Expected numeric value": EXIT FUNCTION + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION 'establish which function (if any!) should be used - If (sourcetyp And ISFLOAT) Then e$ = "floor(" + e$ + ")" Else e$ = "(" + e$ + ")" + IF (sourcetyp AND ISFLOAT) THEN e$ = "floor(" + e$ + ")" ELSE e$ = "(" + e$ + ")" r$ = e$ typ& = sourcetyp - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF '*special case* - If n$ = "FIX" Then - If (sourcetyp And ISSTRING) Then Give_Error "Expected numeric value": EXIT Function - If (sourcetyp And ISREFERENCE) Then e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF n$ = "FIX" THEN + IF (sourcetyp AND ISSTRING) THEN Give_Error "Expected numeric value": EXIT FUNCTION + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION 'establish which function (if any!) should be used - bits = sourcetyp And 511 - If (sourcetyp And ISFLOAT) Then - If bits > 64 Then e$ = "func_fix_float(" + e$ + ")" Else e$ = "func_fix_double(" + e$ + ")" - Else + bits = sourcetyp AND 511 + IF (sourcetyp AND ISFLOAT) THEN + IF bits > 64 THEN e$ = "func_fix_float(" + e$ + ")" ELSE e$ = "func_fix_double(" + e$ + ")" + ELSE e$ = "(" + e$ + ")" - End If + END IF r$ = e$ typ& = sourcetyp - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF '*special case* - If n$ = "_ROUND" Or (n$ = "ROUND" And qb64prefix_set = 1) Then - If (sourcetyp And ISSTRING) Then Give_Error "Expected numeric value": EXIT Function - If (sourcetyp And ISREFERENCE) Then e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF n$ = "_ROUND" OR (n$ = "ROUND" AND qb64prefix_set = 1) THEN + IF (sourcetyp AND ISSTRING) THEN Give_Error "Expected numeric value": EXIT FUNCTION + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION 'establish which function (if any!) should be used - If (sourcetyp And ISFLOAT) Then - bits = sourcetyp And 511 - If bits > 64 Then e$ = "func_round_float(" + e$ + ")" Else e$ = "func_round_double(" + e$ + ")" - Else + IF (sourcetyp AND ISFLOAT) THEN + bits = sourcetyp AND 511 + IF bits > 64 THEN e$ = "func_round_float(" + e$ + ")" ELSE e$ = "func_round_double(" + e$ + ")" + ELSE e$ = "(" + e$ + ")" - End If + END IF r$ = e$ typ& = 64& - If (sourcetyp And ISOFFSET) Then - If sourcetyp And ISUNSIGNED Then typ& = UOFFSETTYPE - ISPOINTER Else typ& = OFFSETTYPE - ISPOINTER - End If - GoTo evalfuncspecial - End If + IF (sourcetyp AND ISOFFSET) THEN + IF sourcetyp AND ISUNSIGNED THEN typ& = UOFFSETTYPE - ISPOINTER ELSE typ& = OFFSETTYPE - ISPOINTER + END IF + GOTO evalfuncspecial + END IF '*special case* - If n$ = "CDBL" Then - If (sourcetyp And ISOFFSET) Then Give_Error "Cannot convert _OFFSET type to other types": EXIT Function - If (sourcetyp And ISSTRING) Then Give_Error "Expected numeric value": EXIT Function - If (sourcetyp And ISREFERENCE) Then e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF n$ = "CDBL" THEN + IF (sourcetyp AND ISOFFSET) THEN Give_Error "Cannot convert _OFFSET type to other types": EXIT FUNCTION + IF (sourcetyp AND ISSTRING) THEN Give_Error "Expected numeric value": EXIT FUNCTION + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION 'establish which function (if any!) should be used - bits = sourcetyp And 511 - If (sourcetyp And ISFLOAT) Then - If bits > 64 Then e$ = "func_cdbl_float(" + e$ + ")" - Else + bits = sourcetyp AND 511 + IF (sourcetyp AND ISFLOAT) THEN + IF bits > 64 THEN e$ = "func_cdbl_float(" + e$ + ")" + ELSE e$ = "((double)(" + e$ + "))" - End If + END IF r$ = e$ typ& = DOUBLETYPE - ISPOINTER - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF '*special case* - If n$ = "CSNG" Then - If (sourcetyp And ISOFFSET) Then Give_Error "Cannot convert _OFFSET type to other types": EXIT Function - If (sourcetyp And ISSTRING) Then Give_Error "Expected numeric value": EXIT Function - If (sourcetyp And ISREFERENCE) Then e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF n$ = "CSNG" THEN + IF (sourcetyp AND ISOFFSET) THEN Give_Error "Cannot convert _OFFSET type to other types": EXIT FUNCTION + IF (sourcetyp AND ISSTRING) THEN Give_Error "Expected numeric value": EXIT FUNCTION + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION 'establish which function (if any!) should be used - bits = sourcetyp And 511 - If (sourcetyp And ISFLOAT) Then - If bits = 64 Then e$ = "func_csng_double(" + e$ + ")" - If bits > 64 Then e$ = "func_csng_float(" + e$ + ")" - Else + bits = sourcetyp AND 511 + IF (sourcetyp AND ISFLOAT) THEN + IF bits = 64 THEN e$ = "func_csng_double(" + e$ + ")" + IF bits > 64 THEN e$ = "func_csng_float(" + e$ + ")" + ELSE e$ = "((double)(" + e$ + "))" - End If + END IF r$ = e$ typ& = SINGLETYPE - ISPOINTER - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF '*special case* - If n$ = "CLNG" Then - If (sourcetyp And ISOFFSET) Then Give_Error "Cannot convert _OFFSET type to other types": EXIT Function - If (sourcetyp And ISSTRING) Then Give_Error "Expected numeric value": EXIT Function - If (sourcetyp And ISREFERENCE) Then e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF n$ = "CLNG" THEN + IF (sourcetyp AND ISOFFSET) THEN Give_Error "Cannot convert _OFFSET type to other types": EXIT FUNCTION + IF (sourcetyp AND ISSTRING) THEN Give_Error "Expected numeric value": EXIT FUNCTION + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION 'establish which function (if any!) should be used - bits = sourcetyp And 511 - If (sourcetyp And ISFLOAT) Then - If bits > 64 Then e$ = "func_clng_float(" + e$ + ")" Else e$ = "func_clng_double(" + e$ + ")" - Else 'integer - If (sourcetyp And ISUNSIGNED) Then - If bits = 32 Then e$ = "func_clng_ulong(" + e$ + ")" - If bits > 32 Then e$ = "func_clng_uint64(" + e$ + ")" - Else 'signed - If bits > 32 Then e$ = "func_clng_int64(" + e$ + ")" - End If - End If + bits = sourcetyp AND 511 + IF (sourcetyp AND ISFLOAT) THEN + IF bits > 64 THEN e$ = "func_clng_float(" + e$ + ")" ELSE e$ = "func_clng_double(" + e$ + ")" + ELSE 'integer + IF (sourcetyp AND ISUNSIGNED) THEN + IF bits = 32 THEN e$ = "func_clng_ulong(" + e$ + ")" + IF bits > 32 THEN e$ = "func_clng_uint64(" + e$ + ")" + ELSE 'signed + IF bits > 32 THEN e$ = "func_clng_int64(" + e$ + ")" + END IF + END IF r$ = e$ typ& = 32& - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF '*special case* - If n$ = "CINT" Then - If (sourcetyp And ISOFFSET) Then Give_Error "Cannot convert _OFFSET type to other types": EXIT Function - If (sourcetyp And ISSTRING) Then Give_Error "Expected numeric value": EXIT Function - If (sourcetyp And ISREFERENCE) Then e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF n$ = "CINT" THEN + IF (sourcetyp AND ISOFFSET) THEN Give_Error "Cannot convert _OFFSET type to other types": EXIT FUNCTION + IF (sourcetyp AND ISSTRING) THEN Give_Error "Expected numeric value": EXIT FUNCTION + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION 'establish which function (if any!) should be used - bits = sourcetyp And 511 - If (sourcetyp And ISFLOAT) Then - If bits > 64 Then e$ = "func_cint_float(" + e$ + ")" Else e$ = "func_cint_double(" + e$ + ")" - Else 'integer - If (sourcetyp And ISUNSIGNED) Then - If bits > 15 And bits <= 32 Then e$ = "func_cint_ulong(" + e$ + ")" - If bits > 32 Then e$ = "func_cint_uint64(" + e$ + ")" - Else 'signed - If bits > 16 And bits <= 32 Then e$ = "func_cint_long(" + e$ + ")" - If bits > 32 Then e$ = "func_cint_int64(" + e$ + ")" - End If - End If + bits = sourcetyp AND 511 + IF (sourcetyp AND ISFLOAT) THEN + IF bits > 64 THEN e$ = "func_cint_float(" + e$ + ")" ELSE e$ = "func_cint_double(" + e$ + ")" + ELSE 'integer + IF (sourcetyp AND ISUNSIGNED) THEN + IF bits > 15 AND bits <= 32 THEN e$ = "func_cint_ulong(" + e$ + ")" + IF bits > 32 THEN e$ = "func_cint_uint64(" + e$ + ")" + ELSE 'signed + IF bits > 16 AND bits <= 32 THEN e$ = "func_cint_long(" + e$ + ")" + IF bits > 32 THEN e$ = "func_cint_int64(" + e$ + ")" + END IF + END IF r$ = e$ typ& = 16& - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF '*special case MKI,MKL,MKS,MKD,_MK (part #2) mktype = 0 size = 0 - If n$ = "MKI" Then mktype = 1: mktype$ = "%" - If n$ = "MKL" Then mktype = 2: mktype$ = "&" - If n$ = "MKS" Then mktype = 3: mktype$ = "!" - If n$ = "MKD" Then mktype = 4: mktype$ = "#" - If n$ = "_MK" Or (n$ = "MK" And qb64prefix_set = 1) Then mktype = -1 - If mktype Then - If mktype <> -1 Or curarg = 2 Then - If (sourcetyp And ISOFFSET) Then Give_Error "Cannot convert " + qb64prefix$ + "OFFSET type to other types": EXIT Function + IF n$ = "MKI" THEN mktype = 1: mktype$ = "%" + IF n$ = "MKL" THEN mktype = 2: mktype$ = "&" + IF n$ = "MKS" THEN mktype = 3: mktype$ = "!" + IF n$ = "MKD" THEN mktype = 4: mktype$ = "#" + IF n$ = "_MK" OR (n$ = "MK" AND qb64prefix_set = 1) THEN mktype = -1 + IF mktype THEN + IF mktype <> -1 OR curarg = 2 THEN + IF (sourcetyp AND ISOFFSET) THEN Give_Error "Cannot convert " + qb64prefix$ + "OFFSET type to other types": EXIT FUNCTION 'both _MK and trad. process the following qtyp& = 0 - If mktype$ = "%%" Then ctype$ = "b": qtyp& = BYTETYPE - ISPOINTER - If mktype$ = "~%%" Then ctype$ = "ub": qtyp& = UBYTETYPE - ISPOINTER - If mktype$ = "%" Then ctype$ = "i": qtyp& = INTEGERTYPE - ISPOINTER - If mktype$ = "~%" Then ctype$ = "ui": qtyp& = UINTEGERTYPE - ISPOINTER - If mktype$ = "&" Then ctype$ = "l": qtyp& = LONGTYPE - ISPOINTER - If mktype$ = "~&" Then ctype$ = "ul": qtyp& = ULONGTYPE - ISPOINTER - If mktype$ = "&&" Then ctype$ = "i64": qtyp& = INTEGER64TYPE - ISPOINTER - If mktype$ = "~&&" Then ctype$ = "ui64": qtyp& = UINTEGER64TYPE - ISPOINTER - If mktype$ = "!" Then ctype$ = "s": qtyp& = SINGLETYPE - ISPOINTER - If mktype$ = "#" Then ctype$ = "d": qtyp& = DOUBLETYPE - ISPOINTER - If mktype$ = "##" Then ctype$ = "f": qtyp& = FLOATTYPE - ISPOINTER - If Left$(mktype$, 2) = "~`" Then ctype$ = "ubit": qtyp& = UINTEGER64TYPE - ISPOINTER: size = Val(Right$(mktype$, Len(mktype$) - 2)) - If Left$(mktype$, 1) = "`" Then ctype$ = "bit": qtyp& = INTEGER64TYPE - ISPOINTER: size = Val(Right$(mktype$, Len(mktype$) - 1)) - If qtyp& = 0 Then Give_Error qb64prefix$ + "MK only accepts numeric types": EXIT Function - If size Then + IF mktype$ = "%%" THEN ctype$ = "b": qtyp& = BYTETYPE - ISPOINTER + IF mktype$ = "~%%" THEN ctype$ = "ub": qtyp& = UBYTETYPE - ISPOINTER + IF mktype$ = "%" THEN ctype$ = "i": qtyp& = INTEGERTYPE - ISPOINTER + IF mktype$ = "~%" THEN ctype$ = "ui": qtyp& = UINTEGERTYPE - ISPOINTER + IF mktype$ = "&" THEN ctype$ = "l": qtyp& = LONGTYPE - ISPOINTER + IF mktype$ = "~&" THEN ctype$ = "ul": qtyp& = ULONGTYPE - ISPOINTER + IF mktype$ = "&&" THEN ctype$ = "i64": qtyp& = INTEGER64TYPE - ISPOINTER + IF mktype$ = "~&&" THEN ctype$ = "ui64": qtyp& = UINTEGER64TYPE - ISPOINTER + IF mktype$ = "!" THEN ctype$ = "s": qtyp& = SINGLETYPE - ISPOINTER + IF mktype$ = "#" THEN ctype$ = "d": qtyp& = DOUBLETYPE - ISPOINTER + IF mktype$ = "##" THEN ctype$ = "f": qtyp& = FLOATTYPE - ISPOINTER + IF LEFT$(mktype$, 2) = "~`" THEN ctype$ = "ubit": qtyp& = UINTEGER64TYPE - ISPOINTER: size = VAL(RIGHT$(mktype$, LEN(mktype$) - 2)) + IF LEFT$(mktype$, 1) = "`" THEN ctype$ = "bit": qtyp& = INTEGER64TYPE - ISPOINTER: size = VAL(RIGHT$(mktype$, LEN(mktype$) - 1)) + IF qtyp& = 0 THEN Give_Error qb64prefix$ + "MK only accepts numeric types": EXIT FUNCTION + IF size THEN r$ = ctype$ + "2string(" + str2(size) + "," - Else + ELSE r$ = ctype$ + "2string(" - End If + END IF nocomma = 1 targettyp = qtyp& - End If - End If + END IF + END IF '*special case CVI,CVL,CVS,CVD,_CV (part #2) cvtype = 0 - If n$ = "CVI" Then cvtype = 1: cvtype$ = "%" - If n$ = "CVL" Then cvtype = 2: cvtype$ = "&" - If n$ = "CVS" Then cvtype = 3: cvtype$ = "!" - If n$ = "CVD" Then cvtype = 4: cvtype$ = "#" - If n$ = "_CV" Or (n$ = "CV" And qb64prefix_set = 1) Then cvtype = -1 - If cvtype Then - If cvtype <> -1 Or curarg = 2 Then - If (sourcetyp And ISSTRING) = 0 Then Give_Error n$ + " requires a STRING argument": EXIT Function - If (sourcetyp And ISREFERENCE) Then e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF n$ = "CVI" THEN cvtype = 1: cvtype$ = "%" + IF n$ = "CVL" THEN cvtype = 2: cvtype$ = "&" + IF n$ = "CVS" THEN cvtype = 3: cvtype$ = "!" + IF n$ = "CVD" THEN cvtype = 4: cvtype$ = "#" + IF n$ = "_CV" OR (n$ = "CV" AND qb64prefix_set = 1) THEN cvtype = -1 + IF cvtype THEN + IF cvtype <> -1 OR curarg = 2 THEN + IF (sourcetyp AND ISSTRING) = 0 THEN Give_Error n$ + " requires a STRING argument": EXIT FUNCTION + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION typ& = 0 - If cvtype$ = "%%" Then ctype$ = "b": typ& = BYTETYPE - ISPOINTER - If cvtype$ = "~%%" Then ctype$ = "ub": typ& = UBYTETYPE - ISPOINTER - If cvtype$ = "%" Then ctype$ = "i": typ& = INTEGERTYPE - ISPOINTER - If cvtype$ = "~%" Then ctype$ = "ui": typ& = UINTEGERTYPE - ISPOINTER - If cvtype$ = "&" Then ctype$ = "l": typ& = LONGTYPE - ISPOINTER - If cvtype$ = "~&" Then ctype$ = "ul": typ& = ULONGTYPE - ISPOINTER - If cvtype$ = "&&" Then ctype$ = "i64": typ& = INTEGER64TYPE - ISPOINTER - If cvtype$ = "~&&" Then ctype$ = "ui64": typ& = UINTEGER64TYPE - ISPOINTER - If cvtype$ = "!" Then ctype$ = "s": typ& = SINGLETYPE - ISPOINTER - If cvtype$ = "#" Then ctype$ = "d": typ& = DOUBLETYPE - ISPOINTER - If cvtype$ = "##" Then ctype$ = "f": typ& = FLOATTYPE - ISPOINTER - If Left$(cvtype$, 2) = "~`" Then ctype$ = "ubit": typ& = UINTEGER64TYPE - ISPOINTER: size = Val(Right$(cvtype$, Len(cvtype$) - 2)) - If Left$(cvtype$, 1) = "`" Then ctype$ = "bit": typ& = INTEGER64TYPE - ISPOINTER: size = Val(Right$(cvtype$, Len(cvtype$) - 1)) - If typ& = 0 Then Give_Error qb64prefix$ + "CV cannot return STRING type!": EXIT Function - If ctype$ = "bit" Or ctype$ = "ubit" Then + IF cvtype$ = "%%" THEN ctype$ = "b": typ& = BYTETYPE - ISPOINTER + IF cvtype$ = "~%%" THEN ctype$ = "ub": typ& = UBYTETYPE - ISPOINTER + IF cvtype$ = "%" THEN ctype$ = "i": typ& = INTEGERTYPE - ISPOINTER + IF cvtype$ = "~%" THEN ctype$ = "ui": typ& = UINTEGERTYPE - ISPOINTER + IF cvtype$ = "&" THEN ctype$ = "l": typ& = LONGTYPE - ISPOINTER + IF cvtype$ = "~&" THEN ctype$ = "ul": typ& = ULONGTYPE - ISPOINTER + IF cvtype$ = "&&" THEN ctype$ = "i64": typ& = INTEGER64TYPE - ISPOINTER + IF cvtype$ = "~&&" THEN ctype$ = "ui64": typ& = UINTEGER64TYPE - ISPOINTER + IF cvtype$ = "!" THEN ctype$ = "s": typ& = SINGLETYPE - ISPOINTER + IF cvtype$ = "#" THEN ctype$ = "d": typ& = DOUBLETYPE - ISPOINTER + IF cvtype$ = "##" THEN ctype$ = "f": typ& = FLOATTYPE - ISPOINTER + IF LEFT$(cvtype$, 2) = "~`" THEN ctype$ = "ubit": typ& = UINTEGER64TYPE - ISPOINTER: size = VAL(RIGHT$(cvtype$, LEN(cvtype$) - 2)) + IF LEFT$(cvtype$, 1) = "`" THEN ctype$ = "bit": typ& = INTEGER64TYPE - ISPOINTER: size = VAL(RIGHT$(cvtype$, LEN(cvtype$) - 1)) + IF typ& = 0 THEN Give_Error qb64prefix$ + "CV cannot return STRING type!": EXIT FUNCTION + IF ctype$ = "bit" OR ctype$ = "ubit" THEN r$ = "string2" + ctype$ + "(" + e$ + "," + str2(size) + ")" - Else + ELSE r$ = "string2" + ctype$ + "(" + e$ + ")" - End If - GoTo evalfuncspecial - End If - End If + END IF + GOTO evalfuncspecial + END IF + END IF '*special case - If RTrim$(id2.n) = "STRING" Then - If curarg = 2 Then - If (sourcetyp And ISSTRING) Then - If (sourcetyp And ISREFERENCE) Then e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF RTRIM$(id2.n) = "STRING" THEN + IF curarg = 2 THEN + IF (sourcetyp AND ISSTRING) THEN + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION sourcetyp = 64& e$ = "(" + e$ + "->chr[0])" - End If - End If - End If + END IF + END IF + END IF '*special case - If RTrim$(id2.n) = "SADD" Then - If (sourcetyp And ISREFERENCE) = 0 Then - Give_Error "SADD only accepts variable-length string variables": EXIT Function - End If - If (sourcetyp And ISFIXEDLENGTH) Then - Give_Error "SADD only accepts variable-length string variables": EXIT Function - End If - If (sourcetyp And ISINCONVENTIONALMEMORY) = 0 Then + IF RTRIM$(id2.n) = "SADD" THEN + IF (sourcetyp AND ISREFERENCE) = 0 THEN + Give_Error "SADD only accepts variable-length string variables": EXIT FUNCTION + END IF + IF (sourcetyp AND ISFIXEDLENGTH) THEN + Give_Error "SADD only accepts variable-length string variables": EXIT FUNCTION + END IF + IF (sourcetyp AND ISINCONVENTIONALMEMORY) = 0 THEN recompile = 1 - cmemlist(Val(e$)) = 1 + cmemlist(VAL(e$)) = 1 r$ = "[CONVENTIONAL_MEMORY_REQUIRED]" typ& = 64& - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF r$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION r$ = "((unsigned short)(" + r$ + "->chr-&cmem[1280]))" typ& = 64& - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF '*special case - If RTrim$(id2.n) = "VARPTR" Then - If (sourcetyp And ISREFERENCE) = 0 Then - Give_Error "Expected reference to a variable/array": EXIT Function - End If + IF RTRIM$(id2.n) = "VARPTR" THEN + IF (sourcetyp AND ISREFERENCE) = 0 THEN + Give_Error "Expected reference to a variable/array": EXIT FUNCTION + END IF - If RTrim$(id2.musthave) = "$" Then - If (sourcetyp And ISINCONVENTIONALMEMORY) = 0 Then + IF RTRIM$(id2.musthave) = "$" THEN + IF (sourcetyp AND ISINCONVENTIONALMEMORY) = 0 THEN recompile = 1 - cmemlist(Val(e$)) = 1 + cmemlist(VAL(e$)) = 1 r$ = "[CONVENTIONAL_MEMORY_REQUIRED]" typ& = ISSTRING - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF - If (sourcetyp And ISARRAY) Then - If (sourcetyp And ISSTRING) = 0 Then Give_Error "VARPTR$ only accepts variable-length string arrays": EXIT Function - If (sourcetyp And ISFIXEDLENGTH) Then Give_Error "VARPTR$ only accepts variable-length string arrays": EXIT Function - End If + IF (sourcetyp AND ISARRAY) THEN + IF (sourcetyp AND ISSTRING) = 0 THEN Give_Error "VARPTR$ only accepts variable-length string arrays": EXIT FUNCTION + IF (sourcetyp AND ISFIXEDLENGTH) THEN Give_Error "VARPTR$ only accepts variable-length string arrays": EXIT FUNCTION + END IF 'must be a simple variable '!assuming it is in cmem in DBLOCK r$ = refer(e$, sourcetyp, 1) - If Error_Happened Then EXIT Function - If (sourcetyp And ISSTRING) Then - If (sourcetyp And ISARRAY) Then r$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION + IF (sourcetyp AND ISSTRING) THEN + IF (sourcetyp AND ISARRAY) THEN r$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION r$ = r$ + "->cmem_descriptor_offset" t = 3 - Else + ELSE r$ = "((unsigned short)(((uint8*)" + r$ + ")-&cmem[1280]))" '*top bit on=unsigned '*second top bit on=bit-value (lower bits indicate the size) @@ -16658,28 +16658,28 @@ Function evaluatefunc$ (a2$, args As Long, typ As Long) 'LONG=20 'BIT=64+n t = 0 - If (sourcetyp And ISUNSIGNED) Then t = t + 128 - If (sourcetyp And ISOFFSETINBITS) Then + IF (sourcetyp AND ISUNSIGNED) THEN t = t + 128 + IF (sourcetyp AND ISOFFSETINBITS) THEN t = t + 64 - t = t + (sourcetyp And 63) - Else - bits = sourcetyp And 511 - If (sourcetyp And ISFLOAT) Then - If bits = 32 Then t = t + 4 - If bits = 64 Then t = t + 8 - If bits = 256 Then t = t + 6 - Else - If bits = 8 Then t = t + 1 - If bits = 16 Then t = t + 2 - If bits = 32 Then t = t + 20 - If bits = 64 Then t = t + 5 - End If - End If - End If + t = t + (sourcetyp AND 63) + ELSE + bits = sourcetyp AND 511 + IF (sourcetyp AND ISFLOAT) THEN + IF bits = 32 THEN t = t + 4 + IF bits = 64 THEN t = t + 8 + IF bits = 256 THEN t = t + 6 + ELSE + IF bits = 8 THEN t = t + 1 + IF bits = 16 THEN t = t + 2 + IF bits = 32 THEN t = t + 20 + IF bits = 64 THEN t = t + 5 + END IF + END IF + END IF r$ = "func_varptr_helper(" + str2(t) + "," + r$ + ")" typ& = ISSTRING - GoTo evalfuncspecial - End If 'end of varptr$ + GOTO evalfuncspecial + END IF 'end of varptr$ @@ -16692,163 +16692,163 @@ Function evaluatefunc$ (a2$, args As Long, typ As Long) 'VARPTR - If (sourcetyp And ISINCONVENTIONALMEMORY) = 0 Then + IF (sourcetyp AND ISINCONVENTIONALMEMORY) = 0 THEN recompile = 1 - cmemlist(Val(e$)) = 1 + cmemlist(VAL(e$)) = 1 r$ = "[CONVENTIONAL_MEMORY_REQUIRED]" typ& = 64& - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF - If (sourcetyp And ISARRAY) Then - If (sourcetyp And ISOFFSETINBITS) Then Give_Error "VARPTR cannot reference _BIT type arrays": EXIT Function + IF (sourcetyp AND ISARRAY) THEN + IF (sourcetyp AND ISOFFSETINBITS) THEN Give_Error "VARPTR cannot reference _BIT type arrays": EXIT FUNCTION 'string array? - If (sourcetyp And ISSTRING) Then - If (sourcetyp And ISFIXEDLENGTH) Then - getid Val(e$) - If Error_Happened Then EXIT Function + IF (sourcetyp AND ISSTRING) THEN + IF (sourcetyp AND ISFIXEDLENGTH) THEN + getid VAL(e$) + IF Error_Happened THEN EXIT FUNCTION m = id.tsize - index$ = Right$(e$, Len(e$) - InStr(e$, sp3)) + index$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) typ = 64& r$ = "((" + index$ + ")*" + str2(m) + ")" - GoTo evalfuncspecial - Else + GOTO evalfuncspecial + ELSE 'return the offset of the string's descriptor r$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION r$ = r$ + "->cmem_descriptor_offset" typ = 64& - GoTo evalfuncspecial - End If - End If + GOTO evalfuncspecial + END IF + END IF - If sourcetyp And ISUDT Then - e$ = Right$(e$, Len(e$) - InStr(e$, sp3)) 'skip idnumber - e$ = Right$(e$, Len(e$) - InStr(e$, sp3)) 'skip u - o$ = Right$(e$, Len(e$) - InStr(e$, sp3)) 'skip e + IF sourcetyp AND ISUDT THEN + e$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) 'skip idnumber + e$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) 'skip u + o$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) 'skip e typ = 64& r$ = "(" + o$ + ")" - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF 'non-UDT array - m = (sourcetyp And 511) \ 8 'calculate size multiplier - index$ = Right$(e$, Len(e$) - InStr(e$, sp3)) + m = (sourcetyp AND 511) \ 8 'calculate size multiplier + index$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) typ = 64& r$ = "((" + index$ + ")*" + str2(m) + ")" - GoTo evalfuncspecial + GOTO evalfuncspecial - End If + END IF 'not an array - If sourcetyp And ISUDT Then + IF sourcetyp AND ISUDT THEN r$ = refer(e$, sourcetyp, 1) - If Error_Happened Then EXIT Function - e$ = Right$(e$, Len(e$) - InStr(e$, sp3)) 'skip idnumber - e$ = Right$(e$, Len(e$) - InStr(e$, sp3)) 'skip u - o$ = Right$(e$, Len(e$) - InStr(e$, sp3)) 'skip e + IF Error_Happened THEN EXIT FUNCTION + e$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) 'skip idnumber + e$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) 'skip u + o$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) 'skip e typ = 64& 'if sub/func arg, may not be in DBLOCK - getid Val(e$) - If Error_Happened Then EXIT Function - If id.sfarg Then 'could be in DBLOCK + getid VAL(e$) + IF Error_Happened THEN EXIT FUNCTION + IF id.sfarg THEN 'could be in DBLOCK 'note: segment could be the closest segment to UDT element or the base of DBLOCK r$ = "varptr_dblock_check(((uint8*)" + r$ + ")+(" + o$ + "))" - Else 'definitely in DBLOCK + ELSE 'definitely in DBLOCK 'give offset relative to DBLOCK r$ = "((unsigned short)(((uint8*)" + r$ + ") - &cmem[1280] + (" + o$ + ") ))" - End If + END IF - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF typ = 64& r$ = refer(e$, sourcetyp, 1) - If Error_Happened Then EXIT Function - If (sourcetyp And ISSTRING) Then - If (sourcetyp And ISFIXEDLENGTH) Then + IF Error_Happened THEN EXIT FUNCTION + IF (sourcetyp AND ISSTRING) THEN + IF (sourcetyp AND ISFIXEDLENGTH) THEN 'if sub/func arg, may not be in DBLOCK - getid Val(e$) - If Error_Happened Then EXIT Function - If id.sfarg Then 'could be in DBLOCK + getid VAL(e$) + IF Error_Happened THEN EXIT FUNCTION + IF id.sfarg THEN 'could be in DBLOCK r$ = "varptr_dblock_check(" + r$ + "->chr)" - Else 'definitely in DBLOCK + ELSE 'definitely in DBLOCK r$ = "((unsigned short)(" + r$ + "->chr-&cmem[1280]))" - End If + END IF - Else + ELSE r$ = r$ + "->cmem_descriptor_offset" - End If - GoTo evalfuncspecial - End If + END IF + GOTO evalfuncspecial + END IF 'single, simple variable 'if sub/func arg, may not be in DBLOCK - getid Val(e$) - If Error_Happened Then EXIT Function - If id.sfarg Then 'could be in DBLOCK + getid VAL(e$) + IF Error_Happened THEN EXIT FUNCTION + IF id.sfarg THEN 'could be in DBLOCK r$ = "varptr_dblock_check((uint8*)" + r$ + ")" - Else 'definitely in DBLOCK + ELSE 'definitely in DBLOCK r$ = "((unsigned short)(((uint8*)" + r$ + ")-&cmem[1280]))" - End If + END IF - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF '*special case* - If RTrim$(id2.n) = "VARSEG" Then - If (sourcetyp And ISREFERENCE) = 0 Then - Give_Error "Expected reference to a variable/array": EXIT Function - End If - If (sourcetyp And ISINCONVENTIONALMEMORY) = 0 Then + IF RTRIM$(id2.n) = "VARSEG" THEN + IF (sourcetyp AND ISREFERENCE) = 0 THEN + Give_Error "Expected reference to a variable/array": EXIT FUNCTION + END IF + IF (sourcetyp AND ISINCONVENTIONALMEMORY) = 0 THEN recompile = 1 - cmemlist(Val(e$)) = 1 + cmemlist(VAL(e$)) = 1 r$ = "[CONVENTIONAL_MEMORY_REQUIRED]" typ& = 64& - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF 'array? - If (sourcetyp And ISARRAY) Then - If (sourcetyp And ISFIXEDLENGTH) = 0 Then - If (sourcetyp And ISSTRING) Then + IF (sourcetyp AND ISARRAY) THEN + IF (sourcetyp AND ISFIXEDLENGTH) = 0 THEN + IF (sourcetyp AND ISSTRING) THEN r$ = "80" typ = 64& - GoTo evalfuncspecial - End If - End If + GOTO evalfuncspecial + END IF + END IF typ = 64& r$ = "( ( ((ptrszint)(" + refer(e$, sourcetyp, 1) + "[0])) - ((ptrszint)(&cmem[0])) ) /16)" - If Error_Happened Then EXIT Function - GoTo evalfuncspecial - End If + IF Error_Happened THEN EXIT FUNCTION + GOTO evalfuncspecial + END IF 'single variable/(var-len)string/udt? (usually stored in DBLOCK) typ = 64& 'if sub/func arg, may not be in DBLOCK - getid Val(e$) - If Error_Happened Then EXIT Function - If id.sfarg <> 0 And (sourcetyp And ISSTRING) = 0 Then - If sourcetyp And ISUDT Then + getid VAL(e$) + IF Error_Happened THEN EXIT FUNCTION + IF id.sfarg <> 0 AND (sourcetyp AND ISSTRING) = 0 THEN + IF sourcetyp AND ISUDT THEN r$ = refer(e$, sourcetyp, 1) - If Error_Happened Then EXIT Function - e$ = Right$(e$, Len(e$) - InStr(e$, sp3)) 'skip idnumber - e$ = Right$(e$, Len(e$) - InStr(e$, sp3)) 'skip u - o$ = Right$(e$, Len(e$) - InStr(e$, sp3)) 'skip e + IF Error_Happened THEN EXIT FUNCTION + e$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) 'skip idnumber + e$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) 'skip u + o$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) 'skip e r$ = "varseg_dblock_check(((uint8*)" + r$ + ")+(" + o$ + "))" - Else + ELSE r$ = "varseg_dblock_check((uint8*)" + refer(e$, sourcetyp, 1) + ")" - If Error_Happened Then EXIT Function - End If - Else + IF Error_Happened THEN EXIT FUNCTION + END IF + ELSE 'can be assumed to be in DBLOCK r$ = "80" - End If - GoTo evalfuncspecial - End If 'varseg + END IF + GOTO evalfuncspecial + END IF 'varseg @@ -16873,113 +16873,113 @@ Function evaluatefunc$ (a2$, args As Long, typ As Long) 'note: this comment makes no sense... 'any numeric variable, but it must be type-speficied - If targettyp = -2 Then + IF targettyp = -2 THEN e$ = evaluatetotyp(e2$, -2) - If Error_Happened Then EXIT Function - GoTo dontevaluate - End If '-2 + IF Error_Happened THEN EXIT FUNCTION + GOTO dontevaluate + END IF '-2 - If targettyp = -7 Then + IF targettyp = -7 THEN e$ = evaluatetotyp(e2$, -7) - If Error_Happened Then EXIT Function - GoTo dontevaluate - End If '-7 + IF Error_Happened THEN EXIT FUNCTION + GOTO dontevaluate + END IF '-7 - If targettyp = -8 Then + IF targettyp = -8 THEN e$ = evaluatetotyp(e2$, -8) - If Error_Happened Then EXIT Function - GoTo dontevaluate - End If '-8 + IF Error_Happened THEN EXIT FUNCTION + GOTO dontevaluate + END IF '-8 - If sourcetyp And ISOFFSET Then - If (targettyp And ISOFFSET) = 0 Then - If id2.internal_subfunc = 0 Then Give_Error "Cannot convert _OFFSET type to other types": EXIT Function - End If - End If + IF sourcetyp AND ISOFFSET THEN + IF (targettyp AND ISOFFSET) = 0 THEN + IF id2.internal_subfunc = 0 THEN Give_Error "Cannot convert _OFFSET type to other types": EXIT FUNCTION + END IF + END IF 'note: this is used for functions like STR(...) which accept all types... explicitreference = 0 - If targettyp = -1 Then + IF targettyp = -1 THEN explicitreference = 1 - If (sourcetyp And ISSTRING) Then Give_Error "Number required for function": EXIT Function + IF (sourcetyp AND ISSTRING) THEN Give_Error "Number required for function": EXIT FUNCTION targettyp = sourcetyp - If (targettyp And ISPOINTER) Then targettyp = targettyp - ISPOINTER - End If + IF (targettyp AND ISPOINTER) THEN targettyp = targettyp - ISPOINTER + END IF 'pointer? - If (targettyp And ISPOINTER) Then - If dereference = 0 Then 'check deferencing wasn't used + IF (targettyp AND ISPOINTER) THEN + IF dereference = 0 THEN 'check deferencing wasn't used 'note: array pointer - If (targettyp And ISARRAY) Then - If (sourcetyp And ISREFERENCE) = 0 Then Give_Error "Expected arrayname()": EXIT Function - If (sourcetyp And ISARRAY) = 0 Then Give_Error "Expected arrayname()": EXIT Function - If Debug Then Print #9, "evaluatefunc:array reference:[" + e$ + "]" + IF (targettyp AND ISARRAY) THEN + IF (sourcetyp AND ISREFERENCE) = 0 THEN Give_Error "Expected arrayname()": EXIT FUNCTION + IF (sourcetyp AND ISARRAY) = 0 THEN Give_Error "Expected arrayname()": EXIT FUNCTION + IF Debug THEN PRINT #9, "evaluatefunc:array reference:[" + e$ + "]" 'check arrays are of same type targettyp2 = targettyp: sourcetyp2 = sourcetyp - targettyp2 = targettyp2 And (511 + ISOFFSETINBITS + ISUDT + ISSTRING + ISFIXEDLENGTH + ISFLOAT) - sourcetyp2 = sourcetyp2 And (511 + ISOFFSETINBITS + ISUDT + ISSTRING + ISFIXEDLENGTH + ISFLOAT) - If sourcetyp2 <> targettyp2 Then Give_Error "Incorrect array type passed to function": EXIT Function + targettyp2 = targettyp2 AND (511 + ISOFFSETINBITS + ISUDT + ISSTRING + ISFIXEDLENGTH + ISFLOAT) + sourcetyp2 = sourcetyp2 AND (511 + ISOFFSETINBITS + ISUDT + ISSTRING + ISFIXEDLENGTH + ISFLOAT) + IF sourcetyp2 <> targettyp2 THEN Give_Error "Incorrect array type passed to function": EXIT FUNCTION 'check arrayname was followed by '()' - If targettyp And ISUDT Then - If Debug Then Print #9, "evaluatefunc:array reference:udt reference:[" + e$ + "]" + IF targettyp AND ISUDT THEN + IF Debug THEN PRINT #9, "evaluatefunc:array reference:udt reference:[" + e$ + "]" 'get UDT info - udtrefid = Val(e$) + udtrefid = VAL(e$) getid udtrefid - If Error_Happened Then EXIT Function - udtrefi = InStr(e$, sp3) 'end of id - udtrefi2 = InStr(udtrefi + 1, e$, sp3) 'end of u - udtrefu = Val(Mid$(e$, udtrefi + 1, udtrefi2 - udtrefi - 1)) - udtrefi3 = InStr(udtrefi2 + 1, e$, sp3) 'skip e - udtrefe = Val(Mid$(e$, udtrefi2 + 1, udtrefi3 - udtrefi2 - 1)) - o$ = Right$(e$, Len(e$) - udtrefi3) + IF Error_Happened THEN EXIT FUNCTION + udtrefi = INSTR(e$, sp3) 'end of id + udtrefi2 = INSTR(udtrefi + 1, e$, sp3) 'end of u + udtrefu = VAL(MID$(e$, udtrefi + 1, udtrefi2 - udtrefi - 1)) + udtrefi3 = INSTR(udtrefi2 + 1, e$, sp3) 'skip e + udtrefe = VAL(MID$(e$, udtrefi2 + 1, udtrefi3 - udtrefi2 - 1)) + o$ = RIGHT$(e$, LEN(e$) - udtrefi3) 'note: most of the UDT info above is not required - If Left$(o$, 4) <> "(0)*" Then Give_Error "Expected arrayname()": EXIT Function - Else - If Right$(e$, 2) <> sp3 + "0" Then Give_Error "Expected arrayname()": EXIT Function - End If + IF LEFT$(o$, 4) <> "(0)*" THEN Give_Error "Expected arrayname()": EXIT FUNCTION + ELSE + IF RIGHT$(e$, 2) <> sp3 + "0" THEN Give_Error "Expected arrayname()": EXIT FUNCTION + END IF - idnum = Val(Left$(e$, InStr(e$, sp3) - 1)) + idnum = VAL(LEFT$(e$, INSTR(e$, sp3) - 1)) getid idnum - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION - If targettyp And ISFIXEDLENGTH Then - targettypsize = CVL(Mid$(id2.argsize, curarg * 4 - 4 + 1, 4)) - If id.tsize <> targettypsize Then Give_Error "Incorrect array type passed to function": EXIT Function - End If + IF targettyp AND ISFIXEDLENGTH THEN + targettypsize = CVL(MID$(id2.argsize, curarg * 4 - 4 + 1, 4)) + IF id.tsize <> targettypsize THEN Give_Error "Incorrect array type passed to function": EXIT FUNCTION + END IF - If Mid$(sfcmemargs(targetid), curarg, 1) = Chr$(1) Then 'cmem required? - If cmemlist(idnum) = 0 Then + IF MID$(sfcmemargs(targetid), curarg, 1) = CHR$(1) THEN 'cmem required? + IF cmemlist(idnum) = 0 THEN cmemlist(idnum) = 1 recompile = 1 - End If - End If + END IF + END IF - If id.linkid = 0 Then + IF id.linkid = 0 THEN 'if id.linkid is 0, it means the number of array elements is definietly 'known of the array being passed, this is not some "fake"/unknown array. 'using the numer of array elements of a fake array would be dangerous! - If nelereq = 0 Then + IF nelereq = 0 THEN 'only continue if the number of array elements required is unknown 'and it needs to be set - If id.arrayelements <> -1 Then + IF id.arrayelements <> -1 THEN nelereq = id.arrayelements - Mid$(id2.nelereq, curarg, 1) = Chr$(nelereq) - End If + MID$(id2.nelereq, curarg, 1) = CHR$(nelereq) + END IF ids(targetid) = id2 - Else + ELSE 'the number of array elements required is known AND 'the number of elements in the array to be passed is known @@ -16990,18 +16990,18 @@ Function evaluatefunc$ (a2$, args As Long, typ As Long) 'print id.arrayelements,nelereq ' 1 , 2 - If id.arrayelements <> nelereq Then Give_Error "Passing arrays with a differing number of elements to a SUB/FUNCTION is not supported (yet)": EXIT Function + IF id.arrayelements <> nelereq THEN Give_Error "Passing arrays with a differing number of elements to a SUB/FUNCTION is not supported (yet)": EXIT FUNCTION - End If - End If + END IF + END IF e$ = refer(e$, sourcetyp, 1) - If Error_Happened Then EXIT Function - GoTo dontevaluate - End If + IF Error_Happened THEN EXIT FUNCTION + GOTO dontevaluate + END IF @@ -17018,79 +17018,79 @@ Function evaluatefunc$ (a2$, args As Long, typ As Long) 'target is not an array - If (targettyp And ISSTRING) = 0 Then - If (sourcetyp And ISREFERENCE) Then - idnum = Val(Left$(e$, InStr(e$, sp3) - 1)) 'id# of sourcetyp + IF (targettyp AND ISSTRING) = 0 THEN + IF (sourcetyp AND ISREFERENCE) THEN + idnum = VAL(LEFT$(e$, INSTR(e$, sp3) - 1)) 'id# of sourcetyp targettyp2 = targettyp: sourcetyp2 = sourcetyp 'get info about source/target - arr = 0: If (sourcetyp2 And ISARRAY) Then arr = 1 - passudtelement = 0: If (targettyp2 And ISUDT) = 0 And (sourcetyp2 And ISUDT) <> 0 Then passudtelement = 1: sourcetyp2 = sourcetyp2 - ISUDT + arr = 0: IF (sourcetyp2 AND ISARRAY) THEN arr = 1 + passudtelement = 0: IF (targettyp2 AND ISUDT) = 0 AND (sourcetyp2 AND ISUDT) <> 0 THEN passudtelement = 1: sourcetyp2 = sourcetyp2 - ISUDT 'remove flags irrelevant for comparison... ISPOINTER,ISREFERENCE,ISINCONVENTIONALMEMORY,ISARRAY - targettyp2 = targettyp2 And (511 + ISOFFSETINBITS + ISUDT + ISFLOAT + ISSTRING) - sourcetyp2 = sourcetyp2 And (511 + ISOFFSETINBITS + ISUDT + ISFLOAT + ISSTRING) + targettyp2 = targettyp2 AND (511 + ISOFFSETINBITS + ISUDT + ISFLOAT + ISSTRING) + sourcetyp2 = sourcetyp2 AND (511 + ISOFFSETINBITS + ISUDT + ISFLOAT + ISSTRING) 'compare types - If sourcetyp2 = targettyp2 Then + IF sourcetyp2 = targettyp2 THEN - If sourcetyp And ISUDT Then + IF sourcetyp AND ISUDT THEN 'udt/udt array 'get info - udtrefid = Val(e$) + udtrefid = VAL(e$) getid udtrefid - If Error_Happened Then EXIT Function - udtrefi = InStr(e$, sp3) 'end of id - udtrefi2 = InStr(udtrefi + 1, e$, sp3) 'end of u - udtrefu = Val(Mid$(e$, udtrefi + 1, udtrefi2 - udtrefi - 1)) - udtrefi3 = InStr(udtrefi2 + 1, e$, sp3) 'skip e - udtrefe = Val(Mid$(e$, udtrefi2 + 1, udtrefi3 - udtrefi2 - 1)) - o$ = Right$(e$, Len(e$) - udtrefi3) + IF Error_Happened THEN EXIT FUNCTION + udtrefi = INSTR(e$, sp3) 'end of id + udtrefi2 = INSTR(udtrefi + 1, e$, sp3) 'end of u + udtrefu = VAL(MID$(e$, udtrefi + 1, udtrefi2 - udtrefi - 1)) + udtrefi3 = INSTR(udtrefi2 + 1, e$, sp3) 'skip e + udtrefe = VAL(MID$(e$, udtrefi2 + 1, udtrefi3 - udtrefi2 - 1)) + o$ = RIGHT$(e$, LEN(e$) - udtrefi3) 'note: most of the UDT info above is not required - If arr Then - n2$ = scope$ + "ARRAY_UDT_" + RTrim$(id.n) + "[0]" - Else - n2$ = scope$ + "UDT_" + RTrim$(id.n) - End If + IF arr THEN + n2$ = scope$ + "ARRAY_UDT_" + RTRIM$(id.n) + "[0]" + ELSE + n2$ = scope$ + "UDT_" + RTRIM$(id.n) + END IF e$ = "(void*)( ((char*)(" + n2$ + ")) + (" + o$ + ") )" 'convert void* to target type* - If passudtelement Then e$ = "(" + typ2ctyp$(targettyp2 + (targettyp And ISUNSIGNED), "") + "*)" + e$ - If Error_Happened Then EXIT Function + IF passudtelement THEN e$ = "(" + typ2ctyp$(targettyp2 + (targettyp AND ISUNSIGNED), "") + "*)" + e$ + IF Error_Happened THEN EXIT FUNCTION - Else + ELSE 'not a udt - If arr Then - If (sourcetyp2 And ISOFFSETINBITS) Then Give_Error "Cannot pass BIT array offsets yet": EXIT Function + IF arr THEN + IF (sourcetyp2 AND ISOFFSETINBITS) THEN Give_Error "Cannot pass BIT array offsets yet": EXIT FUNCTION e$ = "(&(" + refer(e$, sourcetyp, 0) + "))" - If Error_Happened Then EXIT Function - Else + IF Error_Happened THEN EXIT FUNCTION + ELSE e$ = refer(e$, sourcetyp, 1) - If Error_Happened Then EXIT Function - End If + IF Error_Happened THEN EXIT FUNCTION + END IF 'note: signed/unsigned mismatch requires casting - If (sourcetyp And ISUNSIGNED) <> (targettyp And ISUNSIGNED) Then - e$ = "(" + typ2ctyp$(targettyp2 + (targettyp And ISUNSIGNED), "") + "*)" + e$ - If Error_Happened Then EXIT Function - End If + IF (sourcetyp AND ISUNSIGNED) <> (targettyp AND ISUNSIGNED) THEN + e$ = "(" + typ2ctyp$(targettyp2 + (targettyp AND ISUNSIGNED), "") + "*)" + e$ + IF Error_Happened THEN EXIT FUNCTION + END IF - End If 'udt? + END IF 'udt? 'force recompile if target needs to be in cmem and the source is not - If Mid$(sfcmemargs(targetid), curarg, 1) = Chr$(1) Then 'cmem required? - If cmemlist(idnum) = 0 Then + IF MID$(sfcmemargs(targetid), curarg, 1) = CHR$(1) THEN 'cmem required? + IF cmemlist(idnum) = 0 THEN cmemlist(idnum) = 1 recompile = 1 - End If - End If + END IF + END IF - GoTo dontevaluate - End If 'similar + GOTO dontevaluate + END IF 'similar 'IF sourcetyp2 = targettyp2 THEN 'IF arr THEN @@ -17102,25 +17102,25 @@ Function evaluatefunc$ (a2$, args As Long, typ As Long) 'GOTO dontevaluate 'END IF - End If 'source is a reference + END IF 'source is a reference - Else 'string + ELSE 'string 'its a string - If (sourcetyp And ISREFERENCE) Then - idnum = Val(Left$(e$, InStr(e$, sp3) - 1)) 'id# of sourcetyp - If Mid$(sfcmemargs(targetid), curarg, 1) = Chr$(1) Then 'cmem required? - If cmemlist(idnum) = 0 Then + IF (sourcetyp AND ISREFERENCE) THEN + idnum = VAL(LEFT$(e$, INSTR(e$, sp3) - 1)) 'id# of sourcetyp + IF MID$(sfcmemargs(targetid), curarg, 1) = CHR$(1) THEN 'cmem required? + IF cmemlist(idnum) = 0 THEN cmemlist(idnum) = 1 recompile = 1 - End If - End If - End If 'reference + END IF + END IF + END IF 'reference - End If 'string + END IF 'string - End If 'dereference was not used - End If 'pointer + END IF 'dereference was not used + END IF 'pointer 'note: Target is not a pointer... @@ -17135,412 +17135,412 @@ Function evaluatefunc$ (a2$, args As Long, typ As Long) 'END IF 'String-numeric mismatch? - If targettyp And ISSTRING Then - If (sourcetyp And ISSTRING) = 0 Then + IF targettyp AND ISSTRING THEN + IF (sourcetyp AND ISSTRING) = 0 THEN nth = curarg - If omitarg_last <> 0 And nth > omitarg_last Then nth = nth - 1 - If ids(targetid).args = 1 Then Give_Error "String required for function": EXIT Function - Give_Error str_nth$(nth) + " function argument requires a string": EXIT Function - End If - End If - If (targettyp And ISSTRING) = 0 Then - If sourcetyp And ISSTRING Then + IF omitarg_last <> 0 AND nth > omitarg_last THEN nth = nth - 1 + IF ids(targetid).args = 1 THEN Give_Error "String required for function": EXIT FUNCTION + Give_Error str_nth$(nth) + " function argument requires a string": EXIT FUNCTION + END IF + END IF + IF (targettyp AND ISSTRING) = 0 THEN + IF sourcetyp AND ISSTRING THEN nth = curarg - If omitarg_last <> 0 And nth > omitarg_last Then nth = nth - 1 - If ids(targetid).args = 1 Then Give_Error "Number required for function": EXIT Function - Give_Error str_nth$(nth) + " function argument requires a number": EXIT Function - End If - End If + IF omitarg_last <> 0 AND nth > omitarg_last THEN nth = nth - 1 + IF ids(targetid).args = 1 THEN Give_Error "Number required for function": EXIT FUNCTION + Give_Error str_nth$(nth) + " function argument requires a number": EXIT FUNCTION + END IF + END IF 'change to "non-pointer" value - If (sourcetyp And ISREFERENCE) Then + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function - End If + IF Error_Happened THEN EXIT FUNCTION + END IF - If explicitreference = 0 Then - If targettyp And ISUDT Then + IF explicitreference = 0 THEN + IF targettyp AND ISUDT THEN nth = curarg - If omitarg_last <> 0 And nth > omitarg_last Then nth = nth - 1 - If qb64prefix_set And udtxcname(targettyp And 511) = "_MEM" Then - x$ = "'" + Mid$(RTrim$(udtxcname(targettyp And 511)), 2) + "'" - Else - x$ = "'" + RTrim$(udtxcname(targettyp And 511)) + "'" - End If - If ids(targetid).args = 1 Then Give_Error "TYPE " + x$ + " required for function": EXIT Function - Give_Error str_nth$(nth) + " function argument requires TYPE " + x$: EXIT Function - End If - Else - If sourcetyp And ISUDT Then Give_Error "Number required for function": EXIT Function - End If + IF omitarg_last <> 0 AND nth > omitarg_last THEN nth = nth - 1 + IF qb64prefix_set AND udtxcname(targettyp AND 511) = "_MEM" THEN + x$ = "'" + MID$(RTRIM$(udtxcname(targettyp AND 511)), 2) + "'" + ELSE + x$ = "'" + RTRIM$(udtxcname(targettyp AND 511)) + "'" + END IF + IF ids(targetid).args = 1 THEN Give_Error "TYPE " + x$ + " required for function": EXIT FUNCTION + Give_Error str_nth$(nth) + " function argument requires TYPE " + x$: EXIT FUNCTION + END IF + ELSE + IF sourcetyp AND ISUDT THEN Give_Error "Number required for function": EXIT FUNCTION + END IF 'round to integer if required - If (sourcetyp And ISFLOAT) Then - If (targettyp And ISFLOAT) = 0 Then + IF (sourcetyp AND ISFLOAT) THEN + IF (targettyp AND ISFLOAT) = 0 THEN '**32 rounding fix - bits = targettyp And 511 - If bits <= 16 Then e$ = "qbr_float_to_long(" + e$ + ")" - If bits > 16 And bits < 32 Then e$ = "qbr_double_to_long(" + e$ + ")" - If bits >= 32 Then e$ = "qbr(" + e$ + ")" - End If - End If + bits = targettyp AND 511 + IF bits <= 16 THEN e$ = "qbr_float_to_long(" + e$ + ")" + IF bits > 16 AND bits < 32 THEN e$ = "qbr_double_to_long(" + e$ + ")" + IF bits >= 32 THEN e$ = "qbr(" + e$ + ")" + END IF + END IF - If explicitreference Then - If (targettyp And ISOFFSETINBITS) Then + IF explicitreference THEN + IF (targettyp AND ISOFFSETINBITS) THEN 'integer value can fit inside int64 e$ = "(int64)(" + e$ + ")" - Else - If (targettyp And ISFLOAT) Then - If (targettyp And 511) = 32 Then e$ = "(float)(" + e$ + ")" - If (targettyp And 511) = 64 Then e$ = "(double)(" + e$ + ")" - If (targettyp And 511) = 256 Then e$ = "(long double)(" + e$ + ")" - Else - If (targettyp And ISUNSIGNED) Then - If (targettyp And 511) = 8 Then e$ = "(uint8)(" + e$ + ")" - If (targettyp And 511) = 16 Then e$ = "(uint16)(" + e$ + ")" - If (targettyp And 511) = 32 Then e$ = "(uint32)(" + e$ + ")" - If (targettyp And 511) = 64 Then e$ = "(uint64)(" + e$ + ")" - Else - If (targettyp And 511) = 8 Then e$ = "(int8)(" + e$ + ")" - If (targettyp And 511) = 16 Then e$ = "(int16)(" + e$ + ")" - If (targettyp And 511) = 32 Then e$ = "(int32)(" + e$ + ")" - If (targettyp And 511) = 64 Then e$ = "(int64)(" + e$ + ")" - End If - End If 'float? - End If 'offset in bits? - End If 'explicit? + ELSE + IF (targettyp AND ISFLOAT) THEN + IF (targettyp AND 511) = 32 THEN e$ = "(float)(" + e$ + ")" + IF (targettyp AND 511) = 64 THEN e$ = "(double)(" + e$ + ")" + IF (targettyp AND 511) = 256 THEN e$ = "(long double)(" + e$ + ")" + ELSE + IF (targettyp AND ISUNSIGNED) THEN + IF (targettyp AND 511) = 8 THEN e$ = "(uint8)(" + e$ + ")" + IF (targettyp AND 511) = 16 THEN e$ = "(uint16)(" + e$ + ")" + IF (targettyp AND 511) = 32 THEN e$ = "(uint32)(" + e$ + ")" + IF (targettyp AND 511) = 64 THEN e$ = "(uint64)(" + e$ + ")" + ELSE + IF (targettyp AND 511) = 8 THEN e$ = "(int8)(" + e$ + ")" + IF (targettyp AND 511) = 16 THEN e$ = "(int16)(" + e$ + ")" + IF (targettyp AND 511) = 32 THEN e$ = "(int32)(" + e$ + ")" + IF (targettyp AND 511) = 64 THEN e$ = "(int64)(" + e$ + ")" + END IF + END IF 'float? + END IF 'offset in bits? + END IF 'explicit? - If (targettyp And ISPOINTER) Then 'pointer required - If (targettyp And ISSTRING) Then GoTo dontevaluate 'no changes required + IF (targettyp AND ISPOINTER) THEN 'pointer required + IF (targettyp AND ISSTRING) THEN GOTO dontevaluate 'no changes required '20090703 t$ = typ2ctyp$(targettyp, "") - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION v$ = "pass" + str2$(uniquenumber) 'assume numeric type - If Mid$(sfcmemargs(targetid), curarg, 1) = Chr$(1) Then 'cmem required? - bytesreq = ((targettyp And 511) + 7) \ 8 - Print #defdatahandle, t$ + " *" + v$ + "=NULL;" - Print #13, "if(" + v$ + "==NULL){" - Print #13, "cmem_sp-=" + str2(bytesreq) + ";" - Print #13, v$ + "=(" + t$ + "*)(dblock+cmem_sp);" - Print #13, "if (cmem_spchr" - End If + END IF - If LTrim$(RTrim$(e$)) = "0" Then e$ = "NULL" + IF LTRIM$(RTRIM$(e$)) = "0" THEN e$ = "NULL" - End If + END IF r$ = r$ + e$ '***special case**** - If n$ = "_MEM" Or (n$ = "MEM" And qb64prefix_set = 1) Then - If args = 1 Then - If curarg = 1 Then r$ = r$ + ")": GoTo evalfuncspecial - End If - If args = 2 Then - If curarg = 2 Then r$ = r$ + ")": GoTo evalfuncspecial - End If - End If + IF n$ = "_MEM" OR (n$ = "MEM" AND qb64prefix_set = 1) THEN + IF args = 1 THEN + IF curarg = 1 THEN r$ = r$ + ")": GOTO evalfuncspecial + END IF + IF args = 2 THEN + IF curarg = 2 THEN r$ = r$ + ")": GOTO evalfuncspecial + END IF + END IF - If i <> n And nocomma = 0 Then r$ = r$ + "," + IF i <> n AND nocomma = 0 THEN r$ = r$ + "," nocomma = 0 firsti = i + 1 curarg = curarg + 1 - End If + END IF - If (curarg >= omitarg_first And curarg <= omitarg_last) And i = n Then - targettyp = CVL(Mid$(id2.arg, curarg * 4 - 4 + 1, 4)) + IF (curarg >= omitarg_first AND curarg <= omitarg_last) AND i = n THEN + targettyp = CVL(MID$(id2.arg, curarg * 4 - 4 + 1, 4)) 'IF (targettyp AND ISSTRING) THEN Give_Error "QB64 doesn't support optional string arguments for functions yet!": EXIT FUNCTION - For fi = 1 To omitargs: r$ = r$ + ",NULL": Next + FOR fi = 1 TO omitargs: r$ = r$ + ",NULL": NEXT curarg = curarg + omitargs - End If + END IF - Next - End If + NEXT + END IF - If n$ = "UBOUND" Or n$ = "LBOUND" Then - If r$ = ",NULL" Then r$ = ",1" - If n$ = "UBOUND" Then r2$ = "func_ubound(" Else r2$ = "func_lbound(" + IF n$ = "UBOUND" OR n$ = "LBOUND" THEN + IF r$ = ",NULL" THEN r$ = ",1" + IF n$ = "UBOUND" THEN r2$ = "func_ubound(" ELSE r2$ = "func_lbound(" e$ = refer$(ulboundarray$, sourcetyp, 1) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION 'note: ID contins refer'ed array info arrayelements = id.arrayelements '2009 - If arrayelements = -1 Then arrayelements = 1 '2009 + IF arrayelements = -1 THEN arrayelements = 1 '2009 r$ = r2$ + e$ + r$ + "," + str2$(arrayelements) + ")" typ& = INTEGER64TYPE - ISPOINTER - GoTo evalfuncspecial - End If + GOTO evalfuncspecial + END IF - If passomit Then - If omitarg_first Then r$ = r$ + ",0" Else r$ = r$ + ",1" - End If + IF passomit THEN + IF omitarg_first THEN r$ = r$ + ",0" ELSE r$ = r$ + ",1" + END IF r$ = r$ + ")" evalfuncspecial: - If n$ = "ABS" Then typ& = sourcetyp 'ABS Note: ABS() returns argument #1's type + IF n$ = "ABS" THEN typ& = sourcetyp 'ABS Note: ABS() returns argument #1's type 'QB-like conversion of math functions returning floating point values - If n$ = "SIN" Or n$ = "COS" Or n$ = "TAN" Or n$ = "ATN" Or n$ = "SQR" Or n$ = "LOG" Then - b = sourcetyp And 511 - If sourcetyp And ISFLOAT Then + IF n$ = "SIN" OR n$ = "COS" OR n$ = "TAN" OR n$ = "ATN" OR n$ = "SQR" OR n$ = "LOG" THEN + b = sourcetyp AND 511 + IF sourcetyp AND ISFLOAT THEN 'Default is FLOATTYPE - If b = 64 Then typ& = DOUBLETYPE - ISPOINTER - If b = 32 Then typ& = SINGLETYPE - ISPOINTER - Else + IF b = 64 THEN typ& = DOUBLETYPE - ISPOINTER + IF b = 32 THEN typ& = SINGLETYPE - ISPOINTER + ELSE 'Default is FLOATTYPE - If b <= 32 Then typ& = DOUBLETYPE - ISPOINTER - If b <= 16 Then typ& = SINGLETYPE - ISPOINTER - End If - End If + IF b <= 32 THEN typ& = DOUBLETYPE - ISPOINTER + IF b <= 16 THEN typ& = SINGLETYPE - ISPOINTER + END IF + END IF - If id2.ret = ISUDT + (1) Then + IF id2.ret = ISUDT + (1) THEN '***special case*** v$ = "func" + str2$(uniquenumber) - Print #defdatahandle, "mem_block " + v$ + ";" + PRINT #defdatahandle, "mem_block " + v$ + ";" r$ = "(" + v$ + "=" + r$ + ")" - End If + END IF - If id2.ccall Then - If Left$(r$, 11) = "( char* )" Then + IF id2.ccall THEN + IF LEFT$(r$, 11) = "( char* )" THEN r$ = "qbs_new_txt(" + r$ + ")" - End If - End If + END IF + END IF - If Debug Then Print #9, "evaluatefunc:out:"; r$ + IF Debug THEN PRINT #9, "evaluatefunc:out:"; r$ evaluatefunc$ = r$ -End Function +END FUNCTION -Function variablesize$ (i As Long) 'ID or -1 (if ID already 'loaded') +FUNCTION variablesize$ (i AS LONG) 'ID or -1 (if ID already 'loaded') 'Note: assumes whole bytes, no bit offsets/sizes - If i <> -1 Then getid i - If Error_Happened Then EXIT Function + IF i <> -1 THEN getid i + IF Error_Happened THEN EXIT FUNCTION 'find base size from type - t = id.t: If t = 0 Then t = id.arraytype - bytes = (t And 511) \ 8 + t = id.t: IF t = 0 THEN t = id.arraytype + bytes = (t AND 511) \ 8 - If t And ISUDT Then 'correct size for UDTs - u = t And 511 + IF t AND ISUDT THEN 'correct size for UDTs + u = t AND 511 bytes = udtxsize(u) \ 8 - End If + END IF - If t And ISSTRING Then 'correct size for strings - If t And ISFIXEDLENGTH Then + IF t AND ISSTRING THEN 'correct size for strings + IF t AND ISFIXEDLENGTH THEN bytes = id.tsize - Else - If id.arraytype Then Give_Error "Cannot determine size of variable-length string array": EXIT Function - variablesize$ = scope$ + "STRING_" + RTrim$(id.n) + "->len" - EXIT Function - End If - End If + ELSE + IF id.arraytype THEN Give_Error "Cannot determine size of variable-length string array": EXIT FUNCTION + variablesize$ = scope$ + "STRING_" + RTRIM$(id.n) + "->len" + EXIT FUNCTION + END IF + END IF - If id.arraytype Then 'multiply size for arrays - n$ = RTrim$(id.callname) + IF id.arraytype THEN 'multiply size for arrays + n$ = RTRIM$(id.callname) s$ = str2(bytes) + "*(" + n$ + "[2]&1)" 'note: multiplying by 0 if array not currently defined (affects dynamic arrays) - arrayelements = id.arrayelements: If arrayelements = -1 Then arrayelements = 1 '2009 - For i2 = 1 To arrayelements + arrayelements = id.arrayelements: IF arrayelements = -1 THEN arrayelements = 1 '2009 + FOR i2 = 1 TO arrayelements s$ = s$ + "*" + n$ + "[" + str2(i2 * 4 - 4 + 5) + "]" - Next + NEXT variablesize$ = "(" + s$ + ")" - EXIT Function - End If + EXIT FUNCTION + END IF variablesize$ = str2(bytes) -End Function +END FUNCTION -Function evaluatetotyp$ (a2$, targettyp As Long) +FUNCTION evaluatetotyp$ (a2$, targettyp AS LONG) 'note: 'evaluatetotyp' no longer performs 'fixoperationorder' on a2$ (in many cases, this has already been done) a$ = a2$ e$ = evaluate(a$, sourcetyp) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION 'Offset protection: - If sourcetyp And ISOFFSET Then - If (targettyp And ISOFFSET) = 0 And targettyp >= 0 Then - Give_Error "Cannot convert _OFFSET type to other types": EXIT Function - End If - End If + IF sourcetyp AND ISOFFSET THEN + IF (targettyp AND ISOFFSET) = 0 AND targettyp >= 0 THEN + Give_Error "Cannot convert _OFFSET type to other types": EXIT FUNCTION + END IF + END IF '-5 size '-6 offset - If targettyp = -4 Or targettyp = -5 Or targettyp = -6 Then '? -> byte_element(offset,element size in bytes) - If (sourcetyp And ISREFERENCE) = 0 Then Give_Error "Expected variable name/array element": EXIT Function - If (sourcetyp And ISOFFSETINBITS) Then Give_Error "Variable/element cannot be BIT aligned": EXIT Function + IF targettyp = -4 OR targettyp = -5 OR targettyp = -6 THEN '? -> byte_element(offset,element size in bytes) + IF (sourcetyp AND ISREFERENCE) = 0 THEN Give_Error "Expected variable name/array element": EXIT FUNCTION + IF (sourcetyp AND ISOFFSETINBITS) THEN Give_Error "Variable/element cannot be BIT aligned": EXIT FUNCTION ' print "-4: evaluated as ["+e$+"]":sleep 1 - If (sourcetyp And ISUDT) Then 'User Defined Type -> byte_element(offset,bytes) - If udtxvariable(sourcetyp And 511) Then Give_Error "UDT must have fixed size": EXIT Function - idnumber = Val(e$) - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i) - u = Val(e$) 'closest parent - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i) - E = Val(e$) - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i) + IF (sourcetyp AND ISUDT) THEN 'User Defined Type -> byte_element(offset,bytes) + IF udtxvariable(sourcetyp AND 511) THEN Give_Error "UDT must have fixed size": EXIT FUNCTION + idnumber = VAL(e$) + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i) + u = VAL(e$) 'closest parent + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i) + E = VAL(e$) + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i) o$ = e$ getid idnumber - If Error_Happened Then EXIT Function - n$ = "UDT_" + RTrim$(id.n) - If id.arraytype Then + IF Error_Happened THEN EXIT FUNCTION + n$ = "UDT_" + RTRIM$(id.n) + IF id.arraytype THEN n$ = "ARRAY_" + n$ + "[0]" 'whole array reference examplename()? - If Left$(o$, 3) = "(0)" Then + IF LEFT$(o$, 3) = "(0)" THEN 'use -2 type method - GoTo method2usealludt - End If - End If + GOTO method2usealludt + END IF + END IF dst$ = "(((char*)" + scope$ + n$ + ")+(" + o$ + "))" 'determine size of element - If E = 0 Then 'no specific element, use size of entire type + IF E = 0 THEN 'no specific element, use size of entire type bytes$ = str2(udtxsize(u) \ 8) - Else 'a specific element - If (udtetype(E) And ISSTRING) > 0 And (udtetype(E) And ISFIXEDLENGTH) = 0 And (targettyp = -5) Then + ELSE 'a specific element + IF (udtetype(E) AND ISSTRING) > 0 AND (udtetype(E) AND ISFIXEDLENGTH) = 0 AND (targettyp = -5) THEN evaluatetotyp$ = "(*(qbs**)" + dst$ + ")->len" - EXIT Function - End If + EXIT FUNCTION + END IF bytes$ = str2(udtesize(E) \ 8) - End If + END IF evaluatetotyp$ = "byte_element((uint64)" + dst$ + "," + bytes$ + "," + NewByteElement$ + ")" - If targettyp = -5 Then evaluatetotyp$ = bytes$ - If targettyp = -6 Then evaluatetotyp$ = dst$ - EXIT Function - End If + IF targettyp = -5 THEN evaluatetotyp$ = bytes$ + IF targettyp = -6 THEN evaluatetotyp$ = dst$ + EXIT FUNCTION + END IF - If (sourcetyp And ISARRAY) Then 'Array reference -> byte_element(offset,bytes) + IF (sourcetyp AND ISARRAY) THEN 'Array reference -> byte_element(offset,bytes) 'whole array reference examplename()? - If Right$(e$, 2) = sp3 + "0" Then + IF RIGHT$(e$, 2) = sp3 + "0" THEN 'use -2 type method - If sourcetyp And ISSTRING Then - If (sourcetyp And ISFIXEDLENGTH) = 0 Then - Give_Error "Cannot pass array of variable-length strings": EXIT Function - End If - End If - GoTo method2useall - End If + IF sourcetyp AND ISSTRING THEN + IF (sourcetyp AND ISFIXEDLENGTH) = 0 THEN + Give_Error "Cannot pass array of variable-length strings": EXIT FUNCTION + END IF + END IF + GOTO method2useall + END IF 'assume a specific element - If sourcetyp And ISSTRING Then - If sourcetyp And ISFIXEDLENGTH Then - idnumber = Val(e$) + IF sourcetyp AND ISSTRING THEN + IF sourcetyp AND ISFIXEDLENGTH THEN + idnumber = VAL(e$) getid idnumber - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION bytes$ = str2(id.tsize) e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION evaluatetotyp$ = "byte_element((uint64)" + e$ + "->chr," + bytes$ + "," + NewByteElement$ + ")" - If targettyp = -5 Then evaluatetotyp$ = bytes$ - If targettyp = -6 Then evaluatetotyp$ = e$ + "->chr" - Else + IF targettyp = -5 THEN evaluatetotyp$ = bytes$ + IF targettyp = -6 THEN evaluatetotyp$ = e$ + "->chr" + ELSE e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION evaluatetotyp$ = "byte_element((uint64)" + e$ + "->chr," + e$ + "->len," + NewByteElement$ + ")" - If targettyp = -5 Then evaluatetotyp$ = e$ + "->len" - If targettyp = -6 Then evaluatetotyp$ = e$ + "->chr" - End If - EXIT Function - End If + IF targettyp = -5 THEN evaluatetotyp$ = e$ + "->len" + IF targettyp = -6 THEN evaluatetotyp$ = e$ + "->chr" + END IF + EXIT FUNCTION + END IF e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION e$ = "(&(" + e$ + "))" - bytes$ = str2((sourcetyp And 511) \ 8) + bytes$ = str2((sourcetyp AND 511) \ 8) evaluatetotyp$ = "byte_element((uint64)" + e$ + "," + bytes$ + "," + NewByteElement$ + ")" - If targettyp = -5 Then evaluatetotyp$ = bytes$ - If targettyp = -6 Then evaluatetotyp$ = e$ - EXIT Function - End If + IF targettyp = -5 THEN evaluatetotyp$ = bytes$ + IF targettyp = -6 THEN evaluatetotyp$ = e$ + EXIT FUNCTION + END IF - If sourcetyp And ISSTRING Then 'String -> byte_element(offset,bytes) - If sourcetyp And ISFIXEDLENGTH Then - idnumber = Val(e$) + IF sourcetyp AND ISSTRING THEN 'String -> byte_element(offset,bytes) + IF sourcetyp AND ISFIXEDLENGTH THEN + idnumber = VAL(e$) getid idnumber - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION bytes$ = str2(id.tsize) e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function - Else + IF Error_Happened THEN EXIT FUNCTION + ELSE e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION bytes$ = e$ + "->len" - End If + END IF evaluatetotyp$ = "byte_element((uint64)" + e$ + "->chr," + bytes$ + "," + NewByteElement$ + ")" - If targettyp = -5 Then evaluatetotyp$ = bytes$ - If targettyp = -6 Then evaluatetotyp$ = e$ + "->chr" - EXIT Function - End If + IF targettyp = -5 THEN evaluatetotyp$ = bytes$ + IF targettyp = -6 THEN evaluatetotyp$ = e$ + "->chr" + EXIT FUNCTION + END IF 'Standard variable -> byte_element(offset,bytes) e$ = refer(e$, sourcetyp, 1) 'get the variable's formal name - If Error_Happened Then EXIT Function - size = (sourcetyp And 511) \ 8 'calculate its size in bytes + IF Error_Happened THEN EXIT FUNCTION + size = (sourcetyp AND 511) \ 8 'calculate its size in bytes evaluatetotyp$ = "byte_element((uint64)" + e$ + "," + str2(size) + "," + NewByteElement$ + ")" - If targettyp = -5 Then evaluatetotyp$ = str2(size) - If targettyp = -6 Then evaluatetotyp$ = e$ - EXIT Function + IF targettyp = -5 THEN evaluatetotyp$ = str2(size) + IF targettyp = -6 THEN evaluatetotyp$ = e$ + EXIT FUNCTION - End If '-4, -5, -6 + END IF '-4, -5, -6 - If targettyp = -8 Then '? -> _MEM structure helper {offset, fullsize, typeval, elementsize, sf_mem_lock|???} - If (sourcetyp And ISREFERENCE) = 0 Then Give_Error "Expected variable name/array element": EXIT Function - If (sourcetyp And ISOFFSETINBITS) Then Give_Error "Variable/element cannot be BIT aligned": EXIT Function + IF targettyp = -8 THEN '? -> _MEM structure helper {offset, fullsize, typeval, elementsize, sf_mem_lock|???} + IF (sourcetyp AND ISREFERENCE) = 0 THEN Give_Error "Expected variable name/array element": EXIT FUNCTION + IF (sourcetyp AND ISOFFSETINBITS) THEN Give_Error "Variable/element cannot be BIT aligned": EXIT FUNCTION - If (sourcetyp And ISUDT) Then 'User Defined Type -> byte_element(offset,bytes) - idnumber = Val(e$) - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i) - u = Val(e$) 'closest parent - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i) - E = Val(e$) - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i) + IF (sourcetyp AND ISUDT) THEN 'User Defined Type -> byte_element(offset,bytes) + idnumber = VAL(e$) + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i) + u = VAL(e$) 'closest parent + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i) + E = VAL(e$) + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i) o$ = e$ getid idnumber - If Error_Happened Then EXIT Function - n$ = "UDT_" + RTrim$(id.n) - If id.arraytype Then + IF Error_Happened THEN EXIT FUNCTION + n$ = "UDT_" + RTRIM$(id.n) + IF id.arraytype THEN n$ = "ARRAY_" + n$ + "[0]" 'whole array reference examplename()? - If Left$(o$, 3) = "(0)" Then + IF LEFT$(o$, 3) = "(0)" THEN 'use -7 type method - GoTo method2usealludt__7 - End If - End If + GOTO method2usealludt__7 + END IF + END IF 'determine size of element - If E = 0 Then 'no specific element, use size of entire type + IF E = 0 THEN 'no specific element, use size of entire type bytes$ = str2(udtxsize(u) \ 8) t1 = ISUDT + udtetype(u) - Else 'a specific element + ELSE 'a specific element bytes$ = str2(udtesize(E) \ 8) t1 = udtetype(E) - End If + END IF dst$ = "(((char*)" + scope$ + n$ + ")+(" + o$ + "))" 'evaluatetotyp$ = "byte_element((uint64)" + dst$ + "," + bytes$ + "," + NewByteElement$ + ")" 'IF targettyp = -5 THEN evaluatetotyp$ = bytes$ @@ -17549,34 +17549,34 @@ Function evaluatetotyp$ (a2$, targettyp As Long) t = Type2MemTypeValue(t1) evaluatetotyp$ = "(ptrszint)" + dst$ + "," + bytes$ + "," + str2(t) + "," + bytes$ + ",sf_mem_lock" - EXIT Function - End If + EXIT FUNCTION + END IF - If (sourcetyp And ISARRAY) Then 'Array reference -> byte_element(offset,bytes) + IF (sourcetyp AND ISARRAY) THEN 'Array reference -> byte_element(offset,bytes) 'whole array reference examplename()? - If Right$(e$, 2) = sp3 + "0" Then + IF RIGHT$(e$, 2) = sp3 + "0" THEN 'use -7 type method - If sourcetyp And ISSTRING Then - If (sourcetyp And ISFIXEDLENGTH) = 0 Then - Give_Error "Cannot pass array of variable-length strings": EXIT Function - End If - End If - GoTo method2useall__7 - End If + IF sourcetyp AND ISSTRING THEN + IF (sourcetyp AND ISFIXEDLENGTH) = 0 THEN + Give_Error "Cannot pass array of variable-length strings": EXIT FUNCTION + END IF + END IF + GOTO method2useall__7 + END IF - idnumber = Val(e$) + idnumber = VAL(e$) getid idnumber - If Error_Happened Then EXIT Function - n$ = RTrim$(id.callname) + IF Error_Happened THEN EXIT FUNCTION + n$ = RTRIM$(id.callname) lk$ = "(mem_lock*)((ptrszint*)" + n$ + ")[" + str2(4 * id.arrayelements + 4 + 1 - 1) + "]" 'assume a specific element - If sourcetyp And ISSTRING Then - If sourcetyp And ISFIXEDLENGTH Then + IF sourcetyp AND ISSTRING THEN + IF sourcetyp AND ISFIXEDLENGTH THEN bytes$ = str2(id.tsize) e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION 'evaluatetotyp$ = "byte_element((uint64)" + e$ + "->chr," + bytes$ + "," + NewByteElement$ + ")" 'IF targettyp = -5 THEN evaluatetotyp$ = bytes$ 'IF targettyp = -6 THEN evaluatetotyp$ = e$ + "->chr" @@ -17584,18 +17584,18 @@ Function evaluatetotyp$ (a2$, targettyp As Long) t = Type2MemTypeValue(sourcetyp) evaluatetotyp$ = "(ptrszint)" + e$ + "->chr," + bytes$ + "," + str2(t) + "," + bytes$ + "," + lk$ - Else + ELSE - Give_Error qb64prefix$ + "MEMELEMENT cannot reference variable-length strings": EXIT Function + Give_Error qb64prefix$ + "MEMELEMENT cannot reference variable-length strings": EXIT FUNCTION - End If - EXIT Function - End If + END IF + EXIT FUNCTION + END IF e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION e$ = "(&(" + e$ + "))" - bytes$ = str2((sourcetyp And 511) \ 8) + bytes$ = str2((sourcetyp AND 511) \ 8) 'evaluatetotyp$ = "byte_element((uint64)" + e$ + "," + bytes$ + "," + NewByteElement$ + ")" 'IF targettyp = -5 THEN evaluatetotyp$ = bytes$ 'IF targettyp = -6 THEN evaluatetotyp$ = e$ @@ -17603,20 +17603,20 @@ Function evaluatetotyp$ (a2$, targettyp As Long) t = Type2MemTypeValue(sourcetyp) evaluatetotyp$ = "(ptrszint)" + e$ + "," + bytes$ + "," + str2(t) + "," + bytes$ + "," + lk$ - EXIT Function - End If 'isarray + EXIT FUNCTION + END IF 'isarray - If sourcetyp And ISSTRING Then 'String -> byte_element(offset,bytes) - If sourcetyp And ISFIXEDLENGTH Then - idnumber = Val(e$) + IF sourcetyp AND ISSTRING THEN 'String -> byte_element(offset,bytes) + IF sourcetyp AND ISFIXEDLENGTH THEN + idnumber = VAL(e$) getid idnumber - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION bytes$ = str2(id.tsize) e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function - Else - Give_Error qb64prefix$ + "MEMELEMENT cannot reference variable-length strings": EXIT Function - End If + IF Error_Happened THEN EXIT FUNCTION + ELSE + Give_Error qb64prefix$ + "MEMELEMENT cannot reference variable-length strings": EXIT FUNCTION + END IF 'evaluatetotyp$ = "byte_element((uint64)" + e$ + "->chr," + bytes$ + "," + NewByteElement$ + ")" 'IF targettyp = -5 THEN evaluatetotyp$ = bytes$ @@ -17625,13 +17625,13 @@ Function evaluatetotyp$ (a2$, targettyp As Long) t = Type2MemTypeValue(sourcetyp) evaluatetotyp$ = "(ptrszint)" + e$ + "->chr," + bytes$ + "," + str2(t) + "," + bytes$ + ",sf_mem_lock" - EXIT Function - End If + EXIT FUNCTION + END IF 'Standard variable -> byte_element(offset,bytes) e$ = refer(e$, sourcetyp, 1) 'get the variable's formal name - If Error_Happened Then EXIT Function - size = (sourcetyp And 511) \ 8 'calculate its size in bytes + IF Error_Happened THEN EXIT FUNCTION + size = (sourcetyp AND 511) \ 8 'calculate its size in bytes 'evaluatetotyp$ = "byte_element((uint64)" + e$ + "," + str2(size) + "," + NewByteElement$ + ")" 'IF targettyp = -5 THEN evaluatetotyp$ = str2(size) 'IF targettyp = -6 THEN evaluatetotyp$ = e$ @@ -17639,9 +17639,9 @@ Function evaluatetotyp$ (a2$, targettyp As Long) t = Type2MemTypeValue(sourcetyp) evaluatetotyp$ = "(ptrszint)" + e$ + "," + str2(size) + "," + str2(t) + "," + str2(size) + ",sf_mem_lock" - EXIT Function + EXIT FUNCTION - End If '-8 + END IF '-8 @@ -17652,305 +17652,305 @@ Function evaluatetotyp$ (a2$, targettyp As Long) - If targettyp = -7 Then '? -> _MEM structure helper {offset, fullsize, typeval, elementsize, sf_mem_lock|???} + IF targettyp = -7 THEN '? -> _MEM structure helper {offset, fullsize, typeval, elementsize, sf_mem_lock|???} method2useall__7: - If (sourcetyp And ISREFERENCE) = 0 Then Give_Error "Expected variable name/array element": EXIT Function - If (sourcetyp And ISOFFSETINBITS) Then Give_Error "Variable/element cannot be BIT aligned": EXIT Function + IF (sourcetyp AND ISREFERENCE) = 0 THEN Give_Error "Expected variable name/array element": EXIT FUNCTION + IF (sourcetyp AND ISOFFSETINBITS) THEN Give_Error "Variable/element cannot be BIT aligned": EXIT FUNCTION 'User Defined Type - If (sourcetyp And ISUDT) Then + IF (sourcetyp AND ISUDT) THEN ' print "CI: -2 type from a UDT":sleep 1 - idnumber = Val(e$) - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i) - u = Val(e$) 'closest parent - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i) - E = Val(e$) - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i) + idnumber = VAL(e$) + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i) + u = VAL(e$) 'closest parent + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i) + E = VAL(e$) + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i) o$ = e$ getid idnumber - If Error_Happened Then EXIT Function - n$ = "UDT_" + RTrim$(id.n): If id.arraytype Then n$ = "ARRAY_" + n$ + "[0]" + IF Error_Happened THEN EXIT FUNCTION + n$ = "UDT_" + RTRIM$(id.n): IF id.arraytype THEN n$ = "ARRAY_" + n$ + "[0]" method2usealludt__7: bytes$ = variablesize$(-1) + "-(" + o$ + ")" - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION dst$ = "(((char*)" + scope$ + n$ + ")+(" + o$ + "))" 'evaluatetotyp$ = "byte_element((uint64)" + dst$ + "," + bytes$ + "," + NewByteElement$ + ")" 'note: myudt.myelement results in a size of 1 because it is a continuous run of no consistent granularity - If E <> 0 Then size = 1 Else size = udtxsize(u) \ 8 + IF E <> 0 THEN size = 1 ELSE size = udtxsize(u) \ 8 t = Type2MemTypeValue(sourcetyp) evaluatetotyp$ = "(ptrszint)" + dst$ + "," + bytes$ + "," + str2(t) + "," + str2(size) + ",sf_mem_lock" - EXIT Function - End If + EXIT FUNCTION + END IF 'Array reference - If (sourcetyp And ISARRAY) Then - If sourcetyp And ISSTRING Then - If (sourcetyp And ISFIXEDLENGTH) = 0 Then - Give_Error qb64prefix$ + "MEM cannot reference variable-length strings": EXIT Function - End If - End If + IF (sourcetyp AND ISARRAY) THEN + IF sourcetyp AND ISSTRING THEN + IF (sourcetyp AND ISFIXEDLENGTH) = 0 THEN + Give_Error qb64prefix$ + "MEM cannot reference variable-length strings": EXIT FUNCTION + END IF + END IF - idnumber = Val(e$) + idnumber = VAL(e$) getid idnumber - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION - n$ = RTrim$(id.callname) + n$ = RTRIM$(id.callname) lk$ = "(mem_lock*)((ptrszint*)" + n$ + ")[" + str2(4 * id.arrayelements + 4 + 1 - 1) + "]" tsize = id.tsize 'used later to determine element size of fixed length strings 'note: array references consist of idnumber|unmultiplied-element-index - index$ = Right$(e$, Len(e$) - InStr(e$, sp3)) 'get element index + index$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) 'get element index bytes$ = variablesize$(-1) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION - If sourcetyp And ISSTRING Then + IF sourcetyp AND ISSTRING THEN e$ = "((" + e$ + ")->chr)" '[2013] handle fixed string arrays differently because they are already pointers - Else + ELSE e$ = "(&(" + e$ + "))" - End If + END IF ' print "CI: array: e$["+e$+"], bytes$["+bytes$+"]":sleep 1 'calculate size of elements - If sourcetyp And ISSTRING Then + IF sourcetyp AND ISSTRING THEN bytes = tsize - Else - bytes = (sourcetyp And 511) \ 8 - End If + ELSE + bytes = (sourcetyp AND 511) \ 8 + END IF bytes$ = bytes$ + "-(" + str2(bytes) + "*(" + index$ + "))" t = Type2MemTypeValue(sourcetyp) evaluatetotyp$ = "(ptrszint)" + e$ + "," + bytes$ + "," + str2(t) + "," + str2(bytes) + "," + lk$ - EXIT Function - End If + EXIT FUNCTION + END IF 'String - If sourcetyp And ISSTRING Then - If (sourcetyp And ISFIXEDLENGTH) = 0 Then Give_Error qb64prefix$ + "MEM cannot reference variable-length strings": EXIT Function + IF sourcetyp AND ISSTRING THEN + IF (sourcetyp AND ISFIXEDLENGTH) = 0 THEN Give_Error qb64prefix$ + "MEM cannot reference variable-length strings": EXIT FUNCTION - idnumber = Val(e$) - getid idnumber: If Error_Happened Then EXIT Function + idnumber = VAL(e$) + getid idnumber: IF Error_Happened THEN EXIT FUNCTION bytes$ = str2(id.tsize) - e$ = refer(e$, sourcetyp, 0): If Error_Happened Then EXIT Function + e$ = refer(e$, sourcetyp, 0): IF Error_Happened THEN EXIT FUNCTION t = Type2MemTypeValue(sourcetyp) evaluatetotyp$ = "(ptrszint)" + e$ + "->chr," + bytes$ + "," + str2(t) + "," + bytes$ + ",sf_mem_lock" - EXIT Function - End If + EXIT FUNCTION + END IF 'Standard variable -> byte_element(offset,bytes) e$ = refer(e$, sourcetyp, 1) 'get the variable's formal name - If Error_Happened Then EXIT Function - size = (sourcetyp And 511) \ 8 'calculate its size in bytes + IF Error_Happened THEN EXIT FUNCTION + size = (sourcetyp AND 511) \ 8 'calculate its size in bytes t = Type2MemTypeValue(sourcetyp) evaluatetotyp$ = "(ptrszint)" + e$ + "," + str2(size) + "," + str2(t) + "," + str2(size) + ",sf_mem_lock" - EXIT Function + EXIT FUNCTION - End If '-7 _MEM structure helper + END IF '-7 _MEM structure helper - If targettyp = -2 Then '? -> byte_element(offset,max possible bytes) + IF targettyp = -2 THEN '? -> byte_element(offset,max possible bytes) method2useall: ' print "CI: eval2typ detected target type of -2 for ["+a2$+"] evaluated as ["+e$+"]":sleep 1 - If (sourcetyp And ISREFERENCE) = 0 Then Give_Error "Expected variable name/array element": EXIT Function - If (sourcetyp And ISOFFSETINBITS) Then Give_Error "Variable/element cannot be BIT aligned": EXIT Function + IF (sourcetyp AND ISREFERENCE) = 0 THEN Give_Error "Expected variable name/array element": EXIT FUNCTION + IF (sourcetyp AND ISOFFSETINBITS) THEN Give_Error "Variable/element cannot be BIT aligned": EXIT FUNCTION 'User Defined Type -> byte_element(offset,bytes) - If (sourcetyp And ISUDT) Then + IF (sourcetyp AND ISUDT) THEN ' print "CI: -2 type from a UDT":sleep 1 - idnumber = Val(e$) - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i) - u = Val(e$) 'closest parent - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i) - E = Val(e$) - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i) + idnumber = VAL(e$) + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i) + u = VAL(e$) 'closest parent + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i) + E = VAL(e$) + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i) o$ = e$ getid idnumber - If Error_Happened Then EXIT Function - n$ = "UDT_" + RTrim$(id.n): If id.arraytype Then n$ = "ARRAY_" + n$ + "[0]" + IF Error_Happened THEN EXIT FUNCTION + n$ = "UDT_" + RTRIM$(id.n): IF id.arraytype THEN n$ = "ARRAY_" + n$ + "[0]" method2usealludt: bytes$ = variablesize$(-1) + "-(" + o$ + ")" - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION dst$ = "(((char*)" + scope$ + n$ + ")+(" + o$ + "))" evaluatetotyp$ = "byte_element((uint64)" + dst$ + "," + bytes$ + "," + NewByteElement$ + ")" - If targettyp = -5 Then evaluatetotyp$ = bytes$ - If targettyp = -6 Then evaluatetotyp$ = dst$ - EXIT Function - End If + IF targettyp = -5 THEN evaluatetotyp$ = bytes$ + IF targettyp = -6 THEN evaluatetotyp$ = dst$ + EXIT FUNCTION + END IF 'Array reference -> byte_element(offset,bytes) - If (sourcetyp And ISARRAY) Then + IF (sourcetyp AND ISARRAY) THEN 'array of variable length strings (special case, can only refer to single element) - If sourcetyp And ISSTRING Then - If (sourcetyp And ISFIXEDLENGTH) = 0 Then + IF sourcetyp AND ISSTRING THEN + IF (sourcetyp AND ISFIXEDLENGTH) = 0 THEN e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION evaluatetotyp$ = "byte_element((uint64)" + e$ + "->chr," + e$ + "->len," + NewByteElement$ + ")" - If targettyp = -5 Then evaluatetotyp$ = e$ + "->len" - If targettyp = -6 Then evaluatetotyp$ = e$ + "->chr" - EXIT Function - End If - End If - idnumber = Val(e$) + IF targettyp = -5 THEN evaluatetotyp$ = e$ + "->len" + IF targettyp = -6 THEN evaluatetotyp$ = e$ + "->chr" + EXIT FUNCTION + END IF + END IF + idnumber = VAL(e$) getid idnumber - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION tsize = id.tsize 'used later to determine element size of fixed length strings 'note: array references consist of idnumber|unmultiplied-element-index - index$ = Right$(e$, Len(e$) - InStr(e$, sp3)) 'get element index + index$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) 'get element index bytes$ = variablesize$(-1) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION e$ = "(&(" + e$ + "))" ' print "CI: array: e$["+e$+"], bytes$["+bytes$+"]":sleep 1 'calculate size of elements - If sourcetyp And ISSTRING Then + IF sourcetyp AND ISSTRING THEN bytes = tsize - Else - bytes = (sourcetyp And 511) \ 8 - End If + ELSE + bytes = (sourcetyp AND 511) \ 8 + END IF bytes$ = bytes$ + "-(" + str2(bytes) + "*(" + index$ + "))" evaluatetotyp$ = "byte_element((uint64)" + e$ + "," + bytes$ + "," + NewByteElement$ + ")" - If targettyp = -5 Then evaluatetotyp$ = bytes$ - If targettyp = -6 Then evaluatetotyp$ = e$ + IF targettyp = -5 THEN evaluatetotyp$ = bytes$ + IF targettyp = -6 THEN evaluatetotyp$ = e$ ' print "CI: array ->["+"byte_element((uint64)" + e$ + "," + bytes$+ ","+NewByteElement$+")"+"]":sleep 1 - EXIT Function - End If + EXIT FUNCTION + END IF 'String -> byte_element(offset,bytes) - If sourcetyp And ISSTRING Then - If sourcetyp And ISFIXEDLENGTH Then - idnumber = Val(e$) + IF sourcetyp AND ISSTRING THEN + IF sourcetyp AND ISFIXEDLENGTH THEN + idnumber = VAL(e$) getid idnumber - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION bytes$ = str2(id.tsize) e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function - Else + IF Error_Happened THEN EXIT FUNCTION + ELSE e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION bytes$ = e$ + "->len" - End If + END IF evaluatetotyp$ = "byte_element((uint64)" + e$ + "->chr," + bytes$ + "," + NewByteElement$ + ")" - If targettyp = -5 Then evaluatetotyp$ = bytes$ - If targettyp = -6 Then evaluatetotyp$ = e$ + "->chr" - EXIT Function - End If + IF targettyp = -5 THEN evaluatetotyp$ = bytes$ + IF targettyp = -6 THEN evaluatetotyp$ = e$ + "->chr" + EXIT FUNCTION + END IF 'Standard variable -> byte_element(offset,bytes) e$ = refer(e$, sourcetyp, 1) 'get the variable's formal name - If Error_Happened Then EXIT Function - size = (sourcetyp And 511) \ 8 'calculate its size in bytes + IF Error_Happened THEN EXIT FUNCTION + size = (sourcetyp AND 511) \ 8 'calculate its size in bytes evaluatetotyp$ = "byte_element((uint64)" + e$ + "," + str2(size) + "," + NewByteElement$ + ")" - If targettyp = -5 Then evaluatetotyp$ = str2(size) - If targettyp = -6 Then evaluatetotyp$ = e$ - EXIT Function + IF targettyp = -5 THEN evaluatetotyp$ = str2(size) + IF targettyp = -6 THEN evaluatetotyp$ = e$ + EXIT FUNCTION - End If '-2 byte_element(offset,bytes) + END IF '-2 byte_element(offset,bytes) 'string? - If (sourcetyp And ISSTRING) <> (targettyp And ISSTRING) Then - Give_Error "Illegal string-number conversion": EXIT Function - End If + IF (sourcetyp AND ISSTRING) <> (targettyp AND ISSTRING) THEN + Give_Error "Illegal string-number conversion": EXIT FUNCTION + END IF - If (sourcetyp And ISSTRING) Then + IF (sourcetyp AND ISSTRING) THEN evaluatetotyp$ = e$ - If (sourcetyp And ISREFERENCE) Then + IF (sourcetyp AND ISREFERENCE) THEN evaluatetotyp$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function - End If - EXIT Function - End If + IF Error_Happened THEN EXIT FUNCTION + END IF + EXIT FUNCTION + END IF 'pointer required? - If (targettyp And ISPOINTER) Then - Give_Error "evaluatetotyp received a request for a pointer! (as yet unsupported)": EXIT Function + IF (targettyp AND ISPOINTER) THEN + Give_Error "evaluatetotyp received a request for a pointer! (as yet unsupported)": EXIT FUNCTION '... - Give_Error "Invalid pointer": EXIT Function - End If + Give_Error "Invalid pointer": EXIT FUNCTION + END IF 'change to "non-pointer" value - If (sourcetyp And ISREFERENCE) Then + IF (sourcetyp AND ISREFERENCE) THEN e$ = refer(e$, sourcetyp, 0) - If Error_Happened Then EXIT Function - End If + IF Error_Happened THEN EXIT FUNCTION + END IF 'check if successful - If (sourcetyp And ISPOINTER) Then - Give_Error "evaluatetotyp couldn't convert pointer type!": EXIT Function - End If + IF (sourcetyp AND ISPOINTER) THEN + Give_Error "evaluatetotyp couldn't convert pointer type!": EXIT FUNCTION + END IF 'round to integer if required - If (sourcetyp And ISFLOAT) Then - If (targettyp And ISFLOAT) = 0 Then - bits = targettyp And 511 + IF (sourcetyp AND ISFLOAT) THEN + IF (targettyp AND ISFLOAT) = 0 THEN + bits = targettyp AND 511 '**32 rounding fix - If bits <= 16 Then e$ = "qbr_float_to_long(" + e$ + ")" - If bits > 16 And bits < 32 Then e$ = "qbr_double_to_long(" + e$ + ")" - If bits >= 32 Then e$ = "qbr(" + e$ + ")" - End If - End If + IF bits <= 16 THEN e$ = "qbr_float_to_long(" + e$ + ")" + IF bits > 16 AND bits < 32 THEN e$ = "qbr_double_to_long(" + e$ + ")" + IF bits >= 32 THEN e$ = "qbr(" + e$ + ")" + END IF + END IF evaluatetotyp$ = e$ -End Function +END FUNCTION -Function findid& (n2$) - n$ = UCase$(n2$) 'case insensitive +FUNCTION findid& (n2$) + n$ = UCASE$(n2$) 'case insensitive 'return all strings as 'not found' - If Asc(n$) = 34 Then GoTo noid + IF ASC(n$) = 34 THEN GOTO noid 'if findidsecondarg was set, it will be used for finding the name of a sub (not a func or variable) secondarg$ = findidsecondarg: findidsecondarg = "" 'if findanotherid was set, findid will continue scan from last index, otherwise, it will begin a new search findanother = findanotherid: findanotherid = 0 - If findanother <> 0 And findidinternal <> 2 Then Give_Error "FINDID() ERROR: Invalid repeat search requested!": EXIT Function 'cannot continue search, no more indexes left! - If Error_Happened Then EXIT Function + IF findanother <> 0 AND findidinternal <> 2 THEN Give_Error "FINDID() ERROR: Invalid repeat search requested!": EXIT FUNCTION 'cannot continue search, no more indexes left! + IF Error_Happened THEN EXIT FUNCTION '(the above should never happen) findid& = 2 '2=not finished searching all indexes 'seperate symbol from name (if a symbol has been added), this is the only way symbols can be passed to findid i = 0 - i = InStr(n$, "~"): If i Then GoTo gotsc - i = InStr(n$, "`"): If i Then GoTo gotsc - i = InStr(n$, "%"): If i Then GoTo gotsc - i = InStr(n$, "&"): If i Then GoTo gotsc - i = InStr(n$, "!"): If i Then GoTo gotsc - i = InStr(n$, "#"): If i Then GoTo gotsc - i = InStr(n$, "$"): If i Then GoTo gotsc + i = INSTR(n$, "~"): IF i THEN GOTO gotsc + i = INSTR(n$, "`"): IF i THEN GOTO gotsc + i = INSTR(n$, "%"): IF i THEN GOTO gotsc + i = INSTR(n$, "&"): IF i THEN GOTO gotsc + i = INSTR(n$, "!"): IF i THEN GOTO gotsc + i = INSTR(n$, "#"): IF i THEN GOTO gotsc + i = INSTR(n$, "$"): IF i THEN GOTO gotsc gotsc: - If i Then - sc$ = Right$(n$, Len(n$) - i + 1): n$ = Left$(n$, i - 1) - If sc$ = "`" Or sc$ = "~`" Then sc$ = sc$ + "1" 'clarify abbreviated 1 bit reference - Else + IF i THEN + sc$ = RIGHT$(n$, LEN(n$) - i + 1): n$ = LEFT$(n$, i - 1) + IF sc$ = "`" OR sc$ = "~`" THEN sc$ = sc$ + "1" 'clarify abbreviated 1 bit reference + ELSE ''' 'no symbol passed, so check what symbol could be assumed under the current DEF... ''' v = ASC(n$): IF v = 95 THEN v = 27 ELSE v = v - 64 ''' IF v >= 1 AND v <= 27 THEN 'safeguard against n$ not being a standard name ''' couldhavesc$ = defineextaz(v) ''' IF couldhavesc$ = "`" OR couldhavesc$ = "~`" THEN couldhavesc$ = couldhavesc$ + "1" 'clarify abbreviated 1 bit reference ''' END IF 'safeguard - End If + END IF 'optomizations for later comparisons - insf$ = subfunc + Space$(256 - Len(subfunc)) - secondarg$ = secondarg$ + Space$(256 - Len(secondarg$)) - If Len(sc$) Then scpassed = 1: sc$ = sc$ + Space$(8 - Len(sc$)) Else scpassed = 0 + insf$ = subfunc + SPACE$(256 - LEN(subfunc)) + secondarg$ = secondarg$ + SPACE$(256 - LEN(secondarg$)) + IF LEN(sc$) THEN scpassed = 1: sc$ = sc$ + SPACE$(8 - LEN(sc$)) ELSE scpassed = 0 '''IF LEN(couldhavesc$) THEN couldhavesc$ = couldhavesc$ + SPACE$(8 - LEN(couldhavesc$)): couldhavescpassed = 1 ELSE couldhavescpassed = 0 - If Len(n$) < 256 Then n$ = n$ + Space$(256 - Len(n$)) + IF LEN(n$) < 256 THEN n$ = n$ + SPACE$(256 - LEN(n$)) 'FUNCTION HashFind (a$, searchflags, resultflags, resultreference) '(0,1,2)z=hashfind[rev]("RUMI",Hashflag_label,resflag,resref) @@ -17959,15 +17959,15 @@ Function findid& (n2$) '2=found, more items still to scan 'NEW HASH SYSTEM - n$ = RTrim$(n$) - If findanother Then + n$ = RTRIM$(n$) + IF findanother THEN hashretry: z = HashFindCont(unrequired, i) - Else + ELSE z = HashFindRev(n$, 1, unrequired, i) - End If + END IF findidinternal = z - If z = 0 Then GoTo noid + IF z = 0 THEN GOTO noid findid = z @@ -17982,36 +17982,36 @@ Function findid& (n2$) '' IF ids(i).n = n$ THEN 'same name? 'in scope? - If ids(i).subfunc = 0 And ids(i).share = 0 Then 'scope check required (not a shared variable or the name of a sub/function) - If ids(i).insubfunc <> insf$ Then GoTo findidnomatch - End If + IF ids(i).subfunc = 0 AND ids(i).share = 0 THEN 'scope check required (not a shared variable or the name of a sub/function) + IF ids(i).insubfunc <> insf$ THEN GOTO findidnomatch + END IF 'some subs require a second argument (eg. PUT #, DEF SEG, etc.) - If ids(i).subfunc = 2 Then - If Asc(ids(i).secondargmustbe) <> 32 Then 'exists? - If RTrim$(secondarg$) = UCase$(RTrim$(ids(i).secondargmustbe)) Then - ElseIf qb64prefix_set = 1 And Left$(ids(i).secondargmustbe, 1) = "_" And Left$(secondarg$, 1) <> "_" And RTrim$(secondarg$) = UCase$(Mid$(RTrim$(ids(i).secondargmustbe), 2)) Then - Else - GoTo findidnomatch - End If - End If - If Asc(ids(i).secondargcantbe) <> 32 Then 'exists? - If RTrim$(secondarg$) <> UCase$(RTrim$(ids(i).secondargcantbe)) Then - ElseIf qb64prefix_set = 1 And Left$(ids(i).secondargcantbe, 1) = "_" And Left$(secondarg$, 1) <> "_" And RTrim$(secondarg$) <> UCase$(Mid$(RTrim$(ids(i).secondargcantbe), 2)) Then - Else - GoTo findidnomatch - End If - End If - End If 'second sub argument possible + IF ids(i).subfunc = 2 THEN + IF ASC(ids(i).secondargmustbe) <> 32 THEN 'exists? + IF RTRIM$(secondarg$) = UCASE$(RTRIM$(ids(i).secondargmustbe)) THEN + ELSEIF qb64prefix_set = 1 AND LEFT$(ids(i).secondargmustbe, 1) = "_" AND LEFT$(secondarg$, 1) <> "_" AND RTRIM$(secondarg$) = UCASE$(MID$(RTRIM$(ids(i).secondargmustbe), 2)) THEN + ELSE + GOTO findidnomatch + END IF + END IF + IF ASC(ids(i).secondargcantbe) <> 32 THEN 'exists? + IF RTRIM$(secondarg$) <> UCASE$(RTRIM$(ids(i).secondargcantbe)) THEN + ELSEIF qb64prefix_set = 1 AND LEFT$(ids(i).secondargcantbe, 1) = "_" AND LEFT$(secondarg$, 1) <> "_" AND RTRIM$(secondarg$) <> UCASE$(MID$(RTRIM$(ids(i).secondargcantbe), 2)) THEN + ELSE + GOTO findidnomatch + END IF + END IF + END IF 'second sub argument possible 'must have symbol? 'typically for variables defined automatically or by a symbol and not the full type name imusthave = CVI(ids(i).musthave) 'speed up checks of first 2 characters - amusthave = imusthave And 255 'speed up checks of first character - If amusthave <> 32 Then - If scpassed Then - If sc$ = ids(i).musthave Then GoTo findidok - End If + amusthave = imusthave AND 255 'speed up checks of first character + IF amusthave <> 32 THEN + IF scpassed THEN + IF sc$ = ids(i).musthave THEN GOTO findidok + END IF ''' IF couldhavescpassed THEN ''' IF couldhavesc$ = ids(i).musthave THEN GOTO findidok ''' END IF @@ -18021,27 +18021,27 @@ Function findid& (n2$) 'note: symbol defined fixed length strings cannot be referred to by $ without an extension 'note: sc$ and couldhavesc$ are already changed from ` to `1 to match stored musthave - GoTo findidnomatch - End If + GOTO findidnomatch + END IF 'may have symbol? 'typically for variables formally dim'd 'note: couldhavesc$ needn't be considered for mayhave checks - If scpassed Then 'symbol was passed, so it must match the mayhave symbol + IF scpassed THEN 'symbol was passed, so it must match the mayhave symbol imayhave = CVI(ids(i).mayhave) 'speed up checks of first 2 characters - amayhave = imayhave And 255 'speed up checks of first character - If amayhave = 32 Then GoTo findidnomatch 'it cannot have the symbol passed (nb. musthave symbols have already been ok'd) + amayhave = imayhave AND 255 'speed up checks of first character + IF amayhave = 32 THEN GOTO findidnomatch 'it cannot have the symbol passed (nb. musthave symbols have already been ok'd) 'note: variable length strings are not a problem here, as they can only have one possible extension - If amayhave = 36 Then '"$" - If imayhave <> 8228 Then '"$ " + IF amayhave = 36 THEN '"$" + IF imayhave <> 8228 THEN '"$ " 'it is a fixed length string - If CVI(sc$) = 8228 Then GoTo findidok 'allow myvariable$ to become myvariable$10 + IF CVI(sc$) = 8228 THEN GOTO findidok 'allow myvariable$ to become myvariable$10 'allow later comparison to verify if extension is correct - End If - End If - If sc$ <> ids(i).mayhave Then GoTo findidnomatch - End If 'scpassed + END IF + END IF + IF sc$ <> ids(i).mayhave THEN GOTO findidnomatch + END IF 'scpassed 'return id findidok: @@ -18049,156 +18049,156 @@ Function findid& (n2$) id = ids(i) t = id.t - If t = 0 Then + IF t = 0 THEN t = id.arraytype - If t And ISUDT Then - manageVariableList "", scope$ + "ARRAY_UDT_" + RTrim$(id.n), 1 - Else + IF t AND ISUDT THEN + manageVariableList "", scope$ + "ARRAY_UDT_" + RTRIM$(id.n), 1 + ELSE n$ = id2shorttypename$ - If Left$(n$, 1) = "_" Then - manageVariableList "", scope$ + "ARRAY" + n$ + "_" + RTrim$(id.n), 2 - Else - manageVariableList "", scope$ + "ARRAY_" + n$ + "_" + RTrim$(id.n), 3 - End If - End If - Else - If t And ISUDT Then - manageVariableList "", scope$ + "UDT_" + RTrim$(id.n), 4 - Else + IF LEFT$(n$, 1) = "_" THEN + manageVariableList "", scope$ + "ARRAY" + n$ + "_" + RTRIM$(id.n), 2 + ELSE + manageVariableList "", scope$ + "ARRAY_" + n$ + "_" + RTRIM$(id.n), 3 + END IF + END IF + ELSE + IF t AND ISUDT THEN + manageVariableList "", scope$ + "UDT_" + RTRIM$(id.n), 4 + ELSE n$ = id2shorttypename$ - If Left$(n$, 1) = "_" Then - manageVariableList "", scope$ + Mid$(n$, 2) + "_" + RTrim$(id.n), 5 - Else - manageVariableList "", scope$ + n$ + "_" + RTrim$(id.n), 6 - End If - End If - End If + IF LEFT$(n$, 1) = "_" THEN + manageVariableList "", scope$ + MID$(n$, 2) + "_" + RTRIM$(id.n), 5 + ELSE + manageVariableList "", scope$ + n$ + "_" + RTRIM$(id.n), 6 + END IF + END IF + END IF currentid = i - EXIT Function + EXIT FUNCTION 'END IF 'same name findidnomatch: 'NEXT - If z = 2 Then GoTo hashretry + IF z = 2 THEN GOTO hashretry 'totally unclassifiable noid: findid& = 0 currentid = -1 -End Function +END FUNCTION -Function FindArray (secure$) +FUNCTION FindArray (secure$) FindArray = -1 n$ = secure$ - If Debug Then Print #9, "func findarray:in:" + n$ - If alphanumeric(Asc(n$)) = 0 Then FindArray = 0: EXIT Function + IF Debug THEN PRINT #9, "func findarray:in:" + n$ + IF alphanumeric(ASC(n$)) = 0 THEN FindArray = 0: EXIT FUNCTION 'establish whether n$ includes an extension - i = InStr(n$, "~"): If i Then sc$ = Right$(n$, Len(n$) - i + 1): n$ = Left$(n$, i - 1): GoTo gotsc2 - i = InStr(n$, "`"): If i Then sc$ = Right$(n$, Len(n$) - i + 1): n$ = Left$(n$, i - 1): GoTo gotsc2 - i = InStr(n$, "%"): If i Then sc$ = Right$(n$, Len(n$) - i + 1): n$ = Left$(n$, i - 1): GoTo gotsc2 - i = InStr(n$, "&"): If i Then sc$ = Right$(n$, Len(n$) - i + 1): n$ = Left$(n$, i - 1): GoTo gotsc2 - i = InStr(n$, "!"): If i Then sc$ = Right$(n$, Len(n$) - i + 1): n$ = Left$(n$, i - 1): GoTo gotsc2 - i = InStr(n$, "#"): If i Then sc$ = Right$(n$, Len(n$) - i + 1): n$ = Left$(n$, i - 1): GoTo gotsc2 - i = InStr(n$, "$"): If i Then sc$ = Right$(n$, Len(n$) - i + 1): n$ = Left$(n$, i - 1): GoTo gotsc2 + i = INSTR(n$, "~"): IF i THEN sc$ = RIGHT$(n$, LEN(n$) - i + 1): n$ = LEFT$(n$, i - 1): GOTO gotsc2 + i = INSTR(n$, "`"): IF i THEN sc$ = RIGHT$(n$, LEN(n$) - i + 1): n$ = LEFT$(n$, i - 1): GOTO gotsc2 + i = INSTR(n$, "%"): IF i THEN sc$ = RIGHT$(n$, LEN(n$) - i + 1): n$ = LEFT$(n$, i - 1): GOTO gotsc2 + i = INSTR(n$, "&"): IF i THEN sc$ = RIGHT$(n$, LEN(n$) - i + 1): n$ = LEFT$(n$, i - 1): GOTO gotsc2 + i = INSTR(n$, "!"): IF i THEN sc$ = RIGHT$(n$, LEN(n$) - i + 1): n$ = LEFT$(n$, i - 1): GOTO gotsc2 + i = INSTR(n$, "#"): IF i THEN sc$ = RIGHT$(n$, LEN(n$) - i + 1): n$ = LEFT$(n$, i - 1): GOTO gotsc2 + i = INSTR(n$, "$"): IF i THEN sc$ = RIGHT$(n$, LEN(n$) - i + 1): n$ = LEFT$(n$, i - 1): GOTO gotsc2 gotsc2: n2$ = n$ + sc$ - If sc$ <> "" Then + IF sc$ <> "" THEN 'has an extension 'note! findid must unambiguify ` to `5 or $ to $10 where applicable - try = findid(n2$): If Error_Happened Then EXIT Function - Do While try - If id.arraytype Then - EXIT Function - End If - If try = 2 Then findanotherid = 1: try = findid(n2$) Else try = 0 - If Error_Happened Then EXIT Function - Loop + try = findid(n2$): IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF id.arraytype THEN + EXIT FUNCTION + END IF + IF try = 2 THEN findanotherid = 1: try = findid(n2$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP - Else + ELSE 'no extension '1. pass as is, without any extension (local) - try = findid(n2$): If Error_Happened Then EXIT Function - Do While try - If id.arraytype Then - If subfuncn = 0 Then EXIT Function - If id.insubfuncn = subfuncn Then EXIT Function - End If - If try = 2 Then findanotherid = 1: try = findid(n2$) Else try = 0 - If Error_Happened Then EXIT Function - Loop + try = findid(n2$): IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF id.arraytype THEN + IF subfuncn = 0 THEN EXIT FUNCTION + IF id.insubfuncn = subfuncn THEN EXIT FUNCTION + END IF + IF try = 2 THEN findanotherid = 1: try = findid(n2$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP '2. that failed, so apply the _define'd extension and pass (local) - a = Asc(UCase$(n$)): If a = 95 Then a = 91 + a = ASC(UCASE$(n$)): IF a = 95 THEN a = 91 a = a - 64 'so A=1, Z=27 and _=28 n2$ = n$ + defineextaz(a) - try = findid(n2$): If Error_Happened Then EXIT Function - Do While try - If id.arraytype Then - If subfuncn = 0 Then EXIT Function - If id.insubfuncn = subfuncn Then EXIT Function - EXIT Function - End If - If try = 2 Then findanotherid = 1: try = findid(n2$) Else try = 0 - If Error_Happened Then EXIT Function - Loop + try = findid(n2$): IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF id.arraytype THEN + IF subfuncn = 0 THEN EXIT FUNCTION + IF id.insubfuncn = subfuncn THEN EXIT FUNCTION + EXIT FUNCTION + END IF + IF try = 2 THEN findanotherid = 1: try = findid(n2$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP '3. pass as is, without any extension (global) n2$ = n$ - try = findid(n2$): If Error_Happened Then EXIT Function - Do While try - If id.arraytype Then - EXIT Function - End If - If try = 2 Then findanotherid = 1: try = findid(n2$) Else try = 0 - If Error_Happened Then EXIT Function - Loop + try = findid(n2$): IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF id.arraytype THEN + EXIT FUNCTION + END IF + IF try = 2 THEN findanotherid = 1: try = findid(n2$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP '4. that failed, so apply the _define'd extension and pass (global) - a = Asc(UCase$(n$)): If a = 95 Then a = 91 + a = ASC(UCASE$(n$)): IF a = 95 THEN a = 91 a = a - 64 'so A=1, Z=27 and _=28 n2$ = n$ + defineextaz(a) - try = findid(n2$): If Error_Happened Then EXIT Function - Do While try - If id.arraytype Then - EXIT Function - End If - If try = 2 Then findanotherid = 1: try = findid(n2$) Else try = 0 - If Error_Happened Then EXIT Function - Loop + try = findid(n2$): IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF id.arraytype THEN + EXIT FUNCTION + END IF + IF try = 2 THEN findanotherid = 1: try = findid(n2$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP - End If + END IF FindArray = 0 -End Function +END FUNCTION -Function fixoperationorder$ (savea$) +FUNCTION fixoperationorder$ (savea$) a$ = savea$ - If Debug Then Print #9, "fixoperationorder:in:" + a$ + IF Debug THEN PRINT #9, "fixoperationorder:in:" + a$ fooindwel = fooindwel + 1 n = numelements(a$) 'n is maintained throughout function - If fooindwel = 1 Then 'actions to take on initial call only + IF fooindwel = 1 THEN 'actions to take on initial call only 'Quick check for duplicate binary operations - uppercasea$ = UCase$(a$) 'capitalize it once to reduce calls to ucase over and over - For i = 1 To n - 1 + uppercasea$ = UCASE$(a$) 'capitalize it once to reduce calls to ucase over and over + FOR i = 1 TO n - 1 temp1$ = getelement(uppercasea$, i) temp2$ = getelement(uppercasea$, i + 1) - If temp1$ = "AND" And temp2$ = "AND" Then Give_Error "Error: AND AND": EXIT Function - If temp1$ = "OR" And temp2$ = "OR" Then Give_Error "Error: OR OR": EXIT Function - If temp1$ = "XOR" And temp2$ = "XOR" Then Give_Error "Error: XOR XOR": EXIT Function - If temp1$ = "IMP" And temp2$ = "IMP" Then Give_Error "Error: IMP IMP": EXIT Function - If temp1$ = "EQV" And temp2$ = "EQV" Then Give_Error "Error: EQV EQV": EXIT Function - Next + IF temp1$ = "AND" AND temp2$ = "AND" THEN Give_Error "Error: AND AND": EXIT FUNCTION + IF temp1$ = "OR" AND temp2$ = "OR" THEN Give_Error "Error: OR OR": EXIT FUNCTION + IF temp1$ = "XOR" AND temp2$ = "XOR" THEN Give_Error "Error: XOR XOR": EXIT FUNCTION + IF temp1$ = "IMP" AND temp2$ = "IMP" THEN Give_Error "Error: IMP IMP": EXIT FUNCTION + IF temp1$ = "EQV" AND temp2$ = "EQV" THEN Give_Error "Error: EQV EQV": EXIT FUNCTION + NEXT '----------------A. 'Quick' mismatched brackets check---------------- b = 0 @@ -18207,24 +18207,24 @@ Function fixoperationorder$ (savea$) b2$ = sp + ")" + sp i = 1 findmmb: - i1 = InStr(i, a2$, b1$) - i2 = InStr(i, a2$, b2$) + i1 = INSTR(i, a2$, b1$) + i2 = INSTR(i, a2$, b2$) i3 = i1 - If i2 Then - If i1 = 0 Then + IF i2 THEN + IF i1 = 0 THEN i3 = i2 - Else - If i2 < i1 Then i3 = i2 - End If - End If - If i3 Then - If i3 = i1 Then b = b + 1 - If i3 = i2 Then b = b - 1 + ELSE + IF i2 < i1 THEN i3 = i2 + END IF + END IF + IF i3 THEN + IF i3 = i1 THEN b = b + 1 + IF i3 = i2 THEN b = b - 1 i = i3 + 2 - If b < 0 Then Give_Error "Missing (": EXIT Function - GoTo findmmb - End If - If b > 0 Then Give_Error "Missing )": EXIT Function + IF b < 0 THEN Give_Error "Missing (": EXIT FUNCTION + GOTO findmmb + END IF + IF b > 0 THEN Give_Error "Missing )": EXIT FUNCTION '----------------B. 'Quick' correction of over-use of +,- ---------------- 'note: the results of this change are beneficial to foolayout @@ -18232,43 +18232,43 @@ Function fixoperationorder$ (savea$) 'rule 1: change ++ to + rule1: - i = InStr(a2$, sp + "+" + sp + "+" + sp) - If i Then - a2$ = Left$(a2$, i + 2) + Right$(a2$, Len(a2$) - i - 4) - a$ = Mid$(a2$, 2, Len(a2$) - 2) + i = INSTR(a2$, sp + "+" + sp + "+" + sp) + IF i THEN + a2$ = LEFT$(a2$, i + 2) + RIGHT$(a2$, LEN(a2$) - i - 4) + a$ = MID$(a2$, 2, LEN(a2$) - 2) n = n - 1 - If Debug Then Print #9, "fixoperationorder:+/-:" + a$ - GoTo rule1 - End If + IF Debug THEN PRINT #9, "fixoperationorder:+/-:" + a$ + GOTO rule1 + END IF 'rule 2: change -+ to - rule2: - i = InStr(a2$, sp + "-" + sp + "+" + sp) - If i Then - a2$ = Left$(a2$, i + 2) + Right$(a2$, Len(a2$) - i - 4) - a$ = Mid$(a2$, 2, Len(a2$) - 2) + i = INSTR(a2$, sp + "-" + sp + "+" + sp) + IF i THEN + a2$ = LEFT$(a2$, i + 2) + RIGHT$(a2$, LEN(a2$) - i - 4) + a$ = MID$(a2$, 2, LEN(a2$) - 2) n = n - 1 - If Debug Then Print #9, "fixoperationorder:+/-:" + a$ - GoTo rule2 - End If + IF Debug THEN PRINT #9, "fixoperationorder:+/-:" + a$ + GOTO rule2 + END IF 'rule 3: change anyoperator-- to anyoperator rule3: - If InStr(a2$, sp + "-" + sp + "-" + sp) Then - For i = 1 To n - 2 - If isoperator(getelement(a$, i)) Then - If getelement(a$, i + 1) = "-" Then - If getelement(a$, i + 2) = "-" Then + IF INSTR(a2$, sp + "-" + sp + "-" + sp) THEN + FOR i = 1 TO n - 2 + IF isoperator(getelement(a$, i)) THEN + IF getelement(a$, i + 1) = "-" THEN + IF getelement(a$, i + 2) = "-" THEN removeelements a$, i + 1, i + 2, 0 a2$ = sp + a$ + sp n = n - 2 - If Debug Then Print #9, "fixoperationorder:+/-:" + a$ - GoTo rule3 - End If - End If - End If - Next - End If 'rule 3 + IF Debug THEN PRINT #9, "fixoperationorder:+/-:" + a$ + GOTO rule3 + END IF + END IF + END IF + NEXT + END IF 'rule 3 @@ -18287,103 +18287,103 @@ Function fixoperationorder$ (savea$) 'before: anyoperator,-,number,^ 'after: anyoperator,CHR$(241),number,^ - For i = 1 To n - 1 - If i > n - 1 Then Exit For 'n changes, so manually exit if required + FOR i = 1 TO n - 1 + IF i > n - 1 THEN EXIT FOR 'n changes, so manually exit if required - If Asc(getelement(a$, i)) = 45 Then '- + IF ASC(getelement(a$, i)) = 45 THEN '- neg = 0 - If i = 1 Then + IF i = 1 THEN neg = 1 - Else + ELSE a2$ = getelement(a$, i - 1) - c = Asc(a2$) - If c = 40 Or c = 44 Then '(, + c = ASC(a2$) + IF c = 40 OR c = 44 THEN '(, neg = 1 - Else - If isoperator(a2$) Then neg = 1 - End If '() - End If 'i=1 - If neg = 1 Then + ELSE + IF isoperator(a2$) THEN neg = 1 + END IF '() + END IF 'i=1 + IF neg = 1 THEN a2$ = getelement(a$, i + 1) - c = Asc(a2$) - If c >= 48 And c <= 57 Then - c2 = 0: If i < n - 1 Then c2 = Asc(getelement(a$, i + 2)) - If c2 <> 94 Then 'not ^ + c = ASC(a2$) + IF c >= 48 AND c <= 57 THEN + c2 = 0: IF i < n - 1 THEN c2 = ASC(getelement(a$, i + 2)) + IF c2 <> 94 THEN 'not ^ 'number... - i2 = InStr(a2$, ",") - If i2 And Asc(a2$, i2 + 1) <> 38 Then '&H/&O/&B values don't need the assumed negation - a2$ = "-" + Left$(a2$, i2) + "-" + Right$(a2$, Len(a2$) - i2) - Else + i2 = INSTR(a2$, ",") + IF i2 AND ASC(a2$, i2 + 1) <> 38 THEN '&H/&O/&B values don't need the assumed negation + a2$ = "-" + LEFT$(a2$, i2) + "-" + RIGHT$(a2$, LEN(a2$) - i2) + ELSE a2$ = "-" + a2$ - End If + END IF removeelements a$, i, i + 1, 0 insertelements a$, i - 1, a2$ n = n - 1 - If Debug Then Print #9, "fixoperationorder:negation:" + a$ + IF Debug THEN PRINT #9, "fixoperationorder:negation:" + a$ - GoTo negdone + GOTO negdone - End If - End If + END IF + END IF 'not a number (or for exceptions)... removeelements a$, i, i, 0 - insertelements a$, i - 1, Chr$(241) - If Debug Then Print #9, "fixoperationorder:negation:" + a$ + insertelements a$, i - 1, CHR$(241) + IF Debug THEN PRINT #9, "fixoperationorder:negation:" + a$ - End If 'isoperator - End If '- + END IF 'isoperator + END IF '- negdone: - Next + NEXT - End If 'fooindwel=1 + END IF 'fooindwel=1 '----------------D. 'Quick' Add 'power of' with negation {}bracketing to bottom bracket level---------------- pownegused = 0 powneg: - If InStr(a$, "^" + sp + Chr$(241)) Then 'quick check + IF INSTR(a$, "^" + sp + CHR$(241)) THEN 'quick check b = 0 b1 = 0 - For i = 1 To n + FOR i = 1 TO n a2$ = getelement(a$, i) - c = Asc(a2$) - If c = 40 Then b = b + 1 - If c = 41 Then b = b - 1 - If b = 0 Then - If b1 Then - If isoperator(a2$) Then - If a2$ <> "^" And a2$ <> Chr$(241) Then + c = ASC(a2$) + IF c = 40 THEN b = b + 1 + IF c = 41 THEN b = b - 1 + IF b = 0 THEN + IF b1 THEN + IF isoperator(a2$) THEN + IF a2$ <> "^" AND a2$ <> CHR$(241) THEN insertelements a$, i - 1, "}" insertelements a$, b1, "{" n = n + 2 - If Debug Then Print #9, "fixoperationorder:^-:" + a$ - GoTo powneg + IF Debug THEN PRINT #9, "fixoperationorder:^-:" + a$ + GOTO powneg pownegused = 1 - End If - End If - End If - If c = 94 Then '^ - If getelement$(a$, i + 1) = Chr$(241) Then b1 = i: i = i + 1 - End If - End If 'b=0 - Next i - If b1 Then + END IF + END IF + END IF + IF c = 94 THEN '^ + IF getelement$(a$, i + 1) = CHR$(241) THEN b1 = i: i = i + 1 + END IF + END IF 'b=0 + NEXT i + IF b1 THEN insertelements a$, b1, "{" a$ = a$ + sp + "}" n = n + 2 - If Debug Then Print #9, "fixoperationorder:^-:" + a$ + IF Debug THEN PRINT #9, "fixoperationorder:^-:" + a$ pownegused = 1 - GoTo powneg - End If + GOTO powneg + END IF - End If 'quick check + END IF 'quick check '----------------E. Find lowest & highest operator level in bottom bracket level---------------- @@ -18391,112 +18391,112 @@ Function fixoperationorder$ (savea$) lco = 255 hco = 0 b = 0 - For i = 1 To n + FOR i = 1 TO n a2$ = getelement(a$, i) - c = Asc(a2$) - If c = 40 Or c = 123 Then b = b + 1 - If c = 41 Or c = 125 Then b = b - 1 - If b = 0 Then + c = ASC(a2$) + IF c = 40 OR c = 123 THEN b = b + 1 + IF c = 41 OR c = 125 THEN b = b - 1 + IF b = 0 THEN op = isoperator(a2$) - If op Then - If op < lco Then lco = op - If op > hco Then hco = op - End If - End If - Next + IF op THEN + IF op < lco THEN lco = op + IF op > hco THEN hco = op + END IF + END IF + NEXT '----------------F. Add operator {}bracketting---------------- 'apply bracketting only if required - If hco <> 0 Then 'operators were used - If lco <> hco Then + IF hco <> 0 THEN 'operators were used + IF lco <> hco THEN 'brackets needed - If lco = 6 Then 'NOT exception + IF lco = 6 THEN 'NOT exception 'Step 1: Add brackets as follows ~~~ ( NOT ( ~~~ NOT ~~~ NOT ~~~ NOT ~~~ )) 'Step 2: Recheck line from beginning - If n = 1 Then Give_Error "Expected NOT ...": EXIT Function + IF n = 1 THEN Give_Error "Expected NOT ...": EXIT FUNCTION b = 0 - For i = 1 To n + FOR i = 1 TO n a2$ = getelement(a$, i) - c = Asc(a2$) - If c = 40 Or c = 123 Then b = b + 1 - If c = 41 Or c = 125 Then b = b - 1 - If b = 0 Then - If UCase$(a2$) = "NOT" Then - If i = n Then Give_Error "Expected NOT ...": EXIT Function - If i = 1 Then a$ = "NOT" + sp + "{" + sp + getelements$(a$, 2, n) + sp + "}": n = n + 2: GoTo lco_bracketting_done + c = ASC(a2$) + IF c = 40 OR c = 123 THEN b = b + 1 + IF c = 41 OR c = 125 THEN b = b - 1 + IF b = 0 THEN + IF UCASE$(a2$) = "NOT" THEN + IF i = n THEN Give_Error "Expected NOT ...": EXIT FUNCTION + IF i = 1 THEN a$ = "NOT" + sp + "{" + sp + getelements$(a$, 2, n) + sp + "}": n = n + 2: GOTO lco_bracketting_done a$ = getelements$(a$, 1, i - 1) + sp + "{" + sp + "NOT" + sp + "{" + sp + getelements$(a$, i + 1, n) + sp + "}" + sp + "}" n = n + 4 - GoTo NOT_recheck - End If 'not - End If 'b=0 - Next - End If 'NOT exception + GOTO NOT_recheck + END IF 'not + END IF 'b=0 + NEXT + END IF 'NOT exception n2 = n b = 0 a3$ = "{" n = 1 - For i = 1 To n2 + FOR i = 1 TO n2 a2$ = getelement(a$, i) - c = Asc(a2$) - If c = 40 Or c = 123 Then b = b + 1 - If c = 41 Or c = 125 Then b = b - 1 - If b = 0 Then + c = ASC(a2$) + IF c = 40 OR c = 123 THEN b = b + 1 + IF c = 41 OR c = 125 THEN b = b - 1 + IF b = 0 THEN op = isoperator(a2$) - If op = lco Then - If i = 1 Then + IF op = lco THEN + IF i = 1 THEN a3$ = a2$ + sp + "{" n = 2 - Else - If i = n2 Then Give_Error "Expected variable/value after '" + UCase$(a2$) + "'": EXIT Function + ELSE + IF i = n2 THEN Give_Error "Expected variable/value after '" + UCASE$(a2$) + "'": EXIT FUNCTION a3$ = a3$ + sp + "}" + sp + a2$ + sp + "{" n = n + 3 - End If - GoTo fixop0 - End If + END IF + GOTO fixop0 + END IF - End If 'b=0 + END IF 'b=0 a3$ = a3$ + sp + a2$ n = n + 1 fixop0: - Next + NEXT a3$ = a3$ + sp + "}" n = n + 1 a$ = a3$ lco_bracketting_done: - If Debug Then Print #9, "fixoperationorder:lco bracketing["; lco; ","; hco; "]:" + a$ + IF Debug THEN PRINT #9, "fixoperationorder:lco bracketing["; lco; ","; hco; "]:" + a$ '--------(F)G. Remove indwelling {}bracketting from power-negation-------- - If pownegused Then + IF pownegused THEN b = 0 i = 0 - Do + DO i = i + 1 - If i > n Then Exit Do - c = Asc(getelement(a$, i)) - If c = 41 Or c = 125 Then b = b - 1 - If (c = 123 Or c = 125) And b <> 0 Then + IF i > n THEN EXIT DO + c = ASC(getelement(a$, i)) + IF c = 41 OR c = 125 THEN b = b - 1 + IF (c = 123 OR c = 125) AND b <> 0 THEN removeelements a$, i, i, 0 n = n - 1 i = i - 1 - If Debug Then Print #9, "fixoperationorder:^- {} removed:" + a$ - End If - If c = 40 Or c = 123 Then b = b + 1 - Loop - End If 'pownegused + IF Debug THEN PRINT #9, "fixoperationorder:^- {} removed:" + a$ + END IF + IF c = 40 OR c = 123 THEN b = b + 1 + LOOP + END IF 'pownegused - End If 'lco <> hco - End If 'hco <> 0 + END IF 'lco <> hco + END IF 'hco <> 0 '--------Bracketting of multiple NOT/negation unary operators-------- - If Left$(a$, 4) = Chr$(241) + sp + Chr$(241) + sp Then - a$ = Chr$(241) + sp + "{" + sp + getelements$(a$, 2, n) + sp + "}": n = n + 2 - End If - If UCase$(Left$(a$, 8)) = "NOT" + sp + "NOT" + sp Then + IF LEFT$(a$, 4) = CHR$(241) + sp + CHR$(241) + sp THEN + a$ = CHR$(241) + sp + "{" + sp + getelements$(a$, 2, n) + sp + "}": n = n + 2 + END IF + IF UCASE$(LEFT$(a$, 8)) = "NOT" + sp + "NOT" + sp THEN a$ = "NOT" + sp + "{" + sp + getelements$(a$, 2, n) + sp + "}": n = n + 2 - End If + END IF '----------------H. Identification/conversion of elements within bottom bracket level---------------- 'actions performed: @@ -18508,38 +18508,38 @@ Function fixoperationorder$ (savea$) b = 0 c = 0 lastt = 0: lastti = 0 - For i = 1 To n + FOR i = 1 TO n f2$ = getelement(a$, i) lastc = c - c = Asc(f2$) + c = ASC(f2$) - If c = 40 Or c = 123 Then - If c <> 40 Or b <> 0 Then f2$ = "" 'skip temporary & indwelling brackets + IF c = 40 OR c = 123 THEN + IF c <> 40 OR b <> 0 THEN f2$ = "" 'skip temporary & indwelling brackets b = b + 1 - GoTo classdone - End If - If c = 41 Or c = 125 Then + GOTO classdone + END IF + IF c = 41 OR c = 125 THEN b = b - 1 'check for "("+sp+")" after literal-string, operator, number or nothing - If b = 0 Then 'must be within the lowest level - If c = 41 Then - If lastc = 40 Then - If lastti = i - 2 Or lastti = 0 Then - If lastt >= 0 And lastt <= 3 Then - Give_Error "Unexpected (": EXIT Function - End If - End If - End If - End If - End If + IF b = 0 THEN 'must be within the lowest level + IF c = 41 THEN + IF lastc = 40 THEN + IF lastti = i - 2 OR lastti = 0 THEN + IF lastt >= 0 AND lastt <= 3 THEN + Give_Error "Unexpected (": EXIT FUNCTION + END IF + END IF + END IF + END IF + END IF - If c <> 41 Or b <> 0 Then f2$ = "" 'skip temporary & indwelling brackets - GoTo classdone - End If + IF c <> 41 OR b <> 0 THEN f2$ = "" 'skip temporary & indwelling brackets + GOTO classdone + END IF - If b = 0 Then + IF b = 0 THEN 'classifications/conversions: '1. quoted string ("....) @@ -18550,114 +18550,114 @@ Function fixoperationorder$ (savea$) 'quoted string? - If c = 34 Then '" + IF c = 34 THEN '" lastt = 1: lastti = i 'convert \\ to \ 'convert \??? to CHR$(&O???) x2 = 1 - x = InStr(x2, f2$, "\") - Do While x - c2 = Asc(f2$, x + 1) - If c2 = 92 Then '\\ - f2$ = Left$(f2$, x) + Right$(f2$, Len(f2$) - x - 1) 'remove second \ + x = INSTR(x2, f2$, "\") + DO WHILE x + c2 = ASC(f2$, x + 1) + IF c2 = 92 THEN '\\ + f2$ = LEFT$(f2$, x) + RIGHT$(f2$, LEN(f2$) - x - 1) 'remove second \ x2 = x + 1 - Else + ELSE 'octal triplet value - c3 = (Asc(f2$, x + 3) - 48) + (Asc(f2$, x + 2) - 48) * 8 + (Asc(f2$, x + 1) - 48) * 64 - f2$ = Left$(f2$, x - 1) + Chr$(c3) + Right$(f2$, Len(f2$) - x - 3) + c3 = (ASC(f2$, x + 3) - 48) + (ASC(f2$, x + 2) - 48) * 8 + (ASC(f2$, x + 1) - 48) * 64 + f2$ = LEFT$(f2$, x - 1) + CHR$(c3) + RIGHT$(f2$, LEN(f2$) - x - 3) x2 = x + 1 - End If - x = InStr(x2, f2$, "\") - Loop + END IF + x = INSTR(x2, f2$, "\") + LOOP 'remove ',len' (if it exists) - x = InStr(2, f2$, Chr$(34) + ","): If x Then f2$ = Left$(f2$, x) - GoTo classdone - End If + x = INSTR(2, f2$, CHR$(34) + ","): IF x THEN f2$ = LEFT$(f2$, x) + GOTO classdone + END IF 'number? - If (c >= 48 And c <= 57) Or c = 45 Then + IF (c >= 48 AND c <= 57) OR c = 45 THEN lastt = 2: lastti = i - x = InStr(f2$, ",") - If x Then - removeelements a$, i, i, 0: insertelements a$, i - 1, Left$(f2$, x - 1) - f2$ = Right$(f2$, Len(f2$) - x) - End If + x = INSTR(f2$, ",") + IF x THEN + removeelements a$, i, i, 0: insertelements a$, i - 1, LEFT$(f2$, x - 1) + f2$ = RIGHT$(f2$, LEN(f2$) - x) + END IF - If x = 0 Then - c2 = Asc(f2$, Len(f2$)) - If c2 < 48 Or c2 > 57 Then + IF x = 0 THEN + c2 = ASC(f2$, LEN(f2$)) + IF c2 < 48 OR c2 > 57 THEN x = 1 'extension given - Else - x = InStr(f2$, "`") - End If - End If + ELSE + x = INSTR(f2$, "`") + END IF + END IF 'add appropriate integer symbol if none present - If x = 0 Then + IF x = 0 THEN f3$ = f2$ s$ = "" - If c = 45 Then + IF c = 45 THEN s$ = "&&" - If (f3$ < "-2147483648" And Len(f3$) = 11) Or Len(f3$) < 11 Then s$ = "&" - If (f3$ <= "-32768" And Len(f3$) = 6) Or Len(f3$) < 6 Then s$ = "%" - Else + IF (f3$ < "-2147483648" AND LEN(f3$) = 11) OR LEN(f3$) < 11 THEN s$ = "&" + IF (f3$ <= "-32768" AND LEN(f3$) = 6) OR LEN(f3$) < 6 THEN s$ = "%" + ELSE s$ = "~&&" - If (f3$ <= "9223372036854775807" And Len(f3$) = 19) Or Len(f3$) < 19 Then s$ = "&&" - If (f3$ <= "2147483647" And Len(f3$) = 10) Or Len(f3$) < 10 Then s$ = "&" - If (f3$ <= "32767" And Len(f3$) = 5) Or Len(f3$) < 5 Then s$ = "%" - End If + IF (f3$ <= "9223372036854775807" AND LEN(f3$) = 19) OR LEN(f3$) < 19 THEN s$ = "&&" + IF (f3$ <= "2147483647" AND LEN(f3$) = 10) OR LEN(f3$) < 10 THEN s$ = "&" + IF (f3$ <= "32767" AND LEN(f3$) = 5) OR LEN(f3$) < 5 THEN s$ = "%" + END IF f3$ = f3$ + s$ removeelements a$, i, i, 0: insertelements a$, i - 1, f3$ - End If 'x=0 + END IF 'x=0 - GoTo classdone - End If + GOTO classdone + END IF 'operator? - If isoperator(f2$) Then + IF isoperator(f2$) THEN lastt = 3: lastti = i - If Len(f2$) > 1 Then - If f2$ <> SCase2$(f2$) Then + IF LEN(f2$) > 1 THEN + IF f2$ <> SCase2$(f2$) THEN f2$ = SCase2$(f2$) removeelements a$, i, i, 0 insertelements a$, i - 1, f2$ - End If - End If + END IF + END IF 'append negation - If f2$ = Chr$(241) Then f$ = f$ + sp + "-": GoTo classdone_special - GoTo classdone - End If + IF f2$ = CHR$(241) THEN f$ = f$ + sp + "-": GOTO classdone_special + GOTO classdone + END IF - If alphanumeric(c) Then + IF alphanumeric(c) THEN lastt = 4: lastti = i - If i < n Then nextc = Asc(getelement(a$, i + 1)) Else nextc = 0 + IF i < n THEN nextc = ASC(getelement(a$, i + 1)) ELSE nextc = 0 ' a constant? - If nextc <> 40 Then '<>"(" (not an array) - If lastc <> 46 Then '<>"." (not an element of a UDT) + IF nextc <> 40 THEN '<>"(" (not an array) + IF lastc <> 46 THEN '<>"." (not an element of a UDT) - e$ = UCase$(f2$) + e$ = UCASE$(f2$) es$ = removesymbol$(e$) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION hashfound = 0 hashname$ = e$ hashchkflags = HASHFLAG_CONSTANT hashres = HashFindRev(hashname$, hashchkflags, hashresflags, hashresref) - Do While hashres - If constsubfunc(hashresref) = subfuncn Or constsubfunc(hashresref) = 0 Then - If constdefined(hashresref) Then + DO WHILE hashres + IF constsubfunc(hashresref) = subfuncn OR constsubfunc(hashresref) = 0 THEN + IF constdefined(hashresref) THEN hashfound = 1 - Exit Do - End If - End If - If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0 - Loop + EXIT DO + END IF + END IF + IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 + LOOP - If hashfound Then + IF hashfound THEN i2 = hashresref 'FOR i2 = constlast TO 0 STEP -1 'IF e$ = constname(i2) THEN @@ -18669,119 +18669,119 @@ Function fixoperationorder$ (savea$) 'is a STATIC variable overriding this constant? staticvariable = 0 try = findid(e$ + es$) - If Error_Happened Then EXIT Function - Do While try - If id.arraytype = 0 Then staticvariable = 1: Exit Do 'if it's not an array, it's probably a static variable - If try = 2 Then findanotherid = 1: try = findid(e$ + es$) Else try = 0 - If Error_Happened Then EXIT Function - Loop + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF id.arraytype = 0 THEN staticvariable = 1: EXIT DO 'if it's not an array, it's probably a static variable + IF try = 2 THEN findanotherid = 1: try = findid(e$ + es$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP 'add symbol and try again - If staticvariable = 0 Then - If Len(es$) = 0 Then - a = Asc(UCase$(e$)): If a = 95 Then a = 91 + IF staticvariable = 0 THEN + IF LEN(es$) = 0 THEN + a = ASC(UCASE$(e$)): IF a = 95 THEN a = 91 a = a - 64 'so A=1, Z=27 and _=28 es2$ = defineextaz(a) try = findid(e$ + es2$) - If Error_Happened Then EXIT Function - Do While try - If id.arraytype = 0 Then staticvariable = 1: Exit Do 'if it's not an array, it's probably a static variable - If try = 2 Then findanotherid = 1: try = findid(e$ + es2$) Else try = 0 - If Error_Happened Then EXIT Function - Loop - End If - End If + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF id.arraytype = 0 THEN staticvariable = 1: EXIT DO 'if it's not an array, it's probably a static variable + IF try = 2 THEN findanotherid = 1: try = findid(e$ + es2$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP + END IF + END IF - If staticvariable = 0 Then + IF staticvariable = 0 THEN t = consttype(i2) - If t And ISSTRING Then - If Len(es$) > 0 And es$ <> "$" Then Give_Error "Type mismatch": EXIT Function + IF t AND ISSTRING THEN + IF LEN(es$) > 0 AND es$ <> "$" THEN Give_Error "Type mismatch": EXIT FUNCTION e$ = conststring(i2) - Else 'not a string - If Len(es$) Then et = typname2typ(es$) Else et = 0 - If Error_Happened Then EXIT Function - If et And ISSTRING Then Give_Error "Type mismatch": EXIT Function + ELSE 'not a string + IF LEN(es$) THEN et = typname2typ(es$) ELSE et = 0 + IF Error_Happened THEN EXIT FUNCTION + IF et AND ISSTRING THEN Give_Error "Type mismatch": EXIT FUNCTION 'convert value to general formats - If t And ISFLOAT Then + IF t AND ISFLOAT THEN v## = constfloat(i2) v&& = v## v~&& = v&& - Else - If t And ISUNSIGNED Then + ELSE + IF t AND ISUNSIGNED THEN v~&& = constuinteger(i2) v&& = v~&& v## = v&& - Else + ELSE v&& = constinteger(i2) v## = v&& v~&& = v&& - End If - End If + END IF + END IF 'apply type conversion if necessary - If et Then t = et + IF et THEN t = et '(todo: range checking) 'convert value into string for returning - If t And ISFLOAT Then - e$ = LTrim$(RTrim$(Str$(v##))) - Else - If t And ISUNSIGNED Then - e$ = LTrim$(RTrim$(Str$(v~&&))) - Else - e$ = LTrim$(RTrim$(Str$(v&&))) - End If - End If + IF t AND ISFLOAT THEN + e$ = LTRIM$(RTRIM$(STR$(v##))) + ELSE + IF t AND ISUNSIGNED THEN + e$ = LTRIM$(RTRIM$(STR$(v~&&))) + ELSE + e$ = LTRIM$(RTRIM$(STR$(v&&))) + END IF + END IF 'floats returned by str$ must be converted to qb64 standard format - If t And ISFLOAT Then - t2 = t And 511 + IF t AND ISFLOAT THEN + t2 = t AND 511 'find E,D or F s$ = "" - If InStr(e$, "E") Then s$ = "E" - If InStr(e$, "D") Then s$ = "D" - If InStr(e$, "F") Then s$ = "F" - If Len(s$) Then + IF INSTR(e$, "E") THEN s$ = "E" + IF INSTR(e$, "D") THEN s$ = "D" + IF INSTR(e$, "F") THEN s$ = "F" + IF LEN(s$) THEN 'E,D,F found - x = InStr(e$, s$) + x = INSTR(e$, s$) 'as incorrect type letter may have been returned by STR$, override it - If t2 = 32 Then s$ = "E" - If t2 = 64 Then s$ = "D" - If t2 = 256 Then s$ = "F" - Mid$(e$, x, 1) = s$ - If InStr(e$, ".") = 0 Then e$ = Left$(e$, x - 1) + ".0" + Right$(e$, Len(e$) - x + 1): x = x + 2 - If Left$(e$, 1) = "." Then e$ = "0" + e$ - If Left$(e$, 2) = "-." Then e$ = "-0" + Right$(e$, Len(e$) - 1) - If InStr(e$, "+") = 0 And InStr(e$, "-") = 0 Then - e$ = Left$(e$, x) + "+" + Right$(e$, Len(e$) - x) - End If - Else + IF t2 = 32 THEN s$ = "E" + IF t2 = 64 THEN s$ = "D" + IF t2 = 256 THEN s$ = "F" + MID$(e$, x, 1) = s$ + IF INSTR(e$, ".") = 0 THEN e$ = LEFT$(e$, x - 1) + ".0" + RIGHT$(e$, LEN(e$) - x + 1): x = x + 2 + IF LEFT$(e$, 1) = "." THEN e$ = "0" + e$ + IF LEFT$(e$, 2) = "-." THEN e$ = "-0" + RIGHT$(e$, LEN(e$) - 1) + IF INSTR(e$, "+") = 0 AND INSTR(e$, "-") = 0 THEN + e$ = LEFT$(e$, x) + "+" + RIGHT$(e$, LEN(e$) - x) + END IF + ELSE 'E,D,F not found - If InStr(e$, ".") = 0 Then e$ = e$ + ".0" - If Left$(e$, 1) = "." Then e$ = "0" + e$ - If Left$(e$, 2) = "-." Then e$ = "-0" + Right$(e$, Len(e$) - 1) - If t2 = 32 Then e$ = e$ + "E+0" - If t2 = 64 Then e$ = e$ + "D+0" - If t2 = 256 Then e$ = e$ + "F+0" - End If - Else + IF INSTR(e$, ".") = 0 THEN e$ = e$ + ".0" + IF LEFT$(e$, 1) = "." THEN e$ = "0" + e$ + IF LEFT$(e$, 2) = "-." THEN e$ = "-0" + RIGHT$(e$, LEN(e$) - 1) + IF t2 = 32 THEN e$ = e$ + "E+0" + IF t2 = 64 THEN e$ = e$ + "D+0" + IF t2 = 256 THEN e$ = e$ + "F+0" + END IF + ELSE s$ = typevalue2symbol$(t) - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION e$ = e$ + s$ 'simply append symbol to integer - End If + END IF - End If 'not a string + END IF 'not a string removeelements a$, i, i, 0 insertelements a$, i - 1, e$ 'alter f2$ here to original casing f2$ = constcname(i2) + es$ - GoTo classdone + GOTO classdone - End If 'not static + END IF 'not static 'END IF 'same name 'NEXT - End If 'hashfound - End If 'not udt element - End If 'not array + END IF 'hashfound + END IF 'not udt element + END IF 'not array 'variable/array/udt? u$ = f2$ @@ -18789,56 +18789,56 @@ Function fixoperationorder$ (savea$) try_string$ = f2$ try_string2$ = try_string$ 'pure version of try_string$ - For try_method = 1 To 4 + FOR try_method = 1 TO 4 try_string$ = try_string2$ - If try_method = 2 Or try_method = 4 Then + IF try_method = 2 OR try_method = 4 THEN dtyp$ = removesymbol(try_string$) - If Len(dtyp$) = 0 Then - If isoperator(try_string$) = 0 Then - If isvalidvariable(try_string$) Then - If Left$(try_string$, 1) = "_" Then v = 27 Else v = Asc(UCase$(try_string$)) - 64 + IF LEN(dtyp$) = 0 THEN + IF isoperator(try_string$) = 0 THEN + IF isvalidvariable(try_string$) THEN + IF LEFT$(try_string$, 1) = "_" THEN v = 27 ELSE v = ASC(UCASE$(try_string$)) - 64 try_string$ = try_string$ + defineextaz(v) - End If - End If - Else + END IF + END IF + ELSE try_string$ = try_string2$ - End If - End If + END IF + END IF try = findid(try_string$) - If Error_Happened Then EXIT Function - Do While try - If (subfuncn = id.insubfuncn And try_method <= 2) Or try_method >= 3 Then + IF Error_Happened THEN EXIT FUNCTION + DO WHILE try + IF (subfuncn = id.insubfuncn AND try_method <= 2) OR try_method >= 3 THEN - If Debug Then Print #9, "found id matching " + f2$ + IF Debug THEN PRINT #9, "found id matching " + f2$ - If nextc = 40 Then '( + IF nextc = 40 THEN '( 'function or array? - If id.arraytype <> 0 Or id.subfunc = 1 Then + IF id.arraytype <> 0 OR id.subfunc = 1 THEN 'note: even if it's an array of UDTs, the bracketted index will follow immediately 'correct name f3$ = f2$ s$ = removesymbol$(f3$) - If Error_Happened Then EXIT Function - If id.internal_subfunc Then - f2$ = SCase$(RTrim$(id.cn)) + s$ - Else - f2$ = RTrim$(id.cn) + s$ - End If + IF Error_Happened THEN EXIT FUNCTION + IF id.internal_subfunc THEN + f2$ = SCase$(RTRIM$(id.cn)) + s$ + ELSE + f2$ = RTRIM$(id.cn) + s$ + END IF removeelements a$, i, i, 0 - insertelements a$, i - 1, UCase$(f2$) + insertelements a$, i - 1, UCASE$(f2$) f$ = f$ + f2$ + sp + "(" + sp 'skip (but record with nothing inside them) brackets b2 = 1 'already in first bracket - For i2 = i + 2 To n - c2 = Asc(getelement(a$, i2)) - If c2 = 40 Then b2 = b2 + 1 - If c2 = 41 Then b2 = b2 - 1 - If b2 = 0 Then Exit For 'note: mismatched brackets check ensures this always succeeds + FOR i2 = i + 2 TO n + c2 = ASC(getelement(a$, i2)) + IF c2 = 40 THEN b2 = b2 + 1 + IF c2 = 41 THEN b2 = b2 - 1 + IF b2 = 0 THEN EXIT FOR 'note: mismatched brackets check ensures this always succeeds f$ = f$ + sp - Next + NEXT 'adjust i accordingly i = i2 @@ -18846,142 +18846,142 @@ Function fixoperationorder$ (savea$) f$ = f$ + ")" 'jump to UDT section if array is of UDT type (and elements are referenced) - If id.arraytype And ISUDT Then - If i < n Then nextc = Asc(getelement(a$, i + 1)) Else nextc = 0 - If nextc = 46 Then t = id.arraytype: GoTo fooudt - End If + IF id.arraytype AND ISUDT THEN + IF i < n THEN nextc = ASC(getelement(a$, i + 1)) ELSE nextc = 0 + IF nextc = 46 THEN t = id.arraytype: GOTO fooudt + END IF f$ = f$ + sp - GoTo classdone_special - End If 'id.arraytype - End If 'nextc "(" + GOTO classdone_special + END IF 'id.arraytype + END IF 'nextc "(" - If nextc <> 40 Then 'not "(" (this avoids confusing simple variables with arrays) - If id.t <> 0 Or id.subfunc = 1 Then 'simple variable or function (without parameters) + IF nextc <> 40 THEN 'not "(" (this avoids confusing simple variables with arrays) + IF id.t <> 0 OR id.subfunc = 1 THEN 'simple variable or function (without parameters) - If id.t And ISUDT Then + IF id.t AND ISUDT THEN 'note: it may or may not be followed by a period (eg. if whole udt is being referred to) 'check if next item is a period 'correct name - If id.internal_subfunc Then - f2$ = SCase$(RTrim$(id.cn)) + removesymbol$(f2$) - Else - f2$ = RTrim$(id.cn) + removesymbol$(f2$) - End If - If Error_Happened Then EXIT Function + IF id.internal_subfunc THEN + f2$ = SCase$(RTRIM$(id.cn)) + removesymbol$(f2$) + ELSE + f2$ = RTRIM$(id.cn) + removesymbol$(f2$) + END IF + IF Error_Happened THEN EXIT FUNCTION removeelements a$, i, i, 0 - insertelements a$, i - 1, UCase$(f2$) + insertelements a$, i - 1, UCASE$(f2$) f$ = f$ + f2$ - If nextc <> 46 Then f$ = f$ + sp: GoTo classdone_special 'no sub-elements referenced + IF nextc <> 46 THEN f$ = f$ + sp: GOTO classdone_special 'no sub-elements referenced t = id.t fooudt: f$ = f$ + sp + "." + sp - E = udtxnext(t And 511) 'next element to check + E = udtxnext(t AND 511) 'next element to check i = i + 2 'loop '"." encountered, i must be an element - If i > n Then Give_Error "Expected .element": EXIT Function + IF i > n THEN Give_Error "Expected .element": EXIT FUNCTION f2$ = getelement(a$, i) s$ = removesymbol$(f2$) - If Error_Happened Then EXIT Function - u$ = UCase$(f2$) + Space$(256 - Len(f2$)) 'fast scanning + IF Error_Happened THEN EXIT FUNCTION + u$ = UCASE$(f2$) + SPACE$(256 - LEN(f2$)) 'fast scanning 'is f$ the same as element e? fooudtnexte: - If udtename(E) = u$ Then + IF udtename(E) = u$ THEN 'match found 'todo: check symbol(s$) matches element's type 'correct name - f2$ = RTrim$(udtecname(E)) + s$ + f2$ = RTRIM$(udtecname(E)) + s$ removeelements a$, i, i, 0 - insertelements a$, i - 1, UCase$(f2$) + insertelements a$, i - 1, UCASE$(f2$) f$ = f$ + f2$ - If i = n Then f$ = f$ + sp: GoTo classdone_special - nextc = Asc(getelement(a$, i + 1)) - If nextc <> 46 Then f$ = f$ + sp: GoTo classdone_special 'no sub-elements referenced + IF i = n THEN f$ = f$ + sp: GOTO classdone_special + nextc = ASC(getelement(a$, i + 1)) + IF nextc <> 46 THEN f$ = f$ + sp: GOTO classdone_special 'no sub-elements referenced 'sub-element exists t = udtetype(E) - If (t And ISUDT) = 0 Then Give_Error "Invalid . after element": EXIT Function - GoTo fooudt + IF (t AND ISUDT) = 0 THEN Give_Error "Invalid . after element": EXIT FUNCTION + GOTO fooudt - End If 'match found + END IF 'match found 'no, so check next element E = udtenext(E) - If E = 0 Then Give_Error "Element not defined": EXIT Function - GoTo fooudtnexte + IF E = 0 THEN Give_Error "Element not defined": EXIT FUNCTION + GOTO fooudtnexte - End If 'udt + END IF 'udt 'non array/udt based variable f3$ = f2$ s$ = removesymbol$(f3$) - If Error_Happened Then EXIT Function - If id.internal_subfunc Then - f2$ = SCase$(RTrim$(id.cn)) + s$ - Else - f2$ = RTrim$(id.cn) + s$ - End If + IF Error_Happened THEN EXIT FUNCTION + IF id.internal_subfunc THEN + f2$ = SCase$(RTRIM$(id.cn)) + s$ + ELSE + f2$ = RTRIM$(id.cn) + s$ + END IF 'change was is returned to uppercase removeelements a$, i, i, 0 - insertelements a$, i - 1, UCase$(f2$) - GoTo CouldNotClassify - End If 'id.t + insertelements a$, i - 1, UCASE$(f2$) + GOTO CouldNotClassify + END IF 'id.t - End If 'nextc not "(" + END IF 'nextc not "(" - End If - If try = 2 Then findanotherid = 1: try = findid(try_string$) Else try = 0 - If Error_Happened Then EXIT Function - Loop - Next 'try method (1-4) + END IF + IF try = 2 THEN findanotherid = 1: try = findid(try_string$) ELSE try = 0 + IF Error_Happened THEN EXIT FUNCTION + LOOP + NEXT 'try method (1-4) CouldNotClassify: 'alphanumeric, but item name is unknown... is it an internal type? if so, use capitals - f3$ = UCase$(f2$) + f3$ = UCASE$(f2$) internaltype = 0 - If f3$ = "STRING" Then internaltype = 1 - If f3$ = "_UNSIGNED" Or (f3$ = "UNSIGNED" And qb64prefix_set = 1) Then internaltype = 1 - If f3$ = "_BIT" Or (f3$ = "BIT" And qb64prefix_set = 1) Then internaltype = 1 - If f3$ = "_BYTE" Or (f3$ = "BYTE" And qb64prefix_set = 1) Then internaltype = 1 - If f3$ = "INTEGER" Then internaltype = 1 - If f3$ = "LONG" Then internaltype = 1 - If f3$ = "_INTEGER64" Or (f3$ = "INTEGER64" And qb64prefix_set = 1) Then internaltype = 1 - If f3$ = "SINGLE" Then internaltype = 1 - If f3$ = "DOUBLE" Then internaltype = 1 - If f3$ = "_FLOAT" Or (f3$ = "FLOAT" And qb64prefix_set = 1) Then internaltype = 1 - If f3$ = "_OFFSET" Or (f3$ = "OFFSET" And qb64prefix_set = 1) Then internaltype = 1 - If internaltype = 1 Then + IF f3$ = "STRING" THEN internaltype = 1 + IF f3$ = "_UNSIGNED" OR (f3$ = "UNSIGNED" AND qb64prefix_set = 1) THEN internaltype = 1 + IF f3$ = "_BIT" OR (f3$ = "BIT" AND qb64prefix_set = 1) THEN internaltype = 1 + IF f3$ = "_BYTE" OR (f3$ = "BYTE" AND qb64prefix_set = 1) THEN internaltype = 1 + IF f3$ = "INTEGER" THEN internaltype = 1 + IF f3$ = "LONG" THEN internaltype = 1 + IF f3$ = "_INTEGER64" OR (f3$ = "INTEGER64" AND qb64prefix_set = 1) THEN internaltype = 1 + IF f3$ = "SINGLE" THEN internaltype = 1 + IF f3$ = "DOUBLE" THEN internaltype = 1 + IF f3$ = "_FLOAT" OR (f3$ = "FLOAT" AND qb64prefix_set = 1) THEN internaltype = 1 + IF f3$ = "_OFFSET" OR (f3$ = "OFFSET" AND qb64prefix_set = 1) THEN internaltype = 1 + IF internaltype = 1 THEN f2$ = SCase2$(f3$) removeelements a$, i, i, 0 insertelements a$, i - 1, f3$ - GoTo classdone - End If + GOTO classdone + END IF - GoTo classdone - End If 'alphanumeric + GOTO classdone + END IF 'alphanumeric classdone: f$ = f$ + f2$ - End If 'b=0 + END IF 'b=0 f$ = f$ + sp classdone_special: - Next + NEXT - If Len(f$) Then f$ = Left$(f$, Len(f$) - 1) 'remove trailing 'sp' + IF LEN(f$) THEN f$ = LEFT$(f$, LEN(f$) - 1) 'remove trailing 'sp' - If Debug Then Print #9, "fixoperationorder:identification:" + a$, n - If Debug Then Print #9, "fixoperationorder:identification(layout):" + f$, n + IF Debug THEN PRINT #9, "fixoperationorder:identification:" + a$, n + IF Debug THEN PRINT #9, "fixoperationorder:identification(layout):" + f$, n '----------------I. Pass (){}bracketed items (if any) to fixoperationorder & build return---------------- @@ -18993,20 +18993,20 @@ Function fixoperationorder$ (savea$) p1 = 0 'where level 1 began aa$ = "" n = numelements(a$) - For i = 1 To n + FOR i = 1 TO n openbracket = 0 a2$ = getelement(a$, i) - c = Asc(a2$) + c = ASC(a2$) - If c = 40 Or c = 123 Then '({ + IF c = 40 OR c = 123 THEN '({ b = b + 1 - If b = 1 Then + IF b = 1 THEN @@ -19014,190 +19014,190 @@ Function fixoperationorder$ (savea$) p1 = i + 1 aa$ = aa$ + "(" + sp - End If + END IF openbracket = 1 - GoTo foopass + GOTO foopass - End If '({ + END IF '({ - If c = 44 Then ', - If b = 1 Then - GoTo foopassit - End If - End If + IF c = 44 THEN ', + IF b = 1 THEN + GOTO foopassit + END IF + END IF - If c = 41 Or c = 125 Then ')} + IF c = 41 OR c = 125 THEN ')} b = b - 1 - If b = 0 Then + IF b = 0 THEN foopassit: - If p1 <> i Then + IF p1 <> i THEN foo$ = fixoperationorder(getelements(a$, p1, i - 1)) - If Error_Happened Then EXIT Function - If Len(foo$) Then + IF Error_Happened THEN EXIT FUNCTION + IF LEN(foo$) THEN aa$ = aa$ + foo$ + sp - If c = 125 Then ff$ = ff$ + tlayout$ + sp Else ff$ = ff$ + tlayout$ + sp2 'spacing between ) } , varies - End If - End If - If c = 44 Then aa$ = aa$ + "," + sp: ff$ = ff$ + "," + sp Else aa$ = aa$ + ")" + sp + IF c = 125 THEN ff$ = ff$ + tlayout$ + sp ELSE ff$ = ff$ + tlayout$ + sp2 'spacing between ) } , varies + END IF + END IF + IF c = 44 THEN aa$ = aa$ + "," + sp: ff$ = ff$ + "," + sp ELSE aa$ = aa$ + ")" + sp p1 = i + 1 - End If + END IF - GoTo foopass - End If ')} + GOTO foopass + END IF ')} - If b = 0 Then aa$ = aa$ + a2$ + sp + IF b = 0 THEN aa$ = aa$ + a2$ + sp foopass: f2$ = getelementspecial(f$, i) - If Error_Happened Then EXIT Function - If Len(f2$) Then + IF Error_Happened THEN EXIT FUNCTION + IF LEN(f2$) THEN 'use sp2 to join items connected by a period - If c = 46 Then '"." - If i > 1 And i < n Then 'stupidity check - If Len(ff$) Then Mid$(ff$, Len(ff$), 1) = sp2 'convert last spacer to a sp2 + IF c = 46 THEN '"." + IF i > 1 AND i < n THEN 'stupidity check + IF LEN(ff$) THEN MID$(ff$, LEN(ff$), 1) = sp2 'convert last spacer to a sp2 ff$ = ff$ + "." + sp2 - GoTo fooloopnxt - End If - End If + GOTO fooloopnxt + END IF + END IF 'spacing just before ( - If openbracket Then + IF openbracket THEN 'convert last spacer? - If i <> 1 Then - If isoperator(getelement$(a$, i - 1)) = 0 Then - Mid$(ff$, Len(ff$), 1) = sp2 - End If - End If + IF i <> 1 THEN + IF isoperator(getelement$(a$, i - 1)) = 0 THEN + MID$(ff$, LEN(ff$), 1) = sp2 + END IF + END IF ff$ = ff$ + f2$ + sp2 - Else 'not openbracket + ELSE 'not openbracket ff$ = ff$ + f2$ + sp - End If + END IF - End If 'len(f2$) + END IF 'len(f2$) fooloopnxt: - Next + NEXT - If Len(aa$) Then aa$ = Left$(aa$, Len(aa$) - 1) - If Len(ff$) Then ff$ = Left$(ff$, Len(ff$) - 1) + IF LEN(aa$) THEN aa$ = LEFT$(aa$, LEN(aa$) - 1) + IF LEN(ff$) THEN ff$ = LEFT$(ff$, LEN(ff$) - 1) - If Debug Then Print #9, "fixoperationorder:return:" + aa$ - If Debug Then Print #9, "fixoperationorder:layout:" + ff$ + IF Debug THEN PRINT #9, "fixoperationorder:return:" + aa$ + IF Debug THEN PRINT #9, "fixoperationorder:layout:" + ff$ tlayout$ = ff$ fixoperationorder$ = aa$ fooindwel = fooindwel - 1 -End Function +END FUNCTION -Function getelementspecial$ (savea$, elenum) +FUNCTION getelementspecial$ (savea$, elenum) a$ = savea$ - If a$ = "" Then EXIT Function 'no elements! + IF a$ = "" THEN EXIT FUNCTION 'no elements! n = 1 p = 1 getelementspecialnext: - i = InStr(p, a$, sp) + i = INSTR(p, a$, sp) 'avoid sp inside "..." - i2 = InStr(p, a$, Chr$(34)) - If i2 < i And i2 <> 0 Then - i3 = InStr(i2 + 1, a$, Chr$(34)): If i3 = 0 Then Give_Error "Expected " + Chr$(34): EXIT Function - i = InStr(i3, a$, sp) - End If + i2 = INSTR(p, a$, CHR$(34)) + IF i2 < i AND i2 <> 0 THEN + i3 = INSTR(i2 + 1, a$, CHR$(34)): IF i3 = 0 THEN Give_Error "Expected " + CHR$(34): EXIT FUNCTION + i = INSTR(i3, a$, sp) + END IF - If elenum = n Then - If i Then - getelementspecial$ = Mid$(a$, p, i - p) - Else - getelementspecial$ = Right$(a$, Len(a$) - p + 1) - End If - EXIT Function - End If + IF elenum = n THEN + IF i THEN + getelementspecial$ = MID$(a$, p, i - p) + ELSE + getelementspecial$ = RIGHT$(a$, LEN(a$) - p + 1) + END IF + EXIT FUNCTION + END IF - If i = 0 Then EXIT Function 'no more elements! + IF i = 0 THEN EXIT FUNCTION 'no more elements! n = n + 1 p = i + 1 - GoTo getelementspecialnext -End Function + GOTO getelementspecialnext +END FUNCTION -Function getelement$ (a$, elenum) - If a$ = "" Then EXIT Function 'no elements! +FUNCTION getelement$ (a$, elenum) + IF a$ = "" THEN EXIT FUNCTION 'no elements! n = 1 p = 1 getelementnext: - i = InStr(p, a$, sp) + i = INSTR(p, a$, sp) - If elenum = n Then - If i Then - getelement$ = Mid$(a$, p, i - p) - Else - getelement$ = Right$(a$, Len(a$) - p + 1) - End If - EXIT Function - End If + IF elenum = n THEN + IF i THEN + getelement$ = MID$(a$, p, i - p) + ELSE + getelement$ = RIGHT$(a$, LEN(a$) - p + 1) + END IF + EXIT FUNCTION + END IF - If i = 0 Then EXIT Function 'no more elements! + IF i = 0 THEN EXIT FUNCTION 'no more elements! n = n + 1 p = i + 1 - GoTo getelementnext -End Function + GOTO getelementnext +END FUNCTION -Function getelements$ (a$, i1, i2) - If i2 < i1 Then getelements$ = "": EXIT Function +FUNCTION getelements$ (a$, i1, i2) + IF i2 < i1 THEN getelements$ = "": EXIT FUNCTION n = 1 p = 1 getelementsnext: - i = InStr(p, a$, sp) - If n = i1 Then + i = INSTR(p, a$, sp) + IF n = i1 THEN i1pos = p - End If - If n = i2 Then - If i Then - getelements$ = Mid$(a$, i1pos, i - i1pos) - Else - getelements$ = Right$(a$, Len(a$) - i1pos + 1) - End If - EXIT Function - End If + END IF + IF n = i2 THEN + IF i THEN + getelements$ = MID$(a$, i1pos, i - i1pos) + ELSE + getelements$ = RIGHT$(a$, LEN(a$) - i1pos + 1) + END IF + EXIT FUNCTION + END IF n = n + 1 p = i + 1 - GoTo getelementsnext -End Function + GOTO getelementsnext +END FUNCTION -Sub getid (i As Long) - If i = -1 Then Give_Error "-1 passed to getid!": EXIT Sub +SUB getid (i AS LONG) + IF i = -1 THEN Give_Error "-1 passed to getid!": EXIT SUB id = ids(i) currentid = i -End Sub +END SUB -Sub insertelements (a$, i, elements$) - If i = 0 Then - If a$ = "" Then +SUB insertelements (a$, i, elements$) + IF i = 0 THEN + IF a$ = "" THEN a$ = elements$ - EXIT Sub - End If + EXIT SUB + END IF a$ = elements$ + sp + a$ - EXIT Sub - End If + EXIT SUB + END IF a2$ = "" n = numelements(a$) @@ -19205,130 +19205,130 @@ Sub insertelements (a$, i, elements$) - For i2 = 1 To n - If i2 > 1 Then a2$ = a2$ + sp + FOR i2 = 1 TO n + IF i2 > 1 THEN a2$ = a2$ + sp a2$ = a2$ + getelement$(a$, i2) - If i = i2 Then a2$ = a2$ + sp + elements$ - Next + IF i = i2 THEN a2$ = a2$ + sp + elements$ + NEXT a$ = a2$ -End Sub +END SUB -Function isnumber (a$) - If Len(a$) = 0 Then EXIT Function - For i = 1 To Len(a$) - a = Asc(Mid$(a$, i, 1)) - If a = 45 Then - If (i = 1 And Len(a$) > 1) Or (i > 1 And ((d > 0 And d = i - 1) Or (E > 0 And E = i - 1))) Then _Continue - EXIT Function - End If - If a = 46 Then - If dp = 1 Then EXIT Function +FUNCTION isnumber (a$) + IF LEN(a$) = 0 THEN EXIT FUNCTION + FOR i = 1 TO LEN(a$) + a = ASC(MID$(a$, i, 1)) + IF a = 45 THEN + IF (i = 1 AND LEN(a$) > 1) OR (i > 1 AND ((d > 0 AND d = i - 1) OR (E > 0 AND E = i - 1))) THEN _CONTINUE + EXIT FUNCTION + END IF + IF a = 46 THEN + IF dp = 1 THEN EXIT FUNCTION dp = 1 - _Continue - End If - If a = 100 Or a = 68 Then 'D - If d > 0 Or E > 0 Then EXIT Function - If i = 1 Then EXIT Function + _CONTINUE + END IF + IF a = 100 OR a = 68 THEN 'D + IF d > 0 OR E > 0 THEN EXIT FUNCTION + IF i = 1 THEN EXIT FUNCTION d = i - _Continue - End If - If a = 101 Or a = 69 Then 'E - If d > 0 Or E > 0 Then EXIT Function - If i = 1 Then EXIT Function + _CONTINUE + END IF + IF a = 101 OR a = 69 THEN 'E + IF d > 0 OR E > 0 THEN EXIT FUNCTION + IF i = 1 THEN EXIT FUNCTION E = i - _Continue - End If - If a = 43 Then '+ - If (d > 0 And d = i - 1) Or (E > 0 And E = i - 1) Then _Continue - EXIT Function - End If + _CONTINUE + END IF + IF a = 43 THEN '+ + IF (d > 0 AND d = i - 1) OR (E > 0 AND E = i - 1) THEN _CONTINUE + EXIT FUNCTION + END IF - If a >= 48 And a <= 57 Then _Continue - EXIT Function - Next + IF a >= 48 AND a <= 57 THEN _CONTINUE + EXIT FUNCTION + NEXT isnumber = 1 -End Function +END FUNCTION -Function isoperator (a2$) - a$ = UCase$(a2$) +FUNCTION isoperator (a2$) + a$ = UCASE$(a2$) l = 0 - l = l + 1: If a$ = "IMP" Then GoTo opfound - l = l + 1: If a$ = "EQV" Then GoTo opfound - l = l + 1: If a$ = "XOR" Then GoTo opfound - l = l + 1: If a$ = "OR" Then GoTo opfound - l = l + 1: If a$ = "AND" Then GoTo opfound - l = l + 1: If a$ = "NOT" Then GoTo opfound + l = l + 1: IF a$ = "IMP" THEN GOTO opfound + l = l + 1: IF a$ = "EQV" THEN GOTO opfound + l = l + 1: IF a$ = "XOR" THEN GOTO opfound + l = l + 1: IF a$ = "OR" THEN GOTO opfound + l = l + 1: IF a$ = "AND" THEN GOTO opfound + l = l + 1: IF a$ = "NOT" THEN GOTO opfound l = l + 1 - If a$ = "=" Then GoTo opfound - If a$ = ">" Then GoTo opfound - If a$ = "<" Then GoTo opfound - If a$ = "<>" Then GoTo opfound - If a$ = "<=" Then GoTo opfound - If a$ = ">=" Then GoTo opfound + IF a$ = "=" THEN GOTO opfound + IF a$ = ">" THEN GOTO opfound + IF a$ = "<" THEN GOTO opfound + IF a$ = "<>" THEN GOTO opfound + IF a$ = "<=" THEN GOTO opfound + IF a$ = ">=" THEN GOTO opfound l = l + 1 - If a$ = "+" Then GoTo opfound - If a$ = "-" Then GoTo opfound '!CAREFUL! could be negation - l = l + 1: If a$ = "MOD" Then GoTo opfound - l = l + 1: If a$ = "\" Then GoTo opfound + IF a$ = "+" THEN GOTO opfound + IF a$ = "-" THEN GOTO opfound '!CAREFUL! could be negation + l = l + 1: IF a$ = "MOD" THEN GOTO opfound + l = l + 1: IF a$ = "\" THEN GOTO opfound l = l + 1 - If a$ = "*" Then GoTo opfound - If a$ = "/" Then GoTo opfound + IF a$ = "*" THEN GOTO opfound + IF a$ = "/" THEN GOTO opfound 'NEGATION LEVEL (MUST BE SET AFTER CALLING ISOPERATOR BY CONTEXT) - l = l + 1: If a$ = Chr$(241) Then GoTo opfound - l = l + 1: If a$ = "^" Then GoTo opfound - EXIT Function + l = l + 1: IF a$ = CHR$(241) THEN GOTO opfound + l = l + 1: IF a$ = "^" THEN GOTO opfound + EXIT FUNCTION opfound: isoperator = l -End Function +END FUNCTION -Function isuinteger (i$) - If Len(i$) = 0 Then EXIT Function - If Asc(i$, 1) = 48 And Len(i$) > 1 Then EXIT Function - For c = 1 To Len(i$) - v = Asc(i$, c) - If v < 48 Or v > 57 Then EXIT Function - Next +FUNCTION isuinteger (i$) + IF LEN(i$) = 0 THEN EXIT FUNCTION + IF ASC(i$, 1) = 48 AND LEN(i$) > 1 THEN EXIT FUNCTION + FOR c = 1 TO LEN(i$) + v = ASC(i$, c) + IF v < 48 OR v > 57 THEN EXIT FUNCTION + NEXT isuinteger = -1 -End Function +END FUNCTION -Function isvalidvariable (a$) - For i = 1 To Len(a$) - c = Asc(a$, i) +FUNCTION isvalidvariable (a$) + FOR i = 1 TO LEN(a$) + c = ASC(a$, i) t = 0 - If c >= 48 And c <= 57 Then t = 1 'numeric - If c >= 65 And c <= 90 Then t = 2 'uppercase - If c >= 97 And c <= 122 Then t = 2 'lowercase - If c = 95 Then t = 2 '_ underscore - If t = 2 Or (t = 1 And i > 1) Then + IF c >= 48 AND c <= 57 THEN t = 1 'numeric + IF c >= 65 AND c <= 90 THEN t = 2 'uppercase + IF c >= 97 AND c <= 122 THEN t = 2 'lowercase + IF c = 95 THEN t = 2 '_ underscore + IF t = 2 OR (t = 1 AND i > 1) THEN 'valid (continue) - Else - If i = 1 Then isvalidvariable = 0: EXIT Function - Exit For - End If - Next + ELSE + IF i = 1 THEN isvalidvariable = 0: EXIT FUNCTION + EXIT FOR + END IF + NEXT isvalidvariable = 1 - If i > n Then EXIT Function - e$ = Right$(a$, Len(a$) - i - 1) - If e$ = "%%" Or e$ = "~%%" Then EXIT Function - If e$ = "%" Or e$ = "~%" Then EXIT Function - If e$ = "&" Or e$ = "~&" Then EXIT Function - If e$ = "&&" Or e$ = "~&&" Then EXIT Function - If e$ = "!" Or e$ = "#" Or e$ = "##" Then EXIT Function - If e$ = "$" Then EXIT Function - If e$ = "`" Then EXIT Function - If Left$(e$, 1) <> "$" And Left$(e$, 1) <> "`" Then isvalidvariable = 0: EXIT Function - e$ = Right$(e$, Len(e$) - 1) - If isuinteger(e$) Then isvalidvariable = 1: EXIT Function + IF i > n THEN EXIT FUNCTION + e$ = RIGHT$(a$, LEN(a$) - i - 1) + IF e$ = "%%" OR e$ = "~%%" THEN EXIT FUNCTION + IF e$ = "%" OR e$ = "~%" THEN EXIT FUNCTION + IF e$ = "&" OR e$ = "~&" THEN EXIT FUNCTION + IF e$ = "&&" OR e$ = "~&&" THEN EXIT FUNCTION + IF e$ = "!" OR e$ = "#" OR e$ = "##" THEN EXIT FUNCTION + IF e$ = "$" THEN EXIT FUNCTION + IF e$ = "`" THEN EXIT FUNCTION + IF LEFT$(e$, 1) <> "$" AND LEFT$(e$, 1) <> "`" THEN isvalidvariable = 0: EXIT FUNCTION + e$ = RIGHT$(e$, LEN(e$) - 1) + IF isuinteger(e$) THEN isvalidvariable = 1: EXIT FUNCTION isvalidvariable = 0 -End Function +END FUNCTION -Function lineformat$ (a$) +FUNCTION lineformat$ (a$) a2$ = "" linecontinuation = 0 @@ -19337,68 +19337,68 @@ Function lineformat$ (a$) a$ = a$ + " " 'add 2 extra spaces to make reading next char easier ca$ = a$ - a$ = UCase$(a$) + a$ = UCASE$(a$) - n = Len(a$) + n = LEN(a$) i = 1 lineformatnext: - If i >= n Then GoTo lineformatdone + IF i >= n THEN GOTO lineformatdone - c = Asc(a$, i) - c$ = Chr$(c) '***remove later*** + c = ASC(a$, i) + c$ = CHR$(c) '***remove later*** '----------------quoted string---------------- - If c = 34 Then '" - a2$ = a2$ + sp + Chr$(34) + IF c = 34 THEN '" + a2$ = a2$ + sp + CHR$(34) p1 = i + 1 - For i2 = i + 1 To n - 2 - c2 = Asc(a$, i2) + FOR i2 = i + 1 TO n - 2 + c2 = ASC(a$, i2) - If c2 = 34 Then - a2$ = a2$ + Mid$(ca$, p1, i2 - p1 + 1) + "," + str2$(i2 - (i + 1)) + IF c2 = 34 THEN + a2$ = a2$ + MID$(ca$, p1, i2 - p1 + 1) + "," + str2$(i2 - (i + 1)) i = i2 + 1 - Exit For - End If + EXIT FOR + END IF - If c2 = 92 Then '\ - a2$ = a2$ + Mid$(ca$, p1, i2 - p1) + "\\" + IF c2 = 92 THEN '\ + a2$ = a2$ + MID$(ca$, p1, i2 - p1) + "\\" p1 = i2 + 1 - End If + END IF - If c2 < 32 Or c2 > 126 Then - o$ = Oct$(c2) - If Len(o$) < 3 Then + IF c2 < 32 OR c2 > 126 THEN + o$ = OCT$(c2) + IF LEN(o$) < 3 THEN o$ = "0" + o$ - If Len(o$) < 3 Then o$ = "0" + o$ - End If - a2$ = a2$ + Mid$(ca$, p1, i2 - p1) + "\" + o$ + IF LEN(o$) < 3 THEN o$ = "0" + o$ + END IF + a2$ = a2$ + MID$(ca$, p1, i2 - p1) + "\" + o$ p1 = i2 + 1 - End If + END IF - Next + NEXT - If i2 = n - 1 Then 'no closing " - a2$ = a2$ + Mid$(ca$, p1, (n - 2) - p1 + 1) + Chr$(34) + "," + str2$((n - 2) - (i + 1) + 1) + IF i2 = n - 1 THEN 'no closing " + a2$ = a2$ + MID$(ca$, p1, (n - 2) - p1 + 1) + CHR$(34) + "," + str2$((n - 2) - (i + 1) + 1) i = n - 1 - End If + END IF - GoTo lineformatnext + GOTO lineformatnext - End If + END IF '----------------number---------------- firsti = i - If c = 46 Then - c2$ = Mid$(a$, i + 1, 1): c2 = Asc(c2$) - If (c2 >= 48 And c2 <= 57) Then GoTo lfnumber - End If - If (c >= 48 And c <= 57) Then '0-9 + IF c = 46 THEN + c2$ = MID$(a$, i + 1, 1): c2 = ASC(c2$) + IF (c2 >= 48 AND c2 <= 57) THEN GOTO lfnumber + END IF + IF (c >= 48 AND c <= 57) THEN '0-9 lfnumber: 'handle 'IF a=1 THEN a=2 ELSE 100' by assuming numeric after ELSE to be a - If Right$(a2$, 5) = sp + "ELSE" Then + IF RIGHT$(a2$, 5) = sp + "ELSE" THEN a2$ = a2$ + sp + "GOTO" - End If + END IF 'Number will be converted to the following format: ' 999999 . 99999 E + 999 @@ -19419,573 +19419,573 @@ Function lineformat$ (a$) lfreadnumber: valid = 0 - If c = 46 Then - If mode = 0 Then valid = 1: dp = 1: mode = 1 - End If + IF c = 46 THEN + IF mode = 0 THEN valid = 1: dp = 1: mode = 1 + END IF - If c >= 48 And c <= 57 Then '0-9 + IF c >= 48 AND c <= 57 THEN '0-9 valid = 1 - If mode = 0 Then whole$ = whole$ + c$ - If mode = 1 Then frac$ = frac$ + c$ - If mode = 2 Then mode = 3 - If mode = 3 Then ex$ = ex$ + c$ - End If + IF mode = 0 THEN whole$ = whole$ + c$ + IF mode = 1 THEN frac$ = frac$ + c$ + IF mode = 2 THEN mode = 3 + IF mode = 3 THEN ex$ = ex$ + c$ + END IF - If c = 69 Or c = 68 Or c = 70 Then 'E,D,F - If mode < 2 Then + IF c = 69 OR c = 68 OR c = 70 THEN 'E,D,F + IF mode < 2 THEN valid = 1 - If c = 69 Then ed = 1 - If c = 68 Then ed = 2 - If c = 70 Then ed = 3 + IF c = 69 THEN ed = 1 + IF c = 68 THEN ed = 2 + IF c = 70 THEN ed = 3 mode = 2 - End If - End If + END IF + END IF - If c = 43 Or c = 45 Then '+,- - If mode = 2 Then + IF c = 43 OR c = 45 THEN '+,- + IF mode = 2 THEN valid = 1 - If c = 45 Then pm = -1 + IF c = 45 THEN pm = -1 mode = 3 - End If - End If + END IF + END IF - If valid Then - If i <= n Then i = i + 1: c$ = Mid$(a$, i, 1): c = Asc(c$): GoTo lfreadnumber - End If + IF valid THEN + IF i <= n THEN i = i + 1: c$ = MID$(a$, i, 1): c = ASC(c$): GOTO lfreadnumber + END IF 'cull leading 0s off whole$ - Do While Left$(whole$, 1) = "0": whole$ = Right$(whole$, Len(whole$) - 1): Loop + DO WHILE LEFT$(whole$, 1) = "0": whole$ = RIGHT$(whole$, LEN(whole$) - 1): LOOP 'cull trailing 0s off frac$ - Do While Right$(frac$, 1) = "0": frac$ = Left$(frac$, Len(frac$) - 1): Loop + DO WHILE RIGHT$(frac$, 1) = "0": frac$ = LEFT$(frac$, LEN(frac$) - 1): LOOP 'cull leading 0s off ex$ - Do While Left$(ex$, 1) = "0": ex$ = Right$(ex$, Len(ex$) - 1): Loop + DO WHILE LEFT$(ex$, 1) = "0": ex$ = RIGHT$(ex$, LEN(ex$) - 1): LOOP - If dp <> 0 Or ed <> 0 Then float = 1 Else float = 0 + IF dp <> 0 OR ed <> 0 THEN float = 1 ELSE float = 0 extused = 1 - If ed Then e$ = "": GoTo lffoundext 'no extensions valid after E/D/F specified + IF ed THEN e$ = "": GOTO lffoundext 'no extensions valid after E/D/F specified '3-character extensions - If i <= n - 2 Then - e$ = Mid$(a$, i, 3) - If e$ = "~%%" And float = 0 Then i = i + 3: GoTo lffoundext - If e$ = "~&&" And float = 0 Then i = i + 3: GoTo lffoundext - If e$ = "~%&" And float = 0 Then Give_Error "Cannot use _OFFSET symbols after numbers": EXIT Function - End If + IF i <= n - 2 THEN + e$ = MID$(a$, i, 3) + IF e$ = "~%%" AND float = 0 THEN i = i + 3: GOTO lffoundext + IF e$ = "~&&" AND float = 0 THEN i = i + 3: GOTO lffoundext + IF e$ = "~%&" AND float = 0 THEN Give_Error "Cannot use _OFFSET symbols after numbers": EXIT FUNCTION + END IF '2-character extensions - If i <= n - 1 Then - e$ = Mid$(a$, i, 2) - If e$ = "%%" And float = 0 Then i = i + 2: GoTo lffoundext - If e$ = "~%" And float = 0 Then i = i + 2: GoTo lffoundext - If e$ = "&&" And float = 0 Then i = i + 2: GoTo lffoundext - If e$ = "~&" And float = 0 Then i = i + 2: GoTo lffoundext - If e$ = "%&" And float = 0 Then Give_Error "Cannot use _OFFSET symbols after numbers": EXIT Function - If e$ = "##" Then + IF i <= n - 1 THEN + e$ = MID$(a$, i, 2) + IF e$ = "%%" AND float = 0 THEN i = i + 2: GOTO lffoundext + IF e$ = "~%" AND float = 0 THEN i = i + 2: GOTO lffoundext + IF e$ = "&&" AND float = 0 THEN i = i + 2: GOTO lffoundext + IF e$ = "~&" AND float = 0 THEN i = i + 2: GOTO lffoundext + IF e$ = "%&" AND float = 0 THEN Give_Error "Cannot use _OFFSET symbols after numbers": EXIT FUNCTION + IF e$ = "##" THEN i = i + 2 ed = 3 e$ = "" - GoTo lffoundext - End If - If e$ = "~`" Then + GOTO lffoundext + END IF + IF e$ = "~`" THEN i = i + 2 - GoTo lffoundbitext - End If - End If + GOTO lffoundbitext + END IF + END IF '1-character extensions - If i <= n Then - e$ = Mid$(a$, i, 1) - If e$ = "%" And float = 0 Then i = i + 1: GoTo lffoundext - If e$ = "&" And float = 0 Then i = i + 1: GoTo lffoundext - If e$ = "!" Then + IF i <= n THEN + e$ = MID$(a$, i, 1) + IF e$ = "%" AND float = 0 THEN i = i + 1: GOTO lffoundext + IF e$ = "&" AND float = 0 THEN i = i + 1: GOTO lffoundext + IF e$ = "!" THEN i = i + 1 ed = 1 e$ = "" - GoTo lffoundext - End If - If e$ = "#" Then + GOTO lffoundext + END IF + IF e$ = "#" THEN i = i + 1 ed = 2 e$ = "" - GoTo lffoundext - End If - If e$ = "`" Then + GOTO lffoundext + END IF + IF e$ = "`" THEN i = i + 1 lffoundbitext: bitn$ = "" - Do While i <= n - c2 = Asc(Mid$(a$, i, 1)) - If c2 >= 48 And c2 <= 57 Then - bitn$ = bitn$ + Chr$(c2) + DO WHILE i <= n + c2 = ASC(MID$(a$, i, 1)) + IF c2 >= 48 AND c2 <= 57 THEN + bitn$ = bitn$ + CHR$(c2) i = i + 1 - Else - Exit Do - End If - Loop - If bitn$ = "" Then bitn$ = "1" + ELSE + EXIT DO + END IF + LOOP + IF bitn$ = "" THEN bitn$ = "1" 'cull leading 0s off bitn$ - Do While Left$(bitn$, 1) = "0": bitn$ = Right$(bitn$, Len(bitn$) - 1): Loop + DO WHILE LEFT$(bitn$, 1) = "0": bitn$ = RIGHT$(bitn$, LEN(bitn$) - 1): LOOP e$ = e$ + bitn$ - GoTo lffoundext - End If - End If + GOTO lffoundext + END IF + END IF - If float Then 'floating point types CAN be assumed + IF float THEN 'floating point types CAN be assumed 'calculate first significant digit offset & number of significant digits - If whole$ <> "" Then - offset = Len(whole$) - 1 - sigdigits = Len(whole$) + Len(frac$) - Else - If frac$ <> "" Then + IF whole$ <> "" THEN + offset = LEN(whole$) - 1 + sigdigits = LEN(whole$) + LEN(frac$) + ELSE + IF frac$ <> "" THEN offset = -1 - sigdigits = Len(frac$) - For i2 = 1 To Len(frac$) - If Mid$(frac$, i2, 1) <> "0" Then Exit For + sigdigits = LEN(frac$) + FOR i2 = 1 TO LEN(frac$) + IF MID$(frac$, i2, 1) <> "0" THEN EXIT FOR offset = offset - 1 sigdigits = sigdigits - 1 - Next - Else + NEXT + ELSE 'number is 0 offset = 0 sigdigits = 0 - End If - End If - sigdig$ = Right$(whole$ + frac$, sigdigits) + END IF + END IF + sigdig$ = RIGHT$(whole$ + frac$, sigdigits) 'SINGLE? - If sigdigits <= 7 Then 'QBASIC interprets anything with more than 7 sig. digits as a DOUBLE - If offset <= 38 And offset >= -38 Then 'anything outside this range cannot be represented as a SINGLE - If offset = 38 Then - If sigdig$ > "3402823" Then GoTo lfxsingle - End If - If offset = -38 Then - If sigdig$ < "1175494" Then GoTo lfxsingle - End If + IF sigdigits <= 7 THEN 'QBASIC interprets anything with more than 7 sig. digits as a DOUBLE + IF offset <= 38 AND offset >= -38 THEN 'anything outside this range cannot be represented as a SINGLE + IF offset = 38 THEN + IF sigdig$ > "3402823" THEN GOTO lfxsingle + END IF + IF offset = -38 THEN + IF sigdig$ < "1175494" THEN GOTO lfxsingle + END IF ed = 1 e$ = "" - GoTo lffoundext - End If - End If + GOTO lffoundext + END IF + END IF lfxsingle: 'DOUBLE? - If sigdigits <= 16 Then 'QB64 handles DOUBLES with 16-digit precision - If offset <= 308 And offset >= -308 Then 'anything outside this range cannot be represented as a DOUBLE - If offset = 308 Then - If sigdig$ > "1797693134862315" Then GoTo lfxdouble - End If - If offset = -308 Then - If sigdig$ < "2225073858507201" Then GoTo lfxdouble - End If + IF sigdigits <= 16 THEN 'QB64 handles DOUBLES with 16-digit precision + IF offset <= 308 AND offset >= -308 THEN 'anything outside this range cannot be represented as a DOUBLE + IF offset = 308 THEN + IF sigdig$ > "1797693134862315" THEN GOTO lfxdouble + END IF + IF offset = -308 THEN + IF sigdig$ < "2225073858507201" THEN GOTO lfxdouble + END IF ed = 2 e$ = "" - GoTo lffoundext - End If - End If + GOTO lffoundext + END IF + END IF lfxdouble: 'assume _FLOAT ed = 3 - e$ = "": GoTo lffoundext - End If + e$ = "": GOTO lffoundext + END IF extused = 0 e$ = "" lffoundext: 'make sure a leading numberic character exists - If whole$ = "" Then whole$ = "0" + IF whole$ = "" THEN whole$ = "0" 'if a float, ensure frac$<>"" and dp=1 - If float Then + IF float THEN dp = 1 - If frac$ = "" Then frac$ = "0" - End If + IF frac$ = "" THEN frac$ = "0" + END IF 'if ed is specified, make sure ex$ exists - If ed <> 0 And ex$ = "" Then ex$ = "0" + IF ed <> 0 AND ex$ = "" THEN ex$ = "0" a2$ = a2$ + sp a2$ = a2$ + whole$ - If dp Then a2$ = a2$ + "." + frac$ - If ed Then - If ed = 1 Then a2$ = a2$ + "E" - If ed = 2 Then a2$ = a2$ + "D" - If ed = 3 Then a2$ = a2$ + "F" - If pm = -1 And ex$ <> "0" Then a2$ = a2$ + "-" Else a2$ = a2$ + "+" + IF dp THEN a2$ = a2$ + "." + frac$ + IF ed THEN + IF ed = 1 THEN a2$ = a2$ + "E" + IF ed = 2 THEN a2$ = a2$ + "D" + IF ed = 3 THEN a2$ = a2$ + "F" + IF pm = -1 AND ex$ <> "0" THEN a2$ = a2$ + "-" ELSE a2$ = a2$ + "+" a2$ = a2$ + ex$ - End If + END IF a2$ = a2$ + e$ - If extused Then a2$ = a2$ + "," + Mid$(a$, firsti, i - firsti) + IF extused THEN a2$ = a2$ + "," + MID$(a$, firsti, i - firsti) - GoTo lineformatnext - End If + GOTO lineformatnext + END IF '----------------(number)&H...---------------- 'note: the final value, not the number of hex characters, sets the default type - If c = 38 Then '& - If Mid$(a$, i + 1, 1) = "H" Then + IF c = 38 THEN '& + IF MID$(a$, i + 1, 1) = "H" THEN i = i + 2 hx$ = "" lfreadhex: - If i <= n Then - c$ = Mid$(a$, i, 1): c = Asc(c$) - If (c >= 48 And c <= 57) Or (c >= 65 And c <= 70) Then hx$ = hx$ + c$: i = i + 1: GoTo lfreadhex - End If + IF i <= n THEN + c$ = MID$(a$, i, 1): c = ASC(c$) + IF (c >= 48 AND c <= 57) OR (c >= 65 AND c <= 70) THEN hx$ = hx$ + c$: i = i + 1: GOTO lfreadhex + END IF fullhx$ = "&H" + hx$ 'cull leading 0s off hx$ - Do While Left$(hx$, 1) = "0": hx$ = Right$(hx$, Len(hx$) - 1): Loop - If hx$ = "" Then hx$ = "0" + DO WHILE LEFT$(hx$, 1) = "0": hx$ = RIGHT$(hx$, LEN(hx$) - 1): LOOP + IF hx$ = "" THEN hx$ = "0" bitn$ = "" '3-character extensions - If i <= n - 2 Then - e$ = Mid$(a$, i, 3) - If e$ = "~%%" Then i = i + 3: GoTo lfhxext - If e$ = "~&&" Then i = i + 3: GoTo lfhxext - If e$ = "~%&" Then Give_Error "Cannot use _OFFSET symbols after numbers": EXIT Function - End If + IF i <= n - 2 THEN + e$ = MID$(a$, i, 3) + IF e$ = "~%%" THEN i = i + 3: GOTO lfhxext + IF e$ = "~&&" THEN i = i + 3: GOTO lfhxext + IF e$ = "~%&" THEN Give_Error "Cannot use _OFFSET symbols after numbers": EXIT FUNCTION + END IF '2-character extensions - If i <= n - 1 Then - e$ = Mid$(a$, i, 2) - If e$ = "%%" Then i = i + 2: GoTo lfhxext - If e$ = "~%" Then i = i + 2: GoTo lfhxext - If e$ = "&&" Then i = i + 2: GoTo lfhxext - If e$ = "%&" Then Give_Error "Cannot use _OFFSET symbols after numbers": EXIT Function - If e$ = "~&" Then i = i + 2: GoTo lfhxext - If e$ = "~`" Then + IF i <= n - 1 THEN + e$ = MID$(a$, i, 2) + IF e$ = "%%" THEN i = i + 2: GOTO lfhxext + IF e$ = "~%" THEN i = i + 2: GOTO lfhxext + IF e$ = "&&" THEN i = i + 2: GOTO lfhxext + IF e$ = "%&" THEN Give_Error "Cannot use _OFFSET symbols after numbers": EXIT FUNCTION + IF e$ = "~&" THEN i = i + 2: GOTO lfhxext + IF e$ = "~`" THEN i = i + 2 - GoTo lfhxbitext - End If - End If + GOTO lfhxbitext + END IF + END IF '1-character extensions - If i <= n Then - e$ = Mid$(a$, i, 1) - If e$ = "%" Then i = i + 1: GoTo lfhxext - If e$ = "&" Then i = i + 1: GoTo lfhxext - If e$ = "`" Then + IF i <= n THEN + e$ = MID$(a$, i, 1) + IF e$ = "%" THEN i = i + 1: GOTO lfhxext + IF e$ = "&" THEN i = i + 1: GOTO lfhxext + IF e$ = "`" THEN i = i + 1 lfhxbitext: - Do While i <= n - c2 = Asc(Mid$(a$, i, 1)) - If c2 >= 48 And c2 <= 57 Then - bitn$ = bitn$ + Chr$(c2) + DO WHILE i <= n + c2 = ASC(MID$(a$, i, 1)) + IF c2 >= 48 AND c2 <= 57 THEN + bitn$ = bitn$ + CHR$(c2) i = i + 1 - Else - Exit Do - End If - Loop - If bitn$ = "" Then bitn$ = "1" + ELSE + EXIT DO + END IF + LOOP + IF bitn$ = "" THEN bitn$ = "1" 'cull leading 0s off bitn$ - Do While Left$(bitn$, 1) = "0": bitn$ = Right$(bitn$, Len(bitn$) - 1): Loop - GoTo lfhxext - End If - End If + DO WHILE LEFT$(bitn$, 1) = "0": bitn$ = RIGHT$(bitn$, LEN(bitn$) - 1): LOOP + GOTO lfhxext + END IF + END IF 'if no valid extension context was given, assume one 'note: leading 0s have been culled, so LEN(hx$) reflects its values size e$ = "&&" - If Len(hx$) <= 8 Then e$ = "&" 'as in QBASIC, signed values must be used - If Len(hx$) <= 4 Then e$ = "%" 'as in QBASIC, signed values must be used - GoTo lfhxext2 + IF LEN(hx$) <= 8 THEN e$ = "&" 'as in QBASIC, signed values must be used + IF LEN(hx$) <= 4 THEN e$ = "%" 'as in QBASIC, signed values must be used + GOTO lfhxext2 lfhxext: fullhx$ = fullhx$ + e$ + bitn$ lfhxext2: 'build 8-byte unsigned integer rep. of hx$ - If Len(hx$) > 16 Then Give_Error "Overflow": EXIT Function + IF LEN(hx$) > 16 THEN Give_Error "Overflow": EXIT FUNCTION v~&& = 0 - For i2 = 1 To Len(hx$) - v2 = Asc(Mid$(hx$, i2, 1)) - If v2 <= 57 Then v2 = v2 - 48 Else v2 = v2 - 65 + 10 + FOR i2 = 1 TO LEN(hx$) + v2 = ASC(MID$(hx$, i2, 1)) + IF v2 <= 57 THEN v2 = v2 - 48 ELSE v2 = v2 - 65 + 10 v~&& = v~&& * 16 + v2 - Next + NEXT finishhexoctbin: num$ = str2u64$(v~&&) 'correct for unsigned values (overflow of unsigned can be checked later) - If Left$(e$, 1) <> "~" Then 'note: range checking will be performed later in fixop.order + IF LEFT$(e$, 1) <> "~" THEN 'note: range checking will be performed later in fixop.order 'signed - If e$ = "%%" Then - If v~&& > 127 Then - If v~&& > 255 Then Give_Error "Overflow": EXIT Function - v~&& = ((Not v~&&) And 255) + 1 + IF e$ = "%%" THEN + IF v~&& > 127 THEN + IF v~&& > 255 THEN Give_Error "Overflow": EXIT FUNCTION + v~&& = ((NOT v~&&) AND 255) + 1 num$ = "-" + sp + str2u64$(v~&&) - End If - End If + END IF + END IF - If e$ = "%" Then - If v~&& > 32767 Then - If v~&& > 65535 Then Give_Error "Overflow": EXIT Function - v~&& = ((Not v~&&) And 65535) + 1 + IF e$ = "%" THEN + IF v~&& > 32767 THEN + IF v~&& > 65535 THEN Give_Error "Overflow": EXIT FUNCTION + v~&& = ((NOT v~&&) AND 65535) + 1 num$ = "-" + sp + str2u64$(v~&&) - End If - End If + END IF + END IF - If e$ = "&" Then - If v~&& > 2147483647 Then - If v~&& > 4294967295 Then Give_Error "Overflow": EXIT Function - v~&& = ((Not v~&&) And 4294967295) + 1 + IF e$ = "&" THEN + IF v~&& > 2147483647 THEN + IF v~&& > 4294967295 THEN Give_Error "Overflow": EXIT FUNCTION + v~&& = ((NOT v~&&) AND 4294967295) + 1 num$ = "-" + sp + str2u64$(v~&&) - End If - End If + END IF + END IF - If e$ = "&&" Then - If v~&& > 9223372036854775807 Then + IF e$ = "&&" THEN + IF v~&& > 9223372036854775807 THEN 'note: no error checking necessary - v~&& = (Not v~&&) + 1 + v~&& = (NOT v~&&) + 1 num$ = "-" + sp + str2u64$(v~&&) - End If - End If + END IF + END IF - If e$ = "`" Then - vbitn = Val(bitn$) - h~&& = 1: For i2 = 1 To vbitn - 1: h~&& = h~&& * 2: Next: h~&& = h~&& - 1 'build h~&& - If v~&& > h~&& Then - h~&& = 1: For i2 = 1 To vbitn: h~&& = h~&& * 2: Next: h~&& = h~&& - 1 'build h~&& - If v~&& > h~&& Then Give_Error "Overflow": EXIT Function - v~&& = ((Not v~&&) And h~&&) + 1 + IF e$ = "`" THEN + vbitn = VAL(bitn$) + h~&& = 1: FOR i2 = 1 TO vbitn - 1: h~&& = h~&& * 2: NEXT: h~&& = h~&& - 1 'build h~&& + IF v~&& > h~&& THEN + h~&& = 1: FOR i2 = 1 TO vbitn: h~&& = h~&& * 2: NEXT: h~&& = h~&& - 1 'build h~&& + IF v~&& > h~&& THEN Give_Error "Overflow": EXIT FUNCTION + v~&& = ((NOT v~&&) AND h~&&) + 1 num$ = "-" + sp + str2u64$(v~&&) - End If - End If + END IF + END IF - End If '<>"~" + END IF '<>"~" a2$ = a2$ + sp + num$ + e$ + bitn$ + "," + fullhx$ - GoTo lineformatnext - End If - End If + GOTO lineformatnext + END IF + END IF '----------------(number)&O...---------------- 'note: the final value, not the number of oct characters, sets the default type - If c = 38 Then '& - If Mid$(a$, i + 1, 1) = "O" Then + IF c = 38 THEN '& + IF MID$(a$, i + 1, 1) = "O" THEN i = i + 2 'note: to avoid mistakes, hx$ is used instead of 'ot$' hx$ = "" lfreadoct: - If i <= n Then - c$ = Mid$(a$, i, 1): c = Asc(c$) - If c >= 48 And c <= 55 Then hx$ = hx$ + c$: i = i + 1: GoTo lfreadoct - End If + IF i <= n THEN + c$ = MID$(a$, i, 1): c = ASC(c$) + IF c >= 48 AND c <= 55 THEN hx$ = hx$ + c$: i = i + 1: GOTO lfreadoct + END IF fullhx$ = "&O" + hx$ 'cull leading 0s off hx$ - Do While Left$(hx$, 1) = "0": hx$ = Right$(hx$, Len(hx$) - 1): Loop - If hx$ = "" Then hx$ = "0" + DO WHILE LEFT$(hx$, 1) = "0": hx$ = RIGHT$(hx$, LEN(hx$) - 1): LOOP + IF hx$ = "" THEN hx$ = "0" bitn$ = "" '3-character extensions - If i <= n - 2 Then - e$ = Mid$(a$, i, 3) - If e$ = "~%%" Then i = i + 3: GoTo lfotext - If e$ = "~&&" Then i = i + 3: GoTo lfotext - If e$ = "~%&" Then Give_Error "Cannot use _OFFSET symbols after numbers": EXIT Function - End If + IF i <= n - 2 THEN + e$ = MID$(a$, i, 3) + IF e$ = "~%%" THEN i = i + 3: GOTO lfotext + IF e$ = "~&&" THEN i = i + 3: GOTO lfotext + IF e$ = "~%&" THEN Give_Error "Cannot use _OFFSET symbols after numbers": EXIT FUNCTION + END IF '2-character extensions - If i <= n - 1 Then - e$ = Mid$(a$, i, 2) - If e$ = "%%" Then i = i + 2: GoTo lfotext - If e$ = "~%" Then i = i + 2: GoTo lfotext - If e$ = "&&" Then i = i + 2: GoTo lfotext - If e$ = "%&" Then Give_Error "Cannot use _OFFSET symbols after numbers": EXIT Function - If e$ = "~&" Then i = i + 2: GoTo lfotext - If e$ = "~`" Then + IF i <= n - 1 THEN + e$ = MID$(a$, i, 2) + IF e$ = "%%" THEN i = i + 2: GOTO lfotext + IF e$ = "~%" THEN i = i + 2: GOTO lfotext + IF e$ = "&&" THEN i = i + 2: GOTO lfotext + IF e$ = "%&" THEN Give_Error "Cannot use _OFFSET symbols after numbers": EXIT FUNCTION + IF e$ = "~&" THEN i = i + 2: GOTO lfotext + IF e$ = "~`" THEN i = i + 2 - GoTo lfotbitext - End If - End If + GOTO lfotbitext + END IF + END IF '1-character extensions - If i <= n Then - e$ = Mid$(a$, i, 1) - If e$ = "%" Then i = i + 1: GoTo lfotext - If e$ = "&" Then i = i + 1: GoTo lfotext - If e$ = "`" Then + IF i <= n THEN + e$ = MID$(a$, i, 1) + IF e$ = "%" THEN i = i + 1: GOTO lfotext + IF e$ = "&" THEN i = i + 1: GOTO lfotext + IF e$ = "`" THEN i = i + 1 lfotbitext: bitn$ = "" - Do While i <= n - c2 = Asc(Mid$(a$, i, 1)) - If c2 >= 48 And c2 <= 57 Then - bitn$ = bitn$ + Chr$(c2) + DO WHILE i <= n + c2 = ASC(MID$(a$, i, 1)) + IF c2 >= 48 AND c2 <= 57 THEN + bitn$ = bitn$ + CHR$(c2) i = i + 1 - Else - Exit Do - End If - Loop - If bitn$ = "" Then bitn$ = "1" + ELSE + EXIT DO + END IF + LOOP + IF bitn$ = "" THEN bitn$ = "1" 'cull leading 0s off bitn$ - Do While Left$(bitn$, 1) = "0": bitn$ = Right$(bitn$, Len(bitn$) - 1): Loop - GoTo lfotext - End If - End If + DO WHILE LEFT$(bitn$, 1) = "0": bitn$ = RIGHT$(bitn$, LEN(bitn$) - 1): LOOP + GOTO lfotext + END IF + END IF 'if no valid extension context was given, assume one 'note: leading 0s have been culled, so LEN(hx$) reflects its values size e$ = "&&" '37777777777 - If Len(hx$) <= 11 Then - If Len(hx$) < 11 Or Asc(Left$(hx$, 1)) <= 51 Then e$ = "&" - End If + IF LEN(hx$) <= 11 THEN + IF LEN(hx$) < 11 OR ASC(LEFT$(hx$, 1)) <= 51 THEN e$ = "&" + END IF '177777 - If Len(hx$) <= 6 Then - If Len(hx$) < 6 Or Left$(hx$, 1) = "1" Then e$ = "%" - End If + IF LEN(hx$) <= 6 THEN + IF LEN(hx$) < 6 OR LEFT$(hx$, 1) = "1" THEN e$ = "%" + END IF - GoTo lfotext2 + GOTO lfotext2 lfotext: fullhx$ = fullhx$ + e$ + bitn$ lfotext2: 'build 8-byte unsigned integer rep. of hx$ '1777777777777777777777 (22 digits) - If Len(hx$) > 22 Then Give_Error "Overflow": EXIT Function - If Len(hx$) = 22 Then - If Left$(hx$, 1) <> "1" Then Give_Error "Overflow": EXIT Function - End If + IF LEN(hx$) > 22 THEN Give_Error "Overflow": EXIT FUNCTION + IF LEN(hx$) = 22 THEN + IF LEFT$(hx$, 1) <> "1" THEN Give_Error "Overflow": EXIT FUNCTION + END IF '********change v& to v~&&******** v~&& = 0 - For i2 = 1 To Len(hx$) - v2 = Asc(Mid$(hx$, i2, 1)) + FOR i2 = 1 TO LEN(hx$) + v2 = ASC(MID$(hx$, i2, 1)) v2 = v2 - 48 v~&& = v~&& * 8 + v2 - Next + NEXT - GoTo finishhexoctbin - End If - End If + GOTO finishhexoctbin + END IF + END IF '----------------(number)&B...---------------- 'note: the final value, not the number of bin characters, sets the default type - If c = 38 Then '& - If Mid$(a$, i + 1, 1) = "B" Then + IF c = 38 THEN '& + IF MID$(a$, i + 1, 1) = "B" THEN i = i + 2 'note: to avoid mistakes, hx$ is used instead of 'bi$' hx$ = "" lfreadbin: - If i <= n Then - c$ = Mid$(a$, i, 1): c = Asc(c$) - If c >= 48 And c <= 49 Then hx$ = hx$ + c$: i = i + 1: GoTo lfreadbin - End If + IF i <= n THEN + c$ = MID$(a$, i, 1): c = ASC(c$) + IF c >= 48 AND c <= 49 THEN hx$ = hx$ + c$: i = i + 1: GOTO lfreadbin + END IF fullhx$ = "&B" + hx$ 'cull leading 0s off hx$ - Do While Left$(hx$, 1) = "0": hx$ = Right$(hx$, Len(hx$) - 1): Loop - If hx$ = "" Then hx$ = "0" + DO WHILE LEFT$(hx$, 1) = "0": hx$ = RIGHT$(hx$, LEN(hx$) - 1): LOOP + IF hx$ = "" THEN hx$ = "0" bitn$ = "" '3-character extensions - If i <= n - 2 Then - e$ = Mid$(a$, i, 3) - If e$ = "~%%" Then i = i + 3: GoTo lfbiext - If e$ = "~&&" Then i = i + 3: GoTo lfbiext - If e$ = "~%&" Then Give_Error "Cannot use _OFFSET symbols after numbers": EXIT Function - End If + IF i <= n - 2 THEN + e$ = MID$(a$, i, 3) + IF e$ = "~%%" THEN i = i + 3: GOTO lfbiext + IF e$ = "~&&" THEN i = i + 3: GOTO lfbiext + IF e$ = "~%&" THEN Give_Error "Cannot use _OFFSET symbols after numbers": EXIT FUNCTION + END IF '2-character extensions - If i <= n - 1 Then - e$ = Mid$(a$, i, 2) - If e$ = "%%" Then i = i + 2: GoTo lfbiext - If e$ = "~%" Then i = i + 2: GoTo lfbiext - If e$ = "&&" Then i = i + 2: GoTo lfbiext - If e$ = "%&" Then Give_Error "Cannot use _OFFSET symbols after numbers": EXIT Function - If e$ = "~&" Then i = i + 2: GoTo lfbiext - If e$ = "~`" Then + IF i <= n - 1 THEN + e$ = MID$(a$, i, 2) + IF e$ = "%%" THEN i = i + 2: GOTO lfbiext + IF e$ = "~%" THEN i = i + 2: GOTO lfbiext + IF e$ = "&&" THEN i = i + 2: GOTO lfbiext + IF e$ = "%&" THEN Give_Error "Cannot use _OFFSET symbols after numbers": EXIT FUNCTION + IF e$ = "~&" THEN i = i + 2: GOTO lfbiext + IF e$ = "~`" THEN i = i + 2 - GoTo lfbibitext - End If - End If + GOTO lfbibitext + END IF + END IF '1-character extensions - If i <= n Then - e$ = Mid$(a$, i, 1) - If e$ = "%" Then i = i + 1: GoTo lfbiext - If e$ = "&" Then i = i + 1: GoTo lfbiext - If e$ = "`" Then + IF i <= n THEN + e$ = MID$(a$, i, 1) + IF e$ = "%" THEN i = i + 1: GOTO lfbiext + IF e$ = "&" THEN i = i + 1: GOTO lfbiext + IF e$ = "`" THEN i = i + 1 lfbibitext: bitn$ = "" - Do While i <= n - c2 = Asc(Mid$(a$, i, 1)) - If c2 >= 48 And c2 <= 57 Then - bitn$ = bitn$ + Chr$(c2) + DO WHILE i <= n + c2 = ASC(MID$(a$, i, 1)) + IF c2 >= 48 AND c2 <= 57 THEN + bitn$ = bitn$ + CHR$(c2) i = i + 1 - Else - Exit Do - End If - Loop - If bitn$ = "" Then bitn$ = "1" + ELSE + EXIT DO + END IF + LOOP + IF bitn$ = "" THEN bitn$ = "1" 'cull leading 0s off bitn$ - Do While Left$(bitn$, 1) = "0": bitn$ = Right$(bitn$, Len(bitn$) - 1): Loop - GoTo lfbiext - End If - End If + DO WHILE LEFT$(bitn$, 1) = "0": bitn$ = RIGHT$(bitn$, LEN(bitn$) - 1): LOOP + GOTO lfbiext + END IF + END IF 'if no valid extension context was given, assume one 'note: leading 0s have been culled, so LEN(hx$) reflects its values size e$ = "&&" - If Len(hx$) <= 32 Then e$ = "&" - If Len(hx$) <= 16 Then e$ = "%" + IF LEN(hx$) <= 32 THEN e$ = "&" + IF LEN(hx$) <= 16 THEN e$ = "%" - GoTo lfbiext2 + GOTO lfbiext2 lfbiext: fullhx$ = fullhx$ + e$ + bitn$ lfbiext2: 'build 8-byte unsigned integer rep. of hx$ - If Len(hx$) > 64 Then Give_Error "Overflow": EXIT Function + IF LEN(hx$) > 64 THEN Give_Error "Overflow": EXIT FUNCTION v~&& = 0 - For i2 = 1 To Len(hx$) - v2 = Asc(Mid$(hx$, i2, 1)) + FOR i2 = 1 TO LEN(hx$) + v2 = ASC(MID$(hx$, i2, 1)) v2 = v2 - 48 v~&& = v~&& * 2 + v2 - Next + NEXT - GoTo finishhexoctbin - End If - End If + GOTO finishhexoctbin + END IF + END IF '----------------(number)&H??? error---------------- - If c = 38 Then Give_Error "Expected &H... or &O...": EXIT Function + IF c = 38 THEN Give_Error "Expected &H... or &O...": EXIT FUNCTION '----------------variable/name---------------- '*trailing _ is treated as a seperate line extension* - If (c >= 65 And c <= 90) Or c = 95 Then 'A-Z(a-z) or _ - If c = 95 Then p2 = 0 Else p2 = i - For i2 = i + 1 To n - c2 = Asc(a$, i2) - If Not alphanumeric(c2) Then Exit For - If c2 <> 95 Then p2 = i2 - Next - If p2 Then 'not just underscores! + IF (c >= 65 AND c <= 90) OR c = 95 THEN 'A-Z(a-z) or _ + IF c = 95 THEN p2 = 0 ELSE p2 = i + FOR i2 = i + 1 TO n + c2 = ASC(a$, i2) + IF NOT alphanumeric(c2) THEN EXIT FOR + IF c2 <> 95 THEN p2 = i2 + NEXT + IF p2 THEN 'not just underscores! 'char is from i to p2 n2 = p2 - i + 1 - a3$ = Mid$(a$, i, n2) + a3$ = MID$(a$, i, n2) '----(variable/name)rem---- - If n2 = 3 Then - If a3$ = "REM" Then + IF n2 = 3 THEN + IF a3$ = "REM" THEN i = i + n2 - If i < n Then - c = Asc(a$, i) - If c = 46 Then a2$ = a2$ + sp + Mid$(ca$, i - n2, n2): GoTo extcheck 'rem.Variable is a valid variable name in QB45 - End If + IF i < n THEN + c = ASC(a$, i) + IF c = 46 THEN a2$ = a2$ + sp + MID$(ca$, i - n2, n2): GOTO extcheck 'rem.Variable is a valid variable name in QB45 + END IF 'note: In QBASIC 'IF cond THEN REM comment' counts as a single line IF statement, however use of ' instead of REM does not - If UCase$(Right$(a2$, 5)) = sp + "THEN" Then a2$ = a2$ + sp + "'" 'add nop + IF UCASE$(RIGHT$(a2$, 5)) = sp + "THEN" THEN a2$ = a2$ + sp + "'" 'add nop layoutcomment = SCase$("Rem") - GoTo comment - End If - End If + GOTO comment + END IF + END IF '----(variable/name)data---- - If n2 = 4 Then - If a3$ = "DATA" Then + IF n2 = 4 THEN + IF a3$ = "DATA" THEN x$ = "" i = i + n2 - If i < n Then - c = Asc(a$, i) - If c = 46 Then a2$ = a2$ + sp + Mid$(ca$, i - n2, n2): GoTo extcheck 'data.Variable is a valid variable name in QB45 - End If + IF i < n THEN + c = ASC(a$, i) + IF c = 46 THEN a2$ = a2$ + sp + MID$(ca$, i - n2, n2): GOTO extcheck 'data.Variable is a valid variable name in QB45 + END IF scan = 0 speechmarks = 0 @@ -19995,36 +19995,36 @@ Function lineformat$ (a$) p1 = 0 p2 = 0 nextdatachr: - If i < n Then - c = Asc(a$, i) - If c = 9 Or c = 32 Then - If scan = 0 Then GoTo skipwhitespace - End If + IF i < n THEN + c = ASC(a$, i) + IF c = 9 OR c = 32 THEN + IF scan = 0 THEN GOTO skipwhitespace + END IF - If c = 58 Then '":" - If speechmarks = 0 Then finaldata = 1: GoTo adddata - End If + IF c = 58 THEN '":" + IF speechmarks = 0 THEN finaldata = 1: GOTO adddata + END IF - If c = 44 Then '"," - If speechmarks = 0 Then + IF c = 44 THEN '"," + IF speechmarks = 0 THEN adddata: - If prepass = 0 Then - If p1 Then + IF prepass = 0 THEN + IF p1 THEN 'FOR i2 = p1 TO p2 ' DATA_add ASC(ca$, i2) 'NEXT - x$ = x$ + Mid$(ca$, p1, p2 - p1 + 1) - End If + x$ = x$ + MID$(ca$, p1, p2 - p1 + 1) + END IF 'assume closing " - If speechmarks Then + IF speechmarks THEN 'DATA_add 34 - x$ = x$ + Chr$(34) - End If + x$ = x$ + CHR$(34) + END IF 'append comma 'DATA_add 44 - x$ = x$ + Chr$(44) - End If - If finaldata = 1 Then GoTo finisheddata + x$ = x$ + CHR$(44) + END IF + IF finaldata = 1 THEN GOTO finisheddata e$ = "" p1 = 0 p2 = 0 @@ -20032,237 +20032,237 @@ Function lineformat$ (a$) scan = 0 commanext = 0 i = i + 1 - GoTo nextdatachr - End If - End If '"," + GOTO nextdatachr + END IF + END IF '"," - If commanext = 1 Then - If c <> 32 And c <> 9 Then Give_Error "Expected , after quoted string in DATA statement": EXIT Function - End If + IF commanext = 1 THEN + IF c <> 32 AND c <> 9 THEN Give_Error "Expected , after quoted string in DATA statement": EXIT FUNCTION + END IF - If c = 34 Then - If speechmarks = 1 Then + IF c = 34 THEN + IF speechmarks = 1 THEN commanext = 1 speechmarks = 0 - End If - If scan = 0 Then speechmarks = 1 - End If + END IF + IF scan = 0 THEN speechmarks = 1 + END IF scan = 1 - If p1 = 0 Then p1 = i: p2 = i - If c <> 9 And c <> 32 Then p2 = i + IF p1 = 0 THEN p1 = i: p2 = i + IF c <> 9 AND c <> 32 THEN p2 = i skipwhitespace: - i = i + 1: GoTo nextdatachr - End If 'i 40 Then Give_Error "Identifier longer than 40 character limit": EXIT Function - c3 = Asc(a$, i) + IF n2 > 40 THEN Give_Error "Identifier longer than 40 character limit": EXIT FUNCTION + c3 = ASC(a$, i) m = 0 - If c3 = 126 Then '"~" - e2$ = Mid$(a$, i + 1, 2) - If e2$ = "&&" Then e2$ = "~&&": GoTo lfgetve - If e2$ = "%%" Then e2$ = "~%%": GoTo lfgetve - If e2$ = "%&" Then e2$ = "~%&": GoTo lfgetve - e2$ = Chr$(Asc(e2$)) - If e2$ = "&" Then e2$ = "~&": GoTo lfgetve - If e2$ = "%" Then e2$ = "~%": GoTo lfgetve - If e2$ = "`" Then m = 1: e2$ = "~`": GoTo lfgetve - End If - If c3 = 37 Then - c4 = Asc(a$, i + 1) - If c4 = 37 Then e2$ = "%%": GoTo lfgetve - If c4 = 38 Then e2$ = "%&": GoTo lfgetve - e2$ = "%": GoTo lfgetve - End If - If c3 = 38 Then - c4 = Asc(a$, i + 1) - If c4 = 38 Then e2$ = "&&": GoTo lfgetve - e2$ = "&": GoTo lfgetve - End If - If c3 = 33 Then e2$ = "!": GoTo lfgetve - If c3 = 35 Then - c4 = Asc(a$, i + 1) - If c4 = 35 Then e2$ = "##": GoTo lfgetve - e2$ = "#": GoTo lfgetve - End If - If c3 = 36 Then m = 1: e2$ = "$": GoTo lfgetve - If c3 = 96 Then m = 1: e2$ = "`": GoTo lfgetve + IF c3 = 126 THEN '"~" + e2$ = MID$(a$, i + 1, 2) + IF e2$ = "&&" THEN e2$ = "~&&": GOTO lfgetve + IF e2$ = "%%" THEN e2$ = "~%%": GOTO lfgetve + IF e2$ = "%&" THEN e2$ = "~%&": GOTO lfgetve + e2$ = CHR$(ASC(e2$)) + IF e2$ = "&" THEN e2$ = "~&": GOTO lfgetve + IF e2$ = "%" THEN e2$ = "~%": GOTO lfgetve + IF e2$ = "`" THEN m = 1: e2$ = "~`": GOTO lfgetve + END IF + IF c3 = 37 THEN + c4 = ASC(a$, i + 1) + IF c4 = 37 THEN e2$ = "%%": GOTO lfgetve + IF c4 = 38 THEN e2$ = "%&": GOTO lfgetve + e2$ = "%": GOTO lfgetve + END IF + IF c3 = 38 THEN + c4 = ASC(a$, i + 1) + IF c4 = 38 THEN e2$ = "&&": GOTO lfgetve + e2$ = "&": GOTO lfgetve + END IF + IF c3 = 33 THEN e2$ = "!": GOTO lfgetve + IF c3 = 35 THEN + c4 = ASC(a$, i + 1) + IF c4 = 35 THEN e2$ = "##": GOTO lfgetve + e2$ = "#": GOTO lfgetve + END IF + IF c3 = 36 THEN m = 1: e2$ = "$": GOTO lfgetve + IF c3 = 96 THEN m = 1: e2$ = "`": GOTO lfgetve '(no symbol) 'cater for unusual names/labels (eg a.0b%) - If Asc(a$, i) = 46 Then '"." - c2 = Asc(a$, i + 1) - If c2 >= 48 And c2 <= 57 Then + IF ASC(a$, i) = 46 THEN '"." + c2 = ASC(a$, i + 1) + IF c2 >= 48 AND c2 <= 57 THEN 'scan until no further alphanumerics p2 = i + 1 - For i2 = i + 2 To n - c = Asc(a$, i2) + FOR i2 = i + 2 TO n + c = ASC(a$, i2) - If Not alphanumeric(c) Then Exit For - If c <> 95 Then p2 = i2 'don't including trailing _ - Next - a2$ = a2$ + sp + "." + sp + Mid$(ca$, i + 1, p2 - (i + 1) + 1) 'case sensitive + IF NOT alphanumeric(c) THEN EXIT FOR + IF c <> 95 THEN p2 = i2 'don't including trailing _ + NEXT + a2$ = a2$ + sp + "." + sp + MID$(ca$, i + 1, p2 - (i + 1) + 1) 'case sensitive n2 = n2 + 1 + (p2 - (i + 1) + 1) i = p2 + 1 - GoTo extcheck 'it may have an extension or be continued with another "." - End If - End If + GOTO extcheck 'it may have an extension or be continued with another "." + END IF + END IF - GoTo lineformatnext + GOTO lineformatnext lfgetve: - i = i + Len(e2$) + i = i + LEN(e2$) a2$ = a2$ + e2$ - If m Then 'allow digits after symbol + IF m THEN 'allow digits after symbol lfgetvd: - If i < n Then - c = Asc(a$, i) - If c >= 48 And c <= 57 Then a2$ = a2$ + Chr$(c): i = i + 1: GoTo lfgetvd - End If - End If 'm + IF i < n THEN + c = ASC(a$, i) + IF c >= 48 AND c <= 57 THEN a2$ = a2$ + CHR$(c): i = i + 1: GOTO lfgetvd + END IF + END IF 'm - GoTo lineformatnext + GOTO lineformatnext - End If 'p2 - End If 'variable/name + END IF 'p2 + END IF 'variable/name '----------------variable/name end---------------- '----------------spacing---------------- - If c = 32 Or c = 9 Then i = i + 1: GoTo lineformatnext + IF c = 32 OR c = 9 THEN i = i + 1: GOTO lineformatnext '----------------symbols---------------- '--------single characters-------- - If lfsinglechar(c) Then - If (c = 60) Or (c = 61) Or (c = 62) Then + IF lfsinglechar(c) THEN + IF (c = 60) OR (c = 61) OR (c = 62) THEN count = 0 - Do + DO count = count + 1 - If i + count >= Len(a$) - 2 Then Exit Do - Loop Until Asc(a$, i + count) <> 32 - c2 = Asc(a$, i + count) - If c = 60 Then '< - If c2 = 61 Then a2$ = a2$ + sp + "<=": i = i + count + 1: GoTo lineformatnext - If c2 = 62 Then a2$ = a2$ + sp + "<>": i = i + count + 1: GoTo lineformatnext - ElseIf c = 62 Then '> - If c2 = 61 Then a2$ = a2$ + sp + ">=": i = i + count + 1: GoTo lineformatnext - If c2 = 60 Then a2$ = a2$ + sp + "<>": i = i + count + 1: GoTo lineformatnext '>< to <> - ElseIf c = 61 Then '= - If c2 = 62 Then a2$ = a2$ + sp + ">=": i = i + count + 1: GoTo lineformatnext '=> to >= - If c2 = 60 Then a2$ = a2$ + sp + "<=": i = i + count + 1: GoTo lineformatnext '=< to <= - End If - End If + IF i + count >= LEN(a$) - 2 THEN EXIT DO + LOOP UNTIL ASC(a$, i + count) <> 32 + c2 = ASC(a$, i + count) + IF c = 60 THEN '< + IF c2 = 61 THEN a2$ = a2$ + sp + "<=": i = i + count + 1: GOTO lineformatnext + IF c2 = 62 THEN a2$ = a2$ + sp + "<>": i = i + count + 1: GOTO lineformatnext + ELSEIF c = 62 THEN '> + IF c2 = 61 THEN a2$ = a2$ + sp + ">=": i = i + count + 1: GOTO lineformatnext + IF c2 = 60 THEN a2$ = a2$ + sp + "<>": i = i + count + 1: GOTO lineformatnext '>< to <> + ELSEIF c = 61 THEN '= + IF c2 = 62 THEN a2$ = a2$ + sp + ">=": i = i + count + 1: GOTO lineformatnext '=> to >= + IF c2 = 60 THEN a2$ = a2$ + sp + "<=": i = i + count + 1: GOTO lineformatnext '=< to <= + END IF + END IF - If c = 36 And Len(a2$) Then GoTo badusage '$ + IF c = 36 AND LEN(a2$) THEN GOTO badusage '$ - a2$ = a2$ + sp + Chr$(c) + a2$ = a2$ + sp + CHR$(c) i = i + 1 - GoTo lineformatnext - End If + GOTO lineformatnext + END IF badusage: - If c <> 39 Then Give_Error "Unexpected character on line": EXIT Function 'invalid symbol encountered + IF c <> 39 THEN Give_Error "Unexpected character on line": EXIT FUNCTION 'invalid symbol encountered '----------------comment(')---------------- layoutcomment = "'" i = i + 1 comment: - If i >= n Then GoTo lineformatdone2 - c$ = Right$(a$, Len(a$) - i + 1) - cc$ = Right$(ca$, Len(ca$) - i + 1) - If Len(c$) = 0 Then GoTo lineformatdone2 - layoutcomment$ = RTrim$(layoutcomment$ + cc$) + IF i >= n THEN GOTO lineformatdone2 + c$ = RIGHT$(a$, LEN(a$) - i + 1) + cc$ = RIGHT$(ca$, LEN(ca$) - i + 1) + IF LEN(c$) = 0 THEN GOTO lineformatdone2 + layoutcomment$ = RTRIM$(layoutcomment$ + cc$) - c$ = LTrim$(c$) - If Len(c$) = 0 Then GoTo lineformatdone2 - ac = Asc(c$) - If ac <> 36 Then GoTo lineformatdone2 - nocasec$ = LTrim$(Right$(ca$, Len(ca$) - i + 1)) + c$ = LTRIM$(c$) + IF LEN(c$) = 0 THEN GOTO lineformatdone2 + ac = ASC(c$) + IF ac <> 36 THEN GOTO lineformatdone2 + nocasec$ = LTRIM$(RIGHT$(ca$, LEN(ca$) - i + 1)) memmode = 0 - For x = 1 To Len(c$) + FOR x = 1 TO LEN(c$) mcnext: - If Mid$(c$, x, 1) = "$" Then + IF MID$(c$, x, 1) = "$" THEN 'note: $STATICksdcdweh$DYNAMIC is valid! - If Mid$(c$, x, 7) = "$STATIC" Then + IF MID$(c$, x, 7) = "$STATIC" THEN memmode = 1 - xx = InStr(x + 1, c$, "$") + xx = INSTR(x + 1, c$, "$") if xx=0 then exit for else - x = xx: GoTo mcnext - End If + x = xx: GOTO mcnext + END IF - If Mid$(c$, x, 8) = "$DYNAMIC" Then + IF MID$(c$, x, 8) = "$DYNAMIC" THEN memmode = 2 - xx = InStr(x + 1, c$, "$") - If xx = 0 Then Exit For - x = xx: GoTo mcnext - End If + xx = INSTR(x + 1, c$, "$") + IF xx = 0 THEN EXIT FOR + x = xx: GOTO mcnext + END IF - If Mid$(c$, x, 8) = "$INCLUDE" Then + IF MID$(c$, x, 8) = "$INCLUDE" THEN 'note: INCLUDE adds the file AFTER the line it is on has been processed 'note: No other metacommands can follow the INCLUDE metacommand! 'skip spaces until : - For xx = x + 8 To Len(c$) - ac = Asc(Mid$(c$, xx, 1)) - If ac = 58 Then Exit For ': - If ac <> 32 And ac <> 9 Then Give_Error "Expected $INCLUDE:'filename'": EXIT Function - Next + FOR xx = x + 8 TO LEN(c$) + ac = ASC(MID$(c$, xx, 1)) + IF ac = 58 THEN EXIT FOR ': + IF ac <> 32 AND ac <> 9 THEN Give_Error "Expected $INCLUDE:'filename'": EXIT FUNCTION + NEXT x = xx 'skip spaces until ' - For xx = x + 1 To Len(c$) - ac = Asc(Mid$(c$, xx, 1)) - If ac = 39 Then Exit For 'character:' - If ac <> 32 And ac <> 9 Then Give_Error "Expected $INCLUDE:'filename'": EXIT Function - Next + FOR xx = x + 1 TO LEN(c$) + ac = ASC(MID$(c$, xx, 1)) + IF ac = 39 THEN EXIT FOR 'character:' + IF ac <> 32 AND ac <> 9 THEN Give_Error "Expected $INCLUDE:'filename'": EXIT FUNCTION + NEXT x = xx - xx = InStr(x + 1, c$, "'") - If xx = 0 Then Give_Error "Expected $INCLUDE:'filename'": EXIT Function - addmetainclude$ = Mid$(nocasec$, x + 1, xx - x - 1) - If addmetainclude$ = "" Then Give_Error "Expected $INCLUDE:'filename'": EXIT Function - GoTo mcfinal - End If + xx = INSTR(x + 1, c$, "'") + IF xx = 0 THEN Give_Error "Expected $INCLUDE:'filename'": EXIT FUNCTION + addmetainclude$ = MID$(nocasec$, x + 1, xx - x - 1) + IF addmetainclude$ = "" THEN Give_Error "Expected $INCLUDE:'filename'": EXIT FUNCTION + GOTO mcfinal + END IF 'add more metacommands here - End If '$ - Next + END IF '$ + NEXT mcfinal: - If memmode = 1 Then addmetastatic = 1 - If memmode = 2 Then addmetadynamic = 1 + IF memmode = 1 THEN addmetastatic = 1 + IF memmode = 2 THEN addmetadynamic = 1 - GoTo lineformatdone2 + GOTO lineformatdone2 @@ -20270,77 +20270,77 @@ Function lineformat$ (a$) 'line continuation? 'note: line continuation in idemode is illegal - If Len(a2$) Then - If Right$(a2$, 1) = "_" Then + IF LEN(a2$) THEN + IF RIGHT$(a2$, 1) = "_" THEN linecontinuation = 1 'avoids auto-format glitches layout$ = "" 'remove _ from the end of the building string - If Len(a2$) >= 2 Then - If Right$(a2$, 2) = sp + "_" Then a2$ = Left$(a2$, Len(a2$) - 1) - End If - a2$ = Left$(a2$, Len(a2$) - 1) + IF LEN(a2$) >= 2 THEN + IF RIGHT$(a2$, 2) = sp + "_" THEN a2$ = LEFT$(a2$, LEN(a2$) - 1) + END IF + a2$ = LEFT$(a2$, LEN(a2$) - 1) - If inclevel Then + IF inclevel THEN fh = 99 + inclevel - If EOF(fh) Then GoTo lineformatdone2 - Line Input #fh, a$ + IF EOF(fh) THEN GOTO lineformatdone2 + LINE INPUT #fh, a$ inclinenumber(inclevel) = inclinenumber(inclevel) + 1 - GoTo includecont 'note: should not increase linenumber - End If + GOTO includecont 'note: should not increase linenumber + END IF - If idemode Then - idecommand$ = Chr$(100) + IF idemode THEN + idecommand$ = CHR$(100) ignore = ide(0) ideerror = 0 a$ = idereturn$ - If a$ = "" Then GoTo lineformatdone2 - Else + IF a$ = "" THEN GOTO lineformatdone2 + ELSE a$ = lineinput3$ - If a$ = Chr$(13) Then GoTo lineformatdone2 - End If + IF a$ = CHR$(13) THEN GOTO lineformatdone2 + END IF linenumber = linenumber + 1 includecont: contline = 1 - GoTo continueline - End If - End If + GOTO continueline + END IF + END IF lineformatdone2: - If Left$(a2$, 1) = sp Then a2$ = Right$(a2$, Len(a2$) - 1) + IF LEFT$(a2$, 1) = sp THEN a2$ = RIGHT$(a2$, LEN(a2$) - 1) 'fix for trailing : error - If Right$(a2$, 1) = ":" Then a2$ = a2$ + sp + "'" 'add nop + IF RIGHT$(a2$, 1) = ":" THEN a2$ = a2$ + sp + "'" 'add nop - If Debug Then Print #9, "lineformat():return:" + a2$ - If Error_Happened Then EXIT Function + IF Debug THEN PRINT #9, "lineformat():return:" + a2$ + IF Error_Happened THEN EXIT FUNCTION lineformat$ = a2$ -End Function +END FUNCTION -Sub makeidrefer (ref$, typ As Long) +SUB makeidrefer (ref$, typ AS LONG) ref$ = str2$(currentid) typ = id.t + ISREFERENCE -End Sub +END SUB -Function numelements (a$) - If a$ = "" Then EXIT Function +FUNCTION numelements (a$) + IF a$ = "" THEN EXIT FUNCTION n = 1 p = 1 numelementsnext: - i = InStr(p, a$, sp) - If i = 0 Then numelements = n: EXIT Function + i = INSTR(p, a$, sp) + IF i = 0 THEN numelements = n: EXIT FUNCTION n = n + 1 p = i + 1 - GoTo numelementsnext -End Function + GOTO numelementsnext +END FUNCTION -Function operatorusage (operator$, typ As Long, info$, lhs As Long, rhs As Long, result As Long) +FUNCTION operatorusage (operator$, typ AS LONG, info$, lhs AS LONG, rhs AS LONG, result AS LONG) lhs = 7: rhs = 7: result = 0 'return values '1 = use info$ as the operator without any other changes @@ -20357,70 +20357,70 @@ Function operatorusage (operator$, typ As Long, info$, lhs As Long, rhs As Long, '8=bool 'string operator - If (typ And ISSTRING) Then + IF (typ AND ISSTRING) THEN lhs = 4: rhs = 4 result = 4 - If operator$ = "+" Then info$ = "qbs_add": operatorusage = 2: EXIT Function + IF operator$ = "+" THEN info$ = "qbs_add": operatorusage = 2: EXIT FUNCTION result = 8 - If operator$ = "=" Then info$ = "qbs_equal": operatorusage = 2: EXIT Function - If operator$ = "<>" Then info$ = "qbs_notequal": operatorusage = 2: EXIT Function - If operator$ = ">" Then info$ = "qbs_greaterthan": operatorusage = 2: EXIT Function - If operator$ = "<" Then info$ = "qbs_lessthan": operatorusage = 2: EXIT Function - If operator$ = ">=" Then info$ = "qbs_greaterorequal": operatorusage = 2: EXIT Function - If operator$ = "<=" Then info$ = "qbs_lessorequal": operatorusage = 2: EXIT Function - If Debug Then Print #9, "INVALID STRING OPERATOR!": End - End If + IF operator$ = "=" THEN info$ = "qbs_equal": operatorusage = 2: EXIT FUNCTION + IF operator$ = "<>" THEN info$ = "qbs_notequal": operatorusage = 2: EXIT FUNCTION + IF operator$ = ">" THEN info$ = "qbs_greaterthan": operatorusage = 2: EXIT FUNCTION + IF operator$ = "<" THEN info$ = "qbs_lessthan": operatorusage = 2: EXIT FUNCTION + IF operator$ = ">=" THEN info$ = "qbs_greaterorequal": operatorusage = 2: EXIT FUNCTION + IF operator$ = "<=" THEN info$ = "qbs_lessorequal": operatorusage = 2: EXIT FUNCTION + IF Debug THEN PRINT #9, "INVALID STRING OPERATOR!": END + END IF 'assume numeric operator lhs = 1 + 2: rhs = 1 + 2 - If operator$ = "^" Then result = 2: info$ = "pow2": operatorusage = 2: EXIT Function - If operator$ = Chr$(241) Then info$ = "-": operatorusage = 5: EXIT Function - If operator$ = "/" Then + IF operator$ = "^" THEN result = 2: info$ = "pow2": operatorusage = 2: EXIT FUNCTION + IF operator$ = CHR$(241) THEN info$ = "-": operatorusage = 5: EXIT FUNCTION + IF operator$ = "/" THEN info$ = "/ ": operatorusage = 1 'for / division, either the lhs or the rhs must be a float to make 'c++ return a result in floating point form - If (typ And ISFLOAT) Then + IF (typ AND ISFLOAT) THEN 'lhs is a float lhs = 2 rhs = 1 + 2 - Else + ELSE 'lhs isn't a float! lhs = 1 + 2 rhs = 2 - End If + END IF result = 2 - EXIT Function - End If - If operator$ = "*" Then info$ = "*": operatorusage = 1: EXIT Function - If operator$ = "+" Then info$ = "+": operatorusage = 1: EXIT Function - If operator$ = "-" Then info$ = "-": operatorusage = 1: EXIT Function + EXIT FUNCTION + END IF + IF operator$ = "*" THEN info$ = "*": operatorusage = 1: EXIT FUNCTION + IF operator$ = "+" THEN info$ = "+": operatorusage = 1: EXIT FUNCTION + IF operator$ = "-" THEN info$ = "-": operatorusage = 1: EXIT FUNCTION result = 8 - If operator$ = "=" Then info$ = "==": operatorusage = 3: EXIT Function - If operator$ = ">" Then info$ = ">": operatorusage = 3: EXIT Function - If operator$ = "<" Then info$ = "<": operatorusage = 3: EXIT Function - If operator$ = "<>" Then info$ = "!=": operatorusage = 3: EXIT Function - If operator$ = "<=" Then info$ = "<=": operatorusage = 3: EXIT Function - If operator$ = ">=" Then info$ = ">=": operatorusage = 3: EXIT Function + IF operator$ = "=" THEN info$ = "==": operatorusage = 3: EXIT FUNCTION + IF operator$ = ">" THEN info$ = ">": operatorusage = 3: EXIT FUNCTION + IF operator$ = "<" THEN info$ = "<": operatorusage = 3: EXIT FUNCTION + IF operator$ = "<>" THEN info$ = "!=": operatorusage = 3: EXIT FUNCTION + IF operator$ = "<=" THEN info$ = "<=": operatorusage = 3: EXIT FUNCTION + IF operator$ = ">=" THEN info$ = ">=": operatorusage = 3: EXIT FUNCTION lhs = 1: rhs = 1: result = 1 - operator$ = UCase$(operator$) - If operator$ = "MOD" Then info$ = "%": operatorusage = 1: EXIT Function - If operator$ = "\" Then info$ = "/ ": operatorusage = 1: EXIT Function - If operator$ = "IMP" Then info$ = "|": operatorusage = 4: EXIT Function - If operator$ = "EQV" Then info$ = "^": operatorusage = 4: EXIT Function - If operator$ = "XOR" Then info$ = "^": operatorusage = 1: EXIT Function - If operator$ = "OR" Then info$ = "|": operatorusage = 1: EXIT Function - If operator$ = "AND" Then info$ = "&": operatorusage = 1: EXIT Function + operator$ = UCASE$(operator$) + IF operator$ = "MOD" THEN info$ = "%": operatorusage = 1: EXIT FUNCTION + IF operator$ = "\" THEN info$ = "/ ": operatorusage = 1: EXIT FUNCTION + IF operator$ = "IMP" THEN info$ = "|": operatorusage = 4: EXIT FUNCTION + IF operator$ = "EQV" THEN info$ = "^": operatorusage = 4: EXIT FUNCTION + IF operator$ = "XOR" THEN info$ = "^": operatorusage = 1: EXIT FUNCTION + IF operator$ = "OR" THEN info$ = "|": operatorusage = 1: EXIT FUNCTION + IF operator$ = "AND" THEN info$ = "&": operatorusage = 1: EXIT FUNCTION lhs = 7 - If operator$ = "NOT" Then info$ = "~": operatorusage = 5: EXIT Function + IF operator$ = "NOT" THEN info$ = "~": operatorusage = 5: EXIT FUNCTION - If Debug Then Print #9, "INVALID NUMBERIC OPERATOR!": End + IF Debug THEN PRINT #9, "INVALID NUMBERIC OPERATOR!": END -End Function +END FUNCTION -Function refer$ (a2$, typ As Long, method As Long) +FUNCTION refer$ (a2$, typ AS LONG, method AS LONG) typbak = typ 'method: 0 return an equation which calculates the value of the "variable" ' 1 return the C name of the variable, typ will be left unchanged @@ -20428,202 +20428,202 @@ Function refer$ (a2$, typ As Long, method As Long) a$ = a2$ 'retrieve ID - i = InStr(a$, sp3) - If i Then - idnumber = Val(Left$(a$, i - 1)): a$ = Right$(a$, Len(a$) - i) - Else - idnumber = Val(a$) - End If + i = INSTR(a$, sp3) + IF i THEN + idnumber = VAL(LEFT$(a$, i - 1)): a$ = RIGHT$(a$, LEN(a$) - i) + ELSE + idnumber = VAL(a$) + END IF getid idnumber - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION 'UDT? - If typ And ISUDT Then - If method = 1 Then - n$ = "UDT_" + RTrim$(id.n) - If id.t = 0 Then n$ = "ARRAY_" + n$ + IF typ AND ISUDT THEN + IF method = 1 THEN + n$ = "UDT_" + RTRIM$(id.n) + IF id.t = 0 THEN n$ = "ARRAY_" + n$ n$ = scope$ + n$ refer$ = n$ - EXIT Function - End If + EXIT FUNCTION + END IF 'print "UDTSUBSTRING[idX|u|e|o]:"+a$ - u = Val(a$) - i = InStr(a$, sp3): a$ = Right$(a$, Len(a$) - i): E = Val(a$) - i = InStr(a$, sp3): o$ = Right$(a$, Len(a$) - i) - n$ = "UDT_" + RTrim$(id.n): If id.t = 0 Then n$ = "ARRAY_" + n$ + "[0]" - If E = 0 Then Give_Error "User defined types in expressions are invalid": EXIT Function - If typ And ISOFFSETINBITS Then Give_Error "Cannot resolve bit-length variables inside user defined types yet": EXIT Function + u = VAL(a$) + i = INSTR(a$, sp3): a$ = RIGHT$(a$, LEN(a$) - i): E = VAL(a$) + i = INSTR(a$, sp3): o$ = RIGHT$(a$, LEN(a$) - i) + n$ = "UDT_" + RTRIM$(id.n): IF id.t = 0 THEN n$ = "ARRAY_" + n$ + "[0]" + IF E = 0 THEN Give_Error "User defined types in expressions are invalid": EXIT FUNCTION + IF typ AND ISOFFSETINBITS THEN Give_Error "Cannot resolve bit-length variables inside user defined types yet": EXIT FUNCTION - If typ And ISSTRING Then - If typ And ISFIXEDLENGTH Then + IF typ AND ISSTRING THEN + IF typ AND ISFIXEDLENGTH THEN o2$ = "(((uint8*)" + scope$ + n$ + ")+(" + o$ + "))" r$ = "qbs_new_fixed(" + o2$ + "," + str2(udtetypesize(E)) + ",1)" typ = STRINGTYPE + ISFIXEDLENGTH 'ISPOINTER retained, it is still a pointer! - Else + ELSE r$ = "*((qbs**)((char*)" + scope$ + n$ + "+(" + o$ + ")))" typ = STRINGTYPE - End If - Else + END IF + ELSE typ = typ - ISUDT - ISREFERENCE - ISPOINTER - If typ And ISARRAY Then typ = typ - ISARRAY + IF typ AND ISARRAY THEN typ = typ - ISARRAY t$ = typ2ctyp$(typ, "") - If Error_Happened Then EXIT Function + IF Error_Happened THEN EXIT FUNCTION o2$ = "(((char*)" + scope$ + n$ + ")+(" + o$ + "))" r$ = "*" + "(" + t$ + "*)" + o2$ - End If + END IF 'print "REFER:"+r$+","+str2$(typ) refer$ = r$ - EXIT Function - End If + EXIT FUNCTION + END IF 'array? - If id.arraytype Then + IF id.arraytype THEN - n$ = RTrim$(id.callname) - If method = 1 Then + n$ = RTRIM$(id.callname) + IF method = 1 THEN refer$ = n$ typ = typbak - EXIT Function - End If + EXIT FUNCTION + END IF typ = typ - ISPOINTER - ISREFERENCE 'typ now looks like a regular value - If (typ And ISSTRING) Then - If (typ And ISFIXEDLENGTH) Then + IF (typ AND ISSTRING) THEN + IF (typ AND ISFIXEDLENGTH) THEN offset$ = "&((uint8*)(" + n$ + "[0]))[(" + a$ + ")*" + str2(id.tsize) + "]" r$ = "qbs_new_fixed(" + offset$ + "," + str2(id.tsize) + ",1)" - Else + ELSE r$ = "((qbs*)(((uint64*)(" + n$ + "[0]))[" + a$ + "]))" - End If + END IF stringprocessinghappened = 1 refer$ = r$ - EXIT Function - End If + EXIT FUNCTION + END IF - If (typ And ISOFFSETINBITS) Then + IF (typ AND ISOFFSETINBITS) THEN 'IF (typ AND ISUNSIGNED) THEN r$ = "getubits_" ELSE r$ = "getbits_" 'r$ = r$ + str2(typ AND 511) + "(" - If (typ And ISUNSIGNED) Then r$ = "getubits" Else r$ = "getbits" - r$ = r$ + "(" + str2(typ And 511) + "," + IF (typ AND ISUNSIGNED) THEN r$ = "getubits" ELSE r$ = "getbits" + r$ = r$ + "(" + str2(typ AND 511) + "," r$ = r$ + "(uint8*)(" + n$ + "[0])" + "," r$ = r$ + a$ + ")" refer$ = r$ - EXIT Function - Else + EXIT FUNCTION + ELSE t$ = "" - If (typ And ISFLOAT) Then - If (typ And 511) = 32 Then t$ = "float" - If (typ And 511) = 64 Then t$ = "double" - If (typ And 511) = 256 Then t$ = "long double" - Else - If (typ And ISUNSIGNED) Then - If (typ And 511) = 8 Then t$ = "uint8" - If (typ And 511) = 16 Then t$ = "uint16" - If (typ And 511) = 32 Then t$ = "uint32" - If (typ And 511) = 64 Then t$ = "uint64" - If typ And ISOFFSET Then t$ = "uptrszint" - Else - If (typ And 511) = 8 Then t$ = "int8" - If (typ And 511) = 16 Then t$ = "int16" - If (typ And 511) = 32 Then t$ = "int32" - If (typ And 511) = 64 Then t$ = "int64" - If typ And ISOFFSET Then t$ = "ptrszint" - End If - End If - End If - If t$ = "" Then Give_Error "Cannot find C type to return array data": EXIT Function + IF (typ AND ISFLOAT) THEN + IF (typ AND 511) = 32 THEN t$ = "float" + IF (typ AND 511) = 64 THEN t$ = "double" + IF (typ AND 511) = 256 THEN t$ = "long double" + ELSE + IF (typ AND ISUNSIGNED) THEN + IF (typ AND 511) = 8 THEN t$ = "uint8" + IF (typ AND 511) = 16 THEN t$ = "uint16" + IF (typ AND 511) = 32 THEN t$ = "uint32" + IF (typ AND 511) = 64 THEN t$ = "uint64" + IF typ AND ISOFFSET THEN t$ = "uptrszint" + ELSE + IF (typ AND 511) = 8 THEN t$ = "int8" + IF (typ AND 511) = 16 THEN t$ = "int16" + IF (typ AND 511) = 32 THEN t$ = "int32" + IF (typ AND 511) = 64 THEN t$ = "int64" + IF typ AND ISOFFSET THEN t$ = "ptrszint" + END IF + END IF + END IF + IF t$ = "" THEN Give_Error "Cannot find C type to return array data": EXIT FUNCTION r$ = "((" + t$ + "*)(" + n$ + "[0]))[" + a$ + "]" refer$ = r$ - EXIT Function - End If 'array + EXIT FUNCTION + END IF 'array 'variable? - If id.t Then - r$ = RTrim$(id.n) + IF id.t THEN + r$ = RTRIM$(id.n) t = id.t 'remove irrelavant flags - If (t And ISINCONVENTIONALMEMORY) Then t = t - ISINCONVENTIONALMEMORY + IF (t AND ISINCONVENTIONALMEMORY) THEN t = t - ISINCONVENTIONALMEMORY 'string? - If (t And ISSTRING) Then - If (t And ISFIXEDLENGTH) Then - r$ = scope$ + "STRING" + str2(id.tsize) + "_" + r$: GoTo ref - End If - r$ = scope$ + "STRING_" + r$: GoTo ref - End If + IF (t AND ISSTRING) THEN + IF (t AND ISFIXEDLENGTH) THEN + r$ = scope$ + "STRING" + str2(id.tsize) + "_" + r$: GOTO ref + END IF + r$ = scope$ + "STRING_" + r$: GOTO ref + END IF 'bit-length single variable? - If (t And ISOFFSETINBITS) Then - If (t And ISUNSIGNED) Then - r$ = "*" + scope$ + "UBIT" + str2(t And 511) + "_" + r$ - Else - r$ = "*" + scope$ + "BIT" + str2(t And 511) + "_" + r$ - End If - GoTo ref - End If - If t = BYTETYPE Then r$ = "*" + scope$ + "BYTE_" + r$: GoTo ref - If t = UBYTETYPE Then r$ = "*" + scope$ + "UBYTE_" + r$: GoTo ref - If t = INTEGERTYPE Then r$ = "*" + scope$ + "INTEGER_" + r$: GoTo ref - If t = UINTEGERTYPE Then r$ = "*" + scope$ + "UINTEGER_" + r$: GoTo ref - If t = LONGTYPE Then r$ = "*" + scope$ + "LONG_" + r$: GoTo ref - If t = ULONGTYPE Then r$ = "*" + scope$ + "ULONG_" + r$: GoTo ref - If t = INTEGER64TYPE Then r$ = "*" + scope$ + "INTEGER64_" + r$: GoTo ref - If t = UINTEGER64TYPE Then r$ = "*" + scope$ + "UINTEGER64_" + r$: GoTo ref - If t = SINGLETYPE Then r$ = "*" + scope$ + "SINGLE_" + r$: GoTo ref - If t = DOUBLETYPE Then r$ = "*" + scope$ + "DOUBLE_" + r$: GoTo ref - If t = FLOATTYPE Then r$ = "*" + scope$ + "FLOAT_" + r$: GoTo ref - If t = OFFSETTYPE Then r$ = "*" + scope$ + "OFFSET_" + r$: GoTo ref - If t = UOFFSETTYPE Then r$ = "*" + scope$ + "UOFFSET_" + r$: GoTo ref + IF (t AND ISOFFSETINBITS) THEN + IF (t AND ISUNSIGNED) THEN + r$ = "*" + scope$ + "UBIT" + str2(t AND 511) + "_" + r$ + ELSE + r$ = "*" + scope$ + "BIT" + str2(t AND 511) + "_" + r$ + END IF + GOTO ref + END IF + IF t = BYTETYPE THEN r$ = "*" + scope$ + "BYTE_" + r$: GOTO ref + IF t = UBYTETYPE THEN r$ = "*" + scope$ + "UBYTE_" + r$: GOTO ref + IF t = INTEGERTYPE THEN r$ = "*" + scope$ + "INTEGER_" + r$: GOTO ref + IF t = UINTEGERTYPE THEN r$ = "*" + scope$ + "UINTEGER_" + r$: GOTO ref + IF t = LONGTYPE THEN r$ = "*" + scope$ + "LONG_" + r$: GOTO ref + IF t = ULONGTYPE THEN r$ = "*" + scope$ + "ULONG_" + r$: GOTO ref + IF t = INTEGER64TYPE THEN r$ = "*" + scope$ + "INTEGER64_" + r$: GOTO ref + IF t = UINTEGER64TYPE THEN r$ = "*" + scope$ + "UINTEGER64_" + r$: GOTO ref + IF t = SINGLETYPE THEN r$ = "*" + scope$ + "SINGLE_" + r$: GOTO ref + IF t = DOUBLETYPE THEN r$ = "*" + scope$ + "DOUBLE_" + r$: GOTO ref + IF t = FLOATTYPE THEN r$ = "*" + scope$ + "FLOAT_" + r$: GOTO ref + IF t = OFFSETTYPE THEN r$ = "*" + scope$ + "OFFSET_" + r$: GOTO ref + IF t = UOFFSETTYPE THEN r$ = "*" + scope$ + "UOFFSET_" + r$: GOTO ref ref: - If (t And ISSTRING) Then stringprocessinghappened = 1 - If (t And ISPOINTER) Then t = t - ISPOINTER + IF (t AND ISSTRING) THEN stringprocessinghappened = 1 + IF (t AND ISPOINTER) THEN t = t - ISPOINTER typ = t - If method = 1 Then - If Left$(r$, 1) = "*" Then r$ = Right$(r$, Len(r$) - 1) + IF method = 1 THEN + IF LEFT$(r$, 1) = "*" THEN r$ = RIGHT$(r$, LEN(r$) - 1) typ = typbak - End If + END IF refer$ = r$ - EXIT Function - End If 'variable + EXIT FUNCTION + END IF 'variable -End Function +END FUNCTION -Sub regid +SUB regid idn = idn + 1 - If idn > ids_max Then + IF idn > ids_max THEN ids_max = ids_max * 2 - ReDim _Preserve ids(1 To ids_max) As idstruct - ReDim _Preserve cmemlist(1 To ids_max + 1) As Integer - ReDim _Preserve sfcmemargs(1 To ids_max + 1) As String * 100 - ReDim _Preserve arrayelementslist(1 To ids_max + 1) As Integer - End If + REDIM _PRESERVE ids(1 TO ids_max) AS idstruct + REDIM _PRESERVE cmemlist(1 TO ids_max + 1) AS INTEGER + REDIM _PRESERVE sfcmemargs(1 TO ids_max + 1) AS STRING * 100 + REDIM _PRESERVE arrayelementslist(1 TO ids_max + 1) AS INTEGER + END IF - n$ = RTrim$(id.n) + n$ = RTRIM$(id.n) - If reginternalsubfunc = 0 Then - If validname(n$) = 0 Then Give_Error "Invalid name": EXIT Sub - End If + IF reginternalsubfunc = 0 THEN + IF validname(n$) = 0 THEN Give_Error "Invalid name": EXIT SUB + END IF 'register case sensitive name if none given - If Asc(id.cn) = 32 Then - n$ = RTrim$(id.n) - id.n = UCase$(n$) + IF ASC(id.cn) = 32 THEN + n$ = RTRIM$(id.n) + id.n = UCASE$(n$) id.cn = n$ - End If + END IF id.insubfunc = subfunc id.insubfuncn = subfuncn 'note: cannot be STATIC and SHARED at the same time - If dimshared Then + IF dimshared THEN id.share = dimshared - Else - If dimstatic Then id.staticscope = 1 - End If + ELSE + IF dimstatic THEN id.staticscope = 1 + END IF ids(idn) = id @@ -20634,201 +20634,201 @@ Sub regid 'sub/function? 'Note: QBASIC does not allow: Internal type names (INTEGER,LONG,...) - If id.subfunc Then + IF id.subfunc THEN ids(currentid).internal_subfunc = reginternalsubfunc - If id.subfunc = 1 Then hashflags = hashflags + HASHFLAG_FUNCTION Else hashflags = hashflags + HASHFLAG_SUB - If reginternalsubfunc = 0 Then 'allow internal definition of subs/functions without checks + IF id.subfunc = 1 THEN hashflags = hashflags + HASHFLAG_FUNCTION ELSE hashflags = hashflags + HASHFLAG_SUB + IF reginternalsubfunc = 0 THEN 'allow internal definition of subs/functions without checks hashchkflags = HASHFLAG_RESERVED + HASHFLAG_CONSTANT - If id.subfunc = 1 Then hashchkflags = hashchkflags + HASHFLAG_FUNCTION Else hashchkflags = hashchkflags + HASHFLAG_SUB + IF id.subfunc = 1 THEN hashchkflags = hashchkflags + HASHFLAG_FUNCTION ELSE hashchkflags = hashchkflags + HASHFLAG_SUB hashres = HashFind(n$, hashchkflags, hashresflags, hashresref) - Do While hashres - If hashres Then + DO WHILE hashres + IF hashres THEN 'Note: Numeric sub/function names like 'mid' do not clash with Internal string sub/function names ' like 'MID$' because MID$ always requires a '$'. For user defined string sub/function names ' the '$' would be optional so the rule should not be applied there. allow = 0 - If hashresflags And (HASHFLAG_FUNCTION + HASHFLAG_SUB) Then - If RTrim$(ids(hashresref).musthave) = "$" Then - If InStr(ids(currentid).mayhave, "$") = 0 Then allow = 1 - End If - End If - If allow = 0 Then Give_Error "Name already in use": EXIT Sub - End If 'hashres - If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0 - Loop - If idemode Then - If InStr(listOfCustomKeywords$, "@" + UCase$(n$) + "@") = 0 Then - listOfCustomKeywords$ = listOfCustomKeywords$ + "@" + UCase$(n$) + "@" - End If - End If - End If 'reginternalsubfunc = 0 - End If + IF hashresflags AND (HASHFLAG_FUNCTION + HASHFLAG_SUB) THEN + IF RTRIM$(ids(hashresref).musthave) = "$" THEN + IF INSTR(ids(currentid).mayhave, "$") = 0 THEN allow = 1 + END IF + END IF + IF allow = 0 THEN Give_Error "Name already in use": EXIT SUB + END IF 'hashres + IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 + LOOP + IF idemode THEN + IF INSTR(listOfCustomKeywords$, "@" + UCASE$(n$) + "@") = 0 THEN + listOfCustomKeywords$ = listOfCustomKeywords$ + "@" + UCASE$(n$) + "@" + END IF + END IF + END IF 'reginternalsubfunc = 0 + END IF 'variable? - If id.t Then + IF id.t THEN hashflags = hashflags + HASHFLAG_VARIABLE - If reginternalvariable = 0 Then + IF reginternalvariable = 0 THEN allow = 0 var_recheck: - If Asc(id.musthave) = 32 Then astype2 = 1 '"AS type" declaration? + IF ASC(id.musthave) = 32 THEN astype2 = 1 '"AS type" declaration? scope2 = subfuncn hashchkflags = HASHFLAG_RESERVED + HASHFLAG_SUB + HASHFLAG_FUNCTION + HASHFLAG_CONSTANT + HASHFLAG_VARIABLE hashres = HashFind(n$, hashchkflags, hashresflags, hashresref) - Do While hashres + DO WHILE hashres 'conflict with reserved word? - If hashresflags And HASHFLAG_RESERVED Then - musthave$ = RTrim$(id.musthave) - If InStr(musthave$, "$") Then + IF hashresflags AND HASHFLAG_RESERVED THEN + musthave$ = RTRIM$(id.musthave) + IF INSTR(musthave$, "$") THEN 'All reserved words can be used as variables in QBASIC if "$" is appended to the variable name! '(allow) - Else - Give_Error "Name already in use": EXIT Sub 'Conflicts with reserved word - End If - End If 'HASHFLAG_RESERVED + ELSE + Give_Error "Name already in use": EXIT SUB 'Conflicts with reserved word + END IF + END IF 'HASHFLAG_RESERVED 'conflict with sub/function? - If hashresflags And (HASHFLAG_FUNCTION + HASHFLAG_SUB) Then - If ids(hashresref).internal_subfunc = 0 Then Give_Error "Name already in use": EXIT Sub 'QBASIC doesn't allow a variable of the same name as a user-defined sub/func - If RTrim$(id.n) = "WIDTH" And ids(hashresref).subfunc = 2 Then GoTo varname_exception - musthave$ = RTrim$(id.musthave) - If Len(musthave$) = 0 Then - If RTrim$(ids(hashresref).musthave) = "$" Then + IF hashresflags AND (HASHFLAG_FUNCTION + HASHFLAG_SUB) THEN + IF ids(hashresref).internal_subfunc = 0 THEN Give_Error "Name already in use": EXIT SUB 'QBASIC doesn't allow a variable of the same name as a user-defined sub/func + IF RTRIM$(id.n) = "WIDTH" AND ids(hashresref).subfunc = 2 THEN GOTO varname_exception + musthave$ = RTRIM$(id.musthave) + IF LEN(musthave$) = 0 THEN + IF RTRIM$(ids(hashresref).musthave) = "$" THEN 'a sub/func requiring "$" can co-exist with implicit numeric variables - If InStr(id.mayhave, "$") Then Give_Error "Name already in use": EXIT Sub - Else - Give_Error "Name already in use": EXIT Sub 'Implicitly defined variables cannot conflict with sub/func names - End If - End If 'len(musthave$)=0 - If InStr(musthave$, "$") Then - If RTrim$(ids(hashresref).musthave) = "$" Then Give_Error "Name already in use": EXIT Sub 'A sub/function name already exists as a string + IF INSTR(id.mayhave, "$") THEN Give_Error "Name already in use": EXIT SUB + ELSE + Give_Error "Name already in use": EXIT SUB 'Implicitly defined variables cannot conflict with sub/func names + END IF + END IF 'len(musthave$)=0 + IF INSTR(musthave$, "$") THEN + IF RTRIM$(ids(hashresref).musthave) = "$" THEN Give_Error "Name already in use": EXIT SUB 'A sub/function name already exists as a string '(allow) - Else - If RTrim$(ids(hashresref).musthave) <> "$" Then Give_Error "Name already in use": EXIT Sub 'A non-"$" sub/func name already exists with this name - End If - End If 'HASHFLAG_FUNCTION + HASHFLAG_SUB + ELSE + IF RTRIM$(ids(hashresref).musthave) <> "$" THEN Give_Error "Name already in use": EXIT SUB 'A non-"$" sub/func name already exists with this name + END IF + END IF 'HASHFLAG_FUNCTION + HASHFLAG_SUB 'conflict with constant? - If hashresflags And HASHFLAG_CONSTANT Then + IF hashresflags AND HASHFLAG_CONSTANT THEN scope1 = constsubfunc(hashresref) - If (scope1 = 0 And AllowLocalName = 0) Or scope1 = scope2 Then Give_Error "Name already in use": EXIT Sub - End If + IF (scope1 = 0 AND AllowLocalName = 0) OR scope1 = scope2 THEN Give_Error "Name already in use": EXIT SUB + END IF 'conflict with variable? - If hashresflags And HASHFLAG_VARIABLE Then - astype1 = 0: If Asc(ids(hashresref).musthave) = 32 Then astype1 = 1 + IF hashresflags AND HASHFLAG_VARIABLE THEN + astype1 = 0: IF ASC(ids(hashresref).musthave) = 32 THEN astype1 = 1 scope1 = ids(hashresref).insubfuncn - If astype1 = 1 And astype2 = 1 Then - If scope1 = scope2 Then Give_Error "Name already in use": EXIT Sub - End If + IF astype1 = 1 AND astype2 = 1 THEN + IF scope1 = scope2 THEN Give_Error "Name already in use": EXIT SUB + END IF 'same type? - If id.t = ids(hashresref).t Then - If id.tsize = ids(hashresref).tsize Then - If scope1 = scope2 Then Give_Error "Name already in use": EXIT Sub - End If - End If + IF id.t = ids(hashresref).t THEN + IF id.tsize = ids(hashresref).tsize THEN + IF scope1 = scope2 THEN Give_Error "Name already in use": EXIT SUB + END IF + END IF 'will astype'd fixed STRING-variable mask a non-fixed string? - If id.t And ISFIXEDLENGTH Then - If astype2 = 1 Then - If ids(hashresref).t And ISSTRING Then - If (ids(hashresref).t And ISFIXEDLENGTH) = 0 Then - If scope1 = scope2 Then Give_Error "Name already in use": EXIT Sub - End If - End If - End If - End If - End If + IF id.t AND ISFIXEDLENGTH THEN + IF astype2 = 1 THEN + IF ids(hashresref).t AND ISSTRING THEN + IF (ids(hashresref).t AND ISFIXEDLENGTH) = 0 THEN + IF scope1 = scope2 THEN Give_Error "Name already in use": EXIT SUB + END IF + END IF + END IF + END IF + END IF varname_exception: - If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0 - Loop - End If 'reginternalvariable - End If 'variable + IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 + LOOP + END IF 'reginternalvariable + END IF 'variable 'array? - If id.arraytype Then + IF id.arraytype THEN hashflags = hashflags + HASHFLAG_ARRAY allow = 0 ary_recheck: scope2 = subfuncn - If Asc(id.musthave) = 32 Then astype2 = 1 '"AS type" declaration? + IF ASC(id.musthave) = 32 THEN astype2 = 1 '"AS type" declaration? hashchkflags = HASHFLAG_RESERVED + HASHFLAG_SUB + HASHFLAG_FUNCTION + HASHFLAG_ARRAY hashres = HashFind(n$, hashchkflags, hashresflags, hashresref) - Do While hashres + DO WHILE hashres 'conflict with reserved word? - If hashresflags And HASHFLAG_RESERVED Then - musthave$ = RTrim$(id.musthave) - If InStr(musthave$, "$") Then + IF hashresflags AND HASHFLAG_RESERVED THEN + musthave$ = RTRIM$(id.musthave) + IF INSTR(musthave$, "$") THEN 'All reserved words can be used as variables in QBASIC if "$" is appended to the variable name! '(allow) - Else - Give_Error "Name already in use": EXIT Sub 'Conflicts with reserved word - End If - End If 'HASHFLAG_RESERVED + ELSE + Give_Error "Name already in use": EXIT SUB 'Conflicts with reserved word + END IF + END IF 'HASHFLAG_RESERVED 'conflict with sub/function? - If hashresflags And (HASHFLAG_FUNCTION + HASHFLAG_SUB) Then - If ids(hashresref).internal_subfunc = 0 Then Give_Error "Name already in use": EXIT Sub 'QBASIC doesn't allow a variable of the same name as a user-defined sub/func - If RTrim$(id.n) = "WIDTH" And ids(hashresref).subfunc = 2 Then GoTo arrayname_exception - musthave$ = RTrim$(id.musthave) + IF hashresflags AND (HASHFLAG_FUNCTION + HASHFLAG_SUB) THEN + IF ids(hashresref).internal_subfunc = 0 THEN Give_Error "Name already in use": EXIT SUB 'QBASIC doesn't allow a variable of the same name as a user-defined sub/func + IF RTRIM$(id.n) = "WIDTH" AND ids(hashresref).subfunc = 2 THEN GOTO arrayname_exception + musthave$ = RTRIM$(id.musthave) - If Len(musthave$) = 0 Then - If RTrim$(ids(hashresref).musthave) = "$" Then + IF LEN(musthave$) = 0 THEN + IF RTRIM$(ids(hashresref).musthave) = "$" THEN 'a sub/func requiring "$" can co-exist with implicit numeric variables - If InStr(id.mayhave, "$") Then Give_Error "Name already in use": EXIT Sub - Else - Give_Error "Name already in use": EXIT Sub 'Implicitly defined variables cannot conflict with sub/func names - End If - End If 'len(musthave$)=0 - If InStr(musthave$, "$") Then - If RTrim$(ids(hashresref).musthave) = "$" Then Give_Error "Name already in use": EXIT Sub 'A sub/function name already exists as a string + IF INSTR(id.mayhave, "$") THEN Give_Error "Name already in use": EXIT SUB + ELSE + Give_Error "Name already in use": EXIT SUB 'Implicitly defined variables cannot conflict with sub/func names + END IF + END IF 'len(musthave$)=0 + IF INSTR(musthave$, "$") THEN + IF RTRIM$(ids(hashresref).musthave) = "$" THEN Give_Error "Name already in use": EXIT SUB 'A sub/function name already exists as a string '(allow) - Else - If RTrim$(ids(hashresref).musthave) <> "$" Then Give_Error "Name already in use": EXIT Sub 'A non-"$" sub/func name already exists with this name - End If - End If 'HASHFLAG_FUNCTION + HASHFLAG_SUB + ELSE + IF RTRIM$(ids(hashresref).musthave) <> "$" THEN Give_Error "Name already in use": EXIT SUB 'A non-"$" sub/func name already exists with this name + END IF + END IF 'HASHFLAG_FUNCTION + HASHFLAG_SUB 'conflict with array? - If hashresflags And HASHFLAG_ARRAY Then - astype1 = 0: If Asc(ids(hashresref).musthave) = 32 Then astype1 = 1 + IF hashresflags AND HASHFLAG_ARRAY THEN + astype1 = 0: IF ASC(ids(hashresref).musthave) = 32 THEN astype1 = 1 scope1 = ids(hashresref).insubfuncn - If astype1 = 1 And astype2 = 1 Then - If scope1 = scope2 Then Give_Error "Name already in use": EXIT Sub - End If + IF astype1 = 1 AND astype2 = 1 THEN + IF scope1 = scope2 THEN Give_Error "Name already in use": EXIT SUB + END IF 'same type? - If id.arraytype = ids(hashresref).arraytype Then - If id.tsize = ids(hashresref).tsize Then - If scope1 = scope2 Then Give_Error "Name already in use": EXIT Sub - End If - End If + IF id.arraytype = ids(hashresref).arraytype THEN + IF id.tsize = ids(hashresref).tsize THEN + IF scope1 = scope2 THEN Give_Error "Name already in use": EXIT SUB + END IF + END IF 'will astype'd fixed STRING-variable mask a non-fixed string? - If id.arraytype And ISFIXEDLENGTH Then - If astype2 = 1 Then - If ids(hashresref).arraytype And ISSTRING Then - If (ids(hashresref).arraytype And ISFIXEDLENGTH) = 0 Then - If scope1 = scope2 Then Give_Error "Name already in use": EXIT Sub - End If - End If - End If - End If - End If + IF id.arraytype AND ISFIXEDLENGTH THEN + IF astype2 = 1 THEN + IF ids(hashresref).arraytype AND ISSTRING THEN + IF (ids(hashresref).arraytype AND ISFIXEDLENGTH) = 0 THEN + IF scope1 = scope2 THEN Give_Error "Name already in use": EXIT SUB + END IF + END IF + END IF + END IF + END IF arrayname_exception: - If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0 - Loop - End If 'array + IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 + LOOP + END IF 'array 'add it to the hash table HashAdd n$, hashflags, currentid -End Sub +END SUB -Sub reginternal +SUB reginternal reginternalsubfunc = 1 '$INCLUDE:'subs_functions\subs_functions.bas' reginternalsubfunc = 0 -End Sub +END SUB 'this sub is faulty atm! 'sub replacelement (a$, i, newe$) @@ -20853,138 +20853,138 @@ End Sub 'end sub -Sub removeelements (a$, first, last, keepindexing) +SUB removeelements (a$, first, last, keepindexing) a2$ = "" 'note: first and last MUST be valid ' keepindexing means the number of elements will stay the same ' but some elements will be equal to "" n = numelements(a$) - For i = 1 To n - If i < first Or i > last Then + FOR i = 1 TO n + IF i < first OR i > last THEN a2$ = a2$ + sp + getelement(a$, i) - Else - If keepindexing Then a2$ = a2$ + sp - End If - Next - If Left$(a2$, 1) = sp Then a2$ = Right$(a2$, Len(a2$) - 1) + ELSE + IF keepindexing THEN a2$ = a2$ + sp + END IF + NEXT + IF LEFT$(a2$, 1) = sp THEN a2$ = RIGHT$(a2$, LEN(a2$) - 1) a$ = a2$ -End Sub +END SUB -Function symboltype (s$) 'returns type or 0(not a valid symbol) +FUNCTION symboltype (s$) 'returns type or 0(not a valid symbol) 'note: sets symboltype_size for fixed length strings 'created: 2011 (fast & comprehensive) - If Len(s$) = 0 Then EXIT Function + IF LEN(s$) = 0 THEN EXIT FUNCTION 'treat common cases first - a = Asc(s$) - l = Len(s$) - If a = 37 Then '% - If l = 1 Then symboltype = 16: EXIT Function - If l > 2 Then EXIT Function - If Asc(s$, 2) = 37 Then symboltype = 8: EXIT Function - If Asc(s$, 2) = 38 Then symboltype = OFFSETTYPE - ISPOINTER: EXIT Function '%& - EXIT Function - End If - If a = 38 Then '& - If l = 1 Then symboltype = 32: EXIT Function - If l > 2 Then EXIT Function - If Asc(s$, 2) = 38 Then symboltype = 64: EXIT Function - EXIT Function - End If - If a = 33 Then '! - If l = 1 Then symboltype = 32 + ISFLOAT: EXIT Function - EXIT Function - End If - If a = 35 Then '# - If l = 1 Then symboltype = 64 + ISFLOAT: EXIT Function - If l > 2 Then EXIT Function - If Asc(s$, 2) = 35 Then symboltype = 64 + ISFLOAT: EXIT Function - EXIT Function - End If - If a = 36 Then '$ - If l = 1 Then symboltype = ISSTRING: EXIT Function - If isuinteger(Right$(s$, l - 1)) Then - If l >= (1 + 10) Then - If l > (1 + 10) Then EXIT Function - If s$ > "$2147483647" Then EXIT Function - End If - symboltype_size = Val(Right$(s$, l - 1)) + a = ASC(s$) + l = LEN(s$) + IF a = 37 THEN '% + IF l = 1 THEN symboltype = 16: EXIT FUNCTION + IF l > 2 THEN EXIT FUNCTION + IF ASC(s$, 2) = 37 THEN symboltype = 8: EXIT FUNCTION + IF ASC(s$, 2) = 38 THEN symboltype = OFFSETTYPE - ISPOINTER: EXIT FUNCTION '%& + EXIT FUNCTION + END IF + IF a = 38 THEN '& + IF l = 1 THEN symboltype = 32: EXIT FUNCTION + IF l > 2 THEN EXIT FUNCTION + IF ASC(s$, 2) = 38 THEN symboltype = 64: EXIT FUNCTION + EXIT FUNCTION + END IF + IF a = 33 THEN '! + IF l = 1 THEN symboltype = 32 + ISFLOAT: EXIT FUNCTION + EXIT FUNCTION + END IF + IF a = 35 THEN '# + IF l = 1 THEN symboltype = 64 + ISFLOAT: EXIT FUNCTION + IF l > 2 THEN EXIT FUNCTION + IF ASC(s$, 2) = 35 THEN symboltype = 64 + ISFLOAT: EXIT FUNCTION + EXIT FUNCTION + END IF + IF a = 36 THEN '$ + IF l = 1 THEN symboltype = ISSTRING: EXIT FUNCTION + IF isuinteger(RIGHT$(s$, l - 1)) THEN + IF l >= (1 + 10) THEN + IF l > (1 + 10) THEN EXIT FUNCTION + IF s$ > "$2147483647" THEN EXIT FUNCTION + END IF + symboltype_size = VAL(RIGHT$(s$, l - 1)) symboltype = ISSTRING + ISFIXEDLENGTH - EXIT Function - End If - EXIT Function - End If - If a = 96 Then '` - If l = 1 Then symboltype = 1 + ISOFFSETINBITS: EXIT Function - If isuinteger(Right$(s$, l - 1)) Then - If l > 3 Then EXIT Function - n = Val(Right$(s$, l - 1)) - If n > 56 Then EXIT Function - symboltype = n + ISOFFSETINBITS: EXIT Function - End If - EXIT Function - End If - If a = 126 Then '~ - If l = 1 Then EXIT Function - a = Asc(s$, 2) - If a = 37 Then '% - If l = 2 Then symboltype = 16 + ISUNSIGNED: EXIT Function - If l > 3 Then EXIT Function - If Asc(s$, 3) = 37 Then symboltype = 8 + ISUNSIGNED: EXIT Function - If Asc(s$, 3) = 38 Then symboltype = UOFFSETTYPE - ISPOINTER: EXIT Function '~%& - EXIT Function - End If - If a = 38 Then '& - If l = 2 Then symboltype = 32 + ISUNSIGNED: EXIT Function - If l > 3 Then EXIT Function - If Asc(s$, 3) = 38 Then symboltype = 64 + ISUNSIGNED: EXIT Function - EXIT Function - End If - If a = 96 Then '` - If l = 2 Then symboltype = 1 + ISOFFSETINBITS + ISUNSIGNED: EXIT Function - If isuinteger(Right$(s$, l - 2)) Then - If l > 4 Then EXIT Function - n = Val(Right$(s$, l - 2)) - If n > 56 Then EXIT Function - symboltype = n + ISOFFSETINBITS + ISUNSIGNED: EXIT Function - End If - EXIT Function - End If - End If '~ -End Function + EXIT FUNCTION + END IF + EXIT FUNCTION + END IF + IF a = 96 THEN '` + IF l = 1 THEN symboltype = 1 + ISOFFSETINBITS: EXIT FUNCTION + IF isuinteger(RIGHT$(s$, l - 1)) THEN + IF l > 3 THEN EXIT FUNCTION + n = VAL(RIGHT$(s$, l - 1)) + IF n > 56 THEN EXIT FUNCTION + symboltype = n + ISOFFSETINBITS: EXIT FUNCTION + END IF + EXIT FUNCTION + END IF + IF a = 126 THEN '~ + IF l = 1 THEN EXIT FUNCTION + a = ASC(s$, 2) + IF a = 37 THEN '% + IF l = 2 THEN symboltype = 16 + ISUNSIGNED: EXIT FUNCTION + IF l > 3 THEN EXIT FUNCTION + IF ASC(s$, 3) = 37 THEN symboltype = 8 + ISUNSIGNED: EXIT FUNCTION + IF ASC(s$, 3) = 38 THEN symboltype = UOFFSETTYPE - ISPOINTER: EXIT FUNCTION '~%& + EXIT FUNCTION + END IF + IF a = 38 THEN '& + IF l = 2 THEN symboltype = 32 + ISUNSIGNED: EXIT FUNCTION + IF l > 3 THEN EXIT FUNCTION + IF ASC(s$, 3) = 38 THEN symboltype = 64 + ISUNSIGNED: EXIT FUNCTION + EXIT FUNCTION + END IF + IF a = 96 THEN '` + IF l = 2 THEN symboltype = 1 + ISOFFSETINBITS + ISUNSIGNED: EXIT FUNCTION + IF isuinteger(RIGHT$(s$, l - 2)) THEN + IF l > 4 THEN EXIT FUNCTION + n = VAL(RIGHT$(s$, l - 2)) + IF n > 56 THEN EXIT FUNCTION + symboltype = n + ISOFFSETINBITS + ISUNSIGNED: EXIT FUNCTION + END IF + EXIT FUNCTION + END IF + END IF '~ +END FUNCTION -Function removesymbol$ (varname$) - i = InStr(varname$, "~"): If i Then GoTo foundsymbol - i = InStr(varname$, "`"): If i Then GoTo foundsymbol - i = InStr(varname$, "%"): If i Then GoTo foundsymbol - i = InStr(varname$, "&"): If i Then GoTo foundsymbol - i = InStr(varname$, "!"): If i Then GoTo foundsymbol - i = InStr(varname$, "#"): If i Then GoTo foundsymbol - i = InStr(varname$, "$"): If i Then GoTo foundsymbol - EXIT Function +FUNCTION removesymbol$ (varname$) + i = INSTR(varname$, "~"): IF i THEN GOTO foundsymbol + i = INSTR(varname$, "`"): IF i THEN GOTO foundsymbol + i = INSTR(varname$, "%"): IF i THEN GOTO foundsymbol + i = INSTR(varname$, "&"): IF i THEN GOTO foundsymbol + i = INSTR(varname$, "!"): IF i THEN GOTO foundsymbol + i = INSTR(varname$, "#"): IF i THEN GOTO foundsymbol + i = INSTR(varname$, "$"): IF i THEN GOTO foundsymbol + EXIT FUNCTION foundsymbol: - If i = 1 Then Give_Error "Expected variable name before symbol": EXIT Function - symbol$ = Right$(varname$, Len(varname$) - i + 1) - If symboltype(symbol$) = 0 Then Give_Error "Invalid symbol": EXIT Function + IF i = 1 THEN Give_Error "Expected variable name before symbol": EXIT FUNCTION + symbol$ = RIGHT$(varname$, LEN(varname$) - i + 1) + IF symboltype(symbol$) = 0 THEN Give_Error "Invalid symbol": EXIT FUNCTION removesymbol$ = symbol$ - varname$ = Left$(varname$, i - 1) -End Function + varname$ = LEFT$(varname$, i - 1) +END FUNCTION -Function scope$ - If id.share Then scope$ = module$ + "__": EXIT Function +FUNCTION scope$ + IF id.share THEN scope$ = module$ + "__": EXIT FUNCTION scope$ = module$ + "_" + subfunc$ + "_" -End Function +END FUNCTION -Function seperateargs (a$, ca$, pass&) +FUNCTION seperateargs (a$, ca$, pass&) pass& = 0 - For i = 1 To OptMax: separgs(i) = "": Next - For i = 1 To OptMax + 1: separgslayout(i) = "": Next - For i = 1 To OptMax + FOR i = 1 TO OptMax: separgs(i) = "": NEXT + FOR i = 1 TO OptMax + 1: separgslayout(i) = "": NEXT + FOR i = 1 TO OptMax Lev(i) = 0 EntryLev(i) = 0 DitchLev(i) = 0 @@ -20992,24 +20992,24 @@ Function seperateargs (a$, ca$, pass&) TempList(i) = 0 PassRule(i) = 0 LevelEntered(i) = 0 - Next + NEXT - Dim id2 As idstruct + DIM id2 AS idstruct id2 = id - If id2.args = 0 Then EXIT Function 'no arguments! + IF id2.args = 0 THEN EXIT FUNCTION 'no arguments! s$ = id2.specialformat - s$ = RTrim$(s$) + s$ = RTRIM$(s$) 'build a special format if none exists - If s$ = "" Then - For i = 1 To id2.args - If i <> 1 Then s$ = s$ + ",?" Else s$ = "?" - Next - End If + IF s$ = "" THEN + FOR i = 1 TO id2.args + IF i <> 1 THEN s$ = s$ + ",?" ELSE s$ = "?" + NEXT + END IF 'note: dim'd arrays moved to global to prevent high recreation cost @@ -21019,75 +21019,75 @@ Function seperateargs (a$, ca$, pass&) level = 0 lastt = 0 ditchlevel = 0 - For i = 1 To Len(s$) - s2$ = Mid$(s$, i, 1) + FOR i = 1 TO LEN(s$) + s2$ = MID$(s$, i, 1) - If s2$ = "[" Then + IF s2$ = "[" THEN level = level + 1 LevelEntered(level) = 0 - GoTo nextsymbol - End If + GOTO nextsymbol + END IF - If s2$ = "]" Then + IF s2$ = "]" THEN level = level - 1 - If level < ditchlevel Then ditchlevel = level - GoTo nextsymbol - End If + IF level < ditchlevel THEN ditchlevel = level + GOTO nextsymbol + END IF - If s2$ = "{" Then + IF s2$ = "{" THEN lastt = lastt + 1: Lev(lastt) = level: PassRule(lastt) = 0 DitchLev(lastt) = ditchlevel: ditchlevel = level 'store & reset ditch level i = i + 1 - i2 = InStr(i, s$, "}") + i2 = INSTR(i, s$, "}") numopts = 0 nextopt: numopts = numopts + 1 - i3 = InStr(i + 1, s$, "|") - If i3 <> 0 And i3 < i2 Then - Opt(lastt, numopts) = Mid$(s$, i, i3 - i) - i = i3 + 1: GoTo nextopt - End If - Opt(lastt, numopts) = Mid$(s$, i, i2 - i) + i3 = INSTR(i + 1, s$, "|") + IF i3 <> 0 AND i3 < i2 THEN + Opt(lastt, numopts) = MID$(s$, i, i3 - i) + i = i3 + 1: GOTO nextopt + END IF + Opt(lastt, numopts) = MID$(s$, i, i2 - i) T(lastt) = numopts 'calculate words in each option - For x = 1 To T(lastt) + FOR x = 1 TO T(lastt) w = 1 x2 = 1 newword: - If InStr(x2, RTrim$(Opt(lastt, x)), " ") Then w = w + 1: x2 = InStr(x2, RTrim$(Opt(lastt, x)), " ") + 1: GoTo newword + IF INSTR(x2, RTRIM$(Opt(lastt, x)), " ") THEN w = w + 1: x2 = INSTR(x2, RTRIM$(Opt(lastt, x)), " ") + 1: GOTO newword OptWords(lastt, x) = w - Next + NEXT i = i2 'set entry level routine EntryLev(lastt) = level 'default level when continuing a previously entered level - If LevelEntered(level) = 0 Then + IF LevelEntered(level) = 0 THEN EntryLev(lastt) = 0 - For i2 = 1 To level - 1 - If LevelEntered(i2) = 1 Then EntryLev(lastt) = i2 - Next - End If + FOR i2 = 1 TO level - 1 + IF LevelEntered(i2) = 1 THEN EntryLev(lastt) = i2 + NEXT + END IF LevelEntered(level) = 1 - GoTo nextsymbol - End If + GOTO nextsymbol + END IF - If s2$ = "?" Then + IF s2$ = "?" THEN lastt = lastt + 1: Lev(lastt) = level: PassRule(lastt) = 0 DitchLev(lastt) = ditchlevel: ditchlevel = level 'store & reset ditch level T(lastt) = 0 'set entry level routine EntryLev(lastt) = level 'default level when continuing a previously entered level - If LevelEntered(level) = 0 Then + IF LevelEntered(level) = 0 THEN EntryLev(lastt) = 0 - For i2 = 1 To level - 1 - If LevelEntered(i2) = 1 Then EntryLev(lastt) = i2 - Next - End If + FOR i2 = 1 TO level - 1 + IF LevelEntered(i2) = 1 THEN EntryLev(lastt) = i2 + NEXT + END IF LevelEntered(level) = 1 - GoTo nextsymbol - End If + GOTO nextsymbol + END IF 'assume "special" character (like ( ) , . - etc.) lastt = lastt + 1: Lev(lastt) = level: PassRule(lastt) = 0 @@ -21096,55 +21096,55 @@ Function seperateargs (a$, ca$, pass&) 'set entry level routine EntryLev(lastt) = level 'default level when continuing a previously entered level - If LevelEntered(level) = 0 Then + IF LevelEntered(level) = 0 THEN EntryLev(lastt) = 0 - For i2 = 1 To level - 1 - If LevelEntered(i2) = 1 Then EntryLev(lastt) = i2 - Next - End If + FOR i2 = 1 TO level - 1 + IF LevelEntered(i2) = 1 THEN EntryLev(lastt) = i2 + NEXT + END IF LevelEntered(level) = 1 - GoTo nextsymbol + GOTO nextsymbol nextsymbol: - Next + NEXT - If Debug Then - Print #9, "--------SEPERATE ARGUMENTS REPORT #1:1--------" - For i = 1 To lastt - Print #9, i, "OPT=" + Chr$(34) + RTrim$(Opt(i, 1)) + Chr$(34) - Print #9, i, "OPTWORDS="; OptWords(i, 1) - Print #9, i, "T="; T(i) - Print #9, i, "DONTPASS="; DontPass(i) - Print #9, i, "PASSRULE="; PassRule(i) - Print #9, i, "LEV="; Lev(i) - Print #9, i, "ENTRYLEV="; EntryLev(i) - Next - End If + IF Debug THEN + PRINT #9, "--------SEPERATE ARGUMENTS REPORT #1:1--------" + FOR i = 1 TO lastt + PRINT #9, i, "OPT=" + CHR$(34) + RTRIM$(Opt(i, 1)) + CHR$(34) + PRINT #9, i, "OPTWORDS="; OptWords(i, 1) + PRINT #9, i, "T="; T(i) + PRINT #9, i, "DONTPASS="; DontPass(i) + PRINT #9, i, "PASSRULE="; PassRule(i) + PRINT #9, i, "LEV="; Lev(i) + PRINT #9, i, "ENTRYLEV="; EntryLev(i) + NEXT + END IF 'Any symbols already have dontpass() set to 1 'This sets any {}blocks with only one option/word (eg. {PRINT}) at the lowest level to dontpass()=1 'because their content is manadatory and there is no choice as to which word to use - For x = 1 To lastt - If Lev(x) = 0 Then - If T(x) = 1 Then DontPass(x) = 1 - End If - Next + FOR x = 1 TO lastt + IF Lev(x) = 0 THEN + IF T(x) = 1 THEN DontPass(x) = 1 + END IF + NEXT - If Debug Then - Print #9, "--------SEPERATE ARGUMENTS REPORT #1:2--------" - For i = 1 To lastt - Print #9, i, "OPT=" + Chr$(34) + RTrim$(Opt(i, 1)) + Chr$(34) - Print #9, i, "OPTWORDS="; OptWords(i, 1) - Print #9, i, "T="; T(i) - Print #9, i, "DONTPASS="; DontPass(i) - Print #9, i, "PASSRULE="; PassRule(i) - Print #9, i, "LEV="; Lev(i) - Print #9, i, "ENTRYLEV="; EntryLev(i) - Next - End If + IF Debug THEN + PRINT #9, "--------SEPERATE ARGUMENTS REPORT #1:2--------" + FOR i = 1 TO lastt + PRINT #9, i, "OPT=" + CHR$(34) + RTRIM$(Opt(i, 1)) + CHR$(34) + PRINT #9, i, "OPTWORDS="; OptWords(i, 1) + PRINT #9, i, "T="; T(i) + PRINT #9, i, "DONTPASS="; DontPass(i) + PRINT #9, i, "PASSRULE="; PassRule(i) + PRINT #9, i, "LEV="; Lev(i) + PRINT #9, i, "ENTRYLEV="; EntryLev(i) + NEXT + END IF @@ -21157,127 +21157,127 @@ Function seperateargs (a$, ca$, pass&) ' has to be made, in such cases, a flag is preferable to wasting a full new int32 on 'hello' templistn = 0 - For l = 1 To 32767 + FOR l = 1 TO 32767 scannextlevel = 0 - For x = 1 To lastt - If Lev(x) > l Then scannextlevel = 1 + FOR x = 1 TO lastt + IF Lev(x) > l THEN scannextlevel = 1 - If x1 Then - If EntryLev(x) < l Then 'end of block reached - If MustPassOpt Then + IF x1 THEN + IF EntryLev(x) < l THEN 'end of block reached + IF MustPassOpt THEN 'If there's an opt () which must be passed that will be identified, 'all the 1 option {}blocks can be assumed... - If MustPassOptNeedsFlag Then + IF MustPassOptNeedsFlag THEN 'The MustPassOpt requires a flag, so use the same flag for everything - For x2 = 1 To templistn + FOR x2 = 1 TO templistn PassRule(TempList(x2)) = PassFlag - Next + NEXT PassFlag = PassFlag * 2 - Else + ELSE 'The MustPassOpt is a {}block which doesn't need a flag, so everything else needs to 'reference it - For x2 = 1 To templistn - If TempList(x2) <> MustPassOpt Then PassRule(TempList(x2)) = -MustPassOpt - Next - End If - Else + FOR x2 = 1 TO templistn + IF TempList(x2) <> MustPassOpt THEN PassRule(TempList(x2)) = -MustPassOpt + NEXT + END IF + ELSE 'if not, use a unique flag for everything in this block - For x2 = 1 To templistn: PassRule(TempList(x2)) = PassFlag: Next - If templistn <> 0 Then PassFlag = PassFlag * 2 - End If + FOR x2 = 1 TO templistn: PassRule(TempList(x2)) = PassFlag: NEXT + IF templistn <> 0 THEN PassFlag = PassFlag * 2 + END IF x1 = 0 - End If - End If + END IF + END IF - If Lev(x) = l Then 'on same level - If EntryLev(x) < l Then 'just (re)entered this level (not continuing along it) + IF Lev(x) = l THEN 'on same level + IF EntryLev(x) < l THEN 'just (re)entered this level (not continuing along it) x1 = x 'set x1 to the starting element of this level MustPassOpt = 0 templistn = 0 - End If - End If + END IF + END IF - If x1 Then - If Lev(x) = l Then 'same level + IF x1 THEN + IF Lev(x) = l THEN 'same level - If T(x) <> 1 Then + IF T(x) <> 1 THEN 'It isn't a symbol or a {}block with only one option therefore this opt () must be passed - If MustPassOpt = 0 Then + IF MustPassOpt = 0 THEN MustPassOpt = x 'Only record the first instance (it MAY require a flag) - If T(x) = 0 Then MustPassOptNeedsFlag = 1 Else MustPassOptNeedsFlag = 0 - Else + IF T(x) = 0 THEN MustPassOptNeedsFlag = 1 ELSE MustPassOptNeedsFlag = 0 + ELSE 'Update current MustPassOpt to non-flag-based {}block if possible (to save flag usage) '(Consider [{A|B}?], where a flag is not required) - If MustPassOptNeedsFlag = 1 Then - If T(x) > 1 Then + IF MustPassOptNeedsFlag = 1 THEN + IF T(x) > 1 THEN MustPassOpt = x: MustPassOptNeedsFlag = 0 - End If - End If - End If + END IF + END IF + END IF 'add to list templistn = templistn + 1: TempList(templistn) = x - End If + END IF - If T(x) = 1 Then + IF T(x) = 1 THEN 'It is a symbol or a {}block with only one option 'a {}block with only one option MAY not need to be passed 'depending on if anything else is in this block could make the existance of this opt () assumed 'Note: Symbols which are not encapsulated inside a {}block never need to be passed ' Symbols already have dontpass() set to 1 - If DontPass(x) = 0 Then templistn = templistn + 1: TempList(templistn) = x: DontPass(x) = 1 - End If + IF DontPass(x) = 0 THEN templistn = templistn + 1: TempList(templistn) = x: DontPass(x) = 1 + END IF - End If - End If + END IF + END IF - Next + NEXT 'scan last run (mostly just a copy of code from above) - If x1 Then - If MustPassOpt Then + IF x1 THEN + IF MustPassOpt THEN 'If there's an opt () which must be passed that will be identified, 'all the 1 option {}blocks can be assumed... - If MustPassOptNeedsFlag Then + IF MustPassOptNeedsFlag THEN 'The MustPassOpt requires a flag, so use the same flag for everything - For x2 = 1 To templistn + FOR x2 = 1 TO templistn PassRule(TempList(x2)) = PassFlag - Next + NEXT PassFlag = PassFlag * 2 - Else + ELSE 'The MustPassOpt is a {}block which doesn't need a flag, so everything else needs to 'reference it - For x2 = 1 To templistn - If TempList(x2) <> MustPassOpt Then PassRule(TempList(x2)) = -MustPassOpt - Next - End If - Else + FOR x2 = 1 TO templistn + IF TempList(x2) <> MustPassOpt THEN PassRule(TempList(x2)) = -MustPassOpt + NEXT + END IF + ELSE 'if not, use a unique flag for everything in this block - For x2 = 1 To templistn: PassRule(TempList(x2)) = PassFlag: Next - If templistn <> 0 Then PassFlag = PassFlag * 2 - End If + FOR x2 = 1 TO templistn: PassRule(TempList(x2)) = PassFlag: NEXT + IF templistn <> 0 THEN PassFlag = PassFlag * 2 + END IF x1 = 0 - End If + END IF - If scannextlevel = 0 Then Exit For - Next + IF scannextlevel = 0 THEN EXIT FOR + NEXT - If Debug Then - Print #9, "--------SEPERATE ARGUMENTS REPORT #1:3--------" - For i = 1 To lastt - Print #9, i, "OPT=" + Chr$(34) + RTrim$(Opt(i, 1)) + Chr$(34) - Print #9, i, "OPTWORDS="; OptWords(i, 1) - Print #9, i, "T="; T(i) - Print #9, i, "DONTPASS="; DontPass(i) - Print #9, i, "PASSRULE="; PassRule(i) - Print #9, i, "LEV="; Lev(i) - Print #9, i, "ENTRYLEV="; EntryLev(i) - Next - End If + IF Debug THEN + PRINT #9, "--------SEPERATE ARGUMENTS REPORT #1:3--------" + FOR i = 1 TO lastt + PRINT #9, i, "OPT=" + CHR$(34) + RTRIM$(Opt(i, 1)) + CHR$(34) + PRINT #9, i, "OPTWORDS="; OptWords(i, 1) + PRINT #9, i, "T="; T(i) + PRINT #9, i, "DONTPASS="; DontPass(i) + PRINT #9, i, "PASSRULE="; PassRule(i) + PRINT #9, i, "LEV="; Lev(i) + PRINT #9, i, "ENTRYLEV="; EntryLev(i) + NEXT + END IF - For i = 1 To lastt: separgs(i) = "n-ll": Next + FOR i = 1 TO lastt: separgs(i) = "n-ll": NEXT @@ -21296,51 +21296,51 @@ Function seperateargs (a$, ca$, pass&) 'An expression ("?") simply means a branch where you can scan ahead Branches = 0 - Dim BranchFormatPos(1 To 100) As Long - Dim BranchTaken(1 To 100) As Long + DIM BranchFormatPos(1 TO 100) AS LONG + DIM BranchTaken(1 TO 100) AS LONG '1=taken (this usually involves moving up a level) '0=not taken - Dim BranchInputPos(1 To 100) As Long - Dim BranchWithExpression(1 To 100) As Long + DIM BranchInputPos(1 TO 100) AS LONG + DIM BranchWithExpression(1 TO 100) AS LONG 'non-zero=expression expected before next item for format item value represents '0=no expression allowed before next item - Dim BranchLevel(1 To 100) As Long 'Level before this branch was/wasn't taken + DIM BranchLevel(1 TO 100) AS LONG 'Level before this branch was/wasn't taken n = numelements(ca$) i = 1 'Position within ca$ level = 0 Expression = 0 - For x = 1 To lastt + FOR x = 1 TO lastt ContinueScan: - If DitchLev(x) < level Then 'dropping down to a lower level + IF DitchLev(x) < level THEN 'dropping down to a lower level 'we can only go as low as the 'ditch' will allow us, which will limit our options level = DitchLev(x) - End If + END IF - If EntryLev(x) <= level Then 'possible to enter level + IF EntryLev(x) <= level THEN 'possible to enter level 'But was this optional or were we forced to be on this level? - If EntryLev(x) < Lev(x) Then + IF EntryLev(x) < Lev(x) THEN optional = 1 - If level > EntryLev(x) Then optional = 0 - Else + IF level > EntryLev(x) THEN optional = 0 + ELSE 'entrylev=lev optional = 0 - End If + END IF t = T(x) - If t = 0 Then 'A "?" expression - If Expression Then + IF t = 0 THEN 'A "?" expression + IF Expression THEN '*********backtrack************ 'We are tracking an expression which we assumed would be present but was not - GoTo Backtrack + GOTO Backtrack '****************************** - End If - If optional Then + END IF + IF optional THEN Branches = Branches + 1 BranchFormatPos(Branches) = x BranchTaken(Branches) = 1 @@ -21348,27 +21348,27 @@ Function seperateargs (a$, ca$, pass&) BranchWithExpression(Branches) = 0 BranchLevel(Branches) = level level = Lev(x) - End If + END IF Expression = x - End If 'A "?" expression + END IF 'A "?" expression - If t Then + IF t THEN currentlev = level 'Add new branch if new level will be entered - If optional Then + IF optional THEN Branches = Branches + 1 BranchFormatPos(Branches) = x BranchTaken(Branches) = 1 BranchInputPos(Branches) = i BranchWithExpression(Branches) = Expression BranchLevel(Branches) = level - End If + END IF 'Scan for Opt () options i1 = i: i2 = i - If Expression Then i2 = n + IF Expression THEN i2 = n 'Scan a$ for opt () x 'Note: Finding the closest opt option is necessary 'Note: This needs to be bracket sensitive @@ -21376,93 +21376,93 @@ Function seperateargs (a$, ca$, pass&) position = OutOfRange which = 0 removePrefix = 0 - If i <= n Then 'Past end of contect check - For o = 1 To t + IF i <= n THEN 'Past end of contect check + FOR o = 1 TO t words = OptWords(x, o) b = 0 - For i3 = i1 To i2 - If i3 + words - 1 <= n Then 'enough elements exist + FOR i3 = i1 TO i2 + IF i3 + words - 1 <= n THEN 'enough elements exist c$ = getelement$(a$, i3) - If b = 0 Then + IF b = 0 THEN 'Build comparison string (spacing elements) - For w = 2 To words + FOR w = 2 TO words c$ = c$ + " " + getelement$(a$, i3 + w - 1) - Next w + NEXT w 'Compare - noPrefixMatch = Left$(Opt(x, o), 1) = "_" And qb64prefix_set = 1 And c$ = UCase$(Mid$(RTrim$(Opt(x, o)), 2)) - If c$ = UCase$(RTrim$(Opt(x, o))) Or noPrefixMatch Then + noPrefixMatch = LEFT$(Opt(x, o), 1) = "_" AND qb64prefix_set = 1 AND c$ = UCASE$(MID$(RTRIM$(Opt(x, o)), 2)) + IF c$ = UCASE$(RTRIM$(Opt(x, o))) OR noPrefixMatch THEN 'Record Match - If i3 < position Then + IF i3 < position THEN position = i3 which = o - If noPrefixMatch Then removePrefix = 1 + IF noPrefixMatch THEN removePrefix = 1 bvalue = b - Exit For 'Exit the i3 loop - End If 'position check - End If 'match - End If + EXIT FOR 'Exit the i3 loop + END IF 'position check + END IF 'match + END IF - If Asc(c$) = 44 And b = 0 Then - Exit For 'Expressions cannot contain a "," in their base level + IF ASC(c$) = 44 AND b = 0 THEN + EXIT FOR 'Expressions cannot contain a "," in their base level 'Because this wasn't interceppted by the above code it isn't the Opt either - End If - If Asc(c$) = 40 Then + END IF + IF ASC(c$) = 40 THEN b = b + 1 - End If - If Asc(c$) = 41 Then + END IF + IF ASC(c$) = 41 THEN b = b - 1 - If b = -1 Then Exit For 'Exited current bracketting level, making any following match invalid - End If + IF b = -1 THEN EXIT FOR 'Exited current bracketting level, making any following match invalid + END IF - End If 'enough elements exist - Next i3 - Next o - End If 'Past end of contect check + END IF 'enough elements exist + NEXT i3 + NEXT o + END IF 'Past end of contect check - If position <> OutOfRange Then 'Found? + IF position <> OutOfRange THEN 'Found? 'Found... level = Lev(x) 'Adjust level - If Expression Then + IF Expression THEN 'Found...Expression... 'Has an expression been provided? - If position > i And bvalue = 0 Then + IF position > i AND bvalue = 0 THEN 'Found...Expression...Provided... separgs(Expression) = getelements$(ca$, i, position - 1) Expression = 0 i = position - Else + ELSE 'Found...Expression...Omitted... '*********backtrack************ - GoTo OptCheckBacktrack + GOTO OptCheckBacktrack '****************************** - End If - End If 'Expression + END IF + END IF 'Expression i = i + OptWords(x, which) - separgslayout(x) = Chr$(Len(RTrim$(Opt(x, which))) - removePrefix) + SCase$(Mid$(RTrim$(Opt(x, which)), removePrefix + 1)) - separgs(x) = Chr$(0) + str2(which) - Else + separgslayout(x) = CHR$(LEN(RTRIM$(Opt(x, which))) - removePrefix) + SCase$(MID$(RTRIM$(Opt(x, which)), removePrefix + 1)) + separgs(x) = CHR$(0) + str2(which) + ELSE 'Not Found... '*********backtrack************ OptCheckBacktrack: 'Was this optional? - If Lev(x) > EntryLev(x) Then 'Optional Opt ()? + IF Lev(x) > EntryLev(x) THEN 'Optional Opt ()? 'Not Found...Optional... 'Simply don't enter the optional higher level and continue as normal BranchTaken(Branches) = 0 level = currentlev 'We aren't entering the level after all, so our level should remain at the opt's entrylevel - Else + ELSE Backtrack: 'Not Found...Mandatory... '1)Erase previous branches where both options have been tried - For branch = Branches To 1 Step -1 'Remove branches until last taken branch is found - If BranchTaken(branch) Then Exit For + FOR branch = Branches TO 1 STEP -1 'Remove branches until last taken branch is found + IF BranchTaken(branch) THEN EXIT FOR Branches = Branches - 1 'Remove branch (it has already been tried with both possible combinations) - Next - If Branches = 0 Then 'All options have been exhausted + NEXT + IF Branches = 0 THEN 'All options have been exhausted seperateargs_error = 1 seperateargs_error_message = "Syntax error" - EXIT Function - End If + EXIT FUNCTION + END IF '2)Toggle taken branch to untaken and revert BranchTaken(Branches) = 0 'toggle branch to untaken Expression = BranchWithExpression(Branches) @@ -21470,59 +21470,59 @@ Function seperateargs (a$, ca$, pass&) x = BranchFormatPos(Branches) level = BranchLevel(Branches) '3)Erase any content created after revert position - If Expression Then separgs(Expression) = "n-ll" - For x2 = x To lastt + IF Expression THEN separgs(Expression) = "n-ll" + FOR x2 = x TO lastt separgs(x2) = "n-ll" separgslayout(x2) = "" - Next - End If 'Optional Opt ()? + NEXT + END IF 'Optional Opt ()? '****************************** - End If 'Found? + END IF 'Found? - End If 't + END IF 't - End If 'possible to enter level + END IF 'possible to enter level - Next x + NEXT x 'Final expression? - If Expression Then - If i <= n Then + IF Expression THEN + IF i <= n THEN separgs(Expression) = getelements$(ca$, i, n) 'can this be an expression? 'check it passes bracketting and comma rules b = 0 - For i2 = i To n + FOR i2 = i TO n c$ = getelement$(a$, i2) - If Asc(c$) = 44 And b = 0 Then - GoTo Backtrack - End If - If Asc(c$) = 40 Then + IF ASC(c$) = 44 AND b = 0 THEN + GOTO Backtrack + END IF + IF ASC(c$) = 40 THEN b = b + 1 - End If - If Asc(c$) = 41 Then + END IF + IF ASC(c$) = 41 THEN b = b - 1 - If b = -1 Then GoTo Backtrack - End If - Next - If b <> 0 Then GoTo Backtrack + IF b = -1 THEN GOTO Backtrack + END IF + NEXT + IF b <> 0 THEN GOTO Backtrack i = n + 1 'So it passes the test below - Else - GoTo Backtrack - End If - End If 'Expression + ELSE + GOTO Backtrack + END IF + END IF 'Expression - If i <> n + 1 Then GoTo Backtrack 'Trailing content? + IF i <> n + 1 THEN GOTO Backtrack 'Trailing content? - If Debug Then - Print #9, "--------SEPERATE ARGUMENTS REPORT #2--------" - For i = 1 To lastt - Print #9, i, separgs(i) - Next - End If + IF Debug THEN + PRINT #9, "--------SEPERATE ARGUMENTS REPORT #2--------" + FOR i = 1 TO lastt + PRINT #9, i, separgs(i) + NEXT + END IF ' DIM PassRule(1 TO 100) AS LONG ' '0 means no pass rule @@ -21531,47 +21531,47 @@ Function seperateargs (a$, ca$, pass&) ' PassFlag = 1 - If PassFlag <> 1 Then seperateargs = 1 'Return whether a 'passed' flags variable is required + IF PassFlag <> 1 THEN seperateargs = 1 'Return whether a 'passed' flags variable is required pass& = 0 'The 'passed' value (shared by argument reference) 'Note: The separgs() elements will be compacted to the C++ function arguments x = 1 'The new index to move compacted content to within separgs() - For i = 1 To lastt + FOR i = 1 TO lastt - If DontPass(i) = 0 Then + IF DontPass(i) = 0 THEN - If PassRule(i) > 0 Then - If separgs(i) <> "n-ll" Then pass& = pass& Or PassRule(i) 'build 'passed' flags - End If + IF PassRule(i) > 0 THEN + IF separgs(i) <> "n-ll" THEN pass& = pass& OR PassRule(i) 'build 'passed' flags + END IF separgs(x) = separgs(i) separgslayout(x) = separgslayout(i) - If Len(separgs(x)) Then - If Asc(separgs(x)) = 0 Then + IF LEN(separgs(x)) THEN + IF ASC(separgs(x)) = 0 THEN 'switch omit layout tag from item to layout info - separgs(x) = Right$(separgs(x), Len(separgs(x)) - 1) - separgslayout(x) = separgslayout(x) + Chr$(0) - End If - End If + separgs(x) = RIGHT$(separgs(x), LEN(separgs(x)) - 1) + separgslayout(x) = separgslayout(x) + CHR$(0) + END IF + END IF - If separgs(x) = "n-ll" Then separgs(x) = "N-LL" + IF separgs(x) = "n-ll" THEN separgs(x) = "N-LL" x = x + 1 - Else + ELSE 'its gonna be skipped! 'add layout to the next one to be safe 'for syntax such as [{HELLO}] which uses a flag instead of being passed - If PassRule(i) > 0 Then - If separgs(i) <> "n-ll" Then pass& = pass& Or PassRule(i) 'build 'passed' flags - End If + IF PassRule(i) > 0 THEN + IF separgs(i) <> "n-ll" THEN pass& = pass& OR PassRule(i) 'build 'passed' flags + END IF separgslayout(i + 1) = separgslayout(i) + separgslayout(i + 1) - End If - Next + END IF + NEXT separgslayout(x) = separgslayout(i) 'set final layout 'x = x - 1 @@ -21579,12 +21579,12 @@ Function seperateargs (a$, ca$, pass&) 'PRINT "pass omit (0/1):"; omit 'PRINT "pass&="; pass& -End Function +END FUNCTION -Sub setrefer (a2$, typ2 As Long, e2$, method As Long) +SUB setrefer (a2$, typ2 AS LONG, e2$, method AS LONG) a$ = a2$: typ = typ2: e$ = e2$ - If method <> 1 Then e$ = fixoperationorder$(e$) - If Error_Happened Then EXIT Sub + IF method <> 1 THEN e$ = fixoperationorder$(e$) + IF Error_Happened THEN EXIT SUB tl$ = tlayout$ 'method: 0 evaulatetotyp e$ @@ -21593,65 +21593,65 @@ Sub setrefer (a2$, typ2 As Long, e2$, method As Long) ' this function handles the problem 'retrieve ID - i = InStr(a$, sp3) - If i Then - idnumber = Val(Left$(a$, i - 1)): a$ = Right$(a$, Len(a$) - i) - Else - idnumber = Val(a$) - End If + i = INSTR(a$, sp3) + IF i THEN + idnumber = VAL(LEFT$(a$, i - 1)): a$ = RIGHT$(a$, LEN(a$) - i) + ELSE + idnumber = VAL(a$) + END IF getid idnumber - If Error_Happened Then EXIT Sub + IF Error_Happened THEN EXIT SUB 'UDT? - If typ And ISUDT Then + IF typ AND ISUDT THEN 'print "setrefer-ing a UDT!" - u = Val(a$) - i = InStr(a$, sp3): a$ = Right$(a$, Len(a$) - i): E = Val(a$) - i = InStr(a$, sp3): o$ = Right$(a$, Len(a$) - i) - n$ = "UDT_" + RTrim$(id.n): If id.t = 0 Then n$ = "ARRAY_" + n$ + "[0]" + u = VAL(a$) + i = INSTR(a$, sp3): a$ = RIGHT$(a$, LEN(a$) - i): E = VAL(a$) + i = INSTR(a$, sp3): o$ = RIGHT$(a$, LEN(a$) - i) + n$ = "UDT_" + RTRIM$(id.n): IF id.t = 0 THEN n$ = "ARRAY_" + n$ + "[0]" - If E <> 0 And u = 1 Then 'Setting _MEM type elements is not allowed! - Give_Error "Cannot set read-only element of _MEM TYPE": EXIT Sub - End If + IF E <> 0 AND u = 1 THEN 'Setting _MEM type elements is not allowed! + Give_Error "Cannot set read-only element of _MEM TYPE": EXIT SUB + END IF - If E = 0 Then + IF E = 0 THEN 'use u and u's size - If method <> 0 Then Give_Error "Unexpected internal code reference to UDT": EXIT Sub + IF method <> 0 THEN Give_Error "Unexpected internal code reference to UDT": EXIT SUB lhsscope$ = scope$ e$ = evaluate(e$, t2) - If Error_Happened Then EXIT Sub - If (t2 And ISUDT) = 0 Then Give_Error "Expected = similar user defined type": EXIT Sub + IF Error_Happened THEN EXIT SUB + IF (t2 AND ISUDT) = 0 THEN Give_Error "Expected = similar user defined type": EXIT SUB - If (t2 And ISREFERENCE) = 0 Then - If t2 And ISPOINTER Then + IF (t2 AND ISREFERENCE) = 0 THEN + IF t2 AND ISPOINTER THEN src$ = "((char*)" + e$ + ")" - e2 = 0: u2 = t2 And 511 - Else + e2 = 0: u2 = t2 AND 511 + ELSE src$ = "((char*)&" + e$ + ")" - e2 = 0: u2 = t2 And 511 - End If - GoTo directudt - End If + e2 = 0: u2 = t2 AND 511 + END IF + GOTO directudt + END IF '****problem**** - idnumber2 = Val(e$) + idnumber2 = VAL(e$) getid idnumber2 - If Error_Happened Then EXIT Sub - n2$ = "UDT_" + RTrim$(id.n): If id.t = 0 Then n2$ = "ARRAY_" + n2$ + "[0]" - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i): u2 = Val(e$) - i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i): e2 = Val(e$) - i = InStr(e$, sp3): o2$ = Right$(e$, Len(e$) - i) + IF Error_Happened THEN EXIT SUB + n2$ = "UDT_" + RTRIM$(id.n): IF id.t = 0 THEN n2$ = "ARRAY_" + n2$ + "[0]" + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i): u2 = VAL(e$) + i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i): e2 = VAL(e$) + i = INSTR(e$, sp3): o2$ = RIGHT$(e$, LEN(e$) - i) 'WARNING: u2 may need minor modifications based on e to see if they are the same 'we have now established we have 2 pointers to similar data types! 'ASSUME BYTE TYPE!!! src$ = "((char*)" + scope$ + n2$ + ")+(" + o2$ + ")" directudt: - If u <> u2 Or e2 <> 0 Then Give_Error "Expected = similar user defined type": EXIT Sub + IF u <> u2 OR e2 <> 0 THEN Give_Error "Expected = similar user defined type": EXIT SUB dst$ = "((char*)" + lhsscope$ + n$ + ")+(" + o$ + ")" copy_full_udt dst$, src$, 12, 0, u @@ -21659,582 +21659,582 @@ Sub setrefer (a2$, typ2 As Long, e2$, method As Long) 'print "setFULLUDTrefer!" tlayout$ = tl$ - EXIT Sub + EXIT SUB - End If 'e=0 + END IF 'e=0 - If typ And ISOFFSETINBITS Then Give_Error "Cannot resolve bit-length variables inside user defined types yet": EXIT Sub - If typ And ISSTRING Then - If typ And ISFIXEDLENGTH Then + IF typ AND ISOFFSETINBITS THEN Give_Error "Cannot resolve bit-length variables inside user defined types yet": EXIT SUB + IF typ AND ISSTRING THEN + IF typ AND ISFIXEDLENGTH THEN o2$ = "(((uint8*)" + scope$ + n$ + ")+(" + o$ + "))" r$ = "qbs_new_fixed(" + o2$ + "," + str2(udtetypesize(E)) + ",1)" - Else + ELSE r$ = "*((qbs**)((char*)(" + scope$ + n$ + ")+(" + o$ + ")))" - End If - If method = 0 Then e$ = evaluatetotyp(e$, STRINGTYPE - ISPOINTER) - If Error_Happened Then EXIT Sub - Print #12, "qbs_set(" + r$ + "," + e$ + ");" - Print #12, cleanupstringprocessingcall$ + "0);" - Else + END IF + IF method = 0 THEN e$ = evaluatetotyp(e$, STRINGTYPE - ISPOINTER) + IF Error_Happened THEN EXIT SUB + PRINT #12, "qbs_set(" + r$ + "," + e$ + ");" + PRINT #12, cleanupstringprocessingcall$ + "0);" + ELSE typ = typ - ISUDT - ISREFERENCE - ISPOINTER - If typ And ISARRAY Then typ = typ - ISARRAY + IF typ AND ISARRAY THEN typ = typ - ISARRAY t$ = typ2ctyp$(typ, "") - If Error_Happened Then EXIT Sub + IF Error_Happened THEN EXIT SUB o2$ = "(((char*)" + scope$ + n$ + ")+(" + o$ + "))" r$ = "*" + "(" + t$ + "*)" + o2$ - If method = 0 Then e$ = evaluatetotyp(e$, typ) - If Error_Happened Then EXIT Sub - Print #12, r$ + "=" + e$ + ";" - End If + IF method = 0 THEN e$ = evaluatetotyp(e$, typ) + IF Error_Happened THEN EXIT SUB + PRINT #12, r$ + "=" + e$ + ";" + END IF 'print "setUDTrefer:"+r$,e$ tlayout$ = tl$ - If Left$(r$, 1) = "*" Then r$ = Mid$(r$, 2) + IF LEFT$(r$, 1) = "*" THEN r$ = MID$(r$, 2) manageVariableList "", scope$ + n$, 7 - EXIT Sub - End If + EXIT SUB + END IF 'array? - If id.arraytype Then - n$ = RTrim$(id.callname) + IF id.arraytype THEN + n$ = RTRIM$(id.callname) typ = typ - ISPOINTER - ISREFERENCE 'typ now looks like a regular value - If (typ And ISSTRING) Then - If (typ And ISFIXEDLENGTH) Then + IF (typ AND ISSTRING) THEN + IF (typ AND ISFIXEDLENGTH) THEN offset$ = "&((uint8*)(" + n$ + "[0]))[tmp_long*" + str2(id.tsize) + "]" r$ = "qbs_new_fixed(" + offset$ + "," + str2(id.tsize) + ",1)" - Print #12, "tmp_long=" + a$ + ";" - If method = 0 Then + PRINT #12, "tmp_long=" + a$ + ";" + IF method = 0 THEN l$ = "if (!new_error) qbs_set(" + r$ + "," + evaluatetotyp(e$, typ) + ");" - If Error_Happened Then EXIT Sub - Else + IF Error_Happened THEN EXIT SUB + ELSE l$ = "if (!new_error) qbs_set(" + r$ + "," + e$ + ");" - End If - Print #12, l$ - Else - Print #12, "tmp_long=" + a$ + ";" - If method = 0 Then + END IF + PRINT #12, l$ + ELSE + PRINT #12, "tmp_long=" + a$ + ";" + IF method = 0 THEN l$ = "if (!new_error) qbs_set( ((qbs*)(((uint64*)(" + n$ + "[0]))[tmp_long]))," + evaluatetotyp(e$, typ) + ");" - If Error_Happened Then EXIT Sub - Else + IF Error_Happened THEN EXIT SUB + ELSE l$ = "if (!new_error) qbs_set( ((qbs*)(((uint64*)(" + n$ + "[0]))[tmp_long]))," + e$ + ");" - End If - Print #12, l$ - End If - Print #12, cleanupstringprocessingcall$ + "0);" + END IF + PRINT #12, l$ + END IF + PRINT #12, cleanupstringprocessingcall$ + "0);" tlayout$ = tl$ - If Left$(r$, 1) = "*" Then r$ = Mid$(r$, 2) + IF LEFT$(r$, 1) = "*" THEN r$ = MID$(r$, 2) manageVariableList "", r$, 8 - EXIT Sub - End If + EXIT SUB + END IF - If (typ And ISOFFSETINBITS) Then + IF (typ AND ISOFFSETINBITS) THEN 'r$ = "setbits_" + str2(typ AND 511) + "(" - r$ = "setbits(" + str2(typ And 511) + "," + r$ = "setbits(" + str2(typ AND 511) + "," r$ = r$ + "(uint8*)(" + n$ + "[0])" + ",tmp_long," - Print #12, "tmp_long=" + a$ + ";" - If method = 0 Then + PRINT #12, "tmp_long=" + a$ + ";" + IF method = 0 THEN l$ = "if (!new_error) " + r$ + evaluatetotyp(e$, typ) + ");" - If Error_Happened Then EXIT Sub - Else + IF Error_Happened THEN EXIT SUB + ELSE l$ = "if (!new_error) " + r$ + e$ + ");" - End If - Print #12, l$ + END IF + PRINT #12, l$ tlayout$ = tl$ - EXIT Sub - Else + EXIT SUB + ELSE t$ = "" - If (typ And ISFLOAT) Then - If (typ And 511) = 32 Then t$ = "float" - If (typ And 511) = 64 Then t$ = "double" - If (typ And 511) = 256 Then t$ = "long double" - Else - If (typ And ISUNSIGNED) Then - If (typ And 511) = 8 Then t$ = "uint8" - If (typ And 511) = 16 Then t$ = "uint16" - If (typ And 511) = 32 Then t$ = "uint32" - If (typ And 511) = 64 Then t$ = "uint64" - If typ And ISOFFSET Then t$ = "uptrszint" - Else - If (typ And 511) = 8 Then t$ = "int8" - If (typ And 511) = 16 Then t$ = "int16" - If (typ And 511) = 32 Then t$ = "int32" - If (typ And 511) = 64 Then t$ = "int64" - If typ And ISOFFSET Then t$ = "ptrszint" - End If - End If - End If - If t$ = "" Then Give_Error "Cannot find C type to return array data": EXIT Sub - Print #12, "tmp_long=" + a$ + ";" - If method = 0 Then + IF (typ AND ISFLOAT) THEN + IF (typ AND 511) = 32 THEN t$ = "float" + IF (typ AND 511) = 64 THEN t$ = "double" + IF (typ AND 511) = 256 THEN t$ = "long double" + ELSE + IF (typ AND ISUNSIGNED) THEN + IF (typ AND 511) = 8 THEN t$ = "uint8" + IF (typ AND 511) = 16 THEN t$ = "uint16" + IF (typ AND 511) = 32 THEN t$ = "uint32" + IF (typ AND 511) = 64 THEN t$ = "uint64" + IF typ AND ISOFFSET THEN t$ = "uptrszint" + ELSE + IF (typ AND 511) = 8 THEN t$ = "int8" + IF (typ AND 511) = 16 THEN t$ = "int16" + IF (typ AND 511) = 32 THEN t$ = "int32" + IF (typ AND 511) = 64 THEN t$ = "int64" + IF typ AND ISOFFSET THEN t$ = "ptrszint" + END IF + END IF + END IF + IF t$ = "" THEN Give_Error "Cannot find C type to return array data": EXIT SUB + PRINT #12, "tmp_long=" + a$ + ";" + IF method = 0 THEN l$ = "if (!new_error) ((" + t$ + "*)(" + n$ + "[0]))[tmp_long]=" + evaluatetotyp(e$, typ) + ";" - If Error_Happened Then EXIT Sub - Else + IF Error_Happened THEN EXIT SUB + ELSE l$ = "if (!new_error) ((" + t$ + "*)(" + n$ + "[0]))[tmp_long]=" + e$ + ";" - End If + END IF - Print #12, l$ + PRINT #12, l$ tlayout$ = tl$ - EXIT Sub - End If 'array + EXIT SUB + END IF 'array 'variable? - If id.t Then - r$ = RTrim$(id.n) + IF id.t THEN + r$ = RTRIM$(id.n) t = id.t 'remove irrelavant flags - If (t And ISINCONVENTIONALMEMORY) Then t = t - ISINCONVENTIONALMEMORY + IF (t AND ISINCONVENTIONALMEMORY) THEN t = t - ISINCONVENTIONALMEMORY typ = t 'string variable? - If (t And ISSTRING) Then - If (t And ISFIXEDLENGTH) Then + IF (t AND ISSTRING) THEN + IF (t AND ISFIXEDLENGTH) THEN r$ = scope$ + "STRING" + str2(id.tsize) + "_" + r$ - Else + ELSE r$ = scope$ + "STRING_" + r$ - End If - If method = 0 Then e$ = evaluatetotyp(e$, ISSTRING) - If Error_Happened Then EXIT Sub - Print #12, "qbs_set(" + r$ + "," + e$ + ");" - Print #12, cleanupstringprocessingcall$ + "0);" - If arrayprocessinghappened Then arrayprocessinghappened = 0 + END IF + IF method = 0 THEN e$ = evaluatetotyp(e$, ISSTRING) + IF Error_Happened THEN EXIT SUB + PRINT #12, "qbs_set(" + r$ + "," + e$ + ");" + PRINT #12, cleanupstringprocessingcall$ + "0);" + IF arrayprocessinghappened THEN arrayprocessinghappened = 0 tlayout$ = tl$ - If Left$(r$, 1) = "*" Then r$ = Mid$(r$, 2) + IF LEFT$(r$, 1) = "*" THEN r$ = MID$(r$, 2) manageVariableList "", r$, 9 - EXIT Sub - End If + EXIT SUB + END IF 'bit-length variable? - If (t And ISOFFSETINBITS) Then - b = t And 511 - If (t And ISUNSIGNED) Then - r$ = "*" + scope$ + "UBIT" + str2(t And 511) + "_" + r$ - If method = 0 Then e$ = evaluatetotyp(e$, 64& + ISUNSIGNED) - If Error_Happened Then EXIT Sub + IF (t AND ISOFFSETINBITS) THEN + b = t AND 511 + IF (t AND ISUNSIGNED) THEN + r$ = "*" + scope$ + "UBIT" + str2(t AND 511) + "_" + r$ + IF method = 0 THEN e$ = evaluatetotyp(e$, 64& + ISUNSIGNED) + IF Error_Happened THEN EXIT SUB l$ = r$ + "=(" + e$ + ")&" + str2(bitmask(b)) + ";" - Print #12, l$ - Else - r$ = "*" + scope$ + "BIT" + str2(t And 511) + "_" + r$ - If method = 0 Then e$ = evaluatetotyp(e$, 64&) - If Error_Happened Then EXIT Sub + PRINT #12, l$ + ELSE + r$ = "*" + scope$ + "BIT" + str2(t AND 511) + "_" + r$ + IF method = 0 THEN e$ = evaluatetotyp(e$, 64&) + IF Error_Happened THEN EXIT SUB l$ = "if ((" + r$ + "=" + e$ + ")&" + str2(2 ^ (b - 1)) + "){" - Print #12, l$ + PRINT #12, l$ 'signed bit is set l$ = r$ + "|=" + str2(bitmaskinv(b)) + ";" - Print #12, l$ - Print #12, "}else{" + PRINT #12, l$ + PRINT #12, "}else{" 'signed bit is not set l$ = r$ + "&=" + str2(bitmask(b)) + ";" - Print #12, l$ - Print #12, "}" - End If - If stringprocessinghappened Then Print #12, cleanupstringprocessingcall$ + "0);": stringprocessinghappened = 0 - If arrayprocessinghappened Then arrayprocessinghappened = 0 + PRINT #12, l$ + PRINT #12, "}" + END IF + IF stringprocessinghappened THEN PRINT #12, cleanupstringprocessingcall$ + "0);": stringprocessinghappened = 0 + IF arrayprocessinghappened THEN arrayprocessinghappened = 0 tlayout$ = tl$ - If Left$(r$, 1) = "*" Then r$ = Mid$(r$, 2) + IF LEFT$(r$, 1) = "*" THEN r$ = MID$(r$, 2) manageVariableList "", r$, 10 - EXIT Sub - End If + EXIT SUB + END IF 'standard variable? - If t = BYTETYPE Then r$ = "*" + scope$ + "BYTE_" + r$: GoTo sref - If t = UBYTETYPE Then r$ = "*" + scope$ + "UBYTE_" + r$: GoTo sref - If t = INTEGERTYPE Then r$ = "*" + scope$ + "INTEGER_" + r$: GoTo sref - If t = UINTEGERTYPE Then r$ = "*" + scope$ + "UINTEGER_" + r$: GoTo sref - If t = LONGTYPE Then r$ = "*" + scope$ + "LONG_" + r$: GoTo sref - If t = ULONGTYPE Then r$ = "*" + scope$ + "ULONG_" + r$: GoTo sref - If t = INTEGER64TYPE Then r$ = "*" + scope$ + "INTEGER64_" + r$: GoTo sref - If t = UINTEGER64TYPE Then r$ = "*" + scope$ + "UINTEGER64_" + r$: GoTo sref - If t = SINGLETYPE Then r$ = "*" + scope$ + "SINGLE_" + r$: GoTo sref - If t = DOUBLETYPE Then r$ = "*" + scope$ + "DOUBLE_" + r$: GoTo sref - If t = FLOATTYPE Then r$ = "*" + scope$ + "FLOAT_" + r$: GoTo sref - If t = OFFSETTYPE Then r$ = "*" + scope$ + "OFFSET_" + r$: GoTo sref - If t = UOFFSETTYPE Then r$ = "*" + scope$ + "UOFFSET_" + r$: GoTo sref + IF t = BYTETYPE THEN r$ = "*" + scope$ + "BYTE_" + r$: GOTO sref + IF t = UBYTETYPE THEN r$ = "*" + scope$ + "UBYTE_" + r$: GOTO sref + IF t = INTEGERTYPE THEN r$ = "*" + scope$ + "INTEGER_" + r$: GOTO sref + IF t = UINTEGERTYPE THEN r$ = "*" + scope$ + "UINTEGER_" + r$: GOTO sref + IF t = LONGTYPE THEN r$ = "*" + scope$ + "LONG_" + r$: GOTO sref + IF t = ULONGTYPE THEN r$ = "*" + scope$ + "ULONG_" + r$: GOTO sref + IF t = INTEGER64TYPE THEN r$ = "*" + scope$ + "INTEGER64_" + r$: GOTO sref + IF t = UINTEGER64TYPE THEN r$ = "*" + scope$ + "UINTEGER64_" + r$: GOTO sref + IF t = SINGLETYPE THEN r$ = "*" + scope$ + "SINGLE_" + r$: GOTO sref + IF t = DOUBLETYPE THEN r$ = "*" + scope$ + "DOUBLE_" + r$: GOTO sref + IF t = FLOATTYPE THEN r$ = "*" + scope$ + "FLOAT_" + r$: GOTO sref + IF t = OFFSETTYPE THEN r$ = "*" + scope$ + "OFFSET_" + r$: GOTO sref + IF t = UOFFSETTYPE THEN r$ = "*" + scope$ + "UOFFSET_" + r$: GOTO sref sref: t2 = t - ISPOINTER - If method = 0 Then e$ = evaluatetotyp(e$, t2) - If Error_Happened Then EXIT Sub + IF method = 0 THEN e$ = evaluatetotyp(e$, t2) + IF Error_Happened THEN EXIT SUB l$ = r$ + "=" + e$ + ";" - Print #12, l$ - If stringprocessinghappened Then Print #12, cleanupstringprocessingcall$ + "0);": stringprocessinghappened = 0 - If arrayprocessinghappened Then arrayprocessinghappened = 0 + PRINT #12, l$ + IF stringprocessinghappened THEN PRINT #12, cleanupstringprocessingcall$ + "0);": stringprocessinghappened = 0 + IF arrayprocessinghappened THEN arrayprocessinghappened = 0 tlayout$ = tl$ - If Left$(r$, 1) = "*" Then r$ = Mid$(r$, 2) + IF LEFT$(r$, 1) = "*" THEN r$ = MID$(r$, 2) manageVariableList "", r$, 11 - EXIT Sub - End If 'variable + EXIT SUB + END IF 'variable tlayout$ = tl$ -End Sub +END SUB -Function str2$ (v As Long) - str2$ = _Trim$(Str$(v)) -End Function +FUNCTION str2$ (v AS LONG) + str2$ = _TRIM$(STR$(v)) +END FUNCTION -Function str2u64$ (v~&&) - str2u64$ = LTrim$(RTrim$(Str$(v~&&))) -End Function +FUNCTION str2u64$ (v~&&) + str2u64$ = LTRIM$(RTRIM$(STR$(v~&&))) +END FUNCTION -Function str2i64$ (v&&) - str2i64$ = LTrim$(RTrim$(Str$(v&&))) -End Function +FUNCTION str2i64$ (v&&) + str2i64$ = LTRIM$(RTRIM$(STR$(v&&))) +END FUNCTION -Function typ2ctyp$ (t As Long, tstr As String) +FUNCTION typ2ctyp$ (t AS LONG, tstr AS STRING) ctyp$ = "" 'typ can be passed as either: (the unused value is ignored) 'i. as a typ value in t 'ii. as a typ symbol (eg. "~%") in tstr 'iii. as a typ name (eg. _UNSIGNED INTEGER) in tstr - If tstr$ = "" Then - If (t And ISARRAY) Then EXIT Function 'cannot return array types - If (t And ISSTRING) Then typ2ctyp$ = "qbs": EXIT Function - b = t And 511 - If (t And ISUDT) Then typ2ctyp$ = "void": EXIT Function - If (t And ISOFFSETINBITS) Then - If b <= 32 Then ctyp$ = "int32" Else ctyp$ = "int64" - If (t And ISUNSIGNED) Then ctyp$ = "u" + ctyp$ - typ2ctyp$ = ctyp$: EXIT Function - End If - If (t And ISFLOAT) Then - If b = 32 Then ctyp$ = "float" - If b = 64 Then ctyp$ = "double" - If b = 256 Then ctyp$ = "long double" - Else - If b = 8 Then ctyp$ = "int8" - If b = 16 Then ctyp$ = "int16" - If b = 32 Then ctyp$ = "int32" - If b = 64 Then ctyp$ = "int64" - If typ And ISOFFSET Then ctyp$ = "ptrszint" - If (t And ISUNSIGNED) Then ctyp$ = "u" + ctyp$ - End If - If t And ISOFFSET Then - ctyp$ = "ptrszint": If (t And ISUNSIGNED) Then ctyp$ = "uptrszint" - End If - typ2ctyp$ = ctyp$: EXIT Function - End If + IF tstr$ = "" THEN + IF (t AND ISARRAY) THEN EXIT FUNCTION 'cannot return array types + IF (t AND ISSTRING) THEN typ2ctyp$ = "qbs": EXIT FUNCTION + b = t AND 511 + IF (t AND ISUDT) THEN typ2ctyp$ = "void": EXIT FUNCTION + IF (t AND ISOFFSETINBITS) THEN + IF b <= 32 THEN ctyp$ = "int32" ELSE ctyp$ = "int64" + IF (t AND ISUNSIGNED) THEN ctyp$ = "u" + ctyp$ + typ2ctyp$ = ctyp$: EXIT FUNCTION + END IF + IF (t AND ISFLOAT) THEN + IF b = 32 THEN ctyp$ = "float" + IF b = 64 THEN ctyp$ = "double" + IF b = 256 THEN ctyp$ = "long double" + ELSE + IF b = 8 THEN ctyp$ = "int8" + IF b = 16 THEN ctyp$ = "int16" + IF b = 32 THEN ctyp$ = "int32" + IF b = 64 THEN ctyp$ = "int64" + IF typ AND ISOFFSET THEN ctyp$ = "ptrszint" + IF (t AND ISUNSIGNED) THEN ctyp$ = "u" + ctyp$ + END IF + IF t AND ISOFFSET THEN + ctyp$ = "ptrszint": IF (t AND ISUNSIGNED) THEN ctyp$ = "uptrszint" + END IF + typ2ctyp$ = ctyp$: EXIT FUNCTION + END IF ts$ = tstr$ 'is ts$ a symbol? - If ts$ = "$" Then ctyp$ = "qbs" - If ts$ = "!" Then ctyp$ = "float" - If ts$ = "#" Then ctyp$ = "double" - If ts$ = "##" Then ctyp$ = "long double" - If Left$(ts$, 1) = "~" Then unsgn = 1: ts$ = Right$(ts$, Len(ts$) - 1) - If Left$(ts$, 1) = "`" Then - n$ = Right$(ts$, Len(ts$) - 1) + IF ts$ = "$" THEN ctyp$ = "qbs" + IF ts$ = "!" THEN ctyp$ = "float" + IF ts$ = "#" THEN ctyp$ = "double" + IF ts$ = "##" THEN ctyp$ = "long double" + IF LEFT$(ts$, 1) = "~" THEN unsgn = 1: ts$ = RIGHT$(ts$, LEN(ts$) - 1) + IF LEFT$(ts$, 1) = "`" THEN + n$ = RIGHT$(ts$, LEN(ts$) - 1) b = 1 - If n$ <> "" Then - If isuinteger(n$) = 0 Then Give_Error "Invalid index after _BIT type": EXIT Function - b = Val(n$) - If b > 57 Then Give_Error "Invalid index after _BIT type": EXIT Function - End If - If b <= 32 Then ctyp$ = "int32" Else ctyp$ = "int64" - If unsgn Then ctyp$ = "u" + ctyp$ - typ2ctyp$ = ctyp$: EXIT Function - End If - If ts$ = "%&" Then - typ2ctyp$ = "ptrszint": If (t And ISUNSIGNED) Then typ2ctyp$ = "uptrszint" - EXIT Function - End If - If ts$ = "%%" Then ctyp$ = "int8" - If ts$ = "%" Then ctyp$ = "int16" - If ts$ = "&" Then ctyp$ = "int32" - If ts$ = "&&" Then ctyp$ = "int64" - If ctyp$ <> "" Then - If unsgn Then ctyp$ = "u" + ctyp$ - typ2ctyp$ = ctyp$: EXIT Function - End If + IF n$ <> "" THEN + IF isuinteger(n$) = 0 THEN Give_Error "Invalid index after _BIT type": EXIT FUNCTION + b = VAL(n$) + IF b > 57 THEN Give_Error "Invalid index after _BIT type": EXIT FUNCTION + END IF + IF b <= 32 THEN ctyp$ = "int32" ELSE ctyp$ = "int64" + IF unsgn THEN ctyp$ = "u" + ctyp$ + typ2ctyp$ = ctyp$: EXIT FUNCTION + END IF + IF ts$ = "%&" THEN + typ2ctyp$ = "ptrszint": IF (t AND ISUNSIGNED) THEN typ2ctyp$ = "uptrszint" + EXIT FUNCTION + END IF + IF ts$ = "%%" THEN ctyp$ = "int8" + IF ts$ = "%" THEN ctyp$ = "int16" + IF ts$ = "&" THEN ctyp$ = "int32" + IF ts$ = "&&" THEN ctyp$ = "int64" + IF ctyp$ <> "" THEN + IF unsgn THEN ctyp$ = "u" + ctyp$ + typ2ctyp$ = ctyp$: EXIT FUNCTION + END IF 'is tstr$ a named type? (eg. 'LONG') s$ = type2symbol$(tstr$) - If Error_Happened Then EXIT Function - If Len(s$) Then + IF Error_Happened THEN EXIT FUNCTION + IF LEN(s$) THEN typ2ctyp$ = typ2ctyp$(0, s$) - If Error_Happened Then EXIT Function - EXIT Function - End If + IF Error_Happened THEN EXIT FUNCTION + EXIT FUNCTION + END IF - Give_Error "Invalid type": EXIT Function + Give_Error "Invalid type": EXIT FUNCTION -End Function +END FUNCTION -Function type2symbol$ (typ$) +FUNCTION type2symbol$ (typ$) t$ = typ$ - For i = 1 To Len(t$) - If Mid$(t$, i, 1) = sp Then Mid$(t$, i, 1) = " " - Next + FOR i = 1 TO LEN(t$) + IF MID$(t$, i, 1) = sp THEN MID$(t$, i, 1) = " " + NEXT e$ = "Cannot convert type (" + typ$ + ") to symbol" - t2$ = "_UNSIGNED _BIT": s$ = "~`1": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "_UNSIGNED _BYTE": s$ = "~%%": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "_UNSIGNED INTEGER": s$ = "~%": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "_UNSIGNED LONG": s$ = "~&": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "_UNSIGNED _INTEGER64": s$ = "~&&": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "_UNSIGNED _OFFSET": s$ = "~%&": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "_BIT": s$ = "`1": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "_BYTE": s$ = "%%": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "INTEGER": s$ = "%": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "LONG": s$ = "&": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "_INTEGER64": s$ = "&&": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "_OFFSET": s$ = "%&": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "SINGLE": s$ = "!": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "DOUBLE": s$ = "#": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "_FLOAT": s$ = "##": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "STRING": s$ = "$": If Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "UNSIGNED BIT": s$ = "~`1": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "UNSIGNED BYTE": s$ = "~%%": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "UNSIGNED INTEGER": s$ = "~%": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "UNSIGNED LONG": s$ = "~&": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "UNSIGNED INTEGER64": s$ = "~&&": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "UNSIGNED OFFSET": s$ = "~%&": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "BIT": s$ = "`1": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "BYTE": s$ = "%%": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "INTEGER64": s$ = "&&": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "OFFSET": s$ = "%&": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - t2$ = "FLOAT": s$ = "##": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound - Give_Error e$: EXIT Function + t2$ = "_UNSIGNED _BIT": s$ = "~`1": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "_UNSIGNED _BYTE": s$ = "~%%": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "_UNSIGNED INTEGER": s$ = "~%": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "_UNSIGNED LONG": s$ = "~&": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "_UNSIGNED _INTEGER64": s$ = "~&&": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "_UNSIGNED _OFFSET": s$ = "~%&": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "_BIT": s$ = "`1": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "_BYTE": s$ = "%%": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "INTEGER": s$ = "%": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "LONG": s$ = "&": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "_INTEGER64": s$ = "&&": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "_OFFSET": s$ = "%&": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "SINGLE": s$ = "!": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "DOUBLE": s$ = "#": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "_FLOAT": s$ = "##": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "STRING": s$ = "$": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "UNSIGNED BIT": s$ = "~`1": IF qb64prefix_set = 1 AND LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "UNSIGNED BYTE": s$ = "~%%": IF qb64prefix_set = 1 AND LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "UNSIGNED INTEGER": s$ = "~%": IF qb64prefix_set = 1 AND LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "UNSIGNED LONG": s$ = "~&": IF qb64prefix_set = 1 AND LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "UNSIGNED INTEGER64": s$ = "~&&": IF qb64prefix_set = 1 AND LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "UNSIGNED OFFSET": s$ = "~%&": IF qb64prefix_set = 1 AND LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "BIT": s$ = "`1": IF qb64prefix_set = 1 AND LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "BYTE": s$ = "%%": IF qb64prefix_set = 1 AND LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "INTEGER64": s$ = "&&": IF qb64prefix_set = 1 AND LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "OFFSET": s$ = "%&": IF qb64prefix_set = 1 AND LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + t2$ = "FLOAT": s$ = "##": IF qb64prefix_set = 1 AND LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound + Give_Error e$: EXIT FUNCTION t2sfound: type2symbol$ = s$ - If Len(t2$) <> Len(t$) Then - If s$ <> "$" And s$ <> "~`1" And s$ <> "`1" Then Give_Error e$: EXIT Function - t$ = Right$(t$, Len(t$) - Len(t2$)) - If Left$(t$, 3) <> " * " Then Give_Error e$: EXIT Function - t$ = Right$(t$, Len(t$) - 3) - If isuinteger(t$) = 0 Then Give_Error e$: EXIT Function - v = Val(t$) - If v = 0 Then Give_Error e$: EXIT Function - If s$ <> "$" And v > 56 Then Give_Error e$: EXIT Function - If s$ = "$" Then + IF LEN(t2$) <> LEN(t$) THEN + IF s$ <> "$" AND s$ <> "~`1" AND s$ <> "`1" THEN Give_Error e$: EXIT FUNCTION + t$ = RIGHT$(t$, LEN(t$) - LEN(t2$)) + IF LEFT$(t$, 3) <> " * " THEN Give_Error e$: EXIT FUNCTION + t$ = RIGHT$(t$, LEN(t$) - 3) + IF isuinteger(t$) = 0 THEN Give_Error e$: EXIT FUNCTION + v = VAL(t$) + IF v = 0 THEN Give_Error e$: EXIT FUNCTION + IF s$ <> "$" AND v > 56 THEN Give_Error e$: EXIT FUNCTION + IF s$ = "$" THEN s$ = s$ + str2$(v) - Else - s$ = Left$(s$, Len(s$) - 1) + str2$(v) - End If + ELSE + s$ = LEFT$(s$, LEN(s$) - 1) + str2$(v) + END IF type2symbol$ = s$ - End If -End Function + END IF +END FUNCTION 'Strips away bits/indentifiers which make locating a variables source difficult -Function typecomp (typ) +FUNCTION typecomp (typ) typ2 = typ - If (typ2 And ISINCONVENTIONALMEMORY) Then typ2 = typ2 - ISINCONVENTIONALMEMORY + IF (typ2 AND ISINCONVENTIONALMEMORY) THEN typ2 = typ2 - ISINCONVENTIONALMEMORY typecomp = typ2 -End Function +END FUNCTION -Function typname2typ& (t2$) +FUNCTION typname2typ& (t2$) typname2typsize = 0 'the default t$ = t2$ 'symbol? ts$ = t$ - If ts$ = "$" Then typname2typ& = STRINGTYPE: EXIT Function - If ts$ = "!" Then typname2typ& = SINGLETYPE: EXIT Function - If ts$ = "#" Then typname2typ& = DOUBLETYPE: EXIT Function - If ts$ = "##" Then typname2typ& = FLOATTYPE: EXIT Function + IF ts$ = "$" THEN typname2typ& = STRINGTYPE: EXIT FUNCTION + IF ts$ = "!" THEN typname2typ& = SINGLETYPE: EXIT FUNCTION + IF ts$ = "#" THEN typname2typ& = DOUBLETYPE: EXIT FUNCTION + IF ts$ = "##" THEN typname2typ& = FLOATTYPE: EXIT FUNCTION 'fixed length string? - If Left$(ts$, 1) = "$" Then - n$ = Right$(ts$, Len(ts$) - 1) - If isuinteger(n$) = 0 Then Give_Error "Invalid index after STRING * type": EXIT Function - b = Val(n$) - If b = 0 Then Give_Error "Invalid index after STRING * type": EXIT Function + IF LEFT$(ts$, 1) = "$" THEN + n$ = RIGHT$(ts$, LEN(ts$) - 1) + IF isuinteger(n$) = 0 THEN Give_Error "Invalid index after STRING * type": EXIT FUNCTION + b = VAL(n$) + IF b = 0 THEN Give_Error "Invalid index after STRING * type": EXIT FUNCTION typname2typsize = b typname2typ& = STRINGTYPE + ISFIXEDLENGTH - EXIT Function - End If + EXIT FUNCTION + END IF 'unsigned? - If Left$(ts$, 1) = "~" Then unsgn = 1: ts$ = Right$(ts$, Len(ts$) - 1) + IF LEFT$(ts$, 1) = "~" THEN unsgn = 1: ts$ = RIGHT$(ts$, LEN(ts$) - 1) 'bit-type? - If Left$(ts$, 1) = "`" Then - n$ = Right$(ts$, Len(ts$) - 1) + IF LEFT$(ts$, 1) = "`" THEN + n$ = RIGHT$(ts$, LEN(ts$) - 1) b = 1 - If n$ <> "" Then - If isuinteger(n$) = 0 Then Give_Error "Invalid index after _BIT type": EXIT Function - b = Val(n$) - If b > 56 Then Give_Error "Invalid index after _BIT type": EXIT Function - End If - If unsgn Then typname2typ& = UBITTYPE + (b - 1) Else typname2typ& = BITTYPE + (b - 1) - EXIT Function - End If + IF n$ <> "" THEN + IF isuinteger(n$) = 0 THEN Give_Error "Invalid index after _BIT type": EXIT FUNCTION + b = VAL(n$) + IF b > 56 THEN Give_Error "Invalid index after _BIT type": EXIT FUNCTION + END IF + IF unsgn THEN typname2typ& = UBITTYPE + (b - 1) ELSE typname2typ& = BITTYPE + (b - 1) + EXIT FUNCTION + END IF t = 0 - If ts$ = "%%" Then t = BYTETYPE - If ts$ = "%" Then t = INTEGERTYPE - If ts$ = "&" Then t = LONGTYPE - If ts$ = "&&" Then t = INTEGER64TYPE - If ts$ = "%&" Then t = OFFSETTYPE + IF ts$ = "%%" THEN t = BYTETYPE + IF ts$ = "%" THEN t = INTEGERTYPE + IF ts$ = "&" THEN t = LONGTYPE + IF ts$ = "&&" THEN t = INTEGER64TYPE + IF ts$ = "%&" THEN t = OFFSETTYPE - If t Then - If unsgn Then t = t + ISUNSIGNED - typname2typ& = t: EXIT Function - End If + IF t THEN + IF unsgn THEN t = t + ISUNSIGNED + typname2typ& = t: EXIT FUNCTION + END IF 'not a valid symbol 'type name? - For i = 1 To Len(t$) - If Mid$(t$, i, 1) = sp Then Mid$(t$, i, 1) = " " - Next - If t$ = "STRING" Then typname2typ& = STRINGTYPE: EXIT Function + FOR i = 1 TO LEN(t$) + IF MID$(t$, i, 1) = sp THEN MID$(t$, i, 1) = " " + NEXT + IF t$ = "STRING" THEN typname2typ& = STRINGTYPE: EXIT FUNCTION - If Left$(t$, 9) = "STRING * " Then + IF LEFT$(t$, 9) = "STRING * " THEN - n$ = Right$(t$, Len(t$) - 9) + n$ = RIGHT$(t$, LEN(t$) - 9) 'constant check 2011 hashfound = 0 hashname$ = n$ hashchkflags = HASHFLAG_CONSTANT hashres = HashFindRev(hashname$, hashchkflags, hashresflags, hashresref) - Do While hashres - If constsubfunc(hashresref) = subfuncn Or constsubfunc(hashresref) = 0 Then - If constdefined(hashresref) Then + DO WHILE hashres + IF constsubfunc(hashresref) = subfuncn OR constsubfunc(hashresref) = 0 THEN + IF constdefined(hashresref) THEN hashfound = 1 - Exit Do - End If - End If - If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0 - Loop - If hashfound Then + EXIT DO + END IF + END IF + IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 + LOOP + IF hashfound THEN i2 = hashresref t = consttype(i2) - If t And ISSTRING Then Give_Error "Expected STRING * numeric-constant": EXIT Function + IF t AND ISSTRING THEN Give_Error "Expected STRING * numeric-constant": EXIT FUNCTION 'convert value to general formats - If t And ISFLOAT Then + IF t AND ISFLOAT THEN v## = constfloat(i2) v&& = v## v~&& = v&& - Else - If t And ISUNSIGNED Then + ELSE + IF t AND ISUNSIGNED THEN v~&& = constuinteger(i2) v&& = v~&& v## = v&& - Else + ELSE v&& = constinteger(i2) v## = v&& v~&& = v&& - End If - End If - If v&& < 1 Or v&& > 9999999999 Then Give_Error "STRING * out-of-range constant": EXIT Function + END IF + END IF + IF v&& < 1 OR v&& > 9999999999 THEN Give_Error "STRING * out-of-range constant": EXIT FUNCTION b = v&& - GoTo constantlenstr - End If + GOTO constantlenstr + END IF - If isuinteger(n$) = 0 Or Len(n$) > 10 Then Give_Error "Invalid number/constant after STRING * type": EXIT Function - b = Val(n$) - If b = 0 Or Len(n$) > 10 Then Give_Error "Invalid number after STRING * type": EXIT Function + IF isuinteger(n$) = 0 OR LEN(n$) > 10 THEN Give_Error "Invalid number/constant after STRING * type": EXIT FUNCTION + b = VAL(n$) + IF b = 0 OR LEN(n$) > 10 THEN Give_Error "Invalid number after STRING * type": EXIT FUNCTION constantlenstr: typname2typsize = b typname2typ& = STRINGTYPE + ISFIXEDLENGTH - EXIT Function - End If + EXIT FUNCTION + END IF - If t$ = "SINGLE" Then typname2typ& = SINGLETYPE: EXIT Function - If t$ = "DOUBLE" Then typname2typ& = DOUBLETYPE: EXIT Function - If t$ = "_FLOAT" Or (t$ = "FLOAT" And qb64prefix_set = 1) Then typname2typ& = FLOATTYPE: EXIT Function - If Left$(t$, 10) = "_UNSIGNED " Or (Left$(t$, 9) = "UNSIGNED " And qb64prefix_set = 1) Then + IF t$ = "SINGLE" THEN typname2typ& = SINGLETYPE: EXIT FUNCTION + IF t$ = "DOUBLE" THEN typname2typ& = DOUBLETYPE: EXIT FUNCTION + IF t$ = "_FLOAT" OR (t$ = "FLOAT" AND qb64prefix_set = 1) THEN typname2typ& = FLOATTYPE: EXIT FUNCTION + IF LEFT$(t$, 10) = "_UNSIGNED " OR (LEFT$(t$, 9) = "UNSIGNED " AND qb64prefix_set = 1) THEN u = 1 - t$ = Mid$(t$, InStr(t$, Chr$(32)) + 1) - End If - If Left$(t$, 4) = "_BIT" Or (Left$(t$, 3) = "BIT" And qb64prefix_set = 1) Then - If t$ = "_BIT" Or (t$ = "BIT" And qb64prefix_set = 1) Then - If u Then typname2typ& = UBITTYPE Else typname2typ& = BITTYPE - EXIT Function - End If - If Left$(t$, 7) <> "_BIT * " Or (Left$(t$, 6) = "BIT * " And qb64prefix_set = 1) Then Give_Error "Expected _BIT * number": EXIT Function + t$ = MID$(t$, INSTR(t$, CHR$(32)) + 1) + END IF + IF LEFT$(t$, 4) = "_BIT" OR (LEFT$(t$, 3) = "BIT" AND qb64prefix_set = 1) THEN + IF t$ = "_BIT" OR (t$ = "BIT" AND qb64prefix_set = 1) THEN + IF u THEN typname2typ& = UBITTYPE ELSE typname2typ& = BITTYPE + EXIT FUNCTION + END IF + IF LEFT$(t$, 7) <> "_BIT * " OR (LEFT$(t$, 6) = "BIT * " AND qb64prefix_set = 1) THEN Give_Error "Expected _BIT * number": EXIT FUNCTION - n$ = Right$(t$, Len(t$) - 7) - If isuinteger(n$) = 0 Then Give_Error "Invalid size after " + qb64prefix$ + "BIT *": EXIT Function - b = Val(n$) - If b = 0 Or b > 56 Then Give_Error "Invalid size after " + qb64prefix$ + "BIT *": EXIT Function - t = BITTYPE - 1 + b: If u Then t = t + ISUNSIGNED + n$ = RIGHT$(t$, LEN(t$) - 7) + IF isuinteger(n$) = 0 THEN Give_Error "Invalid size after " + qb64prefix$ + "BIT *": EXIT FUNCTION + b = VAL(n$) + IF b = 0 OR b > 56 THEN Give_Error "Invalid size after " + qb64prefix$ + "BIT *": EXIT FUNCTION + t = BITTYPE - 1 + b: IF u THEN t = t + ISUNSIGNED typname2typ& = t - EXIT Function - End If + EXIT FUNCTION + END IF t = 0 - If t$ = "_BYTE" Or (t$ = "BYTE" And qb64prefix_set = 1) Then t = BYTETYPE - If t$ = "INTEGER" Then t = INTEGERTYPE - If t$ = "LONG" Then t = LONGTYPE - If t$ = "_INTEGER64" Or (t$ = "INTEGER64" And qb64prefix_set = 1) Then t = INTEGER64TYPE - If t$ = "_OFFSET" Or (t$ = "OFFSET" And qb64prefix_set = 1) Then t = OFFSETTYPE - If t Then - If u Then t = t + ISUNSIGNED + IF t$ = "_BYTE" OR (t$ = "BYTE" AND qb64prefix_set = 1) THEN t = BYTETYPE + IF t$ = "INTEGER" THEN t = INTEGERTYPE + IF t$ = "LONG" THEN t = LONGTYPE + IF t$ = "_INTEGER64" OR (t$ = "INTEGER64" AND qb64prefix_set = 1) THEN t = INTEGER64TYPE + IF t$ = "_OFFSET" OR (t$ = "OFFSET" AND qb64prefix_set = 1) THEN t = OFFSETTYPE + IF t THEN + IF u THEN t = t + ISUNSIGNED typname2typ& = t - EXIT Function - End If - If u Then EXIT Function '_UNSIGNED (nothing) + EXIT FUNCTION + END IF + IF u THEN EXIT FUNCTION '_UNSIGNED (nothing) 'UDT? - For i = 1 To lasttype - If t$ = RTrim$(udtxname(i)) Then + FOR i = 1 TO lasttype + IF t$ = RTRIM$(udtxname(i)) THEN typname2typ& = ISUDT + ISPOINTER + i - EXIT Function - ElseIf RTrim$(udtxname(i)) = "_MEM" And t$ = "MEM" And qb64prefix_set = 1 Then + EXIT FUNCTION + ELSEIF RTRIM$(udtxname(i)) = "_MEM" AND t$ = "MEM" AND qb64prefix_set = 1 THEN typname2typ& = ISUDT + ISPOINTER + i - EXIT Function - End If - Next + EXIT FUNCTION + END IF + NEXT 'return 0 (failed) -End Function +END FUNCTION -Function uniquenumber& +FUNCTION uniquenumber& uniquenumbern = uniquenumbern + 1 uniquenumber& = uniquenumbern -End Function +END FUNCTION -Function validlabel (LABEL2$) +FUNCTION validlabel (LABEL2$) create = CreatingLabel: CreatingLabel = 0 validlabel = 0 - If Len(LABEL2$) = 0 Then EXIT Function + IF LEN(LABEL2$) = 0 THEN EXIT FUNCTION clabel$ = LABEL2$ - label$ = UCase$(LABEL2$) + label$ = UCASE$(LABEL2$) n = numelements(label$) - If n = 1 Then + IF n = 1 THEN 'Note: Reserved words and internal sub/function names are invalid hashres = HashFind(label$, HASHFLAG_RESERVED + HASHFLAG_SUB + HASHFLAG_FUNCTION, hashresflags, hashresref) - Do While hashres - If hashresflags And (HASHFLAG_SUB + HASHFLAG_FUNCTION) Then - If ids(hashresref).internal_subfunc Then EXIT Function + DO WHILE hashres + IF hashresflags AND (HASHFLAG_SUB + HASHFLAG_FUNCTION) THEN + IF ids(hashresref).internal_subfunc THEN EXIT FUNCTION - If hashresflags And HASHFLAG_SUB Then 'could be a label or a sub call! + IF hashresflags AND HASHFLAG_SUB THEN 'could be a label or a sub call! 'analyze format - If Asc(ids(hashresref).specialformat) = 32 Then - If ids(hashresref).args = 0 Then onecommandsub = 1 Else onecommandsub = 0 - Else - If Asc(ids(hashresref).specialformat) <> 91 Then '"[" + IF ASC(ids(hashresref).specialformat) = 32 THEN + IF ids(hashresref).args = 0 THEN onecommandsub = 1 ELSE onecommandsub = 0 + ELSE + IF ASC(ids(hashresref).specialformat) <> 91 THEN '"[" onecommandsub = 0 - Else + ELSE onecommandsub = 1 - a$ = RTrim$(ids(hashresref).specialformat) + a$ = RTRIM$(ids(hashresref).specialformat) b = 1 - For x = 2 To Len(a$) - a = Asc(a$, x) - If a = 91 Then b = b + 1 - If a = 93 Then b = b - 1 - If b = 0 And x <> Len(a$) Then onecommandsub = 0: Exit For - Next - End If - End If - If create <> 0 And onecommandsub = 1 Then - If InStr(SubNameLabels$, sp + UCase$(label$) + sp) = 0 Then PossibleSubNameLabels$ = PossibleSubNameLabels$ + UCase$(label$) + sp: EXIT Function 'treat as sub call - End If + FOR x = 2 TO LEN(a$) + a = ASC(a$, x) + IF a = 91 THEN b = b + 1 + IF a = 93 THEN b = b - 1 + IF b = 0 AND x <> LEN(a$) THEN onecommandsub = 0: EXIT FOR + NEXT + END IF + END IF + IF create <> 0 AND onecommandsub = 1 THEN + IF INSTR(SubNameLabels$, sp + UCASE$(label$) + sp) = 0 THEN PossibleSubNameLabels$ = PossibleSubNameLabels$ + UCASE$(label$) + sp: EXIT FUNCTION 'treat as sub call + END IF - End If 'sub name + END IF 'sub name - Else + ELSE 'reserved - EXIT Function - End If - If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0 - Loop + EXIT FUNCTION + END IF + IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 + LOOP 'Numeric label? 'quasi numbers are possible, but: @@ -22242,415 +22242,415 @@ Function validlabel (LABEL2$) 'b) They must be typed with the exact same characters to match t$ = label$ 'numeric? - a = Asc(t$) - If (a >= 48 And a <= 57) Or a = 46 Then + a = ASC(t$) + IF (a >= 48 AND a <= 57) OR a = 46 THEN 'refer to original formatting if possible (eg. 1.10 not 1.1) - x = InStr(t$, Chr$(44)) - If x Then - t$ = Right$(t$, Len(t$) - x) - End If + x = INSTR(t$, CHR$(44)) + IF x THEN + t$ = RIGHT$(t$, LEN(t$) - x) + END IF 'note: The symbols ! and # are valid trailing symbols in QBASIC, regardless of the number's size, ' so they are allowed in QB64 for compatibility reasons addsymbol$ = removesymbol$(t$) - If Error_Happened Then EXIT Function - If Len(addsymbol$) Then - If InStr(addsymbol$, "$") Then EXIT Function - If addsymbol$ <> "#" And addsymbol$ <> "!" Then addsymbol$ = "" - End If + IF Error_Happened THEN EXIT FUNCTION + IF LEN(addsymbol$) THEN + IF INSTR(addsymbol$, "$") THEN EXIT FUNCTION + IF addsymbol$ <> "#" AND addsymbol$ <> "!" THEN addsymbol$ = "" + END IF - If a = 46 Then dp = 1 - For x = 2 To Len(t$) - a = Asc(Mid$(t$, x, 1)) - If a = 46 Then dp = dp + 1 - If (a < 48 Or a > 57) And a <> 46 Then EXIT Function 'not numeric - Next x - If dp > 1 Then EXIT Function 'too many decimal points - If dp = 1 And Len(t$) = 1 Then EXIT Function 'cant have '.' as a label + IF a = 46 THEN dp = 1 + FOR x = 2 TO LEN(t$) + a = ASC(MID$(t$, x, 1)) + IF a = 46 THEN dp = dp + 1 + IF (a < 48 OR a > 57) AND a <> 46 THEN EXIT FUNCTION 'not numeric + NEXT x + IF dp > 1 THEN EXIT FUNCTION 'too many decimal points + IF dp = 1 AND LEN(t$) = 1 THEN EXIT FUNCTION 'cant have '.' as a label tlayout$ = t$ + addsymbol$ - i = InStr(t$, "."): If i Then Mid$(t$, i, 1) = "p" - If addsymbol$ = "#" Then t$ = t$ + "d" - If addsymbol$ = "!" Then t$ = t$ + "s" + i = INSTR(t$, "."): IF i THEN MID$(t$, i, 1) = "p" + IF addsymbol$ = "#" THEN t$ = t$ + "d" + IF addsymbol$ = "!" THEN t$ = t$ + "s" - If Len(t$) > 40 Then EXIT Function + IF LEN(t$) > 40 THEN EXIT FUNCTION LABEL2$ = t$ validlabel = 1 - EXIT Function - End If 'numeric + EXIT FUNCTION + END IF 'numeric - End If 'n=1 + END IF 'n=1 'Alpha-numeric label? 'Build label 'structure check (???.???.???.???) - If (n And 1) = 0 Then EXIT Function 'must be an odd number of elements - For nx = 2 To n - 1 Step 2 + IF (n AND 1) = 0 THEN EXIT FUNCTION 'must be an odd number of elements + FOR nx = 2 TO n - 1 STEP 2 a$ = getelement$(LABEL2$, nx) - If a$ <> "." Then EXIT Function 'every 2nd element must be a period - Next + IF a$ <> "." THEN EXIT FUNCTION 'every 2nd element must be a period + NEXT 'cannot begin with numeric - c = Asc(clabel$): If c >= 48 And c <= 57 Then EXIT Function + c = ASC(clabel$): IF c >= 48 AND c <= 57 THEN EXIT FUNCTION 'elements check label3$ = "" - For nx = 1 To n Step 2 + FOR nx = 1 TO n STEP 2 label$ = getelement$(clabel$, nx) 'alpha-numeric? - For x = 1 To Len(label$) - If alphanumeric(Asc(label$, x)) = 0 Then EXIT Function - Next + FOR x = 1 TO LEN(label$) + IF alphanumeric(ASC(label$, x)) = 0 THEN EXIT FUNCTION + NEXT 'build label - If label3$ = "" Then label3$ = UCase$(label$): tlayout$ = label$ Else label3$ = label3$ + fix046$ + UCase$(label$): tlayout$ = tlayout$ + "." + label$ - Next nx + IF label3$ = "" THEN label3$ = UCASE$(label$): tlayout$ = label$ ELSE label3$ = label3$ + fix046$ + UCASE$(label$): tlayout$ = tlayout$ + "." + label$ + NEXT nx validlabel = 1 LABEL2$ = label3$ -End Function +END FUNCTION -Sub xend +SUB xend - Print #12, "sub_end();" -End Sub + PRINT #12, "sub_end();" +END SUB -Sub xfileprint (a$, ca$, n) +SUB xfileprint (a$, ca$, n) u$ = str2$(uniquenumber) - Print #12, "tab_spc_cr_size=2;" - If n = 2 Then Give_Error "Expected # ... , ...": EXIT Sub + PRINT #12, "tab_spc_cr_size=2;" + IF n = 2 THEN Give_Error "Expected # ... , ...": EXIT SUB a3$ = "" b = 0 - For i = 3 To n + FOR i = 3 TO n a2$ = getelement$(ca$, i) - If a2$ = "(" Then b = b + 1 - If a2$ = ")" Then b = b - 1 - If a2$ = "," And b = 0 Then - If a3$ = "" Then Give_Error "Expected # ... , ...": EXIT Sub - GoTo printgotfn - End If - If a3$ = "" Then a3$ = a2$ Else a3$ = a3$ + sp + a2$ - Next - Give_Error "Expected # ... ,": EXIT Sub + IF a2$ = "(" THEN b = b + 1 + IF a2$ = ")" THEN b = b - 1 + IF a2$ = "," AND b = 0 THEN + IF a3$ = "" THEN Give_Error "Expected # ... , ...": EXIT SUB + GOTO printgotfn + END IF + IF a3$ = "" THEN a3$ = a2$ ELSE a3$ = a3$ + sp + a2$ + NEXT + Give_Error "Expected # ... ,": EXIT SUB printgotfn: e$ = fixoperationorder$(a3$) - If Error_Happened Then EXIT Sub + IF Error_Happened THEN EXIT SUB l$ = SCase$("Print") + sp + "#" + sp2 + tlayout$ + sp2 + "," e$ = evaluatetotyp(e$, 64&) - If Error_Happened Then EXIT Sub - Print #12, "tab_fileno=tmp_fileno=" + e$ + ";" - Print #12, "if (new_error) goto skip" + u$ + ";" + IF Error_Happened THEN EXIT SUB + PRINT #12, "tab_fileno=tmp_fileno=" + e$ + ";" + PRINT #12, "if (new_error) goto skip" + u$ + ";" i = i + 1 'PRINT USING? (file) - If n >= i Then - If getelement(a$, i) = "USING" Then + IF n >= i THEN + IF getelement(a$, i) = "USING" THEN 'get format string fpujump: l$ = l$ + sp + SCase$("Using") e$ = "": b = 0: puformat$ = "" - For i = i + 1 To n + FOR i = i + 1 TO n a2$ = getelement(ca$, i) - If a2$ = "(" Then b = b + 1 - If a2$ = ")" Then b = b - 1 - If b = 0 Then - If a2$ = "," Then Give_Error "Expected PRINT USING #filenumber, formatstring ; ...": EXIT Sub - If a2$ = ";" Then + IF a2$ = "(" THEN b = b + 1 + IF a2$ = ")" THEN b = b - 1 + IF b = 0 THEN + IF a2$ = "," THEN Give_Error "Expected PRINT USING #filenumber, formatstring ; ...": EXIT SUB + IF a2$ = ";" THEN e$ = fixoperationorder$(e$) - If Error_Happened Then EXIT Sub + IF Error_Happened THEN EXIT SUB l$ = l$ + sp + tlayout$ + sp2 + ";" e$ = evaluate(e$, typ) - If Error_Happened Then EXIT Sub - If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0) - If Error_Happened Then EXIT Sub - If (typ And ISSTRING) = 0 Then Give_Error "Expected PRINT USING #filenumber, formatstring ; ...": EXIT Sub + IF Error_Happened THEN EXIT SUB + IF (typ AND ISREFERENCE) THEN e$ = refer(e$, typ, 0) + IF Error_Happened THEN EXIT SUB + IF (typ AND ISSTRING) = 0 THEN Give_Error "Expected PRINT USING #filenumber, formatstring ; ...": EXIT SUB puformat$ = e$ - Exit For - End If '; - End If 'b - If Len(e$) Then e$ = e$ + sp + a2$ Else e$ = a2$ - Next - If puformat$ = "" Then Give_Error "Expected PRINT USING #filenumber, formatstring ; ...": EXIT Sub - If i = n Then Give_Error "Expected PRINT USING #filenumber, formatstring ; ...": EXIT Sub + EXIT FOR + END IF '; + END IF 'b + IF LEN(e$) THEN e$ = e$ + sp + a2$ ELSE e$ = a2$ + NEXT + IF puformat$ = "" THEN Give_Error "Expected PRINT USING #filenumber, formatstring ; ...": EXIT SUB + IF i = n THEN Give_Error "Expected PRINT USING #filenumber, formatstring ; ...": EXIT SUB 'create build string - Print #12, "tqbs=qbs_new(0,0);" + PRINT #12, "tqbs=qbs_new(0,0);" 'set format start/index variable - Print #12, "tmp_long=0;" 'scan format from beginning + PRINT #12, "tmp_long=0;" 'scan format from beginning 'create string to hold format in for multiple references puf$ = "print_using_format" + u$ - If subfunc = "" Then - Print #13, "static qbs *" + puf$ + ";" - Else - Print #13, "qbs *" + puf$ + ";" - End If - Print #12, puf$ + "=qbs_new(0,0); qbs_set(" + puf$ + "," + puformat$ + ");" - Print #12, "if (new_error) goto skip" + u$ + ";" + IF subfunc = "" THEN + PRINT #13, "static qbs *" + puf$ + ";" + ELSE + PRINT #13, "qbs *" + puf$ + ";" + END IF + PRINT #12, puf$ + "=qbs_new(0,0); qbs_set(" + puf$ + "," + puformat$ + ");" + PRINT #12, "if (new_error) goto skip" + u$ + ";" 'print expressions b = 0 e$ = "" last = 0 - For i = i + 1 To n + FOR i = i + 1 TO n a2$ = getelement(ca$, i) - If a2$ = "(" Then b = b + 1 - If a2$ = ")" Then b = b - 1 - If b = 0 Then - If a2$ = ";" Or a2$ = "," Then + IF a2$ = "(" THEN b = b + 1 + IF a2$ = ")" THEN b = b - 1 + IF b = 0 THEN + IF a2$ = ";" OR a2$ = "," THEN fprintulast: e$ = fixoperationorder$(e$) - If Error_Happened Then EXIT Sub - If last Then l$ = l$ + sp + tlayout$ Else l$ = l$ + sp + tlayout$ + sp2 + a2$ + IF Error_Happened THEN EXIT SUB + IF last THEN l$ = l$ + sp + tlayout$ ELSE l$ = l$ + sp + tlayout$ + sp2 + a2$ e$ = evaluate(e$, typ) - If Error_Happened Then EXIT Sub - If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0) - If Error_Happened Then EXIT Sub - If typ And ISSTRING Then + IF Error_Happened THEN EXIT SUB + IF (typ AND ISREFERENCE) THEN e$ = refer(e$, typ, 0) + IF Error_Happened THEN EXIT SUB + IF typ AND ISSTRING THEN - If Left$(e$, 9) = "func_tab(" Or Left$(e$, 9) = "func_spc(" Then + IF LEFT$(e$, 9) = "func_tab(" OR LEFT$(e$, 9) = "func_spc(" THEN 'TAB/SPC exception 'note: position in format-string must be maintained '-print any string up until now - Print #12, "sub_file_print(tmp_fileno,tqbs,0,0,0);" + PRINT #12, "sub_file_print(tmp_fileno,tqbs,0,0,0);" '-print e$ - Print #12, "qbs_set(tqbs," + e$ + ");" - Print #12, "if (new_error) goto skip_pu" + u$ + ";" - Print #12, "sub_file_print(tmp_fileno,tqbs,0,0,0);" + PRINT #12, "qbs_set(tqbs," + e$ + ");" + PRINT #12, "if (new_error) goto skip_pu" + u$ + ";" + PRINT #12, "sub_file_print(tmp_fileno,tqbs,0,0,0);" '-set length of tqbs to 0 - Print #12, "tqbs->len=0;" + PRINT #12, "tqbs->len=0;" - Else + ELSE 'regular string - Print #12, "tmp_long=print_using(" + puf$ + ",tmp_long,tqbs," + e$ + ");" + PRINT #12, "tmp_long=print_using(" + puf$ + ",tmp_long,tqbs," + e$ + ");" - End If + END IF - Else 'not a string - If typ And ISFLOAT Then - If (typ And 511) = 32 Then Print #12, "tmp_long=print_using_single(" + puf$ + "," + e$ + ",tmp_long,tqbs);" - If (typ And 511) = 64 Then Print #12, "tmp_long=print_using_double(" + puf$ + "," + e$ + ",tmp_long,tqbs);" - If (typ And 511) > 64 Then Print #12, "tmp_long=print_using_float(" + puf$ + "," + e$ + ",tmp_long,tqbs);" - Else - If ((typ And 511) = 64) And (typ And ISUNSIGNED) <> 0 Then - Print #12, "tmp_long=print_using_uinteger64(" + puf$ + "," + e$ + ",tmp_long,tqbs);" - Else - Print #12, "tmp_long=print_using_integer64(" + puf$ + "," + e$ + ",tmp_long,tqbs);" - End If - End If - End If 'string/not string - Print #12, "if (new_error) goto skip_pu" + u$ + ";" + ELSE 'not a string + IF typ AND ISFLOAT THEN + IF (typ AND 511) = 32 THEN PRINT #12, "tmp_long=print_using_single(" + puf$ + "," + e$ + ",tmp_long,tqbs);" + IF (typ AND 511) = 64 THEN PRINT #12, "tmp_long=print_using_double(" + puf$ + "," + e$ + ",tmp_long,tqbs);" + IF (typ AND 511) > 64 THEN PRINT #12, "tmp_long=print_using_float(" + puf$ + "," + e$ + ",tmp_long,tqbs);" + ELSE + IF ((typ AND 511) = 64) AND (typ AND ISUNSIGNED) <> 0 THEN + PRINT #12, "tmp_long=print_using_uinteger64(" + puf$ + "," + e$ + ",tmp_long,tqbs);" + ELSE + PRINT #12, "tmp_long=print_using_integer64(" + puf$ + "," + e$ + ",tmp_long,tqbs);" + END IF + END IF + END IF 'string/not string + PRINT #12, "if (new_error) goto skip_pu" + u$ + ";" e$ = "" - If last Then Exit For - GoTo fprintunext - End If - End If - If Len(e$) Then e$ = e$ + sp + a2$ Else e$ = a2$ + IF last THEN EXIT FOR + GOTO fprintunext + END IF + END IF + IF LEN(e$) THEN e$ = e$ + sp + a2$ ELSE e$ = a2$ fprintunext: - Next - If e$ <> "" Then a2$ = "": last = 1: GoTo fprintulast - Print #12, "skip_pu" + u$ + ":" + NEXT + IF e$ <> "" THEN a2$ = "": last = 1: GOTO fprintulast + PRINT #12, "skip_pu" + u$ + ":" 'check for errors - Print #12, "if (new_error){" - Print #12, "g_tmp_long=new_error; new_error=0; sub_file_print(tmp_fileno,tqbs,0,0,0); new_error=g_tmp_long;" - Print #12, "}else{" - If a2$ = "," Or a2$ = ";" Then nl = 0 Else nl = 1 'note: a2$ is set to the last element of a$ - Print #12, "sub_file_print(tmp_fileno,tqbs,0,0," + str2$(nl) + ");" - Print #12, "}" - Print #12, "qbs_free(tqbs);" - Print #12, "qbs_free(" + puf$ + ");" - Print #12, "skip" + u$ + ":" - Print #12, cleanupstringprocessingcall$ + "0);" - Print #12, "tab_spc_cr_size=1;" + PRINT #12, "if (new_error){" + PRINT #12, "g_tmp_long=new_error; new_error=0; sub_file_print(tmp_fileno,tqbs,0,0,0); new_error=g_tmp_long;" + PRINT #12, "}else{" + IF a2$ = "," OR a2$ = ";" THEN nl = 0 ELSE nl = 1 'note: a2$ is set to the last element of a$ + PRINT #12, "sub_file_print(tmp_fileno,tqbs,0,0," + str2$(nl) + ");" + PRINT #12, "}" + PRINT #12, "qbs_free(tqbs);" + PRINT #12, "qbs_free(" + puf$ + ");" + PRINT #12, "skip" + u$ + ":" + PRINT #12, cleanupstringprocessingcall$ + "0);" + PRINT #12, "tab_spc_cr_size=1;" tlayout$ = l$ - EXIT Sub - End If - End If + EXIT SUB + END IF + END IF 'end of print using code - If i > n Then - Print #12, "sub_file_print(tmp_fileno,nothingstring,0,0,1);" - GoTo printblankline - End If + IF i > n THEN + PRINT #12, "sub_file_print(tmp_fileno,nothingstring,0,0,1);" + GOTO printblankline + END IF b = 0 e$ = "" last = 0 - For i = i To n + FOR i = i TO n a2$ = getelement(ca$, i) - If a2$ = "(" Then b = b + 1 - If a2$ = ")" Then b = b - 1 - If b = 0 Then - If a2$ = ";" Or a2$ = "," Or UCase$(a2$) = "USING" Then + IF a2$ = "(" THEN b = b + 1 + IF a2$ = ")" THEN b = b - 1 + IF b = 0 THEN + IF a2$ = ";" OR a2$ = "," OR UCASE$(a2$) = "USING" THEN printfilelast: - If UCase$(a2$) = "USING" Then - If e$ <> "" Then gotofpu = 1 Else GoTo fpujump - End If + IF UCASE$(a2$) = "USING" THEN + IF e$ <> "" THEN gotofpu = 1 ELSE GOTO fpujump + END IF - If a2$ = "," Then usetab = 1 Else usetab = 0 - If last = 1 Then newline = 1 Else newline = 0 + IF a2$ = "," THEN usetab = 1 ELSE usetab = 0 + IF last = 1 THEN newline = 1 ELSE newline = 0 extraspace = 0 - If Len(e$) Then + IF LEN(e$) THEN ebak$ = e$ pnrtnum = 0 printfilenumber: e$ = fixoperationorder$(e$) - If Error_Happened Then EXIT Sub - If pnrtnum = 0 Then - If last Then l$ = l$ + sp + tlayout$ Else l$ = l$ + sp + tlayout$ + sp2 + a2$ - End If + IF Error_Happened THEN EXIT SUB + IF pnrtnum = 0 THEN + IF last THEN l$ = l$ + sp + tlayout$ ELSE l$ = l$ + sp + tlayout$ + sp2 + a2$ + END IF e$ = evaluate(e$, typ) - If Error_Happened Then EXIT Sub - If (typ And ISSTRING) = 0 Then + IF Error_Happened THEN EXIT SUB + IF (typ AND ISSTRING) = 0 THEN e$ = "STR$" + sp + "(" + sp + ebak$ + sp + ")" extraspace = 1 pnrtnum = 1 - GoTo printfilenumber 'force re-evaluation - End If - If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0) - If Error_Happened Then EXIT Sub + GOTO printfilenumber 'force re-evaluation + END IF + IF (typ AND ISREFERENCE) THEN e$ = refer(e$, typ, 0) + IF Error_Happened THEN EXIT SUB 'format: string, (1/0) extraspace, (1/0) tab, (1/0)begin a new line - Print #12, "sub_file_print(tmp_fileno," + e$ + ","; extraspace; ","; usetab; ","; newline; ");" - Else 'len(e$)=0 - If a2$ = "," Then l$ = l$ + sp + a2$ - If a2$ = ";" Then - If Right$(l$, 1) <> ";" Then l$ = l$ + sp + a2$ 'concat ;; to ; - End If - If usetab Then Print #12, "sub_file_print(tmp_fileno,nothingstring,0,1,0);" - End If 'len(e$) - Print #12, "if (new_error) goto skip" + u$ + ";" + PRINT #12, "sub_file_print(tmp_fileno," + e$ + ","; extraspace; ","; usetab; ","; newline; ");" + ELSE 'len(e$)=0 + IF a2$ = "," THEN l$ = l$ + sp + a2$ + IF a2$ = ";" THEN + IF RIGHT$(l$, 1) <> ";" THEN l$ = l$ + sp + a2$ 'concat ;; to ; + END IF + IF usetab THEN PRINT #12, "sub_file_print(tmp_fileno,nothingstring,0,1,0);" + END IF 'len(e$) + PRINT #12, "if (new_error) goto skip" + u$ + ";" e$ = "" - If gotofpu Then GoTo fpujump - If last Then Exit For - GoTo printfilenext - End If ', or ; - End If 'b=0 - If e$ <> "" Then e$ = e$ + sp + a2$ Else e$ = a2$ + IF gotofpu THEN GOTO fpujump + IF last THEN EXIT FOR + GOTO printfilenext + END IF ', or ; + END IF 'b=0 + IF e$ <> "" THEN e$ = e$ + sp + a2$ ELSE e$ = a2$ printfilenext: - Next - If e$ <> "" Then a2$ = "": last = 1: GoTo printfilelast + NEXT + IF e$ <> "" THEN a2$ = "": last = 1: GOTO printfilelast printblankline: - Print #12, "skip" + u$ + ":" - Print #12, cleanupstringprocessingcall$ + "0);" - Print #12, "tab_spc_cr_size=1;" + PRINT #12, "skip" + u$ + ":" + PRINT #12, cleanupstringprocessingcall$ + "0);" + PRINT #12, "tab_spc_cr_size=1;" tlayout$ = l$ -End Sub +END SUB -Sub xfilewrite (ca$, n) +SUB xfilewrite (ca$, n) l$ = SCase$("Write") + sp + "#" u$ = str2$(uniquenumber) - Print #12, "tab_spc_cr_size=2;" - If n = 2 Then Give_Error "Expected # ...": EXIT Sub + PRINT #12, "tab_spc_cr_size=2;" + IF n = 2 THEN Give_Error "Expected # ...": EXIT SUB a3$ = "" b = 0 - For i = 3 To n + FOR i = 3 TO n a2$ = getelement$(ca$, i) - If a2$ = "(" Then b = b + 1 - If a2$ = ")" Then b = b - 1 - If a2$ = "," And b = 0 Then - If a3$ = "" Then Give_Error "Expected # ... , ...": EXIT Sub - GoTo writegotfn - End If - If a3$ = "" Then a3$ = a2$ Else a3$ = a3$ + sp + a2$ - Next - Give_Error "Expected # ... ,": EXIT Sub + IF a2$ = "(" THEN b = b + 1 + IF a2$ = ")" THEN b = b - 1 + IF a2$ = "," AND b = 0 THEN + IF a3$ = "" THEN Give_Error "Expected # ... , ...": EXIT SUB + GOTO writegotfn + END IF + IF a3$ = "" THEN a3$ = a2$ ELSE a3$ = a3$ + sp + a2$ + NEXT + Give_Error "Expected # ... ,": EXIT SUB writegotfn: e$ = fixoperationorder$(a3$) - If Error_Happened Then EXIT Sub + IF Error_Happened THEN EXIT SUB l$ = l$ + sp2 + tlayout$ + sp2 + "," e$ = evaluatetotyp(e$, 64&) - If Error_Happened Then EXIT Sub - Print #12, "tab_fileno=tmp_fileno=" + e$ + ";" - Print #12, "if (new_error) goto skip" + u$ + ";" + IF Error_Happened THEN EXIT SUB + PRINT #12, "tab_fileno=tmp_fileno=" + e$ + ";" + PRINT #12, "if (new_error) goto skip" + u$ + ";" i = i + 1 - If i > n Then - Print #12, "sub_file_print(tmp_fileno,nothingstring,0,0,1);" - GoTo writeblankline - End If + IF i > n THEN + PRINT #12, "sub_file_print(tmp_fileno,nothingstring,0,0,1);" + GOTO writeblankline + END IF b = 0 e$ = "" last = 0 - For i = i To n + FOR i = i TO n a2$ = getelement(ca$, i) - If a2$ = "(" Then b = b + 1 - If a2$ = ")" Then b = b - 1 - If b = 0 Then - If a2$ = "," Then + IF a2$ = "(" THEN b = b + 1 + IF a2$ = ")" THEN b = b - 1 + IF b = 0 THEN + IF a2$ = "," THEN writefilelast: - If last = 1 Then newline = 1 Else newline = 0 + IF last = 1 THEN newline = 1 ELSE newline = 0 ebak$ = e$ reevaled = 0 writefilenumber: e$ = fixoperationorder$(e$) - If Error_Happened Then EXIT Sub - If reevaled = 0 Then + IF Error_Happened THEN EXIT SUB + IF reevaled = 0 THEN l$ = l$ + sp + tlayout$ - If last = 0 Then l$ = l$ + sp2 + "," - End If + IF last = 0 THEN l$ = l$ + sp2 + "," + END IF e$ = evaluate(e$, typ) - If Error_Happened Then EXIT Sub - If reevaled = 0 Then - If (typ And ISSTRING) = 0 Then + IF Error_Happened THEN EXIT SUB + IF reevaled = 0 THEN + IF (typ AND ISSTRING) = 0 THEN e$ = "LTRIM$" + sp + "(" + sp + "STR$" + sp + "(" + sp + ebak$ + sp + ")" + sp + ")" - If last = 0 Then e$ = e$ + sp + "+" + sp + Chr$(34) + "," + Chr$(34) + ",1" + IF last = 0 THEN e$ = e$ + sp + "+" + sp + CHR$(34) + "," + CHR$(34) + ",1" reevaled = 1 - GoTo writefilenumber 'force re-evaluation - Else - e$ = Chr$(34) + "\042" + Chr$(34) + ",1" + sp + "+" + sp + ebak$ + sp + "+" + sp + Chr$(34) + "\042" + Chr$(34) + ",1" - If last = 0 Then e$ = e$ + sp + "+" + sp + Chr$(34) + "," + Chr$(34) + ",1" + GOTO writefilenumber 'force re-evaluation + ELSE + e$ = CHR$(34) + "\042" + CHR$(34) + ",1" + sp + "+" + sp + ebak$ + sp + "+" + sp + CHR$(34) + "\042" + CHR$(34) + ",1" + IF last = 0 THEN e$ = e$ + sp + "+" + sp + CHR$(34) + "," + CHR$(34) + ",1" reevaled = 1 - GoTo writefilenumber 'force re-evaluation - End If - End If - If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0) - If Error_Happened Then EXIT Sub + GOTO writefilenumber 'force re-evaluation + END IF + END IF + IF (typ AND ISREFERENCE) THEN e$ = refer(e$, typ, 0) + IF Error_Happened THEN EXIT SUB 'format: string, (1/0) extraspace, (1/0) tab, (1/0)begin a new line - Print #12, "sub_file_print(tmp_fileno," + e$ + ",0,0,"; newline; ");" - Print #12, "if (new_error) goto skip" + u$ + ";" + PRINT #12, "sub_file_print(tmp_fileno," + e$ + ",0,0,"; newline; ");" + PRINT #12, "if (new_error) goto skip" + u$ + ";" e$ = "" - If last Then Exit For - GoTo writefilenext - End If ', - End If 'b=0 - If e$ <> "" Then e$ = e$ + sp + a2$ Else e$ = a2$ + IF last THEN EXIT FOR + GOTO writefilenext + END IF ', + END IF 'b=0 + IF e$ <> "" THEN e$ = e$ + sp + a2$ ELSE e$ = a2$ writefilenext: - Next - If e$ <> "" Then a2$ = ",": last = 1: GoTo writefilelast + NEXT + IF e$ <> "" THEN a2$ = ",": last = 1: GOTO writefilelast writeblankline: 'print #12, "}"'new_error - Print #12, "skip" + u$ + ":" - Print #12, cleanupstringprocessingcall$ + "0);" - Print #12, "tab_spc_cr_size=1;" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ -End Sub + PRINT #12, "skip" + u$ + ":" + PRINT #12, cleanupstringprocessingcall$ + "0);" + PRINT #12, "tab_spc_cr_size=1;" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ +END SUB -Sub xgosub (ca$) +SUB xgosub (ca$) a2$ = getelement(ca$, 2) - If validlabel(a2$) = 0 Then Give_Error "Invalid label": EXIT Sub + IF validlabel(a2$) = 0 THEN Give_Error "Invalid label": EXIT SUB v = HashFind(a2$, HASHFLAG_LABEL, ignore, r) x = 1 labchk200: - If v Then + IF v THEN s = Labels(r).Scope - If s = subfuncn Or s = -1 Then 'same scope? - If s = -1 Then Labels(r).Scope = subfuncn 'acquire scope + IF s = subfuncn OR s = -1 THEN 'same scope? + IF s = -1 THEN Labels(r).Scope = subfuncn 'acquire scope x = 0 'already defined - tlayout$ = RTrim$(Labels(r).cn) - Else - If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk200 - End If - End If - If x Then + tlayout$ = RTRIM$(Labels(r).cn) + ELSE + IF v = 2 THEN v = HashFindCont(ignore, r): GOTO labchk200 + END IF + END IF + IF x THEN 'does not exist - nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type + nLabels = nLabels + 1: IF nLabels > Labels_Ubound THEN Labels_Ubound = Labels_Ubound * 2: REDIM _PRESERVE Labels(1 TO Labels_Ubound) AS Label_Type Labels(nLabels) = Empty_Label HashAdd a2$, HASHFLAG_LABEL, nLabels r = nLabels @@ -22658,81 +22658,81 @@ Sub xgosub (ca$) Labels(r).cn = tlayout$ Labels(r).Scope = subfuncn Labels(r).Error_Line = linenumber - End If 'x + END IF 'x l$ = SCase$("GoSub") + sp + tlayout$ - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ 'note: This code fragment also used by ON ... GOTO/GOSUB 'assume label is reachable (revise) - Print #12, "return_point[next_return_point++]=" + str2(gosubid) + ";" - Print #12, "if (next_return_point>=return_points) more_return_points();" - Print #12, "goto LABEL_" + a2$ + ";" + PRINT #12, "return_point[next_return_point++]=" + str2(gosubid) + ";" + PRINT #12, "if (next_return_point>=return_points) more_return_points();" + PRINT #12, "goto LABEL_" + a2$ + ";" 'add return point jump - Print #15, "case " + str2(gosubid) + ":" - Print #15, "goto RETURN_" + str2(gosubid) + ";" - Print #15, "break;" - Print #12, "RETURN_" + str2(gosubid) + ":;" + PRINT #15, "case " + str2(gosubid) + ":" + PRINT #15, "goto RETURN_" + str2(gosubid) + ";" + PRINT #15, "break;" + PRINT #12, "RETURN_" + str2(gosubid) + ":;" gosubid = gosubid + 1 -End Sub +END SUB -Sub xongotogosub (a$, ca$, n) - If n < 4 Then Give_Error "Expected ON expression GOTO/GOSUB label,label,...": EXIT Sub +SUB xongotogosub (a$, ca$, n) + IF n < 4 THEN Give_Error "Expected ON expression GOTO/GOSUB label,label,...": EXIT SUB l$ = SCase$("On") b = 0 - For i = 2 To n + FOR i = 2 TO n e2$ = getelement$(a$, i) - If e2$ = "(" Then b = b + 1 - If e2$ = ")" Then b = b - 1 - If e2$ = "GOTO" Or e2$ = "GOSUB" Then Exit For - Next - If i >= n Or i = 2 Then Give_Error "Expected ON expression GOTO/GOSUB label,label,...": EXIT Sub + IF e2$ = "(" THEN b = b + 1 + IF e2$ = ")" THEN b = b - 1 + IF e2$ = "GOTO" OR e2$ = "GOSUB" THEN EXIT FOR + NEXT + IF i >= n OR i = 2 THEN Give_Error "Expected ON expression GOTO/GOSUB label,label,...": EXIT SUB e$ = getelements$(ca$, 2, i - 1) - g = 0: If e2$ = "GOSUB" Then g = 1 + g = 0: IF e2$ = "GOSUB" THEN g = 1 e$ = fixoperationorder(e$) - If Error_Happened Then EXIT Sub + IF Error_Happened THEN EXIT SUB l$ = l$ + sp + tlayout$ e$ = evaluate(e$, typ) - If Error_Happened Then EXIT Sub - If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0) - If Error_Happened Then EXIT Sub - If (typ And ISSTRING) Then Give_Error "Expected numeric expression": EXIT Sub - If (typ And ISFLOAT) Then + IF Error_Happened THEN EXIT SUB + IF (typ AND ISREFERENCE) THEN e$ = refer(e$, typ, 0) + IF Error_Happened THEN EXIT SUB + IF (typ AND ISSTRING) THEN Give_Error "Expected numeric expression": EXIT SUB + IF (typ AND ISFLOAT) THEN e$ = "qbr_float_to_long(" + e$ + ")" - End If + END IF l$ = l$ + sp + e2$ u$ = str2$(uniquenumber) - Print #13, "static int32 ongo_" + u$ + "=0;" - Print #12, "ongo_" + u$ + "=" + e$ + ";" + PRINT #13, "static int32 ongo_" + u$ + "=0;" + PRINT #12, "ongo_" + u$ + "=" + e$ + ";" ln = 1 labelwaslast = 0 - For i = i + 1 To n + FOR i = i + 1 TO n e$ = getelement$(ca$, i) - If e$ = "," Then + IF e$ = "," THEN l$ = l$ + sp2 + "," - If i = n Then Give_Error "Trailing , invalid": EXIT Sub + IF i = n THEN Give_Error "Trailing , invalid": EXIT SUB ln = ln + 1 labelwaslast = 0 - Else - If labelwaslast Then Give_Error "Expected ,": EXIT Sub - If validlabel(e$) = 0 Then Give_Error "Invalid label!": EXIT Sub + ELSE + IF labelwaslast THEN Give_Error "Expected ,": EXIT SUB + IF validlabel(e$) = 0 THEN Give_Error "Invalid label!": EXIT SUB v = HashFind(e$, HASHFLAG_LABEL, ignore, r) x = 1 labchk507: - If v Then + IF v THEN s = Labels(r).Scope - If s = subfuncn Or s = -1 Then 'same scope? - If s = -1 Then Labels(r).Scope = subfuncn 'acquire scope + IF s = subfuncn OR s = -1 THEN 'same scope? + IF s = -1 THEN Labels(r).Scope = subfuncn 'acquire scope x = 0 'already defined - tlayout$ = RTrim$(Labels(r).cn) - Else - If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk507 - End If - End If - If x Then + tlayout$ = RTRIM$(Labels(r).cn) + ELSE + IF v = 2 THEN v = HashFindCont(ignore, r): GOTO labchk507 + END IF + END IF + IF x THEN 'does not exist - nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type + nLabels = nLabels + 1: IF nLabels > Labels_Ubound THEN Labels_Ubound = Labels_Ubound * 2: REDIM _PRESERVE Labels(1 TO Labels_Ubound) AS Label_Type Labels(nLabels) = Empty_Label HashAdd e$, HASHFLAG_LABEL, nLabels r = nLabels @@ -22740,430 +22740,430 @@ Sub xongotogosub (a$, ca$, n) Labels(r).cn = tlayout$ Labels(r).Scope = subfuncn Labels(r).Error_Line = linenumber - End If 'x + END IF 'x l$ = l$ + sp + tlayout$ - If g Then 'gosub + IF g THEN 'gosub lb$ = e$ - Print #12, "if (ongo_" + u$ + "==" + str2$(ln) + "){" + PRINT #12, "if (ongo_" + u$ + "==" + str2$(ln) + "){" 'note: This code fragment also used by ON ... GOTO/GOSUB 'assume label is reachable (revise) - Print #12, "return_point[next_return_point++]=" + str2(gosubid) + ";" - Print #12, "if (next_return_point>=return_points) more_return_points();" - Print #12, "goto LABEL_" + lb$ + ";" + PRINT #12, "return_point[next_return_point++]=" + str2(gosubid) + ";" + PRINT #12, "if (next_return_point>=return_points) more_return_points();" + PRINT #12, "goto LABEL_" + lb$ + ";" 'add return point jump - Print #15, "case " + str2(gosubid) + ":" - Print #15, "goto RETURN_" + str2(gosubid) + ";" - Print #15, "break;" - Print #12, "RETURN_" + str2(gosubid) + ":;" + PRINT #15, "case " + str2(gosubid) + ":" + PRINT #15, "goto RETURN_" + str2(gosubid) + ";" + PRINT #15, "break;" + PRINT #12, "RETURN_" + str2(gosubid) + ":;" gosubid = gosubid + 1 - Print #12, "goto ongo_" + u$ + "_skip;" - Print #12, "}" - Else 'goto - Print #12, "if (ongo_" + u$ + "==" + str2$(ln) + ") goto LABEL_" + e$ + ";" - End If + PRINT #12, "goto ongo_" + u$ + "_skip;" + PRINT #12, "}" + ELSE 'goto + PRINT #12, "if (ongo_" + u$ + "==" + str2$(ln) + ") goto LABEL_" + e$ + ";" + END IF labelwaslast = 1 - End If - Next - Print #12, "if (ongo_" + u$ + "<0) error(5);" - If g = 1 Then Print #12, "ongo_" + u$ + "_skip:;" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ -End Sub + END IF + NEXT + PRINT #12, "if (ongo_" + u$ + "<0) error(5);" + IF g = 1 THEN PRINT #12, "ongo_" + u$ + "_skip:;" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ +END SUB -Sub xprint (a$, ca$, n) +SUB xprint (a$, ca$, n) u$ = str2$(uniquenumber) l$ = SCase$("Print") - If Asc(a$) = 76 Then lp = 1: lp$ = "l": l$ = SCase$("LPrint"): Print #12, "tab_LPRINT=1;": DEPENDENCY(DEPENDENCY_PRINTER) = 1 '"L" + IF ASC(a$) = 76 THEN lp = 1: lp$ = "l": l$ = SCase$("LPrint"): PRINT #12, "tab_LPRINT=1;": DEPENDENCY(DEPENDENCY_PRINTER) = 1 '"L" 'PRINT USING? - If n >= 2 Then - If getelement(a$, 2) = "USING" Then + IF n >= 2 THEN + IF getelement(a$, 2) = "USING" THEN 'get format string i = 3 pujump: l$ = l$ + sp + SCase$("Using") e$ = "": b = 0: puformat$ = "" - For i = i To n + FOR i = i TO n a2$ = getelement(ca$, i) - If a2$ = "(" Then b = b + 1 - If a2$ = ")" Then b = b - 1 - If b = 0 Then - If a2$ = "," Then Give_Error "Expected PRINT USING formatstring ; ...": EXIT Sub - If a2$ = ";" Then + IF a2$ = "(" THEN b = b + 1 + IF a2$ = ")" THEN b = b - 1 + IF b = 0 THEN + IF a2$ = "," THEN Give_Error "Expected PRINT USING formatstring ; ...": EXIT SUB + IF a2$ = ";" THEN e$ = fixoperationorder$(e$) - If Error_Happened Then EXIT Sub + IF Error_Happened THEN EXIT SUB l$ = l$ + sp + tlayout$ + sp2 + ";" e$ = evaluate(e$, typ) - If Error_Happened Then EXIT Sub - If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0) - If Error_Happened Then EXIT Sub - If (typ And ISSTRING) = 0 Then Give_Error "Expected PRINT USING formatstring ; ...": EXIT Sub + IF Error_Happened THEN EXIT SUB + IF (typ AND ISREFERENCE) THEN e$ = refer(e$, typ, 0) + IF Error_Happened THEN EXIT SUB + IF (typ AND ISSTRING) = 0 THEN Give_Error "Expected PRINT USING formatstring ; ...": EXIT SUB puformat$ = e$ - Exit For - End If '; - End If 'b - If Len(e$) Then e$ = e$ + sp + a2$ Else e$ = a2$ - Next - If puformat$ = "" Then Give_Error "Expected PRINT USING formatstring ; ...": EXIT Sub - If i = n Then Give_Error "Expected PRINT USING formatstring ; ...": EXIT Sub + EXIT FOR + END IF '; + END IF 'b + IF LEN(e$) THEN e$ = e$ + sp + a2$ ELSE e$ = a2$ + NEXT + IF puformat$ = "" THEN Give_Error "Expected PRINT USING formatstring ; ...": EXIT SUB + IF i = n THEN Give_Error "Expected PRINT USING formatstring ; ...": EXIT SUB 'create build string - If TQBSset = 0 Then - Print #12, "tqbs=qbs_new(0,0);" - Else - Print #12, "qbs_set(tqbs,qbs_new_txt_len(" + Chr$(34) + Chr$(34) + ",0));" - End If + IF TQBSset = 0 THEN + PRINT #12, "tqbs=qbs_new(0,0);" + ELSE + PRINT #12, "qbs_set(tqbs,qbs_new_txt_len(" + CHR$(34) + CHR$(34) + ",0));" + END IF 'set format start/index variable - Print #12, "tmp_long=0;" 'scan format from beginning + PRINT #12, "tmp_long=0;" 'scan format from beginning 'create string to hold format in for multiple references puf$ = "print_using_format" + u$ - If subfunc = "" Then - Print #13, "static qbs *" + puf$ + ";" - Else - Print #13, "qbs *" + puf$ + ";" - End If - Print #12, puf$ + "=qbs_new(0,0); qbs_set(" + puf$ + "," + puformat$ + ");" - Print #12, "if (new_error) goto skip_pu" + u$ + ";" + IF subfunc = "" THEN + PRINT #13, "static qbs *" + puf$ + ";" + ELSE + PRINT #13, "qbs *" + puf$ + ";" + END IF + PRINT #12, puf$ + "=qbs_new(0,0); qbs_set(" + puf$ + "," + puformat$ + ");" + PRINT #12, "if (new_error) goto skip_pu" + u$ + ";" 'print expressions b = 0 e$ = "" last = 0 - For i = i + 1 To n + FOR i = i + 1 TO n a2$ = getelement(ca$, i) - If a2$ = "(" Then b = b + 1 - If a2$ = ")" Then b = b - 1 - If b = 0 Then - If a2$ = ";" Or a2$ = "," Then + IF a2$ = "(" THEN b = b + 1 + IF a2$ = ")" THEN b = b - 1 + IF b = 0 THEN + IF a2$ = ";" OR a2$ = "," THEN printulast: e$ = fixoperationorder$(e$) - If Error_Happened Then EXIT Sub - If last Then l$ = l$ + sp + tlayout$ Else l$ = l$ + sp + tlayout$ + sp2 + a2$ + IF Error_Happened THEN EXIT SUB + IF last THEN l$ = l$ + sp + tlayout$ ELSE l$ = l$ + sp + tlayout$ + sp2 + a2$ e$ = evaluate(e$, typ) - If Error_Happened Then EXIT Sub - If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0) - If Error_Happened Then EXIT Sub - If typ And ISSTRING Then + IF Error_Happened THEN EXIT SUB + IF (typ AND ISREFERENCE) THEN e$ = refer(e$, typ, 0) + IF Error_Happened THEN EXIT SUB + IF typ AND ISSTRING THEN - If Left$(e$, 9) = "func_tab(" Or Left$(e$, 9) = "func_spc(" Then + IF LEFT$(e$, 9) = "func_tab(" OR LEFT$(e$, 9) = "func_spc(" THEN 'TAB/SPC exception 'note: position in format-string must be maintained '-print any string up until now - Print #12, "qbs_" + lp$ + "print(tqbs,0);" + PRINT #12, "qbs_" + lp$ + "print(tqbs,0);" '-print e$ - Print #12, "qbs_set(tqbs," + e$ + ");" - Print #12, "if (new_error) goto skip_pu" + u$ + ";" - If lp Then Print #12, "lprint_makefit(tqbs);" Else Print #12, "makefit(tqbs);" - Print #12, "qbs_" + lp$ + "print(tqbs,0);" + PRINT #12, "qbs_set(tqbs," + e$ + ");" + PRINT #12, "if (new_error) goto skip_pu" + u$ + ";" + IF lp THEN PRINT #12, "lprint_makefit(tqbs);" ELSE PRINT #12, "makefit(tqbs);" + PRINT #12, "qbs_" + lp$ + "print(tqbs,0);" '-set length of tqbs to 0 - Print #12, "tqbs->len=0;" + PRINT #12, "tqbs->len=0;" - Else + ELSE 'regular string - Print #12, "tmp_long=print_using(" + puf$ + ",tmp_long,tqbs," + e$ + ");" + PRINT #12, "tmp_long=print_using(" + puf$ + ",tmp_long,tqbs," + e$ + ");" - End If + END IF - Else 'not a string - If typ And ISFLOAT Then - If (typ And 511) = 32 Then Print #12, "tmp_long=print_using_single(" + puf$ + "," + e$ + ",tmp_long,tqbs);" - If (typ And 511) = 64 Then Print #12, "tmp_long=print_using_double(" + puf$ + "," + e$ + ",tmp_long,tqbs);" - If (typ And 511) > 64 Then Print #12, "tmp_long=print_using_float(" + puf$ + "," + e$ + ",tmp_long,tqbs);" - Else - If ((typ And 511) = 64) And (typ And ISUNSIGNED) <> 0 Then - Print #12, "tmp_long=print_using_uinteger64(" + puf$ + "," + e$ + ",tmp_long,tqbs);" - Else - Print #12, "tmp_long=print_using_integer64(" + puf$ + "," + e$ + ",tmp_long,tqbs);" - End If - End If - End If 'string/not string - Print #12, "if (new_error) goto skip_pu" + u$ + ";" + ELSE 'not a string + IF typ AND ISFLOAT THEN + IF (typ AND 511) = 32 THEN PRINT #12, "tmp_long=print_using_single(" + puf$ + "," + e$ + ",tmp_long,tqbs);" + IF (typ AND 511) = 64 THEN PRINT #12, "tmp_long=print_using_double(" + puf$ + "," + e$ + ",tmp_long,tqbs);" + IF (typ AND 511) > 64 THEN PRINT #12, "tmp_long=print_using_float(" + puf$ + "," + e$ + ",tmp_long,tqbs);" + ELSE + IF ((typ AND 511) = 64) AND (typ AND ISUNSIGNED) <> 0 THEN + PRINT #12, "tmp_long=print_using_uinteger64(" + puf$ + "," + e$ + ",tmp_long,tqbs);" + ELSE + PRINT #12, "tmp_long=print_using_integer64(" + puf$ + "," + e$ + ",tmp_long,tqbs);" + END IF + END IF + END IF 'string/not string + PRINT #12, "if (new_error) goto skip_pu" + u$ + ";" e$ = "" - If last Then Exit For - GoTo printunext - End If - End If - If Len(e$) Then e$ = e$ + sp + a2$ Else e$ = a2$ + IF last THEN EXIT FOR + GOTO printunext + END IF + END IF + IF LEN(e$) THEN e$ = e$ + sp + a2$ ELSE e$ = a2$ printunext: - Next - If e$ <> "" Then a2$ = "": last = 1: GoTo printulast - Print #12, "skip_pu" + u$ + ":" + NEXT + IF e$ <> "" THEN a2$ = "": last = 1: GOTO printulast + PRINT #12, "skip_pu" + u$ + ":" 'check for errors - Print #12, "if (new_error){" - Print #12, "g_tmp_long=new_error; new_error=0; qbs_" + lp$ + "print(tqbs,0); new_error=g_tmp_long;" - Print #12, "}else{" - If a2$ = "," Or a2$ = ";" Then nl = 0 Else nl = 1 'note: a2$ is set to the last element of a$ - Print #12, "qbs_" + lp$ + "print(tqbs," + str2$(nl) + ");" - Print #12, "}" - Print #12, "qbs_free(tqbs);" - Print #12, "qbs_free(" + puf$ + ");" - Print #12, "skip" + u$ + ":" - Print #12, cleanupstringprocessingcall$ + "0);" - If lp Then Print #12, "tab_LPRINT=0;" + PRINT #12, "if (new_error){" + PRINT #12, "g_tmp_long=new_error; new_error=0; qbs_" + lp$ + "print(tqbs,0); new_error=g_tmp_long;" + PRINT #12, "}else{" + IF a2$ = "," OR a2$ = ";" THEN nl = 0 ELSE nl = 1 'note: a2$ is set to the last element of a$ + PRINT #12, "qbs_" + lp$ + "print(tqbs," + str2$(nl) + ");" + PRINT #12, "}" + PRINT #12, "qbs_free(tqbs);" + PRINT #12, "qbs_free(" + puf$ + ");" + PRINT #12, "skip" + u$ + ":" + PRINT #12, cleanupstringprocessingcall$ + "0);" + IF lp THEN PRINT #12, "tab_LPRINT=0;" tlayout$ = l$ - EXIT Sub - End If - End If + EXIT SUB + END IF + END IF 'end of print using code b = 0 e$ = "" last = 0 - Print #12, "tqbs=qbs_new(0,0);" 'initialize the temp string + PRINT #12, "tqbs=qbs_new(0,0);" 'initialize the temp string TQBSset = -1 'set the temporary flag so we don't create a temp string twice, in case USING comes after something - For i = 2 To n + FOR i = 2 TO n a2$ = getelement(ca$, i) - If a2$ = "(" Then b = b + 1 - If a2$ = ")" Then b = b - 1 - If b = 0 Then - If a2$ = ";" Or a2$ = "," Or UCase$(a2$) = "USING" Then + IF a2$ = "(" THEN b = b + 1 + IF a2$ = ")" THEN b = b - 1 + IF b = 0 THEN + IF a2$ = ";" OR a2$ = "," OR UCASE$(a2$) = "USING" THEN printlast: - If UCase$(a2$) = "USING" Then - If e$ <> "" Then gotopu = 1 Else i = i + 1: GoTo pujump - End If + IF UCASE$(a2$) = "USING" THEN + IF e$ <> "" THEN gotopu = 1 ELSE i = i + 1: GOTO pujump + END IF - If Len(e$) Then + IF LEN(e$) THEN ebak$ = e$ pnrtnum = 0 printnumber: e$ = fixoperationorder$(e$) - If Error_Happened Then EXIT Sub - If pnrtnum = 0 Then - If last Then l$ = l$ + sp + tlayout$ Else l$ = l$ + sp + tlayout$ + sp2 + a2$ - End If + IF Error_Happened THEN EXIT SUB + IF pnrtnum = 0 THEN + IF last THEN l$ = l$ + sp + tlayout$ ELSE l$ = l$ + sp + tlayout$ + sp2 + a2$ + END IF e$ = evaluate(e$, typ) - If Error_Happened Then EXIT Sub - If (typ And ISSTRING) = 0 Then + IF Error_Happened THEN EXIT SUB + IF (typ AND ISSTRING) = 0 THEN 'not a string expresion! - e$ = "STR$" + sp + "(" + sp + ebak$ + sp + ")" + sp + "+" + sp + Chr$(34) + " " + Chr$(34) + e$ = "STR$" + sp + "(" + sp + ebak$ + sp + ")" + sp + "+" + sp + CHR$(34) + " " + CHR$(34) pnrtnum = 1 - GoTo printnumber - End If - If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0) - If Error_Happened Then EXIT Sub - Print #12, "qbs_set(tqbs," + e$ + ");" - Print #12, "if (new_error) goto skip" + u$ + ";" - If lp Then Print #12, "lprint_makefit(tqbs);" Else Print #12, "makefit(tqbs);" - Print #12, "qbs_" + lp$ + "print(tqbs,0);" - Else - If a2$ = "," Then l$ = l$ + sp + a2$ - If a2$ = ";" Then - If Right$(l$, 1) <> ";" Then l$ = l$ + sp + a2$ 'concat ;; to ; - End If - End If 'len(e$) - If a2$ = "," Then Print #12, "tab();" + GOTO printnumber + END IF + IF (typ AND ISREFERENCE) THEN e$ = refer(e$, typ, 0) + IF Error_Happened THEN EXIT SUB + PRINT #12, "qbs_set(tqbs," + e$ + ");" + PRINT #12, "if (new_error) goto skip" + u$ + ";" + IF lp THEN PRINT #12, "lprint_makefit(tqbs);" ELSE PRINT #12, "makefit(tqbs);" + PRINT #12, "qbs_" + lp$ + "print(tqbs,0);" + ELSE + IF a2$ = "," THEN l$ = l$ + sp + a2$ + IF a2$ = ";" THEN + IF RIGHT$(l$, 1) <> ";" THEN l$ = l$ + sp + a2$ 'concat ;; to ; + END IF + END IF 'len(e$) + IF a2$ = "," THEN PRINT #12, "tab();" e$ = "" - If gotopu Then i = i + 1: GoTo pujump + IF gotopu THEN i = i + 1: GOTO pujump - If last Then - Print #12, "qbs_" + lp$ + "print(nothingstring,1);" 'go to new line - Exit For - End If + IF last THEN + PRINT #12, "qbs_" + lp$ + "print(nothingstring,1);" 'go to new line + EXIT FOR + END IF - GoTo printnext - End If 'a2$ - End If 'b=0 + GOTO printnext + END IF 'a2$ + END IF 'b=0 - If Len(e$) Then e$ = e$ + sp + a2$ Else e$ = a2$ + IF LEN(e$) THEN e$ = e$ + sp + a2$ ELSE e$ = a2$ printnext: - Next - If Len(e$) Then a2$ = "": last = 1: GoTo printlast - If n = 1 Then Print #12, "qbs_" + lp$ + "print(nothingstring,1);" - Print #12, "skip" + u$ + ":" - Print #12, "qbs_free(tqbs);" - Print #12, cleanupstringprocessingcall$ + "0);" - If lp Then Print #12, "tab_LPRINT=0;" + NEXT + IF LEN(e$) THEN a2$ = "": last = 1: GOTO printlast + IF n = 1 THEN PRINT #12, "qbs_" + lp$ + "print(nothingstring,1);" + PRINT #12, "skip" + u$ + ":" + PRINT #12, "qbs_free(tqbs);" + PRINT #12, cleanupstringprocessingcall$ + "0);" + IF lp THEN PRINT #12, "tab_LPRINT=0;" tlayout$ = l$ -End Sub +END SUB -Sub xread (ca$, n) +SUB xread (ca$, n) l$ = SCase$("Read") - If n = 1 Then Give_Error "Expected variable": EXIT Sub + IF n = 1 THEN Give_Error "Expected variable": EXIT SUB i = 2 - If i > n Then Give_Error "Expected , ...": EXIT Sub + IF i > n THEN Give_Error "Expected , ...": EXIT SUB a3$ = "" b = 0 - For i = i To n + FOR i = i TO n a2$ = getelement$(ca$, i) - If a2$ = "(" Then b = b + 1 - If a2$ = ")" Then b = b - 1 - If (a2$ = "," And b = 0) Or i = n Then - If i = n Then - If a3$ = "" Then a3$ = a2$ Else a3$ = a3$ + sp + a2$ - End If - If a3$ = "" Then Give_Error "Expected , ...": EXIT Sub + IF a2$ = "(" THEN b = b + 1 + IF a2$ = ")" THEN b = b - 1 + IF (a2$ = "," AND b = 0) OR i = n THEN + IF i = n THEN + IF a3$ = "" THEN a3$ = a2$ ELSE a3$ = a3$ + sp + a2$ + END IF + IF a3$ = "" THEN Give_Error "Expected , ...": EXIT SUB e$ = fixoperationorder$(a3$) - If Error_Happened Then EXIT Sub - l$ = l$ + sp + tlayout$: If i <> n Then l$ = l$ + sp2 + "," + IF Error_Happened THEN EXIT SUB + l$ = l$ + sp + tlayout$: IF i <> n THEN l$ = l$ + sp2 + "," e$ = evaluate(e$, t) - If Error_Happened Then EXIT Sub - If (t And ISREFERENCE) = 0 Then Give_Error "Expected variable": EXIT Sub + IF Error_Happened THEN EXIT SUB + IF (t AND ISREFERENCE) = 0 THEN Give_Error "Expected variable": EXIT SUB - If (t And ISSTRING) Then + IF (t AND ISSTRING) THEN e$ = refer(e$, t, 0) - If Error_Happened Then EXIT Sub - Print #12, "sub_read_string(data,&data_offset,data_size," + e$ + ");" + IF Error_Happened THEN EXIT SUB + PRINT #12, "sub_read_string(data,&data_offset,data_size," + e$ + ");" stringprocessinghappened = 1 - Else + ELSE 'numeric variable - If (t And ISFLOAT) <> 0 Or (t And 511) <> 64 Then - If (t And ISOFFSETINBITS) Then + IF (t AND ISFLOAT) <> 0 OR (t AND 511) <> 64 THEN + IF (t AND ISOFFSETINBITS) THEN setrefer e$, t, "((int64)func_read_float(data,&data_offset,data_size," + str2(t) + "))", 1 - If Error_Happened Then EXIT Sub - Else + IF Error_Happened THEN EXIT SUB + ELSE setrefer e$, t, "func_read_float(data,&data_offset,data_size," + str2(t) + ")", 1 - If Error_Happened Then EXIT Sub - End If - Else - If t And ISUNSIGNED Then + IF Error_Happened THEN EXIT SUB + END IF + ELSE + IF t AND ISUNSIGNED THEN setrefer e$, t, "func_read_uint64(data,&data_offset,data_size)", 1 - If Error_Happened Then EXIT Sub - Else + IF Error_Happened THEN EXIT SUB + ELSE setrefer e$, t, "func_read_int64(data,&data_offset,data_size)", 1 - If Error_Happened Then EXIT Sub - End If - End If - End If 'string/numeric - If i = n Then Exit For + IF Error_Happened THEN EXIT SUB + END IF + END IF + END IF 'string/numeric + IF i = n THEN EXIT FOR a3$ = "": a2$ = "" - End If - If a3$ = "" Then a3$ = a2$ Else a3$ = a3$ + sp + a2$ - Next - If stringprocessinghappened Then Print #12, cleanupstringprocessingcall$ + "0);" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ -End Sub + END IF + IF a3$ = "" THEN a3$ = a2$ ELSE a3$ = a3$ + sp + a2$ + NEXT + IF stringprocessinghappened THEN PRINT #12, cleanupstringprocessingcall$ + "0);" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ +END SUB -Sub xwrite (ca$, n) +SUB xwrite (ca$, n) l$ = SCase$("Write") u$ = str2$(uniquenumber) - If n = 1 Then - Print #12, "qbs_print(nothingstring,1);" - GoTo writeblankline2 - End If + IF n = 1 THEN + PRINT #12, "qbs_print(nothingstring,1);" + GOTO writeblankline2 + END IF b = 0 e$ = "" last = 0 - For i = 2 To n + FOR i = 2 TO n a2$ = getelement(ca$, i) - If a2$ = "(" Then b = b + 1 - If a2$ = ")" Then b = b - 1 - If b = 0 Then - If a2$ = "," Then + IF a2$ = "(" THEN b = b + 1 + IF a2$ = ")" THEN b = b - 1 + IF b = 0 THEN + IF a2$ = "," THEN writelast: - If last = 1 Then newline = 1 Else newline = 0 + IF last = 1 THEN newline = 1 ELSE newline = 0 ebak$ = e$ reevaled = 0 writechecked: e$ = fixoperationorder$(e$) - If Error_Happened Then EXIT Sub - If reevaled = 0 Then + IF Error_Happened THEN EXIT SUB + IF reevaled = 0 THEN l$ = l$ + sp + tlayout$ - If last = 0 Then l$ = l$ + sp2 + "," - End If + IF last = 0 THEN l$ = l$ + sp2 + "," + END IF e$ = evaluate(e$, typ) - If Error_Happened Then EXIT Sub - If reevaled = 0 Then - If (typ And ISSTRING) = 0 Then + IF Error_Happened THEN EXIT SUB + IF reevaled = 0 THEN + IF (typ AND ISSTRING) = 0 THEN e$ = "LTRIM$" + sp + "(" + sp + "STR$" + sp + "(" + sp + ebak$ + sp + ")" + sp + ")" - If last = 0 Then e$ = e$ + sp + "+" + sp + Chr$(34) + "," + Chr$(34) + ",1" + IF last = 0 THEN e$ = e$ + sp + "+" + sp + CHR$(34) + "," + CHR$(34) + ",1" reevaled = 1 - GoTo writechecked 'force re-evaluation - Else - e$ = Chr$(34) + "\042" + Chr$(34) + ",1" + sp + "+" + sp + ebak$ + sp + "+" + sp + Chr$(34) + "\042" + Chr$(34) + ",1" - If last = 0 Then e$ = e$ + sp + "+" + sp + Chr$(34) + "," + Chr$(34) + ",1" + GOTO writechecked 'force re-evaluation + ELSE + e$ = CHR$(34) + "\042" + CHR$(34) + ",1" + sp + "+" + sp + ebak$ + sp + "+" + sp + CHR$(34) + "\042" + CHR$(34) + ",1" + IF last = 0 THEN e$ = e$ + sp + "+" + sp + CHR$(34) + "," + CHR$(34) + ",1" reevaled = 1 - GoTo writechecked 'force re-evaluation - End If - End If - If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0) - If Error_Happened Then EXIT Sub + GOTO writechecked 'force re-evaluation + END IF + END IF + IF (typ AND ISREFERENCE) THEN e$ = refer(e$, typ, 0) + IF Error_Happened THEN EXIT SUB 'format: string, (1/0) extraspace, (1/0) tab, (1/0)begin a new line - Print #12, "qbs_print(" + e$ + ","; newline; ");" - Print #12, "if (new_error) goto skip" + u$ + ";" + PRINT #12, "qbs_print(" + e$ + ","; newline; ");" + PRINT #12, "if (new_error) goto skip" + u$ + ";" e$ = "" - If last Then Exit For - GoTo writenext - End If ', - End If 'b=0 - If e$ <> "" Then e$ = e$ + sp + a2$ Else e$ = a2$ + IF last THEN EXIT FOR + GOTO writenext + END IF ', + END IF 'b=0 + IF e$ <> "" THEN e$ = e$ + sp + a2$ ELSE e$ = a2$ writenext: - Next - If e$ <> "" Then a2$ = ",": last = 1: GoTo writelast + NEXT + IF e$ <> "" THEN a2$ = ",": last = 1: GOTO writelast writeblankline2: - Print #12, "skip" + u$ + ":" - Print #12, cleanupstringprocessingcall$ + "0);" - layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$ -End Sub + PRINT #12, "skip" + u$ + ":" + PRINT #12, cleanupstringprocessingcall$ + "0);" + layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ +END SUB -Function evaluateconst$ (a2$, t As Long) +FUNCTION evaluateconst$ (a2$, t AS LONG) a$ = a2$ - If Debug Then Print #9, "evaluateconst:in:" + a$ + IF Debug THEN PRINT #9, "evaluateconst:in:" + a$ - Dim block(1000) As String - Dim status(1000) As Integer + DIM block(1000) AS STRING + DIM status(1000) AS INTEGER '0=unprocessed (can be "") '1=processed - Dim btype(1000) As Long 'for status=1 blocks + DIM btype(1000) AS LONG 'for status=1 blocks 'put a$ into blocks n = numelements(a$) - For i = 1 To n + FOR i = 1 TO n block(i) = getelement$(a$, i) - Next + NEXT evalconstevalbrack: 'find highest bracket level l = 0 b = 0 - For i = 1 To n - If block(i) = "(" Then b = b + 1 - If block(i) = ")" Then b = b - 1 - If b > l Then l = b - Next + FOR i = 1 TO n + IF block(i) = "(" THEN b = b + 1 + IF block(i) = ")" THEN b = b - 1 + IF b > l THEN l = b + NEXT 'if brackets exist, evaluate that item first - If l Then + IF l THEN b = 0 e$ = "" - For i = 1 To n + FOR i = 1 TO n - If block(i) = ")" Then - If b = l Then block(i) = "": Exit For + IF block(i) = ")" THEN + IF b = l THEN block(i) = "": EXIT FOR b = b - 1 - End If + END IF - If b >= l Then - If Len(e$) = 0 Then e$ = block(i) Else e$ = e$ + sp + block(i) + IF b >= l THEN + IF LEN(e$) = 0 THEN e$ = block(i) ELSE e$ = e$ + sp + block(i) block(i) = "" - End If + END IF - If block(i) = "(" Then + IF block(i) = "(" THEN b = b + 1 - If b = l Then i2 = i: block(i) = "" - End If + IF b = l THEN i2 = i: block(i) = "" + END IF - Next i + NEXT i status(i) = 1 block(i) = evaluateconst$(e$, btype(i)) - If Error_Happened Then EXIT Function - GoTo evalconstevalbrack + IF Error_Happened THEN EXIT FUNCTION + GOTO evalconstevalbrack - End If 'l + END IF 'l 'linear equation remains with some pre-calculated & non-pre-calc blocks @@ -23174,143 +23174,143 @@ Function evaluateconst$ (a2$, t As Long) ' all float calc. will be performed using a _FLOAT 'convert non-calc block numbers into binary form with QBASIC-like type - For i = 1 To n - If status(i) = 0 Then - If Len(block(i)) Then + FOR i = 1 TO n + IF status(i) = 0 THEN + IF LEN(block(i)) THEN - a = Asc(block(i)) - If (a = 45 And Len(block(i)) > 1) Or (a >= 48 And a <= 57) Then 'number? + a = ASC(block(i)) + IF (a = 45 AND LEN(block(i)) > 1) OR (a >= 48 AND a <= 57) THEN 'number? 'integers - e$ = Right$(block(i), 3) - If e$ = "~&&" Then btype(i) = UINTEGER64TYPE - ISPOINTER: GoTo gotconstblkityp - If e$ = "~%%" Then btype(i) = UBYTETYPE - ISPOINTER: GoTo gotconstblkityp - e$ = Right$(block(i), 2) - If e$ = "&&" Then btype(i) = INTEGER64TYPE - ISPOINTER: GoTo gotconstblkityp - If e$ = "%%" Then btype(i) = BYTETYPE - ISPOINTER: GoTo gotconstblkityp - If e$ = "~%" Then btype(i) = UINTEGERTYPE - ISPOINTER: GoTo gotconstblkityp - If e$ = "~&" Then btype(i) = ULONGTYPE - ISPOINTER: GoTo gotconstblkityp - e$ = Right$(block(i), 1) - If e$ = "%" Then btype(i) = INTEGERTYPE - ISPOINTER: GoTo gotconstblkityp - If e$ = "&" Then btype(i) = LONGTYPE - ISPOINTER: GoTo gotconstblkityp + e$ = RIGHT$(block(i), 3) + IF e$ = "~&&" THEN btype(i) = UINTEGER64TYPE - ISPOINTER: GOTO gotconstblkityp + IF e$ = "~%%" THEN btype(i) = UBYTETYPE - ISPOINTER: GOTO gotconstblkityp + e$ = RIGHT$(block(i), 2) + IF e$ = "&&" THEN btype(i) = INTEGER64TYPE - ISPOINTER: GOTO gotconstblkityp + IF e$ = "%%" THEN btype(i) = BYTETYPE - ISPOINTER: GOTO gotconstblkityp + IF e$ = "~%" THEN btype(i) = UINTEGERTYPE - ISPOINTER: GOTO gotconstblkityp + IF e$ = "~&" THEN btype(i) = ULONGTYPE - ISPOINTER: GOTO gotconstblkityp + e$ = RIGHT$(block(i), 1) + IF e$ = "%" THEN btype(i) = INTEGERTYPE - ISPOINTER: GOTO gotconstblkityp + IF e$ = "&" THEN btype(i) = LONGTYPE - ISPOINTER: GOTO gotconstblkityp 'ubit-type? - If InStr(block(i), "~`") Then - x = InStr(block(i), "~`") - If x = Len(block(i)) - 1 Then block(i) = block(i) + "1" - btype(i) = UBITTYPE - ISPOINTER - 1 + Val(Right$(block(i), Len(block(i)) - x - 1)) - block(i) = _MK$(_Integer64, Val(Left$(block(i), x - 1))) + IF INSTR(block(i), "~`") THEN + x = INSTR(block(i), "~`") + IF x = LEN(block(i)) - 1 THEN block(i) = block(i) + "1" + btype(i) = UBITTYPE - ISPOINTER - 1 + VAL(RIGHT$(block(i), LEN(block(i)) - x - 1)) + block(i) = _MK$(_INTEGER64, VAL(LEFT$(block(i), x - 1))) status(i) = 1 - GoTo gotconstblktyp - End If + GOTO gotconstblktyp + END IF 'bit-type? - If InStr(block(i), "`") Then - x = InStr(block(i), "`") - If x = Len(block(i)) Then block(i) = block(i) + "1" - btype(i) = BITTYPE - ISPOINTER - 1 + Val(Right$(block(i), Len(block(i)) - x)) - block(i) = _MK$(_Integer64, Val(Left$(block(i), x - 1))) + IF INSTR(block(i), "`") THEN + x = INSTR(block(i), "`") + IF x = LEN(block(i)) THEN block(i) = block(i) + "1" + btype(i) = BITTYPE - ISPOINTER - 1 + VAL(RIGHT$(block(i), LEN(block(i)) - x)) + block(i) = _MK$(_INTEGER64, VAL(LEFT$(block(i), x - 1))) status(i) = 1 - GoTo gotconstblktyp - End If + GOTO gotconstblktyp + END IF 'floats - If InStr(block(i), "E") Then - block(i) = _MK$(_Float, Val(block(i))) + IF INSTR(block(i), "E") THEN + block(i) = _MK$(_FLOAT, VAL(block(i))) btype(i) = SINGLETYPE - ISPOINTER status(i) = 1 - GoTo gotconstblktyp - End If - If InStr(block(i), "D") Then - block(i) = _MK$(_Float, Val(block(i))) + GOTO gotconstblktyp + END IF + IF INSTR(block(i), "D") THEN + block(i) = _MK$(_FLOAT, VAL(block(i))) btype(i) = DOUBLETYPE - ISPOINTER status(i) = 1 - GoTo gotconstblktyp - End If - If InStr(block(i), "F") Then - block(i) = _MK$(_Float, Val(block(i))) + GOTO gotconstblktyp + END IF + IF INSTR(block(i), "F") THEN + block(i) = _MK$(_FLOAT, VAL(block(i))) btype(i) = FLOATTYPE - ISPOINTER status(i) = 1 - GoTo gotconstblktyp - End If + GOTO gotconstblktyp + END IF - Give_Error "Invalid CONST expression.1": EXIT Function + Give_Error "Invalid CONST expression.1": EXIT FUNCTION gotconstblkityp: - block(i) = Left$(block(i), Len(block(i)) - Len(e$)) - block(i) = _MK$(_Integer64, Val(block(i))) + block(i) = LEFT$(block(i), LEN(block(i)) - LEN(e$)) + block(i) = _MK$(_INTEGER64, VAL(block(i))) status(i) = 1 gotconstblktyp: - End If 'a + END IF 'a - If a = 34 Then 'string? + IF a = 34 THEN 'string? 'no changes need to be made to block(i) which is of format "CHARACTERS",size btype(i) = STRINGTYPE - ISPOINTER status(i) = 1 - End If + END IF - End If 'len<>0 - End If 'status - Next + END IF 'len<>0 + END IF 'status + NEXT 'remove NULL blocks n2 = 0 - For i = 1 To n - If block(i) <> "" Then + FOR i = 1 TO n + IF block(i) <> "" THEN n2 = n2 + 1 block(n2) = block(i) status(n2) = status(i) btype(n2) = btype(i) - End If - Next + END IF + NEXT n = n2 'only one block? - If n = 1 Then - If status(1) = 0 Then Give_Error "Invalid CONST expression.2": EXIT Function + IF n = 1 THEN + IF status(1) = 0 THEN Give_Error "Invalid CONST expression.2": EXIT FUNCTION t = btype(1) evaluateconst$ = block(1) - EXIT Function - End If 'n=1 + EXIT FUNCTION + END IF 'n=1 'evaluate equation (equation cannot contain any STRINGs) '[negation/not][variable] e$ = block(1) - If status(1) = 0 Then - If n <> 2 Then Give_Error "Invalid CONST expression.4": EXIT Function - If status(2) = 0 Then Give_Error "Invalid CONST expression.5": EXIT Function - If btype(2) And ISSTRING Then Give_Error "Invalid CONST expression.6": EXIT Function + IF status(1) = 0 THEN + IF n <> 2 THEN Give_Error "Invalid CONST expression.4": EXIT FUNCTION + IF status(2) = 0 THEN Give_Error "Invalid CONST expression.5": EXIT FUNCTION + IF btype(2) AND ISSTRING THEN Give_Error "Invalid CONST expression.6": EXIT FUNCTION o$ = block(1) - If o$ = Chr$(241) Then - If btype(2) And ISFLOAT Then - r## = -_CV(_Float, block(2)) - evaluateconst$ = _MK$(_Float, r##) - Else - r&& = -_CV(_Integer64, block(2)) - evaluateconst$ = _MK$(_Integer64, r&&) - End If + IF o$ = CHR$(241) THEN + IF btype(2) AND ISFLOAT THEN + r## = -_CV(_FLOAT, block(2)) + evaluateconst$ = _MK$(_FLOAT, r##) + ELSE + r&& = -_CV(_INTEGER64, block(2)) + evaluateconst$ = _MK$(_INTEGER64, r&&) + END IF t = btype(2) - EXIT Function - End If + EXIT FUNCTION + END IF - If o$ = "NOT" Then - If btype(2) And ISFLOAT Then - r&& = _CV(_Float, block(2)) - Else - r&& = _CV(_Integer64, block(2)) - End If - r&& = Not r&& + IF o$ = "NOT" THEN + IF btype(2) AND ISFLOAT THEN + r&& = _CV(_FLOAT, block(2)) + ELSE + r&& = _CV(_INTEGER64, block(2)) + END IF + r&& = NOT r&& t = btype(2) - If t And ISFLOAT Then t = LONGTYPE - ISPOINTER 'markdown to LONG - evaluateconst$ = _MK$(_Integer64, r&&) - EXIT Function - End If + IF t AND ISFLOAT THEN t = LONGTYPE - ISPOINTER 'markdown to LONG + evaluateconst$ = _MK$(_INTEGER64, r&&) + EXIT FUNCTION + END IF - Give_Error "Invalid CONST expression.7": EXIT Function - End If + Give_Error "Invalid CONST expression.7": EXIT FUNCTION + END IF '[variable][bool-operator][variable]... @@ -23323,631 +23323,631 @@ Function evaluateconst$ (a2$, t As Long) evalconstequ: 'get operator - If i >= n Then Give_Error "Invalid CONST expression.8": EXIT Function + IF i >= n THEN Give_Error "Invalid CONST expression.8": EXIT FUNCTION o$ = block(i) i = i + 1 - If isoperator(o$) = 0 Then Give_Error "Invalid CONST expression.9": EXIT Function - If i > n Then Give_Error "Invalid CONST expression.10": EXIT Function + IF isoperator(o$) = 0 THEN Give_Error "Invalid CONST expression.9": EXIT FUNCTION + IF i > n THEN Give_Error "Invalid CONST expression.10": EXIT FUNCTION 'string/numeric mismatch? - If (btype(i) And ISSTRING) <> (et And ISSTRING) Then Give_Error "Invalid CONST expression.11": EXIT Function + IF (btype(i) AND ISSTRING) <> (et AND ISSTRING) THEN Give_Error "Invalid CONST expression.11": EXIT FUNCTION - If et And ISSTRING Then - If o$ <> "+" Then Give_Error "Invalid CONST expression.12": EXIT Function + IF et AND ISSTRING THEN + IF o$ <> "+" THEN Give_Error "Invalid CONST expression.12": EXIT FUNCTION 'concat strings - s1$ = Right$(ev$, Len(ev$) - 1) - s1$ = Left$(s1$, InStr(s1$, Chr$(34)) - 1) - s1size = Val(Right$(ev$, Len(ev$) - Len(s1$) - 3)) - s2$ = Right$(block(i), Len(block(i)) - 1) - s2$ = Left$(s2$, InStr(s2$, Chr$(34)) - 1) - s2size = Val(Right$(block(i), Len(block(i)) - Len(s2$) - 3)) - ev$ = Chr$(34) + s1$ + s2$ + Chr$(34) + "," + str2$(s1size + s2size) - GoTo econstmarkedup - End If + s1$ = RIGHT$(ev$, LEN(ev$) - 1) + s1$ = LEFT$(s1$, INSTR(s1$, CHR$(34)) - 1) + s1size = VAL(RIGHT$(ev$, LEN(ev$) - LEN(s1$) - 3)) + s2$ = RIGHT$(block(i), LEN(block(i)) - 1) + s2$ = LEFT$(s2$, INSTR(s2$, CHR$(34)) - 1) + s2size = VAL(RIGHT$(block(i), LEN(block(i)) - LEN(s2$) - 3)) + ev$ = CHR$(34) + s1$ + s2$ + CHR$(34) + "," + str2$(s1size + s2size) + GOTO econstmarkedup + END IF 'prepare left and right values - If et And ISFLOAT Then + IF et AND ISFLOAT THEN linteger = 0 - l## = _CV(_Float, ev$) + l## = _CV(_FLOAT, ev$) l&& = l## - Else + ELSE linteger = 1 - l&& = _CV(_Integer64, ev$) + l&& = _CV(_INTEGER64, ev$) l## = l&& - End If - If btype(i) And ISFLOAT Then + END IF + IF btype(i) AND ISFLOAT THEN rinteger = 0 - r## = _CV(_Float, block(i)) + r## = _CV(_FLOAT, block(i)) r&& = r## - Else + ELSE rinteger = 1 - r&& = _CV(_Integer64, block(i)) + r&& = _CV(_INTEGER64, block(i)) r## = r&& - End If + END IF - If linteger = 1 And rinteger = 1 Then - If o$ = "+" Then r&& = l&& + r&&: GoTo econstmarkupi - If o$ = "-" Then r&& = l&& - r&&: GoTo econstmarkupi - If o$ = "*" Then r&& = l&& * r&&: GoTo econstmarkupi - If o$ = "^" Then r## = l&& ^ r&&: GoTo econstmarkupf - If o$ = "/" Then r## = l&& / r&&: GoTo econstmarkupf - If o$ = "\" Then r&& = l&& \ r&&: GoTo econstmarkupi - If o$ = "MOD" Then r&& = l&& Mod r&&: GoTo econstmarkupi - If o$ = "=" Then r&& = l&& = r&&: GoTo econstmarkupi16 - If o$ = ">" Then r&& = l&& > r&&: GoTo econstmarkupi16 - If o$ = "<" Then r&& = l&& < r&&: GoTo econstmarkupi16 - If o$ = ">=" Then r&& = l&& >= r&&: GoTo econstmarkupi16 - If o$ = "<=" Then r&& = l&& <= r&&: GoTo econstmarkupi16 - If o$ = "<>" Then r&& = l&& <> r&&: GoTo econstmarkupi16 - If o$ = "IMP" Then r&& = l&& Imp r&&: GoTo econstmarkupi - If o$ = "EQV" Then r&& = l&& Eqv r&&: GoTo econstmarkupi - If o$ = "XOR" Then r&& = l&& Xor r&&: GoTo econstmarkupi - If o$ = "OR" Then r&& = l&& Or r&&: GoTo econstmarkupi - If o$ = "AND" Then r&& = l&& And r&&: GoTo econstmarkupi - End If + IF linteger = 1 AND rinteger = 1 THEN + IF o$ = "+" THEN r&& = l&& + r&&: GOTO econstmarkupi + IF o$ = "-" THEN r&& = l&& - r&&: GOTO econstmarkupi + IF o$ = "*" THEN r&& = l&& * r&&: GOTO econstmarkupi + IF o$ = "^" THEN r## = l&& ^ r&&: GOTO econstmarkupf + IF o$ = "/" THEN r## = l&& / r&&: GOTO econstmarkupf + IF o$ = "\" THEN r&& = l&& \ r&&: GOTO econstmarkupi + IF o$ = "MOD" THEN r&& = l&& MOD r&&: GOTO econstmarkupi + IF o$ = "=" THEN r&& = l&& = r&&: GOTO econstmarkupi16 + IF o$ = ">" THEN r&& = l&& > r&&: GOTO econstmarkupi16 + IF o$ = "<" THEN r&& = l&& < r&&: GOTO econstmarkupi16 + IF o$ = ">=" THEN r&& = l&& >= r&&: GOTO econstmarkupi16 + IF o$ = "<=" THEN r&& = l&& <= r&&: GOTO econstmarkupi16 + IF o$ = "<>" THEN r&& = l&& <> r&&: GOTO econstmarkupi16 + IF o$ = "IMP" THEN r&& = l&& IMP r&&: GOTO econstmarkupi + IF o$ = "EQV" THEN r&& = l&& EQV r&&: GOTO econstmarkupi + IF o$ = "XOR" THEN r&& = l&& XOR r&&: GOTO econstmarkupi + IF o$ = "OR" THEN r&& = l&& OR r&&: GOTO econstmarkupi + IF o$ = "AND" THEN r&& = l&& AND r&&: GOTO econstmarkupi + END IF - If o$ = "+" Then r## = l## + r##: GoTo econstmarkupf - If o$ = "-" Then r## = l## - r##: GoTo econstmarkupf - If o$ = "*" Then r## = l## * r##: GoTo econstmarkupf - If o$ = "^" Then r## = l## ^ r##: GoTo econstmarkupf - If o$ = "/" Then r## = l## / r##: GoTo econstmarkupf - If o$ = "\" Then r&& = l## \ r##: GoTo econstmarkupi32 - If o$ = "MOD" Then r&& = l## Mod r##: GoTo econstmarkupi32 - If o$ = "=" Then r&& = l## = r##: GoTo econstmarkupi16 - If o$ = ">" Then r&& = l## > r##: GoTo econstmarkupi16 - If o$ = "<" Then r&& = l## < r##: GoTo econstmarkupi16 - If o$ = ">=" Then r&& = l## >= r##: GoTo econstmarkupi16 - If o$ = "<=" Then r&& = l## <= r##: GoTo econstmarkupi16 - If o$ = "<>" Then r&& = l## <> r##: GoTo econstmarkupi16 - If o$ = "IMP" Then r&& = l## Imp r##: GoTo econstmarkupi32 - If o$ = "EQV" Then r&& = l## Eqv r##: GoTo econstmarkupi32 - If o$ = "XOR" Then r&& = l## Xor r##: GoTo econstmarkupi32 - If o$ = "OR" Then r&& = l## Or r##: GoTo econstmarkupi32 - If o$ = "AND" Then r&& = l## And r##: GoTo econstmarkupi32 + IF o$ = "+" THEN r## = l## + r##: GOTO econstmarkupf + IF o$ = "-" THEN r## = l## - r##: GOTO econstmarkupf + IF o$ = "*" THEN r## = l## * r##: GOTO econstmarkupf + IF o$ = "^" THEN r## = l## ^ r##: GOTO econstmarkupf + IF o$ = "/" THEN r## = l## / r##: GOTO econstmarkupf + IF o$ = "\" THEN r&& = l## \ r##: GOTO econstmarkupi32 + IF o$ = "MOD" THEN r&& = l## MOD r##: GOTO econstmarkupi32 + IF o$ = "=" THEN r&& = l## = r##: GOTO econstmarkupi16 + IF o$ = ">" THEN r&& = l## > r##: GOTO econstmarkupi16 + IF o$ = "<" THEN r&& = l## < r##: GOTO econstmarkupi16 + IF o$ = ">=" THEN r&& = l## >= r##: GOTO econstmarkupi16 + IF o$ = "<=" THEN r&& = l## <= r##: GOTO econstmarkupi16 + IF o$ = "<>" THEN r&& = l## <> r##: GOTO econstmarkupi16 + IF o$ = "IMP" THEN r&& = l## IMP r##: GOTO econstmarkupi32 + IF o$ = "EQV" THEN r&& = l## EQV r##: GOTO econstmarkupi32 + IF o$ = "XOR" THEN r&& = l## XOR r##: GOTO econstmarkupi32 + IF o$ = "OR" THEN r&& = l## OR r##: GOTO econstmarkupi32 + IF o$ = "AND" THEN r&& = l## AND r##: GOTO econstmarkupi32 - Give_Error "Invalid CONST expression.13": EXIT Function + Give_Error "Invalid CONST expression.13": EXIT FUNCTION econstmarkupi16: et = INTEGERTYPE - ISPOINTER - ev$ = _MK$(_Integer64, r&&) - GoTo econstmarkedup + ev$ = _MK$(_INTEGER64, r&&) + GOTO econstmarkedup econstmarkupi32: et = LONGTYPE - ISPOINTER - ev$ = _MK$(_Integer64, r&&) - GoTo econstmarkedup + ev$ = _MK$(_INTEGER64, r&&) + GOTO econstmarkedup econstmarkupi: - If et <> btype(i) Then + IF et <> btype(i) THEN 'keep unsigned? - u = 0: If (et And ISUNSIGNED) <> 0 And (btype(i) And ISUNSIGNED) <> 0 Then u = 1 - lb = et And 511: rb = btype(i) And 511 + u = 0: IF (et AND ISUNSIGNED) <> 0 AND (btype(i) AND ISUNSIGNED) <> 0 THEN u = 1 + lb = et AND 511: rb = btype(i) AND 511 ob = 0 - If lb = rb Then - If (et And ISOFFSETINBITS) <> 0 And (btype(i) And ISOFFSETINBITS) <> 0 Then ob = 1 + IF lb = rb THEN + IF (et AND ISOFFSETINBITS) <> 0 AND (btype(i) AND ISOFFSETINBITS) <> 0 THEN ob = 1 b = lb - End If - If lb > rb Then - If (et And ISOFFSETINBITS) <> 0 Then ob = 1 + END IF + IF lb > rb THEN + IF (et AND ISOFFSETINBITS) <> 0 THEN ob = 1 b = lb - End If - If lb < rb Then - If (btype(i) And ISOFFSETINBITS) <> 0 Then ob = 1 + END IF + IF lb < rb THEN + IF (btype(i) AND ISOFFSETINBITS) <> 0 THEN ob = 1 b = rb - End If + END IF et = b - If ob Then et = et + ISOFFSETINBITS - If u Then et = et + ISUNSIGNED - End If - ev$ = _MK$(_Integer64, r&&) - GoTo econstmarkedup + IF ob THEN et = et + ISOFFSETINBITS + IF u THEN et = et + ISUNSIGNED + END IF + ev$ = _MK$(_INTEGER64, r&&) + GOTO econstmarkedup econstmarkupf: lfb = 0: rfb = 0 lib = 0: rib = 0 - If et And ISFLOAT Then lfb = et And 511 Else lib = et And 511 - If btype(i) And ISFLOAT Then rfb = btype(i) And 511 Else rib = btype(i) And 511 + IF et AND ISFLOAT THEN lfb = et AND 511 ELSE lib = et AND 511 + IF btype(i) AND ISFLOAT THEN rfb = btype(i) AND 511 ELSE rib = btype(i) AND 511 f = 32 - If lib > 16 Or rib > 16 Then f = 64 - If lfb > 32 Or rfb > 32 Then f = 64 - If lib > 32 Or rib > 32 Then f = 256 - If lfb > 64 Or rfb > 64 Then f = 256 + IF lib > 16 OR rib > 16 THEN f = 64 + IF lfb > 32 OR rfb > 32 THEN f = 64 + IF lib > 32 OR rib > 32 THEN f = 256 + IF lfb > 64 OR rfb > 64 THEN f = 256 et = ISFLOAT + f - ev$ = _MK$(_Float, r##) + ev$ = _MK$(_FLOAT, r##) econstmarkedup: i = i + 1 - If i <= n Then GoTo evalconstequ + IF i <= n THEN GOTO evalconstequ t = et evaluateconst$ = ev$ -End Function +END FUNCTION -Function typevalue2symbol$ (t) +FUNCTION typevalue2symbol$ (t) - If t And ISSTRING Then - If t And ISFIXEDLENGTH Then Give_Error "Cannot convert expression type to symbol": EXIT Function + IF t AND ISSTRING THEN + IF t AND ISFIXEDLENGTH THEN Give_Error "Cannot convert expression type to symbol": EXIT FUNCTION typevalue2symbol$ = "$" - EXIT Function - End If + EXIT FUNCTION + END IF s$ = "" - If t And ISUNSIGNED Then s$ = "~" + IF t AND ISUNSIGNED THEN s$ = "~" - b = t And 511 + b = t AND 511 - If t And ISOFFSETINBITS Then - If b > 1 Then s$ = s$ + "`" + str2$(b) Else s$ = s$ + "`" + IF t AND ISOFFSETINBITS THEN + IF b > 1 THEN s$ = s$ + "`" + str2$(b) ELSE s$ = s$ + "`" typevalue2symbol$ = s$ - EXIT Function - End If + EXIT FUNCTION + END IF - If t And ISFLOAT Then - If b = 32 Then s$ = "!" - If b = 64 Then s$ = "#" - If b = 256 Then s$ = "##" + IF t AND ISFLOAT THEN + IF b = 32 THEN s$ = "!" + IF b = 64 THEN s$ = "#" + IF b = 256 THEN s$ = "##" typevalue2symbol$ = s$ - EXIT Function - End If + EXIT FUNCTION + END IF - If b = 8 Then s$ = s$ + "%%" - If b = 16 Then s$ = s$ + "%" - If b = 32 Then s$ = s$ + "&" - If b = 64 Then s$ = s$ + "&&" + IF b = 8 THEN s$ = s$ + "%%" + IF b = 16 THEN s$ = s$ + "%" + IF b = 32 THEN s$ = s$ + "&" + IF b = 64 THEN s$ = s$ + "&&" typevalue2symbol$ = s$ -End Function +END FUNCTION -Function id2fulltypename$ +FUNCTION id2fulltypename$ t = id.t - If t = 0 Then t = id.arraytype + IF t = 0 THEN t = id.arraytype size = id.tsize - bits = t And 511 - If t And ISUDT Then - a$ = RTrim$(udtxcname(t And 511)) - id2fulltypename$ = a$: EXIT Function - End If - If t And ISSTRING Then - If t And ISFIXEDLENGTH Then a$ = "STRING * " + str2(size) Else a$ = "STRING" - id2fulltypename$ = a$: EXIT Function - End If - If t And ISOFFSETINBITS Then - If bits > 1 Then a$ = qb64prefix$ + "BIT * " + str2(bits) Else a$ = qb64prefix$ + "BIT" - If t And ISUNSIGNED Then a$ = qb64prefix$ + "UNSIGNED " + a$ - id2fulltypename$ = a$: EXIT Function - End If - If t And ISFLOAT Then - If bits = 32 Then a$ = "SINGLE" - If bits = 64 Then a$ = "DOUBLE" - If bits = 256 Then a$ = qb64prefix$ + "FLOAT" - Else 'integer-based - If bits = 8 Then a$ = qb64prefix$ + "BYTE" - If bits = 16 Then a$ = "INTEGER" - If bits = 32 Then a$ = "LONG" - If bits = 64 Then a$ = qb64prefix$ + "INTEGER64" - If t And ISUNSIGNED Then a$ = qb64prefix$ + "UNSIGNED " + a$ - End If + bits = t AND 511 + IF t AND ISUDT THEN + a$ = RTRIM$(udtxcname(t AND 511)) + id2fulltypename$ = a$: EXIT FUNCTION + END IF + IF t AND ISSTRING THEN + IF t AND ISFIXEDLENGTH THEN a$ = "STRING * " + str2(size) ELSE a$ = "STRING" + id2fulltypename$ = a$: EXIT FUNCTION + END IF + IF t AND ISOFFSETINBITS THEN + IF bits > 1 THEN a$ = qb64prefix$ + "BIT * " + str2(bits) ELSE a$ = qb64prefix$ + "BIT" + IF t AND ISUNSIGNED THEN a$ = qb64prefix$ + "UNSIGNED " + a$ + id2fulltypename$ = a$: EXIT FUNCTION + END IF + IF t AND ISFLOAT THEN + IF bits = 32 THEN a$ = "SINGLE" + IF bits = 64 THEN a$ = "DOUBLE" + IF bits = 256 THEN a$ = qb64prefix$ + "FLOAT" + ELSE 'integer-based + IF bits = 8 THEN a$ = qb64prefix$ + "BYTE" + IF bits = 16 THEN a$ = "INTEGER" + IF bits = 32 THEN a$ = "LONG" + IF bits = 64 THEN a$ = qb64prefix$ + "INTEGER64" + IF t AND ISUNSIGNED THEN a$ = qb64prefix$ + "UNSIGNED " + a$ + END IF id2fulltypename$ = a$ -End Function +END FUNCTION -Function id2shorttypename$ +FUNCTION id2shorttypename$ t = id.t - If t = 0 Then t = id.arraytype + IF t = 0 THEN t = id.arraytype size = id.tsize - bits = t And 511 - If t And ISUDT Then - a$ = RTrim$(udtxcname(t And 511)) - id2shorttypename$ = a$: EXIT Function - End If - If t And ISSTRING Then - If t And ISFIXEDLENGTH Then a$ = "STRING" + str2(size) Else a$ = "STRING" - id2shorttypename$ = a$: EXIT Function - End If - If t And ISOFFSETINBITS Then - If t And ISUNSIGNED Then a$ = "_U" Else a$ = "_" - If bits > 1 Then a$ = a$ + "BIT" + str2(bits) Else a$ = a$ + "BIT1" - id2shorttypename$ = a$: EXIT Function - End If - If t And ISFLOAT Then - If bits = 32 Then a$ = "SINGLE" - If bits = 64 Then a$ = "DOUBLE" - If bits = 256 Then a$ = "_FLOAT" - Else 'integer-based - If bits = 8 Then - If (t And ISUNSIGNED) Then a$ = "_UBYTE" Else a$ = "_BYTE" - End If - If bits = 16 Then - If (t And ISUNSIGNED) Then a$ = "UINTEGER" Else a$ = "INTEGER" - End If - If bits = 32 Then - If (t And ISUNSIGNED) Then a$ = "ULONG" Else a$ = "LONG" - End If - If bits = 64 Then - If (t And ISUNSIGNED) Then a$ = "_UINTEGER64" Else a$ = "_INTEGER64" - End If - End If + bits = t AND 511 + IF t AND ISUDT THEN + a$ = RTRIM$(udtxcname(t AND 511)) + id2shorttypename$ = a$: EXIT FUNCTION + END IF + IF t AND ISSTRING THEN + IF t AND ISFIXEDLENGTH THEN a$ = "STRING" + str2(size) ELSE a$ = "STRING" + id2shorttypename$ = a$: EXIT FUNCTION + END IF + IF t AND ISOFFSETINBITS THEN + IF t AND ISUNSIGNED THEN a$ = "_U" ELSE a$ = "_" + IF bits > 1 THEN a$ = a$ + "BIT" + str2(bits) ELSE a$ = a$ + "BIT1" + id2shorttypename$ = a$: EXIT FUNCTION + END IF + IF t AND ISFLOAT THEN + IF bits = 32 THEN a$ = "SINGLE" + IF bits = 64 THEN a$ = "DOUBLE" + IF bits = 256 THEN a$ = "_FLOAT" + ELSE 'integer-based + IF bits = 8 THEN + IF (t AND ISUNSIGNED) THEN a$ = "_UBYTE" ELSE a$ = "_BYTE" + END IF + IF bits = 16 THEN + IF (t AND ISUNSIGNED) THEN a$ = "UINTEGER" ELSE a$ = "INTEGER" + END IF + IF bits = 32 THEN + IF (t AND ISUNSIGNED) THEN a$ = "ULONG" ELSE a$ = "LONG" + END IF + IF bits = 64 THEN + IF (t AND ISUNSIGNED) THEN a$ = "_UINTEGER64" ELSE a$ = "_INTEGER64" + END IF + END IF id2shorttypename$ = a$ -End Function +END FUNCTION -Function symbol2fulltypename$ (s2$) +FUNCTION symbol2fulltypename$ (s2$) 'note: accepts both symbols and type names s$ = s2$ - If Left$(s$, 1) = "~" Then + IF LEFT$(s$, 1) = "~" THEN u = 1 - If Len(typ$) = 1 Then Give_Error "Expected ~...": EXIT Function - s$ = Right$(s$, Len(s$) - 1) + IF LEN(typ$) = 1 THEN Give_Error "Expected ~...": EXIT FUNCTION + s$ = RIGHT$(s$, LEN(s$) - 1) u$ = qb64prefix$ + "UNSIGNED " - End If + END IF - If s$ = "%%" Then t$ = u$ + qb64prefix$ + "BYTE": GoTo gotsym2typ - If s$ = "%" Then t$ = u$ + "INTEGER": GoTo gotsym2typ - If s$ = "&" Then t$ = u$ + "LONG": GoTo gotsym2typ - If s$ = "&&" Then t$ = u$ + qb64prefix$ + "INTEGER64": GoTo gotsym2typ - If s$ = "%&" Then t$ = u$ + qb64prefix$ + "OFFSET": GoTo gotsym2typ + IF s$ = "%%" THEN t$ = u$ + qb64prefix$ + "BYTE": GOTO gotsym2typ + IF s$ = "%" THEN t$ = u$ + "INTEGER": GOTO gotsym2typ + IF s$ = "&" THEN t$ = u$ + "LONG": GOTO gotsym2typ + IF s$ = "&&" THEN t$ = u$ + qb64prefix$ + "INTEGER64": GOTO gotsym2typ + IF s$ = "%&" THEN t$ = u$ + qb64prefix$ + "OFFSET": GOTO gotsym2typ - If Left$(s$, 1) = "`" Then - If Len(s$) = 1 Then + IF LEFT$(s$, 1) = "`" THEN + IF LEN(s$) = 1 THEN t$ = u$ + qb64prefix$ + "BIT * 1" - GoTo gotsym2typ - End If - n$ = Right$(s$, Len(s$) - 1) - If isuinteger(n$) = 0 Then Give_Error "Expected number after symbol `": EXIT Function + GOTO gotsym2typ + END IF + n$ = RIGHT$(s$, LEN(s$) - 1) + IF isuinteger(n$) = 0 THEN Give_Error "Expected number after symbol `": EXIT FUNCTION t$ = u$ + qb64prefix$ + "BIT * " + n$ - GoTo gotsym2typ - End If + GOTO gotsym2typ + END IF - If u = 1 Then Give_Error "Expected type symbol after ~": EXIT Function + IF u = 1 THEN Give_Error "Expected type symbol after ~": EXIT FUNCTION - If s$ = "!" Then t$ = "SINGLE": GoTo gotsym2typ - If s$ = "#" Then t$ = "DOUBLE": GoTo gotsym2typ - If s$ = "##" Then t$ = qb64prefix$ + "FLOAT": GoTo gotsym2typ - If s$ = "$" Then t$ = "STRING": GoTo gotsym2typ + IF s$ = "!" THEN t$ = "SINGLE": GOTO gotsym2typ + IF s$ = "#" THEN t$ = "DOUBLE": GOTO gotsym2typ + IF s$ = "##" THEN t$ = qb64prefix$ + "FLOAT": GOTO gotsym2typ + IF s$ = "$" THEN t$ = "STRING": GOTO gotsym2typ - If Left$(s$, 1) = "$" Then - n$ = Right$(s$, Len(s$) - 1) - If isuinteger(n$) = 0 Then Give_Error "Expected number after symbol $": EXIT Function + IF LEFT$(s$, 1) = "$" THEN + n$ = RIGHT$(s$, LEN(s$) - 1) + IF isuinteger(n$) = 0 THEN Give_Error "Expected number after symbol $": EXIT FUNCTION t$ = "STRING * " + n$ - GoTo gotsym2typ - End If + GOTO gotsym2typ + END IF t$ = s$ gotsym2typ: - If Right$(" " + t$, 5) = " _BIT" Then t$ = t$ + " * 1" 'clarify (_UNSIGNED) _BIT as (_UNSIGNED) _BIT * 1 + IF RIGHT$(" " + t$, 5) = " _BIT" THEN t$ = t$ + " * 1" 'clarify (_UNSIGNED) _BIT as (_UNSIGNED) _BIT * 1 - For i = 1 To Len(t$) - If Asc(t$, i) = Asc(sp) Then Asc(t$, i) = 32 - Next + FOR i = 1 TO LEN(t$) + IF ASC(t$, i) = ASC(sp) THEN ASC(t$, i) = 32 + NEXT symbol2fulltypename$ = t$ -End Function +END FUNCTION -Sub lineinput3load (f$) - Open f$ For Binary As #1 +SUB lineinput3load (f$) + OPEN f$ FOR BINARY AS #1 l = LOF(1) - lineinput3buffer$ = Space$(l) - Get #1, , lineinput3buffer$ - If Len(lineinput3buffer$) Then If Right$(lineinput3buffer$, 1) = Chr$(26) Then lineinput3buffer$ = Left$(lineinput3buffer$, Len(lineinput3buffer$) - 1) - Close #1 + lineinput3buffer$ = SPACE$(l) + GET #1, , lineinput3buffer$ + IF LEN(lineinput3buffer$) THEN IF RIGHT$(lineinput3buffer$, 1) = CHR$(26) THEN lineinput3buffer$ = LEFT$(lineinput3buffer$, LEN(lineinput3buffer$) - 1) + CLOSE #1 lineinput3index = 1 -End Sub +END SUB -Function lineinput3$ +FUNCTION lineinput3$ 'returns CHR$(13) if no more lines are available - l = Len(lineinput3buffer$) - If lineinput3index > l Then lineinput3$ = Chr$(13): EXIT Function - c13 = InStr(lineinput3index, lineinput3buffer$, Chr$(13)) - c10 = InStr(lineinput3index, lineinput3buffer$, Chr$(10)) - If c10 = 0 And c13 = 0 Then - lineinput3$ = Mid$(lineinput3buffer$, lineinput3index, l - lineinput3index + 1) + l = LEN(lineinput3buffer$) + IF lineinput3index > l THEN lineinput3$ = CHR$(13): EXIT FUNCTION + c13 = INSTR(lineinput3index, lineinput3buffer$, CHR$(13)) + c10 = INSTR(lineinput3index, lineinput3buffer$, CHR$(10)) + IF c10 = 0 AND c13 = 0 THEN + lineinput3$ = MID$(lineinput3buffer$, lineinput3index, l - lineinput3index + 1) lineinput3index = l + 1 - EXIT Function - End If - If c10 = 0 Then c10 = 2147483647 - If c13 = 0 Then c13 = 2147483647 - If c10 < c13 Then + EXIT FUNCTION + END IF + IF c10 = 0 THEN c10 = 2147483647 + IF c13 = 0 THEN c13 = 2147483647 + IF c10 < c13 THEN '10 before 13 - lineinput3$ = Mid$(lineinput3buffer$, lineinput3index, c10 - lineinput3index) + lineinput3$ = MID$(lineinput3buffer$, lineinput3index, c10 - lineinput3index) lineinput3index = c10 + 1 - If lineinput3index <= l Then - If Asc(Mid$(lineinput3buffer$, lineinput3index, 1)) = 13 Then lineinput3index = lineinput3index + 1 - End If - Else + IF lineinput3index <= l THEN + IF ASC(MID$(lineinput3buffer$, lineinput3index, 1)) = 13 THEN lineinput3index = lineinput3index + 1 + END IF + ELSE '13 before 10 - lineinput3$ = Mid$(lineinput3buffer$, lineinput3index, c13 - lineinput3index) + lineinput3$ = MID$(lineinput3buffer$, lineinput3index, c13 - lineinput3index) lineinput3index = c13 + 1 - If lineinput3index <= l Then - If Asc(Mid$(lineinput3buffer$, lineinput3index, 1)) = 10 Then lineinput3index = lineinput3index + 1 - End If - End If -End Function + IF lineinput3index <= l THEN + IF ASC(MID$(lineinput3buffer$, lineinput3index, 1)) = 10 THEN lineinput3index = lineinput3index + 1 + END IF + END IF +END FUNCTION -Function getfilepath$ (f$) - For i = Len(f$) To 1 Step -1 - a$ = Mid$(f$, i, 1) - If a$ = "/" Or a$ = "\" Then - getfilepath$ = Left$(f$, i) - EXIT Function - End If - Next +FUNCTION getfilepath$ (f$) + FOR i = LEN(f$) TO 1 STEP -1 + a$ = MID$(f$, i, 1) + IF a$ = "/" OR a$ = "\" THEN + getfilepath$ = LEFT$(f$, i) + EXIT FUNCTION + END IF + NEXT getfilepath$ = "" -End Function +END FUNCTION -Function eleucase$ (a$) +FUNCTION eleucase$ (a$) 'this function upper-cases all elements except for quoted strings 'check first element - If Len(a$) = 0 Then EXIT Function + IF LEN(a$) = 0 THEN EXIT FUNCTION i = 1 - If Asc(a$) = 34 Then - i2 = InStr(a$, sp) - If i2 = 0 Then eleucase$ = a$: EXIT Function - a2$ = Left$(a$, i2 - 1) + IF ASC(a$) = 34 THEN + i2 = INSTR(a$, sp) + IF i2 = 0 THEN eleucase$ = a$: EXIT FUNCTION + a2$ = LEFT$(a$, i2 - 1) i = i2 - End If + END IF 'check other elements - sp34$ = sp + Chr$(34) - If i < Len(a$) Then - Do While InStr(i, a$, sp34$) - i2 = InStr(i, a$, sp34$) - a2$ = a2$ + UCase$(Mid$(a$, i, i2 - i + 1)) 'everything prior including spacer - i3 = InStr(i2 + 1, a$, sp): If i3 = 0 Then i3 = Len(a$) Else i3 = i3 - 1 - a2$ = a2$ + Mid$(a$, i2 + 1, i3 - (i2 + 1) + 1) 'everything from " to before next spacer or end + sp34$ = sp + CHR$(34) + IF i < LEN(a$) THEN + DO WHILE INSTR(i, a$, sp34$) + i2 = INSTR(i, a$, sp34$) + a2$ = a2$ + UCASE$(MID$(a$, i, i2 - i + 1)) 'everything prior including spacer + i3 = INSTR(i2 + 1, a$, sp): IF i3 = 0 THEN i3 = LEN(a$) ELSE i3 = i3 - 1 + a2$ = a2$ + MID$(a$, i2 + 1, i3 - (i2 + 1) + 1) 'everything from " to before next spacer or end i = i3 + 1 - If i > Len(a$) Then Exit Do - Loop - End If - a2$ = a2$ + UCase$(Mid$(a$, i, Len(a$) - i + 1)) + IF i > LEN(a$) THEN EXIT DO + LOOP + END IF + a2$ = a2$ + UCASE$(MID$(a$, i, LEN(a$) - i + 1)) eleucase$ = a2$ -End Function +END FUNCTION -Sub SetDependency (requirement) - If requirement Then +SUB SetDependency (requirement) + IF requirement THEN DEPENDENCY(requirement) = 1 - End If -End Sub + END IF +END SUB -Sub Build (path$) +SUB Build (path$) previous_dir$ = _CWD$ 'Count the separators in the path depth = 1 - For x = 1 To Len(path$) - If Asc(path$, x) = 92 Or Asc(path$, x) = 47 Then depth = depth + 1 - Next - ChDir path$ + FOR x = 1 TO LEN(path$) + IF ASC(path$, x) = 92 OR ASC(path$, x) = 47 THEN depth = depth + 1 + NEXT + CHDIR path$ return_path$ = ".." - For x = 2 To depth + FOR x = 2 TO depth return_path$ = return_path$ + "\.." - Next + NEXT - bfh = FreeFile - Open "build" + BATCHFILE_EXTENSION For Binary As #bfh - Do Until EOF(bfh) - Line Input #bfh, c$ + bfh = FREEFILE + OPEN "build" + BATCHFILE_EXTENSION FOR BINARY AS #bfh + DO UNTIL EOF(bfh) + LINE INPUT #bfh, c$ use = 0 - If Len(c$) Then use = 1 - If c$ = "pause" Then use = 0 - If Left$(c$, 1) = "#" Then use = 0 'eg. #!/bin/sh - If Left$(c$, 13) = "cd " + Chr$(34) + "$(dirname" Then use = 0 'eg. cd "$(dirname "$0")" - If InStr(LCase$(c$), "press any key") Then Exit Do + IF LEN(c$) THEN use = 1 + IF c$ = "pause" THEN use = 0 + IF LEFT$(c$, 1) = "#" THEN use = 0 'eg. #!/bin/sh + IF LEFT$(c$, 13) = "cd " + CHR$(34) + "$(dirname" THEN use = 0 'eg. cd "$(dirname "$0")" + IF INSTR(LCASE$(c$), "press any key") THEN EXIT DO c$ = GDB_Fix$(c$) - If use Then - If os$ = "WIN" Then - Shell _Hide "cmd /C " + c$ + " 2>> " + return_path$ + "\" + compilelog$ - Else - Shell _Hide c$ + " 2>> " + previous_dir$ + "/" + compilelog$ - End If - End If - Loop - Close #bfh + IF use THEN + IF os$ = "WIN" THEN + SHELL _HIDE "cmd /C " + c$ + " 2>> " + return_path$ + "\" + compilelog$ + ELSE + SHELL _HIDE c$ + " 2>> " + previous_dir$ + "/" + compilelog$ + END IF + END IF + LOOP + CLOSE #bfh - If os$ = "WIN" Then - ChDir return_path$ - Else - ChDir previous_dir$ - End If -End Sub + IF os$ = "WIN" THEN + CHDIR return_path$ + ELSE + CHDIR previous_dir$ + END IF +END SUB -Function GDB_Fix$ (g_command$) 'edit a gcc/g++ command line to include debugging info +FUNCTION GDB_Fix$ (g_command$) 'edit a gcc/g++ command line to include debugging info c$ = g_command$ - If Include_GDB_Debugging_Info Then - If Left$(c$, 4) = "gcc " Or Left$(c$, 4) = "g++ " Then - c$ = Left$(c$, 4) + " -g " + Right$(c$, Len(c$) - 4) - GoTo added_gdb_flag - End If - For o = 1 To 6 - If o = 1 Then o$ = "\g++ " - If o = 2 Then o$ = "/g++ " - If o = 3 Then o$ = "\gcc " - If o = 4 Then o$ = "/gcc " - If o = 5 Then o$ = " gcc " - If o = 6 Then o$ = " g++ " - x = InStr(UCase$(c$), UCase$(o$)) + IF Include_GDB_Debugging_Info THEN + IF LEFT$(c$, 4) = "gcc " OR LEFT$(c$, 4) = "g++ " THEN + c$ = LEFT$(c$, 4) + " -g " + RIGHT$(c$, LEN(c$) - 4) + GOTO added_gdb_flag + END IF + FOR o = 1 TO 6 + IF o = 1 THEN o$ = "\g++ " + IF o = 2 THEN o$ = "/g++ " + IF o = 3 THEN o$ = "\gcc " + IF o = 4 THEN o$ = "/gcc " + IF o = 5 THEN o$ = " gcc " + IF o = 6 THEN o$ = " g++ " + x = INSTR(UCASE$(c$), UCASE$(o$)) 'note: -g adds debug symbols - If x Then c$ = Left$(c$, x - 1) + o$ + " -g " + Right$(c$, Len(c$) - x - (Len(o$) - 1)): Exit For - Next + IF x THEN c$ = LEFT$(c$, x - 1) + o$ + " -g " + RIGHT$(c$, LEN(c$) - x - (LEN(o$) - 1)): EXIT FOR + NEXT added_gdb_flag: 'note: -s strips all debug symbols which is good for size but not for debugging - x = InStr(c$, " -s "): If x Then c$ = Left$(c$, x - 1) + " " + Right$(c$, Len(c$) - x - 3) - End If + x = INSTR(c$, " -s "): IF x THEN c$ = LEFT$(c$, x - 1) + " " + RIGHT$(c$, LEN(c$) - x - 3) + END IF GDB_Fix$ = c$ -End Function +END FUNCTION -Sub PATH_SLASH_CORRECT (a$) - If os$ = "WIN" Then - For x = 1 To Len(a$) - If Asc(a$, x) = 47 Then Asc(a$, x) = 92 - Next - Else - For x = 1 To Len(a$) - If Asc(a$, x) = 92 Then Asc(a$, x) = 47 - Next - End If -End Sub +SUB PATH_SLASH_CORRECT (a$) + IF os$ = "WIN" THEN + FOR x = 1 TO LEN(a$) + IF ASC(a$, x) = 47 THEN ASC(a$, x) = 92 + NEXT + ELSE + FOR x = 1 TO LEN(a$) + IF ASC(a$, x) = 92 THEN ASC(a$, x) = 47 + NEXT + END IF +END SUB 'Steve Subs/Functins for _MATH support with CONST -Function Evaluate_Expression$ (e$) +FUNCTION Evaluate_Expression$ (e$) t$ = e$ 'So we preserve our original data, we parse a temp copy of it PreParse t$ - If Left$(t$, 5) = "ERROR" Then Evaluate_Expression$ = t$: EXIT Function + IF LEFT$(t$, 5) = "ERROR" THEN Evaluate_Expression$ = t$: EXIT FUNCTION 'Deal with brackets first exp$ = "(" + t$ + ")" 'Starting and finishing brackets for our parse routine. - Do - Eval_E = InStr(exp$, ")") - If Eval_E > 0 Then + DO + Eval_E = INSTR(exp$, ")") + IF Eval_E > 0 THEN c = 0 - Do Until Eval_E - c <= 0 + DO UNTIL Eval_E - c <= 0 c = c + 1 - If Eval_E Then - If Mid$(exp$, Eval_E - c, 1) = "(" Then Exit Do - End If - Loop + IF Eval_E THEN + IF MID$(exp$, Eval_E - c, 1) = "(" THEN EXIT DO + END IF + LOOP s = Eval_E - c + 1 - If s < 1 Then Evaluate_Expression$ = "ERROR -- BAD () Count": EXIT Function - eval$ = " " + Mid$(exp$, s, Eval_E - s) + " " 'pad with a space before and after so the parser can pick up the values properly. + IF s < 1 THEN Evaluate_Expression$ = "ERROR -- BAD () Count": EXIT FUNCTION + eval$ = " " + MID$(exp$, s, Eval_E - s) + " " 'pad with a space before and after so the parser can pick up the values properly. ParseExpression eval$ - eval$ = LTrim$(RTrim$(eval$)) - If Left$(eval$, 5) = "ERROR" Then Evaluate_Expression$ = eval$: EXIT Function - exp$ = DWD(Left$(exp$, s - 2) + eval$ + Mid$(exp$, Eval_E + 1)) - If Mid$(exp$, 1, 1) = "N" Then Mid$(exp$, 1) = "-" - End If - Loop Until Eval_E = 0 + eval$ = LTRIM$(RTRIM$(eval$)) + IF LEFT$(eval$, 5) = "ERROR" THEN Evaluate_Expression$ = eval$: EXIT FUNCTION + exp$ = DWD(LEFT$(exp$, s - 2) + eval$ + MID$(exp$, Eval_E + 1)) + IF MID$(exp$, 1, 1) = "N" THEN MID$(exp$, 1) = "-" + END IF + LOOP UNTIL Eval_E = 0 c = 0 - Do + DO c = c + 1 - Select Case Mid$(exp$, c, 1) - Case "0" TO "9", ".", "-" 'At this point, we should only have number values left. - Case Else: Evaluate_Expression$ = "ERROR - Unknown Diagnosis: (" + exp$ + ") ": EXIT Function - End Select - Loop Until c >= Len(exp$) + SELECT CASE MID$(exp$, c, 1) + CASE "0" TO "9", ".", "-" 'At this point, we should only have number values left. + CASE ELSE: Evaluate_Expression$ = "ERROR - Unknown Diagnosis: (" + exp$ + ") ": EXIT FUNCTION + END SELECT + LOOP UNTIL c >= LEN(exp$) Evaluate_Expression$ = exp$ -End Function +END FUNCTION -Sub ParseExpression (exp$) - Dim num(10) As String +SUB ParseExpression (exp$) + DIM num(10) AS STRING 'PRINT exp$ exp$ = DWD(exp$) 'We should now have an expression with no () to deal with - For J = 1 To 250 + FOR J = 1 TO 250 lowest = 0 - Do Until lowest = Len(exp$) - lowest = Len(exp$): OpOn = 0 - For P = 1 To UBound(OName) + DO UNTIL lowest = LEN(exp$) + lowest = LEN(exp$): OpOn = 0 + FOR P = 1 TO UBOUND(OName) 'Look for first valid operator - If J = PL(P) Then 'Priority levels match - If Left$(exp$, 1) = "-" Then startAt = 2 Else startAt = 1 - op = InStr(startAt, exp$, OName(P)) - If op = 0 And Left$(OName(P), 1) = "_" And qb64prefix_set = 1 Then + IF J = PL(P) THEN 'Priority levels match + IF LEFT$(exp$, 1) = "-" THEN startAt = 2 ELSE startAt = 1 + op = INSTR(startAt, exp$, OName(P)) + IF op = 0 AND LEFT$(OName(P), 1) = "_" AND qb64prefix_set = 1 THEN 'try again without prefix - op = InStr(startAt, exp$, Mid$(OName(P), 2)) - If op > 0 Then - exp$ = Left$(exp$, op - 1) + "_" + Mid$(exp$, op) + op = INSTR(startAt, exp$, MID$(OName(P), 2)) + IF op > 0 THEN + exp$ = LEFT$(exp$, op - 1) + "_" + MID$(exp$, op) lowest = lowest + 1 - End If - End If - If op > 0 And op < lowest Then lowest = op: OpOn = P - End If - Next - If OpOn = 0 Then Exit Do 'We haven't gotten to the proper PL for this OP to be processed yet. - If Left$(exp$, 1) = "-" Then startAt = 2 Else startAt = 1 - op = InStr(startAt, exp$, OName(OpOn)) + END IF + END IF + IF op > 0 AND op < lowest THEN lowest = op: OpOn = P + END IF + NEXT + IF OpOn = 0 THEN EXIT DO 'We haven't gotten to the proper PL for this OP to be processed yet. + IF LEFT$(exp$, 1) = "-" THEN startAt = 2 ELSE startAt = 1 + op = INSTR(startAt, exp$, OName(OpOn)) numset = 0 '*** SPECIAL OPERATION RULESETS - If OName(OpOn) = "-" Then 'check for BOOLEAN operators before the - - Select Case Mid$(exp$, op - 3, 3) - Case "NOT", "XOR", "AND", "EQV", "IMP" - Exit Do 'Not an operator, it's a negative - End Select - If Mid$(exp$, op - 3, 2) = "OR" Then Exit Do 'Not an operator, it's a negative - End If + IF OName(OpOn) = "-" THEN 'check for BOOLEAN operators before the - + SELECT CASE MID$(exp$, op - 3, 3) + CASE "NOT", "XOR", "AND", "EQV", "IMP" + EXIT DO 'Not an operator, it's a negative + END SELECT + IF MID$(exp$, op - 3, 2) = "OR" THEN EXIT DO 'Not an operator, it's a negative + END IF - If op Then - c = Len(OName(OpOn)) - 1 - Do - Select Case Mid$(exp$, op + c + 1, 1) - Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", ".", "N": numset = -1 'Valid digit - Case "-" 'We need to check if it's a minus or a negative - If OName(OpOn) = "_PI" Or numset Then Exit Do - Case ",": numset = 0 - Case Else 'Not a valid digit, we found our separator - Exit Do - End Select + IF op THEN + c = LEN(OName(OpOn)) - 1 + DO + SELECT CASE MID$(exp$, op + c + 1, 1) + CASE "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", ".", "N": numset = -1 'Valid digit + CASE "-" 'We need to check if it's a minus or a negative + IF OName(OpOn) = "_PI" OR numset THEN EXIT DO + CASE ",": numset = 0 + CASE ELSE 'Not a valid digit, we found our separator + EXIT DO + END SELECT c = c + 1 - Loop Until op + c >= Len(exp$) + LOOP UNTIL op + c >= LEN(exp$) E = op + c c = 0 - Do + DO c = c + 1 - Select Case Mid$(exp$, op - c, 1) - Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", ".", "N" 'Valid digit - Case "-" 'We need to check if it's a minus or a negative + SELECT CASE MID$(exp$, op - c, 1) + CASE "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", ".", "N" 'Valid digit + CASE "-" 'We need to check if it's a minus or a negative c1 = c bad = 0 - Do + DO c1 = c1 + 1 - Select Case Mid$(exp$, op - c1, 1) - Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "." + SELECT CASE MID$(exp$, op - c1, 1) + CASE "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "." bad = -1 - Exit Do 'It's a minus sign - Case Else + EXIT DO 'It's a minus sign + CASE ELSE 'It's a negative sign and needs to count as part of our numbers - End Select - Loop Until op - c1 <= 0 - If bad Then Exit Do 'We found our seperator - Case Else 'Not a valid digit, we found our separator - Exit Do - End Select - Loop Until op - c <= 0 + END SELECT + LOOP UNTIL op - c1 <= 0 + IF bad THEN EXIT DO 'We found our seperator + CASE ELSE 'Not a valid digit, we found our separator + EXIT DO + END SELECT + LOOP UNTIL op - c <= 0 s = op - c - num(1) = Mid$(exp$, s + 1, op - s - 1) 'Get our first number - num(2) = Mid$(exp$, op + Len(OName(OpOn)), E - op - Len(OName(OpOn)) + 1) 'Get our second number - If Mid$(num(1), 1, 1) = "N" Then Mid$(num(1), 1) = "-" - If Mid$(num(2), 1, 1) = "N" Then Mid$(num(2), 1) = "-" - If num(1) = "-" Then + num(1) = MID$(exp$, s + 1, op - s - 1) 'Get our first number + num(2) = MID$(exp$, op + LEN(OName(OpOn)), E - op - LEN(OName(OpOn)) + 1) 'Get our second number + IF MID$(num(1), 1, 1) = "N" THEN MID$(num(1), 1) = "-" + IF MID$(num(2), 1, 1) = "N" THEN MID$(num(2), 1) = "-" + IF num(1) = "-" THEN num(3) = "N" + EvaluateNumbers(OpOn, num()) - Else + ELSE num(3) = EvaluateNumbers(OpOn, num()) - End If - If Mid$(num(3), 1, 1) = "-" Then Mid$(num(3), 1) = "N" - If Left$(num(3), 5) = "ERROR" Then exp$ = num(3): EXIT Sub - exp$ = LTrim$(N2S(DWD(Left$(exp$, s) + RTrim$(LTrim$(num(3))) + Mid$(exp$, E + 1)))) - End If + END IF + IF MID$(num(3), 1, 1) = "-" THEN MID$(num(3), 1) = "N" + IF LEFT$(num(3), 5) = "ERROR" THEN exp$ = num(3): EXIT SUB + exp$ = LTRIM$(N2S(DWD(LEFT$(exp$, s) + RTRIM$(LTRIM$(num(3))) + MID$(exp$, E + 1)))) + END IF op = 0 - Loop - Next + LOOP + NEXT -End Sub +END SUB -Sub Set_OrderOfOperations +SUB Set_OrderOfOperations 'PL sets our priortity level. 1 is highest to 65535 for the lowest. 'I used a range here so I could add in new priority levels as needed. 'OName ended up becoming the name of our commands, as I modified things.... Go figure! LOL! - ReDim OName(10000) As String, PL(10000) As Integer + REDIM OName(10000) AS STRING, PL(10000) AS INTEGER 'Constants get evaluated first, with a Priority Level of 1 i = i + 1: OName(i) = "C_UOF": PL(i) = 5 'convert to unsigned offset @@ -24046,301 +24046,301 @@ Sub Set_OrderOfOperations i = i + 1: OName(i) = "IMP": PL(i) = 130 i = i + 1: OName(i) = ",": PL(i) = 1000 - ReDim _Preserve OName(i) As String, PL(i) As Integer -End Sub + REDIM _PRESERVE OName(i) AS STRING, PL(i) AS INTEGER +END SUB -Function EvaluateNumbers$ (p, num() As String) - Dim n1 As _Float, n2 As _Float, n3 As _Float +FUNCTION EvaluateNumbers$ (p, num() AS STRING) + DIM n1 AS _FLOAT, n2 AS _FLOAT, n3 AS _FLOAT 'PRINT "EVALNUM:"; OName(p), num(1), num(2) - If _Trim$(num(1)) = "" Then num(1) = "0" + IF _TRIM$(num(1)) = "" THEN num(1) = "0" - If PL(p) >= 20 And (Len(_Trim$(num(1))) = 0 Or Len(_Trim$(num(2))) = 0) Then - EvaluateNumbers$ = "ERROR - Missing operand": EXIT Function - End If + IF PL(p) >= 20 AND (LEN(_TRIM$(num(1))) = 0 OR LEN(_TRIM$(num(2))) = 0) THEN + EvaluateNumbers$ = "ERROR - Missing operand": EXIT FUNCTION + END IF - If InStr(num(1), ",") Then - EvaluateNumbers$ = "ERROR - Invalid comma (" + num(1) + ")": EXIT Function - End If - l2 = InStr(num(2), ",") - If l2 Then - Select Case OName(p) 'only certain commands should pass a comma value - Case "C_RG", "C_RA", "_RGB", "_RGBA", "_RED", "_GREEN", "C_BL", "_ALPHA" - Case Else - C$ = Mid$(num(2), l2) - num(2) = Left$(num(2), l2 - 1) - End Select - End If + IF INSTR(num(1), ",") THEN + EvaluateNumbers$ = "ERROR - Invalid comma (" + num(1) + ")": EXIT FUNCTION + END IF + l2 = INSTR(num(2), ",") + IF l2 THEN + SELECT CASE OName(p) 'only certain commands should pass a comma value + CASE "C_RG", "C_RA", "_RGB", "_RGBA", "_RED", "_GREEN", "C_BL", "_ALPHA" + CASE ELSE + C$ = MID$(num(2), l2) + num(2) = LEFT$(num(2), l2 - 1) + END SELECT + END IF - Select Case PL(p) 'divide up the work so we want do as much case checking - Case 5 'Type conversions + SELECT CASE PL(p) 'divide up the work so we want do as much case checking + CASE 5 'Type conversions 'Note, these are special cases and work with the number BEFORE the command and not after - Select Case OName(p) 'Depending on our operator.. - Case "C_UOF": n1~%& = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1~%&))) - Case "C_ULO": n1%& = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1%&))) - Case "C_UBY": n1~%% = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1~%%))) - Case "C_UIN": n1~% = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1~%))) - Case "C_BY": n1%% = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1%%))) - Case "C_IN": n1% = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1%))) - Case "C_UIF": n1~&& = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1~&&))) - Case "C_OF": n1~& = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1~&))) - Case "C_IF": n1&& = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1&&))) - Case "C_LO": n1& = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1&))) - Case "C_UBI": n1~` = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1~`))) - Case "C_BI": n1` = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1`))) - Case "C_FL": n1## = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1##))) - Case "C_DO": n1# = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1#))) - Case "C_SI": n1! = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1!))) - End Select - EXIT Function - Case 10 'functions - Select Case OName(p) 'Depending on our operator.. - Case "_PI" + SELECT CASE OName(p) 'Depending on our operator.. + CASE "C_UOF": n1~%& = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1~%&))) + CASE "C_ULO": n1%& = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1%&))) + CASE "C_UBY": n1~%% = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1~%%))) + CASE "C_UIN": n1~% = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1~%))) + CASE "C_BY": n1%% = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1%%))) + CASE "C_IN": n1% = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1%))) + CASE "C_UIF": n1~&& = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1~&&))) + CASE "C_OF": n1~& = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1~&))) + CASE "C_IF": n1&& = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1&&))) + CASE "C_LO": n1& = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1&))) + CASE "C_UBI": n1~` = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1~`))) + CASE "C_BI": n1` = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1`))) + CASE "C_FL": n1## = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1##))) + CASE "C_DO": n1# = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1#))) + CASE "C_SI": n1! = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1!))) + END SELECT + EXIT FUNCTION + CASE 10 'functions + SELECT CASE OName(p) 'Depending on our operator.. + CASE "_PI" n1 = 3.14159265358979323846264338327950288## 'Future compatable in case something ever stores extra digits for PI - If num(2) <> "" Then n1 = n1 * Val(num(2)) - Case "_ACOS": n1 = _Acos(Val(num(2))) - Case "_ASIN": n1 = _Asin(Val(num(2))) - Case "_ARCSEC": n1 = _Arcsec(Val(num(2))) - Case "_ARCCSC": n1 = _Arccsc(Val(num(2))) - Case "_ARCCOT": n1 = _Arccot(Val(num(2))) - Case "_SECH": n1 = _Sech(Val(num(2))) - Case "_CSCH": n1 = _Csch(Val(num(2))) - Case "_COTH": n1 = _Coth(Val(num(2))) - Case "C_RG" + IF num(2) <> "" THEN n1 = n1 * VAL(num(2)) + CASE "_ACOS": n1 = _ACOS(VAL(num(2))) + CASE "_ASIN": n1 = _ASIN(VAL(num(2))) + CASE "_ARCSEC": n1 = _ARCSEC(VAL(num(2))) + CASE "_ARCCSC": n1 = _ARCCSC(VAL(num(2))) + CASE "_ARCCOT": n1 = _ARCCOT(VAL(num(2))) + CASE "_SECH": n1 = _SECH(VAL(num(2))) + CASE "_CSCH": n1 = _CSCH(VAL(num(2))) + CASE "_COTH": n1 = _COTH(VAL(num(2))) + CASE "C_RG" n$ = num(2) - If n$ = "" Then EvaluateNumbers$ = "ERROR - Invalid null _RGB32": EXIT Function - c1 = InStr(n$, ",") - If c1 Then c2 = InStr(c1 + 1, n$, ",") - If c2 Then c3 = InStr(c2 + 1, n$, ",") - If c3 Then c4 = InStr(c3 + 1, n$, ",") - If c1 = 0 Then 'there's no comma in the command to parse. It's a grayscale value - n = Val(num(2)) + IF n$ = "" THEN EvaluateNumbers$ = "ERROR - Invalid null _RGB32": EXIT FUNCTION + c1 = INSTR(n$, ",") + IF c1 THEN c2 = INSTR(c1 + 1, n$, ",") + IF c2 THEN c3 = INSTR(c2 + 1, n$, ",") + IF c3 THEN c4 = INSTR(c3 + 1, n$, ",") + IF c1 = 0 THEN 'there's no comma in the command to parse. It's a grayscale value + n = VAL(num(2)) n1 = _RGB32(n, n, n) - ElseIf c2 = 0 Then 'there's one comma and not 2. It's grayscale with alpha. - n = Val(Left$(num(2), c1)) - n2 = Val(Mid$(num(2), c1 + 1)) + ELSEIF c2 = 0 THEN 'there's one comma and not 2. It's grayscale with alpha. + n = VAL(LEFT$(num(2), c1)) + n2 = VAL(MID$(num(2), c1 + 1)) n1 = _RGBA32(n, n, n, n2) - ElseIf c3 = 0 Then 'there's two commas. It's _RGB values - n = Val(Left$(num(2), c1)) - n2 = Val(Mid$(num(2), c1 + 1)) - n3 = Val(Mid$(num(2), c2 + 1)) + ELSEIF c3 = 0 THEN 'there's two commas. It's _RGB values + n = VAL(LEFT$(num(2), c1)) + n2 = VAL(MID$(num(2), c1 + 1)) + n3 = VAL(MID$(num(2), c2 + 1)) n1 = _RGB32(n, n2, n3) - ElseIf c4 = 0 Then 'there's three commas. It's _RGBA values - n = Val(Left$(num(2), c1)) - n2 = Val(Mid$(num(2), c1 + 1)) - n3 = Val(Mid$(num(2), c2 + 1)) - n4 = Val(Mid$(num(2), c3 + 1)) + ELSEIF c4 = 0 THEN 'there's three commas. It's _RGBA values + n = VAL(LEFT$(num(2), c1)) + n2 = VAL(MID$(num(2), c1 + 1)) + n3 = VAL(MID$(num(2), c2 + 1)) + n4 = VAL(MID$(num(2), c3 + 1)) n1 = _RGBA32(n, n2, n3, n4) - Else 'we have more than three commas. I have no idea WTH type of values got passed here! - EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + ")": EXIT Function - End If - Case "C_RA" + ELSE 'we have more than three commas. I have no idea WTH type of values got passed here! + EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + ")": EXIT FUNCTION + END IF + CASE "C_RA" n$ = num(2) - If n$ = "" Then EvaluateNumbers$ = "ERROR - Invalid null _RGBA32": EXIT Function - c1 = InStr(n$, ",") - If c1 Then c2 = InStr(c1 + 1, n$, ",") - If c2 Then c3 = InStr(c2 + 1, n$, ",") - If c3 Then c4 = InStr(c3 + 1, n$, ",") - If c3 = 0 Or c4 <> 0 Then EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + ")": EXIT Function + IF n$ = "" THEN EvaluateNumbers$ = "ERROR - Invalid null _RGBA32": EXIT FUNCTION + c1 = INSTR(n$, ",") + IF c1 THEN c2 = INSTR(c1 + 1, n$, ",") + IF c2 THEN c3 = INSTR(c2 + 1, n$, ",") + IF c3 THEN c4 = INSTR(c3 + 1, n$, ",") + IF c3 = 0 OR c4 <> 0 THEN EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + ")": EXIT FUNCTION 'we have to have 3 commas; not more, not less. - n = Val(Left$(num(2), c1)) - n2 = Val(Mid$(num(2), c1 + 1)) - n3 = Val(Mid$(num(2), c2 + 1)) - n4 = Val(Mid$(num(2), c3 + 1)) + n = VAL(LEFT$(num(2), c1)) + n2 = VAL(MID$(num(2), c1 + 1)) + n3 = VAL(MID$(num(2), c2 + 1)) + n4 = VAL(MID$(num(2), c3 + 1)) n1 = _RGBA32(n, n2, n3, n4) - Case "_RGB" + CASE "_RGB" n$ = num(2) - If n$ = "" Then EvaluateNumbers$ = "ERROR - Invalid null _RGB": EXIT Function - c1 = InStr(n$, ",") - If c1 Then c2 = InStr(c1 + 1, n$, ",") - If c2 Then c3 = InStr(c2 + 1, n$, ",") - If c3 Then c4 = InStr(c3 + 1, n$, ",") - If c3 = 0 Or c4 <> 0 Then EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + "). _RGB requires 4 parameters for Red, Green, Blue, ScreenMode.": EXIT Function + IF n$ = "" THEN EvaluateNumbers$ = "ERROR - Invalid null _RGB": EXIT FUNCTION + c1 = INSTR(n$, ",") + IF c1 THEN c2 = INSTR(c1 + 1, n$, ",") + IF c2 THEN c3 = INSTR(c2 + 1, n$, ",") + IF c3 THEN c4 = INSTR(c3 + 1, n$, ",") + IF c3 = 0 OR c4 <> 0 THEN EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + "). _RGB requires 4 parameters for Red, Green, Blue, ScreenMode.": EXIT FUNCTION 'we have to have 3 commas; not more, not less. - n = Val(Left$(num(2), c1)) - n2 = Val(Mid$(num(2), c1 + 1)) - n3 = Val(Mid$(num(2), c2 + 1)) - n4 = Val(Mid$(num(2), c3 + 1)) - Select Case n4 - Case 0 TO 2, 7 TO 13, 256, 32 'these are the good screen values - Case Else - EvaluateNumbers$ = "ERROR - Invalid Screen Mode (" + Str$(n4) + ")": EXIT Function - End Select - t = _NewImage(1, 1, n4) + n = VAL(LEFT$(num(2), c1)) + n2 = VAL(MID$(num(2), c1 + 1)) + n3 = VAL(MID$(num(2), c2 + 1)) + n4 = VAL(MID$(num(2), c3 + 1)) + SELECT CASE n4 + CASE 0 TO 2, 7 TO 13, 256, 32 'these are the good screen values + CASE ELSE + EvaluateNumbers$ = "ERROR - Invalid Screen Mode (" + STR$(n4) + ")": EXIT FUNCTION + END SELECT + t = _NEWIMAGE(1, 1, n4) n1 = _RGB(n, n2, n3, t) - _FreeImage t - Case "_RGBA" + _FREEIMAGE t + CASE "_RGBA" n$ = num(2) - If n$ = "" Then EvaluateNumbers$ = "ERROR - Invalid null _RGBA": EXIT Function - c1 = InStr(n$, ",") - If c1 Then c2 = InStr(c1 + 1, n$, ",") - If c2 Then c3 = InStr(c2 + 1, n$, ",") - If c3 Then c4 = InStr(c3 + 1, n$, ",") - If c4 Then c5 = InStr(c4 + 1, n$, ",") - If c4 = 0 Or c5 <> 0 Then EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + "). _RGBA requires 5 parameters for Red, Green, Blue, Alpha, ScreenMode.": EXIT Function + IF n$ = "" THEN EvaluateNumbers$ = "ERROR - Invalid null _RGBA": EXIT FUNCTION + c1 = INSTR(n$, ",") + IF c1 THEN c2 = INSTR(c1 + 1, n$, ",") + IF c2 THEN c3 = INSTR(c2 + 1, n$, ",") + IF c3 THEN c4 = INSTR(c3 + 1, n$, ",") + IF c4 THEN c5 = INSTR(c4 + 1, n$, ",") + IF c4 = 0 OR c5 <> 0 THEN EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + "). _RGBA requires 5 parameters for Red, Green, Blue, Alpha, ScreenMode.": EXIT FUNCTION 'we have to have 4 commas; not more, not less. - n = Val(Left$(num(2), c1)) - n2 = Val(Mid$(num(2), c1 + 1)) - n3 = Val(Mid$(num(2), c2 + 1)) - n4 = Val(Mid$(num(2), c3 + 1)) - n5 = Val(Mid$(num(2), c4 + 1)) - Select Case n5 - Case 0 TO 2, 7 TO 13, 256, 32 'these are the good screen values - Case Else - EvaluateNumbers$ = "ERROR - Invalid Screen Mode (" + Str$(n5) + ")": EXIT Function - End Select - t = _NewImage(1, 1, n5) + n = VAL(LEFT$(num(2), c1)) + n2 = VAL(MID$(num(2), c1 + 1)) + n3 = VAL(MID$(num(2), c2 + 1)) + n4 = VAL(MID$(num(2), c3 + 1)) + n5 = VAL(MID$(num(2), c4 + 1)) + SELECT CASE n5 + CASE 0 TO 2, 7 TO 13, 256, 32 'these are the good screen values + CASE ELSE + EvaluateNumbers$ = "ERROR - Invalid Screen Mode (" + STR$(n5) + ")": EXIT FUNCTION + END SELECT + t = _NEWIMAGE(1, 1, n5) n1 = _RGBA(n, n2, n3, n4, t) - _FreeImage t - Case "_RED", "_GREEN", "_BLUE", "_ALPHA" + _FREEIMAGE t + CASE "_RED", "_GREEN", "_BLUE", "_ALPHA" n$ = num(2) - If n$ = "" Then EvaluateNumbers$ = "ERROR - Invalid null " + OName(p): EXIT Function - c1 = InStr(n$, ",") - If c1 = 0 Then EvaluateNumbers$ = "ERROR - " + OName(p) + " requires 2 parameters for Color, ScreenMode.": EXIT Function - If c1 Then c2 = InStr(c1 + 1, n$, ",") - If c2 Then EvaluateNumbers$ = "ERROR - " + OName(p) + " requires 2 parameters for Color, ScreenMode.": EXIT Function - n = Val(Left$(num(2), c1)) - n2 = Val(Mid$(num(2), c1 + 1)) - Select Case n2 - Case 0 TO 2, 7 TO 13, 256, 32 'these are the good screen values - Case Else - EvaluateNumbers$ = "ERROR - Invalid Screen Mode (" + Str$(n2) + ")": EXIT Function - End Select - t = _NewImage(1, 1, n4) - Select Case OName(p) - Case "_RED": n1 = _Red(n, t) - Case "_BLUE": n1 = _Blue(n, t) - Case "_GREEN": n1 = _Green(n, t) - Case "_ALPHA": n1 = _Alpha(n, t) - End Select - _FreeImage t - Case "C_RX", "C_GR", "C_BL", "C_AL" + IF n$ = "" THEN EvaluateNumbers$ = "ERROR - Invalid null " + OName(p): EXIT FUNCTION + c1 = INSTR(n$, ",") + IF c1 = 0 THEN EvaluateNumbers$ = "ERROR - " + OName(p) + " requires 2 parameters for Color, ScreenMode.": EXIT FUNCTION + IF c1 THEN c2 = INSTR(c1 + 1, n$, ",") + IF c2 THEN EvaluateNumbers$ = "ERROR - " + OName(p) + " requires 2 parameters for Color, ScreenMode.": EXIT FUNCTION + n = VAL(LEFT$(num(2), c1)) + n2 = VAL(MID$(num(2), c1 + 1)) + SELECT CASE n2 + CASE 0 TO 2, 7 TO 13, 256, 32 'these are the good screen values + CASE ELSE + EvaluateNumbers$ = "ERROR - Invalid Screen Mode (" + STR$(n2) + ")": EXIT FUNCTION + END SELECT + t = _NEWIMAGE(1, 1, n4) + SELECT CASE OName(p) + CASE "_RED": n1 = _RED(n, t) + CASE "_BLUE": n1 = _BLUE(n, t) + CASE "_GREEN": n1 = _GREEN(n, t) + CASE "_ALPHA": n1 = _ALPHA(n, t) + END SELECT + _FREEIMAGE t + CASE "C_RX", "C_GR", "C_BL", "C_AL" n$ = num(2) - If n$ = "" Then EvaluateNumbers$ = "ERROR - Invalid null " + OName(p): EXIT Function - n = Val(num(2)) - Select Case OName(p) - Case "C_RX": n1 = _Red32(n) - Case "C_BL": n1 = _Blue32(n) - Case "C_GR": n1 = _Green32(n) - Case "C_AL": n1 = _Alpha32(n) - End Select - Case "COS": n1 = Cos(Val(num(2))) - Case "SIN": n1 = Sin(Val(num(2))) - Case "TAN": n1 = Tan(Val(num(2))) - Case "LOG": n1 = Log(Val(num(2))) - Case "EXP": n1 = Exp(Val(num(2))) - Case "ATN": n1 = Atn(Val(num(2))) - Case "_D2R": n1 = 0.0174532925 * (Val(num(2))) - Case "_D2G": n1 = 1.1111111111 * (Val(num(2))) - Case "_R2D": n1 = 57.2957795 * (Val(num(2))) - Case "_R2G": n1 = 0.015707963 * (Val(num(2))) - Case "_G2D": n1 = 0.9 * (Val(num(2))) - Case "_G2R": n1 = 63.661977237 * (Val(num(2))) - Case "ABS": n1 = Abs(Val(num(2))) - Case "SGN": n1 = Sgn(Val(num(2))) - Case "INT": n1 = Int(Val(num(2))) - Case "_ROUND": n1 = _Round(Val(num(2))) - Case "_CEIL": n1 = _Ceil(Val(num(2))) - Case "FIX": n1 = Fix(Val(num(2))) - Case "_SEC": n1 = _Sec(Val(num(2))) - Case "_CSC": n1 = _Csc(Val(num(2))) - Case "_COT": n1 = _Cot(Val(num(2))) - End Select - Case 20 TO 60 'Math Operators - Select Case OName(p) 'Depending on our operator.. - Case "^": n1 = Val(num(1)) ^ Val(num(2)) - Case "SQR": n1 = Sqr(Val(num(2))) - Case "ROOT" - n1 = Val(num(1)): n2 = Val(num(2)) - If n2 = 1 Then EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1))): EXIT Function - If n1 < 0 And n2 >= 1 Then sign = -1: n1 = -n1 Else sign = 1 + IF n$ = "" THEN EvaluateNumbers$ = "ERROR - Invalid null " + OName(p): EXIT FUNCTION + n = VAL(num(2)) + SELECT CASE OName(p) + CASE "C_RX": n1 = _RED32(n) + CASE "C_BL": n1 = _BLUE32(n) + CASE "C_GR": n1 = _GREEN32(n) + CASE "C_AL": n1 = _ALPHA32(n) + END SELECT + CASE "COS": n1 = COS(VAL(num(2))) + CASE "SIN": n1 = SIN(VAL(num(2))) + CASE "TAN": n1 = TAN(VAL(num(2))) + CASE "LOG": n1 = LOG(VAL(num(2))) + CASE "EXP": n1 = EXP(VAL(num(2))) + CASE "ATN": n1 = ATN(VAL(num(2))) + CASE "_D2R": n1 = 0.0174532925 * (VAL(num(2))) + CASE "_D2G": n1 = 1.1111111111 * (VAL(num(2))) + CASE "_R2D": n1 = 57.2957795 * (VAL(num(2))) + CASE "_R2G": n1 = 0.015707963 * (VAL(num(2))) + CASE "_G2D": n1 = 0.9 * (VAL(num(2))) + CASE "_G2R": n1 = 63.661977237 * (VAL(num(2))) + CASE "ABS": n1 = ABS(VAL(num(2))) + CASE "SGN": n1 = SGN(VAL(num(2))) + CASE "INT": n1 = INT(VAL(num(2))) + CASE "_ROUND": n1 = _ROUND(VAL(num(2))) + CASE "_CEIL": n1 = _CEIL(VAL(num(2))) + CASE "FIX": n1 = FIX(VAL(num(2))) + CASE "_SEC": n1 = _SEC(VAL(num(2))) + CASE "_CSC": n1 = _CSC(VAL(num(2))) + CASE "_COT": n1 = _COT(VAL(num(2))) + END SELECT + CASE 20 TO 60 'Math Operators + SELECT CASE OName(p) 'Depending on our operator.. + CASE "^": n1 = VAL(num(1)) ^ VAL(num(2)) + CASE "SQR": n1 = SQR(VAL(num(2))) + CASE "ROOT" + n1 = VAL(num(1)): n2 = VAL(num(2)) + IF n2 = 1 THEN EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1))): EXIT FUNCTION + IF n1 < 0 AND n2 >= 1 THEN sign = -1: n1 = -n1 ELSE sign = 1 n3 = 1## / n2 - If n3 <> Int(n3) And n2 < 1 Then sign = Sgn(n1): n1 = Abs(n1) + IF n3 <> INT(n3) AND n2 < 1 THEN sign = SGN(n1): n1 = ABS(n1) n1 = sign * (n1 ^ n3) - Case "*": n1 = Val(num(1)) * Val(num(2)) - Case "/" - If Val(num(2)) <> 0 Then - n1 = Val(num(1)) / Val(num(2)) - Else + CASE "*": n1 = VAL(num(1)) * VAL(num(2)) + CASE "/" + IF VAL(num(2)) <> 0 THEN + n1 = VAL(num(1)) / VAL(num(2)) + ELSE EvaluateNumbers$ = "ERROR - Division By Zero" - EXIT Function - End If - Case "\" - If Val(num(2)) <> 0 Then - n1 = Val(num(1)) \ Val(num(2)) - Else + EXIT FUNCTION + END IF + CASE "\" + IF VAL(num(2)) <> 0 THEN + n1 = VAL(num(1)) \ VAL(num(2)) + ELSE EvaluateNumbers$ = "ERROR - Division By Zero" - EXIT Function - End If - Case "MOD" - If Val(num(2)) <> 0 Then - n1 = Val(num(1)) Mod Val(num(2)) - Else + EXIT FUNCTION + END IF + CASE "MOD" + IF VAL(num(2)) <> 0 THEN + n1 = VAL(num(1)) MOD VAL(num(2)) + ELSE EvaluateNumbers$ = "ERROR - Division By Zero" - EXIT Function - End If - Case "+": n1 = Val(num(1)) + Val(num(2)) - Case "-": - n1 = Val(num(1)) - Val(num(2)) - End Select - Case 70 'Relational Operators =, >, <, <>, <=, >= - Select Case OName(p) 'Depending on our operator.. - Case "=": n1 = Val(num(1)) = Val(num(2)) - Case ">": n1 = Val(num(1)) > Val(num(2)) - Case "<": n1 = Val(num(1)) < Val(num(2)) - Case "<>", "><": n1 = Val(num(1)) <> Val(num(2)) - Case "<=", "=<": n1 = Val(num(1)) <= Val(num(2)) - Case ">=", "=>": n1 = Val(num(1)) >= Val(num(2)) - End Select - Case Else 'a value we haven't processed elsewhere - Select Case OName(p) 'Depending on our operator.. - Case "NOT": n1 = Not Val(num(2)) - Case "AND": n1 = Val(num(1)) And Val(num(2)) - Case "OR": n1 = Val(num(1)) Or Val(num(2)) - Case "XOR": n1 = Val(num(1)) Xor Val(num(2)) - Case "EQV": n1 = Val(num(1)) Eqv Val(num(2)) - Case "IMP": n1 = Val(num(1)) Imp Val(num(2)) - End Select - End Select + EXIT FUNCTION + END IF + CASE "+": n1 = VAL(num(1)) + VAL(num(2)) + CASE "-": + n1 = VAL(num(1)) - VAL(num(2)) + END SELECT + CASE 70 'Relational Operators =, >, <, <>, <=, >= + SELECT CASE OName(p) 'Depending on our operator.. + CASE "=": n1 = VAL(num(1)) = VAL(num(2)) + CASE ">": n1 = VAL(num(1)) > VAL(num(2)) + CASE "<": n1 = VAL(num(1)) < VAL(num(2)) + CASE "<>", "><": n1 = VAL(num(1)) <> VAL(num(2)) + CASE "<=", "=<": n1 = VAL(num(1)) <= VAL(num(2)) + CASE ">=", "=>": n1 = VAL(num(1)) >= VAL(num(2)) + END SELECT + CASE ELSE 'a value we haven't processed elsewhere + SELECT CASE OName(p) 'Depending on our operator.. + CASE "NOT": n1 = NOT VAL(num(2)) + CASE "AND": n1 = VAL(num(1)) AND VAL(num(2)) + CASE "OR": n1 = VAL(num(1)) OR VAL(num(2)) + CASE "XOR": n1 = VAL(num(1)) XOR VAL(num(2)) + CASE "EQV": n1 = VAL(num(1)) EQV VAL(num(2)) + CASE "IMP": n1 = VAL(num(1)) IMP VAL(num(2)) + END SELECT + END SELECT - EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1))) + C$ -End Function + EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1))) + C$ +END FUNCTION -Function DWD$ (exp$) 'Deal With Duplicates +FUNCTION DWD$ (exp$) 'Deal With Duplicates 'To deal with duplicate operators in our code. 'Such as -- becomes a + '++ becomes a + '+- becomes a - '-+ becomes a - t$ = exp$ - Do + DO bad = 0 - Do - l = InStr(t$, "++") - If l Then t$ = Left$(t$, l - 1) + "+" + Mid$(t$, l + 2): bad = -1 - Loop Until l = 0 - Do - l = InStr(t$, "+-") - If l Then t$ = Left$(t$, l - 1) + "-" + Mid$(t$, l + 2): bad = -1 - Loop Until l = 0 - Do - l = InStr(t$, "-+") - If l Then t$ = Left$(t$, l - 1) + "-" + Mid$(t$, l + 2): bad = -1 - Loop Until l = 0 - Do - l = InStr(t$, "--") - If l Then t$ = Left$(t$, l - 1) + "+" + Mid$(t$, l + 2): bad = -1 - Loop Until l = 0 - Loop Until Not bad + DO + l = INSTR(t$, "++") + IF l THEN t$ = LEFT$(t$, l - 1) + "+" + MID$(t$, l + 2): bad = -1 + LOOP UNTIL l = 0 + DO + l = INSTR(t$, "+-") + IF l THEN t$ = LEFT$(t$, l - 1) + "-" + MID$(t$, l + 2): bad = -1 + LOOP UNTIL l = 0 + DO + l = INSTR(t$, "-+") + IF l THEN t$ = LEFT$(t$, l - 1) + "-" + MID$(t$, l + 2): bad = -1 + LOOP UNTIL l = 0 + DO + l = INSTR(t$, "--") + IF l THEN t$ = LEFT$(t$, l - 1) + "+" + MID$(t$, l + 2): bad = -1 + LOOP UNTIL l = 0 + LOOP UNTIL NOT bad DWD$ = t$ -End Function +END FUNCTION -Sub PreParse (e$) - Dim f As _Float - Static TotalPrefixedPP_TypeMod As Long, TotalPP_TypeMod As Long +SUB PreParse (e$) + DIM f AS _FLOAT + STATIC TotalPrefixedPP_TypeMod AS LONG, TotalPP_TypeMod AS LONG - If PP_TypeMod(0) = "" Then - ReDim PP_TypeMod(100) As String, PP_ConvertedMod(100) As String 'Large enough to hold all values to begin with + IF PP_TypeMod(0) = "" THEN + REDIM PP_TypeMod(100) AS STRING, PP_ConvertedMod(100) AS STRING 'Large enough to hold all values to begin with PP_TypeMod(0) = "Initialized" 'Set so we don't do this section over and over, as we keep the values in shared memory. 'and the below is a conversion list so symbols don't get cross confused. i = i + 1: PP_TypeMod(i) = "~`": PP_ConvertedMod(i) = "C_UBI" 'unsigned bit @@ -24372,636 +24372,636 @@ Sub PreParse (e$) i = i + 1: PP_TypeMod(i) = "BLUE32": PP_ConvertedMod(i) = "C_BL" 'blue32 i = i + 1: PP_TypeMod(i) = "ALPHA32": PP_ConvertedMod(i) = "C_AL" 'alpha32 TotalPP_TypeMod = i - ReDim _Preserve PP_TypeMod(i) As String, PP_ConvertedMod(i) As String 'And then resized to just contain the necessary space in memory - End If + REDIM _PRESERVE PP_TypeMod(i) AS STRING, PP_ConvertedMod(i) AS STRING 'And then resized to just contain the necessary space in memory + END IF t$ = e$ 'First strip all spaces t$ = "" - For i = 1 To Len(e$) - If Mid$(e$, i, 1) <> " " Then t$ = t$ + Mid$(e$, i, 1) - Next + FOR i = 1 TO LEN(e$) + IF MID$(e$, i, 1) <> " " THEN t$ = t$ + MID$(e$, i, 1) + NEXT - t$ = UCase$(t$) - If t$ = "" Then e$ = "ERROR -- NULL string; nothing to evaluate": EXIT Sub + t$ = UCASE$(t$) + IF t$ = "" THEN e$ = "ERROR -- NULL string; nothing to evaluate": EXIT SUB 'ERROR CHECK by counting our brackets l = 0 - Do - l = InStr(l + 1, t$, "("): If l Then c = c + 1 - Loop Until l = 0 + DO + l = INSTR(l + 1, t$, "("): IF l THEN c = c + 1 + LOOP UNTIL l = 0 l = 0 - Do - l = InStr(l + 1, t$, ")"): If l Then c1 = c1 + 1 - Loop Until l = 0 - If c <> c1 Then e$ = "ERROR -- Bad Parenthesis:" + Str$(c) + "( vs" + Str$(c1) + ")": EXIT Sub + DO + l = INSTR(l + 1, t$, ")"): IF l THEN c1 = c1 + 1 + LOOP UNTIL l = 0 + IF c <> c1 THEN e$ = "ERROR -- Bad Parenthesis:" + STR$(c) + "( vs" + STR$(c1) + ")": EXIT SUB 'Modify so that NOT will process properly l = 0 - Do - l = InStr(l + 1, t$, "NOT") - If l Then + DO + l = INSTR(l + 1, t$, "NOT") + IF l THEN 'We need to work magic on the statement so it looks pretty. ' 1 + NOT 2 + 1 is actually processed as 1 + (NOT 2 + 1) 'Look for something not proper - l1 = InStr(l + 1, t$, "AND") - If l1 = 0 Or (InStr(l + 1, t$, "OR") > 0 And InStr(l + 1, t$, "OR") < l1) Then l1 = InStr(l + 1, t$, "OR") - If l1 = 0 Or (InStr(l + 1, t$, "XOR") > 0 And InStr(l + 1, t$, "XOR") < l1) Then l1 = InStr(l + 1, t$, "XOR") - If l1 = 0 Or (InStr(l + 1, t$, "EQV") > 0 And InStr(l + 1, t$, "EQV") < l1) Then l1 = InStr(l + 1, t$, "EQV") - If l1 = 0 Or (InStr(l + 1, t$, "IMP") > 0 And InStr(l + 1, t$, "IMP") < l1) Then l1 = InStr(l + 1, t$, "IMP") - If l1 = 0 Then l1 = Len(t$) + 1 - t$ = Left$(t$, l - 1) + "(" + Mid$(t$, l, l1 - l) + ")" + Mid$(t$, l + l1 - l) + l1 = INSTR(l + 1, t$, "AND") + IF l1 = 0 OR (INSTR(l + 1, t$, "OR") > 0 AND INSTR(l + 1, t$, "OR") < l1) THEN l1 = INSTR(l + 1, t$, "OR") + IF l1 = 0 OR (INSTR(l + 1, t$, "XOR") > 0 AND INSTR(l + 1, t$, "XOR") < l1) THEN l1 = INSTR(l + 1, t$, "XOR") + IF l1 = 0 OR (INSTR(l + 1, t$, "EQV") > 0 AND INSTR(l + 1, t$, "EQV") < l1) THEN l1 = INSTR(l + 1, t$, "EQV") + IF l1 = 0 OR (INSTR(l + 1, t$, "IMP") > 0 AND INSTR(l + 1, t$, "IMP") < l1) THEN l1 = INSTR(l + 1, t$, "IMP") + IF l1 = 0 THEN l1 = LEN(t$) + 1 + t$ = LEFT$(t$, l - 1) + "(" + MID$(t$, l, l1 - l) + ")" + MID$(t$, l + l1 - l) l = l + 3 'PRINT t$ - End If - Loop Until l = 0 + END IF + LOOP UNTIL l = 0 'replace existing CONST values sep$ = "()+-*/\><=^" - For i2 = 0 To constlast + FOR i2 = 0 TO constlast thisConstName$ = constname(i2) - For replaceConstPass = 1 To 2 + FOR replaceConstPass = 1 TO 2 found = 0 - Do - found = InStr(found + 1, UCase$(t$), thisConstName$) - If found Then - If found > 1 Then - If InStr(sep$, Mid$(t$, found - 1, 1)) = 0 Then _Continue - End If - If found + Len(thisConstName$) <= Len(t$) Then - If InStr(sep$, Mid$(t$, found + Len(thisConstName$), 1)) = 0 Then _Continue - End If + DO + found = INSTR(found + 1, UCASE$(t$), thisConstName$) + IF found THEN + IF found > 1 THEN + IF INSTR(sep$, MID$(t$, found - 1, 1)) = 0 THEN _CONTINUE + END IF + IF found + LEN(thisConstName$) <= LEN(t$) THEN + IF INSTR(sep$, MID$(t$, found + LEN(thisConstName$), 1)) = 0 THEN _CONTINUE + END IF t = consttype(i2) - If t And ISSTRING Then + IF t AND ISSTRING THEN r$ = conststring(i2) - i4 = _InStrRev(r$, ",") - r$ = Left$(r$, i4 - 1) - Else - If t And ISFLOAT Then - r$ = Str$(constfloat(i2)) + i4 = _INSTRREV(r$, ",") + r$ = LEFT$(r$, i4 - 1) + ELSE + IF t AND ISFLOAT THEN + r$ = STR$(constfloat(i2)) r$ = N2S(r$) - Else - If t And ISUNSIGNED Then r$ = Str$(constuinteger(i2)) Else r$ = Str$(constinteger(i2)) - End If - End If - t$ = Left$(t$, found - 1) + _Trim$(r$) + Mid$(t$, found + Len(thisConstName$)) - End If - Loop Until found = 0 + ELSE + IF t AND ISUNSIGNED THEN r$ = STR$(constuinteger(i2)) ELSE r$ = STR$(constinteger(i2)) + END IF + END IF + t$ = LEFT$(t$, found - 1) + _TRIM$(r$) + MID$(t$, found + LEN(thisConstName$)) + END IF + LOOP UNTIL found = 0 thisConstName$ = constname(i2) + constnamesymbol(i2) - Next - Next + NEXT + NEXT uboundPP_TypeMod = TotalPrefixedPP_TypeMod - If qb64prefix_set = 1 Then uboundPP_TypeMod = TotalPP_TypeMod - For j = 1 To uboundPP_TypeMod + IF qb64prefix_set = 1 THEN uboundPP_TypeMod = TotalPP_TypeMod + FOR j = 1 TO uboundPP_TypeMod l = 0 - Do - l = InStr(l + 1, t$, PP_TypeMod(j)) - If l = 0 Then Exit Do - i = 0: l1 = 0: l2 = 0: lo = Len(PP_TypeMod(j)) - Do - If PL(i) > 10 Then - l2 = _InStrRev(l, t$, OName$(i)) - If l2 > 0 And l2 > l1 Then l1 = l2 - End If + DO + l = INSTR(l + 1, t$, PP_TypeMod(j)) + IF l = 0 THEN EXIT DO + i = 0: l1 = 0: l2 = 0: lo = LEN(PP_TypeMod(j)) + DO + IF PL(i) > 10 THEN + l2 = _INSTRREV(l, t$, OName$(i)) + IF l2 > 0 AND l2 > l1 THEN l1 = l2 + END IF i = i + lo - Loop Until i > UBound(PL) - l$ = Left$(t$, l1) - m$ = Mid$(t$, l1 + 1, l - l1 - 1) - r$ = PP_ConvertedMod(j) + Mid$(t$, l + lo) - If j > 15 Then + LOOP UNTIL i > UBOUND(PL) + l$ = LEFT$(t$, l1) + m$ = MID$(t$, l1 + 1, l - l1 - 1) + r$ = PP_ConvertedMod(j) + MID$(t$, l + lo) + IF j > 15 THEN t$ = l$ + m$ + r$ 'replacement routine for commands which might get confused with others, like _RGB and _RGB32 - Else + ELSE 'the first 15 commands need to properly place the parenthesis around the value we want to convert. t$ = l$ + "(" + m$ + ")" + r$ - End If - l = l + 2 + Len(PP_TypeMod(j)) 'move forward from the length of the symbol we checked + the new "(" and ")" - Loop - Next + END IF + l = l + 2 + LEN(PP_TypeMod(j)) 'move forward from the length of the symbol we checked + the new "(" and ")" + LOOP + NEXT 'Check for bad operators before a ( bracket l = 0 - Do - l = InStr(l + 1, t$, "(") - If l > 0 And l > 2 Then 'Don't check the starting bracket; there's nothing before it. + DO + l = INSTR(l + 1, t$, "(") + IF l > 0 AND l > 2 THEN 'Don't check the starting bracket; there's nothing before it. good = 0 - For i = 1 To UBound(OName) - m$ = Mid$(t$, l - Len(OName(i)), Len(OName(i))) - If m$ = OName(i) Then - good = -1: Exit For 'We found an operator after our ), and it's not a CONST (like PI) - Else - If Left$(OName(i), 1) = "_" And qb64prefix_set = 1 Then + FOR i = 1 TO UBOUND(OName) + m$ = MID$(t$, l - LEN(OName(i)), LEN(OName(i))) + IF m$ = OName(i) THEN + good = -1: EXIT FOR 'We found an operator after our ), and it's not a CONST (like PI) + ELSE + IF LEFT$(OName(i), 1) = "_" AND qb64prefix_set = 1 THEN 'try without prefix - m$ = Mid$(t$, l - (Len(OName(i)) - 1), Len(OName(i)) - 1) - If m$ = Mid$(OName(i), 2) Then good = -1: Exit For - End If - End If - Next - If Not good Then e$ = "ERROR - Improper operations before (.": EXIT Sub + m$ = MID$(t$, l - (LEN(OName(i)) - 1), LEN(OName(i)) - 1) + IF m$ = MID$(OName(i), 2) THEN good = -1: EXIT FOR + END IF + END IF + NEXT + IF NOT good THEN e$ = "ERROR - Improper operations before (.": EXIT SUB l = l + 1 - End If - Loop Until l = 0 + END IF + LOOP UNTIL l = 0 'Check for bad operators after a ) bracket l = 0 - Do - l = InStr(l + 1, t$, ")") - If l > 0 And l < Len(t$) Then + DO + l = INSTR(l + 1, t$, ")") + IF l > 0 AND l < LEN(t$) THEN good = 0 - For i = 1 To UBound(OName) - m$ = Mid$(t$, l + 1, Len(OName(i))) - If m$ = OName(i) Then - good = -1: Exit For 'We found an operator after our ), and it's not a CONST (like PI - Else - If Left$(OName(i), 1) = "_" And qb64prefix_set = 1 Then + FOR i = 1 TO UBOUND(OName) + m$ = MID$(t$, l + 1, LEN(OName(i))) + IF m$ = OName(i) THEN + good = -1: EXIT FOR 'We found an operator after our ), and it's not a CONST (like PI + ELSE + IF LEFT$(OName(i), 1) = "_" AND qb64prefix_set = 1 THEN 'try without prefix - m$ = Mid$(t$, l + 1, Len(OName(i)) - 1) - If m$ = Mid$(OName(i), 2) Then good = -1: Exit For - End If - End If - Next - If Mid$(t$, l + 1, 1) = ")" Then good = -1 - If Not good Then e$ = "ERROR - Improper operations after ).": EXIT Sub + m$ = MID$(t$, l + 1, LEN(OName(i)) - 1) + IF m$ = MID$(OName(i), 2) THEN good = -1: EXIT FOR + END IF + END IF + NEXT + IF MID$(t$, l + 1, 1) = ")" THEN good = -1 + IF NOT good THEN e$ = "ERROR - Improper operations after ).": EXIT SUB l = l + 1 - End If - Loop Until l = 0 Or l = Len(t$) 'last symbol is a bracket + END IF + LOOP UNTIL l = 0 OR l = LEN(t$) 'last symbol is a bracket 'Turn all &H (hex) numbers into decimal values for the program to process properly l = 0 - Do - l = InStr(t$, "&H") - If l Then + DO + l = INSTR(t$, "&H") + IF l THEN E = l + 1: finished = 0 - Do + DO E = E + 1 - comp$ = Mid$(t$, E, 1) - Select Case comp$ - Case "0" TO "9", "A" TO "F" 'All is good, our next digit is a number, continue to add to the hex$ - Case Else + comp$ = MID$(t$, E, 1) + SELECT CASE comp$ + CASE "0" TO "9", "A" TO "F" 'All is good, our next digit is a number, continue to add to the hex$ + CASE ELSE good = 0 - For i = 1 To UBound(OName) - If Mid$(t$, E, Len(OName(i))) = OName(i) And PL(i) > 1 And PL(i) <= 250 Then good = -1: Exit For 'We found an operator after our ), and it's not a CONST (like PI) - Next - If Not good Then e$ = "ERROR - Improper &H value. (" + comp$ + ")": EXIT Sub + FOR i = 1 TO UBOUND(OName) + IF MID$(t$, E, LEN(OName(i))) = OName(i) AND PL(i) > 1 AND PL(i) <= 250 THEN good = -1: EXIT FOR 'We found an operator after our ), and it's not a CONST (like PI) + NEXT + IF NOT good THEN e$ = "ERROR - Improper &H value. (" + comp$ + ")": EXIT SUB E = E - 1 finished = -1 - End Select - Loop Until finished Or E = Len(t$) - t$ = Left$(t$, l - 1) + LTrim$(RTrim$(Str$(Val(Mid$(t$, l, E - l + 1))))) + Mid$(t$, E + 1) - End If - Loop Until l = 0 + END SELECT + LOOP UNTIL finished OR E = LEN(t$) + t$ = LEFT$(t$, l - 1) + LTRIM$(RTRIM$(STR$(VAL(MID$(t$, l, E - l + 1))))) + MID$(t$, E + 1) + END IF + LOOP UNTIL l = 0 'Turn all &B (binary) numbers into decimal values for the program to process properly l = 0 - Do - l = InStr(t$, "&B") - If l Then + DO + l = INSTR(t$, "&B") + IF l THEN E = l + 1: finished = 0 - Do + DO E = E + 1 - comp$ = Mid$(t$, E, 1) - Select Case comp$ - Case "0", "1" 'All is good, our next digit is a number, continue to add to the hex$ - Case Else + comp$ = MID$(t$, E, 1) + SELECT CASE comp$ + CASE "0", "1" 'All is good, our next digit is a number, continue to add to the hex$ + CASE ELSE good = 0 - For i = 1 To UBound(OName) - If Mid$(t$, E, Len(OName(i))) = OName(i) And PL(i) > 1 And PL(i) <= 250 Then good = -1: Exit For 'We found an operator after our ), and it's not a CONST (like PI) - Next - If Not good Then e$ = "ERROR - Improper &B value. (" + comp$ + ")": EXIT Sub + FOR i = 1 TO UBOUND(OName) + IF MID$(t$, E, LEN(OName(i))) = OName(i) AND PL(i) > 1 AND PL(i) <= 250 THEN good = -1: EXIT FOR 'We found an operator after our ), and it's not a CONST (like PI) + NEXT + IF NOT good THEN e$ = "ERROR - Improper &B value. (" + comp$ + ")": EXIT SUB E = E - 1 finished = -1 - End Select - Loop Until finished Or E = Len(t$) - bin$ = Mid$(t$, l + 2, E - l - 1) - For i = 1 To Len(bin$) - If Mid$(bin$, i, 1) = "1" Then f = f + 2 ^ (Len(bin$) - i) - Next - t$ = Left$(t$, l - 1) + LTrim$(RTrim$(Str$(f))) + Mid$(t$, E + 1) - End If - Loop Until l = 0 + END SELECT + LOOP UNTIL finished OR E = LEN(t$) + bin$ = MID$(t$, l + 2, E - l - 1) + FOR i = 1 TO LEN(bin$) + IF MID$(bin$, i, 1) = "1" THEN f = f + 2 ^ (LEN(bin$) - i) + NEXT + t$ = LEFT$(t$, l - 1) + LTRIM$(RTRIM$(STR$(f))) + MID$(t$, E + 1) + END IF + LOOP UNTIL l = 0 't$ = N2S(t$) VerifyString t$ e$ = t$ -End Sub +END SUB -Sub VerifyString (t$) +SUB VerifyString (t$) 'ERROR CHECK for unrecognized operations j = 1 - Do - comp$ = Mid$(t$, j, 1) - Select Case comp$ - Case "0" TO "9", ".", "(", ")", ",": j = j + 1 - Case Else + DO + comp$ = MID$(t$, j, 1) + SELECT CASE comp$ + CASE "0" TO "9", ".", "(", ")", ",": j = j + 1 + CASE ELSE good = 0 extrachar = 0 - For i = 1 To UBound(OName) - If Mid$(t$, j, Len(OName(i))) = OName(i) Then - good = -1: Exit For 'We found an operator after our ), and it's not a CONST (like PI) - Else - If Left$(OName(i), 1) = "_" And qb64prefix_set = 1 Then + FOR i = 1 TO UBOUND(OName) + IF MID$(t$, j, LEN(OName(i))) = OName(i) THEN + good = -1: EXIT FOR 'We found an operator after our ), and it's not a CONST (like PI) + ELSE + IF LEFT$(OName(i), 1) = "_" AND qb64prefix_set = 1 THEN 'try without prefix - If Mid$(t$, j, Len(OName(i)) - 1) = Mid$(OName(i), 2) Then - good = -1: extrachar = 1: Exit For - End If - End If - End If - Next - If Not good Then t$ = "ERROR - Bad Operational value. (" + comp$ + ")": EXIT Sub - j = j + (Len(OName(i)) - extrachar) - End Select - Loop Until j > Len(t$) -End Sub + IF MID$(t$, j, LEN(OName(i)) - 1) = MID$(OName(i), 2) THEN + good = -1: extrachar = 1: EXIT FOR + END IF + END IF + END IF + NEXT + IF NOT good THEN t$ = "ERROR - Bad Operational value. (" + comp$ + ")": EXIT SUB + j = j + (LEN(OName(i)) - extrachar) + END SELECT + LOOP UNTIL j > LEN(t$) +END SUB -Function N2S$ (exp$) 'scientific Notation to String +FUNCTION N2S$ (exp$) 'scientific Notation to String - t$ = LTrim$(RTrim$(exp$)) - If Left$(t$, 1) = "-" Or Left$(t$, 1) = "N" Then sign$ = "-": t$ = Mid$(t$, 2) + t$ = LTRIM$(RTRIM$(exp$)) + IF LEFT$(t$, 1) = "-" OR LEFT$(t$, 1) = "N" THEN sign$ = "-": t$ = MID$(t$, 2) - dp = InStr(t$, "D+"): dm = InStr(t$, "D-") - ep = InStr(t$, "E+"): em = InStr(t$, "E-") - check1 = Sgn(dp) + Sgn(dm) + Sgn(ep) + Sgn(em) - If check1 < 1 Or check1 > 1 Then N2S = exp$: EXIT Function 'If no scientic notation is found, or if we find more than 1 type, it's not SN! + dp = INSTR(t$, "D+"): dm = INSTR(t$, "D-") + ep = INSTR(t$, "E+"): em = INSTR(t$, "E-") + check1 = SGN(dp) + SGN(dm) + SGN(ep) + SGN(em) + IF check1 < 1 OR check1 > 1 THEN N2S = exp$: EXIT FUNCTION 'If no scientic notation is found, or if we find more than 1 type, it's not SN! - Select Case l 'l now tells us where the SN starts at. - Case Is < dp: l = dp - Case Is < dm: l = dm - Case Is < ep: l = ep - Case Is < em: l = em - End Select + SELECT CASE l 'l now tells us where the SN starts at. + CASE IS < dp: l = dp + CASE IS < dm: l = dm + CASE IS < ep: l = ep + CASE IS < em: l = em + END SELECT - l$ = Left$(t$, l - 1) 'The left of the SN - r$ = Mid$(t$, l + 1): r&& = Val(r$) 'The right of the SN, turned into a workable long + l$ = LEFT$(t$, l - 1) 'The left of the SN + r$ = MID$(t$, l + 1): r&& = VAL(r$) 'The right of the SN, turned into a workable long - If InStr(l$, ".") Then 'Location of the decimal, if any - If r&& > 0 Then - r&& = r&& - Len(l$) + 2 - Else + IF INSTR(l$, ".") THEN 'Location of the decimal, if any + IF r&& > 0 THEN + r&& = r&& - LEN(l$) + 2 + ELSE r&& = r&& + 1 - End If - l$ = Left$(l$, 1) + Mid$(l$, 3) - End If + END IF + l$ = LEFT$(l$, 1) + MID$(l$, 3) + END IF - Select Case r&& - Case 0 'what the heck? We solved it already? + SELECT CASE r&& + CASE 0 'what the heck? We solved it already? 'l$ = l$ - Case Is < 0 - For i = 1 To -r&& + CASE IS < 0 + FOR i = 1 TO -r&& l$ = "0" + l$ - Next + NEXT l$ = "0." + l$ - Case Else - For i = 1 To r&& + CASE ELSE + FOR i = 1 TO r&& l$ = l$ + "0" - Next - End Select + NEXT + END SELECT N2S$ = sign$ + l$ -End Function +END FUNCTION -Function QuotedFilename$ (f$) +FUNCTION QuotedFilename$ (f$) - If os$ = "WIN" Then - QuotedFilename$ = Chr$(34) + f$ + Chr$(34) - EXIT Function - End If + IF os$ = "WIN" THEN + QuotedFilename$ = CHR$(34) + f$ + CHR$(34) + EXIT FUNCTION + END IF - If os$ = "LNX" Then + IF os$ = "LNX" THEN QuotedFilename$ = "'" + f$ + "'" - EXIT Function - End If + EXIT FUNCTION + END IF -End Function +END FUNCTION -Function HashValue& (a$) 'returns the hash table value of a string +FUNCTION HashValue& (a$) 'returns the hash table value of a string '[5(first)][5(second)][5(last)][5(2nd-last)][3(length AND 7)][1(first char is underscore)] - l = Len(a$) - If l = 0 Then EXIT Function 'an (invalid) NULL string equates to 0 - a = Asc(a$) - If a <> 95 Then 'does not begin with underscore - Select Case l - Case 1 + l = LEN(a$) + IF l = 0 THEN EXIT FUNCTION 'an (invalid) NULL string equates to 0 + a = ASC(a$) + IF a <> 95 THEN 'does not begin with underscore + SELECT CASE l + CASE 1 HashValue& = hash1char(a) + 1048576 - EXIT Function - Case 2 + EXIT FUNCTION + CASE 2 HashValue& = hash2char(CVI(a$)) + 2097152 - EXIT Function - Case 3 - HashValue& = hash2char(CVI(a$)) + hash1char(Asc(a$, 3)) * 1024 + 3145728 - EXIT Function - Case Else - HashValue& = hash2char(CVI(a$)) + hash2char(Asc(a$, l) + Asc(a$, l - 1) * 256) * 1024 + (l And 7) * 1048576 - EXIT Function - End Select - Else 'does begin with underscore - Select Case l - Case 1 - HashValue& = (1048576 + 8388608): EXIT Function 'note: underscore only is illegal in QB64 but supported by hash - Case 2 - HashValue& = hash1char(Asc(a$, 2)) + (2097152 + 8388608) - EXIT Function - Case 3 - HashValue& = hash2char(Asc(a$, 2) + Asc(a$, 3) * 256) + (3145728 + 8388608) - EXIT Function - Case 4 - HashValue& = hash2char((CVL(a$) And &HFFFF00) \ 256) + hash1char(Asc(a$, 4)) * 1024 + (4194304 + 8388608) - EXIT Function - Case Else - HashValue& = hash2char((CVL(a$) And &HFFFF00) \ 256) + hash2char(Asc(a$, l) + Asc(a$, l - 1) * 256) * 1024 + (l And 7) * 1048576 + 8388608 - EXIT Function - End Select - End If -End Function + EXIT FUNCTION + CASE 3 + HashValue& = hash2char(CVI(a$)) + hash1char(ASC(a$, 3)) * 1024 + 3145728 + EXIT FUNCTION + CASE ELSE + HashValue& = hash2char(CVI(a$)) + hash2char(ASC(a$, l) + ASC(a$, l - 1) * 256) * 1024 + (l AND 7) * 1048576 + EXIT FUNCTION + END SELECT + ELSE 'does begin with underscore + SELECT CASE l + CASE 1 + HashValue& = (1048576 + 8388608): EXIT FUNCTION 'note: underscore only is illegal in QB64 but supported by hash + CASE 2 + HashValue& = hash1char(ASC(a$, 2)) + (2097152 + 8388608) + EXIT FUNCTION + CASE 3 + HashValue& = hash2char(ASC(a$, 2) + ASC(a$, 3) * 256) + (3145728 + 8388608) + EXIT FUNCTION + CASE 4 + HashValue& = hash2char((CVL(a$) AND &HFFFF00) \ 256) + hash1char(ASC(a$, 4)) * 1024 + (4194304 + 8388608) + EXIT FUNCTION + CASE ELSE + HashValue& = hash2char((CVL(a$) AND &HFFFF00) \ 256) + hash2char(ASC(a$, l) + ASC(a$, l - 1) * 256) * 1024 + (l AND 7) * 1048576 + 8388608 + EXIT FUNCTION + END SELECT + END IF +END FUNCTION -Sub HashAdd (a$, flags, reference) +SUB HashAdd (a$, flags, reference) 'find the index to use - If HashListFreeLast > 0 Then + IF HashListFreeLast > 0 THEN 'take from free list i = HashListFree(HashListFreeLast) HashListFreeLast = HashListFreeLast - 1 - Else - If HashListNext > HashListSize Then + ELSE + IF HashListNext > HashListSize THEN 'double hash list size HashListSize = HashListSize * 2 - ReDim _Preserve HashList(1 To HashListSize) As HashListItem - ReDim _Preserve HashListName(1 To HashListSize) As String * 256 - End If + REDIM _PRESERVE HashList(1 TO HashListSize) AS HashListItem + REDIM _PRESERVE HashListName(1 TO HashListSize) AS STRING * 256 + END IF i = HashListNext HashListNext = HashListNext + 1 - End If + END IF 'setup links to index x = HashValue(a$) i2 = HashTable(x) - If i2 Then + IF i2 THEN i3 = HashList(i2).LastItem HashList(i2).LastItem = i HashList(i3).NextItem = i HashList(i).PrevItem = i3 - Else + ELSE HashTable(x) = i HashList(i).PrevItem = 0 HashList(i).LastItem = i - End If + END IF HashList(i).NextItem = 0 'set common hashlist values HashList(i).Flags = flags HashList(i).Reference = reference - HashListName(i) = UCase$(a$) + HashListName(i) = UCASE$(a$) -End Sub +END SUB -Function HashFind (a$, searchflags, resultflags, resultreference) +FUNCTION HashFind (a$, searchflags, resultflags, resultreference) '(0,1,2)z=hashfind[rev]("RUMI",Hashflag_label,resflag,resref) '0=doesn't exist '1=found, no more items to scan '2=found, more items still to scan i = HashTable(HashValue(a$)) - If i Then - ua$ = UCase$(a$) + Space$(256 - Len(a$)) + IF i THEN + ua$ = UCASE$(a$) + SPACE$(256 - LEN(a$)) hashfind_next: f = HashList(i).Flags - If searchflags And f Then 'flags in common - If HashListName(i) = ua$ Then + IF searchflags AND f THEN 'flags in common + IF HashListName(i) = ua$ THEN resultflags = f resultreference = HashList(i).Reference i2 = HashList(i).NextItem - If i2 Then + IF i2 THEN HashFind = 2 HashFind_NextListItem = i2 HashFind_Reverse = 0 HashFind_SearchFlags = searchflags HashFind_Name = ua$ HashRemove_LastFound = i - EXIT Function - Else + EXIT FUNCTION + ELSE HashFind = 1 HashRemove_LastFound = i - EXIT Function - End If - End If - End If + EXIT FUNCTION + END IF + END IF + END IF i = HashList(i).NextItem - If i Then GoTo hashfind_next - End If -End Function + IF i THEN GOTO hashfind_next + END IF +END FUNCTION -Function HashFindRev (a$, searchflags, resultflags, resultreference) +FUNCTION HashFindRev (a$, searchflags, resultflags, resultreference) '(0,1,2)z=hashfind[rev]("RUMI",Hashflag_label,resflag,resref) '0=doesn't exist '1=found, no more items to scan '2=found, more items still to scan i = HashTable(HashValue(a$)) - If i Then + IF i THEN i = HashList(i).LastItem - ua$ = UCase$(a$) + Space$(256 - Len(a$)) + ua$ = UCASE$(a$) + SPACE$(256 - LEN(a$)) hashfindrev_next: f = HashList(i).Flags - If searchflags And f Then 'flags in common - If HashListName(i) = ua$ Then + IF searchflags AND f THEN 'flags in common + IF HashListName(i) = ua$ THEN resultflags = f resultreference = HashList(i).Reference i2 = HashList(i).PrevItem - If i2 Then + IF i2 THEN HashFindRev = 2 HashFind_NextListItem = i2 HashFind_Reverse = 1 HashFind_SearchFlags = searchflags HashFind_Name = ua$ HashRemove_LastFound = i - EXIT Function - Else + EXIT FUNCTION + ELSE HashFindRev = 1 HashRemove_LastFound = i - EXIT Function - End If - End If - End If + EXIT FUNCTION + END IF + END IF + END IF i = HashList(i).PrevItem - If i Then GoTo hashfindrev_next - End If -End Function + IF i THEN GOTO hashfindrev_next + END IF +END FUNCTION -Function HashFindCont (resultflags, resultreference) +FUNCTION HashFindCont (resultflags, resultreference) '(0,1,2)z=hashfind[rev](resflag,resref) '0=no more items exist '1=found, no more items to scan '2=found, more items still to scan - If HashFind_Reverse Then + IF HashFind_Reverse THEN i = HashFind_NextListItem hashfindrevc_next: f = HashList(i).Flags - If HashFind_SearchFlags And f Then 'flags in common - If HashListName(i) = HashFind_Name Then + IF HashFind_SearchFlags AND f THEN 'flags in common + IF HashListName(i) = HashFind_Name THEN resultflags = f resultreference = HashList(i).Reference i2 = HashList(i).PrevItem - If i2 Then + IF i2 THEN HashFindCont = 2 HashFind_NextListItem = i2 HashRemove_LastFound = i - EXIT Function - Else + EXIT FUNCTION + ELSE HashFindCont = 1 HashRemove_LastFound = i - EXIT Function - End If - End If - End If + EXIT FUNCTION + END IF + END IF + END IF i = HashList(i).PrevItem - If i Then GoTo hashfindrevc_next - EXIT Function + IF i THEN GOTO hashfindrevc_next + EXIT FUNCTION - Else + ELSE i = HashFind_NextListItem hashfindc_next: f = HashList(i).Flags - If HashFind_SearchFlags And f Then 'flags in common - If HashListName(i) = HashFind_Name Then + IF HashFind_SearchFlags AND f THEN 'flags in common + IF HashListName(i) = HashFind_Name THEN resultflags = f resultreference = HashList(i).Reference i2 = HashList(i).NextItem - If i2 Then + IF i2 THEN HashFindCont = 2 HashFind_NextListItem = i2 HashRemove_LastFound = i - EXIT Function - Else + EXIT FUNCTION + ELSE HashFindCont = 1 HashRemove_LastFound = i - EXIT Function - End If - End If - End If + EXIT FUNCTION + END IF + END IF + END IF i = HashList(i).NextItem - If i Then GoTo hashfindc_next - EXIT Function + IF i THEN GOTO hashfindc_next + EXIT FUNCTION - End If -End Function + END IF +END FUNCTION -Sub HashRemove +SUB HashRemove i = HashRemove_LastFound 'add to free list HashListFreeLast = HashListFreeLast + 1 - If HashListFreeLast > HashListFreeSize Then + IF HashListFreeLast > HashListFreeSize THEN HashListFreeSize = HashListFreeSize * 2 - ReDim _Preserve HashListFree(1 To HashListFreeSize) As Long - End If + REDIM _PRESERVE HashListFree(1 TO HashListFreeSize) AS LONG + END IF HashListFree(HashListFreeLast) = i 'unlink i1 = HashList(i).PrevItem - If i1 Then + IF i1 THEN 'not first item in list i2 = HashList(i).NextItem - If i2 Then + IF i2 THEN '(not first and) not last item HashList(i1).NextItem = i2 HashList(i2).LastItem = i1 - Else + ELSE 'last item x = HashTable(HashValue(HashListName$(i))) HashList(x).LastItem = i1 HashList(i1).NextItem = 0 - End If - Else + END IF + ELSE 'first item in list x = HashTable(HashValue(HashListName$(i))) i2 = HashList(i).NextItem - If i2 Then + IF i2 THEN '(first item but) not last item HashTable(x) = i2 HashList(i2).PrevItem = 0 HashList(i2).LastItem = HashList(i).LastItem - Else + ELSE '(first and) last item HashTable(x) = 0 - End If - End If + END IF + END IF -End Sub +END SUB -Sub HashDump 'used for debugging purposes - fh = FreeFile - Open "hashdump.txt" For Output As #fh +SUB HashDump 'used for debugging purposes + fh = FREEFILE + OPEN "hashdump.txt" FOR OUTPUT AS #fh b$ = "12345678901234567890123456789012}" - For x = 0 To 16777215 - If HashTable(x) Then + FOR x = 0 TO 16777215 + IF HashTable(x) THEN - Print #fh, "START HashTable("; x; "):" + PRINT #fh, "START HashTable("; x; "):" i = HashTable(x) 'validate lasti = HashList(i).LastItem - If HashList(i).LastItem = 0 Or HashList(i).PrevItem <> 0 Or HashValue(HashListName(i)) <> x Then GoTo corrupt + IF HashList(i).LastItem = 0 OR HashList(i).PrevItem <> 0 OR HashValue(HashListName(i)) <> x THEN GOTO corrupt - Print #fh, " HashList("; i; ").LastItem="; HashList(i).LastItem + PRINT #fh, " HashList("; i; ").LastItem="; HashList(i).LastItem hashdumpnextitem: - x$ = " [" + Str$(i) + "]" + HashListName(i) + x$ = " [" + STR$(i) + "]" + HashListName(i) f = HashList(i).Flags - x$ = x$ + ",.Flags=" + Str$(f) + "{" - For z = 1 To 32 - Asc(b$, z) = (f And 1) + 48 + x$ = x$ + ",.Flags=" + STR$(f) + "{" + FOR z = 1 TO 32 + ASC(b$, z) = (f AND 1) + 48 f = f \ 2 - Next + NEXT x$ = x$ + b$ - x$ = x$ + ",.Reference=" + Str$(HashList(i).Reference) + x$ = x$ + ",.Reference=" + STR$(HashList(i).Reference) - Print #fh, x$ + PRINT #fh, x$ 'validate i1 = HashList(i).PrevItem i2 = HashList(i).NextItem - If i1 Then - If HashList(i1).NextItem <> i Then GoTo corrupt - End If - If i2 Then - If HashList(i2).PrevItem <> i Then GoTo corrupt - End If - If i2 = 0 Then - If lasti <> i Then GoTo corrupt - End If + IF i1 THEN + IF HashList(i1).NextItem <> i THEN GOTO corrupt + END IF + IF i2 THEN + IF HashList(i2).PrevItem <> i THEN GOTO corrupt + END IF + IF i2 = 0 THEN + IF lasti <> i THEN GOTO corrupt + END IF i = HashList(i).NextItem - If i Then GoTo hashdumpnextitem + IF i THEN GOTO hashdumpnextitem - Print #fh, "END HashTable("; x; ")" - End If - Next - Close #fh + PRINT #fh, "END HashTable("; x; ")" + END IF + NEXT + CLOSE #fh - EXIT Sub + EXIT SUB corrupt: - Print #fh, "HASH TABLE CORRUPT!" 'should never happen - Close #fh + PRINT #fh, "HASH TABLE CORRUPT!" 'should never happen + CLOSE #fh -End Sub +END SUB -Sub HashClear 'clear entire hash table +SUB HashClear 'clear entire hash table HashListSize = 65536 HashListNext = 1 HashListFreeSize = 1024 HashListFreeLast = 0 - ReDim HashList(1 To HashListSize) As HashListItem - ReDim HashListName(1 To HashListSize) As String * 256 - ReDim HashListFree(1 To HashListFreeSize) As Long - ReDim HashTable(16777215) As Long '64MB lookup table with indexes to the hashlist + REDIM HashList(1 TO HashListSize) AS HashListItem + REDIM HashListName(1 TO HashListSize) AS STRING * 256 + REDIM HashListFree(1 TO HashListFreeSize) AS LONG + REDIM HashTable(16777215) AS LONG '64MB lookup table with indexes to the hashlist HashFind_NextListItem = 0 HashFind_Reverse = 0 @@ -25009,307 +25009,307 @@ Sub HashClear 'clear entire hash table HashFind_Name = "" HashRemove_LastFound = 0 -End Sub +END SUB -Function removecast$ (a$) +FUNCTION removecast$ (a$) removecast$ = a$ - If InStr(a$, " )") Then - removecast$ = Right$(a$, Len(a$) - InStr(a$, " )") - 2) - End If -End Function + IF INSTR(a$, " )") THEN + removecast$ = RIGHT$(a$, LEN(a$) - INSTR(a$, " )") - 2) + END IF +END FUNCTION -Function converttabs$ (a2$) - If ideautoindent Then s = ideautoindentsize Else s = 4 +FUNCTION converttabs$ (a2$) + IF ideautoindent THEN s = ideautoindentsize ELSE s = 4 a$ = a2$ - Do While InStr(a$, CHR_TAB) - x = InStr(a$, CHR_TAB) - a$ = Left$(a$, x - 1) + Space$(s - ((x - 1) Mod s)) + Right$(a$, Len(a$) - x) - Loop + DO WHILE INSTR(a$, CHR_TAB) + x = INSTR(a$, CHR_TAB) + a$ = LEFT$(a$, x - 1) + SPACE$(s - ((x - 1) MOD s)) + RIGHT$(a$, LEN(a$) - x) + LOOP converttabs$ = a$ -End Function +END FUNCTION -Function NewByteElement$ +FUNCTION NewByteElement$ a$ = "byte_element_" + str2$(uniquenumber) NewByteElement$ = a$ - If use_global_byte_elements Then - Print #18, "byte_element_struct *" + a$ + "=(byte_element_struct*)malloc(12);" - Else - Print #13, "byte_element_struct *" + a$ + "=NULL;" - Print #13, "if (!" + a$ + "){" - Print #13, "if ((mem_static_pointer+=12) 40 Then - If l = 0 Then EXIT Function + IF l = 0 OR l > 40 THEN + IF l = 0 THEN EXIT FUNCTION 'Note: variable names with periods need to be obfuscated, and this affects their length - i = InStr(a$, fix046$) - Do While i - l = l - Len(fix046$) + 1 - i = InStr(i + 1, a$, fix046$) - Loop - If l > 40 Then EXIT Function - l = Len(a$) - End If + i = INSTR(a$, fix046$) + DO WHILE i + l = l - LEN(fix046$) + 1 + i = INSTR(i + 1, a$, fix046$) + LOOP + IF l > 40 THEN EXIT FUNCTION + l = LEN(a$) + END IF 'check for single, leading underscore - If l >= 2 Then - If Asc(a$, 1) = 95 And Asc(a$, 2) <> 95 Then EXIT Function - End If + IF l >= 2 THEN + IF ASC(a$, 1) = 95 AND ASC(a$, 2) <> 95 THEN EXIT FUNCTION + END IF - For i = 1 To l - a = Asc(a$, i) - If alphanumeric(a) = 0 Then EXIT Function - If isnumeric(a) Then + FOR i = 1 TO l + a = ASC(a$, i) + IF alphanumeric(a) = 0 THEN EXIT FUNCTION + IF isnumeric(a) THEN trailingunderscore = 0 - If alphabetletter = 0 Then EXIT Function - Else - If a = 95 Then + IF alphabetletter = 0 THEN EXIT FUNCTION + ELSE + IF a = 95 THEN trailingunderscore = 1 - Else + ELSE alphabetletter = 1 trailingunderscore = 0 - End If - End If - Next - If trailingunderscore Then EXIT Function + END IF + END IF + NEXT + IF trailingunderscore THEN EXIT FUNCTION validname = 1 -End Function +END FUNCTION -Function str_nth$ (x) - If x = 1 Then str_nth$ = "1st": EXIT Function - If x = 2 Then str_nth$ = "2nd": EXIT Function - If x = 3 Then str_nth$ = "3rd": EXIT Function +FUNCTION str_nth$ (x) + IF x = 1 THEN str_nth$ = "1st": EXIT FUNCTION + IF x = 2 THEN str_nth$ = "2nd": EXIT FUNCTION + IF x = 3 THEN str_nth$ = "3rd": EXIT FUNCTION str_nth$ = str2(x) + "th" -End Function +END FUNCTION -Sub Give_Error (a$) +SUB Give_Error (a$) Error_Happened = 1 Error_Message = a$ -End Sub +END SUB -Sub WriteConfigSetting (heading$, item$, tvalue$) +SUB WriteConfigSetting (heading$, item$, tvalue$) value$ = tvalue$ - Shared ConfigFile$, ConfigBak$ + SHARED ConfigFile$, ConfigBak$ - InFile = FreeFile: Open ConfigFile$ For Binary As #InFile - OutFile = FreeFile: Open ConfigBak$ For Output As #OutFile + InFile = FREEFILE: OPEN ConfigFile$ FOR BINARY AS #InFile + OutFile = FREEFILE: OPEN ConfigBak$ FOR OUTPUT AS #OutFile placed = 0 'check for quotes where needed for strings - If Right$(RTrim$(item$), 1) = "$" Then - If Left$(value$, 1) <> Chr$(34) Then value$ = Chr$(34) + value$ - If Right$(value$, 1) <> Chr$(34) Then value$ = value$ + Chr$(34) - End If + IF RIGHT$(RTRIM$(item$), 1) = "$" THEN + IF LEFT$(value$, 1) <> CHR$(34) THEN value$ = CHR$(34) + value$ + IF RIGHT$(value$, 1) <> CHR$(34) THEN value$ = value$ + CHR$(34) + END IF - If LOF(InFile) Then - Do Until EOF(InFile) - Line Input #InFile, junk$ + IF LOF(InFile) THEN + DO UNTIL EOF(InFile) + LINE INPUT #InFile, junk$ 'we really don't care about heading$ here; it's only used to make things easier for the user to locate in the config file - junk$ = LTrim$(RTrim$(junk$)) - l = InStr(junk$, "=") 'compare the values to the left of the equal sign - compare$ = RTrim$(Left$(junk$, l - 1)) + junk$ = LTRIM$(RTRIM$(junk$)) + l = INSTR(junk$, "=") 'compare the values to the left of the equal sign + compare$ = RTRIM$(LEFT$(junk$, l - 1)) - If UCase$(compare$) = UCase$(item$) Then 'if it's a match, replace it - Print #OutFile, item$; " = "; value$ + IF UCASE$(compare$) = UCASE$(item$) THEN 'if it's a match, replace it + PRINT #OutFile, item$; " = "; value$ placed = -1 - Else - Print #OutFile, junk$ 'otherwise put that line back and check the next one - End If - Loop - End If + ELSE + PRINT #OutFile, junk$ 'otherwise put that line back and check the next one + END IF + LOOP + END IF - Close #InFile, #OutFile - Kill ConfigFile$ - If Not placed Then 'we didn't find the proper setting already in the file somewhere. + CLOSE #InFile, #OutFile + KILL ConfigFile$ + IF NOT placed THEN 'we didn't find the proper setting already in the file somewhere. 'Either the file was corrupted, or the user deleted this particulat setting sometime in the past. 'Now we look to see if the heading exists in the file or not. 'If it does, then we place the new setting under that heading. 'If not then we write that heading to the end of the file to make it easier for the user to locate in the future 'and then we write it below there. - Open ConfigBak$ For Binary As #InFile - Open "internal/config.tmp" For Output As #OutFile + OPEN ConfigBak$ FOR BINARY AS #InFile + OPEN "internal/config.tmp" FOR OUTPUT AS #OutFile out$ = item$ + " = " + value$ - Do Until EOF(InFile) Or LOF(InFile) = 0 - Line Input #InFile, temp$ - Print #OutFile, temp$ - If InStr(temp$, heading$) Then Print #OutFile, out$: placed = -1 'If we have the heading, we want to print the item after it - Loop - If Not placed Then 'If the heading doesn't exist already then we'll make the heading and the item - Print #OutFile, "" - Print #OutFile, heading$ - Print #OutFile, out$ - End If - Close #InFile, #OutFile - Kill ConfigBak$ - Name "internal/config.tmp" As ConfigFile$ - Else - Name ConfigBak$ As ConfigFile$ - End If -End Sub + DO UNTIL EOF(InFile) OR LOF(InFile) = 0 + LINE INPUT #InFile, temp$ + PRINT #OutFile, temp$ + IF INSTR(temp$, heading$) THEN PRINT #OutFile, out$: placed = -1 'If we have the heading, we want to print the item after it + LOOP + IF NOT placed THEN 'If the heading doesn't exist already then we'll make the heading and the item + PRINT #OutFile, "" + PRINT #OutFile, heading$ + PRINT #OutFile, out$ + END IF + CLOSE #InFile, #OutFile + KILL ConfigBak$ + NAME "internal/config.tmp" AS ConfigFile$ + ELSE + NAME ConfigBak$ AS ConfigFile$ + END IF +END SUB -Function ReadConfigSetting (item$, value$) - Shared ConfigFile$ +FUNCTION ReadConfigSetting (item$, value$) + SHARED ConfigFile$ value$ = "" 'We start by blanking the value$ as a default return state - InFile = FreeFile: Open ConfigFile$ For Binary As #InFile + InFile = FREEFILE: OPEN ConfigFile$ FOR BINARY AS #InFile - If LOF(InFile) Then + IF LOF(InFile) THEN found = 0 - Do Until EOF(InFile) - Line Input #InFile, temp$ - temp$ = LTrim$(RTrim$(temp$)) - l = InStr(temp$, "=") - compare$ = LTrim$(RTrim$(Left$(temp$, l - 1))) - If UCase$(compare$) = UCase$(item$) Then found = -1: Exit Do - Loop - Close #InFile - If found Then 'we found what we're looking for - If l Then - value$ = Mid$(temp$, l + 1) - l = InStr(value$, Chr$(13)) 'we only want what's before a CR - If l Then value$ = Left$(value$, l) - l = InStr(value$, Chr$(10)) 'or a LineFeed + DO UNTIL EOF(InFile) + LINE INPUT #InFile, temp$ + temp$ = LTRIM$(RTRIM$(temp$)) + l = INSTR(temp$, "=") + compare$ = LTRIM$(RTRIM$(LEFT$(temp$, l - 1))) + IF UCASE$(compare$) = UCASE$(item$) THEN found = -1: EXIT DO + LOOP + CLOSE #InFile + IF found THEN 'we found what we're looking for + IF l THEN + value$ = MID$(temp$, l + 1) + l = INSTR(value$, CHR$(13)) 'we only want what's before a CR + IF l THEN value$ = LEFT$(value$, l) + l = INSTR(value$, CHR$(10)) 'or a LineFeed 'These are basic text files; they shouldn't have stray CHR$(10) or CHR$(13) characters in them! - If l Then value$ = Left$(value$, l) - value$ = LTrim$(RTrim$(value$)) + IF l THEN value$ = LEFT$(value$, l) + value$ = LTRIM$(RTRIM$(value$)) 'check for quotes where needed for strings and remove them so our return value doesn't contain them - If Right$(RTrim$(item$), 1) = "$" Then - If Left$(value$, 1) = Chr$(34) Then value$ = Mid$(value$, 2) - If Right$(value$, 1) = Chr$(34) Then value$ = Left$(value$, Len(value$) - 1) - End If + IF RIGHT$(RTRIM$(item$), 1) = "$" THEN + IF LEFT$(value$, 1) = CHR$(34) THEN value$ = MID$(value$, 2) + IF RIGHT$(value$, 1) = CHR$(34) THEN value$ = LEFT$(value$, LEN(value$) - 1) + END IF ReadConfigSetting = -1 - EXIT Function - End If - End If - End If - Close #InFile + EXIT FUNCTION + END IF + END IF + END IF + CLOSE #InFile ReadConfigSetting = 0 'failed to find the setting -End Function +END FUNCTION -Function VRGBS (text$, DefaultColor As _Unsigned Long) +FUNCTION VRGBS (text$, DefaultColor AS _UNSIGNED LONG) 'Value of RGB String = VRGBS without a ton of typing 'A function to get the RGB value back from a string such as _RGB32(255,255,255) 'text$ is the string that we send to check for a value 'DefaultColor is the value we send back if the string isn't in the proper format VRGBS = DefaultColor 'A return the default value if we can't parse the string properly - If UCase$(Left$(text$, 4)) = "_RGB" Then - rpos = InStr(text$, "(") - gpos = InStr(rpos, text$, ",") - bpos = InStr(gpos + 1, text$, ",") - If rpos <> 0 And bpos <> 0 And gpos <> 0 Then - red = Val(Mid$(text$, rpos + 1)) - green = Val(Mid$(text$, gpos + 1)) - blue = Val(Mid$(text$, bpos + 1)) + IF UCASE$(LEFT$(text$, 4)) = "_RGB" THEN + rpos = INSTR(text$, "(") + gpos = INSTR(rpos, text$, ",") + bpos = INSTR(gpos + 1, text$, ",") + IF rpos <> 0 AND bpos <> 0 AND gpos <> 0 THEN + red = VAL(MID$(text$, rpos + 1)) + green = VAL(MID$(text$, gpos + 1)) + blue = VAL(MID$(text$, bpos + 1)) VRGBS = _RGB32(red, green, blue) - End If - End If -End Function + END IF + END IF +END FUNCTION -Function EvalPreIF (text$, err$) +FUNCTION EvalPreIF (text$, err$) temp$ = text$ 'so we don't corrupt the string sent to us for evaluation err$ = "" 'null the err message to begin with 'first order of business is to solve for <>= - Dim PC_Op(3) As String + DIM PC_Op(3) AS STRING PC_Op(1) = "=" PC_Op(2) = "<" PC_Op(3) = ">" - Do + DO 'look for the existence of the first symbol if there is any firstsymbol$ = "": first = 0 - For i = 1 To UBound(PC_Op) - temp = InStr(temp$, PC_Op(i)) - If first = 0 Then first = temp: firstsymbol$ = PC_Op(i) - If temp <> 0 And temp < first Then first = temp: firstsymbol$ = PC_Op(i) - Next - If firstsymbol$ <> "" Then 'we've got = < >; let's see if we have a combination of them + FOR i = 1 TO UBOUND(PC_Op) + temp = INSTR(temp$, PC_Op(i)) + IF first = 0 THEN first = temp: firstsymbol$ = PC_Op(i) + IF temp <> 0 AND temp < first THEN first = temp: firstsymbol$ = PC_Op(i) + NEXT + IF firstsymbol$ <> "" THEN 'we've got = < >; let's see if we have a combination of them secondsymbol = 0: second = 0 - For i = first + 1 To Len(temp$) - a$ = Mid$(temp$, i, 1) - Select Case a$ - Case " " 'ignore spaces - Case "=", "<", ">" - If a$ = firstsymbol$ Then err$ = "Duplicate operator (" + a$ + ")": EXIT Function + FOR i = first + 1 TO LEN(temp$) + a$ = MID$(temp$, i, 1) + SELECT CASE a$ + CASE " " 'ignore spaces + CASE "=", "<", ">" + IF a$ = firstsymbol$ THEN err$ = "Duplicate operator (" + a$ + ")": EXIT FUNCTION second = i: secondsymbol$ = a$ - Case Else 'we found a symbol we don't recognize - Exit For - End Select - Next - End If - If first Then 'we found a symbol - l$ = RTrim$(Left$(temp$, first - 1)) - If second Then rightstart = second + 1 Else rightstart = first + 1 + CASE ELSE 'we found a symbol we don't recognize + EXIT FOR + END SELECT + NEXT + END IF + IF first THEN 'we found a symbol + l$ = RTRIM$(LEFT$(temp$, first - 1)) + IF second THEN rightstart = second + 1 ELSE rightstart = first + 1 - r$ = LTrim$(Mid$(temp$, rightstart)) - symbol$ = Mid$(temp$, first, 1) + Mid$(temp$, second, 1) + r$ = LTRIM$(MID$(temp$, rightstart)) + symbol$ = MID$(temp$, first, 1) + MID$(temp$, second, 1) 'now we check for spaces to separate this segment from any other AND/OR conditions and such - For i = Len(l$) To 1 Step -1 - If Asc(l$, i) = 32 Then Exit For - Next - leftside$ = RTrim$(Left$(temp$, i)) - l$ = LTrim$(RTrim$(Mid$(temp$, i + 1, Len(l$) - i))) - rightstop = Len(r$) - For i = 1 To Len(r$) - If Asc(r$, i) = 32 Then Exit For - Next - rightside$ = LTrim$(Mid$(r$, i + 1)) - r$ = LTrim$(RTrim$(Left$(r$, i - 1))) - If symbol$ = "=<" Then symbol$ = "<=" - If symbol$ = "=>" Then symbol$ = ">=" - If symbol$ = "><" Then symbol$ = "<>" + FOR i = LEN(l$) TO 1 STEP -1 + IF ASC(l$, i) = 32 THEN EXIT FOR + NEXT + leftside$ = RTRIM$(LEFT$(temp$, i)) + l$ = LTRIM$(RTRIM$(MID$(temp$, i + 1, LEN(l$) - i))) + rightstop = LEN(r$) + FOR i = 1 TO LEN(r$) + IF ASC(r$, i) = 32 THEN EXIT FOR + NEXT + rightside$ = LTRIM$(MID$(r$, i + 1)) + r$ = LTRIM$(RTRIM$(LEFT$(r$, i - 1))) + IF symbol$ = "=<" THEN symbol$ = "<=" + IF symbol$ = "=>" THEN symbol$ = ">=" + IF symbol$ = "><" THEN symbol$ = "<>" result$ = " 0 " - If symbol$ = "<>" Then 'check to see if we're NOT equal in any case with <> - For i = 0 To UserDefineCount - If UserDefine(0, i) = l$ And UserDefine(1, i) <> r$ Then result$ = " -1 ": GoTo finishedcheck - Next - End If - If InStr(symbol$, "=") Then 'check to see if we're equal in any case with = + IF symbol$ = "<>" THEN 'check to see if we're NOT equal in any case with <> + FOR i = 0 TO UserDefineCount + IF UserDefine(0, i) = l$ AND UserDefine(1, i) <> r$ THEN result$ = " -1 ": GOTO finishedcheck + NEXT + END IF + IF INSTR(symbol$, "=") THEN 'check to see if we're equal in any case with = UserFound = 0 - For i = 0 To UserDefineCount - If UserDefine(0, i) = l$ Then + FOR i = 0 TO UserDefineCount + IF UserDefine(0, i) = l$ THEN UserFound = -1 - If UserDefine(1, i) = r$ Then result$ = " -1 ": GoTo finishedcheck - End If - Next - If UserFound = 0 And LTrim$(RTrim$(r$)) = "UNDEFINED" Then result$ = " -1 ": GoTo finishedcheck - If UserFound = -1 And LTrim$(RTrim$(r$)) = "DEFINED" Then result$ = " -1 ": GoTo finishedcheck - End If + IF UserDefine(1, i) = r$ THEN result$ = " -1 ": GOTO finishedcheck + END IF + NEXT + IF UserFound = 0 AND LTRIM$(RTRIM$(r$)) = "UNDEFINED" THEN result$ = " -1 ": GOTO finishedcheck + IF UserFound = -1 AND LTRIM$(RTRIM$(r$)) = "DEFINED" THEN result$ = " -1 ": GOTO finishedcheck + END IF - If InStr(symbol$, ">") Then 'check to see if we're greater than in any case with > - For i = 0 To UserDefineCount - If VerifyNumber(r$) And VerifyNumber(UserDefine(1, i)) Then 'we're comparing numeric values - If UserDefine(0, i) = l$ And Val(UserDefine(1, i)) > Val(r$) Then result$ = " -1 ": GoTo finishedcheck - Else - If UserDefine(0, i) = l$ And UserDefine(1, i) > r$ Then result$ = " -1 ": GoTo finishedcheck - End If - Next - End If - If InStr(symbol$, "<") Then 'check to see if we're less than in any case with < - For i = 0 To UserDefineCount - If VerifyNumber(r$) And VerifyNumber(UserDefine(1, i)) Then 'we're comparing numeric values - If UserDefine(0, i) = l$ And Val(UserDefine(1, i)) < Val(r$) Then result$ = " -1 ": GoTo finishedcheck - Else - If UserDefine(0, i) = l$ And UserDefine(1, i) < r$ Then result$ = " -1 ": GoTo finishedcheck - End If - Next - End If + IF INSTR(symbol$, ">") THEN 'check to see if we're greater than in any case with > + FOR i = 0 TO UserDefineCount + IF VerifyNumber(r$) AND VerifyNumber(UserDefine(1, i)) THEN 'we're comparing numeric values + IF UserDefine(0, i) = l$ AND VAL(UserDefine(1, i)) > VAL(r$) THEN result$ = " -1 ": GOTO finishedcheck + ELSE + IF UserDefine(0, i) = l$ AND UserDefine(1, i) > r$ THEN result$ = " -1 ": GOTO finishedcheck + END IF + NEXT + END IF + IF INSTR(symbol$, "<") THEN 'check to see if we're less than in any case with < + FOR i = 0 TO UserDefineCount + IF VerifyNumber(r$) AND VerifyNumber(UserDefine(1, i)) THEN 'we're comparing numeric values + IF UserDefine(0, i) = l$ AND VAL(UserDefine(1, i)) < VAL(r$) THEN result$ = " -1 ": GOTO finishedcheck + ELSE + IF UserDefine(0, i) = l$ AND UserDefine(1, i) < r$ THEN result$ = " -1 ": GOTO finishedcheck + END IF + NEXT + END IF finishedcheck: temp$ = leftside$ + result$ + rightside$ - End If - Loop Until first = 0 + END IF + LOOP UNTIL first = 0 'And at this point we should now be down to a statement with nothing but AND/OR/XORS in it @@ -25317,321 +25317,321 @@ Function EvalPreIF (text$, err$) PC_Op(2) = " OR " PC_Op(3) = " XOR " - Do + DO first = 0 - For i = 1 To UBound(PC_Op) - If PC_Op(i) <> "" Then - t = InStr(temp$, PC_Op(i)) - If first <> 0 Then - If t < first And t <> 0 Then first = t: firstsymbol = i - Else + FOR i = 1 TO UBOUND(PC_Op) + IF PC_Op(i) <> "" THEN + t = INSTR(temp$, PC_Op(i)) + IF first <> 0 THEN + IF t < first AND t <> 0 THEN first = t: firstsymbol = i + ELSE first = t: firstsymbol = i - End If - End If - Next - If first = 0 Then Exit Do - leftside$ = RTrim$(Left$(temp$, first - 1)) - symbol$ = Mid$(temp$, first, Len(PC_Op(firstsymbol))) - t$ = Mid$(temp$, first + Len(PC_Op(firstsymbol))) - t = InStr(t$, " ") 'the first space we come to - If t Then - m$ = LTrim$(RTrim$(Left$(t$, t - 1))) - rightside$ = LTrim$(Mid$(t$, t)) - Else - m$ = LTrim$(Mid$(t$, t)) + END IF + END IF + NEXT + IF first = 0 THEN EXIT DO + leftside$ = RTRIM$(LEFT$(temp$, first - 1)) + symbol$ = MID$(temp$, first, LEN(PC_Op(firstsymbol))) + t$ = MID$(temp$, first + LEN(PC_Op(firstsymbol))) + t = INSTR(t$, " ") 'the first space we come to + IF t THEN + m$ = LTRIM$(RTRIM$(LEFT$(t$, t - 1))) + rightside$ = LTRIM$(MID$(t$, t)) + ELSE + m$ = LTRIM$(MID$(t$, t)) rightside$ = "" - End If + END IF leftresult = 0 - If VerifyNumber(leftside$) Then - If Val(leftside$) <> 0 Then leftresult = -1 - Else - For i = 0 To UserDefineCount - If UserDefine(0, i) = leftside$ Then - t$ = LTrim$(RTrim$(UserDefine(1, i))) - If t$ <> "0" And t$ <> "" Then leftresult = -1: Exit For - End If - Next - End If + IF VerifyNumber(leftside$) THEN + IF VAL(leftside$) <> 0 THEN leftresult = -1 + ELSE + FOR i = 0 TO UserDefineCount + IF UserDefine(0, i) = leftside$ THEN + t$ = LTRIM$(RTRIM$(UserDefine(1, i))) + IF t$ <> "0" AND t$ <> "" THEN leftresult = -1: EXIT FOR + END IF + NEXT + END IF rightresult = 0 - If VerifyNumber(m$) Then - If Val(m$) <> 0 Then rightresult = -1 - Else - For i = 0 To UserDefineCount - If UserDefine(0, i) = m$ Then - t$ = LTrim$(RTrim$(UserDefine(1, i))) - If t$ <> "0" And t$ <> "" Then rightresult = -1: Exit For - End If - Next - End If - Select Case LTrim$(RTrim$(symbol$)) - Case "AND" - If leftresult <> 0 And rightresult <> 0 Then result$ = " -1 " Else result$ = " 0 " - Case "OR" - If leftresult <> 0 Or rightresult <> 0 Then result$ = " -1 " Else result$ = " 0 " - Case "XOR" - If leftresult <> rightresult Then result$ = " -1 " Else result$ = " 0 " - End Select + IF VerifyNumber(m$) THEN + IF VAL(m$) <> 0 THEN rightresult = -1 + ELSE + FOR i = 0 TO UserDefineCount + IF UserDefine(0, i) = m$ THEN + t$ = LTRIM$(RTRIM$(UserDefine(1, i))) + IF t$ <> "0" AND t$ <> "" THEN rightresult = -1: EXIT FOR + END IF + NEXT + END IF + SELECT CASE LTRIM$(RTRIM$(symbol$)) + CASE "AND" + IF leftresult <> 0 AND rightresult <> 0 THEN result$ = " -1 " ELSE result$ = " 0 " + CASE "OR" + IF leftresult <> 0 OR rightresult <> 0 THEN result$ = " -1 " ELSE result$ = " 0 " + CASE "XOR" + IF leftresult <> rightresult THEN result$ = " -1 " ELSE result$ = " 0 " + END SELECT temp$ = result$ + rightside$ - Loop + LOOP - If VerifyNumber(temp$) Then - EvalPreIF = Val(temp$) - Else - If InStr(temp$, " ") Then err$ = "Invalid Resolution of $IF; check statements" 'If we've got more than 1 statement, it's invalid - For i = 0 To UserDefineCount - If UserDefine(0, i) = temp$ Then - t$ = LTrim$(RTrim$(UserDefine(1, i))) - If t$ <> "0" And t$ <> "" Then EvalPreIF = -1: Exit For - End If - Next - End If + IF VerifyNumber(temp$) THEN + EvalPreIF = VAL(temp$) + ELSE + IF INSTR(temp$, " ") THEN err$ = "Invalid Resolution of $IF; check statements" 'If we've got more than 1 statement, it's invalid + FOR i = 0 TO UserDefineCount + IF UserDefine(0, i) = temp$ THEN + t$ = LTRIM$(RTRIM$(UserDefine(1, i))) + IF t$ <> "0" AND t$ <> "" THEN EvalPreIF = -1: EXIT FOR + END IF + NEXT + END IF -End Function +END FUNCTION -Function VerifyNumber (text$) - t$ = LTrim$(RTrim$(text$)) - v = Val(t$) - t1$ = LTrim$(Str$(v)) - If t$ = t1$ Then VerifyNumber = -1 -End Function +FUNCTION VerifyNumber (text$) + t$ = LTRIM$(RTRIM$(text$)) + v = VAL(t$) + t1$ = LTRIM$(STR$(v)) + IF t$ = t1$ THEN VerifyNumber = -1 +END FUNCTION -Sub initialise_udt_varstrings (n$, udt, file, base_offset) - If Not udtxvariable(udt) Then EXIT Sub +SUB initialise_udt_varstrings (n$, udt, file, base_offset) + IF NOT udtxvariable(udt) THEN EXIT SUB element = udtxnext(udt) offset = 0 - Do While element - If udtetype(element) And ISSTRING Then - If (udtetype(element) And ISFIXEDLENGTH) = 0 Then - Print #file, "*(qbs**)(((char*)" + n$ + ")+" + Str$(base_offset + offset) + ") = qbs_new(0,0);" - End If - ElseIf udtetype(element) And ISUDT Then - initialise_udt_varstrings n$, udtetype(element) And 511, file, offset - End If + DO WHILE element + IF udtetype(element) AND ISSTRING THEN + IF (udtetype(element) AND ISFIXEDLENGTH) = 0 THEN + PRINT #file, "*(qbs**)(((char*)" + n$ + ")+" + STR$(base_offset + offset) + ") = qbs_new(0,0);" + END IF + ELSEIF udtetype(element) AND ISUDT THEN + initialise_udt_varstrings n$, udtetype(element) AND 511, file, offset + END IF offset = offset + udtesize(element) \ 8 element = udtenext(element) - Loop -End Sub + LOOP +END SUB -Sub free_udt_varstrings (n$, udt, file, base_offset) - If Not udtxvariable(udt) Then EXIT Sub +SUB free_udt_varstrings (n$, udt, file, base_offset) + IF NOT udtxvariable(udt) THEN EXIT SUB element = udtxnext(udt) offset = 0 - Do While element - If udtetype(element) And ISSTRING Then - If (udtetype(element) And ISFIXEDLENGTH) = 0 Then - Print #file, "qbs_free(*((qbs**)(((char*)" + n$ + ")+" + Str$(base_offset + offset) + ")));" - End If - ElseIf udtetype(element) And ISUDT Then - initialise_udt_varstrings n$, udtetype(element) And 511, file, offset - End If + DO WHILE element + IF udtetype(element) AND ISSTRING THEN + IF (udtetype(element) AND ISFIXEDLENGTH) = 0 THEN + PRINT #file, "qbs_free(*((qbs**)(((char*)" + n$ + ")+" + STR$(base_offset + offset) + ")));" + END IF + ELSEIF udtetype(element) AND ISUDT THEN + initialise_udt_varstrings n$, udtetype(element) AND 511, file, offset + END IF offset = offset + udtesize(element) \ 8 element = udtenext(element) - Loop -End Sub + LOOP +END SUB -Sub initialise_array_udt_varstrings (n$, udt, base_offset, bytesperelement$, acc$) - If Not udtxvariable(udt) Then EXIT Sub +SUB initialise_array_udt_varstrings (n$, udt, base_offset, bytesperelement$, acc$) + IF NOT udtxvariable(udt) THEN EXIT SUB offset = base_offset element = udtxnext(udt) - Do While element - If udtetype(element) And ISSTRING Then - If (udtetype(element) And ISFIXEDLENGTH) = 0 Then - acc$ = acc$ + Chr$(13) + Chr$(10) + "*(qbs**)(" + n$ + "[0]+(" + bytesperelement$ + "-1)*tmp_long+" + Str$(offset) + ")=qbs_new(0,0);" - End If - ElseIf udtetype(element) And ISUDT Then - initialise_array_udt_varstrings n$, udtetype(element) And 511, offset, bytesperelement$, acc$ - End If + DO WHILE element + IF udtetype(element) AND ISSTRING THEN + IF (udtetype(element) AND ISFIXEDLENGTH) = 0 THEN + acc$ = acc$ + CHR$(13) + CHR$(10) + "*(qbs**)(" + n$ + "[0]+(" + bytesperelement$ + "-1)*tmp_long+" + STR$(offset) + ")=qbs_new(0,0);" + END IF + ELSEIF udtetype(element) AND ISUDT THEN + initialise_array_udt_varstrings n$, udtetype(element) AND 511, offset, bytesperelement$, acc$ + END IF offset = offset + udtesize(element) \ 8 element = udtenext(element) - Loop -End Sub + LOOP +END SUB -Sub free_array_udt_varstrings (n$, udt, base_offset, bytesperelement$, acc$) - If Not udtxvariable(udt) Then EXIT Sub +SUB free_array_udt_varstrings (n$, udt, base_offset, bytesperelement$, acc$) + IF NOT udtxvariable(udt) THEN EXIT SUB offset = base_offset element = udtxnext(udt) - Do While element - If udtetype(element) And ISSTRING Then - If (udtetype(element) And ISFIXEDLENGTH) = 0 Then - acc$ = acc$ + Chr$(13) + Chr$(10) + "qbs_free(*(qbs**)(" + n$ + "[0]+(" + bytesperelement$ + "-1)*tmp_long+" + Str$(offset) + "));" - End If - ElseIf udtetype(element) And ISUDT Then - free_array_udt_varstrings n$, udtetype(element) And 511, offset, bytesperelement$, acc$ - End If + DO WHILE element + IF udtetype(element) AND ISSTRING THEN + IF (udtetype(element) AND ISFIXEDLENGTH) = 0 THEN + acc$ = acc$ + CHR$(13) + CHR$(10) + "qbs_free(*(qbs**)(" + n$ + "[0]+(" + bytesperelement$ + "-1)*tmp_long+" + STR$(offset) + "));" + END IF + ELSEIF udtetype(element) AND ISUDT THEN + free_array_udt_varstrings n$, udtetype(element) AND 511, offset, bytesperelement$, acc$ + END IF offset = offset + udtesize(element) \ 8 element = udtenext(element) - Loop -End Sub + LOOP +END SUB -Sub copy_full_udt (dst$, src$, file, base_offset, udt) - If Not udtxvariable(udt) Then - Print #file, "memcpy(" + dst$ + "+" + Str$(base_offset) + "," + src$ + "+" + Str$(base_offset) + "," + Str$(udtxsize(udt) \ 8) + ");" - EXIT Sub - End If +SUB copy_full_udt (dst$, src$, file, base_offset, udt) + IF NOT udtxvariable(udt) THEN + PRINT #file, "memcpy(" + dst$ + "+" + STR$(base_offset) + "," + src$ + "+" + STR$(base_offset) + "," + STR$(udtxsize(udt) \ 8) + ");" + EXIT SUB + END IF offset = base_offset element = udtxnext(udt) - Do While element - If ((udtetype(element) And ISSTRING) > 0) And (udtetype(element) And ISFIXEDLENGTH) = 0 Then - Print #file, "qbs_set(*(qbs**)(" + dst$ + "+" + Str$(offset) + "), *(qbs**)(" + src$ + "+" + Str$(offset) + "));" - ElseIf ((udtetype(element) And ISUDT) > 0) Then - copy_full_udt dst$, src$, 12, offset, udtetype(element) And 511 - Else - Print #file, "memcpy((" + dst$ + "+" + Str$(offset) + "),(" + src$ + "+" + Str$(offset) + ")," + Str$(udtesize(element) \ 8) + ");" - End If + DO WHILE element + IF ((udtetype(element) AND ISSTRING) > 0) AND (udtetype(element) AND ISFIXEDLENGTH) = 0 THEN + PRINT #file, "qbs_set(*(qbs**)(" + dst$ + "+" + STR$(offset) + "), *(qbs**)(" + src$ + "+" + STR$(offset) + "));" + ELSEIF ((udtetype(element) AND ISUDT) > 0) THEN + copy_full_udt dst$, src$, 12, offset, udtetype(element) AND 511 + ELSE + PRINT #file, "memcpy((" + dst$ + "+" + STR$(offset) + "),(" + src$ + "+" + STR$(offset) + ")," + STR$(udtesize(element) \ 8) + ");" + END IF offset = offset + udtesize(element) \ 8 element = udtenext(element) - Loop -End Sub + LOOP +END SUB -Sub dump_udts - f = FreeFile - Open "types.txt" For Output As #f - Print #f, "Name Size Align? Next Var?" - For i = 1 To lasttype - Print #f, RTrim$(udtxname(i)), udtxsize(i), udtxbytealign(i), udtxnext(i), udtxvariable(i) - Next i - Print #f, "Name Size Align? Next Type Tsize Arr" - For i = 1 To lasttypeelement - Print #f, RTrim$(udtename(i)), udtesize(i), udtebytealign(i), udtenext(i), udtetype(i), udtetypesize(i), udtearrayelements(i) - Next i - Close #f -End Sub +SUB dump_udts + f = FREEFILE + OPEN "types.txt" FOR OUTPUT AS #f + PRINT #f, "Name Size Align? Next Var?" + FOR i = 1 TO lasttype + PRINT #f, RTRIM$(udtxname(i)), udtxsize(i), udtxbytealign(i), udtxnext(i), udtxvariable(i) + NEXT i + PRINT #f, "Name Size Align? Next Type Tsize Arr" + FOR i = 1 TO lasttypeelement + PRINT #f, RTRIM$(udtename(i)), udtesize(i), udtebytealign(i), udtenext(i), udtetype(i), udtetypesize(i), udtearrayelements(i) + NEXT i + CLOSE #f +END SUB -Sub manageVariableList (name$, __cname$, action As _Byte) - Dim findItem As Long, cname$, i As Long +SUB manageVariableList (name$, __cname$, action AS _BYTE) + DIM findItem AS LONG, cname$, i AS LONG cname$ = __cname$ - findItem = InStr(cname$, "[") - If findItem Then - cname$ = Left$(cname$, findItem - 1) - End If + findItem = INSTR(cname$, "[") + IF findItem THEN + cname$ = LEFT$(cname$, findItem - 1) + END IF found = 0 - For i = 1 To totalVariablesCreated - If usedVariableList(i).cname = cname$ Then found = -1: Exit For - Next + FOR i = 1 TO totalVariablesCreated + IF usedVariableList(i).cname = cname$ THEN found = -1: EXIT FOR + NEXT - Select Case action - Case 0 'add - If found = 0 Then - If i > UBound(usedVariableList) Then - ReDim _Preserve usedVariableList(UBound(usedVariableList) + 999) As usedVarList - End If + SELECT CASE action + CASE 0 'add + IF found = 0 THEN + IF i > UBOUND(usedVariableList) THEN + REDIM _PRESERVE usedVariableList(UBOUND(usedVariableList) + 999) AS usedVarList + END IF usedVariableList(i).used = 0 usedVariableList(i).linenumber = linenumber usedVariableList(i).includeLevel = inclevel - If inclevel > 0 Then + IF inclevel > 0 THEN usedVariableList(i).includedLine = inclinenumber(inclevel) thisincname$ = getfilepath$(incname$(inclevel)) - thisincname$ = Mid$(incname$(inclevel), Len(thisincname$) + 1) + thisincname$ = MID$(incname$(inclevel), LEN(thisincname$) + 1) usedVariableList(i).includedFile = thisincname$ - Else + ELSE usedVariableList(i).includedLine = 0 usedVariableList(i).includedFile = "" - End If + END IF usedVariableList(i).cname = cname$ usedVariableList(i).name = name$ totalVariablesCreated = totalVariablesCreated + 1 - End If - Case Else 'find and mark as used - If found Then + END IF + CASE ELSE 'find and mark as used + IF found THEN usedVariableList(i).used = -1 - End If - End Select -End Sub + END IF + END SELECT +END SUB -Sub addWarning (whichLineNumber As Long, includeLevel As Long, incLineNumber As Long, incFileName$, header$, text$) +SUB addWarning (whichLineNumber AS LONG, includeLevel AS LONG, incLineNumber AS LONG, incFileName$, header$, text$) warningsissued = -1 totalWarnings = totalWarnings + 1 - If idemode = 0 And ShowWarnings Then + IF idemode = 0 AND ShowWarnings THEN thissource$ = getfilepath$(CMDLineFile) - thissource$ = Mid$(CMDLineFile, Len(thissource$) + 1) + thissource$ = MID$(CMDLineFile, LEN(thissource$) + 1) thisincname$ = getfilepath$(incFileName$) - thisincname$ = Mid$(incFileName$, Len(thisincname$) + 1) + thisincname$ = MID$(incFileName$, LEN(thisincname$) + 1) - If Not MonochromeLoggingMode Then Color 15 - If includeLevel > 0 And incLineNumber > 0 Then - Print thisincname$; ":"; - Print str2$(incLineNumber); ": "; - Else - Print thissource$; ":"; - Print str2$(whichLineNumber); ": "; - End If + IF NOT MonochromeLoggingMode THEN COLOR 15 + IF includeLevel > 0 AND incLineNumber > 0 THEN + PRINT thisincname$; ":"; + PRINT str2$(incLineNumber); ": "; + ELSE + PRINT thissource$; ":"; + PRINT str2$(whichLineNumber); ": "; + END IF - If Not MonochromeLoggingMode Then Color 13 - Print "warning: "; - If Not MonochromeLoggingMode Then Color 7 - Print header$ + IF NOT MonochromeLoggingMode THEN COLOR 13 + PRINT "warning: "; + IF NOT MonochromeLoggingMode THEN COLOR 7 + PRINT header$ - If Len(text$) > 0 Then - If Not MonochromeLoggingMode Then Color 2 - Print Space$(4); text$ - If Not MonochromeLoggingMode Then Color 7 - End If - ElseIf idemode Then - If Not IgnoreWarnings Then - If lastWarningHeader <> header$ Then + IF LEN(text$) > 0 THEN + IF NOT MonochromeLoggingMode THEN COLOR 2 + PRINT SPACE$(4); text$ + IF NOT MonochromeLoggingMode THEN COLOR 7 + END IF + ELSEIF idemode THEN + IF NOT IgnoreWarnings THEN + IF lastWarningHeader <> header$ THEN lastWarningHeader = header$ - GoSub increaseWarningCount - warning$(warningListItems) = MKL$(0) + Chr$(2) + header$ - End If + GOSUB increaseWarningCount + warning$(warningListItems) = MKL$(0) + CHR$(2) + header$ + END IF - GoSub increaseWarningCount - If includeLevel > 0 Then + GOSUB increaseWarningCount + IF includeLevel > 0 THEN thisincname$ = getfilepath$(incFileName$) - thisincname$ = Mid$(incFileName$, Len(thisincname$) + 1) - warning$(warningListItems) = MKL$(whichLineNumber) + MKL$(includeLevel) + MKL$(incLineNumber) + thisincname$ + Chr$(2) + text$ - Else - warning$(warningListItems) = MKL$(whichLineNumber) + MKL$(0) + Chr$(2) + text$ - End If - End If - End If - EXIT Sub + thisincname$ = MID$(incFileName$, LEN(thisincname$) + 1) + warning$(warningListItems) = MKL$(whichLineNumber) + MKL$(includeLevel) + MKL$(incLineNumber) + thisincname$ + CHR$(2) + text$ + ELSE + warning$(warningListItems) = MKL$(whichLineNumber) + MKL$(0) + CHR$(2) + text$ + END IF + END IF + END IF + EXIT SUB increaseWarningCount: warningListItems = warningListItems + 1 - If warningListItems > UBound(warning$) Then ReDim _Preserve warning$(warningListItems + 999) - Return -End Sub + IF warningListItems > UBOUND(warning$) THEN REDIM _PRESERVE warning$(warningListItems + 999) + RETURN +END SUB -Function SCase$ (t$) - If ideautolayoutkwcapitals Then SCase$ = UCase$(t$) Else SCase$ = t$ -End Function +FUNCTION SCase$ (t$) + IF ideautolayoutkwcapitals THEN SCase$ = UCASE$(t$) ELSE SCase$ = t$ +END FUNCTION -Function SCase2$ (t$) +FUNCTION SCase2$ (t$) separator$ = sp - If ideautolayoutkwcapitals Then - SCase2$ = UCase$(t$) - Else + IF ideautolayoutkwcapitals THEN + SCase2$ = UCASE$(t$) + ELSE newWord = -1 temp$ = "" - For i = 1 To Len(t$) - s$ = Mid$(t$, i, 1) - If newWord Then - If s$ = "_" Or s$ = separator$ Then + FOR i = 1 TO LEN(t$) + s$ = MID$(t$, i, 1) + IF newWord THEN + IF s$ = "_" OR s$ = separator$ THEN temp$ = temp$ + s$ - Else - temp$ = temp$ + UCase$(s$) + ELSE + temp$ = temp$ + UCASE$(s$) newWord = 0 - End If - Else - If s$ = separator$ Then + END IF + ELSE + IF s$ = separator$ THEN temp$ = temp$ + separator$ newWord = -1 - Else - temp$ = temp$ + LCase$(s$) - End If - End If - Next + ELSE + temp$ = temp$ + LCASE$(s$) + END IF + END IF + NEXT SCase2$ = temp$ - End If -End Function + END IF +END FUNCTION '$INCLUDE:'utilities\strings.bas' '$INCLUDE:'subs_functions\extensions\opengl\opengl_methods.bas' -DefLng A-Z +DEFLNG A-Z '-------- Optional IDE Component (2/2) -------- '$INCLUDE:'ide\ide_methods.bas'