mirror of
https://github.com/QB64-Phoenix-Edition/QB64pe.git
synced 2024-07-06 07:00:23 +00:00
90941fffa7
This moves the CONST replacement up before we turn the elements into a single string. The advantage is that we don't have to worry about splitting the string properly to find the CONST names as the elements are already split for us.t
766 lines
28 KiB
QBasic
766 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 udtxbytealign(x + 1000) AS INTEGER 'first element MUST be on a byte alignment & size is a multiple of 8
|
|
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 udtebytealign(x + 1000) AS INTEGER
|
|
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$ + "-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$, 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 Align? Next Var?"
|
|
FOR i = 1 TO lasttype
|
|
PRINT #fh, RTRIM$(udtxname(i)), udtxsize(i), udtxbytealign(i), udtxnext(i), udtxvariable(i)
|
|
NEXT i
|
|
PRINT #fh, "Name Size Align? Next Type Tsize Arr"
|
|
FOR i = 1 TO lasttypeelement
|
|
PRINT #fh, RTRIM$(udtename(i)), udtesize(i), udtebytealign(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
|