QB64/QB64-PE
QB64/QB64-PE
1
1
Fork 0
mirror of https://github.com/QB64-Phoenix-Edition/QB64pe.git synced 2024-09-20 04:24:48 +00:00
Code Issues Releases Wiki Activity

Merge branch 'QB64-Phoenix-Edition:main' into midi-update

Browse source
This commit is contained in:
Samuel Gomes 2024-06-02 16:02:47 +05:30 committed by GitHub
commit 800365d314
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
13 changed files with 61714 additions and 61957 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
internal/source/clear.txt
View file

@ -213,22 +213,6 @@ __ARRAY_LONG_UDTXSIZE[6]=0;
__ARRAY_LONG_UDTXSIZE[0]=(ptrszint)nothingvalue;
}
}
if (__ARRAY_INTEGER_UDTXBYTEALIGN[2]&1){
if (__ARRAY_INTEGER_UDTXBYTEALIGN[2]&2){
memset((void*)(__ARRAY_INTEGER_UDTXBYTEALIGN[0]),0,__ARRAY_INTEGER_UDTXBYTEALIGN[5]*2);
}else{
if (__ARRAY_INTEGER_UDTXBYTEALIGN[2]&4){
cmem_dynamic_free((uint8*)(__ARRAY_INTEGER_UDTXBYTEALIGN[0]));
}else{
free((void*)(__ARRAY_INTEGER_UDTXBYTEALIGN[0]));
}
__ARRAY_INTEGER_UDTXBYTEALIGN[2]^=1;
__ARRAY_INTEGER_UDTXBYTEALIGN[4]=2147483647;
__ARRAY_INTEGER_UDTXBYTEALIGN[5]=0;
__ARRAY_INTEGER_UDTXBYTEALIGN[6]=0;
__ARRAY_INTEGER_UDTXBYTEALIGN[0]=(ptrszint)nothingvalue;
}
}
if (__ARRAY_LONG_UDTXNEXT[2]&1){
if (__ARRAY_LONG_UDTXNEXT[2]&2){
memset((void*)(__ARRAY_LONG_UDTXNEXT[0]),0,__ARRAY_LONG_UDTXNEXT[5]*4);
@ -293,22 +277,6 @@ __ARRAY_STRING256_UDTECNAME[6]=0;
__ARRAY_STRING256_UDTECNAME[0]=(ptrszint)nothingvalue;
}
}
if (__ARRAY_INTEGER_UDTEBYTEALIGN[2]&1){
if (__ARRAY_INTEGER_UDTEBYTEALIGN[2]&2){
memset((void*)(__ARRAY_INTEGER_UDTEBYTEALIGN[0]),0,__ARRAY_INTEGER_UDTEBYTEALIGN[5]*2);
}else{
if (__ARRAY_INTEGER_UDTEBYTEALIGN[2]&4){
cmem_dynamic_free((uint8*)(__ARRAY_INTEGER_UDTEBYTEALIGN[0]));
}else{
free((void*)(__ARRAY_INTEGER_UDTEBYTEALIGN[0]));
}
__ARRAY_INTEGER_UDTEBYTEALIGN[2]^=1;
__ARRAY_INTEGER_UDTEBYTEALIGN[4]=2147483647;
__ARRAY_INTEGER_UDTEBYTEALIGN[5]=0;
__ARRAY_INTEGER_UDTEBYTEALIGN[6]=0;
__ARRAY_INTEGER_UDTEBYTEALIGN[0]=(ptrszint)nothingvalue;
}
}
if (__ARRAY_LONG_UDTESIZE[2]&1){
if (__ARRAY_LONG_UDTESIZE[2]&2){
memset((void*)(__ARRAY_LONG_UDTESIZE[0]),0,__ARRAY_LONG_UDTESIZE[5]*4);

2
internal/source/global.txt
View file

@ -88,12 +88,10 @@ int32 *__LONG_UDTTYPE=NULL;
ptrszint *__ARRAY_STRING256_UDTXNAME=NULL;
ptrszint *__ARRAY_STRING256_UDTXCNAME=NULL;
ptrszint *__ARRAY_LONG_UDTXSIZE=NULL;
ptrszint *__ARRAY_INTEGER_UDTXBYTEALIGN=NULL;
ptrszint *__ARRAY_LONG_UDTXNEXT=NULL;
ptrszint *__ARRAY_INTEGER_UDTXVARIABLE=NULL;
ptrszint *__ARRAY_STRING256_UDTENAME=NULL;
ptrszint *__ARRAY_STRING256_UDTECNAME=NULL;
ptrszint *__ARRAY_INTEGER_UDTEBYTEALIGN=NULL;
ptrszint *__ARRAY_LONG_UDTESIZE=NULL;
ptrszint *__ARRAY_LONG_UDTETYPE=NULL;
ptrszint *__ARRAY_LONG_UDTETYPESIZE=NULL;

123300
internal/source/main.txt
View file

File diff suppressed because it is too large Load diff

22
internal/source/maindata.txt
View file

@ -303,17 +303,6 @@ __ARRAY_LONG_UDTXSIZE[5]=0;
__ARRAY_LONG_UDTXSIZE[6]=0;
__ARRAY_LONG_UDTXSIZE[0]=(ptrszint)nothingvalue;
}
if (!__ARRAY_INTEGER_UDTXBYTEALIGN){
__ARRAY_INTEGER_UDTXBYTEALIGN=(ptrszint*)mem_static_malloc(9*ptrsz);
new_mem_lock();
mem_lock_tmp->type=4;
((ptrszint*)__ARRAY_INTEGER_UDTXBYTEALIGN)[8]=(ptrszint)mem_lock_tmp;
__ARRAY_INTEGER_UDTXBYTEALIGN[2]=0;
__ARRAY_INTEGER_UDTXBYTEALIGN[4]=2147483647;
__ARRAY_INTEGER_UDTXBYTEALIGN[5]=0;
__ARRAY_INTEGER_UDTXBYTEALIGN[6]=0;
__ARRAY_INTEGER_UDTXBYTEALIGN[0]=(ptrszint)nothingvalue;
}
if (!__ARRAY_LONG_UDTXNEXT){
__ARRAY_LONG_UDTXNEXT=(ptrszint*)mem_static_malloc(9*ptrsz);
new_mem_lock();
@ -358,17 +347,6 @@ __ARRAY_STRING256_UDTECNAME[5]=0;
__ARRAY_STRING256_UDTECNAME[6]=0;
__ARRAY_STRING256_UDTECNAME[0]=(ptrszint)nothingvalue;
}
if (!__ARRAY_INTEGER_UDTEBYTEALIGN){
__ARRAY_INTEGER_UDTEBYTEALIGN=(ptrszint*)mem_static_malloc(9*ptrsz);
new_mem_lock();
mem_lock_tmp->type=4;
((ptrszint*)__ARRAY_INTEGER_UDTEBYTEALIGN)[8]=(ptrszint)mem_lock_tmp;
__ARRAY_INTEGER_UDTEBYTEALIGN[2]=0;
__ARRAY_INTEGER_UDTEBYTEALIGN[4]=2147483647;
__ARRAY_INTEGER_UDTEBYTEALIGN[5]=0;
__ARRAY_INTEGER_UDTEBYTEALIGN[6]=0;
__ARRAY_INTEGER_UDTEBYTEALIGN[0]=(ptrszint)nothingvalue;
}
if (!__ARRAY_LONG_UDTESIZE){
__ARRAY_LONG_UDTESIZE=(ptrszint*)mem_static_malloc(9*ptrsz);
new_mem_lock();

16
internal/source/mainfree.txt
View file

@ -81,14 +81,6 @@ free((void*)(__ARRAY_LONG_UDTXSIZE[0]));
}
}
free_mem_lock( (mem_lock*)((ptrszint*)__ARRAY_LONG_UDTXSIZE)[8] );
if (__ARRAY_INTEGER_UDTXBYTEALIGN[2]&1){
if (__ARRAY_INTEGER_UDTXBYTEALIGN[2]&4){
cmem_dynamic_free((uint8*)(__ARRAY_INTEGER_UDTXBYTEALIGN[0]));
}else{
free((void*)(__ARRAY_INTEGER_UDTXBYTEALIGN[0]));
}
}
free_mem_lock( (mem_lock*)((ptrszint*)__ARRAY_INTEGER_UDTXBYTEALIGN)[8] );
if (__ARRAY_LONG_UDTXNEXT[2]&1){
if (__ARRAY_LONG_UDTXNEXT[2]&4){
cmem_dynamic_free((uint8*)(__ARRAY_LONG_UDTXNEXT[0]));
@ -121,14 +113,6 @@ free((void*)(__ARRAY_STRING256_UDTECNAME[0]));
}
}
free_mem_lock( (mem_lock*)((ptrszint*)__ARRAY_STRING256_UDTECNAME)[8] );
if (__ARRAY_INTEGER_UDTEBYTEALIGN[2]&1){
if (__ARRAY_INTEGER_UDTEBYTEALIGN[2]&4){
cmem_dynamic_free((uint8*)(__ARRAY_INTEGER_UDTEBYTEALIGN[0]));
}else{
free((void*)(__ARRAY_INTEGER_UDTEBYTEALIGN[0]));
}
}
free_mem_lock( (mem_lock*)((ptrszint*)__ARRAY_INTEGER_UDTEBYTEALIGN)[8] );
if (__ARRAY_LONG_UDTESIZE[2]&1){
if (__ARRAY_LONG_UDTESIZE[2]&4){
cmem_dynamic_free((uint8*)(__ARRAY_LONG_UDTESIZE[0]));

10
source/ide/ide_methods.bas
View file

@ -8875,10 +8875,7 @@ FUNCTION idevariablewatchbox$(currentScope$, filter$, selectVar, returnAction)
END IF
usedVariableList(tempIndex&).arrayElementSize = udtxsize(typ)
IF udtxbytealign(typ) THEN
IF usedVariableList(tempIndex&).arrayElementSize MOD 8 THEN usedVariableList(tempIndex&).arrayElementSize = usedVariableList(tempIndex&).arrayElementSize + (8 - (usedVariableList(tempIndex&).arrayElementSize MOD 8)) 'round up to nearest byte
usedVariableList(tempIndex&).arrayElementSize = usedVariableList(tempIndex&).arrayElementSize \ 8
END IF
usedVariableList(tempIndex&).arrayElementSize = usedVariableList(tempIndex&).arrayElementSize \ 8
ELSE
usedVariableList(tempIndex&).arrayElementSize = 0
END IF
@ -9400,10 +9397,7 @@ FUNCTION idevariablewatchbox$(currentScope$, filter$, selectVar, returnAction)
END IF
usedVariableList(varDlgList(y).index).arrayElementSize = udtxsize(typ)
IF udtxbytealign(typ) THEN
IF usedVariableList(varDlgList(y).index).arrayElementSize MOD 8 THEN usedVariableList(varDlgList(y).index).arrayElementSize = usedVariableList(varDlgList(y).index).arrayElementSize + (8 - (usedVariableList(varDlgList(y).index).arrayElementSize MOD 8)) 'round up to nearest byte
usedVariableList(varDlgList(y).index).arrayElementSize = usedVariableList(varDlgList(y).index).arrayElementSize \ 8
END IF
usedVariableList(varDlgList(y).index).arrayElementSize = usedVariableList(varDlgList(y).index).arrayElementSize \ 8
ELSE
usedVariableList(varDlgList(y).index).arrayElementSize = 0
END IF

85
source/qb64pe.bas
View file

@ -1326,13 +1326,11 @@ lasttypeelement = 0
REDIM SHARED udtxname(1000) AS STRING * 256
REDIM SHARED udtxcname(1000) AS STRING * 256
REDIM SHARED udtxsize(1000) AS LONG
REDIM SHARED udtxbytealign(1000) AS INTEGER 'first element MUST be on a byte alignment & size is a multiple of 8
REDIM SHARED udtxnext(1000) AS LONG
REDIM SHARED udtxvariable(1000) AS INTEGER 'true if the udt contains variable length elements
'elements
REDIM SHARED udtename(1000) AS STRING * 256
REDIM SHARED udtecname(1000) AS STRING * 256
REDIM SHARED udtebytealign(1000) AS INTEGER
REDIM SHARED udtesize(1000) AS LONG
REDIM SHARED udtetype(1000) AS LONG
REDIM SHARED udtetypesize(1000) AS LONG
@ -1392,27 +1390,6 @@ REDIM SHARED warningIncFiles(1000) AS STRING
maxLineNumber = 0
uniquenumbern = 0
''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
@ -1420,11 +1397,9 @@ 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
@ -1432,7 +1407,6 @@ 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
@ -1440,7 +1414,6 @@ 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
@ -1448,7 +1421,6 @@ 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
@ -1456,7 +1428,6 @@ 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
@ -1464,7 +1435,6 @@ 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
@ -1473,7 +1443,6 @@ 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
@ -1482,7 +1451,6 @@ 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
@ -1882,8 +1850,6 @@ DO
'create global buffer for SWAP space
siz$ = str2$(udtxsize(i) \ 8)
WriteBufLine GlobTxtBuf, "char *g_tmp_udt_" + RTRIM$(udtxname(i)) + "=(char*)malloc(" + siz$ + ");"
'print "END TYPE";udtxsize(i);udtxbytealign(i)
GOTO finishedlinepp
END IF
END IF
@ -1940,29 +1906,21 @@ DO
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
ELSEIF typ AND ISSTRING THEN
IF (typ AND ISFIXEDLENGTH) = 0 THEN
udtesize(i2) = OFFSETTYPE AND 511
udtxvariable(i) = -1
ELSE
udtesize(i2) = typ AND 511
IF (typ AND ISOFFSETINBITS) = 0 THEN udtxbytealign(i) = 1: udtebytealign(i2) = 1
udtesize(i2) = typsize * 8
END IF
ELSEIF typ AND ISOFFSETINBITS THEN
a$ = "Cannot use " + qb64prefix$ + "BIT inside user defined types": GOTO errmes
ELSE
udtesize(i2) = typ AND 511
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
@ -1972,7 +1930,7 @@ DO
udtenext(i2 - 1) = i2
END IF
'print "+"+rtrim$(udtename(i2));udtetype(i2);udtesize(i2);udtebytealign(i2);udtxsize(i)
'print "+"+rtrim$(udtename(i2));udtetype(i2);udtesize(i2);udtxsize(i)
IF newAsTypeBlockSyntax THEN RETURN
GOTO finishedlinepp
ELSE
@ -13826,6 +13784,10 @@ FUNCTION allocarray (n2$, elements$, elementsize, udt)
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){"
IF stringarray = 0 THEN
'ensure any numeric udt elements are zeroed
f12$ = f12$ + CRLF + "ZeroMemory(((uint8*)(" + n$ + "[0]))+preserved_elements*" + bytesperelement$ + ",(tmp_long2*" + bytesperelement$ + ")-(preserved_elements*" + bytesperelement$ + "));"
END IF
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
@ -13859,6 +13821,7 @@ FUNCTION allocarray (n2$, elements$, elementsize, udt)
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 + "ZeroMemory((uint8*)(" + n$ + "[0]),tmp_long*" + bytesperelement$ + ");"
f12$ = f12$ + CRLF + "while(tmp_long--){"
acc$ = ""
initialise_array_udt_varstrings n$, udt, 0, bytesperelement$, acc$
@ -14372,16 +14335,13 @@ FUNCTION dim2 (varname$, typ2$, method, elements$)
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)
nume = allocarray(n$, elements$, bits \ 8, i)
IF Error_Happened THEN EXIT FUNCTION
l$ = l$ + sp + tlayout$
IF arraydesc THEN GOTO dim2exitfunc
@ -15569,9 +15529,6 @@ FUNCTION udtreference$ (o$, a$, typ AS LONG)
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
@ -15609,7 +15566,7 @@ FUNCTION udtreference$ (o$, a$, typ AS LONG)
r$ = r$ + str2$(u) + sp3 + str2$(E) + sp3
IF o MOD 8 THEN Give_Error "QB64 cannot handle bit offsets within user defined types": EXIT FUNCTION
IF o MOD 8 THEN Give_Error "Non-byte aligned user defined type": EXIT FUNCTION
o = o \ 8
IF o$ <> "" THEN
@ -15727,13 +15684,9 @@ FUNCTION evaluate$ (a2$, typ AS LONG)
getid arrayid
IF Error_Happened THEN EXIT FUNCTION
o$ = RIGHT$(c$, LEN(c$) - INSTR(c$, sp3))
'change o$ to a byte offset if necessary
'change o$ to a byte offset
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
s = udtxsize(u) \ 8
o$ = "(" + o$ + ")*" + str2$(s)
'print "calling evaludt with o$:"+o$
GOTO evaludt

14
source/utilities/type.bas
View file

@ -615,13 +615,11 @@ SUB increaseUDTArrays
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
@ -693,7 +691,7 @@ SUB initialise_array_udt_varstrings (n$, udt, base_offset, bytesperelement$, acc
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);"
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$
@ -710,7 +708,7 @@ SUB free_array_udt_varstrings (n$, udt, base_offset, bytesperelement$, acc$)
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) + "));"
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$
@ -743,13 +741,13 @@ END SUB
SUB dump_udts
fh = FREEFILE
OPEN "types.txt" FOR OUTPUT AS #fh
PRINT #fh, "Name Size Align? Next Var?"
PRINT #fh, "Name Size Next Var?"
FOR i = 1 TO lasttype
PRINT #fh, RTRIM$(udtxname(i)), udtxsize(i), udtxbytealign(i), udtxnext(i), udtxvariable(i)
PRINT #fh, RTRIM$(udtxname(i)), udtxsize(i), udtxnext(i), udtxvariable(i)
NEXT i
PRINT #fh, "Name Size Align? Next Type Tsize Arr"
PRINT #fh, "Name Size 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)
PRINT #fh, RTRIM$(udtename(i)), udtesize(i), udtenext(i), udtetype(i), udtetypesize(i), udtearrayelements(i)
NEXT i
CLOSE #fh
END SUB

2
source/utilities/type.bi
View file

@ -62,13 +62,11 @@ UDTTYPE = ISUDT + ISPOINTER
REDIM SHARED udtxname(1000) AS STRING * 256
REDIM SHARED udtxcname(1000) AS STRING * 256
REDIM SHARED udtxsize(1000) AS LONG
REDIM SHARED udtxbytealign(1000) AS INTEGER 'first element MUST be on a byte alignment & size is a multiple of 8
REDIM SHARED udtxnext(1000) AS LONG
REDIM SHARED udtxvariable(1000) AS INTEGER 'true if the udt contains variable length elements
'elements
REDIM SHARED udtename(1000) AS STRING * 256
REDIM SHARED udtecname(1000) AS STRING * 256
REDIM SHARED udtebytealign(1000) AS INTEGER
REDIM SHARED udtesize(1000) AS LONG
REDIM SHARED udtetype(1000) AS LONG
REDIM SHARED udtetypesize(1000) AS LONG

81
tests/compile_tests/types/udt.bas Normal file
View file

@ -0,0 +1,81 @@
$Console:Only
'Test assignment to and size of UDT with numeric values
Type num_t
b As _Byte
ub As _Unsigned _Byte
i As Integer
ui As _Unsigned Integer
l As Long
ul As _Unsigned Long
i64 As _Integer64
ui64 As _Unsigned _Integer64
o As _Offset
uo As _Unsigned _Offset
s As Single
d As Double
f As _Float
End Type
Dim num As num_t
num.b = -100
num.ub = 200
num.i = -12345
num.ui = 54321
num.l = -1234567
num.ul = 7654321
num.i64 = -123412341234
num.ui64 = 432143214321
num.o = -1
num.uo = 1
num.s = 3.5
num.d = -1.25
num.f = 10.125
expected_size = Len(x%%) + Len(x~%%) + Len(x%) + Len(x~%) + Len(x&) + Len(x~&) + Len(x&&) + Len(x~&&) + Len(x%&) + Len(x~%&) + Len(x!) + Len(x#) + Len(x##)
Print "NUM VALUES: "; num.b; num.ub; num.i; num.ui; num.l; num.ul; num.i64; num.ui64; num.o; num.uo; num.s; num.d; num.f
Print "NUM SIZE: "; expected_size - Len(num)
'Test copying between UDT instances
Dim num2 As num_t
num2 = num
Print "NUM2 VALUES: "; num2.b; num2.ub; num2.i; num2.ui; num2.l; num2.ul; num2.i64; num2.ui64; num2.o; num2.uo; num2.s; num2.d; num2.f
'Test fixed length string in UDT is initialised to NUL
Type fstr_t
a As Long
s As String * 10
b As Long
End Type
Dim fstr As fstr_t
fstr.a = 1000
fstr.b = -6666
Print "FSTR UNINIT: ";
For i = 1 To 10
Print Asc(fstr.s, i);
Next i
Print
'Test assignment to fixed length string in UDT
fstr.s = "hello"
Print "FSTR: "; fstr.a; "["; fstr.s; "] "; fstr.b
'Test variable length string in UDT is initialised to 0 length
Type vstr_t
a As Long
s As String
b As Long
End Type
Dim vstr As vstr_t
vstr.a = 1000
vstr.b = -6666
Print "VSTR LEN: "; Len(vstr.s)
'Test assignment to variable length string in UDT
vstr.s = "hello"
Print "VSTR: "; vstr.a; "["; vstr.s; "] "; vstr.b
System

7
tests/compile_tests/types/udt.output Normal file
View file

@ -0,0 +1,7 @@
NUM VALUES: -100 200 -12345 54321 -1234567 7654321 -123412341234 432143214321 -1 1 3.5 -1.25 10.125
NUM SIZE: 0
NUM2 VALUES: -100 200 -12345 54321 -1234567 7654321 -123412341234 432143214321 -1 1 3.5 -1.25 10.125
FSTR UNINIT: 0 0 0 0 0 0 0 0 0 0
FSTR: 1000 [hello ] -6666
VSTR LEN: 0
VSTR: 1000 [hello] -6666

89
tests/compile_tests/types/udt_array.bas Normal file
View file

@ -0,0 +1,89 @@
$Console:Only
'Test assignment to and size of numeric UDT array
Type num_t
a As Long
b As Long
End Type
Dim na(-3 To 2) As num_t
na(-3).a = -12345
na(-3).b = -54321
na(2).a = 12345
na(2).b = 54321
Print "NA VALUES: "; na(-3).a; na(-3).b; na(2).a; na(2).b
Print "NA SIZE: "; Len(na())
'Test resizing dynamic array of numeric UDT initialises to 0
ReDim nda(0 To 2) As num_t
nda(0).a = -12345
nda(0).b = -54321
nda(2).a = 12345
nda(2).b = 54321
ReDim nda(0 To 1) As num_t
Print "NDA VALUES1: "; nda(0).a; nda(0).b; nda(1).a; nda(1).b
ReDim nda(0 To 2) As num_t
Print "NDA VALUES2: "; nda(0).a; nda(0).b; nda(1).a; nda(1).b; nda(2).a; nda(2).b
'Test resizing _preserve dynamic array of numeric UDT initialises to 0
ReDim _Preserve ndpa(0 To 2) As num_t
ndpa(0).a = -12345
ndpa(0).b = -54321
ndpa(2).a = 12345
ndpa(2).b = 54321
ReDim _Preserve ndpa(0 To 1) As num_t
Print "NDPA VALUES1: "; ndpa(0).a; ndpa(0).b; ndpa(1).a; ndpa(1).b
ndpa(1).a = 56789
ndpa(1).b = 98765
ReDim _Preserve ndpa(0 To 2) As num_t
Print "NDPA VALUES2: "; ndpa(0).a; ndpa(0).b; ndpa(1).a; ndpa(1).b; ndpa(2).a; ndpa(2).b
'Test assignment to variable string UDT array
Type str_t
a As Long
s As String
b As Long
End Type
Dim sa(-3 To 2) As str_t
sa(-3).a = -12345
sa(-3).s = "hello"
sa(-3).b = -54321
sa(2).a = 12345
sa(2).s = "strings"
sa(2).b = 54321
Print "SA VALUES: "; sa(-3).a; sa(-3).s; sa(-3).b; sa(2).a; sa(2).s; sa(2).b
'Test resizing dynamic array of variable string UDT initialises to 0 / empty string
ReDim sda(0 To 2) As str_t
sda(0).a = -12345
sda(0).s = "hello"
sda(0).b = -54321
sda(2).a = 12345
sda(2).s = "strings"
sda(2).b = 54321
ReDim sda(0 To 1) As str_t
Print "SDA VALUES1: "; sda(0).a; sda(0).s; sda(0).b; sda(1).a; sda(1).s; sda(1).b
ReDim sda(0 To 2) As str_t
Print "SDA VALUES2: "; sda(0).a; sda(0).s; sda(0).b; sda(1).a; sda(1).s; sda(1).b; sda(2).a; sda(2).s; sda(2).b
'Test resizing _preserve dynamic array of variable string UDT initialises new elements to 0 / empty string
ReDim _Preserve sdpa(0 To 2) As str_t
sdpa(0).a = -12345
sdpa(0).s = "hello"
sdpa(0).b = -54321
sdpa(2).a = 12345
sdpa(2).s = "strings"
sdpa(2).b = 54321
ReDim _Preserve sdpa(0 To 1) As str_t
Print "SDPA VALUES1: "; sdpa(0).a; sdpa(0).s; sdpa(0).b; sdpa(1).a; sdpa(1).s; sdpa(1).b
sdpa(1).a = 56789
sdpa(1).s = "more"
sdpa(1).b = 98765
ReDim _Preserve sdpa(0 To 2) As str_t
Print "SDPA VALUES2: "; sdpa(0).a; sdpa(0).s; sdpa(0).b; sdpa(1).a; sdpa(1).s; sdpa(1).b; sdpa(2).a; sdpa(2).s; sdpa(2).b
System

11
tests/compile_tests/types/udt_array.output Normal file
View file

@ -0,0 +1,11 @@
NA VALUES: -12345 -54321 12345 54321
NA SIZE: 48
NDA VALUES1: 0 0 0 0
NDA VALUES2: 0 0 0 0 0 0
NDPA VALUES1: -12345 -54321 0 0
NDPA VALUES2: -12345 -54321 56789 98765 0 0
SA VALUES: -12345 hello-54321 12345 strings 54321
SDA VALUES1: 0 0 0 0
SDA VALUES2: 0 0 0 0 0 0
SDPA VALUES1: -12345 hello-54321 0 0
SDPA VALUES2: -12345 hello-54321 56789 more 98765 0 0