From 902868a7eea8b37fe483ec61788dc0d840481ec6 Mon Sep 17 00:00:00 2001 From: Luke Ceddia Date: Sat, 20 Oct 2018 00:13:24 +1100 Subject: [PATCH 1/7] Allow assignment and access of variable length strings in TYPEs To do: - arrays of UDT's - clone qbs on UDT copy - check for memory leaks - UDT's declared in subs/functions --- source/qb64.bas | 170 +++++++++--------------------------------------- 1 file changed, 31 insertions(+), 139 deletions(-) diff --git a/source/qb64.bas b/source/qb64.bas index ca9412b65..fc07844aa 100644 --- a/source/qb64.bas +++ b/source/qb64.bas @@ -1043,137 +1043,6 @@ IF C = 9 THEN 'run idecompiled = 1 END IF - - IF MakeAndroid THEN - - - CreateAndroidProject file$ - - - 'generate program name - - - 'pf$ = "programs\android\" + file$ - - 'IF _DIREXISTS(pf$) = 0 THEN - ' 'once only setup - - ' COLOR 7, 1: LOCATE idewy - 3, 2: PRINT SPACE$(idewx - 2);: LOCATE idewy - 2, 2: PRINT SPACE$(idewx - 2);: LOCATE idewy - 1, 2: PRINT SPACE$(idewx - 2); 'clear status window - ' LOCATE idewy - 3, 2: PRINT "Initializing project [programs\android\" + file$ + "]..."; - ' PCOPY 3, 0 - - - ' MKDIR pf$ - ' SHELL _HIDE "cmd /c xcopy /e programs\android\project_template\*.* " + pf$ - ' SHELL _HIDE "cmd /c xcopy /e programs\android\eclipse_template\*.* " + pf$ - - ' 'modify templates - ' fr_fh = FREEFILE - ' OPEN pf$ + "\AndroidManifest.xml" FOR BINARY AS #fr_fh - ' a$ = SPACE$(LOF(fr_fh)) - ' GET #fr_fh, , a$ - ' CLOSE fr_fh - ' OPEN pf$ + "\AndroidManifest.xml" FOR OUTPUT AS #fr_fh - ' ss$ = CHR$(34) + "com.example.native_activity" + CHR$(34) - ' file_namespace$ = LCASE$(file$) - ' a = ASC(file_namespace$) - ' IF a >= 48 AND a <= 57 THEN file_namespace$ = "ns_" + file_namespace$ - ' i = INSTR(a$, ss$) - ' a$ = LEFT$(a$, i - 1) + CHR$(34) + "com.example." + file_namespace$ + CHR$(34) + RIGHT$(a$, LEN(a$) - i - LEN(ss$) + 1) - ' PRINT #fr_fh, a$; - ' CLOSE fr_fh - - ' fr_fh = FREEFILE - ' OPEN pf$ + "\res\values\strings.xml" FOR BINARY AS #fr_fh - ' a$ = SPACE$(LOF(fr_fh)) - ' GET #fr_fh, , a$ - ' CLOSE fr_fh - ' OPEN pf$ + "\res\values\strings.xml" FOR OUTPUT AS #fr_fh - ' ss$ = ">NativeActivity<" - ' i = INSTR(a$, ss$) - ' a$ = LEFT$(a$, i - 1) + ">" + file$ + "<" + RIGHT$(a$, LEN(a$) - i - LEN(ss$) + 1) - ' PRINT #fr_fh, a$; - ' CLOSE fr_fh - - ' fr_fh = FREEFILE - ' OPEN pf$ + "\.project" FOR BINARY AS #fr_fh - ' a$ = SPACE$(LOF(fr_fh)) - ' GET #fr_fh, , a$ - ' CLOSE fr_fh - ' OPEN pf$ + "\.project" FOR OUTPUT AS #fr_fh - ' ss$ = "NativeActivity" - ' i = INSTR(a$, ss$) - ' a$ = LEFT$(a$, i - 1) + "" + file$ + "" + RIGHT$(a$, LEN(a$) - i - LEN(ss$) + 1) - ' PRINT #fr_fh, a$; - ' CLOSE fr_fh - - ' IF _DIREXISTS(pf$ + "\jni\temp") = 0 THEN MKDIR pf$ + "\jni\temp" - - ' IF _DIREXISTS(pf$ + "\jni\c") = 0 THEN MKDIR pf$ + "\jni\c" - - ' 'c - ' ex_fh = FREEFILE - ' OPEN "internal\temp\xcopy_exclude.txt" FOR OUTPUT AS #ex_fh - ' PRINT #ex_fh, "c_compiler\" - ' CLOSE ex_fh - ' SHELL _HIDE "cmd /c xcopy /e /EXCLUDE:internal\temp\xcopy_exclude.txt internal\c\*.* " + pf$ + "\jni\c" - - 'ELSE - - ' COLOR 7, 1: LOCATE idewy - 3, 2: PRINT SPACE$(idewx - 2);: LOCATE idewy - 2, 2: PRINT SPACE$(idewx - 2);: LOCATE idewy - 1, 2: PRINT SPACE$(idewx - 2); 'clear status window - ' LOCATE idewy - 3, 2: PRINT "Updating project [programs\android\" + file$ + "]..."; - ' PCOPY 3, 0 - - 'END IF - - ''temp - 'SHELL _HIDE "cmd /c del " + pf$ + "\jni\temp\*.txt" - 'SHELL _HIDE "cmd /c copy " + tmpdir$ + "*.txt " + pf$ + "\jni\temp" - - ''touch main.cpp (for ndk) - 'fr_fh = FREEFILE - 'OPEN pf$ + "\jni\main.cpp" FOR BINARY AS #fr_fh - 'a$ = SPACE$(LOF(fr_fh)) - 'GET #fr_fh, , a$ - 'CLOSE fr_fh - 'OPEN pf$ + "\jni\main.cpp" FOR OUTPUT AS #fr_fh - 'IF ASC(a$, LEN(a$)) <> 32 THEN a$ = a$ + " " ELSE a$ = LEFT$(a$, LEN(a$) - 1) - 'PRINT #fr_fh, a$; - 'CLOSE fr_fh - - ''note: .bat files affect the directory they are called from - 'CHDIR pf$ - 'IF INSTR(IdeAndroidStartScript$, ":") THEN - ' SHELL _HIDE IdeAndroidMakeScript$ - 'ELSE - ' SHELL _HIDE "..\..\..\" + IdeAndroidMakeScript$ - 'END IF - 'CHDIR "..\..\.." - - '''touch manifest (for Eclipse) - ''fr_fh = FREEFILE - ''OPEN pf$ + "\AndroidManifest.xml" FOR BINARY AS #fr_fh - ''a$ = SPACE$(LOF(fr_fh)) - ''GET #fr_fh, , a$ - ''CLOSE fr_fh - ''OPEN pf$ + "\AndroidManifest.xml" FOR OUTPUT AS #fr_fh - ''IF ASC(a$, LEN(a$)) <> 32 THEN a$ = a$ + " " ELSE a$ = LEFT$(a$, LEN(a$) - 1) - ''PRINT #fr_fh, a$; - ''CLOSE fr_fh - ''^^^^above inconsistent^^^^ - - ''clear the gen folder (for Eclipse) - 'IF _DIREXISTS(pf$ + "\gen") THEN - ' SHELL _HIDE "cmd /c rmdir /s /q " + pf$ + "\gen" - ' SHELL _HIDE "cmd /c md " + pf$ + "\gen" - 'END IF - - sendc$ = CHR$(11) '".EXE file created" aka "Android project created" - GOTO sendcommand - - END IF - - IF iderunmode = 2 THEN sendc$ = CHR$(11) '.EXE file created GOTO sendcommand @@ -2022,8 +1891,11 @@ DO IF udtxbytealign(u) THEN udtxbytealign(i) = 1: udtebytealign(i2) = 1 ELSE IF (typ AND ISSTRING) THEN - IF (typ AND ISFIXEDLENGTH) = 0 THEN a$ = "Expected STRING *": GOTO errmes - udtesize(i2) = typsize * 8 + IF (typ AND ISFIXEDLENGTH) = 0 THEN + udtesize(i2) = OFFSETTYPE AND 511 + ELSE + udtesize(i2) = typsize * 8 + END IF udtxbytealign(i) = 1: udtebytealign(i2) = 1 ELSE udtesize(i2) = typ AND 511 @@ -2046,7 +1918,7 @@ DO udtenext(i2 - 1) = i2 END IF - 'print "+"+rtrim$(udtename(i2));udtesize(i2);udtebytealign(i2);udtxsize(i) + 'print "+"+rtrim$(udtename(i2));udtetype(i2);udtesize(i2);udtebytealign(i2);udtxsize(i) GOTO finishedlinepp @@ -13650,6 +13522,17 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) IF f THEN PRINT #13, "if(" + n$ + "==NULL){" IF f THEN PRINT #13, n$ + "=(void*)mem_static_malloc(" + str2$(bytes) + ");" IF f THEN PRINT #13, "memset(" + n$ + ",0," + str2(bytes) + ");" + i2 = udtxnext(i) + offset = 0 + do while i2 + 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 IF f THEN PRINT #13, "}" END IF regid @@ -20053,9 +19936,14 @@ FUNCTION refer$ (a2$, typ AS LONG, method AS LONG) IF typ AND ISOFFSETINBITS THEN Give_Error "Cannot resolve bit-length variables inside user defined types yet": EXIT FUNCTION IF typ AND ISSTRING 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! + 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*)(" + scope$ + n$ + "+(" + o$ + ")))" + typ = STRINGTYPE + END IF ELSE typ = typ - ISUDT - ISREFERENCE - ISPOINTER IF typ AND ISARRAY THEN typ = typ - ISARRAY @@ -21266,8 +21154,12 @@ SUB setrefer (a2$, typ2 AS LONG, e2$, method AS LONG) IF typ AND ISOFFSETINBITS THEN Give_Error "Cannot resolve bit-length variables inside user defined types yet": EXIT SUB IF typ AND ISSTRING THEN - o2$ = "(((uint8*)" + scope$ + n$ + ")+(" + o$ + "))" - r$ = "qbs_new_fixed(" + o2$ + "," + str2(udtetypesize(E)) + ",1)" + IF typ AND ISFIXEDLENGTH THEN + o2$ = "(((uint8*)" + scope$ + n$ + ")+(" + o$ + "))" + r$ = "qbs_new_fixed(" + o2$ + "," + str2(udtetypesize(E)) + ",1)" + ELSE + r$ = "((qbs*)((" + 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$ + ");" From 18bab24af17adbaa8d73bc1e46f94b850aad7add Mon Sep 17 00:00:00 2001 From: Luke Ceddia Date: Sun, 21 Oct 2018 01:46:52 +1100 Subject: [PATCH 2/7] Do element-wise assignment with string copy when necessary --- source/qb64.bas | 48 +++++++++++++++++++++++++++++++++--------------- 1 file changed, 33 insertions(+), 15 deletions(-) diff --git a/source/qb64.bas b/source/qb64.bas index fc07844aa..4b4a1ff5f 100644 --- a/source/qb64.bas +++ b/source/qb64.bas @@ -626,6 +626,7 @@ 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 @@ -1893,6 +1894,7 @@ DO 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 @@ -13522,17 +13524,19 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) IF f THEN PRINT #13, "if(" + n$ + "==NULL){" IF f THEN PRINT #13, n$ + "=(void*)mem_static_malloc(" + str2$(bytes) + ");" IF f THEN PRINT #13, "memset(" + n$ + ",0," + str2(bytes) + ");" - i2 = udtxnext(i) - offset = 0 - do while i2 - 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);" + if udtxvariable(i) then + i2 = udtxnext(i) + offset = 0 + do while i2 + 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 - end if - offset = offset + udtesize(i2) \ 8 - i2 = udtenext(i2) - loop + offset = offset + udtesize(i2) \ 8 + i2 = udtenext(i2) + loop + end if IF f THEN PRINT #13, "}" END IF regid @@ -19941,7 +19945,7 @@ FUNCTION refer$ (a2$, typ AS LONG, method AS LONG) r$ = "qbs_new_fixed(" + o2$ + "," + str2(udtetypesize(E)) + ",1)" typ = STRINGTYPE + ISFIXEDLENGTH 'ISPOINTER retained, it is still a pointer! ELSE - r$ = "((qbs*)(" + scope$ + n$ + "+(" + o$ + ")))" + r$ = "*((qbs**)(" + scope$ + n$ + "+(" + o$ + ")))" typ = STRINGTYPE END IF ELSE @@ -21136,14 +21140,28 @@ SUB setrefer (a2$, typ2 AS LONG, e2$, method AS LONG) 'we have now established we have 2 pointers to similar data types! 'ASSUME BYTE TYPE!!! - src$ = "(((char*)" + scope$ + n2$ + ")+(" + o2$ + "))" + 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$ + "))" + dst$ = "((char*)" + lhsscope$ + n$ + ")+(" + o$ + ")" siz$ = str2$(udtxsize(u) \ 8) - PRINT #12, "memcpy(" + dst$ + "," + src$ + "," + siz$ + ");" + if udtxvariable(u) then + 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!" @@ -21158,7 +21176,7 @@ SUB setrefer (a2$, typ2 AS LONG, e2$, method AS LONG) o2$ = "(((uint8*)" + scope$ + n$ + ")+(" + o$ + "))" r$ = "qbs_new_fixed(" + o2$ + "," + str2(udtetypesize(E)) + ",1)" ELSE - r$ = "((qbs*)((" + scope$ + n$ + ")+(" + o$ + ")))" + r$ = "*((qbs**)((" + scope$ + n$ + ")+(" + o$ + ")))" END IF IF method = 0 THEN e$ = evaluatetotyp(e$, STRINGTYPE - ISPOINTER) IF Error_Happened THEN EXIT SUB From 0eb2b4307fdaf9050f5072b5c62ae3fc7c6238b4 Mon Sep 17 00:00:00 2001 From: Luke Ceddia Date: Mon, 22 Oct 2018 18:35:20 +1100 Subject: [PATCH 3/7] Process nested UDT's --- source/qb64.bas | 110 ++++++++++++++++++++++++++++++------------------ 1 file changed, 69 insertions(+), 41 deletions(-) diff --git a/source/qb64.bas b/source/qb64.bas index 4b4a1ff5f..038804126 100644 --- a/source/qb64.bas +++ b/source/qb64.bas @@ -626,7 +626,7 @@ 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 +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 @@ -1890,6 +1890,7 @@ DO 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 @@ -13514,30 +13515,22 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) id.t = UDTTYPE + i 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 u2 OR e2 <> 0 THEN Give_Error "Expected = similar user defined type": EXIT SUB - dst$ = "((char*)" + lhsscope$ + n$ + ")+(" + o$ + ")" - siz$ = str2$(udtxsize(u) \ 8) - if udtxvariable(u) then - 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 + copy_full_udt dst$, src$, 12, 0, u 'print "setFULLUDTrefer!" @@ -25252,6 +25229,57 @@ FUNCTION VerifyNumber (text$) 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 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:'subs_functions\extensions\opengl\opengl_methods.bas' From 683e4f192059a36740b0b193a2ec2bc11774bd92 Mon Sep 17 00:00:00 2001 From: Luke Ceddia Date: Tue, 23 Oct 2018 12:53:38 +1100 Subject: [PATCH 4/7] Global static arrays --- source/qb64.bas | 53 +++++++++++++++++++++++++++++++++++++------------ 1 file changed, 40 insertions(+), 13 deletions(-) diff --git a/source/qb64.bas b/source/qb64.bas index 038804126..3834cff0e 100644 --- a/source/qb64.bas +++ b/source/qb64.bas @@ -12754,7 +12754,8 @@ END FUNCTION -FUNCTION allocarray (n2$, elements$, elementsize) +'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 @@ -12971,6 +12972,14 @@ FUNCTION allocarray (n2$, elements$, elementsize) END IF PRINT #13, n$ + "[2]=1+2;" 'init+static END IF + + if udt > 0 then + print #13, "tmp_long=" + elesizestr$ + ";" + print #13, "while(tmp_long--){" + initialise_array_udt_varstrings n$, udt, 13, 0, bytesperelement$ + print #13, "}" + end if + 'Close static array desc PRINT #13, "}" allocarray = nume + 65536 @@ -13473,7 +13482,7 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) 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) + nume = allocarray(n$, elements$, -bits, i) IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ IF arraydesc THEN GOTO dim2exitfunc @@ -13632,7 +13641,7 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) 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) + nume = allocarray(n$, elements$, bytes, 0) IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ IF arraydesc THEN GOTO dim2exitfunc @@ -13732,7 +13741,7 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) 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) + nume = allocarray(n$, elements$, -2147483647, 0) IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ IF arraydesc THEN GOTO dim2exitfunc @@ -13837,7 +13846,7 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) 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) + nume = allocarray(n$, elements$, -bits, 0) IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ IF arraydesc THEN GOTO dim2exitfunc @@ -13928,7 +13937,7 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) 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) + nume = allocarray(n$, elements$, 1, 0) IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ IF arraydesc THEN GOTO dim2exitfunc @@ -14009,7 +14018,7 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) 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) + nume = allocarray(n$, elements$, 2, 0) IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ IF arraydesc THEN GOTO dim2exitfunc @@ -14097,7 +14106,7 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) 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) + nume = allocarray(n$, elements$, OS_BITS \ 8, 0) IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ IF arraydesc THEN GOTO dim2exitfunc @@ -14181,7 +14190,7 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) 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) + nume = allocarray(n$, elements$, 4, 0) IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ IF arraydesc THEN GOTO dim2exitfunc @@ -14265,7 +14274,7 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) 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) + nume = allocarray(n$, elements$, 8, 0) IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ IF arraydesc THEN GOTO dim2exitfunc @@ -14349,7 +14358,7 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) 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) + nume = allocarray(n$, elements$, 4, 0) IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ IF arraydesc THEN GOTO dim2exitfunc @@ -14431,7 +14440,7 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) 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) + nume = allocarray(n$, elements$, 8, 0) IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ IF arraydesc THEN GOTO dim2exitfunc @@ -14513,7 +14522,7 @@ FUNCTION dim2 (varname$, typ2$, method, elements$) 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) + nume = allocarray(n$, elements$, 32, 0) IF Error_Happened THEN EXIT FUNCTION l$ = l$ + sp + tlayout$ IF arraydesc THEN GOTO dim2exitfunc @@ -25246,6 +25255,24 @@ SUB initialise_udt_varstrings (n$, udt, file, base_offset) LOOP END SUB +sub initialise_array_udt_varstrings(n$, udt, file, base_offset, bytesperelement$) + if not udtxvariable(udt) then exit sub + offset = base_offset + element = udtxnext(udt) + do while element + print _trim$(udtename(element)), udtetype(element) + if udtetype(element) and isstring then + if (udtetype(element) and isfixedlength) = 0 then + print #file, "*(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, 13, offset, bytesperelement$ + 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) + ");" From daf5cba518a989f8954d331db94af8da58debd76 Mon Sep 17 00:00:00 2001 From: Luke Ceddia Date: Tue, 23 Oct 2018 20:36:32 +1100 Subject: [PATCH 5/7] Dynamic arrays (handles arrays in subs too) --- source/qb64.bas | 71 ++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 55 insertions(+), 16 deletions(-) diff --git a/source/qb64.bas b/source/qb64.bas index 3834cff0e..ee3c54da2 100644 --- a/source/qb64.bas +++ b/source/qb64.bas @@ -12973,10 +12973,11 @@ FUNCTION allocarray (n2$, elements$, elementsize, udt) PRINT #13, n$ + "[2]=1+2;" 'init+static END IF - if udt > 0 then + if udt > 0 and udtxvariable(udt) then print #13, "tmp_long=" + elesizestr$ + ";" print #13, "while(tmp_long--){" - initialise_array_udt_varstrings n$, udt, 13, 0, bytesperelement$ + initialise_array_udt_varstrings n$, udt, 0, bytesperelement$, acc$ + print #13, acc$ print #13, "}" end if @@ -13031,6 +13032,14 @@ FUNCTION allocarray (n2$, elements$, elementsize, udt) 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 @@ -13059,9 +13068,9 @@ FUNCTION allocarray (n2$, elements$, elementsize, udt) '--------CREATE ARRAY & CLEAN-UP CODE-------- 'Overwrite existing array dimension sizes/ranges f12$ = f12$ + CRLF + sd$ - IF stringarray THEN + IF stringarray or ((udt > 0) and udtxvariable(udt)) THEN - 'Note: String arrays are always created in 64bit memory + 'Note: String and variable-length udt arrays are always created in 64bit memory IF redimoption = 2 THEN f12$ = f12$ + CRLF + "if (preserved_elements){" @@ -13089,7 +13098,7 @@ FUNCTION allocarray (n2$, elements$, elementsize, udt) f12$ = f12$ + CRLF + "}else{" END IF - '1. Create string array + '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 @@ -13097,11 +13106,18 @@ FUNCTION allocarray (n2$, elements$, elementsize, udt) 'init individual strings - 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 + 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 + "}" @@ -13112,7 +13128,14 @@ FUNCTION allocarray (n2$, elements$, elementsize, udt) IF arraydesc = 0 THEN 'only add for first declaration of the array PRINT #19, "if (" + n$ + "[2]&1){" 'initialized? PRINT #19, "tmp_long=" + elesizestr$ + ";" - PRINT #19, "while(tmp_long--) qbs_free((qbs*)((uint64*)(" + n$ + "[0]))[tmp_long]);" + 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) @@ -13120,7 +13143,7 @@ FUNCTION allocarray (n2$, elements$, elementsize, udt) END IF - ELSE 'not string array + ELSE 'not string/var-udt array '1. Create array f12$ = f12$ + CRLF + "if (" + n$ + "[2]&4){" 'array will be in cmem @@ -25255,18 +25278,34 @@ SUB initialise_udt_varstrings (n$, udt, file, base_offset) LOOP END SUB -sub initialise_array_udt_varstrings(n$, udt, file, base_offset, bytesperelement$) +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 - print _trim$(udtename(element)), udtetype(element) if udtetype(element) and isstring then if (udtetype(element) and isfixedlength) = 0 then - print #file, "*(qbs**)(" + n$ + "[0]+(" + bytesperelement$ + "-1)*tmp_long+" + str$(offset) + ")=qbs_new(0,0);" + 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, 13, offset, bytesperelement$ + 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) From 4c94b54f1043a6c2f359ffffdad75a0a494175f2 Mon Sep 17 00:00:00 2001 From: Luke Ceddia Date: Tue, 23 Oct 2018 21:23:13 +1100 Subject: [PATCH 6/7] redim _preserve --- source/qb64.bas | 37 +++++++++++++++++++++++++------------ 1 file changed, 25 insertions(+), 12 deletions(-) diff --git a/source/qb64.bas b/source/qb64.bas index ee3c54da2..5e15f749b 100644 --- a/source/qb64.bas +++ b/source/qb64.bas @@ -13078,20 +13078,33 @@ FUNCTION allocarray (n2$, elements$, elementsize, udt) f12$ = f12$ + CRLF + "static ptrszint tmp_long2;" 'free any qbs strings which will be lost in the realloc - f12$ = f12$ + CRLF + "tmp_long=" + elesizestr$ + ";" - f12$ = f12$ + CRLF + "if (tmp_long Date: Sun, 28 Oct 2018 00:00:29 +1100 Subject: [PATCH 7/7] Disallow GET/PUT for variable UDTs --- source/qb64.bas | 2 ++ 1 file changed, 2 insertions(+) diff --git a/source/qb64.bas b/source/qb64.bas index 5e15f749b..a69c46639 100644 --- a/source/qb64.bas +++ b/source/qb64.bas @@ -1940,6 +1940,7 @@ DO udtxcname(i) = getelement(ca$, 2) udtxnext(i) = 0 udtxsize(i) = 0 + udtxvariable(i) = 0 hashname$ = secondelement$ hashflags = HASHFLAG_UDT @@ -16985,6 +16986,7 @@ FUNCTION evaluatetotyp$ (a2$, targettyp AS LONG) ' 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 "Cannot GET/PUT variable-length TYPE": Exit Function idnumber = VAL(e$) i = INSTR(e$, sp3): e$ = RIGHT$(e$, LEN(e$) - i) u = VAL(e$) 'closest parent