diff --git a/source/ide/ide_methods.bas b/source/ide/ide_methods.bas index 7d6ab9f72..03a495a0c 100644 --- a/source/ide/ide_methods.bas +++ b/source/ide/ide_methods.bas @@ -2780,7 +2780,7 @@ FUNCTION ide2 (ignore) idemouseselect = 1 wholeword.select = 0 END IF - ELSEIF mX > 1 AND mx =< 1 + maxLineNumberLength AND mY > 2 AND mY < (idewy - 5) AND ShowLineNumbers THEN + ELSEIF mX > 1 AND mX <= 1 + maxLineNumberLength AND mY > 2 AND mY < (idewy - 5) AND ShowLineNumbers THEN 'line numbers are visible and been clicked ideselect = 1 idecy = mY - 2 + idesy - 1 @@ -2828,7 +2828,7 @@ FUNCTION ide2 (ignore) IF idecy > iden THEN idecy = iden ELSE 'Ok, there is a selection. But we'll override it if the click was outside it - IF (mX - 1 + idesx - 1) - maxLineNumberLength < sx1 OR (mX - 1 + idesx - 1) - maxLineNumberLength > sx2 THEN + IF (mX - 1 + idesx - 1) - maxLineNumberLength < sx1 OR (mX - 1 + idesx - 1) - maxLineNumberLength > sx2 THEN ideselect = 0 idecx = (mX - 1 + idesx - 1) - maxLineNumberLength idecy = mY - 2 + idesy - 1 @@ -8289,7 +8289,7 @@ SUB ideshowtext LOOP END IF - FOR i = 1 TO LEN (listOfCustomKeywords$) + FOR i = 1 TO LEN(listOfCustomKeywords$) checkChar = ASC(listOfCustomKeywords$, i) IF checkChar = 64 THEN IF RIGHT$(tempList$, 1) <> "@" THEN tempList$ = tempList$ + "@" @@ -8719,7 +8719,7 @@ SUB ideshowtext 'Restore BG color in case a matching bracket was printed with different BG IF l = idecy THEN COLOR , 6 IF isKeyword > 0 THEN isKeyword = isKeyword - 1 - if isKeyword = 0 THEN checkKeyword$ = "": metacommand = 0: is_Number = 0: isCustomKeyword = 0 + IF isKeyword = 0 THEN checkKeyword$ = "": metacommand = 0: is_Number = 0: isCustomKeyword = 0 NEXT m 'apply selection color change if necessary @@ -9448,7 +9448,7 @@ SUB ideobjupdate (o AS idedbotype, focus, f, focusoffset, kk$, altletter$, mb, m o.issel = 0 END IF END IF - IF k <> 8 AND k <> 9 AND k <> 0 AND k <> 10 AND k <> 13 AND k <> 26 AND k <> 255 AND ((KALT = 0 AND KCTRL = 0) OR (KALT = -1 AND KCTRL = -1)) THEN + IF k <> 8 AND k <> 9 AND k <> 0 AND k <> 10 AND k <> 13 AND k <> 26 AND k <> 255 AND ((KALT = 0 AND KCTRL = 0) OR (KALT = -1 AND KCTRL = -1)) THEN IF o.issel THEN sx1 = o.sx1: sx2 = o.v1 IF sx1 > sx2 THEN SWAP sx1, sx2 @@ -12159,7 +12159,7 @@ FUNCTION idechoosecolorsbox 'Build scheme string SchemeString$ = SchemeString$ + "|" - FOR j = 1 to 9 + FOR j = 1 TO 9 SELECT CASE j CASE 1: CurrentColor~& = IDETextColor CASE 2: CurrentColor~& = IDEKeywordColor @@ -12197,7 +12197,7 @@ FUNCTION idechoosecolorsbox SchemeString$ = SchemeString$ + "|" 'Build scheme string - FOR j = 1 to 9 + FOR j = 1 TO 9 SELECT CASE j CASE 1: CurrentColor~& = IDETextColor CASE 2: CurrentColor~& = IDEKeywordColor @@ -12372,7 +12372,7 @@ FUNCTION idechoosecolorsbox i = i + 1: l$ = l$ + sep + SelectionIndicator$(i) + "Keywords" i = i + 1: l$ = l$ + sep + SelectionIndicator$(i) + "Numbers" i = i + 1: l$ = l$ + sep + SelectionIndicator$(i) + "Strings" - i = i + 1: l$ = l$ + sep + SelectionIndicator$(i) + "Metacommand/custom keywords + i = i + 1: l$ = l$ + sep + SelectionIndicator$(i) + "Metacommand/custom keywords" i = i + 1: l$ = l$ + sep + SelectionIndicator$(i) + "Comments" i = i + 1: l$ = l$ + sep + SelectionIndicator$(i) + "Background" i = i + 1: l$ = l$ + sep + SelectionIndicator$(i) + "Current line background" @@ -14520,16 +14520,16 @@ END SUB 'After Cormen, Leiserson, Rivest & Stein "Introduction To Algoritms" via Wikipedia SUB sort (arr() AS STRING * 998) -FOR i& = LBOUND(arr) + 1 TO UBOUND(arr) - x$ = arr(i&) - j& = i& - 1 - WHILE j& >= LBOUND(arr) - IF arr(j&) <= x$ THEN EXIT WHILE - arr$(j& + 1) = arr$(j&) - j& = j& - 1 - WEND - arr$(j& + 1) = x$ -NEXT i& + FOR i& = LBOUND(arr) + 1 TO UBOUND(arr) + x$ = arr(i&) + j& = i& - 1 + WHILE j& >= LBOUND(arr) + IF arr(j&) <= x$ THEN EXIT WHILE + arr$(j& + 1) = arr$(j&) + j& = j& - 1 + WEND + arr$(j& + 1) = x$ + NEXT i& END SUB FUNCTION FindProposedTitle$ @@ -14731,7 +14731,7 @@ SUB LoadColorSchemes ELSEIF LEN(MID$(value$, FoundPipe + 1)) = 54 THEN 'Version 1.1 schemes (only 6 colors) 'Convert to extended scheme: - temp$ = LEFT$(value$, FoundPipe) + temp$ = LEFT$(value$, FoundPipe) temp$ = temp$ + MID$(value$, FoundPipe + 1, 9) + "069147216245128177" temp$ = temp$ + MID$(value$, FoundPipe + 10) + "000147177" ColorSchemes$(TotalColorSchemes) = temp$ diff --git a/source/ide/wiki/wiki_methods.bas b/source/ide/wiki/wiki_methods.bas index ab2e53f98..fa5a0086d 100644 --- a/source/ide/wiki/wiki_methods.bas +++ b/source/ide/wiki/wiki_methods.bas @@ -1,784 +1,784 @@ FUNCTION Back2BackName$ (a$) -IF a$ = "Keyword Reference - Alphabetical" THEN Back2BackName$ = "Alphabetical": EXIT FUNCTION -IF a$ = "Keyword Reference - By usage" THEN Back2BackName$ = "By Usage": EXIT FUNCTION -IF a$ = "QB64 Help Menu" THEN Back2BackName$ = "Help": EXIT FUNCTION -IF a$ = "QB64 FAQ" THEN Back2BackName$ = "FAQ": EXIT FUNCTION -Back2BackName$ = a$ + IF a$ = "Keyword Reference - Alphabetical" THEN Back2BackName$ = "Alphabetical": EXIT FUNCTION + IF a$ = "Keyword Reference - By usage" THEN Back2BackName$ = "By Usage": EXIT FUNCTION + IF a$ = "QB64 Help Menu" THEN Back2BackName$ = "Help": EXIT FUNCTION + IF a$ = "QB64 FAQ" THEN Back2BackName$ = "FAQ": EXIT FUNCTION + Back2BackName$ = a$ END FUNCTION FUNCTION Wiki$ (PageName$) -STATIC AlternativeServer AS _BYTE -Help_PageLoaded$ = PageName$ -PageName2$ = PageName$ + STATIC AlternativeServer AS _BYTE + Help_PageLoaded$ = PageName$ + PageName2$ = PageName$ -DO WHILE INSTR(PageName2$, " ") - ASC(PageName2$, INSTR(PageName2$, " ")) = 95 -LOOP -DO WHILE INSTR(PageName2$, "&") - i = INSTR(PageName2$, "&") - PageName2$ = LEFT$(PageName2$, i - 1) + "%26" + RIGHT$(PageName2$, LEN(PageName2$) - i) -LOOP -DO WHILE INSTR(PageName2$, "/") - i = INSTR(PageName2$, "/") - PageName2$ = LEFT$(PageName2$, i - 1) + "%2F" + RIGHT$(PageName2$, LEN(PageName2$) - i) -LOOP + DO WHILE INSTR(PageName2$, " ") + ASC(PageName2$, INSTR(PageName2$, " ")) = 95 + LOOP + DO WHILE INSTR(PageName2$, "&") + i = INSTR(PageName2$, "&") + PageName2$ = LEFT$(PageName2$, i - 1) + "%26" + RIGHT$(PageName2$, LEN(PageName2$) - i) + LOOP + DO WHILE INSTR(PageName2$, "/") + i = INSTR(PageName2$, "/") + PageName2$ = LEFT$(PageName2$, i - 1) + "%2F" + RIGHT$(PageName2$, LEN(PageName2$) - i) + LOOP -'Is this page in the cache? -IF Help_IgnoreCache = 0 THEN - IF _FILEEXISTS(Cache_Folder$ + "/" + PageName2$ + ".txt") THEN - fh = FREEFILE - OPEN Cache_Folder$ + "/" + PageName2$ + ".txt" FOR BINARY AS #fh - a$ = SPACE$(LOF(fh)) - GET #fh, , a$ - CLOSE #fh - Wiki$ = a$ - EXIT FUNCTION - END IF -END IF - -IF Help_Recaching = 0 THEN - a$ = "Downloading '" + PageName$ + "' page..." - IF LEN(a$) > 60 THEN a$ = LEFT$(a$, 57) + STRING$(3, 250) - IF LEN(a$) < 60 THEN a$ = a$ + SPACE$(60 - LEN(a$)) - - COLOR 0, 3: LOCATE idewy + idesubwindow, 2 - PRINT a$; - - PCOPY 3, 0 -END IF - -url$ = "www.qb64.net/wiki/index.php?title=" + PageName2$ + "&action=edit" -s1$ = "readonly=" + CHR$(34) + "readonly" + CHR$(34) + ">" -try: -IF AlternativeServer THEN - url$ = "www.qb64.org/wiki/index.php?title=" + PageName2$ + "&action=edit" - 'when fetching from .org, look for name="wpTextbox1"> - s1$ = "name=" + CHR$(34) + "wpTextbox1" + CHR$(34) + ">" -END IF -url2$ = url$ -x = INSTR(url2$, "/") -IF x THEN url2$ = LEFT$(url$, x - 1) -c = _OPENCLIENT("TCP/IP:80:" + url2$) -IF c = 0 THEN - IF INSTR(url$, ".org") = 0 THEN - AlternativeServer = -1 - IF Help_Recaching = 0 THEN - a$ = "Downloading '" + PageName$ + "' page from alternative server..." - IF LEN(a$) > 60 THEN a$ = LEFT$(a$, 57) + STRING$(3, 250) - IF LEN(a$) < 60 THEN a$ = a$ + SPACE$(60 - LEN(a$)) - - COLOR 0, 3: LOCATE idewy + idesubwindow, 2 - PRINT a$; - - PCOPY 3, 0 - END IF - GOTO try - ELSE - EXIT FUNCTION - END IF -END IF -e$ = CHR$(13) + CHR$(10) -url3$ = RIGHT$(url$, LEN(url$) - x + 1) -x$ = "GET " + url3$ + " HTTP/1.1" + e$ -x$ = x$ + "Host: " + url2$ + e$ + e$ -PUT #c, , x$ -t! = TIMER - -DO - _DELAY 0.1 - GET #c, , a2$ - IF LEN(a2$) THEN - a$ = a$ + a2$ - IF INSTR(a$, "") THEN - CLOSE #c - s2$ = "" - s1 = INSTR(a$, s1$): IF s1 = 0 THEN EXIT FUNCTION - s1 = s1 + LEN(s1$) - s2 = INSTR(a$, s2$): IF s2 = 0 THEN EXIT FUNCTION - s2 = s2 - 1 - IF s1 > s2 THEN EXIT FUNCTION - a$ = MID$(a$, s1, s2 - s1 + 1) + 'Is this page in the cache? + IF Help_IgnoreCache = 0 THEN + IF _FILEEXISTS(Cache_Folder$ + "/" + PageName2$ + ".txt") THEN fh = FREEFILE - E = 0 - ON ERROR GOTO qberror_test - OPEN Cache_Folder$ + "/" + PageName2$ + ".txt" FOR OUTPUT AS #fh 'clear old content - ON ERROR GOTO qberror - IF E = 0 THEN - CLOSE #fh - ON ERROR GOTO qberror_test - OPEN Cache_Folder$ + "/" + PageName2$ + ".txt" FOR BINARY AS #fh - ON ERROR GOTO qberror - IF E = 0 THEN - PUT #fh, , a$ - CLOSE #fh - END IF - END IF + OPEN Cache_Folder$ + "/" + PageName2$ + ".txt" FOR BINARY AS #fh + a$ = SPACE$(LOF(fh)) + GET #fh, , a$ + CLOSE #fh Wiki$ = a$ EXIT FUNCTION END IF END IF -LOOP UNTIL ABS(TIMER - t!) > 20 -CLOSE #c + + IF Help_Recaching = 0 THEN + a$ = "Downloading '" + PageName$ + "' page..." + IF LEN(a$) > 60 THEN a$ = LEFT$(a$, 57) + STRING$(3, 250) + IF LEN(a$) < 60 THEN a$ = a$ + SPACE$(60 - LEN(a$)) + + COLOR 0, 3: LOCATE idewy + idesubwindow, 2 + PRINT a$; + + PCOPY 3, 0 + END IF + + url$ = "www.qb64.net/wiki/index.php?title=" + PageName2$ + "&action=edit" + s1$ = "readonly=" + CHR$(34) + "readonly" + CHR$(34) + ">" + try: + IF AlternativeServer THEN + url$ = "www.qb64.org/wiki/index.php?title=" + PageName2$ + "&action=edit" + 'when fetching from .org, look for name="wpTextbox1"> + s1$ = "name=" + CHR$(34) + "wpTextbox1" + CHR$(34) + ">" + END IF + url2$ = url$ + x = INSTR(url2$, "/") + IF x THEN url2$ = LEFT$(url$, x - 1) + c = _OPENCLIENT("TCP/IP:80:" + url2$) + IF c = 0 THEN + IF INSTR(url$, ".org") = 0 THEN + AlternativeServer = -1 + IF Help_Recaching = 0 THEN + a$ = "Downloading '" + PageName$ + "' page from alternative server..." + IF LEN(a$) > 60 THEN a$ = LEFT$(a$, 57) + STRING$(3, 250) + IF LEN(a$) < 60 THEN a$ = a$ + SPACE$(60 - LEN(a$)) + + COLOR 0, 3: LOCATE idewy + idesubwindow, 2 + PRINT a$; + + PCOPY 3, 0 + END IF + GOTO try + ELSE + EXIT FUNCTION + END IF + END IF + e$ = CHR$(13) + CHR$(10) + url3$ = RIGHT$(url$, LEN(url$) - x + 1) + x$ = "GET " + url3$ + " HTTP/1.1" + e$ + x$ = x$ + "Host: " + url2$ + e$ + e$ + PUT #c, , x$ + t! = TIMER + + DO + _DELAY 0.1 + GET #c, , a2$ + IF LEN(a2$) THEN + a$ = a$ + a2$ + IF INSTR(a$, "") THEN + CLOSE #c + s2$ = "" + s1 = INSTR(a$, s1$): IF s1 = 0 THEN EXIT FUNCTION + s1 = s1 + LEN(s1$) + s2 = INSTR(a$, s2$): IF s2 = 0 THEN EXIT FUNCTION + s2 = s2 - 1 + IF s1 > s2 THEN EXIT FUNCTION + a$ = MID$(a$, s1, s2 - s1 + 1) + fh = FREEFILE + E = 0 + ON ERROR GOTO qberror_test + OPEN Cache_Folder$ + "/" + PageName2$ + ".txt" FOR OUTPUT AS #fh 'clear old content + ON ERROR GOTO qberror + IF E = 0 THEN + CLOSE #fh + ON ERROR GOTO qberror_test + OPEN Cache_Folder$ + "/" + PageName2$ + ".txt" FOR BINARY AS #fh + ON ERROR GOTO qberror + IF E = 0 THEN + PUT #fh, , a$ + CLOSE #fh + END IF + END IF + Wiki$ = a$ + EXIT FUNCTION + END IF + END IF + LOOP UNTIL ABS(TIMER - t!) > 20 + CLOSE #c END FUNCTION SUB Help_AddTxt (t$, col, link) -IF t$ = CHR$(13) THEN Help_NewLine: EXIT SUB + IF t$ = CHR$(13) THEN Help_NewLine: EXIT SUB -FOR i = 1 TO LEN(t$) + FOR i = 1 TO LEN(t$) - c = ASC(t$, i) + c = ASC(t$, i) - IF Help_BG_Col = 0 AND Help_LockWrap = 0 THEN + IF Help_BG_Col = 0 AND Help_LockWrap = 0 THEN - 'addtxt handles all wrapping issues - IF c = 32 THEN + 'addtxt handles all wrapping issues + IF c = 32 THEN - IF Help_Pos = Help_ww THEN Help_NewLine: GOTO special + IF Help_Pos = Help_ww THEN Help_NewLine: GOTO special - Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = 32 - Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = col + Help_BG_Col * 16 - Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = link AND 255 - Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = link \ 256 + Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = 32 + Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = col + Help_BG_Col * 16 + Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = link AND 255 + Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = link \ 256 - Help_Wrap_Pos = Help_Txt_Len 'pos to backtrack to when wrapping content - Help_Pos = Help_Pos + 1 - GOTO special - END IF - - IF Help_Pos > Help_ww THEN - IF Help_Wrap_Pos THEN 'attempt to wrap - 'backtrack, insert new line, continue - - b$ = MID$(Help_Txt$, Help_Wrap_Pos + 1, Help_Txt_Len - Help_Wrap_Pos) - - Help_Txt_Len = Help_Wrap_Pos - - Help_NewLine - - MID$(Help_Txt$, Help_Txt_Len + 1, LEN(b$)) = b$: Help_Txt_Len = Help_Txt_Len + LEN(b$) - - Help_Pos = Help_Pos + LEN(b$) \ 4 + Help_Wrap_Pos = Help_Txt_Len 'pos to backtrack to when wrapping content + Help_Pos = Help_Pos + 1 + GOTO special END IF - END IF - END IF 'bg_col=0 + IF Help_Pos > Help_ww THEN + IF Help_Wrap_Pos THEN 'attempt to wrap + 'backtrack, insert new line, continue - c = ASC(t$, i) - Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = c - Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = col + Help_BG_Col * 16 - Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = link AND 255 - Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = link \ 256 + b$ = MID$(Help_Txt$, Help_Wrap_Pos + 1, Help_Txt_Len - Help_Wrap_Pos) - Help_Pos = Help_Pos + 1 - special: -NEXT + Help_Txt_Len = Help_Wrap_Pos + + Help_NewLine + + MID$(Help_Txt$, Help_Txt_Len + 1, LEN(b$)) = b$: Help_Txt_Len = Help_Txt_Len + LEN(b$) + + Help_Pos = Help_Pos + LEN(b$) \ 4 + END IF + END IF + + END IF 'bg_col=0 + + c = ASC(t$, i) + Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = c + Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = col + Help_BG_Col * 16 + Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = link AND 255 + Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = link \ 256 + + Help_Pos = Help_Pos + 1 + special: + NEXT END SUB SUB Help_NewLine -IF Help_Pos > help_w THEN help_w = Help_Pos + IF Help_Pos > help_w THEN help_w = Help_Pos -Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = 13 -Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = col + Help_BG_Col * 16 -Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = 0 -Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = 0 + Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = 13 + Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = col + Help_BG_Col * 16 + Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = 0 + Help_Txt_Len = Help_Txt_Len + 1: ASC(Help_Txt$, Help_Txt_Len) = 0 -help_h = help_h + 1 -Help_Line$ = Help_Line$ + MKL$(Help_Txt_Len + 1) -Help_Wrap_Pos = 0 + help_h = help_h + 1 + Help_Line$ = Help_Line$ + MKL$(Help_Txt_Len + 1) + Help_Wrap_Pos = 0 -IF Help_Underline THEN - Help_Underline = 0 - w = Help_Pos + IF Help_Underline THEN + Help_Underline = 0 + w = Help_Pos + Help_Pos = 1 + Help_AddTxt STRING$(w - 1, 196), Help_Col, 0 + Help_NewLine + END IF Help_Pos = 1 - Help_AddTxt STRING$(w - 1, 196), Help_Col, 0 - Help_NewLine -END IF -Help_Pos = 1 -IF Help_NewLineIndent THEN - Help_AddTxt SPACE$(Help_NewLineIndent), Help_Col, 0 -END IF + IF Help_NewLineIndent THEN + Help_AddTxt SPACE$(Help_NewLineIndent), Help_Col, 0 + END IF END SUB SUB Help_PreView -OPEN "help_preview.txt" FOR OUTPUT AS #1 -FOR i = 1 TO LEN(Help_Txt$) STEP 4 - c = ASC(Help_Txt$, i) - c$ = CHR$(c) - IF c = 13 THEN c$ = CHR$(13) + CHR$(10) - PRINT #1, c$; -NEXT -CLOSE #1 + OPEN "help_preview.txt" FOR OUTPUT AS #1 + FOR i = 1 TO LEN(Help_Txt$) STEP 4 + c = ASC(Help_Txt$, i) + c$ = CHR$(c) + IF c = 13 THEN c$ = CHR$(13) + CHR$(10) + PRINT #1, c$; + NEXT + CLOSE #1 -CLS -FOR i = 1 TO LEN(Help_Txt$) STEP 4 - c = ASC(Help_Txt$, i) - col = ASC(Help_Txt$, i + 1) - IF c = 13 THEN - COLOR col AND 15, col \ 16 - PRINT SPACE$(help_w - POS(0)); - COLOR 7, 0 - PRINT SPACE$(_WIDTH - POS(0) + 1); - COLOR col AND 15, col \ 16 - SLEEP - ELSE - COLOR col AND 15, col \ 16 - PRINT CHR$(c); - END IF -NEXT + CLS + FOR i = 1 TO LEN(Help_Txt$) STEP 4 + c = ASC(Help_Txt$, i) + col = ASC(Help_Txt$, i + 1) + IF c = 13 THEN + COLOR col AND 15, col \ 16 + PRINT SPACE$(help_w - POS(0)); + COLOR 7, 0 + PRINT SPACE$(_WIDTH - POS(0) + 1); + COLOR col AND 15, col \ 16 + SLEEP + ELSE + COLOR col AND 15, col \ 16 + PRINT CHR$(c); + END IF + NEXT END SUB FUNCTION Help_Col 'helps to calculate the default color -col = Help_Col_Normal -IF Help_Italic THEN col = Help_Col_Italic -IF Help_Bold THEN col = Help_Col_Bold 'Note: Bold overrides italic -Help_Col = col + col = Help_Col_Normal + IF Help_Italic THEN col = Help_Col_Italic + IF Help_Bold THEN col = Help_Col_Bold 'Note: Bold overrides italic + Help_Col = col END FUNCTION SUB WikiParse (a$) -'PRINT "Parsing...": _DISPLAY + 'PRINT "Parsing...": _DISPLAY -'wiki page interpret + 'wiki page interpret -'clear info -help_h = 0: help_w = 0: Help_Line$ = "": Help_Link$ = "": Help_LinkN = 0 -Help_Txt$ = SPACE$(1000000) -Help_Txt_Len = 0 + 'clear info + help_h = 0: help_w = 0: Help_Line$ = "": Help_Link$ = "": Help_LinkN = 0 + Help_Txt$ = SPACE$(1000000) + Help_Txt_Len = 0 -Help_Pos = 1: Help_Wrap_Pos = 0 -Help_Line$ = MKL$(1) -Help_LockWrap = 0 -Help_Bold = 0: Help_Italic = 0 -Help_Underline = 0 -Help_BG_Col = 0 + Help_Pos = 1: Help_Wrap_Pos = 0 + Help_Line$ = MKL$(1) + Help_LockWrap = 0 + Help_Bold = 0: Help_Italic = 0 + Help_Underline = 0 + Help_BG_Col = 0 -link = 0: elink = 0: cb = 0 + link = 0: elink = 0: cb = 0 -col = Help_Col + col = Help_Col -'Syntax Notes: -' '''=bold -' ''=italic -' {{macroname|macroparam}} or simply {{macroname}} -' eg. {{KW|PRINT}}=a key word, a link to a page -' {{Cl|PRINT}}=a key word in a code example, will be printed in bold and aqua -' {{Parameter|expression}}=a parameter, in italics -' {{PageSyntax}} {{PageDescription}} {{PageExamples}} -' {{CodeStart}} {{CodeEnd}} {{OutputStart}} {{OutputEnd}} -' {{PageSeeAlso}} {{PageNavigation}} -' [[SPACE$]]=a link to wikipage called "SPACE$" -' [[INTEGER|integer]]=a link, link's name is on left and text to appear is on right -' *=a dot point -' **=a sub(ie. further indented) dot point -' "=a quotation mark -' :=indent (if beginning a new line) -' CHR$(10)=new line character + 'Syntax Notes: + ' '''=bold + ' ''=italic + ' {{macroname|macroparam}} or simply {{macroname}} + ' eg. {{KW|PRINT}}=a key word, a link to a page + ' {{Cl|PRINT}}=a key word in a code example, will be printed in bold and aqua + ' {{Parameter|expression}}=a parameter, in italics + ' {{PageSyntax}} {{PageDescription}} {{PageExamples}} + ' {{CodeStart}} {{CodeEnd}} {{OutputStart}} {{OutputEnd}} + ' {{PageSeeAlso}} {{PageNavigation}} + ' [[SPACE$]]=a link to wikipage called "SPACE$" + ' [[INTEGER|integer]]=a link, link's name is on left and text to appear is on right + ' *=a dot point + ' **=a sub(ie. further indented) dot point + ' "=a quotation mark + ' :=indent (if beginning a new line) + ' CHR$(10)=new line character -DIM c$(16) -FOR ii = 1 TO 16 - c$(ii) = SPACE$(ii) -NEXT - -n = LEN(a$) -i = 1 -DO WHILE i <= n - - c = ASC(a$, i): c$ = CHR$(c) - FOR i1 = 1 TO 16 - ii = i - FOR i2 = 1 TO i1 - IF ii < n THEN - ASC(c$(i1), i2) = ASC(a$, ii) - ELSE - ASC(c$(i1), i2) = 32 - END IF - ii = ii + 1 - NEXT + DIM c$(16) + FOR ii = 1 TO 16 + c$(ii) = SPACE$(ii) NEXT - IF c = 38 THEN '"&" + n = LEN(a$) + i = 1 + DO WHILE i <= n - s$ = "<code>": IF c$(LEN(s$)) = s$ THEN i = i + LEN(s$) - 1: GOTO Special - s$ = "</code>": IF c$(LEN(s$)) = s$ THEN i = i + LEN(s$) - 1: GOTO Special - - s$ = """ - IF c$(LEN(s$)) = s$ THEN - i = i + LEN(s$) - 1 - c$ = CHR$(34): c = ASC(c$) - GOTO SpecialChr - END IF - - s$ = "&" - IF c$(LEN(s$)) = s$ THEN - i = i + LEN(s$) - 1 - c$ = "&": c = ASC(c$) - GOTO SpecialChr - END IF - - s$ = "<center>" - IF c$(LEN(s$)) = s$ THEN - i = i + LEN(s$) - 1 - GOTO Special - END IF - - s$ = "</center>" - IF c$(LEN(s$)) = s$ THEN - i = i + LEN(s$) - 1 - GOTO Special - END IF - - s$ = "<p style=" - IF c$(LEN(s$)) = s$ THEN - i = i + LEN(s$) - 1 - FOR ii = i TO LEN(a$) - 3 - IF MID$(a$, ii, 4) = ">" THEN i = ii + 3: EXIT FOR + c = ASC(a$, i): c$ = CHR$(c) + FOR i1 = 1 TO 16 + ii = i + FOR i2 = 1 TO i1 + IF ii < n THEN + ASC(c$(i1), i2) = ASC(a$, ii) + ELSE + ASC(c$(i1), i2) = 32 + END IF + ii = ii + 1 NEXT - GOTO Special - END IF - s$ = "</p" - IF c$(LEN(s$)) = s$ THEN - i = i + LEN(s$) - 1 - FOR ii = i TO LEN(a$) - 3 - IF MID$(a$, ii, 4) = ">" THEN i = ii + 3: EXIT FOR - NEXT - GOTO Special - END IF + NEXT - s$ = ">" - IF c$(LEN(s$)) = s$ THEN - i = i + LEN(s$) - 1 - c$ = ">": c = ASC(c$) - GOTO SpecialChr - END IF - s$ = "<" - IF c$(LEN(s$)) = s$ THEN - i = i + LEN(s$) - 1 - c$ = "<": c = ASC(c$) - GOTO SpecialChr - END IF + IF c = 38 THEN '"&" - IF c$(2) = CHR$(194) + CHR$(160) THEN 'some kind of white-space formatting unicode combo - i = i + 1 - GOTO Special - END IF + s$ = "<code>": IF c$(LEN(s$)) = s$ THEN i = i + LEN(s$) - 1: GOTO Special + s$ = "</code>": IF c$(LEN(s$)) = s$ THEN i = i + LEN(s$) - 1: GOTO Special - SpecialChr: - - END IF 'c=38 '"&" - - 'Links - IF c = 91 THEN '"[" - IF c$(2) = "[[" AND link = 0 THEN - i = i + 1 - link = 1 - link$ = "" - GOTO Special - END IF - END IF - IF link = 1 THEN - IF c$(2) = "]]" OR c$(2) = "}}" THEN - i = i + 1 - link = 0 - text$ = link$ - i2 = INSTR(link$, "|") - IF i2 THEN - text$ = RIGHT$(link$, LEN(link$) - i2) - link$ = LEFT$(link$, i2 - 1) + s$ = """ + IF c$(LEN(s$)) = s$ THEN + i = i + LEN(s$) - 1 + c$ = CHR$(34): c = ASC(c$) + GOTO SpecialChr END IF - IF INSTR(link$, "#") THEN 'local page links not supported yet - Help_AddTxt text$, 8, 0 + s$ = "&" + IF c$(LEN(s$)) = s$ THEN + i = i + LEN(s$) - 1 + c$ = "&": c = ASC(c$) + GOTO SpecialChr + END IF + + s$ = "<center>" + IF c$(LEN(s$)) = s$ THEN + i = i + LEN(s$) - 1 GOTO Special END IF - Help_LinkN = Help_LinkN + 1 - Help_Link$ = Help_Link$ + "PAGE:" + link$ + Help_Link_Sep$ - - IF Help_BG_Col = 0 THEN - Help_AddTxt text$, Help_Col_Link, Help_LinkN - ELSE - Help_AddTxt text$, Help_Col_Bold, Help_LinkN + s$ = "</center>" + IF c$(LEN(s$)) = s$ THEN + i = i + LEN(s$) - 1 + GOTO Special END IF + + s$ = "<p style=" + IF c$(LEN(s$)) = s$ THEN + i = i + LEN(s$) - 1 + FOR ii = i TO LEN(a$) - 3 + IF MID$(a$, ii, 4) = ">" THEN i = ii + 3: EXIT FOR + NEXT + GOTO Special + END IF + s$ = "</p" + IF c$(LEN(s$)) = s$ THEN + i = i + LEN(s$) - 1 + FOR ii = i TO LEN(a$) - 3 + IF MID$(a$, ii, 4) = ">" THEN i = ii + 3: EXIT FOR + NEXT + GOTO Special + END IF + + s$ = ">" + IF c$(LEN(s$)) = s$ THEN + i = i + LEN(s$) - 1 + c$ = ">": c = ASC(c$) + GOTO SpecialChr + END IF + s$ = "<" + IF c$(LEN(s$)) = s$ THEN + i = i + LEN(s$) - 1 + c$ = "<": c = ASC(c$) + GOTO SpecialChr + END IF + + IF c$(2) = CHR$(194) + CHR$(160) THEN 'some kind of white-space formatting unicode combo + i = i + 1 + GOTO Special + END IF + + SpecialChr: + + END IF 'c=38 '"&" + + 'Links + IF c = 91 THEN '"[" + IF c$(2) = "[[" AND link = 0 THEN + i = i + 1 + link = 1 + link$ = "" + GOTO Special + END IF + END IF + IF link = 1 THEN + IF c$(2) = "]]" OR c$(2) = "}}" THEN + i = i + 1 + link = 0 + text$ = link$ + i2 = INSTR(link$, "|") + IF i2 THEN + text$ = RIGHT$(link$, LEN(link$) - i2) + link$ = LEFT$(link$, i2 - 1) + END IF + + IF INSTR(link$, "#") THEN 'local page links not supported yet + Help_AddTxt text$, 8, 0 + GOTO Special + END IF + + Help_LinkN = Help_LinkN + 1 + Help_Link$ = Help_Link$ + "PAGE:" + link$ + Help_Link_Sep$ + + IF Help_BG_Col = 0 THEN + Help_AddTxt text$, Help_Col_Link, Help_LinkN + ELSE + Help_AddTxt text$, Help_Col_Bold, Help_LinkN + END IF + GOTO Special + END IF + link$ = link$ + c$ GOTO Special END IF - link$ = link$ + c$ - GOTO Special - END IF - 'External links - IF c = 91 THEN '"[" - IF c$(6) = "[http:" AND elink = 0 THEN - elink = 2 - elink$ = "" + 'External links + IF c = 91 THEN '"[" + IF c$(6) = "[http:" AND elink = 0 THEN + elink = 2 + elink$ = "" + GOTO Special + END IF + END IF + IF elink = 2 THEN + IF c$ = " " THEN + elink = 1 + GOTO Special + END IF + elink$ = elink$ + c$ GOTO Special END IF - END IF - IF elink = 2 THEN - IF c$ = " " THEN - elink = 1 - GOTO Special + IF elink >= 1 THEN + IF c$ = "]" THEN + elink = 0 + elink$ = " " + elink$ + Help_LockWrap = 1: Help_Wrap_Pos = 0 + Help_AddTxt elink$, 8, 0 + Help_LockWrap = 0 + elink$ = "" + GOTO Special + END IF END IF - elink$ = elink$ + c$ - GOTO Special - END IF - IF elink >= 1 THEN - IF c$ = "]" THEN - elink = 0 - elink$ = " " + elink$ - Help_LockWrap = 1: Help_Wrap_Pos = 0 - Help_AddTxt elink$, 8, 0 - Help_LockWrap = 0 - elink$ = "" - GOTO Special - END IF - END IF - IF c = 123 THEN '"{" - IF c$(5) = "{{KW|" THEN 'this is really a link! - i = i + 4 - link = 1 - link$ = "" - GOTO Special + IF c = 123 THEN '"{" + IF c$(5) = "{{KW|" THEN 'this is really a link! + i = i + 4 + link = 1 + link$ = "" + GOTO Special + END IF + IF c$(5) = "{{Cl|" THEN 'this is really a link too (in code example) + i = i + 4 + link = 1 + link$ = "" + GOTO Special + END IF + IF c$(2) = "{{" THEN + i = i + 1 + cb = 1 + cb$ = "" + GOTO Special + END IF END IF - IF c$(5) = "{{Cl|" THEN 'this is really a link too (in code example) - i = i + 4 - link = 1 - link$ = "" + + IF cb = 1 THEN + IF c$ = "|" OR c$(2) = "}}" THEN + IF c$(2) = "}}" THEN i = i + 1 + cb = 0 + + IF cb$ = "PageSyntax" THEN Help_AddTxt "Syntax:" + CHR$(13), Help_Col_Section, 0 + IF cb$ = "PageDescription" THEN Help_AddTxt "Description:" + CHR$(13), Help_Col_Section, 0 + IF cb$ = "PageExamples" THEN Help_AddTxt "Code Examples:" + CHR$(13), Help_Col_Section, 0 + IF cb$ = "PageSeeAlso" THEN Help_AddTxt "See also:" + CHR$(13), Help_Col_Section, 0 + + IF cb$ = "CodeStart" THEN + Help_NewLine + Help_BG_Col = 1 + 'Skip non-meaningful content before section begins + ws = 1 + FOR ii = i + 1 TO LEN(a$) + IF ASC(a$, ii) = 10 THEN EXIT FOR + IF ASC(a$, ii) <> 32 AND ASC(a$, ii) <> 39 THEN ws = 0 + NEXT + IF ws THEN i = ii + END IF + IF cb$ = "CodeEnd" THEN Help_BG_Col = 0 + IF cb$ = "OutputStart" THEN + Help_NewLine + Help_BG_Col = 2 + 'Skip non-meaningful content before section begins + ws = 1 + FOR ii = i + 1 TO LEN(a$) + IF ASC(a$, ii) = 10 THEN EXIT FOR + IF ASC(a$, ii) <> 32 AND ASC(a$, ii) <> 39 THEN ws = 0 + NEXT + IF ws THEN i = ii + END IF + IF cb$ = "OutputEnd" THEN Help_BG_Col = 0 + + GOTO Special + + END IF + + cb$ = cb$ + c$ 'reading maro name GOTO Special - END IF - IF c$(2) = "{{" THEN + END IF 'cb=1 + + IF c$(2) = "}}" THEN 'probably the end of a text section of macro'd text i = i + 1 - cb = 1 - cb$ = "" GOTO Special END IF - END IF - IF cb = 1 THEN - IF c$ = "|" OR c$(2) = "}}" THEN - IF c$(2) = "}}" THEN i = i + 1 - cb = 0 - IF cb$ = "PageSyntax" THEN Help_AddTxt "Syntax:" + CHR$(13), Help_Col_Section, 0 - IF cb$ = "PageDescription" THEN Help_AddTxt "Description:" + CHR$(13), Help_Col_Section, 0 - IF cb$ = "PageExamples" THEN Help_AddTxt "Code Examples:" + CHR$(13), Help_Col_Section, 0 - IF cb$ = "PageSeeAlso" THEN Help_AddTxt "See also:" + CHR$(13), Help_Col_Section, 0 - - IF cb$ = "CodeStart" THEN - Help_NewLine - Help_BG_Col = 1 - 'Skip non-meaningful content before section begins - ws = 1 - FOR ii = i + 1 TO LEN(a$) - IF ASC(a$, ii) = 10 THEN EXIT FOR - IF ASC(a$, ii) <> 32 AND ASC(a$, ii) <> 39 THEN ws = 0 - NEXT - IF ws THEN i = ii - END IF - IF cb$ = "CodeEnd" THEN Help_BG_Col = 0 - IF cb$ = "OutputStart" THEN - Help_NewLine - Help_BG_Col = 2 - 'Skip non-meaningful content before section begins - ws = 1 - FOR ii = i + 1 TO LEN(a$) - IF ASC(a$, ii) = 10 THEN EXIT FOR - IF ASC(a$, ii) <> 32 AND ASC(a$, ii) <> 39 THEN ws = 0 - NEXT - IF ws THEN i = ii - END IF - IF cb$ = "OutputEnd" THEN Help_BG_Col = 0 + IF c$(4) = " == " THEN + i = i + 3 + Help_Underline = 1 GOTO Special - END IF - - cb$ = cb$ + c$ 'reading maro name - GOTO Special - END IF 'cb=1 - - IF c$(2) = "}}" THEN 'probably the end of a text section of macro'd text - i = i + 1 - GOTO Special - END IF - - - - IF c$(4) = " == " THEN - i = i + 3 - Help_Underline = 1 - GOTO Special - END IF - IF c$(3) = "== " THEN - i = i + 2 - Help_Underline = 1 - GOTO Special - END IF - IF c$(3) = " ==" THEN - i = i + 2 - GOTO Special - END IF - IF c$(2) = "==" THEN - i = i + 1 - Help_Underline = 1 - GOTO Special - END IF - - - IF c$(3) = "'''" THEN - i = i + 2 - IF Help_Bold = 0 THEN Help_Bold = 1 ELSE Help_Bold = 0 - col = Help_Col - GOTO Special - END IF - - IF c$(2) = "''" THEN - i = i + 1 - IF Help_Italic = 0 THEN Help_Italic = 1 ELSE Help_Italic = 0 - col = Help_Col - GOTO Special - END IF - - IF nl = 1 THEN - - IF c$(3) = "** " THEN + IF c$(3) = "== " THEN i = i + 2 - Help_AddTxt " " + CHR$(254) + " ", col, 0 - Help_NewLineIndent = Help_NewLineIndent + 6 + Help_Underline = 1 GOTO Special END IF - IF c$(2) = "* " THEN + IF c$(3) = " ==" THEN + i = i + 2 + GOTO Special + END IF + IF c$(2) = "==" THEN i = i + 1 - Help_AddTxt CHR$(254) + " ", col, 0 - Help_NewLineIndent = Help_NewLineIndent + 2 + Help_Underline = 1 GOTO Special END IF - IF c$(2) = "**" THEN + + + IF c$(3) = "'''" THEN + i = i + 2 + IF Help_Bold = 0 THEN Help_Bold = 1 ELSE Help_Bold = 0 + col = Help_Col + GOTO Special + END IF + + IF c$(2) = "''" THEN i = i + 1 - Help_AddTxt " " + CHR$(254) + " ", col, 0 - Help_NewLineIndent = Help_NewLineIndent + 6 - GOTO Special - END IF - IF c$ = "*" THEN - Help_AddTxt CHR$(254) + " ", col, 0 - Help_NewLineIndent = Help_NewLineIndent + 2 + IF Help_Italic = 0 THEN Help_Italic = 1 ELSE Help_Italic = 0 + col = Help_Col GOTO Special END IF - END IF + IF nl = 1 THEN - s$ = "{|" - IF c$(LEN(s$)) = s$ THEN - i = i + 1 - FOR ii = i TO LEN(a$) - 1 - IF MID$(a$, ii, 2) = "|}" THEN i = ii + 1: EXIT FOR - NEXT - GOTO Special - END IF - - IF c$(3) = CHR$(226) + CHR$(128) + CHR$(166) THEN '... - i = i + 2 - Help_AddTxt "...", col, 0 - GOTO Special - END IF - - IF c$ = CHR$(226) THEN 'UNICODE UTF8 extender, it's a very good bet the following 2 characters will be 2 bytes of UNICODE - i = i + 2 - GOTO Special - END IF - - IF c$ = ":" AND nl = 1 THEN - Help_AddTxt " ", col, 0 - Help_NewLineIndent = Help_NewLineIndent + 4 - i = i + 1: GOTO special2 - END IF - - s$ = "__NOTOC__" + CHR$(10) - IF c$(LEN(s$)) = s$ THEN - i = i + LEN(s$) - 1 - GOTO Special - END IF - s$ = "__NOTOC__" - IF c$(LEN(s$)) = s$ THEN - i = i + LEN(s$) - 1 - GOTO Special - END IF - - s$ = "<div" - IF c$(LEN(s$)) = s$ THEN - i = i + LEN(s$) - 1 - FOR ii = i TO LEN(a$) - 1 - IF MID$(a$, ii, 12) = "</div>" THEN i = ii + 11: EXIT FOR - NEXT - GOTO Special - END IF - - - IF c$(4) = "----" THEN - i = i + 3 - Help_AddTxt STRING$(100, 196), 8, 0 - GOTO Special - END IF - - - - IF c$ = CHR$(10) THEN - Help_NewLineIndent = 0 - - IF Help_Txt_Len >= 8 THEN - IF ASC(Help_Txt$, Help_Txt_Len - 3) = 13 AND ASC(Help_Txt$, Help_Txt_Len - 7) = 13 THEN GOTO skipdoubleblanks - END IF - - Help_AddTxt CHR$(13), col, 0 - - skipdoubleblanks: - nl = 1 - i = i + 1: GOTO special2 - END IF - - Help_AddTxt CHR$(c), col, 0 - - Special: - i = i + 1 - nl = 0 - special2: -LOOP - -'Trim Help_Txt$ -Help_Txt$ = LEFT$(Help_Txt$, Help_Txt_Len) + CHR$(13) 'chr13 stops reads past end of content - -'generate preview file -'OPEN "help_preview.txt" FOR OUTPUT AS #1 -'FOR i = 1 TO LEN(Help_Txt$) STEP 4 -' c = ASC(Help_Txt$, i) -' c$ = CHR$(c) -' IF c = 13 THEN c$ = CHR$(13) + CHR$(10) -' PRINT #1, c$; -'NEXT -'CLOSE #1 - -'PRINT "Finished parsing!": _DISPLAY - - -IF Help_PageLoaded$ = "Keyword Reference - Alphabetical" THEN - - fh = FREEFILE - OPEN "internal\help\links.bin" FOR OUTPUT AS #fh - a$ = SPACE$(1000) - FOR cy = 1 TO help_h - 'isolate and REVERSE select link - l = CVL(MID$(Help_Line$, (cy - 1) * 4 + 1, 4)) - x = l - x2 = 1 - c = ASC(Help_Txt$, x) - oldlnk = 0 - lnkx1 = 0: lnkx2 = 0 - DO UNTIL c = 13 - ASC(a$, x2) = c - lnk = CVI(MID$(Help_Txt$, x + 2, 2)) - IF oldlnk = 0 AND lnk <> 0 THEN lnkx1 = x2 - IF (lnk = 0 OR ASC(Help_Txt$, x + 4) = 13) AND lnkx1 <> 0 THEN - lnkx2 = x2: IF lnk = 0 THEN lnkx2 = lnkx2 - 1 - - IF lnkx1 <> 3 THEN GOTO ignorelink - IF ASC(a$, 1) <> 254 THEN GOTO ignorelink - - 'retrieve lnk info - lnk2 = lnk: IF lnk2 = 0 THEN lnk2 = oldlnk - l1 = 1 - FOR lx = 1 TO lnk2 - 1 - l1 = INSTR(l1, Help_Link$, Help_Link_Sep$) + 1 - NEXT - l2 = INSTR(l1, Help_Link$, Help_Link_Sep$) - 1 - l$ = MID$(Help_Link$, l1, l2 - l1 + 1) - 'assume PAGE - l$ = RIGHT$(l$, LEN(l$) - 5) - - a2$ = MID$(a$, lnkx1, lnkx2 - lnkx1 + 1) - - IF INSTR(a2$, "(") THEN a2$ = LEFT$(a2$, INSTR(a2$, "(") - 1) - IF INSTR(a2$, " ") THEN a2$ = LEFT$(a2$, INSTR(a2$, " ") - 1) - IF INSTR(a2$, "...") THEN - a3$ = RIGHT$(a2$, LEN(a2$) - INSTR(a2$, "...") - 2) - - skip = 0 - - IF UCASE$(LEFT$(a3$, 3)) <> "_GL" THEN - FOR ci = 1 TO LEN(a3$) - ca = ASC(a3$, ci) - IF ca >= 97 AND ca <= 122 THEN skip = 1 - IF ca = 44 THEN skip = 1 - NEXT - END IF - - IF skip = 0 THEN PRINT #fh, a3$ + "," + l$ - - a2$ = LEFT$(a2$, INSTR(a2$, "...") - 1) - END IF - - - skip = 0 - IF UCASE$(LEFT$(a2$, 3)) <> "_GL" THEN - FOR ci = 1 TO LEN(a2$) - ca = ASC(a2$, ci) - IF ca >= 97 AND ca <= 122 THEN skip = 1 - IF ca = 44 THEN skip = 1 - NEXT - END IF - IF skip = 0 THEN PRINT #fh, a2$ + "," + l$ - oa2$ = a2$ - - a2$ = l$ - IF INSTR(a2$, "(") THEN a2$ = LEFT$(a2$, INSTR(a2$, "(") - 1) - IF INSTR(a2$, " ") THEN a2$ = LEFT$(a2$, INSTR(a2$, " ") - 1) - IF INSTR(a2$, "...") THEN - a3$ = RIGHT$(a2$, LEN(a2$) - INSTR(a2$, "...") - 2) - - skip = 0 - IF UCASE$(LEFT$(a3$, 3)) <> "_GL" THEN - FOR ci = 1 TO LEN(a3$) - ca = ASC(a3$, ci) - IF ca >= 97 AND ca <= 122 THEN skip = 1 - IF ca = 44 THEN skip = 1 - NEXT - END IF - IF skip = 0 THEN PRINT #fh, a3$ + "," + l$ - - a2$ = LEFT$(a2$, INSTR(a2$, "...") - 1) - END IF - - skip = 0 - IF UCASE$(LEFT$(a2$, 3)) <> "_GL" THEN - FOR ci = 1 TO LEN(a2$) - ca = ASC(a2$, ci) - IF ca >= 97 AND ca <= 122 THEN skip = 1 - IF ca = 44 THEN skip = 1 - NEXT - END IF - IF skip = 0 AND a2$ <> oa2$ THEN PRINT #fh, a2$ + "," + l$ - - ignorelink: - - lnkx1 = 0: lnkx2 = 0 + IF c$(3) = "** " THEN + i = i + 2 + Help_AddTxt " " + CHR$(254) + " ", col, 0 + Help_NewLineIndent = Help_NewLineIndent + 6 + GOTO Special + END IF + IF c$(2) = "* " THEN + i = i + 1 + Help_AddTxt CHR$(254) + " ", col, 0 + Help_NewLineIndent = Help_NewLineIndent + 2 + GOTO Special + END IF + IF c$(2) = "**" THEN + i = i + 1 + Help_AddTxt " " + CHR$(254) + " ", col, 0 + Help_NewLineIndent = Help_NewLineIndent + 6 + GOTO Special + END IF + IF c$ = "*" THEN + Help_AddTxt CHR$(254) + " ", col, 0 + Help_NewLineIndent = Help_NewLineIndent + 2 + GOTO Special END IF - x = x + 4: c = ASC(Help_Txt$, x) - x2 = x2 + 1 - oldlnk = lnk - LOOP - NEXT - CLOSE #fh -END IF + END IF + + s$ = "{|" + IF c$(LEN(s$)) = s$ THEN + i = i + 1 + FOR ii = i TO LEN(a$) - 1 + IF MID$(a$, ii, 2) = "|}" THEN i = ii + 1: EXIT FOR + NEXT + GOTO Special + END IF + + IF c$(3) = CHR$(226) + CHR$(128) + CHR$(166) THEN '... + i = i + 2 + Help_AddTxt "...", col, 0 + GOTO Special + END IF + + IF c$ = CHR$(226) THEN 'UNICODE UTF8 extender, it's a very good bet the following 2 characters will be 2 bytes of UNICODE + i = i + 2 + GOTO Special + END IF + + IF c$ = ":" AND nl = 1 THEN + Help_AddTxt " ", col, 0 + Help_NewLineIndent = Help_NewLineIndent + 4 + i = i + 1: GOTO special2 + END IF + + s$ = "__NOTOC__" + CHR$(10) + IF c$(LEN(s$)) = s$ THEN + i = i + LEN(s$) - 1 + GOTO Special + END IF + s$ = "__NOTOC__" + IF c$(LEN(s$)) = s$ THEN + i = i + LEN(s$) - 1 + GOTO Special + END IF + + s$ = "<div" + IF c$(LEN(s$)) = s$ THEN + i = i + LEN(s$) - 1 + FOR ii = i TO LEN(a$) - 1 + IF MID$(a$, ii, 12) = "</div>" THEN i = ii + 11: EXIT FOR + NEXT + GOTO Special + END IF + + + IF c$(4) = "----" THEN + i = i + 3 + Help_AddTxt STRING$(100, 196), 8, 0 + GOTO Special + END IF + + + + IF c$ = CHR$(10) THEN + Help_NewLineIndent = 0 + + IF Help_Txt_Len >= 8 THEN + IF ASC(Help_Txt$, Help_Txt_Len - 3) = 13 AND ASC(Help_Txt$, Help_Txt_Len - 7) = 13 THEN GOTO skipdoubleblanks + END IF + + Help_AddTxt CHR$(13), col, 0 + + skipdoubleblanks: + nl = 1 + i = i + 1: GOTO special2 + END IF + + Help_AddTxt CHR$(c), col, 0 + + Special: + i = i + 1 + nl = 0 + special2: + LOOP + + 'Trim Help_Txt$ + Help_Txt$ = LEFT$(Help_Txt$, Help_Txt_Len) + CHR$(13) 'chr13 stops reads past end of content + + 'generate preview file + 'OPEN "help_preview.txt" FOR OUTPUT AS #1 + 'FOR i = 1 TO LEN(Help_Txt$) STEP 4 + ' c = ASC(Help_Txt$, i) + ' c$ = CHR$(c) + ' IF c = 13 THEN c$ = CHR$(13) + CHR$(10) + ' PRINT #1, c$; + 'NEXT + 'CLOSE #1 + + 'PRINT "Finished parsing!": _DISPLAY + + + IF Help_PageLoaded$ = "Keyword Reference - Alphabetical" THEN + + fh = FREEFILE + OPEN "internal\help\links.bin" FOR OUTPUT AS #fh + a$ = SPACE$(1000) + FOR cy = 1 TO help_h + 'isolate and REVERSE select link + l = CVL(MID$(Help_Line$, (cy - 1) * 4 + 1, 4)) + x = l + x2 = 1 + c = ASC(Help_Txt$, x) + oldlnk = 0 + lnkx1 = 0: lnkx2 = 0 + DO UNTIL c = 13 + ASC(a$, x2) = c + lnk = CVI(MID$(Help_Txt$, x + 2, 2)) + IF oldlnk = 0 AND lnk <> 0 THEN lnkx1 = x2 + IF (lnk = 0 OR ASC(Help_Txt$, x + 4) = 13) AND lnkx1 <> 0 THEN + lnkx2 = x2: IF lnk = 0 THEN lnkx2 = lnkx2 - 1 + + IF lnkx1 <> 3 THEN GOTO ignorelink + IF ASC(a$, 1) <> 254 THEN GOTO ignorelink + + 'retrieve lnk info + lnk2 = lnk: IF lnk2 = 0 THEN lnk2 = oldlnk + l1 = 1 + FOR lx = 1 TO lnk2 - 1 + l1 = INSTR(l1, Help_Link$, Help_Link_Sep$) + 1 + NEXT + l2 = INSTR(l1, Help_Link$, Help_Link_Sep$) - 1 + l$ = MID$(Help_Link$, l1, l2 - l1 + 1) + 'assume PAGE + l$ = RIGHT$(l$, LEN(l$) - 5) + + a2$ = MID$(a$, lnkx1, lnkx2 - lnkx1 + 1) + + IF INSTR(a2$, "(") THEN a2$ = LEFT$(a2$, INSTR(a2$, "(") - 1) + IF INSTR(a2$, " ") THEN a2$ = LEFT$(a2$, INSTR(a2$, " ") - 1) + IF INSTR(a2$, "...") THEN + a3$ = RIGHT$(a2$, LEN(a2$) - INSTR(a2$, "...") - 2) + + skip = 0 + + IF UCASE$(LEFT$(a3$, 3)) <> "_GL" THEN + FOR ci = 1 TO LEN(a3$) + ca = ASC(a3$, ci) + IF ca >= 97 AND ca <= 122 THEN skip = 1 + IF ca = 44 THEN skip = 1 + NEXT + END IF + + IF skip = 0 THEN PRINT #fh, a3$ + "," + l$ + + a2$ = LEFT$(a2$, INSTR(a2$, "...") - 1) + END IF + + + skip = 0 + IF UCASE$(LEFT$(a2$, 3)) <> "_GL" THEN + FOR ci = 1 TO LEN(a2$) + ca = ASC(a2$, ci) + IF ca >= 97 AND ca <= 122 THEN skip = 1 + IF ca = 44 THEN skip = 1 + NEXT + END IF + IF skip = 0 THEN PRINT #fh, a2$ + "," + l$ + oa2$ = a2$ + + a2$ = l$ + IF INSTR(a2$, "(") THEN a2$ = LEFT$(a2$, INSTR(a2$, "(") - 1) + IF INSTR(a2$, " ") THEN a2$ = LEFT$(a2$, INSTR(a2$, " ") - 1) + IF INSTR(a2$, "...") THEN + a3$ = RIGHT$(a2$, LEN(a2$) - INSTR(a2$, "...") - 2) + + skip = 0 + IF UCASE$(LEFT$(a3$, 3)) <> "_GL" THEN + FOR ci = 1 TO LEN(a3$) + ca = ASC(a3$, ci) + IF ca >= 97 AND ca <= 122 THEN skip = 1 + IF ca = 44 THEN skip = 1 + NEXT + END IF + IF skip = 0 THEN PRINT #fh, a3$ + "," + l$ + + a2$ = LEFT$(a2$, INSTR(a2$, "...") - 1) + END IF + + skip = 0 + IF UCASE$(LEFT$(a2$, 3)) <> "_GL" THEN + FOR ci = 1 TO LEN(a2$) + ca = ASC(a2$, ci) + IF ca >= 97 AND ca <= 122 THEN skip = 1 + IF ca = 44 THEN skip = 1 + NEXT + END IF + IF skip = 0 AND a2$ <> oa2$ THEN PRINT #fh, a2$ + "," + l$ + + ignorelink: + + lnkx1 = 0: lnkx2 = 0 + END IF + x = x + 4: c = ASC(Help_Txt$, x) + x2 = x2 + 1 + oldlnk = lnk + LOOP + NEXT + CLOSE #fh + + END IF diff --git a/source/qb64.bas b/source/qb64.bas index 909bace67..887a2d474 100644 --- a/source/qb64.bas +++ b/source/qb64.bas @@ -12672,197 +12672,197 @@ IF ConsoleMode THEN SYSTEM 1 END 1 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$) = "-help" OR LCASE$(token$) = "--help" OR LCASE$(token$) = "-h" OR LCASE$(token$) = "/help" THEN token$ = "-?" - SELECT CASE LCASE$(LEFT$(token$, 2)) - CASE "-?" 'Command-line help - _DEST _CONSOLE - 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 " -x Compile instead of edit and output the result to the" - PRINT " console" - PRINT " -p Purge all pre-compiled content first" - PRINT " -z Generate C code without compiling to executable" - PRINT " -o Write output executable to " - PRINT " -e Enables 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: Starts the IDE at the specified line number" - PRINT - SYSTEM - 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" + '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$) = "-help" OR LCASE$(token$) = "--help" OR LCASE$(token$) = "-h" OR LCASE$(token$) = "/help" THEN token$ = "-?" + SELECT CASE LCASE$(LEFT$(token$, 2)) + CASE "-?" 'Command-line help + _DEST _CONSOLE + 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 " -x Compile instead of edit and output the result to the" + PRINT " console" + PRINT " -p Purge all pre-compiled content first" + PRINT " -z Generate C code without compiling to executable" + PRINT " -o Write output executable to " + PRINT " -e Enables 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: Starts the IDE at the specified line number" + PRINT + SYSTEM + CASE "-p" 'Purge + IF os$ = "WIN" THEN + CHDIR "internal\c" + SHELL _HIDE "cmd /c purge_all_precompiled_content_win.bat" + CHDIR "..\.." END IF - CHDIR "../.." - END IF - CASE "-s" 'Settings - _DEST _CONSOLE - 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" - SYSTEM - CASE ":exewithsource=false" - WriteConfigSetting "'[GENERAL SETTINGS]", "SaveExeWithSource", "FALSE" - PRINT "exewithsource = FALSE" - SYSTEM - 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$ = "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" + 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 "-s" 'Settings + _DEST _CONSOLE + 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" + SYSTEM + CASE ":exewithsource=false" + WriteConfigSetting "'[GENERAL SETTINGS]", "SaveExeWithSource", "FALSE" + PRINT "exewithsource = FALSE" + SYSTEM + 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 - CHDIR "../.." - END IF - SYSTEM - 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$ = "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" + 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 - CHDIR "../.." - END IF - SYSTEM - 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 - CASE "-e" 'Option Explicit - optionexplicit_cmd = -1 - CASE "-z" 'Not compiling C code - No_C_Compile_Mode = 1 - ConsoleMode = 1 'Implies -x - NoIDEMode = 1 'Implies -c - CASE "-x" 'Use the console - ConsoleMode = 1 - NoIDEMode = 1 'Implies -c - CASE "-c" 'Compile instead of edit - NoIDEMode = 1 - CASE "-o" 'Specify an output file - IF LEN(COMMAND$(i + 1)) > 0 THEN outputfile_cmd$ = COMMAND$(i + 1): i = i + 1 - CASE "-l" 'goto line (ide mode only); -l: - IF MID$(token$, 3, 1) = ":" THEN ideStartAtLine = VAL(MID$(token$, 4)) - CASE ELSE 'Something we don't recognise, assume it's a filename - IF PassedFileName$ = "" THEN PassedFileName$ = token$ - END SELECT -NEXT i + SYSTEM + 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 LEN(PassedFileName$) THEN ParseCMDLineArgs$ = PassedFileName$ + 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 + SYSTEM + 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 + CASE "-e" 'Option Explicit + optionexplicit_cmd = -1 + CASE "-z" 'Not compiling C code + No_C_Compile_Mode = 1 + ConsoleMode = 1 'Implies -x + NoIDEMode = 1 'Implies -c + CASE "-x" 'Use the console + ConsoleMode = 1 + NoIDEMode = 1 'Implies -c + CASE "-c" 'Compile instead of edit + NoIDEMode = 1 + CASE "-o" 'Specify an output file + IF LEN(COMMAND$(i + 1)) > 0 THEN outputfile_cmd$ = COMMAND$(i + 1): i = i + 1 + CASE "-l" 'goto line (ide mode only); -l: + IF MID$(token$, 3, 1) = ":" THEN ideStartAtLine = VAL(MID$(token$, 4)) + 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 ParseCMDLineArgs$ = PassedFileName$ END FUNCTION FUNCTION Type2MemTypeValue (t1) -t = 0 -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 - t = t + 32768 - END IF -ELSE - IF t1 AND ISSTRING THEN - t = t + 512 'string - ELSE - IF t1 AND ISFLOAT THEN - t = t + 256 'float + t = 0 + 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 - t = t + 128 'integer - IF t1 AND ISUNSIGNED THEN t = t + 1024 - IF t1 AND ISOFFSET THEN t = t + 8192 'offset type + t = t + 32768 + END IF + ELSE + IF t1 AND ISSTRING THEN + t = t + 512 'string + ELSE + IF t1 AND ISFLOAT THEN + t = t + 256 'float + 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 - 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 + Type2MemTypeValue = t 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 + 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 -RemoveFileExtension$ = 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 RemoveFileExtension$ = LEFT$(f$, i - 1): EXIT FUNCTION + NEXT + RemoveFileExtension$ = f$ END FUNCTION @@ -12871,702 +12871,956 @@ END FUNCTION FUNCTION allocarray (n2$, elements$, elementsize) -dimsharedlast = dimshared: dimshared = 0 + 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$ = "" + f12$ = "" -'changelog: -'added 4 to [2] to indicate cmem array where appropriate + 'changelog: + 'added 4 to [2] to indicate cmem array where appropriate -e$ = elements$: n$ = n2$ -IF elementsize = -2147483647 THEN stringarray = 1: elementsize = 8 + e$ = elements$: n$ = n2$ + IF elementsize = -2147483647 THEN stringarray = 1: elementsize = 8 -IF ASC(e$) = 63 THEN '? - l$ = "(" + sp2 + ")" - undefined = -1 + IF ASC(e$) = 63 THEN '? + l$ = "(" + sp2 + ")" + undefined = -1 + nume = 1 + IF LEN(e$) = 1 THEN GOTO undefinedarray + undefined = 1 + nume = VAL(RIGHT$(e$, LEN(e$) - 1)) + GOTO undefinedarray + END IF + + + 'work out how many elements there are (critical to later calculations) nume = 1 - IF LEN(e$) = 1 THEN GOTO undefinedarray - undefined = 1 - nume = VAL(RIGHT$(e$, LEN(e$) - 1)) - GOTO undefinedarray -END IF + n = numelements(e$) + 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 + descstatic = 0 + IF arraydesc THEN + IF id.arrayelements <> nume THEN -'work out how many elements there are (critical to later calculations) -nume = 1 -n = numelements(e$) -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 - -descstatic = 0 -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! - arrayelementslist(currentid) = nume - 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 - -l$ = "(" + sp2 - -cr$ = CHR$(13) + CHR$(10) -sd$ = "" -constdimensions = 1 -ei = 4 + nume * 4 - 4 -cure = 1 -e3$ = "": e3base$ = "" -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) - 'PRINT e3base$ + "[TO]" + e3$ - 'set the base - - basegiven = 1 - 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 + "TO" + sp - e3base$ = evaluatetotyp$(e3base$, 64&) - IF Error_Happened THEN EXIT FUNCTION - - 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 - l$ = l$ + tlayout$ + sp2 - IF i = n THEN l$ = l$ + ")" ELSE l$ = l$ + "," + sp - e3$ = evaluatetotyp$(e3$, 64&) - IF Error_Happened THEN EXIT FUNCTION - - 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 - 'set only for the purpose of the calculating correct multipliers - sd$ = sd$ + n$ + "[" + str2(ei) + "]=1;" + cr$ - ELSE - sd$ = sd$ + n$ + "[" + str2(ei) + "]=" + n$ + "[" + str2(ei + 4) + "]*" + n$ + "[" + str2(ei + 3) + "];" + cr$ - 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 - e3base$ = e3$ - e3$ = "" - ELSE - e3$ = e3$ + sp + e2$ - END IF - aanexte: -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 - -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 arraydesc THEN - IF staticarray = 1 THEN - IF descstatic THEN Give_Error "Cannot redefine a static array!": EXIT FUNCTION - staticarray = 0 - END IF -END IF - - - - - - -bytesperelement$ = str2(elementsize) -IF elementsize < 0 THEN - elementsize = -elementsize - bytesperelement$ = str2(elementsize) + "/8+1" -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 - '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 - -'generate sizestr$ & elesizestr$ (both are used in various places in following code) -sizestr$ = "" -FOR i = 1 TO nume - IF i <> 1 THEN sizestr$ = sizestr$ + "*" - sizestr$ = sizestr$ + n$ + "[" + str2(i * 4 - 4 + 5) + "]" -NEXT -elesizestr$ = sizestr$ 'elements in entire array -sizestr$ = sizestr$ + "*" + bytesperelement$ 'bytes in entire array - - - -'------------------STATIC ARRAY CREATION-------------------------------- -IF staticarray THEN - 'STATIC memory - 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 - 'Note: A string array's pointers are always stored in 64bit memory - '(static)CONVENTINAL memory - 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);" - '64K check - PRINT #13, "if ((" + sizestr$ + ")>65536) error(257);" - 'clear array - PRINT #13, "memset((void*)(" + n$ + "[0]),0," + sizestr$ + ");" - 'set flags - 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 - '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);" + 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 - PRINT #13, "((uint64*)(" + n$ + "[0]))[tmp_long]=(uint64)qbs_new(0,0);" + Give_Error "Cannot change the number of elements an array has!": EXIT FUNCTION END IF - PRINT #13, "}" + + END IF + IF id.staticarray THEN descstatic = 1 + END IF + + l$ = "(" + sp2 + + cr$ = CHR$(13) + CHR$(10) + sd$ = "" + constdimensions = 1 + ei = 4 + nume * 4 - 4 + cure = 1 + e3$ = "": e3base$ = "" + 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) + 'PRINT e3base$ + "[TO]" + e3$ + 'set the base + + basegiven = 1 + 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 + "TO" + sp + e3base$ = evaluatetotyp$(e3base$, 64&) + IF Error_Happened THEN EXIT FUNCTION + + 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 + l$ = l$ + tlayout$ + sp2 + IF i = n THEN l$ = l$ + ")" ELSE l$ = l$ + "," + sp + e3$ = evaluatetotyp$(e3$, 64&) + IF Error_Happened THEN EXIT FUNCTION + + 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 + 'set only for the purpose of the calculating correct multipliers + sd$ = sd$ + n$ + "[" + str2(ei) + "]=1;" + cr$ + ELSE + sd$ = sd$ + n$ + "[" + str2(ei) + "]=" + n$ + "[" + str2(ei + 4) + "]*" + n$ + "[" + str2(ei + 3) + "];" + cr$ + 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 + e3base$ = e3$ + e3$ = "" ELSE + e3$ = e3$ + sp + e2$ + END IF + aanexte: + 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 + + 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 arraydesc THEN + IF staticarray = 1 THEN + IF descstatic THEN Give_Error "Cannot redefine a static array!": EXIT FUNCTION + staticarray = 0 + END IF + END IF + + + + + + + bytesperelement$ = str2(elementsize) + IF elementsize < 0 THEN + elementsize = -elementsize + bytesperelement$ = str2(elementsize) + "/8+1" + 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 + '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 + + 'generate sizestr$ & elesizestr$ (both are used in various places in following code) + sizestr$ = "" + FOR i = 1 TO nume + IF i <> 1 THEN sizestr$ = sizestr$ + "*" + sizestr$ = sizestr$ + n$ + "[" + str2(i * 4 - 4 + 5) + "]" + NEXT + elesizestr$ = sizestr$ 'elements in entire array + sizestr$ = sizestr$ + "*" + bytesperelement$ 'bytes in entire array + + + + '------------------STATIC ARRAY CREATION-------------------------------- + IF staticarray THEN + 'STATIC memory + 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 + 'Note: A string array's pointers are always stored in 64bit memory + '(static)CONVENTINAL memory + 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);" + '64K check + PRINT #13, "if ((" + sizestr$ + ")>65536) error(257);" 'clear array PRINT #13, "memset((void*)(" + n$ + "[0]),0," + sizestr$ + ");" - END IF - PRINT #13, n$ + "[2]=1+2;" 'init+static - END IF - 'Close static array desc - PRINT #13, "}" - allocarray = nume + 65536 -END IF -'------------------END OF STATIC ARRAY CREATION------------------------- - -'------------------DYNAMIC ARRAY CREATION------------------------------- -IF staticarray = 0 THEN - - IF undefined = 0 THEN - - - - 'Generate error if array is static - f12$ = f12$ + CRLF + "if (" + n$ + "[2]&2){" 'static array - f12$ = f12$ + CRLF + "error(10);" 'cannot redefine a static array! - f12$ = f12$ + CRLF + "}else{" - 'Note: Array is either undefined or dynamically defined at this point - - - 'REDIM (not DIM) must be used to redefine an array - 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{" + 'set flags + PRINT #13, n$ + "[2]=1+2+4;" 'init+static+cmem ELSE - '--------ERASE EXISTING ARRAY IF NECESSARY-------- - - 'IMPORTANT: If array is not going to be preserved, it should be cleared before - ' creating the new array for memory considerations - - '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 - f12$ = f12$ + CRLF + "static int32 preserved_elements;" 'must be put here for scope considerations - 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 - f12$ = f12$ + CRLF + "preserved_elements=" + elesizestr$ + ";" - GOTO skiperase - END IF - - 'Note: pointers to strings must be freed before array can be freed + '64BIT MEMORY + PRINT #13, n$ + "[0]=(ptrszint)mem_static_malloc(" + sizestr$ + ");" 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 - 'Free array's memory - IF stringarray THEN - 'Note: String arrays are never in cmem - f12$ = f12$ + CRLF + "free((void*)(" + n$ + "[0]));" + '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 - '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 + "}" + 'clear array + PRINT #13, "memset((void*)(" + n$ + "[0]),0," + sizestr$ + ");" END IF - - skiperase: - - f12$ = f12$ + CRLF + "}" 'array was defined - IF redimoption = 2 THEN - f12$ = f12$ + CRLF + "else preserved_elements=0;" 'if array wasn't defined, no elements are preserved - END IF - - - '--------ERASED ARRAY AS NECESSARY-------- - END IF 'redim specified - - - '--------CREATE ARRAY & CLEAN-UP CODE-------- - 'Overwrite existing array dimension sizes/ranges - f12$ = f12$ + CRLF + sd$ - IF stringarray THEN - - 'Note: String arrays are always created in 64bit memory - - IF redimoption = 2 THEN - f12$ = f12$ + CRLF + "if (preserved_elements){" - - f12$ = f12$ + CRLF + "static ptrszint tmp_long2;" - - 'free any qbs strings which will be lost in the realloc - f12$ = f12$ + CRLF + "tmp_long=" + elesizestr$ + ";" - f12$ = f12$ + CRLF + "if (tmp_longid=(++mem_lock_id);" + + IF redimoption = 2 THEN + f12$ = f12$ + CRLF + "static int32 preserved_elements;" 'must be put here for scope considerations + 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 + f12$ = f12$ + CRLF + "preserved_elements=" + elesizestr$ + ";" + GOTO skiperase + END IF + + 'Note: pointers to strings must be freed before array can be freed + 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 + 'Free array's memory + IF stringarray THEN + 'Note: String arrays are never in cmem + f12$ = f12$ + CRLF + "free((void*)(" + n$ + "[0]));" + 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 + + skiperase: + + f12$ = f12$ + CRLF + "}" 'array was defined + IF redimoption = 2 THEN + f12$ = f12$ + CRLF + "else preserved_elements=0;" 'if array wasn't defined, no elements are preserved + END IF + + + '--------ERASED ARRAY AS NECESSARY-------- + END IF 'redim specified + + + '--------CREATE ARRAY & CLEAN-UP CODE-------- + 'Overwrite existing array dimension sizes/ranges + f12$ = f12$ + CRLF + sd$ + IF stringarray THEN + + 'Note: String arrays are always created in 64bit memory + + IF redimoption = 2 THEN + f12$ = f12$ + CRLF + "if (preserved_elements){" + + f12$ = f12$ + CRLF + "static ptrszint tmp_long2;" + + 'free any qbs strings which will be lost in the realloc + f12$ = f12$ + CRLF + "tmp_long=" + elesizestr$ + ";" + f12$ = f12$ + CRLF + "if (tmp_long 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 - -curarg = 1 -firsti = 1 -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 - e$ = evaluatetotyp(getelements$(a$, firsti, i), 64&) - 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 - argi = (elements - curarg) * 4 + 4 - IF curarg = 1 THEN - r$ = r$ + "array_check((" + e$ + ")-" + n$ + "[" + str2(argi) + "]," + n$ + "[" + str2(argi + 1) + "])+" - ELSE - r$ = r$ + "array_check((" + e$ + ")-" + n$ + "[" + str2(argi) + "]," + n$ + "[" + str2(argi + 1) + "])*" + n$ + "[" + str2(argi + 2) + "]+" - END IF - firsti = i + 1 - curarg = curarg + 1 + IF a$ = "" THEN 'no indexes passed eg. a() + r$ = "0" + GOTO gotarrayindex END IF -NEXT -r$ = LEFT$(r$, LEN(r$) - 1) 'remove trailing + -gotarrayindex: -r$ = idnumber$ + sp3 + r$ -arrayreference$ = r$ -'PRINT "arrayreference returning:" + r$ + n = numelements(a$) + + 'find number of elements supplied + elements = 1 + b = 0 + FOR i = 1 TO n + a = ASC(getelement(a$, i)) + IF a = 40 THEN b = b + 1 + IF a = 41 THEN b = b - 1 + IF a = 44 AND b = 0 THEN elements = elements + 1 + NEXT + + 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 + + curarg = 1 + firsti = 1 + 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 + e$ = evaluatetotyp(getelements$(a$, firsti, i), 64&) + 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 + argi = (elements - curarg) * 4 + 4 + IF curarg = 1 THEN + r$ = r$ + "array_check((" + e$ + ")-" + n$ + "[" + str2(argi) + "]," + n$ + "[" + str2(argi + 1) + "])+" + ELSE + r$ = r$ + "array_check((" + e$ + ")-" + n$ + "[" + str2(argi) + "]," + n$ + "[" + str2(argi + 1) + "])*" + n$ + "[" + str2(argi + 2) + "]+" + END IF + firsti = i + 1 + curarg = curarg + 1 + END IF + NEXT + r$ = LEFT$(r$, LEN(r$) - 1) 'remove trailing + + gotarrayindex: + + r$ = idnumber$ + sp3 + r$ + arrayreference$ = r$ + 'PRINT "arrayreference returning:" + r$ 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 + 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 - 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 - try = findid(a2$) + a2$ = fixoperationorder(getelements$(a$, 1, i - 1)) 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 + 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 + 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 + makeidrefer a2$, typ + GOTO assignsimplevariable + END IF 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 + 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 - assignsimplevariable: - 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 - tlayout$ = l$ + tlayout$ + a2$ = evaluate$(a2$, typ): IF Error_Happened THEN EXIT SUB + assignsimplevariable: + 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 + tlayout$ = l$ + tlayout$ - EXIT SUB + EXIT SUB - END IF '=,b=0 -NEXT -Give_Error "Expected =": EXIT SUB + END IF '=,b=0 + NEXT + Give_Error "Expected =": EXIT SUB END SUB SUB clearid -id = cleariddata + id = cleariddata END SUB SUB closemain -xend + 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 + closedmain = 1 END SUB FUNCTION countelements (a$) -n = numelements(a$) -c = 1 -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 -countelements = c + n = numelements(a$) + c = 1 + 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 + countelements = c END FUNCTION FUNCTION dim2 (varname$, typ2$, method, elements$) -'notes: (DO NOT REMOVE THESE IMPORTANT USAGE NOTES) -' -'(shared)dimsfarray: Creates an ID only (no C++ code) -' Adds an index/'link' to the sub/function's argument -' ID.sfid=glinkid -' ID.sfarg=glinkarg -' Sets arrayelements=-1 'unknown' (if elements$="?") otherwise val(elements$) -' ***Does not refer to arrayelementslist()*** -' -'(argument)method: 0 being created by a DIM name AS type -' 1 being created by a DIM name+symbol -' or automatically without the use of DIM -' -'elements$="?": (see also dimsfarray for that special case) -' Checks arrayelementslist() and; -' if unknown(=0), creates an ID only -' if known, creates a DYNAMIC array's C++ initialization code so it can be used later + 'notes: (DO NOT REMOVE THESE IMPORTANT USAGE NOTES) + ' + '(shared)dimsfarray: Creates an ID only (no C++ code) + ' Adds an index/'link' to the sub/function's argument + ' ID.sfid=glinkid + ' ID.sfarg=glinkarg + ' Sets arrayelements=-1 'unknown' (if elements$="?") otherwise val(elements$) + ' ***Does not refer to arrayelementslist()*** + ' + '(argument)method: 0 being created by a DIM name AS type + ' 1 being created by a DIM name+symbol + ' or automatically without the use of DIM + ' + 'elements$="?": (see also dimsfarray for that special case) + ' Checks arrayelementslist() and; + ' if unknown(=0), creates an ID only + ' if known, creates a DYNAMIC array's C++ initialization code so it can be used later -typ$ = typ2$ -dim2 = 1 'success + 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$) + cvarname$ = varname$ + l$ = cvarname$ + 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 - '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 + 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 -scope2$ = module$ + "_" + subfunc$ + "_" -'Note: when REDIMing a SHARED array in dynamic memory scope2$ must be modified + 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)) THEN - dim2typepassback$ = RTRIM$(udtxcname(i)) + 'UDT + 'is it a udt? + FOR i = 1 TO lasttype + IF typ$ = RTRIM$(udtxname(i)) THEN + dim2typepassback$ = RTRIM$(udtxcname(i)) - n$ = "UDT_" + varname$ + n$ = "UDT_" + varname$ - 'array of UDTs + 'array of UDTs + IF elements$ <> "" THEN + arraydesc = 0 + IF f = 1 THEN + try = findid(varname$) + 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 + 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 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 + nume = allocarray(n$, elements$, -bits) + IF Error_Happened THEN EXIT FUNCTION + l$ = l$ + sp + tlayout$ + IF arraydesc THEN GOTO dim2exitfunc + clearid + + ELSE + clearid + IF elements$ = "?" THEN + nume = -1 + id.linkid = glinkid + id.linkarg = glinkarg + ELSE + nume = VAL(elements$) + END IF + END IF + + id.arraytype = UDTTYPE + i + IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY + id.n = cvarname$ + + 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 + + 'not an array of UDTs + bits = udtxsize(i): bytes = bits \ 8 + IF bits MOD 8 THEN + bytes = bytes + 1 + END IF + n$ = scope2$ + n$ + IF f THEN PRINT #defdatahandle, "void *" + n$ + "=NULL;" + clearid + id.n = cvarname$ + id.t = UDTTYPE + i + 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_sp 6 THEN + IF LEFT$(typ$, 9) <> "STRING * " THEN Give_Error "Expected STRING * number/constant": EXIT FUNCTION + + 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 + hashfound = 1 + 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 + 'convert value to general formats + IF t AND ISFLOAT THEN + v## = constfloat(i2) + v&& = v## + v~&& = v&& + ELSE + IF t AND ISUNSIGNED THEN + v~&& = constuinteger(i2) + v&& = v~&& + v## = v&& + 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 + bytes = v&& + 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 + constantlenstr: + n$ = "STRING" + str2(bytes) + "_" + varname$ + + 'array of fixed length strings + IF elements$ <> "" THEN + arraydesc = 0 + IF f = 1 THEN + try = findid(varname$ + "$") + 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 + n$ = scope2$ + "ARRAY_" + n$ + + 'nume = allocarray(n$, elements$, bytes) + 'IF arraydesc THEN goto dim2exitfunc 'id already exists! + 'clearid + + 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 + nume = allocarray(n$, elements$, bytes) + IF Error_Happened THEN EXIT FUNCTION + l$ = l$ + sp + tlayout$ + IF arraydesc THEN GOTO dim2exitfunc + clearid + + ELSE + clearid + IF elements$ = "?" THEN + nume = -1 + id.linkid = glinkid + id.linkarg = glinkarg + ELSE + nume = VAL(elements$) + END IF + END IF + + id.arraytype = STRINGTYPE + ISFIXEDLENGTH + IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY + id.n = cvarname$ + IF nume > 65536 THEN nume = nume - 65536: id.staticarray = 1 + + id.arrayelements = nume + id.callname = n$ + id.tsize = bytes + IF method = 0 THEN + id.mayhave = "$" + str2(bytes) + END IF + IF method = 1 THEN + id.musthave = "$" + str2(bytes) + END IF + regid + 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 + clearid + id.n = cvarname$ + id.t = STRINGTYPE + ISFIXEDLENGTH + 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){" + 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 + id.tsize = bytes + IF method = 0 THEN + id.mayhave = "$" + str2(bytes) + END IF + IF method = 1 THEN + id.musthave = "$" + str2(bytes) + END IF + regid + 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 arraydesc = 0 IF f = 1 THEN - try = findid(varname$) + try = findid(varname$ + "$") IF Error_Happened THEN EXIT FUNCTION DO WHILE try IF (id.arraytype) THEN @@ -13574,16 +13828,121 @@ FOR i = 1 TO lasttype arraydesc = currentid: scope2$ = scope$ EXIT DO END IF - IF try = 2 THEN findanotherid = 1: try = findid(varname$) ELSE try = 0 + 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) + + 'nume = allocarray(n$, elements$, -2147483647) '-2147483647=STRING + 'IF arraydesc THEN goto dim2exitfunc 'id already exists! + 'clearid + + 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 + nume = allocarray(n$, elements$, -2147483647) + IF Error_Happened THEN EXIT FUNCTION + l$ = l$ + sp + tlayout$ + IF arraydesc THEN GOTO dim2exitfunc + clearid + + ELSE + clearid + IF elements$ = "?" THEN + nume = -1 + id.linkid = glinkid + id.linkarg = glinkarg + 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 + + id.arrayelements = nume + id.callname = n$ + IF method = 0 THEN + id.mayhave = "$" + END IF + IF method = 1 THEN + id.musthave = "$" + END IF + regid + 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);" + 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 + id.mayhave = "$" + END IF + IF method = 1 THEN + id.musthave = "$" + END IF + regid + IF Error_Happened THEN EXIT FUNCTION + GOTO dim2exitfunc + END IF + + IF LEFT$(typ$, 4) = "_BIT" THEN + IF LEN(typ$) > 4 THEN + IF LEFT$(typ$, 7) <> "_BIT * " THEN Give_Error "Expected _BIT * number": EXIT FUNCTION + c$ = RIGHT$(typ$, LEN(typ$) - 7) + 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$ + n$ = n$ + "BIT" + str2(bits) + "_" + varname$ + + 'array of bit-length variables + IF elements$ <> "" THEN + arraydesc = 0 + cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" + cmps$ = cmps$ + "`" + str2(bits) + IF f = 1 THEN + try = findid(cmps$) + 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 + 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 LEN(elements$) = 1 AND ASC(elements$) = 63 THEN '"?" @@ -13606,73 +13965,7692 @@ FOR i = 1 TO lasttype END IF END IF - id.arraytype = UDTTYPE + i - IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY 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 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 regid 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 - bytes = bytes + 1 - END IF + 'standard bit-length variable n$ = scope2$ + n$ - IF f THEN PRINT #defdatahandle, "void *" + n$ + "=NULL;" + PRINT #defdatahandle, ct$ + " *" + n$ + "=NULL;" + PRINT #13, "if(" + n$ + "==NULL){" + PRINT #13, "cmem_sp-=4;" + PRINT #13, "if (cmem_sp "" THEN + arraydesc = 0 + cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" + cmps$ = cmps$ + "%%" + IF f = 1 THEN + try = findid(cmps$) + 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 -'check if _UNSIGNED was specified -unsgn = 0 -IF LEFT$(typ$, 10) = "_UNSIGNED " THEN - unsgn = 1 - typ$ = RIGHT$(typ$, LEN(typ$) - 10) - IF LEN(typ$) = 0 THEN Give_Error "Expected more type information after _UNSIGNED!": EXIT FUNCTION -END IF + END IF + n$ = scope2$ + "ARRAY_" + n$ -n$ = "" 'n$ is assumed to be "" after branching into the code for each type + 'nume = allocarray(n$, elements$, 1) + 'IF arraydesc THEN goto dim2exitfunc + 'clearid -IF LEFT$(typ$, 6) = "STRING" THEN + IF f = 1 THEN - IF LEN(typ$) > 6 THEN - IF LEFT$(typ$, 9) <> "STRING * " THEN Give_Error "Expected STRING * number/constant": EXIT FUNCTION + 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) + IF Error_Happened THEN EXIT FUNCTION + l$ = l$ + sp + tlayout$ + IF arraydesc THEN GOTO dim2exitfunc + clearid - c$ = RIGHT$(typ$, LEN(typ$) - 9) + ELSE + clearid + IF elements$ = "?" THEN + nume = -1 + id.linkid = glinkid + id.linkarg = glinkarg + 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.arrayelements = nume + id.callname = n$ + 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 = 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 + arraydesc = 0 + cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" + cmps$ = cmps$ + "%" + IF f = 1 THEN + try = findid(cmps$) + 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 + n$ = scope2$ + "ARRAY_" + n$ + + 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 + nume = allocarray(n$, elements$, 2) + IF Error_Happened THEN EXIT FUNCTION + l$ = l$ + sp + tlayout$ + IF arraydesc THEN GOTO dim2exitfunc + clearid + + ELSE + clearid + IF elements$ = "?" THEN + nume = -1 + id.linkid = glinkid + id.linkarg = glinkarg + 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.arrayelements = nume + id.callname = n$ + 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 = 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 + arraydesc = 0 + cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" + cmps$ = cmps$ + "%&" + IF f = 1 THEN + try = findid(cmps$) + 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 + n$ = scope2$ + "ARRAY_" + n$ + + 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 + nume = allocarray(n$, elements$, OS_BITS \ 8) + IF Error_Happened THEN EXIT FUNCTION + l$ = l$ + sp + tlayout$ + IF arraydesc THEN GOTO dim2exitfunc + clearid + + ELSE + clearid + IF elements$ = "?" THEN + nume = -1 + id.linkid = glinkid + id.linkarg = glinkarg + 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.arrayelements = nume + id.callname = n$ + 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 = 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 + arraydesc = 0 + cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" + cmps$ = cmps$ + "&" + IF f = 1 THEN + try = findid(cmps$) + 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 + n$ = scope2$ + "ARRAY_" + n$ + + 'nume = allocarray(n$, elements$, 4) + 'IF arraydesc THEN goto dim2exitfunc + 'clearid + + 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 + nume = allocarray(n$, elements$, 4) + IF Error_Happened THEN EXIT FUNCTION + l$ = l$ + sp + tlayout$ + IF arraydesc THEN GOTO dim2exitfunc + clearid + + ELSE + clearid + IF elements$ = "?" THEN + nume = -1 + id.linkid = glinkid + id.linkarg = glinkarg + 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.arrayelements = nume + id.callname = n$ + 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 = 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 + arraydesc = 0 + cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" + cmps$ = cmps$ + "&&" + IF f = 1 THEN + try = findid(cmps$) + 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 + n$ = scope2$ + "ARRAY_" + n$ + + 'nume = allocarray(n$, elements$, 8) + 'IF arraydesc THEN goto dim2exitfunc + 'clearid + + 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 + nume = allocarray(n$, elements$, 8) + IF Error_Happened THEN EXIT FUNCTION + l$ = l$ + sp + tlayout$ + IF arraydesc THEN GOTO dim2exitfunc + clearid + + ELSE + clearid + IF elements$ = "?" THEN + nume = -1 + id.linkid = glinkid + id.linkarg = glinkarg + 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.arrayelements = nume + id.callname = n$ + 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 = 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 + arraydesc = 0 + cmps$ = varname$ + "!" + IF f = 1 THEN + try = findid(cmps$) + 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 + n$ = scope2$ + "ARRAY_" + n$ + + 'nume = allocarray(n$, elements$, 4) + 'IF arraydesc THEN goto dim2exitfunc + 'clearid + + 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 + nume = allocarray(n$, elements$, 4) + IF Error_Happened THEN EXIT FUNCTION + l$ = l$ + sp + tlayout$ + IF arraydesc THEN GOTO dim2exitfunc + clearid + + ELSE + clearid + IF elements$ = "?" THEN + nume = -1 + id.linkid = glinkid + id.linkarg = glinkarg + 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 + + id.arrayelements = nume + id.callname = n$ + 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 + 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 + arraydesc = 0 + cmps$ = varname$ + "#" + IF f = 1 THEN + try = findid(cmps$) + 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 + n$ = scope2$ + "ARRAY_" + n$ + + 'nume = allocarray(n$, elements$, 8) + 'IF arraydesc THEN goto dim2exitfunc + 'clearid + + 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 + nume = allocarray(n$, elements$, 8) + IF Error_Happened THEN EXIT FUNCTION + l$ = l$ + sp + tlayout$ + IF arraydesc THEN GOTO dim2exitfunc + clearid + + ELSE + clearid + IF elements$ = "?" THEN + nume = -1 + id.linkid = glinkid + id.linkarg = glinkarg + 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 + + id.arrayelements = nume + id.callname = n$ + 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 + 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 + arraydesc = 0 + cmps$ = varname$ + "##" + IF f = 1 THEN + try = findid(cmps$) + 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 + n$ = scope2$ + "ARRAY_" + n$ + + 'nume = allocarray(n$, elements$, 32) + 'IF arraydesc THEN goto dim2exitfunc + 'clearid + + 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 + nume = allocarray(n$, elements$, 32) + IF Error_Happened THEN EXIT FUNCTION + l$ = l$ + sp + tlayout$ + IF arraydesc THEN GOTO dim2exitfunc + clearid + + ELSE + clearid + IF elements$ = "?" THEN + nume = -1 + id.linkid = glinkid + id.linkarg = glinkarg + 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 + + id.arrayelements = nume + id.callname = n$ + 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 + 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 + 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 + + tlayout$ = l$ + +END FUNCTION + + +FUNCTION udtreference$ (o$, a$, typ AS LONG) + 'UDT REFERENCE FORMAT + 'idno|udtno|udtelementno|byteoffset + ' ^udt of the element, not of the id + + obak$ = o$ + + 'PRINT "called udtreference!" + + + r$ = str2$(currentid) + sp3 + + + 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 + E = 0 + + n = numelements(a$) + IF n = 0 THEN GOTO fulludt + + i = 1 + udtfindelenext: + 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 + + 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 n$ <> n2$ THEN + 'increment fixed offset + o = o + udtesize(E) + GOTO udtfindele + END IF + + 'check symbol after element's name (if given) is correct + 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 + 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 + E = 0 + i = i + 1 + GOTO udtfindelenext + END IF + + 'Change e reference to u CHR$(179) 0 reference? + IF udtetype(E) AND ISUDT THEN + u = udtetype(E) AND 511 + E = 0 + 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 + o = o \ 8 + + IF o$ <> "" THEN + IF o <> 0 THEN 'dont add an unnecessary 0 + o$ = o$ + "+" + str2$(o) + END IF + ELSE + o$ = str2$(o) + END IF + + r$ = r$ + o$ + + udtreference$ = r$ + typ = udtetype(E) + ISUDT + ISREFERENCE + + 'full udt override: + IF E = 0 THEN + typ = u + ISUDT + ISREFERENCE + END IF + + IF obak$ <> "" THEN typ = typ + ISARRAY + IF incmem THEN typ = typ + ISINCONVENTIONALMEMORY + + 'print "UDTREF:"+r$+","+str2$(typ) + +END FUNCTION + +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 + + + + + + + '''cl$ = classify(a$) + + blockn = 0 + n = numelements(a$) + b = 0 'bracketting level + FOR i = 1 TO n + + reevaluate: + + + + + l$ = getelement(a$, i) + + + IF Debug THEN PRINT #9, "#*#*#* reevaluating:" + l$, i + + + 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 Debug THEN PRINT #9, l$ + + l2$ = l$ 'pure version of l$ + 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 + l$ = l$ + defineextaz(v) + END IF + END IF + ELSE + l$ = l2$ + END IF + END IF + try = findid(l$) + IF Error_Happened THEN EXIT FUNCTION + DO WHILE 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 + arrayid = currentid + constequation = 0 + i2 = i + 2 + b2 = 0 + evalnextele3: + l2$ = getelement(a$, i2) + IF l2$ = "(" THEN b2 = b2 + 1 + IF l2$ = ")" THEN + b2 = b2 - 1 + IF b2 = -1 THEN + c$ = arrayreference(getelements$(a$, i + 2, i2 - 1), typ2) + IF Error_Happened THEN EXIT FUNCTION + i = i2 + + 'UDT + 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)) + 'change o$ to a byte offset if necessary + 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 + s = s \ 8 + END IF + o$ = "(" + o$ + ")*" + str2$(s) + 'print "calling evaludt with o$:"+o$ + GOTO evaludt + END IF + + GOTO evalednextele3 + END IF + END IF + i2 = i2 + 1 + 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 + + 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 + constequation = 0 + blockn = blockn + 1 + makeidrefer block(blockn), blocktype(blockn) + IF (blocktype(blockn) AND ISSTRING) THEN stringprocessinghappened = 1 + evaledblock(blockn) = 2 + 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 + constequation = 0 + o$ = "" + evaludt: + b2 = 0 + i3 = i + 1 + 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 + i4 = i2 - 1 + 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) + 'PRINT "UDTREFERENCE:";l$; e$ + e$ = udtreference(o$, e$, typ2) + IF Error_Happened THEN EXIT FUNCTION + i = i4 + blockn = blockn + 1 + block(blockn) = e$ + evaledblock(blockn) = 2 + blocktype(blockn) = typ2 + 'is the following next necessary? + 'IF (typ2 AND ISSTRING) THEN stringprocessinghappened = 1 + GOTO evaled + END IF + END IF + + END IF '"(" or no "(" + + 'is l$ a function? + IF id.subfunc = 1 THEN + constequation = 0 + 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 + b2 = b2 - 1 + 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 + i = i2 + GOTO evalednextele + END IF + END IF + IF l2$ = "," AND b2 = 0 THEN args = args + 1 + i2 = i2 + 1 + GOTO evalnextele + ELSE + 'no brackets + c$ = evaluatefunc("", 0, typ2) + 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 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 + dtyp$ = removesymbol(l$) + IF Error_Happened THEN EXIT FUNCTION + 'count the number of elements + nume = 1 + b2 = 0 + 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 THEN Give_Error "Array '" + l$ + "' (" + symbol2fulltypename$(dtyp$) + ") not defined": EXIT FUNCTION + IF Error_Happened THEN EXIT FUNCTION + olddimstatic = dimstatic + method = 1 + 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 + varname2$ = getelement$(staticarraylist, xi): xi = xi + 1 + typ2$ = 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 + l3$ = l2$: s$ = removesymbol(l3$) + 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 + ignore = dim2(l$, dtyp$, method, fakee$) + 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 + + l$ = l2$ 'restore l$ + + END IF 'b=0 + + IF l$ = "(" THEN + IF b = 0 THEN i1 = i + 1 + b = b + 1 + END IF + + IF b = 0 THEN + blockn = blockn + 1 + block(blockn) = l$ + evaledblock(blockn) = 0 + END IF + + IF l$ = ")" THEN + b = b - 1 + 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 + blockn = blockn + 1 + IF (typ2 AND ISPOINTER) THEN + block(blockn) = c$ + ELSE + block(blockn) = "(" + c$ + ")" + END IF + evaledblock(blockn) = 1 + blocktype(blockn) = typ2 + END IF + END IF + evaled: + 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 + + + + 'identify any referencable values + 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 + num$ = block(i) + 'a float? + f = 0 + x = INSTR(num$, "E") + IF x THEN + f = 1: blocktype(i) = SINGLETYPE - ISPOINTER + ELSE + x = INSTR(num$, "D") + IF x THEN + f = 2: blocktype(i) = DOUBLETYPE - ISPOINTER + ELSE + x = INSTR(num$, "F") + IF x THEN + f = 3: blocktype(i) = FLOATTYPE - ISPOINTER + 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 + '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 + block(i) = " " + num$ + " " 'pad with spaces to avoid C++ computation errors + evaledblock(i) = 1 + GOTO evaledblock + END IF + + 'number? + 'fc = ASC(LEFT$(block(i), 1)) + 'IF fc = 45 OR (fc >= 48 AND fc <= 57) THEN '- or 0-9 + ''it's a number + ''check for an extension, if none, assume integer + 'blocktype(i) = INTEGER64TYPE - ISPOINTER + 'tblock$ = " " + block(i) + 'IF RIGHT$(tblock$, 2) = "##" THEN blocktype(i) = FLOATTYPE - ISPOINTER: block(i) = LEFT$(block(i), LEN(block$(i)) - 2): GOTO evfltnum + 'IF RIGHT$(tblock$, 1) = "#" THEN blocktype(i) = DOUBLETYPE - ISPOINTER: block(i) = LEFT$(block(i), LEN(block$(i)) - 1): GOTO evfltnum + 'IF RIGHT$(tblock$, 1) = "!" THEN blocktype(i) = SINGLETYPE - ISPOINTER: block(i) = LEFT$(block(i), LEN(block$(i)) - 1): GOTO evfltnum + ' + ''C++ 32bit unsigned to signed 64bit + 'IF INSTR(block(i),".")=0 THEN + ' + 'negated=0 + 'if left$(block(i),1)="-" then block(i)=right$(block(i),len(block(i))-1):negated=1 + ' + 'if left$(block(i),2)="0x" then 'hex + 'if len(block(i))=10 then + 'if block(i)>="0x80000000" and block(i)<="0xFFFFFFFF" then block(i)="(int64)"+block(i): goto evnum + 'end if + 'if len(block(i))>10 then block(i)=block(i)+"ll": goto evnum + 'goto evnum + 'end if + ' + 'if left$(block(i),1)="0" then 'octal + 'if len(block(i))=12 then + 'if block(i)>="020000000000" and block(i)<="037777777777" then block(i)="(int64)"+block(i): goto evnum + 'if block(i)>"037777777777" then block(i)=block(i)+"ll": goto evnum + 'end if + 'if len(block(i))>12 then block(i)=block(i)+"ll": goto evnum + 'goto evnum + 'end if + ' + ''decimal + 'if len(block(i))=10 then + 'if block(i)>="2147483648" and block(i)<="4294967295" then block(i)="(int64)"+block(i): goto evnum + 'if block(i)>"4294967295" then block(i)=block(i)+"ll": goto evnum + 'end if + 'if len(block(i))>10 then block(i)=block(i)+"ll" + ' + 'evnum: + ' + 'if negated=1 then block(i)="-"+block(i) + ' + 'END IF + ' + 'evfltnum: + ' + 'block(i) = " " + block(i)+" " + 'evaledblock(i) = 1 + 'GOTO evaledblock + 'END IF + + 'a typed string in "" + 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 + block(i) = "qbs_new_txt(" + block(i) + ")" + END IF + blocktype(i) = ISSTRING + evaledblock(i) = 1 + stringprocessinghappened = 1 + GOTO evaledblock + END IF + + 'create variable + IF isvalidvariable(block(i)) THEN + x$ = block(i) + + typ$ = removesymbol$(x$) + 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 + typ$ = defineextaz(v) + 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 Debug THEN PRINT #9, "CREATING VARIABLE:" + x$ + IF optionexplicit THEN Give_Error "Variable '" + x$ + "' (" + symbol2fulltypename$(typ$) + ") not defined": EXIT FUNCTION + retval = dim2(x$, typ$, 1, "") + 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 + 'reference value + 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 + + 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 + + END IF + + END IF + END IF + evaledblock: + NEXT + + + 'return a POINTER if possible + 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) + typ = blocktype(1) + evaluate$ = block(1) + EXIT FUNCTION + END IF + END IF + END IF + 'it cannot be returned as a pointer + + + + + + + + + IF Debug THEN PRINT #9, "applying operators:"; + + + 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? + typ = blocktype(2) 'init typ with second blocktype + END IF + END IF + + nonop = 0 + FOR i = 1 TO blockn + + IF evaledblock(i) = 0 THEN + isop = isoperator(block(i)) + IF isop THEN + nonop = 0 + + constequation = 0 + + 'operator found + o$ = block(i) + u = operatorusage(o$, typ, i$, lhstyp, rhstyp, result) + + 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 + + 'lhstyp & rhstyp bit-field values + '1=integeral + '2=floating point + '4=string + '8=bool *only used for result + + oldtyp = typ + newtyp = blocktype(i + 1) + + 'IF block(i - 1) = "6" THEN + 'PRINT o$ + 'PRINT oldtyp AND ISFLOAT + 'PRINT blocktype(i - 1) AND ISFLOAT + 'END + 'END IF + + + + '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 + + 'Offset protection: Override conversion rules for operator as necessary + offsetmode = 0 + offsetcvi = 0 + 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 + + '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 + '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 + 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 + '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 result = 2 THEN result = 1 'force integer result + 'note: result=1 just sets typ&=64 if typ is a float + + 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 + '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 + 'convert float to int + block(i - 1) = "qbr(" + block(i - 1) + ")" + oldtyp = 64& + END IF + ELSE + 'oldtyp is an int + 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 + 'convert rhs + 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 + 'convert float to int + block(i + 1) = "qbr(" + block(i + 1) + ")" + newtyp = 64& + END IF + ELSE + 'newtyp is an int + 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 + + 'Reduce floating point values to common base for comparison? + 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..." + ' IF S < 2.1 THEN PRINT "LESS THAN 2.1" + 'concerns: + '1. Return value from TIMER will be reduced to a SINGLE in direct comparisons + '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 + 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 + 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 + + typ = newtyp + + 'STEP 2: markup typ + ' if either side is a float, markup typ to largest float + ' 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 + '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 + typ = ISFLOAT + b + 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 + 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 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 + typ = 32 + 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 + + 'override typ=ISFLOAT+256 to typ=ISFLOAT+64 for ^ operator's result + IF u = 2 THEN + IF i$ = "pow2" THEN + + 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 + '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 + 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 + typ = ISFLOAT + b + + END IF 'pow2 + END IF 'u=2 + + 'STEP 3: apply operator appropriately + + IF u = 5 THEN + block(i + 1) = i$ + "(" + block(i + 1) + ")" + block(i) = "": i = i + 1: GOTO operatorapplied + END IF + + 'binary operators + + 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 + + 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 + + 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 + + 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 + + '...more?... + + 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 + offsetmode = 0 + + ELSE + nonop = nonop + 1 + 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, "" + + 'join blocks + FOR i = 1 TO blockn + r$ = r$ + block(i) + 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 + + + evaluate$ = r$ + + + +END FUNCTION + + + + +FUNCTION evaluatefunc$ (a2$, args AS LONG, typ AS LONG) + a$ = a2$ + + IF Debug THEN PRINT #9, "evaluatingfunction:" + RTRIM$(id.n) + ":" + a$ + + DIM id2 AS idstruct + + id2 = id + n$ = RTRIM$(id2.n) + typ = id2.ret + targetid = currentid + + 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 + + 'count omittable args + sqb = 0 + a = 0 + 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 + 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 + + passomit = 1 'pass omit flags param to function + + IF id2.args = args THEN omitarg_first = 0: omitarg_last = 0 'all arguments were passed! + + 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 id2.args <> args THEN Give_Error "Incorrect number of arguments passed to function": EXIT FUNCTION + + END IF + + skipargnumchk: + + IF id2.NoCloud THEN + IF Cloud THEN Give_Error "Feature not supported on QLOUD" '***NOCLOUD*** + END IF + + r$ = RTRIM$(id2.callname) + "(" + + + IF id2.args <> 0 THEN + + curarg = 1 + firsti = 1 + + n = numelements(a$) + IF n = 0 THEN i = 0: GOTO noargs + + FOR i = 1 TO n + + + + IF curarg >= omitarg_first AND curarg <= omitarg_last THEN + noargs: + 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" + curarg = curarg + omitargs + IF i = n THEN EXIT FOR + r$ = r$ + "," + 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 + + 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 + e$ = getelements$(a$, firsti, i) + ELSE + e$ = getelements$(a$, firsti, i - 1) + END IF + + IF LEFT$(e$, 2) = "(" + sp THEN dereference = 1 ELSE dereference = 0 + + + + '*special case CVI,CVL,CVS,CVD,_CV (part #1) + IF n$ = "_CV" THEN + IF curarg = 1 THEN + cvtype$ = type2symbol$(e$) + IF Error_Happened THEN EXIT FUNCTION + e$ = "" + GOTO dontevaluate + END IF + END IF + + '*special case MKI,MKL,MKS,MKD,_MK (part #1) + + IF n$ = "_MK" 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$ + "]" + e$ = "" + GOTO dontevaluate + END IF + END IF + END IF + + 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 + 'make a note of the array's index for later + ulboundarray$ = e$ + ulboundarraytyp = sourcetyp + e$ = "" + r$ = "" + 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 + + + '*special case* + IF n$ = "ASC" THEN + IF curarg = 2 THEN + e$ = evaluatetotyp$(e$, 32&) + IF Error_Happened THEN EXIT FUNCTION + typ& = LONGTYPE - ISPOINTER + r$ = r$ + e$ + ")" + GOTO evalfuncspecial + END IF + END IF + + + 'PRINT #12, "n$="; n$ + 'PRINT #12, "curarg="; curarg + 'PRINT #12, "e$="; e$ + 'PRINT #12, "r$="; r$ + + '*special case* + IF n$ = "_MEMGET" THEN + IF curarg = 1 THEN + memget_blk$ = e$ + 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 + t = typname2typ(e$) + IF t = 0 THEN Give_Error "Invalid TYPE name": EXIT FUNCTION + IF t AND ISOFFSETINBITS THEN Give_Error "_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 + memget_ctyp$ = "qbs*" + ELSE + IF t AND ISUDT THEN + memget_size = udtxsize(t AND 511) \ 8 + memget_ctyp$ = "void*" + ELSE + memget_size = (t AND 511) \ 8 + memget_ctyp$ = typ2ctyp$(t, "") + END IF + END IF + + + + + + 'assume checking off + offs$ = evaluatetotyp(memget_offs$, OFFSETTYPE - ISPOINTER) + blkoffs$ = evaluatetotyp(memget_blk$, -6) + 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 + r$ = "qbs_new_txt_len((char*)" + offs$ + "," + str2(memget_size) + ")" + ELSE + IF t AND ISUDT THEN + r$ = "((void*)+" + offs$ + ")" + t = ISUDT + ISPOINTER + (t AND 511) + ELSE + r$ = "*(" + memget_ctyp$ + "*)(" + offs$ + ")" + IF t AND ISPOINTER THEN t = t - ISPOINTER + END IF + END IF + + + + + + + + typ& = t + + + GOTO evalfuncspecial + END IF + END IF + + '------------------------------------------------------------------------------------------------------------ + e2$ = e$ + e$ = evaluate(e$, sourcetyp) + IF Error_Happened THEN EXIT FUNCTION + '------------------------------------------------------------------------------------------------------------ + + '***special case*** + IF n$ = "_MEM" 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 + + '*special case* + IF n$ = "_OFFSET" THEN + IF (sourcetyp AND ISREFERENCE) = 0 THEN + Give_Error "_OFFSET expects the name of a variable/array": EXIT FUNCTION + END IF + IF (sourcetyp AND ISARRAY) THEN + IF (sourcetyp AND ISOFFSETINBITS) THEN Give_Error "_OFFSET cannot reference _BIT type arrays": EXIT FUNCTION + END IF + r$ = "((uptrszint)(" + evaluatetotyp$(e2$, -6) + "))" + IF Error_Happened THEN EXIT FUNCTION + typ& = UOFFSETTYPE - ISPOINTER + 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 + + '*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 + + '*special case* + IF n$ = "LEN" THEN + typ& = LONGTYPE - ISPOINTER + IF (sourcetyp AND ISREFERENCE) = 0 THEN + 'could be a string expression + 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 + r$ = evaluatetotyp$(e2$, -5) 'use evaluatetotyp to get 'element' size + 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 (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 + e$ = "func_oct(" + e$ + "," + str2$(bits) + ")" + ELSE + IF (sourcetyp AND ISFLOAT) THEN + e$ = "func_oct_float(" + e$ + ")" + ELSE + IF bits = 64 THEN + IF wasref = 0 THEN bits = 0 + END IF + e$ = "func_oct(" + e$ + "," + str2$(bits) + ")" + END IF + END IF + typ& = STRINGTYPE - ISPOINTER + r$ = e$ + 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 + 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 + chars = (bits + 3) \ 4 + e$ = "func_hex(" + e$ + "," + str2$(chars) + ")" + 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 + e$ = "func_hex(" + e$ + "," + str2$(chars) + ")" + END IF + END IF + typ& = STRINGTYPE - ISPOINTER + r$ = e$ + GOTO evalfuncspecial + END IF + END IF + + + + + + + + + + '*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 + 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 + 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 + r$ = e$ + 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 + 'establish which function (if any!) should be used + IF (sourcetyp AND ISFLOAT) THEN e$ = "floor(" + e$ + ")" ELSE e$ = "(" + e$ + ")" + r$ = e$ + typ& = sourcetyp + 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 + '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 + e$ = "(" + e$ + ")" + END IF + r$ = e$ + typ& = sourcetyp + GOTO evalfuncspecial + END IF + + '*special case* + IF n$ = "_ROUND" 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 + e$ = "(" + e$ + ")" + 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 + + + '*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 + '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 + e$ = "((double)(" + e$ + "))" + END IF + r$ = e$ + typ& = DOUBLETYPE - ISPOINTER + 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 + '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 + e$ = "((double)(" + e$ + "))" + END IF + r$ = e$ + typ& = SINGLETYPE - ISPOINTER + 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 + '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 + r$ = e$ + typ& = 32& + 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 + '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 + r$ = e$ + typ& = 16& + 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" THEN mktype = -1 + IF mktype THEN + IF mktype <> -1 OR curarg = 2 THEN + IF (sourcetyp AND ISOFFSET) THEN Give_Error "Cannot convert _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 "_MK only accepts numeric types": EXIT FUNCTION + IF size THEN + r$ = ctype$ + "2string(" + str2(size) + "," + ELSE + r$ = ctype$ + "2string(" + END IF + nocomma = 1 + targettyp = qtyp& + 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" 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 "_CV cannot return STRING type!": EXIT FUNCTION + IF ctype$ = "bit" OR ctype$ = "ubit" THEN + r$ = "string2" + ctype$ + "(" + e$ + "," + str2(size) + ")" + ELSE + r$ = "string2" + ctype$ + "(" + e$ + ")" + 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 + sourcetyp = 64& + e$ = "(" + e$ + "->chr[0])" + 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 + recompile = 1 + cmemlist(VAL(e$)) = 1 + r$ = "[CONVENTIONAL_MEMORY_REQUIRED]" + typ& = 64& + GOTO evalfuncspecial + END IF + r$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION + r$ = "((unsigned short)(" + r$ + "->chr-&cmem[1280]))" + typ& = 64& + 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.musthave) = "$" THEN + IF (sourcetyp AND ISINCONVENTIONALMEMORY) = 0 THEN + recompile = 1 + cmemlist(VAL(e$)) = 1 + r$ = "[CONVENTIONAL_MEMORY_REQUIRED]" + typ& = ISSTRING + 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 + + '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 + r$ = r$ + "->cmem_descriptor_offset" + t = 3 + ELSE + r$ = "((unsigned short)(((uint8*)" + r$ + ")-&cmem[1280]))" + '*top bit on=unsigned + '*second top bit on=bit-value (lower bits indicate the size) + 'BYTE=1 + 'INTEGER=2 + 'STRING=3 + 'SINGLE=4 + 'INT64=5 + 'FLOAT=6 + 'DOUBLE=8 + 'LONG=20 + 'BIT=64+n + t = 0 + 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 + r$ = "func_varptr_helper(" + str2(t) + "," + r$ + ")" + typ& = ISSTRING + GOTO evalfuncspecial + END IF 'end of varptr$ + + + + + + + + + + + + 'VARPTR + IF (sourcetyp AND ISINCONVENTIONALMEMORY) = 0 THEN + recompile = 1 + cmemlist(VAL(e$)) = 1 + r$ = "[CONVENTIONAL_MEMORY_REQUIRED]" + typ& = 64& + GOTO evalfuncspecial + END IF + + 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 + m = id.tsize + index$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) + typ = 64& + r$ = "((" + index$ + ")*" + str2(m) + ")" + GOTO evalfuncspecial + ELSE + 'return the offset of the string's descriptor + r$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION + r$ = r$ + "->cmem_descriptor_offset" + typ = 64& + 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 + typ = 64& + r$ = "(" + o$ + ")" + GOTO evalfuncspecial + END IF + + 'non-UDT array + m = (sourcetyp AND 511) \ 8 'calculate size multiplier + index$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) + typ = 64& + r$ = "((" + index$ + ")*" + str2(m) + ")" + GOTO evalfuncspecial + + END IF + + 'not an array + + 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 + 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 + '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 + 'give offset relative to DBLOCK + r$ = "((unsigned short)(((uint8*)" + r$ + ") - &cmem[1280] + (" + o$ + ") ))" + 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 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 + r$ = "varptr_dblock_check(" + r$ + "->chr)" + ELSE 'definitely in DBLOCK + r$ = "((unsigned short)(" + r$ + "->chr-&cmem[1280]))" + END IF + + ELSE + r$ = r$ + "->cmem_descriptor_offset" + 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 + r$ = "varptr_dblock_check((uint8*)" + r$ + ")" + ELSE 'definitely in DBLOCK + r$ = "((unsigned short)(((uint8*)" + r$ + ")-&cmem[1280]))" + 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 + recompile = 1 + cmemlist(VAL(e$)) = 1 + r$ = "[CONVENTIONAL_MEMORY_REQUIRED]" + typ& = 64& + GOTO evalfuncspecial + END IF + 'array? + 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 + typ = 64& + r$ = "( ( ((ptrszint)(" + refer(e$, sourcetyp, 1) + "[0])) - ((ptrszint)(&cmem[0])) ) /16)" + 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 + 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 + r$ = "varseg_dblock_check(((uint8*)" + r$ + ")+(" + o$ + "))" + ELSE + r$ = "varseg_dblock_check((uint8*)" + refer(e$, sourcetyp, 1) + ")" + 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 + + + + + + + + + + + + + + + + 'note: this code has already been called... + '------------------------------------------------------------------------------------------------------------ + 'e2$ = e$ + 'e$ = evaluate(e$, sourcetyp) + '------------------------------------------------------------------------------------------------------------ + + 'note: this comment makes no sense... + 'any numeric variable, but it must be type-speficied + + IF targettyp = -2 THEN + e$ = evaluatetotyp(e2$, -2) + IF Error_Happened THEN EXIT FUNCTION + GOTO dontevaluate + END IF '-2 + + IF targettyp = -7 THEN + e$ = evaluatetotyp(e2$, -7) + IF Error_Happened THEN EXIT FUNCTION + GOTO dontevaluate + END IF '-7 + + IF targettyp = -8 THEN + e$ = evaluatetotyp(e2$, -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 + + 'note: this is used for functions like STR(...) which accept all types... + explicitreference = 0 + IF targettyp = -1 THEN + explicitreference = 1 + 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 + + 'pointer? + 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$ + "]" + + '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 + + 'check arrayname was followed by '()' + IF targettyp AND ISUDT THEN + IF Debug THEN PRINT #9, "evaluatefunc:array reference:udt reference:[" + e$ + "]" + 'get UDT info + 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) + '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 + + + idnum = VAL(LEFT$(e$, INSTR(e$, sp3) - 1)) + getid idnum + 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 MID$(sfcmemargs(targetid), curarg, 1) = CHR$(1) THEN 'cmem required? + IF cmemlist(idnum) = 0 THEN + cmemlist(idnum) = 1 + + recompile = 1 + END IF + END IF + + + + 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 + 'only continue if the number of array elements required is unknown + 'and it needs to be set + + IF id.arrayelements <> -1 THEN + nelereq = id.arrayelements + MID$(id2.nelereq, curarg, 1) = CHR$(nelereq) + END IF + + ids(targetid) = id2 + + ELSE + + 'the number of array elements required is known AND + 'the number of elements in the array to be passed is known + + + + 'REMOVE FOR TESTING PURPOSES ONLY!!! SHOULD BE UNREM'd! + '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 + + + + END IF + END IF + + + e$ = refer(e$, sourcetyp, 1) + IF Error_Happened THEN EXIT FUNCTION + GOTO dontevaluate + END IF + + + + + + + + + + + + + '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 + + 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 + + '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) + + 'compare types + IF sourcetyp2 = targettyp2 THEN + + IF sourcetyp AND ISUDT THEN + 'udt/udt array + + 'get info + 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) + '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 + + 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 + + ELSE + 'not a udt + 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 + e$ = refer(e$, sourcetyp, 1) + 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 + + 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 + cmemlist(idnum) = 1 + recompile = 1 + END IF + END IF + + GOTO dontevaluate + END IF 'similar + + 'IF sourcetyp2 = targettyp2 THEN + 'IF arr THEN + 'IF (sourcetyp2 AND ISOFFSETINBITS) THEN Give_Error "Cannot pass BIT array offsets yet": EXIT FUNCTION + 'e$ = "(&(" + refer(e$, sourcetyp, 0) + "))" + 'ELSE + 'e$ = refer(e$, sourcetyp, 1) + 'END IF + 'GOTO dontevaluate + 'END IF + + END IF 'source is a reference + + 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 + cmemlist(idnum) = 1 + recompile = 1 + END IF + END IF + END IF 'reference + + END IF 'string + + END IF 'dereference was not used + END IF 'pointer + + + 'note: Target is not a pointer... + + 'IF (targettyp AND ISSTRING) = 0 THEN + 'IF (sourcetyp AND ISREFERENCE) THEN + 'targettyp2 = targettyp: sourcetyp2 = sourcetyp - ISREFERENCE + 'IF (sourcetyp2 AND ISINCONVENTIONALMEMORY) THEN sourcetyp2 = sourcetyp2 - ISINCONVENTIONALMEMORY + 'IF sourcetyp2 = targettyp2 THEN e$ = refer(e$, sourcetyp, 1): GOTO dontevaluate + 'END IF + 'END IF + 'END IF + + 'String-numeric mismatch? + 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 + 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 + + 'change to "non-pointer" value + IF (sourcetyp AND ISREFERENCE) THEN + e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION + END IF + + IF explicitreference = 0 THEN + IF targettyp AND ISUDT THEN + nth = curarg + IF omitarg_last <> 0 AND nth > omitarg_last THEN nth = nth - 1 + x$ = "'" + RTRIM$(udtxcname(targettyp AND 511)) + "'" + 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 + '**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 + + 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? + + + 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 + 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 + + IF LTRIM$(RTRIM$(e$)) = "0" THEN e$ = "NULL" + + END IF + + r$ = r$ + e$ + + '***special case**** + IF n$ = "_MEM" 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$ + "," + nocomma = 0 + firsti = i + 1 + curarg = curarg + 1 + 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 (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 + curarg = curarg + omitargs + 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(" + e$ = refer$(ulboundarray$, sourcetyp, 1) + IF Error_Happened THEN EXIT FUNCTION + 'note: ID contins refer'ed array info + + arrayelements = id.arrayelements '2009 + IF arrayelements = -1 THEN arrayelements = 1 '2009 + + r$ = r2$ + e$ + r$ + "," + str2$(arrayelements) + ")" + typ& = INTEGER64TYPE - ISPOINTER + GOTO evalfuncspecial + 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 + + '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 + 'Default is FLOATTYPE + 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 id2.ret = ISUDT + (1) THEN + '***special case*** + v$ = "func" + str2$(uniquenumber) + PRINT #defdatahandle, "mem_block " + v$ + ";" + r$ = "(" + v$ + "=" + r$ + ")" + END IF + + IF id2.ccall THEN + IF LEFT$(r$, 11) = "( char* )" THEN + r$ = "qbs_new_txt(" + r$ + ")" + END IF + END IF + + IF Debug THEN PRINT #9, "evaluatefunc:out:"; r$ + evaluatefunc$ = r$ +END FUNCTION + +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 + 'find base size from type + 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 + bytes = udtxsize(u) \ 8 + END IF + + 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 + + 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 + s$ = s$ + "*" + n$ + "[" + str2(i2 * 4 - 4 + 5) + "]" + NEXT + variablesize$ = "(" + s$ + ")" + EXIT FUNCTION + END IF + + variablesize$ = str2(bytes) +END FUNCTION + + + +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 + + '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 + + '-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 + + ' print "-4: evaluated as ["+e$+"]":sleep 1 + + 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 + n$ = "ARRAY_" + n$ + "[0]" + 'whole array reference examplename()? + IF LEFT$(o$, 3) = "(0)" THEN + 'use -2 type method + GOTO method2usealludt + END IF + END IF + 'determine size of element + IF E = 0 THEN 'no specific element, use size of entire type + bytes$ = str2(udtxsize(u) \ 8) + ELSE 'a specific element + bytes$ = str2(udtesize(E) \ 8) + END IF + 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 (sourcetyp AND ISARRAY) THEN 'Array reference -> byte_element(offset,bytes) + 'whole array reference examplename()? + 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 + 'assume a specific element + IF sourcetyp AND ISSTRING THEN + IF sourcetyp AND ISFIXEDLENGTH THEN + 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 + evaluatetotyp$ = "byte_element((uint64)" + e$ + "->chr," + bytes$ + "," + NewByteElement$ + ")" + 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 + + 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 + e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION + e$ = "(&(" + e$ + "))" + 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 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 + bytes$ = str2(id.tsize) + e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION + ELSE + e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION + bytes$ = e$ + "->len" + 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 + + '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 + evaluatetotyp$ = "byte_element((uint64)" + e$ + "," + str2(size) + "," + NewByteElement$ + ")" + IF targettyp = -5 THEN evaluatetotyp$ = str2(size) + IF targettyp = -6 THEN evaluatetotyp$ = e$ + EXIT FUNCTION + + 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 (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 + n$ = "ARRAY_" + n$ + "[0]" + 'whole array reference examplename()? + IF LEFT$(o$, 3) = "(0)" THEN + 'use -7 type method + GOTO method2usealludt__7 + END IF + END IF + 'determine size of element + 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 + bytes$ = str2(udtesize(E) \ 8) + t1 = udtetype(E) + END IF + dst$ = "(((char*)" + scope$ + n$ + ")+(" + o$ + "))" + 'evaluatetotyp$ = "byte_element((uint64)" + dst$ + "," + bytes$ + "," + NewByteElement$ + ")" + 'IF targettyp = -5 THEN evaluatetotyp$ = bytes$ + 'IF targettyp = -6 THEN evaluatetotyp$ = dst$ + + t = Type2MemTypeValue(t1) + evaluatetotyp$ = "(ptrszint)" + dst$ + "," + bytes$ + "," + str2(t) + "," + bytes$ + ",sf_mem_lock" + + EXIT FUNCTION + END IF + + IF (sourcetyp AND ISARRAY) THEN 'Array reference -> byte_element(offset,bytes) + 'whole array reference examplename()? + 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 + + idnumber = VAL(e$) + getid idnumber + 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 + bytes$ = str2(id.tsize) + e$ = refer(e$, sourcetyp, 0) + 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" + + t = Type2MemTypeValue(sourcetyp) + evaluatetotyp$ = "(ptrszint)" + e$ + "->chr," + bytes$ + "," + str2(t) + "," + bytes$ + "," + lk$ + + ELSE + + Give_Error "_MEMELEMENT cannot reference variable-length strings": EXIT FUNCTION + + END IF + EXIT FUNCTION + END IF + + e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION + e$ = "(&(" + e$ + "))" + 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$ + + t = Type2MemTypeValue(sourcetyp) + evaluatetotyp$ = "(ptrszint)" + e$ + "," + bytes$ + "," + str2(t) + "," + bytes$ + "," + lk$ + + EXIT FUNCTION + END IF 'isarray + + 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 + bytes$ = str2(id.tsize) + e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION + ELSE + Give_Error "_MEMELEMENT cannot reference variable-length strings": EXIT FUNCTION + END IF + + 'evaluatetotyp$ = "byte_element((uint64)" + e$ + "->chr," + bytes$ + "," + NewByteElement$ + ")" + 'IF targettyp = -5 THEN evaluatetotyp$ = bytes$ + 'IF targettyp = -6 THEN evaluatetotyp$ = e$ + "->chr" + + t = Type2MemTypeValue(sourcetyp) + evaluatetotyp$ = "(ptrszint)" + e$ + "->chr," + bytes$ + "," + str2(t) + "," + bytes$ + ",sf_mem_lock" + + 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 + 'evaluatetotyp$ = "byte_element((uint64)" + e$ + "," + str2(size) + "," + NewByteElement$ + ")" + 'IF targettyp = -5 THEN evaluatetotyp$ = str2(size) + 'IF targettyp = -6 THEN evaluatetotyp$ = e$ + + t = Type2MemTypeValue(sourcetyp) + evaluatetotyp$ = "(ptrszint)" + e$ + "," + str2(size) + "," + str2(t) + "," + str2(size) + ",sf_mem_lock" + + EXIT FUNCTION + + END IF '-8 + + + + + + + + + + + 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 + + 'User Defined Type + 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) + + o$ = e$ + getid idnumber + 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 + 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 + + t = Type2MemTypeValue(sourcetyp) + evaluatetotyp$ = "(ptrszint)" + dst$ + "," + bytes$ + "," + str2(t) + "," + str2(size) + ",sf_mem_lock" + + EXIT FUNCTION + END IF + + 'Array reference + IF (sourcetyp AND ISARRAY) THEN + IF sourcetyp AND ISSTRING THEN + IF (sourcetyp AND ISFIXEDLENGTH) = 0 THEN + Give_Error "_MEM cannot reference variable-length strings": EXIT FUNCTION + END IF + END IF + + idnumber = VAL(e$) + getid idnumber + IF Error_Happened THEN EXIT FUNCTION + + 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 + bytes$ = variablesize$(-1) + IF Error_Happened THEN EXIT FUNCTION + e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION + + IF sourcetyp AND ISSTRING THEN + e$ = "((" + e$ + ")->chr)" '[2013] handle fixed string arrays differently because they are already pointers + ELSE + e$ = "(&(" + e$ + "))" + END IF + + ' print "CI: array: e$["+e$+"], bytes$["+bytes$+"]":sleep 1 + 'calculate size of elements + IF sourcetyp AND ISSTRING THEN + bytes = tsize + 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 + + 'String + IF sourcetyp AND ISSTRING THEN + IF (sourcetyp AND ISFIXEDLENGTH) = 0 THEN Give_Error "_MEM cannot reference variable-length strings": 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 + + t = Type2MemTypeValue(sourcetyp) + evaluatetotyp$ = "(ptrszint)" + e$ + "->chr," + bytes$ + "," + str2(t) + "," + bytes$ + ",sf_mem_lock" + + 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 + + t = Type2MemTypeValue(sourcetyp) + evaluatetotyp$ = "(ptrszint)" + e$ + "," + str2(size) + "," + str2(t) + "," + str2(size) + ",sf_mem_lock" + + EXIT FUNCTION + + END IF '-7 _MEM structure helper + + + 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 + + 'User Defined Type -> byte_element(offset,bytes) + 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) + o$ = e$ + getid idnumber + 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 + 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 + + 'Array reference -> byte_element(offset,bytes) + 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 + e$ = refer(e$, sourcetyp, 0) + 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$) + getid idnumber + 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 + bytes$ = variablesize$(-1) + IF Error_Happened THEN EXIT FUNCTION + e$ = refer(e$, sourcetyp, 0) + 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 + bytes = tsize + 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$ + ' print "CI: array ->["+"byte_element((uint64)" + e$ + "," + bytes$+ ","+NewByteElement$+")"+"]":sleep 1 + EXIT FUNCTION + END IF + + 'String -> byte_element(offset,bytes) + IF sourcetyp AND ISSTRING THEN + IF sourcetyp AND ISFIXEDLENGTH THEN + 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 + ELSE + e$ = refer(e$, sourcetyp, 0) + IF Error_Happened THEN EXIT FUNCTION + bytes$ = e$ + "->len" + 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 + + '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 + evaluatetotyp$ = "byte_element((uint64)" + e$ + "," + str2(size) + "," + NewByteElement$ + ")" + IF targettyp = -5 THEN evaluatetotyp$ = str2(size) + IF targettyp = -6 THEN evaluatetotyp$ = e$ + EXIT FUNCTION + + 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) THEN + evaluatetotyp$ = e$ + IF (sourcetyp AND ISREFERENCE) THEN + evaluatetotyp$ = refer(e$, sourcetyp, 0) + 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 + '... + Give_Error "Invalid pointer": EXIT FUNCTION + END IF + + 'change to "non-pointer" value + IF (sourcetyp AND ISREFERENCE) THEN + e$ = refer(e$, sourcetyp, 0) + 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 + + 'round to integer if required + 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 + + evaluatetotyp$ = e$ +END FUNCTION + +FUNCTION findid& (n2$) + n$ = UCASE$(n2$) 'case insensitive + + 'return all strings as 'not found' + 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 + '(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 + 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 + ''' '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 + + '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 + '''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$)) + + '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 + + 'NEW HASH SYSTEM + n$ = RTRIM$(n$) + IF findanother THEN + hashretry: + z = HashFindCont(unrequired, i) + ELSE + z = HashFindRev(n$, 1, unrequired, i) + END IF + findidinternal = z + IF z = 0 THEN GOTO noid + findid = z + + + 'continue from previous position? + ''IF findanother THEN start = findidinternal ELSE start = idn + + ''FOR i = start TO 1 STEP -1 + + '' findidinternal = i - 1 + '' IF findidinternal = 0 THEN findid& = 1 '1=found id, but no more to search + + '' 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 + + '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 secondarg$ <> ids(i).secondargmustbe THEN GOTO findidnomatch + END IF + IF ASC(ids(i).secondargcantbe) <> 32 THEN 'exists? + IF secondarg$ = ids(i).secondargcantbe THEN GOTO findidnomatch + 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 + ''' IF couldhavescpassed THEN + ''' IF couldhavesc$ = ids(i).musthave THEN GOTO findidok + ''' END IF + 'Q: why is the above triple-commented? + 'A: because if something must have a symbol to refer to it, then a could-have is + ' not sufficient, and it could mask shared variables in global scope + + '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 + + '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 + 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) + '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 '"$ " + 'it is a fixed length string + 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 + + 'return id + findidok: + + id = ids(i) + + currentid = i + EXIT FUNCTION + + 'END IF 'same name + findidnomatch: + 'NEXT + IF z = 2 THEN GOTO hashretry + + 'totally unclassifiable + noid: + findid& = 0 + currentid = -1 +END FUNCTION + +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 + + '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 + gotsc2: + n2$ = n$ + sc$ + + 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 + + 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 + + '2. that failed, so apply the _define'd extension and pass (local) + 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 + + '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 + + '4. that failed, so apply the _define'd extension and pass (global) + 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 + + END IF + FindArray = 0 +END FUNCTION + + + + +FUNCTION fixoperationorder$ (savea$) + a$ = savea$ + 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 + + '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 + 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 + + '----------------A. 'Quick' mismatched brackets check---------------- + b = 0 + a2$ = sp + a$ + sp + b1$ = sp + "(" + sp + b2$ = sp + ")" + sp + i = 1 + findmmb: + i1 = INSTR(i, a2$, b1$) + i2 = INSTR(i, a2$, b2$) + i3 = i1 + 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 + 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 + + '----------------B. 'Quick' correction of over-use of +,- ---------------- + 'note: the results of this change are beneficial to foolayout + a2$ = sp + a$ + sp + + '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) + n = n - 1 + 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) + n = n - 1 + 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 + 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 + + + + '----------------C. 'Quick' location of negation---------------- + 'note: the results of this change are beneficial to foolayout + + 'for numbers... + 'before: anyoperator,-,number + 'after: anyoperator,-number + + 'for variables... + 'before: anyoperator,-,variable + 'after: anyoperator,CHR$(241),variable + + 'exception for numbers followed by ^... (they will be bracketed up along with the ^ later) + '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 + + IF ASC(getelement(a$, i)) = 45 THEN '- + + neg = 0 + IF i = 1 THEN + neg = 1 + ELSE + a2$ = getelement(a$, i - 1) + 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 + + 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 ^ + '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 + a2$ = "-" + a2$ + END IF + removeelements a$, i, i + 1, 0 + insertelements a$, i - 1, a2$ + n = n - 1 + IF Debug THEN PRINT #9, "fixoperationorder:negation:" + a$ + + GOTO negdone + + 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$ + + END IF 'isoperator + END IF '- + negdone: + NEXT + + + + 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 + b = 0 + b1 = 0 + 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 + insertelements a$, i - 1, "}" + insertelements a$, b1, "{" + n = n + 2 + 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 + insertelements a$, b1, "{" + a$ = a$ + sp + "}" + n = n + 2 + IF Debug THEN PRINT #9, "fixoperationorder:^-:" + a$ + pownegused = 1 + GOTO powneg + END IF + + END IF 'quick check + + + '----------------E. Find lowest & highest operator level in bottom bracket level---------------- + NOT_recheck: + lco = 255 + hco = 0 + b = 0 + 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 + op = isoperator(a2$) + 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 + 'brackets needed + + 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 + b = 0 + 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 + 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 + + n2 = n + b = 0 + a3$ = "{" + n = 1 + 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 + op = isoperator(a2$) + 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 + a3$ = a3$ + sp + "}" + sp + a2$ + sp + "{" + n = n + 3 + END IF + GOTO fixop0 + END IF + + END IF 'b=0 + a3$ = a3$ + sp + a2$ + n = n + 1 + fixop0: + NEXT + a3$ = a3$ + sp + "}" + n = n + 1 + a$ = a3$ + + lco_bracketting_done: + IF Debug THEN PRINT #9, "fixoperationorder:lco bracketing["; lco; ","; hco; "]:" + a$ + + '--------(F)G. Remove indwelling {}bracketting from power-negation-------- + IF pownegused THEN + b = 0 + i = 0 + 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 + 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 + + 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 + a$ = "NOT" + sp + "{" + sp + getelements$(a$, 2, n) + sp + "}": n = n + 2 + END IF + + '----------------H. Identification/conversion of elements within bottom bracket level---------------- + 'actions performed: + ' ->builds f$(tlayout) + ' ->adds symbols to all numbers + ' ->evaluates constants to numbers + + f$ = "" + b = 0 + c = 0 + lastt = 0: lastti = 0 + FOR i = 1 TO n + f2$ = getelement(a$, i) + lastc = c + c = ASC(f2$) + + 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 + + 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 c <> 41 OR b <> 0 THEN f2$ = "" 'skip temporary & indwelling brackets + GOTO classdone + END IF + + IF b = 0 THEN + + 'classifications/conversions: + '1. quoted string ("....) + '2. number + '3. operator + '4. constant + '5. variable/array/udt/function (note: nothing can share the same name as a function except a label) + + + 'quoted string? + 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 \ + x2 = x + 1 + 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) + x2 = x + 1 + 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 + + 'number? + 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 + + 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 + + 'add appropriate integer symbol if none present + IF x = 0 THEN + f3$ = f2$ + s$ = "" + 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 + 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 + f3$ = f3$ + s$ + removeelements a$, i, i, 0: insertelements a$, i - 1, f3$ + END IF 'x=0 + + GOTO classdone + END IF + + 'operator? + IF isoperator(f2$) THEN + lastt = 3: lastti = i + IF LEN(f2$) > 1 THEN + IF f2$ <> UCASE$(f2$) THEN + f2$ = UCASE$(f2$) + removeelements a$, i, i, 0 + insertelements a$, i - 1, f2$ + END IF + END IF + 'append negation + IF f2$ = CHR$(241) THEN f$ = f$ + sp + "-": GOTO classdone_special + GOTO classdone + END IF + + + IF alphanumeric(c) THEN + lastt = 4: lastti = i + + 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) + + e$ = UCASE$(f2$) + es$ = removesymbol$(e$) + 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 + hashfound = 1 + EXIT DO + END IF + END IF + IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 + LOOP + + IF hashfound THEN + i2 = hashresref + 'FOR i2 = constlast TO 0 STEP -1 + 'IF e$ = constname(i2) THEN + + + + + + '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 + 'add symbol and try again + 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 staticvariable = 0 THEN + + t = consttype(i2) + 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 + 'convert value to general formats + IF t AND ISFLOAT THEN + v## = constfloat(i2) + v&& = v## + v~&& = v&& + ELSE + IF t AND ISUNSIGNED THEN + v~&& = constuinteger(i2) + v&& = v~&& + v## = v&& + ELSE + v&& = constinteger(i2) + v## = v&& + v~&& = v&& + END IF + END IF + 'apply type conversion if necessary + 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 + + 'floats returned by str$ must be converted to qb64 standard format + 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 + 'E,D,F found + 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 + '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 + s$ = typevalue2symbol$(t) + IF Error_Happened THEN EXIT FUNCTION + e$ = e$ + s$ 'simply append symbol to integer + END IF + + 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 + + END IF 'not static + 'END IF 'same name + 'NEXT + END IF 'hashfound + END IF 'not udt element + END IF 'not array + + 'variable/array/udt? + u$ = f2$ + + try_string$ = f2$ + try_string2$ = try_string$ 'pure version of try_string$ + + FOR try_method = 1 TO 4 + try_string$ = try_string2$ + 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 + try_string$ = try_string$ + defineextaz(v) + END IF + END IF + ELSE + try_string$ = try_string2$ + 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 Debug THEN PRINT #9, "found id matching " + f2$ + + IF nextc = 40 THEN '( + + 'function or array? + 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 + f2$ = RTRIM$(id.cn) + s$ + removeelements a$, i, i, 0 + 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 + f$ = f$ + sp + NEXT + + 'adjust i accordingly + i = i2 + + 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 + + f$ = f$ + sp + 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 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 + f2$ = RTRIM$(id.cn) + removesymbol$(f2$) + IF Error_Happened THEN EXIT FUNCTION + removeelements a$, i, i, 0 + insertelements a$, i - 1, UCASE$(f2$) + f$ = f$ + f2$ + + + + 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 + i = i + 2 + + 'loop + + '"." encountered, i must be an element + 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 + + 'is f$ the same as element e? + fooudtnexte: + IF udtename(E) = u$ THEN + 'match found + 'todo: check symbol(s$) matches element's type + + 'correct name + f2$ = RTRIM$(udtecname(E)) + s$ + removeelements a$, i, i, 0 + 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 + 'sub-element exists + t = udtetype(E) + IF (t AND ISUDT) = 0 THEN Give_Error "Invalid . after element": EXIT FUNCTION + GOTO fooudt + + 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 + + END IF 'udt + + 'non array/udt based variable + f3$ = f2$ + s$ = removesymbol$(f3$) + IF Error_Happened THEN EXIT FUNCTION + f2$ = RTRIM$(id.cn) + s$ + 'change was is returned to uppercase + removeelements a$, i, i, 0 + insertelements a$, i - 1, UCASE$(f2$) + GOTO CouldNotClassify + END IF 'id.t + + 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) + CouldNotClassify: + + 'alphanumeric, but item name is unknown... is it an internal type? if so, use capitals + f3$ = UCASE$(f2$) + internaltype = 0 + IF f3$ = "STRING" THEN internaltype = 1 + IF f3$ = "_UNSIGNED" THEN internaltype = 1 + IF f3$ = "_BIT" THEN internaltype = 1 + IF f3$ = "_BYTE" THEN internaltype = 1 + IF f3$ = "INTEGER" THEN internaltype = 1 + IF f3$ = "LONG" THEN internaltype = 1 + IF f3$ = "_INTEGER64" THEN internaltype = 1 + IF f3$ = "SINGLE" THEN internaltype = 1 + IF f3$ = "DOUBLE" THEN internaltype = 1 + IF f3$ = "_FLOAT" THEN internaltype = 1 + IF f3$ = "_OFFSET" THEN internaltype = 1 + IF internaltype = 1 THEN + f2$ = f3$ + removeelements a$, i, i, 0 + insertelements a$, i - 1, f3$ + GOTO classdone + END IF + + GOTO classdone + END IF 'alphanumeric + + classdone: + f$ = f$ + f2$ + END IF 'b=0 + f$ = f$ + sp + classdone_special: + NEXT + 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 + + + + '----------------I. Pass (){}bracketed items (if any) to fixoperationorder & build return---------------- + 'note: items seperated by commas are done seperately + + ff$ = "" + b = 0 + b2 = 0 + p1 = 0 'where level 1 began + aa$ = "" + n = numelements(a$) + FOR i = 1 TO n + + openbracket = 0 + + a2$ = getelement(a$, i) + + c = ASC(a2$) + + + + IF c = 40 OR c = 123 THEN '({ + b = b + 1 + + IF b = 1 THEN + + + + + p1 = i + 1 + aa$ = aa$ + "(" + sp + + END IF + + openbracket = 1 + + GOTO foopass + + END IF '({ + + IF c = 44 THEN ', + IF b = 1 THEN + GOTO foopassit + END IF + END IF + + IF c = 41 OR c = 125 THEN ')} + b = b - 1 + + IF b = 0 THEN + foopassit: + IF p1 <> i THEN + foo$ = fixoperationorder(getelements(a$, p1, i - 1)) + 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 + p1 = i + 1 + END IF + + GOTO foopass + END IF ')} + + + + + IF b = 0 THEN aa$ = aa$ + a2$ + sp + + + foopass: + + f2$ = getelementspecial(f$, i) + 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 + ff$ = ff$ + "." + sp2 + GOTO fooloopnxt + END IF + END IF + + 'spacing just before ( + 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 + ff$ = ff$ + f2$ + sp2 + ELSE 'not openbracket + ff$ = ff$ + f2$ + sp + END IF + + END IF 'len(f2$) + + fooloopnxt: + + NEXT + + 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$ + tlayout$ = ff$ + fixoperationorder$ = aa$ + + fooindwel = fooindwel - 1 +END FUNCTION + + + + +FUNCTION getelementspecial$ (savea$, elenum) + a$ = savea$ + IF a$ = "" THEN EXIT FUNCTION 'no elements! + + n = 1 + p = 1 + getelementspecialnext: + 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 + + 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! + n = n + 1 + p = i + 1 + GOTO getelementspecialnext +END FUNCTION + + + +FUNCTION getelement$ (a$, elenum) + IF a$ = "" THEN EXIT FUNCTION 'no elements! + + n = 1 + p = 1 + getelementnext: + 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 i = 0 THEN EXIT FUNCTION 'no more elements! + n = n + 1 + p = i + 1 + GOTO getelementnext +END 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 + 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 + n = n + 1 + p = i + 1 + GOTO getelementsnext +END FUNCTION + +SUB getid (i AS LONG) + IF i = -1 THEN Give_Error "-1 passed to getid!": EXIT SUB + + id = ids(i) + + currentid = i +END SUB + +SUB insertelements (a$, i, elements$) + IF i = 0 THEN + IF a$ = "" THEN + a$ = elements$ + EXIT SUB + END IF + a$ = elements$ + sp + a$ + EXIT SUB + END IF + + a2$ = "" + n = numelements(a$) + + + + + 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 + + a$ = a2$ + +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 THEN EXIT FUNCTION + GOTO isnumok + END IF + IF a = 46 THEN + IF dp = 1 THEN EXIT FUNCTION + dp = 1 + GOTO isnumok + END IF + IF a >= 48 AND a <= 57 THEN v = 1: GOTO isnumok + EXIT FUNCTION + isnumok: + NEXT + isnumber = 1 +END FUNCTION + +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$ = "=" 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 + l = l + 1 + 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 + opfound: + isoperator = l +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 + isuinteger = -1 +END FUNCTION + +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 + 'valid (continue) + 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 + isvalidvariable = 0 +END FUNCTION + + + + +FUNCTION lineformat$ (a$) + a2$ = "" + linecontinuation = 0 + + continueline: + + a$ = a$ + " " 'add 2 extra spaces to make reading next char easier + + ca$ = a$ + a$ = UCASE$(a$) + + n = LEN(a$) + i = 1 + lineformatnext: + IF i >= n THEN GOTO lineformatdone + + c = ASC(a$, i) + c$ = CHR$(c) '***remove later*** + + '----------------quoted string---------------- + IF c = 34 THEN '" + a2$ = a2$ + sp + CHR$(34) + p1 = i + 1 + 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)) + i = i2 + 1 + EXIT FOR + END IF + + IF c2 = 92 THEN '\ + a2$ = a2$ + MID$(ca$, p1, i2 - p1) + "\\" + p1 = i2 + 1 + END IF + + 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$ + p1 = i2 + 1 + END IF + + 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) + i = n - 1 + END IF + + GOTO lineformatnext + + 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 + 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 + a2$ = a2$ + sp + "GOTO" + END IF + + 'Number will be converted to the following format: + ' 999999 . 99999 E + 999 + '[whole$][dp(0/1)][frac$][ed(1/2)][pm(1/-1)][ex$] + ' 0 1 2 3 <-mode + + mode = 0 + whole$ = "" + dp = 0 + frac$ = "" + ed = 0 'E=1, D=2, F=3 + pm = 1 + ex$ = "" + + + + + lfreadnumber: + valid = 0 + + 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 + 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 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 + mode = 2 + END IF + END IF + + IF c = 43 OR c = 45 THEN '+,- + IF mode = 2 THEN + valid = 1 + IF c = 45 THEN pm = -1 + mode = 3 + 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 + + + + 'cull leading 0s off whole$ + 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 + 'cull leading 0s off ex$ + 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 + + extused = 1 + + 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 + '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 + i = i + 2 + ed = 3 + e$ = "" + GOTO lffoundext + END IF + IF e$ = "~`" THEN + i = i + 2 + 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 + i = i + 1 + ed = 1 + e$ = "" + GOTO lffoundext + END IF + IF e$ = "#" THEN + i = i + 1 + ed = 2 + e$ = "" + 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) + i = i + 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 + e$ = e$ + bitn$ + GOTO lffoundext + END IF + END IF + + 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 + offset = -1 + 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 + 'number is 0 + offset = 0 + sigdigits = 0 + 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 + ed = 1 + e$ = "" + 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 + ed = 2 + e$ = "" + GOTO lffoundext + END IF + END IF + lfxdouble: + 'assume _FLOAT + ed = 3 + e$ = "": GOTO lffoundext + END IF + + extused = 0 + e$ = "" + lffoundext: + + 'make sure a leading numberic character exists + IF whole$ = "" THEN whole$ = "0" + 'if a float, ensure frac$<>"" and dp=1 + IF float THEN + dp = 1 + IF frac$ = "" THEN frac$ = "0" + END IF + 'if ed is specified, make sure ex$ exists + 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$ + "+" + a2$ = a2$ + ex$ + END IF + a2$ = a2$ + e$ + + IF extused THEN a2$ = a2$ + "," + MID$(a$, firsti, i - firsti) + + 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 + 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 + 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" + + 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 + '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 + i = i + 2 + 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 + 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) + i = i + 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 + '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 + lfhxext: + fullhx$ = fullhx$ + e$ + bitn$ + lfhxext2: + + 'build 8-byte unsigned integer rep. of hx$ + 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 + v~&& = v~&& * 16 + v2 + 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 + 'signed + + 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 + + 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 + + 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 + + IF e$ = "&&" THEN + IF v~&& > 9223372036854775807 THEN + 'note: no error checking necessary + v~&& = (NOT v~&&) + 1 + num$ = "-" + sp + str2u64$(v~&&) + 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 + num$ = "-" + sp + str2u64$(v~&&) + END IF + END IF + + END IF '<>"~" + + a2$ = a2$ + sp + num$ + e$ + bitn$ + "," + fullhx$ + + 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 + 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 + 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" + + 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 + '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 + i = i + 2 + 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 + 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) + i = i + 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 + '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 + '177777 + IF LEN(hx$) <= 6 THEN + IF LEN(hx$) < 6 OR LEFT$(hx$, 1) = "1" THEN e$ = "%" + END IF + + 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 + '********change v& to v~&&******** + v~&& = 0 + FOR i2 = 1 TO LEN(hx$) + v2 = ASC(MID$(hx$, i2, 1)) + v2 = v2 - 48 + v~&& = v~&& * 8 + v2 + NEXT + + 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 + 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 + 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" + + 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 + '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 + i = i + 2 + 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 + 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) + i = i + 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 + '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$ = "%" + + 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 + + v~&& = 0 + FOR i2 = 1 TO LEN(hx$) + v2 = ASC(MID$(hx$, i2, 1)) + v2 = v2 - 48 + v~&& = v~&& * 2 + v2 + NEXT + + GOTO finishhexoctbin + END IF + END IF + + + '----------------(number)&H??? error---------------- + 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! + 'char is from i to p2 + n2 = p2 - i + 1 + a3$ = MID$(a$, i, n2) + + '----(variable/name)rem---- + 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 + + '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 + layoutcomment = "REM" + GOTO comment + END IF + END IF + + '----(variable/name)data---- + 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 + + scan = 0 + speechmarks = 0 + commanext = 0 + finaldata = 0 + e$ = "" + 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 c = 58 THEN '":" + IF speechmarks = 0 THEN finaldata = 1: GOTO adddata + END IF + + IF c = 44 THEN '"," + IF speechmarks = 0 THEN + adddata: + 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 + 'assume closing " + IF speechmarks THEN + 'DATA_add 34 + x$ = x$ + CHR$(34) + END IF + 'append comma + 'DATA_add 44 + x$ = x$ + CHR$(44) + END IF + IF finaldata = 1 THEN GOTO finisheddata + e$ = "" + p1 = 0 + p2 = 0 + speechmarks = 0 + scan = 0 + commanext = 0 + i = i + 1 + 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 c = 34 THEN + IF speechmarks = 1 THEN + commanext = 1 + speechmarks = 0 + 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 + + 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) + 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 + '(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 + 'scan until no further alphanumerics + p2 = i + 1 + 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 + 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 lineformatnext + + lfgetve: + i = i + LEN(e2$) + a2$ = a2$ + e2$ + 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 + + GOTO lineformatnext + + END IF 'p2 + END IF 'variable/name + '----------------variable/name end---------------- + + '----------------spacing---------------- + 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 + count = 0 + 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 c = 36 AND LEN(a2$) THEN GOTO badusage '$ + + + a2$ = a2$ + sp + CHR$(c) + i = i + 1 + GOTO lineformatnext + END IF + badusage: + + 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$) + + 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$) + mcnext: + IF MID$(c$, x, 1) = "$" THEN + + 'note: $STATICksdcdweh$DYNAMIC is valid! + + IF MID$(c$, x, 7) = "$STATIC" THEN + memmode = 1 + xx = INSTR(x + 1, c$, "$") + if xx=0 then exit for else + x = xx: GOTO mcnext + END IF + + 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 + + IF MID$(c$, x, 8) = "$INCLUDE" THEN + IF Cloud THEN Give_Error "Feature not supported on QLOUD": EXIT FUNCTION + '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 + 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 + 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 + + 'add more metacommands here + + END IF '$ + NEXT + mcfinal: + + IF memmode = 1 THEN addmetastatic = 1 + IF memmode = 2 THEN addmetadynamic = 1 + + GOTO lineformatdone2 + + + + lineformatdone: + + 'line continuation? + 'note: line continuation in idemode is illegal + 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 inclevel THEN + fh = 99 + inclevel + IF EOF(fh) THEN GOTO lineformatdone2 + LINE INPUT #fh, a$ + inclinenumber(inclevel) = inclinenumber(inclevel) + 1 + GOTO includecont 'note: should not increase linenumber + END IF + + IF idemode THEN + idecommand$ = CHR$(100) + ignore = ide(0) + ideerror = 0 + a$ = idereturn$ + IF a$ = "" THEN GOTO lineformatdone2 + ELSE + a$ = lineinput3$ + IF a$ = CHR$(13) THEN GOTO lineformatdone2 + END IF + + linenumber = linenumber + 1 + + includecont: + + contline = 1 + GOTO continueline + END IF + END IF + + lineformatdone2: + 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 Debug THEN PRINT #9, "lineformat():return:" + a2$ + IF Error_Happened THEN EXIT FUNCTION + lineformat$ = a2$ + +END FUNCTION + + +SUB makeidrefer (ref$, typ AS LONG) + ref$ = str2$(currentid) + typ = id.t + ISREFERENCE +END SUB + +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 + n = n + 1 + p = i + 1 + GOTO numelementsnext +END FUNCTION + +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 + '2 = use the function returned in info$ to apply this operator + ' upon left and right side of equation + '3= bracket left and right side with negation and change operator to info$ + '4= BINARY NOT l.h.s, then apply operator in info$ + '5= UNARY, bracket up rhs, apply operator info$ to left, rebracket again + + 'lhs & rhs bit-field values + '1=integeral + '2=floating point + '4=string + '8=bool + + 'string operator + IF (typ AND ISSTRING) THEN + lhs = 4: rhs = 4 + result = 4 + 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 + + '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 + 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 + 'lhs is a float + lhs = 2 + rhs = 1 + 2 + ELSE + 'lhs isn't a float! + lhs = 1 + 2 + rhs = 2 + 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 + + 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 + + lhs = 1: rhs = 1: result = 1 + 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 Debug THEN PRINT #9, "INVALID NUMBERIC OPERATOR!": END + +END FUNCTION + +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 + + 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 + getid idnumber + 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$ + n$ = scope$ + n$ + refer$ = n$ + 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 + + IF typ AND ISSTRING 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 + typ = typ - ISUDT - ISREFERENCE - ISPOINTER + IF typ AND ISARRAY THEN typ = typ - ISARRAY + t$ = typ2ctyp$(typ, "") + IF Error_Happened THEN EXIT FUNCTION + o2$ = "(((char*)" + scope$ + n$ + ")+(" + o$ + "))" + r$ = "*" + "(" + t$ + "*)" + o2$ + END IF + + 'print "REFER:"+r$+","+str2$(typ) + refer$ = r$ + EXIT FUNCTION + END IF + + + 'array? + IF id.arraytype THEN + + n$ = RTRIM$(id.callname) + IF method = 1 THEN + refer$ = n$ + typ = typbak + 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 + offset$ = "&((uint8*)(" + n$ + "[0]))[(" + a$ + ")*" + str2(id.tsize) + "]" + r$ = "qbs_new_fixed(" + offset$ + "," + str2(id.tsize) + ",1)" + ELSE + r$ = "((qbs*)(((uint64*)(" + n$ + "[0]))[" + a$ + "]))" + END IF + stringprocessinghappened = 1 + refer$ = r$ + EXIT FUNCTION + END IF + + 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) + "," + r$ = r$ + "(uint8*)(" + n$ + "[0])" + "," + r$ = r$ + a$ + ")" + refer$ = r$ + 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 + r$ = "((" + t$ + "*)(" + n$ + "[0]))[" + a$ + "]" + refer$ = r$ + EXIT FUNCTION + END IF 'array + + 'variable? + IF id.t THEN + r$ = RTRIM$(id.n) + t = id.t + 'remove irrelavant flags + 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 + '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 + ref: + 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) + typ = typbak + END IF + refer$ = r$ + EXIT FUNCTION + END IF 'variable + + + +END FUNCTION + +SUB regid + idn = idn + 1 + + 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 + + n$ = RTRIM$(id.n) + + 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$) + id.cn = n$ + END IF + + IF LEN(Refactor_Source) THEN + n$ = RTRIM$(id.n) + IF UCASE$(n$) = UCASE$(Refactor_Source) THEN + id.cn = Refactor_Dest + END IF + END IF + + + id.insubfunc = subfunc + id.insubfuncn = subfuncn + + 'note: cannot be STATIC and SHARED at the same time + IF dimshared THEN + id.share = dimshared + ELSE + IF dimstatic THEN id.staticscope = 1 + END IF + + ids(idn) = id + + currentid = idn + + 'prepare hash flags and check for conflicts + hashflags = 1 + + 'sub/function? + 'Note: QBASIC does not allow: Internal type names (INTEGER,LONG,...) + 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 + hashchkflags = HASHFLAG_RESERVED + HASHFLAG_CONSTANT + 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 + '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 + + 'variable? + IF id.t THEN + hashflags = hashflags + HASHFLAG_VARIABLE + IF reginternalvariable = 0 THEN + allow = 0 + var_recheck: + 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 + + 'conflict with reserved word? + 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 + + '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 + '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 + '(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 + + 'conflict with constant? + 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 + + 'conflict with variable? + 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 + '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 + '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 + + varname_exception: + IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 + LOOP + END IF 'reginternalvariable + END IF 'variable + + 'array? + 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? + hashchkflags = HASHFLAG_RESERVED + HASHFLAG_SUB + HASHFLAG_FUNCTION + HASHFLAG_ARRAY + hashres = HashFind(n$, hashchkflags, hashresflags, hashresref) + DO WHILE hashres + + 'conflict with reserved word? + 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 + + '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 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 + '(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 + + 'conflict with array? + 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 + '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 + '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 + + arrayname_exception: + 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 + +SUB reginternal + reginternalsubfunc = 1 + '$INCLUDE:'subs_functions\subs_functions.bas' + reginternalsubfunc = 0 +END SUB + +'this sub is faulty atm! +'sub replacelement (a$, i, newe$) +''note: performs no action for out of range values of i +'e=1 +'s=1 +'do +'x=instr(s,a$,sp) +'if x then +'if e=i then +'a1$=left$(a$,s-1): a2$=right$(a$,len(a$)-x+1) +'a$=a1$+sp+newe$+a2$ 'note: a2 includes spacer +'exit sub +'end if +'s=x+1 +'e=e+1 +'end if +'loop until x=0 +'if e=i then +'a$=left$(a$,s-1)+sp+newe$ +'end if +'end sub + + +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 + 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) + + a$ = a2$ + +END SUB + + + +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 + '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)) + 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 + +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 + removesymbol$ = symbol$ + varname$ = LEFT$(varname$, i - 1) +END FUNCTION + +FUNCTION scope$ + IF id.share THEN scope$ = module$ + "__": EXIT FUNCTION + scope$ = module$ + "_" + subfunc$ + "_" +END FUNCTION + +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 + Lev(i) = 0 + EntryLev(i) = 0 + DitchLev(i) = 0 + DontPass(i) = 0 + TempList(i) = 0 + PassRule(i) = 0 + LevelEntered(i) = 0 + NEXT + + DIM id2 AS idstruct + + id2 = id + + IF id2.args = 0 THEN EXIT FUNCTION 'no arguments! + + + s$ = id2.specialformat + 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 + + 'note: dim'd arrays moved to global to prevent high recreation cost + + PassFlag = 1 + nextentrylevel = 0 + nextentrylevelset = 1 + level = 0 + lastt = 0 + ditchlevel = 0 + FOR i = 1 TO LEN(s$) + s2$ = MID$(s$, i, 1) + + IF s2$ = "[" THEN + level = level + 1 + LevelEntered(level) = 0 + GOTO nextsymbol + END IF + + IF s2$ = "]" THEN + level = level - 1 + IF level < ditchlevel THEN ditchlevel = level + GOTO nextsymbol + END IF + + 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$, "}") + 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) + T(lastt) = numopts + 'calculate words in each option + 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 + OptWords(lastt, x) = w + NEXT + i = i2 + + 'set entry level routine + EntryLev(lastt) = level 'default level when continuing a previously entered level + 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 + LevelEntered(level) = 1 + + GOTO nextsymbol + END IF + + 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 + EntryLev(lastt) = 0 + FOR i2 = 1 TO level - 1 + IF LevelEntered(i2) = 1 THEN EntryLev(lastt) = i2 + NEXT + END IF + LevelEntered(level) = 1 + + GOTO nextsymbol + END IF + + 'assume "special" character (like ( ) , . - etc.) + lastt = lastt + 1: Lev(lastt) = level: PassRule(lastt) = 0 + DitchLev(lastt) = ditchlevel: ditchlevel = level 'store & reset ditch level + T(lastt) = 1: Opt(lastt, 1) = s2$: OptWords(lastt, 1) = 1: DontPass(lastt) = 1 + + 'set entry level routine + EntryLev(lastt) = level 'default level when continuing a previously entered level + 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 + LevelEntered(level) = 1 + + GOTO nextsymbol + + nextsymbol: + 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 + + + '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 + + 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 + + + + + x1 = 0 'the 'x' position of the beginning element of the current levelled block + MustPassOpt = 0 'the 'x' position of the FIRST opt () in the block which must be passed + MustPassOptNeedsFlag = 0 '{}blocks don't need a flag, ? blocks do + + 'Note: For something like [{HELLO}x] a choice between passing 'hello' or passing a flag to signify x was specified + ' 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 + scannextlevel = 0 + 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 there's an opt () which must be passed that will be identified, + 'all the 1 option {}blocks can be assumed... + IF MustPassOptNeedsFlag THEN + 'The MustPassOpt requires a flag, so use the same flag for everything + FOR x2 = 1 TO templistn + PassRule(TempList(x2)) = PassFlag + NEXT + PassFlag = PassFlag * 2 + 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 + '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 + x1 = 0 + 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) + x1 = x 'set x1 to the starting element of this level + MustPassOpt = 0 + templistn = 0 + END IF + END IF + + IF x1 THEN + IF Lev(x) = l THEN 'same level + + 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 + MustPassOpt = x 'Only record the first instance (it MAY require a flag) + 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 + MustPassOpt = x: MustPassOptNeedsFlag = 0 + END IF + END IF + END IF + 'add to list + templistn = templistn + 1: TempList(templistn) = x + END IF + + 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 + + END IF + END IF + + NEXT + + 'scan last run (mostly just a copy of code from above) + 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 + 'The MustPassOpt requires a flag, so use the same flag for everything + FOR x2 = 1 TO templistn + PassRule(TempList(x2)) = PassFlag + NEXT + PassFlag = PassFlag * 2 + 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 + '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 + x1 = 0 + END IF + + 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 + + + + FOR i = 1 TO lastt: separgs(i) = "n-ll": NEXT + + + + + 'Consider: "?,[?]" + 'Notes: The comma is mandatory but the second ? is entirely optional + 'Consider: "[?[{B}?]{A}]?" + 'Notes: As unlikely as the above is, it is still valid, but pivots on the outcome of {A} being present + 'Consider: "[?]{A}" + 'Consider: "[?{A}][?{B}][?{C}]?" + 'Notes: The trick here is to realize {A} has greater priority than {B}, so all lines of enquiry must + ' be exhausted before considering {B} + + 'Use inquiry approach to solve format + 'Each line of inquiry must be exhausted + '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 + '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 + '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 + + n = numelements(ca$) + i = 1 'Position within ca$ + + level = 0 + Expression = 0 + FOR x = 1 TO lastt + + ContinueScan: + + 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 + + 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 + optional = 1 + IF level > EntryLev(x) THEN optional = 0 + ELSE + 'entrylev=lev + optional = 0 + END IF + + t = T(x) + + 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 + '****************************** + END IF + IF optional THEN + Branches = Branches + 1 + BranchFormatPos(Branches) = x + BranchTaken(Branches) = 1 + BranchInputPos(Branches) = i + BranchWithExpression(Branches) = 0 + BranchLevel(Branches) = level + level = Lev(x) + END IF + Expression = x + END IF 'A "?" expression + + IF t THEN + + currentlev = level + + 'Add new branch if new level will be entered + IF optional THEN + Branches = Branches + 1 + BranchFormatPos(Branches) = x + BranchTaken(Branches) = 1 + BranchInputPos(Branches) = i + BranchWithExpression(Branches) = Expression + BranchLevel(Branches) = level + END IF + + 'Scan for Opt () options + i1 = i: i2 = i + 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 + OutOfRange = 2147483647 + position = OutOfRange + which = 0 + 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 + c$ = getelement$(a$, i3) + IF b = 0 THEN + 'Build comparison string (spacing elements) + FOR w = 2 TO words + c$ = c$ + " " + getelement$(a$, i3 + w - 1) + NEXT w + 'Compare + IF c$ = RTRIM$(Opt(x, o)) THEN + 'Record Match + IF i3 < position THEN + position = i3 + which = o + bvalue = b + 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 + 'Because this wasn't interceppted by the above code it isn't the Opt either + END IF + IF ASC(c$) = 40 THEN + b = b + 1 + 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 + + END IF 'enough elements exist + NEXT i3 + NEXT o + END IF 'Past end of contect check + + IF position <> OutOfRange THEN 'Found? + 'Found... + level = Lev(x) 'Adjust level + IF Expression THEN + 'Found...Expression... + 'Has an expression been provided? + IF position > i AND bvalue = 0 THEN + 'Found...Expression...Provided... + separgs(Expression) = getelements$(ca$, i, position - 1) + Expression = 0 + i = position + ELSE + 'Found...Expression...Omitted... + '*********backtrack************ + GOTO OptCheckBacktrack + '****************************** + END IF + END IF 'Expression + i = i + OptWords(x, which) + separgslayout(x) = CHR$(LEN(RTRIM$(Opt(x, which)))) + RTRIM$(Opt(x, which)) + separgs(x) = CHR$(0) + str2(which) + ELSE + 'Not Found... + '*********backtrack************ + OptCheckBacktrack: + 'Was this optional? + 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 + 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 + Branches = Branches - 1 'Remove branch (it has already been tried with both possible combinations) + NEXT + IF Branches = 0 THEN 'All options have been exhausted + seperateargs_error = 1 + seperateargs_error_message = "Syntax error" + EXIT FUNCTION + END IF + '2)Toggle taken branch to untaken and revert + BranchTaken(Branches) = 0 'toggle branch to untaken + Expression = BranchWithExpression(Branches) + i = BranchInputPos(Branches) + 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 + separgs(x2) = "n-ll" + separgslayout(x2) = "" + NEXT + END IF 'Optional Opt ()? + '****************************** + + END IF 'Found? + + END IF 't + + END IF 'possible to enter level + + NEXT x + + 'Final expression? + 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 + c$ = getelement$(a$, i2) + 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 + b = b - 1 + 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 + + 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 + + ' DIM PassRule(1 TO 100) AS LONG + ' '0 means no pass rule + ' 'negative values refer to an opt () element + ' 'positive values refer to a flag value + ' PassFlag = 1 + + + 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 + + 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 + + separgs(x) = separgs(i) + separgslayout(x) = separgslayout(i) + + 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 + + IF separgs(x) = "n-ll" THEN separgs(x) = "N-LL" + x = x + 1 + + 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 + + separgslayout(i + 1) = separgslayout(i) + separgslayout(i + 1) + + END IF + NEXT + separgslayout(x) = separgslayout(i) 'set final layout + + 'x = x - 1 + 'PRINT "total arguments:"; x + 'PRINT "pass omit (0/1):"; omit + 'PRINT "pass&="; pass& + +END FUNCTION + +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 + tl$ = tlayout$ + + 'method: 0 evaulatetotyp e$ + ' 1 skip evaluation of e$ and use as is + '*due to the complexity of setting a reference with a value/string + ' 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 + getid idnumber + IF Error_Happened THEN EXIT SUB + + + 'UDT? + 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]" + + IF Cloud = 0 THEN + 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 + END IF + + IF E = 0 THEN + 'use u and u's size + + 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 (t2 AND ISREFERENCE) = 0 THEN + IF t2 AND ISPOINTER THEN + src$ = "((char*)" + e$ + ")" + e2 = 0: u2 = t2 AND 511 + ELSE + src$ = "((char*)&" + e$ + ")" + e2 = 0: u2 = t2 AND 511 + END IF + GOTO directudt + END IF + + '****problem**** + 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) + '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 + + dst$ = "(((char*)" + lhsscope$ + n$ + ")+(" + o$ + "))" + siz$ = str2$(udtxsize(u) \ 8) + + PRINT #12, "memcpy(" + dst$ + "," + src$ + "," + siz$ + ");" + + 'print "setFULLUDTrefer!" + + tlayout$ = tl$ + EXIT SUB + + 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 + o2$ = "(((uint8*)" + scope$ + n$ + ")+(" + o$ + "))" + r$ = "qbs_new_fixed(" + o2$ + "," + str2(udtetypesize(E)) + ",1)" + 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 + t$ = typ2ctyp$(typ, "") + 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 + + 'print "setUDTrefer:"+r$,e$ + tlayout$ = tl$ + EXIT SUB + END IF + + + 'array? + 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 + 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 + l$ = "if (!new_error) qbs_set(" + r$ + "," + evaluatetotyp(e$, typ) + ");" + 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 + l$ = "if (!new_error) qbs_set( ((qbs*)(((uint64*)(" + n$ + "[0]))[tmp_long]))," + evaluatetotyp(e$, typ) + ");" + 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);" + tlayout$ = tl$ + EXIT SUB + END IF + + IF (typ AND ISOFFSETINBITS) THEN + '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 + l$ = "if (!new_error) " + r$ + evaluatetotyp(e$, typ) + ");" + IF Error_Happened THEN EXIT SUB + ELSE + l$ = "if (!new_error) " + r$ + e$ + ");" + END IF + PRINT #12, l$ + tlayout$ = tl$ + 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 + l$ = "if (!new_error) ((" + t$ + "*)(" + n$ + "[0]))[tmp_long]=" + evaluatetotyp(e$, typ) + ";" + IF Error_Happened THEN EXIT SUB + ELSE + l$ = "if (!new_error) ((" + t$ + "*)(" + n$ + "[0]))[tmp_long]=" + e$ + ";" + END IF + + PRINT #12, l$ + tlayout$ = tl$ + EXIT SUB + END IF 'array + + 'variable? + IF id.t THEN + r$ = RTRIM$(id.n) + t = id.t + 'remove irrelavant flags + IF (t AND ISINCONVENTIONALMEMORY) THEN t = t - ISINCONVENTIONALMEMORY + typ = t + + 'string variable? + IF (t AND ISSTRING) THEN + IF (t AND ISFIXEDLENGTH) THEN + r$ = scope$ + "STRING" + str2(id.tsize) + "_" + r$ + 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 + tlayout$ = tl$ + 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 + 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 + l$ = "if ((" + r$ + "=" + e$ + ")&" + str2(2 ^ (b - 1)) + "){" + PRINT #12, l$ + 'signed bit is set + l$ = r$ + "|=" + str2(bitmaskinv(b)) + ";" + 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 + tlayout$ = tl$ + 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 + sref: + t2 = t - ISPOINTER + 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 + tlayout$ = tl$ + EXIT SUB + END IF 'variable + + tlayout$ = tl$ +END SUB + +FUNCTION str2$ (v AS LONG) + str2$ = 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 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 + + 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) + 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 + 'is tstr$ a named type? (eg. 'LONG') + s$ = type2symbol$(tstr$) + IF Error_Happened THEN EXIT FUNCTION + IF LEN(s$) THEN + typ2ctyp$ = typ2ctyp$(0, s$) + IF Error_Happened THEN EXIT FUNCTION + EXIT FUNCTION + END IF + + Give_Error "Invalid type": EXIT FUNCTION + +END FUNCTION + +FUNCTION type2symbol$ (typ$) + t$ = typ$ + 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 + 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 + s$ = s$ + str2$(v) + ELSE + s$ = LEFT$(s$, LEN(s$) - 1) + str2$(v) + END IF + type2symbol$ = s$ + END IF +END FUNCTION + +'Strips away bits/indentifiers which make locating a variables source difficult +FUNCTION typecomp (typ) + typ2 = typ + IF (typ2 AND ISINCONVENTIONALMEMORY) THEN typ2 = typ2 - ISINCONVENTIONALMEMORY + typecomp = typ2 +END FUNCTION + +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 + + '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 + typname2typsize = b + typname2typ& = STRINGTYPE + ISFIXEDLENGTH + EXIT FUNCTION + END IF + + 'unsigned? + 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) + 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 + + 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 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 + + IF LEFT$(t$, 9) = "STRING * " THEN + + n$ = RIGHT$(t$, LEN(t$) - 9) 'constant check 2011 hashfound = 0 - hashname$ = c$ + hashname$ = n$ hashchkflags = HASHFLAG_CONSTANT hashres = HashFindRev(hashname$, hashchkflags, hashresflags, hashresref) DO WHILE hashres @@ -13705,10750 +21683,2772 @@ IF LEFT$(typ$, 6) = "STRING" THEN END IF END IF IF v&& < 1 OR v&& > 9999999999 THEN Give_Error "STRING * out-of-range constant": EXIT FUNCTION - bytes = v&& + b = v&& 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(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: - n$ = "STRING" + str2(bytes) + "_" + varname$ - - 'array of fixed length strings - IF elements$ <> "" THEN - arraydesc = 0 - IF f = 1 THEN - try = findid(varname$ + "$") - 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 - n$ = scope2$ + "ARRAY_" + n$ - - 'nume = allocarray(n$, elements$, bytes) - 'IF arraydesc THEN goto dim2exitfunc 'id already exists! - 'clearid - - 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 - nume = allocarray(n$, elements$, bytes) - IF Error_Happened THEN EXIT FUNCTION - l$ = l$ + sp + tlayout$ - IF arraydesc THEN GOTO dim2exitfunc - clearid - - ELSE - clearid - IF elements$ = "?" THEN - nume = -1 - id.linkid = glinkid - id.linkarg = glinkarg - ELSE - nume = VAL(elements$) - END IF - END IF - - id.arraytype = STRINGTYPE + ISFIXEDLENGTH - IF cmemlist(idn + 1) THEN id.arraytype = id.arraytype + ISINCONVENTIONALMEMORY - id.n = cvarname$ - IF nume > 65536 THEN nume = nume - 65536: id.staticarray = 1 - - id.arrayelements = nume - id.callname = n$ - id.tsize = bytes - IF method = 0 THEN - id.mayhave = "$" + str2(bytes) - END IF - IF method = 1 THEN - id.musthave = "$" + str2(bytes) - END IF - regid - 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 - clearid - id.n = cvarname$ - id.t = STRINGTYPE + ISFIXEDLENGTH - 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){" - 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 - id.tsize = bytes - IF method = 0 THEN - id.mayhave = "$" + str2(bytes) - END IF - IF method = 1 THEN - id.musthave = "$" + str2(bytes) - END IF - regid - IF Error_Happened THEN EXIT FUNCTION - GOTO dim2exitfunc + typname2typsize = b + typname2typ& = STRINGTYPE + ISFIXEDLENGTH + EXIT FUNCTION END IF - 'variable length string processing - n$ = "STRING_" + varname$ - - 'array of variable length strings - IF elements$ <> "" THEN - arraydesc = 0 - IF f = 1 THEN - try = findid(varname$ + "$") - 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 - 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 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) - IF Error_Happened THEN EXIT FUNCTION - l$ = l$ + sp + tlayout$ - IF arraydesc THEN GOTO dim2exitfunc - clearid - - ELSE - clearid - IF elements$ = "?" THEN - nume = -1 - id.linkid = glinkid - id.linkarg = glinkarg - 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 - - id.arrayelements = nume - id.callname = n$ - IF method = 0 THEN - id.mayhave = "$" - END IF - IF method = 1 THEN - id.musthave = "$" - END IF - regid - 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);" - 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 - id.mayhave = "$" - END IF - IF method = 1 THEN - id.musthave = "$" - END IF - regid - IF Error_Happened THEN EXIT FUNCTION - GOTO dim2exitfunc -END IF - -IF LEFT$(typ$, 4) = "_BIT" THEN - IF LEN(typ$) > 4 THEN - IF LEFT$(typ$, 7) <> "_BIT * " THEN Give_Error "Expected _BIT * number": EXIT FUNCTION - c$ = RIGHT$(typ$, LEN(typ$) - 7) - 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$ - n$ = n$ + "BIT" + str2(bits) + "_" + varname$ - - 'array of bit-length variables - IF elements$ <> "" THEN - arraydesc = 0 - cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" - cmps$ = cmps$ + "`" + str2(bits) - IF f = 1 THEN - try = findid(cmps$) - 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 - 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 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) - IF Error_Happened THEN EXIT FUNCTION - l$ = l$ + sp + tlayout$ - IF arraydesc THEN GOTO dim2exitfunc - clearid - - ELSE - clearid - IF elements$ = "?" THEN - nume = -1 - id.linkid = glinkid - id.linkarg = glinkarg - 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 - - 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 - regid - 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 - arraydesc = 0 - cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" - cmps$ = cmps$ + "%%" - IF f = 1 THEN - try = findid(cmps$) - 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 - n$ = scope2$ + "ARRAY_" + n$ - - 'nume = allocarray(n$, elements$, 1) - 'IF arraydesc THEN goto dim2exitfunc - 'clearid - - 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 - nume = allocarray(n$, elements$, 1) - IF Error_Happened THEN EXIT FUNCTION - l$ = l$ + sp + tlayout$ - IF arraydesc THEN GOTO dim2exitfunc - clearid - - ELSE - clearid - IF elements$ = "?" THEN - nume = -1 - id.linkid = glinkid - id.linkarg = glinkarg - 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.arrayelements = nume - id.callname = n$ - 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 = 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 - arraydesc = 0 - cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" - cmps$ = cmps$ + "%" - IF f = 1 THEN - try = findid(cmps$) - 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 - n$ = scope2$ + "ARRAY_" + n$ - - 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 - nume = allocarray(n$, elements$, 2) - IF Error_Happened THEN EXIT FUNCTION - l$ = l$ + sp + tlayout$ - IF arraydesc THEN GOTO dim2exitfunc - clearid - - ELSE - clearid - IF elements$ = "?" THEN - nume = -1 - id.linkid = glinkid - id.linkarg = glinkarg - 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.arrayelements = nume - id.callname = n$ - 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 = 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 - arraydesc = 0 - cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" - cmps$ = cmps$ + "%&" - IF f = 1 THEN - try = findid(cmps$) - 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 - n$ = scope2$ + "ARRAY_" + n$ - - 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 - nume = allocarray(n$, elements$, OS_BITS \ 8) - IF Error_Happened THEN EXIT FUNCTION - l$ = l$ + sp + tlayout$ - IF arraydesc THEN GOTO dim2exitfunc - clearid - - ELSE - clearid - IF elements$ = "?" THEN - nume = -1 - id.linkid = glinkid - id.linkarg = glinkarg - 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.arrayelements = nume - id.callname = n$ - 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 = 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 - arraydesc = 0 - cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" - cmps$ = cmps$ + "&" - IF f = 1 THEN - try = findid(cmps$) - 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 - n$ = scope2$ + "ARRAY_" + n$ - - 'nume = allocarray(n$, elements$, 4) - 'IF arraydesc THEN goto dim2exitfunc - 'clearid - - 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 - nume = allocarray(n$, elements$, 4) - IF Error_Happened THEN EXIT FUNCTION - l$ = l$ + sp + tlayout$ - IF arraydesc THEN GOTO dim2exitfunc - clearid - - ELSE - clearid - IF elements$ = "?" THEN - nume = -1 - id.linkid = glinkid - id.linkarg = glinkarg - 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.arrayelements = nume - id.callname = n$ - 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 = 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 - arraydesc = 0 - cmps$ = varname$: IF unsgn THEN cmps$ = cmps$ + "~" - cmps$ = cmps$ + "&&" - IF f = 1 THEN - try = findid(cmps$) - 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 - n$ = scope2$ + "ARRAY_" + n$ - - 'nume = allocarray(n$, elements$, 8) - 'IF arraydesc THEN goto dim2exitfunc - 'clearid - - 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 - nume = allocarray(n$, elements$, 8) - IF Error_Happened THEN EXIT FUNCTION - l$ = l$ + sp + tlayout$ - IF arraydesc THEN GOTO dim2exitfunc - clearid - - ELSE - clearid - IF elements$ = "?" THEN - nume = -1 - id.linkid = glinkid - id.linkarg = glinkarg - 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.arrayelements = nume - id.callname = n$ - 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 = 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 - arraydesc = 0 - cmps$ = varname$ + "!" - IF f = 1 THEN - try = findid(cmps$) - 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 - n$ = scope2$ + "ARRAY_" + n$ - - 'nume = allocarray(n$, elements$, 4) - 'IF arraydesc THEN goto dim2exitfunc - 'clearid - - 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 - nume = allocarray(n$, elements$, 4) - IF Error_Happened THEN EXIT FUNCTION - l$ = l$ + sp + tlayout$ - IF arraydesc THEN GOTO dim2exitfunc - clearid - - ELSE - clearid - IF elements$ = "?" THEN - nume = -1 - id.linkid = glinkid - id.linkarg = glinkarg - 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 - - id.arrayelements = nume - id.callname = n$ - 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 - 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 - arraydesc = 0 - cmps$ = varname$ + "#" - IF f = 1 THEN - try = findid(cmps$) - 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 - n$ = scope2$ + "ARRAY_" + n$ - - 'nume = allocarray(n$, elements$, 8) - 'IF arraydesc THEN goto dim2exitfunc - 'clearid - - 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 - nume = allocarray(n$, elements$, 8) - IF Error_Happened THEN EXIT FUNCTION - l$ = l$ + sp + tlayout$ - IF arraydesc THEN GOTO dim2exitfunc - clearid - - ELSE - clearid - IF elements$ = "?" THEN - nume = -1 - id.linkid = glinkid - id.linkarg = glinkarg - 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 - - id.arrayelements = nume - id.callname = n$ - 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 - 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 - arraydesc = 0 - cmps$ = varname$ + "##" - IF f = 1 THEN - try = findid(cmps$) - 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 - n$ = scope2$ + "ARRAY_" + n$ - - 'nume = allocarray(n$, elements$, 32) - 'IF arraydesc THEN goto dim2exitfunc - 'clearid - - 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 - nume = allocarray(n$, elements$, 32) - IF Error_Happened THEN EXIT FUNCTION - l$ = l$ + sp + tlayout$ - IF arraydesc THEN GOTO dim2exitfunc - clearid - - ELSE - clearid - IF elements$ = "?" THEN - nume = -1 - id.linkid = glinkid - id.linkarg = glinkarg - 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 - - id.arrayelements = nume - id.callname = n$ - 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 - 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 - 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 - -tlayout$ = l$ - -END FUNCTION - - -FUNCTION udtreference$ (o$, a$, typ AS LONG) -'UDT REFERENCE FORMAT -'idno|udtno|udtelementno|byteoffset -' ^udt of the element, not of the id - -obak$ = o$ - -'PRINT "called udtreference!" - - -r$ = str2$(currentid) + sp3 - - -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 -E = 0 - -n = numelements(a$) -IF n = 0 THEN GOTO fulludt - -i = 1 -udtfindelenext: -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 - -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 n$ <> n2$ THEN - 'increment fixed offset - o = o + udtesize(E) - GOTO udtfindele -END IF - -'check symbol after element's name (if given) is correct -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 -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 - E = 0 - i = i + 1 - GOTO udtfindelenext -END IF - -'Change e reference to u CHR$(179) 0 reference? -IF udtetype(E) AND ISUDT THEN - u = udtetype(E) AND 511 - E = 0 -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 -o = o \ 8 - -IF o$ <> "" THEN - IF o <> 0 THEN 'dont add an unnecessary 0 - o$ = o$ + "+" + str2$(o) - END IF -ELSE - o$ = str2$(o) -END IF - -r$ = r$ + o$ - -udtreference$ = r$ -typ = udtetype(E) + ISUDT + ISREFERENCE - -'full udt override: -IF E = 0 THEN - typ = u + ISUDT + ISREFERENCE -END IF - -IF obak$ <> "" THEN typ = typ + ISARRAY -IF incmem THEN typ = typ + ISINCONVENTIONALMEMORY - -'print "UDTREF:"+r$+","+str2$(typ) - -END FUNCTION - -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 - - - - - - -'''cl$ = classify(a$) - -blockn = 0 -n = numelements(a$) -b = 0 'bracketting level -FOR i = 1 TO n - - reevaluate: - - - - - l$ = getelement(a$, i) - - - IF Debug THEN PRINT #9, "#*#*#* reevaluating:" + l$, i - - - 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 Debug THEN PRINT #9, l$ - - l2$ = l$ 'pure version of l$ - 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 - l$ = l$ + defineextaz(v) - END IF - END IF - ELSE - l$ = l2$ - END IF - END IF - try = findid(l$) - IF Error_Happened THEN EXIT FUNCTION - DO WHILE 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 - arrayid = currentid - constequation = 0 - i2 = i + 2 - b2 = 0 - evalnextele3: - l2$ = getelement(a$, i2) - IF l2$ = "(" THEN b2 = b2 + 1 - IF l2$ = ")" THEN - b2 = b2 - 1 - IF b2 = -1 THEN - c$ = arrayreference(getelements$(a$, i + 2, i2 - 1), typ2) - IF Error_Happened THEN EXIT FUNCTION - i = i2 - - 'UDT - 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)) - 'change o$ to a byte offset if necessary - 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 - s = s \ 8 - END IF - o$ = "(" + o$ + ")*" + str2$(s) - 'print "calling evaludt with o$:"+o$ - GOTO evaludt - END IF - - GOTO evalednextele3 - END IF - END IF - i2 = i2 + 1 - 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 - - 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 - constequation = 0 - blockn = blockn + 1 - makeidrefer block(blockn), blocktype(blockn) - IF (blocktype(blockn) AND ISSTRING) THEN stringprocessinghappened = 1 - evaledblock(blockn) = 2 - 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 - constequation = 0 - o$ = "" - evaludt: - b2 = 0 - i3 = i + 1 - 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 - i4 = i2 - 1 - 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) - 'PRINT "UDTREFERENCE:";l$; e$ - e$ = udtreference(o$, e$, typ2) - IF Error_Happened THEN EXIT FUNCTION - i = i4 - blockn = blockn + 1 - block(blockn) = e$ - evaledblock(blockn) = 2 - blocktype(blockn) = typ2 - 'is the following next necessary? - 'IF (typ2 AND ISSTRING) THEN stringprocessinghappened = 1 - GOTO evaled - END IF - END IF - - END IF '"(" or no "(" - - 'is l$ a function? - IF id.subfunc = 1 THEN - constequation = 0 - 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 - b2 = b2 - 1 - 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 - i = i2 - GOTO evalednextele - END IF - END IF - IF l2$ = "," AND b2 = 0 THEN args = args + 1 - i2 = i2 + 1 - GOTO evalnextele - ELSE - 'no brackets - c$ = evaluatefunc("", 0, typ2) - 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 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 - dtyp$ = removesymbol(l$) - IF Error_Happened THEN EXIT FUNCTION - 'count the number of elements - nume = 1 - b2 = 0 - 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 THEN Give_Error "Array '" + l$ + "' (" + symbol2fulltypename$(dtyp$) + ") not defined": EXIT FUNCTION - IF Error_Happened THEN EXIT FUNCTION - olddimstatic = dimstatic - method = 1 - 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 - varname2$ = getelement$(staticarraylist, xi): xi = xi + 1 - typ2$ = 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 - l3$ = l2$: s$ = removesymbol(l3$) - 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 - ignore = dim2(l$, dtyp$, method, fakee$) - 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 - - l$ = l2$ 'restore l$ - - END IF 'b=0 - - IF l$ = "(" THEN - IF b = 0 THEN i1 = i + 1 - b = b + 1 - END IF - - IF b = 0 THEN - blockn = blockn + 1 - block(blockn) = l$ - evaledblock(blockn) = 0 - END IF - - IF l$ = ")" THEN - b = b - 1 - 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 - blockn = blockn + 1 - IF (typ2 AND ISPOINTER) THEN - block(blockn) = c$ - ELSE - block(blockn) = "(" + c$ + ")" - END IF - evaledblock(blockn) = 1 - blocktype(blockn) = typ2 - END IF - END IF - evaled: -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 - - - -'identify any referencable values -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 - num$ = block(i) - 'a float? - f = 0 - x = INSTR(num$, "E") - IF x THEN - f = 1: blocktype(i) = SINGLETYPE - ISPOINTER - ELSE - x = INSTR(num$, "D") - IF x THEN - f = 2: blocktype(i) = DOUBLETYPE - ISPOINTER - ELSE - x = INSTR(num$, "F") - IF x THEN - f = 3: blocktype(i) = FLOATTYPE - ISPOINTER - 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 - '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 - block(i) = " " + num$ + " " 'pad with spaces to avoid C++ computation errors - evaledblock(i) = 1 - GOTO evaledblock - END IF - - 'number? - 'fc = ASC(LEFT$(block(i), 1)) - 'IF fc = 45 OR (fc >= 48 AND fc <= 57) THEN '- or 0-9 - ''it's a number - ''check for an extension, if none, assume integer - 'blocktype(i) = INTEGER64TYPE - ISPOINTER - 'tblock$ = " " + block(i) - 'IF RIGHT$(tblock$, 2) = "##" THEN blocktype(i) = FLOATTYPE - ISPOINTER: block(i) = LEFT$(block(i), LEN(block$(i)) - 2): GOTO evfltnum - 'IF RIGHT$(tblock$, 1) = "#" THEN blocktype(i) = DOUBLETYPE - ISPOINTER: block(i) = LEFT$(block(i), LEN(block$(i)) - 1): GOTO evfltnum - 'IF RIGHT$(tblock$, 1) = "!" THEN blocktype(i) = SINGLETYPE - ISPOINTER: block(i) = LEFT$(block(i), LEN(block$(i)) - 1): GOTO evfltnum - ' - ''C++ 32bit unsigned to signed 64bit - 'IF INSTR(block(i),".")=0 THEN - ' - 'negated=0 - 'if left$(block(i),1)="-" then block(i)=right$(block(i),len(block(i))-1):negated=1 - ' - 'if left$(block(i),2)="0x" then 'hex - 'if len(block(i))=10 then - 'if block(i)>="0x80000000" and block(i)<="0xFFFFFFFF" then block(i)="(int64)"+block(i): goto evnum - 'end if - 'if len(block(i))>10 then block(i)=block(i)+"ll": goto evnum - 'goto evnum - 'end if - ' - 'if left$(block(i),1)="0" then 'octal - 'if len(block(i))=12 then - 'if block(i)>="020000000000" and block(i)<="037777777777" then block(i)="(int64)"+block(i): goto evnum - 'if block(i)>"037777777777" then block(i)=block(i)+"ll": goto evnum - 'end if - 'if len(block(i))>12 then block(i)=block(i)+"ll": goto evnum - 'goto evnum - 'end if - ' - ''decimal - 'if len(block(i))=10 then - 'if block(i)>="2147483648" and block(i)<="4294967295" then block(i)="(int64)"+block(i): goto evnum - 'if block(i)>"4294967295" then block(i)=block(i)+"ll": goto evnum - 'end if - 'if len(block(i))>10 then block(i)=block(i)+"ll" - ' - 'evnum: - ' - 'if negated=1 then block(i)="-"+block(i) - ' - 'END IF - ' - 'evfltnum: - ' - 'block(i) = " " + block(i)+" " - 'evaledblock(i) = 1 - 'GOTO evaledblock - 'END IF - - 'a typed string in "" - 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 - block(i) = "qbs_new_txt(" + block(i) + ")" - END IF - blocktype(i) = ISSTRING - evaledblock(i) = 1 - stringprocessinghappened = 1 - GOTO evaledblock - END IF - - 'create variable - IF isvalidvariable(block(i)) THEN - x$ = block(i) - - typ$ = removesymbol$(x$) - 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 - typ$ = defineextaz(v) - 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 Debug THEN PRINT #9, "CREATING VARIABLE:" + x$ - IF optionexplicit THEN Give_Error "Variable '" + x$ + "' (" + symbol2fulltypename$(typ$) + ") not defined": EXIT FUNCTION - retval = dim2(x$, typ$, 1, "") - 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 - 'reference value - 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 - - 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 - - END IF - - END IF - END IF - evaledblock: -NEXT - - -'return a POINTER if possible -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) - typ = blocktype(1) - evaluate$ = block(1) + IF t$ = "SINGLE" THEN typname2typ& = SINGLETYPE: EXIT FUNCTION + IF t$ = "DOUBLE" THEN typname2typ& = DOUBLETYPE: EXIT FUNCTION + IF t$ = "_FLOAT" THEN typname2typ& = FLOATTYPE: EXIT FUNCTION + IF LEFT$(t$, 10) = "_UNSIGNED " THEN u = 1: t$ = RIGHT$(t$, LEN(t$) - 10) + IF LEFT$(t$, 4) = "_BIT" THEN + IF t$ = "_BIT" THEN + IF u THEN typname2typ& = UBITTYPE ELSE typname2typ& = BITTYPE EXIT FUNCTION END IF - END IF -END IF -'it cannot be returned as a pointer - - - - - - - - -IF Debug THEN PRINT #9, "applying operators:"; - - -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? - typ = blocktype(2) 'init typ with second blocktype - END IF -END IF - -nonop = 0 -FOR i = 1 TO blockn - - IF evaledblock(i) = 0 THEN - isop = isoperator(block(i)) - IF isop THEN - nonop = 0 - - constequation = 0 - - 'operator found - o$ = block(i) - u = operatorusage(o$, typ, i$, lhstyp, rhstyp, result) - - 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 - - 'lhstyp & rhstyp bit-field values - '1=integeral - '2=floating point - '4=string - '8=bool *only used for result - - oldtyp = typ - newtyp = blocktype(i + 1) - - 'IF block(i - 1) = "6" THEN - 'PRINT o$ - 'PRINT oldtyp AND ISFLOAT - 'PRINT blocktype(i - 1) AND ISFLOAT - 'END - 'END IF - - - - '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 - - 'Offset protection: Override conversion rules for operator as necessary - offsetmode = 0 - offsetcvi = 0 - 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 - - '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 - '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 - 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 - '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 result = 2 THEN result = 1 'force integer result - 'note: result=1 just sets typ&=64 if typ is a float - - 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 - '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 - 'convert float to int - block(i - 1) = "qbr(" + block(i - 1) + ")" - oldtyp = 64& - END IF - ELSE - 'oldtyp is an int - 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 - 'convert rhs - 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 - 'convert float to int - block(i + 1) = "qbr(" + block(i + 1) + ")" - newtyp = 64& - END IF - ELSE - 'newtyp is an int - 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 - - 'Reduce floating point values to common base for comparison? - 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..." - ' IF S < 2.1 THEN PRINT "LESS THAN 2.1" - 'concerns: - '1. Return value from TIMER will be reduced to a SINGLE in direct comparisons - '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 - 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 - 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 - - typ = newtyp - - 'STEP 2: markup typ - ' if either side is a float, markup typ to largest float - ' 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 - '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 - typ = ISFLOAT + b - 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 - 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 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 - typ = 32 - 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 - - 'override typ=ISFLOAT+256 to typ=ISFLOAT+64 for ^ operator's result - IF u = 2 THEN - IF i$ = "pow2" THEN - - 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 - '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 - 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 - typ = ISFLOAT + b - - END IF 'pow2 - END IF 'u=2 - - 'STEP 3: apply operator appropriately - - IF u = 5 THEN - block(i + 1) = i$ + "(" + block(i + 1) + ")" - block(i) = "": i = i + 1: GOTO operatorapplied - END IF - - 'binary operators - - 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 - - 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 - - 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 - - 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 - - '...more?... - - 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 - offsetmode = 0 - - ELSE - nonop = nonop + 1 - 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, "" - -'join blocks -FOR i = 1 TO blockn - r$ = r$ + block(i) -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 - - -evaluate$ = r$ - - - -END FUNCTION - - - - -FUNCTION evaluatefunc$ (a2$, args AS LONG, typ AS LONG) -a$ = a2$ - -IF Debug THEN PRINT #9, "evaluatingfunction:" + RTRIM$(id.n) + ":" + a$ - -DIM id2 AS idstruct - -id2 = id -n$ = RTRIM$(id2.n) -typ = id2.ret -targetid = currentid - -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 - - 'count omittable args - sqb = 0 - a = 0 - 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 - 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 - - passomit = 1 'pass omit flags param to function - - IF id2.args = args THEN omitarg_first = 0: omitarg_last = 0 'all arguments were passed! - -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 id2.args <> args THEN Give_Error "Incorrect number of arguments passed to function": EXIT FUNCTION - -END IF - -skipargnumchk: - -IF id2.NoCloud THEN - IF Cloud THEN Give_Error "Feature not supported on QLOUD" '***NOCLOUD*** -END IF - -r$ = RTRIM$(id2.callname) + "(" - - -IF id2.args <> 0 THEN - - curarg = 1 - firsti = 1 - - n = numelements(a$) - IF n = 0 THEN i = 0: GOTO noargs - - FOR i = 1 TO n - - - - IF curarg >= omitarg_first AND curarg <= omitarg_last THEN - noargs: - 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" - curarg = curarg + omitargs - IF i = n THEN EXIT FOR - r$ = r$ + "," - 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 - - 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 - e$ = getelements$(a$, firsti, i) - ELSE - e$ = getelements$(a$, firsti, i - 1) - END IF - - IF LEFT$(e$, 2) = "(" + sp THEN dereference = 1 ELSE dereference = 0 - - - - '*special case CVI,CVL,CVS,CVD,_CV (part #1) - IF n$ = "_CV" THEN - IF curarg = 1 THEN - cvtype$ = type2symbol$(e$) - IF Error_Happened THEN EXIT FUNCTION - e$ = "" - GOTO dontevaluate - END IF - END IF - - '*special case MKI,MKL,MKS,MKD,_MK (part #1) - - IF n$ = "_MK" 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$ + "]" - e$ = "" - GOTO dontevaluate - END IF - END IF - END IF - - 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 - 'make a note of the array's index for later - ulboundarray$ = e$ - ulboundarraytyp = sourcetyp - e$ = "" - r$ = "" - 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 - - - '*special case* - IF n$ = "ASC" THEN - IF curarg = 2 THEN - e$ = evaluatetotyp$(e$, 32&) - IF Error_Happened THEN EXIT FUNCTION - typ& = LONGTYPE - ISPOINTER - r$ = r$ + e$ + ")" - GOTO evalfuncspecial - END IF - END IF - - - 'PRINT #12, "n$="; n$ - 'PRINT #12, "curarg="; curarg - 'PRINT #12, "e$="; e$ - 'PRINT #12, "r$="; r$ - - '*special case* - IF n$ = "_MEMGET" THEN - IF curarg = 1 THEN - memget_blk$ = e$ - 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 - t = typname2typ(e$) - IF t = 0 THEN Give_Error "Invalid TYPE name": EXIT FUNCTION - IF t AND ISOFFSETINBITS THEN Give_Error "_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 - memget_ctyp$ = "qbs*" - ELSE - IF t AND ISUDT THEN - memget_size = udtxsize(t AND 511) \ 8 - memget_ctyp$ = "void*" - ELSE - memget_size = (t AND 511) \ 8 - memget_ctyp$ = typ2ctyp$(t, "") - END IF - END IF - - - - - - 'assume checking off - offs$ = evaluatetotyp(memget_offs$, OFFSETTYPE - ISPOINTER) - blkoffs$ = evaluatetotyp(memget_blk$, -6) - 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 - r$ = "qbs_new_txt_len((char*)" + offs$ + "," + str2(memget_size) + ")" - ELSE - IF t AND ISUDT THEN - r$ = "((void*)+" + offs$ + ")" - t = ISUDT + ISPOINTER + (t AND 511) - ELSE - r$ = "*(" + memget_ctyp$ + "*)(" + offs$ + ")" - IF t AND ISPOINTER THEN t = t - ISPOINTER - END IF - END IF - - - - - - - - typ& = t - - - GOTO evalfuncspecial - END IF - END IF - - '------------------------------------------------------------------------------------------------------------ - e2$ = e$ - e$ = evaluate(e$, sourcetyp) - IF Error_Happened THEN EXIT FUNCTION - '------------------------------------------------------------------------------------------------------------ - - '***special case*** - IF n$ = "_MEM" 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 - - '*special case* - IF n$ = "_OFFSET" THEN - IF (sourcetyp AND ISREFERENCE) = 0 THEN - Give_Error "_OFFSET expects the name of a variable/array": EXIT FUNCTION - END IF - IF (sourcetyp AND ISARRAY) THEN - IF (sourcetyp AND ISOFFSETINBITS) THEN Give_Error "_OFFSET cannot reference _BIT type arrays": EXIT FUNCTION - END IF - r$ = "((uptrszint)(" + evaluatetotyp$(e2$, -6) + "))" - IF Error_Happened THEN EXIT FUNCTION - typ& = UOFFSETTYPE - ISPOINTER - 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 - - '*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 - - '*special case* - IF n$ = "LEN" THEN - typ& = LONGTYPE - ISPOINTER - IF (sourcetyp AND ISREFERENCE) = 0 THEN - 'could be a string expression - 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 - r$ = evaluatetotyp$(e2$, -5) 'use evaluatetotyp to get 'element' size - 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 (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 - e$ = "func_oct(" + e$ + "," + str2$(bits) + ")" - ELSE - IF (sourcetyp AND ISFLOAT) THEN - e$ = "func_oct_float(" + e$ + ")" - ELSE - IF bits = 64 THEN - IF wasref = 0 THEN bits = 0 - END IF - e$ = "func_oct(" + e$ + "," + str2$(bits) + ")" - END IF - END IF - typ& = STRINGTYPE - ISPOINTER - r$ = e$ - 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 - 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 - chars = (bits + 3) \ 4 - e$ = "func_hex(" + e$ + "," + str2$(chars) + ")" - 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 - e$ = "func_hex(" + e$ + "," + str2$(chars) + ")" - END IF - END IF - typ& = STRINGTYPE - ISPOINTER - r$ = e$ - GOTO evalfuncspecial - END IF - END IF - - - - - - - - - - '*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 - 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 - 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 - r$ = e$ - 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 - 'establish which function (if any!) should be used - IF (sourcetyp AND ISFLOAT) THEN e$ = "floor(" + e$ + ")" ELSE e$ = "(" + e$ + ")" - r$ = e$ - typ& = sourcetyp - 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 - '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 - e$ = "(" + e$ + ")" - END IF - r$ = e$ - typ& = sourcetyp - GOTO evalfuncspecial - END IF - - '*special case* - IF n$ = "_ROUND" 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 - e$ = "(" + e$ + ")" - 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 - - - '*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 - '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 - e$ = "((double)(" + e$ + "))" - END IF - r$ = e$ - typ& = DOUBLETYPE - ISPOINTER - 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 - '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 - e$ = "((double)(" + e$ + "))" - END IF - r$ = e$ - typ& = SINGLETYPE - ISPOINTER - 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 - '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 - r$ = e$ - typ& = 32& - 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 - '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 - r$ = e$ - typ& = 16& - 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" THEN mktype = -1 - IF mktype THEN - IF mktype <> -1 OR curarg = 2 THEN - IF (sourcetyp AND ISOFFSET) THEN Give_Error "Cannot convert _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 "_MK only accepts numeric types": EXIT FUNCTION - IF size THEN - r$ = ctype$ + "2string(" + str2(size) + "," - ELSE - r$ = ctype$ + "2string(" - END IF - nocomma = 1 - targettyp = qtyp& - 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" 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 "_CV cannot return STRING type!": EXIT FUNCTION - IF ctype$ = "bit" OR ctype$ = "ubit" THEN - r$ = "string2" + ctype$ + "(" + e$ + "," + str2(size) + ")" - ELSE - r$ = "string2" + ctype$ + "(" + e$ + ")" - 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 - sourcetyp = 64& - e$ = "(" + e$ + "->chr[0])" - 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 - recompile = 1 - cmemlist(VAL(e$)) = 1 - r$ = "[CONVENTIONAL_MEMORY_REQUIRED]" - typ& = 64& - GOTO evalfuncspecial - END IF - r$ = refer(e$, sourcetyp, 0) - IF Error_Happened THEN EXIT FUNCTION - r$ = "((unsigned short)(" + r$ + "->chr-&cmem[1280]))" - typ& = 64& - 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.musthave) = "$" THEN - IF (sourcetyp AND ISINCONVENTIONALMEMORY) = 0 THEN - recompile = 1 - cmemlist(VAL(e$)) = 1 - r$ = "[CONVENTIONAL_MEMORY_REQUIRED]" - typ& = ISSTRING - 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 - - '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 - r$ = r$ + "->cmem_descriptor_offset" - t = 3 - ELSE - r$ = "((unsigned short)(((uint8*)" + r$ + ")-&cmem[1280]))" - '*top bit on=unsigned - '*second top bit on=bit-value (lower bits indicate the size) - 'BYTE=1 - 'INTEGER=2 - 'STRING=3 - 'SINGLE=4 - 'INT64=5 - 'FLOAT=6 - 'DOUBLE=8 - 'LONG=20 - 'BIT=64+n - t = 0 - 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 - r$ = "func_varptr_helper(" + str2(t) + "," + r$ + ")" - typ& = ISSTRING - GOTO evalfuncspecial - END IF 'end of varptr$ - - - - - - - - - - - - 'VARPTR - IF (sourcetyp AND ISINCONVENTIONALMEMORY) = 0 THEN - recompile = 1 - cmemlist(VAL(e$)) = 1 - r$ = "[CONVENTIONAL_MEMORY_REQUIRED]" - typ& = 64& - GOTO evalfuncspecial - END IF - - 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 - m = id.tsize - index$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) - typ = 64& - r$ = "((" + index$ + ")*" + str2(m) + ")" - GOTO evalfuncspecial - ELSE - 'return the offset of the string's descriptor - r$ = refer(e$, sourcetyp, 0) - IF Error_Happened THEN EXIT FUNCTION - r$ = r$ + "->cmem_descriptor_offset" - typ = 64& - 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 - typ = 64& - r$ = "(" + o$ + ")" - GOTO evalfuncspecial - END IF - - 'non-UDT array - m = (sourcetyp AND 511) \ 8 'calculate size multiplier - index$ = RIGHT$(e$, LEN(e$) - INSTR(e$, sp3)) - typ = 64& - r$ = "((" + index$ + ")*" + str2(m) + ")" - GOTO evalfuncspecial - - END IF - - 'not an array - - 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 - 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 - '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 - 'give offset relative to DBLOCK - r$ = "((unsigned short)(((uint8*)" + r$ + ") - &cmem[1280] + (" + o$ + ") ))" - 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 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 - r$ = "varptr_dblock_check(" + r$ + "->chr)" - ELSE 'definitely in DBLOCK - r$ = "((unsigned short)(" + r$ + "->chr-&cmem[1280]))" - END IF - - ELSE - r$ = r$ + "->cmem_descriptor_offset" - 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 - r$ = "varptr_dblock_check((uint8*)" + r$ + ")" - ELSE 'definitely in DBLOCK - r$ = "((unsigned short)(((uint8*)" + r$ + ")-&cmem[1280]))" - 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 - recompile = 1 - cmemlist(VAL(e$)) = 1 - r$ = "[CONVENTIONAL_MEMORY_REQUIRED]" - typ& = 64& - GOTO evalfuncspecial - END IF - 'array? - 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 - typ = 64& - r$ = "( ( ((ptrszint)(" + refer(e$, sourcetyp, 1) + "[0])) - ((ptrszint)(&cmem[0])) ) /16)" - 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 - 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 - r$ = "varseg_dblock_check(((uint8*)" + r$ + ")+(" + o$ + "))" - ELSE - r$ = "varseg_dblock_check((uint8*)" + refer(e$, sourcetyp, 1) + ")" - 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 - - - - - - - - - - - - - - - - 'note: this code has already been called... - '------------------------------------------------------------------------------------------------------------ - 'e2$ = e$ - 'e$ = evaluate(e$, sourcetyp) - '------------------------------------------------------------------------------------------------------------ - - 'note: this comment makes no sense... - 'any numeric variable, but it must be type-speficied - - IF targettyp = -2 THEN - e$ = evaluatetotyp(e2$, -2) - IF Error_Happened THEN EXIT FUNCTION - GOTO dontevaluate - END IF '-2 - - IF targettyp = -7 THEN - e$ = evaluatetotyp(e2$, -7) - IF Error_Happened THEN EXIT FUNCTION - GOTO dontevaluate - END IF '-7 - - IF targettyp = -8 THEN - e$ = evaluatetotyp(e2$, -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 - - 'note: this is used for functions like STR(...) which accept all types... - explicitreference = 0 - IF targettyp = -1 THEN - explicitreference = 1 - 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 - - 'pointer? - 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$ + "]" - - '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 - - 'check arrayname was followed by '()' - IF targettyp AND ISUDT THEN - IF Debug THEN PRINT #9, "evaluatefunc:array reference:udt reference:[" + e$ + "]" - 'get UDT info - 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) - '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 - - - idnum = VAL(LEFT$(e$, INSTR(e$, sp3) - 1)) - getid idnum - 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 MID$(sfcmemargs(targetid), curarg, 1) = CHR$(1) THEN 'cmem required? - IF cmemlist(idnum) = 0 THEN - cmemlist(idnum) = 1 - - recompile = 1 - END IF - END IF - - - - 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 - 'only continue if the number of array elements required is unknown - 'and it needs to be set - - IF id.arrayelements <> -1 THEN - nelereq = id.arrayelements - MID$(id2.nelereq, curarg, 1) = CHR$(nelereq) - END IF - - ids(targetid) = id2 - - ELSE - - 'the number of array elements required is known AND - 'the number of elements in the array to be passed is known - - - - 'REMOVE FOR TESTING PURPOSES ONLY!!! SHOULD BE UNREM'd! - '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 - - - - END IF - END IF - - - e$ = refer(e$, sourcetyp, 1) - IF Error_Happened THEN EXIT FUNCTION - GOTO dontevaluate - END IF - - - - - - - - - - - - - '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 - - 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 - - '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) - - 'compare types - IF sourcetyp2 = targettyp2 THEN - - IF sourcetyp AND ISUDT THEN - 'udt/udt array - - 'get info - 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) - '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 - - 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 - - ELSE - 'not a udt - 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 - e$ = refer(e$, sourcetyp, 1) - 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 - - 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 - cmemlist(idnum) = 1 - recompile = 1 - END IF - END IF - - GOTO dontevaluate - END IF 'similar - - 'IF sourcetyp2 = targettyp2 THEN - 'IF arr THEN - 'IF (sourcetyp2 AND ISOFFSETINBITS) THEN Give_Error "Cannot pass BIT array offsets yet": EXIT FUNCTION - 'e$ = "(&(" + refer(e$, sourcetyp, 0) + "))" - 'ELSE - 'e$ = refer(e$, sourcetyp, 1) - 'END IF - 'GOTO dontevaluate - 'END IF - - END IF 'source is a reference - - 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 - cmemlist(idnum) = 1 - recompile = 1 - END IF - END IF - END IF 'reference - - END IF 'string - - END IF 'dereference was not used - END IF 'pointer - - - 'note: Target is not a pointer... - - 'IF (targettyp AND ISSTRING) = 0 THEN - 'IF (sourcetyp AND ISREFERENCE) THEN - 'targettyp2 = targettyp: sourcetyp2 = sourcetyp - ISREFERENCE - 'IF (sourcetyp2 AND ISINCONVENTIONALMEMORY) THEN sourcetyp2 = sourcetyp2 - ISINCONVENTIONALMEMORY - 'IF sourcetyp2 = targettyp2 THEN e$ = refer(e$, sourcetyp, 1): GOTO dontevaluate - 'END IF - 'END IF - 'END IF - - 'String-numeric mismatch? - 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 - 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 - - 'change to "non-pointer" value - IF (sourcetyp AND ISREFERENCE) THEN - e$ = refer(e$, sourcetyp, 0) - IF Error_Happened THEN EXIT FUNCTION - END IF - - IF explicitreference = 0 THEN - IF targettyp AND ISUDT THEN - nth = curarg - IF omitarg_last <> 0 AND nth > omitarg_last THEN nth = nth - 1 - x$ = "'" + RTRIM$(udtxcname(targettyp AND 511)) + "'" - 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 - '**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 - - 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? - - - 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 - 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 - - IF LTRIM$(RTRIM$(e$)) = "0" THEN e$ = "NULL" - - END IF - - r$ = r$ + e$ - - '***special case**** - IF n$ = "_MEM" 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$ + "," - nocomma = 0 - firsti = i + 1 - curarg = curarg + 1 - 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 (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 - curarg = curarg + omitargs - 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(" - e$ = refer$(ulboundarray$, sourcetyp, 1) - IF Error_Happened THEN EXIT FUNCTION - 'note: ID contins refer'ed array info - - arrayelements = id.arrayelements '2009 - IF arrayelements = -1 THEN arrayelements = 1 '2009 - - r$ = r2$ + e$ + r$ + "," + str2$(arrayelements) + ")" - typ& = INTEGER64TYPE - ISPOINTER - GOTO evalfuncspecial -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 - -'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 - 'Default is FLOATTYPE - 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 id2.ret = ISUDT + (1) THEN - '***special case*** - v$ = "func" + str2$(uniquenumber) - PRINT #defdatahandle, "mem_block " + v$ + ";" - r$ = "(" + v$ + "=" + r$ + ")" -END IF - -IF id2.ccall THEN - IF LEFT$(r$, 11) = "( char* )" THEN - r$ = "qbs_new_txt(" + r$ + ")" - END IF -END IF - -IF Debug THEN PRINT #9, "evaluatefunc:out:"; r$ -evaluatefunc$ = r$ -END FUNCTION - -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 -'find base size from type -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 - bytes = udtxsize(u) \ 8 -END IF - -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 - -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 - s$ = s$ + "*" + n$ + "[" + str2(i2 * 4 - 4 + 5) + "]" - NEXT - variablesize$ = "(" + s$ + ")" - EXIT FUNCTION -END IF - -variablesize$ = str2(bytes) -END FUNCTION - - - -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 - -'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 - -'-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 - - ' print "-4: evaluated as ["+e$+"]":sleep 1 - - 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 - n$ = "ARRAY_" + n$ + "[0]" - 'whole array reference examplename()? - IF LEFT$(o$, 3) = "(0)" THEN - 'use -2 type method - GOTO method2usealludt - END IF - END IF - 'determine size of element - IF E = 0 THEN 'no specific element, use size of entire type - bytes$ = str2(udtxsize(u) \ 8) - ELSE 'a specific element - bytes$ = str2(udtesize(E) \ 8) - END IF - dst$ = "(((char*)" + scope$ + n$ + ")+(" + o$ + "))" - evaluatetotyp$ = "byte_element((uint64)" + dst$ + "," + bytes$ + "," + NewByteElement$ + ")" - IF targettyp = -5 THEN evaluatetotyp$ = bytes$ - IF targettyp = -6 THEN evaluatetotyp$ = dst$ + IF LEFT$(t$, 7) <> "_BIT * " THEN Give_Error "Expected _BIT * number": EXIT FUNCTION + + n$ = RIGHT$(t$, LEN(t$) - 7) + IF isuinteger(n$) = 0 THEN Give_Error "Invalid size after _BIT *": EXIT FUNCTION + b = VAL(n$) + IF b = 0 OR b > 56 THEN Give_Error "Invalid size after _BIT *": EXIT FUNCTION + t = BITTYPE - 1 + b: IF u THEN t = t + ISUNSIGNED + typname2typ& = t EXIT FUNCTION END IF - IF (sourcetyp AND ISARRAY) THEN 'Array reference -> byte_element(offset,bytes) - 'whole array reference examplename()? - 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 - 'assume a specific element - IF sourcetyp AND ISSTRING THEN - IF sourcetyp AND ISFIXEDLENGTH THEN - 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 - evaluatetotyp$ = "byte_element((uint64)" + e$ + "->chr," + bytes$ + "," + NewByteElement$ + ")" - 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 - - 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 - e$ = refer(e$, sourcetyp, 0) - IF Error_Happened THEN EXIT FUNCTION - e$ = "(&(" + e$ + "))" - 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 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 - bytes$ = str2(id.tsize) - e$ = refer(e$, sourcetyp, 0) - IF Error_Happened THEN EXIT FUNCTION - ELSE - e$ = refer(e$, sourcetyp, 0) - IF Error_Happened THEN EXIT FUNCTION - bytes$ = e$ + "->len" - 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 - - '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 - evaluatetotyp$ = "byte_element((uint64)" + e$ + "," + str2(size) + "," + NewByteElement$ + ")" - IF targettyp = -5 THEN evaluatetotyp$ = str2(size) - IF targettyp = -6 THEN evaluatetotyp$ = e$ - EXIT FUNCTION - -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 (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 - n$ = "ARRAY_" + n$ + "[0]" - 'whole array reference examplename()? - IF LEFT$(o$, 3) = "(0)" THEN - 'use -7 type method - GOTO method2usealludt__7 - END IF - END IF - 'determine size of element - 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 - bytes$ = str2(udtesize(E) \ 8) - t1 = udtetype(E) - END IF - dst$ = "(((char*)" + scope$ + n$ + ")+(" + o$ + "))" - 'evaluatetotyp$ = "byte_element((uint64)" + dst$ + "," + bytes$ + "," + NewByteElement$ + ")" - 'IF targettyp = -5 THEN evaluatetotyp$ = bytes$ - 'IF targettyp = -6 THEN evaluatetotyp$ = dst$ - - t = Type2MemTypeValue(t1) - evaluatetotyp$ = "(ptrszint)" + dst$ + "," + bytes$ + "," + str2(t) + "," + bytes$ + ",sf_mem_lock" - - EXIT FUNCTION - END IF - - IF (sourcetyp AND ISARRAY) THEN 'Array reference -> byte_element(offset,bytes) - 'whole array reference examplename()? - 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 - - idnumber = VAL(e$) - getid idnumber - 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 - bytes$ = str2(id.tsize) - e$ = refer(e$, sourcetyp, 0) - 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" - - t = Type2MemTypeValue(sourcetyp) - evaluatetotyp$ = "(ptrszint)" + e$ + "->chr," + bytes$ + "," + str2(t) + "," + bytes$ + "," + lk$ - - ELSE - - Give_Error "_MEMELEMENT cannot reference variable-length strings": EXIT FUNCTION - - END IF - EXIT FUNCTION - END IF - - e$ = refer(e$, sourcetyp, 0) - IF Error_Happened THEN EXIT FUNCTION - e$ = "(&(" + e$ + "))" - 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$ - - t = Type2MemTypeValue(sourcetyp) - evaluatetotyp$ = "(ptrszint)" + e$ + "," + bytes$ + "," + str2(t) + "," + bytes$ + "," + lk$ - - EXIT FUNCTION - END IF 'isarray - - 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 - bytes$ = str2(id.tsize) - e$ = refer(e$, sourcetyp, 0) - IF Error_Happened THEN EXIT FUNCTION - ELSE - Give_Error "_MEMELEMENT cannot reference variable-length strings": EXIT FUNCTION - END IF - - 'evaluatetotyp$ = "byte_element((uint64)" + e$ + "->chr," + bytes$ + "," + NewByteElement$ + ")" - 'IF targettyp = -5 THEN evaluatetotyp$ = bytes$ - 'IF targettyp = -6 THEN evaluatetotyp$ = e$ + "->chr" - - t = Type2MemTypeValue(sourcetyp) - evaluatetotyp$ = "(ptrszint)" + e$ + "->chr," + bytes$ + "," + str2(t) + "," + bytes$ + ",sf_mem_lock" - - 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 - 'evaluatetotyp$ = "byte_element((uint64)" + e$ + "," + str2(size) + "," + NewByteElement$ + ")" - 'IF targettyp = -5 THEN evaluatetotyp$ = str2(size) - 'IF targettyp = -6 THEN evaluatetotyp$ = e$ - - t = Type2MemTypeValue(sourcetyp) - evaluatetotyp$ = "(ptrszint)" + e$ + "," + str2(size) + "," + str2(t) + "," + str2(size) + ",sf_mem_lock" - - EXIT FUNCTION - -END IF '-8 - - - - - - - - - - -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 - - 'User Defined Type - 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) - - o$ = e$ - getid idnumber - 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 - 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 - - t = Type2MemTypeValue(sourcetyp) - evaluatetotyp$ = "(ptrszint)" + dst$ + "," + bytes$ + "," + str2(t) + "," + str2(size) + ",sf_mem_lock" - - EXIT FUNCTION - END IF - - 'Array reference - IF (sourcetyp AND ISARRAY) THEN - IF sourcetyp AND ISSTRING THEN - IF (sourcetyp AND ISFIXEDLENGTH) = 0 THEN - Give_Error "_MEM cannot reference variable-length strings": EXIT FUNCTION - END IF - END IF - - idnumber = VAL(e$) - getid idnumber - IF Error_Happened THEN EXIT FUNCTION - - 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 - bytes$ = variablesize$(-1) - IF Error_Happened THEN EXIT FUNCTION - e$ = refer(e$, sourcetyp, 0) - IF Error_Happened THEN EXIT FUNCTION - - IF sourcetyp AND ISSTRING THEN - e$ = "((" + e$ + ")->chr)" '[2013] handle fixed string arrays differently because they are already pointers - ELSE - e$ = "(&(" + e$ + "))" - END IF - - ' print "CI: array: e$["+e$+"], bytes$["+bytes$+"]":sleep 1 - 'calculate size of elements - IF sourcetyp AND ISSTRING THEN - bytes = tsize - 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 - - 'String - IF sourcetyp AND ISSTRING THEN - IF (sourcetyp AND ISFIXEDLENGTH) = 0 THEN Give_Error "_MEM cannot reference variable-length strings": 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 - - t = Type2MemTypeValue(sourcetyp) - evaluatetotyp$ = "(ptrszint)" + e$ + "->chr," + bytes$ + "," + str2(t) + "," + bytes$ + ",sf_mem_lock" - - 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 - - t = Type2MemTypeValue(sourcetyp) - evaluatetotyp$ = "(ptrszint)" + e$ + "," + str2(size) + "," + str2(t) + "," + str2(size) + ",sf_mem_lock" - - EXIT FUNCTION - -END IF '-7 _MEM structure helper - - -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 - - 'User Defined Type -> byte_element(offset,bytes) - 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) - o$ = e$ - getid idnumber - 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 - 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 - - 'Array reference -> byte_element(offset,bytes) - 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 - e$ = refer(e$, sourcetyp, 0) - 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$) - getid idnumber - 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 - bytes$ = variablesize$(-1) - IF Error_Happened THEN EXIT FUNCTION - e$ = refer(e$, sourcetyp, 0) - 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 - bytes = tsize - 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$ - ' print "CI: array ->["+"byte_element((uint64)" + e$ + "," + bytes$+ ","+NewByteElement$+")"+"]":sleep 1 - EXIT FUNCTION - END IF - - 'String -> byte_element(offset,bytes) - IF sourcetyp AND ISSTRING THEN - IF sourcetyp AND ISFIXEDLENGTH THEN - 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 - ELSE - e$ = refer(e$, sourcetyp, 0) - IF Error_Happened THEN EXIT FUNCTION - bytes$ = e$ + "->len" - 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 - - '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 - evaluatetotyp$ = "byte_element((uint64)" + e$ + "," + str2(size) + "," + NewByteElement$ + ")" - IF targettyp = -5 THEN evaluatetotyp$ = str2(size) - IF targettyp = -6 THEN evaluatetotyp$ = e$ - EXIT FUNCTION - -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) THEN - evaluatetotyp$ = e$ - IF (sourcetyp AND ISREFERENCE) THEN - evaluatetotyp$ = refer(e$, sourcetyp, 0) - 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 - '... - Give_Error "Invalid pointer": EXIT FUNCTION -END IF - -'change to "non-pointer" value -IF (sourcetyp AND ISREFERENCE) THEN - e$ = refer(e$, sourcetyp, 0) - 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 - -'round to integer if required -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 - -evaluatetotyp$ = e$ -END FUNCTION - -FUNCTION findid& (n2$) -n$ = UCASE$(n2$) 'case insensitive - -'return all strings as 'not found' -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 -'(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 -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 - ''' '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 - -'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 -'''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$)) - -'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 - -'NEW HASH SYSTEM -n$ = RTRIM$(n$) -IF findanother THEN - hashretry: - z = HashFindCont(unrequired, i) -ELSE - z = HashFindRev(n$, 1, unrequired, i) -END IF -findidinternal = z -IF z = 0 THEN GOTO noid -findid = z - - -'continue from previous position? -''IF findanother THEN start = findidinternal ELSE start = idn - -''FOR i = start TO 1 STEP -1 - -'' findidinternal = i - 1 -'' IF findidinternal = 0 THEN findid& = 1 '1=found id, but no more to search - -'' 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 - -'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 secondarg$ <> ids(i).secondargmustbe THEN GOTO findidnomatch - END IF - IF ASC(ids(i).secondargcantbe) <> 32 THEN 'exists? - IF secondarg$ = ids(i).secondargcantbe THEN GOTO findidnomatch - 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 - ''' IF couldhavescpassed THEN - ''' IF couldhavesc$ = ids(i).musthave THEN GOTO findidok - ''' END IF - 'Q: why is the above triple-commented? - 'A: because if something must have a symbol to refer to it, then a could-have is - ' not sufficient, and it could mask shared variables in global scope - - '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 - -'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 - 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) - '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 '"$ " - 'it is a fixed length string - 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 - -'return id -findidok: - -id = ids(i) - -currentid = i -EXIT FUNCTION - -'END IF 'same name -findidnomatch: -'NEXT -IF z = 2 THEN GOTO hashretry - -'totally unclassifiable -noid: -findid& = 0 -currentid = -1 -END FUNCTION - -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 - -'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 -gotsc2: -n2$ = n$ + sc$ - -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 - -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 - - '2. that failed, so apply the _define'd extension and pass (local) - 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 - - '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 - - '4. that failed, so apply the _define'd extension and pass (global) - 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 - -END IF -FindArray = 0 -END FUNCTION - - - - -FUNCTION fixoperationorder$ (savea$) -a$ = savea$ -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 - - '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 - 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 - - '----------------A. 'Quick' mismatched brackets check---------------- - b = 0 - a2$ = sp + a$ + sp - b1$ = sp + "(" + sp - b2$ = sp + ")" + sp - i = 1 - findmmb: - i1 = INSTR(i, a2$, b1$) - i2 = INSTR(i, a2$, b2$) - i3 = i1 - 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 - 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 - - '----------------B. 'Quick' correction of over-use of +,- ---------------- - 'note: the results of this change are beneficial to foolayout - a2$ = sp + a$ + sp - - '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) - n = n - 1 - 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) - n = n - 1 - 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 - 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 - - - - '----------------C. 'Quick' location of negation---------------- - 'note: the results of this change are beneficial to foolayout - - 'for numbers... - 'before: anyoperator,-,number - 'after: anyoperator,-number - - 'for variables... - 'before: anyoperator,-,variable - 'after: anyoperator,CHR$(241),variable - - 'exception for numbers followed by ^... (they will be bracketed up along with the ^ later) - '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 - - IF ASC(getelement(a$, i)) = 45 THEN '- - - neg = 0 - IF i = 1 THEN - neg = 1 - ELSE - a2$ = getelement(a$, i - 1) - 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 - - 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 ^ - '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 - a2$ = "-" + a2$ - END IF - removeelements a$, i, i + 1, 0 - insertelements a$, i - 1, a2$ - n = n - 1 - IF Debug THEN PRINT #9, "fixoperationorder:negation:" + a$ - - GOTO negdone - - 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$ - - END IF 'isoperator - END IF '- - negdone: - NEXT - - - -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 - b = 0 - b1 = 0 - 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 - insertelements a$, i - 1, "}" - insertelements a$, b1, "{" - n = n + 2 - 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 - insertelements a$, b1, "{" - a$ = a$ + sp + "}" - n = n + 2 - IF Debug THEN PRINT #9, "fixoperationorder:^-:" + a$ - pownegused = 1 - GOTO powneg - END IF - -END IF 'quick check - - -'----------------E. Find lowest & highest operator level in bottom bracket level---------------- -NOT_recheck: -lco = 255 -hco = 0 -b = 0 -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 - op = isoperator(a2$) - 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 - 'brackets needed - - 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 - b = 0 - 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 - 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 - - n2 = n - b = 0 - a3$ = "{" - n = 1 - 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 - op = isoperator(a2$) - 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 - a3$ = a3$ + sp + "}" + sp + a2$ + sp + "{" - n = n + 3 - END IF - GOTO fixop0 - END IF - - END IF 'b=0 - a3$ = a3$ + sp + a2$ - n = n + 1 - fixop0: - NEXT - a3$ = a3$ + sp + "}" - n = n + 1 - a$ = a3$ - - lco_bracketting_done: - IF Debug THEN PRINT #9, "fixoperationorder:lco bracketing["; lco; ","; hco; "]:" + a$ - - '--------(F)G. Remove indwelling {}bracketting from power-negation-------- - IF pownegused THEN - b = 0 - i = 0 - 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 - 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 - - 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 - a$ = "NOT" + sp + "{" + sp + getelements$(a$, 2, n) + sp + "}": n = n + 2 -END IF - -'----------------H. Identification/conversion of elements within bottom bracket level---------------- -'actions performed: -' ->builds f$(tlayout) -' ->adds symbols to all numbers -' ->evaluates constants to numbers - -f$ = "" -b = 0 -c = 0 -lastt = 0: lastti = 0 -FOR i = 1 TO n - f2$ = getelement(a$, i) - lastc = c - c = ASC(f2$) - - 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 - - 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 c <> 41 OR b <> 0 THEN f2$ = "" 'skip temporary & indwelling brackets - GOTO classdone - END IF - - IF b = 0 THEN - - 'classifications/conversions: - '1. quoted string ("....) - '2. number - '3. operator - '4. constant - '5. variable/array/udt/function (note: nothing can share the same name as a function except a label) - - - 'quoted string? - 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 \ - x2 = x + 1 - 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) - x2 = x + 1 - 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 - - 'number? - 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 - - 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 - - 'add appropriate integer symbol if none present - IF x = 0 THEN - f3$ = f2$ - s$ = "" - 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 - 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 - f3$ = f3$ + s$ - removeelements a$, i, i, 0: insertelements a$, i - 1, f3$ - END IF 'x=0 - - GOTO classdone - END IF - - 'operator? - IF isoperator(f2$) THEN - lastt = 3: lastti = i - IF LEN(f2$) > 1 THEN - IF f2$ <> UCASE$(f2$) THEN - f2$ = UCASE$(f2$) - removeelements a$, i, i, 0 - insertelements a$, i - 1, f2$ - END IF - END IF - 'append negation - IF f2$ = CHR$(241) THEN f$ = f$ + sp + "-": GOTO classdone_special - GOTO classdone - END IF - - - IF alphanumeric(c) THEN - lastt = 4: lastti = i - - 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) - - e$ = UCASE$(f2$) - es$ = removesymbol$(e$) - 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 - hashfound = 1 - EXIT DO - END IF - END IF - IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 - LOOP - - IF hashfound THEN - i2 = hashresref - 'FOR i2 = constlast TO 0 STEP -1 - 'IF e$ = constname(i2) THEN - - - - - - '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 - 'add symbol and try again - 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 staticvariable = 0 THEN - - t = consttype(i2) - 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 - 'convert value to general formats - IF t AND ISFLOAT THEN - v## = constfloat(i2) - v&& = v## - v~&& = v&& - ELSE - IF t AND ISUNSIGNED THEN - v~&& = constuinteger(i2) - v&& = v~&& - v## = v&& - ELSE - v&& = constinteger(i2) - v## = v&& - v~&& = v&& - END IF - END IF - 'apply type conversion if necessary - 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 - - 'floats returned by str$ must be converted to qb64 standard format - 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 - 'E,D,F found - 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 - '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 - s$ = typevalue2symbol$(t) - IF Error_Happened THEN EXIT FUNCTION - e$ = e$ + s$ 'simply append symbol to integer - END IF - - 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 - - END IF 'not static - 'END IF 'same name - 'NEXT - END IF 'hashfound - END IF 'not udt element - END IF 'not array - - 'variable/array/udt? - u$ = f2$ - - try_string$ = f2$ - try_string2$ = try_string$ 'pure version of try_string$ - - FOR try_method = 1 TO 4 - try_string$ = try_string2$ - 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 - try_string$ = try_string$ + defineextaz(v) - END IF - END IF - ELSE - try_string$ = try_string2$ - 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 Debug THEN PRINT #9, "found id matching " + f2$ - - IF nextc = 40 THEN '( - - 'function or array? - 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 - f2$ = RTRIM$(id.cn) + s$ - removeelements a$, i, i, 0 - 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 - f$ = f$ + sp - NEXT - - 'adjust i accordingly - i = i2 - - 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 - - f$ = f$ + sp - 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 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 - f2$ = RTRIM$(id.cn) + removesymbol$(f2$) - IF Error_Happened THEN EXIT FUNCTION - removeelements a$, i, i, 0 - insertelements a$, i - 1, UCASE$(f2$) - f$ = f$ + f2$ - - - - 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 - i = i + 2 - - 'loop - - '"." encountered, i must be an element - 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 - - 'is f$ the same as element e? - fooudtnexte: - IF udtename(E) = u$ THEN - 'match found - 'todo: check symbol(s$) matches element's type - - 'correct name - f2$ = RTRIM$(udtecname(E)) + s$ - removeelements a$, i, i, 0 - 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 - 'sub-element exists - t = udtetype(E) - IF (t AND ISUDT) = 0 THEN Give_Error "Invalid . after element": EXIT FUNCTION - GOTO fooudt - - 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 - - END IF 'udt - - 'non array/udt based variable - f3$ = f2$ - s$ = removesymbol$(f3$) - IF Error_Happened THEN EXIT FUNCTION - f2$ = RTRIM$(id.cn) + s$ - 'change was is returned to uppercase - removeelements a$, i, i, 0 - insertelements a$, i - 1, UCASE$(f2$) - GOTO CouldNotClassify - END IF 'id.t - - 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) - CouldNotClassify: - - 'alphanumeric, but item name is unknown... is it an internal type? if so, use capitals - f3$ = UCASE$(f2$) - internaltype = 0 - IF f3$ = "STRING" THEN internaltype = 1 - IF f3$ = "_UNSIGNED" THEN internaltype = 1 - IF f3$ = "_BIT" THEN internaltype = 1 - IF f3$ = "_BYTE" THEN internaltype = 1 - IF f3$ = "INTEGER" THEN internaltype = 1 - IF f3$ = "LONG" THEN internaltype = 1 - IF f3$ = "_INTEGER64" THEN internaltype = 1 - IF f3$ = "SINGLE" THEN internaltype = 1 - IF f3$ = "DOUBLE" THEN internaltype = 1 - IF f3$ = "_FLOAT" THEN internaltype = 1 - IF f3$ = "_OFFSET" THEN internaltype = 1 - IF internaltype = 1 THEN - f2$ = f3$ - removeelements a$, i, i, 0 - insertelements a$, i - 1, f3$ - GOTO classdone - END IF - - GOTO classdone - END IF 'alphanumeric - - classdone: - f$ = f$ + f2$ - END IF 'b=0 - f$ = f$ + sp - classdone_special: -NEXT -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 - - - -'----------------I. Pass (){}bracketed items (if any) to fixoperationorder & build return---------------- -'note: items seperated by commas are done seperately - -ff$ = "" -b = 0 -b2 = 0 -p1 = 0 'where level 1 began -aa$ = "" -n = numelements(a$) -FOR i = 1 TO n - - openbracket = 0 - - a2$ = getelement(a$, i) - - c = ASC(a2$) - - - - IF c = 40 OR c = 123 THEN '({ - b = b + 1 - - IF b = 1 THEN - - - - - p1 = i + 1 - aa$ = aa$ + "(" + sp - - END IF - - openbracket = 1 - - GOTO foopass - - END IF '({ - - IF c = 44 THEN ', - IF b = 1 THEN - GOTO foopassit - END IF - END IF - - IF c = 41 OR c = 125 THEN ')} - b = b - 1 - - IF b = 0 THEN - foopassit: - IF p1 <> i THEN - foo$ = fixoperationorder(getelements(a$, p1, i - 1)) - 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 - p1 = i + 1 - END IF - - GOTO foopass - END IF ')} - - - - - IF b = 0 THEN aa$ = aa$ + a2$ + sp - - - foopass: - - f2$ = getelementspecial(f$, i) - 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 - ff$ = ff$ + "." + sp2 - GOTO fooloopnxt - END IF - END IF - - 'spacing just before ( - 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 - ff$ = ff$ + f2$ + sp2 - ELSE 'not openbracket - ff$ = ff$ + f2$ + sp - END IF - - END IF 'len(f2$) - - fooloopnxt: - -NEXT - -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$ -tlayout$ = ff$ -fixoperationorder$ = aa$ - -fooindwel = fooindwel - 1 -END FUNCTION - - - - -FUNCTION getelementspecial$ (savea$, elenum) -a$ = savea$ -IF a$ = "" THEN EXIT FUNCTION 'no elements! - -n = 1 -p = 1 -getelementspecialnext: -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 - -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! -n = n + 1 -p = i + 1 -GOTO getelementspecialnext -END FUNCTION - - - -FUNCTION getelement$ (a$, elenum) -IF a$ = "" THEN EXIT FUNCTION 'no elements! - -n = 1 -p = 1 -getelementnext: -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 i = 0 THEN EXIT FUNCTION 'no more elements! -n = n + 1 -p = i + 1 -GOTO getelementnext -END 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 - 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 -n = n + 1 -p = i + 1 -GOTO getelementsnext -END FUNCTION - -SUB getid (i AS LONG) -IF i = -1 THEN Give_Error "-1 passed to getid!": EXIT SUB - -id = ids(i) - -currentid = i -END SUB - -SUB insertelements (a$, i, elements$) -IF i = 0 THEN - IF a$ = "" THEN - a$ = elements$ - EXIT SUB - END IF - a$ = elements$ + sp + a$ - EXIT SUB -END IF - -a2$ = "" -n = numelements(a$) - - - - -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 - -a$ = a2$ - -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 THEN EXIT FUNCTION - GOTO isnumok - END IF - IF a = 46 THEN - IF dp = 1 THEN EXIT FUNCTION - dp = 1 - GOTO isnumok - END IF - IF a >= 48 AND a <= 57 THEN v = 1: GOTO isnumok - EXIT FUNCTION - isnumok: -NEXT -isnumber = 1 -END FUNCTION - -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$ = "=" 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 -l = l + 1 -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 -opfound: -isoperator = l -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 -isuinteger = -1 -END FUNCTION - -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 - 'valid (continue) - ELSE - IF i = 1 THEN isvalidvariable = 0: EXIT FUNCTION - EXIT FOR + IF t$ = "_BYTE" THEN t = BYTETYPE + IF t$ = "INTEGER" THEN t = INTEGERTYPE + IF t$ = "LONG" THEN t = LONGTYPE + IF t$ = "_INTEGER64" THEN t = INTEGER64TYPE + IF t$ = "_OFFSET" THEN t = OFFSETTYPE + IF t THEN + IF u THEN t = t + ISUNSIGNED + typname2typ& = t + EXIT FUNCTION END IF -NEXT + IF u THEN EXIT FUNCTION '_UNSIGNED (nothing) -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 -isvalidvariable = 0 -END FUNCTION - - - - -FUNCTION lineformat$ (a$) -a2$ = "" -linecontinuation = 0 - -continueline: - -a$ = a$ + " " 'add 2 extra spaces to make reading next char easier - -ca$ = a$ -a$ = UCASE$(a$) - -n = LEN(a$) -i = 1 -lineformatnext: -IF i >= n THEN GOTO lineformatdone - -c = ASC(a$, i) -c$ = CHR$(c) '***remove later*** - -'----------------quoted string---------------- -IF c = 34 THEN '" - a2$ = a2$ + sp + CHR$(34) - p1 = i + 1 - 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)) - i = i2 + 1 - EXIT FOR + 'UDT? + FOR i = 1 TO lasttype + IF t$ = RTRIM$(udtxname(i)) THEN + typname2typ& = ISUDT + ISPOINTER + i + EXIT FUNCTION END IF - - IF c2 = 92 THEN '\ - a2$ = a2$ + MID$(ca$, p1, i2 - p1) + "\\" - p1 = i2 + 1 - END IF - - 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$ - p1 = i2 + 1 - END IF - 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) - i = n - 1 - END IF - - GOTO lineformatnext - -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 - 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 - a2$ = a2$ + sp + "GOTO" - END IF - - 'Number will be converted to the following format: - ' 999999 . 99999 E + 999 - '[whole$][dp(0/1)][frac$][ed(1/2)][pm(1/-1)][ex$] - ' 0 1 2 3 <-mode - - mode = 0 - whole$ = "" - dp = 0 - frac$ = "" - ed = 0 'E=1, D=2, F=3 - pm = 1 - ex$ = "" - - - - - lfreadnumber: - valid = 0 - - 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 - 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 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 - mode = 2 - END IF - END IF - - IF c = 43 OR c = 45 THEN '+,- - IF mode = 2 THEN - valid = 1 - IF c = 45 THEN pm = -1 - mode = 3 - 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 - - - - 'cull leading 0s off whole$ - 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 - 'cull leading 0s off ex$ - 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 - - extused = 1 - - 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 - '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 - i = i + 2 - ed = 3 - e$ = "" - GOTO lffoundext - END IF - IF e$ = "~`" THEN - i = i + 2 - 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 - i = i + 1 - ed = 1 - e$ = "" - GOTO lffoundext - END IF - IF e$ = "#" THEN - i = i + 1 - ed = 2 - e$ = "" - 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) - i = i + 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 - e$ = e$ + bitn$ - GOTO lffoundext - END IF - END IF - - 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 - offset = -1 - 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 - 'number is 0 - offset = 0 - sigdigits = 0 - 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 - ed = 1 - e$ = "" - 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 - ed = 2 - e$ = "" - GOTO lffoundext - END IF - END IF - lfxdouble: - 'assume _FLOAT - ed = 3 - e$ = "": GOTO lffoundext - END IF - - extused = 0 - e$ = "" - lffoundext: - - 'make sure a leading numberic character exists - IF whole$ = "" THEN whole$ = "0" - 'if a float, ensure frac$<>"" and dp=1 - IF float THEN - dp = 1 - IF frac$ = "" THEN frac$ = "0" - END IF - 'if ed is specified, make sure ex$ exists - 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$ + "+" - a2$ = a2$ + ex$ - END IF - a2$ = a2$ + e$ - - IF extused THEN a2$ = a2$ + "," + MID$(a$, firsti, i - firsti) - - 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 - 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 - 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" - - 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 - '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 - i = i + 2 - 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 - 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) - i = i + 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 - '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 - lfhxext: - fullhx$ = fullhx$ + e$ + bitn$ - lfhxext2: - - 'build 8-byte unsigned integer rep. of hx$ - 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 - v~&& = v~&& * 16 + v2 - 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 - 'signed - - 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 - - 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 - - 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 - - IF e$ = "&&" THEN - IF v~&& > 9223372036854775807 THEN - 'note: no error checking necessary - v~&& = (NOT v~&&) + 1 - num$ = "-" + sp + str2u64$(v~&&) - 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 - num$ = "-" + sp + str2u64$(v~&&) - END IF - END IF - - END IF '<>"~" - - a2$ = a2$ + sp + num$ + e$ + bitn$ + "," + fullhx$ - - 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 - 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 - 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" - - 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 - '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 - i = i + 2 - 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 - 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) - i = i + 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 - '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 - '177777 - IF LEN(hx$) <= 6 THEN - IF LEN(hx$) < 6 OR LEFT$(hx$, 1) = "1" THEN e$ = "%" - END IF - - 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 - '********change v& to v~&&******** - v~&& = 0 - FOR i2 = 1 TO LEN(hx$) - v2 = ASC(MID$(hx$, i2, 1)) - v2 = v2 - 48 - v~&& = v~&& * 8 + v2 - NEXT - - 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 - 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 - 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" - - 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 - '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 - i = i + 2 - 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 - 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) - i = i + 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 - '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$ = "%" - - 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 - - v~&& = 0 - FOR i2 = 1 TO LEN(hx$) - v2 = ASC(MID$(hx$, i2, 1)) - v2 = v2 - 48 - v~&& = v~&& * 2 + v2 - NEXT - - GOTO finishhexoctbin - END IF -END IF - - -'----------------(number)&H??? error---------------- -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! - 'char is from i to p2 - n2 = p2 - i + 1 - a3$ = MID$(a$, i, n2) - - '----(variable/name)rem---- - 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 - - '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 - layoutcomment = "REM" - GOTO comment - END IF - END IF - - '----(variable/name)data---- - 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 - - scan = 0 - speechmarks = 0 - commanext = 0 - finaldata = 0 - e$ = "" - 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 c = 58 THEN '":" - IF speechmarks = 0 THEN finaldata = 1: GOTO adddata - END IF - - IF c = 44 THEN '"," - IF speechmarks = 0 THEN - adddata: - 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 - 'assume closing " - IF speechmarks THEN - 'DATA_add 34 - x$ = x$ + CHR$(34) - END IF - 'append comma - 'DATA_add 44 - x$ = x$ + CHR$(44) - END IF - IF finaldata = 1 THEN GOTO finisheddata - e$ = "" - p1 = 0 - p2 = 0 - speechmarks = 0 - scan = 0 - commanext = 0 - i = i + 1 - 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 c = 34 THEN - IF speechmarks = 1 THEN - commanext = 1 - speechmarks = 0 - 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 - - 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) - 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 - '(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 - 'scan until no further alphanumerics - p2 = i + 1 - 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 - 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 lineformatnext - - lfgetve: - i = i + LEN(e2$) - a2$ = a2$ + e2$ - 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 - - GOTO lineformatnext - - END IF 'p2 -END IF 'variable/name -'----------------variable/name end---------------- - -'----------------spacing---------------- -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 - count = 0 - 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 c = 36 AND LEN(a2$) THEN GOTO badusage '$ - - - a2$ = a2$ + sp + CHR$(c) - i = i + 1 - GOTO lineformatnext -END IF -badusage: - -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$) - -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$) - mcnext: - IF MID$(c$, x, 1) = "$" THEN - - 'note: $STATICksdcdweh$DYNAMIC is valid! - - IF MID$(c$, x, 7) = "$STATIC" THEN - memmode = 1 - xx = INSTR(x + 1, c$, "$") - if xx=0 then exit for else - x = xx: GOTO mcnext - END IF - - 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 - - IF MID$(c$, x, 8) = "$INCLUDE" THEN - IF Cloud THEN Give_Error "Feature not supported on QLOUD": EXIT FUNCTION - '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 - 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 - 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 - - 'add more metacommands here - - END IF '$ -NEXT -mcfinal: - -IF memmode = 1 THEN addmetastatic = 1 -IF memmode = 2 THEN addmetadynamic = 1 - -GOTO lineformatdone2 - - - -lineformatdone: - -'line continuation? -'note: line continuation in idemode is illegal -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 inclevel THEN - fh = 99 + inclevel - IF EOF(fh) THEN GOTO lineformatdone2 - LINE INPUT #fh, a$ - inclinenumber(inclevel) = inclinenumber(inclevel) + 1 - GOTO includecont 'note: should not increase linenumber - END IF - - IF idemode THEN - idecommand$ = CHR$(100) - ignore = ide(0) - ideerror = 0 - a$ = idereturn$ - IF a$ = "" THEN GOTO lineformatdone2 - ELSE - a$ = lineinput3$ - IF a$ = CHR$(13) THEN GOTO lineformatdone2 - END IF - - linenumber = linenumber + 1 - - includecont: - - contline = 1 - GOTO continueline - END IF -END IF - -lineformatdone2: -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 Debug THEN PRINT #9, "lineformat():return:" + a2$ -IF Error_Happened THEN EXIT FUNCTION -lineformat$ = a2$ - -END FUNCTION - - -SUB makeidrefer (ref$, typ AS LONG) -ref$ = str2$(currentid) -typ = id.t + ISREFERENCE -END SUB - -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 -n = n + 1 -p = i + 1 -GOTO numelementsnext -END FUNCTION - -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 -'2 = use the function returned in info$ to apply this operator -' upon left and right side of equation -'3= bracket left and right side with negation and change operator to info$ -'4= BINARY NOT l.h.s, then apply operator in info$ -'5= UNARY, bracket up rhs, apply operator info$ to left, rebracket again - -'lhs & rhs bit-field values -'1=integeral -'2=floating point -'4=string -'8=bool - -'string operator -IF (typ AND ISSTRING) THEN - lhs = 4: rhs = 4 - result = 4 - 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 - -'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 - 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 - 'lhs is a float - lhs = 2 - rhs = 1 + 2 - ELSE - 'lhs isn't a float! - lhs = 1 + 2 - rhs = 2 - 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 - -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 - -lhs = 1: rhs = 1: result = 1 -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 Debug THEN PRINT #9, "INVALID NUMBERIC OPERATOR!": END - -END FUNCTION - -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 - -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 -getid idnumber -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$ - n$ = scope$ + n$ - refer$ = n$ - 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 - - IF typ AND ISSTRING 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 - typ = typ - ISUDT - ISREFERENCE - ISPOINTER - IF typ AND ISARRAY THEN typ = typ - ISARRAY - t$ = typ2ctyp$(typ, "") - IF Error_Happened THEN EXIT FUNCTION - o2$ = "(((char*)" + scope$ + n$ + ")+(" + o$ + "))" - r$ = "*" + "(" + t$ + "*)" + o2$ - END IF - - 'print "REFER:"+r$+","+str2$(typ) - refer$ = r$ - EXIT FUNCTION -END IF - - -'array? -IF id.arraytype THEN - - n$ = RTRIM$(id.callname) - IF method = 1 THEN - refer$ = n$ - typ = typbak - 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 - offset$ = "&((uint8*)(" + n$ + "[0]))[(" + a$ + ")*" + str2(id.tsize) + "]" - r$ = "qbs_new_fixed(" + offset$ + "," + str2(id.tsize) + ",1)" - ELSE - r$ = "((qbs*)(((uint64*)(" + n$ + "[0]))[" + a$ + "]))" - END IF - stringprocessinghappened = 1 - refer$ = r$ - EXIT FUNCTION - END IF - - 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) + "," - r$ = r$ + "(uint8*)(" + n$ + "[0])" + "," - r$ = r$ + a$ + ")" - refer$ = r$ - 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 - r$ = "((" + t$ + "*)(" + n$ + "[0]))[" + a$ + "]" - refer$ = r$ - EXIT FUNCTION -END IF 'array - -'variable? -IF id.t THEN - r$ = RTRIM$(id.n) - t = id.t - 'remove irrelavant flags - 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 - '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 - ref: - 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) - typ = typbak - END IF - refer$ = r$ - EXIT FUNCTION -END IF 'variable - - - -END FUNCTION - -SUB regid -idn = idn + 1 - -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 - -n$ = RTRIM$(id.n) - -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$) - id.cn = n$ -END IF - -IF LEN(Refactor_Source) THEN - n$ = RTRIM$(id.n) - IF UCASE$(n$) = UCASE$(Refactor_Source) THEN - id.cn = Refactor_Dest - END IF -END IF - - -id.insubfunc = subfunc -id.insubfuncn = subfuncn - -'note: cannot be STATIC and SHARED at the same time -IF dimshared THEN - id.share = dimshared -ELSE - IF dimstatic THEN id.staticscope = 1 -END IF - -ids(idn) = id - -currentid = idn - -'prepare hash flags and check for conflicts -hashflags = 1 - -'sub/function? -'Note: QBASIC does not allow: Internal type names (INTEGER,LONG,...) -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 - hashchkflags = HASHFLAG_RESERVED + HASHFLAG_CONSTANT - 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 - '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 - -'variable? -IF id.t THEN - hashflags = hashflags + HASHFLAG_VARIABLE - IF reginternalvariable = 0 THEN - allow = 0 - var_recheck: - 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 - - 'conflict with reserved word? - 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 - - '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 - '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 - '(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 - - 'conflict with constant? - 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 - - 'conflict with variable? - 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 - '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 - '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 - - varname_exception: - IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 - LOOP - END IF 'reginternalvariable -END IF 'variable - -'array? -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? - hashchkflags = HASHFLAG_RESERVED + HASHFLAG_SUB + HASHFLAG_FUNCTION + HASHFLAG_ARRAY - hashres = HashFind(n$, hashchkflags, hashresflags, hashresref) - DO WHILE hashres - - 'conflict with reserved word? - 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 - - '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 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 - '(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 - - 'conflict with array? - 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 - '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 - '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 - - arrayname_exception: - 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 - -SUB reginternal -reginternalsubfunc = 1 -'$INCLUDE:'subs_functions\subs_functions.bas' -reginternalsubfunc = 0 -END SUB - -'this sub is faulty atm! -'sub replacelement (a$, i, newe$) -''note: performs no action for out of range values of i -'e=1 -'s=1 -'do -'x=instr(s,a$,sp) -'if x then -'if e=i then -'a1$=left$(a$,s-1): a2$=right$(a$,len(a$)-x+1) -'a$=a1$+sp+newe$+a2$ 'note: a2 includes spacer -'exit sub -'end if -'s=x+1 -'e=e+1 -'end if -'loop until x=0 -'if e=i then -'a$=left$(a$,s-1)+sp+newe$ -'end if -'end sub - - -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 - 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) - -a$ = a2$ - -END SUB - - - -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 -'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)) - 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 - -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 -removesymbol$ = symbol$ -varname$ = LEFT$(varname$, i - 1) -END FUNCTION - -FUNCTION scope$ -IF id.share THEN scope$ = module$ + "__": EXIT FUNCTION -scope$ = module$ + "_" + subfunc$ + "_" -END FUNCTION - -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 - Lev(i) = 0 - EntryLev(i) = 0 - DitchLev(i) = 0 - DontPass(i) = 0 - TempList(i) = 0 - PassRule(i) = 0 - LevelEntered(i) = 0 -NEXT - -DIM id2 AS idstruct - -id2 = id - -IF id2.args = 0 THEN EXIT FUNCTION 'no arguments! - - -s$ = id2.specialformat -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 - -'note: dim'd arrays moved to global to prevent high recreation cost - -PassFlag = 1 -nextentrylevel = 0 -nextentrylevelset = 1 -level = 0 -lastt = 0 -ditchlevel = 0 -FOR i = 1 TO LEN(s$) - s2$ = MID$(s$, i, 1) - - IF s2$ = "[" THEN - level = level + 1 - LevelEntered(level) = 0 - GOTO nextsymbol - END IF - - IF s2$ = "]" THEN - level = level - 1 - IF level < ditchlevel THEN ditchlevel = level - GOTO nextsymbol - END IF - - 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$, "}") - 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) - T(lastt) = numopts - 'calculate words in each option - 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 - OptWords(lastt, x) = w - NEXT - i = i2 - - 'set entry level routine - EntryLev(lastt) = level 'default level when continuing a previously entered level - 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 - LevelEntered(level) = 1 - - GOTO nextsymbol - END IF - - 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 - EntryLev(lastt) = 0 - FOR i2 = 1 TO level - 1 - IF LevelEntered(i2) = 1 THEN EntryLev(lastt) = i2 - NEXT - END IF - LevelEntered(level) = 1 - - GOTO nextsymbol - END IF - - 'assume "special" character (like ( ) , . - etc.) - lastt = lastt + 1: Lev(lastt) = level: PassRule(lastt) = 0 - DitchLev(lastt) = ditchlevel: ditchlevel = level 'store & reset ditch level - T(lastt) = 1: Opt(lastt, 1) = s2$: OptWords(lastt, 1) = 1: DontPass(lastt) = 1 - - 'set entry level routine - EntryLev(lastt) = level 'default level when continuing a previously entered level - 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 - LevelEntered(level) = 1 - - GOTO nextsymbol - - nextsymbol: -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 - - -'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 - -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 - - - - -x1 = 0 'the 'x' position of the beginning element of the current levelled block -MustPassOpt = 0 'the 'x' position of the FIRST opt () in the block which must be passed -MustPassOptNeedsFlag = 0 '{}blocks don't need a flag, ? blocks do - -'Note: For something like [{HELLO}x] a choice between passing 'hello' or passing a flag to signify x was specified -' 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 - scannextlevel = 0 - 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 there's an opt () which must be passed that will be identified, - 'all the 1 option {}blocks can be assumed... - IF MustPassOptNeedsFlag THEN - 'The MustPassOpt requires a flag, so use the same flag for everything - FOR x2 = 1 TO templistn - PassRule(TempList(x2)) = PassFlag - NEXT - PassFlag = PassFlag * 2 - 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 - '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 - x1 = 0 - 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) - x1 = x 'set x1 to the starting element of this level - MustPassOpt = 0 - templistn = 0 - END IF - END IF - - IF x1 THEN - IF Lev(x) = l THEN 'same level - - 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 - MustPassOpt = x 'Only record the first instance (it MAY require a flag) - 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 - MustPassOpt = x: MustPassOptNeedsFlag = 0 - END IF - END IF - END IF - 'add to list - templistn = templistn + 1: TempList(templistn) = x - END IF - - 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 - - END IF - END IF - - NEXT - - 'scan last run (mostly just a copy of code from above) - 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 - 'The MustPassOpt requires a flag, so use the same flag for everything - FOR x2 = 1 TO templistn - PassRule(TempList(x2)) = PassFlag - NEXT - PassFlag = PassFlag * 2 - 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 - '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 - x1 = 0 - END IF - - 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 - - - -FOR i = 1 TO lastt: separgs(i) = "n-ll": NEXT - - - - -'Consider: "?,[?]" -'Notes: The comma is mandatory but the second ? is entirely optional -'Consider: "[?[{B}?]{A}]?" -'Notes: As unlikely as the above is, it is still valid, but pivots on the outcome of {A} being present -'Consider: "[?]{A}" -'Consider: "[?{A}][?{B}][?{C}]?" -'Notes: The trick here is to realize {A} has greater priority than {B}, so all lines of enquiry must -' be exhausted before considering {B} - -'Use inquiry approach to solve format -'Each line of inquiry must be exhausted -'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 -'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 -'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 - -n = numelements(ca$) -i = 1 'Position within ca$ - -level = 0 -Expression = 0 -FOR x = 1 TO lastt - - ContinueScan: - - 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 - - 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 - optional = 1 - IF level > EntryLev(x) THEN optional = 0 - ELSE - 'entrylev=lev - optional = 0 - END IF - - t = T(x) - - 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 - '****************************** - END IF - IF optional THEN - Branches = Branches + 1 - BranchFormatPos(Branches) = x - BranchTaken(Branches) = 1 - BranchInputPos(Branches) = i - BranchWithExpression(Branches) = 0 - BranchLevel(Branches) = level - level = Lev(x) - END IF - Expression = x - END IF 'A "?" expression - - IF t THEN - - currentlev = level - - 'Add new branch if new level will be entered - IF optional THEN - Branches = Branches + 1 - BranchFormatPos(Branches) = x - BranchTaken(Branches) = 1 - BranchInputPos(Branches) = i - BranchWithExpression(Branches) = Expression - BranchLevel(Branches) = level - END IF - - 'Scan for Opt () options - i1 = i: i2 = i - 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 - OutOfRange = 2147483647 - position = OutOfRange - which = 0 - 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 - c$ = getelement$(a$, i3) - IF b = 0 THEN - 'Build comparison string (spacing elements) - FOR w = 2 TO words - c$ = c$ + " " + getelement$(a$, i3 + w - 1) - NEXT w - 'Compare - IF c$ = RTRIM$(Opt(x, o)) THEN - 'Record Match - IF i3 < position THEN - position = i3 - which = o - bvalue = b - 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 - 'Because this wasn't interceppted by the above code it isn't the Opt either - END IF - IF ASC(c$) = 40 THEN - b = b + 1 - 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 - - END IF 'enough elements exist - NEXT i3 - NEXT o - END IF 'Past end of contect check - - IF position <> OutOfRange THEN 'Found? - 'Found... - level = Lev(x) 'Adjust level - IF Expression THEN - 'Found...Expression... - 'Has an expression been provided? - IF position > i AND bvalue = 0 THEN - 'Found...Expression...Provided... - separgs(Expression) = getelements$(ca$, i, position - 1) - Expression = 0 - i = position - ELSE - 'Found...Expression...Omitted... - '*********backtrack************ - GOTO OptCheckBacktrack - '****************************** - END IF - END IF 'Expression - i = i + OptWords(x, which) - separgslayout(x) = CHR$(LEN(RTRIM$(Opt(x, which)))) + RTRIM$(Opt(x, which)) - separgs(x) = CHR$(0) + str2(which) - ELSE - 'Not Found... - '*********backtrack************ - OptCheckBacktrack: - 'Was this optional? - 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 - 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 - Branches = Branches - 1 'Remove branch (it has already been tried with both possible combinations) - NEXT - IF Branches = 0 THEN 'All options have been exhausted - seperateargs_error = 1 - seperateargs_error_message = "Syntax error" - EXIT FUNCTION - END IF - '2)Toggle taken branch to untaken and revert - BranchTaken(Branches) = 0 'toggle branch to untaken - Expression = BranchWithExpression(Branches) - i = BranchInputPos(Branches) - 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 - separgs(x2) = "n-ll" - separgslayout(x2) = "" - NEXT - END IF 'Optional Opt ()? - '****************************** - - END IF 'Found? - - END IF 't - - END IF 'possible to enter level - -NEXT x - -'Final expression? -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 - c$ = getelement$(a$, i2) - 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 - b = b - 1 - 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 - -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 - -' DIM PassRule(1 TO 100) AS LONG -' '0 means no pass rule -' 'negative values refer to an opt () element -' 'positive values refer to a flag value -' PassFlag = 1 - - -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 - - 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 - - separgs(x) = separgs(i) - separgslayout(x) = separgslayout(i) - - 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 - - IF separgs(x) = "n-ll" THEN separgs(x) = "N-LL" - x = x + 1 - - 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 - - separgslayout(i + 1) = separgslayout(i) + separgslayout(i + 1) - - END IF -NEXT -separgslayout(x) = separgslayout(i) 'set final layout - -'x = x - 1 -'PRINT "total arguments:"; x -'PRINT "pass omit (0/1):"; omit -'PRINT "pass&="; pass& - -END FUNCTION - -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 -tl$ = tlayout$ - -'method: 0 evaulatetotyp e$ -' 1 skip evaluation of e$ and use as is -'*due to the complexity of setting a reference with a value/string -' 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 -getid idnumber -IF Error_Happened THEN EXIT SUB - - -'UDT? -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]" - - IF Cloud = 0 THEN - 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 - END IF - - IF E = 0 THEN - 'use u and u's size - - 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 (t2 AND ISREFERENCE) = 0 THEN - IF t2 AND ISPOINTER THEN - src$ = "((char*)" + e$ + ")" - e2 = 0: u2 = t2 AND 511 - ELSE - src$ = "((char*)&" + e$ + ")" - e2 = 0: u2 = t2 AND 511 - END IF - GOTO directudt - END IF - - '****problem**** - 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) - '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 - - dst$ = "(((char*)" + lhsscope$ + n$ + ")+(" + o$ + "))" - siz$ = str2$(udtxsize(u) \ 8) - - PRINT #12, "memcpy(" + dst$ + "," + src$ + "," + siz$ + ");" - - 'print "setFULLUDTrefer!" - - tlayout$ = tl$ - EXIT SUB - - 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 - o2$ = "(((uint8*)" + scope$ + n$ + ")+(" + o$ + "))" - r$ = "qbs_new_fixed(" + o2$ + "," + str2(udtetypesize(E)) + ",1)" - 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 - t$ = typ2ctyp$(typ, "") - 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 - - 'print "setUDTrefer:"+r$,e$ - tlayout$ = tl$ - EXIT SUB -END IF - - -'array? -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 - 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 - l$ = "if (!new_error) qbs_set(" + r$ + "," + evaluatetotyp(e$, typ) + ");" - 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 - l$ = "if (!new_error) qbs_set( ((qbs*)(((uint64*)(" + n$ + "[0]))[tmp_long]))," + evaluatetotyp(e$, typ) + ");" - 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);" - tlayout$ = tl$ - EXIT SUB - END IF - - IF (typ AND ISOFFSETINBITS) THEN - '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 - l$ = "if (!new_error) " + r$ + evaluatetotyp(e$, typ) + ");" - IF Error_Happened THEN EXIT SUB - ELSE - l$ = "if (!new_error) " + r$ + e$ + ");" - END IF - PRINT #12, l$ - tlayout$ = tl$ - 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 - l$ = "if (!new_error) ((" + t$ + "*)(" + n$ + "[0]))[tmp_long]=" + evaluatetotyp(e$, typ) + ";" - IF Error_Happened THEN EXIT SUB - ELSE - l$ = "if (!new_error) ((" + t$ + "*)(" + n$ + "[0]))[tmp_long]=" + e$ + ";" - END IF - - PRINT #12, l$ - tlayout$ = tl$ - EXIT SUB -END IF 'array - -'variable? -IF id.t THEN - r$ = RTRIM$(id.n) - t = id.t - 'remove irrelavant flags - IF (t AND ISINCONVENTIONALMEMORY) THEN t = t - ISINCONVENTIONALMEMORY - typ = t - - 'string variable? - IF (t AND ISSTRING) THEN - IF (t AND ISFIXEDLENGTH) THEN - r$ = scope$ + "STRING" + str2(id.tsize) + "_" + r$ - 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 - tlayout$ = tl$ - 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 - 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 - l$ = "if ((" + r$ + "=" + e$ + ")&" + str2(2 ^ (b - 1)) + "){" - PRINT #12, l$ - 'signed bit is set - l$ = r$ + "|=" + str2(bitmaskinv(b)) + ";" - 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 - tlayout$ = tl$ - 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 - sref: - t2 = t - ISPOINTER - 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 - tlayout$ = tl$ - EXIT SUB -END IF 'variable - -tlayout$ = tl$ -END SUB - -FUNCTION str2$ (v AS LONG) -str2$ = 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 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 - -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) - 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 -'is tstr$ a named type? (eg. 'LONG') -s$ = type2symbol$(tstr$) -IF Error_Happened THEN EXIT FUNCTION -IF LEN(s$) THEN - typ2ctyp$ = typ2ctyp$(0, s$) - IF Error_Happened THEN EXIT FUNCTION - EXIT FUNCTION -END IF - -Give_Error "Invalid type": EXIT FUNCTION - -END FUNCTION - -FUNCTION type2symbol$ (typ$) -t$ = typ$ -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 -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 - s$ = s$ + str2$(v) - ELSE - s$ = LEFT$(s$, LEN(s$) - 1) + str2$(v) - END IF - type2symbol$ = s$ -END IF -END FUNCTION - -'Strips away bits/indentifiers which make locating a variables source difficult -FUNCTION typecomp (typ) -typ2 = typ -IF (typ2 AND ISINCONVENTIONALMEMORY) THEN typ2 = typ2 - ISINCONVENTIONALMEMORY -typecomp = typ2 -END FUNCTION - -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 - -'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 - typname2typsize = b - typname2typ& = STRINGTYPE + ISFIXEDLENGTH - EXIT FUNCTION -END IF - -'unsigned? -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) - 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 - -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 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 - -IF LEFT$(t$, 9) = "STRING * " THEN - - 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 - hashfound = 1 - 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 - 'convert value to general formats - IF t AND ISFLOAT THEN - v## = constfloat(i2) - v&& = v## - v~&& = v&& - ELSE - IF t AND ISUNSIGNED THEN - v~&& = constuinteger(i2) - v&& = v~&& - v## = v&& - 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 - b = v&& - 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 - constantlenstr: - typname2typsize = b - typname2typ& = STRINGTYPE + ISFIXEDLENGTH - EXIT FUNCTION -END IF - -IF t$ = "SINGLE" THEN typname2typ& = SINGLETYPE: EXIT FUNCTION -IF t$ = "DOUBLE" THEN typname2typ& = DOUBLETYPE: EXIT FUNCTION -IF t$ = "_FLOAT" THEN typname2typ& = FLOATTYPE: EXIT FUNCTION -IF LEFT$(t$, 10) = "_UNSIGNED " THEN u = 1: t$ = RIGHT$(t$, LEN(t$) - 10) -IF LEFT$(t$, 4) = "_BIT" THEN - IF t$ = "_BIT" THEN - IF u THEN typname2typ& = UBITTYPE ELSE typname2typ& = BITTYPE - EXIT FUNCTION - END IF - IF LEFT$(t$, 7) <> "_BIT * " THEN Give_Error "Expected _BIT * number": EXIT FUNCTION - - n$ = RIGHT$(t$, LEN(t$) - 7) - IF isuinteger(n$) = 0 THEN Give_Error "Invalid size after _BIT *": EXIT FUNCTION - b = VAL(n$) - IF b = 0 OR b > 56 THEN Give_Error "Invalid size after _BIT *": EXIT FUNCTION - t = BITTYPE - 1 + b: IF u THEN t = t + ISUNSIGNED - typname2typ& = t - EXIT FUNCTION -END IF - -t = 0 -IF t$ = "_BYTE" THEN t = BYTETYPE -IF t$ = "INTEGER" THEN t = INTEGERTYPE -IF t$ = "LONG" THEN t = LONGTYPE -IF t$ = "_INTEGER64" THEN t = INTEGER64TYPE -IF t$ = "_OFFSET" 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) - -'UDT? -FOR i = 1 TO lasttype - IF t$ = RTRIM$(udtxname(i)) THEN - typname2typ& = ISUDT + ISPOINTER + i - EXIT FUNCTION - END IF -NEXT - -'return 0 (failed) + 'return 0 (failed) END FUNCTION FUNCTION uniquenumber& -uniquenumbern = uniquenumbern + 1 -uniquenumber& = uniquenumbern + uniquenumbern = uniquenumbern + 1 + uniquenumber& = uniquenumbern END FUNCTION FUNCTION validlabel (LABEL2$) -create = CreatingLabel: CreatingLabel = 0 -validlabel = 0 -IF LEN(LABEL2$) = 0 THEN EXIT FUNCTION -clabel$ = LABEL2$ -label$ = UCASE$(LABEL2$) + create = CreatingLabel: CreatingLabel = 0 + validlabel = 0 + IF LEN(LABEL2$) = 0 THEN EXIT FUNCTION + clabel$ = LABEL2$ + label$ = UCASE$(LABEL2$) -n = numelements(label$) + 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 + '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 - 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 '"[" - onecommandsub = 0 + 'analyze format + IF ASC(ids(hashresref).specialformat) = 32 THEN + IF ids(hashresref).args = 0 THEN onecommandsub = 1 ELSE onecommandsub = 0 ELSE - onecommandsub = 1 - 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 + IF ASC(ids(hashresref).specialformat) <> 91 THEN '"[" + onecommandsub = 0 + ELSE + onecommandsub = 1 + 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 - 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 - 'reserved + ELSE + 'reserved + EXIT FUNCTION + END IF + IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 + LOOP + + 'Numeric label? + 'quasi numbers are possible, but: + 'a) They may only have one decimal place + '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 + + '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 + + '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 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" + + IF LEN(t$) > 40 THEN EXIT FUNCTION + + LABEL2$ = t$ + validlabel = 1 EXIT FUNCTION - END IF - IF hashres <> 1 THEN hashres = HashFindCont(hashresflags, hashresref) ELSE hashres = 0 - LOOP + END IF 'numeric - 'Numeric label? - 'quasi numbers are possible, but: - 'a) They may only have one decimal place - '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 + END IF 'n=1 - '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 + 'Alpha-numeric label? + 'Build label - '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 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" - - IF LEN(t$) > 40 THEN EXIT FUNCTION - - LABEL2$ = t$ - validlabel = 1 - EXIT FUNCTION - END IF 'numeric - -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 - a$ = getelement$(LABEL2$, nx) - 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 - -'elements check -label3$ = "" -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 + '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 + a$ = getelement$(LABEL2$, nx) + IF a$ <> "." THEN EXIT FUNCTION 'every 2nd element must be a period NEXT - 'build label - IF label3$ = "" THEN label3$ = UCASE$(label$): tlayout$ = label$ ELSE label3$ = label3$ + fix046$ + UCASE$(label$): tlayout$ = tlayout$ + "." + label$ -NEXT nx + 'cannot begin with numeric + c = ASC(clabel$): IF c >= 48 AND c <= 57 THEN EXIT FUNCTION -validlabel = 1 -LABEL2$ = label3$ + 'elements check + label3$ = "" + 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 + + 'build label + 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 SUB xend -PRINT #12, "sub_end();" + PRINT #12, "sub_end();" END SUB SUB xfileprint (a$, ca$, n) -u$ = str2$(uniquenumber) -PRINT #12, "tab_spc_cr_size=2;" -IF n = 2 THEN Give_Error "Expected # ... , ...": EXIT SUB -a3$ = "" -b = 0 -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 -printgotfn: -e$ = fixoperationorder$(a3$) -IF Error_Happened THEN EXIT SUB -l$ = "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$ + ";" -i = i + 1 - -'PRINT USING? (file) -IF n >= i THEN - IF getelement(a$, i) = "USING" THEN - 'get format string - fpujump: - l$ = l$ + sp + "USING" - e$ = "": b = 0: puformat$ = "" - 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 - e$ = fixoperationorder$(e$) - 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 - 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 - 'create build string - PRINT #12, "tqbs=qbs_new(0,0);" - 'set format start/index variable - 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$ + ";" + u$ = str2$(uniquenumber) + PRINT #12, "tab_spc_cr_size=2;" + IF n = 2 THEN Give_Error "Expected # ... , ...": EXIT SUB + a3$ = "" + b = 0 + 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 - 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 - 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 - fprintulast: + 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 + l$ = "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$ + ";" + i = i + 1 + + 'PRINT USING? (file) + IF n >= i THEN + IF getelement(a$, i) = "USING" THEN + 'get format string + fpujump: + l$ = l$ + sp + "USING" + e$ = "": b = 0: puformat$ = "" + 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 + e$ = fixoperationorder$(e$) + 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 + 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 + 'create build string + PRINT #12, "tqbs=qbs_new(0,0);" + 'set format start/index variable + 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$ + ";" + 'print expressions + b = 0 + e$ = "" + last = 0 + 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 + fprintulast: + e$ = fixoperationorder$(e$) + 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 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 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);" + '-set length of tqbs to 0 + PRINT #12, "tqbs->len=0;" + + ELSE + + 'regular string + PRINT #12, "tmp_long=print_using(" + puf$ + ",tmp_long,tqbs," + e$ + ");" + + 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$ + ";" + e$ = "" + 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$ + ":" + '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;" + tlayout$ = l$ + 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 + b = 0 + e$ = "" + last = 0 + 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 + printfilelast: + + 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 + extraspace = 0 + + IF LEN(e$) THEN + ebak$ = e$ + pnrtnum = 0 + printfilenumber: e$ = fixoperationorder$(e$) IF Error_Happened THEN EXIT SUB - IF last THEN l$ = l$ + sp + tlayout$ ELSE l$ = l$ + sp + tlayout$ + sp2 + a2$ + 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 + 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 - IF typ AND ISSTRING THEN + '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$ + ";" - IF LEFT$(e$, 9) = "func_tab(" OR LEFT$(e$, 9) = "func_spc(" THEN + 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$ + printfilenext: + 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;" + tlayout$ = l$ +END SUB - '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 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);" - '-set length of tqbs to 0 - PRINT #12, "tqbs->len=0;" - - ELSE - - 'regular string - PRINT #12, "tmp_long=print_using(" + puf$ + ",tmp_long,tqbs," + e$ + ");" - - 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$ + ";" - e$ = "" - 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$ + ":" - '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;" - tlayout$ = l$ - EXIT SUB +SUB xfilewrite (ca$, n) + l$ = "WRITE" + sp + "#" + u$ = str2$(uniquenumber) + PRINT #12, "tab_spc_cr_size=2;" + IF n = 2 THEN Give_Error "Expected # ...": EXIT SUB + a3$ = "" + b = 0 + 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 + writegotfn: + e$ = fixoperationorder$(a3$) + 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$ + ";" + i = i + 1 + IF i > n THEN + PRINT #12, "sub_file_print(tmp_fileno,nothingstring,0,0,1);" + GOTO writeblankline 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 -b = 0 -e$ = "" -last = 0 -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 - printfilelast: - - 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 - extraspace = 0 - - IF LEN(e$) THEN + b = 0 + e$ = "" + last = 0 + 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 + writefilelast: + IF last = 1 THEN newline = 1 ELSE newline = 0 ebak$ = e$ - pnrtnum = 0 - printfilenumber: + reevaled = 0 + writefilenumber: 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$ + IF reevaled = 0 THEN + l$ = l$ + sp + tlayout$ + IF last = 0 THEN l$ = l$ + sp2 + "," END IF e$ = evaluate(e$, typ) 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 + 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" + 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" + 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 '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$ + ";" - - 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$ - printfilenext: -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;" -tlayout$ = l$ -END SUB - -SUB xfilewrite (ca$, n) -l$ = "WRITE" + sp + "#" -u$ = str2$(uniquenumber) -PRINT #12, "tab_spc_cr_size=2;" -IF n = 2 THEN Give_Error "Expected # ...": EXIT SUB -a3$ = "" -b = 0 -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 -writegotfn: -e$ = fixoperationorder$(a3$) -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$ + ";" -i = i + 1 -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 - a2$ = getelement(ca$, i) - 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 - ebak$ = e$ - reevaled = 0 - writefilenumber: - e$ = fixoperationorder$(e$) - IF Error_Happened THEN EXIT SUB - IF reevaled = 0 THEN - l$ = l$ + sp + tlayout$ - 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 - e$ = "LTRIM$" + sp + "(" + sp + "STR$" + sp + "(" + sp + ebak$ + sp + ")" + sp + ")" - 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" - 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 - '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$ + ";" - e$ = "" - 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 -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$ + 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$ + writefilenext: + 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 SUB xgosub (ca$, n&) -a2$ = getelement(ca$, 2) -IF validlabel(a2$) = 0 THEN Give_Error "Invalid label": EXIT SUB + a2$ = getelement(ca$, 2) + IF validlabel(a2$) = 0 THEN Give_Error "Invalid label": EXIT SUB -v = HashFind(a2$, HASHFLAG_LABEL, ignore, r) -x = 1 -labchk200: -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 - x = 0 'already defined - tlayout$ = RTRIM$(Labels(r).cn) - ELSE - IF v = 2 THEN v = HashFindCont(ignore, r): GOTO labchk200 + v = HashFind(a2$, HASHFLAG_LABEL, ignore, r) + x = 1 + labchk200: + 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 + x = 0 'already defined + tlayout$ = RTRIM$(Labels(r).cn) + ELSE + IF v = 2 THEN v = HashFindCont(ignore, r): GOTO labchk200 + END IF 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 - Labels(nLabels) = Empty_Label - HashAdd a2$, HASHFLAG_LABEL, nLabels - r = nLabels - Labels(r).State = 0 - Labels(r).cn = tlayout$ - Labels(r).Scope = subfuncn - Labels(r).Error_Line = linenumber -END IF 'x + 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 + Labels(nLabels) = Empty_Label + HashAdd a2$, HASHFLAG_LABEL, nLabels + r = nLabels + Labels(r).State = 0 + Labels(r).cn = tlayout$ + Labels(r).Scope = subfuncn + Labels(r).Error_Line = linenumber + END IF 'x -l$ = "GOSUB" + sp + tlayout$ -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$ + ";" -'add return point jump -PRINT #15, "case " + str2(gosubid) + ":" -PRINT #15, "goto RETURN_" + str2(gosubid) + ";" -PRINT #15, "break;" -PRINT #12, "RETURN_" + str2(gosubid) + ":;" -gosubid = gosubid + 1 + l$ = "GOSUB" + sp + tlayout$ + 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$ + ";" + 'add return point jump + PRINT #15, "case " + str2(gosubid) + ":" + PRINT #15, "goto RETURN_" + str2(gosubid) + ";" + PRINT #15, "break;" + PRINT #12, "RETURN_" + str2(gosubid) + ":;" + gosubid = gosubid + 1 END SUB SUB xongotogosub (a$, ca$, n) -IF n < 4 THEN Give_Error "Expected ON expression GOTO/GOSUB label,label,...": EXIT SUB -l$ = "ON" -b = 0 -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 -e$ = getelements$(ca$, 2, i - 1) + IF n < 4 THEN Give_Error "Expected ON expression GOTO/GOSUB label,label,...": EXIT SUB + l$ = "ON" + b = 0 + 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 + e$ = getelements$(ca$, 2, i - 1) -g = 0: IF e2$ = "GOSUB" THEN g = 1 -e$ = fixoperationorder(e$) -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 - e$ = "qbr_float_to_long(" + e$ + ")" -END IF -l$ = l$ + sp + e2$ -u$ = str2$(uniquenumber) -PRINT #13, "static int32 ongo_" + u$ + "=0;" -PRINT #12, "ongo_" + u$ + "=" + e$ + ";" -ln = 1 -labelwaslast = 0 -FOR i = i + 1 TO n - e$ = getelement$(ca$, i) - IF e$ = "," THEN - l$ = l$ + sp2 + "," - 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 - - v = HashFind(e$, HASHFLAG_LABEL, ignore, r) - x = 1 - labchk507: - 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 - 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 - '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 - Labels(nLabels) = Empty_Label - HashAdd e$, HASHFLAG_LABEL, nLabels - r = nLabels - Labels(r).State = 0 - Labels(r).cn = tlayout$ - Labels(r).Scope = subfuncn - Labels(r).Error_Line = linenumber - END IF 'x - - l$ = l$ + sp + tlayout$ - IF g THEN 'gosub - lb$ = e$ - 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$ + ";" - 'add return point jump - 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 - labelwaslast = 1 + g = 0: IF e2$ = "GOSUB" THEN g = 1 + e$ = fixoperationorder(e$) + 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 + e$ = "qbr_float_to_long(" + e$ + ")" 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$ + l$ = l$ + sp + e2$ + u$ = str2$(uniquenumber) + PRINT #13, "static int32 ongo_" + u$ + "=0;" + PRINT #12, "ongo_" + u$ + "=" + e$ + ";" + ln = 1 + labelwaslast = 0 + FOR i = i + 1 TO n + e$ = getelement$(ca$, i) + IF e$ = "," THEN + l$ = l$ + sp2 + "," + 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 + + v = HashFind(e$, HASHFLAG_LABEL, ignore, r) + x = 1 + labchk507: + 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 + 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 + '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 + Labels(nLabels) = Empty_Label + HashAdd e$, HASHFLAG_LABEL, nLabels + r = nLabels + Labels(r).State = 0 + Labels(r).cn = tlayout$ + Labels(r).Scope = subfuncn + Labels(r).Error_Line = linenumber + END IF 'x + + l$ = l$ + sp + tlayout$ + IF g THEN 'gosub + lb$ = e$ + 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$ + ";" + 'add return point jump + 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 + 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 SUB xprint (a$, ca$, n) -u$ = str2$(uniquenumber) + u$ = str2$(uniquenumber) -l$ = "PRINT" -IF ASC(a$) = 76 THEN lp = 1: lp$ = "l": l$ = "LPRINT": PRINT #12, "tab_LPRINT=1;": DEPENDENCY(DEPENDENCY_PRINTER) = 1 '"L" + l$ = "PRINT" + IF ASC(a$) = 76 THEN lp = 1: lp$ = "l": l$ = "LPRINT": PRINT #12, "tab_LPRINT=1;": DEPENDENCY(DEPENDENCY_PRINTER) = 1 '"L" -'PRINT USING? -IF n >= 2 THEN - IF getelement(a$, 2) = "USING" THEN - 'get format string - i = 3 - pujump: - l$ = l$ + sp + "USING" - e$ = "": b = 0: puformat$ = "" - 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 - e$ = fixoperationorder$(e$) - 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 - 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 - 'create build string - PRINT #12, "tqbs=qbs_new(0,0);" - 'set format start/index variable - PRINT #12, "tmp_long=0;" 'scan format from beginning + 'PRINT USING? + IF n >= 2 THEN + IF getelement(a$, 2) = "USING" THEN + 'get format string + i = 3 + pujump: + l$ = l$ + sp + "USING" + e$ = "": b = 0: puformat$ = "" + 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 + e$ = fixoperationorder$(e$) + 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 + 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 + 'create build string + PRINT #12, "tqbs=qbs_new(0,0);" + 'set format start/index variable + 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$ + ";" - - 'print expressions - b = 0 - e$ = "" - last = 0 - 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 - printulast: - e$ = fixoperationorder$(e$) - 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 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 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);" - '-set length of tqbs to 0 - PRINT #12, "tqbs->len=0;" - - ELSE - - 'regular string - PRINT #12, "tmp_long=print_using(" + puf$ + ",tmp_long,tqbs," + e$ + ");" - - 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$ + ";" - e$ = "" - 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$ + ":" - '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;" - tlayout$ = l$ - 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 -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 - printlast: - - IF UCASE$(a2$) = "USING" THEN - IF e$ <> "" THEN gotopu = 1 ELSE i = i + 1: GOTO pujump - END IF - - 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 - e$ = evaluate(e$, typ) - 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) - 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);" + 'create string to hold format in for multiple references + puf$ = "print_using_format" + u$ + IF subfunc = "" THEN + PRINT #13, "static qbs *" + puf$ + ";" 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 last THEN - PRINT #12, "qbs_" + lp$ + "print(nothingstring,1);" 'go to new line - EXIT FOR + 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$ + ";" - GOTO printnext - END IF 'a2$ - END IF 'b=0 + 'print expressions + b = 0 + e$ = "" + last = 0 + 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 + printulast: + e$ = fixoperationorder$(e$) + 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 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;" -tlayout$ = l$ + 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 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);" + '-set length of tqbs to 0 + PRINT #12, "tqbs->len=0;" + + ELSE + + 'regular string + PRINT #12, "tmp_long=print_using(" + puf$ + ",tmp_long,tqbs," + e$ + ");" + + 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$ + ";" + e$ = "" + 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$ + ":" + '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;" + tlayout$ = l$ + 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 + 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 + printlast: + + IF UCASE$(a2$) = "USING" THEN + IF e$ <> "" THEN gotopu = 1 ELSE i = i + 1: GOTO pujump + END IF + + 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 + e$ = evaluate(e$, typ) + 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) + 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();" + e$ = "" + + 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 + + GOTO printnext + END IF 'a2$ + END IF 'b=0 + + 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;" + tlayout$ = l$ END SUB SUB xread (ca$, n) -l$ = "READ" -IF n = 1 THEN Give_Error "Expected variable": EXIT SUB -i = 2 -IF i > n THEN Give_Error "Expected , ...": EXIT SUB -a3$ = "" -b = 0 -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 - e$ = fixoperationorder$(a3$) - 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 (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$ + ");" - stringprocessinghappened = 1 - ELSE - 'numeric variable - 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 - 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 - setrefer e$, t, "func_read_uint64(data,&data_offset,data_size)", 1 - 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 + l$ = "READ" + IF n = 1 THEN Give_Error "Expected variable": EXIT SUB + i = 2 + IF i > n THEN Give_Error "Expected , ...": EXIT SUB + a3$ = "" + b = 0 + 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 - 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$ + 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 + "," + e$ = evaluate(e$, t) + IF Error_Happened THEN EXIT SUB + IF (t AND ISREFERENCE) = 0 THEN Give_Error "Expected variable": EXIT SUB + + 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$ + ");" + stringprocessinghappened = 1 + ELSE + 'numeric variable + 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 + 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 + setrefer e$, t, "func_read_uint64(data,&data_offset,data_size)", 1 + 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 + 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 SUB xwrite (ca$, n) -l$ = "WRITE" -u$ = str2$(uniquenumber) -IF n = 1 THEN - PRINT #12, "qbs_print(nothingstring,1);" - GOTO writeblankline2 -END IF -b = 0 -e$ = "" -last = 0 -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 - writelast: - 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 - l$ = l$ + sp + tlayout$ - 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 - e$ = "LTRIM$" + sp + "(" + sp + "STR$" + sp + "(" + sp + ebak$ + sp + ")" + sp + ")" - 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" - reevaled = 1 - GOTO writechecked 'force re-evaluation + l$ = "WRITE" + u$ = str2$(uniquenumber) + IF n = 1 THEN + PRINT #12, "qbs_print(nothingstring,1);" + GOTO writeblankline2 + END IF + b = 0 + e$ = "" + last = 0 + 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 + writelast: + 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 + l$ = l$ + sp + tlayout$ + IF last = 0 THEN l$ = l$ + sp2 + "," 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$ + ";" - e$ = "" - 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 -writeblankline2: -PRINT #12, "skip" + u$ + ":" -PRINT #12, cleanupstringprocessingcall$ + "0);" -layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$ + e$ = evaluate(e$, typ) + 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" + 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" + 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 + '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$ + ";" + e$ = "" + 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 + writeblankline2: + 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) -a$ = a2$ -IF Debug THEN PRINT #9, "evaluateconst:in:" + a$ + a$ = a2$ + IF Debug THEN PRINT #9, "evaluateconst:in:" + a$ -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 block(1000) AS STRING + DIM status(1000) AS INTEGER + '0=unprocessed (can be "") + '1=processed + DIM btype(1000) AS LONG 'for status=1 blocks -'put a$ into blocks -n = numelements(a$) -FOR i = 1 TO n - block(i) = getelement$(a$, i) -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 - -'if brackets exist, evaluate that item first -IF l THEN - - b = 0 - e$ = "" + 'put a$ into blocks + n = numelements(a$) FOR i = 1 TO n + block(i) = getelement$(a$, i) + NEXT - IF block(i) = ")" THEN - IF b = l THEN block(i) = "": EXIT FOR - b = b - 1 - END IF + evalconstevalbrack: - IF b >= l THEN - IF LEN(e$) = 0 THEN e$ = block(i) ELSE e$ = e$ + sp + block(i) - block(i) = "" - END IF + '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 - IF block(i) = "(" THEN - b = b + 1 - IF b = l THEN i2 = i: block(i) = "" - END IF + 'if brackets exist, evaluate that item first + IF l THEN - NEXT i + b = 0 + e$ = "" + FOR i = 1 TO n - status(i) = 1 - block(i) = evaluateconst$(e$, btype(i)) - IF Error_Happened THEN EXIT FUNCTION - GOTO evalconstevalbrack - -END IF 'l - -'linear equation remains with some pre-calculated & non-pre-calc blocks - -'problem: type QBASIC assumes and type required to store calc. value may -' differ dramatically. in qbasic, this would have caused an overflow, -' but in qb64 it MUST work. eg. 32767% * 32767% -'solution: all interger calc. will be performed using a signed _INTEGER64 -' 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 - - 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 - - '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))) - status(i) = 1 - 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))) - status(i) = 1 - GOTO gotconstblktyp - END IF - - 'floats - 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))) - btype(i) = DOUBLETYPE - ISPOINTER - status(i) = 1 - 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 - - 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))) - status(i) = 1 - gotconstblktyp: - - END IF 'a - - 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 + IF block(i) = ")" THEN + IF b = l THEN block(i) = "": EXIT FOR + b = b - 1 END IF - END IF 'len<>0 - END IF 'status -NEXT + IF b >= l THEN + IF LEN(e$) = 0 THEN e$ = block(i) ELSE e$ = e$ + sp + block(i) + block(i) = "" + END IF -'remove NULL blocks -n2 = 0 -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 -n = n2 + IF block(i) = "(" THEN + b = b + 1 + IF b = l THEN i2 = i: block(i) = "" + END IF -'only one block? -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 + NEXT i -'evaluate equation (equation cannot contain any STRINGs) + status(i) = 1 + block(i) = evaluateconst$(e$, btype(i)) + IF Error_Happened THEN EXIT FUNCTION + GOTO evalconstevalbrack -'[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 - o$ = block(1) + END IF 'l - 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)) + 'linear equation remains with some pre-calculated & non-pre-calc blocks + + 'problem: type QBASIC assumes and type required to store calc. value may + ' differ dramatically. in qbasic, this would have caused an overflow, + ' but in qb64 it MUST work. eg. 32767% * 32767% + 'solution: all interger calc. will be performed using a signed _INTEGER64 + ' 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 + + 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 + + '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))) + status(i) = 1 + 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))) + status(i) = 1 + GOTO gotconstblktyp + END IF + + 'floats + 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))) + btype(i) = DOUBLETYPE - ISPOINTER + status(i) = 1 + 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 + + 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))) + status(i) = 1 + gotconstblktyp: + + END IF 'a + + 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 'len<>0 + END IF 'status + NEXT + + 'remove NULL blocks + n2 = 0 + 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 + n = n2 + + 'only one block? + 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 + + '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 + 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 + t = btype(2) + 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&& + t = btype(2) + IF t AND ISFLOAT THEN t = LONGTYPE - ISPOINTER 'markdown to LONG evaluateconst$ = _MK$(_INTEGER64, r&&) + EXIT FUNCTION END IF - t = btype(2) - EXIT FUNCTION + + Give_Error "Invalid CONST expression.7": 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&& - t = btype(2) - IF t AND ISFLOAT THEN t = LONGTYPE - ISPOINTER 'markdown to LONG - evaluateconst$ = _MK$(_INTEGER64, r&&) - EXIT FUNCTION + '[variable][bool-operator][variable]... + + 'get first variable + et = btype(1) + ev$ = block(1) + + i = 2 + + evalconstequ: + + 'get operator + 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 + + 'string/numeric mismatch? + 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 + '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 - Give_Error "Invalid CONST expression.7": EXIT FUNCTION -END IF + 'prepare left and right values + IF et AND ISFLOAT THEN + linteger = 0 + l## = _CV(_FLOAT, ev$) + l&& = l## + ELSE + linteger = 1 + l&& = _CV(_INTEGER64, ev$) + l## = l&& + END IF + IF btype(i) AND ISFLOAT THEN + rinteger = 0 + r## = _CV(_FLOAT, block(i)) + r&& = r## + ELSE + rinteger = 1 + r&& = _CV(_INTEGER64, block(i)) + r## = r&& + END IF -'[variable][bool-operator][variable]... + 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 -'get first variable -et = btype(1) -ev$ = block(1) + 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 -i = 2 + Give_Error "Invalid CONST expression.13": EXIT FUNCTION -evalconstequ: - -'get operator -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 - -'string/numeric mismatch? -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 - '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) + econstmarkupi16: + et = INTEGERTYPE - ISPOINTER + ev$ = _MK$(_INTEGER64, r&&) GOTO econstmarkedup -END IF -'prepare left and right values -IF et AND ISFLOAT THEN - linteger = 0 - l## = _CV(_FLOAT, ev$) - l&& = l## -ELSE - linteger = 1 - l&& = _CV(_INTEGER64, ev$) - l## = l&& -END IF -IF btype(i) AND ISFLOAT THEN - rinteger = 0 - r## = _CV(_FLOAT, block(i)) - r&& = r## -ELSE - rinteger = 1 - r&& = _CV(_INTEGER64, block(i)) - r## = r&& -END IF + econstmarkupi32: + et = LONGTYPE - ISPOINTER + ev$ = _MK$(_INTEGER64, r&&) + GOTO econstmarkedup -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 - -Give_Error "Invalid CONST expression.13": EXIT FUNCTION - -econstmarkupi16: -et = INTEGERTYPE - ISPOINTER -ev$ = _MK$(_INTEGER64, r&&) -GOTO econstmarkedup - -econstmarkupi32: -et = LONGTYPE - ISPOINTER -ev$ = _MK$(_INTEGER64, r&&) -GOTO econstmarkedup - -econstmarkupi: -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 - ob = 0 - IF lb = rb THEN - IF (et AND ISOFFSETINBITS) <> 0 AND (btype(i) AND ISOFFSETINBITS) <> 0 THEN ob = 1 - b = lb + econstmarkupi: + 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 + ob = 0 + 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 + b = lb + END IF + IF lb < rb THEN + IF (btype(i) AND ISOFFSETINBITS) <> 0 THEN ob = 1 + b = rb + END IF + et = b + IF ob THEN et = et + ISOFFSETINBITS + IF u THEN et = et + ISUNSIGNED 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 - b = rb - END IF - et = b - IF ob THEN et = et + ISOFFSETINBITS - IF u THEN et = et + ISUNSIGNED -END IF -ev$ = _MK$(_INTEGER64, r&&) -GOTO econstmarkedup + 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 -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 -et = ISFLOAT + f -ev$ = _MK$(_FLOAT, r##) + 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 + 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 + et = ISFLOAT + f + ev$ = _MK$(_FLOAT, r##) -econstmarkedup: + econstmarkedup: -i = i + 1 + i = i + 1 -IF i <= n THEN GOTO evalconstequ + IF i <= n THEN GOTO evalconstequ -t = et -evaluateconst$ = ev$ + t = et + evaluateconst$ = ev$ END FUNCTION FUNCTION typevalue2symbol$ (t) -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 + 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 -s$ = "" + 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 + + 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 + + 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$ - EXIT FUNCTION -END IF - -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 - -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 FUNCTION id2fulltypename$ -t = id.t -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$ = "_BIT * " + str2(bits) ELSE a$ = "_BIT" - IF t AND ISUNSIGNED THEN a$ = "_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$ = "_FLOAT" -ELSE 'integer-based - IF bits = 8 THEN a$ = "_BYTE" - IF bits = 16 THEN a$ = "INTEGER" - IF bits = 32 THEN a$ = "LONG" - IF bits = 64 THEN a$ = "_INTEGER64" - IF t AND ISUNSIGNED THEN a$ = "_UNSIGNED " + a$ -END IF -id2fulltypename$ = a$ + t = id.t + 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$ = "_BIT * " + str2(bits) ELSE a$ = "_BIT" + IF t AND ISUNSIGNED THEN a$ = "_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$ = "_FLOAT" + ELSE 'integer-based + IF bits = 8 THEN a$ = "_BYTE" + IF bits = 16 THEN a$ = "INTEGER" + IF bits = 32 THEN a$ = "LONG" + IF bits = 64 THEN a$ = "_INTEGER64" + IF t AND ISUNSIGNED THEN a$ = "_UNSIGNED " + a$ + END IF + id2fulltypename$ = a$ END FUNCTION FUNCTION symbol2fulltypename$ (s2$) -'note: accepts both symbols and type names -s$ = s2$ + 'note: accepts both symbols and type names + s$ = s2$ -IF LEFT$(s$, 1) = "~" THEN - u = 1 - IF LEN(typ$) = 1 THEN Give_Error "Expected ~...": EXIT FUNCTION - s$ = RIGHT$(s$, LEN(s$) - 1) - u$ = "_UNSIGNED " -END IF + IF LEFT$(s$, 1) = "~" THEN + u = 1 + IF LEN(typ$) = 1 THEN Give_Error "Expected ~...": EXIT FUNCTION + s$ = RIGHT$(s$, LEN(s$) - 1) + u$ = "_UNSIGNED " + END IF -IF s$ = "%%" THEN t$ = u$ + "_BYTE": GOTO gotsym2typ -IF s$ = "%" THEN t$ = u$ + "INTEGER": GOTO gotsym2typ -IF s$ = "&" THEN t$ = u$ + "LONG": GOTO gotsym2typ -IF s$ = "&&" THEN t$ = u$ + "_INTEGER64": GOTO gotsym2typ -IF s$ = "%&" THEN t$ = u$ + "_OFFSET": GOTO gotsym2typ + IF s$ = "%%" THEN t$ = u$ + "_BYTE": GOTO gotsym2typ + IF s$ = "%" THEN t$ = u$ + "INTEGER": GOTO gotsym2typ + IF s$ = "&" THEN t$ = u$ + "LONG": GOTO gotsym2typ + IF s$ = "&&" THEN t$ = u$ + "_INTEGER64": GOTO gotsym2typ + IF s$ = "%&" THEN t$ = u$ + "_OFFSET": GOTO gotsym2typ -IF LEFT$(s$, 1) = "`" THEN - IF LEN(s$) = 1 THEN - t$ = u$ + "_BIT * 1" + IF LEFT$(s$, 1) = "`" THEN + IF LEN(s$) = 1 THEN + t$ = u$ + "_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 + t$ = u$ + "_BIT * " + n$ 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$ + "_BIT * " + n$ - 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$ = "_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$ = "_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 - t$ = "STRING * " + n$ - GOTO gotsym2typ -END IF + 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 -t$ = s$ + t$ = s$ -gotsym2typ: + 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$ + symbol2fulltypename$ = t$ END FUNCTION 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 -lineinput3index = 1 + 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 + lineinput3index = 1 END SUB 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) - lineinput3index = l + 1 - 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) - lineinput3index = c10 + 1 - IF lineinput3index <= l THEN - IF ASC(MID$(lineinput3buffer$, lineinput3index, 1)) = 13 THEN lineinput3index = lineinput3index + 1 + '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) + lineinput3index = l + 1 + EXIT FUNCTION END IF -ELSE - '13 before 10 - lineinput3$ = MID$(lineinput3buffer$, lineinput3index, c13 - lineinput3index) - lineinput3index = c13 + 1 - IF lineinput3index <= l THEN - IF ASC(MID$(lineinput3buffer$, lineinput3index, 1)) = 10 THEN lineinput3index = lineinput3index + 1 + 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) + lineinput3index = c10 + 1 + 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) + lineinput3index = c13 + 1 + IF lineinput3index <= l THEN + IF ASC(MID$(lineinput3buffer$, lineinput3index, 1)) = 10 THEN lineinput3index = lineinput3index + 1 + END IF 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 -getfilepath$ = "" + 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 FUNCTION eleucase$ (a$) -'this function upper-cases all elements except for quoted strings -'check first element -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) - i = i2 -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 - i = i3 + 1 - IF i > LEN(a$) THEN EXIT DO - LOOP -END IF -a2$ = a2$ + UCASE$(MID$(a$, i, LEN(a$) - i + 1)) -eleucase$ = a2$ + 'this function upper-cases all elements except for quoted strings + 'check first element + 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) + i = i2 + 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 + i = i3 + 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 SUB SetDependency (requirement) -IF requirement THEN - DEPENDENCY(requirement) = 1 -END IF + IF requirement THEN + DEPENDENCY(requirement) = 1 + END IF END SUB SUB Build (path$) -previous_dir$ = _CWD$ + 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$ + '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$ -return_path$ = ".." -FOR x = 2 TO depth - return_path$ = return_path$ + "\.." -NEXT + return_path$ = ".." + FOR x = 2 TO depth + return_path$ = return_path$ + "\.." + NEXT -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 - 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$ + 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 + 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 - END IF -LOOP -CLOSE #bfh + LOOP + CLOSE #bfh -IF os$ = "WIN" THEN - CHDIR return_path$ -ELSE - CHDIR previous_dir$ -END IF + 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 -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 + 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$)) + '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 + 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 - 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 - 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 -GDB_Fix$ = c$ + GDB_Fix$ = c$ 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 + 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 UseAndroid (Yes) -STATIC inline_DATA_backup -STATIC inline_DATA_backup_set -IF inline_DATA_backup_set = 0 THEN - inline_DATA_backup_set = 1 - inline_DATA_backup = inline_DATA -END IF + STATIC inline_DATA_backup + STATIC inline_DATA_backup_set + IF inline_DATA_backup_set = 0 THEN + inline_DATA_backup_set = 1 + inline_DATA_backup = inline_DATA + END IF -IF Yes THEN - IF MakeAndroid = 0 THEN - MakeAndroid = 1 - inline_DATA = 1 - idechangemade = 1 - IDEBuildModeChanged = 1 + IF Yes THEN + IF MakeAndroid = 0 THEN + MakeAndroid = 1 + inline_DATA = 1 + idechangemade = 1 + IDEBuildModeChanged = 1 + END IF + ELSE + IF MakeAndroid THEN + MakeAndroid = 0 + inline_DATA = inline_DATA_backup + idechangemade = 1 + IDEBuildModeChanged = 1 + END IF END IF -ELSE - IF MakeAndroid THEN - MakeAndroid = 0 - inline_DATA = inline_DATA_backup - idechangemade = 1 - IDEBuildModeChanged = 1 - END IF -END IF END SUB 'Steve Subs/Functins for _MATH support with CONST FUNCTION Evaluate_Expression$ (e$) -t$ = e$ 'So we preserve our original data, we parse a temp copy of it + t$ = e$ 'So we preserve our original data, we parse a temp copy of it -b = INSTR(UCASE$(e$), "EQL") 'take out assignment before the preparser sees it -IF b THEN t$ = MID$(e$, b + 3): var$ = UCASE$(LTRIM$(RTRIM$(MID$(e$, 1, b - 1)))) + b = INSTR(UCASE$(e$), "EQL") 'take out assignment before the preparser sees it + IF b THEN t$ = MID$(e$, b + 3): var$ = UCASE$(LTRIM$(RTRIM$(MID$(e$, 1, b - 1)))) -QuickReturn = 0 -PreParse t$ + QuickReturn = 0 + PreParse t$ -IF QuickReturn THEN Evaluate_Expression$ = t$: EXIT FUNCTION + IF QuickReturn THEN Evaluate_Expression$ = t$: EXIT FUNCTION -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. + 'Deal with brackets first + exp$ = "(" + t$ + ")" 'Starting and finishing brackets for our parse routine. -DO - Eval_E = INSTR(exp$, ")") - IF Eval_E > 0 THEN - 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 - s = Eval_E - c + 1 - IF s < 1 THEN PRINT "ERROR -- BAD () Count": END - 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$ + DO + Eval_E = INSTR(exp$, ")") + IF Eval_E > 0 THEN + 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 + s = Eval_E - c + 1 + IF s < 1 THEN PRINT "ERROR -- BAD () Count": END + 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 SUB - exp$ = DWD(LEFT$(exp$, s - 2) + eval$ + MID$(exp$, Eval_E + 1)) - IF MID$(exp$, 1, 1) = "N" THEN MID$(exp$, 1) = "-" + eval$ = LTRIM$(RTRIM$(eval$)) + IF LEFT$(eval$, 5) = "ERROR" THEN Evaluate_Expression$ = eval$: EXIT SUB + exp$ = DWD(LEFT$(exp$, s - 2) + eval$ + MID$(exp$, Eval_E + 1)) + IF MID$(exp$, 1, 1) = "N" THEN MID$(exp$, 1) = "-" - temppp$ = DWD(LEFT$(exp$, s - 2) + " ## " + eval$ + " ## " + MID$(exp$, E + 1)) - END IF -LOOP UNTIL Eval_E = 0 -c = 0 -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 SUB - END SELECT -LOOP UNTIL c >= LEN(exp$) + temppp$ = DWD(LEFT$(exp$, s - 2) + " ## " + eval$ + " ## " + MID$(exp$, E + 1)) + END IF + LOOP UNTIL Eval_E = 0 + c = 0 + 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 SUB + END SELECT + LOOP UNTIL c >= LEN(exp$) -Evaluate_Expression$ = exp$ + Evaluate_Expression$ = exp$ END FUNCTION SUB ParseExpression (exp$) -DIM num(10) AS STRING -'We should now have an expression with no () to deal with -IF MID$(exp$, 2, 1) = "-" THEN exp$ = "0+" + MID$(exp$, 2) -FOR J = 1 TO 250 - lowest = 0 - 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 op = INSTR(2, exp$, OName(P)) ELSE op = INSTR(exp$, OName(P)) - IF op > 0 AND op < lowest THEN lowest = op: OpOn = P + DIM num(10) AS STRING + 'We should now have an expression with no () to deal with + IF MID$(exp$, 2, 1) = "-" THEN exp$ = "0+" + MID$(exp$, 2) + FOR J = 1 TO 250 + lowest = 0 + 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 op = INSTR(2, exp$, OName(P)) ELSE op = INSTR(exp$, OName(P)) + 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 op = INSTR(2, exp$, OName(OpOn)) ELSE op = INSTR(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 - 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 op = INSTR(2, exp$, OName(OpOn)) ELSE op = INSTR(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 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 ELSE 'Not a valid digit, we found our separator + EXIT DO + END SELECT + c = c + 1 + LOOP UNTIL op + c >= LEN(exp$) + E = op + c - 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 ELSE 'Not a valid digit, we found our separator - EXIT DO - END SELECT - c = c + 1 - LOOP UNTIL op + c >= LEN(exp$) - E = op + c - - c = 0 - 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 - c1 = c - bad = 0 - DO - c1 = c1 + 1 - 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 - '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 - 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) = "-" - num(3) = EvaluateNumbers(OpOn, num()) - IF MID$(num(3), 1, 1) = "-" THEN MID$(num(3), 1) = "N" - 'PRINT "*************" - 'PRINT num(1), OName(OpOn), num(2), num(3), exp$ - 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)))) - 'PRINT exp$ - END IF - op = 0 - LOOP -NEXT + c = 0 + 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 + c1 = c + bad = 0 + DO + c1 = c1 + 1 + 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 + '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 + 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) = "-" + num(3) = EvaluateNumbers(OpOn, num()) + IF MID$(num(3), 1, 1) = "-" THEN MID$(num(3), 1) = "N" + 'PRINT "*************" + 'PRINT num(1), OName(OpOn), num(2), num(3), exp$ + 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)))) + 'PRINT exp$ + END IF + op = 0 + LOOP + NEXT END SUB 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! + '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! -'Constants get evaluated first, with a Priority Level of 1 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "PI" -REDIM _PRESERVE PL(i): PL(i) = 1 -'I'm not certain where exactly percentages should go. They kind of seem like a special case to me. COS10% should be COS.1 I'd think... -'I'm putting it here for now, and if anyone knows someplace better for it in our order of operations, let me know. -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "%" -REDIM _PRESERVE PL(i): PL(i) = 5 -'Then Functions with PL 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ARCCOS" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ARCSIN" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ARCSEC" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ARCCSC" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ARCCOT" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "SECH" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "CSCH" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "COTH" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "COS" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "SIN" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "TAN" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "LOG" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "EXP" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ATN" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "D2R" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "D2G" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "R2D" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "R2G" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "G2D" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "G2R" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ABS" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "SGN" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "INT" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "_ROUND" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "FIX" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "SEC" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "CSC" -REDIM _PRESERVE PL(i): PL(i) = 10 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "COT" -REDIM _PRESERVE PL(i): PL(i) = 10 -'Exponents with PL 20 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "^" -REDIM _PRESERVE PL(i): PL(i) = 20 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "SQR" -REDIM _PRESERVE PL(i): PL(i) = 20 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ROOT" -REDIM _PRESERVE PL(i): PL(i) = 20 -'Multiplication and Division PL 30 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "*" -REDIM _PRESERVE PL(i): PL(i) = 30 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "/" -REDIM _PRESERVE PL(i): PL(i) = 30 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "BTM" -REDIM _PRESERVE PL(i): PL(i) = 30 -'Integer Division PL 40 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "\" -REDIM _PRESERVE PL(i): PL(i) = 40 -'MOD PL 50 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "MOD" -REDIM _PRESERVE PL(i): PL(i) = 50 -'Addition and Subtraction PL 60 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "+" -REDIM _PRESERVE PL(i): PL(i) = 60 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "-" -REDIM _PRESERVE PL(i): PL(i) = 60 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "BTA" -REDIM _PRESERVE PL(i): PL(i) = 60 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "BTS" -REDIM _PRESERVE PL(i): PL(i) = 60 + 'Constants get evaluated first, with a Priority Level of 1 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "PI" + REDIM _PRESERVE PL(i): PL(i) = 1 + 'I'm not certain where exactly percentages should go. They kind of seem like a special case to me. COS10% should be COS.1 I'd think... + 'I'm putting it here for now, and if anyone knows someplace better for it in our order of operations, let me know. + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "%" + REDIM _PRESERVE PL(i): PL(i) = 5 + 'Then Functions with PL 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ARCCOS" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ARCSIN" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ARCSEC" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ARCCSC" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ARCCOT" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "SECH" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "CSCH" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "COTH" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "COS" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "SIN" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "TAN" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "LOG" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "EXP" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ATN" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "D2R" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "D2G" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "R2D" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "R2G" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "G2D" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "G2R" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ABS" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "SGN" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "INT" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "_ROUND" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "FIX" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "SEC" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "CSC" + REDIM _PRESERVE PL(i): PL(i) = 10 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "COT" + REDIM _PRESERVE PL(i): PL(i) = 10 + 'Exponents with PL 20 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "^" + REDIM _PRESERVE PL(i): PL(i) = 20 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "SQR" + REDIM _PRESERVE PL(i): PL(i) = 20 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "ROOT" + REDIM _PRESERVE PL(i): PL(i) = 20 + 'Multiplication and Division PL 30 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "*" + REDIM _PRESERVE PL(i): PL(i) = 30 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "/" + REDIM _PRESERVE PL(i): PL(i) = 30 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "BTM" + REDIM _PRESERVE PL(i): PL(i) = 30 + 'Integer Division PL 40 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "\" + REDIM _PRESERVE PL(i): PL(i) = 40 + 'MOD PL 50 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "MOD" + REDIM _PRESERVE PL(i): PL(i) = 50 + 'Addition and Subtraction PL 60 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "+" + REDIM _PRESERVE PL(i): PL(i) = 60 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "-" + REDIM _PRESERVE PL(i): PL(i) = 60 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "BTA" + REDIM _PRESERVE PL(i): PL(i) = 60 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "BTS" + REDIM _PRESERVE PL(i): PL(i) = 60 -'Relational Operators =, >, <, <>, <=, >= PL 70 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "<>" -REDIM _PRESERVE PL(i): PL(i) = 70 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "><" 'These next three are just reversed symbols as an attempt to help process a common typo -REDIM _PRESERVE PL(i): PL(i) = 70 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "<=" -REDIM _PRESERVE PL(i): PL(i) = 70 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = ">=" -REDIM _PRESERVE PL(i): PL(i) = 70 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "=<" 'I personally can never keep these things straight. Is it < = or = <... -REDIM _PRESERVE PL(i): PL(i) = 70 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "=>" 'Who knows, check both! -REDIM _PRESERVE PL(i): PL(i) = 70 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = ">" -REDIM _PRESERVE PL(i): PL(i) = 70 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "<" -REDIM _PRESERVE PL(i): PL(i) = 70 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "=" -REDIM _PRESERVE PL(i): PL(i) = 70 -'Logical Operations PL 80+ -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "NOT" -REDIM _PRESERVE PL(i): PL(i) = 80 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "AND" -REDIM _PRESERVE PL(i): PL(i) = 90 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "OR" -REDIM _PRESERVE PL(i): PL(i) = 100 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "XOR" -REDIM _PRESERVE PL(i): PL(i) = 110 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "EQV" -REDIM _PRESERVE PL(i): PL(i) = 120 -i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "IMP" -REDIM _PRESERVE PL(i): PL(i) = 130 + 'Relational Operators =, >, <, <>, <=, >= PL 70 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "<>" + REDIM _PRESERVE PL(i): PL(i) = 70 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "><" 'These next three are just reversed symbols as an attempt to help process a common typo + REDIM _PRESERVE PL(i): PL(i) = 70 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "<=" + REDIM _PRESERVE PL(i): PL(i) = 70 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = ">=" + REDIM _PRESERVE PL(i): PL(i) = 70 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "=<" 'I personally can never keep these things straight. Is it < = or = <... + REDIM _PRESERVE PL(i): PL(i) = 70 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "=>" 'Who knows, check both! + REDIM _PRESERVE PL(i): PL(i) = 70 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = ">" + REDIM _PRESERVE PL(i): PL(i) = 70 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "<" + REDIM _PRESERVE PL(i): PL(i) = 70 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "=" + REDIM _PRESERVE PL(i): PL(i) = 70 + 'Logical Operations PL 80+ + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "NOT" + REDIM _PRESERVE PL(i): PL(i) = 80 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "AND" + REDIM _PRESERVE PL(i): PL(i) = 90 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "OR" + REDIM _PRESERVE PL(i): PL(i) = 100 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "XOR" + REDIM _PRESERVE PL(i): PL(i) = 110 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "EQV" + REDIM _PRESERVE PL(i): PL(i) = 120 + i = i + 1: REDIM _PRESERVE OName(i): OName(i) = "IMP" + REDIM _PRESERVE PL(i): PL(i) = 130 END SUB FUNCTION EvaluateNumbers$ (p, num() AS STRING) -DIM n1 AS _FLOAT, n2 AS _FLOAT, n3 AS _FLOAT -SELECT CASE OName(p) 'Depending on our operator.. - CASE "PI" - n1 = 3.14159265358979323846264338327950288## 'Future compatable in case something ever stores extra digits for PI - CASE "%" 'Note percent is a special case and works with the number BEFORE the % command and not after - IF num(1) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get percent of NULL string": EXIT FUNCTION - n1 = (VAL(num(1))) / 100 - CASE "ARCCOS" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCCOS of NULL string": EXIT FUNCTION - n1 = VAL(num(2)) - IF n1 > 1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCCOS from value >1, which is Invalid": EXIT FUNCTION - IF n1 < -1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCCOS from value <-1, which is Invalid": EXIT FUNCTION - IF n1 = 1 THEN EvaluateNumbers$ = "0": EXIT FUNCTION - n1 = (2 * ATN(1)) - ATN(n1 / SQR(1 - n1 * n1)) - CASE "ARCSIN" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCSIN of NULL string": EXIT FUNCTION - n1 = VAL(num(2)) - IF n1 > 1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCSIN from value >1, which is Invalid": EXIT FUNCTION - IF n1 < -1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCSIN from value <-1, which is Invalid": EXIT FUNCTION - n1 = ATN(n1 / SQR(1 - (n1 * n1))) - CASE "ARCSEC" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCSEC of NULL string": EXIT FUNCTION - n1 = VAL(num(2)) - IF n1 > 1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCSEC from value > 1, which is Invalid": EXIT FUNCTION - IF n1 < -1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCSEC from value < -1, which is Invalid": EXIT FUNCTION - n1 = ATN(n1 / SQR(1 - n1 * n1)) + (SGN(n1) - 1) * (2 * ATN(1)) - CASE "ARCCSC" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCCSC of NULL string": EXIT FUNCTION - n1 = VAL(num(2)) - IF n1 > 1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCCSC from value >=1, which is Invalid": EXIT FUNCTION - IF n1 < -1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCCSC from value <-1, which is Invalid": EXIT FUNCTION - n1 = ATN(1 / SQR(1 - n1 * n1)) + (SGN(n1) - 1) * (2 * ATN(1)) - CASE "ARCCOT" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCCOT of NULL string": EXIT FUNCTION - n1 = VAL(num(2)) - n1 = (2 * ATN(1)) - ATN(n1) - CASE "SECH" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get SECH of NULL string": EXIT FUNCTION - n1 = VAL(num(2)) - IF n1 > 88.02969 OR (EXP(n1) + EXP(-n1)) = 0 THEN EvaluateNumbers$ = "ERROR - Bad SECH command": EXIT FUNCTION - n1 = 2 / (EXP(n1) + EXP(-n1)) - CASE "CSCH" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get CSCH of NULL string": EXIT FUNCTION - n1 = VAL(num(2)) - IF n1 > 88.02969 OR (EXP(n1) - EXP(-n1)) = 0 THEN EvaluateNumbers$ = "ERROR - Bad CSCH command": EXIT FUNCTION - n1 = 2 / (EXP(n1) - EXP(-n1)) - CASE "COTH" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get COTH of NULL string": EXIT FUNCTION - n1 = VAL(num(2)) - IF 2 * n1 > 88.02969 OR EXP(2 * n1) - 1 = 0 THEN EvaluateNumbers$ = "ERROR - Bad COTH command": EXIT FUNCTION - n1 = (EXP(2 * n1) + 1) / (EXP(2 * n1) - 1) - CASE "COS" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get COS of NULL string": EXIT FUNCTION - n1 = COS(VAL(num(2))) - CASE "SIN" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get SIN of NULL string": EXIT FUNCTION - n1 = SIN(VAL(num(2))) - CASE "TAN" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get TAN of NULL string": EXIT FUNCTION - n1 = TAN(VAL(num(2))) - CASE "LOG" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get LOG of NULL string": EXIT FUNCTION - n1 = LOG(VAL(num(2))) - CASE "EXP" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get EXP of NULL string": EXIT FUNCTION - n1 = EXP(VAL(num(2))) - CASE "ATN" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ATN of NULL string": EXIT FUNCTION - n1 = ATN(VAL(num(2))) - CASE "D2R" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get Radian of NULL Degree value": EXIT FUNCTION - n1 = 0.0174532925 * (VAL(num(2))) - CASE "D2G" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get Grad of NULL Degree string": EXIT FUNCTION - n1 = 1.1111111111 * (VAL(num(2))) - CASE "R2D" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get Degree of NULL Radian string": EXIT FUNCTION - n1 = 57.2957795 * (VAL(num(2))) - CASE "R2G" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get Grad of NULL Radian string": EXIT FUNCTION - n1 = 0.015707963 * (VAL(num(2))) - CASE "G2D" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get Degree of NULL Gradian string": EXIT FUNCTION - n1 = 0.9 * (VAL(num(2))) - CASE "G2R" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get Radian of NULL Grad string": EXIT FUNCTION - n1 = 63.661977237 * (VAL(num(2))) - CASE "ABS" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ABS of NULL string": EXIT FUNCTION - n1 = ABS(VAL(num(2))) - CASE "SGN" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get SGN of NULL string": EXIT FUNCTION - n1 = SGN(VAL(num(2))) - CASE "INT" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get INT of NULL string": EXIT FUNCTION - n1 = INT(VAL(num(2))) - CASE "_ROUND" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to _ROUND a NULL string": EXIT FUNCTION - n1 = _ROUND(VAL(num(2))) - CASE "FIX" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to FIX a NULL string": EXIT FUNCTION - n1 = FIX(VAL(num(2))) - CASE "SEC" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get SEC of NULL string": EXIT FUNCTION - n1 = COS(VAL(num(2))) - IF n1 = 0 THEN EvaluateNumbers$ = "ERROR - COS value is 0, thus SEC is 1/0 which is Invalid": EXIT FUNCTION - n1 = 1 / n1 - CASE "CSC" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get CSC of NULL string": EXIT FUNCTION - n1 = SIN(VAL(num(2))) - IF n1 = 0 THEN EvaluateNumbers$ = "ERROR - SIN value is 0, thus CSC is 1/0 which is Invalid": EXIT FUNCTION - n1 = 1 / n1 - CASE "COT" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get COT of NULL string": EXIT FUNCTION - n1 = COS(VAL(num(2))) - IF n1 = 0 THEN EvaluateNumbers$ = "ERROR - TAN value is 0, thus COT is 1/0 which is Invalid": EXIT FUNCTION - n1 = 1 / n1 - CASE "BTA" - IF num(2) = "" OR num(1) = "" THEN EvaluateNumbers$ = "ERROR - BTA": EXIT FUNCTION - EvaluateNumbers$ = BTen$(num(1), "+", num(2)): EXIT FUNCTION - CASE "BTS" - IF num(2) = "" OR num(1) = "" THEN EvaluateNumbers$ = "ERROR - BTS": EXIT FUNCTION - EvaluateNumbers$ = BTen$(num(1), "-", num(2)): EXIT FUNCTION - CASE "BTM" - IF num(2) = "" OR num(1) = "" THEN EvaluateNumbers$ = "ERROR - BTM": EXIT FUNCTION - EvaluateNumbers$ = BTen$(num(1), "*", num(2)): EXIT FUNCTION - CASE "^" - IF num(1) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to raise NULL string to exponent": EXIT FUNCTION - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to raise number to NULL exponent": EXIT FUNCTION - n1 = VAL(num(1)) ^ VAL(num(2)) - CASE "SQR" - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get SQR of NULL string": EXIT FUNCTION - IF VAL(num(2)) < 0 THEN EvaluateNumbers$ = "ERROR - Cannot take take SQR of numbers < 0. I'm a computer, I have a poor imagination.": EXIT FUNCTION - n1 = SQR(VAL(num(2))) - CASE "ROOT" - IF num(1) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ROOT of a NULL string": EXIT FUNCTION - IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get NULL ROOT of a string": EXIT FUNCTION - n1 = VAL(num(1)): n2 = VAL(num(2)) - IF n2 = 1 THEN EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1))): EXIT FUNCTION - IF n2 = 0 THEN EvaluateNumbers$ = "ERROR - There is no such thing as a 0 ROOT of a number": EXIT FUNCTION - IF n1 < 0 AND n2 MOD 2 = 0 AND n2 > 1 THEN EvaluateNumbers$ = "ERROR - Cannot take take an EVEN ROOT of numbers < 0. I'm a computer, I have a poor imagination.": 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) - n1 = sign * (n1 ^ n3) - CASE "*" - IF num(1) = "" OR num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to multiply NULL string ": EXIT FUNCTION - n1 = VAL(num(1)) * VAL(num(2)) - CASE "/": - IF num(1) = "" OR num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to divide NULL string ": EXIT FUNCTION - IF VAL(num(2)) = 0 THEN EvaluateNumbers$ = "ERROR - Division by 0": EXIT FUNCTION - n1 = VAL(num(1)) / VAL(num(2)) - CASE "\" - IF num(1) = "" OR num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to divide NULL string ": EXIT FUNCTION - IF VAL(num(2)) = 0 THEN EvaluateNumbers$ = "ERROR - Division by 0": EXIT FUNCTION - n1 = VAL(num(1)) \ VAL(num(2)) - CASE "MOD" - IF num(1) = "" OR num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to MOD with NULL string ": EXIT FUNCTION - IF VAL(num(2)) = 0 THEN EvaluateNumbers$ = "ERROR - Division by 0": EXIT FUNCTION - n1 = VAL(num(1)) MOD 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)) - 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 "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)) - CASE ELSE - EvaluateNumbers$ = "ERROR - Bad operation (We shouldn't see this)" 'Let's say we're bad... -END SELECT -EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1))) + DIM n1 AS _FLOAT, n2 AS _FLOAT, n3 AS _FLOAT + SELECT CASE OName(p) 'Depending on our operator.. + CASE "PI" + n1 = 3.14159265358979323846264338327950288## 'Future compatable in case something ever stores extra digits for PI + CASE "%" 'Note percent is a special case and works with the number BEFORE the % command and not after + IF num(1) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get percent of NULL string": EXIT FUNCTION + n1 = (VAL(num(1))) / 100 + CASE "ARCCOS" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCCOS of NULL string": EXIT FUNCTION + n1 = VAL(num(2)) + IF n1 > 1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCCOS from value >1, which is Invalid": EXIT FUNCTION + IF n1 < -1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCCOS from value <-1, which is Invalid": EXIT FUNCTION + IF n1 = 1 THEN EvaluateNumbers$ = "0": EXIT FUNCTION + n1 = (2 * ATN(1)) - ATN(n1 / SQR(1 - n1 * n1)) + CASE "ARCSIN" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCSIN of NULL string": EXIT FUNCTION + n1 = VAL(num(2)) + IF n1 > 1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCSIN from value >1, which is Invalid": EXIT FUNCTION + IF n1 < -1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCSIN from value <-1, which is Invalid": EXIT FUNCTION + n1 = ATN(n1 / SQR(1 - (n1 * n1))) + CASE "ARCSEC" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCSEC of NULL string": EXIT FUNCTION + n1 = VAL(num(2)) + IF n1 > 1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCSEC from value > 1, which is Invalid": EXIT FUNCTION + IF n1 < -1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCSEC from value < -1, which is Invalid": EXIT FUNCTION + n1 = ATN(n1 / SQR(1 - n1 * n1)) + (SGN(n1) - 1) * (2 * ATN(1)) + CASE "ARCCSC" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCCSC of NULL string": EXIT FUNCTION + n1 = VAL(num(2)) + IF n1 > 1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCCSC from value >=1, which is Invalid": EXIT FUNCTION + IF n1 < -1 THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCCSC from value <-1, which is Invalid": EXIT FUNCTION + n1 = ATN(1 / SQR(1 - n1 * n1)) + (SGN(n1) - 1) * (2 * ATN(1)) + CASE "ARCCOT" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ARCCOT of NULL string": EXIT FUNCTION + n1 = VAL(num(2)) + n1 = (2 * ATN(1)) - ATN(n1) + CASE "SECH" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get SECH of NULL string": EXIT FUNCTION + n1 = VAL(num(2)) + IF n1 > 88.02969 OR (EXP(n1) + EXP(-n1)) = 0 THEN EvaluateNumbers$ = "ERROR - Bad SECH command": EXIT FUNCTION + n1 = 2 / (EXP(n1) + EXP(-n1)) + CASE "CSCH" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get CSCH of NULL string": EXIT FUNCTION + n1 = VAL(num(2)) + IF n1 > 88.02969 OR (EXP(n1) - EXP(-n1)) = 0 THEN EvaluateNumbers$ = "ERROR - Bad CSCH command": EXIT FUNCTION + n1 = 2 / (EXP(n1) - EXP(-n1)) + CASE "COTH" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get COTH of NULL string": EXIT FUNCTION + n1 = VAL(num(2)) + IF 2 * n1 > 88.02969 OR EXP(2 * n1) - 1 = 0 THEN EvaluateNumbers$ = "ERROR - Bad COTH command": EXIT FUNCTION + n1 = (EXP(2 * n1) + 1) / (EXP(2 * n1) - 1) + CASE "COS" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get COS of NULL string": EXIT FUNCTION + n1 = COS(VAL(num(2))) + CASE "SIN" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get SIN of NULL string": EXIT FUNCTION + n1 = SIN(VAL(num(2))) + CASE "TAN" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get TAN of NULL string": EXIT FUNCTION + n1 = TAN(VAL(num(2))) + CASE "LOG" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get LOG of NULL string": EXIT FUNCTION + n1 = LOG(VAL(num(2))) + CASE "EXP" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get EXP of NULL string": EXIT FUNCTION + n1 = EXP(VAL(num(2))) + CASE "ATN" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ATN of NULL string": EXIT FUNCTION + n1 = ATN(VAL(num(2))) + CASE "D2R" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get Radian of NULL Degree value": EXIT FUNCTION + n1 = 0.0174532925 * (VAL(num(2))) + CASE "D2G" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get Grad of NULL Degree string": EXIT FUNCTION + n1 = 1.1111111111 * (VAL(num(2))) + CASE "R2D" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get Degree of NULL Radian string": EXIT FUNCTION + n1 = 57.2957795 * (VAL(num(2))) + CASE "R2G" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get Grad of NULL Radian string": EXIT FUNCTION + n1 = 0.015707963 * (VAL(num(2))) + CASE "G2D" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get Degree of NULL Gradian string": EXIT FUNCTION + n1 = 0.9 * (VAL(num(2))) + CASE "G2R" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get Radian of NULL Grad string": EXIT FUNCTION + n1 = 63.661977237 * (VAL(num(2))) + CASE "ABS" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ABS of NULL string": EXIT FUNCTION + n1 = ABS(VAL(num(2))) + CASE "SGN" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get SGN of NULL string": EXIT FUNCTION + n1 = SGN(VAL(num(2))) + CASE "INT" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get INT of NULL string": EXIT FUNCTION + n1 = INT(VAL(num(2))) + CASE "_ROUND" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to _ROUND a NULL string": EXIT FUNCTION + n1 = _ROUND(VAL(num(2))) + CASE "FIX" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to FIX a NULL string": EXIT FUNCTION + n1 = FIX(VAL(num(2))) + CASE "SEC" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get SEC of NULL string": EXIT FUNCTION + n1 = COS(VAL(num(2))) + IF n1 = 0 THEN EvaluateNumbers$ = "ERROR - COS value is 0, thus SEC is 1/0 which is Invalid": EXIT FUNCTION + n1 = 1 / n1 + CASE "CSC" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get CSC of NULL string": EXIT FUNCTION + n1 = SIN(VAL(num(2))) + IF n1 = 0 THEN EvaluateNumbers$ = "ERROR - SIN value is 0, thus CSC is 1/0 which is Invalid": EXIT FUNCTION + n1 = 1 / n1 + CASE "COT" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get COT of NULL string": EXIT FUNCTION + n1 = COS(VAL(num(2))) + IF n1 = 0 THEN EvaluateNumbers$ = "ERROR - TAN value is 0, thus COT is 1/0 which is Invalid": EXIT FUNCTION + n1 = 1 / n1 + CASE "BTA" + IF num(2) = "" OR num(1) = "" THEN EvaluateNumbers$ = "ERROR - BTA": EXIT FUNCTION + EvaluateNumbers$ = BTen$(num(1), "+", num(2)): EXIT FUNCTION + CASE "BTS" + IF num(2) = "" OR num(1) = "" THEN EvaluateNumbers$ = "ERROR - BTS": EXIT FUNCTION + EvaluateNumbers$ = BTen$(num(1), "-", num(2)): EXIT FUNCTION + CASE "BTM" + IF num(2) = "" OR num(1) = "" THEN EvaluateNumbers$ = "ERROR - BTM": EXIT FUNCTION + EvaluateNumbers$ = BTen$(num(1), "*", num(2)): EXIT FUNCTION + CASE "^" + IF num(1) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to raise NULL string to exponent": EXIT FUNCTION + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to raise number to NULL exponent": EXIT FUNCTION + n1 = VAL(num(1)) ^ VAL(num(2)) + CASE "SQR" + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get SQR of NULL string": EXIT FUNCTION + IF VAL(num(2)) < 0 THEN EvaluateNumbers$ = "ERROR - Cannot take take SQR of numbers < 0. I'm a computer, I have a poor imagination.": EXIT FUNCTION + n1 = SQR(VAL(num(2))) + CASE "ROOT" + IF num(1) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get ROOT of a NULL string": EXIT FUNCTION + IF num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to get NULL ROOT of a string": EXIT FUNCTION + n1 = VAL(num(1)): n2 = VAL(num(2)) + IF n2 = 1 THEN EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1))): EXIT FUNCTION + IF n2 = 0 THEN EvaluateNumbers$ = "ERROR - There is no such thing as a 0 ROOT of a number": EXIT FUNCTION + IF n1 < 0 AND n2 MOD 2 = 0 AND n2 > 1 THEN EvaluateNumbers$ = "ERROR - Cannot take take an EVEN ROOT of numbers < 0. I'm a computer, I have a poor imagination.": 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) + n1 = sign * (n1 ^ n3) + CASE "*" + IF num(1) = "" OR num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to multiply NULL string ": EXIT FUNCTION + n1 = VAL(num(1)) * VAL(num(2)) + CASE "/": + IF num(1) = "" OR num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to divide NULL string ": EXIT FUNCTION + IF VAL(num(2)) = 0 THEN EvaluateNumbers$ = "ERROR - Division by 0": EXIT FUNCTION + n1 = VAL(num(1)) / VAL(num(2)) + CASE "\" + IF num(1) = "" OR num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to divide NULL string ": EXIT FUNCTION + IF VAL(num(2)) = 0 THEN EvaluateNumbers$ = "ERROR - Division by 0": EXIT FUNCTION + n1 = VAL(num(1)) \ VAL(num(2)) + CASE "MOD" + IF num(1) = "" OR num(2) = "" THEN EvaluateNumbers$ = "ERROR - Attemping to MOD with NULL string ": EXIT FUNCTION + IF VAL(num(2)) = 0 THEN EvaluateNumbers$ = "ERROR - Division by 0": EXIT FUNCTION + n1 = VAL(num(1)) MOD 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)) + 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 "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)) + CASE ELSE + EvaluateNumbers$ = "ERROR - Bad operation (We shouldn't see this)" 'Let's say we're bad... + END SELECT + EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1))) END FUNCTION 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 - bad = 0 + 'To deal with duplicate operators in our code. + 'Such as -- becomes a + + '++ becomes a + + '+- becomes a - + '-+ becomes a - + t$ = exp$ 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$ -VerifyString t$ + 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 + DWD$ = t$ + VerifyString t$ END FUNCTION SUB PreParse (e$) -DIM f AS _FLOAT + DIM f AS _FLOAT -t$ = e$ + 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 + 'First strip all spaces + t$ = "" + 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 -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 + 'ERROR CHECK by counting our brackets + 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 -'Modify so that NOT will process properly -l = 0 -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) - l = l + 3 - 'PRINT t$ - END IF -LOOP UNTIL l = 0 + 'Modify so that NOT will process properly + l = 0 + 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) + l = l + 3 + 'PRINT t$ + END IF + LOOP UNTIL l = 0 -'Check for bad operators before a ( bracket -l = 0 -DO - l = INSTR(l + 1, t$, "(") - IF l AND l > 2 THEN 'Don't check the starting bracket; there's nothing before it. - good = 0 - FOR i = 1 TO UBOUND(OName) - IF MID$(t$, l - LEN(OName(i)), 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 operations before (.": EXIT SUB - l = l + 1 - END IF -LOOP UNTIL l = 0 + 'Check for bad operators before a ( bracket + l = 0 + DO + l = INSTR(l + 1, t$, "(") + IF l AND l > 2 THEN 'Don't check the starting bracket; there's nothing before it. + good = 0 + FOR i = 1 TO UBOUND(OName) + IF MID$(t$, l - LEN(OName(i)), 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 operations before (.": EXIT SUB + l = l + 1 + END IF + LOOP UNTIL l = 0 -'Check for bad operators after a ) bracket -l = 0 -DO - l = INSTR(l + 1, t$, ")") - IF l AND l < LEN(t$) THEN - good = 0 - FOR i = 1 TO UBOUND(OName) - IF MID$(t$, l + 1, 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 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 + 'Check for bad operators after a ) bracket + l = 0 + DO + l = INSTR(l + 1, t$, ")") + IF l AND l < LEN(t$) THEN + good = 0 + FOR i = 1 TO UBOUND(OName) + IF MID$(t$, l + 1, 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 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 -'Turn all &H (hex) numbers into decimal values for the program to process properly -l = 0 -DO - l = INSTR(t$, "&H") - IF l THEN - E = l + 1: finished = 0 - 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 - 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 - 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 + 'Turn all &H (hex) numbers into decimal values for the program to process properly + l = 0 + DO + l = INSTR(t$, "&H") + IF l THEN + E = l + 1: finished = 0 + 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 + 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 + 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 -'Turn all &B (binary) numbers into decimal values for the program to process properly -l = 0 -DO - l = INSTR(t$, "&B") - IF l THEN - E = l + 1: finished = 0 - 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 - 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 - 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 + 'Turn all &B (binary) numbers into decimal values for the program to process properly + l = 0 + DO + l = INSTR(t$, "&B") + IF l THEN + E = l + 1: finished = 0 + 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 + 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 + 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 -t$ = N2S(t$) -VerifyString t$ + t$ = N2S(t$) + VerifyString t$ -e$ = t$ + e$ = t$ END SUB 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 - good = 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) - NEXT - IF NOT good THEN t$ = "ERROR - Bad Operational value. (" + comp$ + ")": EXIT SUB - j = j + LEN(OName(i)) - END SELECT -LOOP UNTIL j > LEN(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 + good = 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) + NEXT + IF NOT good THEN t$ = "ERROR - Bad Operational value. (" + comp$ + ")": EXIT SUB + j = j + LEN(OName(i)) + END SELECT + LOOP UNTIL j > LEN(t$) END SUB FUNCTION BTen$ (InTop AS STRING, Op AS STRING, InBot AS STRING) -REM $DYNAMIC + REM $DYNAMIC -InTop = LTRIM$(RTRIM$(InTop)) -InBot = LTRIM$(RTRIM$(InBot)) + InTop = LTRIM$(RTRIM$(InTop)) + InBot = LTRIM$(RTRIM$(InBot)) -l = INSTR(InTop, "-") -IF l = 0 THEN l = INSTR(InTop, "+") -IF l = 0 THEN InTop = "+" + InTop -l = INSTR(InBot, "-") -IF l = 0 THEN l = INSTR(InBot, "+") -IF l = 0 THEN InBot = "+" + InBot + l = INSTR(InTop, "-") + IF l = 0 THEN l = INSTR(InTop, "+") + IF l = 0 THEN InTop = "+" + InTop + l = INSTR(InBot, "-") + IF l = 0 THEN l = INSTR(InBot, "+") + IF l = 0 THEN InBot = "+" + InBot -l = INSTR(InTop, ".") -IF l = 0 THEN InTop = InTop + "." -l = INSTR(InBot, ".") -IF l = 0 THEN InBot = InBot + "." + l = INSTR(InTop, ".") + IF l = 0 THEN InTop = InTop + "." + l = INSTR(InBot, ".") + IF l = 0 THEN InBot = InBot + "." -IF Op$ = "-" THEN - Op$ = "+" - IF MID$(InBot, 1, 1) = "-" THEN MID$(InBot, 1, 1) = "+" ELSE MID$(InBot, 1, 1) = "-" -END IF + IF Op$ = "-" THEN + Op$ = "+" + IF MID$(InBot, 1, 1) = "-" THEN MID$(InBot, 1, 1) = "+" ELSE MID$(InBot, 1, 1) = "-" + END IF -TDP& = Check&(10, InTop$) -BDP& = Check&(10, InBot$) + TDP& = Check&(10, InTop$) + BDP& = Check&(10, InBot$) -IF TDP& < 0 OR BDP& < 0 THEN EXIT FUNCTION + IF TDP& < 0 OR BDP& < 0 THEN EXIT FUNCTION -TSign% = Check&(11, InTop$) -BSign% = Check&(11, InBot$) + TSign% = Check&(11, InTop$) + BSign% = Check&(11, InBot$) -' Calculate Array Size - -IF Op$ = CHR$(43) OR Op$ = CHR$(45) THEN - ' "+" (Add) OR "-" (Subtract) - Temp& = 9 -ELSEIF Op$ = CHR$(42) OR Op$ = CHR$(50) THEN - ' "*" (Multiply) OR "2" (SQRT Multiply) - Temp& = 7 -ELSE - EXIT FUNCTION -END IF - -' LSA (Left Side of Array) -LSA& = TDP& - 2 -TLS& = LSA& \ Temp& -IF LSA& MOD Temp& > 0 THEN - TLS& = TLS& + 1 - DO WHILE (TLPad& + LSA&) MOD Temp& > 0 - TLPad& = TLPad& + 1 - LOOP -END IF -LSA& = BDP& - 2 -BLS& = LSA& \ Temp& -IF LSA& MOD Temp& > 0 THEN - BLS& = BLS& + 1 - DO WHILE (BLPad& + LSA&) MOD Temp& > 0 - BLPad& = BLPad& + 1 - LOOP -END IF -IF TLS& >= BLS& THEN LSA& = TLS& ELSE LSA& = BLS& - -' RSA (Right Side of Array) -RSA& = LEN(InTop$) - TDP& -TRS& = RSA& \ Temp& -IF RSA& MOD Temp& > 0 THEN - TRS& = TRS& + 1 - DO WHILE (TRPad& + RSA&) MOD Temp& > 0 - TRPad& = TRPad& + 1 - LOOP -END IF -RSA& = LEN(InBot$) - BDP& -BRS& = RSA& \ Temp& -IF RSA& MOD Temp& > 0 THEN - BRS& = BRS& + 1 - DO WHILE (BRPad& + RSA&) MOD Temp& > 0 - BRPad& = BRPad& + 1 - LOOP -END IF -IF TRS& >= BRS& THEN RSA& = TRS& ELSE RSA& = BRS& - - - -IF Op$ = CHR$(43) OR Op$ = CHR$(45) THEN - ' "+" (Add) OR "-" (Subtract) - - DIM Result(1 TO (LSA& + RSA&)) AS LONG - - IF (Op$ = CHR$(43) AND TSign% = BSign%) OR (Op$ = CHR$(45) AND TSign% <> BSign%) THEN - ' Add Absolute Values and Return Top Sign - - ' Left Side - FOR I& = 1 TO LSA& - ' Top - IF I& <= (LSA& - TLS&) THEN - ''' Result(I&) = Result(I&) + 0 - ELSEIF I& = (1 + LSA& - TLS&) THEN - Result(I&) = VAL(MID$(InTop$, 2, (9 - TLPad&))) - TDP& = 11 - TLPad& - ELSE - Result(I&) = VAL(MID$(InTop$, TDP&, 9)) - TDP& = TDP& + 9 - END IF - ' Bottom - IF I& <= (LSA& - BLS&) THEN - ''' Result(I&) = Result(I&) + 0 - ELSEIF I& = (1 + LSA& - BLS&) THEN - Result(I&) = Result(I&) + VAL(MID$(InBot$, 2, (9 - BLPad&))) - BDP& = 11 - BLPad& - ELSE - Result(I&) = Result(I&) + VAL(MID$(InBot$, BDP&, 9)) - BDP& = BDP& + 9 - END IF - NEXT I& - - ' Right Side - TDP& = TDP& + 1: BDP& = BDP& + 1 - FOR I& = (LSA& + 1) TO (LSA& + RSA&) - ' Top - IF I& > (LSA& + TRS&) THEN - ''' Result(I&) = Result(I&) + 0 - ELSEIF I& = (LSA& + TRS&) THEN - Result(I&) = (10 ^ TRPad&) * VAL(RIGHT$(InTop$, (9 - TRPad&))) - ELSE - Result(I&) = VAL(MID$(InTop$, TDP&, 9)) - TDP& = TDP& + 9 - END IF - ' Bottom - IF I& > (LSA& + BRS&) THEN - ''' Result(I&) = Result(I&) + 0 - ELSEIF I& = (LSA& + BRS&) THEN - Result(I&) = Result(I&) + (10 ^ BRPad&) * VAL(RIGHT$(InBot$, (9 - BRPad&))) - ELSE - Result(I&) = Result(I&) + VAL(MID$(InBot$, BDP&, 9)) - BDP& = BDP& + 9 - END IF - NEXT I& - - ' Carry - FOR I& = (LSA& + RSA&) TO 2 STEP -1 - IF Result(I&) >= 1000000000 THEN - Result(I& - 1) = Result(I& - 1) + 1 - Result(I&) = Result(I&) - 1000000000 - END IF - NEXT I& - - ' Return Sign - IF TSign% = 1 THEN RetStr$ = CHR$(43) ELSE RetStr$ = CHR$(45) + ' Calculate Array Size + IF Op$ = CHR$(43) OR Op$ = CHR$(45) THEN + ' "+" (Add) OR "-" (Subtract) + Temp& = 9 + ELSEIF Op$ = CHR$(42) OR Op$ = CHR$(50) THEN + ' "*" (Multiply) OR "2" (SQRT Multiply) + Temp& = 7 ELSE - ' Compare Absolute Values + EXIT FUNCTION + END IF - IF TDP& > BDP& THEN - Compare& = 1 - ELSEIF TDP& < BDP& THEN - Compare& = -1 - ELSE - IF LEN(InTop$) > LEN(InBot$) THEN Compare& = LEN(InBot$) ELSE Compare& = LEN(InTop$) - FOR I& = 2 TO Compare& - IF VAL(MID$(InTop$, I&, 1)) > VAL(MID$(InBot$, I&, 1)) THEN - Compare& = 1 - EXIT FOR - ELSEIF VAL(MID$(InTop$, I&, 1)) < VAL(MID$(InBot$, I&, 1)) THEN - Compare& = -1 - EXIT FOR - END IF - NEXT I& - IF Compare& > 1 THEN - IF LEN(InTop$) > LEN(InBot$) THEN - Compare& = 1 - ELSEIF LEN(InTop$) < LEN(InBot$) THEN - Compare& = -1 + ' LSA (Left Side of Array) + LSA& = TDP& - 2 + TLS& = LSA& \ Temp& + IF LSA& MOD Temp& > 0 THEN + TLS& = TLS& + 1 + DO WHILE (TLPad& + LSA&) MOD Temp& > 0 + TLPad& = TLPad& + 1 + LOOP + END IF + LSA& = BDP& - 2 + BLS& = LSA& \ Temp& + IF LSA& MOD Temp& > 0 THEN + BLS& = BLS& + 1 + DO WHILE (BLPad& + LSA&) MOD Temp& > 0 + BLPad& = BLPad& + 1 + LOOP + END IF + IF TLS& >= BLS& THEN LSA& = TLS& ELSE LSA& = BLS& + + ' RSA (Right Side of Array) + RSA& = LEN(InTop$) - TDP& + TRS& = RSA& \ Temp& + IF RSA& MOD Temp& > 0 THEN + TRS& = TRS& + 1 + DO WHILE (TRPad& + RSA&) MOD Temp& > 0 + TRPad& = TRPad& + 1 + LOOP + END IF + RSA& = LEN(InBot$) - BDP& + BRS& = RSA& \ Temp& + IF RSA& MOD Temp& > 0 THEN + BRS& = BRS& + 1 + DO WHILE (BRPad& + RSA&) MOD Temp& > 0 + BRPad& = BRPad& + 1 + LOOP + END IF + IF TRS& >= BRS& THEN RSA& = TRS& ELSE RSA& = BRS& + + + + IF Op$ = CHR$(43) OR Op$ = CHR$(45) THEN + ' "+" (Add) OR "-" (Subtract) + + DIM Result(1 TO (LSA& + RSA&)) AS LONG + + IF (Op$ = CHR$(43) AND TSign% = BSign%) OR (Op$ = CHR$(45) AND TSign% <> BSign%) THEN + ' Add Absolute Values and Return Top Sign + + ' Left Side + FOR I& = 1 TO LSA& + ' Top + IF I& <= (LSA& - TLS&) THEN + ''' Result(I&) = Result(I&) + 0 + ELSEIF I& = (1 + LSA& - TLS&) THEN + Result(I&) = VAL(MID$(InTop$, 2, (9 - TLPad&))) + TDP& = 11 - TLPad& ELSE - Compare& = 0 + Result(I&) = VAL(MID$(InTop$, TDP&, 9)) + TDP& = TDP& + 9 END IF - END IF - END IF - - ' Conditional Subtraction - - IF Compare& = 1 THEN - ' Subtract Bottom from Top and Return Top Sign - - ' Top - Result(1) = VAL(MID$(InTop$, 2, (9 - TLPad&))) - TDP& = 11 - TLPad& - FOR I& = 2 TO LSA& - Result(I&) = VAL(MID$(InTop$, TDP&, 9)) - TDP& = TDP& + 9 - NEXT I& - TDP& = TDP& + 1 - FOR I& = (LSA& + 1) TO (LSA& + TRS& - 1) - Result(I&) = VAL(MID$(InTop$, TDP&, 9)) - TDP& = TDP& + 9 - NEXT I& - Result(LSA& + TRS&) = 10& ^ TRPad& * VAL(RIGHT$(InTop$, (9 - TRPad&))) - - ' Bottom - BDP& = (LEN(InBot$) - 17) + BRPad& - FOR I& = (LSA& + BRS&) TO (1 + LSA& - BLS&) STEP -1 - IF I& = LSA& THEN BDP& = BDP& - 1 - IF I& = (LSA& + BRS&) THEN - Temp& = (10& ^ BRPad&) * VAL(RIGHT$(InBot$, (9 - BRPad&))) + ' Bottom + IF I& <= (LSA& - BLS&) THEN + ''' Result(I&) = Result(I&) + 0 ELSEIF I& = (1 + LSA& - BLS&) THEN - Temp& = VAL(MID$(InBot$, 2, (9 - BLPad&))) + Result(I&) = Result(I&) + VAL(MID$(InBot$, 2, (9 - BLPad&))) + BDP& = 11 - BLPad& ELSE - Temp& = VAL(MID$(InBot$, BDP&, 9)) - BDP& = BDP& - 9 + Result(I&) = Result(I&) + VAL(MID$(InBot$, BDP&, 9)) + BDP& = BDP& + 9 END IF - IF Result(I&) < Temp& THEN - ' Borrow - FOR J& = (I& - 1) TO 1 STEP -1 - IF Result(J&) = 0 THEN - Result(J&) = 999999999 - ELSE - Result(J&) = Result(J&) - 1 - EXIT FOR - END IF - NEXT J& - Result(I&) = Result(I&) + 1000000000 + NEXT I& + + ' Right Side + TDP& = TDP& + 1: BDP& = BDP& + 1 + FOR I& = (LSA& + 1) TO (LSA& + RSA&) + ' Top + IF I& > (LSA& + TRS&) THEN + ''' Result(I&) = Result(I&) + 0 + ELSEIF I& = (LSA& + TRS&) THEN + Result(I&) = (10 ^ TRPad&) * VAL(RIGHT$(InTop$, (9 - TRPad&))) + ELSE + Result(I&) = VAL(MID$(InTop$, TDP&, 9)) + TDP& = TDP& + 9 + END IF + ' Bottom + IF I& > (LSA& + BRS&) THEN + ''' Result(I&) = Result(I&) + 0 + ELSEIF I& = (LSA& + BRS&) THEN + Result(I&) = Result(I&) + (10 ^ BRPad&) * VAL(RIGHT$(InBot$, (9 - BRPad&))) + ELSE + Result(I&) = Result(I&) + VAL(MID$(InBot$, BDP&, 9)) + BDP& = BDP& + 9 + END IF + NEXT I& + + ' Carry + FOR I& = (LSA& + RSA&) TO 2 STEP -1 + IF Result(I&) >= 1000000000 THEN + Result(I& - 1) = Result(I& - 1) + 1 + Result(I&) = Result(I&) - 1000000000 END IF - Result(I&) = Result(I&) - Temp& NEXT I& ' Return Sign IF TSign% = 1 THEN RetStr$ = CHR$(43) ELSE RetStr$ = CHR$(45) - ELSEIF Compare& = -1 THEN - ' Subtract Top from Bottom and Return Bottom Sign - - ' Bottom - Result(1) = VAL(MID$(InBot$, 2, (9 - BLPad&))) - BDP& = 11 - BLPad& - FOR I& = 2 TO LSA& - Result(I&) = VAL(MID$(InBot$, BDP&, 9)) - BDP& = BDP& + 9 - NEXT I& - BDP& = BDP& + 1 - FOR I& = (LSA& + 1) TO (LSA& + BRS& - 1) - Result(I&) = VAL(MID$(InBot$, BDP&, 9)) - BDP& = BDP& + 9 - NEXT I& - Result(LSA& + BRS&) = 10& ^ BRPad& * VAL(RIGHT$(InBot$, (9 - BRPad&))) - - ' Top - TDP& = (LEN(InTop$) - 17) + TRPad& - FOR I& = (LSA& + TRS&) TO (1 + LSA& - TLS&) STEP -1 - IF I& = LSA& THEN TDP& = TDP& - 1 - IF I& = (LSA& + TRS&) THEN - Temp& = (10& ^ TRPad&) * VAL(RIGHT$(InTop$, (9 - TRPad&))) - ELSEIF I& = (1 + LSA& - TLS&) THEN - Temp& = VAL(MID$(InTop$, 2, (9 - TLPad&))) - ELSE - Temp& = VAL(MID$(InTop$, TDP&, 9)) - TDP& = TDP& - 9 - END IF - IF Result(I&) < Temp& THEN - ' Borrow - FOR J& = (I& - 1) TO 1 STEP -1 - IF Result(J&) = 0 THEN - Result(J&) = 999999999 - ELSE - Result(J&) = Result(J&) - 1 - EXIT FOR - END IF - NEXT J& - Result(I&) = Result(I&) + 1000000000 - END IF - Result(I&) = Result(I&) - Temp& - NEXT I& - - ' Build Return Sign - IF BSign% = 1 THEN RetStr$ = CHR$(43) ELSE RetStr$ = CHR$(45) - ELSE - ' Result will always be 0 + ' Compare Absolute Values - LSA& = 1: RSA& = 1 - RetStr$ = CHR$(43) + IF TDP& > BDP& THEN + Compare& = 1 + ELSEIF TDP& < BDP& THEN + Compare& = -1 + ELSE + IF LEN(InTop$) > LEN(InBot$) THEN Compare& = LEN(InBot$) ELSE Compare& = LEN(InTop$) + FOR I& = 2 TO Compare& + IF VAL(MID$(InTop$, I&, 1)) > VAL(MID$(InBot$, I&, 1)) THEN + Compare& = 1 + EXIT FOR + ELSEIF VAL(MID$(InTop$, I&, 1)) < VAL(MID$(InBot$, I&, 1)) THEN + Compare& = -1 + EXIT FOR + END IF + NEXT I& + IF Compare& > 1 THEN + IF LEN(InTop$) > LEN(InBot$) THEN + Compare& = 1 + ELSEIF LEN(InTop$) < LEN(InBot$) THEN + Compare& = -1 + ELSE + Compare& = 0 + END IF + END IF + END IF + ' Conditional Subtraction + + IF Compare& = 1 THEN + ' Subtract Bottom from Top and Return Top Sign + + ' Top + Result(1) = VAL(MID$(InTop$, 2, (9 - TLPad&))) + TDP& = 11 - TLPad& + FOR I& = 2 TO LSA& + Result(I&) = VAL(MID$(InTop$, TDP&, 9)) + TDP& = TDP& + 9 + NEXT I& + TDP& = TDP& + 1 + FOR I& = (LSA& + 1) TO (LSA& + TRS& - 1) + Result(I&) = VAL(MID$(InTop$, TDP&, 9)) + TDP& = TDP& + 9 + NEXT I& + Result(LSA& + TRS&) = 10& ^ TRPad& * VAL(RIGHT$(InTop$, (9 - TRPad&))) + + ' Bottom + BDP& = (LEN(InBot$) - 17) + BRPad& + FOR I& = (LSA& + BRS&) TO (1 + LSA& - BLS&) STEP -1 + IF I& = LSA& THEN BDP& = BDP& - 1 + IF I& = (LSA& + BRS&) THEN + Temp& = (10& ^ BRPad&) * VAL(RIGHT$(InBot$, (9 - BRPad&))) + ELSEIF I& = (1 + LSA& - BLS&) THEN + Temp& = VAL(MID$(InBot$, 2, (9 - BLPad&))) + ELSE + Temp& = VAL(MID$(InBot$, BDP&, 9)) + BDP& = BDP& - 9 + END IF + IF Result(I&) < Temp& THEN + ' Borrow + FOR J& = (I& - 1) TO 1 STEP -1 + IF Result(J&) = 0 THEN + Result(J&) = 999999999 + ELSE + Result(J&) = Result(J&) - 1 + EXIT FOR + END IF + NEXT J& + Result(I&) = Result(I&) + 1000000000 + END IF + Result(I&) = Result(I&) - Temp& + NEXT I& + + ' Return Sign + IF TSign% = 1 THEN RetStr$ = CHR$(43) ELSE RetStr$ = CHR$(45) + + ELSEIF Compare& = -1 THEN + ' Subtract Top from Bottom and Return Bottom Sign + + ' Bottom + Result(1) = VAL(MID$(InBot$, 2, (9 - BLPad&))) + BDP& = 11 - BLPad& + FOR I& = 2 TO LSA& + Result(I&) = VAL(MID$(InBot$, BDP&, 9)) + BDP& = BDP& + 9 + NEXT I& + BDP& = BDP& + 1 + FOR I& = (LSA& + 1) TO (LSA& + BRS& - 1) + Result(I&) = VAL(MID$(InBot$, BDP&, 9)) + BDP& = BDP& + 9 + NEXT I& + Result(LSA& + BRS&) = 10& ^ BRPad& * VAL(RIGHT$(InBot$, (9 - BRPad&))) + + ' Top + TDP& = (LEN(InTop$) - 17) + TRPad& + FOR I& = (LSA& + TRS&) TO (1 + LSA& - TLS&) STEP -1 + IF I& = LSA& THEN TDP& = TDP& - 1 + IF I& = (LSA& + TRS&) THEN + Temp& = (10& ^ TRPad&) * VAL(RIGHT$(InTop$, (9 - TRPad&))) + ELSEIF I& = (1 + LSA& - TLS&) THEN + Temp& = VAL(MID$(InTop$, 2, (9 - TLPad&))) + ELSE + Temp& = VAL(MID$(InTop$, TDP&, 9)) + TDP& = TDP& - 9 + END IF + IF Result(I&) < Temp& THEN + ' Borrow + FOR J& = (I& - 1) TO 1 STEP -1 + IF Result(J&) = 0 THEN + Result(J&) = 999999999 + ELSE + Result(J&) = Result(J&) - 1 + EXIT FOR + END IF + NEXT J& + Result(I&) = Result(I&) + 1000000000 + END IF + Result(I&) = Result(I&) - Temp& + NEXT I& + + ' Build Return Sign + IF BSign% = 1 THEN RetStr$ = CHR$(43) ELSE RetStr$ = CHR$(45) + + ELSE + ' Result will always be 0 + + LSA& = 1: RSA& = 1 + RetStr$ = CHR$(43) + + END IF END IF + + ' Generate Return String + RetStr$ = RetStr$ + LTRIM$(STR$(Result(1))) + FOR I& = 2 TO LSA& + RetStr$ = RetStr$ + RIGHT$(STRING$(8, 48) + LTRIM$(STR$(Result(I&))), 9) + NEXT I& + RetStr$ = RetStr$ + CHR$(46) + FOR I& = (LSA& + 1) TO (LSA& + RSA&) + RetStr$ = RetStr$ + RIGHT$(STRING$(8, 48) + LTRIM$(STR$(Result(I&))), 9) + NEXT I& + + ERASE Result + + ELSEIF Op$ = CHR$(42) THEN + ' * (Multiply) + + DIM TArray(1 TO (LSA& + RSA&)) AS LONG + DIM BArray(1 TO (LSA& + RSA&)) AS LONG + DIM ResDBL(0 TO (LSA& + RSA&)) AS DOUBLE + + ' Push String Data Into Array + FOR I& = 1 TO LSA& + IF I& <= (LSA& - TLS&) THEN + ''' TArray(I&) = TArray(I&) + 0 + ELSEIF I& = (1 + LSA& - TLS&) THEN + TArray(I&) = VAL(MID$(InTop$, 2, (7 - TLPad&))) + TDP& = 9 - TLPad& + ELSE + TArray(I&) = VAL(MID$(InTop$, TDP&, 7)) + TDP& = TDP& + 7 + END IF + IF I& <= (LSA& - BLS&) THEN + ''' BArray(I&) = BArray(I&) + 0 + ELSEIF I& = (1 + LSA& - BLS&) THEN + BArray(I&) = VAL(MID$(InBot$, 2, (7 - BLPad&))) + BDP& = 9 - BLPad& + ELSE + BArray(I&) = VAL(MID$(InBot$, BDP&, 7)) + BDP& = BDP& + 7 + END IF + NEXT I& + TDP& = TDP& + 1: BDP& = BDP& + 1 + FOR I& = (LSA& + 1) TO (LSA& + RSA&) + IF I& > (LSA& + TRS&) THEN + ''' TArray(I&) = TArray(I&) + 0 + ELSEIF I& = (LSA& + TRS&) THEN + TArray(I&) = 10 ^ TRPad& * VAL(RIGHT$(InTop$, (7 - TRPad&))) + ELSE + TArray(I&) = VAL(MID$(InTop$, TDP&, 7)) + TDP& = TDP& + 7 + END IF + IF I& > (LSA& + BRS&) THEN + ''' BArray(I&) = BArray(I&) + 0 + ELSEIF I& = (LSA& + BRS&) THEN + BArray(I&) = 10 ^ BRPad& * VAL(RIGHT$(InBot$, (7 - BRPad&))) + ELSE + BArray(I&) = VAL(MID$(InBot$, BDP&, 7)) + BDP& = BDP& + 7 + END IF + NEXT I& + + ' Multiply from Arrays to Array + FOR I& = (LSA& + TRS&) TO (1 + LSA& - TLS&) STEP -1 + FOR J& = (LSA& + BRS&) TO (1 + LSA& - BLS&) STEP -1 + Temp# = 1# * TArray(I&) * BArray(J&) + IF (I& + J&) MOD 2 = 0 THEN + TL& = INT(Temp# / 10000000) + TR& = Temp# - 10000000# * TL& + ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL& + ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + 10000000# * TR& + ELSE + ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + Temp# + END IF + IF ResDBL((I& + J&) \ 2) >= 100000000000000# THEN + Temp# = ResDBL((I& + J&) \ 2) + TL& = INT(Temp# / 100000000000000#) + ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL& + ResDBL((I& + J&) \ 2) = Temp# - 100000000000000# * TL& + END IF + NEXT J& + NEXT I& + + ERASE TArray, BArray + + ' Generate Return String + IF (TSign% * BSign%) = 1 THEN RetStr$ = CHR$(43) ELSE RetStr$ = CHR$(45) + RetStr$ = RetStr$ + LTRIM$(STR$(ResDBL(0))) + FOR I& = 1 TO (LSA&) + RetStr$ = RetStr$ + RIGHT$(STRING$(13, 48) + LTRIM$(STR$(ResDBL(I&))), 14) + NEXT I& + RetStr$ = LEFT$(RetStr$, LEN(RetStr$) - 7) + CHR$(46) + RIGHT$(RetStr$, 7) + FOR I& = (LSA& + 1) TO (LSA& + RSA&) + RetStr$ = RetStr$ + RIGHT$(STRING$(13, 48) + LTRIM$(STR$(ResDBL(I&))), 14) + NEXT I& + + ERASE ResDBL + + ELSEIF Op$ = CHR$(50) THEN + ' 2 (SQRT Multiply) + + DIM IArray(1 TO (LSA& + RSA&)) AS LONG + DIM ResDBL(0 TO (LSA& + RSA&)) AS DOUBLE + + ' Push String Data Into Array + FOR I& = 1 TO LSA& + IF I& <= (LSA& - TLS&) THEN + ''' IArray(I&) = IArray(I&) + 0 + ELSEIF I& = (1 + LSA& - TLS&) THEN + IArray(I&) = VAL(MID$(InTop$, 2, (7 - TLPad&))) + TDP& = 9 - TLPad& + ELSE + IArray(I&) = VAL(MID$(InTop$, TDP&, 7)) + TDP& = TDP& + 7 + END IF + NEXT I& + TDP& = TDP& + 1 + FOR I& = (LSA& + 1) TO (LSA& + RSA&) + IF I& > (LSA& + TRS&) THEN + ''' IArray(I&) = IArray(I&) + 0 + ELSEIF I& = (LSA& + TRS&) THEN + IArray(I&) = 10 ^ TRPad& * VAL(RIGHT$(InTop$, (7 - TRPad&))) + ELSE + IArray(I&) = VAL(MID$(InTop$, TDP&, 7)) + TDP& = TDP& + 7 + END IF + NEXT I& + + ' SQRT Multiply from Array to Array + FOR I& = (LSA& + TRS&) TO 1 STEP -1 + FOR J& = I& TO 1 STEP -1 + Temp# = 1# * IArray(I&) * IArray(J&) + IF I& <> J& THEN Temp# = Temp# * 2 + IF (I& + J&) MOD 2 = 0 THEN + TL& = INT(Temp# / 10000000) + TR& = Temp# - 10000000# * TL& + ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL& + ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + 10000000# * TR& + ELSE + ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + Temp# + END IF + IF ResDBL((I& + J&) \ 2) >= 100000000000000# THEN + Temp# = ResDBL((I& + J&) \ 2) + TL& = INT(Temp# / 100000000000000#) + ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL& + ResDBL((I& + J&) \ 2) = Temp# - 100000000000000# * TL& + END IF + NEXT J& + NEXT I& + + ERASE IArray + + ' Generate Return String + IF (TSign% * BSign%) = 1 THEN RetStr$ = CHR$(43) ELSE RetStr$ = CHR$(45) + RetStr$ = RetStr$ + LTRIM$(STR$(ResDBL(0))) + FOR I& = 1 TO (LSA&) + RetStr$ = RetStr$ + RIGHT$(STRING$(13, 48) + LTRIM$(STR$(ResDBL(I&))), 14) + NEXT I& + RetStr$ = LEFT$(RetStr$, LEN(RetStr$) - 7) + CHR$(46) + RIGHT$(RetStr$, 7) + ' Don't usually want the full right side for this, just enough to check the + ' actual result against the expected result, which is probably an integer. + ' Uncomment the three lines below when trying to find an oddball square root. + 'FOR I& = (LSA& + 1) TO (LSA& + RSA&) + ' RetStr$ = RetStr$ + RIGHT$(STRING$(13, 48) + LTRIM$(STR$(ResDBL(I&))), 14) + 'NEXT I& + + ERASE ResDBL + END IF - ' Generate Return String - RetStr$ = RetStr$ + LTRIM$(STR$(Result(1))) - FOR I& = 2 TO LSA& - RetStr$ = RetStr$ + RIGHT$(STRING$(8, 48) + LTRIM$(STR$(Result(I&))), 9) - NEXT I& - RetStr$ = RetStr$ + CHR$(46) - FOR I& = (LSA& + 1) TO (LSA& + RSA&) - RetStr$ = RetStr$ + RIGHT$(STRING$(8, 48) + LTRIM$(STR$(Result(I&))), 9) - NEXT I& - - ERASE Result - -ELSEIF Op$ = CHR$(42) THEN - ' * (Multiply) - - DIM TArray(1 TO (LSA& + RSA&)) AS LONG - DIM BArray(1 TO (LSA& + RSA&)) AS LONG - DIM ResDBL(0 TO (LSA& + RSA&)) AS DOUBLE - - ' Push String Data Into Array - FOR I& = 1 TO LSA& - IF I& <= (LSA& - TLS&) THEN - ''' TArray(I&) = TArray(I&) + 0 - ELSEIF I& = (1 + LSA& - TLS&) THEN - TArray(I&) = VAL(MID$(InTop$, 2, (7 - TLPad&))) - TDP& = 9 - TLPad& - ELSE - TArray(I&) = VAL(MID$(InTop$, TDP&, 7)) - TDP& = TDP& + 7 - END IF - IF I& <= (LSA& - BLS&) THEN - ''' BArray(I&) = BArray(I&) + 0 - ELSEIF I& = (1 + LSA& - BLS&) THEN - BArray(I&) = VAL(MID$(InBot$, 2, (7 - BLPad&))) - BDP& = 9 - BLPad& - ELSE - BArray(I&) = VAL(MID$(InBot$, BDP&, 7)) - BDP& = BDP& + 7 - END IF - NEXT I& - TDP& = TDP& + 1: BDP& = BDP& + 1 - FOR I& = (LSA& + 1) TO (LSA& + RSA&) - IF I& > (LSA& + TRS&) THEN - ''' TArray(I&) = TArray(I&) + 0 - ELSEIF I& = (LSA& + TRS&) THEN - TArray(I&) = 10 ^ TRPad& * VAL(RIGHT$(InTop$, (7 - TRPad&))) - ELSE - TArray(I&) = VAL(MID$(InTop$, TDP&, 7)) - TDP& = TDP& + 7 - END IF - IF I& > (LSA& + BRS&) THEN - ''' BArray(I&) = BArray(I&) + 0 - ELSEIF I& = (LSA& + BRS&) THEN - BArray(I&) = 10 ^ BRPad& * VAL(RIGHT$(InBot$, (7 - BRPad&))) - ELSE - BArray(I&) = VAL(MID$(InBot$, BDP&, 7)) - BDP& = BDP& + 7 - END IF - NEXT I& - - ' Multiply from Arrays to Array - FOR I& = (LSA& + TRS&) TO (1 + LSA& - TLS&) STEP -1 - FOR J& = (LSA& + BRS&) TO (1 + LSA& - BLS&) STEP -1 - Temp# = 1# * TArray(I&) * BArray(J&) - IF (I& + J&) MOD 2 = 0 THEN - TL& = INT(Temp# / 10000000) - TR& = Temp# - 10000000# * TL& - ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL& - ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + 10000000# * TR& - ELSE - ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + Temp# - END IF - IF ResDBL((I& + J&) \ 2) >= 100000000000000# THEN - Temp# = ResDBL((I& + J&) \ 2) - TL& = INT(Temp# / 100000000000000#) - ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL& - ResDBL((I& + J&) \ 2) = Temp# - 100000000000000# * TL& - END IF - NEXT J& - NEXT I& - - ERASE TArray, BArray - - ' Generate Return String - IF (TSign% * BSign%) = 1 THEN RetStr$ = CHR$(43) ELSE RetStr$ = CHR$(45) - RetStr$ = RetStr$ + LTRIM$(STR$(ResDBL(0))) - FOR I& = 1 TO (LSA&) - RetStr$ = RetStr$ + RIGHT$(STRING$(13, 48) + LTRIM$(STR$(ResDBL(I&))), 14) - NEXT I& - RetStr$ = LEFT$(RetStr$, LEN(RetStr$) - 7) + CHR$(46) + RIGHT$(RetStr$, 7) - FOR I& = (LSA& + 1) TO (LSA& + RSA&) - RetStr$ = RetStr$ + RIGHT$(STRING$(13, 48) + LTRIM$(STR$(ResDBL(I&))), 14) - NEXT I& - - ERASE ResDBL - -ELSEIF Op$ = CHR$(50) THEN - ' 2 (SQRT Multiply) - - DIM IArray(1 TO (LSA& + RSA&)) AS LONG - DIM ResDBL(0 TO (LSA& + RSA&)) AS DOUBLE - - ' Push String Data Into Array - FOR I& = 1 TO LSA& - IF I& <= (LSA& - TLS&) THEN - ''' IArray(I&) = IArray(I&) + 0 - ELSEIF I& = (1 + LSA& - TLS&) THEN - IArray(I&) = VAL(MID$(InTop$, 2, (7 - TLPad&))) - TDP& = 9 - TLPad& - ELSE - IArray(I&) = VAL(MID$(InTop$, TDP&, 7)) - TDP& = TDP& + 7 - END IF - NEXT I& - TDP& = TDP& + 1 - FOR I& = (LSA& + 1) TO (LSA& + RSA&) - IF I& > (LSA& + TRS&) THEN - ''' IArray(I&) = IArray(I&) + 0 - ELSEIF I& = (LSA& + TRS&) THEN - IArray(I&) = 10 ^ TRPad& * VAL(RIGHT$(InTop$, (7 - TRPad&))) - ELSE - IArray(I&) = VAL(MID$(InTop$, TDP&, 7)) - TDP& = TDP& + 7 - END IF - NEXT I& - - ' SQRT Multiply from Array to Array - FOR I& = (LSA& + TRS&) TO 1 STEP -1 - FOR J& = I& TO 1 STEP -1 - Temp# = 1# * IArray(I&) * IArray(J&) - IF I& <> J& THEN Temp# = Temp# * 2 - IF (I& + J&) MOD 2 = 0 THEN - TL& = INT(Temp# / 10000000) - TR& = Temp# - 10000000# * TL& - ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL& - ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + 10000000# * TR& - ELSE - ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + Temp# - END IF - IF ResDBL((I& + J&) \ 2) >= 100000000000000# THEN - Temp# = ResDBL((I& + J&) \ 2) - TL& = INT(Temp# / 100000000000000#) - ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL& - ResDBL((I& + J&) \ 2) = Temp# - 100000000000000# * TL& - END IF - NEXT J& - NEXT I& - - ERASE IArray - - ' Generate Return String - IF (TSign% * BSign%) = 1 THEN RetStr$ = CHR$(43) ELSE RetStr$ = CHR$(45) - RetStr$ = RetStr$ + LTRIM$(STR$(ResDBL(0))) - FOR I& = 1 TO (LSA&) - RetStr$ = RetStr$ + RIGHT$(STRING$(13, 48) + LTRIM$(STR$(ResDBL(I&))), 14) - NEXT I& - RetStr$ = LEFT$(RetStr$, LEN(RetStr$) - 7) + CHR$(46) + RIGHT$(RetStr$, 7) - ' Don't usually want the full right side for this, just enough to check the - ' actual result against the expected result, which is probably an integer. - ' Uncomment the three lines below when trying to find an oddball square root. - 'FOR I& = (LSA& + 1) TO (LSA& + RSA&) - ' RetStr$ = RetStr$ + RIGHT$(STRING$(13, 48) + LTRIM$(STR$(ResDBL(I&))), 14) - 'NEXT I& - - ERASE ResDBL - -END IF - -' Trim Leading and Trailing Zeroes -DO WHILE MID$(RetStr$, 2, 1) = CHR$(48) AND MID$(RetStr$, 3, 1) <> CHR$(46) - RetStr$ = LEFT$(RetStr$, 1) + RIGHT$(RetStr$, LEN(RetStr$) - 2) -LOOP -DO WHILE RIGHT$(RetStr$, 1) = CHR$(48) AND RIGHT$(RetStr$, 2) <> CHR$(46) + CHR$(48) - RetStr$ = LEFT$(RetStr$, LEN(RetStr$) - 1) -LOOP + ' Trim Leading and Trailing Zeroes + DO WHILE MID$(RetStr$, 2, 1) = CHR$(48) AND MID$(RetStr$, 3, 1) <> CHR$(46) + RetStr$ = LEFT$(RetStr$, 1) + RIGHT$(RetStr$, LEN(RetStr$) - 2) + LOOP + DO WHILE RIGHT$(RetStr$, 1) = CHR$(48) AND RIGHT$(RetStr$, 2) <> CHR$(46) + CHR$(48) + RetStr$ = LEFT$(RetStr$, LEN(RetStr$) - 1) + LOOP -IF MID$(RetStr$, 1, 1) = "+" THEN MID$(RetStr$, 1, 1) = " " -DO + IF MID$(RetStr$, 1, 1) = "+" THEN MID$(RetStr$, 1, 1) = " " + DO + r$ = RIGHT$(RetStr$, 1) + IF r$ = "0" THEN RetStr$ = LEFT$(RetStr$, LEN(RetStr$) - 1) + LOOP UNTIL r$ <> "0" + r$ = RIGHT$(RetStr$, 1) - IF r$ = "0" THEN RetStr$ = LEFT$(RetStr$, LEN(RetStr$) - 1) -LOOP UNTIL r$ <> "0" + IF r$ = "." THEN RetStr$ = LEFT$(RetStr$, LEN(RetStr$) - 1) -r$ = RIGHT$(RetStr$, 1) -IF r$ = "." THEN RetStr$ = LEFT$(RetStr$, LEN(RetStr$) - 1) - -BTen$ = RetStr$ + BTen$ = RetStr$ END FUNCTION REM $STATIC ' --------------------------------------------------------------------------- @@ -24468,869 +24468,869 @@ REM $STATIC ' FUNCTION Check& (Op&, InString$) Multi-Purpose String Tester ' --------------------------------------------------------------------------- FUNCTION Check& (Op AS LONG, InString AS STRING) -REM $DYNAMIC + REM $DYNAMIC -RetVal& = LEN(InString$) + RetVal& = LEN(InString$) -SELECT CASE Op& + SELECT CASE Op& - CASE 10 - ' {00A} Test String for Base-10-Format ( *!* ALTERS InString$ *!* ) - ' Returns: - ' {& > 0} = DP offset; {& < 0} = FAILED at negative offset - ' - ' After testing passes, the string is trimmed - ' of nonessential leading and trailing zeroes. + CASE 10 + ' {00A} Test String for Base-10-Format ( *!* ALTERS InString$ *!* ) + ' Returns: + ' {& > 0} = DP offset; {& < 0} = FAILED at negative offset + ' + ' After testing passes, the string is trimmed + ' of nonessential leading and trailing zeroes. - IF RetVal& = 0 THEN - RetVal& = -1 - ELSE - SELECT CASE ASC(LEFT$(InString$, 1)) - CASE 43, 45 ' "+", "-" - FOR I& = 2 TO RetVal& - SELECT CASE ASC(MID$(InString$, I&, 1)) - CASE 46 ' "." - IF DPC% > 0 THEN + IF RetVal& = 0 THEN + RetVal& = -1 + ELSE + SELECT CASE ASC(LEFT$(InString$, 1)) + CASE 43, 45 ' "+", "-" + FOR I& = 2 TO RetVal& + SELECT CASE ASC(MID$(InString$, I&, 1)) + CASE 46 ' "." + IF DPC% > 0 THEN + RetVal& = 0 - I& + EXIT FOR + ELSE + DPC% = DPC% + 1 + RetVal& = I& + END IF + CASE 48 TO 57 + ' keep going + CASE ELSE RetVal& = 0 - I& EXIT FOR - ELSE - DPC% = DPC% + 1 - RetVal& = I& - END IF - CASE 48 TO 57 - ' keep going - CASE ELSE - RetVal& = 0 - I& - EXIT FOR - END SELECT - NEXT I& - CASE ELSE - RetVal& = -1 - END SELECT - IF DPC% = 0 AND RetVal& > 0 THEN - RetVal& = 0 - RetVal& - ELSEIF RetVal& = 2 THEN - InString$ = LEFT$(InString$, 1) + CHR$(48) + RIGHT$(InString$, LEN(InString$) - 1) - RetVal& = RetVal& + 1 + END SELECT + NEXT I& + CASE ELSE + RetVal& = -1 + END SELECT + IF DPC% = 0 AND RetVal& > 0 THEN + RetVal& = 0 - RetVal& + ELSEIF RetVal& = 2 THEN + InString$ = LEFT$(InString$, 1) + CHR$(48) + RIGHT$(InString$, LEN(InString$) - 1) + RetVal& = RetVal& + 1 + END IF + IF RetVal& = LEN(InString$) THEN InString$ = InString$ + CHR$(48) + DO WHILE ASC(RIGHT$(InString$, 1)) = 48 AND RetVal& < (LEN(InString$) - 1) + InString$ = LEFT$(InString$, LEN(InString$) - 1) + LOOP + DO WHILE ASC(MID$(InString$, 2, 1)) = 48 AND RetVal& > 3 + InString$ = LEFT$(InString$, 1) + RIGHT$(InString$, LEN(InString$) - 2) + RetVal& = RetVal& - 1 + LOOP END IF - IF RetVal& = LEN(InString$) THEN InString$ = InString$ + CHR$(48) - DO WHILE ASC(RIGHT$(InString$, 1)) = 48 AND RetVal& < (LEN(InString$) - 1) - InString$ = LEFT$(InString$, LEN(InString$) - 1) - LOOP - DO WHILE ASC(MID$(InString$, 2, 1)) = 48 AND RetVal& > 3 - InString$ = LEFT$(InString$, 1) + RIGHT$(InString$, LEN(InString$) - 2) - RetVal& = RetVal& - 1 - LOOP - END IF - CASE 11 - ' {00B} Read Sign ("+", "-", or CHR$(241)) - ' Returns: - ' Explicit: +1 = Positive; -1 = Negative; 0 = Unsigned; - ' Implied: +64 = Positive; -64 = NULL String + CASE 11 + ' {00B} Read Sign ("+", "-", or CHR$(241)) + ' Returns: + ' Explicit: +1 = Positive; -1 = Negative; 0 = Unsigned; + ' Implied: +64 = Positive; -64 = NULL String - IF RetVal& = 0 THEN RetVal& = -64 - FOR I& = 1 TO RetVal& - SELECT CASE ASC(MID$(InString$, I&, 1)) - CASE 32 - RetVal& = 64 - ' keep going - CASE 43 - RetVal& = 1 - EXIT FOR - CASE 45 - RetVal& = -1 - EXIT FOR - CASE 241 - RetVal& = 0 - EXIT FOR - CASE ELSE - RetVal& = 64 - EXIT FOR - END SELECT - NEXT I& + IF RetVal& = 0 THEN RetVal& = -64 + FOR I& = 1 TO RetVal& + SELECT CASE ASC(MID$(InString$, I&, 1)) + CASE 32 + RetVal& = 64 + ' keep going + CASE 43 + RetVal& = 1 + EXIT FOR + CASE 45 + RetVal& = -1 + EXIT FOR + CASE 241 + RetVal& = 0 + EXIT FOR + CASE ELSE + RetVal& = 64 + EXIT FOR + END SELECT + NEXT I& - CASE ELSE + CASE ELSE - RetVal& = 0 - Op& + RetVal& = 0 - Op& -END SELECT + END SELECT -Check& = RetVal& + Check& = RetVal& END FUNCTION FUNCTION N2S$ (exp$) 'scientific Notation to String -t$ = LTRIM$(RTRIM$(exp$)) -IF LEFT$(t$, 1) = "-" THEN sign$ = "-": t$ = MID$(t$, 2) + t$ = LTRIM$(RTRIM$(exp$)) + IF LEFT$(t$, 1) = "-" 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 SUB '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 SUB '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 - r&& = r&& + 1 + 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 - l$ = LEFT$(l$, 1) + MID$(l$, 3) -END IF -SELECT CASE r&& - CASE 0 'what the heck? We solved it already? - 'l$ = l$ - CASE IS < 0 - FOR i = 1 TO -r&& - l$ = "0" + l$ - NEXT - l$ = "0." + l$ - CASE ELSE - FOR i = 1 TO r&& - l$ = l$ + "0" - NEXT -END SELECT + SELECT CASE r&& + CASE 0 'what the heck? We solved it already? + 'l$ = l$ + CASE IS < 0 + FOR i = 1 TO -r&& + l$ = "0" + l$ + NEXT + l$ = "0." + l$ + CASE ELSE + FOR i = 1 TO r&& + l$ = l$ + "0" + NEXT + END SELECT -N2S$ = sign$ + l$ + N2S$ = sign$ + l$ END SUB 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 - QuotedFilename$ = "'" + f$ + "'" - EXIT FUNCTION -END IF + IF os$ = "LNX" THEN + QuotedFilename$ = "'" + f$ + "'" + EXIT FUNCTION + END IF END FUNCTION 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 - HashValue& = hash1char(a) + 1048576 - 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 + '[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 + HashValue& = hash1char(a) + 1048576 + 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 SUB HashAdd (a$, flags, reference) -'find the index to use -IF HashListFreeLast > 0 THEN - 'take from free list - i = HashListFree(HashListFreeLast) - HashListFreeLast = HashListFreeLast - 1 -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 + 'find the index to use + IF HashListFreeLast > 0 THEN + 'take from free list + i = HashListFree(HashListFreeLast) + HashListFreeLast = HashListFreeLast - 1 + 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 + i = HashListNext + HashListNext = HashListNext + 1 END IF - i = HashListNext - HashListNext = HashListNext + 1 -END IF -'setup links to index -x = HashValue(a$) -i2 = HashTable(x) -IF i2 THEN - i3 = HashList(i2).LastItem - HashList(i2).LastItem = i - HashList(i3).NextItem = i - HashList(i).PrevItem = i3 -ELSE - HashTable(x) = i - HashList(i).PrevItem = 0 - HashList(i).LastItem = i -END IF -HashList(i).NextItem = 0 + 'setup links to index + x = HashValue(a$) + i2 = HashTable(x) + IF i2 THEN + i3 = HashList(i2).LastItem + HashList(i2).LastItem = i + HashList(i3).NextItem = i + HashList(i).PrevItem = i3 + ELSE + HashTable(x) = i + HashList(i).PrevItem = 0 + HashList(i).LastItem = i + END IF + HashList(i).NextItem = 0 -'set common hashlist values -HashList(i).Flags = flags -HashList(i).Reference = reference -HashListName(i) = UCASE$(a$) + 'set common hashlist values + HashList(i).Flags = flags + HashList(i).Reference = reference + HashListName(i) = UCASE$(a$) END SUB 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$)) - hashfind_next: - f = HashList(i).Flags - 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 - HashFind = 2 - HashFind_NextListItem = i2 - HashFind_Reverse = 0 - HashFind_SearchFlags = searchflags - HashFind_Name = ua$ - HashRemove_LastFound = i - EXIT FUNCTION - ELSE - HashFind = 1 - HashRemove_LastFound = i - EXIT FUNCTION + '(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$)) + hashfind_next: + f = HashList(i).Flags + 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 + HashFind = 2 + HashFind_NextListItem = i2 + HashFind_Reverse = 0 + HashFind_SearchFlags = searchflags + HashFind_Name = ua$ + HashRemove_LastFound = i + EXIT FUNCTION + ELSE + HashFind = 1 + HashRemove_LastFound = i + EXIT FUNCTION + END IF END IF END IF + i = HashList(i).NextItem + IF i THEN GOTO hashfind_next END IF - i = HashList(i).NextItem - IF i THEN GOTO hashfind_next -END IF END FUNCTION 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 - i = HashList(i).LastItem - 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 - resultflags = f - resultreference = HashList(i).Reference - i2 = HashList(i).PrevItem - IF i2 THEN - HashFindRev = 2 - HashFind_NextListItem = i2 - HashFind_Reverse = 1 - HashFind_SearchFlags = searchflags - HashFind_Name = ua$ - HashRemove_LastFound = i - EXIT FUNCTION - ELSE - HashFindRev = 1 - HashRemove_LastFound = i - EXIT FUNCTION + '(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 + i = HashList(i).LastItem + 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 + resultflags = f + resultreference = HashList(i).Reference + i2 = HashList(i).PrevItem + IF i2 THEN + HashFindRev = 2 + HashFind_NextListItem = i2 + HashFind_Reverse = 1 + HashFind_SearchFlags = searchflags + HashFind_Name = ua$ + HashRemove_LastFound = i + EXIT FUNCTION + ELSE + HashFindRev = 1 + HashRemove_LastFound = i + EXIT FUNCTION + END IF END IF END IF + i = HashList(i).PrevItem + IF i THEN GOTO hashfindrev_next END IF - i = HashList(i).PrevItem - IF i THEN GOTO hashfindrev_next -END IF END FUNCTION 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 + '(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 - i = HashFind_NextListItem - hashfindrevc_next: - f = HashList(i).Flags - 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 - HashFindCont = 2 - HashFind_NextListItem = i2 - HashRemove_LastFound = i - EXIT FUNCTION - ELSE - HashFindCont = 1 - HashRemove_LastFound = i - EXIT FUNCTION + i = HashFind_NextListItem + hashfindrevc_next: + f = HashList(i).Flags + 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 + HashFindCont = 2 + HashFind_NextListItem = i2 + HashRemove_LastFound = i + EXIT FUNCTION + ELSE + HashFindCont = 1 + HashRemove_LastFound = i + EXIT FUNCTION + END IF END IF END IF - END IF - i = HashList(i).PrevItem - IF i THEN GOTO hashfindrevc_next - EXIT FUNCTION + i = HashList(i).PrevItem + 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 - resultflags = f - resultreference = HashList(i).Reference - i2 = HashList(i).NextItem - IF i2 THEN - HashFindCont = 2 - HashFind_NextListItem = i2 - HashRemove_LastFound = i - EXIT FUNCTION - ELSE - HashFindCont = 1 - HashRemove_LastFound = i - EXIT FUNCTION + i = HashFind_NextListItem + hashfindc_next: + f = HashList(i).Flags + 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 + HashFindCont = 2 + HashFind_NextListItem = i2 + HashRemove_LastFound = i + EXIT FUNCTION + ELSE + HashFindCont = 1 + HashRemove_LastFound = i + EXIT FUNCTION + END IF END IF END IF - END IF - i = HashList(i).NextItem - IF i THEN GOTO hashfindc_next - EXIT FUNCTION + i = HashList(i).NextItem + IF i THEN GOTO hashfindc_next + EXIT FUNCTION -END IF + END IF END FUNCTION SUB HashRemove -i = HashRemove_LastFound + i = HashRemove_LastFound -'add to free list -HashListFreeLast = HashListFreeLast + 1 -IF HashListFreeLast > HashListFreeSize THEN - HashListFreeSize = HashListFreeSize * 2 - REDIM _PRESERVE HashListFree(1 TO HashListFreeSize) AS LONG -END IF -HashListFree(HashListFreeLast) = i + 'add to free list + HashListFreeLast = HashListFreeLast + 1 + IF HashListFreeLast > HashListFreeSize THEN + HashListFreeSize = HashListFreeSize * 2 + REDIM _PRESERVE HashListFree(1 TO HashListFreeSize) AS LONG + END IF + HashListFree(HashListFreeLast) = i -'unlink -i1 = HashList(i).PrevItem -IF i1 THEN - 'not first item in list - i2 = HashList(i).NextItem - IF i2 THEN - '(not first and) not last item - HashList(i1).NextItem = i2 - HashList(i2).LastItem = i1 + 'unlink + i1 = HashList(i).PrevItem + IF i1 THEN + 'not first item in list + i2 = HashList(i).NextItem + IF i2 THEN + '(not first and) not last item + HashList(i1).NextItem = i2 + HashList(i2).LastItem = i1 + ELSE + 'last item + x = HashTable(HashValue(HashListName$(i))) + HashList(x).LastItem = i1 + HashList(i1).NextItem = 0 + END IF ELSE - 'last item + 'first item in list x = HashTable(HashValue(HashListName$(i))) - HashList(x).LastItem = i1 - HashList(i1).NextItem = 0 + i2 = HashList(i).NextItem + IF i2 THEN + '(first item but) not last item + HashTable(x) = i2 + HashList(i2).PrevItem = 0 + HashList(i2).LastItem = HashList(i).LastItem + ELSE + '(first and) last item + HashTable(x) = 0 + END IF END IF -ELSE - 'first item in list - x = HashTable(HashValue(HashListName$(i))) - i2 = HashList(i).NextItem - IF i2 THEN - '(first item but) not last item - HashTable(x) = i2 - HashList(i2).PrevItem = 0 - HashList(i2).LastItem = HashList(i).LastItem - ELSE - '(first and) last item - HashTable(x) = 0 - END IF -END IF END SUB 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 + fh = FREEFILE + OPEN "hashdump.txt" FOR OUTPUT AS #fh + b$ = "12345678901234567890123456789012}" + FOR x = 0 TO 16777215 + IF HashTable(x) THEN - PRINT #fh, "START HashTable("; x; "):" - i = 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 + 'validate + lasti = HashList(i).LastItem + 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 - hashdumpnextitem: - x$ = " [" + STR$(i) + "]" + HashListName(i) + PRINT #fh, " HashList("; i; ").LastItem="; HashList(i).LastItem + hashdumpnextitem: + 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 - f = f \ 2 - NEXT - x$ = x$ + b$ + f = HashList(i).Flags + x$ = x$ + ",.Flags=" + STR$(f) + "{" + FOR z = 1 TO 32 + ASC(b$, z) = (f AND 1) + 48 + f = f \ 2 + 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 + '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 + + i = HashList(i).NextItem + IF i THEN GOTO hashdumpnextitem + + PRINT #fh, "END HashTable("; x; ")" END IF + NEXT + CLOSE #fh - i = HashList(i).NextItem - IF i THEN GOTO hashdumpnextitem - - PRINT #fh, "END HashTable("; x; ")" - END IF -NEXT -CLOSE #fh - -EXIT SUB -corrupt: -PRINT #fh, "HASH TABLE CORRUPT!" 'should never happen -CLOSE #fh + EXIT SUB + corrupt: + PRINT #fh, "HASH TABLE CORRUPT!" 'should never happen + CLOSE #fh END SUB 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 + 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 -HashFind_NextListItem = 0 -HashFind_Reverse = 0 -HashFind_SearchFlags = 0 -HashFind_Name = "" -HashRemove_LastFound = 0 + HashFind_NextListItem = 0 + HashFind_Reverse = 0 + HashFind_SearchFlags = 0 + HashFind_Name = "" + HashRemove_LastFound = 0 END SUB FUNCTION removecast$ (a$) -removecast$ = a$ -IF INSTR(a$, " )") THEN - removecast$ = RIGHT$(a$, LEN(a$) - INSTR(a$, " )") - 2) -END IF + removecast$ = a$ + 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 -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 -converttabs$ = a$ + 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 + converttabs$ = a$ END FUNCTION 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 - '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 + 'notes: + '1) '_1' is invalid because it has no alphabet letters + '2) 'A_' is invalid because it has a trailing _ + '3) '_1A' is invalid because it contains a number before the first alphabet letter + '4) names cannot be longer than 40 characters 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 - -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 - trailingunderscore = 1 - ELSE - alphabetletter = 1 - trailingunderscore = 0 - END IF + 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 -NEXT -IF trailingunderscore THEN EXIT FUNCTION -validname = 1 + + 'check for single, leading underscore + 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 + trailingunderscore = 0 + IF alphabetletter = 0 THEN EXIT FUNCTION + ELSE + IF a = 95 THEN + trailingunderscore = 1 + ELSE + alphabetletter = 1 + trailingunderscore = 0 + END IF + END IF + NEXT + IF trailingunderscore THEN EXIT FUNCTION + validname = 1 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 -str_nth$ = str2(x) + "th" + 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 SUB Give_Error (a$) -Error_Happened = 1 -Error_Message = a$ + Error_Happened = 1 + Error_Message = a$ END SUB SUB WriteConfigSetting (heading$, item$, tvalue$) -value$ = tvalue$ -SHARED ConfigFile$, ConfigBak$ + value$ = tvalue$ + SHARED ConfigFile$, ConfigBak$ -InFile = FREEFILE: OPEN ConfigFile$ FOR BINARY AS #InFile -OutFile = FREEFILE: OPEN ConfigBak$ FOR OUTPUT AS #OutFile -placed = 0 + 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 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)) - - 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 - -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 - 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$ + '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 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)) + + 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 + CLOSE #InFile, #OutFile - KILL ConfigBak$ - NAME "internal/config.tmp" AS ConfigFile$ -ELSE - NAME ConfigBak$ AS ConfigFile$ -END IF + 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 + 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 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 + SHARED ConfigFile$ + value$ = "" 'We start by blanking the value$ as a default return state + InFile = FREEFILE: OPEN ConfigFile$ FOR BINARY AS #InFile -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 - '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$)) - '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) + 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 + '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$)) + '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 + ReadConfigSetting = -1 + EXIT FUNCTION END IF - ReadConfigSetting = -1 - EXIT FUNCTION END IF END IF -END IF -CLOSE #InFile -ReadConfigSetting = 0 'failed to find the setting + CLOSE #InFile + ReadConfigSetting = 0 'failed to find the setting END FUNCTION 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 + '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)) - VRGBS = _RGB32(red, green, blue) + 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)) + VRGBS = _RGB32(red, green, blue) + END IF END IF -END IF END FUNCTION 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 -PC_Op(1) = "=" -PC_Op(2) = "<" -PC_Op(3) = ">" -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 - 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 SUB - second = i: secondsymbol$ = a$ - CASE ELSE 'we found a symbol we don't recognize - EXIT FOR - END SELECT + 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 + PC_Op(1) = "=" + PC_Op(2) = "<" + PC_Op(3) = ">" + 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 - 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) - '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$ = "<>" - 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 = - FOR i = 0 TO UserDefineCount - IF UserDefine(0, i) = l$ AND UserDefine(1, i) = r$ THEN result$ = " -1 ": GOTO finishedcheck + 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 SUB + 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 - 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 + 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$ = "<>" + 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 = + 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 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 + + 'And at this point we should now be down to a statement with nothing but AND/OR/XORS in it + + PC_Op(1) = " AND " + PC_Op(2) = " OR " + PC_Op(3) = " XOR " + + 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 - IF UserDefine(0, i) = l$ AND UserDefine(1, i) > r$ THEN result$ = " -1 ": GOTO finishedcheck + 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)) + rightside$ = "" + 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 INSTR(symbol$, "<") THEN 'check to see if we're less than in any case with < + rightresult = 0 + IF VerifyNumber(m$) THEN + IF VAL(m$) <> 0 THEN rightresult = -1 + ELSE 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 + 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 - - - finishedcheck: - temp$ = leftside$ + result$ + rightside$ - 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 - -PC_Op(1) = " AND " -PC_Op(2) = " OR " -PC_Op(3) = " XOR " - -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 - 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)) - rightside$ = "" - END IF - leftresult = 0 - IF VerifyNumber(leftside$) THEN - IF VAL(leftside$) <> 0 THEN leftresult = -1 + 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) = leftside$ THEN + IF UserDefine(0, i) = temp$ THEN t$ = LTRIM$(RTRIM$(UserDefine(1, i))) - IF t$ <> "0" AND t$ <> "" THEN leftresult = -1: EXIT FOR + IF t$ <> "0" AND t$ <> "" THEN EvalPreIF = -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 - temp$ = result$ + rightside$ -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 END SUB FUNCTION VerifyNumber (text$) -t$ = LTRIM$(RTRIM$(text$)) -v = VAL(t$) -t1$ = LTRIM$(STR$(v)) -IF t$ = t1$ THEN VerifyNumber = -1 + t$ = LTRIM$(RTRIM$(text$)) + v = VAL(t$) + t1$ = LTRIM$(STR$(v)) + IF t$ = t1$ THEN VerifyNumber = -1 END FUNCTION '$INCLUDE:'utilities\strings.bas' diff --git a/source/subs_functions/extensions/opengl/opengl_methods.bas b/source/subs_functions/extensions/opengl/opengl_methods.bas index 4903aa95a..16ef21f78 100644 --- a/source/subs_functions/extensions/opengl/opengl_methods.bas +++ b/source/subs_functions/extensions/opengl/opengl_methods.bas @@ -1,405 +1,405 @@ FUNCTION gl2qb_type_convert$ (a$, symbol$, typ, ctyp$) -symbol$ = "" + symbol$ = "" -'unsigned int -IF a$ = "GLenum" THEN b$ = "_UNSIGNED LONG": symbol$ = "~&": typ = ULONGTYPE - ISPOINTER: ctyp$ = "uint32" -IF a$ = "GLbitfield" THEN b$ = "_UNSIGNED LONG": symbol$ = "~&": typ = ULONGTYPE - ISPOINTER: ctyp$ = "uint32" -IF a$ = "GLuint" THEN b$ = "_UNSIGNED LONG": symbol$ = "~&": typ = ULONGTYPE - ISPOINTER: ctyp$ = "uint32" + 'unsigned int + IF a$ = "GLenum" THEN b$ = "_UNSIGNED LONG": symbol$ = "~&": typ = ULONGTYPE - ISPOINTER: ctyp$ = "uint32" + IF a$ = "GLbitfield" THEN b$ = "_UNSIGNED LONG": symbol$ = "~&": typ = ULONGTYPE - ISPOINTER: ctyp$ = "uint32" + IF a$ = "GLuint" THEN b$ = "_UNSIGNED LONG": symbol$ = "~&": typ = ULONGTYPE - ISPOINTER: ctyp$ = "uint32" -'int -IF a$ = "GLint" THEN b$ = "LONG": symbol$ = "&": typ = LONGTYPE - ISPOINTER: ctyp$ = "int32" -IF a$ = "GLsizei" THEN b$ = "LONG": symbol$ = "&": typ = LONGTYPE - ISPOINTER: ctyp$ = "int32" + 'int + IF a$ = "GLint" THEN b$ = "LONG": symbol$ = "&": typ = LONGTYPE - ISPOINTER: ctyp$ = "int32" + IF a$ = "GLsizei" THEN b$ = "LONG": symbol$ = "&": typ = LONGTYPE - ISPOINTER: ctyp$ = "int32" -'unsigned char -IF a$ = "GLboolean" THEN b$ = "_UNSIGNED _BYTE": symbol$ = "~%%": typ = UBYTETYPE - ISPOINTER: ctyp$ = "uint8" -IF a$ = "GLubyte" THEN b$ = "_UNSIGNED _BYTE": symbol$ = "~%%": typ = UBYTETYPE - ISPOINTER: ctyp$ = "uint8" + 'unsigned char + IF a$ = "GLboolean" THEN b$ = "_UNSIGNED _BYTE": symbol$ = "~%%": typ = UBYTETYPE - ISPOINTER: ctyp$ = "uint8" + IF a$ = "GLubyte" THEN b$ = "_UNSIGNED _BYTE": symbol$ = "~%%": typ = UBYTETYPE - ISPOINTER: ctyp$ = "uint8" -'char -IF a$ = "GLbyte" THEN b$ = "_BYTE": symbol$ = "%%": typ = BYTETYPE - ISPOINTER: ctyp$ = "int8" + 'char + IF a$ = "GLbyte" THEN b$ = "_BYTE": symbol$ = "%%": typ = BYTETYPE - ISPOINTER: ctyp$ = "int8" -'unsigned short -IF a$ = "GLushort" THEN b$ = "_UNSIGNED INTEGER": symbol$ = "~%": typ = UINTEGERTYPE - ISPOINTER: ctyp$ = "uint16" + 'unsigned short + IF a$ = "GLushort" THEN b$ = "_UNSIGNED INTEGER": symbol$ = "~%": typ = UINTEGERTYPE - ISPOINTER: ctyp$ = "uint16" -'short -IF a$ = "GLshort" THEN b$ = "INTEGER": symbol$ = "%": typ = INTEGERTYPE - ISPOINTER: ctyp$ = "int16" + 'short + IF a$ = "GLshort" THEN b$ = "INTEGER": symbol$ = "%": typ = INTEGERTYPE - ISPOINTER: ctyp$ = "int16" -'float -IF a$ = "GLfloat" THEN b$ = "SINGLE": symbol$ = "!": typ = SINGLETYPE - ISPOINTER: ctyp$ = "float" -IF a$ = "GLclampf" THEN b$ = "SINGLE": symbol$ = "!": typ = SINGLETYPE - ISPOINTER: ctyp$ = "float" + 'float + IF a$ = "GLfloat" THEN b$ = "SINGLE": symbol$ = "!": typ = SINGLETYPE - ISPOINTER: ctyp$ = "float" + IF a$ = "GLclampf" THEN b$ = "SINGLE": symbol$ = "!": typ = SINGLETYPE - ISPOINTER: ctyp$ = "float" -'double -IF a$ = "GLdouble" THEN b$ = "DOUBLE": symbol$ = "#": typ = DOUBLETYPE - ISPOINTER: ctyp$ = "double" -IF a$ = "GLclampd" THEN b$ = "DOUBLE": symbol$ = "#": typ = DOUBLETYPE - ISPOINTER: ctyp$ = "double" + 'double + IF a$ = "GLdouble" THEN b$ = "DOUBLE": symbol$ = "#": typ = DOUBLETYPE - ISPOINTER: ctyp$ = "double" + IF a$ = "GLclampd" THEN b$ = "DOUBLE": symbol$ = "#": typ = DOUBLETYPE - ISPOINTER: ctyp$ = "double" -'void -IF a$ = "GLvoid" THEN b$ = "_OFFSET": symbol$ = "%&": typ = OFFSETTYPE - ISPOINTER: ctyp$ = "ptrszint" + 'void + IF a$ = "GLvoid" THEN b$ = "_OFFSET": symbol$ = "%&": typ = OFFSETTYPE - ISPOINTER: ctyp$ = "ptrszint" -'typedef unsigned int GLenum; -'typedef unsigned char GLboolean; -'typedef unsigned int GLbitfield; -'typedef signed char GLbyte; -'typedef short GLshort; -'typedef int GLint; -'typedef int GLsizei; -'typedef unsigned char GLubyte; -'typedef unsigned short GLushort; -'typedef unsigned int GLuint; -'typedef float GLfloat; -'typedef float GLclampf; -'typedef double GLdouble; -'typedef double GLclampd; -'typedef void GLvoid; + 'typedef unsigned int GLenum; + 'typedef unsigned char GLboolean; + 'typedef unsigned int GLbitfield; + 'typedef signed char GLbyte; + 'typedef short GLshort; + 'typedef int GLint; + 'typedef int GLsizei; + 'typedef unsigned char GLubyte; + 'typedef unsigned short GLushort; + 'typedef unsigned int GLuint; + 'typedef float GLfloat; + 'typedef float GLclampf; + 'typedef double GLdouble; + 'typedef double GLclampd; + 'typedef void GLvoid; -IF b$ = "" THEN PRINT "Unknown type:" + a$: END -gl2qb_type_convert$ = b$ + IF b$ = "" THEN PRINT "Unknown type:" + a$: END + gl2qb_type_convert$ = b$ END FUNCTION FUNCTION readchunk$ (a$, last_character$) -a$ = LTRIM$(RTRIM$(a$)) -FOR x = 1 TO LEN(a$) - c = ASC(a$, x) - IF c = 32 OR c = 44 OR c = 40 OR c = 41 THEN last_character$ = CHR$(c): readchunk$ = LEFT$(a$, x - 1): a$ = LTRIM$(RIGHT$(a$, LEN(a$) - x)): EXIT FUNCTION -NEXT -readchunk$ = a$: last_character$ = "": a$ = "" + a$ = LTRIM$(RTRIM$(a$)) + FOR x = 1 TO LEN(a$) + c = ASC(a$, x) + IF c = 32 OR c = 44 OR c = 40 OR c = 41 THEN last_character$ = CHR$(c): readchunk$ = LEFT$(a$, x - 1): a$ = LTRIM$(RIGHT$(a$, LEN(a$) - x)): EXIT FUNCTION + NEXT + readchunk$ = a$: last_character$ = "": a$ = "" END FUNCTION SUB gl_scan_header -IF GL_KIT THEN hk = FREEFILE: OPEN "internal\c\parts\core\gl_header_for_parsing\temp\gl_kit.bas" FOR OUTPUT AS #hk -IF GL_KIT THEN PRINT #hk, "DECLARE LIBRARY" + IF GL_KIT THEN hk = FREEFILE: OPEN "internal\c\parts\core\gl_header_for_parsing\temp\gl_kit.bas" FOR OUTPUT AS #hk + IF GL_KIT THEN PRINT #hk, "DECLARE LIBRARY" -d = 0: a2$ = "" -h = FREEFILE -OPEN "internal\c\parts\core\gl_header_for_parsing\gl.h" FOR INPUT AS #h -DO UNTIL EOF(h) - LINE INPUT #h, a$ - IF LEN(a$) THEN - a$ = LTRIM$(RTRIM$(a$)) - IF LEFT$(a$, 8) = "#define " THEN - a2$ = "" - a$ = a$ + " " - FOR x = 1 TO LEN(a$) - c = ASC(a$, x) - IF c = 32 THEN - FOR x2 = 1 TO LEN(a2$) - c2 = ASC(a2$, x2) - IF c2 >= 65 AND c2 <= 90 THEN GOTO define_ok - IF c2 >= 48 AND c2 <= 57 AND x2 <> 1 THEN GOTO define_ok - IF c2 = 95 THEN GOTO define_ok - GOTO define_not_ok - define_ok: - NEXT - value$ = LTRIM$(RTRIM$(RIGHT$(a$, LEN(a$) - x))) - IF LEN(value$) = 0 THEN GOTO define_not_ok - - IF LEFT$(value$, 2) = "0x" THEN - value&& = VAL("&H" + RIGHT$(value$, LEN(value$) - 2) + "&&") - 'PRINT a2$, value&& - d = d + 1: GL_DEFINES(d) = a2$: GL_DEFINES_VALUE(d) = value&& - ELSEIF ASC(value$) >= 48 AND ASC(value$) <= 57 THEN - value&& = VAL(value$) - 'PRINT a2$, value&& - d = d + 1: GL_DEFINES(d) = a2$: GL_DEFINES_VALUE(d) = value&& - ELSE - 'PRINT a2$, value$, "?" - FOR i = 1 TO d - IF GL_DEFINES(i) = value$ THEN - d = d + 1: GL_DEFINES(d) = a2$: GL_DEFINES_VALUE(d) = GL_DEFINES_VALUE(i) - 'PRINT a2$, GL_DEFINES_VALUE(i) - EXIT FOR - END IF + d = 0: a2$ = "" + h = FREEFILE + OPEN "internal\c\parts\core\gl_header_for_parsing\gl.h" FOR INPUT AS #h + DO UNTIL EOF(h) + LINE INPUT #h, a$ + IF LEN(a$) THEN + a$ = LTRIM$(RTRIM$(a$)) + IF LEFT$(a$, 8) = "#define " THEN + a2$ = "" + a$ = a$ + " " + FOR x = 1 TO LEN(a$) + c = ASC(a$, x) + IF c = 32 THEN + FOR x2 = 1 TO LEN(a2$) + c2 = ASC(a2$, x2) + IF c2 >= 65 AND c2 <= 90 THEN GOTO define_ok + IF c2 >= 48 AND c2 <= 57 AND x2 <> 1 THEN GOTO define_ok + IF c2 = 95 THEN GOTO define_ok + GOTO define_not_ok + define_ok: NEXT + value$ = LTRIM$(RTRIM$(RIGHT$(a$, LEN(a$) - x))) + IF LEN(value$) = 0 THEN GOTO define_not_ok + + IF LEFT$(value$, 2) = "0x" THEN + value&& = VAL("&H" + RIGHT$(value$, LEN(value$) - 2) + "&&") + 'PRINT a2$, value&& + d = d + 1: GL_DEFINES(d) = a2$: GL_DEFINES_VALUE(d) = value&& + ELSEIF ASC(value$) >= 48 AND ASC(value$) <= 57 THEN + value&& = VAL(value$) + 'PRINT a2$, value&& + d = d + 1: GL_DEFINES(d) = a2$: GL_DEFINES_VALUE(d) = value&& + ELSE + 'PRINT a2$, value$, "?" + FOR i = 1 TO d + IF GL_DEFINES(i) = value$ THEN + d = d + 1: GL_DEFINES(d) = a2$: GL_DEFINES_VALUE(d) = GL_DEFINES_VALUE(i) + 'PRINT a2$, GL_DEFINES_VALUE(i) + EXIT FOR + END IF + NEXT + END IF + GOTO got_define + define_not_ok: + a2$ = "" + ELSE + a2$ = a2$ + CHR$(c) END IF - GOTO got_define - define_not_ok: - a2$ = "" + NEXT + got_define: + END IF '#define + + + IF RIGHT$(a$, 1) = ";" THEN + a2$ = readchunk(a$, l$): IF a2$ <> "WINGDIAPI" GOTO discard + ret_type$ = readchunk(a$, l$) + IF ret_type$ = "const" THEN ret_type$ = readchunk(a$, l$) + + is_func = 0: IF ret_type$ <> "void" THEN is_func = 1 + + a2$ = readchunk(a$, l$) + IF a2$ = "*APIENTRY" THEN ret_type$ = ret_type$ + "*": a2$ = "APIENTRY" + IF a2$ <> "APIENTRY" THEN GOTO discard + + GL_COMMANDS_LAST = GL_COMMANDS_LAST + 1 + c = GL_COMMANDS_LAST + + hc$ = "" + hd$ = "" + need_helper_function = 0 + + IF is_func THEN + GL_COMMANDS(c).subfunc = 1 + IF GL_KIT THEN PRINT #hk, "FUNCTION "; ELSE - a2$ = a2$ + CHR$(c) + GL_COMMANDS(c).subfunc = 2 + IF GL_KIT THEN PRINT #hk, "SUB "; END IF - NEXT - got_define: - END IF '#define + + proc_name$ = readchunk(a$, l$) + + GL_COMMANDS(c).cn = "_" + proc_name$: IF GL_KIT THEN PRINT #hk, proc_name$; + GL_COMMANDS(c).callname = proc_name$ + + GL_COMMANDS(c).ret = 0 + IF is_func THEN + pointer = 0: IF RIGHT$(ret_type$, 1) = "*" THEN pointer = 1 + IF pointer THEN + t$ = "_OFFSET": s$ = "&&" + GL_COMMANDS(c).ret = OFFSETTYPE - ISPOINTER + hd$ = hd$ + "ptrszint " + need_helper_function = 1 + ELSE + t$ = gl2qb_type_convert(ret_type$, s$, typ, ctyp$) + GL_COMMANDS(c).ret = typ + hd$ = hd$ + ctyp$ + " " + END IF + IF GL_KIT THEN PRINT #hk, s$; + hc$ = hc$ + "return (" + ctyp$ + ")(" + ret_type$ + ")" + ELSE + hd$ = hd$ + "void " + END IF + + IF GL_KIT THEN PRINT #hk, "("; + + hc$ = hc$ + proc_name$ + "(" + hd$ = hd$ + "call_" + proc_name$ + "(" - IF RIGHT$(a$, 1) = ";" THEN - a2$ = readchunk(a$, l$): IF a2$ <> "WINGDIAPI" GOTO discard - ret_type$ = readchunk(a$, l$) - IF ret_type$ = "const" THEN ret_type$ = readchunk(a$, l$) + GL_COMMANDS(c).args = 0 + GL_COMMANDS(c).arg = "" - is_func = 0: IF ret_type$ <> "void" THEN is_func = 1 + DO - a2$ = readchunk(a$, l$) - IF a2$ = "*APIENTRY" THEN ret_type$ = ret_type$ + "*": a2$ = "APIENTRY" - IF a2$ <> "APIENTRY" THEN GOTO discard + var_type$ = readchunk(a$, l$) + IF var_type$ = "" AND l$ = "(" THEN var_type$ = readchunk(a$, l$) 'space between fun name and "("? + IF var_type$ = "const" THEN var_type$ = readchunk(a$, l$) + IF var_type$ = "void" OR var_type$ = "" THEN GOTO no_arguments + IF l$ <> "," AND l$ <> ")" THEN + var_name$ = readchunk(a$, l$) + IF LEFT$(var_name$, 1) = "*" THEN var_type$ = var_type$ + "*": var_name$ = RIGHT$(var_name$, LEN(var_name$) - 1) + IF LEFT$(var_name$, 1) = "*" THEN var_type$ = var_type$ + "*": var_name$ = RIGHT$(var_name$, LEN(var_name$) - 1) + 'Note: could be a poiner to a pointer + ELSE + var_name$ = "no_name" + END IF - GL_COMMANDS_LAST = GL_COMMANDS_LAST + 1 - c = GL_COMMANDS_LAST + var_type_backup$ = var_type$ - hc$ = "" - hd$ = "" - need_helper_function = 0 + pointer = 0 - IF is_func THEN - GL_COMMANDS(c).subfunc = 1 - IF GL_KIT THEN PRINT #hk, "FUNCTION "; - ELSE - GL_COMMANDS(c).subfunc = 2 - IF GL_KIT THEN PRINT #hk, "SUB "; - END IF + IF RIGHT$(var_type$, 1) = "*" THEN + var_type$ = LEFT$(var_type$, LEN(var_type$) - 1) + pointer = 1 + END IF + IF RIGHT$(var_type$, 1) = "*" THEN + var_type$ = LEFT$(var_type$, LEN(var_type$) - 1) + pointer = 2 + END IF - proc_name$ = readchunk(a$, l$) + IF pointer = 2 THEN + qb_type$ = "_OFFSET" 'it's the offset of an offset + ELSE + qb_type$ = gl2qb_type_convert$(var_type$, s$, typ, ctyp$) + END IF - GL_COMMANDS(c).cn = "_" + proc_name$: IF GL_KIT THEN PRINT #hk, proc_name$; - GL_COMMANDS(c).callname = proc_name$ - - GL_COMMANDS(c).ret = 0 - IF is_func THEN - pointer = 0: IF RIGHT$(ret_type$, 1) = "*" THEN pointer = 1 - IF pointer THEN - t$ = "_OFFSET": s$ = "&&" - GL_COMMANDS(c).ret = OFFSETTYPE - ISPOINTER - hd$ = hd$ + "ptrszint " + 'IF pointer THEN need_helper_function = 1 need_helper_function = 1 - ELSE - t$ = gl2qb_type_convert(ret_type$, s$, typ, ctyp$) - GL_COMMANDS(c).ret = typ - hd$ = hd$ + ctyp$ + " " + + IF GL_KIT THEN + IF pointer = 0 THEN PRINT #hk, "BYVAL "; + PRINT #hk, var_name$ + " AS " + qb_type$; + IF l$ <> ")" THEN PRINT #hk, ","; + END IF + + IF pointer = 0 THEN + arg$ = MKL$(typ) + END IF + IF pointer = 1 THEN 'all pointers convert to BYVAL _OFFSET + arg$ = MKL$(OFFSETTYPE - ISPOINTER) + ctyp$ = "ptrszint" + END IF + IF pointer = 2 THEN 'all pointers-to-pointers convert to xxx"BYREF"xxx BYVAL _OFFSET + arg$ = MKL$(OFFSETTYPE - ISPOINTER) + ctyp$ = "ptrszint" + '***this is important or you lose the ability to specify any offset, only the offset of a variable of type + ' _OFFSET + ' arg$ = MKL$(OFFSETTYPE) + ' ctyp$ = "ptrszint*" + END IF + + GL_COMMANDS(c).args = GL_COMMANDS(c).args + 1 + + MID$(GL_COMMANDS(c).arg, (GL_COMMANDS(c).args - 1) * 4 + 1, 4) = arg$ + 'z$ = GL_COMMANDS(c).arg + 'MID$(z$, (GL_COMMANDS(c).args - 1) * 4 + 1, 4) = arg$ + 'GL_COMMANDS(c).arg = z$ + + letter$ = CHR$(96 + GL_COMMANDS(c).args) + + hc$ = hc$ + "(" + var_type_backup$ + ")" + letter$ + hd$ = hd$ + ctyp$ + " " + letter$ + + + + IF l$ <> ")" THEN hc$ = hc$ + ",": hd$ = hd$ + "," + + LOOP UNTIL l$ = ")" + no_arguments: + + + hd$ = hd$ + "){" + hc$ = hc$ + ");" + IF GL_KIT THEN PRINT #hk, ")" + h$ = hd$ + CRLF + "if (!sub_gl_called) error(270);" + CRLF + hc$ + CRLF + "}" + CRLF + + IF need_helper_function THEN 'do we need the helper function for this command? + GL_HELPER_CODE = GL_HELPER_CODE + h$ + GL_COMMANDS(c).callname = "call_" + proc_name$ END IF - IF GL_KIT THEN PRINT #hk, s$; - hc$ = hc$ + "return (" + ctyp$ + ")(" + ret_type$ + ")" - ELSE - hd$ = hd$ + "void " + + + IF proc_name$ = "glGetString" THEN + GL_COMMANDS(c).ret = STRINGTYPE + GL_COMMANDS(c).callname = "( char* )" + RTRIM$(GL_COMMANDS(c).callname) + END IF + + + + END IF - IF GL_KIT THEN PRINT #hk, "("; - - hc$ = hc$ + proc_name$ + "(" - hd$ = hd$ + "call_" + proc_name$ + "(" - - - GL_COMMANDS(c).args = 0 - GL_COMMANDS(c).arg = "" - - DO - - var_type$ = readchunk(a$, l$) - IF var_type$ = "" AND l$ = "(" THEN var_type$ = readchunk(a$, l$) 'space between fun name and "("? - IF var_type$ = "const" THEN var_type$ = readchunk(a$, l$) - IF var_type$ = "void" OR var_type$ = "" THEN GOTO no_arguments - IF l$ <> "," AND l$ <> ")" THEN - var_name$ = readchunk(a$, l$) - IF LEFT$(var_name$, 1) = "*" THEN var_type$ = var_type$ + "*": var_name$ = RIGHT$(var_name$, LEN(var_name$) - 1) - IF LEFT$(var_name$, 1) = "*" THEN var_type$ = var_type$ + "*": var_name$ = RIGHT$(var_name$, LEN(var_name$) - 1) - 'Note: could be a poiner to a pointer - ELSE - var_name$ = "no_name" - END IF - - var_type_backup$ = var_type$ - - pointer = 0 - - IF RIGHT$(var_type$, 1) = "*" THEN - var_type$ = LEFT$(var_type$, LEN(var_type$) - 1) - pointer = 1 - END IF - IF RIGHT$(var_type$, 1) = "*" THEN - var_type$ = LEFT$(var_type$, LEN(var_type$) - 1) - pointer = 2 - END IF - - IF pointer = 2 THEN - qb_type$ = "_OFFSET" 'it's the offset of an offset - ELSE - qb_type$ = gl2qb_type_convert$(var_type$, s$, typ, ctyp$) - END IF - - 'IF pointer THEN need_helper_function = 1 - need_helper_function = 1 - - IF GL_KIT THEN - IF pointer = 0 THEN PRINT #hk, "BYVAL "; - PRINT #hk, var_name$ + " AS " + qb_type$; - IF l$ <> ")" THEN PRINT #hk, ","; - END IF - - IF pointer = 0 THEN - arg$ = MKL$(typ) - END IF - IF pointer = 1 THEN 'all pointers convert to BYVAL _OFFSET - arg$ = MKL$(OFFSETTYPE - ISPOINTER) - ctyp$ = "ptrszint" - END IF - IF pointer = 2 THEN 'all pointers-to-pointers convert to xxx"BYREF"xxx BYVAL _OFFSET - arg$ = MKL$(OFFSETTYPE - ISPOINTER) - ctyp$ = "ptrszint" - '***this is important or you lose the ability to specify any offset, only the offset of a variable of type - ' _OFFSET - ' arg$ = MKL$(OFFSETTYPE) - ' ctyp$ = "ptrszint*" - END IF - - GL_COMMANDS(c).args = GL_COMMANDS(c).args + 1 - - MID$(GL_COMMANDS(c).arg, (GL_COMMANDS(c).args - 1) * 4 + 1, 4) = arg$ - 'z$ = GL_COMMANDS(c).arg - 'MID$(z$, (GL_COMMANDS(c).args - 1) * 4 + 1, 4) = arg$ - 'GL_COMMANDS(c).arg = z$ - - letter$ = CHR$(96 + GL_COMMANDS(c).args) - - hc$ = hc$ + "(" + var_type_backup$ + ")" + letter$ - hd$ = hd$ + ctyp$ + " " + letter$ - - - - IF l$ <> ")" THEN hc$ = hc$ + ",": hd$ = hd$ + "," - - LOOP UNTIL l$ = ")" - no_arguments: - - - hd$ = hd$ + "){" - hc$ = hc$ + ");" - IF GL_KIT THEN PRINT #hk, ")" - h$ = hd$ + CRLF + "if (!sub_gl_called) error(270);" + CRLF + hc$ + CRLF + "}" + CRLF - - IF need_helper_function THEN 'do we need the helper function for this command? - GL_HELPER_CODE = GL_HELPER_CODE + h$ - GL_COMMANDS(c).callname = "call_" + proc_name$ - END IF - - - IF proc_name$ = "glGetString" THEN - GL_COMMANDS(c).ret = STRINGTYPE - GL_COMMANDS(c).callname = "( char* )" + RTRIM$(GL_COMMANDS(c).callname) - END IF - - - - END IF + + + + + discard: + LOOP + CLOSE #h + + IF GL_KIT THEN PRINT #hk, "END DECLARE" + + GL_DEFINES_LAST = d + REDIM _PRESERVE GL_DEFINES(d) AS STRING + 'PRINT "Defines:"; GL_DEFINES_LAST + + REDIM _PRESERVE GL_COMMANDS(GL_COMMANDS_LAST) AS GL_idstruct + 'PRINT "Commands:"; GL_COMMANDS_LAST + + IF GL_KIT THEN + FOR i = 1 TO GL_DEFINES_LAST + PRINT #hk, "CONST " + GL_DEFINES(i) + "="; GL_DEFINES_VALUE(i) + NEXT END IF + 'FOR i = 1 TO GL_COMMANDS_LAST + ' PRINT ".cn="; GL_COMMANDS(i).cn + ' PRINT ".callname="; GL_COMMANDS(i).callname + ' PRINT ".subfunc="; GL_COMMANDS(i).subfunc + ' PRINT ".args="; GL_COMMANDS(i).args + ' _CONTROLCHR OFF + ' PRINT ".arg=[" + RTRIM$(GL_COMMANDS(i).arg) + "]" + ' _CONTROLCHR ON + ' PRINT ".ret="; GL_COMMANDS(i).ret + 'NEXT + + IF GL_KIT THEN CLOSE #hk - - - discard: -LOOP -CLOSE #h - -IF GL_KIT THEN PRINT #hk, "END DECLARE" - -GL_DEFINES_LAST = d -REDIM _PRESERVE GL_DEFINES(d) AS STRING -'PRINT "Defines:"; GL_DEFINES_LAST - -REDIM _PRESERVE GL_COMMANDS(GL_COMMANDS_LAST) AS GL_idstruct -'PRINT "Commands:"; GL_COMMANDS_LAST - -IF GL_KIT THEN - FOR i = 1 TO GL_DEFINES_LAST - PRINT #hk, "CONST " + GL_DEFINES(i) + "="; GL_DEFINES_VALUE(i) - NEXT -END IF - -'FOR i = 1 TO GL_COMMANDS_LAST -' PRINT ".cn="; GL_COMMANDS(i).cn -' PRINT ".callname="; GL_COMMANDS(i).callname -' PRINT ".subfunc="; GL_COMMANDS(i).subfunc -' PRINT ".args="; GL_COMMANDS(i).args -' _CONTROLCHR OFF -' PRINT ".arg=[" + RTRIM$(GL_COMMANDS(i).arg) + "]" -' _CONTROLCHR ON -' PRINT ".ret="; GL_COMMANDS(i).ret -'NEXT - -IF GL_KIT THEN CLOSE #hk - - -fh = FREEFILE -OPEN "internal\c\parts\core\gl_header_for_parsing\temp\gl_helper_code.h" FOR OUTPUT AS #fh -PRINT #fh, GL_HELPER_CODE -CLOSE #fh + fh = FREEFILE + OPEN "internal\c\parts\core\gl_header_for_parsing\temp\gl_helper_code.h" FOR OUTPUT AS #fh + PRINT #fh, GL_HELPER_CODE + CLOSE #fh END SUB SUB gl_include_content -'add constants -FOR d = 1 TO GL_DEFINES_LAST - IF ASC(GL_DEFINES(d)) <> 95 THEN - GL_DEFINES(d) = "_" + GL_DEFINES(d) - END IF - constlast = constlast + 1 - 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 - i = constlast - constname(i) = GL_DEFINES(d) - constcname(i) = GL_DEFINES(d) - constnamesymbol(i) = "&&" - consttype(i) = INTEGER64TYPE - ISPOINTER - constinteger(i) = GL_DEFINES_VALUE(d) - constsubfunc(i) = 0 'global - constdefined(i) = 1 - 'add to hash table - HashAdd constcname(i), HASHFLAG_CONSTANT, i -NEXT + 'add constants + FOR d = 1 TO GL_DEFINES_LAST + IF ASC(GL_DEFINES(d)) <> 95 THEN + GL_DEFINES(d) = "_" + GL_DEFINES(d) + END IF + constlast = constlast + 1 + 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 + i = constlast + constname(i) = GL_DEFINES(d) + constcname(i) = GL_DEFINES(d) + constnamesymbol(i) = "&&" + consttype(i) = INTEGER64TYPE - ISPOINTER + constinteger(i) = GL_DEFINES_VALUE(d) + constsubfunc(i) = 0 'global + constdefined(i) = 1 + 'add to hash table + HashAdd constcname(i), HASHFLAG_CONSTANT, i + NEXT -'add subs/functions -FOR c = 1 TO GL_COMMANDS_LAST - DIM g AS GL_idstruct - ' TYPE GL_idstruct - ' cn AS STRING * 64 'case sensitive version of n - ' subfunc AS INTEGER 'if function=1, sub=2 - ' callname AS STRING * 64 - ' args AS INTEGER - ' arg AS STRING * 80 'similar to t - ' ret AS LONG 'the value it returns if it is a function (again like t) - ' END TYPE - g = GL_COMMANDS(c) + 'add subs/functions + FOR c = 1 TO GL_COMMANDS_LAST + DIM g AS GL_idstruct + ' TYPE GL_idstruct + ' cn AS STRING * 64 'case sensitive version of n + ' subfunc AS INTEGER 'if function=1, sub=2 + ' callname AS STRING * 64 + ' args AS INTEGER + ' arg AS STRING * 80 'similar to t + ' ret AS LONG 'the value it returns if it is a function (again like t) + ' END TYPE + g = GL_COMMANDS(c) + reginternalsubfunc = 1 + clearid + id.ccall = 1 '*** important for handling string returns correctly *** + id.n = RTRIM$(g.cn) + s = g.subfunc + id.subfunc = s + id.callname = RTRIM$(g.callname) + id.args = g.args + id.arg = g.arg + id.ret = g.ret + regid + reginternalsubfunc = 0 + NEXT + + 'add inline function definitions + + 'SUB gluPerspective (BYVAL fovy#, BYVAL aspect#, BYVAL zNear#, BYVAL zFar#) reginternalsubfunc = 1 clearid - id.ccall = 1 '*** important for handling string returns correctly *** - id.n = RTRIM$(g.cn) - s = g.subfunc - id.subfunc = s - id.callname = RTRIM$(g.callname) - id.args = g.args - id.arg = g.arg - id.ret = g.ret + id.n = "_gluPerspective" + id.subfunc = 2 'sub + id.callname = "gluPerspective" + id.args = 4 + id.arg = MKL$(DOUBLETYPE - ISPOINTER) + MKL$(DOUBLETYPE - ISPOINTER) + MKL$(DOUBLETYPE - ISPOINTER) + MKL$(DOUBLETYPE - ISPOINTER) regid reginternalsubfunc = 0 -NEXT - -'add inline function definitions - -'SUB gluPerspective (BYVAL fovy#, BYVAL aspect#, BYVAL zNear#, BYVAL zFar#) -reginternalsubfunc = 1 -clearid -id.n = "_gluPerspective" -id.subfunc = 2 'sub -id.callname = "gluPerspective" -id.args = 4 -id.arg = MKL$(DOUBLETYPE - ISPOINTER) + MKL$(DOUBLETYPE - ISPOINTER) + MKL$(DOUBLETYPE - ISPOINTER) + MKL$(DOUBLETYPE - ISPOINTER) -regid -reginternalsubfunc = 0 END SUB