mirror of
https://github.com/QB64Official/qb64.git
synced 2024-07-07 19:10:25 +00:00
25638 lines
1 MiB
25638 lines
1 MiB
'All variables will be of type LONG unless explicitly defined
|
|
DefLng A-Z
|
|
|
|
'All arrays will be dynamically allocated so they can be REDIM-ed
|
|
'$DYNAMIC
|
|
|
|
'We need console access to support command-line compilation via the -x command line compile option
|
|
$Console
|
|
|
|
'Initially the "SCREEN" will be hidden, if the -x option is used it will never be created
|
|
$ScreenHide
|
|
|
|
'$INCLUDE:'global\version.bas'
|
|
'$INCLUDE:'global\settings.bas'
|
|
'$INCLUDE:'global\constants.bas'
|
|
'$INCLUDE:'subs_functions\extensions\opengl\opengl_global.bas'
|
|
|
|
DefLng A-Z
|
|
|
|
'-------- Optional IDE Component (1/2) --------
|
|
'$INCLUDE:'ide\ide_global.bas'
|
|
|
|
ReDim Shared OName(1000) As String 'Operation Name
|
|
ReDim Shared PL(1000) As Integer 'Priority Level
|
|
ReDim Shared PP_TypeMod(0) As String, PP_ConvertedMod(0) As String 'Prepass Name Conversion variables.
|
|
Set_OrderOfOperations
|
|
|
|
ReDim EveryCaseSet(100), SelectCaseCounter As _Unsigned Long
|
|
ReDim SelectCaseHasCaseBlock(100)
|
|
Dim ExecLevel(255), ExecCounter As Integer
|
|
ReDim Shared UserDefine(1, 100) As String '0 element is the name, 1 element is the string value
|
|
ReDim Shared InValidLine(10000) As _Byte
|
|
Dim DefineElse(255) As _Byte
|
|
Dim Shared UserDefineCount As Integer
|
|
UserDefine(0, 0) = "WINDOWS": UserDefine(0, 1) = "WIN"
|
|
UserDefine(0, 2) = "LINUX"
|
|
UserDefine(0, 3) = "MAC": UserDefine(0, 4) = "MACOSX"
|
|
UserDefine(0, 5) = "32BIT": UserDefine(0, 6) = "64BIT"
|
|
UserDefine(0, 7) = "VERSION"
|
|
If InStr(_OS$, "WIN") Then UserDefine(1, 0) = "-1": UserDefine(1, 1) = "-1" Else UserDefine(1, 0) = "0": UserDefine(1, 1) = "0"
|
|
If InStr(_OS$, "LINUX") Then UserDefine(1, 2) = "-1" Else UserDefine(1, 2) = "0"
|
|
If InStr(_OS$, "MAC") Then UserDefine(1, 3) = "-1": UserDefine(1, 4) = "-1" Else UserDefine(1, 3) = "0": UserDefine(1, 4) = "0"
|
|
If InStr(_OS$, "32BIT") Then UserDefine(1, 5) = "-1": UserDefine(1, 6) = "0" Else UserDefine(1, 5) = "0": UserDefine(1, 6) = "-1"
|
|
UserDefine(1, 7) = Version$
|
|
|
|
Dim Shared QB64_uptime!
|
|
|
|
QB64_uptime! = Timer
|
|
|
|
NoInternalFolder:
|
|
If _DirExists("internal") = 0 Then
|
|
_ScreenShow
|
|
Print "QB64 cannot locate the 'internal' folder"
|
|
Print
|
|
Print "Check that QB64 has been extracted properly."
|
|
Print "For MacOSX, launch 'qb64_start.command' or enter './qb64' in Terminal."
|
|
Print "For Linux, in the console enter './qb64'."
|
|
Do
|
|
_Limit 1
|
|
Loop Until InKey$ <> ""
|
|
System 1
|
|
End If
|
|
|
|
Dim Shared Include_GDB_Debugging_Info 'set using "options.bin"
|
|
|
|
Dim Shared DEPENDENCY_LAST
|
|
Const DEPENDENCY_LOADFONT = 1: DEPENDENCY_LAST = DEPENDENCY_LAST + 1
|
|
Const DEPENDENCY_AUDIO_CONVERSION = 2: DEPENDENCY_LAST = DEPENDENCY_LAST + 1
|
|
Const DEPENDENCY_AUDIO_DECODE = 3: DEPENDENCY_LAST = DEPENDENCY_LAST + 1
|
|
Const DEPENDENCY_AUDIO_OUT = 4: DEPENDENCY_LAST = DEPENDENCY_LAST + 1
|
|
Const DEPENDENCY_GL = 5: DEPENDENCY_LAST = DEPENDENCY_LAST + 1
|
|
Const DEPENDENCY_IMAGE_CODEC = 6: DEPENDENCY_LAST = DEPENDENCY_LAST + 1
|
|
Const DEPENDENCY_CONSOLE_ONLY = 7: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 '=2 if via -g switch, =1 if via metacommand $CONSOLE:ONLY
|
|
Const DEPENDENCY_SOCKETS = 8: DEPENDENCY_LAST = DEPENDENCY_LAST + 1
|
|
Const DEPENDENCY_PRINTER = 9: DEPENDENCY_LAST = DEPENDENCY_LAST + 1
|
|
Const DEPENDENCY_ICON = 10: DEPENDENCY_LAST = DEPENDENCY_LAST + 1
|
|
Const DEPENDENCY_SCREENIMAGE = 11: DEPENDENCY_LAST = DEPENDENCY_LAST + 1
|
|
Const DEPENDENCY_DEVICEINPUT = 12: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 'removes support for gamepad input if not present
|
|
Const DEPENDENCY_ZLIB = 13: DEPENDENCY_LAST = DEPENDENCY_LAST + 1 'ZLIB library linkage, if desired, for compression/decompression.
|
|
|
|
|
|
|
|
Dim Shared DEPENDENCY(1 To DEPENDENCY_LAST)
|
|
|
|
Dim Shared UseGL 'declared SUB _GL (no params)
|
|
|
|
|
|
Dim Shared OS_BITS As Long, WindowTitle As String
|
|
OS_BITS = 64: If InStr(_OS$, "[32BIT]") Then OS_BITS = 32
|
|
|
|
If OS_BITS = 32 Then WindowTitle = "QB64 x32" Else WindowTitle = "QB64 x64"
|
|
_Title WindowTitle
|
|
|
|
Dim Shared ConsoleMode, No_C_Compile_Mode, NoIDEMode
|
|
Dim Shared ShowWarnings As _Byte, QuietMode As _Byte, CMDLineFile As String
|
|
Dim Shared MonochromeLoggingMode As _Byte
|
|
|
|
Type usedVarList
|
|
used As _Byte
|
|
linenumber As Long
|
|
includeLevel As Long
|
|
includedLine As Long
|
|
includedFile As String
|
|
cname As String
|
|
name As String
|
|
End Type
|
|
|
|
ReDim Shared usedVariableList(1000) As usedVarList, totalVariablesCreated As Long
|
|
Dim Shared bypassNextVariable As _Byte
|
|
Dim Shared totalWarnings As Long, warningListItems As Long, lastWarningHeader As String
|
|
Dim Shared duplicateConstWarning As _Byte, warningsissued As _Byte
|
|
Dim Shared emptySCWarning As _Byte
|
|
Dim Shared ExeIconSet As Long, qb64prefix$, qb64prefix_set
|
|
Dim Shared VersionInfoSet As _Byte
|
|
|
|
'Variables to handle $VERSIONINFO metacommand:
|
|
Dim Shared viFileVersionNum$, viProductVersionNum$, viCompanyName$
|
|
Dim Shared viFileDescription$, viFileVersion$, viInternalName$
|
|
Dim Shared viLegalCopyright$, viLegalTrademarks$, viOriginalFilename$
|
|
Dim Shared viProductName$, viProductVersion$, viComments$, viWeb$
|
|
|
|
Dim Shared NoChecks
|
|
|
|
Dim Shared Console
|
|
Dim Shared ScreenHide
|
|
Dim Shared Asserts
|
|
Dim Shared OptMax As Long
|
|
OptMax = 256
|
|
ReDim Shared Opt(1 To OptMax, 1 To 10) As String * 256
|
|
' (1,1)="READ"
|
|
' (1,2)="WRITE"
|
|
' (1,3)="READ WRITE"
|
|
ReDim Shared OptWords(1 To OptMax, 1 To 10) As Integer 'The number of words of each opt () element
|
|
' (1,1)=1 '"READ"
|
|
' (1,2)=1 '"WRITE"
|
|
' (1,3)=2 '"READ WRITE"
|
|
ReDim Shared T(1 To OptMax) As Integer 'The type of the entry
|
|
' t is 0 for ? opts
|
|
' ---------- 0 means ? , 1+ means a symbol or {}block ----------
|
|
' t is 1 for symbol opts
|
|
' t is the number of rhs opt () index enteries for {READ|WRITE|READ WRITE} like opts
|
|
ReDim Shared Lev(1 To OptMax) As Integer 'The indwelling level of each opt () element (the lowest is 0)
|
|
ReDim Shared EntryLev(1 To OptMax) As Integer 'The level required from which this opt () can be validly be entered/checked-for
|
|
ReDim Shared DitchLev(1 To OptMax) As Integer 'The lowest level recorded between the previous Opt and this Opt
|
|
ReDim Shared DontPass(1 To OptMax) As Integer 'Set to 1 or 0, with 1 meaning don't pass
|
|
'Determines whether the opt () entry needs to actually be passed to the C++ sub/function
|
|
ReDim Shared TempList(1 To OptMax) As Integer
|
|
ReDim Shared PassRule(1 To OptMax) As Long
|
|
'0 means no pass rule
|
|
'negative values refer to an opt () element
|
|
'positive values refer to a flag value
|
|
ReDim Shared LevelEntered(OptMax) 'up to 64 levels supported
|
|
ReDim Shared separgs(OptMax + 1) As String
|
|
ReDim Shared separgslayout(OptMax + 1) As String
|
|
ReDim Shared separgs2(OptMax + 1) As String
|
|
ReDim Shared separgslayout2(OptMax + 1) As String
|
|
|
|
|
|
|
|
|
|
|
|
Dim Shared E
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
Dim Shared ResolveStaticFunctions
|
|
ReDim Shared ResolveStaticFunction_File(1 To 100) As String
|
|
ReDim Shared ResolveStaticFunction_Name(1 To 100) As String
|
|
ReDim Shared ResolveStaticFunction_Method(1 To 100) As Long
|
|
|
|
|
|
|
|
|
|
|
|
Dim Shared Error_Happened As Long
|
|
Dim Shared Error_Message As String
|
|
|
|
Dim Shared os As String
|
|
os$ = "WIN"
|
|
If InStr(_OS$, "[LINUX]") Then os$ = "LNX"
|
|
|
|
Dim Shared MacOSX As Long
|
|
If InStr(_OS$, "[MACOSX]") Then MacOSX = 1
|
|
|
|
Dim Shared inline_DATA
|
|
If MacOSX Then inline_DATA = 1
|
|
|
|
Dim Shared BATCHFILE_EXTENSION As String
|
|
BATCHFILE_EXTENSION = ".bat"
|
|
If os$ = "LNX" Then BATCHFILE_EXTENSION = ".sh"
|
|
If MacOSX Then BATCHFILE_EXTENSION = ".command"
|
|
|
|
|
|
Dim inlinedatastr(255) As String
|
|
For i = 0 To 255
|
|
inlinedatastr(i) = str2$(i) + ","
|
|
Next
|
|
|
|
|
|
Dim Shared extension As String
|
|
Dim Shared path.exe$, path.source$, lastBinaryGenerated$
|
|
extension$ = ".exe"
|
|
If os$ = "LNX" Then extension$ = "" 'no extension under Linux
|
|
|
|
Dim Shared pathsep As String * 1
|
|
pathsep$ = "\"
|
|
If os$ = "LNX" Then pathsep$ = "/"
|
|
'note: QB64 handles OS specific path separators automatically except under SHELL calls
|
|
|
|
On Error GoTo qberror_test
|
|
|
|
Dim Shared tmpdir As String, tmpdir2 As String
|
|
If os$ = "WIN" Then tmpdir$ = ".\internal\temp\": tmpdir2$ = "..\\temp\\"
|
|
If os$ = "LNX" Then tmpdir$ = "./internal/temp/": tmpdir2$ = "../temp/"
|
|
|
|
If Not _DirExists(tmpdir$) Then MkDir tmpdir$
|
|
|
|
Declare Library
|
|
Function getpid& ()
|
|
End Declare
|
|
|
|
thisinstancepid = getpid&
|
|
Dim Shared tempfolderindex
|
|
|
|
If InStr(_OS$, "LINUX") Then
|
|
fh = FreeFile
|
|
Open ".\internal\temp\tempfoldersearch.bin" For Random As #fh Len = Len(tempfolderindex)
|
|
tempfolderrecords = LOF(fh) / Len(tempfolderindex)
|
|
i = 1
|
|
If tempfolderrecords = 0 Then
|
|
'first run ever?
|
|
Put #fh, 1, thisinstancepid
|
|
Else
|
|
For i = 1 To tempfolderrecords
|
|
'check if any of the temp folders is being used = pid still active
|
|
Get #fh, i, tempfoldersearch
|
|
|
|
Shell _Hide "ps -p " + Str$(tempfoldersearch) + " > /dev/null 2>&1; echo $? > internal/temp/checkpid.bin"
|
|
fh2 = FreeFile
|
|
Open "internal/temp/checkpid.bin" For Binary As #fh2
|
|
Line Input #fh2, checkpid$
|
|
Close #fh2
|
|
If Val(checkpid$) = 1 Then
|
|
'This temp folder was locked by an instance that's no longer active, so
|
|
'this will be our temp folder
|
|
Put #fh, i, thisinstancepid
|
|
Exit For
|
|
End If
|
|
Next
|
|
If i > tempfolderrecords Then
|
|
'All indexes were busy. Let's initiate a new one:
|
|
Put #fh, i, thisinstancepid
|
|
End If
|
|
End If
|
|
Close #fh
|
|
If i > 1 Then
|
|
tmpdir$ = "./internal/temp" + str2$(i) + "/": tmpdir2$ = "../temp" + str2$(i) + "/"
|
|
If _DirExists(tmpdir$) = 0 Then
|
|
MkDir tmpdir$
|
|
End If
|
|
End If
|
|
Open tmpdir$ + "temp.bin" For Output Lock Write As #26
|
|
Else
|
|
On Error GoTo qberror_test
|
|
E = 0
|
|
i = 1
|
|
Open tmpdir$ + "temp.bin" For Output Lock Write As #26
|
|
Do While E
|
|
i = i + 1
|
|
If i = 1000 Then Print "Unable to locate the 'internal' folder": End 1
|
|
MkDir ".\internal\temp" + str2$(i)
|
|
If os$ = "WIN" Then tmpdir$ = ".\internal\temp" + str2$(i) + "\": tmpdir2$ = "..\\temp" + str2$(i) + "\\"
|
|
If os$ = "LNX" Then tmpdir$ = "./internal/temp" + str2$(i) + "/": tmpdir2$ = "../temp" + str2$(i) + "/"
|
|
E = 0
|
|
Open tmpdir$ + "temp.bin" For Output Lock Write As #26
|
|
Loop
|
|
End If
|
|
|
|
|
|
'temp folder established
|
|
tempfolderindex = i
|
|
If i > 1 Then
|
|
'create modified version of qbx.cpp
|
|
Open ".\internal\c\qbx" + str2$(i) + ".cpp" For Output As #2
|
|
Open ".\internal\c\qbx.cpp" For Binary As #1
|
|
Do Until EOF(1)
|
|
Line Input #1, a$
|
|
x = InStr(a$, "..\\temp\\"): If x Then a$ = Left$(a$, x - 1) + "..\\temp" + str2$(i) + "\\" + Right$(a$, Len(a$) - (x + 9))
|
|
x = InStr(a$, "../temp/"): If x Then a$ = Left$(a$, x - 1) + "../temp" + str2$(i) + "/" + Right$(a$, Len(a$) - (x + 7))
|
|
Print #2, a$
|
|
Loop
|
|
Close #1, #2
|
|
End If
|
|
|
|
If Debug Then Open tmpdir$ + "debug.txt" For Output As #9
|
|
|
|
On Error GoTo qberror
|
|
|
|
|
|
|
|
Dim Shared tempfolderindexstr As String 'appended to "Untitled"
|
|
Dim Shared tempfolderindexstr2 As String
|
|
If tempfolderindex <> 1 Then tempfolderindexstr$ = "(" + str2$(tempfolderindex) + ")": tempfolderindexstr2$ = str2$(tempfolderindex)
|
|
|
|
|
|
Dim Shared idedebuginfo
|
|
Dim Shared seperateargs_error
|
|
Dim Shared seperateargs_error_message As String
|
|
|
|
Dim Shared compfailed
|
|
|
|
Dim Shared reginternalsubfunc
|
|
Dim Shared reginternalvariable
|
|
|
|
|
|
Dim Shared symboltype_size
|
|
symboltype_size = 0
|
|
|
|
Dim Shared use_global_byte_elements
|
|
use_global_byte_elements = 0
|
|
|
|
'compiler-side IDE data & definitions
|
|
'SHARED variables "passed" to/from the compiler & IDE
|
|
Dim Shared idecommand As String 'a 1 byte message-type code, followed by optional string data
|
|
Dim Shared idereturn As String 'used to pass formatted-lines and return information back to the IDE
|
|
Dim Shared ideerror As Long
|
|
Dim Shared idecompiled As Long
|
|
Dim Shared idemode '1 if using the IDE to compile
|
|
Dim Shared ideerrorline As Long 'set by qb64-error(...) to the line number it would have reported, this number
|
|
'is later passed to the ide in message #8
|
|
Dim Shared idemessage As String 'set by qb64-error(...) to the error message to be reported, this
|
|
'is later passed to the ide in message #8
|
|
|
|
Dim Shared optionexplicit As _Byte
|
|
Dim Shared optionexplicitarray As _Byte
|
|
Dim Shared optionexplicit_cmd As _Byte
|
|
Dim Shared ideStartAtLine As Long, errorLineInInclude As Long
|
|
Dim Shared warningInInclude As Long, warningInIncludeLine As Long
|
|
Dim Shared outputfile_cmd$
|
|
Dim Shared compilelog$
|
|
|
|
'$INCLUDE:'global\IDEsettings.bas'
|
|
|
|
CMDLineFile = ParseCMDLineArgs$
|
|
|
|
If ConsoleMode Then
|
|
_Dest _Console
|
|
Else
|
|
_Console Off
|
|
_ScreenShow
|
|
_Icon
|
|
End If
|
|
|
|
'the function ?=ide(?) should always be passed 0, it returns a message code number, any further information
|
|
'is passed back in idereturn
|
|
|
|
'message code numbers:
|
|
'0 no ide present (auto defined array ide() return 0)
|
|
|
|
'1 launch ide & with passed filename (compiler->ide)
|
|
|
|
'2 begin new compilation with returned line of code (compiler<-ide)
|
|
' [2][line of code]
|
|
|
|
'3 request next line (compiler->ide)
|
|
' [3]
|
|
|
|
'4 next line of code returned (compiler<-ide)
|
|
' [4][line of code]
|
|
|
|
'5 no more lines of code exist (compiler<-ide)
|
|
' [5]
|
|
|
|
'6 code is OK/ready (compiler->ide)
|
|
' [6]
|
|
|
|
'7 repass the code from the beginning (compiler->ide)
|
|
' [7]
|
|
|
|
'8 an error has occurred with 'this' message on 'this' line(compiler->ide)
|
|
' [8][error message][line as LONG]
|
|
|
|
'9 C++ compile (if necessary) and run with 'this' name (compiler<-ide)
|
|
' [9][name(no path, no .bas)]
|
|
|
|
'10 The line requires more time to process
|
|
' Pass-back 'line of code' using method [4] when ready
|
|
' [10][line of code]
|
|
|
|
'11 ".EXE file created" message
|
|
|
|
'12 The name of the exe I'll create is '...' (compiler->ide)
|
|
' [12][exe name without .exe]
|
|
|
|
'255 A qb error happened in the IDE (compiler->ide)
|
|
' note: detected by the fact that ideerror was not set to 0
|
|
' [255]
|
|
|
|
'hash table data
|
|
Type HashListItem
|
|
Flags As Long
|
|
Reference As Long
|
|
NextItem As Long
|
|
PrevItem As Long
|
|
LastItem As Long 'note: this value is only valid on the first item in the list
|
|
'note: name is stored in a seperate array of strings
|
|
End Type
|
|
Dim Shared HashFind_NextListItem As Long
|
|
Dim Shared HashFind_Reverse As Long
|
|
Dim Shared HashFind_SearchFlags As Long
|
|
Dim Shared HashFind_Name As String
|
|
Dim Shared HashRemove_LastFound As Long
|
|
Dim Shared HashListSize As Long
|
|
Dim Shared HashListNext As Long
|
|
Dim Shared HashListFreeSize As Long
|
|
Dim Shared HashListFreeLast As Long
|
|
'hash lookup tables
|
|
Dim Shared hash1char(255) As Integer
|
|
Dim Shared hash2char(65535) As Integer
|
|
For x = 1 To 26
|
|
hash1char(64 + x) = x
|
|
hash1char(96 + x) = x
|
|
Next
|
|
hash1char(95) = 27 '_
|
|
hash1char(48) = 28 '0
|
|
hash1char(49) = 29 '1
|
|
hash1char(50) = 30 '2
|
|
hash1char(51) = 31 '3
|
|
hash1char(52) = 23 '4 'note: x, y, z and beginning alphabet letters avoided because of common usage (eg. a2, y3)
|
|
hash1char(53) = 22 '5
|
|
hash1char(54) = 20 '6
|
|
hash1char(55) = 19 '7
|
|
hash1char(56) = 18 '8
|
|
hash1char(57) = 17 '9
|
|
For c1 = 0 To 255
|
|
For c2 = 0 To 255
|
|
hash2char(c1 + c2 * 256) = hash1char(c1) + hash1char(c2) * 32
|
|
Next
|
|
Next
|
|
'init
|
|
HashListSize = 65536
|
|
HashListNext = 1
|
|
HashListFreeSize = 1024
|
|
HashListFreeLast = 0
|
|
ReDim Shared HashList(1 To HashListSize) As HashListItem
|
|
ReDim Shared HashListName(1 To HashListSize) As String * 256
|
|
ReDim Shared HashListFree(1 To HashListFreeSize) As Long
|
|
ReDim Shared HashTable(16777215) As Long '64MB lookup table with indexes to the hashlist
|
|
|
|
Const HASHFLAG_LABEL = 2
|
|
Const HASHFLAG_TYPE = 4
|
|
Const HASHFLAG_RESERVED = 8
|
|
Const HASHFLAG_OPERATOR = 16
|
|
Const HASHFLAG_CUSTOMSYNTAX = 32
|
|
Const HASHFLAG_SUB = 64
|
|
Const HASHFLAG_FUNCTION = 128
|
|
Const HASHFLAG_UDT = 256
|
|
Const HASHFLAG_UDTELEMENT = 512
|
|
Const HASHFLAG_CONSTANT = 1024
|
|
Const HASHFLAG_VARIABLE = 2048
|
|
Const HASHFLAG_ARRAY = 4096
|
|
Const HASHFLAG_XELEMENTNAME = 8192
|
|
Const HASHFLAG_XTYPENAME = 16384
|
|
|
|
Type Label_Type
|
|
State As _Unsigned _Byte '0=label referenced, 1=label created
|
|
cn As String * 256
|
|
Scope As Long
|
|
Data_Offset As _Integer64 'offset within data
|
|
Data_Referenced As _Unsigned _Byte 'set to 1 if data is referenced (data_offset will be used to create the data offset variable)
|
|
Error_Line As Long 'the line number to reference on errors
|
|
Scope_Restriction As Long 'cannot exist inside this scope (post checked)
|
|
SourceLineNumber As Long
|
|
End Type
|
|
Dim Shared nLabels, Labels_Ubound
|
|
Labels_Ubound = 100
|
|
ReDim Shared Labels(1 To Labels_Ubound) As Label_Type
|
|
Dim Shared Empty_Label As Label_Type
|
|
|
|
Dim Shared PossibleSubNameLabels As String 'format: name+sp+name+sp+name <-ucase$'d
|
|
Dim Shared SubNameLabels As String 'format: name+sp+name+sp+name <-ucase$'d
|
|
Dim Shared CreatingLabel As Long
|
|
|
|
Dim Shared AllowLocalName As Long
|
|
|
|
Dim Shared DataOffset
|
|
|
|
Dim Shared prepass
|
|
|
|
|
|
Dim Shared autoarray
|
|
|
|
Dim Shared ontimerid, onkeyid, onstrigid
|
|
|
|
Dim Shared revertmaymusthave(1 To 10000)
|
|
Dim Shared revertmaymusthaven
|
|
|
|
Dim Shared linecontinuation
|
|
|
|
Dim Shared dim2typepassback As String 'passes back correct case sensitive version of type
|
|
|
|
|
|
Dim Shared inclevel
|
|
Dim Shared incname(100) As String 'must be full path as given
|
|
Dim Shared inclinenumber(100) As Long
|
|
Dim Shared incerror As String
|
|
|
|
|
|
Dim Shared fix046 As String
|
|
fix046$ = "__" + "ASCII" + "_" + "CHR" + "_" + "046" + "__" 'broken up to avoid detection for layout reversion
|
|
|
|
Dim Shared layout As String 'passed to IDE
|
|
Dim Shared layoutok As Long 'tracks status of entire line
|
|
|
|
Dim Shared layoutcomment As String
|
|
|
|
Dim Shared tlayout As String 'temporary layout string set by supporting functions
|
|
Dim Shared layoutdone As Long 'tracks status of single command
|
|
|
|
|
|
Dim Shared fooindwel
|
|
|
|
Dim Shared alphanumeric(255)
|
|
For i = 48 To 57
|
|
alphanumeric(i) = -1
|
|
Next
|
|
For i = 65 To 90
|
|
alphanumeric(i) = -1
|
|
Next
|
|
For i = 97 To 122
|
|
alphanumeric(i) = -1
|
|
Next
|
|
'_ is treated as an alphabet letter
|
|
alphanumeric(95) = -1
|
|
|
|
Dim Shared isalpha(255)
|
|
For i = 65 To 90
|
|
isalpha(i) = -1
|
|
Next
|
|
For i = 97 To 122
|
|
isalpha(i) = -1
|
|
Next
|
|
'_ is treated as an alphabet letter
|
|
isalpha(95) = -1
|
|
|
|
Dim Shared isnumeric(255)
|
|
For i = 48 To 57
|
|
isnumeric(i) = -1
|
|
Next
|
|
|
|
|
|
Dim Shared lfsinglechar(255)
|
|
lfsinglechar(40) = 1 '(
|
|
lfsinglechar(41) = 1 ')
|
|
lfsinglechar(42) = 1 '*
|
|
lfsinglechar(43) = 1 '+
|
|
lfsinglechar(45) = 1 '-
|
|
lfsinglechar(47) = 1 '/
|
|
lfsinglechar(60) = 1 '<
|
|
lfsinglechar(61) = 1 '=
|
|
lfsinglechar(62) = 1 '>
|
|
lfsinglechar(92) = 1 '\
|
|
lfsinglechar(94) = 1 '^
|
|
|
|
lfsinglechar(44) = 1 ',
|
|
lfsinglechar(46) = 1 '.
|
|
lfsinglechar(58) = 1 ':
|
|
lfsinglechar(59) = 1 ';
|
|
|
|
lfsinglechar(35) = 1 '# (file no only)
|
|
lfsinglechar(36) = 1 '$ (metacommand only)
|
|
lfsinglechar(63) = 1 '? (print macro)
|
|
lfsinglechar(95) = 1 '_
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
Dim Shared nextrunlineindex As Long
|
|
|
|
Dim Shared lineinput3buffer As String
|
|
Dim Shared lineinput3index As Long
|
|
|
|
Dim Shared dimstatic As Long
|
|
|
|
Dim Shared staticarraylist As String
|
|
Dim Shared staticarraylistn As Long
|
|
Dim Shared commonarraylist As String
|
|
Dim Shared commonarraylistn As Long
|
|
|
|
'CONST support
|
|
Dim Shared constmax As Long
|
|
constmax = 100
|
|
Dim Shared constlast As Long
|
|
constlast = -1
|
|
ReDim Shared constname(constmax) As String
|
|
ReDim Shared constcname(constmax) As String
|
|
ReDim Shared constnamesymbol(constmax) As String 'optional name symbol
|
|
' `1 and `no-number must be handled correctly
|
|
'DIM SHARED constlastshared AS LONG 'so any defined inside a sub/function after this index can be "forgotten" when sub/function exits
|
|
'constlastshared = -1
|
|
ReDim Shared consttype(constmax) As Long 'variable type number
|
|
'consttype determines storage
|
|
ReDim Shared constinteger(constmax) As _Integer64
|
|
ReDim Shared constuinteger(constmax) As _Unsigned _Integer64
|
|
ReDim Shared constfloat(constmax) As _Float
|
|
ReDim Shared conststring(constmax) As String
|
|
ReDim Shared constsubfunc(constmax) As Long
|
|
ReDim Shared constdefined(constmax) As Long
|
|
|
|
'UDT
|
|
'names
|
|
Dim Shared lasttype As Long
|
|
Dim Shared udtxname(1000) As String * 256
|
|
Dim Shared udtxcname(1000) As String * 256
|
|
Dim Shared udtxsize(1000) As Long
|
|
Dim Shared udtxbytealign(1000) As Integer 'first element MUST be on a byte alignment & size is a multiple of 8
|
|
Dim Shared udtxnext(1000) As Long
|
|
Dim Shared udtxvariable(1000) As Integer 'true if the udt contains variable length elements
|
|
'elements
|
|
Dim Shared lasttypeelement As Long
|
|
Dim Shared udtename(1000) As String * 256
|
|
Dim Shared udtecname(1000) As String * 256
|
|
Dim Shared udtebytealign(1000) As Integer
|
|
Dim Shared udtesize(1000) As Long
|
|
Dim Shared udtetype(1000) As Long
|
|
Dim Shared udtetypesize(1000) As Long
|
|
Dim Shared udtearrayelements(1000) As Long
|
|
Dim Shared udtenext(1000) As Long
|
|
|
|
Type idstruct
|
|
|
|
n As String * 256 'name
|
|
cn As String * 256 'case sensitive version of n
|
|
|
|
arraytype As Long 'similar to t
|
|
arrayelements As Integer
|
|
staticarray As Integer 'set for arrays declared in the main module with static elements
|
|
|
|
mayhave As String * 8 'mayhave and musthave are exclusive of each other
|
|
musthave As String * 8
|
|
t As Long 'type
|
|
|
|
tsize As Long
|
|
|
|
|
|
subfunc As Integer 'if function=1, sub=2 (max 100 arguments)
|
|
Dependency As Integer
|
|
internal_subfunc As Integer
|
|
|
|
callname As String * 256
|
|
ccall As Integer
|
|
overloaded As _Byte
|
|
args As Integer
|
|
minargs As Integer
|
|
arg As String * 400 'similar to t
|
|
argsize As String * 400 'similar to tsize (used for fixed length strings)
|
|
specialformat As String * 256
|
|
secondargmustbe As String * 256
|
|
secondargcantbe As String * 256
|
|
ret As Long 'the value it returns if it is a function (again like t)
|
|
|
|
insubfunc As String * 256
|
|
insubfuncn As Long
|
|
|
|
share As Integer
|
|
nele As String * 100
|
|
nelereq As String * 100
|
|
linkid As Long
|
|
linkarg As Integer
|
|
staticscope As Integer
|
|
'For variables which are arguments passed to a sub/function
|
|
sfid As Long 'id number of variable's parent sub/function
|
|
sfarg As Integer 'argument/parameter # within call (1=first)
|
|
End Type
|
|
|
|
Dim Shared id As idstruct
|
|
|
|
Dim Shared idn As Long
|
|
Dim Shared ids_max As Long
|
|
ids_max = 1024
|
|
ReDim Shared ids(1 To ids_max) As idstruct
|
|
ReDim Shared cmemlist(1 To ids_max + 1) As Integer 'variables that must be in cmem
|
|
ReDim Shared sfcmemargs(1 To ids_max + 1) As String * 100 's/f arg that must be in cmem
|
|
ReDim Shared arrayelementslist(1 To ids_max + 1) As Integer 'arrayelementslist (like cmemlist) helps to resolve the number of elements in arrays with an unknown number of elements. Note: arrays with an unknown number of elements have .arrayelements=-1
|
|
|
|
|
|
'create blank id template for idclear to copy (stops strings being set to chr$(0))
|
|
Dim Shared cleariddata As idstruct
|
|
cleariddata.cn = ""
|
|
cleariddata.n = ""
|
|
cleariddata.mayhave = ""
|
|
cleariddata.musthave = ""
|
|
cleariddata.callname = ""
|
|
cleariddata.arg = ""
|
|
cleariddata.argsize = ""
|
|
cleariddata.specialformat = ""
|
|
cleariddata.secondargmustbe = ""
|
|
cleariddata.secondargcantbe = ""
|
|
cleariddata.insubfunc = ""
|
|
cleariddata.nele = ""
|
|
cleariddata.nelereq = ""
|
|
|
|
Dim Shared ISSTRING As Long
|
|
Dim Shared ISFLOAT As Long
|
|
Dim Shared ISUNSIGNED As Long
|
|
Dim Shared ISPOINTER As Long
|
|
Dim Shared ISFIXEDLENGTH As Long
|
|
Dim Shared ISINCONVENTIONALMEMORY As Long
|
|
Dim Shared ISOFFSETINBITS As Long
|
|
Dim Shared ISARRAY As Long
|
|
Dim Shared ISREFERENCE As Long
|
|
Dim Shared ISUDT As Long
|
|
Dim Shared ISOFFSET As Long
|
|
|
|
Dim Shared STRINGTYPE As Long
|
|
Dim Shared BITTYPE As Long
|
|
Dim Shared UBITTYPE As Long
|
|
Dim Shared BYTETYPE As Long
|
|
Dim Shared UBYTETYPE As Long
|
|
Dim Shared INTEGERTYPE As Long
|
|
Dim Shared UINTEGERTYPE As Long
|
|
Dim Shared LONGTYPE As Long
|
|
Dim Shared ULONGTYPE As Long
|
|
Dim Shared INTEGER64TYPE As Long
|
|
Dim Shared UINTEGER64TYPE As Long
|
|
Dim Shared SINGLETYPE As Long
|
|
Dim Shared DOUBLETYPE As Long
|
|
Dim Shared FLOATTYPE As Long
|
|
Dim Shared OFFSETTYPE As Long
|
|
Dim Shared UOFFSETTYPE As Long
|
|
Dim Shared UDTTYPE As Long
|
|
|
|
Dim Shared gosubid As Long
|
|
Dim Shared redimoption As Integer
|
|
Dim Shared dimoption As Integer
|
|
Dim Shared arraydesc As Integer
|
|
Dim Shared qberrorhappened As Integer
|
|
Dim Shared qberrorcode As Integer
|
|
Dim Shared qberrorline As Integer
|
|
'COMMON SHARED defineaz() AS STRING
|
|
'COMMON SHARED defineextaz() AS STRING
|
|
|
|
Dim Shared sourcefile As String 'the full path and filename
|
|
Dim Shared file As String 'name of the file (without .bas or path)
|
|
|
|
'COMMON SHARED separgs() AS STRING
|
|
|
|
Dim Shared constequation As Integer
|
|
Dim Shared DynamicMode As Integer
|
|
Dim Shared findidsecondarg As String
|
|
Dim Shared findanotherid As Integer
|
|
Dim Shared findidinternal As Long
|
|
Dim Shared currentid As Long 'is the index of the last ID accessed
|
|
Dim Shared linenumber As Long, reallinenumber As Long, totallinenumber As Long
|
|
Dim Shared wholeline As String
|
|
Dim Shared linefragment As String
|
|
'COMMON SHARED bitmask() AS _INTEGER64
|
|
'COMMON SHARED bitmaskinv() AS _INTEGER64
|
|
|
|
Dim Shared arrayprocessinghappened As Integer
|
|
Dim Shared stringprocessinghappened As Integer
|
|
Dim Shared cleanupstringprocessingcall As String
|
|
Dim Shared recompile As Integer 'forces recompilation
|
|
'COMMON SHARED cmemlist() AS INTEGER
|
|
Dim Shared optionbase As Integer
|
|
|
|
Dim Shared addmetastatic As Integer
|
|
Dim Shared addmetadynamic As Integer
|
|
Dim Shared addmetainclude As String
|
|
|
|
Dim Shared closedmain As Integer
|
|
Dim Shared module As String
|
|
|
|
Dim Shared subfunc As String
|
|
Dim Shared subfuncn As Long
|
|
Dim Shared subfuncid As Long
|
|
|
|
Dim Shared defdatahandle As Integer
|
|
Dim Shared dimsfarray As Integer
|
|
Dim Shared dimshared As Integer
|
|
|
|
'Allows passing of known elements to recompilation
|
|
Dim Shared sflistn As Integer
|
|
'COMMON SHARED sfidlist() AS LONG
|
|
'COMMON SHARED sfarglist() AS INTEGER
|
|
'COMMON SHARED sfelelist() AS INTEGER
|
|
Dim Shared glinkid As Long
|
|
Dim Shared glinkarg As Integer
|
|
Dim Shared typname2typsize As Long
|
|
Dim Shared uniquenumbern As Long
|
|
|
|
'CLEAR , , 16384
|
|
|
|
|
|
Dim Shared bitmask(1 To 56) As _Integer64
|
|
Dim Shared bitmaskinv(1 To 56) As _Integer64
|
|
|
|
Dim Shared defineextaz(1 To 27) As String
|
|
Dim Shared defineaz(1 To 27) As String '27 is an underscore
|
|
|
|
ISSTRING = 1073741824
|
|
ISFLOAT = 536870912
|
|
ISUNSIGNED = 268435456
|
|
ISPOINTER = 134217728
|
|
ISFIXEDLENGTH = 67108864 'only set for strings with pointer flag
|
|
ISINCONVENTIONALMEMORY = 33554432
|
|
ISOFFSETINBITS = 16777216
|
|
ISARRAY = 8388608
|
|
ISREFERENCE = 4194304
|
|
ISUDT = 2097152
|
|
ISOFFSET = 1048576
|
|
|
|
STRINGTYPE = ISSTRING + ISPOINTER
|
|
BITTYPE = 1& + ISPOINTER + ISOFFSETINBITS
|
|
UBITTYPE = 1& + ISPOINTER + ISUNSIGNED + ISOFFSETINBITS 'QB64 will also support BIT*n, eg. DIM bitarray[10] AS _UNSIGNED _BIT*10
|
|
BYTETYPE = 8& + ISPOINTER
|
|
UBYTETYPE = 8& + ISPOINTER + ISUNSIGNED
|
|
INTEGERTYPE = 16& + ISPOINTER
|
|
UINTEGERTYPE = 16& + ISPOINTER + ISUNSIGNED
|
|
LONGTYPE = 32& + ISPOINTER
|
|
ULONGTYPE = 32& + ISPOINTER + ISUNSIGNED
|
|
INTEGER64TYPE = 64& + ISPOINTER
|
|
UINTEGER64TYPE = 64& + ISPOINTER + ISUNSIGNED
|
|
SINGLETYPE = 32& + ISFLOAT + ISPOINTER
|
|
DOUBLETYPE = 64& + ISFLOAT + ISPOINTER
|
|
FLOATTYPE = 256& + ISFLOAT + ISPOINTER '8-32 bytes
|
|
OFFSETTYPE = 64& + ISOFFSET + ISPOINTER: If OS_BITS = 32 Then OFFSETTYPE = 32& + ISOFFSET + ISPOINTER
|
|
UOFFSETTYPE = 64& + ISOFFSET + ISUNSIGNED + ISPOINTER: If OS_BITS = 32 Then UOFFSETTYPE = 32& + ISOFFSET + ISUNSIGNED + ISPOINTER
|
|
UDTTYPE = ISUDT + ISPOINTER
|
|
|
|
|
|
|
|
|
|
|
|
|
|
Dim Shared statementn As Long
|
|
Dim Shared everycasenewcase As Long
|
|
|
|
|
|
|
|
|
|
Dim controllevel As Integer '0=not in a control block
|
|
Dim controltype(1000) As Integer
|
|
'1=IF (awaiting END IF)
|
|
'2=FOR (awaiting NEXT)
|
|
'3=DO (awaiting LOOP [UNTIL|WHILE param])
|
|
'4=DO WHILE/UNTIL (awaiting LOOP)
|
|
'5=WHILE (awaiting WEND)
|
|
'6=$IF (precompiler)
|
|
'10=SELECT CASE qbs (awaiting END SELECT/CASE)
|
|
'11=SELECT CASE int64 (awaiting END SELECT/CASE)
|
|
'12=SELECT CASE uint64 (awaiting END SELECT/CASE)
|
|
'13=SELECT CASE LONG double (awaiting END SELECT/CASE/CASE ELSE)
|
|
'14=SELECT CASE float ...
|
|
'15=SELECT CASE double
|
|
'16=SELECT CASE int32
|
|
'17=SELECT CASE uint32
|
|
'18=CASE (awaiting END SELECT/CASE/CASE ELSE)
|
|
'19=CASE ELSE (awaiting END SELECT)
|
|
'32=SUB/FUNCTION (awaiting END SUB/FUNCTION)
|
|
Dim controlid(1000) As Long
|
|
Dim controlvalue(1000) As Long
|
|
Dim controlstate(1000) As Integer
|
|
Dim controlref(1000) As Long 'the line number the control was created on
|
|
|
|
|
|
|
|
|
|
|
|
On Error GoTo qberror
|
|
|
|
i2&& = 1
|
|
For i&& = 1 To 56
|
|
bitmask(i&&) = i2&&
|
|
bitmaskinv(i&&) = Not i2&&
|
|
i2&& = i2&& + 2 ^ i&&
|
|
Next
|
|
|
|
Dim id2 As idstruct
|
|
|
|
cleanupstringprocessingcall$ = "qbs_cleanup(qbs_tmp_base,"
|
|
|
|
Dim Shared sfidlist(1000) As Long
|
|
Dim Shared sfarglist(1000) As Integer
|
|
Dim Shared sfelelist(1000) As Integer
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
'----------------ripgl.bas--------------------------------------------------------------------------------
|
|
gl_scan_header
|
|
'----------------ripgl.bas--------------------------------------------------------------------------------
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
'-----------------------QB64 COMPILER ONCE ONLY SETUP CODE ENDS HERE---------------------------------------
|
|
|
|
If NoIDEMode Then IDE_AutoPosition = 0: GoTo noide
|
|
Dim FileDropEnabled As _Byte
|
|
If FileDropEnabled = 0 Then FileDropEnabled = -1: _AcceptFileDrop
|
|
|
|
If IDE_AutoPosition And Not IDE_BypassAutoPosition Then _ScreenMove IDE_LeftPosition, IDE_TopPosition
|
|
idemode = 1
|
|
sendc$ = "" 'no initial message
|
|
If CMDLineFile <> "" Then sendc$ = Chr$(1) + CMDLineFile
|
|
sendcommand:
|
|
idecommand$ = sendc$
|
|
C = ide(0)
|
|
ideerror = 0
|
|
If C = 0 Then idemode = 0: GoTo noide
|
|
c$ = idereturn$
|
|
|
|
If C = 2 Then 'begin
|
|
ideerrorline = 0 'addresses invalid prepass error line numbers being reported
|
|
idepass = 1
|
|
GoTo fullrecompile
|
|
ideret1:
|
|
wholeline$ = c$
|
|
GoTo ideprepass
|
|
ideret2:
|
|
If lastLineReturn Then GoTo lastLineReturn
|
|
sendc$ = Chr$(3) 'request next line
|
|
GoTo sendcommand
|
|
End If
|
|
|
|
If C = 4 Then 'next line
|
|
If idepass = 1 Then
|
|
wholeline$ = c$
|
|
GoTo ideprepass
|
|
'(returns to ideret2: above)
|
|
End If
|
|
'assume idepass>1
|
|
a3$ = c$
|
|
continuelinefrom = 0
|
|
GoTo ide4
|
|
ideret4:
|
|
If lastLineReturn Then GoTo lastLineReturn
|
|
sendc$ = Chr$(3) 'request next line
|
|
GoTo sendcommand
|
|
End If
|
|
|
|
If C = 5 Then 'end of program reached
|
|
|
|
lastLine = 1
|
|
lastLineReturn = 1
|
|
If idepass = 1 Then
|
|
wholeline$ = ""
|
|
GoTo ideprepass
|
|
'(returns to ideret2: above, then to lastLinePrepassReturn below)
|
|
End If
|
|
'idepass>1
|
|
a3$ = ""
|
|
continuelinefrom = 0
|
|
GoTo ide4 'returns to ideret4, then to lastLinePrepassReturn below
|
|
lastLineReturn:
|
|
lastLineReturn = 0
|
|
lastLine = 0
|
|
|
|
If idepass = 1 Then
|
|
'prepass complete
|
|
idepass = 2
|
|
GoTo ide3
|
|
ideret3:
|
|
sendc$ = Chr$(7) 'repass request
|
|
firstLine = 1
|
|
GoTo sendcommand
|
|
End If
|
|
'assume idepass=2
|
|
'finalize program
|
|
GoTo ide5
|
|
ideret5: 'note: won't return here if a recompile was required!
|
|
sendc$ = Chr$(6) 'ready
|
|
idecompiled = 0
|
|
GoTo sendcommand
|
|
End If
|
|
|
|
If C = 9 Then 'run
|
|
|
|
If idecompiled = 0 Then 'exe needs to be compiled
|
|
file$ = c$
|
|
|
|
'locate accessible file and truncate
|
|
f$ = file$
|
|
|
|
path.exe$ = ""
|
|
If SaveExeWithSource Then
|
|
If Len(ideprogname) Then path.exe$ = idepath$ + pathsep$
|
|
End If
|
|
|
|
i = 1
|
|
nextexeindex:
|
|
If _FileExists(path.exe$ + file$ + extension$) Then
|
|
E = 0
|
|
On Error GoTo qberror_test
|
|
Kill path.exe$ + file$ + extension$
|
|
On Error GoTo qberror
|
|
If E = 1 Then
|
|
i = i + 1
|
|
file$ = f$ + "(" + str2$(i) + ")"
|
|
GoTo nextexeindex
|
|
End If
|
|
End If
|
|
|
|
If path.exe$ = "" Then
|
|
If InStr(_OS$, "WIN") Then path.exe$ = "..\..\" Else path.exe$ = "../../"
|
|
End If
|
|
|
|
'inform IDE of name change if necessary (IDE will respond with message 9 and corrected name)
|
|
If i <> 1 Then
|
|
sendc$ = Chr$(12) + file$
|
|
GoTo sendcommand
|
|
End If
|
|
|
|
ideerrorline = 0 'addresses C++ comp. error's line number
|
|
GoTo ide6
|
|
ideret6:
|
|
idecompiled = 1
|
|
End If
|
|
|
|
If iderunmode = 2 Then
|
|
sendc$ = Chr$(11) '.EXE file created
|
|
GoTo sendcommand
|
|
End If
|
|
|
|
'execute program
|
|
|
|
If iderunmode = 1 Then
|
|
If os$ = "WIN" Then Shell _DontWait QuotedFilename$(Chr$(34) + lastBinaryGenerated$ + Chr$(34)) + ModifyCOMMAND$
|
|
If path.exe$ = "" Then path.exe$ = "./"
|
|
If os$ = "LNX" Then
|
|
If Left$(lastBinaryGenerated$, Len(path.exe$)) = path.exe$ Then
|
|
Shell _DontWait QuotedFilename$(lastBinaryGenerated$) + ModifyCOMMAND$
|
|
Else
|
|
Shell _DontWait QuotedFilename$(path.exe$ + lastBinaryGenerated$) + ModifyCOMMAND$
|
|
End If
|
|
End If
|
|
If path.exe$ = "./" Then path.exe$ = ""
|
|
Else
|
|
If os$ = "WIN" Then Shell QuotedFilename$(Chr$(34) + lastBinaryGenerated$ + Chr$(34)) + ModifyCOMMAND$
|
|
If path.exe$ = "" Then path.exe$ = "./"
|
|
If os$ = "LNX" Then
|
|
If Left$(lastBinaryGenerated$, Len(path.exe$)) = path.exe$ Then
|
|
Shell QuotedFilename$(lastBinaryGenerated$) + ModifyCOMMAND$
|
|
Else
|
|
Shell QuotedFilename$(path.exe$ + lastBinaryGenerated$) + ModifyCOMMAND$
|
|
End If
|
|
End If
|
|
If path.exe$ = "./" Then path.exe$ = ""
|
|
Do: Loop Until InKey$ = ""
|
|
Do: Loop Until _KeyHit = 0
|
|
End If
|
|
|
|
If idemode Then
|
|
'Darken fg/bg colors
|
|
dummy = DarkenFGBG(0)
|
|
End If
|
|
|
|
sendc$ = Chr$(6) 'ready
|
|
GoTo sendcommand
|
|
End If
|
|
|
|
Print "Invalid IDE message": End
|
|
|
|
ideerror:
|
|
If InStr(idemessage$, sp$) Then
|
|
'Something went wrong here, so let's give a generic error message to the user.
|
|
'(No error message should contain sp$ - that is, CHR$(13), when not in Debug mode)
|
|
idemessage$ = "Compiler error (check for syntax errors) (" + _ErrorMessage$ + ":"
|
|
If Err Then idemessage$ = idemessage$ + str2$(Err) + "-"
|
|
If _ErrorLine Then idemessage$ = idemessage$ + str2$(_ErrorLine)
|
|
If _InclErrorLine Then idemessage$ = idemessage$ + "-" + _InclErrorFile$ + "-" + str2$(_InclErrorLine)
|
|
idemessage$ = idemessage$ + ")"
|
|
If inclevel > 0 Then idemessage$ = idemessage$ + incerror$
|
|
End If
|
|
|
|
sendc$ = Chr$(8) + idemessage$ + MKL$(ideerrorline)
|
|
GoTo sendcommand
|
|
|
|
|
|
noide:
|
|
If (qb64versionprinted = 0 Or ConsoleMode = 0) And Not QuietMode Then
|
|
qb64versionprinted = -1
|
|
Print "QB64 Compiler V" + Version$
|
|
End If
|
|
|
|
If CMDLineFile = "" Then
|
|
Line Input ; "COMPILE (.bas)>", f$
|
|
Else
|
|
f$ = CMDLineFile
|
|
End If
|
|
|
|
f$ = LTrim$(RTrim$(f$))
|
|
|
|
If FileHasExtension(f$) = 0 Then f$ = f$ + ".bas"
|
|
|
|
sourcefile$ = f$
|
|
CMDLineFile = sourcefile$
|
|
'derive name from sourcefile
|
|
f$ = RemoveFileExtension$(f$)
|
|
|
|
path.exe$ = ""
|
|
currentdir$ = _CWD$
|
|
path.source$ = getfilepath$(sourcefile$)
|
|
If Len(path.source$) Then
|
|
If _DirExists(path.source$) = 0 Then
|
|
Print
|
|
Print "Cannot locate source file: " + sourcefile$
|
|
If ConsoleMode Then System 1
|
|
End 1
|
|
End If
|
|
ChDir path.source$
|
|
path.source$ = _CWD$
|
|
If Right$(path.source$, 1) <> pathsep$ Then path.source$ = path.source$ + pathsep$
|
|
ChDir currentdir$
|
|
End If
|
|
If SaveExeWithSource Then path.exe$ = path.source$
|
|
If path.exe$ = "" Then
|
|
If InStr(_OS$, "WIN") Then path.exe$ = "..\..\" Else path.exe$ = "../../"
|
|
End If
|
|
|
|
For x = Len(f$) To 1 Step -1
|
|
a$ = Mid$(f$, x, 1)
|
|
If a$ = "/" Or a$ = "\" Then
|
|
f$ = Right$(f$, Len(f$) - x)
|
|
Exit For
|
|
End If
|
|
Next
|
|
file$ = f$
|
|
|
|
'if cmemlist(currentid+1)<>0 before calling regid the variable
|
|
'MUST be defined in cmem!
|
|
|
|
fullrecompile:
|
|
|
|
BU_DEPENDENCY_CONSOLE_ONLY = DEPENDENCY(DEPENDENCY_CONSOLE_ONLY)
|
|
For i = 1 To UBound(Dependency): DEPENDENCY(i) = 0: Next
|
|
DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) = BU_DEPENDENCY_CONSOLE_ONLY And 2 'Restore -g switch if used
|
|
|
|
Error_Happened = 0
|
|
|
|
For closeall = 1 To 255: Close closeall: Next
|
|
|
|
Open tmpdir$ + "temp.bin" For Output Lock Write As #26 'relock
|
|
|
|
fh = FreeFile: Open tmpdir$ + "dyninfo.txt" For Output As #fh: Close #fh
|
|
|
|
If Debug Then Close #9: Open tmpdir$ + "debug.txt" For Output As #9
|
|
|
|
For i = 1 To ids_max + 1
|
|
arrayelementslist(i) = 0
|
|
cmemlist(i) = 0
|
|
sfcmemargs(i) = ""
|
|
Next
|
|
|
|
'erase cmemlist
|
|
'erase sfcmemargs
|
|
|
|
lastunresolved = -1 'first pass
|
|
sflistn = -1 'no entries
|
|
|
|
SubNameLabels = sp 'QB64 will perform a repass to resolve sub names used as labels
|
|
|
|
recompile:
|
|
|
|
lastLineReturn = 0
|
|
lastLine = 0
|
|
firstLine = 1
|
|
|
|
Resize = 0
|
|
Resize_Scale = 0
|
|
|
|
UseGL = 0
|
|
|
|
Error_Happened = 0
|
|
|
|
HashClear 'clear the hash table
|
|
|
|
'add reserved words to hashtable
|
|
|
|
f = HASHFLAG_TYPE + HASHFLAG_RESERVED
|
|
HashAdd "_UNSIGNED", f, 0
|
|
HashAdd "_BIT", f, 0
|
|
HashAdd "_BYTE", f, 0
|
|
HashAdd "INTEGER", f, 0
|
|
HashAdd "LONG", f, 0
|
|
HashAdd "_INTEGER64", f, 0
|
|
HashAdd "_OFFSET", f, 0
|
|
HashAdd "SINGLE", f, 0
|
|
HashAdd "DOUBLE", f, 0
|
|
HashAdd "_FLOAT", f, 0
|
|
HashAdd "STRING", f, 0
|
|
HashAdd "ANY", f, 0
|
|
|
|
f = HASHFLAG_OPERATOR + HASHFLAG_RESERVED
|
|
HashAdd "NOT", f, 0
|
|
HashAdd "IMP", f, 0
|
|
HashAdd "EQV", f, 0
|
|
HashAdd "AND", f, 0
|
|
HashAdd "OR", f, 0
|
|
HashAdd "XOR", f, 0
|
|
HashAdd "MOD", f, 0
|
|
|
|
f = HASHFLAG_RESERVED + HASHFLAG_CUSTOMSYNTAX
|
|
HashAdd "LIST", f, 0
|
|
HashAdd "BASE", f, 0
|
|
HashAdd "_EXPLICIT", f, 0
|
|
HashAdd "AS", f, 0
|
|
HashAdd "IS", f, 0
|
|
HashAdd "OFF", f, 0
|
|
HashAdd "ON", f, 0
|
|
HashAdd "STOP", f, 0
|
|
HashAdd "TO", f, 0
|
|
HashAdd "USING", f, 0
|
|
'PUT(graphics) statement:
|
|
HashAdd "PRESET", f, 0
|
|
HashAdd "PSET", f, 0
|
|
'OPEN statement:
|
|
HashAdd "FOR", f, 0
|
|
HashAdd "OUTPUT", f, 0
|
|
HashAdd "RANDOM", f, 0
|
|
HashAdd "BINARY", f, 0
|
|
HashAdd "APPEND", f, 0
|
|
HashAdd "SHARED", f, 0
|
|
HashAdd "ACCESS", f, 0
|
|
HashAdd "LOCK", f, 0
|
|
HashAdd "READ", f, 0
|
|
HashAdd "WRITE", f, 0
|
|
'LINE statement:
|
|
HashAdd "STEP", f, 0
|
|
'WIDTH statement:
|
|
HashAdd "LPRINT", f, 0
|
|
'VIEW statement:
|
|
HashAdd "PRINT", f, 0
|
|
|
|
f = HASHFLAG_RESERVED + HASHFLAG_XELEMENTNAME + HASHFLAG_XTYPENAME
|
|
'A
|
|
'B
|
|
'C
|
|
HashAdd "COMMON", f, 0
|
|
HashAdd "CALL", f, 0
|
|
HashAdd "CASE", f - HASHFLAG_XELEMENTNAME, 0
|
|
HashAdd "COM", f, 0 '(ON...)
|
|
HashAdd "CONST", f, 0
|
|
'D
|
|
HashAdd "DATA", f, 0
|
|
HashAdd "DECLARE", f, 0
|
|
HashAdd "DEF", f, 0
|
|
HashAdd "DEFDBL", f, 0
|
|
HashAdd "DEFINT", f, 0
|
|
HashAdd "DEFLNG", f, 0
|
|
HashAdd "DEFSNG", f, 0
|
|
HashAdd "DEFSTR", f, 0
|
|
HashAdd "DIM", f, 0
|
|
HashAdd "DO", f - HASHFLAG_XELEMENTNAME, 0
|
|
'E
|
|
HashAdd "ERROR", f - HASHFLAG_XELEMENTNAME, 0 '(ON ...)
|
|
HashAdd "ELSE", f, 0
|
|
HashAdd "ELSEIF", f, 0
|
|
HashAdd "ENDIF", f, 0
|
|
HashAdd "EXIT", f - HASHFLAG_XELEMENTNAME, 0
|
|
'F
|
|
HashAdd "FIELD", f - HASHFLAG_XELEMENTNAME, 0
|
|
HashAdd "FUNCTION", f, 0
|
|
'G
|
|
HashAdd "GOSUB", f, 0
|
|
HashAdd "GOTO", f, 0
|
|
'H
|
|
'I
|
|
HashAdd "INPUT", f - HASHFLAG_XELEMENTNAME - HASHFLAG_XTYPENAME, 0 '(INPUT$ function exists, so conflicts if allowed as custom syntax)
|
|
HashAdd "IF", f, 0
|
|
'K
|
|
HashAdd "KEY", f - HASHFLAG_XELEMENTNAME - HASHFLAG_XTYPENAME, 0 '(ON...)
|
|
'L
|
|
HashAdd "LET", f - HASHFLAG_XELEMENTNAME, 0
|
|
HashAdd "LOOP", f - HASHFLAG_XELEMENTNAME, 0
|
|
HashAdd "LEN", f - HASHFLAG_XELEMENTNAME, 0 '(LEN function exists, so conflicts if allowed as custom syntax)
|
|
'M
|
|
'N
|
|
HashAdd "NEXT", f - HASHFLAG_XELEMENTNAME, 0
|
|
'O
|
|
'P
|
|
HashAdd "PLAY", f - HASHFLAG_XELEMENTNAME - HASHFLAG_XTYPENAME, 0 '(ON...)
|
|
HashAdd "PEN", f - HASHFLAG_XELEMENTNAME - HASHFLAG_XTYPENAME, 0 '(ON...)
|
|
'Q
|
|
'R
|
|
HashAdd "REDIM", f, 0
|
|
HashAdd "REM", f, 0
|
|
HashAdd "RESTORE", f - HASHFLAG_XELEMENTNAME, 0
|
|
HashAdd "RESUME", f - HASHFLAG_XELEMENTNAME, 0
|
|
HashAdd "RETURN", f - HASHFLAG_XELEMENTNAME, 0
|
|
HashAdd "RUN", f - HASHFLAG_XELEMENTNAME, 0
|
|
'S
|
|
HashAdd "STATIC", f, 0
|
|
HashAdd "STRIG", f, 0 '(ON...)
|
|
HashAdd "SEG", f, 0
|
|
HashAdd "SELECT", f - HASHFLAG_XELEMENTNAME - HASHFLAG_XTYPENAME, 0
|
|
HashAdd "SUB", f, 0
|
|
HashAdd "SCREEN", f - HASHFLAG_XELEMENTNAME - HASHFLAG_XTYPENAME, 0
|
|
'T
|
|
HashAdd "THEN", f, 0
|
|
HashAdd "TIMER", f - HASHFLAG_XELEMENTNAME - HASHFLAG_XTYPENAME, 0 '(ON...)
|
|
HashAdd "TYPE", f - HASHFLAG_XELEMENTNAME, 0
|
|
'U
|
|
HashAdd "UNTIL", f, 0
|
|
HashAdd "UEVENT", f, 0
|
|
'V
|
|
'W
|
|
HashAdd "WEND", f, 0
|
|
HashAdd "WHILE", f, 0
|
|
'X
|
|
'Y
|
|
'Z
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
'clear/init variables
|
|
Console = 0
|
|
ScreenHide = 0
|
|
Asserts = 0
|
|
ResolveStaticFunctions = 0
|
|
dynamiclibrary = 0
|
|
dimsfarray = 0
|
|
dimstatic = 0
|
|
AllowLocalName = 0
|
|
PossibleSubNameLabels = sp 'QB64 will perform a repass to resolve sub names used as labels
|
|
use_global_byte_elements = 0
|
|
dimshared = 0: dimmethod = 0: dimoption = 0: redimoption = 0: commonoption = 0
|
|
mylib$ = "": mylibopt$ = ""
|
|
declaringlibrary = 0
|
|
nLabels = 0
|
|
dynscope = 0
|
|
elsefollowup = 0
|
|
ontimerid = 0: onkeyid = 0: onstrigid = 0
|
|
commonarraylist = "": commonarraylistn = 0
|
|
staticarraylist = "": staticarraylistn = 0
|
|
fooindwel = 0
|
|
layout = ""
|
|
layoutok = 0
|
|
NoChecks = 0
|
|
inclevel = 0
|
|
errorLineInInclude = 0
|
|
addmetainclude$ = ""
|
|
nextrunlineindex = 1
|
|
lasttype = 0
|
|
lasttypeelement = 0
|
|
definingtype = 0
|
|
constlast = -1
|
|
'constlastshared = -1
|
|
defdatahandle = 18
|
|
closedmain = 0
|
|
addmetastatic = 0
|
|
addmetadynamic = 0
|
|
DynamicMode = 0
|
|
optionbase = 0
|
|
optionexplicit = 0: If optionexplicit_cmd = -1 And NoIDEMode = 1 Then optionexplicit = -1
|
|
optionexplicitarray = 0
|
|
ExeIconSet = 0
|
|
VersionInfoSet = 0
|
|
viFileVersionNum$ = "": viProductVersionNum$ = "": viCompanyName$ = ""
|
|
viFileDescription$ = "": viFileVersion$ = "": viInternalName$ = ""
|
|
viLegalCopyright$ = "": viLegalTrademarks$ = "": viOriginalFilename$ = ""
|
|
viProductName$ = "": viProductVersion$ = "": viComments$ = "": viWeb$ = ""
|
|
DataOffset = 0
|
|
statementn = 0
|
|
everycasenewcase = 0
|
|
qberrorhappened = 0: qberrorcode = 0: qberrorline = 0
|
|
For i = 1 To 27: defineaz(i) = "SINGLE": defineextaz(i) = "!": Next
|
|
controllevel = 0
|
|
findidsecondarg$ = "": findanotherid = 0: findidinternal = 0: currentid = 0
|
|
linenumber = 0
|
|
wholeline$ = ""
|
|
linefragment$ = ""
|
|
idn = 0
|
|
arrayprocessinghappened = 0
|
|
stringprocessinghappened = 0
|
|
subfuncn = 0
|
|
subfunc = ""
|
|
SelectCaseCounter = 0
|
|
ExecCounter = 0
|
|
UserDefineCount = 7
|
|
totalVariablesCreated = 0
|
|
totalWarnings = 0
|
|
duplicateConstWarning = 0
|
|
emptySCWarning = 0
|
|
warningListItems = 0
|
|
lastWarningHeader = ""
|
|
ReDim Shared warning$(1000)
|
|
uniquenumbern = 0
|
|
qb64prefix_set = 0
|
|
qb64prefix$ = "_"
|
|
|
|
''create a type for storing memory blocks
|
|
''UDT
|
|
''names
|
|
'DIM SHARED lasttype AS LONG
|
|
'DIM SHARED udtxname(1000) AS STRING * 256
|
|
'DIM SHARED udtxcname(1000) AS STRING * 256
|
|
'DIM SHARED udtxsize(1000) AS LONG
|
|
'DIM SHARED udtxbytealign(1000) AS INTEGER 'first element MUST be on a byte alignment & size is a multiple of 8
|
|
'DIM SHARED udtxnext(1000) AS LONG
|
|
''elements
|
|
'DIM SHARED lasttypeelement AS LONG
|
|
'DIM SHARED udtename(1000) AS STRING * 256
|
|
'DIM SHARED udtecname(1000) AS STRING * 256
|
|
'DIM SHARED udtebytealign(1000) AS INTEGER
|
|
'DIM SHARED udtesize(1000) AS LONG
|
|
'DIM SHARED udtetype(1000) AS LONG
|
|
'DIM SHARED udtetypesize(1000) AS LONG
|
|
'DIM SHARED udtearrayelements(1000) AS LONG
|
|
'DIM SHARED udtenext(1000) AS LONG
|
|
|
|
'import _MEM type
|
|
ptrsz = OS_BITS \ 8
|
|
|
|
lasttype = lasttype + 1: i = lasttype
|
|
udtxname(i) = "_MEM"
|
|
udtxcname(i) = "_MEM"
|
|
udtxsize(i) = ((ptrsz) * 5 + (4) * 2 + (8) * 1) * 8
|
|
udtxbytealign(i) = 1
|
|
lasttypeelement = lasttypeelement + 1: i2 = lasttypeelement
|
|
udtename(i2) = "OFFSET"
|
|
udtecname(i2) = "OFFSET"
|
|
udtebytealign(i2) = 1
|
|
udtetype(i2) = OFFSETTYPE: udtesize(i2) = ptrsz * 8
|
|
udtetypesize(i2) = 0 'tsize
|
|
udtxnext(i) = i2
|
|
i3 = i2
|
|
lasttypeelement = lasttypeelement + 1: i2 = lasttypeelement
|
|
udtename(i2) = "SIZE"
|
|
udtecname(i2) = "SIZE"
|
|
udtebytealign(i2) = 1
|
|
udtetype(i2) = OFFSETTYPE: udtesize(i2) = ptrsz * 8
|
|
udtetypesize(i2) = 0 'tsize
|
|
udtenext(i3) = i2
|
|
i3 = i2
|
|
lasttypeelement = lasttypeelement + 1: i2 = lasttypeelement
|
|
udtename(i2) = "$_LOCK_ID"
|
|
udtecname(i2) = "$_LOCK_ID"
|
|
udtebytealign(i2) = 1
|
|
udtetype(i2) = INTEGER64TYPE: udtesize(i2) = 64
|
|
udtetypesize(i2) = 0 'tsize
|
|
udtenext(i3) = i2
|
|
i3 = i2
|
|
lasttypeelement = lasttypeelement + 1: i2 = lasttypeelement
|
|
udtename(i2) = "$_LOCK_OFFSET"
|
|
udtecname(i2) = "$_LOCK_OFFSET"
|
|
udtebytealign(i2) = 1
|
|
udtetype(i2) = OFFSETTYPE: udtesize(i2) = ptrsz * 8
|
|
udtetypesize(i2) = 0 'tsize
|
|
udtenext(i3) = i2
|
|
i3 = i2
|
|
lasttypeelement = lasttypeelement + 1: i2 = lasttypeelement
|
|
udtename(i2) = "TYPE"
|
|
udtecname(i2) = "TYPE"
|
|
udtebytealign(i2) = 1
|
|
udtetype(i2) = OFFSETTYPE: udtesize(i2) = ptrsz * 8
|
|
udtetypesize(i2) = 0 'tsize
|
|
udtenext(i3) = i2
|
|
i3 = i2
|
|
lasttypeelement = lasttypeelement + 1: i2 = lasttypeelement
|
|
udtename(i2) = "ELEMENTSIZE"
|
|
udtecname(i2) = "ELEMENTSIZE"
|
|
udtebytealign(i2) = 1
|
|
udtetype(i2) = OFFSETTYPE: udtesize(i2) = ptrsz * 8
|
|
udtetypesize(i2) = 0 'tsize
|
|
udtenext(i3) = i2
|
|
udtenext(i2) = 0
|
|
i3 = i2
|
|
lasttypeelement = lasttypeelement + 1: i2 = lasttypeelement
|
|
udtename(i2) = "IMAGE"
|
|
udtecname(i2) = "IMAGE"
|
|
udtebytealign(i2) = 1
|
|
udtetype(i2) = LONGTYPE: udtesize(i2) = 32
|
|
udtetypesize(i2) = 0 'tsize
|
|
udtenext(i3) = i2
|
|
udtenext(i2) = 0
|
|
i3 = i2
|
|
lasttypeelement = lasttypeelement + 1: i2 = lasttypeelement
|
|
udtename(i2) = "SOUND"
|
|
udtecname(i2) = "SOUND"
|
|
udtebytealign(i2) = 1
|
|
udtetype(i2) = LONGTYPE: udtesize(i2) = 32
|
|
udtetypesize(i2) = 0 'tsize
|
|
udtenext(i3) = i2
|
|
udtenext(i2) = 0
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
'begin compilation
|
|
For closeall = 1 To 255: Close closeall: Next
|
|
Open tmpdir$ + "temp.bin" For Output Lock Write As #26 'relock
|
|
|
|
ff = FreeFile: Open tmpdir$ + "icon.rc" For Output As #ff: Close #ff
|
|
|
|
If Debug Then Close #9: Open tmpdir$ + "debug.txt" For Append As #9
|
|
|
|
If idemode = 0 Then
|
|
qberrorhappened = -1
|
|
Open sourcefile$ For Input As #1
|
|
qberrorhappened1:
|
|
If qberrorhappened = 1 Then
|
|
Print
|
|
Print "Cannot locate source file:" + sourcefile$
|
|
If ConsoleMode Then System 1
|
|
End 1
|
|
Else
|
|
Close #1
|
|
End If
|
|
qberrorhappened = 0
|
|
End If
|
|
|
|
reginternal
|
|
|
|
Open tmpdir$ + "global.txt" For Output As #18
|
|
|
|
If iderecompile Then
|
|
iderecompile = 0
|
|
idepass = 1 'prepass must be done again
|
|
sendc$ = Chr$(7) 'repass request
|
|
GoTo sendcommand
|
|
End If
|
|
|
|
If idemode Then GoTo ideret1
|
|
|
|
If Not QuietMode Then
|
|
Print
|
|
Print "Beginning C++ output from QB64 code... "
|
|
End If
|
|
|
|
lineinput3load sourcefile$
|
|
|
|
Do
|
|
|
|
'### STEVE EDIT FOR CONST EXPANSION 10/11/2013
|
|
|
|
wholeline$ = lineinput3$
|
|
If wholeline$ = Chr$(13) Then Exit Do
|
|
|
|
ideprepass:
|
|
prepassLastLine:
|
|
|
|
wholestv$ = wholeline$ '### STEVE EDIT FOR CONST EXPANSION 10/11/2013
|
|
|
|
|
|
|
|
prepass = 1
|
|
layout = ""
|
|
layoutok = 0
|
|
|
|
linenumber = linenumber + 1
|
|
reallinenumber = reallinenumber + 1
|
|
|
|
Do Until linenumber < UBound(InValidLine) 'color information flag for each line
|
|
ReDim _Preserve InValidLine(UBound(InValidLine) + 1000) As _Byte
|
|
Loop
|
|
InValidLine(linenumber) = 0
|
|
|
|
ColorPass:
|
|
|
|
If Len(wholeline$) Then
|
|
|
|
If UCase$(_Trim$(wholeline$)) = "$NOPREFIX" Then
|
|
If firstLine = 0 Then a$ = "$NOPREFIX must come before any other statements": GoTo errmes
|
|
|
|
qb64prefix$ = ""
|
|
qb64prefix_set = 1
|
|
|
|
're-add internal keywords without the "_" prefix
|
|
reginternal
|
|
|
|
f = HASHFLAG_TYPE + HASHFLAG_RESERVED
|
|
HashAdd "UNSIGNED", f, 0
|
|
HashAdd "BIT", f, 0
|
|
HashAdd "BYTE", f, 0
|
|
HashAdd "INTEGER64", f, 0
|
|
HashAdd "OFFSET", f, 0
|
|
HashAdd "FLOAT", f, 0
|
|
|
|
f = HASHFLAG_RESERVED + HASHFLAG_CUSTOMSYNTAX
|
|
HashAdd "EXPLICIT", f, 0
|
|
|
|
GoTo finishedlinepp
|
|
End If
|
|
|
|
wholeline$ = lineformat(wholeline$)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
|
|
temp$ = LTrim$(RTrim$(UCase$(wholestv$)))
|
|
|
|
If temp$ = "$COLOR:0" Then
|
|
addmetainclude$ = getfilepath$(Command$(0)) + "source" + pathsep$ + "utilities" + pathsep$ + "color0.bi"
|
|
GoTo finishedlinepp
|
|
End If
|
|
|
|
If temp$ = "$COLOR:32" Then
|
|
addmetainclude$ = getfilepath$(Command$(0)) + "source" + pathsep$ + "utilities" + pathsep$ + "color32.bi"
|
|
GoTo finishedlinepp
|
|
End If
|
|
|
|
If Left$(temp$, 4) = "$IF " Then
|
|
If Right$(temp$, 5) <> " THEN" Then a$ = "$IF without THEN": GoTo errmes
|
|
temp$ = LTrim$(Mid$(temp$, 4)) 'strip off the $IF and extra spaces
|
|
temp$ = RTrim$(Left$(temp$, Len(temp$) - 4)) 'and strip off the THEN and extra spaces
|
|
temp = InStr(temp$, "=")
|
|
ExecCounter = ExecCounter + 1
|
|
ExecLevel(ExecCounter) = -1 'default to a skip value
|
|
DefineElse(ExecCounter) = 1 '1 says we have an $IF statement at this level
|
|
result = EvalPreIF(temp$, a$)
|
|
If a$ <> "" Then GoTo errmes
|
|
If result <> 0 Then
|
|
ExecLevel(ExecCounter) = ExecLevel(ExecCounter - 1) 'So we inherit the execlevel from above
|
|
If ExecLevel(ExecCounter) = 0 Then DefineElse(ExecCounter) = DefineElse(ExecCounter) Or 4 'Else if used and conditon found
|
|
End If
|
|
GoTo finishedlinepp 'and then we're finished -- and at this point we didn't make a match so we exit with a DONT READ type flag on our code.
|
|
End If
|
|
|
|
If temp$ = "$ELSE" Then
|
|
If DefineElse(ExecCounter) = 0 Then a$ = "$ELSE without $IF": GoTo errmes
|
|
If DefineElse(ExecCounter) And 2 Then a$ = "$IF block already has $ELSE statement in it": GoTo errmes
|
|
DefineElse(ExecCounter) = DefineElse(ExecCounter) Or 2 'set the flag to declare an $ELSE already in this block
|
|
If DefineElse(ExecCounter) And 4 Then 'If we executed code in a previous IF or ELSE IF statement, we can't do it here
|
|
ExecLevel(ExecCounter) = -1 'So we inherit the execlevel from above
|
|
Else
|
|
ExecLevel(ExecCounter) = ExecLevel(ExecCounter - 1) 'If we were processing code before, code after this segment is going to be SKIPPED
|
|
End If
|
|
GoTo finishedlinepp
|
|
End If
|
|
|
|
If Left$(temp$, 5) = "$ELSE" Then 'looking for $ELSE IF
|
|
temp$ = LTrim$(Mid$(temp$, 6))
|
|
If Left$(temp$, 3) = "IF " Then
|
|
If DefineElse(ExecCounter) = 0 Then a$ = "$ELSE IF without $IF": GoTo errmes
|
|
If DefineElse(ExecCounter) And 2 Then a$ = "$ELSE IF cannot follow $ELSE": GoTo errmes
|
|
If Right$(temp$, 5) <> " THEN" Then a$ = "$ELSE IF without THEN": GoTo errmes
|
|
If DefineElse(ExecCounter) And 4 Then 'If we executed code in a previous IF or ELSE IF statement, we can't do it here
|
|
ExecLevel(ExecCounter) = -1
|
|
GoTo finishedlinepp
|
|
End If
|
|
temp$ = LTrim$(Mid$(temp$, 3)) 'strip off the IF and extra spaces
|
|
temp$ = RTrim$(Left$(temp$, Len(temp$) - 4)) 'and strip off the THEN and extra spaces
|
|
result = EvalPreIF(temp$, a$)
|
|
If a$ <> "" Then GoTo errmes
|
|
If result <> 0 Then
|
|
ExecLevel(ExecCounter) = ExecLevel(ExecCounter - 1) 'So we inherit the execlevel from above
|
|
If ExecLevel(ExecCounter) = 0 Then DefineElse(ExecCounter) = DefineElse(ExecCounter) Or 4 'Else if used and conditon found
|
|
End If
|
|
GoTo finishedlinepp 'and then we're finished -- and at this point we didn't make a match so we exit with a DONT READ type flag on our code.
|
|
End If
|
|
End If
|
|
|
|
If temp$ = "$END IF" Or temp$ = "$ENDIF" Then
|
|
If DefineElse(ExecCounter) = 0 Then a$ = "$END IF without $IF": GoTo errmes
|
|
DefineElse(ExecCounter) = 0 'We no longer have an $IF block at this level
|
|
ExecCounter = ExecCounter - 1
|
|
GoTo finishedlinepp
|
|
End If
|
|
|
|
If ExecLevel(ExecCounter) Then
|
|
Do Until linenumber < UBound(InValidLine)
|
|
ReDim _Preserve InValidLine(UBound(InValidLine) + 1000) As _Byte
|
|
Loop
|
|
|
|
InValidLine(linenumber) = -1
|
|
GoTo finishedlinepp 'we don't check for anything inside lines that we've marked for skipping
|
|
End If
|
|
|
|
If Left$(temp$, 7) = "$ERROR " Then
|
|
temp$ = LTrim$(Mid$(temp$, 7))
|
|
a$ = "Compilation check failed: " + temp$
|
|
GoTo errmes
|
|
End If
|
|
|
|
If Left$(temp$, 5) = "$LET " Then
|
|
temp$ = LTrim$(Mid$(temp$, 5)) 'simply shorten our string to parse
|
|
'For starters, let's make certain that we have 3 elements to deal with
|
|
temp = InStr(temp$, "=") 'without an = in there, we can't get a value from the left and right side
|
|
If temp = 0 Then a$ = "Invalid Syntax. $LET <flag> = <value>": GoTo errmes
|
|
l$ = RTrim$(Left$(temp$, temp - 1)): r$ = LTrim$(Mid$(temp$, temp + 1))
|
|
'then validate to make certain the left side looks proper
|
|
l1$ = ""
|
|
For i = 1 To Len(l$)
|
|
a = Asc(l$, i)
|
|
Select Case a
|
|
Case 32 'strip out spaces
|
|
Case 46: l1$ = l1$ + Chr$(a)
|
|
Case Is < 48, Is > 90: a$ = "Invalid symbol left of equal sign (" + Chr$(a) + ")": GoTo errmes
|
|
Case Else: l1$ = l1$ + Chr$(a)
|
|
End Select
|
|
Next
|
|
l$ = l1$
|
|
If Left$(r$, 1) = Chr$(34) Then r$ = LTrim$(Mid$(r$, 2))
|
|
If Right$(r$, 1) = Chr$(34) Then r$ = RTrim$(Left$(r$, Len(r$) - 1))
|
|
If Left$(r$, 1) = "-" Then
|
|
r1$ = "-"
|
|
r$ = LTrim$(Mid$(r$, 2))
|
|
Else
|
|
r1$ = ""
|
|
End If
|
|
'then validate to make certain the left side looks proper
|
|
For i = 1 To Len(r$)
|
|
a = Asc(r$, i)
|
|
Select Case a
|
|
Case 32
|
|
Case 46 'periods are fine.
|
|
r1$ = r1$ + "."
|
|
Case Is < 48, Is > 90
|
|
a$ = "Invalid symbol right of equal sign (" + Chr$(a) + ")": GoTo errmes
|
|
Case Else
|
|
r1$ = r1$ + Chr$(a)
|
|
End Select
|
|
Next
|
|
r$ = r1$
|
|
layout$ = SCase$("$Let ") + l$ + " = " + r$
|
|
'First look to see if we have an existing setting like this and if so, update it
|
|
For i = 8 To UserDefineCount 'UserDefineCount 1-7 are reserved for automatic OS/BIT detection & version
|
|
If UserDefine(0, i) = l$ Then UserDefine(1, i) = r$: GoTo finishedlinepp
|
|
Next
|
|
'Otherwise create a new setting and set the initial value for it
|
|
UserDefineCount = UserDefineCount + 1
|
|
If UserDefineCount > UBound(UserDefine, 2) Then
|
|
ReDim _Preserve UserDefine(1, UBound(UserDefine, 2) + 10) 'Add another 10 elements to the array so it'll expand as the user adds to it
|
|
End If
|
|
UserDefine(0, UserDefineCount) = l$
|
|
UserDefine(1, UserDefineCount) = r$
|
|
GoTo finishedlinepp
|
|
End If
|
|
|
|
|
|
cwholeline$ = wholeline$
|
|
wholeline$ = eleucase$(wholeline$) '********REMOVE THIS LINE LATER********
|
|
|
|
|
|
addmetadynamic = 0: addmetastatic = 0
|
|
wholelinen = numelements(wholeline$)
|
|
|
|
If wholelinen Then
|
|
|
|
wholelinei = 1
|
|
|
|
'skip line number?
|
|
e$ = getelement$(wholeline$, 1)
|
|
If (Asc(e$) >= 48 And Asc(e$) <= 59) Or Asc(e$) = 46 Then wholelinei = 2: GoTo ppskpl
|
|
|
|
'skip 'POSSIBLE' line label?
|
|
If wholelinen >= 2 Then
|
|
x2 = InStr(wholeline$, sp + ":" + sp): x3 = x2 + 2
|
|
If x2 = 0 Then
|
|
If Right$(wholeline$, 2) = sp + ":" Then x2 = Len(wholeline$) - 1: x3 = x2 + 1
|
|
End If
|
|
|
|
If x2 Then
|
|
e$ = Left$(wholeline$, x2 - 1)
|
|
If validlabel(e$) Then
|
|
wholeline$ = Right$(wholeline$, Len(wholeline$) - x3)
|
|
cwholeline$ = Right$(cwholeline$, Len(wholeline$) - x3)
|
|
wholelinen = numelements(wholeline$)
|
|
GoTo ppskpl
|
|
End If 'valid
|
|
End If 'includes ":"
|
|
End If 'wholelinen>=2
|
|
|
|
ppskpl:
|
|
If wholelinei <= wholelinen Then
|
|
'----------------------------------------
|
|
a$ = ""
|
|
ca$ = ""
|
|
ppblda:
|
|
e$ = getelement$(wholeline$, wholelinei)
|
|
ce$ = getelement$(cwholeline$, wholelinei)
|
|
If e$ = ":" Or e$ = "ELSE" Or e$ = "THEN" Or e$ = "" Then
|
|
If Len(a$) Then
|
|
If Debug Then Print #9, "PP[" + a$ + "]"
|
|
n = numelements(a$)
|
|
firstelement$ = getelement(a$, 1)
|
|
secondelement$ = getelement(a$, 2)
|
|
thirdelement$ = getelement(a$, 3)
|
|
'========================================
|
|
|
|
'declare library
|
|
If declaringlibrary Then
|
|
|
|
If firstelement$ = "END" Then
|
|
If n <> 2 Or secondelement$ <> "DECLARE" Then a$ = "Expected END DECLARE": GoTo errmes
|
|
declaringlibrary = 0
|
|
GoTo finishedlinepp
|
|
End If 'end declare
|
|
|
|
declaringlibrary = 2
|
|
|
|
If firstelement$ = "SUB" Or firstelement$ = "FUNCTION" Then subfuncn = subfuncn - 1: GoTo declaresubfunc
|
|
|
|
a$ = "Expected SUB/FUNCTION definition or END DECLARE (#2)": GoTo errmes
|
|
End If
|
|
|
|
'UDT TYPE definition
|
|
If definingtype Then
|
|
i = definingtype
|
|
|
|
If n >= 1 Then
|
|
If firstelement$ = "END" Then
|
|
If n <> 2 Or secondelement$ <> "TYPE" Then a$ = "Expected END TYPE": GoTo errmes
|
|
If udtxnext(i) = 0 Then a$ = "No elements defined in TYPE": GoTo errmes
|
|
definingtype = 0
|
|
|
|
'create global buffer for SWAP space
|
|
siz$ = str2$(udtxsize(i) \ 8)
|
|
Print #18, "char *g_tmp_udt_" + RTrim$(udtxname(i)) + "=(char*)malloc(" + siz$ + ");"
|
|
|
|
'print "END TYPE";udtxsize(i);udtxbytealign(i)
|
|
GoTo finishedlinepp
|
|
End If
|
|
End If
|
|
|
|
If n < 3 Then a$ = "Expected element-name AS type, AS type element-list, or END TYPE": GoTo errmes
|
|
n$ = firstelement$
|
|
|
|
If n$ <> "AS" Then
|
|
'traditional variable-name AS type syntax, single-element
|
|
lasttypeelement = lasttypeelement + 1
|
|
i2 = lasttypeelement
|
|
udtenext(i2) = 0
|
|
|
|
ii = 2
|
|
|
|
udtearrayelements(i2) = 0
|
|
|
|
If ii >= n Or getelement$(a$, ii) <> "AS" Then a$ = "Expected element-name AS type, AS type element-list, or END TYPE": GoTo errmes
|
|
t$ = getelements$(a$, ii + 1, n)
|
|
|
|
typ = typname2typ(t$)
|
|
If Error_Happened Then GoTo errmes
|
|
If typ = 0 Then a$ = "Undefined type": GoTo errmes
|
|
typsize = typname2typsize
|
|
|
|
If validname(n$) = 0 Then a$ = "Invalid name": GoTo errmes
|
|
udtename(i2) = n$
|
|
|
|
udtecname(i2) = getelement$(ca$, 1)
|
|
NormalTypeBlock:
|
|
udtetype(i2) = typ
|
|
udtetypesize(i2) = typsize
|
|
|
|
hashname$ = n$
|
|
|
|
'check for name conflicts (any similar reserved or element from current UDT)
|
|
hashchkflags = HASHFLAG_RESERVED + HASHFLAG_UDTELEMENT
|
|
hashres = HashFind(hashname$, hashchkflags, hashresflags, hashresref)
|
|
Do While hashres
|
|
If hashresflags And HASHFLAG_UDTELEMENT Then
|
|
If hashresref = i Then a$ = "Name already in use": GoTo errmes
|
|
End If
|
|
If hashresflags And HASHFLAG_RESERVED Then
|
|
If hashresflags And (HASHFLAG_TYPE + HASHFLAG_CUSTOMSYNTAX + HASHFLAG_OPERATOR + HASHFLAG_XELEMENTNAME) Then a$ = "Name already in use": GoTo errmes
|
|
End If
|
|
If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0
|
|
Loop
|
|
'add to hash table
|
|
HashAdd hashname$, HASHFLAG_UDTELEMENT, i
|
|
|
|
'Calculate element's size
|
|
If typ And ISUDT Then
|
|
u = typ And 511
|
|
udtesize(i2) = udtxsize(u)
|
|
If udtxbytealign(u) Then udtxbytealign(i) = 1: udtebytealign(i2) = 1
|
|
If udtxvariable(u) Then udtxvariable(i) = -1
|
|
Else
|
|
If (typ And ISSTRING) Then
|
|
If (typ And ISFIXEDLENGTH) = 0 Then
|
|
udtesize(i2) = OFFSETTYPE And 511
|
|
udtxvariable(i) = -1
|
|
Else
|
|
udtesize(i2) = typsize * 8
|
|
End If
|
|
udtxbytealign(i) = 1: udtebytealign(i2) = 1
|
|
Else
|
|
udtesize(i2) = typ And 511
|
|
If (typ And ISOFFSETINBITS) = 0 Then udtxbytealign(i) = 1: udtebytealign(i2) = 1
|
|
End If
|
|
End If
|
|
|
|
'Increase block size
|
|
If udtebytealign(i2) Then
|
|
If udtxsize(i) Mod 8 Then
|
|
udtxsize(i) = udtxsize(i) + (8 - (udtxsize(i) Mod 8))
|
|
End If
|
|
End If
|
|
udtxsize(i) = udtxsize(i) + udtesize(i2)
|
|
|
|
'Link element to previous element
|
|
If udtxnext(i) = 0 Then
|
|
udtxnext(i) = i2
|
|
Else
|
|
udtenext(i2 - 1) = i2
|
|
End If
|
|
|
|
'print "+"+rtrim$(udtename(i2));udtetype(i2);udtesize(i2);udtebytealign(i2);udtxsize(i)
|
|
If newAsTypeBlockSyntax Then Return
|
|
GoTo finishedlinepp
|
|
Else
|
|
'new AS type variable-list syntax, multiple elements
|
|
ii = 2
|
|
|
|
If ii >= n Then a$ = "Expected element-name AS type, AS type element-list, or END TYPE": GoTo errmes
|
|
previousElement$ = ""
|
|
t$ = ""
|
|
lastElement$ = ""
|
|
buildTypeName:
|
|
lastElement$ = getelement$(a$, ii)
|
|
If lastElement$ <> "," And lastElement$ <> "" Then
|
|
n$ = lastElement$
|
|
cn$ = getelement$(ca$, ii)
|
|
If Len(previousElement$) Then t$ = t$ + previousElement$ + " "
|
|
previousElement$ = n$
|
|
lastElement$ = ""
|
|
ii = ii + 1
|
|
GoTo buildTypeName
|
|
End If
|
|
|
|
t$ = RTrim$(t$)
|
|
typ = typname2typ(t$)
|
|
If Error_Happened Then GoTo errmes
|
|
If typ = 0 Then a$ = "Undefined type": GoTo errmes
|
|
typsize = typname2typsize
|
|
|
|
nexttypeelement:
|
|
lasttypeelement = lasttypeelement + 1
|
|
i2 = lasttypeelement
|
|
udtenext(i2) = 0
|
|
udtearrayelements(i2) = 0
|
|
|
|
udtename(i2) = n$
|
|
udtecname(i2) = cn$
|
|
|
|
If validname(n$) = 0 Then a$ = "Invalid name": GoTo errmes
|
|
|
|
newAsTypeBlockSyntax = -1
|
|
GoSub NormalTypeBlock
|
|
newAsTypeBlockSyntax = 0
|
|
|
|
getNextElement:
|
|
ii = ii + 1
|
|
lastElement$ = getelement$(a$, ii)
|
|
If lastElement$ = "" Then GoTo finishedlinepp
|
|
If ii = n And lastElement$ = "," Then a$ = "Expected element-name": GoTo errmes
|
|
If lastElement$ = "," Then GoTo getNextElement
|
|
n$ = lastElement$
|
|
cn$ = getelement$(ca$, ii)
|
|
GoTo nexttypeelement
|
|
End If
|
|
End If 'definingtype
|
|
|
|
If definingtype And n >= 1 Then a$ = "Expected END TYPE": GoTo errmes
|
|
|
|
If n >= 1 Then
|
|
If firstelement$ = "TYPE" Then
|
|
If n <> 2 Then a$ = "Expected TYPE typename": GoTo errmes
|
|
lasttype = lasttype + 1
|
|
definingtype = lasttype
|
|
i = definingtype
|
|
If validname(secondelement$) = 0 Then a$ = "Invalid name": GoTo errmes
|
|
udtxname(i) = secondelement$
|
|
udtxcname(i) = getelement(ca$, 2)
|
|
udtxnext(i) = 0
|
|
udtxsize(i) = 0
|
|
udtxvariable(i) = 0
|
|
|
|
hashname$ = secondelement$
|
|
hashflags = HASHFLAG_UDT
|
|
'check for name conflicts (any similar reserved/sub/function/UDT name)
|
|
hashchkflags = HASHFLAG_RESERVED + HASHFLAG_SUB + HASHFLAG_FUNCTION + HASHFLAG_UDT
|
|
hashres = HashFind(hashname$, hashchkflags, hashresflags, hashresref)
|
|
Do While hashres
|
|
allow = 0
|
|
If hashresflags And (HASHFLAG_SUB + HASHFLAG_FUNCTION) Then
|
|
allow = 1
|
|
End If
|
|
If hashresflags And HASHFLAG_RESERVED Then
|
|
If (hashresflags And (HASHFLAG_TYPE + HASHFLAG_OPERATOR + HASHFLAG_CUSTOMSYNTAX + HASHFLAG_XTYPENAME)) = 0 Then allow = 1
|
|
End If
|
|
If allow = 0 Then a$ = "Name already in use": GoTo errmes
|
|
If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0
|
|
Loop
|
|
|
|
'add to hash table
|
|
HashAdd hashname$, hashflags, i
|
|
|
|
GoTo finishedlinepp
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
If n >= 1 And firstelement$ = "CONST" Then
|
|
'l$ = "CONST"
|
|
'DEF... do not change type, the expression is stored in a suitable type
|
|
'based on its value if type isn't forced/specified
|
|
|
|
'convert periods to _046_
|
|
i2 = InStr(a$, sp + "." + sp)
|
|
If i2 Then
|
|
Do
|
|
a$ = Left$(a$, i2 - 1) + fix046$ + Right$(a$, Len(a$) - i2 - 2)
|
|
ca$ = Left$(ca$, i2 - 1) + fix046$ + Right$(ca$, Len(ca$) - i2 - 2)
|
|
i2 = InStr(a$, sp + "." + sp)
|
|
Loop Until i2 = 0
|
|
n = numelements(a$)
|
|
firstelement$ = getelement(a$, 1): secondelement$ = getelement(a$, 2): thirdelement$ = getelement(a$, 3)
|
|
End If
|
|
|
|
If n < 3 Then a$ = "Expected CONST name = value/expression": GoTo errmes
|
|
i = 2
|
|
constdefpendingpp:
|
|
pending = 0
|
|
|
|
n$ = getelement$(ca$, i): i = i + 1
|
|
typeoverride = 0
|
|
s$ = removesymbol$(n$)
|
|
If Error_Happened Then GoTo errmes
|
|
If s$ <> "" Then
|
|
typeoverride = typname2typ(s$)
|
|
If Error_Happened Then GoTo errmes
|
|
If typeoverride And ISFIXEDLENGTH Then a$ = "Invalid constant type": GoTo errmes
|
|
If typeoverride = 0 Then a$ = "Invalid constant type": GoTo errmes
|
|
End If
|
|
|
|
If getelement$(a$, i) <> "=" Then a$ = "Expected =": GoTo errmes
|
|
i = i + 1
|
|
|
|
'get expression
|
|
e$ = ""
|
|
readable_e$ = ""
|
|
B = 0
|
|
For i2 = i To n
|
|
e2$ = getelement$(ca$, i2)
|
|
If e2$ = "(" Then B = B + 1
|
|
If e2$ = ")" Then B = B - 1
|
|
If e2$ = "," And B = 0 Then
|
|
pending = 1
|
|
i = i2 + 1
|
|
If i > n - 2 Then a$ = "Expected CONST ... , name = value/expression": GoTo errmes
|
|
Exit For
|
|
End If
|
|
If Len(e$) = 0 Then e$ = e2$ Else e$ = e$ + sp + e2$
|
|
|
|
e3$ = e2$
|
|
If Len(e2$) > 1 Then
|
|
If Asc(e2$, 1) = 34 Then
|
|
removeComma = _InStrRev(e2$, ",")
|
|
e3$ = Left$(e2$, removeComma - 1)
|
|
Else
|
|
removeComma = InStr(e2$, ",")
|
|
e3$ = Mid$(e2$, removeComma + 1)
|
|
End If
|
|
End If
|
|
|
|
If Len(readable_e$) = 0 Then
|
|
readable_e$ = e3$
|
|
Else
|
|
readable_e$ = readable_e$ + e3$
|
|
End If
|
|
Next
|
|
|
|
'intercept current expression and pass it through Evaluate_Expression$
|
|
temp1$ = _Trim$(Evaluate_Expression$(readable_e$))
|
|
If Left$(temp1$, 5) <> "ERROR" And e$ <> temp1$ Then
|
|
e$ = lineformat(temp1$) 'retrieve parseable format
|
|
Else
|
|
If temp1$ = "ERROR - Division By Zero" Then a$ = temp1$: GoTo errmes
|
|
End If
|
|
|
|
'Proceed as usual
|
|
e$ = fixoperationorder(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
e$ = evaluateconst(e$, t)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
If t And ISSTRING Then 'string type
|
|
|
|
If typeoverride Then
|
|
If (typeoverride And ISSTRING) = 0 Then a$ = "Type mismatch": GoTo errmes
|
|
End If
|
|
|
|
Else 'not a string type
|
|
|
|
If typeoverride Then
|
|
If typeoverride And ISSTRING Then a$ = "Type mismatch": GoTo errmes
|
|
End If
|
|
|
|
If t And ISFLOAT Then
|
|
constval## = _CV(_Float, e$)
|
|
constval&& = constval##
|
|
constval~&& = constval&&
|
|
Else
|
|
If (t And ISUNSIGNED) And (t And 511) = 64 Then
|
|
constval~&& = _CV(_Unsigned _Integer64, e$)
|
|
constval&& = constval~&&
|
|
constval## = constval&&
|
|
Else
|
|
constval&& = _CV(_Integer64, e$)
|
|
constval## = constval&&
|
|
constval~&& = constval&&
|
|
End If
|
|
End If
|
|
|
|
'override type?
|
|
If typeoverride Then
|
|
'range check required here (noted in todo)
|
|
t = typeoverride
|
|
End If
|
|
|
|
End If 'not a string type
|
|
|
|
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
|
|
|
|
i2 = constlast
|
|
|
|
constsubfunc(i2) = subfuncn
|
|
'IF subfunc = "" THEN constlastshared = i2
|
|
|
|
If validname(n$) = 0 Then a$ = "Invalid name": GoTo errmes
|
|
constname(i2) = UCase$(n$)
|
|
|
|
hashname$ = n$
|
|
'check for name conflicts (any similar: reserved, sub, function, constant)
|
|
|
|
allow = 0
|
|
const_recheck:
|
|
hashchkflags = HASHFLAG_RESERVED + HASHFLAG_SUB + HASHFLAG_FUNCTION + HASHFLAG_CONSTANT
|
|
hashres = HashFind(hashname$, hashchkflags, hashresflags, hashresref)
|
|
Do While hashres
|
|
If hashresflags And HASHFLAG_CONSTANT Then
|
|
If constsubfunc(hashresref) = subfuncn Then
|
|
'If merely redefining a CONST with same value
|
|
'just issue a warning instead of an error
|
|
issueWarning = 0
|
|
If t And ISSTRING Then
|
|
If conststring(hashresref) = e$ Then issueWarning = -1: thisconstval$ = e$
|
|
Else
|
|
If t And ISFLOAT Then
|
|
If constfloat(hashresref) = constval## Then issueWarning = -1: thisconstval$ = Str$(constval##)
|
|
Else
|
|
If t And ISUNSIGNED Then
|
|
If constuinteger(hashresref) = constval~&& Then issueWarning = -1: thisconstval$ = Str$(constval~&&)
|
|
Else
|
|
If constinteger(hashresref) = constval&& Then issueWarning = -1: thisconstval$ = Str$(constval&&)
|
|
End If
|
|
End If
|
|
End If
|
|
If issueWarning Then
|
|
If Not IgnoreWarnings Then
|
|
addWarning linenumber, inclevel, inclinenumber(inclevel), incname$(inclevel), "duplicate constant definition", n$ + " =" + thisconstval$
|
|
End If
|
|
GoTo constAddDone
|
|
Else
|
|
a$ = "Name already in use": GoTo errmes
|
|
End If
|
|
End If
|
|
End If
|
|
If hashresflags And HASHFLAG_RESERVED Then
|
|
a$ = "Name already in use": GoTo errmes
|
|
End If
|
|
If hashresflags And (HASHFLAG_SUB + HASHFLAG_FUNCTION) Then
|
|
If ids(hashresref).internal_subfunc = 0 Or RTrim$(ids(hashresref).musthave) <> "$" Then a$ = "Name already in use": GoTo errmes
|
|
If t And ISSTRING Then a$ = "Name already in use": GoTo errmes
|
|
End If
|
|
If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0
|
|
Loop
|
|
|
|
'add to hash table
|
|
HashAdd hashname$, HASHFLAG_CONSTANT, i2
|
|
|
|
|
|
|
|
|
|
|
|
constdefined(i2) = 1
|
|
constcname(i2) = n$
|
|
constnamesymbol(i2) = typevalue2symbol$(t)
|
|
If Error_Happened Then GoTo errmes
|
|
consttype(i2) = t
|
|
If t And ISSTRING Then
|
|
conststring(i2) = e$
|
|
Else
|
|
If t And ISFLOAT Then
|
|
constfloat(i2) = constval##
|
|
Else
|
|
If t And ISUNSIGNED Then
|
|
constuinteger(i2) = constval~&&
|
|
Else
|
|
constinteger(i2) = constval&&
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
constAddDone:
|
|
|
|
If pending Then
|
|
'l$ = l$ + sp2 + ","
|
|
GoTo constdefpendingpp
|
|
End If
|
|
|
|
'layoutdone = 1: IF LEN(layout$) THEN layout$ = layout$ + sp + l$ ELSE layout$ = l$
|
|
GoTo finishedlinepp
|
|
End If
|
|
|
|
|
|
|
|
'DEFINE
|
|
d = 0
|
|
If firstelement$ = "DEFINT" Then d = 1
|
|
If firstelement$ = "DEFLNG" Then d = 1
|
|
If firstelement$ = "DEFSNG" Then d = 1
|
|
If firstelement$ = "DEFDBL" Then d = 1
|
|
If firstelement$ = "DEFSTR" Then d = 1
|
|
If firstelement$ = "_DEFINE" Or (firstelement$ = "DEFINE" And qb64prefix_set = 1) Then d = 1
|
|
If d Then
|
|
predefining = 1: GoTo predefine
|
|
predefined: predefining = 0
|
|
GoTo finishedlinepp
|
|
End If
|
|
|
|
'declare library
|
|
If firstelement$ = "DECLARE" Then
|
|
If secondelement$ = "LIBRARY" Or secondelement$ = "DYNAMIC" Or secondelement$ = "CUSTOMTYPE" Or secondelement$ = "STATIC" Then
|
|
declaringlibrary = 1
|
|
indirectlibrary = 0
|
|
If secondelement$ = "CUSTOMTYPE" Or secondelement$ = "DYNAMIC" Then indirectlibrary = 1
|
|
GoTo finishedlinepp
|
|
End If
|
|
End If
|
|
|
|
'SUB/FUNCTION
|
|
dynamiclibrary = 0
|
|
declaresubfunc:
|
|
firstelement$ = getelement$(a$, 1)
|
|
sf = 0
|
|
If firstelement$ = "FUNCTION" Then sf = 1
|
|
If firstelement$ = "SUB" Then sf = 2
|
|
If sf Then
|
|
|
|
subfuncn = subfuncn + 1
|
|
|
|
If n = 1 Then a$ = "Expected name after SUB/FUNCTION": GoTo errmes
|
|
|
|
'convert periods to _046_
|
|
i2 = InStr(a$, sp + "." + sp)
|
|
If i2 Then
|
|
Do
|
|
a$ = Left$(a$, i2 - 1) + fix046$ + Right$(a$, Len(a$) - i2 - 2)
|
|
ca$ = Left$(ca$, i2 - 1) + fix046$ + Right$(ca$, Len(ca$) - i2 - 2)
|
|
i2 = InStr(a$, sp + "." + sp)
|
|
Loop Until i2 = 0
|
|
n = numelements(a$)
|
|
firstelement$ = getelement(a$, 1): secondelement$ = getelement(a$, 2): thirdelement$ = getelement(a$, 3)
|
|
End If
|
|
|
|
n$ = getelement$(ca$, 2)
|
|
symbol$ = removesymbol$(n$)
|
|
If Error_Happened Then GoTo errmes
|
|
If sf = 2 And symbol$ <> "" Then a$ = "Type symbols after a SUB name are invalid": GoTo errmes
|
|
|
|
'remove STATIC (which is ignored)
|
|
e$ = getelement$(a$, n): If e$ = "STATIC" Then a$ = Left$(a$, Len(a$) - 7): ca$ = Left$(ca$, Len(ca$) - 7): n = n - 1
|
|
|
|
'check for ALIAS
|
|
aliasname$ = n$ 'use given name by default
|
|
If n > 2 Then
|
|
e$ = getelement$(a$, 3)
|
|
If e$ = "ALIAS" Then
|
|
If declaringlibrary = 0 Then a$ = "ALIAS can only be used with DECLARE LIBRARY": GoTo errmes
|
|
If n = 3 Then a$ = "Expected ALIAS name-in-library": GoTo errmes
|
|
e$ = getelement$(ca$, 4)
|
|
'strip string content (optional)
|
|
If Left$(e$, 1) = Chr$(34) Then
|
|
e$ = Right$(e$, Len(e$) - 1)
|
|
x = InStr(e$, Chr$(34)): If x = 0 Then a$ = "Expected " + Chr$(34): GoTo errmes
|
|
e$ = Left$(e$, x - 1)
|
|
End If
|
|
'strip fix046$ (created by unquoted periods)
|
|
Do While InStr(e$, fix046$)
|
|
x = InStr(e$, fix046$): e$ = Left$(e$, x - 1) + "." + Right$(e$, Len(e$) - x + 1 - Len(fix046$))
|
|
Loop
|
|
'validate alias name
|
|
If Len(e$) = 0 Then a$ = "Expected ALIAS name-in-library": GoTo errmes
|
|
For x = 1 To Len(e$)
|
|
a = Asc(e$, x)
|
|
If alphanumeric(a) = 0 And a <> ASC_FULLSTOP And a <> ASC_COLON Then a$ = "Expected ALIAS name-in-library": GoTo errmes
|
|
Next
|
|
aliasname$ = e$
|
|
'remove ALIAS section from line
|
|
If n <= 4 Then a$ = getelements(a$, 1, 2)
|
|
If n >= 5 Then a$ = getelements(a$, 1, 2) + sp + getelements(a$, 5, n)
|
|
If n <= 4 Then ca$ = getelements(ca$, 1, 2)
|
|
If n >= 5 Then ca$ = getelements(ca$, 1, 2) + sp + getelements(ca$, 5, n)
|
|
n = n - 2
|
|
End If
|
|
End If
|
|
|
|
If declaringlibrary Then
|
|
If indirectlibrary Then
|
|
aliasname$ = n$ 'override the alias name
|
|
End If
|
|
End If
|
|
|
|
params = 0
|
|
params$ = ""
|
|
paramsize$ = ""
|
|
nele$ = ""
|
|
nelereq$ = ""
|
|
If n > 2 Then
|
|
e$ = getelement$(a$, 3)
|
|
If e$ <> "(" Then a$ = "Expected (": GoTo errmes
|
|
e$ = getelement$(a$, n)
|
|
If e$ <> ")" Then a$ = "Expected )": GoTo errmes
|
|
If n < 4 Then a$ = "Expected ( ... )": GoTo errmes
|
|
If n = 4 Then GoTo nosfparams
|
|
B = 0
|
|
a2$ = ""
|
|
For i = 4 To n - 1
|
|
e$ = getelement$(a$, i)
|
|
If e$ = "(" Then B = B + 1
|
|
If e$ = ")" Then B = B - 1
|
|
If e$ = "," And B = 0 Then
|
|
If i = n - 1 Then a$ = "Expected , ... )": GoTo errmes
|
|
getlastparam:
|
|
If a2$ = "" Then a$ = "Expected ... ,": GoTo errmes
|
|
a2$ = Left$(a2$, Len(a2$) - 1)
|
|
'possible format: [BYVAL]a[%][(1)][AS][type]
|
|
n2 = numelements(a2$)
|
|
array = 0
|
|
t2$ = ""
|
|
|
|
i2 = 1
|
|
e$ = getelement$(a2$, i2): i2 = i2 + 1
|
|
|
|
byvalue = 0
|
|
If e$ = "BYVAL" Then
|
|
If declaringlibrary = 0 Then a$ = "BYVAL can currently only be used with DECLARE LIBRARY": GoTo errmes
|
|
e$ = getelement$(a2$, i2): i2 = i2 + 1: byvalue = 1
|
|
End If
|
|
|
|
n2$ = e$
|
|
symbol2$ = removesymbol$(n2$)
|
|
If validname(n2$) = 0 Then a$ = "Invalid name": GoTo errmes
|
|
|
|
If Error_Happened Then GoTo errmes
|
|
m = 0
|
|
For i2 = i2 To n2
|
|
e$ = getelement$(a2$, i2)
|
|
If e$ = "(" Then
|
|
If m <> 0 Then a$ = "Syntax error": GoTo errmes
|
|
m = 1
|
|
array = 1
|
|
GoTo gotaa
|
|
End If
|
|
If e$ = ")" Then
|
|
If m <> 1 Then a$ = "Syntax error": GoTo errmes
|
|
m = 2
|
|
GoTo gotaa
|
|
End If
|
|
If e$ = "AS" Then
|
|
If m <> 0 And m <> 2 Then a$ = "Syntax error": GoTo errmes
|
|
m = 3
|
|
GoTo gotaa
|
|
End If
|
|
If m = 1 Then GoTo gotaa 'ignore contents of bracket
|
|
If m <> 3 Then a$ = "Syntax error": GoTo errmes
|
|
If t2$ = "" Then t2$ = e$ Else t2$ = t2$ + " " + e$
|
|
gotaa:
|
|
Next i2
|
|
|
|
params = params + 1: If params > 100 Then a$ = "SUB/FUNCTION exceeds 100 parameter limit": GoTo errmes
|
|
|
|
argnelereq = 0
|
|
|
|
If symbol2$ <> "" And t2$ <> "" Then a$ = "Syntax error": GoTo errmes
|
|
If t2$ = "" Then t2$ = symbol2$
|
|
If t2$ = "" Then
|
|
If Left$(n2$, 1) = "_" Then v = 27 Else v = Asc(UCase$(n2$)) - 64
|
|
t2$ = defineaz(v)
|
|
End If
|
|
|
|
paramsize = 0
|
|
If array = 1 Then
|
|
t = typname2typ(t2$)
|
|
If Error_Happened Then GoTo errmes
|
|
If t = 0 Then a$ = "Illegal SUB/FUNCTION parameter": GoTo errmes
|
|
If (t And ISFIXEDLENGTH) Then paramsize = typname2typsize
|
|
t = t + ISARRAY
|
|
'check for recompilation override
|
|
For i10 = 0 To sflistn
|
|
If sfidlist(i10) = idn + 1 Then
|
|
If sfarglist(i10) = params Then
|
|
argnelereq = sfelelist(i10)
|
|
End If
|
|
End If
|
|
Next
|
|
Else
|
|
t = typname2typ(t2$)
|
|
If Error_Happened Then GoTo errmes
|
|
If t = 0 Then a$ = "Illegal SUB/FUNCTION parameter": GoTo errmes
|
|
If (t And ISFIXEDLENGTH) Then paramsize = typname2typsize
|
|
|
|
If byvalue Then
|
|
If t And ISPOINTER Then t = t - ISPOINTER
|
|
End If
|
|
|
|
End If
|
|
nelereq$ = nelereq$ + Chr$(argnelereq)
|
|
|
|
'consider changing 0 in following line too!
|
|
nele$ = nele$ + Chr$(0)
|
|
|
|
paramsize$ = paramsize$ + MKL$(paramsize)
|
|
params$ = params$ + MKL$(t)
|
|
a2$ = ""
|
|
Else
|
|
a2$ = a2$ + e$ + sp
|
|
If i = n - 1 Then GoTo getlastparam
|
|
End If
|
|
Next i
|
|
End If 'n>2
|
|
nosfparams:
|
|
|
|
If sf = 1 Then
|
|
'function
|
|
clearid
|
|
id.n = n$
|
|
id.subfunc = 1
|
|
|
|
id.callname = "FUNC_" + UCase$(n$)
|
|
If declaringlibrary Then
|
|
id.ccall = 1
|
|
If indirectlibrary = 0 Then id.callname = aliasname$
|
|
End If
|
|
id.args = params
|
|
id.arg = params$
|
|
id.argsize = paramsize$
|
|
id.nele = nele$
|
|
id.nelereq = nelereq$
|
|
If symbol$ <> "" Then
|
|
id.ret = typname2typ(symbol$)
|
|
If Error_Happened Then GoTo errmes
|
|
Else
|
|
If Left$(n$, 1) = "_" Then v = 27 Else v = Asc(UCase$(n$)) - 64
|
|
symbol$ = defineaz(v)
|
|
id.ret = typname2typ(symbol$)
|
|
If Error_Happened Then GoTo errmes
|
|
End If
|
|
If id.ret = 0 Then a$ = "Invalid FUNCTION return type": GoTo errmes
|
|
|
|
If declaringlibrary Then
|
|
|
|
ctype$ = typ2ctyp$(id.ret, "")
|
|
If Error_Happened Then GoTo errmes
|
|
If ctype$ = "qbs" Then ctype$ = "char*"
|
|
id.callname = "( " + ctype$ + " )" + RTrim$(id.callname)
|
|
|
|
End If
|
|
|
|
s$ = Left$(symbol$, 1)
|
|
If s$ <> "~" And s$ <> "`" And s$ <> "%" And s$ <> "&" And s$ <> "!" And s$ <> "#" And s$ <> "$" Then
|
|
symbol$ = type2symbol$(symbol$)
|
|
If Error_Happened Then GoTo errmes
|
|
End If
|
|
id.mayhave = symbol$
|
|
If id.ret And ISPOINTER Then
|
|
If (id.ret And ISSTRING) = 0 Then id.ret = id.ret - ISPOINTER
|
|
End If
|
|
regid
|
|
If Error_Happened Then GoTo errmes
|
|
Else
|
|
'sub
|
|
clearid
|
|
id.n = n$
|
|
id.subfunc = 2
|
|
id.callname = "SUB_" + UCase$(n$)
|
|
If declaringlibrary Then
|
|
id.ccall = 1
|
|
If indirectlibrary = 0 Then id.callname = aliasname$
|
|
End If
|
|
id.args = params
|
|
id.arg = params$
|
|
id.argsize = paramsize$
|
|
id.nele = nele$
|
|
id.nelereq = nelereq$
|
|
|
|
If UCase$(n$) = "_GL" And params = 0 And UseGL = 0 Then reginternalsubfunc = 1: UseGL = 1: id.n = "_GL": DEPENDENCY(DEPENDENCY_GL) = 1
|
|
regid
|
|
reginternalsubfunc = 0
|
|
|
|
If Error_Happened Then GoTo errmes
|
|
End If
|
|
|
|
|
|
End If
|
|
|
|
'========================================
|
|
finishedlinepp:
|
|
firstLine = 0
|
|
End If
|
|
a$ = ""
|
|
ca$ = ""
|
|
Else
|
|
If a$ = "" Then a$ = e$: ca$ = ce$ Else a$ = a$ + sp + e$: ca$ = ca$ + sp + ce$
|
|
End If
|
|
If wholelinei <= wholelinen Then wholelinei = wholelinei + 1: GoTo ppblda
|
|
'----------------------------------------
|
|
End If 'wholelinei<=wholelinen
|
|
End If 'wholelinen
|
|
End If 'len(wholeline$)
|
|
|
|
'Include Manager #1
|
|
|
|
|
|
|
|
If Len(addmetainclude$) Then
|
|
If Debug Then Print #9, "Pre-pass:INCLUDE$-ing file:'" + addmetainclude$ + "':On line"; linenumber
|
|
a$ = addmetainclude$: addmetainclude$ = "" 'read/clear message
|
|
|
|
If inclevel = 100 Then a$ = "Too many indwelling INCLUDE files": GoTo errmes
|
|
'1. Verify file exists (location is either (a)relative to source file or (b)absolute)
|
|
fh = 99 + inclevel + 1
|
|
|
|
firstTryMethod = 1
|
|
For try = firstTryMethod To 2 'if including file from root, do not attempt including from relative location
|
|
If try = 1 Then
|
|
If inclevel = 0 Then
|
|
If idemode Then p$ = idepath$ + pathsep$ Else p$ = getfilepath$(sourcefile$)
|
|
Else
|
|
p$ = getfilepath$(incname(inclevel))
|
|
End If
|
|
f$ = p$ + a$
|
|
End If
|
|
If try = 2 Then f$ = a$
|
|
If _FileExists(f$) Then
|
|
qberrorhappened = -3
|
|
'We're using the faster LINE INPUT, which requires a BINARY open.
|
|
Open f$ For Binary As #fh
|
|
'And another line below edited
|
|
qberrorhappened3:
|
|
If qberrorhappened = -3 Then Exit For
|
|
End If
|
|
qberrorhappened = 0
|
|
Next
|
|
If qberrorhappened <> -3 Then qberrorhappened = 0: a$ = "File " + a$ + " not found": GoTo errmes
|
|
inclevel = inclevel + 1: incname$(inclevel) = f$: inclinenumber(inclevel) = 0
|
|
End If 'fall through to next section...
|
|
'--------------------
|
|
Do While inclevel
|
|
|
|
fh = 99 + inclevel
|
|
'2. Feed next line
|
|
If EOF(fh) = 0 Then
|
|
Line Input #fh, x$
|
|
|
|
wholeline$ = x$
|
|
inclinenumber(inclevel) = inclinenumber(inclevel) + 1
|
|
'create extended error string 'incerror$'
|
|
errorLineInInclude = inclinenumber(inclevel)
|
|
e$ = " in line " + str2(inclinenumber(inclevel)) + " of " + incname$(inclevel) + " included"
|
|
If inclevel > 1 Then
|
|
e$ = e$ + " (through "
|
|
For x = 1 To inclevel - 1 Step 1
|
|
e$ = e$ + incname$(x)
|
|
If x < inclevel - 1 Then 'a sep is req
|
|
If x = inclevel - 2 Then
|
|
e$ = e$ + " then "
|
|
Else
|
|
e$ = e$ + ", "
|
|
End If
|
|
End If
|
|
Next
|
|
e$ = e$ + ")"
|
|
End If
|
|
incerror$ = e$
|
|
linenumber = linenumber - 1 'lower official linenumber to counter later increment
|
|
|
|
If Debug Then Print #9, "Pre-pass:Feeding INCLUDE$ line:[" + wholeline$ + "]"
|
|
|
|
If idemode Then sendc$ = Chr$(10) + wholeline$: GoTo sendcommand 'passback
|
|
GoTo ideprepass
|
|
End If
|
|
'3. Close & return control
|
|
Close #fh
|
|
inclevel = inclevel - 1
|
|
Loop
|
|
'(end manager)
|
|
|
|
If idemode Then GoTo ideret2
|
|
Loop
|
|
|
|
'add final line
|
|
If lastLineReturn = 0 Then
|
|
lastLineReturn = 1
|
|
lastLine = 1
|
|
wholeline$ = ""
|
|
GoTo prepassLastLine
|
|
End If
|
|
|
|
If definingtype Then definingtype = 0 'ignore this error so that auto-formatting can be performed and catch it again later
|
|
If declaringlibrary Then declaringlibrary = 0 'ignore this error so that auto-formatting can be performed and catch it again later
|
|
|
|
totallinenumber = reallinenumber
|
|
|
|
'IF idemode = 0 AND NOT QuietMode THEN PRINT "first pass finished.": PRINT "Translating code... "
|
|
|
|
'prepass finished
|
|
|
|
lineinput3index = 1 'reset input line
|
|
|
|
'ide specific
|
|
ide3:
|
|
|
|
addmetainclude$ = "" 'reset stray meta-includes
|
|
|
|
'reset altered variables
|
|
DataOffset = 0
|
|
inclevel = 0
|
|
subfuncn = 0
|
|
lastLineReturn = 0
|
|
lastLine = 0
|
|
firstLine = 1
|
|
UserDefineCount = 7
|
|
|
|
For i = 0 To constlast: constdefined(i) = 0: Next 'undefine constants
|
|
|
|
For i = 1 To 27: defineaz(i) = "SINGLE": defineextaz(i) = "!": Next
|
|
|
|
Open tmpdir$ + "data.bin" For Output As #16: Close #16
|
|
Open tmpdir$ + "data.bin" For Binary As #16
|
|
|
|
|
|
Open tmpdir$ + "main.txt" For Output As #12
|
|
Open tmpdir$ + "maindata.txt" For Output As #13
|
|
|
|
Open tmpdir$ + "regsf.txt" For Output As #17
|
|
|
|
Open tmpdir$ + "mainfree.txt" For Output As #19
|
|
Open tmpdir$ + "runline.txt" For Output As #21
|
|
|
|
Open tmpdir$ + "mainerr.txt" For Output As #14 'main error handler
|
|
'i. check the value of error_line
|
|
'ii. jump to the appropriate label
|
|
errorlabels = 0
|
|
Print #14, "if (error_occurred){ error_occurred=0;"
|
|
|
|
Open tmpdir$ + "chain.txt" For Output As #22: Close #22 'will be appended to as necessary
|
|
Open tmpdir$ + "inpchain.txt" For Output As #23: Close #23 'will be appended to as necessary
|
|
'*** #22 & #23 are reserved for usage by chain & inpchain ***
|
|
|
|
Open tmpdir$ + "ontimer.txt" For Output As #24
|
|
Open tmpdir$ + "ontimerj.txt" For Output As #25
|
|
|
|
'*****#26 used for locking qb64
|
|
|
|
Open tmpdir$ + "onkey.txt" For Output As #27
|
|
Open tmpdir$ + "onkeyj.txt" For Output As #28
|
|
|
|
Open tmpdir$ + "onstrig.txt" For Output As #29
|
|
Open tmpdir$ + "onstrigj.txt" For Output As #30
|
|
|
|
gosubid = 1
|
|
'to be included whenever return without a label is called
|
|
|
|
'return [label] in QBASIC was not possible in a sub/function, but QB64 will support this
|
|
'special codes will represent special return conditions:
|
|
'0=return from main to calling sub/function/proc by return [NULL];
|
|
'1... a global number representing a return point after a gosub
|
|
'note: RETURN [label] should fail if a "return [NULL];" type return is required
|
|
Open tmpdir$ + "ret0.txt" For Output As #15
|
|
Print #15, "if (next_return_point){"
|
|
Print #15, "next_return_point--;"
|
|
Print #15, "switch(return_point[next_return_point]){"
|
|
Print #15, "case 0:"
|
|
|
|
Print #15, "return;"
|
|
|
|
Print #15, "break;"
|
|
|
|
continueline = 0
|
|
endifs = 0
|
|
lineelseused = 0
|
|
continuelinefrom = 0
|
|
linenumber = 0
|
|
reallinenumber = 0
|
|
declaringlibrary = 0
|
|
|
|
Print #12, "S_0:;" 'note: REQUIRED by run statement
|
|
|
|
If UseGL Then gl_include_content
|
|
|
|
|
|
'ide specific
|
|
If idemode Then GoTo ideret3
|
|
|
|
Do
|
|
ide4:
|
|
includeline:
|
|
mainpassLastLine:
|
|
|
|
prepass = 0
|
|
|
|
stringprocessinghappened = 0
|
|
|
|
If continuelinefrom Then
|
|
start = continuelinefrom
|
|
continuelinefrom = 0
|
|
GoTo contline
|
|
End If
|
|
|
|
'begin a new line
|
|
|
|
impliedendif = 0
|
|
THENGOTO = 0
|
|
continueline = 0
|
|
endifs = 0
|
|
lineelseused = 0
|
|
newif = 0
|
|
|
|
'apply metacommands from previous line
|
|
If addmetadynamic = 1 Then addmetadynamic = 0: DynamicMode = 1
|
|
If addmetastatic = 1 Then addmetastatic = 0: DynamicMode = 0
|
|
|
|
'a3$ is passed in idemode and when using $include
|
|
If idemode = 0 And inclevel = 0 Then a3$ = lineinput3$
|
|
If a3$ = Chr$(13) Then Exit Do
|
|
linenumber = linenumber + 1
|
|
reallinenumber = reallinenumber + 1
|
|
If linenumber = 1 Then opex_comments = -1
|
|
|
|
If InValidLine(linenumber) Then
|
|
layoutok = 1
|
|
layout$ = Space$(controllevel) + LTrim$(RTrim$(a3$))
|
|
If idemode GoTo ideret4 Else GoTo skipide4
|
|
End If
|
|
|
|
layout = ""
|
|
layoutok = 1
|
|
|
|
If idemode = 0 And Not QuietMode Then
|
|
'IF LEN(a3$) THEN
|
|
' dotlinecount = dotlinecount + 1: IF dotlinecount >= 100 THEN dotlinecount = 0: PRINT ".";
|
|
'END IF
|
|
maxprogresswidth = 50 'arbitrary
|
|
percentage = Int(reallinenumber / totallinenumber * 100)
|
|
percentagechars = Int(maxprogresswidth * reallinenumber / totallinenumber)
|
|
If percentage <> prevpercentage And percentagechars <> prevpercentagechars Then
|
|
prevpercentage = percentage
|
|
prevpercentagechars = percentagechars
|
|
If ConsoleMode Then
|
|
Print "[" + String$(percentagechars, ".") + Space$(maxprogresswidth - percentagechars) + "]" + Str$(percentage) + "%";
|
|
If os$ = "LNX" Then
|
|
Print Chr$(27) + "[A"
|
|
Else
|
|
Print Chr$(13);
|
|
End If
|
|
Else
|
|
Locate , 1
|
|
Print String$(percentagechars, 219) + String$(maxprogresswidth - percentagechars, 176) + Str$(percentage) + "%";
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
a3$ = LTrim$(RTrim$(a3$))
|
|
wholeline = a3$
|
|
|
|
layoutoriginal$ = a3$
|
|
layoutcomment$ = "" 'clear any previous layout comment
|
|
lhscontrollevel = controllevel
|
|
|
|
linefragment = "[INFORMATION UNAVAILABLE]"
|
|
If Len(a3$) = 0 Then GoTo finishednonexec
|
|
If Debug Then Print #9, "########" + a3$ + "########"
|
|
|
|
layoutdone = 1 'validates layout of any following goto finishednonexec/finishedline
|
|
|
|
'We've already figured out in the prepass which lines are invalidated by the precompiler
|
|
'No need to go over those lines again.
|
|
'IF InValidLine(linenumber) THEN goto skipide4 'layoutdone = 0: GOTO finishednonexec
|
|
|
|
a3u$ = UCase$(a3$)
|
|
|
|
IF LEFT$(a3u$, 4) = "REM " OR _
|
|
(LEFT$(a3u$, 3) = "REM" AND LEN(a3u$) = 3) OR _
|
|
LEFT$(a3u$, 1) = "'" OR _
|
|
(LEFT$(a3u$, 7) = "OPTION " AND LEFT$(LTRIM$(MID$(a3u$, 8)), 9) = "_EXPLICIT") OR _
|
|
(LEFT$(a3u$, 7) = "OPTION " AND LEFT$(LTRIM$(MID$(a3u$, 8)), 8) = "EXPLICIT" AND qb64prefix_set = 1) OR _
|
|
LEFT$(a3u$, 1) = "$" THEN
|
|
'It's a comment, $metacommand, or OPTION _EXPLICIT itself, alright.
|
|
'But even being a comment, there could be an $INCLUDE in there, let's check:
|
|
If Left$(a3u$, 4) = "REM " Then i = 5 Else i = 2
|
|
If Left$(LTrim$(Mid$(a3u$, i)), 8) = "$INCLUDE" Then opex_comments = 0
|
|
Else
|
|
'As soon as a line isn't a comment anymore, it can't come before OPTION _EXPLICIT
|
|
opex_comments = 0
|
|
End If
|
|
|
|
'QB64 Metacommands
|
|
If Asc(a3$) = 36 Then '$
|
|
|
|
'precompiler commands should always be executed FIRST.
|
|
If a3u$ = "$END IF" Or a3u$ = "$ENDIF" Then
|
|
If DefineElse(ExecCounter) = 0 Then a$ = "$END IF without $IF": GoTo errmes
|
|
DefineElse(ExecCounter) = 0 'We no longer have an $IF block at this level
|
|
ExecCounter = ExecCounter - 1
|
|
layout$ = SCase$("$End If")
|
|
controltype(controllevel) = 0
|
|
controllevel = controllevel - 1
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If Left$(a3u$, 4) = "$IF " Then
|
|
'prevents code from being placed before 'CASE condition' in a SELECT CASE block
|
|
If SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then
|
|
a$ = "Expected CASE expression": GoTo errmes
|
|
End If
|
|
|
|
temp$ = LTrim$(Mid$(a3u$, 4)) 'strip off the $IF and extra spaces
|
|
temp$ = RTrim$(Left$(temp$, Len(temp$) - 4)) 'and strip off the THEN and extra spaces
|
|
temp = InStr(temp$, "=")
|
|
|
|
ExecCounter = ExecCounter + 1
|
|
ExecLevel(ExecCounter) = -1 'default to a skip value
|
|
DefineElse(ExecCounter) = 1 '1 says we have an $IF statement at this level
|
|
result = EvalPreIF(temp$, a$)
|
|
If a$ <> "" Then GoTo errmes
|
|
If result <> 0 Then
|
|
ExecLevel(ExecCounter) = ExecLevel(ExecCounter - 1) 'So we inherit the execlevel from above
|
|
If ExecLevel(ExecCounter) = 0 Then DefineElse(ExecCounter) = DefineElse(ExecCounter) Or 4 'Else if used and conditon found
|
|
End If
|
|
|
|
controllevel = controllevel + 1
|
|
controltype(controllevel) = 6
|
|
If temp = 0 Then layout$ = SCase$("$If ") + temp$ + SCase$(" Then"): GoTo finishednonexec 'no = sign in the $IF statement, so we're going to assume the user is doing something like $IF flag
|
|
l$ = RTrim$(Left$(temp$, temp - 1)): r$ = LTrim$(Mid$(temp$, temp + 1))
|
|
layout$ = SCase$("$If ") + l$ + " = " + r$ + SCase$(" Then")
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If a3u$ = "$ELSE" Then
|
|
If DefineElse(ExecCounter) = 0 Then a$ = "$ELSE without $IF": GoTo errmes
|
|
If DefineElse(ExecCounter) And 2 Then a$ = "$IF block already has $ELSE statement in it": GoTo errmes
|
|
DefineElse(ExecCounter) = DefineElse(ExecCounter) Or 2 'set the flag to declare an $ELSE already in this block
|
|
If DefineElse(ExecCounter) And 4 Then 'If we executed code in a previous IF or ELSE IF statement, we can't do it here
|
|
ExecLevel(ExecCounter) = -1 'So we inherit the execlevel from above
|
|
Else
|
|
ExecLevel(ExecCounter) = ExecLevel(ExecCounter - 1) 'If we were processing code before, code after this segment is going to be SKIPPED
|
|
End If
|
|
layout$ = SCase$("$Else")
|
|
lhscontrollevel = lhscontrollevel - 1
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If Left$(a3u$, 5) = "$ELSE" Then
|
|
temp$ = LTrim$(Mid$(a3u$, 6))
|
|
If Left$(temp$, 3) = "IF " Then
|
|
If DefineElse(ExecCounter) = 0 Then a$ = "$ELSE IF without $IF": GoTo errmes
|
|
If DefineElse(ExecCounter) And 2 Then a$ = "$ELSE IF cannot follow $ELSE": GoTo errmes
|
|
If Right$(temp$, 5) <> " THEN" Then a$ = "$ELSE IF without THEN": GoTo errmes
|
|
temp$ = LTrim$(Mid$(temp$, 3)) 'strip off the IF and extra spaces
|
|
temp$ = RTrim$(Left$(temp$, Len(temp$) - 4)) 'and strip off the THEN and extra spaces
|
|
If DefineElse(ExecCounter) And 4 Then 'If we executed code in a previous IF or ELSE IF statement, we can't do it here
|
|
ExecLevel(ExecCounter) = -1
|
|
Else
|
|
result = EvalPreIF(temp$, a$)
|
|
If a$ <> "" Then GoTo errmes
|
|
If result <> 0 Then
|
|
ExecLevel(ExecCounter) = ExecLevel(ExecCounter - 1) 'So we inherit the execlevel from above
|
|
If ExecLevel(ExecCounter) = 0 Then DefineElse(ExecCounter) = DefineElse(ExecCounter) Or 4 'Else if used and conditon found
|
|
End If
|
|
End If
|
|
|
|
|
|
lhscontrollevel = lhscontrollevel - 1
|
|
temp = InStr(temp$, "=")
|
|
If temp = 0 Then layout$ = SCase$("$ElseIf ") + temp$ + SCase$(" Then"): GoTo finishednonexec 'no = sign in the $IF statement, so we're going to assume the user is doing something like $IF flag
|
|
l$ = RTrim$(Left$(temp$, temp - 1)): r$ = LTrim$(Mid$(temp$, temp + 1))
|
|
layout$ = SCase$("$ElseIf ") + l$ + " = " + r$ + SCase$(" Then")
|
|
GoTo finishednonexec
|
|
End If
|
|
End If
|
|
|
|
If ExecLevel(ExecCounter) Then 'don't check for any more metacommands except the one's which worth with the precompiler
|
|
layoutdone = 0
|
|
GoTo finishednonexec 'we don't check for anything inside lines that we've marked for skipping
|
|
End If
|
|
|
|
If Left$(a3u$, 5) = "$LET " Then
|
|
temp$ = a3u$
|
|
temp$ = LTrim$(Mid$(temp$, 5)) 'simply shorten our string to parse
|
|
'For starters, let's make certain that we have 3 elements to deal with
|
|
temp = InStr(temp$, "=") 'without an = in there, we can't get a value from the left and right side
|
|
l$ = RTrim$(Left$(temp$, temp - 1)): r$ = LTrim$(Mid$(temp$, temp + 1))
|
|
layout$ = SCase$("$Let ") + l$ + " = " + r$
|
|
'First look to see if we have an existing setting like this and if so, update it
|
|
For i = 7 To UserDefineCount 'UserDefineCount 1-7 are reserved for automatic OS/BIT detection & version
|
|
If UserDefine(0, i) = l$ Then UserDefine(1, i) = r$: GoTo finishednonexec
|
|
Next
|
|
'Otherwise create a new setting and set the initial value for it
|
|
UserDefineCount = UserDefineCount + 1
|
|
If UserDefineCount > UBound(UserDefine, 2) Then
|
|
ReDim _Preserve UserDefine(1, UBound(UserDefine, 2) + 10) 'Add another 10 elements to the array so it'll expand as the user adds to it
|
|
End If
|
|
UserDefine(0, UserDefineCount) = l$
|
|
UserDefine(1, UserDefineCount) = r$
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If a3u$ = "$COLOR:0" Then
|
|
layout$ = SCase$("$Color:0")
|
|
addmetainclude$ = getfilepath$(Command$(0)) + "source" + pathsep$ + "utilities" + pathsep$ + "color0.bi"
|
|
layoutdone = 1
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If a3u$ = "$COLOR:32" Then
|
|
layout$ = SCase$("$Color:32")
|
|
addmetainclude$ = getfilepath$(Command$(0)) + "source" + pathsep$ + "utilities" + pathsep$ + "color32.bi"
|
|
layoutdone = 1
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If a3u$ = "$NOPREFIX" Then
|
|
'already set in prepass
|
|
layout$ = SCase$("$NoPrefix")
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If a3u$ = "$VIRTUALKEYBOARD:ON" Then
|
|
'Deprecated; does nothing.
|
|
layout$ = SCase$("$VirtualKeyboard:On")
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If a3u$ = "$VIRTUALKEYBOARD:OFF" Then
|
|
'Deprecated; does nothing.
|
|
layout$ = SCase$("$VirtualKeyboard:Off")
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If a3u$ = "$CHECKING:OFF" Then
|
|
layout$ = SCase$("$Checking:Off")
|
|
NoChecks = 1
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If a3u$ = "$CHECKING:ON" Then
|
|
layout$ = SCase$("$Checking:On")
|
|
NoChecks = 0
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If a3u$ = "$CONSOLE" Then
|
|
layout$ = SCase$("$Console")
|
|
Console = 1
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If a3u$ = "$CONSOLE:ONLY" Then
|
|
layout$ = SCase$("$Console:Only")
|
|
DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) = DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) Or 1
|
|
Console = 1
|
|
If prepass = 0 Then
|
|
If NoChecks = 0 Then Print #12, "do{"
|
|
Print #12, "sub__dest(func__console());"
|
|
GoTo finishedline2
|
|
Else
|
|
GoTo finishednonexec
|
|
End If
|
|
End If
|
|
|
|
If a3u$ = "$ASSERTS" Then
|
|
layout$ = SCase$("$Asserts")
|
|
Asserts = 1
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If a3u$ = "$ASSERTS:CONSOLE" Then
|
|
layout$ = SCase$("$Asserts:Console")
|
|
Asserts = 1
|
|
Console = 1
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If a3u$ = "$SCREENHIDE" Then
|
|
layout$ = SCase$("$ScreenHide")
|
|
ScreenHide = 1
|
|
GoTo finishednonexec
|
|
End If
|
|
If a3u$ = "$SCREENSHOW" Then
|
|
layout$ = SCase$("$ScreenShow")
|
|
ScreenHide = 0
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If a3u$ = "$RESIZE:OFF" Then
|
|
layout$ = SCase$("$Resize:Off")
|
|
Resize = 0: Resize_Scale = 0
|
|
GoTo finishednonexec
|
|
End If
|
|
If a3u$ = "$RESIZE:ON" Then
|
|
layout$ = SCase$("$Resize:On")
|
|
Resize = 1: Resize_Scale = 0
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If a3u$ = "$RESIZE:STRETCH" Then
|
|
layout$ = SCase$("$Resize:Stretch")
|
|
Resize = 1: Resize_Scale = 1
|
|
GoTo finishednonexec
|
|
End If
|
|
If a3u$ = "$RESIZE:SMOOTH" Then
|
|
layout$ = SCase$("$Resize:Smooth")
|
|
Resize = 1: Resize_Scale = 2
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If Left$(a3u$, 12) = "$VERSIONINFO" Then
|
|
'Embed version info into the final binary (Windows only)
|
|
FirstDelimiter = InStr(a3u$, ":")
|
|
SecondDelimiter = InStr(FirstDelimiter + 1, a3u$, "=")
|
|
If FirstDelimiter = 0 Or SecondDelimiter = 0 Or SecondDelimiter = FirstDelimiter + 1 Then
|
|
a$ = "Expected $VERSIONINFO:key=value": GoTo errmes
|
|
End If
|
|
|
|
VersionInfoKey$ = LTrim$(RTrim$(Mid$(a3u$, FirstDelimiter + 1, SecondDelimiter - FirstDelimiter - 1)))
|
|
VersionInfoValue$ = StrReplace$(LTrim$(RTrim$(Mid$(a3$, SecondDelimiter + 1))), Chr$(34), "'")
|
|
|
|
Select Case VersionInfoKey$
|
|
Case "FILEVERSION#"
|
|
GoSub ValidateVersion
|
|
viFileVersionNum$ = VersionInfoValue$
|
|
layout$ = SCase$("$VersionInfo:FILEVERSION#=") + VersionInfoValue$
|
|
Case "PRODUCTVERSION#"
|
|
GoSub ValidateVersion
|
|
viProductVersionNum$ = VersionInfoValue$
|
|
layout$ = SCase$("$VersionInfo:PRODUCTVERSION#=") + VersionInfoValue$
|
|
Case "COMPANYNAME"
|
|
viCompanyName$ = VersionInfoValue$
|
|
layout$ = SCase$("$VersionInfo:") + "CompanyName=" + VersionInfoValue$
|
|
Case "FILEDESCRIPTION"
|
|
viFileDescription$ = VersionInfoValue$
|
|
layout$ = SCase$("$VersionInfo:") + "FileDescription=" + VersionInfoValue$
|
|
Case "FILEVERSION"
|
|
viFileVersion$ = VersionInfoValue$
|
|
layout$ = SCase$("$VersionInfo:") + "FileVersion=" + VersionInfoValue$
|
|
Case "INTERNALNAME"
|
|
viInternalName$ = VersionInfoValue$
|
|
layout$ = SCase$("$VersionInfo:") + "InternalName=" + VersionInfoValue$
|
|
Case "LEGALCOPYRIGHT"
|
|
viLegalCopyright$ = VersionInfoValue$
|
|
layout$ = SCase$("$VersionInfo:") + "LegalCopyright=" + VersionInfoValue$
|
|
Case "LEGALTRADEMARKS"
|
|
viLegalTrademarks$ = VersionInfoValue$
|
|
layout$ = SCase$("$VersionInfo:") + "LegalTrademarks=" + VersionInfoValue$
|
|
Case "ORIGINALFILENAME"
|
|
viOriginalFilename$ = VersionInfoValue$
|
|
layout$ = SCase$("$VersionInfo:") + "OriginalFilename=" + VersionInfoValue$
|
|
Case "PRODUCTNAME"
|
|
viProductName$ = VersionInfoValue$
|
|
layout$ = SCase$("$VersionInfo:") + "ProductName=" + VersionInfoValue$
|
|
Case "PRODUCTVERSION"
|
|
viProductVersion$ = VersionInfoValue$
|
|
layout$ = SCase$("$VersionInfo:") + "ProductVersion=" + VersionInfoValue$
|
|
Case "COMMENTS"
|
|
viComments$ = VersionInfoValue$
|
|
layout$ = SCase$("$VersionInfo:") + "Comments=" + VersionInfoValue$
|
|
Case "WEB"
|
|
viWeb$ = VersionInfoValue$
|
|
layout$ = SCase$("$VersionInfo:") + "Web=" + VersionInfoValue$
|
|
Case Else
|
|
a$ = "Invalid key. (Use FILEVERSION#, PRODUCTVERSION#, CompanyName, FileDescription, FileVersion, InternalName, LegalCopyright, LegalTrademarks, OriginalFilename, ProductName, ProductVersion, Comments or Web)"
|
|
GoTo errmes
|
|
End Select
|
|
|
|
VersionInfoSet = -1
|
|
|
|
GoTo finishednonexec
|
|
|
|
ValidateVersion:
|
|
'Check if only numbers and commas (4 comma-separated values)
|
|
If Len(VersionInfoValue$) = 0 Then a$ = "Expected $VERSIONINFO:" + VersionInfoKey$ + "=#,#,#,# (4 comma-separated numeric values: major, minor, revision and build)": GoTo errmes
|
|
viCommas = 0
|
|
For i = 1 To Len(VersionInfoValue$)
|
|
If Asc(VersionInfoValue$, i) = 44 Then viCommas = viCommas + 1
|
|
If InStr("0123456789,", Mid$(VersionInfoValue$, i, 1)) = 0 Or (i = Len(VersionInfoValue$) And viCommas <> 3) Or Right$(VersionInfoValue$, 1) = "," Then
|
|
a$ = "Expected $VERSIONINFO:" + VersionInfoKey$ + "=#,#,#,# (4 comma-separated numeric values: major, minor, revision and build)": GoTo errmes
|
|
End If
|
|
Next
|
|
Return
|
|
End If
|
|
|
|
If Left$(a3u$, 8) = "$EXEICON" Then
|
|
'Basic syntax check. Multi-platform.
|
|
If ExeIconSet Then a$ = "$EXEICON already defined": GoTo errmes
|
|
FirstDelimiter = InStr(a3u$, "'")
|
|
If FirstDelimiter = 0 Then
|
|
a$ = "Expected $EXEICON:'filename'": GoTo errmes
|
|
Else
|
|
SecondDelimiter = InStr(FirstDelimiter + 1, a3u$, "'")
|
|
If SecondDelimiter = 0 Then a$ = "Expected $EXEICON:'filename'": GoTo errmes
|
|
End If
|
|
ExeIconFile$ = RTrim$(LTrim$(Mid$(a3$, FirstDelimiter + 1, SecondDelimiter - FirstDelimiter - 1)))
|
|
If Len(ExeIconFile$) = 0 Then a$ = "Expected $EXEICON:'filename'": GoTo errmes
|
|
layout$ = SCase$("$ExeIcon:'") + ExeIconFile$ + "'" + Mid$(a3$, SecondDelimiter + 1)
|
|
|
|
If InStr(_OS$, "WIN") Then
|
|
'Actual metacommand processing. Windows only.
|
|
'Expand relative path to full path:
|
|
IconPath$ = ""
|
|
If Left$(ExeIconFile$, 2) = "./" Or Left$(ExeIconFile$, 2) = ".\" Then
|
|
'Relative to source file's folder
|
|
If NoIDEMode Then
|
|
IconPath$ = path.source$
|
|
If Len(IconPath$) > 0 And Right$(IconPath$, 1) <> pathsep$ Then IconPath$ = IconPath$ + pathsep$
|
|
Else
|
|
If Len(ideprogname) Then IconPath$ = idepath$ + pathsep$
|
|
End If
|
|
ExeIconFile$ = IconPath$ + Mid$(ExeIconFile$, 3)
|
|
ElseIf InStr(ExeIconFile$, "/") Or InStr(ExeIconFile$, "\") Then
|
|
For i = Len(ExeIconFile$) To 1 Step -1
|
|
If Mid$(ExeIconFile$, i, 1) = "/" Or Mid$(ExeIconFile$, i, 1) = "\" Then
|
|
IconPath$ = Left$(ExeIconFile$, i)
|
|
ExeIconFile$ = Mid$(ExeIconFile$, i + 1)
|
|
If _DirExists(IconPath$) = 0 Then a$ = "File '" + ExeIconFile$ + "' not found": GoTo errmes
|
|
currentdir$ = _CWD$
|
|
ChDir IconPath$
|
|
IconPath$ = _CWD$
|
|
ChDir currentdir$
|
|
ExeIconFile$ = IconPath$ + pathsep$ + ExeIconFile$
|
|
Exit For
|
|
End If
|
|
Next
|
|
End If
|
|
|
|
If _FileExists(ExeIconFile$) = 0 Then
|
|
If Len(IconPath$) Then
|
|
a$ = "File '" + Mid$(ExeIconFile$, Len(IconPath$) + 1) + "' not found": GoTo errmes
|
|
Else
|
|
a$ = "File '" + ExeIconFile$ + "' not found": GoTo errmes
|
|
End If
|
|
Else
|
|
iconfilehandle = FreeFile
|
|
E = 0
|
|
On Error GoTo qberror_test
|
|
Open tmpdir$ + "icon.rc" For Output As #iconfilehandle
|
|
Print #iconfilehandle, "0 ICON " + QuotedFilename$(StrReplace$(ExeIconFile$, "\", "/"))
|
|
Close #iconfilehandle
|
|
If E = 1 Then a$ = "Error creating icon resource file": GoTo errmes
|
|
On Error GoTo qberror
|
|
End If
|
|
End If
|
|
|
|
ExeIconSet = linenumber
|
|
SetDependency DEPENDENCY_ICON
|
|
If NoChecks = 0 Then Print #12, "do{"
|
|
Print #12, "sub__icon(NULL,NULL,0);"
|
|
GoTo finishedline2
|
|
End If
|
|
|
|
End If 'QB64 Metacommands
|
|
|
|
If ExecLevel(ExecCounter) Then
|
|
layoutdone = 0
|
|
GoTo finishednonexec 'we don't check for anything inside lines that we've marked for skipping
|
|
End If
|
|
|
|
|
|
linedataoffset = DataOffset
|
|
|
|
entireline$ = lineformat(a3$): If Len(entireline$) = 0 Then GoTo finishednonexec
|
|
If Error_Happened Then GoTo errmes
|
|
u$ = UCase$(entireline$)
|
|
|
|
newif = 0
|
|
|
|
'Convert "CASE ELSE" to "CASE C-EL" to avoid confusing compiler
|
|
'note: CASE does not have to begin on a new line
|
|
s = 1
|
|
i = InStr(s, u$, "CASE" + sp + "ELSE")
|
|
Do While i
|
|
skip = 0
|
|
If i <> 1 Then
|
|
If Mid$(u$, i - 1, 1) <> sp Then skip = 1
|
|
End If
|
|
If i <> Len(u$) - 8 Then
|
|
If Mid$(u$, i + 9, 1) <> sp Then skip = 1
|
|
End If
|
|
If skip = 0 Then
|
|
Mid$(entireline$, i) = "CASE" + sp + "C-EL"
|
|
u$ = UCase$(entireline$)
|
|
End If
|
|
s = i + 9
|
|
i = InStr(s, u$, "CASE" + sp + "ELSE")
|
|
Loop
|
|
|
|
n = numelements(entireline$)
|
|
|
|
'line number?
|
|
a = Asc(entireline$)
|
|
If (a >= 48 And a <= 57) Or a = 46 Then 'numeric
|
|
label$ = getelement(entireline$, 1)
|
|
If validlabel(label$) Then
|
|
|
|
v = HashFind(label$, HASHFLAG_LABEL, ignore, r)
|
|
addlabchk100:
|
|
If v Then
|
|
s = Labels(r).Scope
|
|
If s = subfuncn Or s = -1 Then 'same scope?
|
|
If s = -1 Then Labels(r).Scope = subfuncn 'acquire scope
|
|
If Labels(r).State = 1 Then a$ = "Duplicate label (" + RTrim$(Labels(r).cn) + ")": GoTo errmes
|
|
'aquire state 0 types
|
|
tlayout$ = RTrim$(Labels(r).cn)
|
|
GoTo addlabaq100
|
|
End If 'same scope
|
|
If v = 2 Then v = HashFindCont(ignore, r): GoTo addlabchk100
|
|
End If
|
|
|
|
'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 label$, HASHFLAG_LABEL, nLabels
|
|
r = nLabels
|
|
Labels(r).cn = tlayout$
|
|
Labels(r).Scope = subfuncn
|
|
addlabaq100:
|
|
Labels(r).State = 1
|
|
Labels(r).Data_Offset = linedataoffset
|
|
|
|
layout$ = tlayout$
|
|
Print #12, "LABEL_" + label$ + ":;"
|
|
|
|
|
|
If InStr(label$, "p") Then Mid$(label$, InStr(label$, "p"), 1) = "."
|
|
If Right$(label$, 1) = "d" Or Right$(label$, 1) = "s" Then label$ = Left$(label$, Len(label$) - 1)
|
|
Print #12, "last_line=" + label$ + ";"
|
|
inclinenump$ = ""
|
|
If inclinenumber(inclevel) Then
|
|
inclinenump$ = "," + str2$(inclinenumber(inclevel))
|
|
thisincname$ = getfilepath$(incname$(inclevel))
|
|
thisincname$ = Mid$(incname$(inclevel), Len(thisincname$) + 1)
|
|
inclinenump$ = inclinenump$ + "," + Chr$(34) + thisincname$ + Chr$(34)
|
|
End If
|
|
If NoChecks = 0 Then
|
|
Print #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");r=0;}"
|
|
End If
|
|
If n = 1 Then GoTo finishednonexec
|
|
entireline$ = getelements(entireline$, 2, n): u$ = UCase$(entireline$): n = n - 1
|
|
'note: fall through, numeric labels can be followed by alphanumeric label
|
|
End If 'validlabel
|
|
End If 'numeric
|
|
'it wasn't a line number
|
|
|
|
'label?
|
|
'note: ignores possibility that this could be a single command SUB/FUNCTION (as in QBASIC?)
|
|
If n >= 2 Then
|
|
x2 = InStr(entireline$, sp + ":")
|
|
If x2 Then
|
|
If x2 = Len(entireline$) - 1 Then x3 = x2 + 1 Else x3 = x2 + 2
|
|
a$ = Left$(entireline$, x2 - 1)
|
|
|
|
CreatingLabel = 1
|
|
If validlabel(a$) Then
|
|
|
|
If validname(a$) = 0 Then a$ = "Invalid name": GoTo errmes
|
|
|
|
v = HashFind(a$, HASHFLAG_LABEL, ignore, r)
|
|
addlabchk:
|
|
If v Then
|
|
s = Labels(r).Scope
|
|
If s = subfuncn Or s = -1 Then 'same scope?
|
|
If s = -1 Then Labels(r).Scope = subfuncn 'acquire scope
|
|
If Labels(r).State = 1 Then a$ = "Duplicate label (" + RTrim$(Labels(r).cn) + ")": GoTo errmes
|
|
'aquire state 0 types
|
|
tlayout$ = RTrim$(Labels(r).cn)
|
|
GoTo addlabaq
|
|
End If 'same scope
|
|
If v = 2 Then v = HashFindCont(ignore, r): GoTo addlabchk
|
|
End If
|
|
'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 a$, HASHFLAG_LABEL, nLabels
|
|
r = nLabels
|
|
Labels(r).cn = tlayout$
|
|
Labels(r).Scope = subfuncn
|
|
addlabaq:
|
|
Labels(r).State = 1
|
|
Labels(r).Data_Offset = linedataoffset
|
|
Labels(r).SourceLineNumber = linenumber
|
|
|
|
If Len(layout$) Then layout$ = layout$ + sp + tlayout$ + ":" Else layout$ = tlayout$ + ":"
|
|
|
|
Print #12, "LABEL_" + a$ + ":;"
|
|
inclinenump$ = ""
|
|
If inclinenumber(inclevel) Then
|
|
inclinenump$ = "," + str2$(inclinenumber(inclevel))
|
|
thisincname$ = getfilepath$(incname$(inclevel))
|
|
thisincname$ = Mid$(incname$(inclevel), Len(thisincname$) + 1)
|
|
inclinenump$ = inclinenump$ + "," + Chr$(34) + thisincname$ + Chr$(34)
|
|
End If
|
|
If NoChecks = 0 Then
|
|
Print #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");r=0;}"
|
|
End If
|
|
entireline$ = Right$(entireline$, Len(entireline$) - x3): u$ = UCase$(entireline$)
|
|
n = numelements(entireline$): If n = 0 Then GoTo finishednonexec
|
|
End If 'valid
|
|
End If 'includes sp+":"
|
|
End If 'n>=2
|
|
|
|
'remove leading ":"
|
|
Do While Asc(u$) = 58 '":"
|
|
If Len(layout$) Then layout$ = layout$ + sp2 + ":" Else layout$ = ":"
|
|
If Len(u$) = 1 Then GoTo finishednonexec
|
|
entireline$ = getelements(entireline$, 2, n): u$ = UCase$(entireline$): n = n - 1
|
|
Loop
|
|
|
|
'ELSE at the beginning of a line
|
|
If Asc(u$) = 69 Then '"E"
|
|
|
|
e1$ = getelement(u$, 1)
|
|
|
|
If e1$ = "ELSE" Then
|
|
a$ = "ELSE"
|
|
If n > 1 Then continuelinefrom = 2
|
|
GoTo gotcommand
|
|
End If
|
|
|
|
If e1$ = "ELSEIF" Then
|
|
If n < 3 Then a$ = "Expected ... THEN": GoTo errmes
|
|
If getelement(u$, n) = "THEN" Then a$ = entireline$: GoTo gotcommand
|
|
For i = 3 To n - 1
|
|
If getelement(u$, i) = "THEN" Then
|
|
a$ = getelements(entireline$, 1, i)
|
|
continuelinefrom = i + 1
|
|
GoTo gotcommand
|
|
End If
|
|
Next
|
|
a$ = "Expected THEN": GoTo errmes
|
|
End If
|
|
|
|
End If '"E"
|
|
|
|
start = 1
|
|
|
|
GoTo skipcontinit
|
|
|
|
contline:
|
|
|
|
n = numelements(entireline$)
|
|
u$ = UCase$(entireline$)
|
|
|
|
skipcontinit:
|
|
|
|
'jargon:
|
|
'lineelseused - counts how many line ELSEs can POSSIBLY follow
|
|
'endifs - how many C++ endifs "}" need to be added at the end of the line
|
|
'lineelseused - counts the number of indwelling ELSE statements on a line
|
|
'impliedendif - stops autoformat from adding "END IF"
|
|
|
|
a$ = ""
|
|
|
|
For i = start To n
|
|
e$ = getelement(u$, i)
|
|
|
|
|
|
If e$ = ":" Then
|
|
If i = start Then
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp2 + ":" Else layout$ = ":"
|
|
If i <> n Then continuelinefrom = i + 1
|
|
GoTo finishednonexec
|
|
End If
|
|
If i <> n Then continuelinefrom = i
|
|
GoTo gotcommand
|
|
End If
|
|
|
|
|
|
'begin scanning an 'IF' statement
|
|
If e$ = "IF" And a$ = "" Then newif = 1
|
|
|
|
|
|
If e$ = "THEN" Or (e$ = "GOTO" And newif = 1) Then
|
|
If newif = 0 Then a$ = "THEN without IF": GoTo errmes
|
|
newif = 0
|
|
If lineelseused > 0 Then lineelseused = lineelseused - 1
|
|
If e$ = "GOTO" Then
|
|
If i = n Then a$ = "Expected IF expression GOTO label": GoTo errmes
|
|
i = i - 1
|
|
End If
|
|
a$ = a$ + sp + e$ '+"THEN"/"GOTO"
|
|
If i <> n Then continuelinefrom = i + 1: endifs = endifs + 1
|
|
GoTo gotcommand
|
|
End If
|
|
|
|
|
|
If e$ = "ELSE" Then
|
|
|
|
If start = i Then
|
|
If lineelseused >= 1 Then
|
|
'note: more than one else used (in a row) on this line, so close first if with an 'END IF' first
|
|
'note: parses 'END IF' then (after continuelinefrom) parses 'ELSE'
|
|
'consider the following: (square brackets make reading easier)
|
|
'eg. if a=1 then [if b=2 then c=2 else d=2] else e=3
|
|
impliedendif = 1: a$ = "END" + sp + "IF"
|
|
endifs = endifs - 1
|
|
continuelinefrom = i
|
|
lineelseused = lineelseused - 1
|
|
GoTo gotcommand
|
|
End If
|
|
'follow up previously encountered 'ELSE' by applying 'ELSE'
|
|
a$ = "ELSE": continuelinefrom = i + 1
|
|
lineelseused = lineelseused + 1
|
|
GoTo gotcommand
|
|
End If 'start=i
|
|
|
|
'apply everything up to (but not including) 'ELSE'
|
|
continuelinefrom = i
|
|
GoTo gotcommand
|
|
End If '"ELSE"
|
|
|
|
|
|
e$ = getelement(entireline$, i): If a$ = "" Then a$ = e$ Else a$ = a$ + sp + e$
|
|
Next
|
|
|
|
|
|
'we're reached the end of the line
|
|
If endifs > 0 Then
|
|
endifs = endifs - 1
|
|
impliedendif = 1: entireline$ = entireline$ + sp + ":" + sp + "END" + sp + "IF": n = n + 3
|
|
i = i + 1 'skip the ":" (i is now equal to n+2)
|
|
continuelinefrom = i
|
|
GoTo gotcommand
|
|
End If
|
|
|
|
|
|
gotcommand:
|
|
|
|
dynscope = 0
|
|
|
|
ca$ = a$
|
|
a$ = eleucase$(ca$) '***REVISE THIS SECTION LATER***
|
|
|
|
|
|
layoutdone = 0
|
|
|
|
linefragment = a$
|
|
If Debug Then Print #9, a$
|
|
n = numelements(a$)
|
|
If n = 0 Then GoTo finishednonexec
|
|
|
|
'convert non-UDT dimensioned periods to _046_
|
|
If InStr(ca$, sp + "." + sp) Then
|
|
a3$ = getelement(ca$, 1)
|
|
except = 0
|
|
aa$ = a3$ + sp 'rebuilt a$ (always has a trailing spacer)
|
|
lastfuse = -1
|
|
For x = 2 To n
|
|
a2$ = getelement(ca$, x)
|
|
If except = 1 Then except = 2: GoTo udtperiod 'skip element name
|
|
If a2$ = "." And x <> n Then
|
|
If except = 2 Then except = 1: GoTo udtperiod 'sub-element of UDT
|
|
|
|
If a3$ = ")" Then
|
|
'assume it was something like typevar(???).x and treat as a UDT
|
|
except = 1
|
|
GoTo udtperiod
|
|
End If
|
|
|
|
'find an ID of that type
|
|
try = findid(UCase$(a3$))
|
|
If Error_Happened Then GoTo errmes
|
|
Do While try
|
|
If ((id.t And ISUDT) <> 0) Or ((id.arraytype And ISUDT) <> 0) Then
|
|
except = 1
|
|
GoTo udtperiod
|
|
End If
|
|
If try = 2 Then findanotherid = 1: try = findid(UCase$(a3$)) Else try = 0
|
|
If Error_Happened Then GoTo errmes
|
|
Loop
|
|
'not a udt; fuse lhs & rhs with _046_
|
|
If isalpha(Asc(a3$)) = 0 And lastfuse <> x - 2 Then a$ = "Invalid '.'": GoTo errmes
|
|
aa$ = Left$(aa$, Len(aa$) - 1) + fix046$
|
|
lastfuse = x
|
|
GoTo periodfused
|
|
End If '"."
|
|
except = 0
|
|
udtperiod:
|
|
aa$ = aa$ + a2$ + sp
|
|
periodfused:
|
|
a3$ = a2$
|
|
Next
|
|
a$ = Left$(aa$, Len(aa$) - 1)
|
|
ca$ = a$
|
|
a$ = eleucase$(ca$)
|
|
n = numelements(a$)
|
|
End If
|
|
|
|
arrayprocessinghappened = 0
|
|
|
|
firstelement$ = getelement(a$, 1)
|
|
secondelement$ = getelement(a$, 2)
|
|
thirdelement$ = getelement(a$, 3)
|
|
|
|
'non-executable section
|
|
|
|
If n = 1 Then
|
|
If firstelement$ = "'" Then layoutdone = 1: GoTo finishednonexec 'nop
|
|
End If
|
|
|
|
If n <= 2 Then
|
|
If firstelement$ = "DATA" Then
|
|
l$ = SCase$("Data")
|
|
If n = 2 Then
|
|
|
|
e$ = Space$((Len(secondelement$) - 1) \ 2)
|
|
For x = 1 To Len(e$)
|
|
v1 = Asc(secondelement$, x * 2)
|
|
v2 = Asc(secondelement$, x * 2 + 1)
|
|
If v1 < 65 Then v1 = v1 - 48 Else v1 = v1 - 55
|
|
If v2 < 65 Then v2 = v2 - 48 Else v2 = v2 - 55
|
|
Asc(e$, x) = v1 + v2 * 16
|
|
Next
|
|
l$ = l$ + sp + e$
|
|
End If 'n=2
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
|
|
GoTo finishednonexec
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
'declare library
|
|
If declaringlibrary Then
|
|
|
|
If firstelement$ = "END" Then
|
|
If n <> 2 Or secondelement$ <> "DECLARE" Then a$ = "Expected END DECLARE": GoTo errmes
|
|
declaringlibrary = 0
|
|
l$ = SCase$("End" + sp + "Declare")
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishednonexec
|
|
End If 'end declare
|
|
|
|
declaringlibrary = 2
|
|
|
|
If firstelement$ = "SUB" Or firstelement$ = "FUNCTION" Then
|
|
GoTo declaresubfunc2
|
|
End If
|
|
|
|
a$ = "Expected SUB/FUNCTION definition or END DECLARE": GoTo errmes
|
|
End If 'declaringlibrary
|
|
|
|
'check TYPE declarations (created on prepass)
|
|
If definingtype Then
|
|
|
|
If firstelement$ = "END" Then
|
|
If n <> 2 Or secondelement$ <> "TYPE" Then a$ = "Expected END TYPE": GoTo errmes
|
|
definingtype = 0
|
|
l$ = SCase$("End" + sp + "Type")
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
If n < 3 Then a$ = "Expected element-name AS type or AS type element-list": GoTo errmes
|
|
definingtype = 2
|
|
If firstelement$ = "AS" Then
|
|
l$ = SCase$("As")
|
|
t$ = ""
|
|
wordsInTypeName = 0
|
|
Do
|
|
nextElement$ = getelement$(a$, 2 + wordsInTypeName)
|
|
If nextElement$ = "," Then
|
|
'element-list
|
|
wordsInTypeName = wordsInTypeName - 2
|
|
Exit Do
|
|
End If
|
|
|
|
wordsInTypeName = wordsInTypeName + 1
|
|
If wordsInTypeName = n - 2 Then
|
|
'single element in line
|
|
wordsInTypeName = wordsInTypeName - 1
|
|
Exit Do
|
|
End If
|
|
Loop
|
|
|
|
t$ = getelements$(a$, 2, 2 + wordsInTypeName)
|
|
typ = typname2typ(t$)
|
|
If Error_Happened Then GoTo errmes
|
|
If typ = 0 Then a$ = "Undefined type": GoTo errmes
|
|
If typ And ISUDT Then
|
|
If UCase$(RTrim$(t$)) = "MEM" And RTrim$(udtxcname(typ And 511)) = "_MEM" And qb64prefix_set = 1 Then
|
|
t$ = Mid$(RTrim$(udtxcname(typ And 511)), 2)
|
|
Else
|
|
t$ = RTrim$(udtxcname(typ And 511))
|
|
End If
|
|
l$ = l$ + sp + t$
|
|
Else
|
|
l$ = l$ + sp + SCase2$(t$)
|
|
End If
|
|
|
|
'Now add each variable:
|
|
For i = 3 + wordsInTypeName To n
|
|
thisElement$ = getelement$(ca$, i)
|
|
If thisElement$ = "," Then
|
|
l$ = l$ + thisElement$
|
|
Else
|
|
l$ = l$ + sp + thisElement$
|
|
End If
|
|
Next
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
Else
|
|
l$ = getelement(ca$, 1) + sp + SCase$("As")
|
|
t$ = getelements$(a$, 3, n)
|
|
typ = typname2typ(t$)
|
|
If Error_Happened Then GoTo errmes
|
|
If typ = 0 Then a$ = "Undefined type": GoTo errmes
|
|
If typ And ISUDT Then
|
|
If UCase$(RTrim$(t$)) = "MEM" And RTrim$(udtxcname(typ And 511)) = "_MEM" And qb64prefix_set = 1 Then
|
|
t$ = Mid$(RTrim$(udtxcname(typ And 511)), 2)
|
|
Else
|
|
t$ = RTrim$(udtxcname(typ And 511))
|
|
End If
|
|
l$ = l$ + sp + t$
|
|
Else
|
|
l$ = l$ + sp + SCase2$(t$)
|
|
End If
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
End If
|
|
GoTo finishednonexec
|
|
|
|
End If 'defining type
|
|
|
|
If firstelement$ = "TYPE" Then
|
|
If n <> 2 Then a$ = "Expected TYPE type-name": GoTo errmes
|
|
l$ = SCase$("Type") + sp + getelement(ca$, 2)
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
definingtype = 1
|
|
definingtypeerror = linenumber
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
'skip DECLARE SUB/FUNCTION
|
|
If n >= 1 Then
|
|
If firstelement$ = "DECLARE" Then
|
|
|
|
If secondelement$ = "LIBRARY" Or secondelement$ = "DYNAMIC" Or secondelement$ = "CUSTOMTYPE" Or secondelement$ = "STATIC" Then
|
|
|
|
declaringlibrary = 1
|
|
dynamiclibrary = 0
|
|
customtypelibrary = 0
|
|
indirectlibrary = 0
|
|
staticlinkedlibrary = 0
|
|
|
|
x = 3
|
|
l$ = SCase$("Declare" + sp + "Library")
|
|
|
|
If secondelement$ = "DYNAMIC" Then
|
|
e$ = getelement$(a$, 3): If e$ <> "LIBRARY" Then a$ = "Expected DYNAMIC LIBRARY " + Chr$(34) + "..." + Chr$(34): GoTo errmes
|
|
dynamiclibrary = 1
|
|
x = 4
|
|
l$ = SCase$("Declare" + sp + "Dynamic" + sp + "Library")
|
|
If n = 3 Then a$ = "Expected DECLARE DYNAMIC LIBRARY " + Chr$(34) + "..." + Chr$(34): GoTo errmes
|
|
indirectlibrary = 1
|
|
End If
|
|
|
|
If secondelement$ = "CUSTOMTYPE" Then
|
|
e$ = getelement$(a$, 3): If e$ <> "LIBRARY" Then a$ = "Expected CUSTOMTYPE LIBRARY": GoTo errmes
|
|
customtypelibrary = 1
|
|
x = 4
|
|
l$ = SCase$("Declare" + sp + "CustomType" + sp + "Library")
|
|
indirectlibrary = 1
|
|
End If
|
|
|
|
If secondelement$ = "STATIC" Then
|
|
e$ = getelement$(a$, 3): If e$ <> "LIBRARY" Then a$ = "Expected STATIC LIBRARY": GoTo errmes
|
|
x = 4
|
|
l$ = SCase$("Declare" + sp + "Static" + sp + "Library")
|
|
staticlinkedlibrary = 1
|
|
End If
|
|
|
|
sfdeclare = 0: sfheader = 0
|
|
|
|
If n >= x Then
|
|
|
|
sfdeclare = 1
|
|
|
|
addlibrary:
|
|
|
|
libname$ = ""
|
|
headername$ = ""
|
|
|
|
|
|
'assume library name in double quotes follows
|
|
'assume library is in main qb64 folder
|
|
x$ = getelement$(ca$, x)
|
|
If Asc(x$) <> 34 Then a$ = "Expected LIBRARY " + Chr$(34) + "..." + Chr$(34): GoTo errmes
|
|
x$ = Right$(x$, Len(x$) - 1)
|
|
z = InStr(x$, Chr$(34))
|
|
If z = 0 Then a$ = "Expected LIBRARY " + Chr$(34) + "..." + Chr$(34): GoTo errmes
|
|
x$ = Left$(x$, z - 1)
|
|
|
|
If dynamiclibrary <> 0 And Len(x$) = 0 Then a$ = "Expected DECLARE DYNAMIC LIBRARY " + Chr$(34) + "..." + Chr$(34): GoTo errmes
|
|
If customtypelibrary <> 0 And Len(x$) = 0 Then a$ = "Expected DECLARE CUSTOMTYPE LIBRARY " + Chr$(34) + "..." + Chr$(34): GoTo errmes
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
'convert '\\' to '\'
|
|
While InStr(x$, "\\")
|
|
z = InStr(x$, "\\")
|
|
x$ = Left$(x$, z - 1) + Right$(x$, Len(x$) - z)
|
|
Wend
|
|
|
|
autoformat_x$ = x$ 'used for autolayout purposes
|
|
|
|
'Remove version number from library name
|
|
'Eg. libname:1.0 becomes libname <-> 1.0 which later becomes libname.so.1.0
|
|
v$ = ""
|
|
striplibver:
|
|
For z = Len(x$) To 1 Step -1
|
|
a = Asc(x$, z)
|
|
If a = ASC_BACKSLASH Or a = ASC_FORWARDSLASH Then Exit For
|
|
If a = ASC_FULLSTOP Or a = ASC_COLON Then
|
|
If isuinteger(Right$(x$, Len(x$) - z)) Then
|
|
If Len(v$) Then v$ = Right$(x$, Len(x$) - z) + "." + v$ Else v$ = Right$(x$, Len(x$) - z)
|
|
x$ = Left$(x$, z - 1)
|
|
If a = ASC_COLON Then Exit For
|
|
GoTo striplibver
|
|
Else
|
|
Exit For
|
|
End If
|
|
End If
|
|
Next
|
|
libver$ = v$
|
|
|
|
|
|
If os$ = "WIN" Then
|
|
'convert forward-slashes to back-slashes
|
|
Do While InStr(x$, "/")
|
|
z = InStr(x$, "/")
|
|
x$ = Left$(x$, z - 1) + "\" + Right$(x$, Len(x$) - z)
|
|
Loop
|
|
End If
|
|
|
|
If os$ = "LNX" Then
|
|
'convert any back-slashes to forward-slashes
|
|
Do While InStr(x$, "\")
|
|
z = InStr(x$, "\")
|
|
x$ = Left$(x$, z - 1) + "/" + Right$(x$, Len(x$) - z)
|
|
Loop
|
|
End If
|
|
|
|
'Separate path from name
|
|
libpath$ = ""
|
|
For z = Len(x$) To 1 Step -1
|
|
a = Asc(x$, z)
|
|
If a = 47 Or a = 92 Then '\ or /
|
|
libpath$ = Left$(x$, z)
|
|
x$ = Right$(x$, Len(x$) - z)
|
|
Exit For
|
|
End If
|
|
Next
|
|
|
|
'Accept ./ and .\ as a reference to the source file
|
|
'folder, replacing it with the actual full path, if available
|
|
If libpath$ = "./" Or libpath$ = ".\" Then
|
|
libpath$ = ""
|
|
If NoIDEMode Then
|
|
libpath$ = path.source$
|
|
If Len(libpath$) > 0 And Right$(libpath$, 1) <> pathsep$ Then libpath$ = libpath$ + pathsep$
|
|
Else
|
|
If Len(ideprogname) Then libpath$ = idepath$ + pathsep$
|
|
End If
|
|
End If
|
|
|
|
'Create a path which can be used for inline code (uses \\ instead of \)
|
|
libpath_inline$ = ""
|
|
For z = 1 To Len(libpath$)
|
|
a = Asc(libpath$, z)
|
|
libpath_inline$ = libpath_inline$ + Chr$(a)
|
|
If a = 92 Then libpath_inline$ = libpath_inline$ + "\"
|
|
Next
|
|
|
|
If Len(x$) Then
|
|
If dynamiclibrary = 0 Then
|
|
'Static library
|
|
|
|
If os$ = "WIN" Then
|
|
'check for .lib
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(libpath$ + x$ + ".lib") Then
|
|
libname$ = libpath$ + x$ + ".lib"
|
|
inlinelibname$ = libpath_inline$ + x$ + ".lib"
|
|
End If
|
|
End If
|
|
'check for .a
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(libpath$ + x$ + ".a") Then
|
|
libname$ = libpath$ + x$ + ".a"
|
|
inlinelibname$ = libpath_inline$ + x$ + ".a"
|
|
End If
|
|
End If
|
|
'check for .o
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(libpath$ + x$ + ".o") Then
|
|
libname$ = libpath$ + x$ + ".o"
|
|
inlinelibname$ = libpath_inline$ + x$ + ".o"
|
|
End If
|
|
End If
|
|
'check for .lib
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(x$ + ".lib") Then
|
|
libname$ = x$ + ".lib"
|
|
inlinelibname$ = x$ + ".lib"
|
|
End If
|
|
End If
|
|
'check for .a
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(x$ + ".a") Then
|
|
libname$ = x$ + ".a"
|
|
inlinelibname$ = x$ + ".a"
|
|
End If
|
|
End If
|
|
'check for .o
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(x$ + ".o") Then
|
|
libname$ = x$ + ".o"
|
|
inlinelibname$ = x$ + ".o"
|
|
End If
|
|
End If
|
|
End If 'Windows
|
|
|
|
If os$ = "LNX" Then
|
|
If staticlinkedlibrary = 0 Then
|
|
|
|
If MacOSX Then 'dylib support
|
|
'check for .dylib (direct)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(libpath$ + "lib" + x$ + "." + libver$ + ".dylib") Then
|
|
libname$ = libpath$ + "lib" + x$ + "." + libver$ + ".dylib"
|
|
inlinelibname$ = libpath_inline$ + "lib" + x$ + "." + libver$ + ".dylib"
|
|
If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath " + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath ./ "
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(libpath$ + "lib" + x$ + ".dylib") Then
|
|
libname$ = libpath$ + "lib" + x$ + ".dylib"
|
|
inlinelibname$ = libpath_inline$ + "lib" + x$ + ".dylib"
|
|
If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath " + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath ./ "
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
'check for .so (direct)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(libpath$ + "lib" + x$ + ".so." + libver$) Then
|
|
libname$ = libpath$ + "lib" + x$ + ".so." + libver$
|
|
inlinelibname$ = libpath_inline$ + "lib" + x$ + ".so." + libver$
|
|
If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath " + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath ./ "
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(libpath$ + "lib" + x$ + ".so") Then
|
|
libname$ = libpath$ + "lib" + x$ + ".so"
|
|
inlinelibname$ = libpath_inline$ + "lib" + x$ + ".so"
|
|
If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath " + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath ./ "
|
|
End If
|
|
End If
|
|
End If
|
|
'check for .a (direct)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(libpath$ + "lib" + x$ + ".a") Then
|
|
libname$ = libpath$ + "lib" + x$ + ".a"
|
|
inlinelibname$ = libpath_inline$ + "lib" + x$ + ".a"
|
|
End If
|
|
End If
|
|
'check for .o (direct)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(libpath$ + "lib" + x$ + ".o") Then
|
|
libname$ = libpath$ + "lib" + x$ + ".o"
|
|
inlinelibname$ = libpath_inline$ + "lib" + x$ + ".o"
|
|
End If
|
|
End If
|
|
If staticlinkedlibrary = 0 Then
|
|
'check for .so (usr/lib64)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib64/" + libpath$ + "lib" + x$ + ".so." + libver$) Then
|
|
libname$ = "/usr/lib64/" + libpath$ + "lib" + x$ + ".so." + libver$
|
|
inlinelibname$ = "/usr/lib64/" + libpath_inline$ + "lib" + x$ + ".so." + libver$
|
|
If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/" + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/ "
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib64/" + libpath$ + "lib" + x$ + ".so") Then
|
|
libname$ = "/usr/lib64/" + libpath$ + "lib" + x$ + ".so"
|
|
inlinelibname$ = "/usr/lib64/" + libpath_inline$ + "lib" + x$ + ".so"
|
|
If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/" + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/ "
|
|
End If
|
|
End If
|
|
End If
|
|
'check for .a (usr/lib64)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib64/" + libpath$ + "lib" + x$ + ".a") Then
|
|
libname$ = "/usr/lib64/" + libpath$ + "lib" + x$ + ".a"
|
|
inlinelibname$ = "/usr/lib64/" + libpath_inline$ + "lib" + x$ + ".a"
|
|
End If
|
|
End If
|
|
If staticlinkedlibrary = 0 Then
|
|
|
|
If MacOSX Then 'dylib support
|
|
'check for .dylib (usr/lib)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + "." + libver$ + ".dylib") Then
|
|
libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + "." + libver$ + ".dylib"
|
|
inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + "." + libver$ + ".dylib"
|
|
If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/" + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ "
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + ".dylib") Then
|
|
libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + ".dylib"
|
|
inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + ".dylib"
|
|
If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/" + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ "
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
'check for .so (usr/lib)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + ".so." + libver$) Then
|
|
libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + ".so." + libver$
|
|
inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + ".so." + libver$
|
|
If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/" + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ "
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + ".so") Then
|
|
libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + ".so"
|
|
inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + ".so"
|
|
If Len(libpath$) Then mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/" + libpath$ + " " Else mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ "
|
|
End If
|
|
End If
|
|
End If
|
|
'check for .a (usr/lib)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + ".a") Then
|
|
libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + ".a"
|
|
inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + ".a"
|
|
End If
|
|
End If
|
|
'--------------------------(without path)------------------------------
|
|
If staticlinkedlibrary = 0 Then
|
|
|
|
If MacOSX Then 'dylib support
|
|
'check for .dylib (direct)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("lib" + x$ + "." + libver$ + ".dylib") Then
|
|
libname$ = "lib" + x$ + "." + libver$ + ".dylib"
|
|
inlinelibname$ = "lib" + x$ + "." + libver$ + ".dylib"
|
|
mylibopt$ = mylibopt$ + " -Wl,-rpath ./ "
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("lib" + x$ + ".dylib") Then
|
|
libname$ = "lib" + x$ + ".dylib"
|
|
inlinelibname$ = "lib" + x$ + ".dylib"
|
|
mylibopt$ = mylibopt$ + " -Wl,-rpath ./ "
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
'check for .so (direct)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("lib" + x$ + ".so." + libver$) Then
|
|
libname$ = "lib" + x$ + ".so." + libver$
|
|
inlinelibname$ = "lib" + x$ + ".so." + libver$
|
|
mylibopt$ = mylibopt$ + " -Wl,-rpath ./ "
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("lib" + x$ + ".so") Then
|
|
libname$ = "lib" + x$ + ".so"
|
|
inlinelibname$ = "lib" + x$ + ".so"
|
|
mylibopt$ = mylibopt$ + " -Wl,-rpath ./ "
|
|
End If
|
|
End If
|
|
End If
|
|
'check for .a (direct)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("lib" + x$ + ".a") Then
|
|
libname$ = "lib" + x$ + ".a"
|
|
inlinelibname$ = "lib" + x$ + ".a"
|
|
End If
|
|
End If
|
|
'check for .o (direct)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("lib" + x$ + ".o") Then
|
|
libname$ = "lib" + x$ + ".o"
|
|
inlinelibname$ = "lib" + x$ + ".o"
|
|
End If
|
|
End If
|
|
If staticlinkedlibrary = 0 Then
|
|
'check for .so (usr/lib64)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib64/" + "lib" + x$ + ".so." + libver$) Then
|
|
libname$ = "/usr/lib64/" + "lib" + x$ + ".so." + libver$
|
|
inlinelibname$ = "/usr/lib64/" + "lib" + x$ + ".so." + libver$
|
|
mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/ "
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib64/" + "lib" + x$ + ".so") Then
|
|
libname$ = "/usr/lib64/" + "lib" + x$ + ".so"
|
|
inlinelibname$ = "/usr/lib64/" + "lib" + x$ + ".so"
|
|
mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib64/ "
|
|
End If
|
|
End If
|
|
End If
|
|
'check for .a (usr/lib64)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib64/" + "lib" + x$ + ".a") Then
|
|
libname$ = "/usr/lib64/" + "lib" + x$ + ".a"
|
|
inlinelibname$ = "/usr/lib64/" + "lib" + x$ + ".a"
|
|
End If
|
|
End If
|
|
If staticlinkedlibrary = 0 Then
|
|
|
|
If MacOSX Then 'dylib support
|
|
'check for .dylib (usr/lib)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + "lib" + x$ + "." + libver$ + ".dylib") Then
|
|
libname$ = "/usr/lib/" + "lib" + x$ + "." + libver$ + ".dylib"
|
|
inlinelibname$ = "/usr/lib/" + "lib" + x$ + "." + libver$ + ".dylib"
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + "lib" + x$ + ".dylib") Then
|
|
libname$ = "/usr/lib/" + "lib" + x$ + ".dylib"
|
|
inlinelibname$ = "/usr/lib/" + "lib" + x$ + ".dylib"
|
|
mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ "
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
'check for .so (usr/lib)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + "lib" + x$ + ".so." + libver$) Then
|
|
libname$ = "/usr/lib/" + "lib" + x$ + ".so." + libver$
|
|
inlinelibname$ = "/usr/lib/" + "lib" + x$ + ".so." + libver$
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + "lib" + x$ + ".so") Then
|
|
libname$ = "/usr/lib/" + "lib" + x$ + ".so"
|
|
inlinelibname$ = "/usr/lib/" + "lib" + x$ + ".so"
|
|
mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ "
|
|
End If
|
|
End If
|
|
End If
|
|
'check for .a (usr/lib)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + "lib" + x$ + ".a") Then
|
|
libname$ = "/usr/lib/" + "lib" + x$ + ".a"
|
|
inlinelibname$ = "/usr/lib/" + "lib" + x$ + ".a"
|
|
mylibopt$ = mylibopt$ + " -Wl,-rpath /usr/lib/ "
|
|
End If
|
|
End If
|
|
End If 'Linux
|
|
|
|
|
|
'check for header
|
|
If Len(headername$) = 0 Then
|
|
If os$ = "WIN" Then
|
|
If _FileExists(libpath$ + x$ + ".h") Then
|
|
headername$ = libpath_inline$ + x$ + ".h"
|
|
If customtypelibrary = 0 Then sfdeclare = 0
|
|
sfheader = 1
|
|
GoTo GotHeader
|
|
End If
|
|
If _FileExists(libpath$ + x$ + ".hpp") Then
|
|
headername$ = libpath_inline$ + x$ + ".hpp"
|
|
If customtypelibrary = 0 Then sfdeclare = 0
|
|
sfheader = 1
|
|
GoTo GotHeader
|
|
End If
|
|
'--------------------------(without path)------------------------------
|
|
If _FileExists(x$ + ".h") Then
|
|
headername$ = x$ + ".h"
|
|
If customtypelibrary = 0 Then sfdeclare = 0
|
|
sfheader = 1
|
|
GoTo GotHeader
|
|
End If
|
|
If _FileExists(x$ + ".hpp") Then
|
|
headername$ = x$ + ".hpp"
|
|
If customtypelibrary = 0 Then sfdeclare = 0
|
|
sfheader = 1
|
|
GoTo GotHeader
|
|
End If
|
|
End If 'Windows
|
|
|
|
If os$ = "LNX" Then
|
|
If _FileExists(libpath$ + x$ + ".h") Then
|
|
headername$ = libpath_inline$ + x$ + ".h"
|
|
If customtypelibrary = 0 Then sfdeclare = 0
|
|
sfheader = 1
|
|
GoTo GotHeader
|
|
End If
|
|
If _FileExists(libpath$ + x$ + ".hpp") Then
|
|
headername$ = libpath_inline$ + x$ + ".hpp"
|
|
If customtypelibrary = 0 Then sfdeclare = 0
|
|
sfheader = 1
|
|
GoTo GotHeader
|
|
End If
|
|
If _FileExists("/usr/include/" + libpath$ + x$ + ".h") Then
|
|
headername$ = "/usr/include/" + libpath_inline$ + x$ + ".h"
|
|
If customtypelibrary = 0 Then sfdeclare = 0
|
|
sfheader = 1
|
|
GoTo GotHeader
|
|
End If
|
|
If _FileExists("/usr/include/" + libpath$ + x$ + ".hpp") Then
|
|
headername$ = "/usr/include/" + libpath_inline$ + x$ + ".hpp"
|
|
If customtypelibrary = 0 Then sfdeclare = 0
|
|
sfheader = 1
|
|
GoTo GotHeader
|
|
End If
|
|
'--------------------------(without path)------------------------------
|
|
If _FileExists(x$ + ".h") Then
|
|
headername$ = x$ + ".h"
|
|
If customtypelibrary = 0 Then sfdeclare = 0
|
|
sfheader = 1
|
|
GoTo GotHeader
|
|
End If
|
|
If _FileExists(x$ + ".hpp") Then
|
|
headername$ = x$ + ".hpp"
|
|
If customtypelibrary = 0 Then sfdeclare = 0
|
|
sfheader = 1
|
|
GoTo GotHeader
|
|
End If
|
|
If _FileExists("/usr/include/" + x$ + ".h") Then
|
|
headername$ = "/usr/include/" + x$ + ".h"
|
|
If customtypelibrary = 0 Then sfdeclare = 0
|
|
sfheader = 1
|
|
GoTo GotHeader
|
|
End If
|
|
If _FileExists("/usr/include/" + x$ + ".hpp") Then
|
|
headername$ = "/usr/include/" + x$ + ".hpp"
|
|
If customtypelibrary = 0 Then sfdeclare = 0
|
|
sfheader = 1
|
|
GoTo GotHeader
|
|
End If
|
|
End If 'Linux
|
|
|
|
GotHeader:
|
|
End If
|
|
|
|
Else
|
|
'dynamic library
|
|
|
|
If os$ = "WIN" Then
|
|
'check for .dll (direct)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(libpath$ + x$ + ".dll") Then
|
|
libname$ = libpath$ + x$ + ".dll"
|
|
inlinelibname$ = libpath_inline$ + x$ + ".dll"
|
|
End If
|
|
End If
|
|
'check for .dll (system32)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(Environ$("SYSTEMROOT") + "\System32\" + libpath$ + x$ + ".dll") Then
|
|
libname$ = libpath$ + x$ + ".dll"
|
|
inlinelibname$ = libpath_inline$ + x$ + ".dll"
|
|
End If
|
|
End If
|
|
'--------------------------(without path)------------------------------
|
|
'check for .dll (direct)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(x$ + ".dll") Then
|
|
libname$ = x$ + ".dll"
|
|
inlinelibname$ = x$ + ".dll"
|
|
End If
|
|
End If
|
|
'check for .dll (system32)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(Environ$("SYSTEMROOT") + "\System32\" + x$ + ".dll") Then
|
|
libname$ = x$ + ".dll"
|
|
inlinelibname$ = x$ + ".dll"
|
|
End If
|
|
End If
|
|
End If 'Windows
|
|
|
|
If os$ = "LNX" Then
|
|
'Note: STATIC libraries (.a/.o) cannot be loaded as dynamic objects
|
|
|
|
|
|
If MacOSX Then 'dylib support
|
|
'check for .dylib (direct)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(libpath$ + "lib" + x$ + "." + libver$ + ".dylib") Then
|
|
libname$ = libpath$ + "lib" + x$ + "." + libver$ + ".dylib"
|
|
inlinelibname$ = libpath_inline$ + "lib" + x$ + "." + libver$ + ".dylib"
|
|
If Left$(libpath$, 1) <> "/" Then libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(libpath$ + "lib" + x$ + ".dylib") Then
|
|
libname$ = libpath$ + "lib" + x$ + ".dylib"
|
|
inlinelibname$ = libpath_inline$ + "lib" + x$ + ".dylib"
|
|
If Left$(libpath$, 1) <> "/" Then libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
'check for .so (direct)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(libpath$ + "lib" + x$ + ".so." + libver$) Then
|
|
libname$ = libpath$ + "lib" + x$ + ".so." + libver$
|
|
inlinelibname$ = libpath_inline$ + "lib" + x$ + ".so." + libver$
|
|
If Left$(libpath$, 1) <> "/" Then libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists(libpath$ + "lib" + x$ + ".so") Then
|
|
libname$ = libpath$ + "lib" + x$ + ".so"
|
|
inlinelibname$ = libpath_inline$ + "lib" + x$ + ".so"
|
|
If Left$(libpath$, 1) <> "/" Then libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$
|
|
End If
|
|
End If
|
|
'check for .so (usr/lib64)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib64/" + libpath$ + "lib" + x$ + ".so." + libver$) Then
|
|
libname$ = "/usr/lib64/" + libpath$ + "lib" + x$ + ".so." + libver$
|
|
inlinelibname$ = "/usr/lib64/" + libpath_inline$ + "lib" + x$ + ".so." + libver$
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib64/" + libpath$ + "lib" + x$ + ".so") Then
|
|
libname$ = "/usr/lib64/" + libpath$ + "lib" + x$ + ".so"
|
|
inlinelibname$ = "/usr/lib64/" + libpath_inline$ + "lib" + x$ + ".so"
|
|
End If
|
|
End If
|
|
|
|
If MacOSX Then 'dylib support
|
|
'check for .dylib (usr/lib)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + "." + libver$ + ".dylib") Then
|
|
libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + "." + libver$ + ".dylib"
|
|
inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + "." + libver$ + ".dylib"
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + ".dylib") Then
|
|
libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + ".dylib"
|
|
inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + ".dylib"
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
'check for .so (usr/lib)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + ".so." + libver$) Then
|
|
libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + ".so." + libver$
|
|
inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + ".so." + libver$
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + libpath$ + "lib" + x$ + ".so") Then
|
|
libname$ = "/usr/lib/" + libpath$ + "lib" + x$ + ".so"
|
|
inlinelibname$ = "/usr/lib/" + libpath_inline$ + "lib" + x$ + ".so"
|
|
End If
|
|
End If
|
|
'--------------------------(without path)------------------------------
|
|
If MacOSX Then 'dylib support
|
|
'check for .dylib (direct)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("lib" + x$ + "." + libver$ + ".dylib") Then
|
|
libname$ = "lib" + x$ + "." + libver$ + ".dylib"
|
|
inlinelibname$ = "lib" + x$ + "." + libver$ + ".dylib"
|
|
libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("lib" + x$ + ".dylib") Then
|
|
libname$ = "lib" + x$ + ".dylib"
|
|
inlinelibname$ = "lib" + x$ + ".dylib"
|
|
libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
'check for .so (direct)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("lib" + x$ + ".so." + libver$) Then
|
|
libname$ = "lib" + x$ + ".so." + libver$
|
|
inlinelibname$ = "lib" + x$ + ".so." + libver$
|
|
libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("lib" + x$ + ".so") Then
|
|
libname$ = "lib" + x$ + ".so"
|
|
inlinelibname$ = "lib" + x$ + ".so"
|
|
libname$ = "./" + libname$: inlinelibname$ = "./" + inlinelibname$
|
|
End If
|
|
End If
|
|
'check for .so (usr/lib64)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib64/" + "lib" + x$ + ".so." + libver$) Then
|
|
libname$ = "/usr/lib64/" + "lib" + x$ + ".so." + libver$
|
|
inlinelibname$ = "/usr/lib64/" + "lib" + x$ + ".so." + libver$
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib64/" + "lib" + x$ + ".so") Then
|
|
libname$ = "/usr/lib64/" + "lib" + x$ + ".so"
|
|
inlinelibname$ = "/usr/lib64/" + "lib" + x$ + ".so"
|
|
End If
|
|
End If
|
|
|
|
If MacOSX Then 'dylib support
|
|
'check for .dylib (usr/lib)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + "lib" + x$ + "." + libver$ + ".dylib") Then
|
|
libname$ = "/usr/lib/" + "lib" + x$ + "." + libver$ + ".dylib"
|
|
inlinelibname$ = "/usr/lib/" + "lib" + x$ + "." + libver$ + ".dylib"
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + "lib" + x$ + ".dylib") Then
|
|
libname$ = "/usr/lib/" + "lib" + x$ + ".dylib"
|
|
inlinelibname$ = "/usr/lib/" + "lib" + x$ + ".dylib"
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
'check for .so (usr/lib)
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + "lib" + x$ + ".so." + libver$) Then
|
|
libname$ = "/usr/lib/" + "lib" + x$ + ".so." + libver$
|
|
inlinelibname$ = "/usr/lib/" + "lib" + x$ + ".so." + libver$
|
|
End If
|
|
End If
|
|
If Len(libname$) = 0 Then
|
|
If _FileExists("/usr/lib/" + "lib" + x$ + ".so") Then
|
|
libname$ = "/usr/lib/" + "lib" + x$ + ".so"
|
|
inlinelibname$ = "/usr/lib/" + "lib" + x$ + ".so"
|
|
End If
|
|
End If
|
|
End If 'Linux
|
|
|
|
End If 'Dynamic
|
|
|
|
'library found?
|
|
If dynamiclibrary <> 0 And Len(libname$) = 0 Then a$ = "DYNAMIC LIBRARY not found": GoTo errmes
|
|
If Len(libname$) = 0 And Len(headername$) = 0 Then a$ = "LIBRARY not found": GoTo errmes
|
|
|
|
'***actual method should cull redundant header and library entries***
|
|
|
|
If dynamiclibrary = 0 Then
|
|
|
|
'static
|
|
If Len(libname$) Then
|
|
If os$ = "WIN" Then
|
|
If Mid$(libname$, 2, 1) = ":" Or Left$(libname$, 1) = "\" Then
|
|
mylib$ = mylib$ + " " + libname$ + " "
|
|
Else
|
|
mylib$ = mylib$ + " ..\..\" + libname$ + " "
|
|
End If
|
|
End If
|
|
If os$ = "LNX" Then
|
|
If Left$(libname$, 1) = "/" Then
|
|
mylib$ = mylib$ + " " + libname$ + " "
|
|
Else
|
|
mylib$ = mylib$ + " ../../" + libname$ + " "
|
|
End If
|
|
End If
|
|
|
|
End If
|
|
|
|
Else
|
|
|
|
'dynamic
|
|
If Len(headername$) = 0 Then 'no header
|
|
|
|
If subfuncn Then
|
|
f = FreeFile
|
|
Open tmpdir$ + "maindata.txt" For Append As #f
|
|
Else
|
|
f = 13
|
|
End If
|
|
|
|
'make name a C-appropriate variable name
|
|
'by converting everything except numbers and
|
|
'letters to underscores
|
|
x2$ = x$
|
|
For x2 = 1 To Len(x2$)
|
|
If Asc(x2$, x2) < 48 Then Asc(x2$, x2) = 95
|
|
If Asc(x2$, x2) > 57 And Asc(x2$, x2) < 65 Then Asc(x2$, x2) = 95
|
|
If Asc(x2$, x2) > 90 And Asc(x2$, x2) < 97 Then Asc(x2$, x2) = 95
|
|
If Asc(x2$, x2) > 122 Then Asc(x2$, x2) = 95
|
|
Next
|
|
DLLname$ = x2$
|
|
|
|
If sfdeclare Then
|
|
|
|
If os$ = "WIN" Then
|
|
Print #17, "HINSTANCE DLL_" + x2$ + "=NULL;"
|
|
Print #f, "if (!DLL_" + x2$ + "){"
|
|
Print #f, "DLL_" + x2$ + "=LoadLibrary(" + Chr$(34) + inlinelibname$ + Chr$(34) + ");"
|
|
Print #f, "if (!DLL_" + x2$ + ") error(259);"
|
|
Print #f, "}"
|
|
End If
|
|
|
|
If os$ = "LNX" Then
|
|
Print #17, "void *DLL_" + x2$ + "=NULL;"
|
|
Print #f, "if (!DLL_" + x2$ + "){"
|
|
Print #f, "DLL_" + x2$ + "=dlopen(" + Chr$(34) + inlinelibname$ + Chr$(34) + ",RTLD_LAZY);"
|
|
Print #f, "if (!DLL_" + x2$ + ") error(259);"
|
|
Print #f, "}"
|
|
End If
|
|
|
|
|
|
End If
|
|
|
|
If subfuncn Then Close #f
|
|
|
|
End If 'no header
|
|
|
|
End If 'dynamiclibrary
|
|
|
|
If Len(headername$) Then
|
|
If os$ = "WIN" Then
|
|
If Mid$(headername$, 2, 1) = ":" Or Left$(headername$, 1) = "\" Then
|
|
Print #17, "#include " + Chr$(34) + headername$ + Chr$(34)
|
|
Else
|
|
Print #17, "#include " + Chr$(34) + "..\\..\\" + headername$ + Chr$(34)
|
|
End If
|
|
End If
|
|
If os$ = "LNX" Then
|
|
|
|
If Left$(headername$, 1) = "/" Then
|
|
Print #17, "#include " + Chr$(34) + headername$ + Chr$(34)
|
|
Else
|
|
Print #17, "#include " + Chr$(34) + "../../" + headername$ + Chr$(34)
|
|
End If
|
|
|
|
End If
|
|
End If
|
|
|
|
End If
|
|
|
|
l$ = l$ + sp + Chr$(34) + autoformat_x$ + Chr$(34)
|
|
|
|
If n > x Then
|
|
If dynamiclibrary Then a$ = "Cannot specify multiple DYNAMIC LIBRARY names in a single DECLARE statement": GoTo errmes
|
|
x = x + 1: x2$ = getelement$(a$, x): If x2$ <> "," Then a$ = "Expected ,": GoTo errmes
|
|
l$ = l$ + sp2 + ","
|
|
x = x + 1: If x > n Then a$ = "Expected , ...": GoTo errmes
|
|
GoTo addlibrary
|
|
End If
|
|
|
|
End If 'n>=x
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
GoTo finishednonexec 'note: no layout required
|
|
End If
|
|
End If
|
|
|
|
'begin SUB/FUNCTION
|
|
If n >= 1 Then
|
|
dynamiclibrary = 0
|
|
declaresubfunc2:
|
|
sf = 0
|
|
If firstelement$ = "FUNCTION" Then sf = 1
|
|
If firstelement$ = "SUB" Then sf = 2
|
|
If sf Then
|
|
|
|
If declaringlibrary = 0 Then
|
|
If Len(subfunc) Then a$ = "Expected END SUB/FUNCTION before " + firstelement$: GoTo errmes
|
|
End If
|
|
|
|
If n = 1 Then a$ = "Expected name after SUB/FUNCTION": GoTo errmes
|
|
e$ = getelement$(ca$, 2)
|
|
symbol$ = removesymbol$(e$) '$,%,etc.
|
|
If Error_Happened Then GoTo errmes
|
|
If sf = 2 And symbol$ <> "" Then a$ = "Type symbols after a SUB name are invalid": GoTo errmes
|
|
try = findid(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
Do While try
|
|
If id.subfunc = sf Then GoTo createsf
|
|
If try = 2 Then findanotherid = 1: try = findid(e$) Else try = 0
|
|
If Error_Happened Then GoTo errmes
|
|
Loop
|
|
a$ = "Unregistered SUB/FUNCTION encountered": GoTo errmes
|
|
createsf:
|
|
If UCase$(e$) = "_GL" Then e$ = "_GL"
|
|
If firstelement$ = "SUB" Then
|
|
l$ = SCase$("Sub") + sp + e$ + symbol$
|
|
Else
|
|
l$ = SCase$("Function") + sp + e$ + symbol$
|
|
End If
|
|
id2 = id
|
|
targetid = currentid
|
|
|
|
'check for ALIAS
|
|
aliasname$ = RTrim$(id.cn)
|
|
If n > 2 Then
|
|
ee$ = getelement$(a$, 3)
|
|
If ee$ = "ALIAS" Then
|
|
If declaringlibrary = 0 Then a$ = "ALIAS can only be used with DECLARE LIBRARY": GoTo errmes
|
|
If n = 3 Then a$ = "Expected ALIAS name-in-library": GoTo errmes
|
|
ee$ = getelement$(ca$, 4)
|
|
|
|
'strip string content (optional)
|
|
If Left$(ee$, 1) = Chr$(34) Then
|
|
ee$ = Right$(ee$, Len(ee$) - 1)
|
|
x = InStr(ee$, Chr$(34)): If x = 0 Then a$ = "Expected " + Chr$(34): GoTo errmes
|
|
ee$ = Left$(ee$, x - 1)
|
|
l$ = l$ + sp + SCase$("Alias") + sp + CHR_QUOTE + ee$ + CHR_QUOTE
|
|
Else
|
|
l$ = l$ + sp + SCase$("Alias") + sp + ee$
|
|
End If
|
|
|
|
'strip fix046$ (created by unquoted periods)
|
|
Do While InStr(ee$, fix046$)
|
|
x = InStr(ee$, fix046$): ee$ = Left$(ee$, x - 1) + "." + Right$(ee$, Len(ee$) - x + 1 - Len(fix046$))
|
|
Loop
|
|
aliasname$ = ee$
|
|
'remove ALIAS section from line
|
|
If n <= 4 Then a$ = getelements(a$, 1, 2)
|
|
If n >= 5 Then a$ = getelements(a$, 1, 2) + sp + getelements(a$, 5, n)
|
|
If n <= 4 Then ca$ = getelements(ca$, 1, 2)
|
|
If n >= 5 Then ca$ = getelements(ca$, 1, 2) + sp + getelements(ca$, 5, n)
|
|
n = n - 2
|
|
End If
|
|
End If
|
|
|
|
If declaringlibrary Then GoTo declibjmp1
|
|
|
|
|
|
If closedmain = 0 Then closemain
|
|
|
|
'check for open controls (copy #2)
|
|
If controllevel <> 0 And controltype(controllevel) <> 6 Then 'It's OK for subs to be inside $IF blocks
|
|
a$ = "Unidentified open control block"
|
|
Select Case controltype(controllevel)
|
|
Case 1: a$ = "IF without END IF"
|
|
Case 2: a$ = "FOR without NEXT"
|
|
Case 3, 4: a$ = "DO without LOOP"
|
|
Case 5: a$ = "WHILE without WEND"
|
|
Case 10 TO 19: a$ = "SELECT CASE without END SELECT"
|
|
End Select
|
|
linenumber = controlref(controllevel)
|
|
GoTo errmes
|
|
End If
|
|
|
|
If ideindentsubs Then
|
|
controllevel = controllevel + 1
|
|
controltype(controllevel) = 32
|
|
controlref(controllevel) = linenumber
|
|
End If
|
|
|
|
subfunc = RTrim$(id.callname) 'SUB_..."
|
|
subfuncn = subfuncn + 1
|
|
subfuncid = targetid
|
|
|
|
subfuncret$ = ""
|
|
|
|
Close #13: Open tmpdir$ + "data" + str2$(subfuncn) + ".txt" For Output As #13
|
|
Close #19: Open tmpdir$ + "free" + str2$(subfuncn) + ".txt" For Output As #19
|
|
Close #15: Open tmpdir$ + "ret" + str2$(subfuncn) + ".txt" For Output As #15
|
|
Print #15, "if (next_return_point){"
|
|
Print #15, "next_return_point--;"
|
|
Print #15, "switch(return_point[next_return_point]){"
|
|
Print #15, "case 0:"
|
|
Print #15, "error(3);" 'return without gosub!
|
|
Print #15, "break;"
|
|
defdatahandle = 13
|
|
|
|
declibjmp1:
|
|
|
|
If declaringlibrary Then
|
|
If sfdeclare = 0 And indirectlibrary = 0 Then
|
|
Close #17
|
|
Open tmpdir$ + "regsf_ignore.txt" For Output As #17
|
|
End If
|
|
If sfdeclare = 1 And customtypelibrary = 0 And dynamiclibrary = 0 And indirectlibrary = 0 Then
|
|
Print #17, "#include " + Chr$(34) + "externtype" + str2(ResolveStaticFunctions + 1) + ".txt" + Chr$(34)
|
|
fh = FreeFile: Open tmpdir$ + "externtype" + str2(ResolveStaticFunctions + 1) + ".txt" For Output As #fh: Close #fh
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
If sf = 1 Then
|
|
rettyp = id.ret
|
|
t$ = typ2ctyp$(id.ret, "")
|
|
If Error_Happened Then GoTo errmes
|
|
If t$ = "qbs" Then t$ = "qbs*"
|
|
|
|
If declaringlibrary Then
|
|
If rettyp And ISSTRING Then
|
|
t$ = "char*"
|
|
End If
|
|
End If
|
|
|
|
If declaringlibrary <> 0 And dynamiclibrary <> 0 Then
|
|
If os$ = "WIN" Then
|
|
Print #17, "typedef " + t$ + " (CALLBACK* DLLCALL_" + removecast$(RTrim$(id.callname)) + ")(";
|
|
End If
|
|
If os$ = "LNX" Then
|
|
Print #17, "typedef " + t$ + " (*DLLCALL_" + removecast$(RTrim$(id.callname)) + ")(";
|
|
End If
|
|
ElseIf declaringlibrary <> 0 And customtypelibrary <> 0 Then
|
|
Print #17, "typedef " + t$ + " CUSTOMCALL_" + removecast$(RTrim$(id.callname)) + "(";
|
|
Else
|
|
Print #17, t$ + " " + removecast$(RTrim$(id.callname)) + "(";
|
|
End If
|
|
If declaringlibrary Then GoTo declibjmp2
|
|
Print #12, t$ + " " + removecast$(RTrim$(id.callname)) + "(";
|
|
|
|
'create variable to return result
|
|
'if type wasn't specified, define it
|
|
If symbol$ = "" Then
|
|
a = Asc(UCase$(e$)): If a = 95 Then a = 91
|
|
a = a - 64 'so A=1, Z=27 and _=28
|
|
symbol$ = defineextaz(a)
|
|
End If
|
|
reginternalvariable = 1
|
|
ignore = dim2(e$, symbol$, 0, "")
|
|
If Error_Happened Then GoTo errmes
|
|
reginternalvariable = 0
|
|
'the following line stops the return variable from being free'd before being returned
|
|
Close #19: Open tmpdir$ + "free" + str2$(subfuncn) + ".txt" For Output As #19
|
|
'create return
|
|
If (rettyp And ISSTRING) Then
|
|
r$ = refer$(str2$(currentid), id.t, 1)
|
|
If Error_Happened Then GoTo errmes
|
|
subfuncret$ = subfuncret$ + "qbs_maketmp(" + r$ + ");"
|
|
subfuncret$ = subfuncret$ + "return " + r$ + ";"
|
|
Else
|
|
r$ = refer$(str2$(currentid), id.t, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
subfuncret$ = "return " + r$ + ";"
|
|
End If
|
|
Else
|
|
|
|
If declaringlibrary <> 0 And dynamiclibrary <> 0 Then
|
|
If os$ = "WIN" Then
|
|
Print #17, "typedef void (CALLBACK* DLLCALL_" + removecast$(RTrim$(id.callname)) + ")(";
|
|
End If
|
|
If os$ = "LNX" Then
|
|
Print #17, "typedef void (*DLLCALL_" + removecast$(RTrim$(id.callname)) + ")(";
|
|
End If
|
|
ElseIf declaringlibrary <> 0 And customtypelibrary <> 0 Then
|
|
Print #17, "typedef void CUSTOMCALL_" + removecast$(RTrim$(id.callname)) + "(";
|
|
Else
|
|
Print #17, "void " + removecast$(RTrim$(id.callname)) + "(";
|
|
End If
|
|
If declaringlibrary Then GoTo declibjmp2
|
|
Print #12, "void " + removecast$(RTrim$(id.callname)) + "(";
|
|
End If
|
|
declibjmp2:
|
|
|
|
addstatic2layout = 0
|
|
staticsf = 0
|
|
e$ = getelement$(a$, n)
|
|
If e$ = "STATIC" Then
|
|
If declaringlibrary Then a$ = "STATIC cannot be used in a library declaration": GoTo errmes
|
|
addstatic2layout = 1
|
|
staticsf = 2
|
|
a$ = Left$(a$, Len(a$) - 7): n = n - 1 'remove STATIC
|
|
End If
|
|
|
|
'check items to pass
|
|
params = 0
|
|
AllowLocalName = 1
|
|
If n > 2 Then
|
|
e$ = getelement$(a$, 3)
|
|
If e$ <> "(" Then a$ = "Expected (": GoTo errmes
|
|
e$ = getelement$(a$, n)
|
|
If e$ <> ")" Then a$ = "Expected )": GoTo errmes
|
|
l$ = l$ + sp + "("
|
|
If n = 4 Then GoTo nosfparams2
|
|
If n < 4 Then a$ = "Expected ( ... )": GoTo errmes
|
|
B = 0
|
|
a2$ = ""
|
|
For i = 4 To n - 1
|
|
e$ = getelement$(ca$, i)
|
|
If e$ = "(" Then B = B + 1
|
|
If e$ = ")" Then B = B - 1
|
|
If e$ = "," And B = 0 Then
|
|
If i = n - 1 Then a$ = "Expected , ... )": GoTo errmes
|
|
getlastparam2:
|
|
If a2$ = "" Then a$ = "Expected ... ,": GoTo errmes
|
|
a2$ = Left$(a2$, Len(a2$) - 1)
|
|
'possible format: [BYVAL]a[%][(1)][AS][type]
|
|
params = params + 1
|
|
glinkid = targetid
|
|
glinkarg = params
|
|
|
|
|
|
|
|
If params > 1 Then
|
|
Print #17, ",";
|
|
|
|
If declaringlibrary = 0 Then
|
|
Print #12, ",";
|
|
End If
|
|
|
|
End If
|
|
n2 = numelements(a2$)
|
|
array = 0
|
|
t2$ = ""
|
|
e$ = getelement$(a2$, 1)
|
|
|
|
byvalue = 0
|
|
If UCase$(e$) = "BYVAL" Then
|
|
If declaringlibrary = 0 Then a$ = "BYVAL can currently only be used with DECLARE LIBRARY": GoTo errmes
|
|
byvalue = 1: a2$ = Right$(a2$, Len(a2$) - 6)
|
|
If Right$(l$, 1) = "(" Then l$ = l$ + sp2 + SCase$("ByVal") Else l$ = l$ + sp + SCase$("Byval")
|
|
n2 = numelements(a2$): e$ = getelement$(a2$, 1)
|
|
End If
|
|
|
|
If Right$(l$, 1) = "(" Then l$ = l$ + sp2 + e$ Else l$ = l$ + sp + e$
|
|
|
|
n2$ = e$
|
|
dimmethod = 0
|
|
|
|
|
|
symbol2$ = removesymbol$(n2$)
|
|
If validname(n2$) = 0 Then a$ = "Invalid name": GoTo errmes
|
|
|
|
If Error_Happened Then GoTo errmes
|
|
If symbol2$ <> "" Then dimmethod = 1
|
|
m = 0
|
|
For i2 = 2 To n2
|
|
e$ = getelement$(a2$, i2)
|
|
If e$ = "(" Then
|
|
If m <> 0 Then a$ = "Syntax error": GoTo errmes
|
|
m = 1
|
|
array = 1
|
|
l$ = l$ + sp2 + "("
|
|
GoTo gotaa2
|
|
End If
|
|
If e$ = ")" Then
|
|
If m <> 1 Then a$ = "Syntax error": GoTo errmes
|
|
m = 2
|
|
l$ = l$ + sp2 + ")"
|
|
GoTo gotaa2
|
|
End If
|
|
If UCase$(e$) = "AS" Then
|
|
If m <> 0 And m <> 2 Then a$ = "Syntax error": GoTo errmes
|
|
m = 3
|
|
l$ = l$ + sp + SCase$("As")
|
|
GoTo gotaa2
|
|
End If
|
|
If m = 1 Then l$ = l$ + sp + e$: GoTo gotaa2 'ignore contents of option bracket telling how many dimensions (add to layout as is)
|
|
If m <> 3 Then a$ = "Syntax error": GoTo errmes
|
|
If t2$ = "" Then t2$ = e$ Else t2$ = t2$ + " " + e$
|
|
gotaa2:
|
|
Next i2
|
|
If symbol2$ <> "" And t2$ <> "" Then a$ = "Syntax error": GoTo errmes
|
|
|
|
|
|
If Len(t2$) Then 'add type-name after AS
|
|
t2$ = UCase$(t2$)
|
|
t3$ = t2$
|
|
typ = typname2typ(t3$)
|
|
If Error_Happened Then GoTo errmes
|
|
If typ = 0 Then a$ = "Undefined type": GoTo errmes
|
|
If typ And ISUDT Then
|
|
If RTrim$(udtxcname(typ And 511)) = "_MEM" And UCase$(t3$) = "MEM" And qb64prefix_set = 1 Then
|
|
t3$ = Mid$(RTrim$(udtxcname(typ And 511)), 2)
|
|
End If
|
|
t3$ = RTrim$(udtxcname(typ And 511))
|
|
l$ = l$ + sp + t3$
|
|
Else
|
|
For t3i = 1 To Len(t3$)
|
|
If Asc(t3$, t3i) = 32 Then Asc(t3$, t3i) = Asc(sp)
|
|
Next
|
|
t3$ = SCase2$(t3$)
|
|
l$ = l$ + sp + t3$
|
|
End If
|
|
End If
|
|
|
|
If t2$ = "" Then t2$ = symbol2$
|
|
If t2$ = "" Then
|
|
If Left$(n2$, 1) = "_" Then v = 27 Else v = Asc(UCase$(n2$)) - 64
|
|
t2$ = defineaz(v)
|
|
dimmethod = 1
|
|
End If
|
|
|
|
|
|
|
|
|
|
If array = 1 Then
|
|
If declaringlibrary Then a$ = "Arrays cannot be passed to a library": GoTo errmes
|
|
dimsfarray = 1
|
|
'note: id2.nele is currently 0
|
|
nelereq = Asc(Mid$(id2.nelereq, params, 1))
|
|
If nelereq Then
|
|
nele = nelereq
|
|
Mid$(id2.nele, params, 1) = Chr$(nele)
|
|
|
|
ids(targetid) = id2
|
|
|
|
ignore = dim2(n2$, t2$, dimmethod, str2$(nele))
|
|
If Error_Happened Then GoTo errmes
|
|
Else
|
|
nele = 1
|
|
Mid$(id2.nele, params, 1) = Chr$(nele)
|
|
|
|
ids(targetid) = id2
|
|
|
|
ignore = dim2(n2$, t2$, dimmethod, "?")
|
|
If Error_Happened Then GoTo errmes
|
|
End If
|
|
|
|
dimsfarray = 0
|
|
r$ = refer$(str2$(currentid), id.t, 1)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #17, "ptrszint*" + r$;
|
|
Print #12, "ptrszint*" + r$;
|
|
Else
|
|
|
|
If declaringlibrary Then
|
|
'is it a udt?
|
|
For xx = 1 To lasttype
|
|
If t2$ = RTrim$(udtxname(xx)) Then
|
|
Print #17, "void*"
|
|
GoTo decudt
|
|
ElseIf RTrim$(udtxname(xx)) = "_MEM" And t2$ = "MEM" And qb64prefix_set = 1 Then
|
|
Print #17, "void*"
|
|
GoTo decudt
|
|
End If
|
|
Next
|
|
t$ = typ2ctyp$(0, t2$)
|
|
|
|
If Error_Happened Then GoTo errmes
|
|
If t$ = "qbs" Then
|
|
t$ = "char*"
|
|
If byvalue = 1 Then a$ = "STRINGs cannot be passed using BYVAL": GoTo errmes
|
|
byvalue = 1 'use t$ as is
|
|
End If
|
|
If byvalue Then Print #17, t$; Else Print #17, t$ + "*";
|
|
decudt:
|
|
GoTo declibjmp3
|
|
End If
|
|
|
|
dimsfarray = 1
|
|
ignore = dim2(n2$, t2$, dimmethod, "")
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
|
|
dimsfarray = 0
|
|
t$ = ""
|
|
typ = id.t 'the typ of the ID created by dim2
|
|
|
|
t$ = typ2ctyp$(typ, "")
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
|
|
|
|
If t$ = "" Then a$ = "Cannot find C type to return array data": GoTo errmes
|
|
'searchpoint
|
|
'get the name of the variable
|
|
r$ = refer$(str2$(currentid), id.t, 1)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #17, t$ + "*" + r$;
|
|
Print #12, t$ + "*" + r$;
|
|
If t$ = "qbs" Then
|
|
u$ = str2$(uniquenumber)
|
|
Print #13, "qbs*oldstr" + u$ + "=NULL;"
|
|
Print #13, "if(" + r$ + "->tmp||" + r$ + "->fixed||" + r$ + "->readonly){"
|
|
Print #13, "oldstr" + u$ + "=" + r$ + ";"
|
|
|
|
Print #13, "if (oldstr" + u$ + "->cmem_descriptor){"
|
|
Print #13, r$ + "=qbs_new_cmem(oldstr" + u$ + "->len,0);"
|
|
Print #13, "}else{"
|
|
Print #13, r$ + "=qbs_new(oldstr" + u$ + "->len,0);"
|
|
Print #13, "}"
|
|
|
|
Print #13, "memcpy(" + r$ + "->chr,oldstr" + u$ + "->chr,oldstr" + u$ + "->len);"
|
|
Print #13, "}"
|
|
|
|
Print #19, "if(oldstr" + u$ + "){"
|
|
Print #19, "if(oldstr" + u$ + "->fixed)qbs_set(oldstr" + u$ + "," + r$ + ");"
|
|
Print #19, "qbs_free(" + r$ + ");"
|
|
Print #19, "}"
|
|
End If
|
|
End If
|
|
declibjmp3:
|
|
If i <> n - 1 Then l$ = l$ + sp2 + ","
|
|
|
|
a2$ = ""
|
|
Else
|
|
a2$ = a2$ + e$ + sp
|
|
If i = n - 1 Then GoTo getlastparam2
|
|
End If
|
|
Next i
|
|
nosfparams2:
|
|
l$ = l$ + sp2 + ")"
|
|
End If 'n>2
|
|
AllowLocalName = 0
|
|
|
|
If addstatic2layout Then l$ = l$ + sp + SCase$("Static")
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
|
|
Print #17, ");"
|
|
|
|
If declaringlibrary Then GoTo declibjmp4
|
|
|
|
Print #12, "){"
|
|
Print #12, "qbs *tqbs;"
|
|
Print #12, "ptrszint tmp_long;"
|
|
Print #12, "int32 tmp_fileno;"
|
|
Print #12, "uint32 qbs_tmp_base=qbs_tmp_list_nexti;"
|
|
Print #12, "uint8 *tmp_mem_static_pointer=mem_static_pointer;"
|
|
Print #12, "uint32 tmp_cmem_sp=cmem_sp;"
|
|
Print #12, "#include " + Chr$(34) + "data" + str2$(subfuncn) + ".txt" + Chr$(34)
|
|
|
|
'create new _MEM lock for this scope
|
|
Print #12, "mem_lock *sf_mem_lock;" 'MUST not be static for recursion reasons
|
|
Print #12, "new_mem_lock();"
|
|
Print #12, "sf_mem_lock=mem_lock_tmp;"
|
|
Print #12, "sf_mem_lock->type=3;"
|
|
|
|
Print #12, "if (new_error) goto exit_subfunc;"
|
|
|
|
'statementn = statementn + 1
|
|
'if nochecks=0 then PRINT #12, "S_" + str2$(statementn) + ":;"
|
|
|
|
dimstatic = staticsf
|
|
|
|
declibjmp4:
|
|
|
|
If declaringlibrary Then
|
|
|
|
If customtypelibrary Then
|
|
|
|
callname$ = removecast$(RTrim$(id2.callname))
|
|
|
|
Print #17, "CUSTOMCALL_" + callname$ + " *" + callname$ + "=NULL;"
|
|
|
|
If subfuncn Then
|
|
f = FreeFile
|
|
Open tmpdir$ + "maindata.txt" For Append As #f
|
|
Else
|
|
f = 13
|
|
End If
|
|
|
|
|
|
Print #f, callname$ + "=(CUSTOMCALL_" + callname$ + "*)&" + aliasname$ + ";"
|
|
|
|
If subfuncn Then Close #f
|
|
|
|
'if no header exists to make the external function available, the function definition must be found
|
|
If sfheader = 0 And sfdeclare <> 0 Then
|
|
ResolveStaticFunctions = ResolveStaticFunctions + 1
|
|
'expand array if necessary
|
|
If ResolveStaticFunctions > UBound(ResolveStaticFunction_Name) Then
|
|
ReDim _Preserve ResolveStaticFunction_Name(1 To ResolveStaticFunctions + 100) As String
|
|
ReDim _Preserve ResolveStaticFunction_File(1 To ResolveStaticFunctions + 100) As String
|
|
ReDim _Preserve ResolveStaticFunction_Method(1 To ResolveStaticFunctions + 100) As Long
|
|
End If
|
|
ResolveStaticFunction_File(ResolveStaticFunctions) = libname$
|
|
ResolveStaticFunction_Name(ResolveStaticFunctions) = aliasname$
|
|
ResolveStaticFunction_Method(ResolveStaticFunctions) = 1
|
|
End If 'sfheader=0
|
|
|
|
End If
|
|
|
|
If dynamiclibrary Then
|
|
If sfdeclare Then
|
|
|
|
Print #17, "DLLCALL_" + removecast$(RTrim$(id2.callname)) + " " + removecast$(RTrim$(id2.callname)) + "=NULL;"
|
|
|
|
If subfuncn Then
|
|
f = FreeFile
|
|
Open tmpdir$ + "maindata.txt" For Append As #f
|
|
Else
|
|
f = 13
|
|
End If
|
|
|
|
Print #f, "if (!" + removecast$(RTrim$(id2.callname)) + "){"
|
|
If os$ = "WIN" Then
|
|
Print #f, removecast$(RTrim$(id2.callname)) + "=(DLLCALL_" + removecast$(RTrim$(id2.callname)) + ")GetProcAddress(DLL_" + DLLname$ + "," + Chr$(34) + aliasname$ + Chr$(34) + ");"
|
|
Print #f, "if (!" + removecast$(RTrim$(id2.callname)) + ") error(260);"
|
|
End If
|
|
If os$ = "LNX" Then
|
|
Print #f, removecast$(RTrim$(id2.callname)) + "=(DLLCALL_" + removecast$(RTrim$(id2.callname)) + ")dlsym(DLL_" + DLLname$ + "," + Chr$(34) + aliasname$ + Chr$(34) + ");"
|
|
Print #f, "if (dlerror()) error(260);"
|
|
End If
|
|
Print #f, "}"
|
|
|
|
If subfuncn Then Close #f
|
|
|
|
End If 'sfdeclare
|
|
End If 'dynamic
|
|
|
|
If sfdeclare = 1 And customtypelibrary = 0 And dynamiclibrary = 0 And indirectlibrary = 0 Then
|
|
ResolveStaticFunctions = ResolveStaticFunctions + 1
|
|
'expand array if necessary
|
|
If ResolveStaticFunctions > UBound(ResolveStaticFunction_Name) Then
|
|
ReDim _Preserve ResolveStaticFunction_Name(1 To ResolveStaticFunctions + 100) As String
|
|
ReDim _Preserve ResolveStaticFunction_File(1 To ResolveStaticFunctions + 100) As String
|
|
ReDim _Preserve ResolveStaticFunction_Method(1 To ResolveStaticFunctions + 100) As Long
|
|
End If
|
|
ResolveStaticFunction_File(ResolveStaticFunctions) = libname$
|
|
ResolveStaticFunction_Name(ResolveStaticFunctions) = aliasname$
|
|
ResolveStaticFunction_Method(ResolveStaticFunctions) = 2
|
|
End If
|
|
|
|
If sfdeclare = 0 And indirectlibrary = 0 Then
|
|
Close #17
|
|
Open tmpdir$ + "regsf.txt" For Append As #17
|
|
End If
|
|
|
|
End If 'declaring library
|
|
|
|
GoTo finishednonexec
|
|
End If
|
|
End If
|
|
|
|
'END SUB/FUNCTION
|
|
If n = 2 Then
|
|
If firstelement$ = "END" Then
|
|
sf = 0
|
|
If secondelement$ = "FUNCTION" Then sf = 1
|
|
If secondelement$ = "SUB" Then sf = 2
|
|
If sf Then
|
|
|
|
If Len(subfunc) = 0 Then a$ = "END " + secondelement$ + " without " + secondelement$: GoTo errmes
|
|
|
|
'check for open controls (copy #3)
|
|
If controllevel <> 0 And controltype(controllevel) <> 6 And controltype(controllevel) <> 32 Then 'It's OK for subs to be inside $IF blocks
|
|
a$ = "Unidentified open control block"
|
|
Select Case controltype(controllevel)
|
|
Case 1: a$ = "IF without END IF"
|
|
Case 2: a$ = "FOR without NEXT"
|
|
Case 3, 4: a$ = "DO without LOOP"
|
|
Case 5: a$ = "WHILE without WEND"
|
|
Case 10 TO 19: a$ = "SELECT CASE without END SELECT"
|
|
End Select
|
|
linenumber = controlref(controllevel)
|
|
GoTo errmes
|
|
End If
|
|
|
|
If controltype(controllevel) = 32 And ideindentsubs Then
|
|
controltype(controllevel) = 0
|
|
controllevel = controllevel - 1
|
|
End If
|
|
|
|
If Left$(subfunc, 4) = "SUB_" Then secondelement$ = SCase$("Sub") Else secondelement$ = SCase$("Function")
|
|
l$ = SCase$("End") + sp + secondelement$
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
|
|
staticarraylist = "": staticarraylistn = 0 'remove previously listed arrays
|
|
dimstatic = 0
|
|
Print #12, "exit_subfunc:;"
|
|
|
|
'release _MEM lock for this scope
|
|
Print #12, "free_mem_lock(sf_mem_lock);"
|
|
|
|
Print #12, "#include " + Chr$(34) + "free" + str2$(subfuncn) + ".txt" + Chr$(34)
|
|
Print #12, "if ((tmp_mem_static_pointer>=mem_static)&&(tmp_mem_static_pointer<=mem_static_limit)) mem_static_pointer=tmp_mem_static_pointer; else mem_static_pointer=mem_static;"
|
|
Print #12, "cmem_sp=tmp_cmem_sp;"
|
|
If subfuncret$ <> "" Then Print #12, subfuncret$
|
|
|
|
Print #12, "}" 'skeleton sub
|
|
'ret???.txt
|
|
Print #15, "}" 'end case
|
|
Print #15, "}"
|
|
Print #15, "error(3);" 'no valid return possible
|
|
subfunc = ""
|
|
|
|
'unshare temp. shared variables
|
|
For i = 1 To idn
|
|
If ids(i).share And 2 Then ids(i).share = ids(i).share - 2
|
|
Next
|
|
|
|
For i = 1 To revertmaymusthaven
|
|
x = revertmaymusthave(i)
|
|
Swap ids(x).musthave, ids(x).mayhave
|
|
Next
|
|
revertmaymusthaven = 0
|
|
|
|
'undeclare constants in sub/function's scope
|
|
'constlast = constlastshared
|
|
GoTo finishednonexec
|
|
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
If n >= 1 And firstelement$ = "CONST" Then
|
|
l$ = SCase$("Const")
|
|
'DEF... do not change type, the expression is stored in a suitable type
|
|
'based on its value if type isn't forced/specified
|
|
If n < 3 Then a$ = "Expected CONST name = value/expression": GoTo errmes
|
|
i = 2
|
|
|
|
constdefpending:
|
|
pending = 0
|
|
|
|
n$ = getelement$(ca$, i): i = i + 1
|
|
l$ = l$ + sp + n$ + sp + "="
|
|
typeoverride = 0
|
|
s$ = removesymbol$(n$)
|
|
If Error_Happened Then GoTo errmes
|
|
If s$ <> "" Then
|
|
typeoverride = typname2typ(s$)
|
|
If Error_Happened Then GoTo errmes
|
|
If typeoverride And ISFIXEDLENGTH Then a$ = "Invalid constant type": GoTo errmes
|
|
If typeoverride = 0 Then a$ = "Invalid constant type": GoTo errmes
|
|
End If
|
|
|
|
If getelement$(a$, i) <> "=" Then a$ = "Expected =": GoTo errmes
|
|
i = i + 1
|
|
|
|
'get expression
|
|
e$ = ""
|
|
B = 0
|
|
For i2 = i To n
|
|
e2$ = getelement$(ca$, i2)
|
|
If e2$ = "(" Then B = B + 1
|
|
If e2$ = ")" Then B = B - 1
|
|
If e2$ = "," And B = 0 Then
|
|
pending = 1
|
|
i = i2 + 1
|
|
If i > n - 2 Then a$ = "Expected CONST ... , name = value/expression": GoTo errmes
|
|
Exit For
|
|
End If
|
|
If Len(e$) = 0 Then e$ = e2$ Else e$ = e$ + sp + e2$
|
|
Next
|
|
|
|
e$ = fixoperationorder(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + tlayout$
|
|
|
|
'Note: Actual CONST definition handled in prepass
|
|
|
|
'Set CONST as defined
|
|
hashname$ = n$
|
|
hashchkflags = HASHFLAG_CONSTANT
|
|
hashres = HashFind(hashname$, hashchkflags, hashresflags, hashresref)
|
|
Do While hashres
|
|
If constsubfunc(hashresref) = subfuncn Then constdefined(hashresref) = 1: Exit Do
|
|
If hashres <> 1 Then hashres = HashFindCont(hashresflags, hashresref) Else hashres = 0
|
|
Loop
|
|
|
|
If pending Then l$ = l$ + sp2 + ",": GoTo constdefpending
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
predefine:
|
|
If n >= 2 Then
|
|
asreq = 0
|
|
If firstelement$ = "DEFINT" Then l$ = SCase$("DefInt"): a$ = a$ + sp + "AS" + sp + "INTEGER": n = n + 2: GoTo definetype
|
|
If firstelement$ = "DEFLNG" Then l$ = SCase$("DefLng"): a$ = a$ + sp + "AS" + sp + "LONG": n = n + 2: GoTo definetype
|
|
If firstelement$ = "DEFSNG" Then l$ = SCase$("DefSng"): a$ = a$ + sp + "AS" + sp + "SINGLE": n = n + 2: GoTo definetype
|
|
If firstelement$ = "DEFDBL" Then l$ = SCase$("DefDbl"): a$ = a$ + sp + "AS" + sp + "DOUBLE": n = n + 2: GoTo definetype
|
|
If firstelement$ = "DEFSTR" Then l$ = SCase$("DefStr"): a$ = a$ + sp + "AS" + sp + "STRING": n = n + 2: GoTo definetype
|
|
If firstelement$ = "_DEFINE" Or (firstelement$ = "DEFINE" And qb64prefix_set = 1) Then
|
|
asreq = 1
|
|
If firstelement$ = "_DEFINE" Then l$ = SCase$("_Define") Else l$ = SCase$("Define")
|
|
definetype:
|
|
'get type from rhs
|
|
typ$ = ""
|
|
typ2$ = ""
|
|
t$ = ""
|
|
For i = n To 2 Step -1
|
|
t$ = getelement$(a$, i)
|
|
If t$ = "AS" Then Exit For
|
|
typ$ = t$ + " " + typ$
|
|
typ2$ = t$ + sp + typ2$
|
|
Next
|
|
typ$ = RTrim$(typ$)
|
|
If t$ <> "AS" Then a$ = qb64prefix$ + "DEFINE: Expected ... AS ...": GoTo errmes
|
|
If i = n Or i = 2 Then a$ = qb64prefix$ + "DEFINE: Expected ... AS ...": GoTo errmes
|
|
|
|
|
|
n = i - 1
|
|
'the data is from element 2 to element n
|
|
i = 2 - 1
|
|
definenext:
|
|
'expects an alphabet letter or underscore
|
|
i = i + 1: e$ = getelement$(a$, i): E = Asc(UCase$(e$))
|
|
If Len(e$) > 1 Then a$ = qb64prefix$ + "DEFINE: Expected an alphabet letter or the underscore character (_)": GoTo errmes
|
|
If E <> 95 And (E > 90 Or E < 65) Then a$ = qb64prefix$ + "DEFINE: Expected an alphabet letter or the underscore character (_)": GoTo errmes
|
|
If E = 95 Then E = 27 Else E = E - 64
|
|
defineaz(E) = typ$
|
|
defineextaz(E) = type2symbol(typ$)
|
|
If Error_Happened Then GoTo errmes
|
|
firste = E
|
|
l$ = l$ + sp + e$
|
|
|
|
If i = n Then
|
|
If predefining = 1 Then GoTo predefined
|
|
If asreq Then l$ = l$ + sp + SCase$("As") + sp + typ2$
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishednonexec
|
|
End If
|
|
|
|
'expects "-" or ","
|
|
i = i + 1: e$ = getelement$(a$, i)
|
|
If e$ <> "-" And e$ <> "," Then a$ = qb64prefix$ + "DEFINE: Expected - or ,": GoTo errmes
|
|
If e$ = "-" Then
|
|
l$ = l$ + sp2 + "-"
|
|
If i = n Then a$ = qb64prefix$ + "DEFINE: Syntax incomplete": GoTo errmes
|
|
'expects an alphabet letter or underscore
|
|
i = i + 1: e$ = getelement$(a$, i): E = Asc(UCase$(e$))
|
|
If Len(e$) > 1 Then a$ = qb64prefix$ + "DEFINE: Expected an alphabet letter or the underscore character (_)": GoTo errmes
|
|
If E <> 95 And (E > 90 Or E < 65) Then a$ = qb64prefix$ + "DEFINE: Expected an alphabet letter or the underscore character (_)": GoTo errmes
|
|
If E = 95 Then E = 27 Else E = E - 64
|
|
If firste > E Then Swap E, firste
|
|
For e2 = firste To E
|
|
defineaz(e2) = typ$
|
|
defineextaz(e2) = type2symbol(typ$)
|
|
If Error_Happened Then GoTo errmes
|
|
Next
|
|
l$ = l$ + sp2 + e$
|
|
If i = n Then
|
|
If predefining = 1 Then GoTo predefined
|
|
If asreq Then l$ = l$ + sp + SCase$("As") + sp + typ2$
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishednonexec
|
|
End If
|
|
'expects ","
|
|
i = i + 1: e$ = getelement$(a$, i)
|
|
If e$ <> "," Then a$ = qb64prefix$ + "DEFINE: Expected ,": GoTo errmes
|
|
End If
|
|
l$ = l$ + sp2 + ","
|
|
GoTo definenext
|
|
End If '_DEFINE
|
|
End If '2
|
|
If predefining = 1 Then GoTo predefined
|
|
|
|
If closedmain <> 0 And subfunc = "" Then a$ = "Statement cannot be placed between SUB/FUNCTIONs": GoTo errmes
|
|
|
|
'executable section:
|
|
|
|
statementn = statementn + 1
|
|
|
|
|
|
If n >= 1 Then
|
|
If firstelement$ = "NEXT" Then
|
|
|
|
l$ = SCase$("Next")
|
|
If n = 1 Then GoTo simplenext
|
|
v$ = ""
|
|
For i = 2 To n
|
|
a2$ = getelement(ca$, i)
|
|
|
|
If a2$ = "," Then
|
|
|
|
lastnextele:
|
|
e$ = fixoperationorder(v$)
|
|
If Error_Happened Then GoTo errmes
|
|
If Len(l$) = 4 Then l$ = l$ + sp + tlayout$ Else l$ = l$ + sp2 + "," + sp + tlayout$
|
|
e$ = evaluate(e$, typ)
|
|
If Error_Happened Then GoTo errmes
|
|
If (typ And ISREFERENCE) Then
|
|
getid Val(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
If (id.t And ISPOINTER) Then
|
|
If (id.t And ISSTRING) = 0 Then
|
|
If (id.t And ISOFFSETINBITS) = 0 Then
|
|
If (id.t And ISARRAY) = 0 Then
|
|
GoTo fornextfoundvar2
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
a$ = "Unsupported variable after NEXT": GoTo errmes
|
|
fornextfoundvar2:
|
|
simplenext:
|
|
If controltype(controllevel) <> 2 Then a$ = "NEXT without FOR": GoTo errmes
|
|
If n <> 1 And controlvalue(controllevel) <> currentid Then a$ = "Incorrect variable after NEXT": GoTo errmes
|
|
Print #12, "fornext_continue_" + str2$(controlid(controllevel)) + ":;"
|
|
Print #12, "}"
|
|
Print #12, "fornext_exit_" + str2$(controlid(controllevel)) + ":;"
|
|
controllevel = controllevel - 1
|
|
If n = 1 Then Exit For
|
|
v$ = ""
|
|
|
|
Else
|
|
|
|
If Len(v$) Then v$ = v$ + sp + a2$ Else v$ = a2$
|
|
If i = n Then GoTo lastnextele
|
|
|
|
End If
|
|
|
|
Next
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishednonexec '***no error causing code, event checking done by FOR***
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
If n >= 1 Then
|
|
If firstelement$ = "WHILE" Then
|
|
If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1
|
|
|
|
'prevents code from being placed before 'CASE condition' in a SELECT CASE block
|
|
If SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then
|
|
a$ = "Expected CASE expression": GoTo errmes
|
|
End If
|
|
|
|
controllevel = controllevel + 1
|
|
controlref(controllevel) = linenumber
|
|
controltype(controllevel) = 5
|
|
controlid(controllevel) = uniquenumber
|
|
If n >= 2 Then
|
|
e$ = fixoperationorder(getelements$(ca$, 2, n))
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = SCase$("While") + sp + tlayout$
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
e$ = evaluate(e$, typ)
|
|
If Error_Happened Then GoTo errmes
|
|
If (typ And ISREFERENCE) Then e$ = refer$(e$, typ, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
If stringprocessinghappened Then e$ = cleanupstringprocessingcall$ + e$ + ")"
|
|
If (typ And ISSTRING) Then a$ = "WHILE ERROR! Cannot accept a STRING type.": GoTo errmes
|
|
Print #12, "while((" + e$ + ")||new_error){"
|
|
Else
|
|
a$ = "WHILE ERROR! Expected expression after WHILE.": GoTo errmes
|
|
End If
|
|
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
If n = 1 Then
|
|
If firstelement$ = "WEND" Then
|
|
|
|
|
|
If controltype(controllevel) <> 5 Then a$ = "WEND without WHILE": GoTo errmes
|
|
Print #12, "ww_continue_" + str2$(controlid(controllevel)) + ":;"
|
|
Print #12, "}"
|
|
Print #12, "ww_exit_" + str2$(controlid(controllevel)) + ":;"
|
|
controllevel = controllevel - 1
|
|
l$ = SCase$("Wend")
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishednonexec '***no error causing code, event checking done by WHILE***
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
If n >= 1 Then
|
|
If firstelement$ = "DO" Then
|
|
If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1
|
|
|
|
'prevents code from being placed before 'CASE condition' in a SELECT CASE block
|
|
If SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then
|
|
a$ = "Expected CASE expression": GoTo errmes
|
|
End If
|
|
|
|
controllevel = controllevel + 1
|
|
controlref(controllevel) = linenumber
|
|
l$ = SCase$("Do")
|
|
If n >= 2 Then
|
|
whileuntil = 0
|
|
If secondelement$ = "WHILE" Then whileuntil = 1: l$ = l$ + sp + SCase$("While")
|
|
If secondelement$ = "UNTIL" Then whileuntil = 2: l$ = l$ + sp + SCase$("Until")
|
|
If whileuntil = 0 Then a$ = "DO ERROR! Expected WHILE or UNTIL after DO.": GoTo errmes
|
|
If whileuntil > 0 And n = 2 Then a$ = "Condition expected after WHILE/UNTIL": GoTo errmes
|
|
e$ = fixoperationorder(getelements$(ca$, 3, n))
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + tlayout$
|
|
e$ = evaluate(e$, typ)
|
|
If Error_Happened Then GoTo errmes
|
|
If (typ And ISREFERENCE) Then e$ = refer$(e$, typ, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
If stringprocessinghappened Then e$ = cleanupstringprocessingcall$ + e$ + ")"
|
|
If (typ And ISSTRING) Then a$ = "DO ERROR! Cannot accept a STRING type.": GoTo errmes
|
|
If whileuntil = 1 Then Print #12, "while((" + e$ + ")||new_error){" Else Print #12, "while((!(" + e$ + "))||new_error){"
|
|
controltype(controllevel) = 4
|
|
Else
|
|
controltype(controllevel) = 3
|
|
Print #12, "do{"
|
|
End If
|
|
controlid(controllevel) = uniquenumber
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
If n >= 1 Then
|
|
If firstelement$ = "LOOP" Then
|
|
l$ = SCase$("Loop")
|
|
If controltype(controllevel) <> 3 And controltype(controllevel) <> 4 Then a$ = "PROGRAM FLOW ERROR!": GoTo errmes
|
|
If n >= 2 Then
|
|
If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1
|
|
If controltype(controllevel) = 4 Then a$ = "PROGRAM FLOW ERROR!": GoTo errmes
|
|
whileuntil = 0
|
|
If secondelement$ = "WHILE" Then whileuntil = 1: l$ = l$ + sp + SCase$("While")
|
|
If secondelement$ = "UNTIL" Then whileuntil = 2: l$ = l$ + sp + SCase$("Until")
|
|
If whileuntil = 0 Then a$ = "LOOP ERROR! Expected WHILE or UNTIL after LOOP.": GoTo errmes
|
|
If whileuntil > 0 And n = 2 Then a$ = "Condition expected after WHILE/UNTIL": GoTo errmes
|
|
e$ = fixoperationorder(getelements$(ca$, 3, n))
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + tlayout$
|
|
e$ = evaluate(e$, typ)
|
|
If Error_Happened Then GoTo errmes
|
|
If (typ And ISREFERENCE) Then e$ = refer$(e$, typ, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
If stringprocessinghappened Then e$ = cleanupstringprocessingcall$ + e$ + ")"
|
|
If (typ And ISSTRING) Then a$ = "LOOP ERROR! Cannot accept a STRING type.": GoTo errmes
|
|
Print #12, "dl_continue_" + str2$(controlid(controllevel)) + ":;"
|
|
If whileuntil = 1 Then Print #12, "}while((" + e$ + ")&&(!new_error));" Else Print #12, "}while((!(" + e$ + "))&&(!new_error));"
|
|
Else
|
|
Print #12, "dl_continue_" + str2$(controlid(controllevel)) + ":;"
|
|
If controltype(controllevel) = 4 Then
|
|
Print #12, "}"
|
|
Else
|
|
Print #12, "}while(1);" 'infinite loop!
|
|
End If
|
|
End If
|
|
Print #12, "dl_exit_" + str2$(controlid(controllevel)) + ":;"
|
|
controllevel = controllevel - 1
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
If n = 1 Then GoTo finishednonexec '***no error causing code, event checking done by DO***
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
If n >= 1 Then
|
|
If firstelement$ = "FOR" Then
|
|
If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1
|
|
|
|
l$ = SCase$("For")
|
|
|
|
'prevents code from being placed before 'CASE condition' in a SELECT CASE block
|
|
If SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then
|
|
a$ = "Expected CASE expression": GoTo errmes
|
|
End If
|
|
|
|
controllevel = controllevel + 1
|
|
controlref(controllevel) = linenumber
|
|
controltype(controllevel) = 2
|
|
controlid(controllevel) = uniquenumber
|
|
|
|
v$ = ""
|
|
startvalue$ = ""
|
|
p3$ = "1": stepused = 0
|
|
p2$ = ""
|
|
mode = 0
|
|
E = 0
|
|
For i = 2 To n
|
|
e$ = getelement$(a$, i)
|
|
If e$ = "=" Then
|
|
If mode <> 0 Then E = 1: Exit For
|
|
mode = 1
|
|
v$ = getelements$(ca$, 2, i - 1)
|
|
equpos = i
|
|
End If
|
|
If e$ = "TO" Then
|
|
If mode <> 1 Then E = 1: Exit For
|
|
mode = 2
|
|
startvalue$ = getelements$(ca$, equpos + 1, i - 1)
|
|
topos = i
|
|
End If
|
|
If e$ = "STEP" Then
|
|
If mode <> 2 Then E = 1: Exit For
|
|
mode = 3
|
|
stepused = 1
|
|
p2$ = getelements$(ca$, topos + 1, i - 1)
|
|
p3$ = getelements$(ca$, i + 1, n)
|
|
Exit For
|
|
End If
|
|
Next
|
|
If mode < 2 Then E = 1
|
|
If p2$ = "" Then p2$ = getelements$(ca$, topos + 1, n)
|
|
If Len(v$) = 0 Or Len(startvalue$) = 0 Or Len(p2$) = 0 Then E = 1
|
|
If E <> 0 And mode < 3 Then a$ = "Expected FOR name = start TO end": GoTo errmes
|
|
If E Then a$ = "Expected FOR name = start TO end STEP increment": GoTo errmes
|
|
|
|
e$ = fixoperationorder(v$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + tlayout$
|
|
e$ = evaluate(e$, typ)
|
|
If Error_Happened Then GoTo errmes
|
|
If (typ And ISREFERENCE) Then
|
|
getid Val(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
If (id.t And ISPOINTER) Then
|
|
If (id.t And ISSTRING) = 0 Then
|
|
If (id.t And ISOFFSETINBITS) = 0 Then
|
|
If (id.t And ISARRAY) = 0 Then
|
|
GoTo fornextfoundvar
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
a$ = "Unsupported variable used in FOR statement": GoTo errmes
|
|
fornextfoundvar:
|
|
controlvalue(controllevel) = currentid
|
|
v$ = e$
|
|
|
|
'find C++ datatype to match variable
|
|
'markup to cater for greater range/accuracy
|
|
ctype$ = ""
|
|
ctyp = typ - ISPOINTER
|
|
bits = typ And 511
|
|
If (typ And ISFLOAT) Then
|
|
If bits = 32 Then ctype$ = "double": ctyp = 64& + ISFLOAT
|
|
If bits = 64 Then ctype$ = "long double": ctyp = 256& + ISFLOAT
|
|
If bits = 256 Then ctype$ = "long double": ctyp = 256& + ISFLOAT
|
|
Else
|
|
If bits = 8 Then ctype$ = "int16": ctyp = 16&
|
|
If bits = 16 Then ctype$ = "int32": ctyp = 32&
|
|
If bits = 32 Then ctype$ = "int64": ctyp = 64&
|
|
If bits = 64 Then ctype$ = "int64": ctyp = 64&
|
|
End If
|
|
If ctype$ = "" Then a$ = "Unsupported variable used in FOR statement": GoTo errmes
|
|
u$ = str2(uniquenumber)
|
|
|
|
If subfunc = "" Then
|
|
Print #13, "static " + ctype$ + " fornext_value" + u$ + ";"
|
|
Print #13, "static " + ctype$ + " fornext_finalvalue" + u$ + ";"
|
|
Print #13, "static " + ctype$ + " fornext_step" + u$ + ";"
|
|
Print #13, "static uint8 fornext_step_negative" + u$ + ";"
|
|
Else
|
|
Print #13, ctype$ + " fornext_value" + u$ + ";"
|
|
Print #13, ctype$ + " fornext_finalvalue" + u$ + ";"
|
|
Print #13, ctype$ + " fornext_step" + u$ + ";"
|
|
Print #13, "uint8 fornext_step_negative" + u$ + ";"
|
|
End If
|
|
|
|
'calculate start
|
|
e$ = fixoperationorder$(startvalue$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + "=" + sp + tlayout$
|
|
e$ = evaluatetotyp$(e$, ctyp)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "fornext_value" + u$ + "=" + e$ + ";"
|
|
|
|
'final
|
|
e$ = fixoperationorder$(p2$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + SCase$("To") + sp + tlayout$
|
|
e$ = evaluatetotyp(e$, ctyp)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "fornext_finalvalue" + u$ + "=" + e$ + ";"
|
|
|
|
'step
|
|
e$ = fixoperationorder$(p3$)
|
|
If Error_Happened Then GoTo errmes
|
|
If stepused = 1 Then l$ = l$ + sp + SCase$("Step") + sp + tlayout$
|
|
e$ = evaluatetotyp(e$, ctyp)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "fornext_step" + u$ + "=" + e$ + ";"
|
|
Print #12, "if (fornext_step" + u$ + "<0) fornext_step_negative" + u$ + "=1; else fornext_step_negative" + u$ + "=0;"
|
|
|
|
Print #12, "if (new_error) goto fornext_error" + u$ + ";"
|
|
Print #12, "goto fornext_entrylabel" + u$ + ";"
|
|
Print #12, "while(1){"
|
|
typbak = typ
|
|
Print #12, "fornext_value" + u$ + "=fornext_step" + u$ + "+(" + refer$(v$, typ, 0) + ");"
|
|
If Error_Happened Then GoTo errmes
|
|
typ = typbak
|
|
Print #12, "fornext_entrylabel" + u$ + ":"
|
|
setrefer v$, typ, "fornext_value" + u$, 1
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "if (fornext_step_negative" + u$ + "){"
|
|
Print #12, "if (fornext_value" + u$ + "<fornext_finalvalue" + u$ + ") break;"
|
|
Print #12, "}else{"
|
|
Print #12, "if (fornext_value" + u$ + ">fornext_finalvalue" + u$ + ") break;"
|
|
Print #12, "}"
|
|
Print #12, "fornext_error" + u$ + ":;"
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
|
|
If n = 1 Then
|
|
If firstelement$ = "ELSE" Then
|
|
|
|
'Routine to add error checking for ELSE so we'll no longer be able to do things like the following:
|
|
'IF x = 1 THEN
|
|
' SELECT CASE s
|
|
' CASE 1
|
|
' END SELECT ELSE y = 2
|
|
'END IF
|
|
'Notice the ELSE with the SELECT CASE? Before this patch, commands like those were considered valid QB64 code.
|
|
temp$ = UCase$(LTrim$(RTrim$(wholeline)))
|
|
'IF NoIDEMode THEN
|
|
Do While InStr(temp$, Chr$(9))
|
|
Asc(temp$, InStr(temp$, Chr$(9))) = 32
|
|
Loop
|
|
'END IF
|
|
goodelse = 0 'a check to see if it's a good else
|
|
If Left$(temp$, 2) = "IF" Then goodelse = -1: GoTo skipelsecheck 'If we have an IF, the else is probably good
|
|
If Left$(temp$, 4) = "ELSE" Then goodelse = -1: GoTo skipelsecheck 'If it's an else by itself,then we'll call it good too at this point and let the rest of the syntax checking check for us
|
|
Do
|
|
spacelocation = InStr(temp$, " ")
|
|
If spacelocation Then temp$ = Left$(temp$, spacelocation - 1) + Mid$(temp$, spacelocation + 1)
|
|
Loop Until spacelocation = 0
|
|
If InStr(temp$, ":ELSE") Or InStr(temp$, ":IF") Then goodelse = -1: GoTo skipelsecheck 'I personally don't like the idea of a :ELSE statement, but this checks for that and validates it as well. YUCK! (I suppose this might be useful if there's a label where the ELSE is, like thisline: ELSE
|
|
count = 0
|
|
Do
|
|
count = count + 1
|
|
Select Case Mid$(temp$, count, 1)
|
|
Case Is = "1", "2", "3", "4", "5", "6", "7", "8", "9", "0", ":"
|
|
Case Else: Exit Do
|
|
End Select
|
|
Loop Until count >= Len(temp$)
|
|
If Mid$(temp$, count, 4) = "ELSE" Or Mid$(temp$, count, 2) = "IF" Then goodelse = -1 'We only had numbers before our else
|
|
If Not goodelse Then a$ = "Invalid Syntax for ELSE": GoTo errmes
|
|
skipelsecheck:
|
|
'End of ELSE Error checking
|
|
For i = controllevel To 1 Step -1
|
|
t = controltype(i)
|
|
If t = 1 Then
|
|
If controlstate(controllevel) = 2 Then a$ = "IF-THEN already contains an ELSE statement": GoTo errmes
|
|
Print #12, "}else{"
|
|
controlstate(controllevel) = 2
|
|
If lineelseused = 0 Then lhscontrollevel = lhscontrollevel - 1
|
|
l$ = SCase$("Else")
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishednonexec '***no error causing code, event checking done by IF***
|
|
End If
|
|
Next
|
|
a$ = "ELSE without IF": GoTo errmes
|
|
End If
|
|
End If
|
|
|
|
If n >= 3 Then
|
|
If firstelement$ = "ELSEIF" Then
|
|
If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1
|
|
|
|
For i = controllevel To 1 Step -1
|
|
t = controltype(i)
|
|
If t = 1 Then
|
|
If controlstate(controllevel) = 2 Then a$ = "ELSEIF invalid after ELSE": GoTo errmes
|
|
controlstate(controllevel) = 1
|
|
controlvalue(controllevel) = controlvalue(controllevel) + 1
|
|
e$ = getelement$(a$, n)
|
|
If e$ <> "THEN" Then a$ = "Expected ELSEIF expression THEN": GoTo errmes
|
|
Print #12, "}else{"
|
|
e$ = fixoperationorder$(getelements$(ca$, 2, n - 1))
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = SCase$("ElseIf") + sp + tlayout$ + sp + SCase$("Then")
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
e$ = evaluate(e$, typ)
|
|
If Error_Happened Then GoTo errmes
|
|
If (typ And ISREFERENCE) Then e$ = refer$(e$, typ, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
If typ And ISSTRING Then
|
|
a$ = "Expected ELSEIF LEN(stringexpression) THEN": GoTo errmes
|
|
End If
|
|
If stringprocessinghappened Then
|
|
Print #12, "if (" + cleanupstringprocessingcall$ + e$ + ")){"
|
|
Else
|
|
Print #12, "if (" + e$ + "){"
|
|
End If
|
|
lhscontrollevel = lhscontrollevel - 1
|
|
GoTo finishedline
|
|
End If
|
|
Next
|
|
a$ = "ELSEIF without IF": GoTo errmes
|
|
End If
|
|
End If
|
|
|
|
If n >= 3 Then
|
|
If firstelement$ = "IF" Then
|
|
If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1
|
|
|
|
'prevents code from being placed before 'CASE condition' in a SELECT CASE block
|
|
If SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then
|
|
a$ = "Expected CASE expression": GoTo errmes
|
|
End If
|
|
|
|
e$ = getelement(a$, n)
|
|
iftype = 0
|
|
If e$ = "THEN" Then iftype = 1
|
|
If e$ = "GOTO" Then iftype = 2
|
|
If iftype = 0 Then a$ = "Expected IF expression THEN/GOTO": GoTo errmes
|
|
|
|
controllevel = controllevel + 1
|
|
controlref(controllevel) = linenumber
|
|
controltype(controllevel) = 1
|
|
controlvalue(controllevel) = 0 'number of extra closing } required at END IF
|
|
controlstate(controllevel) = 0
|
|
|
|
e$ = fixoperationorder$(getelements(ca$, 2, n - 1))
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = SCase$("If") + sp + tlayout$
|
|
e$ = evaluate(e$, typ)
|
|
If Error_Happened Then GoTo errmes
|
|
If (typ And ISREFERENCE) Then e$ = refer$(e$, typ, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
If typ And ISSTRING Then
|
|
a$ = "Expected IF LEN(stringexpression) THEN": GoTo errmes
|
|
End If
|
|
|
|
If stringprocessinghappened Then
|
|
Print #12, "if ((" + cleanupstringprocessingcall$ + e$ + "))||new_error){"
|
|
Else
|
|
Print #12, "if ((" + e$ + ")||new_error){"
|
|
End If
|
|
|
|
If iftype = 1 Then l$ = l$ + sp + SCase$("Then") 'note: 'GOTO' will be added when iftype=2
|
|
layoutdone = 1: If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$
|
|
|
|
If iftype = 2 Then 'IF ... GOTO
|
|
GoTo finishedline
|
|
End If
|
|
|
|
THENGOTO = 1 'possible: IF a=1 THEN 10
|
|
GoTo finishedline2
|
|
End If
|
|
End If
|
|
|
|
'ENDIF
|
|
If n = 1 And getelement(a$, 1) = "ENDIF" Then
|
|
If controltype(controllevel) <> 1 Then a$ = "END IF without IF": GoTo errmes
|
|
layoutdone = 1
|
|
If impliedendif = 0 Then
|
|
l$ = SCase$("End If")
|
|
If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$
|
|
End If
|
|
|
|
Print #12, "}"
|
|
For i = 1 To controlvalue(controllevel)
|
|
Print #12, "}"
|
|
Next
|
|
controllevel = controllevel - 1
|
|
GoTo finishednonexec '***no error causing code, event checking done by IF***
|
|
End If
|
|
|
|
|
|
'END IF
|
|
If n = 2 Then
|
|
If getelement(a$, 1) = "END" And getelement(a$, 2) = "IF" Then
|
|
|
|
|
|
If controltype(controllevel) <> 1 Then a$ = "END IF without IF": GoTo errmes
|
|
layoutdone = 1
|
|
If impliedendif = 0 Then
|
|
l$ = SCase$("End" + sp + "If")
|
|
If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$
|
|
End If
|
|
|
|
Print #12, "}"
|
|
For i = 1 To controlvalue(controllevel)
|
|
Print #12, "}"
|
|
Next
|
|
controllevel = controllevel - 1
|
|
GoTo finishednonexec '***no error causing code, event checking done by IF***
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
'SELECT CASE
|
|
If n >= 1 Then
|
|
If firstelement$ = "SELECT" Then
|
|
If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1
|
|
|
|
'prevents code from being placed before 'CASE condition' in a SELECT CASE block
|
|
If SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then
|
|
a$ = "Expected CASE expression": GoTo errmes
|
|
End If
|
|
|
|
SelectCaseCounter = SelectCaseCounter + 1
|
|
If UBound(EveryCaseSet) <= SelectCaseCounter Then ReDim _Preserve EveryCaseSet(SelectCaseCounter)
|
|
If UBound(SelectCaseHasCaseBlock) <= SelectCaseCounter Then ReDim _Preserve SelectCaseHasCaseBlock(SelectCaseCounter)
|
|
SelectCaseHasCaseBlock(SelectCaseCounter) = 0
|
|
If secondelement$ = "EVERYCASE" Then
|
|
EveryCaseSet(SelectCaseCounter) = -1
|
|
If n = 2 Then a$ = "Expected SELECT CASE expression": GoTo errmes
|
|
e$ = fixoperationorder(getelements$(ca$, 3, n))
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = SCase$("Select EveryCase ") + tlayout$
|
|
Else
|
|
EveryCaseSet(SelectCaseCounter) = 0
|
|
If n = 1 Or secondelement$ <> "CASE" Then a$ = "Expected CASE or EVERYCASE": GoTo errmes
|
|
If n = 2 Then a$ = "Expected SELECT CASE expression": GoTo errmes
|
|
e$ = fixoperationorder(getelements$(ca$, 3, n))
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = SCase$("Select Case ") + tlayout$
|
|
End If
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
e$ = evaluate(e$, typ)
|
|
If Error_Happened Then GoTo errmes
|
|
u = uniquenumber
|
|
|
|
controllevel = controllevel + 1
|
|
controlvalue(controllevel) = 0 'id
|
|
|
|
t$ = ""
|
|
If (typ And ISSTRING) Then
|
|
t = 0
|
|
If (typ And ISUDT) = 0 And (typ And ISARRAY) = 0 And (typ And ISREFERENCE) <> 0 Then
|
|
controlvalue(controllevel) = Val(e$)
|
|
Else
|
|
If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #13, "static qbs *sc_" + str2$(u) + "=qbs_new(0,0);"
|
|
Print #12, "qbs_set(sc_" + str2$(u) + "," + e$ + ");"
|
|
If stringprocessinghappened Then Print #12, cleanupstringprocessingcall$ + "0);"
|
|
End If
|
|
|
|
Else
|
|
|
|
If (typ And ISFLOAT) Then
|
|
|
|
If (typ And 511) > 64 Then t = 3: t$ = "long double"
|
|
If (typ And 511) = 32 Then t = 4: t$ = "float"
|
|
If (typ And 511) = 64 Then t = 5: t$ = "double"
|
|
If (typ And ISUDT) = 0 And (typ And ISARRAY) = 0 And (typ And ISREFERENCE) <> 0 Then
|
|
controlvalue(controllevel) = Val(e$)
|
|
Else
|
|
If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
Print #13, "static " + t$ + " sc_" + str2$(u) + ";"
|
|
Print #12, "sc_" + str2$(u) + "=" + e$ + ";"
|
|
If stringprocessinghappened Then Print #12, cleanupstringprocessingcall$ + "0);"
|
|
End If
|
|
|
|
Else
|
|
|
|
'non-float
|
|
t = 1: t$ = "int64"
|
|
If (typ And ISUNSIGNED) Then
|
|
If (typ And 511) <= 32 Then t = 7: t$ = "uint32"
|
|
If (typ And 511) > 32 Then t = 2: t$ = "uint64"
|
|
Else
|
|
If (typ And 511) <= 32 Then t = 6: t$ = "int32"
|
|
If (typ And 511) > 32 Then t = 1: t$ = "int64"
|
|
End If
|
|
If (typ And ISUDT) = 0 And (typ And ISARRAY) = 0 And (typ And ISREFERENCE) <> 0 Then
|
|
controlvalue(controllevel) = Val(e$)
|
|
Else
|
|
If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #13, "static " + t$ + " sc_" + str2$(u) + ";"
|
|
Print #12, "sc_" + str2$(u) + "=" + e$ + ";"
|
|
If stringprocessinghappened Then Print #12, cleanupstringprocessingcall$ + "0);"
|
|
End If
|
|
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
controlref(controllevel) = linenumber
|
|
controltype(controllevel) = 10 + t
|
|
controlid(controllevel) = u
|
|
If EveryCaseSet(SelectCaseCounter) Then Print #13, "int32 sc_" + str2$(controlid(controllevel)) + "_var;"
|
|
If EveryCaseSet(SelectCaseCounter) Then Print #12, "sc_" + str2$(controlid(controllevel)) + "_var=0;"
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
|
|
'END SELECT
|
|
If n = 2 Then
|
|
If firstelement$ = "END" And secondelement$ = "SELECT" Then
|
|
'complete current case if necessary
|
|
'18=CASE (awaiting END SELECT/CASE/CASE ELSE)
|
|
'19=CASE ELSE (awaiting END SELECT)
|
|
If controltype(controllevel) = 18 Then
|
|
everycasenewcase = everycasenewcase + 1
|
|
Print #12, "sc_ec_" + str2$(everycasenewcase) + "_end:;"
|
|
controllevel = controllevel - 1
|
|
If EveryCaseSet(SelectCaseCounter) = 0 Then Print #12, "goto sc_" + str2$(controlid(controllevel)) + "_end;"
|
|
Print #12, "}"
|
|
End If
|
|
If controltype(controllevel) = 19 Then
|
|
controllevel = controllevel - 1
|
|
If EveryCaseSet(SelectCaseCounter) Then Print #12, "} /* End of SELECT EVERYCASE ELSE */"
|
|
End If
|
|
Print #12, "sc_" + str2$(controlid(controllevel)) + "_end:;"
|
|
If controltype(controllevel) < 10 Or controltype(controllevel) > 17 Then a$ = "END SELECT without SELECT CASE": GoTo errmes
|
|
|
|
If SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then
|
|
'warn user of empty SELECT CASE block
|
|
If Not IgnoreWarnings Then
|
|
addWarning linenumber, inclevel, inclinenumber(inclevel), incname$(inclevel), "empty SELECT CASE block", ""
|
|
End If
|
|
End If
|
|
|
|
controllevel = controllevel - 1
|
|
SelectCaseCounter = SelectCaseCounter - 1
|
|
l$ = SCase$("End" + sp + "Select")
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishednonexec '***no error causing code, event checking done by SELECT CASE***
|
|
End If
|
|
End If
|
|
|
|
'prevents code from being placed before 'CASE condition' in a SELECT CASE block
|
|
If n >= 1 And firstelement$ <> "CASE" And SelectCaseCounter > 0 And SelectCaseHasCaseBlock(SelectCaseCounter) = 0 Then
|
|
a$ = "Expected CASE expression": GoTo errmes
|
|
End If
|
|
|
|
|
|
'CASE
|
|
If n >= 1 Then
|
|
If firstelement$ = "CASE" Then
|
|
|
|
l$ = SCase$("Case")
|
|
'complete current case if necessary
|
|
'18=CASE (awaiting END SELECT/CASE/CASE ELSE)
|
|
'19=CASE ELSE (awaiting END SELECT)
|
|
If controltype(controllevel) = 19 Then a$ = "Expected END SELECT": GoTo errmes
|
|
If controltype(controllevel) = 18 Then
|
|
lhscontrollevel = lhscontrollevel - 1
|
|
controllevel = controllevel - 1
|
|
everycasenewcase = everycasenewcase + 1
|
|
Print #12, "sc_ec_" + str2$(everycasenewcase) + "_end:;"
|
|
If EveryCaseSet(SelectCaseCounter) = 0 Then
|
|
Print #12, "goto sc_" + str2$(controlid(controllevel)) + "_end;"
|
|
Else
|
|
Print #12, "sc_" + str2$(controlid(controllevel)) + "_var=-1;"
|
|
End If
|
|
Print #12, "}"
|
|
'following line fixes problem related to RESUME after error
|
|
'statementn = statementn + 1
|
|
'if nochecks=0 then PRINT #12, "S_" + str2$(statementn) + ":;"
|
|
End If
|
|
|
|
If controltype(controllevel) <> 6 And (controltype(controllevel) < 10 Or controltype(controllevel) > 17) Then a$ = "CASE without SELECT CASE": GoTo errmes
|
|
If n = 1 Then a$ = "Expected CASE expression": GoTo errmes
|
|
SelectCaseHasCaseBlock(SelectCaseCounter) = -1
|
|
|
|
|
|
'upgrade:
|
|
'#1: variables can be referred to directly by storing an id in 'controlref'
|
|
' (but not if part of an array etc.)
|
|
'DIM controlvalue(1000) AS LONG
|
|
'#2: more types will be available
|
|
' +SINGLE
|
|
' +DOUBLE
|
|
' -LONG DOUBLE
|
|
' +INT32
|
|
' +UINT32
|
|
'14=SELECT CASE float ...
|
|
'15=SELECT CASE double
|
|
'16=SELECT CASE int32
|
|
'17=SELECT CASE uint32
|
|
|
|
'10=SELECT CASE qbs (awaiting END SELECT/CASE)
|
|
'11=SELECT CASE int64 (awaiting END SELECT/CASE)
|
|
'12=SELECT CASE uint64 (awaiting END SELECT/CASE)
|
|
'13=SELECT CASE LONG double (awaiting END SELECT/CASE/CASE ELSE)
|
|
'14=SELECT CASE float ...
|
|
'15=SELECT CASE double
|
|
'16=SELECT CASE int32
|
|
'17=SELECT CASE uint32
|
|
|
|
' 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$ + ")"
|
|
|
|
|
|
t = controltype(controllevel) - 10
|
|
'get required type cast, and float options
|
|
flt = 0
|
|
If t = 0 Then tc$ = ""
|
|
If t = 1 Then tc$ = ""
|
|
If t = 2 Then tc$ = ""
|
|
If t = 3 Then tc$ = "": flt = 1
|
|
If t = 4 Then tc$ = "(float)": flt = 1
|
|
If t = 5 Then tc$ = "(double)": flt = 1
|
|
If t = 6 Then tc$ = ""
|
|
If t = 7 Then tc$ = ""
|
|
|
|
n$ = "sc_" + str2$(controlid(controllevel))
|
|
cv = controlvalue(controllevel)
|
|
If cv Then
|
|
n$ = refer$(str2$(cv), 0, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
End If
|
|
|
|
'CASE ELSE
|
|
If n = 2 Then
|
|
If getelement$(a$, 2) = "C-EL" Then
|
|
If EveryCaseSet(SelectCaseCounter) Then Print #12, "if (sc_" + str2$(controlid(controllevel)) + "_var==0) {"
|
|
controllevel = controllevel + 1: controltype(controllevel) = 19
|
|
controlref(controllevel) = controlref(controllevel - 1)
|
|
l$ = l$ + sp + SCase$("Else")
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishednonexec '***no error causing code, event checking done by SELECT CASE***
|
|
End If
|
|
End If
|
|
|
|
If NoChecks = 0 Then Print #12, "S_" + str2$(statementn) + ":;": dynscope = 1
|
|
|
|
|
|
|
|
f12$ = ""
|
|
|
|
nexp = 0
|
|
B = 0
|
|
e$ = ""
|
|
For i = 2 To n
|
|
e2$ = getelement$(ca$, i)
|
|
If e2$ = "(" Then B = B + 1
|
|
If e2$ = ")" Then B = B - 1
|
|
If i = n Then e$ = e$ + sp + e2$
|
|
If i = n Or (e2$ = "," And B = 0) Then
|
|
If nexp <> 0 Then l$ = l$ + sp2 + ",": f12$ = f12$ + "||"
|
|
If e$ = "" Then a$ = "Expected expression": GoTo errmes
|
|
e$ = Right$(e$, Len(e$) - 1)
|
|
|
|
|
|
|
|
'TYPE 1? ... TO ...
|
|
n2 = numelements(e$)
|
|
b2 = 0
|
|
el$ = "": er$ = ""
|
|
usedto = 0
|
|
For i2 = 1 To n2
|
|
e3$ = getelement$(e$, i2)
|
|
If e3$ = "(" Then b2 = b2 + 1
|
|
If e3$ = ")" Then b2 = b2 - 1
|
|
If b2 = 0 And UCase$(e3$) = "TO" Then
|
|
usedto = 1
|
|
Else
|
|
If usedto = 0 Then el$ = el$ + sp + e3$ Else er$ = er$ + sp + e3$
|
|
End If
|
|
Next
|
|
If usedto = 1 Then
|
|
If el$ = "" Or er$ = "" Then a$ = "Expected expression TO expression": GoTo errmes
|
|
el$ = Right$(el$, Len(el$) - 1): er$ = Right$(er$, Len(er$) - 1)
|
|
'evaluate each side
|
|
For i2 = 1 To 2
|
|
If i2 = 1 Then e$ = el$ Else e$ = er$
|
|
e$ = fixoperationorder(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
If i2 = 1 Then l$ = l$ + sp + tlayout$ Else l$ = l$ + sp + SCase$("TO") + sp + tlayout$
|
|
e$ = evaluate(e$, typ)
|
|
If Error_Happened Then GoTo errmes
|
|
If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
If t = 0 Then
|
|
If (typ And ISSTRING) = 0 Then a$ = "Expected string expression": GoTo errmes
|
|
If i2 = 1 Then f12$ = f12$ + "(qbs_greaterorequal(" + n$ + "," + e$ + ")&&qbs_lessorequal(" + n$ + ","
|
|
If i2 = 2 Then f12$ = f12$ + e$ + "))"
|
|
Else
|
|
If (typ And ISSTRING) Then a$ = "Expected numeric expression": GoTo errmes
|
|
'round to integer?
|
|
If (typ And ISFLOAT) Then
|
|
If t = 1 Then e$ = "qbr(" + e$ + ")"
|
|
If t = 2 Then e$ = "qbr_longdouble_to_uint64(" + e$ + ")"
|
|
If t = 6 Or t = 7 Then e$ = "qbr_double_to_long(" + e$ + ")"
|
|
End If
|
|
'cast result?
|
|
If Len(tc$) Then e$ = tc$ + "(" + e$ + ")"
|
|
If i2 = 1 Then f12$ = f12$ + "((" + n$ + ">=(" + e$ + "))&&(" + n$ + "<=("
|
|
If i2 = 2 Then f12$ = f12$ + e$ + ")))"
|
|
End If
|
|
Next
|
|
GoTo addedexp
|
|
End If
|
|
|
|
'10=SELECT CASE qbs (awaiting END SELECT/CASE)
|
|
'11=SELECT CASE int64 (awaiting END SELECT/CASE)
|
|
'12=SELECT CASE uint64 (awaiting END SELECT/CASE)
|
|
'13=SELECT CASE LONG double (awaiting END SELECT/CASE/CASE ELSE)
|
|
'14=SELECT CASE float ...
|
|
'15=SELECT CASE double
|
|
'16=SELECT CASE int32
|
|
'17=SELECT CASE uint32
|
|
|
|
' 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$ + ")"
|
|
|
|
|
|
|
|
|
|
|
|
|
|
o$ = "==" 'used by type 3
|
|
|
|
'TYPE 2?
|
|
x$ = getelement$(e$, 1)
|
|
If isoperator(x$) Then 'non-standard usage correction
|
|
If x$ = "=" Or x$ = "<>" Or x$ = ">" Or x$ = "<" Or x$ = ">=" Or x$ = "<=" Then
|
|
e$ = "IS" + sp + e$
|
|
x$ = "IS"
|
|
End If
|
|
End If
|
|
If UCase$(x$) = "IS" Then
|
|
n2 = numelements(e$)
|
|
If n2 < 3 Then a$ = "Expected IS =,<>,>,<,>=,<= expression": GoTo errmes
|
|
o$ = getelement$(e$, 2)
|
|
o2$ = o$
|
|
o = 0
|
|
If o$ = "=" Then o$ = "==": o = 1
|
|
If o$ = "<>" Then o$ = "!=": o = 1
|
|
If o$ = ">" Then o = 1
|
|
If o$ = "<" Then o = 1
|
|
If o$ = ">=" Then o = 1
|
|
If o$ = "<=" Then o = 1
|
|
If o <> 1 Then a$ = "Expected IS =,<>,>,<,>=,<= expression": GoTo errmes
|
|
l$ = l$ + sp + SCase$("Is") + sp + o2$
|
|
e$ = getelements$(e$, 3, n2)
|
|
'fall through to type 3 using modified e$ & o$
|
|
End If
|
|
|
|
'TYPE 3? simple expression
|
|
e$ = fixoperationorder(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + tlayout$
|
|
e$ = evaluate(e$, typ)
|
|
If Error_Happened Then GoTo errmes
|
|
If (typ And ISREFERENCE) Then e$ = refer(e$, typ, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
If t = 0 Then
|
|
'string comparison
|
|
If (typ And ISSTRING) = 0 Then a$ = "Expected string expression": GoTo errmes
|
|
If o$ = "==" Then o$ = "qbs_equal"
|
|
If o$ = "!=" Then o$ = "qbs_notequal"
|
|
If o$ = ">" Then o$ = "qbs_greaterthan"
|
|
If o$ = "<" Then o$ = "qbs_lessthan"
|
|
If o$ = ">=" Then o$ = "qbs_greaterorequal"
|
|
If o$ = "<=" Then o$ = "qbs_lessorequal"
|
|
f12$ = f12$ + o$ + "(" + n$ + "," + e$ + ")"
|
|
Else
|
|
'numeric
|
|
If (typ And ISSTRING) Then a$ = "Expected numeric expression": GoTo errmes
|
|
'round to integer?
|
|
If (typ And ISFLOAT) Then
|
|
If t = 1 Then e$ = "qbr(" + e$ + ")"
|
|
If t = 2 Then e$ = "qbr_longdouble_to_uint64(" + e$ + ")"
|
|
If t = 6 Or t = 7 Then e$ = "qbr_double_to_long(" + e$ + ")"
|
|
End If
|
|
'cast result?
|
|
If Len(tc$) Then e$ = tc$ + "(" + e$ + ")"
|
|
f12$ = f12$ + "(" + n$ + o$ + "(" + e$ + "))"
|
|
End If
|
|
|
|
addedexp:
|
|
e$ = ""
|
|
nexp = nexp + 1
|
|
Else
|
|
e$ = e$ + sp + e2$
|
|
End If
|
|
Next
|
|
|
|
If stringprocessinghappened Then
|
|
Print #12, "if ((" + cleanupstringprocessingcall$ + f12$ + "))||new_error){"
|
|
Else
|
|
Print #12, "if ((" + f12$ + ")||new_error){"
|
|
End If
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
controllevel = controllevel + 1
|
|
controlref(controllevel) = controlref(controllevel - 1)
|
|
controltype(controllevel) = 18
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
'static scope commands:
|
|
|
|
If NoChecks = 0 Then
|
|
Print #12, "do{"
|
|
'PRINT #12, "S_" + str2$(statementn) + ":;"
|
|
End If
|
|
|
|
|
|
If n > 1 Then
|
|
If firstelement$ = "PALETTE" Then
|
|
If secondelement$ = "USING" Then
|
|
l$ = SCase$("Palette" + sp + "Using" + sp)
|
|
If n < 3 Then a$ = "Expected PALETTE USING array-name": GoTo errmes
|
|
'check array
|
|
e$ = getelement$(ca$, 3)
|
|
If FindArray(e$) Then
|
|
If Error_Happened Then GoTo errmes
|
|
z = 1
|
|
t = id.arraytype
|
|
If (t And 511) <> 16 And (t And 511) <> 32 Then z = 0
|
|
If t And ISFLOAT Then z = 0
|
|
If t And ISOFFSETINBITS Then z = 0
|
|
If t And ISSTRING Then z = 0
|
|
If t And ISUDT Then z = 0
|
|
If t And ISUNSIGNED Then z = 0
|
|
If z = 0 Then a$ = "Array must be of type INTEGER or LONG": GoTo errmes
|
|
bits = t And 511
|
|
GoTo pu_gotarray
|
|
End If
|
|
If Error_Happened Then GoTo errmes
|
|
a$ = "Expected PALETTE USING array-name": GoTo errmes
|
|
pu_gotarray:
|
|
'add () if index not specified
|
|
If n = 3 Then
|
|
e$ = e$ + sp + "(" + sp + ")"
|
|
Else
|
|
If n = 4 Or getelement$(a$, 4) <> "(" Or getelement$(a$, n) <> ")" Then a$ = "Expected PALETTE USING array-name(...)": GoTo errmes
|
|
e$ = e$ + sp + getelements$(ca$, 4, n)
|
|
End If
|
|
e$ = fixoperationorder$(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$
|
|
e$ = evaluatetotyp(e$, -2)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "sub_paletteusing(" + e$ + "," + str2(bits) + ");"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If 'using
|
|
End If 'palette
|
|
End If 'n>1
|
|
|
|
|
|
If firstelement$ = "KEY" Then
|
|
If n = 1 Then a$ = "Expected KEY ...": GoTo errmes
|
|
l$ = SCase$("KEY") + sp
|
|
If secondelement$ = "OFF" Then
|
|
If n > 2 Then a$ = "Expected KEY OFF only": GoTo errmes
|
|
l$ = l$ + SCase$("Off"): layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
Print #12, "key_off();"
|
|
GoTo finishedline
|
|
End If
|
|
If secondelement$ = "ON" Then
|
|
If n > 2 Then a$ = "Expected KEY ON only": GoTo errmes
|
|
l$ = l$ + SCase$("On"): layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
Print #12, "key_on();"
|
|
GoTo finishedline
|
|
End If
|
|
If secondelement$ = "LIST" Then
|
|
If n > 2 Then a$ = "Expected KEY LIST only": GoTo errmes
|
|
l$ = l$ + SCase$("List"): layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
Print #12, "key_list();"
|
|
GoTo finishedline
|
|
End If
|
|
'search for comma to indicate assignment
|
|
B = 0: e$ = ""
|
|
For i = 2 To n
|
|
e2$ = getelement(ca$, i)
|
|
If e2$ = "(" Then B = B + 1
|
|
If e2$ = ")" Then B = B - 1
|
|
If e2$ = "," And B = 0 Then
|
|
i = i + 1: GoTo key_assignment
|
|
End If
|
|
If Len(e$) Then e$ = e$ + sp + e2$ Else e$ = e2$
|
|
Next
|
|
'assume KEY(x) ON/OFF/STOP and handle as a sub
|
|
GoTo key_fallthrough
|
|
key_assignment:
|
|
'KEY x, "string"
|
|
'index
|
|
e$ = fixoperationorder(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$ + sp2 + "," + sp
|
|
e$ = evaluatetotyp(e$, 32&)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "key_assign(" + e$ + ",";
|
|
'string
|
|
e$ = getelements$(ca$, i, n)
|
|
e$ = fixoperationorder(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$
|
|
e$ = evaluatetotyp(e$, ISSTRING)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, e$ + ");"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If 'KEY
|
|
key_fallthrough:
|
|
|
|
|
|
|
|
|
|
If firstelement$ = "FIELD" Then
|
|
|
|
'get filenumber
|
|
B = 0: e$ = ""
|
|
For i = 2 To n
|
|
e2$ = getelement(ca$, i)
|
|
If e2$ = "(" Then B = B + 1
|
|
If e2$ = ")" Then B = B - 1
|
|
If e2$ = "," And B = 0 Then
|
|
i = i + 1: GoTo fieldgotfn
|
|
End If
|
|
If Len(e$) Then e$ = e$ + sp + e2$ Else e$ = e2$
|
|
Next
|
|
GoTo fielderror
|
|
fieldgotfn:
|
|
If e$ = "#" Or Len(e$) = 0 Then GoTo fielderror
|
|
If Left$(e$, 2) = "#" + sp Then e$ = Right$(e$, Len(e$) - 2): l$ = SCase$("Field") + sp + "#" + sp2 Else l$ = SCase$("Field") + sp
|
|
e$ = fixoperationorder(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$ + sp2 + "," + sp
|
|
e$ = evaluatetotyp(e$, 32&)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "field_new(" + e$ + ");"
|
|
|
|
fieldnext:
|
|
|
|
'get fieldwidth
|
|
If i > n Then GoTo fielderror
|
|
B = 0: e$ = ""
|
|
For i = i To n
|
|
e2$ = getelement(ca$, i)
|
|
If e2$ = "(" Then B = B + 1
|
|
If e2$ = ")" Then B = B - 1
|
|
If UCase$(e2$) = "AS" And B = 0 Then
|
|
i = i + 1: GoTo fieldgotfw
|
|
End If
|
|
If Len(e$) Then e$ = e$ + sp + e2$ Else e$ = e2$
|
|
Next
|
|
GoTo fielderror
|
|
fieldgotfw:
|
|
If Len(e$) = 0 Then GoTo fielderror
|
|
e$ = fixoperationorder(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$ + sp + SCase$("As") + sp
|
|
sizee$ = evaluatetotyp(e$, 32&)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
'get variable name
|
|
If i > n Then GoTo fielderror
|
|
B = 0: e$ = ""
|
|
For i = i To n
|
|
e2$ = getelement(ca$, i)
|
|
If e2$ = "(" Then B = B + 1
|
|
If e2$ = ")" Then B = B - 1
|
|
If (i = n Or e2$ = ",") And B = 0 Then
|
|
If e2$ = "," Then i = i - 1
|
|
If i = n Then
|
|
If Len(e$) Then e$ = e$ + sp + e2$ Else e$ = e2$
|
|
End If
|
|
GoTo fieldgotfname
|
|
End If
|
|
If Len(e$) Then e$ = e$ + sp + e2$ Else e$ = e2$
|
|
Next
|
|
GoTo fielderror
|
|
fieldgotfname:
|
|
If Len(e$) = 0 Then GoTo fielderror
|
|
'evaluate it to check it is a STRING
|
|
e$ = fixoperationorder(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$
|
|
e$ = evaluate(e$, typ)
|
|
If Error_Happened Then GoTo errmes
|
|
If (typ And ISSTRING) = 0 Then GoTo fielderror
|
|
If typ And ISFIXEDLENGTH Then a$ = "Fixed length strings cannot be used in a FIELD statement": GoTo errmes
|
|
If (typ And ISREFERENCE) = 0 Then GoTo fielderror
|
|
e$ = refer(e$, typ, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "field_add(" + e$ + "," + sizee$ + ");"
|
|
|
|
If i < n Then
|
|
i = i + 1
|
|
e$ = getelement(a$, i)
|
|
If e$ <> "," Then a$ = "Expected ,": GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp
|
|
i = i + 1
|
|
GoTo fieldnext
|
|
End If
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
|
|
fielderror: a$ = "Expected FIELD #filenumber, characters AS variable$, ...": GoTo errmes
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
'1=IF (awaiting END IF)
|
|
'2=FOR (awaiting NEXT)
|
|
'3=DO (awaiting LOOP [UNTIL|WHILE param])
|
|
'4=DO WHILE/UNTIL (awaiting LOOP)
|
|
'5=WHILE (awaiting WEND)
|
|
|
|
If n = 2 Then
|
|
If firstelement$ = "EXIT" Then
|
|
|
|
l$ = SCase$("Exit") + sp
|
|
|
|
If secondelement$ = "DO" Then
|
|
'scan backwards until previous control level reached
|
|
l$ = l$ + SCase$("Do")
|
|
For i = controllevel To 1 Step -1
|
|
t = controltype(i)
|
|
If t = 3 Or t = 4 Then
|
|
Print #12, "goto dl_exit_" + str2$(controlid(i)) + ";"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
Next
|
|
a$ = "EXIT DO without DO": GoTo errmes
|
|
End If
|
|
|
|
If secondelement$ = "FOR" Then
|
|
'scan backwards until previous control level reached
|
|
l$ = l$ + SCase$("For")
|
|
For i = controllevel To 1 Step -1
|
|
t = controltype(i)
|
|
If t = 2 Then
|
|
Print #12, "goto fornext_exit_" + str2$(controlid(i)) + ";"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
Next
|
|
a$ = "EXIT FOR without FOR": GoTo errmes
|
|
End If
|
|
|
|
If secondelement$ = "WHILE" Then
|
|
'scan backwards until previous control level reached
|
|
l$ = l$ + SCase$("While")
|
|
For i = controllevel To 1 Step -1
|
|
t = controltype(i)
|
|
If t = 5 Then
|
|
Print #12, "goto ww_exit_" + str2$(controlid(i)) + ";"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
Next
|
|
a$ = "EXIT WHILE without WHILE": GoTo errmes
|
|
End If
|
|
|
|
If secondelement$ = "SELECT" Then
|
|
'scan backwards until previous control level reached
|
|
l$ = l$ + SCase$("Select")
|
|
For i = controllevel To 1 Step -1
|
|
t = controltype(i)
|
|
If t = 18 Or t = 19 Then 'CASE/CASE ELSE
|
|
Print #12, "goto sc_" + str2$(controlid(i - 1)) + "_end;"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
Next
|
|
a$ = "EXIT SELECT without SELECT": GoTo errmes
|
|
End If
|
|
|
|
If secondelement$ = "CASE" Then
|
|
'scan backwards until previous control level reached
|
|
l$ = l$ + SCase$("Case")
|
|
For i = controllevel To 1 Step -1
|
|
t = controltype(i)
|
|
If t = 18 Then 'CASE
|
|
Print #12, "goto sc_ec_" + str2$(everycasenewcase + 1) + "_end;"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
ElseIf t = 19 Then 'CASE ELSE
|
|
Print #12, "goto sc_" + str2$(controlid(i - 1)) + "_end;"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
Next
|
|
a$ = "EXIT CASE without CASE": GoTo errmes
|
|
End If
|
|
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
If n >= 2 Then
|
|
If firstelement$ = "ON" And secondelement$ = "STRIG" Then
|
|
DEPENDENCY(DEPENDENCY_DEVICEINPUT) = 1
|
|
i = 3
|
|
If i > n Then a$ = "Expected (": GoTo errmes
|
|
a2$ = getelement$(ca$, i): i = i + 1
|
|
If a2$ <> "(" Then a$ = "Expected (": GoTo errmes
|
|
l$ = SCase$("On" + sp + "Strig" + sp2 + "(")
|
|
If i > n Then a$ = "Expected ...": GoTo errmes
|
|
B = 0
|
|
x = 0
|
|
e2$ = ""
|
|
e3$ = ""
|
|
For i = i To n
|
|
e$ = getelement$(ca$, i)
|
|
a = Asc(e$)
|
|
If a = 40 Then B = B + 1
|
|
If a = 41 Then B = B - 1
|
|
If B = -1 Then GoTo onstriggotarg
|
|
If a = 44 And B = 0 Then
|
|
x = x + 1
|
|
If x > 1 Then a$ = "Expected )": GoTo errmes
|
|
If e2$ = "" Then a$ = "Expected ... ,": GoTo errmes
|
|
e3$ = e2$
|
|
e2$ = ""
|
|
Else
|
|
If Len(e2$) Then e2$ = e2$ + sp + e$ Else e2$ = e$
|
|
End If
|
|
Next
|
|
a$ = "Expected )": GoTo errmes
|
|
onstriggotarg:
|
|
If e2$ = "" Then a$ = "Expected ... )": GoTo errmes
|
|
Print #12, "onstrig_setup(";
|
|
|
|
'sort scanned results
|
|
If Len(e3$) Then
|
|
optI$ = e3$
|
|
optController$ = e2$
|
|
optPassed$ = "1"
|
|
Else
|
|
optI$ = e2$
|
|
optController$ = "0"
|
|
optPassed$ = "0"
|
|
End If
|
|
|
|
'i
|
|
e$ = fixoperationorder$(optI$): If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + tlayout$
|
|
e$ = evaluatetotyp(e$, 32&): If Error_Happened Then GoTo errmes
|
|
Print #12, e$ + ",";
|
|
|
|
'controller , passed
|
|
If optPassed$ = "1" Then
|
|
e$ = fixoperationorder$(optController$): If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$
|
|
e$ = evaluatetotyp(e$, 32&): If Error_Happened Then GoTo errmes
|
|
Else
|
|
e$ = optController$
|
|
End If
|
|
Print #12, e$ + "," + optPassed$ + ",";
|
|
|
|
l$ = l$ + sp2 + ")" + sp 'close brackets
|
|
|
|
i = i + 1
|
|
If i > n Then a$ = "Expected GOSUB/sub-name": GoTo errmes
|
|
a2$ = getelement$(a$, i): i = i + 1
|
|
onstrigid = onstrigid + 1
|
|
Print #12, str2$(onstrigid) + ",";
|
|
|
|
If a2$ = "GOSUB" Then
|
|
If i > n Then a$ = "Expected linenumber/label": GoTo errmes
|
|
a2$ = getelement$(ca$, i): i = i + 1
|
|
|
|
Print #12, "0);"
|
|
|
|
If validlabel(a2$) = 0 Then a$ = "Invalid label": GoTo errmes
|
|
|
|
v = HashFind(a2$, HASHFLAG_LABEL, ignore, r)
|
|
x = 1
|
|
labchk60z:
|
|
If v Then
|
|
s = Labels(r).Scope
|
|
If s = 0 Or s = -1 Then 'main scope?
|
|
If s = -1 Then Labels(r).Scope = 0 'acquire scope
|
|
x = 0 'already defined
|
|
tlayout$ = RTrim$(Labels(r).cn)
|
|
Labels(r).Scope_Restriction = subfuncn
|
|
Labels(r).Error_Line = linenumber
|
|
Else
|
|
If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk60z
|
|
End If
|
|
End If
|
|
If x Then
|
|
'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 = 0
|
|
Labels(r).Error_Line = linenumber
|
|
Labels(r).Scope_Restriction = subfuncn
|
|
End If 'x
|
|
l$ = l$ + SCase$("GoSub") + sp + tlayout$
|
|
|
|
Print #30, "if(strig_event_id==" + str2$(onstrigid) + ")goto LABEL_" + a2$ + ";"
|
|
|
|
Print #29, "case " + str2$(onstrigid) + ":"
|
|
Print #29, "strig_event_occurred++;"
|
|
Print #29, "strig_event_id=" + str2$(onstrigid) + ";"
|
|
Print #29, "strig_event_occurred++;"
|
|
Print #29, "return_point[next_return_point++]=0;"
|
|
Print #29, "if (next_return_point>=return_points) more_return_points();"
|
|
Print #29, "QBMAIN(NULL);"
|
|
Print #29, "break;"
|
|
|
|
If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$
|
|
layoutdone = 1
|
|
GoTo finishedline
|
|
|
|
Else
|
|
|
|
'establish whether sub a2$ exists using try
|
|
x = 0
|
|
try = findid(a2$)
|
|
If Error_Happened Then GoTo errmes
|
|
Do While try
|
|
If id.subfunc = 2 Then x = 1: Exit Do
|
|
If try = 2 Then findanotherid = 1: try = findid(a2$) Else try = 0
|
|
If Error_Happened Then GoTo errmes
|
|
Loop
|
|
If x = 0 Then a$ = "Expected GOSUB/sub": GoTo errmes
|
|
|
|
l$ = l$ + RTrim$(id.cn)
|
|
|
|
Print #29, "case " + str2$(onstrigid) + ":"
|
|
Print #29, RTrim$(id.callname) + "(";
|
|
|
|
If id.args > 1 Then a$ = "SUB requires more than one argument": GoTo errmes
|
|
|
|
If i > n Then
|
|
|
|
If id.args = 1 Then a$ = "Expected argument after SUB": GoTo errmes
|
|
Print #12, "0);"
|
|
Print #29, ");"
|
|
|
|
Else
|
|
|
|
If id.args = 0 Then a$ = "SUB has no arguments": GoTo errmes
|
|
|
|
t = CVL(id.arg)
|
|
B = t And 511
|
|
If B = 0 Or (t And ISARRAY) <> 0 Or (t And ISFLOAT) <> 0 Or (t And ISSTRING) <> 0 Or (t And ISOFFSETINBITS) <> 0 Then a$ = "Only SUB arguments of integer-type allowed": GoTo errmes
|
|
If B = 8 Then ct$ = "int8"
|
|
If B = 16 Then ct$ = "int16"
|
|
If B = 32 Then ct$ = "int32"
|
|
If B = 64 Then ct$ = "int64"
|
|
If t And ISOFFSET Then ct$ = "ptrszint"
|
|
If t And ISUNSIGNED Then ct$ = "u" + ct$
|
|
Print #29, "(" + ct$ + "*)&i64);"
|
|
|
|
e$ = getelements$(ca$, i, n)
|
|
e$ = fixoperationorder$(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + tlayout$
|
|
e$ = evaluatetotyp(e$, INTEGER64TYPE - ISPOINTER)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, e$ + ");"
|
|
|
|
End If
|
|
|
|
Print #29, "break;"
|
|
If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$
|
|
layoutdone = 1
|
|
GoTo finishedline
|
|
End If
|
|
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
If n >= 2 Then
|
|
If firstelement$ = "ON" And secondelement$ = "TIMER" Then
|
|
i = 3
|
|
If i > n Then a$ = "Expected (": GoTo errmes
|
|
a2$ = getelement$(ca$, i): i = i + 1
|
|
If a2$ <> "(" Then a$ = "Expected (": GoTo errmes
|
|
l$ = SCase$("On" + sp + "Timer" + sp2 + "(")
|
|
If i > n Then a$ = "Expected ...": GoTo errmes
|
|
B = 0
|
|
x = 0
|
|
e2$ = ""
|
|
e3$ = ""
|
|
For i = i To n
|
|
e$ = getelement$(ca$, i)
|
|
a = Asc(e$)
|
|
If a = 40 Then B = B + 1
|
|
If a = 41 Then B = B - 1
|
|
If B = -1 Then GoTo ontimgotarg
|
|
If a = 44 And B = 0 Then
|
|
x = x + 1
|
|
If x > 1 Then a$ = "Expected )": GoTo errmes
|
|
If e2$ = "" Then a$ = "Expected ... ,": GoTo errmes
|
|
e3$ = e2$
|
|
e2$ = ""
|
|
Else
|
|
If Len(e2$) Then e2$ = e2$ + sp + e$ Else e2$ = e$
|
|
End If
|
|
Next
|
|
a$ = "Expected )": GoTo errmes
|
|
ontimgotarg:
|
|
If e2$ = "" Then a$ = "Expected ... )": GoTo errmes
|
|
Print #12, "ontimer_setup(";
|
|
'i
|
|
If Len(e3$) Then
|
|
e$ = fixoperationorder$(e3$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + tlayout$ + "," + sp
|
|
e$ = evaluatetotyp(e$, 32&)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, e$ + ",";
|
|
Else
|
|
Print #12, "0,";
|
|
l$ = l$ + sp2
|
|
End If
|
|
'sec
|
|
e$ = fixoperationorder$(e2$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$ + sp2 + ")" + sp
|
|
e$ = evaluatetotyp(e$, DOUBLETYPE - ISPOINTER)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, e$ + ",";
|
|
i = i + 1
|
|
If i > n Then a$ = "Expected GOSUB/sub-name": GoTo errmes
|
|
a2$ = getelement$(a$, i): i = i + 1
|
|
ontimerid = ontimerid + 1
|
|
Print #12, str2$(ontimerid) + ",";
|
|
|
|
If a2$ = "GOSUB" Then
|
|
If i > n Then a$ = "Expected linenumber/label": GoTo errmes
|
|
a2$ = getelement$(ca$, i): i = i + 1
|
|
|
|
Print #12, "0);"
|
|
|
|
If validlabel(a2$) = 0 Then a$ = "Invalid label": GoTo errmes
|
|
|
|
v = HashFind(a2$, HASHFLAG_LABEL, ignore, r)
|
|
x = 1
|
|
labchk60:
|
|
If v Then
|
|
s = Labels(r).Scope
|
|
If s = 0 Or s = -1 Then 'main scope?
|
|
If s = -1 Then Labels(r).Scope = 0 'acquire scope
|
|
x = 0 'already defined
|
|
tlayout$ = RTrim$(Labels(r).cn)
|
|
Labels(r).Scope_Restriction = subfuncn
|
|
Labels(r).Error_Line = linenumber
|
|
Else
|
|
If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk60
|
|
End If
|
|
End If
|
|
If x Then
|
|
'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 = 0
|
|
Labels(r).Error_Line = linenumber
|
|
Labels(r).Scope_Restriction = subfuncn
|
|
End If 'x
|
|
l$ = l$ + SCase$("GoSub") + sp + tlayout$
|
|
|
|
Print #25, "if(timer_event_id==" + str2$(ontimerid) + ")goto LABEL_" + a2$ + ";"
|
|
|
|
Print #24, "case " + str2$(ontimerid) + ":"
|
|
Print #24, "timer_event_occurred++;"
|
|
Print #24, "timer_event_id=" + str2$(ontimerid) + ";"
|
|
Print #24, "timer_event_occurred++;"
|
|
Print #24, "return_point[next_return_point++]=0;"
|
|
Print #24, "if (next_return_point>=return_points) more_return_points();"
|
|
Print #24, "QBMAIN(NULL);"
|
|
Print #24, "break;"
|
|
|
|
|
|
|
|
'call validlabel (to validate the label) [see goto]
|
|
'increment ontimerid
|
|
'use ontimerid to generate the jumper routine
|
|
'etc.
|
|
|
|
|
|
If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$
|
|
layoutdone = 1
|
|
GoTo finishedline
|
|
Else
|
|
|
|
'establish whether sub a2$ exists using try
|
|
x = 0
|
|
try = findid(a2$)
|
|
If Error_Happened Then GoTo errmes
|
|
Do While try
|
|
If id.subfunc = 2 Then x = 1: Exit Do
|
|
If try = 2 Then findanotherid = 1: try = findid(a2$) Else try = 0
|
|
If Error_Happened Then GoTo errmes
|
|
Loop
|
|
If x = 0 Then a$ = "Expected GOSUB/sub": GoTo errmes
|
|
|
|
l$ = l$ + RTrim$(id.cn)
|
|
|
|
Print #24, "case " + str2$(ontimerid) + ":"
|
|
Print #24, RTrim$(id.callname) + "(";
|
|
|
|
If id.args > 1 Then a$ = "SUB requires more than one argument": GoTo errmes
|
|
|
|
If i > n Then
|
|
|
|
If id.args = 1 Then a$ = "Expected argument after SUB": GoTo errmes
|
|
Print #12, "0);"
|
|
Print #24, ");"
|
|
|
|
Else
|
|
|
|
If id.args = 0 Then a$ = "SUB has no arguments": GoTo errmes
|
|
|
|
t = CVL(id.arg)
|
|
B = t And 511
|
|
If B = 0 Or (t And ISARRAY) <> 0 Or (t And ISFLOAT) <> 0 Or (t And ISSTRING) <> 0 Or (t And ISOFFSETINBITS) <> 0 Then a$ = "Only SUB arguments of integer-type allowed": GoTo errmes
|
|
If B = 8 Then ct$ = "int8"
|
|
If B = 16 Then ct$ = "int16"
|
|
If B = 32 Then ct$ = "int32"
|
|
If B = 64 Then ct$ = "int64"
|
|
If t And ISOFFSET Then ct$ = "ptrszint"
|
|
If t And ISUNSIGNED Then ct$ = "u" + ct$
|
|
Print #24, "(" + ct$ + "*)&i64);"
|
|
|
|
e$ = getelements$(ca$, i, n)
|
|
e$ = fixoperationorder$(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + tlayout$
|
|
e$ = evaluatetotyp(e$, INTEGER64TYPE - ISPOINTER)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, e$ + ");"
|
|
|
|
End If
|
|
|
|
Print #24, "break;"
|
|
If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$
|
|
layoutdone = 1
|
|
GoTo finishedline
|
|
End If
|
|
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
If n >= 2 Then
|
|
If firstelement$ = "ON" And secondelement$ = "KEY" Then
|
|
i = 3
|
|
If i > n Then a$ = "Expected (": GoTo errmes
|
|
a2$ = getelement$(ca$, i): i = i + 1
|
|
If a2$ <> "(" Then a$ = "Expected (": GoTo errmes
|
|
l$ = SCase$("On" + sp + "Key" + sp2 + "(")
|
|
If i > n Then a$ = "Expected ...": GoTo errmes
|
|
B = 0
|
|
x = 0
|
|
e2$ = ""
|
|
For i = i To n
|
|
e$ = getelement$(ca$, i)
|
|
a = Asc(e$)
|
|
|
|
|
|
If a = 40 Then B = B + 1
|
|
If a = 41 Then B = B - 1
|
|
If B = -1 Then Exit For
|
|
If Len(e2$) Then e2$ = e2$ + sp + e$ Else e2$ = e$
|
|
Next
|
|
If i = n + 1 Then a$ = "Expected )": GoTo errmes
|
|
If e2$ = "" Then a$ = "Expected ... )": GoTo errmes
|
|
|
|
e$ = fixoperationorder$(e2$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$ + sp2 + ")" + sp
|
|
e$ = evaluatetotyp(e$, DOUBLETYPE - ISPOINTER)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "onkey_setup(" + e$ + ",";
|
|
|
|
i = i + 1
|
|
If i > n Then a$ = "Expected GOSUB/sub-name": GoTo errmes
|
|
a2$ = getelement$(a$, i): i = i + 1
|
|
onkeyid = onkeyid + 1
|
|
Print #12, str2$(onkeyid) + ",";
|
|
|
|
If a2$ = "GOSUB" Then
|
|
If i > n Then a$ = "Expected linenumber/label": GoTo errmes
|
|
a2$ = getelement$(ca$, i): i = i + 1
|
|
|
|
Print #12, "0);"
|
|
|
|
If validlabel(a2$) = 0 Then a$ = "Invalid label": GoTo errmes
|
|
|
|
v = HashFind(a2$, HASHFLAG_LABEL, ignore, r)
|
|
x = 1
|
|
labchk61:
|
|
If v Then
|
|
s = Labels(r).Scope
|
|
If s = 0 Or s = -1 Then 'main scope?
|
|
If s = -1 Then Labels(r).Scope = 0 'acquire scope
|
|
x = 0 'already defined
|
|
tlayout$ = RTrim$(Labels(r).cn)
|
|
Labels(r).Scope_Restriction = subfuncn
|
|
Labels(r).Error_Line = linenumber
|
|
Else
|
|
If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk61
|
|
End If
|
|
End If
|
|
If x Then
|
|
'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 = 0
|
|
Labels(r).Error_Line = linenumber
|
|
Labels(r).Scope_Restriction = subfuncn
|
|
End If 'x
|
|
l$ = l$ + SCase$("GoSub") + sp + tlayout$
|
|
|
|
Print #28, "if(key_event_id==" + str2$(onkeyid) + ")goto LABEL_" + a2$ + ";"
|
|
|
|
Print #27, "case " + str2$(onkeyid) + ":"
|
|
Print #27, "key_event_occurred++;"
|
|
Print #27, "key_event_id=" + str2$(onkeyid) + ";"
|
|
Print #27, "key_event_occurred++;"
|
|
Print #27, "return_point[next_return_point++]=0;"
|
|
Print #27, "if (next_return_point>=return_points) more_return_points();"
|
|
Print #27, "QBMAIN(NULL);"
|
|
Print #27, "break;"
|
|
|
|
If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$
|
|
layoutdone = 1
|
|
GoTo finishedline
|
|
Else
|
|
|
|
'establish whether sub a2$ exists using try
|
|
x = 0
|
|
try = findid(a2$)
|
|
If Error_Happened Then GoTo errmes
|
|
Do While try
|
|
If id.subfunc = 2 Then x = 1: Exit Do
|
|
If try = 2 Then findanotherid = 1: try = findid(a2$) Else try = 0
|
|
If Error_Happened Then GoTo errmes
|
|
Loop
|
|
If x = 0 Then a$ = "Expected GOSUB/sub": GoTo errmes
|
|
|
|
l$ = l$ + RTrim$(id.cn)
|
|
|
|
Print #27, "case " + str2$(onkeyid) + ":"
|
|
Print #27, RTrim$(id.callname) + "(";
|
|
|
|
If id.args > 1 Then a$ = "SUB requires more than one argument": GoTo errmes
|
|
|
|
If i > n Then
|
|
|
|
If id.args = 1 Then a$ = "Expected argument after SUB": GoTo errmes
|
|
Print #12, "0);"
|
|
Print #27, ");"
|
|
|
|
Else
|
|
|
|
If id.args = 0 Then a$ = "SUB has no arguments": GoTo errmes
|
|
|
|
t = CVL(id.arg)
|
|
B = t And 511
|
|
If B = 0 Or (t And ISARRAY) <> 0 Or (t And ISFLOAT) <> 0 Or (t And ISSTRING) <> 0 Or (t And ISOFFSETINBITS) <> 0 Then a$ = "Only SUB arguments of integer-type allowed": GoTo errmes
|
|
If B = 8 Then ct$ = "int8"
|
|
If B = 16 Then ct$ = "int16"
|
|
If B = 32 Then ct$ = "int32"
|
|
If B = 64 Then ct$ = "int64"
|
|
If t And ISOFFSET Then ct$ = "ptrszint"
|
|
If t And ISUNSIGNED Then ct$ = "u" + ct$
|
|
Print #27, "(" + ct$ + "*)&i64);"
|
|
|
|
e$ = getelements$(ca$, i, n)
|
|
e$ = fixoperationorder$(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + tlayout$
|
|
e$ = evaluatetotyp(e$, INTEGER64TYPE - ISPOINTER)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, e$ + ");"
|
|
|
|
End If
|
|
|
|
Print #27, "break;"
|
|
If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$
|
|
layoutdone = 1
|
|
GoTo finishedline
|
|
End If
|
|
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
'SHARED (SUB)
|
|
If n >= 1 Then
|
|
If firstelement$ = "SHARED" Then
|
|
If n = 1 Then a$ = "Expected SHARED ...": GoTo errmes
|
|
i = 2
|
|
If subfuncn = 0 Then a$ = "SHARED must be used within a SUB/FUNCTION": GoTo errmes
|
|
|
|
|
|
|
|
l$ = SCase$("Shared")
|
|
subfuncshr:
|
|
|
|
'get variable name
|
|
n$ = getelement$(ca$, i): i = i + 1
|
|
|
|
If n$ = "" Then a$ = "Expected SHARED variable-name or SHARED AS type variable-list": GoTo errmes
|
|
|
|
If UCase$(n$) <> "AS" Then
|
|
'traditional dim syntax for SHARED
|
|
s$ = removesymbol(n$)
|
|
If Error_Happened Then GoTo errmes
|
|
l2$ = s$ 'either symbol or nothing
|
|
|
|
'array?
|
|
a = 0
|
|
If getelement$(a$, i) = "(" Then
|
|
If getelement$(a$, i + 1) <> ")" Then a$ = "Expected ()": GoTo errmes
|
|
i = i + 2
|
|
a = 1
|
|
l2$ = l2$ + sp2 + "(" + sp2 + ")"
|
|
End If
|
|
|
|
method = 1
|
|
|
|
'specific type?
|
|
t$ = ""
|
|
ts$ = ""
|
|
t3$ = ""
|
|
If getelement$(a$, i) = "AS" Then
|
|
l2$ = l2$ + sp + SCase$("As")
|
|
getshrtyp:
|
|
i = i + 1
|
|
t2$ = getelement$(a$, i)
|
|
If t2$ <> "," And t2$ <> "" Then
|
|
If t$ = "" Then t$ = t2$ Else t$ = t$ + " " + t2$
|
|
If t3$ = "" Then t3$ = t2$ Else t3$ = t3$ + sp + t2$
|
|
GoTo getshrtyp
|
|
End If
|
|
If t$ = "" Then a$ = "Expected AS type": GoTo errmes
|
|
|
|
t = typname2typ(t$)
|
|
If Error_Happened Then GoTo errmes
|
|
If t And ISINCONVENTIONALMEMORY Then t = t - ISINCONVENTIONALMEMORY
|
|
If t And ISPOINTER Then t = t - ISPOINTER
|
|
If t And ISREFERENCE Then t = t - ISREFERENCE
|
|
tsize = typname2typsize
|
|
method = 0
|
|
If (t And ISUDT) = 0 Then
|
|
ts$ = type2symbol$(t$)
|
|
l2$ = l2$ + sp + SCase2$(t3$)
|
|
Else
|
|
t3$ = RTrim$(udtxcname(t And 511))
|
|
If RTrim$(udtxcname(t And 511)) = "_MEM" And UCase$(t$) = "MEM" And qb64prefix_set = 1 Then
|
|
t3$ = Mid$(RTrim$(udtxcname(t And 511)), 2)
|
|
End If
|
|
l2$ = l2$ + sp + t3$
|
|
End If
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
End If 'as
|
|
|
|
If Len(s$) <> 0 And Len(t$) <> 0 Then a$ = "Expected symbol or AS type after variable name": GoTo errmes
|
|
|
|
'no symbol of type specified, apply default
|
|
If s$ = "" And t$ = "" Then
|
|
If Left$(n$, 1) = "_" Then v = 27 Else v = Asc(UCase$(n$)) - 64
|
|
s$ = defineextaz(v)
|
|
End If
|
|
|
|
NormalSharedBlock:
|
|
'switch to main module
|
|
oldsubfunc$ = subfunc$
|
|
subfunc$ = ""
|
|
defdatahandle = 18
|
|
Close #13: Open tmpdir$ + "maindata.txt" For Append As #13
|
|
Close #19: Open tmpdir$ + "mainfree.txt" For Append As #19
|
|
|
|
'use 'try' to locate the variable (if it already exists)
|
|
n2$ = n$ + s$ + ts$ 'note: either ts$ or s$ will exist unless it is a UDT
|
|
try = findid(n2$)
|
|
If Error_Happened Then GoTo errmes
|
|
Do While try
|
|
If a Then
|
|
'an array
|
|
|
|
If id.arraytype Then
|
|
If Len(t$) = 0 Then GoTo shrfound
|
|
t2 = id.arraytype: t2size = id.tsize
|
|
If t2 And ISINCONVENTIONALMEMORY Then t2 = t2 - ISINCONVENTIONALMEMORY
|
|
If t2 And ISPOINTER Then t2 = t2 - ISPOINTER
|
|
If t2 And ISREFERENCE Then t2 = t2 - ISREFERENCE
|
|
If t = t2 And tsize = t2size Then GoTo shrfound
|
|
End If
|
|
|
|
Else
|
|
'not an array
|
|
|
|
If id.t Then
|
|
If Len(t$) = 0 Then GoTo shrfound
|
|
t2 = id.t: t2size = id.tsize
|
|
If t2 And ISINCONVENTIONALMEMORY Then t2 = t2 - ISINCONVENTIONALMEMORY
|
|
If t2 And ISPOINTER Then t2 = t2 - ISPOINTER
|
|
If t2 And ISREFERENCE Then t2 = t2 - ISREFERENCE
|
|
|
|
If Debug Then Print #9, "SHARED:comparing:"; t; t2, tsize; t2size
|
|
|
|
If t = t2 And tsize = t2size Then GoTo shrfound
|
|
End If
|
|
|
|
End If
|
|
|
|
If try = 2 Then findanotherid = 1: try = findid(n2$) Else try = 0
|
|
If Error_Happened Then GoTo errmes
|
|
Loop
|
|
'unknown variable
|
|
If a Then a$ = "Array '" + n$ + "' not defined": GoTo errmes
|
|
'create variable
|
|
If Len(s$) Then typ$ = s$ Else typ$ = t$
|
|
If optionexplicit Then a$ = "Variable '" + n$ + "' (" + symbol2fulltypename$(typ$) + ") not defined": GoTo errmes
|
|
bypassNextVariable = -1
|
|
retval = dim2(n$, typ$, method, "")
|
|
If Error_Happened Then GoTo errmes
|
|
'note: variable created!
|
|
|
|
shrfound:
|
|
If newSharedSyntax = 0 Then
|
|
l$ = l$ + sp + RTrim$(id.cn) + l2$
|
|
Else
|
|
If sharedAsLayoutAdded = 0 Then
|
|
sharedAsLayoutAdded = -1
|
|
l$ = l$ + l2$ + sp$ + RTrim$(id.cn) + l3$
|
|
Else
|
|
l$ = l$ + sp$ + RTrim$(id.cn) + l3$
|
|
End If
|
|
End If
|
|
|
|
ids(currentid).share = ids(currentid).share Or 2 'set as temporarily shared
|
|
|
|
'method must apply to the current sub/function regardless of how the variable was defined in 'main'
|
|
lmay = Len(RTrim$(id.mayhave)): lmust = Len(RTrim$(id.musthave))
|
|
If lmay <> 0 Or lmust <> 0 Then
|
|
If (method = 1 And lmust = 0) Or (method = 0 And lmay = 0) Then
|
|
revertmaymusthaven = revertmaymusthaven + 1
|
|
revertmaymusthave(revertmaymusthaven) = currentid
|
|
Swap ids(currentid).musthave, ids(currentid).mayhave
|
|
End If
|
|
End If
|
|
|
|
'switch back to sub/func
|
|
subfunc$ = oldsubfunc$
|
|
defdatahandle = 13
|
|
Close #13: Open tmpdir$ + "data" + str2$(subfuncn) + ".txt" For Append As #13
|
|
Close #19: Open tmpdir$ + "free" + str2$(subfuncn) + ".txt" For Append As #19
|
|
|
|
If newSharedSyntax Then Return
|
|
|
|
If getelement$(a$, i) = "," Then i = i + 1: l$ = l$ + sp2 + ",": GoTo subfuncshr
|
|
If getelement$(a$, i) <> "" Then a$ = "Expected ,": GoTo errmes
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
Else
|
|
'new dim syntax for SHARED!
|
|
i = i - 1 'relocate back to "AS"
|
|
|
|
'estabilish the data type:
|
|
t$ = ""
|
|
ts$ = ""
|
|
t3$ = ""
|
|
n$ = ""
|
|
previousElement$ = ""
|
|
l2$ = sp + SCase$("As")
|
|
sharedAsLayoutAdded = 0
|
|
getshrtyp2:
|
|
i = i + 1
|
|
t2$ = getelement$(a$, i)
|
|
If t2$ <> "," And t2$ <> "(" And t2$ <> "" Then
|
|
'get first variable name
|
|
n$ = getelement$(ca$, i)
|
|
|
|
If Len(previousElement$) Then
|
|
If t$ = "" Then t$ = previousElement$ Else t$ = t$ + " " + previousElement$
|
|
If t3$ = "" Then t3$ = previousElement$ Else t3$ = t3$ + sp + previousElement$
|
|
End If
|
|
previousElement$ = t2$
|
|
GoTo getshrtyp2
|
|
End If
|
|
If t$ = "" Then a$ = "Expected SHARED AS type variable-list or SHARED variable-name AS type": GoTo errmes
|
|
|
|
t = typname2typ(t$)
|
|
If Error_Happened Then GoTo errmes
|
|
If t And ISINCONVENTIONALMEMORY Then t = t - ISINCONVENTIONALMEMORY
|
|
If t And ISPOINTER Then t = t - ISPOINTER
|
|
If t And ISREFERENCE Then t = t - ISREFERENCE
|
|
tsize = typname2typsize
|
|
method = 0
|
|
If (t And ISUDT) = 0 Then
|
|
ts$ = type2symbol$(t$)
|
|
l2$ = l2$ + sp + SCase2$(t3$)
|
|
Else
|
|
t3$ = RTrim$(udtxcname(t And 511))
|
|
If RTrim$(udtxcname(t And 511)) = "_MEM" And UCase$(t$) = "MEM" And qb64prefix_set = 1 Then
|
|
t3$ = Mid$(RTrim$(udtxcname(t And 511)), 2)
|
|
End If
|
|
l2$ = l2$ + sp + t3$
|
|
End If
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
subfuncshr2:
|
|
s$ = removesymbol(n$)
|
|
If Error_Happened Then GoTo errmes
|
|
If s$ <> "" Then
|
|
a$ = "Cannot use type symbol with SHARED AS type variable-list (" + s$ + ")"
|
|
GoTo errmes
|
|
End If
|
|
|
|
'array?
|
|
a = 0
|
|
l3$ = ""
|
|
If getelement$(a$, i) = "(" Then
|
|
If getelement$(a$, i + 1) <> ")" Then a$ = "Expected ()": GoTo errmes
|
|
i = i + 2
|
|
a = 1
|
|
l3$ = sp2 + "(" + sp2 + ")"
|
|
End If
|
|
|
|
newSharedSyntax = -1
|
|
GoSub NormalSharedBlock
|
|
newSharedSyntax = 0
|
|
|
|
If getelement$(a$, i) = "," Then
|
|
i = i + 1
|
|
l$ = l$ + sp2 + ","
|
|
|
|
'get next variable name
|
|
n$ = getelement$(ca$, i): i = i + 1
|
|
GoTo subfuncshr2
|
|
End If
|
|
If getelement$(a$, i) <> "" Then a$ = "Expected ,": GoTo errmes
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
'EXIT SUB/FUNCTION
|
|
If n = 2 Then
|
|
If firstelement$ = "EXIT" Then
|
|
sf = 0
|
|
If secondelement$ = "FUNCTION" Then sf = 1
|
|
If secondelement$ = "SUB" Then sf = 2
|
|
If sf Then
|
|
|
|
If Len(subfunc) = 0 Then a$ = "EXIT " + secondelement$ + " must be used within a " + secondelement$: GoTo errmes
|
|
|
|
Print #12, "goto exit_subfunc;"
|
|
If Left$(subfunc, 4) = "SUB_" Then secondelement$ = SCase$("Sub") Else secondelement$ = SCase$("Function")
|
|
l$ = SCase$("Exit") + sp + secondelement$
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
|
|
'_ECHO checking
|
|
If firstelement$ = "_ECHO" Or (firstelement$ = "ECHO" And qb64prefix_set = 1) Then
|
|
If Console = 0 Then
|
|
a$ = qb64prefix$ + "ECHO requires $CONSOLE or $CONSOLE:ONLY to be set first": GoTo errmes
|
|
End If
|
|
End If
|
|
|
|
|
|
'ASC statement (fully inline)
|
|
If n >= 1 Then
|
|
If firstelement$ = "ASC" Then
|
|
If getelement$(a$, 2) <> "(" Then a$ = "Expected ( after ASC": GoTo errmes
|
|
|
|
'calculate 3 parts
|
|
useposition = 0
|
|
part = 1
|
|
i = 3
|
|
a3$ = ""
|
|
stringvariable$ = ""
|
|
position$ = ""
|
|
B = 0
|
|
Do
|
|
|
|
If i > n Then 'got part 3
|
|
If part <> 3 Or Len(a3$) = 0 Then a$ = "Expected ASC ( ... , ... ) = ...": GoTo errmes
|
|
expression$ = a3$
|
|
Exit Do
|
|
End If
|
|
|
|
a2$ = getelement$(ca$, i)
|
|
If a2$ = "(" Then B = B + 1
|
|
If a2$ = ")" Then B = B - 1
|
|
|
|
If B = -1 Then
|
|
|
|
If part = 1 Then 'eg. ASC(a$)=65
|
|
If getelement$(a$, i + 1) <> "=" Then a$ = "Expected =": GoTo errmes
|
|
stringvariable$ = a3$
|
|
position$ = "1"
|
|
part = 3: a3$ = "": i = i + 1: GoTo ascgotpart
|
|
End If
|
|
|
|
If part = 2 Then 'eg. ASC(a$,i)=65
|
|
If getelement$(a$, i + 1) <> "=" Then a$ = "Expected =": GoTo errmes
|
|
useposition = 1
|
|
position$ = a3$
|
|
part = 3: a3$ = "": i = i + 1: GoTo ascgotpart
|
|
End If
|
|
|
|
'fall through, already in part 3
|
|
|
|
End If
|
|
|
|
If a2$ = "," And B = 0 Then
|
|
If part = 1 Then stringvariable$ = a3$: part = 2: a3$ = "": GoTo ascgotpart
|
|
End If
|
|
|
|
If Len(a3$) Then a3$ = a3$ + sp + a2$ Else a3$ = a2$
|
|
ascgotpart:
|
|
i = i + 1
|
|
Loop
|
|
If Len(stringvariable$) = 0 Or Len(position$) = 0 Then a$ = "Expected ASC ( ... , ... ) = ...": GoTo errmes
|
|
|
|
'validate stringvariable$
|
|
stringvariable$ = fixoperationorder$(stringvariable$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = SCase$("Asc") + sp2 + "(" + sp2 + tlayout$
|
|
|
|
e$ = evaluate(stringvariable$, sourcetyp)
|
|
If Error_Happened Then GoTo errmes
|
|
If (sourcetyp And ISREFERENCE) = 0 Or (sourcetyp And ISSTRING) = 0 Then a$ = "Expected ASC ( string-variable , ...": GoTo errmes
|
|
stringvariable$ = evaluatetotyp(stringvariable$, ISSTRING)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
|
|
|
|
If position$ = "1" Then
|
|
If useposition Then l$ = l$ + sp2 + "," + sp + "1" + sp2 + ")" + sp + "=" Else l$ = l$ + sp2 + ")" + sp + "="
|
|
|
|
Print #12, "tqbs=" + stringvariable$ + "; if (!new_error){"
|
|
e$ = fixoperationorder$(expression$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + tlayout$
|
|
e$ = evaluatetotyp(e$, 32&)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "tmp_long=" + e$ + "; if (!new_error){"
|
|
Print #12, "if (tqbs->len){tqbs->chr[0]=tmp_long;}else{error(5);}"
|
|
Print #12, "}}"
|
|
|
|
Else
|
|
|
|
Print #12, "tqbs=" + stringvariable$ + "; if (!new_error){"
|
|
e$ = fixoperationorder$(position$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$ + sp2 + ")" + sp + "="
|
|
e$ = evaluatetotyp(e$, 32&)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "tmp_fileno=" + e$ + "; if (!new_error){"
|
|
e$ = fixoperationorder$(expression$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + tlayout$
|
|
e$ = evaluatetotyp(e$, 32&)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "tmp_long=" + e$ + "; if (!new_error){"
|
|
Print #12, "if ((tmp_fileno>0)&&(tmp_fileno<=tqbs->len)){tqbs->chr[tmp_fileno-1]=tmp_long;}else{error(5);}"
|
|
Print #12, "}}}"
|
|
|
|
End If
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
'MID$ statement
|
|
If n >= 1 Then
|
|
If firstelement$ = "MID$" Then
|
|
If getelement$(a$, 2) <> "(" Then a$ = "Expected ( after MID$": GoTo errmes
|
|
'calculate 4 parts
|
|
length$ = ""
|
|
part = 1
|
|
i = 3
|
|
a3$ = ""
|
|
stringvariable$ = ""
|
|
start$ = ""
|
|
B = 0
|
|
Do
|
|
If i > n Then
|
|
If part <> 4 Or a3$ = "" Then a$ = "Expected MID$(...)=...": GoTo errmes
|
|
stringexpression$ = a3$
|
|
Exit Do
|
|
End If
|
|
a2$ = getelement$(ca$, i)
|
|
If a2$ = "(" Then B = B + 1
|
|
If a2$ = ")" Then B = B - 1
|
|
If B = -1 Then
|
|
If part = 2 Then
|
|
If getelement$(a$, i + 1) <> "=" Then a$ = "Expected = after )": GoTo errmes
|
|
start$ = a3$: part = 4: a3$ = "": i = i + 1: GoTo midgotpart
|
|
End If
|
|
If part = 3 Then
|
|
If getelement$(a$, i + 1) <> "=" Then a$ = "Expected = after )": GoTo errmes
|
|
If a3$ = "" Then a$ = "Omit , before ) if omitting length in MID$ statement": GoTo errmes
|
|
length$ = a3$: part = 4: a3$ = "": i = i + 1: GoTo midgotpart
|
|
End If
|
|
End If
|
|
If a2$ = "," And B = 0 Then
|
|
If part = 1 Then stringvariable$ = a3$: part = 2: a3$ = "": GoTo midgotpart
|
|
If part = 2 Then start$ = a3$: part = 3: a3$ = "": GoTo midgotpart
|
|
End If
|
|
If Len(a3$) Then a3$ = a3$ + sp + a2$ Else a3$ = a2$
|
|
midgotpart:
|
|
i = i + 1
|
|
Loop
|
|
If stringvariable$ = "" Then a$ = "Syntax error": GoTo errmes
|
|
If start$ = "" Then a$ = "Syntax error": GoTo errmes
|
|
'check if it is a valid source string
|
|
stringvariable$ = fixoperationorder$(stringvariable$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = SCase$("Mid$") + sp2 + "(" + sp2 + tlayout$
|
|
e$ = evaluate(stringvariable$, sourcetyp)
|
|
If Error_Happened Then GoTo errmes
|
|
If (sourcetyp And ISREFERENCE) = 0 Or (sourcetyp And ISSTRING) = 0 Then a$ = "MID$ expects a string variable/array-element as its first argument": GoTo errmes
|
|
stringvariable$ = evaluatetotyp(stringvariable$, ISSTRING)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
start$ = fixoperationorder$(start$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$
|
|
start$ = evaluatetotyp((start$), 32&)
|
|
|
|
stringexpression$ = fixoperationorder$(stringexpression$)
|
|
If Error_Happened Then GoTo errmes
|
|
l2$ = tlayout$
|
|
stringexpression$ = evaluatetotyp(stringexpression$, ISSTRING)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
If Len(length$) Then
|
|
length$ = fixoperationorder$(length$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$
|
|
length$ = evaluatetotyp(length$, 32&)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "sub_mid(" + stringvariable$ + "," + start$ + "," + length$ + "," + stringexpression$ + ",1);"
|
|
Else
|
|
Print #12, "sub_mid(" + stringvariable$ + "," + start$ + ",0," + stringexpression$ + ",0);"
|
|
End If
|
|
|
|
l$ = l$ + sp2 + ")" + sp + "=" + sp + l2$
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
|
|
If n >= 2 Then
|
|
If firstelement$ = "ERASE" Then
|
|
i = 2
|
|
l$ = SCase$("Erase")
|
|
erasenextarray:
|
|
var$ = getelement$(ca$, i)
|
|
x$ = var$: ls$ = removesymbol(x$)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
If FindArray(var$) Then
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + RTrim$(id.cn) + ls$
|
|
'erase the array
|
|
clearerase:
|
|
n$ = RTrim$(id.callname)
|
|
bytesperelement$ = str2((id.arraytype And 511) \ 8)
|
|
If id.arraytype And ISSTRING Then bytesperelement$ = str2(id.tsize)
|
|
If id.arraytype And ISOFFSETINBITS Then bytesperelement$ = str2((id.arraytype And 511)) + "/8+1"
|
|
If id.arraytype And ISUDT Then
|
|
bytesperelement$ = str2(udtxsize(id.arraytype And 511) \ 8)
|
|
End If
|
|
Print #12, "if (" + n$ + "[2]&1){" 'array is defined
|
|
Print #12, "if (" + n$ + "[2]&2){" 'array is static
|
|
If (id.arraytype And ISSTRING) <> 0 And (id.arraytype And ISFIXEDLENGTH) = 0 Then
|
|
Print #12, "tmp_long=";
|
|
For i2 = 1 To Abs(id.arrayelements)
|
|
If i2 <> 1 Then Print #12, "*";
|
|
Print #12, n$ + "[" + str2(i2 * 4 - 4 + 5) + "]";
|
|
Next
|
|
Print #12, ";"
|
|
Print #12, "while(tmp_long--){"
|
|
Print #12, "((qbs*)(((uint64*)(" + n$ + "[0]))[tmp_long]))->len=0;"
|
|
Print #12, "}"
|
|
Else
|
|
'numeric
|
|
'clear array
|
|
Print #12, "memset((void*)(" + n$ + "[0]),0,";
|
|
For i2 = 1 To Abs(id.arrayelements)
|
|
If i2 <> 1 Then Print #12, "*";
|
|
Print #12, n$ + "[" + str2(i2 * 4 - 4 + 5) + "]";
|
|
Next
|
|
Print #12, "*" + bytesperelement$ + ");"
|
|
End If
|
|
Print #12, "}else{" 'array is dynamic
|
|
'1. free memory & any allocated strings
|
|
If (id.arraytype And ISSTRING) <> 0 And (id.arraytype And ISFIXEDLENGTH) = 0 Then
|
|
'free strings
|
|
Print #12, "tmp_long=";
|
|
For i2 = 1 To Abs(id.arrayelements)
|
|
If i2 <> 1 Then Print #12, "*";
|
|
Print #12, n$ + "[" + str2(i2 * 4 - 4 + 5) + "]";
|
|
Next
|
|
Print #12, ";"
|
|
Print #12, "while(tmp_long--){"
|
|
Print #12, "qbs_free((qbs*)(((uint64*)(" + n$ + "[0]))[tmp_long]));"
|
|
Print #12, "}"
|
|
'free memory
|
|
Print #12, "free((void*)(" + n$ + "[0]));"
|
|
Else
|
|
'free memory
|
|
Print #12, "if (" + n$ + "[2]&4){" 'cmem array
|
|
Print #12, "cmem_dynamic_free((uint8*)(" + n$ + "[0]));"
|
|
Print #12, "}else{" 'non-cmem array
|
|
Print #12, "free((void*)(" + n$ + "[0]));"
|
|
Print #12, "}"
|
|
End If
|
|
'2. set array (and its elements) as undefined
|
|
Print #12, n$ + "[2]^=1;" 'remove defined flag, keeping other flags (such as cmem)
|
|
'set dimensions as undefined
|
|
For i2 = 1 To Abs(id.arrayelements)
|
|
B = i2 * 4
|
|
Print #12, n$ + "[" + str2(B) + "]=2147483647;" 'base
|
|
Print #12, n$ + "[" + str2(B + 1) + "]=0;" 'num. index
|
|
Print #12, n$ + "[" + str2(B + 2) + "]=0;" 'multiplier
|
|
Next
|
|
If (id.arraytype And ISSTRING) <> 0 And (id.arraytype And ISFIXEDLENGTH) = 0 Then
|
|
Print #12, n$ + "[0]=(ptrszint)¬hingstring;"
|
|
Else
|
|
Print #12, n$ + "[0]=(ptrszint)nothingvalue;"
|
|
End If
|
|
Print #12, "}" 'static/dynamic
|
|
Print #12, "}" 'array is defined
|
|
If clearerasereturn = 1 Then clearerasereturn = 0: GoTo clearerasereturned
|
|
GoTo erasedarray
|
|
End If
|
|
If Error_Happened Then GoTo errmes
|
|
a$ = "Undefined array passed to ERASE": GoTo errmes
|
|
|
|
erasedarray:
|
|
If i < n Then
|
|
i = i + 1: n$ = getelement$(a$, i): If n$ <> "," Then a$ = "Expected ,": GoTo errmes
|
|
l$ = l$ + sp2 + ","
|
|
i = i + 1: If i > n Then a$ = "Expected , ...": GoTo errmes
|
|
GoTo erasenextarray
|
|
End If
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
|
|
'DIM/REDIM/STATIC
|
|
If n >= 2 Then
|
|
dimoption = 0: redimoption = 0: commonoption = 0
|
|
If firstelement$ = "DIM" Then l$ = SCase$("Dim"): dimoption = 1
|
|
If firstelement$ = "REDIM" Then
|
|
l$ = SCase$("ReDim")
|
|
dimoption = 2: redimoption = 1
|
|
If secondelement$ = "_PRESERVE" Or (secondelement$ = "PRESERVE" And qb64prefix_set = 1) Then
|
|
redimoption = 2
|
|
If secondelement$ = "_PRESERVE" Then
|
|
l$ = l$ + sp + SCase$("_Preserve")
|
|
Else
|
|
l$ = l$ + sp + SCase$("Preserve")
|
|
End If
|
|
If n = 2 Then a$ = "Expected REDIM " + qb64prefix$ + "PRESERVE ...": GoTo errmes
|
|
End If
|
|
End If
|
|
If firstelement$ = "STATIC" Then l$ = SCase$("Static"): dimoption = 3
|
|
If firstelement$ = "COMMON" Then l$ = SCase$("Common"): dimoption = 1: commonoption = 1
|
|
If dimoption Then
|
|
|
|
If dimoption = 3 And subfuncn = 0 Then a$ = "STATIC must be used within a SUB/FUNCTION": GoTo errmes
|
|
If commonoption = 1 And subfuncn <> 0 Then a$ = "COMMON cannot be used within a SUB/FUNCTION": GoTo errmes
|
|
|
|
i = 2
|
|
If redimoption = 2 Then i = 3
|
|
|
|
If dimoption <> 3 Then 'shared cannot be static
|
|
a2$ = getelement(a$, i)
|
|
If a2$ = "SHARED" Then
|
|
If subfuncn <> 0 Then a$ = "DIM/REDIM SHARED invalid within a SUB/FUNCTION": GoTo errmes
|
|
dimshared = 1
|
|
i = i + 1
|
|
l$ = l$ + sp + SCase$("Shared")
|
|
End If
|
|
End If
|
|
|
|
If dimoption = 3 Then dimstatic = 1: AllowLocalName = 1
|
|
|
|
'look for new dim syntax: DIM AS variabletype var1, var2, etc....
|
|
e$ = getelement$(a$, i)
|
|
If e$ <> "AS" Then
|
|
'no "AS", so this is the traditional dim syntax
|
|
dimnext:
|
|
notype = 0
|
|
listarray = 0
|
|
|
|
|
|
'old chain code
|
|
'chaincommonarray=0
|
|
|
|
varname$ = getelement(ca$, i): i = i + 1
|
|
If varname$ = "" Then a$ = "Expected " + firstelement$ + " variable-name or " + firstelement$ + " AS type variable-list": GoTo errmes
|
|
|
|
'get the next element
|
|
If i >= n + 1 Then e$ = "" Else e$ = getelement(a$, i): i = i + 1
|
|
|
|
'check if next element is a ( to create an array
|
|
elements$ = ""
|
|
|
|
If e$ = "(" Then
|
|
B = 1
|
|
For i = i To n
|
|
e$ = getelement(ca$, i)
|
|
If e$ = "(" Then B = B + 1
|
|
If e$ = ")" Then B = B - 1
|
|
If B = 0 Then Exit For
|
|
If Len(elements$) Then elements$ = elements$ + sp + e$ Else elements$ = e$
|
|
Next
|
|
If B <> 0 Then a$ = "Expected )": GoTo errmes
|
|
i = i + 1 'set i to point to the next element
|
|
|
|
If commonoption Then elements$ = "?"
|
|
|
|
|
|
If Debug Then Print #9, "DIM2:array:elements$:[" + elements$ + "]"
|
|
|
|
'arrayname() means list array to it will automatically be static when it is formally dimensioned later
|
|
'note: listed arrays are always created in dynamic memory, but their contents are not erased
|
|
' this differs from static arrays from SUB...STATIC and the unique QB64 method -> STATIC arrayname(100)
|
|
If dimoption = 3 Then 'STATIC used
|
|
If Len(elements$) = 0 Then 'nothing between brackets
|
|
listarray = 1 'add to static list
|
|
End If
|
|
End If
|
|
|
|
'last element was ")"
|
|
'get next element
|
|
If i >= n + 1 Then e$ = "" Else e$ = getelement(a$, i): i = i + 1
|
|
End If 'e$="("
|
|
d$ = e$
|
|
|
|
dimmethod = 0
|
|
|
|
appendname$ = "" 'the symbol to append to name returned by dim2
|
|
appendtype$ = "" 'eg. sp+AS+spINTEGER
|
|
dim2typepassback$ = ""
|
|
|
|
'does varname have an appended symbol?
|
|
s$ = removesymbol$(varname$)
|
|
If Error_Happened Then GoTo errmes
|
|
If validname(varname$) = 0 Then a$ = "Invalid variable name": GoTo errmes
|
|
|
|
If s$ <> "" Then
|
|
typ$ = s$
|
|
dimmethod = 1
|
|
appendname$ = typ$
|
|
GoTo dimgottyp
|
|
End If
|
|
|
|
If d$ = "AS" Then
|
|
appendtype$ = sp + SCase$("As")
|
|
typ$ = ""
|
|
For i = i To n
|
|
d$ = getelement(a$, i)
|
|
If d$ = "," Then i = i + 1: Exit For
|
|
typ$ = typ$ + d$ + " "
|
|
appendtype$ = appendtype$ + sp + d$
|
|
d$ = ""
|
|
Next
|
|
appendtype$ = SCase2$(appendtype$) 'capitalise default types (udt override this later if necessary)
|
|
typ$ = RTrim$(typ$)
|
|
GoTo dimgottyp
|
|
End If
|
|
|
|
'auto-define type based on name
|
|
notype = 1
|
|
If Left$(varname$, 1) = "_" Then v = 27 Else v = Asc(UCase$(varname$)) - 64
|
|
typ$ = defineaz(v)
|
|
dimmethod = 1
|
|
GoTo dimgottyp
|
|
|
|
dimgottyp:
|
|
If d$ <> "" And d$ <> "," Then a$ = "DIM: Expected comma!": GoTo errmes
|
|
|
|
'In QBASIC, if no type info is given it can refer to an expeicit/formally defined array
|
|
If notype <> 0 And dimoption <> 3 And dimoption <> 1 Then 'not DIM or STATIC which only create new content
|
|
If Len(elements$) Then 'an array
|
|
If FindArray(varname$) Then
|
|
If Len(RTrim$(id.mayhave)) Then 'explict/formally defined
|
|
typ$ = id2fulltypename$ 'adopt type
|
|
dimmethod = 0 'set as formally defined
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
NormalDimBlock:
|
|
If dimoption = 3 And Len(elements$) Then 'eg. STATIC a(100)
|
|
'does a conflicting array exist? (use findarray) if so again this should lead to duplicate definition
|
|
typ2$ = symbol2fulltypename$(typ$)
|
|
t = typname2typ(typ2$): ts = typname2typsize
|
|
'try name without any extension
|
|
If FindArray(varname$) Then 'name without any symbol
|
|
If id.insubfuncn = subfuncn Then 'global cannot conflict with static
|
|
If Len(RTrim$(id.musthave)) Then
|
|
'if types match then fail
|
|
If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then
|
|
If ts = id.tsize Then
|
|
a$ = "Name already in use": GoTo errmes
|
|
End If
|
|
End If
|
|
Else
|
|
If dimmethod = 0 Then
|
|
a$ = "Name already in use": GoTo errmes 'explicit over explicit
|
|
Else
|
|
'if types match then fail
|
|
If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then
|
|
If ts = id.tsize Then
|
|
a$ = "Name already in use": GoTo errmes
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
'add extension (if possible)
|
|
If (t And ISUDT) = 0 Then
|
|
s2$ = type2symbol$(typ2$)
|
|
If Error_Happened Then GoTo errmes
|
|
If FindArray(varname$ + s2$) Then
|
|
If id.insubfuncn = subfuncn Then 'global cannot conflict with static
|
|
If Len(RTrim$(id.musthave)) Then
|
|
'if types match then fail
|
|
If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then
|
|
If ts = id.tsize Then
|
|
a$ = "Name already in use": GoTo errmes
|
|
End If
|
|
End If
|
|
Else
|
|
If dimmethod = 0 Then
|
|
a$ = "Name already in use": GoTo errmes 'explicit over explicit
|
|
Else
|
|
'if types match then fail
|
|
If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then
|
|
If ts = id.tsize Then
|
|
a$ = "Name already in use": GoTo errmes
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If 'not a UDT
|
|
End If
|
|
|
|
If listarray Then 'eg. STATIC a()
|
|
'note: list is cleared by END SUB/FUNCTION
|
|
|
|
'is a conflicting array already listed? if so this should cause a duplicate definition error
|
|
'check for conflict within list:
|
|
xi = 1
|
|
For x = 1 To staticarraylistn
|
|
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$(varname$) = UCase$(varname2$) Then
|
|
If dimmethod2 = 1 Then
|
|
'old using symbol
|
|
If symbol2fulltypename$(typ$) = typ2$ Then a$ = "Name already in use": GoTo errmes
|
|
Else
|
|
'old using AS
|
|
If dimmethod = 0 Then
|
|
a$ = "Name already in use": GoTo errmes
|
|
Else
|
|
If symbol2fulltypename$(typ$) = typ2$ Then a$ = "Name already in use": GoTo errmes
|
|
End If
|
|
End If
|
|
End If
|
|
Next
|
|
|
|
'does a conflicting array exist? (use findarray) if so again this should lead to duplicate definition
|
|
typ2$ = symbol2fulltypename$(typ$)
|
|
t = typname2typ(typ2$): ts = typname2typsize
|
|
'try name without any extension
|
|
If FindArray(varname$) Then 'name without any symbol
|
|
If id.insubfuncn = subfuncn Then 'global cannot conflict with static
|
|
If Len(RTrim$(id.musthave)) Then
|
|
'if types match then fail
|
|
If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then
|
|
If ts = id.tsize Then
|
|
a$ = "Name already in use": GoTo errmes
|
|
End If
|
|
End If
|
|
Else
|
|
If dimmethod = 0 Then
|
|
a$ = "Name already in use": GoTo errmes 'explicit over explicit
|
|
Else
|
|
'if types match then fail
|
|
If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then
|
|
If ts = id.tsize Then
|
|
a$ = "Name already in use": GoTo errmes
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
'add extension (if possible)
|
|
If (t And ISUDT) = 0 Then
|
|
s2$ = type2symbol$(typ2$)
|
|
If Error_Happened Then GoTo errmes
|
|
If FindArray(varname$ + s2$) Then
|
|
If id.insubfuncn = subfuncn Then 'global cannot conflict with static
|
|
If Len(RTrim$(id.musthave)) Then
|
|
'if types match then fail
|
|
If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then
|
|
If ts = id.tsize Then
|
|
a$ = "Name already in use": GoTo errmes
|
|
End If
|
|
End If
|
|
Else
|
|
If dimmethod = 0 Then
|
|
a$ = "Name already in use": GoTo errmes 'explicit over explicit
|
|
Else
|
|
'if types match then fail
|
|
If (id.arraytype And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) = (t And (ISFLOAT + ISUDT + 511 + ISUNSIGNED + ISSTRING + ISFIXEDLENGTH)) Then
|
|
If ts = id.tsize Then
|
|
a$ = "Name already in use": GoTo errmes
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If 'not a UDT
|
|
|
|
'note: static list arrays cannot be created until they are formally [or informally] (RE)DIM'd later
|
|
If Len(staticarraylist) Then staticarraylist = staticarraylist + sp
|
|
staticarraylist = staticarraylist + varname$ + sp + symbol2fulltypename$(typ$) + sp + str2(dimmethod)
|
|
If Error_Happened Then GoTo errmes
|
|
staticarraylistn = staticarraylistn + 1
|
|
l$ = l$ + sp + varname$ + appendname$ + sp2 + "(" + sp2 + ")" + appendtype$
|
|
'note: none of the following code is run, dim2 call is also skipped
|
|
|
|
Else
|
|
|
|
olddimstatic = dimstatic
|
|
|
|
'check if varname is on the static list
|
|
If Len(elements$) Then 'it's an array
|
|
If subfuncn Then 'it's in a sub/function
|
|
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$(varname$) = UCase$(varname2$) Then
|
|
If symbol2fulltypename$(typ$) = typ2$ Then
|
|
If Error_Happened Then GoTo errmes
|
|
If dimmethod = dimmethod2 Then
|
|
'match found!
|
|
varname$ = varname2$
|
|
dimstatic = 3
|
|
If dimoption = 3 Then a$ = "Array already listed as STATIC": GoTo errmes
|
|
End If
|
|
End If 'typ
|
|
End If 'varname
|
|
Next
|
|
End If
|
|
End If
|
|
|
|
'COMMON exception
|
|
'note: COMMON alone does not imply SHARED
|
|
' if either(or both) COMMON & later DIM have SHARED, variable becomes shared
|
|
If commonoption Then
|
|
If Len(elements$) Then
|
|
|
|
'add array to list
|
|
If Len(commonarraylist) Then commonarraylist = commonarraylist + sp
|
|
'note: dimmethod distinguishes between a%(...) vs a(...) AS INTEGER
|
|
commonarraylist = commonarraylist + varname$ + sp + symbol2fulltypename$(typ$) + sp + str2(dimmethod) + sp + str2(dimshared)
|
|
If Error_Happened Then GoTo errmes
|
|
commonarraylistn = commonarraylistn + 1
|
|
If Debug Then Print #9, "common listed:" + varname$ + sp + symbol2fulltypename$(typ$) + sp + str2(dimmethod) + sp + str2(dimshared)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
x = 0
|
|
|
|
v$ = varname$
|
|
If dimmethod = 1 Then v$ = v$ + typ$
|
|
try = findid(v$)
|
|
If Error_Happened Then GoTo errmes
|
|
Do While try
|
|
If id.arraytype Then
|
|
|
|
t = typname2typ(typ$)
|
|
If Error_Happened Then GoTo errmes
|
|
s = typname2typsize
|
|
match = 1
|
|
'note: dimmethod 2 is already matched
|
|
If dimmethod = 0 Then
|
|
t2 = id.arraytype
|
|
s2 = id.tsize
|
|
If (t And ISFLOAT) <> (t2 And ISFLOAT) Then match = 0
|
|
If (t And ISUNSIGNED) <> (t2 And ISUNSIGNED) Then match = 0
|
|
If (t And ISSTRING) <> (t2 And ISSTRING) Then match = 0
|
|
If (t And ISFIXEDLENGTH) <> (t2 And ISFIXEDLENGTH) Then match = 0
|
|
If (t And ISOFFSETINBITS) <> (t2 And ISOFFSETINBITS) Then match = 0
|
|
If (t And ISUDT) <> (t2 And ISUDT) Then match = 0
|
|
If (t And 511) <> (t2 And 511) Then match = 0
|
|
If s <> s2 Then match = 0
|
|
'check for implicit/explicit declaration match
|
|
oldmethod = 0: If Len(RTrim$(id.musthave)) Then oldmethod = 1
|
|
If oldmethod <> dimmethod Then match = 0
|
|
End If
|
|
|
|
If match Then
|
|
x = currentid
|
|
If dimshared Then ids(x).share = 1 'share if necessary
|
|
tlayout$ = RTrim$(id.cn) + sp + "(" + sp2 + ")"
|
|
|
|
If dimmethod = 0 Then
|
|
If t And ISUDT Then
|
|
dim2typepassback$ = RTrim$(udtxcname(t And 511))
|
|
If UCase$(typ$) = "MEM" And qb64prefix_set = 1 And RTrim$(udtxcname(t And 511)) = "_MEM" Then
|
|
dim2typepassback$ = Mid$(RTrim$(udtxcname(t And 511)), 2)
|
|
End If
|
|
Else
|
|
dim2typepassback$ = typ$
|
|
Do While InStr(dim2typepassback$, " ")
|
|
Asc(dim2typepassback$, InStr(dim2typepassback$, " ")) = Asc(sp)
|
|
Loop
|
|
dim2typepassback$ = SCase2$(dim2typepassback$)
|
|
End If
|
|
End If 'method 0
|
|
|
|
Exit Do
|
|
End If 'match
|
|
|
|
End If 'arraytype
|
|
If try = 2 Then findanotherid = 1: try = findid(v$) Else try = 0
|
|
If Error_Happened Then GoTo errmes
|
|
Loop
|
|
|
|
If x = 0 Then x = idn + 1
|
|
|
|
'note: the following code only adds include directives, everything else is defered
|
|
Open tmpdir$ + "chain.txt" For Append As #22
|
|
'include directive
|
|
Print #22, "#include " + Chr$(34) + "chain" + str2$(x) + ".txt" + Chr$(34)
|
|
Close #22
|
|
'create/clear include file
|
|
Open tmpdir$ + "chain" + str2$(x) + ".txt" For Output As #22: Close #22
|
|
|
|
Open tmpdir$ + "inpchain.txt" For Append As #22
|
|
'include directive
|
|
Print #22, "#include " + Chr$(34) + "inpchain" + str2$(x) + ".txt" + Chr$(34)
|
|
Close #22
|
|
'create/clear include file
|
|
Open tmpdir$ + "inpchain" + str2$(x) + ".txt" For Output As #22: Close #22
|
|
|
|
'note: elements$="?"
|
|
If x <> idn + 1 Then GoTo skipdim 'array already exists
|
|
GoTo dimcommonarray
|
|
|
|
End If
|
|
End If
|
|
|
|
'is varname on common list?
|
|
'******
|
|
If Len(elements$) Then 'it's an array
|
|
If subfuncn = 0 Then 'not in a sub/function
|
|
|
|
If Debug Then Print #9, "common checking:" + varname$
|
|
|
|
xi = 1
|
|
For x = 1 To commonarraylistn
|
|
varname2$ = getelement$(commonarraylist, xi): xi = xi + 1
|
|
typ2$ = getelement$(commonarraylist, xi): xi = xi + 1
|
|
dimmethod2 = Val(getelement$(commonarraylist, xi)): xi = xi + 1
|
|
dimshared2 = Val(getelement$(commonarraylist, xi)): xi = xi + 1
|
|
If Debug Then Print #9, "common checking against:" + varname2$ + sp + typ2$ + sp + str2(dimmethod2) + sp + str2(dimshared2)
|
|
'check if they are similar
|
|
If varname$ = varname2$ Then
|
|
If symbol2fulltypename$(typ$) = typ2$ Then
|
|
If Error_Happened Then GoTo errmes
|
|
If dimmethod = dimmethod2 Then
|
|
|
|
'match found!
|
|
'enforce shared status (if necessary)
|
|
If dimshared2 Then dimshared = dimshared Or 2 'temp force SHARED
|
|
|
|
'old chain code
|
|
'chaincommonarray=x
|
|
|
|
End If 'method
|
|
End If 'typ
|
|
End If 'varname
|
|
Next
|
|
End If
|
|
End If
|
|
|
|
dimcommonarray:
|
|
retval = dim2(varname$, typ$, dimmethod, elements$)
|
|
If Error_Happened Then GoTo errmes
|
|
skipdim:
|
|
If dimshared >= 2 Then dimshared = dimshared - 2
|
|
|
|
'non-array COMMON variable
|
|
If commonoption <> 0 And Len(elements$) = 0 Then
|
|
|
|
'CHAIN.TXT (save)
|
|
|
|
use_global_byte_elements = 1
|
|
|
|
'switch output from main.txt to chain.txt
|
|
Close #12
|
|
Open tmpdir$ + "chain.txt" For Append As #12
|
|
l2$ = tlayout$
|
|
|
|
Print #12, "int32val=1;" 'simple variable
|
|
Print #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);"
|
|
|
|
t = id.t
|
|
bits = t And 511
|
|
If t And ISUDT Then bits = udtxsize(t And 511)
|
|
If t And ISSTRING Then
|
|
If t And ISFIXEDLENGTH Then
|
|
bits = id.tsize * 8
|
|
Else
|
|
Print #12, "int64val=__STRING_" + RTrim$(id.n) + "->len*8;"
|
|
bits = 0
|
|
End If
|
|
End If
|
|
|
|
If bits Then
|
|
Print #12, "int64val=" + str2$(bits) + ";" 'size in bits
|
|
End If
|
|
Print #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);"
|
|
|
|
'put the variable
|
|
e$ = RTrim$(id.n)
|
|
|
|
If (t And ISUDT) = 0 Then
|
|
If t And ISFIXEDLENGTH Then
|
|
e$ = e$ + "$" + str2$(id.tsize)
|
|
Else
|
|
e$ = e$ + typevalue2symbol$(t)
|
|
If Error_Happened Then GoTo errmes
|
|
End If
|
|
End If
|
|
e$ = evaluatetotyp(fixoperationorder$(e$), -4)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
Print #12, "sub_put(FF,NULL," + e$ + ",0);"
|
|
|
|
tlayout$ = l2$
|
|
'revert output to main.txt
|
|
Close #12
|
|
Open tmpdir$ + "main.txt" For Append As #12
|
|
|
|
|
|
'INPCHAIN.TXT (load)
|
|
|
|
'switch output from main.txt to chain.txt
|
|
Close #12
|
|
Open tmpdir$ + "inpchain.txt" For Append As #12
|
|
l2$ = tlayout$
|
|
|
|
|
|
Print #12, "if (int32val==1){"
|
|
'get the size in bits
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);"
|
|
'***assume correct size***
|
|
|
|
e$ = RTrim$(id.n)
|
|
t = id.t
|
|
If (t And ISUDT) = 0 Then
|
|
If t And ISFIXEDLENGTH Then
|
|
e$ = e$ + "$" + str2$(id.tsize)
|
|
Else
|
|
e$ = e$ + typevalue2symbol$(t)
|
|
If Error_Happened Then GoTo errmes
|
|
End If
|
|
End If
|
|
|
|
If t And ISSTRING Then
|
|
If (t And ISFIXEDLENGTH) = 0 Then
|
|
Print #12, "tqbs=qbs_new(int64val>>3,1);"
|
|
Print #12, "qbs_set(__STRING_" + RTrim$(id.n) + ",tqbs);"
|
|
'now that the string is the correct size, the following GET command will work correctly...
|
|
End If
|
|
End If
|
|
|
|
e$ = evaluatetotyp(fixoperationorder$(e$), -4)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "sub_get(FF,NULL," + e$ + ",0);"
|
|
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);" 'get next command
|
|
Print #12, "}"
|
|
|
|
tlayout$ = l2$
|
|
'revert output to main.txt
|
|
Close #12
|
|
Open tmpdir$ + "main.txt" For Append As #12
|
|
|
|
use_global_byte_elements = 0
|
|
|
|
End If
|
|
|
|
commonarraylisted:
|
|
|
|
If Len(appendtype$) And newDimSyntax = -1 Then
|
|
If Len(dim2typepassback$) Then appendtype$ = sp + SCase$("As") + sp + dim2typepassback$
|
|
If newDimSyntaxTypePassBack = 0 Then
|
|
newDimSyntaxTypePassBack = -1
|
|
l$ = l$ + appendtype$
|
|
End If
|
|
End If
|
|
|
|
n2 = numelements(tlayout$)
|
|
l$ = l$ + sp + getelement$(tlayout$, 1) + appendname$
|
|
If n2 > 1 Then
|
|
l$ = l$ + sp2 + getelements$(tlayout$, 2, n2)
|
|
End If
|
|
|
|
If Len(appendtype$) And newDimSyntax = 0 Then
|
|
If Len(dim2typepassback$) Then appendtype$ = sp + SCase$("As") + sp + dim2typepassback$
|
|
l$ = l$ + appendtype$
|
|
End If
|
|
|
|
'modify first element name to include symbol
|
|
|
|
dimstatic = olddimstatic
|
|
|
|
End If 'listarray=0
|
|
|
|
If newDimSyntax Then Return
|
|
|
|
If d$ = "," Then l$ = l$ + sp2 + ",": GoTo dimnext
|
|
|
|
dimoption = 0
|
|
dimshared = 0
|
|
redimoption = 0
|
|
If dimstatic = 1 Then dimstatic = 0
|
|
AllowLocalName = 0
|
|
|
|
layoutdone = 1
|
|
If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$
|
|
|
|
GoTo finishedline
|
|
Else
|
|
'yes, this is the new dim syntax.
|
|
i = i + 1 'skip "AS"
|
|
newDimSyntaxTypePassBack = 0
|
|
|
|
'estabilish the data type:
|
|
appendname$ = ""
|
|
appendtype$ = sp + SCase$("As")
|
|
typ$ = ""
|
|
varname$ = ""
|
|
previousElement$ = ""
|
|
For i = i To n
|
|
d$ = getelement(a$, i)
|
|
If d$ = "," Or d$ = "(" Then Exit For
|
|
varname$ = getelement(ca$, i)
|
|
If Len(previousElement$) Then
|
|
typ$ = typ$ + previousElement$ + " "
|
|
appendtype$ = appendtype$ + sp + previousElement$
|
|
End If
|
|
previousElement$ = d$
|
|
d$ = ""
|
|
Next
|
|
appendtype$ = SCase2$(appendtype$) 'capitalise default types (udt override this later if necessary)
|
|
typ$ = RTrim$(typ$)
|
|
|
|
dimnext2:
|
|
notype = 0
|
|
listarray = 0
|
|
|
|
If typ$ = "" Or varname$ = "" Then a$ = "Expected " + firstelement$ + " AS type variable-list or " + firstelement$ + " variable-name AS type": GoTo errmes
|
|
|
|
'get the next element
|
|
If i >= n + 1 Then e$ = "" Else e$ = getelement(a$, i): i = i + 1
|
|
|
|
'check if next element is a ( to create an array
|
|
elements$ = ""
|
|
|
|
If e$ = "(" Then
|
|
B = 1
|
|
For i = i To n
|
|
e$ = getelement(ca$, i)
|
|
If e$ = "(" Then B = B + 1
|
|
If e$ = ")" Then B = B - 1
|
|
If B = 0 Then Exit For
|
|
If Len(elements$) Then elements$ = elements$ + sp + e$ Else elements$ = e$
|
|
Next
|
|
If B <> 0 Then a$ = "Expected )": GoTo errmes
|
|
i = i + 1 'set i to point to the next element
|
|
|
|
If commonoption Then elements$ = "?"
|
|
|
|
|
|
If Debug Then Print #9, "DIM2:array:elements$:[" + elements$ + "]"
|
|
|
|
'arrayname() means list array to it will automatically be static when it is formally dimensioned later
|
|
'note: listed arrays are always created in dynamic memory, but their contents are not erased
|
|
' this differs from static arrays from SUB...STATIC and the unique QB64 method -> STATIC arrayname(100)
|
|
If dimoption = 3 Then 'STATIC used
|
|
If Len(elements$) = 0 Then 'nothing between brackets
|
|
listarray = 1 'add to static list
|
|
End If
|
|
End If
|
|
|
|
'last element was ")"
|
|
'get next element
|
|
If i >= n + 1 Then e$ = "" Else e$ = getelement(a$, i): i = i + 1
|
|
End If 'e$="("
|
|
d$ = e$
|
|
|
|
dimmethod = 0
|
|
|
|
dim2typepassback$ = ""
|
|
|
|
'does varname have an appended symbol?
|
|
s$ = removesymbol$(varname$)
|
|
If Error_Happened Then GoTo errmes
|
|
If validname(varname$) = 0 Then a$ = "Invalid variable name": GoTo errmes
|
|
|
|
If s$ <> "" Then
|
|
a$ = "Cannot use type symbol with " + firstelement$ + " AS type variable-list (" + s$ + ")"
|
|
GoTo errmes
|
|
End If
|
|
|
|
If d$ <> "" And d$ <> "," Then a$ = "DIM: Expected comma!": GoTo errmes
|
|
|
|
newDimSyntax = -1
|
|
GoSub NormalDimBlock
|
|
newDimSyntax = 0
|
|
|
|
If d$ = "," Then
|
|
l$ = l$ + sp2 + ","
|
|
varname$ = getelement(ca$, i): i = i + 1
|
|
GoTo dimnext2
|
|
End If
|
|
|
|
dimoption = 0
|
|
dimshared = 0
|
|
redimoption = 0
|
|
If dimstatic = 1 Then dimstatic = 0
|
|
AllowLocalName = 0
|
|
|
|
layoutdone = 1
|
|
If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$
|
|
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
'THEN [GOTO] linenumber?
|
|
If THENGOTO = 1 Then
|
|
If n = 1 Then
|
|
l$ = ""
|
|
a = Asc(Left$(firstelement$, 1))
|
|
If a = 46 Or (a >= 48 And a <= 57) Then a2$ = ca$: GoTo THENGOTO
|
|
End If
|
|
End If
|
|
|
|
'goto
|
|
If n = 2 Then
|
|
If getelement$(a$, 1) = "GOTO" Then
|
|
l$ = SCase$("GoTo")
|
|
a2$ = getelement$(ca$, 2)
|
|
THENGOTO:
|
|
If validlabel(a2$) = 0 Then a$ = "Invalid label!": GoTo errmes
|
|
|
|
v = HashFind(a2$, HASHFLAG_LABEL, ignore, r)
|
|
x = 1
|
|
labchk2:
|
|
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 labchk2
|
|
End If
|
|
End If
|
|
If x Then
|
|
'does not exist
|
|
nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type
|
|
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 Len(l$) Then l$ = l$ + sp + tlayout$ Else l$ = tlayout$
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
Print #12, "goto LABEL_" + a2$ + ";"
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
If n = 1 Then
|
|
If firstelement$ = "_CONTINUE" Or (firstelement$ = "CONTINUE" And qb64prefix_set = 1) Then
|
|
If firstelement$ = "_CONTINUE" Then l$ = SCase$("_Continue") Else l$ = SCase$("Continue")
|
|
'scan backwards until previous control level reached
|
|
For i = controllevel To 1 Step -1
|
|
t = controltype(i)
|
|
If t = 2 Then 'for...next
|
|
Print #12, "goto fornext_continue_" + str2$(controlid(i)) + ";"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
ElseIf t = 3 Or t = 4 Then 'do...loop
|
|
Print #12, "goto dl_continue_" + str2$(controlid(i)) + ";"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
ElseIf t = 5 Then 'while...wend
|
|
Print #12, "goto ww_continue_" + str2$(controlid(i)) + ";"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
Next
|
|
a$ = qb64prefix$ + "CONTINUE outside DO..LOOP/FOR..NEXT/WHILE..WEND block": GoTo errmes
|
|
End If
|
|
End If
|
|
|
|
If firstelement$ = "RUN" Then 'RUN
|
|
l$ = SCase$("Run")
|
|
If n = 1 Then
|
|
'no parameters
|
|
Print #12, "sub_run_init();" 'note: called first to free up screen-locked image handles
|
|
Print #12, "sub_clear(NULL,NULL,NULL,NULL);" 'use functionality of CLEAR
|
|
If Len(subfunc$) Then
|
|
Print #12, "QBMAIN(NULL);"
|
|
Else
|
|
Print #12, "goto S_0;"
|
|
End If
|
|
Else
|
|
'parameter passed
|
|
e$ = getelements$(ca$, 2, n)
|
|
e$ = fixoperationorder$(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l2$ = tlayout$
|
|
ignore$ = evaluate(e$, typ)
|
|
If Error_Happened Then GoTo errmes
|
|
If n = 2 And ((typ And ISSTRING) = 0) Then
|
|
'assume it's a label or line number
|
|
lbl$ = getelement$(ca$, 2)
|
|
If validlabel(lbl$) = 0 Then a$ = "Invalid label!": GoTo errmes 'invalid label
|
|
|
|
v = HashFind(lbl$, HASHFLAG_LABEL, ignore, r)
|
|
x = 1
|
|
labchk501:
|
|
If v Then
|
|
s = Labels(r).Scope
|
|
If s = 0 Or s = -1 Then 'main scope?
|
|
If s = -1 Then Labels(r).Scope = 0 'acquire scope
|
|
x = 0 'already defined
|
|
tlayout$ = RTrim$(Labels(r).cn)
|
|
Labels(r).Scope_Restriction = subfuncn
|
|
Labels(r).Error_Line = linenumber
|
|
Else
|
|
If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk501
|
|
End If
|
|
End If
|
|
If x Then
|
|
'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 lbl$, HASHFLAG_LABEL, nLabels
|
|
r = nLabels
|
|
Labels(r).State = 0
|
|
Labels(r).cn = tlayout$
|
|
Labels(r).Scope = 0
|
|
Labels(r).Error_Line = linenumber
|
|
Labels(r).Scope_Restriction = subfuncn
|
|
End If 'x
|
|
|
|
l$ = l$ + sp + tlayout$
|
|
Print #12, "sub_run_init();" 'note: called first to free up screen-locked image handles
|
|
Print #12, "sub_clear(NULL,NULL,NULL,NULL);" 'use functionality of CLEAR
|
|
If Len(subfunc$) Then
|
|
Print #21, "if (run_from_line==" + str2(nextrunlineindex) + "){run_from_line=0;goto LABEL_" + lbl$ + ";}"
|
|
Print #12, "run_from_line=" + str2(nextrunlineindex) + ";"
|
|
nextrunlineindex = nextrunlineindex + 1
|
|
Print #12, "QBMAIN(NULL);"
|
|
Else
|
|
Print #12, "goto LABEL_" + lbl$ + ";"
|
|
End If
|
|
Else
|
|
'assume it's a string containing a filename to execute
|
|
e$ = evaluatetotyp(e$, ISSTRING)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "sub_run(" + e$ + ");"
|
|
l$ = l$ + sp + l2$
|
|
End If 'isstring
|
|
End If 'n=1
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If 'run
|
|
|
|
|
|
|
|
|
|
|
|
If firstelement$ = "END" Then
|
|
l$ = SCase$("End")
|
|
If n > 1 Then
|
|
e$ = getelements$(ca$, 2, n)
|
|
e$ = fixoperationorder$(e$): If Error_Happened Then GoTo errmes
|
|
l2$ = tlayout$
|
|
e$ = evaluatetotyp(e$, ISINTEGER64): If Error_Happened Then GoTo errmes
|
|
inclinenump$ = ""
|
|
If inclinenumber(inclevel) Then
|
|
inclinenump$ = "," + str2$(inclinenumber(inclevel))
|
|
thisincname$ = getfilepath$(incname$(inclevel))
|
|
thisincname$ = Mid$(incname$(inclevel), Len(thisincname$) + 1)
|
|
inclinenump$ = inclinenump$ + "," + Chr$(34) + thisincname$ + Chr$(34)
|
|
End If
|
|
Print #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");}" 'non-resumable error check (cannot exit without handling errors)
|
|
Print #12, "exit_code=" + e$ + ";"
|
|
l$ = l$ + sp + l2$
|
|
End If
|
|
xend
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
|
|
If firstelement$ = "SYSTEM" Then
|
|
l$ = SCase$("System")
|
|
If n > 1 Then
|
|
e$ = getelements$(ca$, 2, n)
|
|
e$ = fixoperationorder$(e$): If Error_Happened Then GoTo errmes
|
|
l2$ = tlayout$
|
|
e$ = evaluatetotyp(e$, ISINTEGER64): If Error_Happened Then GoTo errmes
|
|
inclinenump$ = ""
|
|
If inclinenumber(inclevel) Then
|
|
inclinenump$ = "," + str2$(inclinenumber(inclevel))
|
|
thisincname$ = getfilepath$(incname$(inclevel))
|
|
thisincname$ = Mid$(incname$(inclevel), Len(thisincname$) + 1)
|
|
inclinenump$ = inclinenump$ + "," + Chr$(34) + thisincname$ + Chr$(34)
|
|
End If
|
|
Print #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");}" 'non-resumable error check (cannot exit without handling errors)
|
|
Print #12, "exit_code=" + e$ + ";"
|
|
l$ = l$ + sp + l2$
|
|
End If
|
|
|
|
|
|
Print #12, "if (sub_gl_called) error(271);"
|
|
Print #12, "close_program=1;"
|
|
Print #12, "end();"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
|
|
If n >= 1 Then
|
|
If firstelement$ = "STOP" Then
|
|
l$ = SCase$("Stop")
|
|
If n > 1 Then
|
|
e$ = getelements$(ca$, 2, n)
|
|
e$ = fixoperationorder$(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = SCase$("Stop") + sp + tlayout$
|
|
e$ = evaluatetotyp(e$, 64)
|
|
If Error_Happened Then GoTo errmes
|
|
'note: this value is currently ignored but evaluated for checking reasons
|
|
End If
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
Print #12, "close_program=1;"
|
|
Print #12, "end();"
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
If n = 2 Then
|
|
If firstelement$ = "GOSUB" Then
|
|
xgosub ca$
|
|
If Error_Happened Then GoTo errmes
|
|
'note: layout implemented in xgosub
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
If n >= 1 Then
|
|
If firstelement$ = "RETURN" Then
|
|
If n = 1 Then
|
|
Print #12, "#include " + Chr$(34) + "ret" + str2$(subfuncn) + ".txt" + Chr$(34)
|
|
l$ = SCase$("Return")
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
Else
|
|
'label/linenumber follows
|
|
If subfuncn <> 0 Then a$ = "RETURN linelabel/linenumber invalid within a SUB/FUNCTION": GoTo errmes
|
|
If n > 2 Then a$ = "Expected linelabel/linenumber after RETURN": GoTo errmes
|
|
Print #12, "if (!next_return_point) error(3);" 'check return point available
|
|
Print #12, "next_return_point--;" 'destroy return point
|
|
a2$ = getelement$(ca$, 2)
|
|
If validlabel(a2$) = 0 Then a$ = "Invalid label!": GoTo errmes
|
|
|
|
v = HashFind(a2$, HASHFLAG_LABEL, ignore, r)
|
|
x = 1
|
|
labchk505:
|
|
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 labchk505
|
|
End If
|
|
End If
|
|
If x Then
|
|
'does not exist
|
|
nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type
|
|
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
|
|
|
|
Print #12, "goto LABEL_" + a2$ + ";"
|
|
l$ = SCase$("Return") + sp + tlayout$
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
If n >= 1 Then
|
|
If firstelement$ = "RESUME" Then
|
|
l$ = SCase$("Resume")
|
|
If n = 1 Then
|
|
resumeprev:
|
|
|
|
|
|
Print #12, "if (!error_handling){error(20);}else{error_retry=1; qbevent=1; error_handling=0; error_err=0; return;}"
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
If n > 2 Then a$ = "Too many parameters": GoTo errmes
|
|
s$ = getelement$(ca$, 2)
|
|
If UCase$(s$) = "NEXT" Then
|
|
|
|
|
|
Print #12, "if (!error_handling){error(20);}else{error_handling=0; error_err=0; return;}"
|
|
|
|
l$ = l$ + sp + SCase$("Next")
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
If s$ = "0" Then l$ = l$ + sp + "0": GoTo resumeprev
|
|
If validlabel(s$) = 0 Then a$ = "Invalid label passed to RESUME": GoTo errmes
|
|
|
|
v = HashFind(s$, HASHFLAG_LABEL, ignore, r)
|
|
x = 1
|
|
labchk506:
|
|
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 labchk506
|
|
End If
|
|
End If
|
|
If x Then
|
|
'does not exist
|
|
nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type
|
|
Labels(nLabels) = Empty_Label
|
|
HashAdd s$, 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$
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
Print #12, "if (!error_handling){error(20);}else{error_handling=0; error_err=0; goto LABEL_" + s$ + ";}"
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
If n = 4 Then
|
|
If getelements(a$, 1, 3) = "ON" + sp + "ERROR" + sp + "GOTO" Then
|
|
l$ = SCase$("On" + sp + "Error" + sp + "GoTo")
|
|
lbl$ = getelement$(ca$, 4)
|
|
If lbl$ = "0" Then
|
|
Print #12, "error_goto_line=0;"
|
|
l$ = l$ + sp + "0"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
If validlabel(lbl$) = 0 Then a$ = "Invalid label": GoTo errmes
|
|
|
|
v = HashFind(lbl$, HASHFLAG_LABEL, ignore, r)
|
|
x = 1
|
|
labchk6:
|
|
If v Then
|
|
s = Labels(r).Scope
|
|
If s = 0 Or s = -1 Then 'main scope?
|
|
If s = -1 Then Labels(r).Scope = 0 'acquire scope
|
|
x = 0 'already defined
|
|
tlayout$ = RTrim$(Labels(r).cn)
|
|
Labels(r).Scope_Restriction = subfuncn
|
|
Labels(r).Error_Line = linenumber
|
|
Else
|
|
If v = 2 Then v = HashFindCont(ignore, r): GoTo labchk6
|
|
End If
|
|
End If
|
|
If x Then
|
|
'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 lbl$, HASHFLAG_LABEL, nLabels
|
|
r = nLabels
|
|
Labels(r).State = 0
|
|
Labels(r).cn = tlayout$
|
|
Labels(r).Scope = 0
|
|
Labels(r).Error_Line = linenumber
|
|
Labels(r).Scope_Restriction = subfuncn
|
|
End If 'x
|
|
|
|
|
|
l$ = l$ + sp + tlayout$
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
errorlabels = errorlabels + 1
|
|
Print #12, "error_goto_line=" + str2(errorlabels) + ";"
|
|
Print #14, "if (error_goto_line==" + str2(errorlabels) + "){error_handling=1; goto LABEL_" + lbl$ + ";}"
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
If n >= 1 Then
|
|
If firstelement$ = "RESTORE" Then
|
|
l$ = SCase$("Restore")
|
|
If n = 1 Then
|
|
Print #12, "data_offset=0;"
|
|
Else
|
|
If n > 2 Then a$ = "Syntax error": GoTo errmes
|
|
lbl$ = getelement$(ca$, 2)
|
|
If validlabel(lbl$) = 0 Then a$ = "Invalid label": GoTo errmes
|
|
|
|
'rule: a RESTORE label has no scope, therefore, only one instance of that label may exist
|
|
'how: enforced by a post check for duplicates
|
|
v = HashFind(lbl$, HASHFLAG_LABEL, ignore, r)
|
|
x = 1
|
|
If v Then 'already defined
|
|
x = 0
|
|
tlayout$ = RTrim$(Labels(r).cn)
|
|
Labels(r).Data_Referenced = 1 'make sure the data referenced flag is set
|
|
If Labels(r).Error_Line = 0 Then Labels(r).Error_Line = linenumber
|
|
End If
|
|
If x Then
|
|
nLabels = nLabels + 1: If nLabels > Labels_Ubound Then Labels_Ubound = Labels_Ubound * 2: ReDim _Preserve Labels(1 To Labels_Ubound) As Label_Type
|
|
Labels(nLabels) = Empty_Label
|
|
HashAdd lbl$, HASHFLAG_LABEL, nLabels
|
|
r = nLabels
|
|
Labels(r).State = 0
|
|
Labels(r).cn = tlayout$
|
|
Labels(r).Scope = -1 'modifyable scope
|
|
Labels(r).Error_Line = linenumber
|
|
Labels(r).Data_Referenced = 1
|
|
End If 'x
|
|
|
|
l$ = l$ + sp + tlayout$
|
|
Print #12, "data_offset=data_at_LABEL_" + lbl$ + ";"
|
|
End If
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
'ON ... GOTO/GOSUB
|
|
If n >= 1 Then
|
|
If firstelement$ = "ON" Then
|
|
xongotogosub a$, ca$, n
|
|
If Error_Happened Then GoTo errmes
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
|
|
|
|
'(_MEM) _MEMPUT _MEMGET
|
|
If n >= 1 Then
|
|
If firstelement$ = "_MEMGET" Or (firstelement$ = "MEMGET" And qb64prefix_set = 1) Then
|
|
'get expressions
|
|
e$ = ""
|
|
B = 0
|
|
ne = 0
|
|
For i2 = 2 To n
|
|
e2$ = getelement$(ca$, i2)
|
|
If e2$ = "(" Then B = B + 1
|
|
If e2$ = ")" Then B = B - 1
|
|
If e2$ = "," And B = 0 Then
|
|
ne = ne + 1
|
|
If ne = 1 Then blk$ = e$: e$ = ""
|
|
If ne = 2 Then offs$ = e$: e$ = ""
|
|
If ne = 3 Then a$ = "Syntax error": GoTo errmes
|
|
Else
|
|
If Len(e$) = 0 Then e$ = e2$ Else e$ = e$ + sp + e2$
|
|
End If
|
|
Next
|
|
var$ = e$
|
|
If e$ = "" Or ne <> 2 Then a$ = "Expected " + qb64prefix$ + "MEMGET mem-reference, offset, variable": GoTo errmes
|
|
|
|
If firstelement$ = "_MEMGET" Then l$ = SCase$("_MemGet") + sp Else l$ = SCase$("MemGet") + sp
|
|
|
|
e$ = fixoperationorder$(blk$): If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$
|
|
|
|
test$ = evaluate(e$, typ): If Error_Happened Then GoTo errmes
|
|
If (typ And ISUDT) = 0 Or (typ And 511) <> 1 Then a$ = "Expected " + qb64prefix$ + "MEM type": GoTo errmes
|
|
blkoffs$ = evaluatetotyp(e$, -6)
|
|
|
|
' IF typ AND ISREFERENCE THEN e$ = refer(e$, typ, 0)
|
|
|
|
|
|
'PRINT #12, blkoffs$ '???
|
|
|
|
e$ = fixoperationorder$(offs$): If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$
|
|
e$ = evaluatetotyp(e$, OFFSETTYPE - ISPOINTER): If Error_Happened Then GoTo errmes
|
|
offs$ = e$
|
|
'PRINT #12, e$ '???
|
|
|
|
e$ = fixoperationorder$(var$): If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$
|
|
varsize$ = evaluatetotyp(e$, -5): If Error_Happened Then GoTo errmes
|
|
varoffs$ = evaluatetotyp(e$, -6): If Error_Happened Then GoTo errmes
|
|
|
|
|
|
'PRINT #12, varoffs$ '???
|
|
'PRINT #12, varsize$ '???
|
|
|
|
'what do we do next
|
|
'need to know offset of variable and its size
|
|
|
|
'known sizes will be handled by designated command casts, otherwise use memmove
|
|
s = 0
|
|
If varsize$ = "1" Then s = 1: st$ = "int8"
|
|
If varsize$ = "2" Then s = 2: st$ = "int16"
|
|
If varsize$ = "4" Then s = 4: st$ = "int32"
|
|
If varsize$ = "8" Then s = 8: st$ = "int64"
|
|
|
|
If NoChecks Then
|
|
'fast version:
|
|
If s Then
|
|
Print #12, "*(" + st$ + "*)" + varoffs$ + "=*(" + st$ + "*)(" + offs$ + ");"
|
|
Else
|
|
Print #12, "memmove(" + varoffs$ + ",(void*)" + offs$ + "," + varsize$ + ");"
|
|
End If
|
|
Else
|
|
'safe version:
|
|
Print #12, "tmp_long=" + offs$ + ";"
|
|
'is mem block init?
|
|
Print #12, "if ( ((mem_block*)(" + blkoffs$ + "))->lock_offset ){"
|
|
'are region and id valid?
|
|
Print #12, "if ("
|
|
Print #12, "tmp_long < ((mem_block*)(" + blkoffs$ + "))->offset ||"
|
|
Print #12, "(tmp_long+(" + varsize$ + ")) > ( ((mem_block*)(" + blkoffs$ + "))->offset + ((mem_block*)(" + blkoffs$ + "))->size) ||"
|
|
Print #12, "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id ){"
|
|
'diagnose error
|
|
Print #12, "if (" + "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id" + ") error(308); else error(300);"
|
|
Print #12, "}else{"
|
|
If s Then
|
|
Print #12, "*(" + st$ + "*)" + varoffs$ + "=*(" + st$ + "*)tmp_long;"
|
|
Else
|
|
Print #12, "memmove(" + varoffs$ + ",(void*)tmp_long," + varsize$ + ");"
|
|
End If
|
|
Print #12, "}"
|
|
Print #12, "}else error(309);"
|
|
End If
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
If n >= 1 Then
|
|
If firstelement$ = "_MEMPUT" Or (firstelement$ = "MEMPUT" And qb64prefix_set = 1) Then
|
|
'get expressions
|
|
typ$ = ""
|
|
e$ = ""
|
|
B = 0
|
|
ne = 0
|
|
For i2 = 2 To n
|
|
e2$ = getelement$(ca$, i2)
|
|
If e2$ = "(" Then B = B + 1
|
|
If e2$ = ")" Then B = B - 1
|
|
If (e2$ = "," Or UCase$(e2$) = "AS") And B = 0 Then
|
|
ne = ne + 1
|
|
If ne = 1 Then blk$ = e$: e$ = ""
|
|
If ne = 2 Then offs$ = e$: e$ = ""
|
|
If ne = 3 Then var$ = e$: e$ = ""
|
|
If (UCase$(e2$) = "AS" And ne <> 3) Or (ne = 3 And UCase$(e2$) <> "AS") Or ne = 4 Then a$ = "Expected _MEMPUT mem-reference,offset,variable|value[AS type]": GoTo errmes
|
|
Else
|
|
If Len(e$) = 0 Then e$ = e2$ Else e$ = e$ + sp + e2$
|
|
End If
|
|
Next
|
|
If ne < 2 Or e$ = "" Then a$ = "Expected " + qb64prefix$ + "MEMPUT mem-reference, offset, variable|value[AS type]": GoTo errmes
|
|
If ne = 2 Then var$ = e$ Else typ$ = UCase$(e$)
|
|
|
|
If firstelement$ = "_MEMPUT" Then l$ = SCase$("_MemPut") + sp Else l$ = SCase$("MemPut") + sp
|
|
|
|
e$ = fixoperationorder$(blk$): If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$
|
|
|
|
test$ = evaluate(e$, typ): If Error_Happened Then GoTo errmes
|
|
If (typ And ISUDT) = 0 Or (typ And 511) <> 1 Then a$ = "Expected " + qb64prefix$ + "MEM type": GoTo errmes
|
|
blkoffs$ = evaluatetotyp(e$, -6)
|
|
|
|
e$ = fixoperationorder$(offs$): If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$
|
|
e$ = evaluatetotyp(e$, OFFSETTYPE - ISPOINTER): If Error_Happened Then GoTo errmes
|
|
offs$ = e$
|
|
|
|
If ne = 2 Then
|
|
e$ = fixoperationorder$(var$): If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$
|
|
|
|
test$ = evaluate(e$, t): If Error_Happened Then GoTo errmes
|
|
If (t And ISREFERENCE) = 0 And (t And ISSTRING) Then
|
|
Print #12, "g_tmp_str=" + test$ + ";"
|
|
varsize$ = "g_tmp_str->len"
|
|
varoffs$ = "g_tmp_str->chr"
|
|
Else
|
|
varsize$ = evaluatetotyp(e$, -5): If Error_Happened Then GoTo errmes
|
|
varoffs$ = evaluatetotyp(e$, -6): If Error_Happened Then GoTo errmes
|
|
End If
|
|
|
|
'known sizes will be handled by designated command casts, otherwise use memmove
|
|
s = 0
|
|
If varsize$ = "1" Then s = 1: st$ = "int8"
|
|
If varsize$ = "2" Then s = 2: st$ = "int16"
|
|
If varsize$ = "4" Then s = 4: st$ = "int32"
|
|
If varsize$ = "8" Then s = 8: st$ = "int64"
|
|
|
|
If NoChecks Then
|
|
'fast version:
|
|
If s Then
|
|
Print #12, "*(" + st$ + "*)(" + offs$ + ")=*(" + st$ + "*)" + varoffs$ + ";"
|
|
Else
|
|
Print #12, "memmove((void*)" + offs$ + "," + varoffs$ + "," + varsize$ + ");"
|
|
End If
|
|
Else
|
|
'safe version:
|
|
Print #12, "tmp_long=" + offs$ + ";"
|
|
'is mem block init?
|
|
Print #12, "if ( ((mem_block*)(" + blkoffs$ + "))->lock_offset ){"
|
|
'are region and id valid?
|
|
Print #12, "if ("
|
|
Print #12, "tmp_long < ((mem_block*)(" + blkoffs$ + "))->offset ||"
|
|
Print #12, "(tmp_long+(" + varsize$ + ")) > ( ((mem_block*)(" + blkoffs$ + "))->offset + ((mem_block*)(" + blkoffs$ + "))->size) ||"
|
|
Print #12, "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id ){"
|
|
'diagnose error
|
|
Print #12, "if (" + "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id" + ") error(308); else error(300);"
|
|
Print #12, "}else{"
|
|
If s Then
|
|
Print #12, "*(" + st$ + "*)tmp_long=*(" + st$ + "*)" + varoffs$ + ";"
|
|
Else
|
|
Print #12, "memmove((void*)tmp_long," + varoffs$ + "," + varsize$ + ");"
|
|
End If
|
|
Print #12, "}"
|
|
Print #12, "}else error(309);"
|
|
End If
|
|
|
|
Else
|
|
|
|
'... AS type method
|
|
'FUNCTION typname2typ& (t2$)
|
|
'typname2typsize = 0 'the default
|
|
t = typname2typ(typ$)
|
|
If t = 0 Then a$ = "Invalid type": GoTo errmes
|
|
If (t And ISOFFSETINBITS) <> 0 Or (t And ISUDT) <> 0 Or (t And ISSTRING) Then a$ = qb64prefix$ + "MEMPUT requires numeric type": GoTo errmes
|
|
If (t And ISPOINTER) Then t = t - ISPOINTER
|
|
'attempt conversion...
|
|
e$ = fixoperationorder$(var$): If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$ + sp + SCase$("As") + sp + typ$
|
|
e$ = evaluatetotyp(e$, t): If Error_Happened Then GoTo errmes
|
|
st$ = typ2ctyp$(t, "")
|
|
varsize$ = str2((t And 511) \ 8)
|
|
If NoChecks Then
|
|
'fast version:
|
|
Print #12, "*(" + st$ + "*)(" + offs$ + ")=" + e$ + ";"
|
|
Else
|
|
'safe version:
|
|
Print #12, "tmp_long=" + offs$ + ";"
|
|
'is mem block init?
|
|
Print #12, "if ( ((mem_block*)(" + blkoffs$ + "))->lock_offset ){"
|
|
'are region and id valid?
|
|
Print #12, "if ("
|
|
Print #12, "tmp_long < ((mem_block*)(" + blkoffs$ + "))->offset ||"
|
|
Print #12, "(tmp_long+(" + varsize$ + ")) > ( ((mem_block*)(" + blkoffs$ + "))->offset + ((mem_block*)(" + blkoffs$ + "))->size) ||"
|
|
Print #12, "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id ){"
|
|
'diagnose error
|
|
Print #12, "if (" + "((mem_lock*)((mem_block*)(" + blkoffs$ + "))->lock_offset)->id != ((mem_block*)(" + blkoffs$ + "))->lock_id" + ") error(308); else error(300);"
|
|
Print #12, "}else{"
|
|
Print #12, "*(" + st$ + "*)tmp_long=" + e$ + ";"
|
|
Print #12, "}"
|
|
Print #12, "}else error(309);"
|
|
End If
|
|
|
|
End If
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
If n >= 1 Then
|
|
If firstelement$ = "_MEMFILL" Or (firstelement$ = "MEMFILL" And qb64prefix_set = 1) Then
|
|
'get expressions
|
|
typ$ = ""
|
|
e$ = ""
|
|
B = 0
|
|
ne = 0
|
|
For i2 = 2 To n
|
|
e2$ = getelement$(ca$, i2)
|
|
If e2$ = "(" Then B = B + 1
|
|
If e2$ = ")" Then B = B - 1
|
|
If (e2$ = "," Or UCase$(e2$) = "AS") And B = 0 Then
|
|
ne = ne + 1
|
|
If ne = 1 Then blk$ = e$: e$ = ""
|
|
If ne = 2 Then offs$ = e$: e$ = ""
|
|
If ne = 3 Then bytes$ = e$: e$ = ""
|
|
If ne = 4 Then var$ = e$: e$ = ""
|
|
If (UCase$(e2$) = "AS" And ne <> 4) Or (ne = 4 And UCase$(e2$) <> "AS") Or ne = 5 Then a$ = "Expected _MEMFILL mem-reference,offset,bytes,variable|value[AS type]": GoTo errmes
|
|
Else
|
|
If Len(e$) = 0 Then e$ = e2$ Else e$ = e$ + sp + e2$
|
|
End If
|
|
Next
|
|
If ne < 3 Or e$ = "" Then a$ = "Expected " + qb64prefix$ + "MEMFILL mem-reference, offset, bytes, variable|value[AS type]": GoTo errmes
|
|
If ne = 3 Then var$ = e$ Else typ$ = UCase$(e$)
|
|
|
|
If firstelement$ = "_MEMFILL" Then l$ = SCase$("_MemFill") + sp Else l$ = SCase$("MemFill") + sp
|
|
|
|
e$ = fixoperationorder$(blk$): If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$
|
|
|
|
test$ = evaluate(e$, typ): If Error_Happened Then GoTo errmes
|
|
If (typ And ISUDT) = 0 Or (typ And 511) <> 1 Then a$ = "Expected " + qb64prefix$ + "MEM type": GoTo errmes
|
|
blkoffs$ = evaluatetotyp(e$, -6)
|
|
|
|
e$ = fixoperationorder$(offs$): If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$
|
|
e$ = evaluatetotyp(e$, OFFSETTYPE - ISPOINTER): If Error_Happened Then GoTo errmes
|
|
offs$ = e$
|
|
|
|
e$ = fixoperationorder$(bytes$): If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$
|
|
e$ = evaluatetotyp(e$, OFFSETTYPE - ISPOINTER): If Error_Happened Then GoTo errmes
|
|
bytes$ = e$
|
|
|
|
If ne = 3 Then 'no AS
|
|
e$ = fixoperationorder$(var$): If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$
|
|
test$ = evaluate(e$, t)
|
|
If (t And ISREFERENCE) = 0 And (t And ISSTRING) Then
|
|
Print #12, "tmp_long=(ptrszint)" + test$ + ";"
|
|
varsize$ = "((qbs*)tmp_long)->len"
|
|
varoffs$ = "((qbs*)tmp_long)->chr"
|
|
Else
|
|
varsize$ = evaluatetotyp(e$, -5): If Error_Happened Then GoTo errmes
|
|
varoffs$ = evaluatetotyp(e$, -6): If Error_Happened Then GoTo errmes
|
|
End If
|
|
|
|
If NoChecks Then
|
|
Print #12, "sub__memfill_nochecks(" + offs$ + "," + bytes$ + ",(ptrszint)" + varoffs$ + "," + varsize$ + ");"
|
|
Else
|
|
Print #12, "sub__memfill((mem_block*)" + blkoffs$ + "," + offs$ + "," + bytes$ + ",(ptrszint)" + varoffs$ + "," + varsize$ + ");"
|
|
End If
|
|
|
|
Else
|
|
|
|
'... AS type method
|
|
t = typname2typ(typ$)
|
|
If t = 0 Then a$ = "Invalid type": GoTo errmes
|
|
If (t And ISOFFSETINBITS) <> 0 Or (t And ISUDT) <> 0 Or (t And ISSTRING) Then a$ = qb64prefix$ + "MEMFILL requires numeric type": GoTo errmes
|
|
If (t And ISPOINTER) Then t = t - ISPOINTER
|
|
'attempt conversion...
|
|
e$ = fixoperationorder$(var$): If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$ + sp + SCase$("As") + sp + typ$
|
|
e$ = evaluatetotyp(e$, t): If Error_Happened Then GoTo errmes
|
|
|
|
c$ = "sub__memfill_"
|
|
If NoChecks Then c$ = "sub__memfill_nochecks_"
|
|
If t And ISOFFSET Then
|
|
c$ = c$ + "OFFSET"
|
|
Else
|
|
If t And ISFLOAT Then
|
|
If (t And 511) = 32 Then c$ = c$ + "SINGLE"
|
|
If (t And 511) = 64 Then c$ = c$ + "DOUBLE"
|
|
If (t And 511) = 256 Then c$ = c$ + "FLOAT" 'padded variable
|
|
Else
|
|
c$ = c$ + str2((t And 511) \ 8)
|
|
End If
|
|
End If
|
|
c$ = c$ + "("
|
|
If NoChecks = 0 Then c$ = c$ + "(mem_block*)" + blkoffs$ + ","
|
|
Print #12, c$ + offs$ + "," + bytes$ + "," + e$ + ");"
|
|
End If
|
|
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
'note: ABSOLUTE cannot be used without CALL
|
|
cispecial = 0
|
|
If n > 1 Then
|
|
If firstelement$ = "INTERRUPT" Or firstelement$ = "INTERRUPTX" Then
|
|
a$ = "CALL" + sp + firstelement$ + sp + "(" + sp + getelements$(a$, 2, n) + sp + ")"
|
|
ca$ = "CALL" + sp + firstelement$ + sp + "(" + sp + getelements$(ca$, 2, n) + sp + ")"
|
|
n = n + 3
|
|
firstelement$ = "CALL"
|
|
cispecial = 1
|
|
'fall through
|
|
End If
|
|
End If
|
|
|
|
usecall = 0
|
|
If firstelement$ = "CALL" Then
|
|
usecall = 1
|
|
If n = 1 Then a$ = "Expected CALL sub-name [(...)]": GoTo errmes
|
|
cn$ = getelement$(ca$, 2): n$ = UCase$(cn$)
|
|
|
|
If n > 2 Then
|
|
|
|
If n <= 4 Then a$ = "Expected CALL sub-name (...)": GoTo errmes
|
|
If getelement$(a$, 3) <> "(" Or getelement$(a$, n) <> ")" Then a$ = "Expected CALL sub-name (...)": GoTo errmes
|
|
a$ = n$ + sp + getelements$(a$, 4, n - 1)
|
|
ca$ = cn$ + sp + getelements$(ca$, 4, n - 1)
|
|
|
|
|
|
If n$ = "INTERRUPT" Or n$ = "INTERRUPTX" Then 'assume CALL INTERRUPT[X] request
|
|
'print "CI: call interrupt command reached":sleep 1
|
|
If n$ = "INTERRUPT" Then Print #12, "call_interrupt("; Else Print #12, "call_interruptx(";
|
|
argn = 0
|
|
n = numelements(a$)
|
|
B = 0
|
|
e$ = ""
|
|
For i = 2 To n
|
|
e2$ = getelement$(ca$, i)
|
|
If e2$ = "(" Then B = B + 1
|
|
If e2$ = ")" Then B = B - 1
|
|
If (e2$ = "," And B = 0) Or i = n Then
|
|
If i = n Then
|
|
If e$ = "" Then e$ = e2$ Else e$ = e$ + sp + e2$
|
|
End If
|
|
argn = argn + 1
|
|
If argn = 1 Then 'interrupt number
|
|
e$ = fixoperationorder$(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = SCase$("Call") + sp + n$ + sp2 + "(" + sp2 + tlayout$
|
|
If cispecial = 1 Then l$ = n$ + sp + tlayout$
|
|
e$ = evaluatetotyp(e$, 64&)
|
|
If Error_Happened Then GoTo errmes
|
|
'print "CI: evaluated interrupt number as ["+e$+"]":sleep 1
|
|
Print #12, e$;
|
|
End If
|
|
If argn = 2 Or argn = 3 Then 'inregs, outregs
|
|
e$ = fixoperationorder$(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$
|
|
e2$ = e$
|
|
e$ = evaluatetotyp(e$, -2) 'offset+size
|
|
If Error_Happened Then GoTo errmes
|
|
'print "CI: evaluated in/out regs ["+e2$+"] as ["+e$+"]":sleep 1
|
|
Print #12, "," + e$;
|
|
End If
|
|
e$ = ""
|
|
Else
|
|
If e$ = "" Then e$ = e2$ Else e$ = e$ + sp + e2$
|
|
End If
|
|
Next
|
|
If argn <> 3 Then a$ = "Expected CALL INTERRUPT (interrupt-no, inregs, outregs)": GoTo errmes
|
|
Print #12, ");"
|
|
If cispecial = 0 Then l$ = l$ + sp2 + ")"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
'print "CI: done":sleep 1
|
|
GoTo finishedline
|
|
End If 'call interrupt
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
'call to CALL ABSOLUTE beyond reasonable doubt
|
|
If n$ = "ABSOLUTE" Then
|
|
l$ = SCase$("Call" + sp + "Absolute" + sp2 + "(" + sp2)
|
|
argn = 0
|
|
n = numelements(a$)
|
|
B = 0
|
|
e$ = ""
|
|
For i = 2 To n
|
|
e2$ = getelement$(ca$, i)
|
|
If e2$ = "(" Then B = B + 1
|
|
If e2$ = ")" Then B = B - 1
|
|
If (e2$ = "," And B = 0) Or i = n Then
|
|
If i < n Then
|
|
If e$ = "" Then a$ = "Expected expression before , or )": GoTo errmes
|
|
'1. variable or value?
|
|
e$ = fixoperationorder$(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$ + sp2 + "," + sp
|
|
ignore$ = evaluate(e$, typ)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
If (typ And ISPOINTER) <> 0 And (typ And ISREFERENCE) <> 0 Then
|
|
|
|
'assume standard variable
|
|
'assume not string/array/udt/etc
|
|
e$ = "VARPTR" + sp + "(" + sp + e$ + sp + ")"
|
|
e$ = evaluatetotyp(e$, UINTEGERTYPE - ISPOINTER)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
Else
|
|
|
|
'assume not string
|
|
'single, double or integer64?
|
|
If typ And ISFLOAT Then
|
|
If (typ And 511) = 32 Then
|
|
e$ = evaluatetotyp(e$, SINGLETYPE - ISPOINTER)
|
|
If Error_Happened Then GoTo errmes
|
|
v$ = "pass" + str2$(uniquenumber)
|
|
Print #defdatahandle, "float *" + v$ + "=NULL;"
|
|
Print #13, "if(" + v$ + "==NULL){"
|
|
Print #13, "cmem_sp-=4;"
|
|
Print #13, v$ + "=(float*)(dblock+cmem_sp);"
|
|
Print #13, "if (cmem_sp<qbs_cmem_sp) error(257);"
|
|
Print #13, "}"
|
|
e$ = "(uint16)(((uint8*)&(*" + v$ + "=" + e$ + "))-((uint8*)dblock))"
|
|
Else
|
|
e$ = evaluatetotyp(e$, DOUBLETYPE - ISPOINTER)
|
|
If Error_Happened Then GoTo errmes
|
|
v$ = "pass" + str2$(uniquenumber)
|
|
Print #defdatahandle, "double *" + v$ + "=NULL;"
|
|
Print #13, "if(" + v$ + "==NULL){"
|
|
Print #13, "cmem_sp-=8;"
|
|
Print #13, v$ + "=(double*)(dblock+cmem_sp);"
|
|
Print #13, "if (cmem_sp<qbs_cmem_sp) error(257);"
|
|
Print #13, "}"
|
|
e$ = "(uint16)(((uint8*)&(*" + v$ + "=" + e$ + "))-((uint8*)dblock))"
|
|
End If
|
|
Else
|
|
e$ = evaluatetotyp(e$, INTEGER64TYPE - ISPOINTER)
|
|
If Error_Happened Then GoTo errmes
|
|
v$ = "pass" + str2$(uniquenumber)
|
|
Print #defdatahandle, "int64 *" + v$ + "=NULL;"
|
|
Print #13, "if(" + v$ + "==NULL){"
|
|
Print #13, "cmem_sp-=8;"
|
|
Print #13, v$ + "=(int64*)(dblock+cmem_sp);"
|
|
Print #13, "if (cmem_sp<qbs_cmem_sp) error(257);"
|
|
Print #13, "}"
|
|
e$ = "(uint16)(((uint8*)&(*" + v$ + "=" + e$ + "))-((uint8*)dblock))"
|
|
End If
|
|
|
|
End If
|
|
|
|
Print #12, "call_absolute_offsets[" + str2$(argn) + "]=" + e$ + ";"
|
|
Else
|
|
If e$ = "" Then e$ = e2$ Else e$ = e$ + sp + e2$
|
|
e$ = fixoperationorder(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$ + sp2 + ")"
|
|
e$ = evaluatetotyp(e$, UINTEGERTYPE - ISPOINTER)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "call_absolute(" + str2$(argn) + "," + e$ + ");"
|
|
End If
|
|
argn = argn + 1
|
|
e$ = ""
|
|
Else
|
|
If e$ = "" Then e$ = e2$ Else e$ = e$ + sp + e2$
|
|
End If
|
|
Next
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
|
|
Else 'n>2
|
|
|
|
a$ = n$
|
|
ca$ = cn$
|
|
usecall = 2
|
|
|
|
End If 'n>2
|
|
|
|
n = numelements(a$)
|
|
firstelement$ = getelement$(a$, 1)
|
|
|
|
'valid SUB name
|
|
validsub = 0
|
|
findidsecondarg = "": If n >= 2 Then findidsecondarg = getelement$(a$, 2)
|
|
try = findid(firstelement$)
|
|
If Error_Happened Then GoTo errmes
|
|
Do While try
|
|
If id.subfunc = 2 Then validsub = 1: Exit Do
|
|
If try = 2 Then
|
|
findidsecondarg = "": If n >= 2 Then findidsecondarg = getelement$(a$, 2)
|
|
findanotherid = 1
|
|
try = findid(firstelement$)
|
|
If Error_Happened Then GoTo errmes
|
|
Else
|
|
try = 0
|
|
End If
|
|
Loop
|
|
If validsub = 0 Then a$ = "Expected CALL sub-name [(...)]": GoTo errmes
|
|
End If
|
|
|
|
'sub?
|
|
If n >= 1 Then
|
|
|
|
If firstelement$ = "?" Then firstelement$ = "PRINT"
|
|
|
|
findidsecondarg = "": If n >= 2 Then findidsecondarg = getelement$(a$, 2)
|
|
try = findid(firstelement$)
|
|
If Error_Happened Then GoTo errmes
|
|
Do While try
|
|
If id.subfunc = 2 Then
|
|
|
|
'check symbol
|
|
s$ = removesymbol$(firstelement$ + "")
|
|
If Error_Happened Then GoTo errmes
|
|
If Asc(id.musthave) = 36 Then '="$"
|
|
If s$ <> "$" Then GoTo notsubcall 'missing musthave "$"
|
|
Else
|
|
If Len(s$) Then GoTo notsubcall 'unrequired symbol added
|
|
End If
|
|
'check for variable assignment
|
|
If n > 1 Then
|
|
If Asc(id.specialformat) <> 61 Then '<>"="
|
|
If Asc(getelement$(a$, 2)) = 61 Then GoTo notsubcall 'assignment, not sub call
|
|
End If
|
|
End If
|
|
'check for array assignment
|
|
If n > 2 Then
|
|
If firstelement$ <> "PRINT" And firstelement$ <> "LPRINT" Then
|
|
If getelement$(a$, 2) = "(" Then
|
|
B = 1
|
|
For i = 3 To n
|
|
e$ = getelement$(a$, i)
|
|
If e$ = "(" Then B = B + 1
|
|
If e$ = ")" Then
|
|
B = B - 1
|
|
If B = 0 Then
|
|
If i = n Then Exit For
|
|
If getelement$(a$, i + 1) = "=" Then GoTo notsubcall
|
|
End If
|
|
End If
|
|
Next
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
|
|
'generate error on driect _GL call
|
|
If firstelement$ = "_GL" Then
|
|
a$ = "Cannot call SUB _GL directly": GoTo errmes
|
|
End If
|
|
|
|
If firstelement$ = "OPEN" Then
|
|
'gwbasic or qbasic version?
|
|
B = 0
|
|
For x = 2 To n
|
|
a2$ = getelement$(a$, x)
|
|
If a2$ = "(" Then B = B + 1
|
|
If a2$ = ")" Then B = B - 1
|
|
If a2$ = "FOR" Or a2$ = "AS" Then Exit For 'qb style open verified
|
|
If B = 0 And a2$ = "," Then 'the gwbasic version includes a comma after the first string expression
|
|
findanotherid = 1
|
|
try = findid(firstelement$) 'id of sub_open_gwbasic
|
|
If Error_Happened Then GoTo errmes
|
|
Exit For
|
|
End If
|
|
Next
|
|
End If
|
|
|
|
|
|
'IF findid(firstelement$) THEN
|
|
'IF id.subfunc = 2 THEN
|
|
|
|
|
|
If firstelement$ = "CLOSE" Or firstelement$ = "RESET" Then
|
|
If firstelement$ = "RESET" Then
|
|
If n > 1 Then a$ = "Syntax error": GoTo errmes
|
|
l$ = SCase$("Reset")
|
|
Else
|
|
l$ = SCase$("Close")
|
|
End If
|
|
|
|
If n = 1 Then
|
|
Print #12, "sub_close(NULL,0);" 'closes all files
|
|
Else
|
|
l$ = l$ + sp
|
|
B = 0
|
|
s = 0
|
|
a3$ = ""
|
|
For x = 2 To n
|
|
a2$ = getelement$(ca$, x)
|
|
If a2$ = "(" Then B = B + 1
|
|
If a2$ = ")" Then B = B - 1
|
|
If a2$ = "#" And B = 0 Then
|
|
If s = 0 Then s = 1 Else a$ = "Unexpected #": GoTo errmes
|
|
l$ = l$ + "#" + sp2
|
|
GoTo closenexta
|
|
End If
|
|
|
|
If a2$ = "," And B = 0 Then
|
|
If s = 2 Then
|
|
e$ = fixoperationorder$(a3$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$ + sp2 + "," + sp
|
|
e$ = evaluatetotyp(e$, 64&)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "sub_close(" + e$ + ",1);"
|
|
a3$ = ""
|
|
s = 0
|
|
GoTo closenexta
|
|
Else
|
|
a$ = "Expected expression before ,": GoTo errmes
|
|
End If
|
|
End If
|
|
|
|
s = 2
|
|
If a3$ = "" Then a3$ = a2$ Else a3$ = a3$ + sp + a2$
|
|
|
|
closenexta:
|
|
Next
|
|
|
|
If s = 2 Then
|
|
e$ = fixoperationorder$(a3$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + tlayout$
|
|
e$ = evaluatetotyp(e$, 64&)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "sub_close(" + e$ + ",1);"
|
|
Else
|
|
l$ = Left$(l$, Len(l$) - 1)
|
|
End If
|
|
|
|
End If
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If 'close
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
'data, restore, read
|
|
If firstelement$ = "READ" Then 'file input
|
|
xread ca$, n
|
|
If Error_Happened Then GoTo errmes
|
|
'note: layout done in xread sub
|
|
GoTo finishedline
|
|
End If 'read
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
lineinput = 0
|
|
If n >= 2 Then
|
|
If firstelement$ = "LINE" And secondelement$ = "INPUT" Then
|
|
lineinput = 1
|
|
a$ = Right$(a$, Len(a$) - 5): ca$ = Right$(ca$, Len(ca$) - 5): n = n - 1 'remove "LINE"
|
|
firstelement$ = "INPUT"
|
|
End If
|
|
End If
|
|
|
|
If firstelement$ = "INPUT" Then 'file input
|
|
If n > 1 Then
|
|
If getelement$(a$, 2) = "#" Then
|
|
l$ = SCase$("Input") + sp + "#": If lineinput Then l$ = SCase$("Line") + sp + l$
|
|
|
|
u$ = str2$(uniquenumber)
|
|
'which file?
|
|
If n = 2 Then a$ = "Expected # ... , ...": GoTo errmes
|
|
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 a$ = "Expected # ... , ...": GoTo errmes
|
|
GoTo inputgotfn
|
|
End If
|
|
If a3$ = "" Then a3$ = a2$ Else a3$ = a3$ + sp + a2$
|
|
Next
|
|
inputgotfn:
|
|
e$ = fixoperationorder$(a3$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + tlayout$
|
|
e$ = evaluatetotyp(e$, 64&)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "tmp_fileno=" + e$ + ";"
|
|
Print #12, "if (new_error) goto skip" + u$ + ";"
|
|
i = i + 1
|
|
If i > n Then a$ = "Expected , ...": GoTo errmes
|
|
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 i = n Then
|
|
If a3$ = "" Then a3$ = a2$ Else a3$ = a3$ + sp + a2$
|
|
a2$ = ",": B = 0
|
|
End If
|
|
If a2$ = "," And B = 0 Then
|
|
If a3$ = "" Then a$ = "Expected , ...": GoTo errmes
|
|
e$ = fixoperationorder$(a3$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp2 + "," + sp + tlayout$
|
|
e$ = evaluate(e$, t)
|
|
If Error_Happened Then GoTo errmes
|
|
If (t And ISREFERENCE) = 0 Then a$ = "Expected variable-name": GoTo errmes
|
|
If (t And ISSTRING) Then
|
|
e$ = refer(e$, t, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
If lineinput Then
|
|
Print #12, "sub_file_line_input_string(tmp_fileno," + e$ + ");"
|
|
Print #12, "if (new_error) goto skip" + u$ + ";"
|
|
Else
|
|
Print #12, "sub_file_input_string(tmp_fileno," + e$ + ");"
|
|
Print #12, "if (new_error) goto skip" + u$ + ";"
|
|
End If
|
|
stringprocessinghappened = 1
|
|
Else
|
|
If lineinput Then a$ = "Expected string-variable": GoTo errmes
|
|
|
|
'numeric variable
|
|
If (t And ISFLOAT) <> 0 Or (t And 511) <> 64 Then
|
|
If (t And ISOFFSETINBITS) Then
|
|
setrefer e$, t, "((int64)func_file_input_float(tmp_fileno," + str2(t) + "))", 1
|
|
If Error_Happened Then GoTo errmes
|
|
Else
|
|
setrefer e$, t, "func_file_input_float(tmp_fileno," + str2(t) + ")", 1
|
|
If Error_Happened Then GoTo errmes
|
|
End If
|
|
Else
|
|
If t And ISUNSIGNED Then
|
|
setrefer e$, t, "func_file_input_uint64(tmp_fileno)", 1
|
|
If Error_Happened Then GoTo errmes
|
|
Else
|
|
setrefer e$, t, "func_file_input_int64(tmp_fileno)", 1
|
|
If Error_Happened Then GoTo errmes
|
|
End If
|
|
End If
|
|
|
|
Print #12, "if (new_error) goto skip" + u$ + ";"
|
|
|
|
End If
|
|
If i = n Then Exit For
|
|
If lineinput Then a$ = "Too many variables": GoTo errmes
|
|
a3$ = "": a2$ = ""
|
|
End If
|
|
If a3$ = "" Then a3$ = a2$ Else a3$ = a3$ + sp + a2$
|
|
Next
|
|
Print #12, "skip" + u$ + ":"
|
|
If stringprocessinghappened Then Print #12, cleanupstringprocessingcall$ + "0);"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
End If
|
|
End If 'input#
|
|
|
|
|
|
If firstelement$ = "INPUT" Then
|
|
l$ = SCase$("Input"): If lineinput Then l$ = SCase$("Line") + sp + l$
|
|
commaneeded = 0
|
|
i = 2
|
|
|
|
newline = 1: If getelement$(a$, i) = ";" Then newline = 0: i = i + 1: l$ = l$ + sp + ";"
|
|
|
|
a2$ = getelement$(ca$, i)
|
|
If Left$(a2$, 1) = Chr$(34) Then
|
|
e$ = fixoperationorder$(a2$): l$ = l$ + sp + tlayout$
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "qbs_print(qbs_new_txt_len(" + a2$ + "),0);"
|
|
i = i + 1
|
|
'MUST be followed by a ; or ,
|
|
a2$ = getelement$(ca$, i)
|
|
i = i + 1
|
|
l$ = l$ + sp2 + a2$
|
|
If a2$ = ";" Then
|
|
If lineinput Then GoTo finishedpromptstring
|
|
Print #12, "qbs_print(qbs_new_txt(" + Chr$(34) + "? " + Chr$(34) + "),0);"
|
|
GoTo finishedpromptstring
|
|
End If
|
|
If a2$ = "," Then
|
|
GoTo finishedpromptstring
|
|
End If
|
|
a$ = "INPUT STATEMENT: SYNTAX ERROR!": GoTo errmes
|
|
End If
|
|
'there was no promptstring, so print a ?
|
|
If lineinput = 0 Then Print #12, "qbs_print(qbs_new_txt(" + Chr$(34) + "? " + Chr$(34) + "),0);"
|
|
finishedpromptstring:
|
|
numvar = 0
|
|
For i = i To n
|
|
If commaneeded = 1 Then
|
|
a2$ = getelement$(ca$, i)
|
|
If a2$ <> "," Then a$ = "INPUT STATEMENT: SYNTAX ERROR! (COMMA EXPECTED)": GoTo errmes
|
|
Else
|
|
|
|
B = 0
|
|
e$ = ""
|
|
For i2 = i To n
|
|
e2$ = getelement$(ca$, i2)
|
|
If e2$ = "(" Then B = B + 1
|
|
If e2$ = ")" Then B = B - 1
|
|
If e2$ = "," And B = 0 Then i2 = i2 - 1: Exit For
|
|
e$ = e$ + sp + e2$
|
|
Next
|
|
i = i2: If i > n Then i = n
|
|
If e$ = "" Then a$ = "Expected variable": GoTo errmes
|
|
e$ = Right$(e$, Len(e$) - 1)
|
|
e$ = fixoperationorder$(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + tlayout$: If i <> n Then l$ = l$ + sp2 + ","
|
|
e$ = evaluate(e$, t)
|
|
If Error_Happened Then GoTo errmes
|
|
If (t And ISREFERENCE) = 0 Then a$ = "Expected variable": GoTo errmes
|
|
|
|
If (t And ISSTRING) Then
|
|
e$ = refer(e$, t, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
numvar = numvar + 1
|
|
If lineinput Then
|
|
Print #12, "qbs_input_variabletypes[" + str2(numvar) + "]=ISSTRING+512;"
|
|
Else
|
|
Print #12, "qbs_input_variabletypes[" + str2(numvar) + "]=ISSTRING;"
|
|
End If
|
|
Print #12, "qbs_input_variableoffsets[" + str2(numvar) + "]=" + e$ + ";"
|
|
GoTo gotinputvar
|
|
End If
|
|
|
|
If lineinput Then a$ = "Expected string variable": GoTo errmes
|
|
If (t And ISARRAY) Then
|
|
If (t And ISOFFSETINBITS) Then
|
|
a$ = "INPUT cannot handle BIT array elements yet": GoTo errmes
|
|
End If
|
|
End If
|
|
e$ = "&(" + refer(e$, t, 0) + ")"
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
'remove assumed/unnecessary flags
|
|
If (t And ISPOINTER) Then t = t - ISPOINTER
|
|
If (t And ISINCONVENTIONALMEMORY) Then t = t - ISINCONVENTIONALMEMORY
|
|
If (t And ISREFERENCE) Then t = t - ISREFERENCE
|
|
|
|
'IF (t AND ISOFFSETINBITS) THEN
|
|
'numvar = numvar + 1
|
|
'consider storing the bit offset in unused bits of t
|
|
'PRINT #12, "qbs_input_variabletypes[" + str2(numvar) + "]=" + str2(t) + ";"
|
|
'PRINT #12, "qbs_input_variableoffsets[" + str2(numvar) + "]=" + refer(ref$, typ, 1) + ";"
|
|
'GOTO gotinputvar
|
|
'END IF
|
|
|
|
'assume it is a regular variable
|
|
numvar = numvar + 1
|
|
Print #12, "qbs_input_variabletypes[" + str2(numvar) + "]=" + str2$(t) + ";"
|
|
Print #12, "qbs_input_variableoffsets[" + str2(numvar) + "]=" + e$ + ";"
|
|
GoTo gotinputvar
|
|
|
|
End If
|
|
gotinputvar:
|
|
commaneeded = commaneeded + 1: If commaneeded = 2 Then commaneeded = 0
|
|
Next
|
|
If numvar = 0 Then a$ = "INPUT STATEMENT: SYNTAX ERROR! (NO VARIABLES LISTED FOR INPUT)": GoTo errmes
|
|
If lineinput = 1 And numvar > 1 Then a$ = "Too many variables": GoTo errmes
|
|
Print #12, "qbs_input(" + str2(numvar) + "," + str2$(newline) + ");"
|
|
Print #12, "if (stop_program) end();"
|
|
Print #12, cleanupstringprocessingcall$ + "0);"
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
|
|
|
|
|
|
If firstelement$ = "WRITE" Then 'file write
|
|
If n > 1 Then
|
|
If getelement$(a$, 2) = "#" Then
|
|
xfilewrite ca$, n
|
|
If Error_Happened Then GoTo errmes
|
|
GoTo finishedline
|
|
End If '#
|
|
End If 'n>1
|
|
End If '"write"
|
|
|
|
If firstelement$ = "WRITE" Then 'write
|
|
xwrite ca$, n
|
|
If Error_Happened Then GoTo errmes
|
|
GoTo finishedline
|
|
End If '"write"
|
|
|
|
If firstelement$ = "PRINT" Then 'file print
|
|
If n > 1 Then
|
|
If getelement$(a$, 2) = "#" Then
|
|
xfileprint a$, ca$, n
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = tlayout$
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If '#
|
|
End If 'n>1
|
|
End If '"print"
|
|
|
|
If firstelement$ = "PRINT" Or firstelement$ = "LPRINT" Then
|
|
If secondelement$ <> "USING" Then 'check to see if we need to auto-add semicolons
|
|
elementon = 2
|
|
redosemi:
|
|
For i = elementon To n - 1
|
|
nextchar$ = getelement$(a$, i + 1)
|
|
If nextchar$ <> ";" And nextchar$ <> "," And nextchar$ <> "+" And nextchar$ <> ")" Then
|
|
temp1$ = getelement$(a$, i)
|
|
beginpoint = InStr(beginpoint, temp1$, Chr$(34))
|
|
endpoint = InStr(beginpoint + 1, temp1$, Chr$(34) + ",")
|
|
If beginpoint <> 0 And endpoint <> 0 Then 'if we have both positions
|
|
'Quote without semicolon check (like PRINT "abc"123)
|
|
textlength = endpoint - beginpoint - 1
|
|
textvalue$ = Mid$(temp1$, endpoint + 2, Len(LTrim$(Str$(textlength))))
|
|
If Val(textvalue$) = textlength Then
|
|
insertelements a$, i, ";"
|
|
insertelements ca$, i, ";"
|
|
n = n + 1
|
|
elementon = i + 2 'just a easy way to reduce redundant calls to the routine
|
|
GoTo redosemi
|
|
End If
|
|
End If
|
|
If temp1$ <> "USING" Then
|
|
If Left$(LTrim$(nextchar$), 1) = Chr$(34) Then
|
|
If temp1$ <> ";" And temp1$ <> "," And temp1$ <> "+" And temp1$ <> "(" Then
|
|
insertelements a$, i, ";"
|
|
insertelements ca$, i, ";"
|
|
n = n + 1
|
|
elementon = i + 2 'just a easy way to reduce redundant calls to the routine
|
|
GoTo redosemi
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
Next
|
|
End If
|
|
|
|
xprint a$, ca$, n
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = tlayout$
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
End If
|
|
|
|
|
|
|
|
If firstelement$ = "CLEAR" Then
|
|
If subfunc$ <> "" Then a$ = "CLEAR cannot be used inside a SUB/FUNCTION": GoTo errmes
|
|
End If
|
|
|
|
'LSET/RSET
|
|
If firstelement$ = "LSET" Or firstelement$ = "RSET" Then
|
|
If n = 1 Then a$ = "Expected " + firstelement$ + " ...": GoTo errmes
|
|
If firstelement$ = "LSET" Then l$ = SCase$("LSet") Else l$ = SCase$("RSet")
|
|
dest$ = ""
|
|
source$ = ""
|
|
part = 1
|
|
i = 2
|
|
a3$ = ""
|
|
B = 0
|
|
Do
|
|
If i > n Then
|
|
If part <> 2 Or a3$ = "" Then a$ = "Expected LSET/RSET stringvariable=string": GoTo errmes
|
|
source$ = a3$
|
|
Exit Do
|
|
End If
|
|
a2$ = getelement$(ca$, i)
|
|
If a2$ = "(" Then B = B + 1
|
|
If a2$ = ")" Then B = B - 1
|
|
If a2$ = "=" And B = 0 Then
|
|
If part = 1 Then dest$ = a3$: part = 2: a3$ = "": GoTo lrsetgotpart
|
|
End If
|
|
If Len(a3$) Then a3$ = a3$ + sp + a2$ Else a3$ = a2$
|
|
lrsetgotpart:
|
|
i = i + 1
|
|
Loop
|
|
If dest$ = "" Then a$ = "Expected LSET/RSET stringvariable=string": GoTo errmes
|
|
'check if it is a valid source string
|
|
f$ = fixoperationorder$(dest$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + tlayout$ + sp + "="
|
|
e$ = evaluate(f$, sourcetyp)
|
|
If Error_Happened Then GoTo errmes
|
|
If (sourcetyp And ISREFERENCE) = 0 Or (sourcetyp And ISSTRING) = 0 Then a$ = "LSET/RSET expects a string variable/array-element as its first argument": GoTo errmes
|
|
dest$ = evaluatetotyp(f$, ISSTRING)
|
|
If Error_Happened Then GoTo errmes
|
|
source$ = fixoperationorder$(source$)
|
|
If Error_Happened Then GoTo errmes
|
|
l$ = l$ + sp + tlayout$
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
source$ = evaluatetotyp(source$, ISSTRING)
|
|
If Error_Happened Then GoTo errmes
|
|
If firstelement$ = "LSET" Then
|
|
Print #12, "sub_lset(" + dest$ + "," + source$ + ");"
|
|
Else
|
|
Print #12, "sub_rset(" + dest$ + "," + source$ + ");"
|
|
End If
|
|
GoTo finishedline
|
|
End If
|
|
|
|
'SWAP
|
|
If firstelement$ = "SWAP" Then
|
|
If n < 4 Then a$ = "Expected SWAP ... , ...": GoTo errmes
|
|
B = 0
|
|
ele = 1
|
|
e1$ = ""
|
|
e2$ = ""
|
|
For i = 2 To n
|
|
e$ = getelement$(ca$, i)
|
|
If e$ = "(" Then B = B + 1
|
|
If e$ = ")" Then B = B - 1
|
|
If e$ = "," And B = 0 Then
|
|
If ele = 2 Then a$ = "Expected SWAP ... , ...": GoTo errmes
|
|
ele = 2
|
|
Else
|
|
If ele = 1 Then e1$ = e1$ + sp + e$ Else e2$ = e2$ + sp + e$
|
|
End If
|
|
Next
|
|
If e2$ = "" Then a$ = "Expected SWAP ... , ...": GoTo errmes
|
|
e1$ = Right$(e1$, Len(e1$) - 1): e2$ = Right$(e2$, Len(e2$) - 1)
|
|
|
|
e1$ = fixoperationorder(e1$)
|
|
If Error_Happened Then GoTo errmes
|
|
e1l$ = tlayout$
|
|
e2$ = fixoperationorder(e2$)
|
|
If Error_Happened Then GoTo errmes
|
|
e2l$ = tlayout$
|
|
e1$ = evaluate(e1$, e1typ): e2$ = evaluate(e2$, e2typ)
|
|
If Error_Happened Then GoTo errmes
|
|
If (e1typ And ISREFERENCE) = 0 Or (e2typ And ISREFERENCE) = 0 Then a$ = "Expected variable": GoTo errmes
|
|
|
|
layoutdone = 1
|
|
l$ = SCase$("Swap") + sp + e1l$ + sp2 + "," + sp + e2l$
|
|
If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$
|
|
|
|
'swap strings?
|
|
If (e1typ And ISSTRING) Then
|
|
If (e2typ And ISSTRING) = 0 Then a$ = "Type mismatch": GoTo errmes
|
|
e1$ = refer(e1$, e1typ, 0): e2$ = refer(e2$, e2typ, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "swap_string(" + e1$ + "," + e2$ + ");"
|
|
GoTo finishedline
|
|
End If
|
|
|
|
'swap UDT?
|
|
'note: entire UDTs, unlike thier elements cannot be swapped like standard variables
|
|
' as UDT sizes may vary, and to avoid a malloc operation, QB64 should allocate a buffer
|
|
' in global.txt for the purpose of swapping each UDT type
|
|
|
|
If e1typ And ISUDT Then
|
|
a$ = e1$
|
|
'retrieve ID
|
|
i = InStr(a$, sp3)
|
|
If i Then
|
|
idnumber = Val(Left$(a$, i - 1)): a$ = Right$(a$, Len(a$) - i)
|
|
getid idnumber
|
|
If Error_Happened Then GoTo errmes
|
|
u = Val(a$)
|
|
i = InStr(a$, sp3): a$ = Right$(a$, Len(a$) - i): E = Val(a$)
|
|
i = InStr(a$, sp3): o$ = Right$(a$, Len(a$) - i)
|
|
n$ = "UDT_" + RTrim$(id.n): If id.t = 0 Then n$ = "ARRAY_" + n$ + "[0]"
|
|
If E = 0 Then 'not an element of UDT u
|
|
lhsscope$ = scope$
|
|
e$ = e2$: t2 = e2typ
|
|
If (t2 And ISUDT) = 0 Then a$ = "Expected SWAP with similar user defined type": GoTo errmes
|
|
idnumber2 = Val(e$)
|
|
getid idnumber2
|
|
If Error_Happened Then GoTo errmes
|
|
n2$ = "UDT_" + RTrim$(id.n): If id.t = 0 Then n2$ = "ARRAY_" + n2$ + "[0]"
|
|
i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i): u2 = Val(e$)
|
|
i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i): e2 = Val(e$)
|
|
|
|
i = InStr(e$, sp3): o2$ = Right$(e$, Len(e$) - i)
|
|
'WARNING: u2 may need minor modifications based on e to see if they are the same
|
|
If u <> u2 Or e2 <> 0 Then a$ = "Expected SWAP with similar user defined type": GoTo errmes
|
|
dst$ = "(((char*)" + lhsscope$ + n$ + ")+(" + o$ + "))"
|
|
src$ = "(((char*)" + scope$ + n2$ + ")+(" + o2$ + "))"
|
|
B = udtxsize(u) \ 8
|
|
siz$ = str2$(B)
|
|
If B = 1 Then Print #12, "swap_8(" + src$ + "," + dst$ + ");"
|
|
If B = 2 Then Print #12, "swap_16(" + src$ + "," + dst$ + ");"
|
|
If B = 4 Then Print #12, "swap_32(" + src$ + "," + dst$ + ");"
|
|
If B = 8 Then Print #12, "swap_64(" + src$ + "," + dst$ + ");"
|
|
If B <> 1 And B <> 2 And B <> 4 And B <> 8 Then Print #12, "swap_block(" + src$ + "," + dst$ + "," + siz$ + ");"
|
|
GoTo finishedline
|
|
End If 'e=0
|
|
End If 'i
|
|
End If 'isudt
|
|
|
|
'cull irrelavent flags to make comparison possible
|
|
e1typc = e1typ
|
|
If e1typc And ISPOINTER Then e1typc = e1typc - ISPOINTER
|
|
If e1typc And ISINCONVENTIONALMEMORY Then e1typc = e1typc - ISINCONVENTIONALMEMORY
|
|
If e1typc And ISARRAY Then e1typc = e1typc - ISARRAY
|
|
If e1typc And ISUNSIGNED Then e1typc = e1typc - ISUNSIGNED
|
|
If e1typc And ISUDT Then e1typc = e1typc - ISUDT
|
|
e2typc = e2typ
|
|
If e2typc And ISPOINTER Then e2typc = e2typc - ISPOINTER
|
|
If e2typc And ISINCONVENTIONALMEMORY Then e2typc = e2typc - ISINCONVENTIONALMEMORY
|
|
If e2typc And ISARRAY Then e2typc = e2typc - ISARRAY
|
|
If e2typc And ISUNSIGNED Then e2typc = e2typc - ISUNSIGNED
|
|
If e2typc And ISUDT Then e2typc = e2typc - ISUDT
|
|
If e1typc <> e2typc Then a$ = "Type mismatch": GoTo errmes
|
|
t = e1typ
|
|
If t And ISOFFSETINBITS Then a$ = "Cannot SWAP bit-length variables": GoTo errmes
|
|
B = t And 511
|
|
t$ = str2$(B): If B > 64 Then t$ = "longdouble"
|
|
Print #12, "swap_" + t$ + "(&" + refer(e1$, e1typ, 0) + ",&" + refer(e2$, e2typ, 0) + ");"
|
|
If Error_Happened Then GoTo errmes
|
|
GoTo finishedline
|
|
End If
|
|
|
|
If firstelement$ = "OPTION" Then
|
|
If optionexplicit = 0 Then e$ = " or OPTION " + qb64prefix$ + "EXPLICIT" Else e$ = ""
|
|
If optionexplicitarray = 0 Then e$ = e$ + " or OPTION " + qb64prefix$ + "EXPLICITARRAY"
|
|
If n = 1 Then a$ = "Expected OPTION BASE" + e$: GoTo errmes
|
|
e$ = getelement$(a$, 2)
|
|
Select Case e$
|
|
Case "BASE"
|
|
l$ = getelement$(a$, 3)
|
|
If l$ <> "0" And l$ <> "1" Then a$ = "Expected OPTION BASE 0 or 1": GoTo errmes
|
|
If l$ = "1" Then optionbase = 1 Else optionbase = 0
|
|
l$ = SCase$("Option" + sp + "Base") + sp + l$
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
Case "EXPLICIT", "_EXPLICIT"
|
|
If e$ = "EXPLICIT" And qb64prefix$ = "_" Then
|
|
If optionexplicit = 0 Then e$ = " or OPTION " + qb64prefix$ + "EXPLICIT" Else e$ = ""
|
|
If optionexplicitarray = 0 Then e$ = e$ + " or OPTION " + qb64prefix$ + "EXPLICITARRAY"
|
|
a$ = "Expected OPTION BASE" + e$: GoTo errmes
|
|
End If
|
|
If optionexplicit = -1 And NoIDEMode = 0 Then a$ = "Duplicate OPTION " + qb64prefix$ + "EXPLICIT": GoTo errmes
|
|
If Len(layout$) Then a$ = "OPTION " + qb64prefix$ + "EXPLICIT must come before any other statement": GoTo errmes
|
|
If linenumber > 1 And opex_comments = 0 Then a$ = "OPTION " + qb64prefix$ + "EXPLICIT must come before any other statement": GoTo errmes
|
|
optionexplicit = -1
|
|
l$ = SCase$("Option") + sp
|
|
If e$ = "EXPLICIT" Then l$ = l$ + SCase$("Explicit") Else l$ = l$ + SCase$("_Explicit")
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
Case "EXPLICITARRAY", "_EXPLICITARRAY"
|
|
If e$ = "EXPLICITARRAY" And qb64prefix$ = "_" Then
|
|
If optionexplicit = 0 Then e$ = " or OPTION " + qb64prefix$ + "EXPLICIT" Else e$ = ""
|
|
If optionexplicitarray = 0 Then e$ = e$ + " or OPTION " + qb64prefix$ + "EXPLICITARRAY"
|
|
a$ = "Expected OPTION BASE" + e$: GoTo errmes
|
|
End If
|
|
If optionexplicitarray = -1 And NoIDEMode = 0 Then a$ = "Duplicate OPTION " + qb64prefix$ + "EXPLICITARRAY": GoTo errmes
|
|
If Len(layout$) Then a$ = "OPTION " + qb64prefix$ + "EXPLICITARRAY must come before any other statement": GoTo errmes
|
|
If linenumber > 1 And opex_comments = 0 Then a$ = "OPTION " + qb64prefix$ + "EXPLICITARRAY must come before any other statement": GoTo errmes
|
|
optionexplicitarray = -1
|
|
l$ = SCase$("Option") + sp
|
|
If e$ = "EXPLICITARRAY" Then l$ = l$ + SCase$("ExplicitArray") Else l$ = l$ + SCase$("_ExplicitArray")
|
|
layoutdone = 1: If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
GoTo finishedline
|
|
Case Else
|
|
If optionexplicit = 0 Then e$ = " or OPTION " + qb64prefix$ + "EXPLICIT" Else e$ = ""
|
|
If optionexplicitarray = 0 Then e$ = e$ + " or OPTION " + qb64prefix$ + "EXPLICITARRAY"
|
|
a$ = "Expected OPTION BASE" + e$: GoTo errmes
|
|
End Select
|
|
End If
|
|
|
|
'any other "unique" subs can be processed above
|
|
|
|
id2 = id
|
|
|
|
targetid = currentid
|
|
|
|
If RTrim$(id2.callname) = "sub_stub" Then a$ = "Command not implemented": GoTo errmes
|
|
|
|
If n > 1 Then
|
|
If id2.args = 0 Then a$ = "SUB does not require any arguments": GoTo errmes
|
|
End If
|
|
|
|
SetDependency id2.Dependency
|
|
|
|
seperateargs_error = 0
|
|
passedneeded = seperateargs(getelements(a$, 2, n), getelements(ca$, 2, n), passed&)
|
|
If seperateargs_error Then a$ = seperateargs_error_message: GoTo errmes
|
|
|
|
'backup args to local string array space before calling evaluate
|
|
For i = 1 To OptMax: separgs2(i) = "": Next 'save space!
|
|
For i = 1 To OptMax + 1: separgslayout2(i) = "": Next
|
|
For i = 1 To id2.args: separgs2(i) = separgs(i): Next
|
|
For i = 1 To id2.args + 1: separgslayout2(i) = separgslayout(i): Next
|
|
|
|
|
|
|
|
If Debug Then
|
|
Print #9, "separgs:": For i = 1 To id2.args: Print #9, i, separgs2(i): Next
|
|
Print #9, "separgslayout:": For i = 1 To id2.args + 1: Print #9, i, separgslayout2(i): Next
|
|
End If
|
|
|
|
|
|
|
|
'note: seperateargs finds the arguments to pass and sets passed& as necessary
|
|
' FIXOPERTIONORDER is not called on these args yet
|
|
' what we need it to do is build a second array of layout info at the same time
|
|
' ref:DIM SHARED separgslayout(100) AS STRING
|
|
' the above array stores what layout info (if any) goes BEFORE the arg in question
|
|
' it has one extra index which is the arg after
|
|
|
|
If usecall Then
|
|
If id.internal_subfunc Then
|
|
If usecall = 1 Then l$ = SCase$("Call") + sp + SCase$(RTrim$(id.cn)) + RTrim$(id.musthave) + sp2 + "(" + sp2
|
|
If usecall = 2 Then l$ = SCase$("Call") + sp + SCase$(RTrim$(id.cn)) + RTrim$(id.musthave) + sp 'sp at end for easy parsing
|
|
Else
|
|
If usecall = 1 Then l$ = SCase$("Call") + sp + RTrim$(id.cn) + RTrim$(id.musthave) + sp2 + "(" + sp2
|
|
If usecall = 2 Then l$ = SCase$("Call") + sp + RTrim$(id.cn) + RTrim$(id.musthave) + sp 'sp at end for easy parsing
|
|
End If
|
|
Else
|
|
If id.internal_subfunc Then
|
|
l$ = SCase$(RTrim$(id.cn)) + RTrim$(id.musthave) + sp
|
|
Else
|
|
l$ = RTrim$(id.cn) + RTrim$(id.musthave) + sp
|
|
End If
|
|
End If
|
|
|
|
subcall$ = RTrim$(id.callname) + "("
|
|
addedlayout = 0
|
|
|
|
fieldcall = 0
|
|
'GET/PUT field exception
|
|
If RTrim$(id2.callname) = "sub_get" Or RTrim$(id2.callname) = "sub_put" Then
|
|
If passed And 2 Then
|
|
'regular GET/PUT call with variable provided
|
|
passed = passed - 2 'for complience with existing methods, remove 'passed' flag for the passing of a variable
|
|
Else
|
|
'FIELD GET/PUT call with variable omited
|
|
If RTrim$(id2.callname) = "sub_get" Then
|
|
fieldcall = 1
|
|
subcall$ = "field_get("
|
|
Else
|
|
fieldcall = 2
|
|
subcall$ = "field_put("
|
|
End If
|
|
End If
|
|
End If 'field exception
|
|
|
|
If RTrim$(id2.callname) = "sub_timer" Or RTrim$(id2.callname) = "sub_key" Then 'spacing exception
|
|
If usecall = 0 Then
|
|
l$ = Left$(l$, Len(l$) - 1) + sp2
|
|
End If
|
|
End If
|
|
|
|
For i = 1 To id2.args
|
|
targettyp = CVL(Mid$(id2.arg, -3 + i * 4, 4))
|
|
nele = Asc(Mid$(id2.nele, i, 1))
|
|
nelereq = Asc(Mid$(id2.nelereq, i, 1))
|
|
|
|
addlayout = 1 'omits option values in layout (eg. BINARY="2")
|
|
convertspacing = 0 'if an 'equation' is next, it will be preceeded by a space
|
|
x$ = separgslayout2$(i)
|
|
Do While Len(x$)
|
|
x = Asc(x$)
|
|
If x Then
|
|
convertspacing = 0
|
|
x2$ = Mid$(x$, 2, x)
|
|
x$ = Right$(x$, Len(x$) - x - 1)
|
|
|
|
s = 0
|
|
an = 0
|
|
x3$ = Right$(l$, 1)
|
|
If x3$ = sp Then s = 1
|
|
If x3$ = sp2 Then
|
|
s = 2
|
|
If alphanumeric(Asc(Right$(l$, 2))) Then an = 1
|
|
Else
|
|
If alphanumeric(Asc(x3$)) Then an = 1
|
|
End If
|
|
s1 = s
|
|
|
|
If alphanumeric(Asc(x2$)) Then convertspacing = 1
|
|
|
|
|
|
If x2$ = "LPRINT" Then
|
|
|
|
'x2$="LPRINT"
|
|
'x$=CHR$(0)
|
|
'x3$=[sp] from WIDTH[sp]
|
|
'therefore...
|
|
's=1
|
|
'an=0
|
|
'convertspacing=1
|
|
|
|
|
|
'if debug=1 then
|
|
'print #9,"LPRINT:"
|
|
'print #9,s
|
|
'print #9,an
|
|
'print #9,l$
|
|
'print #9,x2$
|
|
'end if
|
|
|
|
End If
|
|
|
|
|
|
|
|
|
|
If (an = 1 Or addedlayout = 1) And alphanumeric(Asc(x2$)) <> 0 Then
|
|
|
|
|
|
|
|
s = 1 'force space
|
|
x2$ = x2$ + sp2
|
|
GoTo customlaychar
|
|
End If
|
|
|
|
If x2$ = "=" Then
|
|
s = 1
|
|
x2$ = x2$ + sp
|
|
GoTo customlaychar
|
|
End If
|
|
|
|
If x2$ = "#" Then
|
|
s = 1
|
|
x2$ = x2$ + sp2
|
|
GoTo customlaychar
|
|
End If
|
|
|
|
If x2$ = "," Then x2$ = x2$ + sp: GoTo customlaychar
|
|
|
|
|
|
If x$ = Chr$(0) Then 'substitution
|
|
If x2$ = "STEP" Then x2$ = x2$ + sp2: GoTo customlaychar
|
|
x2$ = x2$ + sp: GoTo customlaychar
|
|
End If
|
|
|
|
'default solution sp2+?+sp2
|
|
x2$ = x2$ + sp2
|
|
|
|
|
|
|
|
|
|
|
|
customlaychar:
|
|
If s = 0 Then s = 2
|
|
If s <> s1 Then
|
|
If s1 Then l$ = Left$(l$, Len(l$) - 1)
|
|
If s = 1 Then l$ = l$ + sp
|
|
If s = 2 Then l$ = l$ + sp2
|
|
End If
|
|
|
|
If (RTrim$(id2.callname) = "sub_timer" Or RTrim$(id2.callname) = "sub_key") And i = id2.args Then 'spacing exception
|
|
If x2$ <> ")" + sp2 Then
|
|
l$ = Left$(l$, Len(l$) - 1) + sp
|
|
End If
|
|
End If
|
|
|
|
l$ = l$ + x2$
|
|
|
|
Else
|
|
addlayout = 0
|
|
x$ = Right$(x$, Len(x$) - 1)
|
|
End If
|
|
addedlayout = 0
|
|
Loop
|
|
|
|
|
|
|
|
'---better sub syntax checking begins here---
|
|
|
|
|
|
|
|
If targettyp = -3 Then
|
|
If separgs2(i) = "N-LL" Then a$ = "Expected array name": GoTo errmes
|
|
'names of numeric arrays have ( ) automatically appended (nothing else)
|
|
e$ = separgs2(i)
|
|
|
|
If InStr(e$, sp) = 0 Then 'one element only
|
|
try_string$ = e$
|
|
try = findid(try_string$)
|
|
If Error_Happened Then GoTo errmes
|
|
Do
|
|
If try Then
|
|
If id.arraytype Then
|
|
If (id.arraytype And ISSTRING) = 0 Then
|
|
e$ = e$ + sp + "(" + sp + ")"
|
|
Exit Do
|
|
End If
|
|
End If
|
|
'---
|
|
If try = 2 Then findanotherid = 1: try = findid(try_string$) Else try = 0
|
|
If Error_Happened Then GoTo errmes
|
|
End If 'if try
|
|
If try = 0 Then 'add symbol?
|
|
If Len(removesymbol$(try_string$)) = 0 Then
|
|
If Error_Happened Then GoTo errmes
|
|
a = Asc(try_string$)
|
|
If a >= 97 And a <= 122 Then a = a - 32
|
|
If a = 95 Then a = 91
|
|
a = a - 64
|
|
If Len(defineextaz(a)) Then try_string$ = try_string$ + defineextaz(a): try = findid(try_string$)
|
|
If Error_Happened Then GoTo errmes
|
|
End If
|
|
End If 'try=0
|
|
Loop Until try = 0
|
|
End If 'one element only
|
|
|
|
|
|
|
|
e$ = fixoperationorder$(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
If convertspacing = 1 And addlayout = 1 Then l$ = Left$(l$, Len(l$) - 1) + sp
|
|
If addlayout Then l$ = l$ + tlayout$: addedlayout = 1
|
|
e$ = evaluatetotyp(e$, -2)
|
|
If Error_Happened Then GoTo errmes
|
|
GoTo sete
|
|
End If '-3
|
|
|
|
|
|
If targettyp = -2 Then
|
|
e$ = fixoperationorder$(e$)
|
|
If Error_Happened Then GoTo errmes
|
|
If convertspacing = 1 And addlayout = 1 Then l$ = Left$(l$, Len(l$) - 1) + sp
|
|
If addlayout Then l$ = l$ + tlayout$: addedlayout = 1
|
|
e$ = evaluatetotyp(e$, -2)
|
|
If Error_Happened Then GoTo errmes
|
|
GoTo sete
|
|
End If '-2
|
|
|
|
If targettyp = -4 Then
|
|
|
|
If fieldcall Then
|
|
i = id2.args + 1
|
|
Exit For
|
|
End If
|
|
|
|
If separgs2(i) = "N-LL" Then a$ = "Expected variable name/array element": GoTo errmes
|
|
e$ = fixoperationorder$(separgs2(i))
|
|
If Error_Happened Then GoTo errmes
|
|
If convertspacing = 1 And addlayout = 1 Then l$ = Left$(l$, Len(l$) - 1) + sp
|
|
If addlayout Then l$ = l$ + tlayout$: addedlayout = 1
|
|
|
|
'GET/PUT RANDOM-ACCESS override
|
|
If firstelement$ = "GET" Or firstelement$ = "PUT" Then
|
|
e2$ = e$ 'backup
|
|
e$ = evaluate(e$, sourcetyp)
|
|
If Error_Happened Then GoTo errmes
|
|
If (sourcetyp And ISSTRING) Then
|
|
If (sourcetyp And ISFIXEDLENGTH) = 0 Then
|
|
'replace name of sub to call
|
|
subcall$ = Right$(subcall$, Len(subcall$) - 7) 'delete original name
|
|
'note: GET2 & PUT2 take differing input, following code is correct
|
|
If firstelement$ = "GET" Then
|
|
subcall$ = "sub_get2" + subcall$
|
|
e$ = refer(e$, sourcetyp, 0) 'pass a qbs pointer instead
|
|
If Error_Happened Then GoTo errmes
|
|
GoTo sete
|
|
Else
|
|
subcall$ = "sub_put2" + subcall$
|
|
'no goto sete required, fall through
|
|
End If
|
|
End If
|
|
End If
|
|
e$ = e2$ 'restore
|
|
End If 'override
|
|
|
|
e$ = evaluatetotyp(e$, -4)
|
|
If Error_Happened Then GoTo errmes
|
|
GoTo sete
|
|
End If '-4
|
|
|
|
If separgs2(i) = "N-LL" Then
|
|
e$ = "NULL"
|
|
Else
|
|
|
|
e2$ = fixoperationorder$(separgs2(i))
|
|
If Error_Happened Then GoTo errmes
|
|
If convertspacing = 1 And addlayout = 1 Then l$ = Left$(l$, Len(l$) - 1) + sp
|
|
If addlayout Then l$ = l$ + tlayout$: addedlayout = 1
|
|
|
|
e$ = evaluate(e2$, sourcetyp)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
If sourcetyp And ISOFFSET Then
|
|
If (targettyp And ISOFFSET) = 0 Then
|
|
If id2.internal_subfunc = 0 Then a$ = "Cannot convert _OFFSET type to other types": GoTo errmes
|
|
End If
|
|
End If
|
|
|
|
If RTrim$(id2.callname) = "sub_paint" Then
|
|
If i = 3 Then
|
|
If (sourcetyp And ISSTRING) Then
|
|
targettyp = ISSTRING
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
If Left$(separgs2(i), 2) = "(" + sp Then dereference = 1 Else dereference = 0
|
|
|
|
'pass by reference
|
|
If (targettyp And ISPOINTER) Then
|
|
If dereference = 0 Then 'check deferencing wasn't used
|
|
|
|
'note: array pointer
|
|
If (targettyp And ISARRAY) Then
|
|
If (sourcetyp And ISREFERENCE) = 0 Then a$ = "Expected arrayname()": GoTo errmes
|
|
If (sourcetyp And ISARRAY) = 0 Then a$ = "Expected arrayname()": GoTo errmes
|
|
If Debug Then Print #9, "sub:array reference:[" + e$ + "]"
|
|
|
|
'check arrays are of same type
|
|
targettyp2 = targettyp: sourcetyp2 = sourcetyp
|
|
targettyp2 = targettyp2 And (511 + ISOFFSETINBITS + ISUDT + ISSTRING + ISFIXEDLENGTH + ISFLOAT)
|
|
sourcetyp2 = sourcetyp2 And (511 + ISOFFSETINBITS + ISUDT + ISSTRING + ISFIXEDLENGTH + ISFLOAT)
|
|
If sourcetyp2 <> targettyp2 Then a$ = "Incorrect array type passed to sub": GoTo errmes
|
|
|
|
'check arrayname was followed by '()'
|
|
If targettyp And ISUDT Then
|
|
If Debug Then Print #9, "sub:array reference:udt reference:[" + e$ + "]"
|
|
'get UDT info
|
|
udtrefid = Val(e$)
|
|
getid udtrefid
|
|
If Error_Happened Then GoTo errmes
|
|
udtrefi = InStr(e$, sp3) 'end of id
|
|
udtrefi2 = InStr(udtrefi + 1, e$, sp3) 'end of u
|
|
udtrefu = Val(Mid$(e$, udtrefi + 1, udtrefi2 - udtrefi - 1))
|
|
udtrefi3 = InStr(udtrefi2 + 1, e$, sp3) 'skip e
|
|
udtrefe = Val(Mid$(e$, udtrefi2 + 1, udtrefi3 - udtrefi2 - 1))
|
|
o$ = Right$(e$, Len(e$) - udtrefi3)
|
|
'note: most of the UDT info above is not required
|
|
If Left$(o$, 4) <> "(0)*" Then a$ = "Expected arrayname()": GoTo errmes
|
|
Else
|
|
If Right$(e$, 2) <> sp3 + "0" Then a$ = "Expected arrayname()": GoTo errmes
|
|
End If
|
|
|
|
idnum = Val(Left$(e$, InStr(e$, sp3) - 1))
|
|
getid idnum
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
If targettyp And ISFIXEDLENGTH Then
|
|
targettypsize = CVL(Mid$(id2.argsize, i * 4 - 4 + 1, 4))
|
|
If id.tsize <> targettypsize Then a$ = "Incorrect array type passed to sub": GoTo errmes
|
|
End If
|
|
|
|
If Mid$(sfcmemargs(targetid), i, 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 > 0 Then '2009
|
|
|
|
nelereq = id.arrayelements
|
|
Mid$(id2.nelereq, i, 1) = Chr$(nelereq)
|
|
|
|
End If
|
|
|
|
'print rtrim$(id2.n)+">nelereq=";nelereq
|
|
|
|
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
|
|
|
|
If id.arrayelements <> nelereq Then a$ = "Passing arrays with a differing number of elements to a SUB/FUNCTION is not supported (yet)": GoTo errmes
|
|
|
|
|
|
End If
|
|
End If
|
|
|
|
e$ = refer(e$, sourcetyp, 1)
|
|
If Error_Happened Then GoTo errmes
|
|
GoTo sete
|
|
|
|
End If 'target is an array
|
|
|
|
'note: not an array...
|
|
'target is not an array
|
|
|
|
If (targettyp And ISSTRING) = 0 Then
|
|
If (sourcetyp And ISREFERENCE) Then
|
|
idnum = Val(Left$(e$, InStr(e$, sp3) - 1)) 'id# of sourcetyp
|
|
|
|
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 GoTo errmes
|
|
udtrefi = InStr(e$, sp3) 'end of id
|
|
udtrefi2 = InStr(udtrefi + 1, e$, sp3) 'end of u
|
|
udtrefu = Val(Mid$(e$, udtrefi + 1, udtrefi2 - udtrefi - 1))
|
|
udtrefi3 = InStr(udtrefi2 + 1, e$, sp3) 'skip e
|
|
udtrefe = Val(Mid$(e$, udtrefi2 + 1, udtrefi3 - udtrefi2 - 1))
|
|
o$ = Right$(e$, Len(e$) - udtrefi3)
|
|
'note: most of the UDT info above is not required
|
|
|
|
If arr Then
|
|
n$ = scope$ + "ARRAY_UDT_" + RTrim$(id.n) + "[0]"
|
|
Else
|
|
n$ = scope$ + "UDT_" + RTrim$(id.n)
|
|
End If
|
|
|
|
e$ = "(void*)( ((char*)(" + n$ + ")) + (" + o$ + ") )"
|
|
|
|
'convert void* to target type*
|
|
If passudtelement Then e$ = "(" + typ2ctyp$(targettyp2 + (targettyp And ISUNSIGNED), "") + "*)" + e$
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
Else
|
|
'not a udt
|
|
If arr Then
|
|
If (sourcetyp2 And ISOFFSETINBITS) Then a$ = "Cannot pass BIT array offsets yet": GoTo errmes
|
|
e$ = "(&(" + refer(e$, sourcetyp, 0) + "))"
|
|
If Error_Happened Then GoTo errmes
|
|
Else
|
|
e$ = refer(e$, sourcetyp, 1)
|
|
If Error_Happened Then GoTo errmes
|
|
End If
|
|
|
|
'note: signed/unsigned mismatch requires casting
|
|
If (sourcetyp And ISUNSIGNED) <> (targettyp And ISUNSIGNED) Then
|
|
e$ = "(" + typ2ctyp$(targettyp2 + (targettyp And ISUNSIGNED), "") + "*)" + e$
|
|
If Error_Happened Then GoTo errmes
|
|
End If
|
|
|
|
End If 'udt?
|
|
|
|
If Mid$(sfcmemargs(targetid), i, 1) = Chr$(1) Then 'cmem required?
|
|
If cmemlist(idnum) = 0 Then
|
|
cmemlist(idnum) = 1
|
|
recompile = 1
|
|
End If
|
|
End If
|
|
|
|
GoTo sete
|
|
End If 'similar
|
|
End If 'reference
|
|
Else 'not a string
|
|
'its a string
|
|
If (sourcetyp And ISREFERENCE) Then
|
|
idnum = Val(Left$(e$, InStr(e$, sp3) - 1)) 'id# of sourcetyp
|
|
If Mid$(sfcmemargs(targetid), i, 1) = Chr$(1) Then 'cmem required?
|
|
If cmemlist(idnum) = 0 Then
|
|
cmemlist(idnum) = 1
|
|
recompile = 1
|
|
End If
|
|
End If
|
|
End If 'reference
|
|
End If 'its a string
|
|
|
|
End If 'dereference check
|
|
End If 'target is a pointer
|
|
|
|
'note: Target is not a pointer...
|
|
|
|
'String-numeric mismatch?
|
|
If targettyp And ISSTRING Then
|
|
If (sourcetyp And ISSTRING) = 0 Then
|
|
nth = i
|
|
If ids(targetid).args = 1 Then a$ = "String required for sub": GoTo errmes
|
|
a$ = str_nth$(nth) + " sub argument requires a string": GoTo errmes
|
|
End If
|
|
End If
|
|
If (targettyp And ISSTRING) = 0 Then
|
|
If sourcetyp And ISSTRING Then
|
|
nth = i
|
|
If ids(targetid).args = 1 Then a$ = "Number required for sub": GoTo errmes
|
|
a$ = str_nth$(nth) + " sub argument requires a number": GoTo errmes
|
|
End If
|
|
End If
|
|
|
|
'change to "non-pointer" value
|
|
If (sourcetyp And ISREFERENCE) Then
|
|
e$ = refer(e$, sourcetyp, 0)
|
|
If Error_Happened Then GoTo errmes
|
|
End If
|
|
|
|
If explicitreference = 0 Then
|
|
If targettyp And ISUDT Then
|
|
nth = i
|
|
If qb64prefix_set And udtxcname(targettyp And 511) = "_MEM" Then
|
|
x$ = "'" + Mid$(RTrim$(udtxcname(targettyp And 511)), 2) + "'"
|
|
Else
|
|
x$ = "'" + RTrim$(udtxcname(targettyp And 511)) + "'"
|
|
End If
|
|
If ids(targetid).args = 1 Then a$ = "TYPE " + x$ + " required for sub": GoTo errmes
|
|
a$ = str_nth$(nth) + " sub argument requires TYPE " + x$: GoTo errmes
|
|
End If
|
|
Else
|
|
If sourcetyp And ISUDT Then a$ = "Number required for sub": GoTo errmes
|
|
End If
|
|
|
|
'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 (targettyp And ISPOINTER) Then 'pointer required
|
|
If (targettyp And ISSTRING) Then GoTo sete 'no changes required
|
|
t$ = typ2ctyp$(targettyp, "")
|
|
If Error_Happened Then GoTo errmes
|
|
v$ = "pass" + str2$(uniquenumber)
|
|
'assume numeric type
|
|
If Mid$(sfcmemargs(targetid), i, 1) = Chr$(1) Then 'cmem required?
|
|
bytesreq = ((targettyp And 511) + 7) \ 8
|
|
Print #defdatahandle, t$ + " *" + v$ + "=NULL;"
|
|
Print #13, "if(" + v$ + "==NULL){"
|
|
Print #13, "cmem_sp-=" + str2(bytesreq) + ";"
|
|
Print #13, v$ + "=(" + t$ + "*)(dblock+cmem_sp);"
|
|
Print #13, "if (cmem_sp<qbs_cmem_sp) error(257);"
|
|
Print #13, "}"
|
|
e$ = "&(*" + v$ + "=" + e$ + ")"
|
|
Else
|
|
Print #13, t$ + " " + v$ + ";"
|
|
e$ = "&(" + v$ + "=" + e$ + ")"
|
|
End If
|
|
GoTo sete
|
|
End If
|
|
|
|
End If 'not "NULL"
|
|
|
|
sete:
|
|
|
|
If RTrim$(id2.callname) = "sub_paint" Then
|
|
If i = 3 Then
|
|
If (sourcetyp And ISSTRING) Then
|
|
e$ = "(qbs*)" + e$
|
|
Else
|
|
e$ = "(uint32)" + e$
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
If id2.ccall Then
|
|
|
|
'if a forced cast from a returned ccall function is in e$, remove it
|
|
If Left$(e$, 3) = "( " Then
|
|
e$ = removecast$(e$)
|
|
End If
|
|
|
|
If targettyp And ISSTRING Then
|
|
e$ = "(char*)(" + e$ + ")->chr"
|
|
End If
|
|
|
|
If LTrim$(RTrim$(e$)) = "0" Then e$ = "NULL"
|
|
|
|
End If
|
|
|
|
If i <> 1 Then subcall$ = subcall$ + ","
|
|
subcall$ = subcall$ + e$
|
|
Next
|
|
|
|
'note: i=id.args+1
|
|
x$ = separgslayout2$(i)
|
|
Do While Len(x$)
|
|
x = Asc(x$)
|
|
If x Then
|
|
x2$ = Mid$(x$, 2, x)
|
|
x$ = Right$(x$, Len(x$) - x - 1)
|
|
|
|
s = 0
|
|
an = 0
|
|
x3$ = Right$(l$, 1)
|
|
If x3$ = sp Then s = 1
|
|
If x3$ = sp2 Then
|
|
s = 2
|
|
If alphanumeric(Asc(Right$(l$, 2))) Then an = 1
|
|
'if asc(right$(l$,2))=34 then an=1
|
|
Else
|
|
If alphanumeric(Asc(x3$)) Then an = 1
|
|
'if asc(x3$)=34 then an=1
|
|
End If
|
|
s1 = s
|
|
|
|
If (an = 1 Or addedlayout = 1) And alphanumeric(Asc(x2$)) <> 0 Then
|
|
s = 1 'force space
|
|
x2$ = x2$ + sp2
|
|
GoTo customlaychar2
|
|
End If
|
|
|
|
If x2$ = "=" Then
|
|
s = 1
|
|
x2$ = x2$ + sp
|
|
GoTo customlaychar2
|
|
End If
|
|
|
|
If x2$ = "#" Then
|
|
s = 1
|
|
x2$ = x2$ + sp2
|
|
GoTo customlaychar2
|
|
End If
|
|
|
|
If x2$ = "," Then x2$ = x2$ + sp: GoTo customlaychar2
|
|
|
|
If x$ = Chr$(0) Then 'substitution
|
|
If x2$ = "STEP" Then x2$ = SCase$("Step") + sp2: GoTo customlaychar2
|
|
x2$ = x2$ + sp: GoTo customlaychar2
|
|
End If
|
|
|
|
'default solution sp2+?+sp2
|
|
x2$ = x2$ + sp2
|
|
customlaychar2:
|
|
If s = 0 Then s = 2
|
|
If s <> s1 Then
|
|
If s1 Then l$ = Left$(l$, Len(l$) - 1)
|
|
If s = 1 Then l$ = l$ + sp
|
|
If s = 2 Then l$ = l$ + sp2
|
|
End If
|
|
l$ = l$ + x2$
|
|
|
|
Else
|
|
addlayout = 0
|
|
x$ = Right$(x$, Len(x$) - 1)
|
|
End If
|
|
addedlayout = 0
|
|
Loop
|
|
|
|
|
|
|
|
|
|
|
|
|
|
If passedneeded Then
|
|
subcall$ = subcall$ + "," + str2$(passed&)
|
|
End If
|
|
subcall$ = subcall$ + ");"
|
|
Print #12, subcall$
|
|
subcall$ = ""
|
|
If stringprocessinghappened Then Print #12, cleanupstringprocessingcall$ + "0);"
|
|
|
|
layoutdone = 1
|
|
x$ = Right$(l$, 1): If x$ = sp Or x$ = sp2 Then l$ = Left$(l$, Len(l$) - 1)
|
|
If usecall = 1 Then l$ = l$ + sp2 + ")"
|
|
If Debug Then Print #9, "SUB layout:[" + l$ + "]"
|
|
If Len(layout$) = 0 Then layout$ = l$ Else layout$ = layout$ + sp + l$
|
|
GoTo finishedline
|
|
|
|
|
|
End If
|
|
|
|
If try = 2 Then
|
|
findidsecondarg = "": If n >= 2 Then findidsecondarg = getelement$(a$, 2)
|
|
findanotherid = 1
|
|
try = findid(firstelement$)
|
|
If Error_Happened Then GoTo errmes
|
|
Else
|
|
try = 0
|
|
End If
|
|
Loop
|
|
|
|
End If
|
|
|
|
notsubcall:
|
|
|
|
If n >= 1 Then
|
|
If firstelement$ = "LET" Then
|
|
If n = 1 Then a$ = "Syntax error": GoTo errmes
|
|
ca$ = Right$(ca$, Len(ca$) - 4)
|
|
n = n - 1
|
|
l$ = SCase$("Let")
|
|
If Len(layout$) Then layout$ = layout$ + sp + l$ Else layout$ = l$
|
|
'note: layoutdone=1 will be set later
|
|
GoTo letused
|
|
End If
|
|
End If
|
|
|
|
'LET ???=???
|
|
If n >= 3 Then
|
|
If InStr(a$, sp + "=" + sp) Then
|
|
letused:
|
|
assign ca$, n
|
|
If Error_Happened Then GoTo errmes
|
|
layoutdone = 1
|
|
If Len(layout$) = 0 Then layout$ = tlayout$ Else layout$ = layout$ + sp + tlayout$
|
|
GoTo finishedline
|
|
End If
|
|
End If '>=3
|
|
If Right$(a$, 2) = sp + "=" Then a$ = "Expected ... = expression": GoTo errmes
|
|
|
|
'Syntax error
|
|
a$ = "Syntax error": GoTo errmes
|
|
|
|
finishedline:
|
|
THENGOTO = 0
|
|
finishedline2:
|
|
|
|
If arrayprocessinghappened = 1 Then arrayprocessinghappened = 0
|
|
|
|
inclinenump$ = ""
|
|
If inclinenumber(inclevel) Then
|
|
inclinenump$ = "," + str2$(inclinenumber(inclevel))
|
|
thisincname$ = getfilepath$(incname$(inclevel))
|
|
thisincname$ = Mid$(incname$(inclevel), Len(thisincname$) + 1)
|
|
inclinenump$ = inclinenump$ + "," + Chr$(34) + thisincname$ + Chr$(34)
|
|
End If
|
|
If NoChecks = 0 Then
|
|
If dynscope Then
|
|
dynscope = 0
|
|
Print #12, "if(qbevent){evnt(" + str2$(linenumber) + inclinenump$ + ");if(r)goto S_" + str2$(statementn) + ";}"
|
|
Else
|
|
Print #12, "if(!qbevent)break;evnt(" + str2$(linenumber) + inclinenump$ + ");}while(r);"
|
|
End If
|
|
End If
|
|
|
|
finishednonexec:
|
|
|
|
firstLine = 0
|
|
|
|
If layoutdone = 0 Then layoutok = 0 'invalidate layout if not handled
|
|
|
|
If continuelinefrom = 0 Then 'note: manager #2 requires this condition
|
|
|
|
'Include Manager #2 '***
|
|
If Len(addmetainclude$) Then
|
|
|
|
If inclevel = 0 Then
|
|
'backup line formatting
|
|
layoutcomment_backup$ = layoutcomment$
|
|
layoutok_backup = layoutok
|
|
layout_backup$ = layout$
|
|
End If
|
|
|
|
a$ = addmetainclude$: addmetainclude$ = "" 'read/clear message
|
|
|
|
If inclevel = 100 Then a$ = "Too many indwelling INCLUDE files": GoTo errmes
|
|
'1. Verify file exists (location is either (a)relative to source file or (b)absolute)
|
|
fh = 99 + inclevel + 1
|
|
|
|
firstTryMethod = 1
|
|
For try = firstTryMethod To 2 'if including file from root, do not attempt including from relative location
|
|
If try = 1 Then
|
|
If inclevel = 0 Then
|
|
If idemode Then p$ = idepath$ + pathsep$ Else p$ = getfilepath$(sourcefile$)
|
|
Else
|
|
p$ = getfilepath$(incname(inclevel))
|
|
End If
|
|
f$ = p$ + a$
|
|
End If
|
|
If try = 2 Then f$ = a$
|
|
If _FileExists(f$) Then
|
|
qberrorhappened = -2 '***
|
|
Open f$ For Binary As #fh
|
|
qberrorhappened2: '***
|
|
If qberrorhappened = -2 Then Exit For '***
|
|
End If
|
|
qberrorhappened = 0
|
|
Next
|
|
If qberrorhappened <> -2 Then qberrorhappened = 0: a$ = "File " + a$ + " not found": GoTo errmes
|
|
inclevel = inclevel + 1: incname$(inclevel) = f$: inclinenumber(inclevel) = 0
|
|
End If 'fall through to next section...
|
|
'--------------------
|
|
Do While inclevel
|
|
fh = 99 + inclevel
|
|
'2. Feed next line
|
|
If EOF(fh) = 0 Then
|
|
Line Input #fh, x$
|
|
a3$ = x$
|
|
continuelinefrom = 0
|
|
inclinenumber(inclevel) = inclinenumber(inclevel) + 1
|
|
'create extended error string 'incerror$'
|
|
errorLineInInclude = inclinenumber(inclevel)
|
|
e$ = " in line " + str2(inclinenumber(inclevel)) + " of " + incname$(inclevel) + " included"
|
|
If inclevel > 1 Then
|
|
e$ = e$ + " (through "
|
|
For x = 1 To inclevel - 1 Step 1
|
|
e$ = e$ + incname$(x)
|
|
If x < inclevel - 1 Then 'a sep is req
|
|
If x = inclevel - 2 Then
|
|
e$ = e$ + " then "
|
|
Else
|
|
e$ = e$ + ", "
|
|
End If
|
|
End If
|
|
Next
|
|
e$ = e$ + ")"
|
|
End If
|
|
incerror$ = e$
|
|
linenumber = linenumber - 1 'lower official linenumber to counter later increment
|
|
If idemode Then sendc$ = Chr$(10) + a3$: GoTo sendcommand 'passback
|
|
GoTo includeline
|
|
End If
|
|
'3. Close & return control
|
|
Close #fh
|
|
inclevel = inclevel - 1
|
|
If inclevel = 0 Then
|
|
'restore line formatting
|
|
layoutok = layoutok_backup
|
|
layout$ = layout_backup$
|
|
layoutcomment$ = layoutcomment_backup$
|
|
End If
|
|
Loop 'fall through to next section...
|
|
'(end manager)
|
|
|
|
|
|
|
|
End If 'continuelinefrom=0
|
|
|
|
|
|
If Debug Then
|
|
Print #9, "[layout check]"
|
|
Print #9, "[" + layoutoriginal$ + "]"
|
|
Print #9, "[" + layout$ + "]"
|
|
Print #9, layoutok
|
|
Print #9, "[end layout check]"
|
|
End If
|
|
|
|
|
|
|
|
|
|
If idemode Then
|
|
If continuelinefrom <> 0 Then GoTo ide4 'continue processing other commands on line
|
|
|
|
If Len(layoutcomment$) Then
|
|
If Len(layout$) Then layout$ = layout$ + sp + layoutcomment$ Else layout$ = layoutcomment$
|
|
End If
|
|
|
|
If layoutok = 0 Then
|
|
layout$ = layoutoriginal$
|
|
Else
|
|
|
|
'reverse '046' changes present in autolayout
|
|
'replace fix046$ with .
|
|
i = InStr(layout$, fix046$)
|
|
Do While i
|
|
layout$ = Left$(layout$, i - 1) + "." + Right$(layout$, Len(layout$) - (i + Len(fix046$) - 1))
|
|
i = InStr(layout$, fix046$)
|
|
Loop
|
|
|
|
End If
|
|
x = lhscontrollevel: If controllevel < lhscontrollevel Then x = controllevel
|
|
If definingtype = 2 Then x = x + 1
|
|
If definingtype > 0 Then definingtype = 2
|
|
If declaringlibrary = 2 Then x = x + 1
|
|
If declaringlibrary > 0 Then declaringlibrary = 2
|
|
layout$ = Space$(x) + layout$
|
|
If linecontinuation Then layout$ = ""
|
|
|
|
GoTo ideret4 'return control to IDE
|
|
End If
|
|
|
|
'layout is not currently used by the compiler (as appose to the IDE), if it was it would be used here
|
|
skipide4:
|
|
Loop
|
|
|
|
'add final line
|
|
If lastLineReturn = 0 Then
|
|
lastLineReturn = 1
|
|
lastLine = 1
|
|
wholeline$ = ""
|
|
GoTo mainpassLastLine
|
|
End If
|
|
|
|
ide5:
|
|
linenumber = 0
|
|
|
|
If closedmain = 0 Then closemain
|
|
|
|
If definingtype Then linenumber = definingtypeerror: a$ = "TYPE without END TYPE": GoTo errmes
|
|
|
|
'check for open controls (copy #1)
|
|
If controllevel Then
|
|
a$ = "Unidentified open control block"
|
|
Select Case controltype(controllevel)
|
|
Case 1: a$ = "IF without END IF"
|
|
Case 2: a$ = "FOR without NEXT"
|
|
Case 3, 4: a$ = "DO without LOOP"
|
|
Case 5: a$ = "WHILE without WEND"
|
|
Case 6: a$ = "$IF without $END IF"
|
|
Case 10 TO 19: a$ = "SELECT CASE without END SELECT"
|
|
Case 32: a$ = "SUB/FUNCTION without END SUB/FUNCTION"
|
|
End Select
|
|
linenumber = controlref(controllevel)
|
|
GoTo errmes
|
|
End If
|
|
|
|
If ideindentsubs = 0 Then
|
|
If Len(subfunc) Then a$ = "SUB/FUNCTION without END SUB/FUNCTION": GoTo errmes
|
|
End If
|
|
|
|
'close the error handler (cannot be put in 'closemain' because subs/functions can also add error jumps to this file)
|
|
Print #14, "exit(99);" 'in theory this line should never be run!
|
|
Print #14, "}" 'close error jump handler
|
|
|
|
'create CLEAR method "CLEAR"
|
|
Close #12 'close code handle
|
|
Open tmpdir$ + "clear.txt" For Output As #12 'direct code to clear.txt
|
|
|
|
For i = 1 To idn
|
|
|
|
If ids(i).staticscope Then 'static scope?
|
|
subfunc = RTrim$(ids(i).insubfunc) 'set static scope
|
|
GoTo clearstaticscope
|
|
End If
|
|
|
|
a = Asc(ids(i).insubfunc)
|
|
If a = 0 Or a = 32 Then 'global scope?
|
|
subfunc = "" 'set global scope
|
|
clearstaticscope:
|
|
|
|
If ids(i).arraytype Then 'an array
|
|
getid i
|
|
If Error_Happened Then GoTo errmes
|
|
If id.arrayelements = -1 Then GoTo clearerasereturned 'cannot erase non-existant array
|
|
clearerasereturn = 1: GoTo clearerase
|
|
End If 'array
|
|
|
|
If ids(i).t Then 'non-array variable
|
|
getid i
|
|
If Error_Happened Then GoTo errmes
|
|
bytes$ = variablesize$(-1)
|
|
If Error_Happened Then GoTo errmes
|
|
'create a reference
|
|
typ = id.t + ISREFERENCE
|
|
If typ And ISUDT Then
|
|
e$ = str2(i) + sp3 + str2(typ And 511) + sp3 + "0" + sp3 + "0"
|
|
Else
|
|
e$ = str2(i)
|
|
End If
|
|
e$ = refer$(e$, typ, 1)
|
|
If Error_Happened Then GoTo errmes
|
|
If typ And ISSTRING Then
|
|
If typ And ISFIXEDLENGTH Then
|
|
Print #12, "memset((void*)(" + e$ + "->chr),0," + bytes$ + ");"
|
|
GoTo cleared
|
|
Else
|
|
Print #12, e$ + "->len=0;"
|
|
GoTo cleared
|
|
End If
|
|
End If
|
|
If typ And ISUDT Then
|
|
Print #12, "memset((void*)" + e$ + ",0," + bytes$ + ");"
|
|
Else
|
|
Print #12, "*" + e$ + "=0;"
|
|
End If
|
|
GoTo cleared
|
|
End If 'non-array variable
|
|
|
|
End If 'scope
|
|
|
|
cleared:
|
|
clearerasereturned:
|
|
Next
|
|
Close #12
|
|
|
|
If Debug Then
|
|
Print #9, "finished making program!"
|
|
Print #9, "recompile="; recompile
|
|
End If
|
|
|
|
'Set cmem flags for subs/functions requiring data passed in cmem
|
|
For i = 1 To idn
|
|
If cmemlist(i) Then 'must be in cmem
|
|
|
|
getid i
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
If Debug Then Print #9, "recompiling cmem sf! checking:"; RTrim$(id.n)
|
|
|
|
If id.sfid Then 'it is an argument of a sub/function
|
|
|
|
If Debug Then Print #9, "recompiling cmem sf! It's a sub/func arg!"
|
|
|
|
i2 = id.sfid
|
|
x = id.sfarg
|
|
|
|
If Debug Then Print #9, "recompiling cmem sf! values:"; i2; x
|
|
|
|
'check if cmem flag is set, if not then set it & force recompile
|
|
If Mid$(sfcmemargs(i2), x, 1) <> Chr$(1) Then
|
|
Mid$(sfcmemargs(i2), x, 1) = Chr$(1)
|
|
|
|
|
|
If Debug Then Print #9, "recompiling cmem sf! setting:"; i2; x
|
|
|
|
|
|
recompile = 1
|
|
End If
|
|
End If
|
|
End If
|
|
Next i
|
|
|
|
unresolved = 0
|
|
For i = 1 To idn
|
|
getid i
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
If Debug Then Print #9, "checking id named:"; id.n
|
|
|
|
If id.subfunc Then
|
|
For i2 = 1 To id.args
|
|
t = CVL(Mid$(id.arg, i2 * 4 - 3, 4))
|
|
If t > 0 Then
|
|
If (t And ISPOINTER) Then
|
|
If (t And ISARRAY) Then
|
|
|
|
If Debug Then Print #9, "checking argument "; i2; " of "; id.args
|
|
|
|
nele = Asc(Mid$(id.nele, i2, 1))
|
|
nelereq = Asc(Mid$(id.nelereq, i2, 1))
|
|
|
|
If Debug Then Print #9, "nele="; nele
|
|
If Debug Then Print #9, "nelereq="; nelereq
|
|
|
|
If nele <> nelereq Then
|
|
|
|
If Debug Then Print #9, "mismatch detected!"
|
|
|
|
unresolved = unresolved + 1
|
|
sflistn = sflistn + 1
|
|
sfidlist(sflistn) = i
|
|
sfarglist(sflistn) = i2
|
|
sfelelist(sflistn) = nelereq '0 means still unknown
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
Next
|
|
End If
|
|
Next
|
|
|
|
'is recompilation required to resolve this?
|
|
If unresolved > 0 Then
|
|
If lastunresolved = -1 Then
|
|
'first pass
|
|
recompile = 1
|
|
If Debug Then
|
|
Print #9, "recompiling to resolve array elements (first time)"
|
|
Print #9, "sflistn="; sflistn
|
|
Print #9, "oldsflistn="; oldsflistn
|
|
End If
|
|
Else
|
|
'not first pass
|
|
If unresolved < lastunresolved Then
|
|
recompile = 1
|
|
If Debug Then
|
|
Print #9, "recompiling to resolve array elements (not first time)"
|
|
Print #9, "sflistn="; sflistn
|
|
Print #9, "oldsflistn="; oldsflistn
|
|
End If
|
|
End If
|
|
End If
|
|
End If 'unresolved
|
|
lastunresolved = unresolved
|
|
|
|
'IDEA!
|
|
'have a flag to record if anything gets resolved in a pass
|
|
'if not then it's time to stop
|
|
'the problem is the same amount of new problems may be created by a
|
|
'resolve as those that get fixed
|
|
'also/or.. could it be that previous fixes are overridden in a recompile
|
|
' by a new fix? if so, it would give these effects
|
|
|
|
|
|
|
|
'could recompilation resolve this?
|
|
'IF sflistn <> -1 THEN
|
|
'IF sflistn <> oldsflistn THEN
|
|
'recompile = 1
|
|
'
|
|
'if debug then
|
|
'print #9,"recompile set to 1 to resolve array elements"
|
|
'print #9,"sflistn=";sflistn
|
|
'print #9,"oldsflistn=";oldsflistn
|
|
'end if
|
|
'
|
|
'END IF
|
|
'END IF
|
|
|
|
If Debug Then Print #9, "Beginning COMMON array list check..."
|
|
xi = 1
|
|
For x = 1 To commonarraylistn
|
|
varname$ = getelement$(commonarraylist, xi): xi = xi + 1
|
|
typ$ = getelement$(commonarraylist, xi): xi = xi + 1
|
|
dimmethod2 = Val(getelement$(commonarraylist, xi)): xi = xi + 1
|
|
dimshared2 = Val(getelement$(commonarraylist, xi)): xi = xi + 1
|
|
'find the array ID (try method)
|
|
t = typname2typ(typ$)
|
|
If Error_Happened Then GoTo errmes
|
|
If (t And ISUDT) = 0 Then varname$ = varname$ + type2symbol$(typ$)
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
If Debug Then Print #9, "Checking for array '" + varname$ + "'..."
|
|
|
|
try = findid(varname$)
|
|
If Error_Happened Then GoTo errmes
|
|
Do While try
|
|
If id.arraytype Then GoTo foundcommonarray2
|
|
If try = 2 Then findanotherid = 1: try = findid(varname$) Else try = 0
|
|
If Error_Happened Then GoTo errmes
|
|
Loop
|
|
foundcommonarray2:
|
|
|
|
If Debug Then Print #9, "Found array '" + varname$ + "!"
|
|
|
|
If id.arrayelements = -1 Then
|
|
If arrayelementslist(currentid) <> 0 Then recompile = 1
|
|
If Debug Then Print #9, "Recompiling to resolve elements of:" + varname$
|
|
End If
|
|
Next
|
|
If Debug Then Print #9, "Finished COMMON array list check!"
|
|
|
|
If recompile Then
|
|
do_recompile:
|
|
If Debug Then Print #9, "Recompile required!"
|
|
recompile = 0
|
|
If idemode Then iderecompile = 1
|
|
For closeall = 1 To 255: Close closeall: Next
|
|
Open tmpdir$ + "temp.bin" For Output Lock Write As #26 'relock
|
|
GoTo recompile
|
|
End If
|
|
|
|
If Debug Then Print #9, "Beginning label check..."
|
|
For r = 1 To nLabels
|
|
|
|
If Labels(r).Scope_Restriction Then
|
|
a$ = RTrim$(Labels(r).cn)
|
|
ignore = validlabel(a$)
|
|
v = HashFind(a$, HASHFLAG_LABEL, ignore, r2)
|
|
addlabchk7:
|
|
If v Then
|
|
If Labels(r2).Scope = Labels(r).Scope_Restriction Then
|
|
linenumber = Labels(r).Error_Line: a$ = "Common label within a SUB/FUNCTION": GoTo errmes
|
|
End If
|
|
If v = 2 Then v = HashFindCont(ignore, r2): GoTo addlabchk7
|
|
End If 'v
|
|
End If 'restriction
|
|
|
|
'check for undefined labels
|
|
If Labels(r).State = 0 Then
|
|
|
|
If InStr(PossibleSubNameLabels$, sp + UCase$(RTrim$(Labels(r).cn)) + sp) Then
|
|
If InStr(SubNameLabels$, sp + UCase$(RTrim$(Labels(r).cn)) + sp) = 0 Then 'not already added
|
|
SubNameLabels$ = SubNameLabels$ + UCase$(RTrim$(Labels(r).cn)) + sp
|
|
If Debug Then Print #9, "Recompiling to resolve label:"; RTrim$(Labels(r).cn)
|
|
GoTo do_recompile
|
|
End If
|
|
End If
|
|
|
|
linenumber = Labels(r).Error_Line: a$ = "Label '" + RTrim$(Labels(r).cn) + "' not defined": GoTo errmes
|
|
End If
|
|
|
|
|
|
If Labels(r).Data_Referenced Then
|
|
|
|
'check for ambiguous RESTORE reference
|
|
x = 0
|
|
a$ = RTrim$(Labels(r).cn)
|
|
ignore = validlabel(a$)
|
|
v = HashFind(a$, HASHFLAG_LABEL, ignore, r2)
|
|
addlabchk4:
|
|
If v Then
|
|
x = x + 1
|
|
If v = 2 Then v = HashFindCont(ignore, r2): GoTo addlabchk4
|
|
End If 'v
|
|
If x <> 1 Then linenumber = Labels(r).Error_Line: a$ = "Ambiguous DATA label": GoTo errmes
|
|
|
|
'add global data offset variable
|
|
Print #18, "ptrszint data_at_LABEL_" + a$ + "=" + str2(Labels(r).Data_Offset) + ";"
|
|
|
|
End If 'data referenced
|
|
|
|
Next
|
|
If Debug Then Print #9, "Finished check!"
|
|
|
|
|
|
'if targettyp=-4 or targettyp=-5 then '? -> byte_element(offset,element size in bytes)
|
|
' IF (sourcetyp AND ISREFERENCE) = 0 THEN a$ = "Expected variable name/array element": GOTO errmes
|
|
|
|
|
|
'create include files for COMMON arrays
|
|
|
|
Close #12
|
|
|
|
'return to 'main'
|
|
subfunc$ = ""
|
|
defdatahandle = 18
|
|
Close #13: Open tmpdir$ + "maindata.txt" For Append As #13
|
|
Close #19: Open tmpdir$ + "mainfree.txt" For Append As #19
|
|
|
|
If Console Then
|
|
Print #18, "int32 console=1;"
|
|
Else
|
|
Print #18, "int32 console=0;"
|
|
End If
|
|
|
|
If ScreenHide Then
|
|
Print #18, "int32 screen_hide_startup=1;"
|
|
Else
|
|
Print #18, "int32 screen_hide_startup=0;"
|
|
End If
|
|
|
|
If Asserts Then
|
|
Print #18, "int32 asserts=1;"
|
|
Else
|
|
Print #18, "int32 asserts=0;"
|
|
End If
|
|
|
|
fh = FreeFile
|
|
Open tmpdir$ + "dyninfo.txt" For Append As #fh
|
|
If Resize Then
|
|
Print #fh, "ScreenResize=1;"
|
|
End If
|
|
If Resize_Scale Then
|
|
Print #fh, "ScreenResizeScale=" + str2(Resize_Scale) + ";"
|
|
End If
|
|
Close #fh
|
|
|
|
'DATA_finalize
|
|
Print #18, "ptrszint data_size=" + str2(DataOffset) + ";"
|
|
If DataOffset = 0 Then
|
|
|
|
Print #18, "uint8 *data=(uint8*)calloc(1,1);"
|
|
|
|
Else
|
|
|
|
If inline_DATA = 0 Then
|
|
If os$ = "WIN" Then
|
|
If OS_BITS = 32 Then
|
|
x$ = Chr$(0): Put #16, , x$
|
|
Print #18, "extern " + Chr$(34) + "C" + Chr$(34) + "{"
|
|
Print #18, "extern char *binary_____temp" + tempfolderindexstr2$ + "__data_bin_start;"
|
|
Print #18, "}"
|
|
Print #18, "uint8 *data=(uint8*)&binary_____temp" + tempfolderindexstr2$ + "__data_bin_start;"
|
|
Else
|
|
x$ = Chr$(0): Put #16, , x$
|
|
Print #18, "extern " + Chr$(34) + "C" + Chr$(34) + "{"
|
|
Print #18, "extern char *_binary_____temp" + tempfolderindexstr2$ + "__data_bin_start;"
|
|
Print #18, "}"
|
|
Print #18, "uint8 *data=(uint8*)&_binary_____temp" + tempfolderindexstr2$ + "__data_bin_start;"
|
|
End If
|
|
End If
|
|
If os$ = "LNX" Then
|
|
x$ = Chr$(0): Put #16, , x$
|
|
Print #18, "extern " + Chr$(34) + "C" + Chr$(34) + "{"
|
|
Print #18, "extern char *_binary____temp" + tempfolderindexstr2$ + "_data_bin_start;"
|
|
Print #18, "}"
|
|
Print #18, "uint8 *data=(uint8*)&_binary____temp" + tempfolderindexstr2$ + "_data_bin_start;"
|
|
End If
|
|
Else
|
|
'inline data
|
|
Close #16
|
|
ff = FreeFile
|
|
Open tmpdir$ + "data.bin" For Binary As #ff
|
|
x$ = Space$(LOF(ff))
|
|
Get #ff, , x$
|
|
Close #ff
|
|
x2$ = "uint8 inline_data[]={"
|
|
For i = 1 To Len(x$)
|
|
x2$ = x2$ + inlinedatastr$(Asc(x$, i))
|
|
Next
|
|
x2$ = x2$ + "0};"
|
|
Print #18, x2$
|
|
Print #18, "uint8 *data=&inline_data[0];"
|
|
x$ = "": x2$ = ""
|
|
End If
|
|
End If
|
|
|
|
If Debug Then Print #9, "Beginning generation of code for saving/sharing common array data..."
|
|
use_global_byte_elements = 1
|
|
ncommontmp = 0
|
|
xi = 1
|
|
For x = 1 To commonarraylistn
|
|
varname$ = getelement$(commonarraylist, xi): xi = xi + 1
|
|
typ$ = getelement$(commonarraylist, xi): xi = xi + 1
|
|
dimmethod2 = Val(getelement$(commonarraylist, xi)): xi = xi + 1
|
|
dimshared2 = Val(getelement$(commonarraylist, xi)): xi = xi + 1
|
|
|
|
'find the array ID (try method)
|
|
purevarname$ = varname$
|
|
t = typname2typ(typ$)
|
|
If Error_Happened Then GoTo errmes
|
|
If (t And ISUDT) = 0 Then varname$ = varname$ + type2symbol$(typ$)
|
|
If Error_Happened Then GoTo errmes
|
|
try = findid(varname$)
|
|
If Error_Happened Then GoTo errmes
|
|
Do While try
|
|
If id.arraytype Then GoTo foundcommonarray
|
|
If try = 2 Then findanotherid = 1: try = findid(varname$) Else try = 0
|
|
If Error_Happened Then GoTo errmes
|
|
Loop
|
|
a$ = "COMMON array unlocatable": GoTo errmes 'should never happen
|
|
foundcommonarray:
|
|
If Debug Then Print #9, "Found common array '" + varname$ + "'!"
|
|
|
|
i = currentid
|
|
arraytype = id.arraytype
|
|
arrayelements = id.arrayelements
|
|
e$ = RTrim$(id.n)
|
|
If (t And ISUDT) = 0 Then e$ = e$ + typevalue2symbol$(t)
|
|
If Error_Happened Then GoTo errmes
|
|
n$ = e$
|
|
n2$ = RTrim$(id.callname)
|
|
tsize = id.tsize
|
|
|
|
'select command
|
|
command = 3 'fixed length elements
|
|
If t And ISSTRING Then
|
|
If (t And ISFIXEDLENGTH) = 0 Then
|
|
command = 4 'var-len elements
|
|
End If
|
|
End If
|
|
|
|
|
|
'if...
|
|
'i) array elements are still undefined (ie. arrayelements=-1) pass the input content along
|
|
' if any existed or an array-placeholder
|
|
'ii) if the array's elements were defined, any input content would have been loaded so the
|
|
' array (in whatever state it currently is) should be passed. If it is currently erased
|
|
' then it should be passed as a placeholder
|
|
|
|
If arrayelements = -1 Then
|
|
|
|
'load array (copies the array, if any, into a buffer for later)
|
|
|
|
|
|
|
|
Open tmpdir$ + "inpchain" + str2$(i) + ".txt" For Output As #12
|
|
Print #12, "if (int32val==2){" 'array place-holder
|
|
'create buffer to store array as-is in global.txt
|
|
x$ = str2$(uniquenumber)
|
|
x1$ = "chainarraybuf" + x$
|
|
x2$ = "chainarraybufsiz" + x$
|
|
Print #18, "static uint8 *" + x1$ + "=(uint8*)malloc(1);"
|
|
Print #18, "static int64 " + x2$ + "=0;"
|
|
'read next command
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);"
|
|
|
|
If command = 3 Then Print #12, "if (int32val==3){" 'fixed-length-element array
|
|
If command = 4 Then Print #12, "if (int32val==4){" 'var-length-element array
|
|
Print #12, x2$ + "+=4; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int32*)(" + x1$ + "+" + x2$ + "-4)=int32val;"
|
|
|
|
If command = 3 Then
|
|
'read size in bits of one element, convert it to bytes
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);"
|
|
Print #12, x2$ + "+=8; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int64*)(" + x1$ + "+" + x2$ + "-8)=int64val;"
|
|
Print #12, "bytes=int64val>>3;"
|
|
End If 'com=3
|
|
|
|
If command = 4 Then Print #12, "bytes=1;" 'bytes used to calculate number of elements
|
|
|
|
'read number of dimensions
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);"
|
|
Print #12, x2$ + "+=4; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int32*)(" + x1$ + "+" + x2$ + "-4)=int32val;"
|
|
|
|
'read size of dimensions & calculate the size of the array in bytes
|
|
Print #12, "while(int32val--){"
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" 'lbound
|
|
Print #12, x2$ + "+=8; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int64*)(" + x1$ + "+" + x2$ + "-8)=int64val;"
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val2,8," + NewByteElement$ + "),0);" 'ubound
|
|
Print #12, x2$ + "+=8; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int64*)(" + x1$ + "+" + x2$ + "-8)=int64val2;"
|
|
Print #12, "bytes*=(int64val2-int64val+1);"
|
|
Print #12, "}"
|
|
|
|
If command = 3 Then
|
|
'read the array data
|
|
Print #12, x2$ + "+=bytes; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + ");"
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)(" + x1$ + "+" + x2$ + "-bytes),bytes," + NewByteElement$ + "),0);"
|
|
End If 'com=3
|
|
|
|
If command = 4 Then
|
|
Print #12, "bytei=0;"
|
|
Print #12, "while(bytei<bytes){"
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" 'get size
|
|
Print #12, x2$ + "+=8; " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + "); *(int64*)(" + x1$ + "+" + x2$ + "-8)=int64val;"
|
|
Print #12, x2$ + "+=(int64val>>3); " + x1$ + "=(uint8*)realloc(" + x1$ + "," + x2$ + ");"
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)(" + x1$ + "+" + x2$ + "-(int64val>>3)),(int64val>>3)," + NewByteElement$ + "),0);"
|
|
Print #12, "bytei++;"
|
|
Print #12, "}"
|
|
End If
|
|
|
|
'get next command
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);"
|
|
Print #12, "}" 'command=3 or 4
|
|
|
|
Print #12, "}" 'array place-holder
|
|
Close #12
|
|
|
|
|
|
'save array (saves the buffered data, if any, for later)
|
|
|
|
Open tmpdir$ + "chain" + str2$(i) + ".txt" For Output As #12
|
|
Print #12, "int32val=2;" 'placeholder
|
|
Print #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);"
|
|
|
|
Print #12, "sub_put(FF,NULL,byte_element((uint64)" + x1$ + "," + x2$ + "," + NewByteElement$ + "),0);"
|
|
Close #12
|
|
|
|
|
|
|
|
|
|
Else
|
|
'note: arrayelements<>-1
|
|
|
|
'load array
|
|
|
|
Open tmpdir$ + "inpchain" + str2$(i) + ".txt" For Output As #12
|
|
|
|
Print #12, "if (int32val==2){" 'array place-holder
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);"
|
|
|
|
If command = 3 Then Print #12, "if (int32val==3){" 'fixed-length-element array
|
|
If command = 4 Then Print #12, "if (int32val==4){" 'var-length-element array
|
|
|
|
If command = 3 Then
|
|
'get size in bits
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);"
|
|
'***assume correct***
|
|
End If
|
|
|
|
'get number of elements
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);"
|
|
'***assume correct***
|
|
|
|
e$ = ""
|
|
If command = 4 Then Print #12, "bytes=1;" 'bytes counts the number of total elements
|
|
For x2 = 1 To arrayelements
|
|
|
|
'create 'secret' variables to assist in passing common arrays
|
|
If x2 > ncommontmp Then
|
|
ncommontmp = ncommontmp + 1
|
|
|
|
If Debug Then Print #9, "Calling DIM2(...)..."
|
|
If Error_Happened Then GoTo errmes
|
|
retval = dim2("___RESERVED_COMMON_LBOUND" + str2$(ncommontmp), "_INTEGER64", 0, "")
|
|
If Error_Happened Then GoTo errmes
|
|
retval = dim2("___RESERVED_COMMON_UBOUND" + str2$(ncommontmp), "_INTEGER64", 0, "")
|
|
If Error_Happened Then GoTo errmes
|
|
If Debug Then Print #9, "Finished calling DIM2(...)!"
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
|
|
End If
|
|
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);"
|
|
Print #12, "*__INTEGER64____RESERVED_COMMON_LBOUND" + str2$(x2) + "=int64val;"
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val2,8," + NewByteElement$ + "),0);"
|
|
Print #12, "*__INTEGER64____RESERVED_COMMON_UBOUND" + str2$(x2) + "=int64val2;"
|
|
If command = 4 Then Print #12, "bytes*=(int64val2-int64val+1);"
|
|
If x2 > 1 Then e$ = e$ + sp + "," + sp
|
|
e$ = e$ + "___RESERVED_COMMON_LBOUND" + str2$(x2) + sp + "TO" + sp + "___RESERVED_COMMON_UBOUND" + str2$(x2)
|
|
Next
|
|
|
|
If Debug Then Print #9, "Calling DIM2(" + purevarname$ + "," + typ$ + ",0," + e$ + ")..."
|
|
If Error_Happened Then GoTo errmes
|
|
'Note: purevarname$ is simply varname$ without the type symbol after it
|
|
redimoption = 1
|
|
retval = dim2(purevarname$, typ$, 0, e$)
|
|
If Error_Happened Then GoTo errmes
|
|
redimoption = 0
|
|
If Debug Then Print #9, "Finished calling DIM2(" + purevarname$ + "," + typ$ + ",0," + e$ + ")!"
|
|
If Error_Happened Then GoTo errmes
|
|
|
|
If command = 3 Then
|
|
'use get to load in the array data
|
|
varname$ = varname$ + sp + "(" + sp + ")"
|
|
e$ = evaluatetotyp(fixoperationorder$(varname$), -4)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "sub_get(FF,NULL," + e$ + ",0);"
|
|
End If
|
|
|
|
If command = 4 Then
|
|
Print #12, "bytei=0;"
|
|
Print #12, "while(bytei<bytes){"
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" 'get size
|
|
Print #12, "tqbs=((qbs*)(((uint64*)(" + n2$ + "[0]))[bytei]));" 'get element
|
|
Print #12, "qbs_set(tqbs,qbs_new(int64val>>3,1));" 'change string size
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)tqbs->chr,int64val>>3," + NewByteElement$ + "),0);" 'get size
|
|
Print #12, "bytei++;"
|
|
Print #12, "}"
|
|
End If
|
|
|
|
'get next command
|
|
Print #12, "sub_get(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);"
|
|
Print #12, "}"
|
|
Print #12, "}"
|
|
Close #12
|
|
|
|
'save array
|
|
|
|
Open tmpdir$ + "chain" + str2$(i) + ".txt" For Output As #12
|
|
|
|
Print #12, "int32val=2;" 'placeholder
|
|
Print #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);"
|
|
|
|
Print #12, "if (" + n2$ + "[2]&1){" 'don't add unless defined
|
|
|
|
If command = 3 Then Print #12, "int32val=3;"
|
|
If command = 4 Then Print #12, "int32val=4;"
|
|
Print #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);"
|
|
|
|
If command = 3 Then
|
|
'size of each element in bits
|
|
bits = t And 511
|
|
If t And ISUDT Then bits = udtxsize(t And 511)
|
|
If t And ISSTRING Then bits = tsize * 8
|
|
Print #12, "int64val=" + str2$(bits) + ";" 'size in bits
|
|
Print #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);"
|
|
End If 'com=3
|
|
|
|
Print #12, "int32val=" + str2$(arrayelements) + ";" 'number of dimensions
|
|
Print #12, "sub_put(FF,NULL,byte_element((uint64)&int32val,4," + NewByteElement$ + "),0);"
|
|
|
|
If command = 3 Then
|
|
|
|
For x2 = 1 To arrayelements
|
|
'simulate calls to lbound/ubound
|
|
e$ = "LBOUND" + sp + "(" + sp + n$ + sp + "," + sp + str2$(x2) + sp + ")"
|
|
e$ = evaluatetotyp(fixoperationorder$(e$), 64)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "int64val=" + e$ + ";"
|
|
Print #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);"
|
|
e$ = "UBOUND" + sp + "(" + sp + n$ + sp + "," + sp + str2$(x2) + sp + ")"
|
|
e$ = evaluatetotyp(fixoperationorder$(e$), 64)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "int64val=" + e$ + ";"
|
|
Print #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);"
|
|
Next
|
|
|
|
'array data
|
|
e$ = evaluatetotyp(fixoperationorder$(n$ + sp + "(" + sp + ")"), -4)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "sub_put(FF,NULL," + e$ + ",0);"
|
|
|
|
End If 'com=3
|
|
|
|
If command = 4 Then
|
|
|
|
'store LBOUND/UBOUND values and calculate number of total elements/strings
|
|
Print #12, "bytes=1;" 'note: bytes is actually the total number of elements
|
|
For x2 = 1 To arrayelements
|
|
e$ = "LBOUND" + sp + "(" + sp + n$ + sp + "," + sp + str2$(x2) + sp + ")"
|
|
e$ = evaluatetotyp(fixoperationorder$(e$), 64)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "int64val=" + e$ + ";"
|
|
Print #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);"
|
|
e$ = "UBOUND" + sp + "(" + sp + n$ + sp + "," + sp + str2$(x2) + sp + ")"
|
|
e$ = evaluatetotyp(fixoperationorder$(e$), 64)
|
|
If Error_Happened Then GoTo errmes
|
|
Print #12, "int64val2=" + e$ + ";"
|
|
Print #12, "sub_put(FF,NULL,byte_element((uint64)&int64val2,8," + NewByteElement$ + "),0);"
|
|
Print #12, "bytes*=(int64val2-int64val+1);"
|
|
Next
|
|
|
|
Print #12, "bytei=0;"
|
|
Print #12, "while(bytei<bytes){"
|
|
Print #12, "tqbs=((qbs*)(((uint64*)(" + n2$ + "[0]))[bytei]));" 'get element
|
|
Print #12, "int64val=tqbs->len; int64val<<=3;"
|
|
Print #12, "sub_put(FF,NULL,byte_element((uint64)&int64val,8," + NewByteElement$ + "),0);" 'size of element
|
|
Print #12, "sub_put(FF,NULL,byte_element((uint64)tqbs->chr,tqbs->len," + NewByteElement$ + "),0);" 'element data
|
|
Print #12, "bytei++;"
|
|
Print #12, "}"
|
|
|
|
End If 'com=4
|
|
|
|
Print #12, "}" 'don't add unless defined
|
|
|
|
Close #12
|
|
|
|
|
|
|
|
|
|
'if chaincommonarray then
|
|
'l2$=tlayout$
|
|
'x=chaincommonarray
|
|
'
|
|
''chain???.txt
|
|
'open tmpdir$ + "chain" + str2$(x) + ".txt" for append as #22
|
|
'if lof(22) then close #22: goto chaindone 'only add this once
|
|
''***assume non-var-len-string array***
|
|
'print #22,"int32val=3;" 'non-var-len-element array
|
|
'print #22,"sub_put(FF,NULL,byte_element((uint64)&int32val,4,"+NewByteElement$+"),0);"
|
|
't=id.arraytype
|
|
''***check for UDT size if necessary***
|
|
''***check for string length if necessary***
|
|
'bits=t and 511
|
|
'print #22,"int64val="+str2$(bits)+";" 'size in bits
|
|
'print #22,"sub_put(FF,NULL,byte_element((uint64)&int64val,8,"+NewByteElement$+"),0);"
|
|
'print #22,"int32val="+str2$(id.arrayelements)+";" 'number of elements
|
|
'print #22,"sub_put(FF,NULL,byte_element((uint64)&int32val,4,"+NewByteElement$+"),0);"
|
|
'e$=rtrim$(id.n)
|
|
'if (t and ISUDT)=0 then e$=e$+typevalue2symbol$(t)
|
|
'n$=e$
|
|
'for x2=1 to id.arrayelements
|
|
''simulate calls to lbound/ubound
|
|
'e$="LBOUND"+sp+"("+sp+n$+sp+","+sp+str2$(x2)+sp+")"
|
|
'e$=evaluatetotyp(fixoperationorder$(e$),64)
|
|
'print #22,"int64val="+e$+";"'LBOUND
|
|
'print #22,"sub_put(FF,NULL,byte_element((uint64)&int64val,8,"+NewByteElement$+"),0);"
|
|
'e$="UBOUND"+sp+"("+sp+n$+sp+","+sp+str2$(x2)+sp+")"
|
|
'e$=evaluatetotyp(fixoperationorder$(e$),64)
|
|
'print #22,"int64val="+e$+";"'LBOUND
|
|
'print #22,"sub_put(FF,NULL,byte_element((uint64)&int64val,8,"+NewByteElement$+"),0);"
|
|
'next
|
|
''add array data
|
|
'e$=evaluatetotyp(fixoperationorder$(n$+sp+"("+sp+")"),-4)
|
|
'print #22,"sub_put(FF,NULL,"+e$+",0);"
|
|
'close #22
|
|
'
|
|
''inpchain???.txt
|
|
'open tmpdir$ + "chain" + str2$(x) + ".txt" for append as #22
|
|
'print #22,"if (int32val==1){" 'common declaration of an array
|
|
'print #22,"sub_get(FF,NULL,byte_element((uint64)&int32val,4,"+NewByteElement$+"),0);"
|
|
'print #22,"if (int32val==3){" 'fixed-length-element array
|
|
'
|
|
'print #22,"sub_get(FF,NULL,byte_element((uint64)&int64val,8,"+NewByteElement$+"),0);"
|
|
''***assume size correct and continue***
|
|
'
|
|
''get number of elements
|
|
'print #22,"sub_get(FF,NULL,byte_element((uint64)&int32val,4,"+NewByteElement$+"),0);"
|
|
'
|
|
''call dim2 and tell it to redim an array
|
|
'
|
|
''*********this should happen BEFORE the array (above) is actually dimensioned,
|
|
''*********where the common() declaration is
|
|
'
|
|
''****although, if you never reference the array.............
|
|
''****ARGH! you can access an undimmed array just like in a sub/function
|
|
'
|
|
'
|
|
'
|
|
'
|
|
'print #22,"}"
|
|
'print #22,"}"
|
|
'close #22
|
|
'
|
|
'chaindone:
|
|
'tlayout$=l2$
|
|
'end if 'chaincommonarray
|
|
|
|
|
|
|
|
|
|
'OPEN tmpdir$ + "chain.txt" FOR APPEND AS #22
|
|
''include directive
|
|
'print #22, "#include " + CHR$(34) + "chain" + str2$(x) + ".txt" + CHR$(34)
|
|
'close #22
|
|
''create/clear include file
|
|
'open tmpdir$ + "chain" + str2$(x) + ".txt" for output as #22:close #22
|
|
'
|
|
'OPEN tmpdir$ + "inpchain.txt" FOR APPEND AS #22
|
|
''include directive
|
|
'print #22, "#include " + CHR$(34) + "inpchain" + str2$(x) + ".txt" + CHR$(34)
|
|
'close #22
|
|
''create/clear include file
|
|
'open tmpdir$ + "inpchain" + str2$(x) + ".txt" for output as #22:close #22
|
|
|
|
|
|
|
|
|
|
|
|
|
|
End If 'id.arrayelements=-1
|
|
|
|
Next
|
|
use_global_byte_elements = 0
|
|
If Debug Then Print #9, "Finished generation of code for saving/sharing common array data!"
|
|
|
|
|
|
For closeall = 1 To 255: Close closeall: Next
|
|
Open tmpdir$ + "temp.bin" For Output Lock Write As #26 'relock
|
|
compilelog$ = tmpdir$ + "compilelog.txt"
|
|
Open compilelog$ For Output As #1: Close #1 'Clear log
|
|
|
|
If idemode = 0 And Not QuietMode Then
|
|
If ConsoleMode Then
|
|
Print "[" + String$(maxprogresswidth, ".") + "] 100%"
|
|
Else
|
|
Locate , 1
|
|
Print String$(maxprogresswidth, 219) + " 100%"
|
|
End If
|
|
End If
|
|
|
|
'OPEN "unusedVariableList.txt" FOR OUTPUT AS #1: CLOSE #1
|
|
'OPEN "unusedVariableList.txt" FOR BINARY AS #1
|
|
'PUT #1, 1, usedVariableList$ 'warning$(1)
|
|
'CLOSE #1
|
|
If Not IgnoreWarnings Then
|
|
totalUnusedVariables = 0
|
|
For i = 1 To totalVariablesCreated
|
|
If usedVariableList(i).used = 0 Then
|
|
totalUnusedVariables = totalUnusedVariables + 1
|
|
End If
|
|
Next
|
|
|
|
If totalUnusedVariables > 0 Then
|
|
maxVarNameLen = 0
|
|
For i = 1 To totalVariablesCreated
|
|
If usedVariableList(i).used = 0 Then
|
|
If Len(usedVariableList(i).name) > maxVarNameLen Then maxVarNameLen = Len(usedVariableList(i).name)
|
|
End If
|
|
Next
|
|
|
|
header$ = "unused variable" 's (" + LTRIM$(STR$(totalUnusedVariables)) + ")"
|
|
For i = 1 To totalVariablesCreated
|
|
If usedVariableList(i).used = 0 Then
|
|
addWarning usedVariableList(i).linenumber, usedVariableList(i).includeLevel, usedVariableList(i).includedLine, usedVariableList(i).includedFile, header$, usedVariableList(i).name + Space$((maxVarNameLen + 1) - Len(usedVariableList(i).name)) + " (" + usedVariableList(i).cname + ")"
|
|
End If
|
|
Next
|
|
End If
|
|
End If
|
|
|
|
If idemode Then GoTo ideret5
|
|
ide6:
|
|
|
|
If idemode = 0 And No_C_Compile_Mode = 0 Then
|
|
If Not QuietMode Then
|
|
Print
|
|
If os$ = "LNX" Then
|
|
Print "Compiling C++ code into executable..."
|
|
Else
|
|
Print "Compiling C++ code into EXE..."
|
|
End If
|
|
End If
|
|
If Len(outputfile_cmd$) Then
|
|
'resolve relative path for output file
|
|
path.out$ = getfilepath$(outputfile_cmd$)
|
|
f$ = Mid$(outputfile_cmd$, Len(path.out$) + 1)
|
|
file$ = RemoveFileExtension$(f$)
|
|
If Len(path.out$) Then
|
|
If _DirExists(path.out$) = 0 Then
|
|
Print
|
|
Print "Can't create output executable - path not found: " + path.out$
|
|
If ConsoleMode Then System 1
|
|
End 1
|
|
End If
|
|
currentdir$ = _CWD$
|
|
ChDir path.out$
|
|
path.out$ = _CWD$
|
|
ChDir currentdir$
|
|
If Right$(path.out$, 1) <> pathsep$ Then path.out$ = path.out$ + pathsep$
|
|
path.exe$ = path.out$
|
|
SaveExeWithSource = -1 'Override the global setting if an output file was specified
|
|
End If
|
|
End If
|
|
t.path.exe$ = path.exe$
|
|
If path.exe$ = "../../" Or path.exe$ = "..\..\" Then path.exe$ = ""
|
|
If _FileExists(path.exe$ + file$ + extension$) Then
|
|
E = 0
|
|
On Error GoTo qberror_test
|
|
Kill path.exe$ + file$ + extension$
|
|
On Error GoTo qberror
|
|
If E = 1 Then
|
|
a$ = "CANNOT CREATE " + Chr$(34) + file$ + extension$ + Chr$(34) + " BECAUSE THE FILE IS ALREADY IN USE!": GoTo errmes
|
|
End If
|
|
End If
|
|
path.exe$ = t.path.exe$
|
|
End If
|
|
|
|
|
|
If os$ = "WIN" Then
|
|
'Prepare to embed icon into .EXE
|
|
If ExeIconSet Or VersionInfoSet Then
|
|
If _FileExists(tmpdir$ + "icon.o") Then
|
|
E = 0
|
|
On Error GoTo qberror_test
|
|
Kill tmpdir$ + "icon.o"
|
|
If E = 1 Or _FileExists(tmpdir$ + "icon.o") = -1 Then a$ = "Error creating resource file": GoTo errmes
|
|
On Error GoTo qberror
|
|
End If
|
|
End If
|
|
|
|
If ExeIconSet Then
|
|
linenumber = ExeIconSet 'on error, this allows reporting the linenumber where $EXEICON was used
|
|
wholeline = " $EXEICON:'" + ExeIconFile$ + "'"
|
|
End If
|
|
|
|
If VersionInfoSet Then
|
|
iconfilehandle = FreeFile
|
|
Open tmpdir$ + "icon.rc" For Append As #iconfilehandle
|
|
Print #iconfilehandle, ""
|
|
Print #iconfilehandle, "1 VERSIONINFO"
|
|
If Len(viFileVersionNum$) Then Print #iconfilehandle, "FILEVERSION "; viFileVersionNum$
|
|
If Len(viProductVersionNum$) Then Print #iconfilehandle, "PRODUCTVERSION "; viProductVersionNum$
|
|
Print #iconfilehandle, "BEGIN"
|
|
Print #iconfilehandle, " BLOCK " + QuotedFilename$("StringFileInfo")
|
|
Print #iconfilehandle, " BEGIN"
|
|
Print #iconfilehandle, " BLOCK " + QuotedFilename$("040904E4")
|
|
Print #iconfilehandle, " BEGIN"
|
|
Print #iconfilehandle, " VALUE " + QuotedFilename$("CompanyName") + "," + QuotedFilename$(viCompanyName$ + "\0")
|
|
Print #iconfilehandle, " VALUE " + QuotedFilename$("FileDescription") + "," + QuotedFilename$(viFileDescription$ + "\0")
|
|
Print #iconfilehandle, " VALUE " + QuotedFilename$("FileVersion") + "," + QuotedFilename$(viFileVersion$ + "\0")
|
|
Print #iconfilehandle, " VALUE " + QuotedFilename$("InternalName") + "," + QuotedFilename$(viInternalName$ + "\0")
|
|
Print #iconfilehandle, " VALUE " + QuotedFilename$("LegalCopyright") + "," + QuotedFilename$(viLegalCopyright$ + "\0")
|
|
Print #iconfilehandle, " VALUE " + QuotedFilename$("LegalTrademarks") + "," + QuotedFilename$(viLegalTrademarks$ + "\0")
|
|
Print #iconfilehandle, " VALUE " + QuotedFilename$("OriginalFilename") + "," + QuotedFilename$(viOriginalFilename$ + "\0")
|
|
Print #iconfilehandle, " VALUE " + QuotedFilename$("ProductName") + "," + QuotedFilename$(viProductName$ + "\0")
|
|
Print #iconfilehandle, " VALUE " + QuotedFilename$("ProductVersion") + "," + QuotedFilename$(viProductVersion$ + "\0")
|
|
Print #iconfilehandle, " VALUE " + QuotedFilename$("Comments") + "," + QuotedFilename$(viComments$ + "\0")
|
|
Print #iconfilehandle, " VALUE " + QuotedFilename$("Web") + "," + QuotedFilename$(viWeb$ + "\0")
|
|
Print #iconfilehandle, " END"
|
|
Print #iconfilehandle, " END"
|
|
Print #iconfilehandle, " BLOCK " + QuotedFilename$("VarFileInfo")
|
|
Print #iconfilehandle, " BEGIN"
|
|
Print #iconfilehandle, " VALUE " + QuotedFilename$("Translation") + ", 0x409, 0x04E4"
|
|
Print #iconfilehandle, " END"
|
|
Print #iconfilehandle, "END"
|
|
Close #iconfilehandle
|
|
End If
|
|
|
|
If ExeIconSet Or VersionInfoSet Then
|
|
ffh = FreeFile
|
|
Open tmpdir$ + "call_windres.bat" For Output As #ffh
|
|
Print #ffh, "internal\c\c_compiler\bin\windres.exe -i " + tmpdir$ + "icon.rc -o " + tmpdir$ + "icon.o"
|
|
Close #ffh
|
|
Shell _Hide tmpdir$ + "call_windres.bat"
|
|
If _FileExists(tmpdir$ + "icon.o") = 0 Then
|
|
a$ = "Bad icon file"
|
|
If VersionInfoSet Then a$ = a$ + " or invalid $VERSIONINFO values"
|
|
GoTo errmes
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
'Update dependencies
|
|
|
|
o$ = LCase$(os$)
|
|
win = 0: If os$ = "WIN" Then win = 1
|
|
lnx = 0: If os$ = "LNX" Then lnx = 1
|
|
mac = 0: If MacOSX Then mac = 1: o$ = "osx"
|
|
defines$ = "": defines_header$ = " -D "
|
|
ver$ = Version$ 'eg. "0.123"
|
|
x = InStr(ver$, "."): If x Then Asc(ver$, x) = 95 'change "." to "_"
|
|
libs$ = ""
|
|
|
|
If DEPENDENCY(DEPENDENCY_GL) Then
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_GL"
|
|
End If
|
|
|
|
If DEPENDENCY(DEPENDENCY_SCREENIMAGE) Then
|
|
DEPENDENCY(DEPENDENCY_IMAGE_CODEC) = 1 'used by OSX to read in screen capture files
|
|
End If
|
|
|
|
If DEPENDENCY(DEPENDENCY_IMAGE_CODEC) Then
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_IMAGE_CODEC"
|
|
End If
|
|
|
|
If DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) Then
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_CONSOLE_ONLY"
|
|
End If
|
|
|
|
If DEPENDENCY(DEPENDENCY_SOCKETS) Then
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_SOCKETS"
|
|
Else
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_NO_SOCKETS"
|
|
End If
|
|
|
|
If DEPENDENCY(DEPENDENCY_PRINTER) Then
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_PRINTER"
|
|
Else
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_NO_PRINTER"
|
|
End If
|
|
|
|
If DEPENDENCY(DEPENDENCY_ICON) Then
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_ICON"
|
|
Else
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_NO_ICON"
|
|
End If
|
|
|
|
If DEPENDENCY(DEPENDENCY_SCREENIMAGE) Then
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_SCREENIMAGE"
|
|
Else
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_NO_SCREENIMAGE"
|
|
End If
|
|
|
|
If DEPENDENCY(DEPENDENCY_LOADFONT) Then
|
|
d$ = "internal\c\parts\video\font\ttf\"
|
|
'rebuild?
|
|
If _FileExists(d$ + "os\" + o$ + "\src.o") = 0 Then
|
|
Build d$ + "os\" + o$
|
|
End If
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_LOADFONT"
|
|
libs$ = libs$ + " " + "parts\video\font\ttf\os\" + o$ + "\src.o"
|
|
End If
|
|
|
|
localpath$ = "internal\c\"
|
|
|
|
If DEPENDENCY(DEPENDENCY_DEVICEINPUT) Then
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_DEVICEINPUT"
|
|
libname$ = "input\game_controller"
|
|
libpath$ = "parts\" + libname$ + "\os\" + o$
|
|
libfile$ = libpath$ + "\src.a"
|
|
If _FileExists(localpath$ + libfile$) = 0 Then Build localpath$ + libpath$ 'rebuild?
|
|
libs$ = libs$ + " " + libfile$
|
|
End If
|
|
|
|
If DEPENDENCY(DEPENDENCY_AUDIO_DECODE) Then DEPENDENCY(DEPENDENCY_AUDIO_CONVERSION) = 1
|
|
If DEPENDENCY(DEPENDENCY_AUDIO_CONVERSION) Then DEPENDENCY(DEPENDENCY_AUDIO_OUT) = 1
|
|
If DEPENDENCY(DEPENDENCY_AUDIO_DECODE) Then DEPENDENCY(DEPENDENCY_AUDIO_OUT) = 1
|
|
|
|
|
|
If DEPENDENCY(DEPENDENCY_AUDIO_CONVERSION) Then
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_AUDIO_CONVERSION"
|
|
|
|
d1$ = "parts\audio\conversion"
|
|
d2$ = d1$ + "\os\" + o$
|
|
d3$ = "internal\c\" + d2$
|
|
If _FileExists(d3$ + "\src.a") = 0 Then 'rebuild?
|
|
Build d3$
|
|
End If
|
|
libs$ = libs$ + " " + d2$ + "\src.a"
|
|
End If
|
|
|
|
If DEPENDENCY(DEPENDENCY_AUDIO_DECODE) Then
|
|
'General decoder
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_AUDIO_DECODE"
|
|
'MINI_MP3 decoder
|
|
d1$ = "parts\audio\decode\mp3_mini"
|
|
d2$ = d1$ + "\os\" + o$
|
|
d3$ = "internal\c\" + d2$
|
|
If _FileExists(d3$ + "\src.a") = 0 Then 'rebuild?
|
|
Build d3$
|
|
End If
|
|
libs$ = libs$ + " " + d2$ + "\src.a"
|
|
'OGG decoder
|
|
d1$ = "parts\audio\decode\ogg"
|
|
d2$ = d1$ + "\os\" + o$
|
|
d3$ = "internal\c\" + d2$
|
|
If _FileExists(d3$ + "\src.o") = 0 Then 'rebuild?
|
|
Build d3$
|
|
End If
|
|
libs$ = libs$ + " " + d2$ + "\src.o"
|
|
'WAV decoder
|
|
'(no action required)
|
|
End If
|
|
|
|
If DEPENDENCY(DEPENDENCY_AUDIO_OUT) Then
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_AUDIO_OUT"
|
|
d1$ = "parts\audio\out"
|
|
d2$ = d1$ + "\os\" + o$
|
|
d3$ = "internal\c\" + d2$
|
|
If _FileExists(d3$ + "\src.a") = 0 Then 'rebuild?
|
|
Build d3$
|
|
End If
|
|
libs$ = libs$ + " " + d2$ + "\src.a"
|
|
End If
|
|
|
|
If DEPENDENCY(DEPENDENCY_ZLIB) Then
|
|
defines$ = defines$ + defines_header$ + "DEPENDENCY_ZLIB"
|
|
If MacOSX Then
|
|
libs$ = libs$ + " -lz"
|
|
Else
|
|
libs$ = libs$ + " -l:libz.a"
|
|
End If
|
|
End If
|
|
|
|
'finalize libs$ and defines$ strings
|
|
If Len(libs$) Then libs$ = libs$ + " "
|
|
PATH_SLASH_CORRECT libs$
|
|
If Len(defines$) Then defines$ = defines$ + " "
|
|
|
|
'Build core?
|
|
If mac = 0 Then 'macosx uses Apple's GLUT not FreeGLUT
|
|
d1$ = "parts\core"
|
|
d2$ = d1$ + "\os\" + o$
|
|
d3$ = "internal\c\" + d2$
|
|
If _FileExists(d3$ + "\src.a") = 0 Then 'rebuild?
|
|
Build d3$
|
|
End If
|
|
End If 'mac = 0
|
|
|
|
'Build libqb?
|
|
depstr$ = ver$ + "_"
|
|
For i = 1 To DEPENDENCY_LAST
|
|
If DEPENDENCY(i) Then depstr$ = depstr$ + "1" Else depstr$ = depstr$ + "0"
|
|
Next
|
|
libqb$ = " libqb\os\" + o$ + "\libqb_" + depstr$ + ".o "
|
|
PATH_SLASH_CORRECT libqb$
|
|
If _FileExists("internal\c\" + LTrim$(RTrim$(libqb$))) = 0 Then
|
|
ChDir "internal\c"
|
|
If os$ = "WIN" Then
|
|
Shell _Hide GDB_Fix("cmd /c c_compiler\bin\g++ -c -s -w -Wall libqb.cpp -D FREEGLUT_STATIC " + defines$ + " -o libqb\os\" + o$ + "\libqb_" + depstr$ + ".o") + " 2>> ..\..\" + compilelog$
|
|
Else
|
|
If mac Then
|
|
Shell _Hide GDB_Fix("g++ -c -s -w -Wall libqb.mm " + defines$ + " -o libqb/os/" + o$ + "/libqb_" + depstr$ + ".o") + " 2>> ../../" + compilelog$
|
|
Else
|
|
Shell _Hide GDB_Fix("g++ -c -s -w -Wall libqb.cpp -D FREEGLUT_STATIC " + defines$ + " -o libqb/os/" + o$ + "/libqb_" + depstr$ + ".o") + " 2>> ../../" + compilelog$
|
|
End If
|
|
End If
|
|
ChDir "..\.."
|
|
End If
|
|
|
|
'link-time only defines
|
|
If DEPENDENCY(DEPENDENCY_AUDIO_OUT) Then
|
|
If mac Then defines$ = defines$ + " -framework AudioUnit -framework AudioToolbox "
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
If os$ = "WIN" Then
|
|
|
|
'resolve static function definitions and add to global.txt
|
|
For x = 1 To ResolveStaticFunctions
|
|
If Len(ResolveStaticFunction_File(x)) Then
|
|
|
|
n = 0
|
|
Shell _Hide "internal\c\c_compiler\bin\nm.exe " + Chr$(34) + ResolveStaticFunction_File(x) + Chr$(34) + " --demangle -g >internal\temp\nm_output.txt"
|
|
fh = FreeFile
|
|
s$ = " " + ResolveStaticFunction_Name(x) + "("
|
|
Open "internal\temp\nm_output.txt" For Binary As #fh
|
|
Do Until EOF(fh)
|
|
Line Input #fh, a$
|
|
If Len(a$) Then
|
|
'search for SPACE+functionname+LEFTBRACKET
|
|
x1 = InStr(a$, s$)
|
|
If x1 Then
|
|
If ResolveStaticFunction_Method(x) = 1 Then
|
|
x1 = x1 + 1
|
|
x2 = InStr(x1, a$, ")")
|
|
fh2 = FreeFile
|
|
Open tmpdir$ + "global.txt" For Append As #fh2
|
|
Print #fh2, "extern void " + Mid$(a$, x1, x2 - x1 + 1) + ";"
|
|
Close #fh2
|
|
End If
|
|
n = n + 1
|
|
End If 'x1
|
|
End If '<>""
|
|
Loop
|
|
Close #fh
|
|
If n > 1 Then a$ = "Unable to resolve multiple instances of sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GoTo errmes
|
|
|
|
If n = 0 Then 'attempt to locate simple function name without brackets
|
|
fh = FreeFile
|
|
s$ = " " + ResolveStaticFunction_Name(x)
|
|
Open "internal\temp\nm_output.txt" For Binary As #fh
|
|
Do Until EOF(fh)
|
|
Line Input #fh, a$
|
|
If Len(a$) Then
|
|
'search for SPACE+functionname
|
|
x1 = InStr(a$, s$)
|
|
If Right$(a$, Len(s$)) = s$ Then
|
|
fh2 = FreeFile
|
|
If ResolveStaticFunction_Method(x) = 1 Then
|
|
Open tmpdir$ + "global.txt" For Append As #fh2
|
|
Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + "{"
|
|
Print #fh2, "extern void " + s$ + "(void);"
|
|
Print #fh2, "}"
|
|
Else
|
|
Open tmpdir$ + "externtype" + str2(x) + ".txt" For Output As #fh2
|
|
Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + " "
|
|
End If
|
|
Close #fh2
|
|
n = n + 1
|
|
Exit Do
|
|
End If 'x1
|
|
End If '<>""
|
|
Loop
|
|
Close #fh
|
|
End If
|
|
|
|
If n = 0 Then 'a C++ dynamic object library?
|
|
Shell _Hide "internal\c\c_compiler\bin\nm " + Chr$(34) + ResolveStaticFunction_File(x) + Chr$(34) + " -D --demangle -g >.\internal\temp\nm_output_dynamic.txt"
|
|
fh = FreeFile
|
|
s$ = " " + ResolveStaticFunction_Name(x) + "("
|
|
Open "internal\temp\nm_output_dynamic.txt" For Binary As #fh
|
|
Do Until EOF(fh)
|
|
Line Input #fh, a$
|
|
If Len(a$) Then
|
|
'search for SPACE+functionname+LEFTBRACKET
|
|
x1 = InStr(a$, s$)
|
|
If x1 Then
|
|
If ResolveStaticFunction_Method(x) = 1 Then
|
|
x1 = x1 + 1
|
|
x2 = InStr(x1, a$, ")")
|
|
fh2 = FreeFile
|
|
Open tmpdir$ + "global.txt" For Append As #fh2
|
|
Print #fh2, "extern void " + Mid$(a$, x1, x2 - x1 + 1) + ";"
|
|
Close #fh2
|
|
End If
|
|
n = n + 1
|
|
End If 'x1
|
|
End If '<>""
|
|
Loop
|
|
Close #fh
|
|
If n > 1 Then a$ = "Unable to resolve multiple instances of sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GoTo errmes
|
|
End If
|
|
|
|
If n = 0 Then 'a C dynamic object library?
|
|
fh = FreeFile
|
|
s$ = " " + ResolveStaticFunction_Name(x)
|
|
Open "internal\temp\nm_output_dynamic.txt" For Binary As #fh
|
|
Do Until EOF(fh)
|
|
Line Input #fh, a$
|
|
If Len(a$) Then
|
|
'search for SPACE+functionname
|
|
x1 = InStr(a$, s$)
|
|
If Right$(a$, Len(s$)) = s$ Then
|
|
fh2 = FreeFile
|
|
If ResolveStaticFunction_Method(x) = 1 Then
|
|
Open tmpdir$ + "global.txt" For Append As #fh2
|
|
Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + "{"
|
|
Print #fh2, "extern void " + s$ + "(void);"
|
|
Print #fh2, "}"
|
|
Else
|
|
Open tmpdir$ + "externtype" + str2(x) + ".txt" For Output As #fh2
|
|
Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + " "
|
|
End If
|
|
Close #fh2
|
|
n = n + 1
|
|
Exit Do
|
|
End If 'x1
|
|
End If '<>""
|
|
Loop
|
|
Close #fh
|
|
If n = 0 Then a$ = "Could not find sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GoTo errmes
|
|
End If
|
|
|
|
End If
|
|
Next
|
|
|
|
If inline_DATA = 0 Then
|
|
If DataOffset Then
|
|
If OS_BITS = 32 Then
|
|
Open ".\internal\c\makedat_win32.txt" For Binary As #150: Line Input #150, a$: Close #150
|
|
Else
|
|
Open ".\internal\c\makedat_win64.txt" For Binary As #150: Line Input #150, a$: Close #150
|
|
End If
|
|
a$ = a$ + " " + tmpdir2$ + "data.bin " + tmpdir2$ + "data.o"
|
|
ChDir ".\internal\c"
|
|
Shell _Hide "cmd /c " + a$ + " 2>> ..\..\" + compilelog$
|
|
ChDir "..\.."
|
|
End If
|
|
End If
|
|
|
|
|
|
|
|
|
|
Open ".\internal\c\makeline_win.txt" For Binary As #150
|
|
Line Input #150, a$: a$ = GDB_Fix(a$)
|
|
Close #150
|
|
If Right$(a$, 7) = " ..\..\" Then a$ = Left$(a$, Len(a$) - 6) 'makeline.txt patch (line will become unrequired in later versions)
|
|
'change qbx.cpp to qbx999.cpp?
|
|
x = InStr(a$, "qbx.cpp"): If x <> 0 And tempfolderindex <> 1 Then a$ = Left$(a$, x - 1) + "qbx" + str2$(tempfolderindex) + ".cpp" + Right$(a$, Len(a$) - (x + 6))
|
|
|
|
If Console Then
|
|
x = InStr(a$, " -s"): a$ = Left$(a$, x - 1) + " -mconsole" + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
|
|
If DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) Then
|
|
a$ = StrRemove(a$, "-mwindows")
|
|
a$ = StrRemove(a$, "-lopengl32")
|
|
a$ = StrRemove(a$, "-lglu32")
|
|
a$ = StrRemove(a$, "parts\core\os\win\src.a")
|
|
a$ = StrRemove(a$, "-D FREEGLUT_STATIC")
|
|
a$ = StrRemove(a$, "-D GLEW_STATIC")
|
|
End If
|
|
|
|
a$ = StrRemove(a$, "-lws2_32")
|
|
If DEPENDENCY(DEPENDENCY_SOCKETS) Then
|
|
x = InStr(a$, " -o"): a$ = Left$(a$, x - 1) + " -lws2_32" + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
|
|
a$ = StrRemove(a$, "-lwinspool")
|
|
If DEPENDENCY(DEPENDENCY_PRINTER) Then
|
|
x = InStr(a$, " -o"): a$ = Left$(a$, x - 1) + " -lwinspool" + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
|
|
a$ = StrRemove(a$, "-lwinmm")
|
|
If DEPENDENCY(DEPENDENCY_AUDIO_OUT) <> 0 Or DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) = 0 Then
|
|
x = InStr(a$, " -o"): a$ = Left$(a$, x - 1) + " -lwinmm" + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
|
|
a$ = StrRemove(a$, "-lksguid")
|
|
If DEPENDENCY(DEPENDENCY_AUDIO_OUT) Then
|
|
x = InStr(a$, " -o"): a$ = Left$(a$, x - 1) + " -lksguid" + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
|
|
a$ = StrRemove(a$, "-ldxguid")
|
|
If DEPENDENCY(DEPENDENCY_AUDIO_OUT) Then
|
|
x = InStr(a$, " -o"): a$ = Left$(a$, x - 1) + " -ldxguid" + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
|
|
a$ = StrRemove(a$, "-lole32")
|
|
If DEPENDENCY(DEPENDENCY_AUDIO_OUT) Then
|
|
x = InStr(a$, " -o"): a$ = Left$(a$, x - 1) + " -lole32" + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
|
|
a$ = StrRemove(a$, "-lgdi32")
|
|
If DEPENDENCY(DEPENDENCY_ICON) <> 0 Or DEPENDENCY(DEPENDENCY_SCREENIMAGE) <> 0 Or DEPENDENCY(DEPENDENCY_PRINTER) <> 0 Then
|
|
x = InStr(a$, " -o"): a$ = Left$(a$, x - 1) + " -lgdi32" + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
|
|
If inline_DATA = 0 Then
|
|
'add data.o?
|
|
If DataOffset Then
|
|
x = InStr(a$, ".cpp ")
|
|
If x Then
|
|
x = x + 3
|
|
a$ = Left$(a$, x) + " " + tmpdir2$ + "data.o" + " " + Right$(a$, Len(a$) - x)
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
'add custom libraries
|
|
'mylib$="..\..\"+x$+".lib"
|
|
If Len(mylib$) Then
|
|
x = InStr(a$, ".cpp ")
|
|
If x Then
|
|
x = x + 3
|
|
a$ = Left$(a$, x) + " " + mylib$ + " " + Right$(a$, Len(a$) - x)
|
|
End If
|
|
End If
|
|
|
|
|
|
'add dependent libraries
|
|
If Len(libs$) Then
|
|
x = InStr(a$, ".cpp ")
|
|
If x Then
|
|
x = x + 5
|
|
a$ = Left$(a$, x - 1) + libs$ + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
End If
|
|
|
|
'add dependency defines
|
|
If Len(defines$) Then
|
|
x = InStr(a$, ".cpp ")
|
|
If x Then
|
|
x = x + 5
|
|
a$ = Left$(a$, x - 1) + defines$ + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
End If
|
|
|
|
'add libqb
|
|
x = InStr(a$, ".cpp ")
|
|
If x Then
|
|
x = x + 5
|
|
a$ = Left$(a$, x - 1) + libqb$ + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
|
|
'Add icon.o to the makeline
|
|
If ExeIconSet Or VersionInfoSet Then
|
|
If x Then 'Use the previous libqb insertion point
|
|
a$ = Left$(a$, x + Len(libqb$)) + "..\..\" + tmpdir$ + "icon.o " + Mid$(a$, x + Len(libqb$) + 1)
|
|
End If
|
|
End If
|
|
|
|
a$ = a$ + QuotedFilename$(path.exe$ + file$ + extension$)
|
|
|
|
ffh = FreeFile
|
|
Open tmpdir$ + "recompile_win.bat" For Output As #ffh
|
|
Print #ffh, "@echo off"
|
|
Print #ffh, "cd %0\..\"
|
|
Print #ffh, "echo Recompiling..."
|
|
Print #ffh, "cd ../c"
|
|
Print #ffh, a$
|
|
Print #ffh, "pause"
|
|
Close ffh
|
|
|
|
ffh = FreeFile
|
|
Open tmpdir$ + "debug_win.bat" For Output As #ffh
|
|
Print #ffh, "@echo off"
|
|
Print #ffh, "cd %0\..\"
|
|
Print #ffh, "cd ../.."
|
|
Print #ffh, "echo C++ Debugging: " + file$ + extension$ + " using gdb.exe"
|
|
Print #ffh, "echo Debugger commands:"
|
|
Print #ffh, "echo After the debugger launches type 'run' to start your program"
|
|
Print #ffh, "echo After your program crashes type 'list' to find where the problem is and fix/report it"
|
|
Print #ffh, "echo Type 'quit' to exit"
|
|
Print #ffh, "echo (the GDB debugger has many other useful commands, this advice is for beginners)"
|
|
Print #ffh, "pause"
|
|
Print #ffh, "internal\c\c_compiler\bin\gdb.exe " + Chr$(34) + path.exe$ + file$ + extension$ + Chr$(34)
|
|
Print #ffh, "pause"
|
|
Close ffh
|
|
|
|
If No_C_Compile_Mode = 0 Then
|
|
ChDir ".\internal\c"
|
|
Shell _Hide "cmd /c " + a$ + " 2>> ..\..\" + compilelog$
|
|
ChDir "..\.."
|
|
If idemode Then
|
|
'Restore fg/bg colors
|
|
dummy = DarkenFGBG(0)
|
|
End If
|
|
End If 'No_C_Compile_Mode=0
|
|
|
|
End If
|
|
|
|
If os$ = "LNX" Then
|
|
For x = 1 To ResolveStaticFunctions
|
|
If Len(ResolveStaticFunction_File(x)) Then
|
|
|
|
n = 0
|
|
If MacOSX = 0 Then Shell _Hide "nm " + Chr$(34) + ResolveStaticFunction_File(x) + Chr$(34) + " --demangle -g >./internal/temp/nm_output.txt 2>./internal/temp/nm_error.txt"
|
|
If MacOSX Then Shell _Hide "nm " + Chr$(34) + ResolveStaticFunction_File(x) + Chr$(34) + " >./internal/temp/nm_output.txt 2>./internal/temp/nm_error.txt"
|
|
|
|
If MacOSX = 0 Then 'C++ name demangling not supported in MacOSX
|
|
fh = FreeFile
|
|
s$ = " " + ResolveStaticFunction_Name(x) + "("
|
|
Open "internal\temp\nm_output.txt" For Binary As #fh
|
|
Do Until EOF(fh)
|
|
Line Input #fh, a$
|
|
If Len(a$) Then
|
|
'search for SPACE+functionname+LEFTBRACKET
|
|
x1 = InStr(a$, s$)
|
|
If x1 Then
|
|
If ResolveStaticFunction_Method(x) = 1 Then
|
|
x1 = x1 + 1
|
|
x2 = InStr(x1, a$, ")")
|
|
fh2 = FreeFile
|
|
Open tmpdir$ + "global.txt" For Append As #fh2
|
|
Print #fh2, "extern void " + Mid$(a$, x1, x2 - x1 + 1) + ";"
|
|
Close #fh2
|
|
End If
|
|
n = n + 1
|
|
End If 'x1
|
|
End If '<>""
|
|
Loop
|
|
Close #fh
|
|
If n > 1 Then a$ = "Unable to resolve multiple instances of sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GoTo errmes
|
|
End If 'macosx=0
|
|
|
|
If n = 0 Then 'attempt to locate simple function name without brackets
|
|
fh = FreeFile
|
|
s$ = " " + ResolveStaticFunction_Name(x): s2$ = s$
|
|
If MacOSX Then s$ = " _" + ResolveStaticFunction_Name(x) 'search for C mangled name
|
|
Open "internal\temp\nm_output.txt" For Binary As #fh
|
|
Do Until EOF(fh)
|
|
Line Input #fh, a$
|
|
If Len(a$) Then
|
|
'search for SPACE+functionname
|
|
x1 = InStr(a$, s$)
|
|
If Right$(a$, Len(s$)) = s$ Then
|
|
fh2 = FreeFile
|
|
If ResolveStaticFunction_Method(x) = 1 Then
|
|
Open tmpdir$ + "global.txt" For Append As #fh2
|
|
Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + "{"
|
|
Print #fh2, "extern void " + s2$ + "(void);"
|
|
Print #fh2, "}"
|
|
Else
|
|
Open tmpdir$ + "externtype" + str2(x) + ".txt" For Output As #fh2
|
|
Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + " "
|
|
End If
|
|
Close #fh2
|
|
n = n + 1
|
|
Exit Do
|
|
End If 'x1
|
|
End If '<>""
|
|
Loop
|
|
Close #fh
|
|
End If
|
|
|
|
If n = 0 Then 'a C++ dynamic object library?
|
|
If MacOSX Then GoTo macosx_libfind_failed
|
|
Shell _Hide "nm " + Chr$(34) + ResolveStaticFunction_File(x) + Chr$(34) + " -D --demangle -g >./internal/temp/nm_output_dynamic.txt 2>./internal/temp/nm_error.txt"
|
|
fh = FreeFile
|
|
s$ = " " + ResolveStaticFunction_Name(x) + "("
|
|
Open "internal\temp\nm_output_dynamic.txt" For Binary As #fh
|
|
Do Until EOF(fh)
|
|
Line Input #fh, a$
|
|
If Len(a$) Then
|
|
'search for SPACE+functionname+LEFTBRACKET
|
|
x1 = InStr(a$, s$)
|
|
If x1 Then
|
|
If ResolveStaticFunction_Method(x) = 1 Then
|
|
x1 = x1 + 1
|
|
x2 = InStr(x1, a$, ")")
|
|
fh2 = FreeFile
|
|
Open tmpdir$ + "global.txt" For Append As #fh2
|
|
Print #fh2, "extern void " + Mid$(a$, x1, x2 - x1 + 1) + ";"
|
|
Close #fh2
|
|
End If
|
|
n = n + 1
|
|
End If 'x1
|
|
End If '<>""
|
|
Loop
|
|
Close #fh
|
|
If n > 1 Then a$ = "Unable to resolve multiple instances of sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GoTo errmes
|
|
End If
|
|
|
|
If n = 0 Then 'a C dynamic object library?
|
|
fh = FreeFile
|
|
s$ = " " + ResolveStaticFunction_Name(x)
|
|
Open "internal\temp\nm_output_dynamic.txt" For Binary As #fh
|
|
Do Until EOF(fh)
|
|
Line Input #fh, a$
|
|
If Len(a$) Then
|
|
'search for SPACE+functionname
|
|
x1 = InStr(a$, s$)
|
|
If Right$(a$, Len(s$)) = s$ Then
|
|
fh2 = FreeFile
|
|
If ResolveStaticFunction_Method(x) = 1 Then
|
|
Open tmpdir$ + "global.txt" For Append As #fh2
|
|
Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + "{"
|
|
Print #fh2, "extern void " + s$ + "(void);"
|
|
Print #fh2, "}"
|
|
Else
|
|
Open tmpdir$ + "externtype" + str2(x) + ".txt" For Output As #fh2
|
|
Print #fh2, "extern " + Chr$(34) + "C" + Chr$(34) + " "
|
|
End If
|
|
Close #fh2
|
|
n = n + 1
|
|
Exit Do
|
|
End If 'x1
|
|
End If '<>""
|
|
Loop
|
|
Close #fh
|
|
macosx_libfind_failed:
|
|
If n = 0 Then a$ = "Could not find sub/function '" + ResolveStaticFunction_Name(x) + "' in '" + ResolveStaticFunction_File(x) + "'": GoTo errmes
|
|
End If
|
|
|
|
End If
|
|
Next
|
|
|
|
If inline_DATA = 0 Then
|
|
If DataOffset Then
|
|
If InStr(_OS$, "[32BIT]") Then b$ = "32" Else b$ = "64"
|
|
Open ".\internal\c\makedat_lnx" + b$ + ".txt" For Binary As #150: Line Input #150, a$: Close #150
|
|
a$ = a$ + " " + tmpdir2$ + "data.bin " + tmpdir2$ + "data.o"
|
|
ChDir ".\internal\c"
|
|
Shell _Hide a$ + " 2>> ../../" + compilelog$
|
|
ChDir "..\.."
|
|
End If
|
|
End If
|
|
|
|
If InStr(_OS$, "[MACOSX]") Then
|
|
Open "./internal/c/makeline_osx.txt" For Input As #150
|
|
ElseIf DEPENDENCY(DEPENDENCY_CONSOLE_ONLY) Then
|
|
Open "./internal/c/makeline_lnx_nogui.txt" For Input As #150
|
|
Else
|
|
Open "./internal/c/makeline_lnx.txt" For Input As #150
|
|
End If
|
|
|
|
Line Input #150, a$: a$ = GDB_Fix(a$)
|
|
Close #150
|
|
'change qbx.cpp to qbx999.cpp?
|
|
x = InStr(a$, "qbx.cpp"): If x <> 0 And tempfolderindex <> 1 Then a$ = Left$(a$, x - 1) + "qbx" + str2$(tempfolderindex) + ".cpp" + Right$(a$, Len(a$) - (x + 6))
|
|
|
|
If inline_DATA = 0 Then
|
|
'add data.o?
|
|
If DataOffset Then
|
|
x = InStr(a$, "-lX11")
|
|
If x Then
|
|
a$ = Left$(a$, x - 1) + " " + tmpdir2$ + "data.o " + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
|
|
'add custom libraries
|
|
If Len(mylib$) Then
|
|
x = InStr(a$, ".cpp ")
|
|
If x Then
|
|
x = x + 5
|
|
a$ = Left$(a$, x - 1) + " " + mylibopt$ + " " + mylib$ + " " + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
End If
|
|
|
|
'add dependent libraries
|
|
If Len(libs$) Then
|
|
x = InStr(a$, ".cpp ")
|
|
If x Then
|
|
x = x + 5
|
|
a$ = Left$(a$, x - 1) + libs$ + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
End If
|
|
|
|
'add dependency defines
|
|
If Len(defines$) Then
|
|
x = InStr(a$, ".cpp ")
|
|
If x Then
|
|
x = x + 5
|
|
a$ = Left$(a$, x - 1) + defines$ + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
End If
|
|
|
|
'add libqb
|
|
x = InStr(a$, ".cpp ")
|
|
If x Then
|
|
x = x + 5
|
|
a$ = Left$(a$, x - 1) + libqb$ + Right$(a$, Len(a$) - x + 1)
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
a$ = a$ + QuotedFilename$(path.exe$ + file$ + extension$)
|
|
|
|
If InStr(_OS$, "[MACOSX]") Then
|
|
|
|
ffh = FreeFile
|
|
Open tmpdir$ + "recompile_osx.command" For Output As #ffh
|
|
Print #ffh, "cd " + CHR_QUOTE + "$(dirname " + CHR_QUOTE + "$0" + CHR_QUOTE + ")" + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "echo " + CHR_QUOTE + "Recompiling..." + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "cd ../c" + Chr$(10);
|
|
Print #ffh, a$ + Chr$(10);
|
|
Print #ffh, "read -p " + CHR_QUOTE + "Press ENTER to exit..." + CHR_QUOTE + Chr$(10);
|
|
Close ffh
|
|
Shell _Hide "chmod +x " + tmpdir$ + "recompile_osx.command"
|
|
|
|
ffh = FreeFile
|
|
Open tmpdir$ + "debug_osx.command" For Output As #ffh
|
|
Print #ffh, "cd " + CHR_QUOTE + "$(dirname " + CHR_QUOTE + "$0" + CHR_QUOTE + ")" + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "Pause()" + Chr$(10);
|
|
Print #ffh, "{" + Chr$(10);
|
|
Print #ffh, "OLDCONFIG=`stty -g`" + Chr$(10);
|
|
Print #ffh, "stty -icanon -echo min 1 time 0" + Chr$(10);
|
|
Print #ffh, "dd count=1 2>/dev/null" + Chr$(10);
|
|
Print #ffh, "stty $OLDCONFIG" + Chr$(10);
|
|
Print #ffh, "}" + Chr$(10);
|
|
Print #ffh, "echo " + CHR_QUOTE + "C++ Debugging: " + file$ + extension$ + " using GDB" + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "echo " + CHR_QUOTE + "Debugger commands:" + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "echo " + CHR_QUOTE + "After the debugger launches type 'run' to start your program" + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "echo " + CHR_QUOTE + "After your program crashes type 'list' to find where the problem is and fix/report it" + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "echo " + CHR_QUOTE + "(the GDB debugger has many other useful commands, this advice is for beginners)" + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "gdb " + Chr$(34) + path.exe$ + file$ + extension$ + Chr$(34) + Chr$(10);
|
|
Print #ffh, "Pause" + Chr$(10);
|
|
Close ffh
|
|
Shell _Hide "chmod +x " + tmpdir$ + "debug_osx.command"
|
|
|
|
Else
|
|
|
|
ffh = FreeFile
|
|
Open tmpdir$ + "recompile_lnx.sh" For Output As #ffh
|
|
Print #ffh, "#!/bin/sh" + Chr$(10);
|
|
Print #ffh, "Pause()" + Chr$(10);
|
|
Print #ffh, "{" + Chr$(10);
|
|
Print #ffh, "OLDCONFIG=`stty -g`" + Chr$(10);
|
|
Print #ffh, "stty -icanon -echo min 1 time 0" + Chr$(10);
|
|
Print #ffh, "dd count=1 2>/dev/null" + Chr$(10);
|
|
Print #ffh, "stty $OLDCONFIG" + Chr$(10);
|
|
Print #ffh, "}" + Chr$(10);
|
|
Print #ffh, "echo " + CHR_QUOTE + "Recompiling..." + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "cd ../c" + Chr$(10);
|
|
Print #ffh, a$ + Chr$(10);
|
|
Print #ffh, "echo " + CHR_QUOTE + "Press ENTER to exit..." + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "Pause" + Chr$(10);
|
|
Close ffh
|
|
Shell _Hide "chmod +x " + tmpdir$ + "recompile_lnx.sh"
|
|
|
|
ffh = FreeFile
|
|
Open tmpdir$ + "debug_lnx.sh" For Output As #ffh
|
|
Print #ffh, "#!/bin/sh" + Chr$(10);
|
|
Print #ffh, "Pause()" + Chr$(10);
|
|
Print #ffh, "{" + Chr$(10);
|
|
Print #ffh, "OLDCONFIG=`stty -g`" + Chr$(10);
|
|
Print #ffh, "stty -icanon -echo min 1 time 0" + Chr$(10);
|
|
Print #ffh, "dd count=1 2>/dev/null" + Chr$(10);
|
|
Print #ffh, "stty $OLDCONFIG" + Chr$(10);
|
|
Print #ffh, "}" + Chr$(10);
|
|
Print #ffh, "echo " + CHR_QUOTE + "C++ Debugging: " + file$ + extension$ + " using GDB" + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "echo " + CHR_QUOTE + "Debugger commands:" + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "echo " + CHR_QUOTE + "After the debugger launches type 'run' to start your program" + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "echo " + CHR_QUOTE + "After your program crashes type 'list' to find where the problem is and fix/report it" + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "echo " + CHR_QUOTE + "(the GDB debugger has many other useful commands, this advice is for beginners)" + CHR_QUOTE + Chr$(10);
|
|
Print #ffh, "gdb " + Chr$(34) + path.exe$ + file$ + extension$ + Chr$(34) + Chr$(10);
|
|
Print #ffh, "Pause" + Chr$(10);
|
|
Close ffh
|
|
Shell _Hide "chmod +x " + tmpdir$ + "debug_lnx.sh"
|
|
|
|
End If
|
|
|
|
If No_C_Compile_Mode = 0 Then
|
|
ChDir "./internal/c"
|
|
Shell _Hide a$ + " 2>> ../../" + compilelog$
|
|
ChDir "../.."
|
|
If idemode Then
|
|
'Restore fg/bg colors
|
|
dummy = DarkenFGBG(0)
|
|
End If
|
|
End If
|
|
|
|
If InStr(_OS$, "[MACOSX]") Then
|
|
ff = FreeFile
|
|
If path.exe$ = "./" Or path.exe$ = "../../" Or path.exe$ = "..\..\" Then path.exe$ = ""
|
|
Open path.exe$ + file$ + extension$ + "_start.command" For Output As #ff
|
|
Print #ff, "cd " + Chr$(34) + "$(dirname " + Chr$(34) + "$0" + Chr$(34) + ")" + Chr$(34);
|
|
Print #ff, Chr$(10);
|
|
Print #ff, "./" + file$ + extension$ + " &";
|
|
Print #ff, Chr$(10);
|
|
Print #ff, "osascript -e 'tell application " + Chr$(34) + "Terminal" + Chr$(34) + " to close (every window whose name contains " + Chr$(34) + file$ + extension$ + "_start.command" + Chr$(34) + ")' &";
|
|
Print #ff, Chr$(10);
|
|
Print #ff, "osascript -e 'if (count the windows of application " + Chr$(34) + "Terminal" + Chr$(34) + ") is 0 then tell application " + Chr$(34) + "Terminal" + Chr$(34) + " to quit' &";
|
|
Print #ff, Chr$(10);
|
|
Print #ff, "exit";
|
|
Print #ff, Chr$(10);
|
|
Close #ff
|
|
Shell _Hide "chmod +x " + path.exe$ + file$ + extension$ + "_start.command"
|
|
End If
|
|
|
|
End If
|
|
|
|
If No_C_Compile_Mode Then compfailed = 0: GoTo No_C_Compile
|
|
If path.exe$ = "../../" Or path.exe$ = "..\..\" Then path.exe$ = ""
|
|
If _FileExists(path.exe$ + file$ + extension$) Then
|
|
compfailed = 0
|
|
lastBinaryGenerated$ = path.exe$ + file$ + extension$
|
|
Else
|
|
compfailed = 1 'detect compilation failure
|
|
End If
|
|
|
|
If compfailed Then
|
|
If idemode Then
|
|
idemessage$ = "C++ Compilation failed (Check " + Chr$(0) + compilelog$ + Chr$(0) + ")"
|
|
GoTo ideerror
|
|
End If
|
|
If compfailed Then
|
|
Print "ERROR: C++ compilation failed."
|
|
Print "Check " + compilelog$ + " for details."
|
|
End If
|
|
Else
|
|
If idemode = 0 And Not QuietMode Then Print "Output: "; lastBinaryGenerated$
|
|
End If
|
|
|
|
|
|
|
|
Skip_Build:
|
|
|
|
|
|
|
|
If idemode Then GoTo ideret6
|
|
|
|
No_C_Compile:
|
|
|
|
If (compfailed <> 0 Or warningsissued <> 0) And ConsoleMode = 0 Then End 1
|
|
If compfailed <> 0 Then System 1
|
|
System 0
|
|
|
|
qberror_test:
|
|
E = 1
|
|
Resume Next
|
|
|
|
qberror:
|
|
If Debug Then 'A more in-your-face error handler
|
|
If ConsoleMode Then
|
|
Print
|
|
Else
|
|
_AutoDisplay
|
|
Screen _NewImage(80, 25, 0), , 0, 0
|
|
Color 7, 0
|
|
End If
|
|
_ControlChr Off
|
|
Print "A QB error has occurred (and you have compiled in debugging support)."
|
|
Print "Some key information (qb64.bas):"
|
|
Print "Error"; Err
|
|
Print "Description: "; _ErrorMessage$
|
|
Print "Line"; _ErrorLine
|
|
If _InclErrorLine Then
|
|
Print "Included line"; _InclErrorLine
|
|
Print "Included file "; _InclErrorFile$
|
|
End If
|
|
Print
|
|
Print "Loaded source file details:"
|
|
Print "ideerror ="; ideerror; "qberrorhappened ="; qberrorhappened; "qberrorhappenedvalue ="; qberrorhappenedvalue; "linenumber ="; linenumber
|
|
Print "ca$ = {"; ca$; "}, idecommand$ = {"; idecommand$; "}"
|
|
Print "linefragment = {"; linefragment; "}"
|
|
End
|
|
End If
|
|
|
|
If ideerror Then 'error happened inside the IDE
|
|
fh = FreeFile
|
|
Open "internal\temp\ideerror.txt" For Output As #fh
|
|
Print #fh, Err
|
|
Print #fh, _ErrorMessage$
|
|
Print #fh, _ErrorLine
|
|
Print #fh, _InclErrorLine
|
|
Print #fh, _InclErrorFile$
|
|
Close #fh
|
|
sendc$ = Chr$(255) 'a runtime error has occurred
|
|
Resume sendcommand 'allow IDE to handle error recovery
|
|
End If
|
|
|
|
qberrorhappenedvalue = qberrorhappened
|
|
qberrorhappened = 1
|
|
|
|
If Debug Then Print #9, "QB ERROR!"
|
|
If Debug Then Print #9, "ERR="; Err
|
|
If Debug Then Print #9, "ERL="; Erl
|
|
|
|
If idemode And qberrorhappenedvalue >= 0 Then
|
|
'real qb error occurred
|
|
ideerrorline = linenumber
|
|
idemessage$ = "Compiler error (check for syntax errors) (" + _ErrorMessage$ + ":"
|
|
If Err Then idemessage$ = idemessage$ + str2$(Err) + "-"
|
|
If _ErrorLine Then idemessage$ = idemessage$ + str2$(_ErrorLine)
|
|
If _InclErrorLine Then idemessage$ = idemessage$ + "-" + _InclErrorFile$ + "-" + str2$(_InclErrorLine)
|
|
idemessage$ = idemessage$ + ")"
|
|
If inclevel > 0 Then idemessage$ = idemessage$ + incerror$
|
|
Resume ideerror
|
|
End If
|
|
|
|
If qberrorhappenedvalue >= 0 Then
|
|
a$ = "UNEXPECTED INTERNAL COMPILER ERROR!": GoTo errmes 'internal comiler error
|
|
End If
|
|
|
|
|
|
qberrorcode = Err
|
|
qberrorline = Erl
|
|
If qberrorhappenedvalue = -1 Then Resume qberrorhappened1
|
|
If qberrorhappenedvalue = -2 Then Resume qberrorhappened2
|
|
If qberrorhappenedvalue = -3 Then Resume qberrorhappened3
|
|
End
|
|
|
|
errmes: 'set a$ to message
|
|
If Error_Happened Then a$ = Error_Message: Error_Happened = 0
|
|
layout$ = "": layoutok = 0 'invalidate layout
|
|
|
|
If inclevel > 0 Then a$ = a$ + incerror$
|
|
|
|
If idemode Then
|
|
ideerrorline = linenumber
|
|
idemessage$ = a$
|
|
GoTo ideerror 'infinitely preferable to RESUME
|
|
End If
|
|
'non-ide mode output
|
|
Print
|
|
If Not MonochromeLoggingMode Then Color 4
|
|
Print a$
|
|
If Not MonochromeLoggingMode Then Color 7
|
|
For i = 1 To Len(linefragment)
|
|
If Mid$(linefragment, i, 1) = sp$ Then Mid$(linefragment, i, 1) = " "
|
|
Next
|
|
For i = 1 To Len(wholeline)
|
|
If Mid$(wholeline, i, 1) = sp$ Then Mid$(wholeline, i, 1) = " "
|
|
Next
|
|
Print "Caused by (or after):" + linefragment
|
|
If Not MonochromeLoggingMode Then Color 8
|
|
Print "LINE ";
|
|
If Not MonochromeLoggingMode Then Color 15
|
|
Print str2(linenumber) + ":";
|
|
If Not MonochromeLoggingMode Then Color 7
|
|
Print wholeline
|
|
|
|
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$) = "/?" Or LCase$(token$) = "--help" Or LCase$(token$) = "/help" Then token$ = "-?"
|
|
Select Case LCase$(Left$(token$, 2))
|
|
Case "-?" 'Command-line help
|
|
_Dest _Console
|
|
If qb64versionprinted = 0 Then qb64versionprinted = -1: Print "QB64 Compiler V" + Version$
|
|
Print
|
|
Print "Usage: qb64 [switches] <file>"
|
|
Print
|
|
Print "Options:"
|
|
Print " <file> Source file to load" ' '80 columns
|
|
Print " -c Compile instead of edit"
|
|
Print " -o <output file> Write output executable to <output file>"
|
|
Print " -x Compile instead of edit and output the result to the"
|
|
Print " console"
|
|
Print " -w Show warnings"
|
|
Print " -q Quiet mode (does not inhibit warnings or errors)"
|
|
Print " -m Do not colorize compiler output (monochrome mode)"
|
|
Print " -e Enable OPTION _EXPLICIT, making variable declaration"
|
|
Print " mandatory (per-compilation; doesn't affect the"
|
|
Print " source file or global settings)"
|
|
Print " -s[:switch=true/false] View/edit compiler settings"
|
|
Print " -l:<line number> Start the IDE at the specified line number"
|
|
Print " -p Purge all pre-compiled content first"
|
|
Print " -z Generate C code without compiling to executable"
|
|
Print
|
|
System
|
|
Case "-c" 'Compile instead of edit
|
|
NoIDEMode = 1
|
|
cmdlineswitch = -1
|
|
Case "-o" 'Specify an output file
|
|
If Len(Command$(i + 1)) > 0 Then outputfile_cmd$ = Command$(i + 1): i = i + 1
|
|
cmdlineswitch = -1
|
|
Case "-x" 'Use the console
|
|
ConsoleMode = 1
|
|
NoIDEMode = 1 'Implies -c
|
|
cmdlineswitch = -1
|
|
Case "-w" 'Show warnings
|
|
ShowWarnings = -1
|
|
cmdlineswitch = -1
|
|
Case "-q" 'Quiet mode
|
|
QuietMode = -1
|
|
cmdlineswitch = -1
|
|
Case "-m" 'Monochrome mode
|
|
MonochromeLoggingMode = -1
|
|
cmdlineswitch = -1
|
|
Case "-e" 'Option Explicit
|
|
optionexplicit_cmd = -1
|
|
cmdlineswitch = -1
|
|
Case "-s" 'Settings
|
|
settingsMode = -1
|
|
_Dest _Console
|
|
If qb64versionprinted = 0 Then qb64versionprinted = -1: Print "QB64 Compiler V" + Version$
|
|
Select Case LCase$(Mid$(token$, 3))
|
|
Case ""
|
|
Print "debuginfo = ";
|
|
If idedebuginfo Then Print "true" Else Print "false"
|
|
Print "exewithsource = ";
|
|
If SaveExeWithSource Then Print "true" Else Print "false"
|
|
System
|
|
Case ":exewithsource"
|
|
Print "exewithsource = ";
|
|
If SaveExeWithSource Then Print "true" Else Print "false"
|
|
System
|
|
Case ":exewithsource=true"
|
|
WriteConfigSetting "'[GENERAL SETTINGS]", "SaveExeWithSource", "TRUE"
|
|
Print "exewithsource = true"
|
|
SaveExeWithSource = -1
|
|
Case ":exewithsource=false"
|
|
WriteConfigSetting "'[GENERAL SETTINGS]", "SaveExeWithSource", "FALSE"
|
|
Print "exewithsource = false"
|
|
SaveExeWithSource = 0
|
|
Case ":debuginfo"
|
|
Print "debuginfo = ";
|
|
If idedebuginfo Then Print "true" Else Print "false"
|
|
System
|
|
Case ":debuginfo=true"
|
|
Print "debuginfo = true"
|
|
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 InStr(_OS$, "[MACOSX]") Then
|
|
Shell _Hide "./purge_all_precompiled_content_osx.command"
|
|
Else
|
|
Shell _Hide "./purge_all_precompiled_content_lnx.sh"
|
|
End If
|
|
ChDir "../.."
|
|
End If
|
|
Case ":debuginfo=false"
|
|
Print "debuginfo = false"
|
|
WriteConfigSetting "'[GENERAL SETTINGS]", "DebugInfo", "FALSE 'INTERNAL VARIABLE USE ONLY!! DO NOT MANUALLY CHANGE!"
|
|
idedebuginfo = 0
|
|
Include_GDB_Debugging_Info = idedebuginfo
|
|
If os$ = "WIN" Then
|
|
ChDir "internal\c"
|
|
Shell _Hide "cmd /c purge_all_precompiled_content_win.bat"
|
|
ChDir "..\.."
|
|
End If
|
|
If os$ = "LNX" Then
|
|
ChDir "./internal/c"
|
|
|
|
If InStr(_OS$, "[MACOSX]") Then
|
|
Shell _Hide "./purge_all_precompiled_content_osx.command"
|
|
Else
|
|
Shell _Hide "./purge_all_precompiled_content_lnx.sh"
|
|
End If
|
|
ChDir "../.."
|
|
End If
|
|
Case Else
|
|
Print "Invalid settings switch: "; token$
|
|
Print
|
|
Print "Valid switches:"
|
|
Print " -s:debuginfo=true/false (Embed C++ debug info into .EXE)"
|
|
Print " -s:exewithsource=true/false (Save .EXE in the source folder)"
|
|
System
|
|
End Select
|
|
_Dest 0
|
|
Case "-l" 'goto line (ide mode only); -l:<line number>
|
|
If Mid$(token$, 3, 1) = ":" Then ideStartAtLine = Val(Mid$(token$, 4))
|
|
cmdlineswitch = -1
|
|
Case "-p" 'Purge
|
|
If os$ = "WIN" Then
|
|
ChDir "internal\c"
|
|
Shell _Hide "cmd /c purge_all_precompiled_content_win.bat"
|
|
ChDir "..\.."
|
|
End If
|
|
If os$ = "LNX" Then
|
|
ChDir "./internal/c"
|
|
|
|
If InStr(_OS$, "[MACOSX]") Then
|
|
Shell _Hide "./purge_all_precompiled_content_osx.command"
|
|
Else
|
|
Shell _Hide "./purge_all_precompiled_content_lnx.sh"
|
|
End If
|
|
ChDir "../.."
|
|
End If
|
|
cmdlineswitch = -1
|
|
Case "-z" 'Not compiling C code
|
|
No_C_Compile_Mode = 1
|
|
ConsoleMode = 1 'Implies -x
|
|
NoIDEMode = 1 'Implies -c
|
|
cmdlineswitch = -1
|
|
Case Else 'Something we don't recognise, assume it's a filename
|
|
If PassedFileName$ = "" Then PassedFileName$ = token$
|
|
End Select
|
|
Next i
|
|
|
|
If Len(PassedFileName$) Then
|
|
ParseCMDLineArgs$ = PassedFileName$
|
|
Else
|
|
If cmdlineswitch = 0 And settingsMode = -1 Then System
|
|
End If
|
|
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
|
|
Else
|
|
t = t + 128 'integer
|
|
If t1 And ISUNSIGNED Then t = t + 1024
|
|
If t1 And ISOFFSET Then t = t + 8192 'offset type
|
|
End If
|
|
t1s = (t1 And 511) \ 8
|
|
If t1s = 1 Then t = t + t1s
|
|
If t1s = 2 Then t = t + t1s
|
|
If t1s = 4 Then t = t + t1s
|
|
If t1s = 8 Then t = t + t1s
|
|
If t1s = 16 Then t = t + t1s
|
|
If t1s = 32 Then t = t + t1s
|
|
If t1s = 64 Then t = t + t1s
|
|
End If
|
|
End If
|
|
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
|
|
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$
|
|
End Function
|
|
|
|
|
|
|
|
|
|
|
|
|
|
'udt is non-zero if this is an array of udt's, to allow examining each udt element
|
|
Function allocarray (n2$, elements$, elementsize, udt)
|
|
dimsharedlast = dimshared: dimshared = 0
|
|
|
|
If autoarray = 1 Then autoarray = 0: autoary = 1 'clear global value & set local value
|
|
|
|
f12$ = ""
|
|
|
|
'changelog:
|
|
'added 4 to [2] to indicate cmem array where appropriate
|
|
|
|
e$ = elements$: n$ = n2$
|
|
If elementsize = -2147483647 Then stringarray = 1: elementsize = 8
|
|
|
|
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
|
|
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 + SCase$("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);"
|
|
Else
|
|
Print #13, "((uint64*)(" + n$ + "[0]))[tmp_long]=(uint64)qbs_new(0,0);"
|
|
End If
|
|
Print #13, "}"
|
|
Else
|
|
'clear array
|
|
Print #13, "memset((void*)(" + n$ + "[0]),0," + sizestr$ + ");"
|
|
End If
|
|
Print #13, n$ + "[2]=1+2;" 'init+static
|
|
End If
|
|
|
|
If udt > 0 And udtxvariable(udt) Then
|
|
Print #13, "tmp_long=" + elesizestr$ + ";"
|
|
Print #13, "while(tmp_long--){"
|
|
initialise_array_udt_varstrings n$, udt, 0, bytesperelement$, acc$
|
|
Print #13, acc$
|
|
Print #13, "}"
|
|
End If
|
|
|
|
'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{"
|
|
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
|
|
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
|
|
'As must any variable length strings in UDT's
|
|
If udt > 0 And udtxvariable(udt) Then
|
|
f12$ = f12$ + CRLF + "tmp_long=" + elesizestr$ + ";"
|
|
f12$ = f12$ + CRLF + "while(tmp_long--) {"
|
|
free_array_udt_varstrings n$, udt, 0, bytesperelement$, acc$
|
|
f12$ = f12$ + acc$ + "}"
|
|
End If
|
|
|
|
'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 Or ((udt > 0) And udtxvariable(udt)) Then
|
|
|
|
'Note: String and variable-length udt 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_long2=" + elesizestr$ + ";"
|
|
f12$ = f12$ + CRLF + "if (tmp_long2<preserved_elements){"
|
|
f12$ = f12$ + CRLF + "for(tmp_long=tmp_long2;tmp_long<preserved_elements;tmp_long++) {"
|
|
If stringarray Then
|
|
f12$ = f12$ + CRLF + "qbs_free((qbs*)((uint64*)(" + n$ + "[0]))[tmp_long]);"
|
|
Else
|
|
acc$ = ""
|
|
free_array_udt_varstrings n$, udt, 0, bytesperelement$, acc$
|
|
f12$ = f12$ + acc$
|
|
End If
|
|
f12$ = f12$ + CRLF + "}}"
|
|
'reallocate the array
|
|
f12$ = f12$ + CRLF + n$ + "[0]=(ptrszint)realloc((void*)(" + n$ + "[0]),tmp_long2*" + bytesperelement$ + ");"
|
|
f12$ = f12$ + CRLF + "if (!" + n$ + "[0]) error(257);" 'not enough memory
|
|
f12$ = f12$ + CRLF + "if (preserved_elements<tmp_long2){"
|
|
f12$ = f12$ + CRLF + "for(tmp_long=preserved_elements;tmp_long<tmp_long2;tmp_long++){"
|
|
If stringarray Then
|
|
f12$ = f12$ + CRLF + "if (" + n$ + "[2]&4){" 'array is in cmem
|
|
f12$ = f12$ + CRLF + "((uint64*)(" + n$ + "[0]))[tmp_long]=(uint64)qbs_new_cmem(0,0);"
|
|
f12$ = f12$ + CRLF + "}else{" 'not in cmem
|
|
f12$ = f12$ + CRLF + "((uint64*)(" + n$ + "[0]))[tmp_long]=(uint64)qbs_new(0,0);"
|
|
f12$ = f12$ + CRLF + "}" 'not in cmem
|
|
Else
|
|
acc$ = ""
|
|
initialise_array_udt_varstrings n$, udt, 0, bytesperelement$, acc$
|
|
f12$ = f12$ + acc$
|
|
End If
|
|
f12$ = f12$ + CRLF + "}"
|
|
f12$ = f12$ + CRLF + "}"
|
|
|
|
f12$ = f12$ + CRLF + "}else{"
|
|
End If
|
|
|
|
'1. Create array
|
|
f12$ = f12$ + CRLF + n$ + "[0]=(ptrszint)malloc(" + sizestr$ + ");"
|
|
f12$ = f12$ + CRLF + "if (!" + n$ + "[0]) error(257);" 'not enough memory
|
|
f12$ = f12$ + CRLF + n$ + "[2]|=1;" 'ADD initialized flag
|
|
f12$ = f12$ + CRLF + "tmp_long=" + elesizestr$ + ";"
|
|
|
|
|
|
'init individual strings
|
|
If stringarray Then
|
|
f12$ = f12$ + CRLF + "if (" + n$ + "[2]&4){" 'array is in cmem
|
|
f12$ = f12$ + CRLF + "while(tmp_long--) ((uint64*)(" + n$ + "[0]))[tmp_long]=(uint64)qbs_new_cmem(0,0);"
|
|
f12$ = f12$ + CRLF + "}else{" 'not in cmem
|
|
f12$ = f12$ + CRLF + "while(tmp_long--) ((uint64*)(" + n$ + "[0]))[tmp_long]=(uint64)qbs_new(0,0);"
|
|
f12$ = f12$ + CRLF + "}" 'not in cmem
|
|
Else 'initialise udt's
|
|
f12$ = f12$ + CRLF + "while(tmp_long--){"
|
|
acc$ = ""
|
|
initialise_array_udt_varstrings n$, udt, 0, bytesperelement$, acc$
|
|
f12$ = f12$ + acc$ + "}"
|
|
End If
|
|
|
|
If redimoption = 2 Then
|
|
f12$ = f12$ + CRLF + "}"
|
|
End If
|
|
|
|
|
|
'2. Generate "clean up" code (called when EXITING A SUB/FUNCTION)
|
|
If arraydesc = 0 Then 'only add for first declaration of the array
|
|
Print #19, "if (" + n$ + "[2]&1){" 'initialized?
|
|
Print #19, "tmp_long=" + elesizestr$ + ";"
|
|
If udt > 0 And udtxvariable(udt) Then
|
|
Print #19, "while(tmp_long--) {"
|
|
acc$ = ""
|
|
free_array_udt_varstrings n$, udt, 0, bytesperelement$, acc$
|
|
Print #19, acc$ + "}"
|
|
Else
|
|
Print #19, "while(tmp_long--) qbs_free((qbs*)((uint64*)(" + n$ + "[0]))[tmp_long]);"
|
|
End If
|
|
Print #19, "free((void*)(" + n$ + "[0]));"
|
|
Print #19, "}"
|
|
'free lock (_MEM)
|
|
Print #19, "free_mem_lock( (mem_lock*)((ptrszint*)" + n$ + ")[" + str2(4 * nume + 4 + 1 - 1) + "] );"
|
|
End If
|
|
|
|
|
|
Else 'not string/var-udt array
|
|
|
|
'1. Create array
|
|
f12$ = f12$ + CRLF + "if (" + n$ + "[2]&4){" 'array will be in cmem
|
|
|
|
If redimoption = 2 Then
|
|
f12$ = f12$ + CRLF + "if (preserved_elements){"
|
|
|
|
'reallocation method
|
|
'backup data
|
|
f12$ = f12$ + CRLF + "memcpy(redim_preserve_cmem_buffer,(void*)(" + n$ + "[0]),preserved_elements*" + bytesperelement$ + ");"
|
|
'free old array
|
|
f12$ = f12$ + CRLF + "cmem_dynamic_free((uint8*)(" + n$ + "[0]));"
|
|
f12$ = f12$ + CRLF + "tmp_long=" + elesizestr$ + ";"
|
|
f12$ = f12$ + CRLF + n$ + "[0]=(ptrszint)cmem_dynamic_malloc(tmp_long*" + bytesperelement$ + ");"
|
|
f12$ = f12$ + CRLF + "memcpy((void*)(" + n$ + "[0]),redim_preserve_cmem_buffer,preserved_elements*" + bytesperelement$ + ");"
|
|
f12$ = f12$ + CRLF + "if (preserved_elements<tmp_long) ZeroMemory(((uint8*)(" + n$ + "[0]))+preserved_elements*" + bytesperelement$ + ",(tmp_long*" + bytesperelement$ + ")-(preserved_elements*" + bytesperelement$ + "));"
|
|
|
|
f12$ = f12$ + CRLF + "}else{"
|
|
End If
|
|
|
|
'standard cmem method
|
|
f12$ = f12$ + CRLF + n$ + "[0]=(ptrszint)cmem_dynamic_malloc(" + sizestr$ + ");"
|
|
'clear array
|
|
f12$ = f12$ + CRLF + "memset((void*)(" + n$ + "[0]),0," + sizestr$ + ");"
|
|
|
|
If redimoption = 2 Then
|
|
f12$ = f12$ + CRLF + "}"
|
|
End If
|
|
|
|
|
|
f12$ = f12$ + CRLF + "}else{" 'not in cmem
|
|
|
|
If redimoption = 2 Then
|
|
f12$ = f12$ + CRLF + "if (preserved_elements){"
|
|
'reallocation method
|
|
f12$ = f12$ + CRLF + "tmp_long=" + elesizestr$ + ";"
|
|
f12$ = f12$ + CRLF + n$ + "[0]=(ptrszint)realloc((void*)(" + n$ + "[0]),tmp_long*" + bytesperelement$ + ");"
|
|
f12$ = f12$ + CRLF + "if (!" + n$ + "[0]) error(257);" 'not enough memory
|
|
f12$ = f12$ + CRLF + "if (preserved_elements<tmp_long) ZeroMemory(((uint8*)(" + n$ + "[0]))+preserved_elements*" + bytesperelement$ + ",(tmp_long*" + bytesperelement$ + ")-(preserved_elements*" + bytesperelement$ + "));"
|
|
|
|
f12$ = f12$ + CRLF + "}else{"
|
|
End If
|
|
'standard allocation method
|
|
f12$ = f12$ + CRLF + n$ + "[0]=(ptrszint)calloc(" + sizestr$ + ",1);"
|
|
f12$ = f12$ + CRLF + "if (!" + n$ + "[0]) error(257);" 'not enough memory
|
|
If redimoption = 2 Then
|
|
f12$ = f12$ + CRLF + "}"
|
|
End If
|
|
|
|
f12$ = f12$ + CRLF + "}" 'not in cmem
|
|
f12$ = f12$ + CRLF + n$ + "[2]|=1;" 'ADD initialized flag
|
|
|
|
'2. Generate "clean up" code (called when EXITING A SUB/FUNCTION)
|
|
If arraydesc = 0 Then 'only add for first declaration of the array
|
|
Print #19, "if (" + n$ + "[2]&1){" 'initialized?
|
|
Print #19, "if (" + n$ + "[2]&4){" 'array is in cmem
|
|
Print #19, "cmem_dynamic_free((uint8*)(" + n$ + "[0]));"
|
|
Print #19, "}else{"
|
|
Print #19, "free((void*)(" + n$ + "[0]));"
|
|
Print #19, "}" 'cmem
|
|
Print #19, "}" 'init
|
|
'free lock (_MEM)
|
|
Print #19, "free_mem_lock( (mem_lock*)((ptrszint*)" + n$ + ")[" + str2(4 * nume + 4 + 1 - 1) + "] );"
|
|
End If
|
|
End If 'not string array
|
|
|
|
End If 'undefined=0
|
|
|
|
'----FINISH ARRAY DESCRIPTOR IF DEFINING FOR THE FIRST TIME----
|
|
If arraydesc = 0 Then
|
|
'Note: Array is init as undefined (& possibly a cmem flag)
|
|
If cmem Then Print #13, n$ + "[2]=4;" Else Print #13, n$ + "[2]=0;"
|
|
'set dimensions as undefined
|
|
For i = 1 To nume
|
|
b = i * 4
|
|
Print #13, n$ + "[" + str2(b) + "]=2147483647;" 'base
|
|
Print #13, n$ + "[" + str2(b + 1) + "]=0;" 'num. index
|
|
Print #13, n$ + "[" + str2(b + 2) + "]=0;" 'multiplier
|
|
Next
|
|
If stringarray Then
|
|
'set array's data offset to the offset of the offset to nothingstring
|
|
Print #13, n$ + "[0]=(ptrszint)¬hingstring;"
|
|
Else
|
|
'set array's data offset to "nothing"
|
|
Print #13, n$ + "[0]=(ptrszint)nothingvalue;"
|
|
End If
|
|
Print #13, "}" 'close array descriptor
|
|
End If 'arraydesc = 0
|
|
|
|
If undefined = 0 Then
|
|
|
|
If redimoption = 0 Then f12$ = f12$ + CRLF + "}" 'if REDIM not specified the above is conditional
|
|
f12$ = f12$ + CRLF + "}" 'not static
|
|
|
|
End If 'undefined=0
|
|
|
|
allocarray = nume
|
|
If undefined = -1 Then allocarray = -1
|
|
|
|
End If
|
|
|
|
If autoary = 0 Then
|
|
If dimoption = 3 Then 'STATIC a(100) puts creation code in main
|
|
Print #13, f12$
|
|
Else
|
|
Print #12, f12$
|
|
End If
|
|
End If
|
|
|
|
'[8] offset of data
|
|
'[8] reserved (could be used to store a bit offset)
|
|
'(the following repeats depending on the number of elements)
|
|
'[4] base-offset
|
|
'[4] number of indexes
|
|
'[4] multiplier (the last multiplier doesn't actually exist)
|
|
'[4] reserved
|
|
|
|
dimshared = dimsharedlast
|
|
|
|
tlayout$ = l$
|
|
End Function
|
|
|
|
Function arrayreference$ (indexes$, typ)
|
|
arrayprocessinghappened = 1
|
|
'*returns an array reference: idnumber CHR$(179) index$
|
|
'*does not take into consideration the type of the array
|
|
|
|
'*expects array id to be passed in the global id structure
|
|
|
|
|
|
|
|
|
|
|
|
idnumber$ = str2(currentid)
|
|
|
|
Dim id2 As idstruct
|
|
|
|
id2 = id
|
|
|
|
a$ = indexes$
|
|
typ = id2.arraytype + ISARRAY + ISREFERENCE
|
|
n$ = RTrim$(id2.callname)
|
|
|
|
If a$ = "" Then 'no indexes passed eg. a()
|
|
r$ = "0"
|
|
GoTo gotarrayindex
|
|
End If
|
|
|
|
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
|
|
If NoChecks = 0 Then
|
|
r$ = r$ + "array_check((" + e$ + ")-" + n$ + "[" + str2(argi) + "]," + n$ + "[" + str2(argi + 1) + "])+"
|
|
Else
|
|
r$ = r$ + "(" + e$ + ")-" + n$ + "[" + str2(argi) + "]+"
|
|
End If
|
|
|
|
Else
|
|
If NoChecks = 0 Then
|
|
r$ = r$ + "array_check((" + e$ + ")-" + n$ + "[" + str2(argi) + "]," + n$ + "[" + str2(argi + 1) + "])*" + n$ + "[" + str2(argi + 2) + "]+"
|
|
Else
|
|
r$ = r$ + "((" + e$ + ")-" + n$ + "[" + str2(argi) + "])*" + n$ + "[" + str2(argi + 2) + "]+"
|
|
End If
|
|
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
|
|
|
|
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$)
|
|
If Error_Happened Then EXIT Sub
|
|
Do While try
|
|
If id.t Then
|
|
If subfuncn = id.insubfuncn Then 'avoid global before local
|
|
If (id.t And ISUDT) = 0 Then
|
|
makeidrefer a2$, typ
|
|
GoTo assignsimplevariable
|
|
End If
|
|
End If
|
|
End If
|
|
If try = 2 Then findanotherid = 1: try = findid(a2$) Else try = 0
|
|
If Error_Happened Then EXIT Sub
|
|
Loop
|
|
End If
|
|
|
|
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
|
|
|
|
End If '=,b=0
|
|
Next
|
|
Give_Error "Expected =": EXIT Sub
|
|
End Sub
|
|
|
|
Sub clearid
|
|
id = cleariddata
|
|
End Sub
|
|
|
|
Sub closemain
|
|
xend
|
|
|
|
Print #12, "return;"
|
|
|
|
Print #12, "}"
|
|
Print #15, "}" 'end case
|
|
Print #15, "}"
|
|
Print #15, "error(3);" 'no valid return possible
|
|
|
|
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
|
|
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
|
|
|
|
typ$ = typ2$
|
|
dim2 = 1 'success
|
|
|
|
If Debug Then Print #9, "dim2 called", method
|
|
|
|
cvarname$ = varname$
|
|
l$ = cvarname$
|
|
varname$ = UCase$(varname$)
|
|
|
|
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
|
|
|
|
|
|
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
|
|
|
|
'UDT
|
|
'is it a udt?
|
|
For i = 1 To lasttype
|
|
If typ$ = RTrim$(udtxname(i)) Or (typ$ = "MEM" And RTrim$(udtxname(i)) = "_MEM" And qb64prefix_set = 1) Then
|
|
dim2typepassback$ = RTrim$(udtxcname(i))
|
|
If typ$ = "MEM" And RTrim$(udtxname(i)) = "_MEM" Then
|
|
dim2typepassback$ = Mid$(RTrim$(udtxcname(i)), 2)
|
|
End If
|
|
|
|
n$ = "UDT_" + varname$
|
|
|
|
'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, i)
|
|
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){"
|
|
Print #13, "cmem_sp-=" + str2(bytes) + ";"
|
|
Print #13, "if (cmem_sp<qbs_cmem_sp) error(257);"
|
|
Print #13, n$ + "=(void*)(dblock+cmem_sp);"
|
|
Print #13, "memset(" + n$ + ",0," + str2(bytes) + ");"
|
|
Print #13, "}"
|
|
End If
|
|
Else
|
|
If f Then
|
|
Print #13, "if(" + n$ + "==NULL){"
|
|
Print #13, n$ + "=(void*)mem_static_malloc(" + str2$(bytes) + ");"
|
|
Print #13, "memset(" + n$ + ",0," + str2(bytes) + ");"
|
|
If udtxvariable(i) Then
|
|
initialise_udt_varstrings n$, i, 13, 0
|
|
free_udt_varstrings n$, i, 19, 0
|
|
End If
|
|
Print #13, "}"
|
|
End If
|
|
End If
|
|
regid
|
|
If Error_Happened Then EXIT Function
|
|
GoTo dim2exitfunc
|
|
End If
|
|
Next i
|
|
'it isn't a udt
|
|
|
|
typ$ = symbol2fulltypename$(typ$)
|
|
If Error_Happened Then EXIT Function
|
|
|
|
'check if _UNSIGNED was specified
|
|
unsgn = 0
|
|
If Left$(typ$, 10) = "_UNSIGNED " Or (Left$(typ$, 9) = "UNSIGNED " And qb64prefix_set = 1) Then
|
|
unsgn = 1
|
|
typ$ = Mid$(typ$, InStr(typ$, Chr$(32)) + 1)
|
|
If Len(typ$) = 0 Then Give_Error "Expected more type information after " + qb64prefix$ + "UNSIGNED!": EXIT Function
|
|
End If
|
|
|
|
n$ = "" 'n$ is assumed to be "" after branching into the code for each type
|
|
|
|
If Left$(typ$, 6) = "STRING" Then
|
|
|
|
If Len(typ$) > 6 Then
|
|
If Left$(typ$, 9) <> "STRING * " Then Give_Error "Expected STRING * number/constant": EXIT Function
|
|
|
|
c$ = Right$(typ$, Len(typ$) - 9)
|
|
|
|
'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, 0)
|
|
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_sp<qbs_cmem_sp) error(257);"
|
|
If f Then Print #13, n$ + "=qbs_new_fixed((uint8*)(dblock+cmem_sp)," + str2(bytes) + ",0);"
|
|
If f Then Print #13, "memset(" + n$ + "->chr,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$ + "$")
|
|
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, 0)
|
|
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" Or (Left$(typ$, 3) = "BIT" And qb64prefix_set = 1) Then
|
|
If (Left$(typ$, 4) = "_BIT" And Len(typ$) > 4) Or (Left$(typ$, 3) = "BIT" And Len(typ$) > 3) Then
|
|
If Left$(typ$, 7) <> "_BIT * " And Left$(typ$, 6) <> "BIT * " Then Give_Error "Expected " + qb64prefix$ + "BIT * number": EXIT Function
|
|
c$ = Mid$(typ$, InStr(typ$, " * ") + 3)
|
|
If isuinteger(c$) = 0 Then Give_Error "Number expected after *": EXIT Function
|
|
If Len(c$) > 2 Then Give_Error "Too many characters in number after *": EXIT Function
|
|
bits = Val(c$)
|
|
If bits = 0 Then Give_Error "Cannot create a bit variable of size 0 bits": EXIT Function
|
|
If bits > 57 Then Give_Error "Cannot create a bit variable of size > 24 bits": EXIT Function
|
|
Else
|
|
bits = 1
|
|
End If
|
|
If bits <= 32 Then ct$ = "int32" Else ct$ = "int64"
|
|
If unsgn Then n$ = "U": ct$ = "u" + ct$
|
|
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, 0)
|
|
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<qbs_cmem_sp) error(257);"
|
|
Print #13, n$ + "=(" + ct$ + "*)(dblock+cmem_sp);"
|
|
Print #13, "*" + n$ + "=0;"
|
|
Print #13, "}"
|
|
clearid
|
|
id.n = cvarname$
|
|
id.t = BITTYPE - 1 + bits + ISINCONVENTIONALMEMORY: If unsgn Then id.t = id.t + ISUNSIGNED
|
|
If method = 0 Then
|
|
If unsgn Then id.mayhave = "~`" + str2(bits) Else id.mayhave = "`" + str2(bits)
|
|
End If
|
|
If method = 1 Then
|
|
If unsgn Then id.musthave = "~`" + str2(bits) Else id.musthave = "`" + str2(bits)
|
|
End If
|
|
regid
|
|
If Error_Happened Then EXIT Function
|
|
GoTo dim2exitfunc
|
|
End If
|
|
|
|
If typ$ = "_BYTE" Or (typ$ = "BYTE" And qb64prefix_set = 1) Then
|
|
ct$ = "int8"
|
|
If unsgn Then n$ = "U": ct$ = "u" + ct$
|
|
n$ = n$ + "BYTE_" + varname$
|
|
If elements$ <> "" 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, 0)
|
|
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<qbs_cmem_sp) error(257);"
|
|
Else
|
|
If f = 1 Then Print #13, n$ + "=(" + ct$ + "*)mem_static_malloc(1);"
|
|
End If
|
|
If f = 1 Then Print #13, "*" + n$ + "=0;"
|
|
If f = 1 Then Print #13, "}"
|
|
End If
|
|
id.n = cvarname$
|
|
If method = 0 Then
|
|
If unsgn Then id.mayhave = "~%%" Else id.mayhave = "%%"
|
|
End If
|
|
If method = 1 Then
|
|
If unsgn Then id.musthave = "~%%" Else id.musthave = "%%"
|
|
End If
|
|
regid
|
|
If Error_Happened Then EXIT Function
|
|
GoTo dim2exitfunc
|
|
End If
|
|
|
|
If typ$ = "INTEGER" Then
|
|
ct$ = "int16"
|
|
If unsgn Then n$ = "U": ct$ = "u" + ct$
|
|
n$ = n$ + "INTEGER_" + varname$
|
|
|
|
If elements$ <> "" 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, 0)
|
|
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<qbs_cmem_sp) error(257);"
|
|
Else
|
|
If f = 1 Then Print #13, n$ + "=(" + ct$ + "*)mem_static_malloc(2);"
|
|
End If
|
|
If f = 1 Then Print #13, "*" + n$ + "=0;"
|
|
If f = 1 Then Print #13, "}"
|
|
End If
|
|
id.n = cvarname$
|
|
If method = 0 Then
|
|
If unsgn Then id.mayhave = "~%" Else id.mayhave = "%"
|
|
End If
|
|
If method = 1 Then
|
|
If unsgn Then id.musthave = "~%" Else id.musthave = "%"
|
|
End If
|
|
regid
|
|
If Error_Happened Then EXIT Function
|
|
GoTo dim2exitfunc
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
If typ$ = "_OFFSET" Or (typ$ = "OFFSET" And qb64prefix_set = 1) Then
|
|
ct$ = "ptrszint"
|
|
If unsgn Then n$ = "U": ct$ = "u" + ct$
|
|
n$ = n$ + "OFFSET_" + varname$
|
|
If elements$ <> "" 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, 0)
|
|
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<qbs_cmem_sp) error(257);"
|
|
Else
|
|
If f = 1 Then Print #13, n$ + "=(" + ct$ + "*)mem_static_malloc(" + str2(OS_BITS \ 8) + ");"
|
|
End If
|
|
If f = 1 Then Print #13, "*" + n$ + "=0;"
|
|
If f = 1 Then Print #13, "}"
|
|
End If
|
|
id.n = cvarname$
|
|
If method = 0 Then
|
|
If unsgn Then id.mayhave = "~%&" Else id.mayhave = "%&"
|
|
End If
|
|
If method = 1 Then
|
|
If unsgn Then id.musthave = "~%&" Else id.musthave = "%&"
|
|
End If
|
|
regid
|
|
If Error_Happened Then EXIT Function
|
|
GoTo dim2exitfunc
|
|
End If
|
|
|
|
If typ$ = "LONG" Then
|
|
ct$ = "int32"
|
|
If unsgn Then n$ = "U": ct$ = "u" + ct$
|
|
n$ = n$ + "LONG_" + varname$
|
|
If elements$ <> "" 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, 0)
|
|
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<qbs_cmem_sp) error(257);"
|
|
Else
|
|
If f = 1 Then Print #13, n$ + "=(" + ct$ + "*)mem_static_malloc(4);"
|
|
End If
|
|
If f = 1 Then Print #13, "*" + n$ + "=0;"
|
|
If f = 1 Then Print #13, "}"
|
|
End If
|
|
id.n = cvarname$
|
|
If method = 0 Then
|
|
If unsgn Then id.mayhave = "~&" Else id.mayhave = "&"
|
|
End If
|
|
If method = 1 Then
|
|
If unsgn Then id.musthave = "~&" Else id.musthave = "&"
|
|
End If
|
|
regid
|
|
If Error_Happened Then EXIT Function
|
|
GoTo dim2exitfunc
|
|
End If
|
|
|
|
If typ$ = "_INTEGER64" Or (typ$ = "INTEGER64" And qb64prefix_set = 1) Then
|
|
ct$ = "int64"
|
|
If unsgn Then n$ = "U": ct$ = "u" + ct$
|
|
n$ = n$ + "INTEGER64_" + varname$
|
|
If elements$ <> "" 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, 0)
|
|
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<qbs_cmem_sp) error(257);"
|
|
Else
|
|
If f = 1 Then Print #13, n$ + "=(" + ct$ + "*)mem_static_malloc(8);"
|
|
End If
|
|
If f = 1 Then Print #13, "*" + n$ + "=0;"
|
|
If f = 1 Then Print #13, "}"
|
|
End If
|
|
id.n = cvarname$
|
|
If method = 0 Then
|
|
If unsgn Then id.mayhave = "~&&" Else id.mayhave = "&&"
|
|
End If
|
|
If method = 1 Then
|
|
If unsgn Then id.musthave = "~&&" Else id.musthave = "&&"
|
|
End If
|
|
regid
|
|
If Error_Happened Then EXIT Function
|
|
GoTo dim2exitfunc
|
|
End If
|
|
|
|
If unsgn = 1 Then Give_Error "Type cannot be unsigned": EXIT Function
|
|
|
|
If typ$ = "SINGLE" Then
|
|
ct$ = "float"
|
|
n$ = n$ + "SINGLE_" + varname$
|
|
If elements$ <> "" 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, 0)
|
|
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<qbs_cmem_sp) error(257);"
|
|
Else
|
|
If f = 1 Then Print #13, n$ + "=(" + ct$ + "*)mem_static_malloc(4);"
|
|
End If
|
|
If f = 1 Then Print #13, "*" + n$ + "=0;"
|
|
If f = 1 Then Print #13, "}"
|
|
End If
|
|
id.n = cvarname$
|
|
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 typ$ = "DOUBLE" Then
|
|
ct$ = "double"
|
|
n$ = n$ + "DOUBLE_" + varname$
|
|
If elements$ <> "" 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, 0)
|
|
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<qbs_cmem_sp) error(257);"
|
|
Else
|
|
If f = 1 Then Print #13, n$ + "=(" + ct$ + "*)mem_static_malloc(8);"
|
|
End If
|
|
If f = 1 Then Print #13, "*" + n$ + "=0;"
|
|
If f = 1 Then Print #13, "}"
|
|
End If
|
|
id.n = cvarname$
|
|
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 typ$ = "_FLOAT" Or (typ$ = "FLOAT" And qb64prefix_set = 1) Then
|
|
ct$ = "long double"
|
|
n$ = n$ + "FLOAT_" + varname$
|
|
If elements$ <> "" 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, 0)
|
|
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<qbs_cmem_sp) error(257);"
|
|
Else
|
|
If f Then Print #13, n$ + "=(" + ct$ + "*)mem_static_malloc(32);"
|
|
End If
|
|
If f Then Print #13, "*" + n$ + "=0;"
|
|
If f Then Print #13, "}"
|
|
End If
|
|
id.n = cvarname$
|
|
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
|
|
|
|
Give_Error "Unknown type": EXIT Function
|
|
dim2exitfunc:
|
|
|
|
If bypassNextVariable = 0 Then
|
|
manageVariableList cvarname$, n$, 0
|
|
End If
|
|
bypassNextVariable = 0
|
|
|
|
If dimsfarray Then
|
|
ids(idn).sfid = glinkid
|
|
ids(idn).sfarg = glinkarg
|
|
End If
|
|
|
|
'restore STATIC state
|
|
If dimstatic <> 0 And dimshared = 0 Then
|
|
defdatahandle = 13
|
|
Close #13: Open tmpdir$ + "data" + str2$(subfuncn) + ".txt" For Append As #13
|
|
Close #19: Open tmpdir$ + "free" + str2$(subfuncn) + ".txt" For Append As #19
|
|
End If
|
|
|
|
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 Or optionexplicitarray Then Give_Error "Array '" + l$ + "' (" + symbol2fulltypename$(dtyp$) + ") not defined": EXIT Function
|
|
If Error_Happened Then EXIT Function
|
|
olddimstatic = dimstatic
|
|
method = 1
|
|
If subfuncn Then
|
|
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
|
|
bypassNextVariable = -1
|
|
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
|
|
bypassNextVariable = -1
|
|
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:
|
|
|
|
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" Or (n$ = "CV" And qb64prefix_set = 1) 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" Or (n$ = "MK" And qb64prefix_set = 1) Then
|
|
If RTrim$(id2.musthave) = "$" Then
|
|
If curarg = 1 Then
|
|
mktype$ = type2symbol$(e$)
|
|
If Error_Happened Then EXIT Function
|
|
If Debug Then Print #9, "_MK:[" + e$ + "]:[" + mktype$ + "]"
|
|
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" Or (n$ = "MEMGET" And qb64prefix_set = 1) 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 qb64prefix$ + "BIT TYPE unsupported": EXIT Function
|
|
memget_size = typname2typsize
|
|
If t And ISSTRING Then
|
|
If (t And ISFIXEDLENGTH) = 0 Then Give_Error "Expected STRING * ...": EXIT Function
|
|
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" Or (n$ = "MEM" And qb64prefix_set = 1) Then
|
|
If curarg = 1 Then
|
|
If args = 1 Then
|
|
targettyp = -7
|
|
End If
|
|
If args = 2 Then
|
|
r$ = RTrim$(id2.callname) + "_at_offset" + Right$(r$, Len(r$) - Len(RTrim$(id2.callname)))
|
|
If (sourcetyp And ISOFFSET) = 0 Then Give_Error "Expected _MEM(_OFFSET-value,...)": EXIT Function
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
'*special case*
|
|
If n$ = "_OFFSET" Or (n$ = "OFFSET" And qb64prefix_set = 1) Then
|
|
If (sourcetyp And ISREFERENCE) = 0 Then
|
|
Give_Error qb64prefix$ + "OFFSET expects the name of a variable/array": EXIT Function
|
|
End If
|
|
If (sourcetyp And ISARRAY) Then
|
|
If (sourcetyp And ISOFFSETINBITS) Then Give_Error qb64prefix$ + "OFFSET cannot reference _BIT type arrays": EXIT Function
|
|
End If
|
|
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" Or (n$ = "ROUND" And qb64prefix_set = 1) Then
|
|
If (sourcetyp And ISSTRING) Then Give_Error "Expected numeric value": EXIT Function
|
|
If (sourcetyp And ISREFERENCE) Then e$ = refer(e$, sourcetyp, 0)
|
|
If Error_Happened Then EXIT Function
|
|
'establish which function (if any!) should be used
|
|
If (sourcetyp And ISFLOAT) Then
|
|
bits = sourcetyp And 511
|
|
If bits > 64 Then e$ = "func_round_float(" + e$ + ")" Else e$ = "func_round_double(" + e$ + ")"
|
|
Else
|
|
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" Or (n$ = "MK" And qb64prefix_set = 1) Then mktype = -1
|
|
If mktype Then
|
|
If mktype <> -1 Or curarg = 2 Then
|
|
If (sourcetyp And ISOFFSET) Then Give_Error "Cannot convert " + qb64prefix$ + "OFFSET type to other types": EXIT Function
|
|
'both _MK and trad. process the following
|
|
qtyp& = 0
|
|
If mktype$ = "%%" Then ctype$ = "b": qtyp& = BYTETYPE - ISPOINTER
|
|
If mktype$ = "~%%" Then ctype$ = "ub": qtyp& = UBYTETYPE - ISPOINTER
|
|
If mktype$ = "%" Then ctype$ = "i": qtyp& = INTEGERTYPE - ISPOINTER
|
|
If mktype$ = "~%" Then ctype$ = "ui": qtyp& = UINTEGERTYPE - ISPOINTER
|
|
If mktype$ = "&" Then ctype$ = "l": qtyp& = LONGTYPE - ISPOINTER
|
|
If mktype$ = "~&" Then ctype$ = "ul": qtyp& = ULONGTYPE - ISPOINTER
|
|
If mktype$ = "&&" Then ctype$ = "i64": qtyp& = INTEGER64TYPE - ISPOINTER
|
|
If mktype$ = "~&&" Then ctype$ = "ui64": qtyp& = UINTEGER64TYPE - ISPOINTER
|
|
If mktype$ = "!" Then ctype$ = "s": qtyp& = SINGLETYPE - ISPOINTER
|
|
If mktype$ = "#" Then ctype$ = "d": qtyp& = DOUBLETYPE - ISPOINTER
|
|
If mktype$ = "##" Then ctype$ = "f": qtyp& = FLOATTYPE - ISPOINTER
|
|
If Left$(mktype$, 2) = "~`" Then ctype$ = "ubit": qtyp& = UINTEGER64TYPE - ISPOINTER: size = Val(Right$(mktype$, Len(mktype$) - 2))
|
|
If Left$(mktype$, 1) = "`" Then ctype$ = "bit": qtyp& = INTEGER64TYPE - ISPOINTER: size = Val(Right$(mktype$, Len(mktype$) - 1))
|
|
If qtyp& = 0 Then Give_Error qb64prefix$ + "MK only accepts numeric types": EXIT Function
|
|
If size Then
|
|
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" Or (n$ = "CV" And qb64prefix_set = 1) Then cvtype = -1
|
|
If cvtype Then
|
|
If cvtype <> -1 Or curarg = 2 Then
|
|
If (sourcetyp And ISSTRING) = 0 Then Give_Error n$ + " requires a STRING argument": EXIT Function
|
|
If (sourcetyp And ISREFERENCE) Then e$ = refer(e$, sourcetyp, 0)
|
|
If Error_Happened Then EXIT Function
|
|
typ& = 0
|
|
If cvtype$ = "%%" Then ctype$ = "b": typ& = BYTETYPE - ISPOINTER
|
|
If cvtype$ = "~%%" Then ctype$ = "ub": typ& = UBYTETYPE - ISPOINTER
|
|
If cvtype$ = "%" Then ctype$ = "i": typ& = INTEGERTYPE - ISPOINTER
|
|
If cvtype$ = "~%" Then ctype$ = "ui": typ& = UINTEGERTYPE - ISPOINTER
|
|
If cvtype$ = "&" Then ctype$ = "l": typ& = LONGTYPE - ISPOINTER
|
|
If cvtype$ = "~&" Then ctype$ = "ul": typ& = ULONGTYPE - ISPOINTER
|
|
If cvtype$ = "&&" Then ctype$ = "i64": typ& = INTEGER64TYPE - ISPOINTER
|
|
If cvtype$ = "~&&" Then ctype$ = "ui64": typ& = UINTEGER64TYPE - ISPOINTER
|
|
If cvtype$ = "!" Then ctype$ = "s": typ& = SINGLETYPE - ISPOINTER
|
|
If cvtype$ = "#" Then ctype$ = "d": typ& = DOUBLETYPE - ISPOINTER
|
|
If cvtype$ = "##" Then ctype$ = "f": typ& = FLOATTYPE - ISPOINTER
|
|
If Left$(cvtype$, 2) = "~`" Then ctype$ = "ubit": typ& = UINTEGER64TYPE - ISPOINTER: size = Val(Right$(cvtype$, Len(cvtype$) - 2))
|
|
If Left$(cvtype$, 1) = "`" Then ctype$ = "bit": typ& = INTEGER64TYPE - ISPOINTER: size = Val(Right$(cvtype$, Len(cvtype$) - 1))
|
|
If typ& = 0 Then Give_Error qb64prefix$ + "CV cannot return STRING type!": EXIT Function
|
|
If ctype$ = "bit" Or ctype$ = "ubit" Then
|
|
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
|
|
If qb64prefix_set And udtxcname(targettyp And 511) = "_MEM" Then
|
|
x$ = "'" + Mid$(RTrim$(udtxcname(targettyp And 511)), 2) + "'"
|
|
Else
|
|
x$ = "'" + RTrim$(udtxcname(targettyp And 511)) + "'"
|
|
End If
|
|
If ids(targetid).args = 1 Then Give_Error "TYPE " + x$ + " required for function": EXIT Function
|
|
Give_Error str_nth$(nth) + " function argument requires TYPE " + x$: EXIT Function
|
|
End If
|
|
Else
|
|
If sourcetyp And ISUDT Then Give_Error "Number required for function": EXIT Function
|
|
End If
|
|
|
|
'round to integer if required
|
|
If (sourcetyp And ISFLOAT) Then
|
|
If (targettyp And ISFLOAT) = 0 Then
|
|
'**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_sp<qbs_cmem_sp) error(257);"
|
|
Print #13, "}"
|
|
e$ = "&(*" + v$ + "=" + e$ + ")"
|
|
Else
|
|
Print #13, t$ + " " + v$ + ";"
|
|
e$ = "&(" + v$ + "=" + e$ + ")"
|
|
End If
|
|
GoTo dontevaluate
|
|
End If
|
|
|
|
dontevaluate:
|
|
|
|
If id2.ccall Then
|
|
|
|
'if a forced cast from a returned ccall function is in e$, remove it
|
|
If Left$(e$, 3) = "( " Then
|
|
e$ = removecast$(e$)
|
|
End If
|
|
|
|
If targettyp And ISSTRING Then
|
|
e$ = "(char*)(" + e$ + ")->chr"
|
|
End If
|
|
|
|
If LTrim$(RTrim$(e$)) = "0" Then e$ = "NULL"
|
|
|
|
End If
|
|
|
|
r$ = r$ + e$
|
|
|
|
'***special case****
|
|
If n$ = "_MEM" Or (n$ = "MEM" And qb64prefix_set = 1) Then
|
|
If args = 1 Then
|
|
If curarg = 1 Then r$ = r$ + ")": GoTo evalfuncspecial
|
|
End If
|
|
If args = 2 Then
|
|
If curarg = 2 Then r$ = r$ + ")": GoTo evalfuncspecial
|
|
End If
|
|
End If
|
|
|
|
If 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)
|
|
If udtxvariable(sourcetyp And 511) Then Give_Error "UDT must have fixed size": EXIT Function
|
|
idnumber = Val(e$)
|
|
i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i)
|
|
u = Val(e$) 'closest parent
|
|
i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i)
|
|
E = Val(e$)
|
|
i = InStr(e$, sp3): e$ = Right$(e$, Len(e$) - i)
|
|
o$ = e$
|
|
getid idnumber
|
|
If Error_Happened Then EXIT Function
|
|
n$ = "UDT_" + RTrim$(id.n)
|
|
If id.arraytype Then
|
|
n$ = "ARRAY_" + n$ + "[0]"
|
|
'whole array reference examplename()?
|
|
If Left$(o$, 3) = "(0)" Then
|
|
'use -2 type method
|
|
GoTo method2usealludt
|
|
End If
|
|
End If
|
|
|
|
dst$ = "(((char*)" + scope$ + n$ + ")+(" + o$ + "))"
|
|
|
|
'determine size of element
|
|
If E = 0 Then 'no specific element, use size of entire type
|
|
bytes$ = str2(udtxsize(u) \ 8)
|
|
Else 'a specific element
|
|
If (udtetype(E) And ISSTRING) > 0 And (udtetype(E) And ISFIXEDLENGTH) = 0 And (targettyp = -5) Then
|
|
evaluatetotyp$ = "(*(qbs**)" + dst$ + ")->len"
|
|
EXIT Function
|
|
End If
|
|
bytes$ = str2(udtesize(E) \ 8)
|
|
End If
|
|
evaluatetotyp$ = "byte_element((uint64)" + dst$ + "," + bytes$ + "," + NewByteElement$ + ")"
|
|
If targettyp = -5 Then evaluatetotyp$ = bytes$
|
|
If targettyp = -6 Then evaluatetotyp$ = dst$
|
|
EXIT Function
|
|
End If
|
|
|
|
If (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 qb64prefix$ + "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 qb64prefix$ + "MEMELEMENT cannot reference variable-length strings": EXIT Function
|
|
End If
|
|
|
|
'evaluatetotyp$ = "byte_element((uint64)" + e$ + "->chr," + bytes$ + "," + NewByteElement$ + ")"
|
|
'IF targettyp = -5 THEN evaluatetotyp$ = bytes$
|
|
'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 qb64prefix$ + "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 qb64prefix$ + "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 RTrim$(secondarg$) = UCase$(RTrim$(ids(i).secondargmustbe)) Then
|
|
ElseIf qb64prefix_set = 1 And Left$(ids(i).secondargmustbe, 1) = "_" And Left$(secondarg$, 1) <> "_" And RTrim$(secondarg$) = UCase$(Mid$(RTrim$(ids(i).secondargmustbe), 2)) Then
|
|
Else
|
|
GoTo findidnomatch
|
|
End If
|
|
End If
|
|
If Asc(ids(i).secondargcantbe) <> 32 Then 'exists?
|
|
If RTrim$(secondarg$) <> UCase$(RTrim$(ids(i).secondargcantbe)) Then
|
|
ElseIf qb64prefix_set = 1 And Left$(ids(i).secondargcantbe, 1) = "_" And Left$(secondarg$, 1) <> "_" And RTrim$(secondarg$) <> UCase$(Mid$(RTrim$(ids(i).secondargcantbe), 2)) Then
|
|
Else
|
|
GoTo findidnomatch
|
|
End If
|
|
End If
|
|
End If 'second sub argument possible
|
|
|
|
'must have symbol?
|
|
'typically for variables defined automatically or by a symbol and not the full type name
|
|
imusthave = CVI(ids(i).musthave) 'speed up checks of first 2 characters
|
|
amusthave = imusthave And 255 'speed up checks of first character
|
|
If amusthave <> 32 Then
|
|
If scpassed Then
|
|
If sc$ = ids(i).musthave Then GoTo findidok
|
|
End If
|
|
''' 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)
|
|
|
|
t = id.t
|
|
If t = 0 Then
|
|
t = id.arraytype
|
|
If t And ISUDT Then
|
|
manageVariableList "", scope$ + "ARRAY_UDT_" + RTrim$(id.n), 1
|
|
Else
|
|
n$ = id2shorttypename$
|
|
If Left$(n$, 1) = "_" Then
|
|
manageVariableList "", scope$ + "ARRAY" + n$ + "_" + RTrim$(id.n), 2
|
|
Else
|
|
manageVariableList "", scope$ + "ARRAY_" + n$ + "_" + RTrim$(id.n), 3
|
|
End If
|
|
End If
|
|
Else
|
|
If t And ISUDT Then
|
|
manageVariableList "", scope$ + "UDT_" + RTrim$(id.n), 4
|
|
Else
|
|
n$ = id2shorttypename$
|
|
If Left$(n$, 1) = "_" Then
|
|
manageVariableList "", scope$ + Mid$(n$, 2) + "_" + RTrim$(id.n), 5
|
|
Else
|
|
manageVariableList "", scope$ + n$ + "_" + RTrim$(id.n), 6
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
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$ <> SCase2$(f2$) Then
|
|
f2$ = SCase2$(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
|
|
If id.internal_subfunc Then
|
|
f2$ = SCase$(RTrim$(id.cn)) + s$
|
|
Else
|
|
f2$ = RTrim$(id.cn) + s$
|
|
End If
|
|
removeelements a$, i, i, 0
|
|
insertelements a$, i - 1, UCase$(f2$)
|
|
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
|
|
If id.internal_subfunc Then
|
|
f2$ = SCase$(RTrim$(id.cn)) + removesymbol$(f2$)
|
|
Else
|
|
f2$ = RTrim$(id.cn) + removesymbol$(f2$)
|
|
End If
|
|
If Error_Happened Then EXIT Function
|
|
removeelements a$, i, i, 0
|
|
insertelements a$, i - 1, UCase$(f2$)
|
|
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
|
|
If id.internal_subfunc Then
|
|
f2$ = SCase$(RTrim$(id.cn)) + s$
|
|
Else
|
|
f2$ = RTrim$(id.cn) + s$
|
|
End If
|
|
'change was is returned to uppercase
|
|
removeelements a$, i, i, 0
|
|
insertelements a$, i - 1, UCase$(f2$)
|
|
GoTo CouldNotClassify
|
|
End If 'id.t
|
|
|
|
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" Or (f3$ = "UNSIGNED" And qb64prefix_set = 1) Then internaltype = 1
|
|
If f3$ = "_BIT" Or (f3$ = "BIT" And qb64prefix_set = 1) Then internaltype = 1
|
|
If f3$ = "_BYTE" Or (f3$ = "BYTE" And qb64prefix_set = 1) Then internaltype = 1
|
|
If f3$ = "INTEGER" Then internaltype = 1
|
|
If f3$ = "LONG" Then internaltype = 1
|
|
If f3$ = "_INTEGER64" Or (f3$ = "INTEGER64" And qb64prefix_set = 1) Then internaltype = 1
|
|
If f3$ = "SINGLE" Then internaltype = 1
|
|
If f3$ = "DOUBLE" Then internaltype = 1
|
|
If f3$ = "_FLOAT" Or (f3$ = "FLOAT" And qb64prefix_set = 1) Then internaltype = 1
|
|
If f3$ = "_OFFSET" Or (f3$ = "OFFSET" And qb64prefix_set = 1) Then internaltype = 1
|
|
If internaltype = 1 Then
|
|
f2$ = SCase2$(f3$)
|
|
removeelements a$, i, i, 0
|
|
insertelements a$, i - 1, f3$
|
|
GoTo classdone
|
|
End If
|
|
|
|
GoTo classdone
|
|
End If '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 And Len(a$) > 1) Or (i > 1 And ((d > 0 And d = i - 1) Or (E > 0 And E = i - 1))) Then _Continue
|
|
EXIT Function
|
|
End If
|
|
If a = 46 Then
|
|
If dp = 1 Then EXIT Function
|
|
dp = 1
|
|
_Continue
|
|
End If
|
|
If a = 100 Or a = 68 Then 'D
|
|
If d > 0 Or E > 0 Then EXIT Function
|
|
If i = 1 Then EXIT Function
|
|
d = i
|
|
_Continue
|
|
End If
|
|
If a = 101 Or a = 69 Then 'E
|
|
If d > 0 Or E > 0 Then EXIT Function
|
|
If i = 1 Then EXIT Function
|
|
E = i
|
|
_Continue
|
|
End If
|
|
If a = 43 Then '+
|
|
If (d > 0 And d = i - 1) Or (E > 0 And E = i - 1) Then _Continue
|
|
EXIT Function
|
|
End If
|
|
|
|
If a >= 48 And a <= 57 Then _Continue
|
|
EXIT Function
|
|
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 = SCase$("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<n
|
|
finaldata = 1: GoTo adddata
|
|
finisheddata:
|
|
e$ = ""
|
|
If prepass = 0 Then
|
|
Put #16, , x$
|
|
DataOffset = DataOffset + Len(x$)
|
|
|
|
e$ = Space$((Len(x$) - 1) * 2)
|
|
For ec = 1 To Len(x$) - 1
|
|
'2 chr hex encode each character
|
|
v1 = Asc(x$, ec)
|
|
v2 = v1 \ 16: If v2 <= 9 Then v2 = v2 + 48 Else v2 = v2 + 55
|
|
v1 = v1 And 15: If v1 <= 9 Then v1 = v1 + 48 Else v1 = v1 + 55
|
|
Asc(e$, ec * 2 - 1) = v1
|
|
Asc(e$, ec * 2) = v2
|
|
Next
|
|
|
|
End If
|
|
|
|
a2$ = a2$ + sp + "DATA": If Len(e$) Then a2$ = a2$ + sp + "_" + e$
|
|
GoTo lineformatnext
|
|
End If
|
|
End If
|
|
|
|
a2$ = a2$ + sp + Mid$(ca$, i, n2)
|
|
i = i + n2
|
|
|
|
'----(variable/name)extensions----
|
|
extcheck:
|
|
If n2 > 40 Then Give_Error "Identifier longer than 40 character limit": EXIT Function
|
|
c3 = Asc(a$, i)
|
|
m = 0
|
|
If c3 = 126 Then '"~"
|
|
e2$ = Mid$(a$, i + 1, 2)
|
|
If e2$ = "&&" Then e2$ = "~&&": GoTo lfgetve
|
|
If e2$ = "%%" Then e2$ = "~%%": GoTo lfgetve
|
|
If e2$ = "%&" Then e2$ = "~%&": GoTo lfgetve
|
|
e2$ = Chr$(Asc(e2$))
|
|
If e2$ = "&" Then e2$ = "~&": GoTo lfgetve
|
|
If e2$ = "%" Then e2$ = "~%": GoTo lfgetve
|
|
If e2$ = "`" Then m = 1: e2$ = "~`": GoTo lfgetve
|
|
End If
|
|
If c3 = 37 Then
|
|
c4 = Asc(a$, i + 1)
|
|
If c4 = 37 Then e2$ = "%%": GoTo lfgetve
|
|
If c4 = 38 Then e2$ = "%&": GoTo lfgetve
|
|
e2$ = "%": GoTo lfgetve
|
|
End If
|
|
If c3 = 38 Then
|
|
c4 = Asc(a$, i + 1)
|
|
If c4 = 38 Then e2$ = "&&": GoTo lfgetve
|
|
e2$ = "&": GoTo lfgetve
|
|
End If
|
|
If c3 = 33 Then e2$ = "!": GoTo lfgetve
|
|
If c3 = 35 Then
|
|
c4 = Asc(a$, i + 1)
|
|
If c4 = 35 Then e2$ = "##": GoTo lfgetve
|
|
e2$ = "#": GoTo lfgetve
|
|
End If
|
|
If c3 = 36 Then m = 1: e2$ = "$": GoTo lfgetve
|
|
If c3 = 96 Then m = 1: e2$ = "`": GoTo lfgetve
|
|
'(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
|
|
'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
|
|
operator$ = UCase$(operator$)
|
|
If operator$ = "MOD" Then info$ = "%": operatorusage = 1: EXIT Function
|
|
If operator$ = "\" Then info$ = "/ ": operatorusage = 1: EXIT Function
|
|
If operator$ = "IMP" Then info$ = "|": operatorusage = 4: EXIT Function
|
|
If operator$ = "EQV" Then info$ = "^": operatorusage = 4: EXIT Function
|
|
If operator$ = "XOR" Then info$ = "^": operatorusage = 1: EXIT Function
|
|
If operator$ = "OR" Then info$ = "|": operatorusage = 1: EXIT Function
|
|
If operator$ = "AND" Then info$ = "&": operatorusage = 1: EXIT Function
|
|
|
|
lhs = 7
|
|
If operator$ = "NOT" Then info$ = "~": operatorusage = 5: EXIT Function
|
|
|
|
If 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
|
|
If typ And ISFIXEDLENGTH Then
|
|
o2$ = "(((uint8*)" + scope$ + n$ + ")+(" + o$ + "))"
|
|
r$ = "qbs_new_fixed(" + o2$ + "," + str2(udtetypesize(E)) + ",1)"
|
|
typ = STRINGTYPE + ISFIXEDLENGTH 'ISPOINTER retained, it is still a pointer!
|
|
Else
|
|
r$ = "*((qbs**)((char*)" + scope$ + n$ + "+(" + o$ + ")))"
|
|
typ = STRINGTYPE
|
|
End If
|
|
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
|
|
|
|
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
|
|
removePrefix = 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
|
|
noPrefixMatch = Left$(Opt(x, o), 1) = "_" And qb64prefix_set = 1 And c$ = UCase$(Mid$(RTrim$(Opt(x, o)), 2))
|
|
If c$ = UCase$(RTrim$(Opt(x, o))) Or noPrefixMatch Then
|
|
'Record Match
|
|
If i3 < position Then
|
|
position = i3
|
|
which = o
|
|
If noPrefixMatch Then removePrefix = 1
|
|
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))) - removePrefix) + SCase$(Mid$(RTrim$(Opt(x, which)), removePrefix + 1))
|
|
separgs(x) = Chr$(0) + str2(which)
|
|
Else
|
|
'Not Found...
|
|
'*********backtrack************
|
|
OptCheckBacktrack:
|
|
'Was this optional?
|
|
If Lev(x) > EntryLev(x) Then 'Optional Opt ()?
|
|
'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 E <> 0 And u = 1 Then 'Setting _MEM type elements is not allowed!
|
|
Give_Error "Cannot set read-only element of _MEM TYPE": EXIT Sub
|
|
End If
|
|
|
|
If E = 0 Then
|
|
'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$ + ")"
|
|
|
|
copy_full_udt dst$, src$, 12, 0, u
|
|
|
|
'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
|
|
If typ And ISFIXEDLENGTH Then
|
|
o2$ = "(((uint8*)" + scope$ + n$ + ")+(" + o$ + "))"
|
|
r$ = "qbs_new_fixed(" + o2$ + "," + str2(udtetypesize(E)) + ",1)"
|
|
Else
|
|
r$ = "*((qbs**)((char*)(" + scope$ + n$ + ")+(" + o$ + ")))"
|
|
End If
|
|
If method = 0 Then e$ = evaluatetotyp(e$, STRINGTYPE - ISPOINTER)
|
|
If Error_Happened Then EXIT Sub
|
|
Print #12, "qbs_set(" + r$ + "," + e$ + ");"
|
|
Print #12, cleanupstringprocessingcall$ + "0);"
|
|
Else
|
|
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$
|
|
If Left$(r$, 1) = "*" Then r$ = Mid$(r$, 2)
|
|
manageVariableList "", scope$ + n$, 7
|
|
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$
|
|
If Left$(r$, 1) = "*" Then r$ = Mid$(r$, 2)
|
|
manageVariableList "", r$, 8
|
|
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$
|
|
If Left$(r$, 1) = "*" Then r$ = Mid$(r$, 2)
|
|
manageVariableList "", r$, 9
|
|
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$
|
|
If Left$(r$, 1) = "*" Then r$ = Mid$(r$, 2)
|
|
manageVariableList "", r$, 10
|
|
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$
|
|
|
|
If Left$(r$, 1) = "*" Then r$ = Mid$(r$, 2)
|
|
manageVariableList "", r$, 11
|
|
|
|
EXIT Sub
|
|
End If 'variable
|
|
|
|
tlayout$ = tl$
|
|
End Sub
|
|
|
|
Function str2$ (v As Long)
|
|
str2$ = _Trim$(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
|
|
t2$ = "UNSIGNED BIT": s$ = "~`1": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound
|
|
t2$ = "UNSIGNED BYTE": s$ = "~%%": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound
|
|
t2$ = "UNSIGNED INTEGER": s$ = "~%": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound
|
|
t2$ = "UNSIGNED LONG": s$ = "~&": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound
|
|
t2$ = "UNSIGNED INTEGER64": s$ = "~&&": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound
|
|
t2$ = "UNSIGNED OFFSET": s$ = "~%&": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound
|
|
t2$ = "BIT": s$ = "`1": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound
|
|
t2$ = "BYTE": s$ = "%%": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound
|
|
t2$ = "INTEGER64": s$ = "&&": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound
|
|
t2$ = "OFFSET": s$ = "%&": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound
|
|
t2$ = "FLOAT": s$ = "##": If qb64prefix_set = 1 And Left$(t$, Len(t2$)) = t2$ Then GoTo t2sfound
|
|
Give_Error e$: EXIT Function
|
|
t2sfound:
|
|
type2symbol$ = s$
|
|
If Len(t2$) <> Len(t$) Then
|
|
If s$ <> "$" And s$ <> "~`1" And s$ <> "`1" Then Give_Error e$: EXIT Function
|
|
t$ = Right$(t$, Len(t$) - Len(t2$))
|
|
If Left$(t$, 3) <> " * " Then Give_Error e$: EXIT Function
|
|
t$ = Right$(t$, Len(t$) - 3)
|
|
If isuinteger(t$) = 0 Then Give_Error e$: EXIT Function
|
|
v = Val(t$)
|
|
If v = 0 Then Give_Error e$: EXIT Function
|
|
If s$ <> "$" And v > 56 Then Give_Error e$: EXIT Function
|
|
If s$ = "$" Then
|
|
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" Or (t$ = "FLOAT" And qb64prefix_set = 1) Then typname2typ& = FLOATTYPE: EXIT Function
|
|
If Left$(t$, 10) = "_UNSIGNED " Or (Left$(t$, 9) = "UNSIGNED " And qb64prefix_set = 1) Then
|
|
u = 1
|
|
t$ = Mid$(t$, InStr(t$, Chr$(32)) + 1)
|
|
End If
|
|
If Left$(t$, 4) = "_BIT" Or (Left$(t$, 3) = "BIT" And qb64prefix_set = 1) Then
|
|
If t$ = "_BIT" Or (t$ = "BIT" And qb64prefix_set = 1) Then
|
|
If u Then typname2typ& = UBITTYPE Else typname2typ& = BITTYPE
|
|
EXIT Function
|
|
End If
|
|
If Left$(t$, 7) <> "_BIT * " Or (Left$(t$, 6) = "BIT * " And qb64prefix_set = 1) Then Give_Error "Expected _BIT * number": EXIT Function
|
|
|
|
n$ = Right$(t$, Len(t$) - 7)
|
|
If isuinteger(n$) = 0 Then Give_Error "Invalid size after " + qb64prefix$ + "BIT *": EXIT Function
|
|
b = Val(n$)
|
|
If b = 0 Or b > 56 Then Give_Error "Invalid size after " + qb64prefix$ + "BIT *": EXIT Function
|
|
t = BITTYPE - 1 + b: If u Then t = t + ISUNSIGNED
|
|
typname2typ& = t
|
|
EXIT Function
|
|
End If
|
|
|
|
t = 0
|
|
If t$ = "_BYTE" Or (t$ = "BYTE" And qb64prefix_set = 1) Then t = BYTETYPE
|
|
If t$ = "INTEGER" Then t = INTEGERTYPE
|
|
If t$ = "LONG" Then t = LONGTYPE
|
|
If t$ = "_INTEGER64" Or (t$ = "INTEGER64" And qb64prefix_set = 1) Then t = INTEGER64TYPE
|
|
If t$ = "_OFFSET" Or (t$ = "OFFSET" And qb64prefix_set = 1) Then t = OFFSETTYPE
|
|
If t Then
|
|
If u Then t = t + ISUNSIGNED
|
|
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
|
|
ElseIf RTrim$(udtxname(i)) = "_MEM" And t$ = "MEM" And qb64prefix_set = 1 Then
|
|
typname2typ& = ISUDT + ISPOINTER + i
|
|
EXIT Function
|
|
End If
|
|
Next
|
|
|
|
'return 0 (failed)
|
|
End Function
|
|
|
|
Function uniquenumber&
|
|
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$)
|
|
|
|
n = numelements(label$)
|
|
|
|
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
|
|
|
|
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
|
|
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 'sub name
|
|
|
|
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 '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
|
|
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();"
|
|
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$ = SCase$("Print") + sp + "#" + sp2 + tlayout$ + sp2 + ","
|
|
e$ = evaluatetotyp(e$, 64&)
|
|
If Error_Happened Then EXIT Sub
|
|
Print #12, "tab_fileno=tmp_fileno=" + e$ + ";"
|
|
Print #12, "if (new_error) goto skip" + u$ + ";"
|
|
i = i + 1
|
|
|
|
'PRINT USING? (file)
|
|
If n >= i Then
|
|
If getelement(a$, i) = "USING" Then
|
|
'get format string
|
|
fpujump:
|
|
l$ = l$ + sp + SCase$("Using")
|
|
e$ = "": b = 0: puformat$ = ""
|
|
For i = i + 1 To n
|
|
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 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
|
|
'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$ = SCase$("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$
|
|
End Sub
|
|
|
|
Sub xgosub (ca$)
|
|
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
|
|
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
|
|
|
|
l$ = SCase$("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$ = SCase$("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
|
|
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)
|
|
|
|
l$ = SCase$("Print")
|
|
If Asc(a$) = 76 Then lp = 1: lp$ = "l": l$ = SCase$("LPrint"): Print #12, "tab_LPRINT=1;": DEPENDENCY(DEPENDENCY_PRINTER) = 1 '"L"
|
|
|
|
'PRINT USING?
|
|
If n >= 2 Then
|
|
If getelement(a$, 2) = "USING" Then
|
|
'get format string
|
|
i = 3
|
|
pujump:
|
|
l$ = l$ + sp + SCase$("Using")
|
|
e$ = "": b = 0: puformat$ = ""
|
|
For i = i To n
|
|
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
|
|
If TQBSset = 0 Then
|
|
Print #12, "tqbs=qbs_new(0,0);"
|
|
Else
|
|
Print #12, "qbs_set(tqbs,qbs_new_txt_len(" + Chr$(34) + Chr$(34) + ",0));"
|
|
End If
|
|
'set format start/index variable
|
|
Print #12, "tmp_long=0;" 'scan format from beginning
|
|
|
|
|
|
'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
|
|
TQBSset = -1 'set the temporary flag so we don't create a temp string twice, in case USING comes after something
|
|
For i = 2 To n
|
|
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$ = SCase$("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
|
|
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$ = SCase$("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
|
|
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$
|
|
|
|
|
|
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$ = ""
|
|
For i = 1 To n
|
|
|
|
If block(i) = ")" Then
|
|
If b = l Then block(i) = "": Exit For
|
|
b = b - 1
|
|
End If
|
|
|
|
If b >= l Then
|
|
If Len(e$) = 0 Then e$ = block(i) Else e$ = e$ + sp + block(i)
|
|
block(i) = ""
|
|
End If
|
|
|
|
If block(i) = "(" Then
|
|
b = b + 1
|
|
If b = l Then i2 = i: block(i) = ""
|
|
End If
|
|
|
|
Next i
|
|
|
|
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
|
|
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
|
|
|
|
Give_Error "Invalid CONST expression.7": EXIT Function
|
|
End If
|
|
|
|
'[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
|
|
|
|
'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
|
|
|
|
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
|
|
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
|
|
|
|
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:
|
|
|
|
i = i + 1
|
|
|
|
If i <= n Then GoTo evalconstequ
|
|
|
|
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
|
|
|
|
s$ = ""
|
|
|
|
If t And ISUNSIGNED Then s$ = "~"
|
|
|
|
b = t And 511
|
|
|
|
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$
|
|
|
|
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$ = qb64prefix$ + "BIT * " + str2(bits) Else a$ = qb64prefix$ + "BIT"
|
|
If t And ISUNSIGNED Then a$ = qb64prefix$ + "UNSIGNED " + a$
|
|
id2fulltypename$ = a$: EXIT Function
|
|
End If
|
|
If t And ISFLOAT Then
|
|
If bits = 32 Then a$ = "SINGLE"
|
|
If bits = 64 Then a$ = "DOUBLE"
|
|
If bits = 256 Then a$ = qb64prefix$ + "FLOAT"
|
|
Else 'integer-based
|
|
If bits = 8 Then a$ = qb64prefix$ + "BYTE"
|
|
If bits = 16 Then a$ = "INTEGER"
|
|
If bits = 32 Then a$ = "LONG"
|
|
If bits = 64 Then a$ = qb64prefix$ + "INTEGER64"
|
|
If t And ISUNSIGNED Then a$ = qb64prefix$ + "UNSIGNED " + a$
|
|
End If
|
|
id2fulltypename$ = a$
|
|
End Function
|
|
|
|
Function id2shorttypename$
|
|
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))
|
|
id2shorttypename$ = a$: EXIT Function
|
|
End If
|
|
If t And ISSTRING Then
|
|
If t And ISFIXEDLENGTH Then a$ = "STRING" + str2(size) Else a$ = "STRING"
|
|
id2shorttypename$ = a$: EXIT Function
|
|
End If
|
|
If t And ISOFFSETINBITS Then
|
|
If t And ISUNSIGNED Then a$ = "_U" Else a$ = "_"
|
|
If bits > 1 Then a$ = a$ + "BIT" + str2(bits) Else a$ = a$ + "BIT1"
|
|
id2shorttypename$ = a$: EXIT Function
|
|
End If
|
|
If t And ISFLOAT Then
|
|
If bits = 32 Then a$ = "SINGLE"
|
|
If bits = 64 Then a$ = "DOUBLE"
|
|
If bits = 256 Then a$ = "_FLOAT"
|
|
Else 'integer-based
|
|
If bits = 8 Then
|
|
If (t And ISUNSIGNED) Then a$ = "_UBYTE" Else a$ = "_BYTE"
|
|
End If
|
|
If bits = 16 Then
|
|
If (t And ISUNSIGNED) Then a$ = "UINTEGER" Else a$ = "INTEGER"
|
|
End If
|
|
If bits = 32 Then
|
|
If (t And ISUNSIGNED) Then a$ = "ULONG" Else a$ = "LONG"
|
|
End If
|
|
If bits = 64 Then
|
|
If (t And ISUNSIGNED) Then a$ = "_UINTEGER64" Else a$ = "_INTEGER64"
|
|
End If
|
|
End If
|
|
id2shorttypename$ = a$
|
|
End Function
|
|
|
|
Function symbol2fulltypename$ (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$ = qb64prefix$ + "UNSIGNED "
|
|
End If
|
|
|
|
If s$ = "%%" Then t$ = u$ + qb64prefix$ + "BYTE": GoTo gotsym2typ
|
|
If s$ = "%" Then t$ = u$ + "INTEGER": GoTo gotsym2typ
|
|
If s$ = "&" Then t$ = u$ + "LONG": GoTo gotsym2typ
|
|
If s$ = "&&" Then t$ = u$ + qb64prefix$ + "INTEGER64": GoTo gotsym2typ
|
|
If s$ = "%&" Then t$ = u$ + qb64prefix$ + "OFFSET": GoTo gotsym2typ
|
|
|
|
If Left$(s$, 1) = "`" Then
|
|
If Len(s$) = 1 Then
|
|
t$ = u$ + qb64prefix$ + "BIT * 1"
|
|
GoTo gotsym2typ
|
|
End If
|
|
n$ = Right$(s$, Len(s$) - 1)
|
|
If isuinteger(n$) = 0 Then Give_Error "Expected number after symbol `": EXIT Function
|
|
t$ = u$ + qb64prefix$ + "BIT * " + n$
|
|
GoTo gotsym2typ
|
|
End If
|
|
|
|
If u = 1 Then Give_Error "Expected type symbol after ~": EXIT Function
|
|
|
|
If s$ = "!" Then t$ = "SINGLE": GoTo gotsym2typ
|
|
If s$ = "#" Then t$ = "DOUBLE": GoTo gotsym2typ
|
|
If s$ = "##" Then t$ = qb64prefix$ + "FLOAT": GoTo gotsym2typ
|
|
If s$ = "$" Then t$ = "STRING": GoTo gotsym2typ
|
|
|
|
If 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$
|
|
|
|
gotsym2typ:
|
|
|
|
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
|
|
|
|
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
|
|
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
|
|
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 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$ = ""
|
|
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$
|
|
End Function
|
|
|
|
|
|
Sub SetDependency (requirement)
|
|
If requirement Then
|
|
DEPENDENCY(requirement) = 1
|
|
End If
|
|
End Sub
|
|
|
|
Sub Build (path$)
|
|
previous_dir$ = _CWD$
|
|
|
|
'Count the separators in the path
|
|
depth = 1
|
|
For x = 1 To Len(path$)
|
|
If Asc(path$, x) = 92 Or Asc(path$, x) = 47 Then depth = depth + 1
|
|
Next
|
|
ChDir path$
|
|
|
|
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$
|
|
End If
|
|
End If
|
|
Loop
|
|
Close #bfh
|
|
|
|
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
|
|
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$
|
|
End Function
|
|
|
|
|
|
Sub PATH_SLASH_CORRECT (a$)
|
|
If os$ = "WIN" Then
|
|
For x = 1 To Len(a$)
|
|
If Asc(a$, x) = 47 Then Asc(a$, x) = 92
|
|
Next
|
|
Else
|
|
For x = 1 To Len(a$)
|
|
If Asc(a$, x) = 92 Then Asc(a$, x) = 47
|
|
Next
|
|
End If
|
|
End Sub
|
|
|
|
'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
|
|
PreParse t$
|
|
|
|
|
|
If Left$(t$, 5) = "ERROR" Then Evaluate_Expression$ = t$: EXIT Function
|
|
|
|
'Deal with brackets first
|
|
exp$ = "(" + t$ + ")" 'Starting and finishing brackets for our parse routine.
|
|
|
|
Do
|
|
Eval_E = InStr(exp$, ")")
|
|
If Eval_E > 0 Then
|
|
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 Evaluate_Expression$ = "ERROR -- BAD () Count": EXIT Function
|
|
eval$ = " " + Mid$(exp$, s, Eval_E - s) + " " 'pad with a space before and after so the parser can pick up the values properly.
|
|
|
|
ParseExpression eval$
|
|
eval$ = LTrim$(RTrim$(eval$))
|
|
If Left$(eval$, 5) = "ERROR" Then Evaluate_Expression$ = eval$: EXIT Function
|
|
exp$ = DWD(Left$(exp$, s - 2) + eval$ + Mid$(exp$, Eval_E + 1))
|
|
If Mid$(exp$, 1, 1) = "N" Then Mid$(exp$, 1) = "-"
|
|
End If
|
|
Loop Until Eval_E = 0
|
|
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 Function
|
|
End Select
|
|
Loop Until c >= Len(exp$)
|
|
|
|
Evaluate_Expression$ = exp$
|
|
End Function
|
|
|
|
|
|
|
|
Sub ParseExpression (exp$)
|
|
Dim num(10) As String
|
|
'PRINT exp$
|
|
exp$ = DWD(exp$)
|
|
'We should now have an expression with no () to deal with
|
|
|
|
For J = 1 To 250
|
|
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 startAt = 2 Else startAt = 1
|
|
op = InStr(startAt, exp$, OName(P))
|
|
If op = 0 And Left$(OName(P), 1) = "_" And qb64prefix_set = 1 Then
|
|
'try again without prefix
|
|
op = InStr(startAt, exp$, Mid$(OName(P), 2))
|
|
If op > 0 Then
|
|
exp$ = Left$(exp$, op - 1) + "_" + Mid$(exp$, op)
|
|
lowest = lowest + 1
|
|
End If
|
|
End If
|
|
If op > 0 And op < lowest Then lowest = op: OpOn = P
|
|
End If
|
|
Next
|
|
If OpOn = 0 Then Exit Do 'We haven't gotten to the proper PL for this OP to be processed yet.
|
|
If Left$(exp$, 1) = "-" Then startAt = 2 Else startAt = 1
|
|
op = InStr(startAt, exp$, OName(OpOn))
|
|
|
|
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 ",": numset = 0
|
|
Case Else 'Not a valid digit, we found our separator
|
|
Exit Do
|
|
End Select
|
|
c = c + 1
|
|
Loop Until op + c >= Len(exp$)
|
|
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) = "-"
|
|
If num(1) = "-" Then
|
|
num(3) = "N" + EvaluateNumbers(OpOn, num())
|
|
Else
|
|
num(3) = EvaluateNumbers(OpOn, num())
|
|
End If
|
|
If Mid$(num(3), 1, 1) = "-" Then Mid$(num(3), 1) = "N"
|
|
If Left$(num(3), 5) = "ERROR" Then exp$ = num(3): EXIT Sub
|
|
exp$ = LTrim$(N2S(DWD(Left$(exp$, s) + RTrim$(LTrim$(num(3))) + Mid$(exp$, E + 1))))
|
|
End If
|
|
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!
|
|
ReDim OName(10000) As String, PL(10000) As Integer
|
|
'Constants get evaluated first, with a Priority Level of 1
|
|
|
|
i = i + 1: OName(i) = "C_UOF": PL(i) = 5 'convert to unsigned offset
|
|
i = i + 1: OName(i) = "C_OF": PL(i) = 5 'convert to offset
|
|
i = i + 1: OName(i) = "C_UBY": PL(i) = 5 'convert to unsigned byte
|
|
i = i + 1: OName(i) = "C_BY": PL(i) = 5 'convert to byte
|
|
i = i + 1: OName(i) = "C_UIN": PL(i) = 5 'convert to unsigned integer
|
|
i = i + 1: OName(i) = "C_IN": PL(i) = 5 'convert to integer
|
|
i = i + 1: OName(i) = "C_UIF": PL(i) = 5 'convert to unsigned int64
|
|
i = i + 1: OName(i) = "C_IF": PL(i) = 5 'convert to int64
|
|
i = i + 1: OName(i) = "C_ULO": PL(i) = 5 'convert to unsigned long
|
|
i = i + 1: OName(i) = "C_LO": PL(i) = 5 'convert to long
|
|
i = i + 1: OName(i) = "C_SI": PL(i) = 5 'convert to single
|
|
i = i + 1: OName(i) = "C_FL": PL(i) = 5 'convert to float
|
|
i = i + 1: OName(i) = "C_DO": PL(i) = 5 'convert to double
|
|
i = i + 1: OName(i) = "C_UBI": PL(i) = 5 'convert to unsigned bit
|
|
i = i + 1: OName(i) = "C_BI": PL(i) = 5 'convert to bit
|
|
|
|
'Then Functions with PL 10
|
|
i = i + 1:: OName(i) = "_PI": PL(i) = 10
|
|
i = i + 1: OName(i) = "_ACOS": PL(i) = 10
|
|
i = i + 1: OName(i) = "_ASIN": PL(i) = 10
|
|
i = i + 1: OName(i) = "_ARCSEC": PL(i) = 10
|
|
i = i + 1: OName(i) = "_ARCCSC": PL(i) = 10
|
|
i = i + 1: OName(i) = "_ARCCOT": PL(i) = 10
|
|
i = i + 1: OName(i) = "_SECH": PL(i) = 10
|
|
i = i + 1: OName(i) = "_CSCH": PL(i) = 10
|
|
i = i + 1: OName(i) = "_COTH": PL(i) = 10
|
|
i = i + 1: OName(i) = "COS": PL(i) = 10
|
|
i = i + 1: OName(i) = "SIN": PL(i) = 10
|
|
i = i + 1: OName(i) = "TAN": PL(i) = 10
|
|
i = i + 1: OName(i) = "LOG": PL(i) = 10
|
|
i = i + 1: OName(i) = "EXP": PL(i) = 10
|
|
i = i + 1: OName(i) = "ATN": PL(i) = 10
|
|
i = i + 1: OName(i) = "_D2R": PL(i) = 10
|
|
i = i + 1: OName(i) = "_D2G": PL(i) = 10
|
|
i = i + 1: OName(i) = "_R2D": PL(i) = 10
|
|
i = i + 1: OName(i) = "_R2G": PL(i) = 10
|
|
i = i + 1: OName(i) = "_G2D": PL(i) = 10
|
|
i = i + 1: OName(i) = "_G2R": PL(i) = 10
|
|
i = i + 1: OName(i) = "ABS": PL(i) = 10
|
|
i = i + 1: OName(i) = "SGN": PL(i) = 10
|
|
i = i + 1: OName(i) = "INT": PL(i) = 10
|
|
i = i + 1: OName(i) = "_ROUND": PL(i) = 10
|
|
i = i + 1: OName(i) = "_CEIL": PL(i) = 10
|
|
i = i + 1: OName(i) = "FIX": PL(i) = 10
|
|
i = i + 1: OName(i) = "_SEC": PL(i) = 10
|
|
i = i + 1: OName(i) = "_CSC": PL(i) = 10
|
|
i = i + 1: OName(i) = "_COT": PL(i) = 10
|
|
i = i + 1: OName(i) = "ASC": PL(i) = 10
|
|
i = i + 1: OName(i) = "CHR$": PL(i) = 10
|
|
i = i + 1: OName(i) = "C_RG": PL(i) = 10 '_RGB32 converted
|
|
i = i + 1: OName(i) = "C_RA": PL(i) = 10 '_RGBA32 converted
|
|
i = i + 1: OName(i) = "_RGB": PL(i) = 10
|
|
i = i + 1: OName(i) = "_RGBA": PL(i) = 10
|
|
i = i + 1: OName(i) = "C_RX": PL(i) = 10 '_RED32 converted
|
|
i = i + 1: OName(i) = "C_GR": PL(i) = 10 ' _GREEN32 converted
|
|
i = i + 1: OName(i) = "C_BL": PL(i) = 10 '_BLUE32 converted
|
|
i = i + 1: OName(i) = "C_AL": PL(i) = 10 '_ALPHA32 converted
|
|
i = i + 1: OName(i) = "_RED": PL(i) = 10
|
|
i = i + 1: OName(i) = "_GREEN": PL(i) = 10
|
|
i = i + 1: OName(i) = "_BLUE": PL(i) = 10
|
|
i = i + 1: OName(i) = "_ALPHA": PL(i) = 10
|
|
|
|
'Exponents with PL 20
|
|
i = i + 1: OName(i) = "^": PL(i) = 20
|
|
i = i + 1: OName(i) = "SQR": PL(i) = 20
|
|
i = i + 1: OName(i) = "ROOT": PL(i) = 20
|
|
'Multiplication and Division PL 30
|
|
i = i + 1: OName(i) = "*": PL(i) = 30
|
|
i = i + 1: OName(i) = "/": PL(i) = 30
|
|
'Integer Division PL 40
|
|
i = i + 1: OName(i) = "\": PL(i) = 40
|
|
'MOD PL 50
|
|
i = i + 1: OName(i) = "MOD": PL(i) = 50
|
|
'Addition and Subtraction PL 60
|
|
i = i + 1: OName(i) = "+": PL(i) = 60
|
|
i = i + 1: OName(i) = "-": PL(i) = 60
|
|
|
|
'Relational Operators =, >, <, <>, <=, >= PL 70
|
|
i = i + 1: OName(i) = "<>": PL(i) = 70 'These next three are just reversed symbols as an attempt to help process a common typo
|
|
i = i + 1: OName(i) = "><": PL(i) = 70
|
|
i = i + 1: OName(i) = "<=": PL(i) = 70
|
|
i = i + 1: OName(i) = ">=": PL(i) = 70
|
|
i = i + 1: OName(i) = "=<": PL(i) = 70 'I personally can never keep these things straight. Is it < = or = <...
|
|
i = i + 1: OName(i) = "=>": PL(i) = 70 'Who knows, check both!
|
|
i = i + 1: OName(i) = ">": PL(i) = 70
|
|
i = i + 1: OName(i) = "<": PL(i) = 70
|
|
i = i + 1: OName(i) = "=": PL(i) = 70
|
|
'Logical Operations PL 80+
|
|
i = i + 1: OName(i) = "NOT": PL(i) = 80
|
|
i = i + 1: OName(i) = "AND": PL(i) = 90
|
|
i = i + 1: OName(i) = "OR": PL(i) = 100
|
|
i = i + 1: OName(i) = "XOR": PL(i) = 110
|
|
i = i + 1: OName(i) = "EQV": PL(i) = 120
|
|
i = i + 1: OName(i) = "IMP": PL(i) = 130
|
|
i = i + 1: OName(i) = ",": PL(i) = 1000
|
|
|
|
ReDim _Preserve OName(i) As String, PL(i) As Integer
|
|
End Sub
|
|
|
|
Function EvaluateNumbers$ (p, num() As String)
|
|
Dim n1 As _Float, n2 As _Float, n3 As _Float
|
|
'PRINT "EVALNUM:"; OName(p), num(1), num(2)
|
|
|
|
If _Trim$(num(1)) = "" Then num(1) = "0"
|
|
|
|
If PL(p) >= 20 And (Len(_Trim$(num(1))) = 0 Or Len(_Trim$(num(2))) = 0) Then
|
|
EvaluateNumbers$ = "ERROR - Missing operand": EXIT Function
|
|
End If
|
|
|
|
If InStr(num(1), ",") Then
|
|
EvaluateNumbers$ = "ERROR - Invalid comma (" + num(1) + ")": EXIT Function
|
|
End If
|
|
l2 = InStr(num(2), ",")
|
|
If l2 Then
|
|
Select Case OName(p) 'only certain commands should pass a comma value
|
|
Case "C_RG", "C_RA", "_RGB", "_RGBA", "_RED", "_GREEN", "C_BL", "_ALPHA"
|
|
Case Else
|
|
C$ = Mid$(num(2), l2)
|
|
num(2) = Left$(num(2), l2 - 1)
|
|
End Select
|
|
End If
|
|
|
|
Select Case PL(p) 'divide up the work so we want do as much case checking
|
|
Case 5 'Type conversions
|
|
'Note, these are special cases and work with the number BEFORE the command and not after
|
|
Select Case OName(p) 'Depending on our operator..
|
|
Case "C_UOF": n1~%& = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1~%&)))
|
|
Case "C_ULO": n1%& = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1%&)))
|
|
Case "C_UBY": n1~%% = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1~%%)))
|
|
Case "C_UIN": n1~% = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1~%)))
|
|
Case "C_BY": n1%% = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1%%)))
|
|
Case "C_IN": n1% = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1%)))
|
|
Case "C_UIF": n1~&& = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1~&&)))
|
|
Case "C_OF": n1~& = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1~&)))
|
|
Case "C_IF": n1&& = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1&&)))
|
|
Case "C_LO": n1& = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1&)))
|
|
Case "C_UBI": n1~` = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1~`)))
|
|
Case "C_BI": n1` = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1`)))
|
|
Case "C_FL": n1## = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1##)))
|
|
Case "C_DO": n1# = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1#)))
|
|
Case "C_SI": n1! = Val(num(1)): EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1!)))
|
|
End Select
|
|
EXIT Function
|
|
Case 10 'functions
|
|
Select Case OName(p) 'Depending on our operator..
|
|
Case "_PI"
|
|
n1 = 3.14159265358979323846264338327950288## 'Future compatable in case something ever stores extra digits for PI
|
|
If num(2) <> "" Then n1 = n1 * Val(num(2))
|
|
Case "_ACOS": n1 = _Acos(Val(num(2)))
|
|
Case "_ASIN": n1 = _Asin(Val(num(2)))
|
|
Case "_ARCSEC": n1 = _Arcsec(Val(num(2)))
|
|
Case "_ARCCSC": n1 = _Arccsc(Val(num(2)))
|
|
Case "_ARCCOT": n1 = _Arccot(Val(num(2)))
|
|
Case "_SECH": n1 = _Sech(Val(num(2)))
|
|
Case "_CSCH": n1 = _Csch(Val(num(2)))
|
|
Case "_COTH": n1 = _Coth(Val(num(2)))
|
|
Case "C_RG"
|
|
n$ = num(2)
|
|
If n$ = "" Then EvaluateNumbers$ = "ERROR - Invalid null _RGB32": EXIT Function
|
|
c1 = InStr(n$, ",")
|
|
If c1 Then c2 = InStr(c1 + 1, n$, ",")
|
|
If c2 Then c3 = InStr(c2 + 1, n$, ",")
|
|
If c3 Then c4 = InStr(c3 + 1, n$, ",")
|
|
If c1 = 0 Then 'there's no comma in the command to parse. It's a grayscale value
|
|
n = Val(num(2))
|
|
n1 = _RGB32(n, n, n)
|
|
ElseIf c2 = 0 Then 'there's one comma and not 2. It's grayscale with alpha.
|
|
n = Val(Left$(num(2), c1))
|
|
n2 = Val(Mid$(num(2), c1 + 1))
|
|
n1 = _RGBA32(n, n, n, n2)
|
|
ElseIf c3 = 0 Then 'there's two commas. It's _RGB values
|
|
n = Val(Left$(num(2), c1))
|
|
n2 = Val(Mid$(num(2), c1 + 1))
|
|
n3 = Val(Mid$(num(2), c2 + 1))
|
|
n1 = _RGB32(n, n2, n3)
|
|
ElseIf c4 = 0 Then 'there's three commas. It's _RGBA values
|
|
n = Val(Left$(num(2), c1))
|
|
n2 = Val(Mid$(num(2), c1 + 1))
|
|
n3 = Val(Mid$(num(2), c2 + 1))
|
|
n4 = Val(Mid$(num(2), c3 + 1))
|
|
n1 = _RGBA32(n, n2, n3, n4)
|
|
Else 'we have more than three commas. I have no idea WTH type of values got passed here!
|
|
EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + ")": EXIT Function
|
|
End If
|
|
Case "C_RA"
|
|
n$ = num(2)
|
|
If n$ = "" Then EvaluateNumbers$ = "ERROR - Invalid null _RGBA32": EXIT Function
|
|
c1 = InStr(n$, ",")
|
|
If c1 Then c2 = InStr(c1 + 1, n$, ",")
|
|
If c2 Then c3 = InStr(c2 + 1, n$, ",")
|
|
If c3 Then c4 = InStr(c3 + 1, n$, ",")
|
|
If c3 = 0 Or c4 <> 0 Then EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + ")": EXIT Function
|
|
'we have to have 3 commas; not more, not less.
|
|
n = Val(Left$(num(2), c1))
|
|
n2 = Val(Mid$(num(2), c1 + 1))
|
|
n3 = Val(Mid$(num(2), c2 + 1))
|
|
n4 = Val(Mid$(num(2), c3 + 1))
|
|
n1 = _RGBA32(n, n2, n3, n4)
|
|
Case "_RGB"
|
|
n$ = num(2)
|
|
If n$ = "" Then EvaluateNumbers$ = "ERROR - Invalid null _RGB": EXIT Function
|
|
c1 = InStr(n$, ",")
|
|
If c1 Then c2 = InStr(c1 + 1, n$, ",")
|
|
If c2 Then c3 = InStr(c2 + 1, n$, ",")
|
|
If c3 Then c4 = InStr(c3 + 1, n$, ",")
|
|
If c3 = 0 Or c4 <> 0 Then EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + "). _RGB requires 4 parameters for Red, Green, Blue, ScreenMode.": EXIT Function
|
|
'we have to have 3 commas; not more, not less.
|
|
n = Val(Left$(num(2), c1))
|
|
n2 = Val(Mid$(num(2), c1 + 1))
|
|
n3 = Val(Mid$(num(2), c2 + 1))
|
|
n4 = Val(Mid$(num(2), c3 + 1))
|
|
Select Case n4
|
|
Case 0 TO 2, 7 TO 13, 256, 32 'these are the good screen values
|
|
Case Else
|
|
EvaluateNumbers$ = "ERROR - Invalid Screen Mode (" + Str$(n4) + ")": EXIT Function
|
|
End Select
|
|
t = _NewImage(1, 1, n4)
|
|
n1 = _RGB(n, n2, n3, t)
|
|
_FreeImage t
|
|
Case "_RGBA"
|
|
n$ = num(2)
|
|
If n$ = "" Then EvaluateNumbers$ = "ERROR - Invalid null _RGBA": EXIT Function
|
|
c1 = InStr(n$, ",")
|
|
If c1 Then c2 = InStr(c1 + 1, n$, ",")
|
|
If c2 Then c3 = InStr(c2 + 1, n$, ",")
|
|
If c3 Then c4 = InStr(c3 + 1, n$, ",")
|
|
If c4 Then c5 = InStr(c4 + 1, n$, ",")
|
|
If c4 = 0 Or c5 <> 0 Then EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + "). _RGBA requires 5 parameters for Red, Green, Blue, Alpha, ScreenMode.": EXIT Function
|
|
'we have to have 4 commas; not more, not less.
|
|
n = Val(Left$(num(2), c1))
|
|
n2 = Val(Mid$(num(2), c1 + 1))
|
|
n3 = Val(Mid$(num(2), c2 + 1))
|
|
n4 = Val(Mid$(num(2), c3 + 1))
|
|
n5 = Val(Mid$(num(2), c4 + 1))
|
|
Select Case n5
|
|
Case 0 TO 2, 7 TO 13, 256, 32 'these are the good screen values
|
|
Case Else
|
|
EvaluateNumbers$ = "ERROR - Invalid Screen Mode (" + Str$(n5) + ")": EXIT Function
|
|
End Select
|
|
t = _NewImage(1, 1, n5)
|
|
n1 = _RGBA(n, n2, n3, n4, t)
|
|
_FreeImage t
|
|
Case "_RED", "_GREEN", "_BLUE", "_ALPHA"
|
|
n$ = num(2)
|
|
If n$ = "" Then EvaluateNumbers$ = "ERROR - Invalid null " + OName(p): EXIT Function
|
|
c1 = InStr(n$, ",")
|
|
If c1 = 0 Then EvaluateNumbers$ = "ERROR - " + OName(p) + " requires 2 parameters for Color, ScreenMode.": EXIT Function
|
|
If c1 Then c2 = InStr(c1 + 1, n$, ",")
|
|
If c2 Then EvaluateNumbers$ = "ERROR - " + OName(p) + " requires 2 parameters for Color, ScreenMode.": EXIT Function
|
|
n = Val(Left$(num(2), c1))
|
|
n2 = Val(Mid$(num(2), c1 + 1))
|
|
Select Case n2
|
|
Case 0 TO 2, 7 TO 13, 256, 32 'these are the good screen values
|
|
Case Else
|
|
EvaluateNumbers$ = "ERROR - Invalid Screen Mode (" + Str$(n2) + ")": EXIT Function
|
|
End Select
|
|
t = _NewImage(1, 1, n4)
|
|
Select Case OName(p)
|
|
Case "_RED": n1 = _Red(n, t)
|
|
Case "_BLUE": n1 = _Blue(n, t)
|
|
Case "_GREEN": n1 = _Green(n, t)
|
|
Case "_ALPHA": n1 = _Alpha(n, t)
|
|
End Select
|
|
_FreeImage t
|
|
Case "C_RX", "C_GR", "C_BL", "C_AL"
|
|
n$ = num(2)
|
|
If n$ = "" Then EvaluateNumbers$ = "ERROR - Invalid null " + OName(p): EXIT Function
|
|
n = Val(num(2))
|
|
Select Case OName(p)
|
|
Case "C_RX": n1 = _Red32(n)
|
|
Case "C_BL": n1 = _Blue32(n)
|
|
Case "C_GR": n1 = _Green32(n)
|
|
Case "C_AL": n1 = _Alpha32(n)
|
|
End Select
|
|
Case "COS": n1 = Cos(Val(num(2)))
|
|
Case "SIN": n1 = Sin(Val(num(2)))
|
|
Case "TAN": n1 = Tan(Val(num(2)))
|
|
Case "LOG": n1 = Log(Val(num(2)))
|
|
Case "EXP": n1 = Exp(Val(num(2)))
|
|
Case "ATN": n1 = Atn(Val(num(2)))
|
|
Case "_D2R": n1 = 0.0174532925 * (Val(num(2)))
|
|
Case "_D2G": n1 = 1.1111111111 * (Val(num(2)))
|
|
Case "_R2D": n1 = 57.2957795 * (Val(num(2)))
|
|
Case "_R2G": n1 = 0.015707963 * (Val(num(2)))
|
|
Case "_G2D": n1 = 0.9 * (Val(num(2)))
|
|
Case "_G2R": n1 = 63.661977237 * (Val(num(2)))
|
|
Case "ABS": n1 = Abs(Val(num(2)))
|
|
Case "SGN": n1 = Sgn(Val(num(2)))
|
|
Case "INT": n1 = Int(Val(num(2)))
|
|
Case "_ROUND": n1 = _Round(Val(num(2)))
|
|
Case "_CEIL": n1 = _Ceil(Val(num(2)))
|
|
Case "FIX": n1 = Fix(Val(num(2)))
|
|
Case "_SEC": n1 = _Sec(Val(num(2)))
|
|
Case "_CSC": n1 = _Csc(Val(num(2)))
|
|
Case "_COT": n1 = _Cot(Val(num(2)))
|
|
End Select
|
|
Case 20 TO 60 'Math Operators
|
|
Select Case OName(p) 'Depending on our operator..
|
|
Case "^": n1 = Val(num(1)) ^ Val(num(2))
|
|
Case "SQR": n1 = Sqr(Val(num(2)))
|
|
Case "ROOT"
|
|
n1 = Val(num(1)): n2 = Val(num(2))
|
|
If n2 = 1 Then EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1))): EXIT Function
|
|
If n1 < 0 And n2 >= 1 Then sign = -1: n1 = -n1 Else sign = 1
|
|
n3 = 1## / n2
|
|
If n3 <> Int(n3) And n2 < 1 Then sign = Sgn(n1): n1 = Abs(n1)
|
|
n1 = sign * (n1 ^ n3)
|
|
Case "*": n1 = Val(num(1)) * Val(num(2))
|
|
Case "/"
|
|
If Val(num(2)) <> 0 Then
|
|
n1 = Val(num(1)) / Val(num(2))
|
|
Else
|
|
EvaluateNumbers$ = "ERROR - Division By Zero"
|
|
EXIT Function
|
|
End If
|
|
Case "\"
|
|
If Val(num(2)) <> 0 Then
|
|
n1 = Val(num(1)) \ Val(num(2))
|
|
Else
|
|
EvaluateNumbers$ = "ERROR - Division By Zero"
|
|
EXIT Function
|
|
End If
|
|
Case "MOD"
|
|
If Val(num(2)) <> 0 Then
|
|
n1 = Val(num(1)) Mod Val(num(2))
|
|
Else
|
|
EvaluateNumbers$ = "ERROR - Division By Zero"
|
|
EXIT Function
|
|
End If
|
|
Case "+": n1 = Val(num(1)) + Val(num(2))
|
|
Case "-":
|
|
n1 = Val(num(1)) - Val(num(2))
|
|
End Select
|
|
Case 70 'Relational Operators =, >, <, <>, <=, >=
|
|
Select Case OName(p) 'Depending on our operator..
|
|
Case "=": n1 = Val(num(1)) = Val(num(2))
|
|
Case ">": n1 = Val(num(1)) > Val(num(2))
|
|
Case "<": n1 = Val(num(1)) < Val(num(2))
|
|
Case "<>", "><": n1 = Val(num(1)) <> Val(num(2))
|
|
Case "<=", "=<": n1 = Val(num(1)) <= Val(num(2))
|
|
Case ">=", "=>": n1 = Val(num(1)) >= Val(num(2))
|
|
End Select
|
|
Case Else 'a value we haven't processed elsewhere
|
|
Select Case OName(p) 'Depending on our operator..
|
|
Case "NOT": n1 = Not Val(num(2))
|
|
Case "AND": n1 = Val(num(1)) And Val(num(2))
|
|
Case "OR": n1 = Val(num(1)) Or Val(num(2))
|
|
Case "XOR": n1 = Val(num(1)) Xor Val(num(2))
|
|
Case "EQV": n1 = Val(num(1)) Eqv Val(num(2))
|
|
Case "IMP": n1 = Val(num(1)) Imp Val(num(2))
|
|
End Select
|
|
End Select
|
|
|
|
EvaluateNumbers$ = RTrim$(LTrim$(Str$(n1))) + C$
|
|
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
|
|
Do
|
|
l = InStr(t$, "++")
|
|
If l Then t$ = Left$(t$, l - 1) + "+" + Mid$(t$, l + 2): bad = -1
|
|
Loop Until l = 0
|
|
Do
|
|
l = InStr(t$, "+-")
|
|
If l Then t$ = Left$(t$, l - 1) + "-" + Mid$(t$, l + 2): bad = -1
|
|
Loop Until l = 0
|
|
Do
|
|
l = InStr(t$, "-+")
|
|
If l Then t$ = Left$(t$, l - 1) + "-" + Mid$(t$, l + 2): bad = -1
|
|
Loop Until l = 0
|
|
Do
|
|
l = InStr(t$, "--")
|
|
If l Then t$ = Left$(t$, l - 1) + "+" + Mid$(t$, l + 2): bad = -1
|
|
Loop Until l = 0
|
|
Loop Until Not bad
|
|
DWD$ = t$
|
|
End Function
|
|
|
|
Sub PreParse (e$)
|
|
Dim f As _Float
|
|
Static TotalPrefixedPP_TypeMod As Long, TotalPP_TypeMod As Long
|
|
|
|
If PP_TypeMod(0) = "" Then
|
|
ReDim PP_TypeMod(100) As String, PP_ConvertedMod(100) As String 'Large enough to hold all values to begin with
|
|
PP_TypeMod(0) = "Initialized" 'Set so we don't do this section over and over, as we keep the values in shared memory.
|
|
'and the below is a conversion list so symbols don't get cross confused.
|
|
i = i + 1: PP_TypeMod(i) = "~`": PP_ConvertedMod(i) = "C_UBI" 'unsigned bit
|
|
i = i + 1: PP_TypeMod(i) = "~%%": PP_ConvertedMod(i) = "C_UBY" 'unsigned byte
|
|
i = i + 1: PP_TypeMod(i) = "~%&": PP_ConvertedMod(i) = "C_UOF" 'unsigned offset
|
|
i = i + 1: PP_TypeMod(i) = "~%": PP_ConvertedMod(i) = "C_UIN" 'unsigned integer
|
|
i = i + 1: PP_TypeMod(i) = "~&&": PP_ConvertedMod(i) = "C_UIF" 'unsigned integer64
|
|
i = i + 1: PP_TypeMod(i) = "~&": PP_ConvertedMod(i) = "C_ULO" 'unsigned long
|
|
i = i + 1: PP_TypeMod(i) = "`": PP_ConvertedMod(i) = "C_BI" 'bit
|
|
i = i + 1: PP_TypeMod(i) = "%%": PP_ConvertedMod(i) = "C_BY" 'byte
|
|
i = i + 1: PP_TypeMod(i) = "%&": PP_ConvertedMod(i) = "C_OF" 'offset
|
|
i = i + 1: PP_TypeMod(i) = "%": PP_ConvertedMod(i) = "C_IN" 'integer
|
|
i = i + 1: PP_TypeMod(i) = "&&": PP_ConvertedMod(i) = "C_IF" 'integer64
|
|
i = i + 1: PP_TypeMod(i) = "&": PP_ConvertedMod(i) = "C_LO" 'long
|
|
i = i + 1: PP_TypeMod(i) = "!": PP_ConvertedMod(i) = "C_SI" 'single
|
|
i = i + 1: PP_TypeMod(i) = "##": PP_ConvertedMod(i) = "C_FL" 'float
|
|
i = i + 1: PP_TypeMod(i) = "#": PP_ConvertedMod(i) = "C_DO" 'double
|
|
i = i + 1: PP_TypeMod(i) = "_RGB32": PP_ConvertedMod(i) = "C_RG" 'rgb32
|
|
i = i + 1: PP_TypeMod(i) = "_RGBA32": PP_ConvertedMod(i) = "C_RA" 'rgba32
|
|
i = i + 1: PP_TypeMod(i) = "_RED32": PP_ConvertedMod(i) = "C_RX" 'red32
|
|
i = i + 1: PP_TypeMod(i) = "_GREEN32": PP_ConvertedMod(i) = "C_GR" 'green32
|
|
i = i + 1: PP_TypeMod(i) = "_BLUE32": PP_ConvertedMod(i) = "C_BL" 'blue32
|
|
i = i + 1: PP_TypeMod(i) = "_ALPHA32": PP_ConvertedMod(i) = "C_AL" 'alpha32
|
|
TotalPrefixedPP_TypeMod = i
|
|
i = i + 1: PP_TypeMod(i) = "RGB32": PP_ConvertedMod(i) = "C_RG" 'rgb32
|
|
i = i + 1: PP_TypeMod(i) = "RGBA32": PP_ConvertedMod(i) = "C_RA" 'rgba32
|
|
i = i + 1: PP_TypeMod(i) = "RED32": PP_ConvertedMod(i) = "C_RX" 'red32
|
|
i = i + 1: PP_TypeMod(i) = "GREEN32": PP_ConvertedMod(i) = "C_GR" 'green32
|
|
i = i + 1: PP_TypeMod(i) = "BLUE32": PP_ConvertedMod(i) = "C_BL" 'blue32
|
|
i = i + 1: PP_TypeMod(i) = "ALPHA32": PP_ConvertedMod(i) = "C_AL" 'alpha32
|
|
TotalPP_TypeMod = i
|
|
ReDim _Preserve PP_TypeMod(i) As String, PP_ConvertedMod(i) As String 'And then resized to just contain the necessary space in memory
|
|
End If
|
|
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
|
|
|
|
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
|
|
|
|
'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
|
|
|
|
'replace existing CONST values
|
|
sep$ = "()+-*/\><=^"
|
|
For i2 = 0 To constlast
|
|
thisConstName$ = constname(i2)
|
|
For replaceConstPass = 1 To 2
|
|
found = 0
|
|
Do
|
|
found = InStr(found + 1, UCase$(t$), thisConstName$)
|
|
If found Then
|
|
If found > 1 Then
|
|
If InStr(sep$, Mid$(t$, found - 1, 1)) = 0 Then _Continue
|
|
End If
|
|
If found + Len(thisConstName$) <= Len(t$) Then
|
|
If InStr(sep$, Mid$(t$, found + Len(thisConstName$), 1)) = 0 Then _Continue
|
|
End If
|
|
t = consttype(i2)
|
|
If t And ISSTRING Then
|
|
r$ = conststring(i2)
|
|
i4 = _InStrRev(r$, ",")
|
|
r$ = Left$(r$, i4 - 1)
|
|
Else
|
|
If t And ISFLOAT Then
|
|
r$ = Str$(constfloat(i2))
|
|
r$ = N2S(r$)
|
|
Else
|
|
If t And ISUNSIGNED Then r$ = Str$(constuinteger(i2)) Else r$ = Str$(constinteger(i2))
|
|
End If
|
|
End If
|
|
t$ = Left$(t$, found - 1) + _Trim$(r$) + Mid$(t$, found + Len(thisConstName$))
|
|
End If
|
|
Loop Until found = 0
|
|
thisConstName$ = constname(i2) + constnamesymbol(i2)
|
|
Next
|
|
Next
|
|
|
|
uboundPP_TypeMod = TotalPrefixedPP_TypeMod
|
|
If qb64prefix_set = 1 Then uboundPP_TypeMod = TotalPP_TypeMod
|
|
For j = 1 To uboundPP_TypeMod
|
|
l = 0
|
|
Do
|
|
l = InStr(l + 1, t$, PP_TypeMod(j))
|
|
If l = 0 Then Exit Do
|
|
i = 0: l1 = 0: l2 = 0: lo = Len(PP_TypeMod(j))
|
|
Do
|
|
If PL(i) > 10 Then
|
|
l2 = _InStrRev(l, t$, OName$(i))
|
|
If l2 > 0 And l2 > l1 Then l1 = l2
|
|
End If
|
|
i = i + lo
|
|
Loop Until i > UBound(PL)
|
|
l$ = Left$(t$, l1)
|
|
m$ = Mid$(t$, l1 + 1, l - l1 - 1)
|
|
r$ = PP_ConvertedMod(j) + Mid$(t$, l + lo)
|
|
If j > 15 Then
|
|
t$ = l$ + m$ + r$ 'replacement routine for commands which might get confused with others, like _RGB and _RGB32
|
|
Else
|
|
'the first 15 commands need to properly place the parenthesis around the value we want to convert.
|
|
t$ = l$ + "(" + m$ + ")" + r$
|
|
End If
|
|
l = l + 2 + Len(PP_TypeMod(j)) 'move forward from the length of the symbol we checked + the new "(" and ")"
|
|
Loop
|
|
Next
|
|
|
|
'Check for bad operators before a ( bracket
|
|
l = 0
|
|
Do
|
|
l = InStr(l + 1, t$, "(")
|
|
If l > 0 And l > 2 Then 'Don't check the starting bracket; there's nothing before it.
|
|
good = 0
|
|
For i = 1 To UBound(OName)
|
|
m$ = Mid$(t$, l - Len(OName(i)), Len(OName(i)))
|
|
If m$ = OName(i) Then
|
|
good = -1: Exit For 'We found an operator after our ), and it's not a CONST (like PI)
|
|
Else
|
|
If Left$(OName(i), 1) = "_" And qb64prefix_set = 1 Then
|
|
'try without prefix
|
|
m$ = Mid$(t$, l - (Len(OName(i)) - 1), Len(OName(i)) - 1)
|
|
If m$ = Mid$(OName(i), 2) Then good = -1: Exit For
|
|
End If
|
|
End If
|
|
Next
|
|
If Not good Then e$ = "ERROR - Improper operations before (.": EXIT Sub
|
|
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 > 0 And l < Len(t$) Then
|
|
good = 0
|
|
For i = 1 To UBound(OName)
|
|
m$ = Mid$(t$, l + 1, Len(OName(i)))
|
|
If m$ = OName(i) Then
|
|
good = -1: Exit For 'We found an operator after our ), and it's not a CONST (like PI
|
|
Else
|
|
If Left$(OName(i), 1) = "_" And qb64prefix_set = 1 Then
|
|
'try without prefix
|
|
m$ = Mid$(t$, l + 1, Len(OName(i)) - 1)
|
|
If m$ = Mid$(OName(i), 2) Then good = -1: Exit For
|
|
End If
|
|
End If
|
|
Next
|
|
If Mid$(t$, l + 1, 1) = ")" Then good = -1
|
|
If Not good Then e$ = "ERROR - Improper operations after ).": EXIT Sub
|
|
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 &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$
|
|
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
|
|
extrachar = 0
|
|
For i = 1 To UBound(OName)
|
|
If Mid$(t$, j, Len(OName(i))) = OName(i) Then
|
|
good = -1: Exit For 'We found an operator after our ), and it's not a CONST (like PI)
|
|
Else
|
|
If Left$(OName(i), 1) = "_" And qb64prefix_set = 1 Then
|
|
'try without prefix
|
|
If Mid$(t$, j, Len(OName(i)) - 1) = Mid$(OName(i), 2) Then
|
|
good = -1: extrachar = 1: Exit For
|
|
End If
|
|
End If
|
|
End If
|
|
Next
|
|
If Not good Then t$ = "ERROR - Bad Operational value. (" + comp$ + ")": EXIT Sub
|
|
j = j + (Len(OName(i)) - extrachar)
|
|
End Select
|
|
Loop Until j > Len(t$)
|
|
End Sub
|
|
|
|
Function N2S$ (exp$) 'scientific Notation to String
|
|
|
|
t$ = LTrim$(RTrim$(exp$))
|
|
If Left$(t$, 1) = "-" Or Left$(t$, 1) = "N" Then sign$ = "-": t$ = Mid$(t$, 2)
|
|
|
|
dp = InStr(t$, "D+"): dm = InStr(t$, "D-")
|
|
ep = InStr(t$, "E+"): em = InStr(t$, "E-")
|
|
check1 = Sgn(dp) + Sgn(dm) + Sgn(ep) + Sgn(em)
|
|
If check1 < 1 Or check1 > 1 Then N2S = exp$: EXIT Function 'If no scientic notation is found, or if we find more than 1 type, it's not SN!
|
|
|
|
Select Case l 'l now tells us where the SN starts at.
|
|
Case Is < dp: l = dp
|
|
Case Is < dm: l = dm
|
|
Case Is < ep: l = ep
|
|
Case Is < em: l = em
|
|
End Select
|
|
|
|
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
|
|
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
|
|
|
|
N2S$ = sign$ + l$
|
|
End Function
|
|
|
|
|
|
Function QuotedFilename$ (f$)
|
|
|
|
If os$ = "WIN" Then
|
|
QuotedFilename$ = Chr$(34) + f$ + Chr$(34)
|
|
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
|
|
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
|
|
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
|
|
|
|
'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
|
|
End If
|
|
End If
|
|
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
|
|
End If
|
|
End If
|
|
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
|
|
|
|
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
|
|
i = HashList(i).PrevItem
|
|
If i Then GoTo hashfindrevc_next
|
|
EXIT Function
|
|
|
|
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
|
|
End If
|
|
End If
|
|
End If
|
|
i = HashList(i).NextItem
|
|
If i Then GoTo hashfindc_next
|
|
EXIT Function
|
|
|
|
End If
|
|
End Function
|
|
|
|
Sub HashRemove
|
|
|
|
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
|
|
|
|
'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
|
|
'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
|
|
|
|
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
|
|
|
|
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$
|
|
|
|
x$ = x$ + ",.Reference=" + Str$(HashList(i).Reference)
|
|
|
|
Print #fh, x$
|
|
|
|
'validate
|
|
i1 = HashList(i).PrevItem
|
|
i2 = HashList(i).NextItem
|
|
If i1 Then
|
|
If HashList(i1).NextItem <> i Then GoTo corrupt
|
|
End If
|
|
If i2 Then
|
|
If HashList(i2).PrevItem <> i Then GoTo corrupt
|
|
End If
|
|
If i2 = 0 Then
|
|
If lasti <> i Then GoTo corrupt
|
|
End If
|
|
|
|
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
|
|
|
|
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
|
|
|
|
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
|
|
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$
|
|
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)<mem_static_limit) " + a$ + "=(byte_element_struct*)(mem_static_pointer-12); else " + a$ + "=(byte_element_struct*)mem_static_malloc(12);"
|
|
Print #13, "}"
|
|
End If
|
|
End Function
|
|
|
|
Function validname (a$)
|
|
'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$)
|
|
|
|
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
|
|
|
|
'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"
|
|
End Function
|
|
|
|
Sub Give_Error (a$)
|
|
Error_Happened = 1
|
|
Error_Message = a$
|
|
End Sub
|
|
|
|
Sub WriteConfigSetting (heading$, item$, tvalue$)
|
|
value$ = tvalue$
|
|
Shared ConfigFile$, ConfigBak$
|
|
|
|
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$
|
|
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
|
|
|
|
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
|
|
End If
|
|
End If
|
|
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
|
|
|
|
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 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 Function
|
|
second = i: secondsymbol$ = a$
|
|
Case Else 'we found a symbol we don't recognize
|
|
Exit For
|
|
End Select
|
|
Next
|
|
End If
|
|
If first Then 'we found a symbol
|
|
l$ = RTrim$(Left$(temp$, first - 1))
|
|
If second Then rightstart = second + 1 Else rightstart = first + 1
|
|
|
|
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 =
|
|
UserFound = 0
|
|
For i = 0 To UserDefineCount
|
|
If UserDefine(0, i) = l$ Then
|
|
UserFound = -1
|
|
If UserDefine(1, i) = r$ Then result$ = " -1 ": GoTo finishedcheck
|
|
End If
|
|
Next
|
|
If UserFound = 0 And LTrim$(RTrim$(r$)) = "UNDEFINED" Then result$ = " -1 ": GoTo finishedcheck
|
|
If UserFound = -1 And LTrim$(RTrim$(r$)) = "DEFINED" Then result$ = " -1 ": GoTo finishedcheck
|
|
End If
|
|
|
|
If 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
|
|
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
|
|
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 Function
|
|
|
|
Function VerifyNumber (text$)
|
|
t$ = LTrim$(RTrim$(text$))
|
|
v = Val(t$)
|
|
t1$ = LTrim$(Str$(v))
|
|
If t$ = t1$ Then VerifyNumber = -1
|
|
End Function
|
|
|
|
Sub initialise_udt_varstrings (n$, udt, file, base_offset)
|
|
If Not udtxvariable(udt) Then EXIT Sub
|
|
element = udtxnext(udt)
|
|
offset = 0
|
|
Do While element
|
|
If udtetype(element) And ISSTRING Then
|
|
If (udtetype(element) And ISFIXEDLENGTH) = 0 Then
|
|
Print #file, "*(qbs**)(((char*)" + n$ + ")+" + Str$(base_offset + offset) + ") = qbs_new(0,0);"
|
|
End If
|
|
ElseIf udtetype(element) And ISUDT Then
|
|
initialise_udt_varstrings n$, udtetype(element) And 511, file, offset
|
|
End If
|
|
offset = offset + udtesize(element) \ 8
|
|
element = udtenext(element)
|
|
Loop
|
|
End Sub
|
|
|
|
Sub free_udt_varstrings (n$, udt, file, base_offset)
|
|
If Not udtxvariable(udt) Then EXIT Sub
|
|
element = udtxnext(udt)
|
|
offset = 0
|
|
Do While element
|
|
If udtetype(element) And ISSTRING Then
|
|
If (udtetype(element) And ISFIXEDLENGTH) = 0 Then
|
|
Print #file, "qbs_free(*((qbs**)(((char*)" + n$ + ")+" + Str$(base_offset + offset) + ")));"
|
|
End If
|
|
ElseIf udtetype(element) And ISUDT Then
|
|
initialise_udt_varstrings n$, udtetype(element) And 511, file, offset
|
|
End If
|
|
offset = offset + udtesize(element) \ 8
|
|
element = udtenext(element)
|
|
Loop
|
|
End Sub
|
|
|
|
Sub initialise_array_udt_varstrings (n$, udt, base_offset, bytesperelement$, acc$)
|
|
If Not udtxvariable(udt) Then EXIT Sub
|
|
offset = base_offset
|
|
element = udtxnext(udt)
|
|
Do While element
|
|
If udtetype(element) And ISSTRING Then
|
|
If (udtetype(element) And ISFIXEDLENGTH) = 0 Then
|
|
acc$ = acc$ + Chr$(13) + Chr$(10) + "*(qbs**)(" + n$ + "[0]+(" + bytesperelement$ + "-1)*tmp_long+" + Str$(offset) + ")=qbs_new(0,0);"
|
|
End If
|
|
ElseIf udtetype(element) And ISUDT Then
|
|
initialise_array_udt_varstrings n$, udtetype(element) And 511, offset, bytesperelement$, acc$
|
|
End If
|
|
offset = offset + udtesize(element) \ 8
|
|
element = udtenext(element)
|
|
Loop
|
|
End Sub
|
|
|
|
Sub free_array_udt_varstrings (n$, udt, base_offset, bytesperelement$, acc$)
|
|
If Not udtxvariable(udt) Then EXIT Sub
|
|
offset = base_offset
|
|
element = udtxnext(udt)
|
|
Do While element
|
|
If udtetype(element) And ISSTRING Then
|
|
If (udtetype(element) And ISFIXEDLENGTH) = 0 Then
|
|
acc$ = acc$ + Chr$(13) + Chr$(10) + "qbs_free(*(qbs**)(" + n$ + "[0]+(" + bytesperelement$ + "-1)*tmp_long+" + Str$(offset) + "));"
|
|
End If
|
|
ElseIf udtetype(element) And ISUDT Then
|
|
free_array_udt_varstrings n$, udtetype(element) And 511, offset, bytesperelement$, acc$
|
|
End If
|
|
offset = offset + udtesize(element) \ 8
|
|
element = udtenext(element)
|
|
Loop
|
|
End Sub
|
|
|
|
Sub copy_full_udt (dst$, src$, file, base_offset, udt)
|
|
If Not udtxvariable(udt) Then
|
|
Print #file, "memcpy(" + dst$ + "+" + Str$(base_offset) + "," + src$ + "+" + Str$(base_offset) + "," + Str$(udtxsize(udt) \ 8) + ");"
|
|
EXIT Sub
|
|
End If
|
|
offset = base_offset
|
|
element = udtxnext(udt)
|
|
Do While element
|
|
If ((udtetype(element) And ISSTRING) > 0) And (udtetype(element) And ISFIXEDLENGTH) = 0 Then
|
|
Print #file, "qbs_set(*(qbs**)(" + dst$ + "+" + Str$(offset) + "), *(qbs**)(" + src$ + "+" + Str$(offset) + "));"
|
|
ElseIf ((udtetype(element) And ISUDT) > 0) Then
|
|
copy_full_udt dst$, src$, 12, offset, udtetype(element) And 511
|
|
Else
|
|
Print #file, "memcpy((" + dst$ + "+" + Str$(offset) + "),(" + src$ + "+" + Str$(offset) + ")," + Str$(udtesize(element) \ 8) + ");"
|
|
End If
|
|
offset = offset + udtesize(element) \ 8
|
|
element = udtenext(element)
|
|
Loop
|
|
End Sub
|
|
|
|
Sub dump_udts
|
|
f = FreeFile
|
|
Open "types.txt" For Output As #f
|
|
Print #f, "Name Size Align? Next Var?"
|
|
For i = 1 To lasttype
|
|
Print #f, RTrim$(udtxname(i)), udtxsize(i), udtxbytealign(i), udtxnext(i), udtxvariable(i)
|
|
Next i
|
|
Print #f, "Name Size Align? Next Type Tsize Arr"
|
|
For i = 1 To lasttypeelement
|
|
Print #f, RTrim$(udtename(i)), udtesize(i), udtebytealign(i), udtenext(i), udtetype(i), udtetypesize(i), udtearrayelements(i)
|
|
Next i
|
|
Close #f
|
|
End Sub
|
|
|
|
Sub manageVariableList (name$, __cname$, action As _Byte)
|
|
Dim findItem As Long, cname$, i As Long
|
|
cname$ = __cname$
|
|
|
|
findItem = InStr(cname$, "[")
|
|
If findItem Then
|
|
cname$ = Left$(cname$, findItem - 1)
|
|
End If
|
|
|
|
found = 0
|
|
For i = 1 To totalVariablesCreated
|
|
If usedVariableList(i).cname = cname$ Then found = -1: Exit For
|
|
Next
|
|
|
|
Select Case action
|
|
Case 0 'add
|
|
If found = 0 Then
|
|
If i > UBound(usedVariableList) Then
|
|
ReDim _Preserve usedVariableList(UBound(usedVariableList) + 999) As usedVarList
|
|
End If
|
|
usedVariableList(i).used = 0
|
|
usedVariableList(i).linenumber = linenumber
|
|
usedVariableList(i).includeLevel = inclevel
|
|
If inclevel > 0 Then
|
|
usedVariableList(i).includedLine = inclinenumber(inclevel)
|
|
thisincname$ = getfilepath$(incname$(inclevel))
|
|
thisincname$ = Mid$(incname$(inclevel), Len(thisincname$) + 1)
|
|
usedVariableList(i).includedFile = thisincname$
|
|
Else
|
|
usedVariableList(i).includedLine = 0
|
|
usedVariableList(i).includedFile = ""
|
|
End If
|
|
usedVariableList(i).cname = cname$
|
|
usedVariableList(i).name = name$
|
|
totalVariablesCreated = totalVariablesCreated + 1
|
|
End If
|
|
Case Else 'find and mark as used
|
|
If found Then
|
|
usedVariableList(i).used = -1
|
|
End If
|
|
End Select
|
|
End Sub
|
|
|
|
Sub addWarning (whichLineNumber As Long, includeLevel As Long, incLineNumber As Long, incFileName$, header$, text$)
|
|
warningsissued = -1
|
|
totalWarnings = totalWarnings + 1
|
|
|
|
If idemode = 0 And ShowWarnings Then
|
|
thissource$ = getfilepath$(CMDLineFile)
|
|
thissource$ = Mid$(CMDLineFile, Len(thissource$) + 1)
|
|
thisincname$ = getfilepath$(incFileName$)
|
|
thisincname$ = Mid$(incFileName$, Len(thisincname$) + 1)
|
|
|
|
If Not MonochromeLoggingMode Then Color 15
|
|
If includeLevel > 0 And incLineNumber > 0 Then
|
|
Print thisincname$; ":";
|
|
Print str2$(incLineNumber); ": ";
|
|
Else
|
|
Print thissource$; ":";
|
|
Print str2$(whichLineNumber); ": ";
|
|
End If
|
|
|
|
If Not MonochromeLoggingMode Then Color 13
|
|
Print "warning: ";
|
|
If Not MonochromeLoggingMode Then Color 7
|
|
Print header$
|
|
|
|
If Len(text$) > 0 Then
|
|
If Not MonochromeLoggingMode Then Color 2
|
|
Print Space$(4); text$
|
|
If Not MonochromeLoggingMode Then Color 7
|
|
End If
|
|
ElseIf idemode Then
|
|
If Not IgnoreWarnings Then
|
|
If lastWarningHeader <> header$ Then
|
|
lastWarningHeader = header$
|
|
GoSub increaseWarningCount
|
|
warning$(warningListItems) = MKL$(0) + Chr$(2) + header$
|
|
End If
|
|
|
|
GoSub increaseWarningCount
|
|
If includeLevel > 0 Then
|
|
thisincname$ = getfilepath$(incFileName$)
|
|
thisincname$ = Mid$(incFileName$, Len(thisincname$) + 1)
|
|
warning$(warningListItems) = MKL$(whichLineNumber) + MKL$(includeLevel) + MKL$(incLineNumber) + thisincname$ + Chr$(2) + text$
|
|
Else
|
|
warning$(warningListItems) = MKL$(whichLineNumber) + MKL$(0) + Chr$(2) + text$
|
|
End If
|
|
End If
|
|
End If
|
|
EXIT Sub
|
|
increaseWarningCount:
|
|
warningListItems = warningListItems + 1
|
|
If warningListItems > UBound(warning$) Then ReDim _Preserve warning$(warningListItems + 999)
|
|
Return
|
|
End Sub
|
|
|
|
Function SCase$ (t$)
|
|
If ideautolayoutkwcapitals Then SCase$ = UCase$(t$) Else SCase$ = t$
|
|
End Function
|
|
|
|
Function SCase2$ (t$)
|
|
separator$ = sp
|
|
If ideautolayoutkwcapitals Then
|
|
SCase2$ = UCase$(t$)
|
|
Else
|
|
newWord = -1
|
|
temp$ = ""
|
|
For i = 1 To Len(t$)
|
|
s$ = Mid$(t$, i, 1)
|
|
If newWord Then
|
|
If s$ = "_" Or s$ = separator$ Then
|
|
temp$ = temp$ + s$
|
|
Else
|
|
temp$ = temp$ + UCase$(s$)
|
|
newWord = 0
|
|
End If
|
|
Else
|
|
If s$ = separator$ Then
|
|
temp$ = temp$ + separator$
|
|
newWord = -1
|
|
Else
|
|
temp$ = temp$ + LCase$(s$)
|
|
End If
|
|
End If
|
|
Next
|
|
SCase2$ = temp$
|
|
End If
|
|
End Function
|
|
|
|
'$INCLUDE:'utilities\strings.bas'
|
|
|
|
'$INCLUDE:'subs_functions\extensions\opengl\opengl_methods.bas'
|
|
|
|
DefLng A-Z
|
|
|
|
'-------- Optional IDE Component (2/2) --------
|
|
'$INCLUDE:'ide\ide_methods.bas'
|