QB64/QB64-PE
QB64/QB64-PE
1
1
Fork 0
mirror of https://github.com/QB64-Phoenix-Edition/QB64pe.git synced 2024-07-02 03:50:36 +00:00
Code Issues Releases Wiki Activity

Process nested UDT's

Browse source
This commit is contained in:
Luke Ceddia 2018-10-22 18:35:20 +11:00
parent 18bab24af1
commit 0eb2b4307f
1 changed files with 69 additions and 41 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

110
source/qb64.bas
View file

@ -626,7 +626,7 @@ DIM SHARED udtxcname(1000) AS STRING * 256
DIM SHARED udtxsize(1000) AS LONG 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 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 udtxnext(1000) AS LONG
dim shared udtxvariable(1000) as integer 'true if the udt contains variable length elements DIM SHARED udtxvariable(1000) AS INTEGER 'true if the udt contains variable length elements
'elements 'elements
DIM SHARED lasttypeelement AS LONG DIM SHARED lasttypeelement AS LONG
DIM SHARED udtename(1000) AS STRING * 256 DIM SHARED udtename(1000) AS STRING * 256
@ -1890,6 +1890,7 @@ DO
u = typ AND 511 u = typ AND 511
udtesize(i2) = udtxsize(u) udtesize(i2) = udtxsize(u)
IF udtxbytealign(u) THEN udtxbytealign(i) = 1: udtebytealign(i2) = 1 IF udtxbytealign(u) THEN udtxbytealign(i) = 1: udtebytealign(i2) = 1
IF udtxvariable(u) THEN udtxvariable(i) = -1
ELSE ELSE
IF (typ AND ISSTRING) THEN IF (typ AND ISSTRING) THEN
IF (typ AND ISFIXEDLENGTH) = 0 THEN IF (typ AND ISFIXEDLENGTH) = 0 THEN
@ -13514,30 +13515,22 @@ FUNCTION dim2 (varname$, typ2$, method, elements$)
id.t = UDTTYPE + i id.t = UDTTYPE + i
IF cmemlist(idn + 1) THEN IF cmemlist(idn + 1) THEN
id.t = id.t + ISINCONVENTIONALMEMORY id.t = id.t + ISINCONVENTIONALMEMORY
IF f THEN PRINT #13, "if(" + n$ + "==NULL){" IF f THEN
IF f THEN PRINT #13, "cmem_sp-=" + str2(bytes) + ";" PRINT #13, "if(" + n$ + "==NULL){"
IF f THEN PRINT #13, "if (cmem_sp<qbs_cmem_sp) error(257);" PRINT #13, "cmem_sp-=" + str2(bytes) + ";"
IF f THEN PRINT #13, n$ + "=(void*)(dblock+cmem_sp);" PRINT #13, "if (cmem_sp<qbs_cmem_sp) error(257);"
IF f THEN PRINT #13, "memset(" + n$ + ",0," + str2(bytes) + ");" PRINT #13, n$ + "=(void*)(dblock+cmem_sp);"
IF f THEN PRINT #13, "}" PRINT #13, "memset(" + n$ + ",0," + str2(bytes) + ");"
PRINT #13, "}"
END IF
ELSE ELSE
IF f THEN PRINT #13, "if(" + n$ + "==NULL){" IF f THEN
IF f THEN PRINT #13, n$ + "=(void*)mem_static_malloc(" + str2$(bytes) + ");" PRINT #13, "if(" + n$ + "==NULL){"
IF f THEN PRINT #13, "memset(" + n$ + ",0," + str2(bytes) + ");" PRINT #13, n$ + "=(void*)mem_static_malloc(" + str2$(bytes) + ");"
if udtxvariable(i) then PRINT #13, "memset(" + n$ + ",0," + str2(bytes) + ");"
i2 = udtxnext(i) IF udtxvariable(i) THEN initialise_udt_varstrings n$, i, 13, 0
offset = 0 PRINT #13, "}"
do while i2 END IF
if udtetype(i2) and ISSTRING then
if (udtetype(i2) and ISFIXEDLENGTH) = 0 then
if f then print #13, "*(qbs**)(((char*)" + n$ + ")+" + str$(offset) + ") = qbs_new(0,0);"
end if
end if
offset = offset + udtesize(i2) \ 8
i2 = udtenext(i2)
loop
end if
IF f THEN PRINT #13, "}"
END IF END IF
regid regid
IF Error_Happened THEN EXIT FUNCTION IF Error_Happened THEN EXIT FUNCTION
@ -21143,25 +21136,9 @@ SUB setrefer (a2$, typ2 AS LONG, e2$, method AS LONG)
src$ = "((char*)" + scope$ + n2$ + ")+(" + o2$ + ")" src$ = "((char*)" + scope$ + n2$ + ")+(" + o2$ + ")"
directudt: directudt:
IF u <> u2 OR e2 <> 0 THEN Give_Error "Expected = similar user defined type": EXIT SUB IF u <> u2 OR e2 <> 0 THEN Give_Error "Expected = similar user defined type": EXIT SUB
dst$ = "((char*)" + lhsscope$ + n$ + ")+(" + o$ + ")" dst$ = "((char*)" + lhsscope$ + n$ + ")+(" + o$ + ")"
siz$ = str2$(udtxsize(u) \ 8)
if udtxvariable(u) then copy_full_udt dst$, src$, 12, 0, u
u3 = udtxnext(u)
offset = 0
do while u3
if ((udtetype(u3) and ISSTRING) > 0) and (udtetype(u3) and ISFIXEDLENGTH) = 0 then
print #12, "qbs_set(*(qbs**)(" + dst$ + "+" + str$(offset) + "), *(qbs**)(" + src$ + "+" + str$(offset) + "));"
else
print #12, "memcpy((" + dst$ + "+" + str$(offset) + "),(" + src$ + "+" + str$(offset) + ")," + str$(udtesize(u3) \ 8) + ");"
end if
offset = offset + udtesize(u3) \ 8
u3 = udtenext(u3)
loop
else
PRINT #12, "memcpy(" + dst$ + "," + src$ + "," + siz$ + ");"
end if
'print "setFULLUDTrefer!" 'print "setFULLUDTrefer!"
@ -25252,6 +25229,57 @@ FUNCTION VerifyNumber (text$)
IF t$ = t1$ THEN VerifyNumber = -1 IF t$ = t1$ THEN VerifyNumber = -1
END FUNCTION 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 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
'$INCLUDE:'utilities\strings.bas' '$INCLUDE:'utilities\strings.bas'
'$INCLUDE:'subs_functions\extensions\opengl\opengl_methods.bas' '$INCLUDE:'subs_functions\extensions\opengl\opengl_methods.bas'