mirror of
https://github.com/QB64-Phoenix-Edition/QB64pe.git
synced 2024-09-19 21:25:11 +00:00
49f0471e03
This allows simplifying how the size of UDT arrays are calculated, and thus not leave memory uninitialised when doing a redim that expands the array size.
763 lines
28 KiB
QBasic
763 lines
28 KiB
QBasic
|
|
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
|
|
IF t AND ISOFFSET THEN
|
|
a$ = qb64prefix$ + "OFFSET"
|
|
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
|
|
|
|
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 > 64 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 > 64 THEN EXIT FUNCTION
|
|
symboltype = n + ISOFFSETINBITS + ISUNSIGNED: EXIT FUNCTION
|
|
END IF
|
|
EXIT FUNCTION
|
|
END IF
|
|
END IF '~
|
|
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 t 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 > 64 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$ = "INTEGER": s$ = "%": IF t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "LONG": s$ = "&": IF t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "SINGLE": s$ = "!": IF t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "DOUBLE": s$ = "#": IF t$ = t2$ THEN GOTO t2sfound
|
|
|
|
t2$ = "_BYTE": s$ = "%%": IF t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "BYTE": s$ = "%%": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
|
|
t2$ = "_UNSIGNED LONG": s$ = "~&": IF t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "UNSIGNED LONG": s$ = "~&": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
|
|
t2$ = "_UNSIGNED INTEGER": s$ = "~%": IF t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "UNSIGNED INTEGER": s$ = "~%": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
|
|
t2$ = "_UNSIGNED _BYTE": s$ = "~%%": IF t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "_UNSIGNED BYTE": s$ = "~%%": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "UNSIGNED _BYTE": s$ = "~%%": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "UNSIGNED BYTE": s$ = "~%%": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
|
|
t2$ = "_UNSIGNED _OFFSET": s$ = "~%&": IF t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "_UNSIGNED OFFSET": s$ = "~%&": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "UNSIGNED _OFFSET": s$ = "~%&": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "UNSIGNED OFFSET": s$ = "~%&": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
|
|
t2$ = "_UNSIGNED _INTEGER64": s$ = "~&&": IF t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "_UNSIGNED INTEGER64": s$ = "~&&": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "UNSIGNED _INTEGER64": s$ = "~&&": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "UNSIGNED INTEGER64": s$ = "~&&": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
|
|
t2$ = "_INTEGER64": s$ = "&&": IF t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "INTEGER64": s$ = "&&": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
|
|
t2$ = "_OFFSET": s$ = "%&": IF t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "OFFSET": s$ = "%&": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
|
|
t2$ = "_FLOAT": s$ = "##": IF t$ = t2$ THEN GOTO t2sfound
|
|
t2$ = "FLOAT": s$ = "##": IF qb64prefix_set = 1 AND t$ = t2$ THEN GOTO t2sfound
|
|
|
|
' These can have a length after them, so LEFT$() is used
|
|
t2$ = "STRING": s$ = "$": IF LEFT$(t$, LEN(t2$)) = t2$ THEN GOTO t2sfound
|
|
t2$ = "_UNSIGNED _BIT": s$ = "~`1": 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 _BIT": s$ = "~`1": IF qb64prefix_set = 1 AND 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$ = "_BIT": s$ = "`1": IF 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
|
|
|
|
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 > 64 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 > 64 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 * " AND LEFT$(t$, 6) <> "BIT * " THEN Give_Error "Expected " + qb64prefix$ + "BIT * number": EXIT FUNCTION
|
|
|
|
IF LEFT$(t$, 4) = "_BIT" THEN
|
|
n$ = RIGHT$(t$, LEN(t$) - 7)
|
|
ELSE
|
|
n$ = RIGHT$(t$, LEN(t$) - 6)
|
|
END IF
|
|
|
|
IF isuinteger(n$) = 0 THEN Give_Error "Invalid size after " + qb64prefix$ + "BIT *": EXIT FUNCTION
|
|
b = VAL(n$)
|
|
IF b = 0 OR b > 64 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 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
|
|
|
|
'
|
|
' Does not report an error if the symbol is invalid or varname is blank
|
|
'
|
|
FUNCTION tryRemoveSymbol$ (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:
|
|
symbol$ = RIGHT$(varname$, LEN(varname$) - i + 1)
|
|
IF symboltype(symbol$) = 0 THEN EXIT FUNCTION
|
|
tryRemoveSymbol$ = symbol$
|
|
varname$ = LEFT$(varname$, i - 1)
|
|
END FUNCTION
|
|
|
|
SUB increaseUDTArrays
|
|
x = UBOUND(udtxname)
|
|
REDIM _PRESERVE udtxname(x + 1000) AS STRING * 256
|
|
REDIM _PRESERVE udtxcname(x + 1000) AS STRING * 256
|
|
REDIM _PRESERVE udtxsize(x + 1000) AS LONG
|
|
REDIM _PRESERVE udtxnext(x + 1000) AS LONG
|
|
REDIM _PRESERVE udtxvariable(x + 1000) AS INTEGER 'true if the udt contains variable length elements
|
|
'elements
|
|
REDIM _PRESERVE udtename(x + 1000) AS STRING * 256
|
|
REDIM _PRESERVE udtecname(x + 1000) AS STRING * 256
|
|
REDIM _PRESERVE udtesize(x + 1000) AS LONG
|
|
REDIM _PRESERVE udtetype(x + 1000) AS LONG
|
|
REDIM _PRESERVE udtetypesize(x + 1000) AS LONG
|
|
REDIM _PRESERVE udtearrayelements(x + 1000) AS LONG
|
|
REDIM _PRESERVE udtenext(x + 1000) AS LONG
|
|
END SUB
|
|
|
|
SUB initialise_udt_varstrings (n$, udt, buf, 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
|
|
WriteBufLine buf, "*(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, buf, offset
|
|
END IF
|
|
offset = offset + udtesize(element) \ 8
|
|
element = udtenext(element)
|
|
LOOP
|
|
END SUB
|
|
|
|
SUB free_udt_varstrings (n$, udt, buf, 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
|
|
WriteBufLine buf, "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, buf, offset
|
|
END IF
|
|
offset = offset + udtesize(element) \ 8
|
|
element = udtenext(element)
|
|
LOOP
|
|
END SUB
|
|
|
|
SUB clear_udt_with_varstrings (n$, udt, buf, 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
|
|
WriteBufLine buf, "(*(qbs**)(((char*)" + n$ + ")+" + STR$(base_offset + offset) + "))->len=0;"
|
|
ELSE
|
|
WriteBufLine buf, "memset((char*)" + n$ + "+" + STR$(base_offset + offset) + ",0," + STR$(udtesize(element) \ 8) + ");"
|
|
END IF
|
|
ELSE
|
|
IF udtetype(element) AND ISUDT THEN
|
|
clear_udt_with_varstrings n$, udtetype(element) AND 511, buf, base_offset + offset
|
|
ELSE
|
|
WriteBufLine buf, "memset((char*)" + n$ + "+" + STR$(base_offset + offset) + ",0," + STR$(udtesize(element) \ 8) + ");"
|
|
END IF
|
|
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$ + "*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$ + "*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$, buf, base_offset, udt)
|
|
IF NOT udtxvariable(udt) THEN
|
|
WriteBufLine buf, "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
|
|
WriteBufLine buf, "qbs_set(*(qbs**)(" + dst$ + "+" + STR$(offset) + "), *(qbs**)(" + src$ + "+" + STR$(offset) + "));"
|
|
ELSEIF ((udtetype(element) AND ISUDT) > 0) THEN
|
|
copy_full_udt dst$, src$, MainTxtBuf, offset, udtetype(element) AND 511
|
|
ELSE
|
|
WriteBufLine buf, "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
|
|
fh = FREEFILE
|
|
OPEN "types.txt" FOR OUTPUT AS #fh
|
|
PRINT #fh, "Name Size Next Var?"
|
|
FOR i = 1 TO lasttype
|
|
PRINT #fh, RTRIM$(udtxname(i)), udtxsize(i), udtxnext(i), udtxvariable(i)
|
|
NEXT i
|
|
PRINT #fh, "Name Size Next Type Tsize Arr"
|
|
FOR i = 1 TO lasttypeelement
|
|
PRINT #fh, RTRIM$(udtename(i)), udtesize(i), udtenext(i), udtetype(i), udtetypesize(i), udtearrayelements(i)
|
|
NEXT i
|
|
CLOSE #fh
|
|
END SUB
|
|
|
|
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
|