Here is the complete code:
'Generated with PluriBASIC DEMO version 6.0.6.301903
$ filename "C:\Users\Diamante\Documents\PluriBASIC\Clean\StringBench.exe"
uses rtl32
%NoConsole
uses console
DIM STRING ?SYSTEM_UDT_OFFSETS(0)
STRING ?TMPS = "" ' a temporary string.
LONG ?CNTR = 0 ' a temporary counter.
DECLARE FUNCTION ?GetLastError Lib "Kernel32.dll" Alias "GetLastError" () AS LONG
DECLARE FUNCTION ?GetAsyncKeyState Lib "User32.dll" Alias "GetAsyncKeyState" (ByVal vKey AS LONG) AS short
DECLARE SUB ?Sleep lib "Kernel32.dll" alias "Sleep" (dword mSec)
function ?INI_QUAD(dword v1, v2) as quad
quad v = 0
copy(@v+0, @v2, 4)
copy(@v+4, @v1, 4)
return v
end function
'#if X64
'#DEF ?udt sys
'#else
#DEF ?udt sys ptr
'#endif
DECLARE FUNCTION ?OpenProcess Lib "KERNEL32.DLL" Alias "OpenProcess" (ByVal dwDesiredAccess AS DWORD, ByVal bInheritHandle AS LONG, ByVal dwProcessId AS SYS) AS SYS
DECLARE FUNCTION ?TerminateProcess Lib "KERNEL32.DLL" Alias "TerminateProcess" ( ByVal hProcess AS SYS, ByVal uExitCode AS DWORD) AS LONG
DECLARE FUNCTION ?CloseHandle Lib "KERNEL32.DLL" Alias "CloseHandle" (ByVal hObject AS SYS) AS LONG
DECLARE FUNCTION ?GetCurrentProcessId Lib "KERNEL32.DLL" Alias "GetCurrentProcessId" () AS SYS
declare function PluriBASICGetTickCntTimer lib "kernel32.dll" alias "GetTickCount" () as dword
DECLARE FUNCTION ?WriteConsole LIB "KERNEL32.DLL" ALIAS "WriteFile" (BYVAL hFile AS SYS, lpBuffer AS ANY, BYVAL nNumberOfBytesToWrite AS dword, lpNumberOfBytesWritten AS dword, lpReserved AS long) AS LONG
DECLARE FUNCTION ?AllocConsole LIB "KERNEL32.DLL" ALIAS "AllocConsole" () AS LONG
DECLARE FUNCTION ?FlushFileBuffers LIB "KERNEL32.DLL" ALIAS "FlushFileBuffers" (BYVAL hFile AS SYS) AS LONG
DECLARE FUNCTION ?GetStdHandle LIB "KERNEL32.DLL" Alias "GetStdHandle" (ByVal nStdHandle AS DWORD) AS SYS
DECLARE SUB ?PRINTSTR(string c, byval int cr)
' STARTS PLURIBASIC_PREPARE.BIN
' This code is executed before anything else, if you want to do something after defining other things, see PLURIBASIC_INIT
int ?i = 0
' STARTS SYSTEM_OPERATORS.BIN
'Initialize QUAD
function ?IQD(dword v1, v2) as quad
quad v = 0
copy(@v+0, @v2, 4)
copy(@v+4, @v1, 4)
return v
end function
FUNCTION ?BytOvf(byte b) AS byte
return b
END FUNCTION
FUNCTION ?NOT(byval quad v1) AS QUAD
dword w1
dword w2
quad r
copy @w1, @v1, 4
copy @w2, @v1+4, 4
w1 = not(w1)
w2 = not(w2)
copy @r, @w1, 4
copy @r+4, @w2, 4
return r
END FUNCTION
FUNCTION ?opAND(byval quad v1, v2) as quad
dword w1
dword w2
quad r
copy @w1, @v1, 4
copy @w2, @v2, 4
w1 = (w1 and w2)
copy @r, @w1, 4
copy @w1, @v1+4, 4
copy @w2, @v2+4, 4
w1 = (w1 and w2)
copy @r+4, @w1, 4
return r
end function
FUNCTION ?opOR(byval quad v1, v2) as quad
addr rcx,v1
addr rdx,v2
mov eax,[rcx]
or eax,[rdx]
mov [rcx],eax
mov eax,[rcx+3]
or eax,[rdx+3]
mov [rcx+3],eax
return v1
end function
FUNCTION ?opIMP(byval quad v1, v2) as quad
if v1 then return -1
if v2 then return -1
end function
FUNCTION ?opMOD(byval quad v1, v2) as quad
return mod((quad)v1, (quad)v2)
end function
FUNCTION ?opEXP(byval quad v1, v2) as extended
return v1 ^ v2
end function
FUNCTION ?opSHL(byval quad v1, v2) as quad
int i = 0
for i = 1 to v2
v1 = (v1 * 2)
next i
return v1
end function
FUNCTION ?opSHR(byval quad v1, v2) as quad
int i = 0
for i = 1 to v2
v1 = (v1 * 2)
next i
return v1
end function
FUNCTION ?opEQV(byval quad v1, v2) as quad
if v1=0 then return 0
if v2=0 then return 0
return -1
end function
macro ?mkcopy
end macro
macro dblcopy double(R,X)
r = x
end macro
' END OF SYSTEM_OPERATORS.BIN
' CONTINUES (20) PLURIBASIC_PREPARE.BIN
#DEF HANDLE SYS
TYPE ?SYSNMHDR
hwndFrom AS SYS
idFrom AS SYS
Code AS DWORD
END TYPE
class ?SYSF
FUNCTION CONSTRUCTOR()
END FUNCTION
function full() as string
return ""
end function
END CLASS
new ?SYSF EXE()
class IPOWERTIME
sub setInterface(string s)
end sub
sub now()
end sub
function FileTime() as quad
end function
end class
' The following are ASSEMBLY macros required for assembly to seamlesly work
' with basic...
macro asminit?
dword iebx?
dword eax?, ebx?, ecx?, edx?, esi?, edi?, ebp?
dword ?teax, ?tebx, ?tecx, ?tedx, ?tesi, ?tedi, ?tebp
mov iebx?, ebx
mov eax?, eax
mov ebx?, ebx
mov ecx?, ecx
mov edx?, edx
mov esi?, esi
mov edi?, edi
mov ebp?, ebp
end macro
macro push?
mov eax?, eax
mov ebx?, ebx
mov ecx?, ecx
mov edx?, edx
mov esi?, esi
mov edi?, edi
mov ebp?, ebp
mov ebx, iebx?
end macro
macro endasm?
mov ebx, iebx?
end macro
macro pop?(t)
mov eax, eax?
mov ebx, ebx?
mov ecx, ecx?
mov ebx, ebx?
mov esi, esi?
mov edi, edi?
mov ebp, ebp?
end macro
macro mov_n2r?(rg, vv, sr)
sr = 0
mov rg, vv
end macro
macro mov_v2r?(rg, vv, sr t?)
sr = 1
sys t? = (vv)
mov rg, t?
end macro
macro mov_p2r?(rg, vv, sr a)
sr = 1
sys a
a = (vv)
mov rg, a
end macro
macro mov_r2v?(vv, rg, sr a, b, c, d)
sys ptr b, a
cmp sr, 0
je d
cmp rg, 0
je c
mov a, rg
@b = a
vv = b
jmp c
d:
mov vv, rg
c:
end macro
' END OF PLURIBASIC_PREPARE.BIN
' STARTS TYPESIZE.BIN
' not necessary.
' END OF TYPESIZE.BIN
' STARTS TIMER.BIN
// returns the number of seconds since midnight.
FUNCTION TIMER() AS DOUBLE
return (PluriBASICGetTickCntTimer() / 1000)
END FUNCTION
' END OF TIMER.BIN
' STARTS STRINGN.BIN
//Assigns a truncated null terminated string.
MACRO ?STRN_SET(v, c, l b)
string b = c
if len(b) > l then
b = left(b, l)
elseif len(b) < l then
b += space(l-len(b))
end if
v = b
END MACRO
' END OF STRINGN.BIN
' STARTS STR$.BIN
FUNCTION STR$(long v, byref int d) as string
if v < 0 then
return str(v, 0)
else
return " " + str(v, 0)
end if
END FUNCTION
FUNCTION STR$(quad v, byref int d) as string
if v < 0 then
return str(v, 0)
else
return " " + str(v, 0)
end if
END FUNCTION
FUNCTION STR$(byref extended v, byref int d) as string
if v < 0 then
if @d then
return str(v, d)
else
return str(v)
end if
else
if @d then
return " " + str(v, d)
else
return " " + str(v)
end if
end if
END FUNCTION
FUNCTION STR$(long v) as string
if v < 0 then
return str(v, 0)
else
return " " + str(v, 0)
end if
END FUNCTION
FUNCTION STR$(quad v) as string
if v < 0 then
return str(v, 0)
else
return " " + str(v, 0)
end if
END FUNCTION
FUNCTION STR$(byref extended v) as string
if v < 0 then
return str(v)
else
return " " + str(v)
end if
END FUNCTION
' END OF STR$.BIN
' STARTS PRINTR.BIN
SUB ?INITCONSOLE()
STATIC Allc AS LONG
IF Allc=0 THEN
?AllocConsole()
Allc = 1
END IF
END SUB
MACRO ?STDOUT()
INT lWritten = 0
SYS hFile = 0
INT Btc = 0
hFile = ?GetStdHandle(-11)
if cr=1 then s += chr(13, 10)
if cr=2 then s += "</br>"
FOR Btc = 1 TO 50
IF ((Btc*32000)-31999) > len(s) THEN EXIT FOR
TTsnd = MID(s, ((Btc*32000)-31999), 32000)
?WriteConsole(hFile, ByVal StrPtr(TTsnd), byval Len(TTsnd), lWritten, ByVal 0)
NEXT Btc
END MACRO
SUB ?PRINTASZ(ASCIIZ c[0], byval int cr)
STRING TTsnd = ""
string s = c
?STDOUT()
END SUB
SUB ?PRINTSTR(string c, int cr)
STRING TTsnd = ""
STRING s = c
?STDOUT()
END SUB
SUB ?PRINTJSN(STRING c, byval int cr)
STRING TTsnd = ""
STRING s = c
?STDOUT()
END SUB
SUB ?PRINTSTZ(ZSTRING c[0], byval int cr)
STRING TTsnd = ""
STRING s = c
?STDOUT()
END SUB
SUB ?PRINTWST(WSTRING c, byval int cr)
STRING TTsnd = ""
STRING s = c
?STDOUT()
END SUB
SUB ?PRINTWSZ(WZSTRING c[0], byval int cr)
WSTRING TTsnd = ""
WSTRING s = c
?STDOUT()
END SUB
' END OF PRINTR.BIN
' STARTS PLURIBASIC_INIT.BIN
' This code is executed before anything else, if you want to do something before nything else, see PLURIBASIC_PREPARE
' END OF PLURIBASIC_INIT.BIN
' STARTS LTRIM$.BIN
// returns a trimed string
FUNCTION LTRIM$(string src, long a = 0, string ch = " ") as string
if len(src) = 0 then return ""
if len(ch) = 0 then return ""
byte srcchar at strptr(src)
byte trichar at strptr(ch)
long p1 = 1
long index
long cha
if a then
for index = 1 to len(src)
for cha = 1 to len(ch)
if srcchar[index] = trichar[cha] then
goto checknextchar
end if
next
p1 = index
exit for
checknextchar:
next
return mid(src, p1)
else
for index = 1 to len(src)
for cha = 1 to len(ch)
if srcchar[index+cha-1] <> trichar[cha] then
goto nomorematches
end if
next
p1 += len(ch)
next
nomorematches:
return mid(src, p1)
end if
END FUNCTION
' END OF LTRIM$.BIN
' STARTS ISTRUE.BIN
' Returns -1 if the passed value is non-zero.
FUNCTION ISTRUE(byval quad v) as int
if v THEN
return -1
else
return 0
end if
END FUNCTION
'MACRO ISTRUE quad(r, i)
' if (int(i) = 0) then
' r = 0
' else
' r = -1
' end if
'END MACRO
' END OF ISTRUE.BIN
' STARTS IIF$.BIN
macro IIF$ string(R,X,A,B)
if int(x) = 0 then
r = b
else
r = a
end if
end macro
' END OF IIF$.BIN
' STARTS FORMAT$.BIN
FUNCTION ?XFORMAT(byref extended dd, byref string f) as string
f += news(3) ' extra space to allow checking.
int iPeriod = -1
int iCommas = 0
int iDigits = 0
int iZeroes = 0
int iPercent = 0
int iFill = 0
int i = 0
int cm = 0
int iBegin = 0
int ml = len(f)-3
string o = ""
int p[2]
byte b at strptr(f)
for i = 1 to ml
select case b[i]
case 44 ' ,
if iDigits then
iCommas = 1
b[i] = 0
end if
case 42 ' *
iDigits += 1
if iPeriod != -1 then
p[2] += 2
else
p[1] += 2
end if
iFill = b[i+1]
b[i] = 2
b[i+1] = 2
i += 1
case 34
b[i] = 0
do
i += 1
if b[i] = 34 then
if b[i+1] != 34 then
b[i] = 0
exit do
end if
end if
loop
case 92 ' \
b[i] = 0
if b[i+1] = 0 then
i += 1 ' Unicode fix.
end if
if b[i+1] = 34 then
if b[i+2] = 34 then
b[i+2] = 0
i += 2
else
b[i+1] = 0
i += 1
end if
continue
end if
i += 1
case 48 ' 0
iDigits += 1
iZeroes += 1
if iPeriod != -1 then
p[2] += 1
b[i] = 1
else
p[1] += 1
b[i] = 1
end if
case 35 ' #
iDigits += 1
if iPeriod != -1 then
p[2] += 1
b[i] = 2
else
p[1] += 1
b[i] = 2
end if
case 37
b[i] = 0
iPercent = 1
case 46
if iPeriod = -1 then
iPeriod = i
end if
CASE 32, 36, 38, 40, 41, 43, 45
' these are allowed directly...
case else
' anything else is removed.
b[i] = 0
end select
next i
if iPeriod = -1 then
iBegin = ml
else
iBegin = iPeriod
end if
if iPercent then
dd = (dd * 100)
end if
string ss
if (dd = 0.00) then
ss = "0.0"
else
ss = str(dd, p[2])
if instr(ss, ".") then
ss += "0"
end if
end if
p[2]++
' split the real numbers.
byte b at strptr(ss)
string sValue = ""
string sDecimal = ""
for i = 1 to len(ss)
if b[i] = 46 then
sValue = left(ss, i-1)
sDecimal = mid(ss, i+1)
exit for
elseif i = len(ss) then
sValue = ss
sDecimal = ""
end if
next i
' print ss chr(13, 10)
' print sValue chr(13, 10)
' print sDecimal chr(13, 10)
' print p[1] chr(13, 10)
' print ci chr(13, 10)
byte b at strptr(f)
int ci = len(sValue)
byte n at strptr(sValue) 'first the integer part.
cm = -1
for i = iBegin to 1 step -1
'print "@=>" cr
'print "[" i "] " o " " b[i] " " i
select case b[i]
case 0 ' discard it!
case 1, 2 ' 0 #
p[1] -= 1
' print "@@@@@@@@@@@@@" cr
' print p[1] " ====== " cr
' print b[i] " ====== " cr
' print ci " ====== " cr
' print ifill " ====== " cr
' print o " =!= " cr
'
if p[1] < 1 then
if ci then
for ci = ci to 1 step -1
gosub addcomma
if n[ci] = 32 then
if n[2] = 0 then
o = "0" + o
end if
else
o = chr(n[ci]) + o
end if
next ci
elseif iFill then
if b[i] = 2 then
o = chr(iFill) + o
end if
end if
else
if ci then
gosub addcomma
o = chr(n[ci]) + o
ci -= 1
if (ci = 0) and (p[1]>0) then
if iFill then
o = chr(iFill) + o
else
o = "0" + o
end if
end if
elseif b[i] = 1 then
gosub addcomma
o = "0" + o
elseif iFill then
o = chr(iFill) + o
end if
end if
case 45
if (dd<0) then
if asc(mid(o, 1, 1)) <> 45 then
o = chr(b[i]) + o
end if
else
o = chr(b[i]) + o
end if
case else
o = chr(b[i]) + o
end select
next i
' phew!! last... the decimals!
int ci = 1
byte n at strptr(sDecimal)
for i = iBegin+1 to ml
select case b[i]
case 0 ' discard it!
case 1, 2 ' 0 #
p[2] -= 1
if p[2] < 0 then
if iFill then
if b[i] = 2 then
o += chr(iFill)
end if
end if
elseif p[2] = 0 then
if ci = len(sDecimal) then
for ci = ci to len(sDecimal)
o += chr(n[ci])
next ci
if iPercent then
o += "%"
end if
elseif ci > len(sDecimal) then
if b[i] = 1 then
o += "0"
elseif iFill then
o += chr(iFill)
end if
if iPercent then
o += "%"
end if
elseif iFill then
if b[i] = 2 then
o += chr(iFill)
end if
end if
elseif p[2] > 0 then
if ci < len(sDecimal) then
o += chr(n[ci])
ci += 1
elseif b[i] = 1 then
o += "0"
elseif iFill then
o += chr(iFill)
end if
end if
case else
o += chr(b[i])
end select
next i
return o
addcomma:
if iCommas then
cm += 1
if cm = 3 then
cm = 0
o = "," + o
end if
end if
ret
END FUNCTION
FUNCTION ?FFORMAT(byref extended dd, byval string tf) AS STRING
string f = tf
if instr(f, ";") then
if dd>0 then
f = mid(f, 1, instr(f, ";")-1)
elseif dd<0 then
f = mid(f, instr(f, ";")+1)
if instr(f, ";") then
f = mid(f, 1, instr(f, ";")-1)
end if
elseif dd = 0
f = mid(f, instr(f, ";")+1)
if instr(f, ";") then
f = mid(f, instr(f, ";")+1)
if instr(f, ";") then
f = mid(f, 1, instr(f, ";")-1)
end if
else
f = fs
end if
end if
end if
return ?XFORMAT(dd, f)
END FUNCTION
macro OverFlowFormats(nt, ta, st, vv, df)
FUNCTION FORMAT$(nt v, byval st f) as string
extended nv = vv
if strptr(f) then
'start raw
'#if typecodeof(v) > 99
return ?FFORMAT(nv, f)
'#else
' return ?FFORMAT(str(vv), f)
'#endif
'end raw
else
return ?FFORMAT(str(vv), df)
end if
END FUNCTION
end macro
OverFlowFormats(byval byte, quad, string, v, "0")
OverFlowFormats(byval long, quad, string, v, "0")
OverFlowFormats(byval short, quad, string, v, "0")
OverFlowFormats(byval quad, quad, string, v, "0")
OverFlowFormats(byval single, single, string, v, "0.0#######")
OverFlowFormats(byval double, double, string, v, "0.0############")
OverFlowFormats(byref extended, extended, string, v, "0.##################")
OverFlowFormats(byval byte, quad, wstring, v, "0")
OverFlowFormats(byval long, quad, wstring, v, "0")
OverFlowFormats(byval short, quad, wstring, v, "0")
OverFlowFormats(byval quad, quad, wstring, v, "0")
OverFlowFormats(byval single, single, wstring, v, "0.0########")
OverFlowFormats(byval double, double, wstring, v, "0.0###############")
OverFlowFormats(byref extended, extended, wstring, v, "0.####################")
' END OF FORMAT$.BIN
' STARTS ASCIIZ.BIN
//Assigns a truncated null terminated string.
MACRO ?ASCZ_SET(v, c, l)
if l < 2 then
copy0(@v, chr(0), 1)
else
copy0(@v, left(c, l-1), l)
end if
END MACRO
' END OF ASCIIZ.BIN
' STARTS CALLBACKDATA.BIN
' END OF CALLBACKDATA.BIN
DECLARE FUNCTION PBMAIN() AS LONG
' Initializes various things in the program.
FUNCTION PluriBASIC_Initialize() AS LONG
END FUNCTION
macro TEST$ string(R,X,A,B)
if int(x) == 0 then
r = b
else
r = a
end if
end macro
'print test$((1=1) or (2=2), "-1", "0") cr
'print test$(?opAND(((1000000=1000000)), ((1000000=1000000))), "*OK!* ", "ERROR ")
FUNCTION PBMAIN() AS INT
INT ?RETVAL = 0
LONG ??in1
STRING ??sbn2
STRING ??sun3
STRING ??san4
SINGLE ??t1n5
SINGLE ??t2n6
LONG ??c1n7
LONG ??c2n8
LONG ??in9
STRING ??sbna
STRING ??sunb
ASCIIZ ??sanc[22]
SINGLE ??t1nd
SINGLE ??t2ne
LONG ??c1nf
LONG ??c2n10
?PRINTSTR("OxygenBASIC" & " benchmark for string comparison! (" & LTRIM$(STR$(32, null), null) & "bits)", 1)
?PRINTSTR("", 1)
??sbn2 = ("concat")
??sun3 = ("compare1")
??san4 = ("compare2")
??t1n5 = (TIMER())
??in1 = 1
gosub .?FNini0009
goto .?FNind0009
..?FNini0009
int ?ite0009 = 0
LONG ?tov0009 = 1000000
RET
..?FNind0009
FOR ?ite0009 = 0 TO 2 STEP 1
..?FNst0009
if ?ite0009 then
??in1 = (??in1 + 1)
if ??in1 > ?tov0009 then exit for
end if
?ite0009 = 1
IF ??sbn2 + ??sun3=??sbn2 + ??sun3 THEN
??c1n7 = ((??c1n7) + 1)
END IF
IF ??sbn2 + ??sun3 <> ??sbn2 + ??san4 THEN
??c2n8 = ((??c2n8) + 1)
END IF
..?FNite0009:
if ?ite0009=0 then gosub .?FNini0009
?ite0009 = 1
goto .?FNst0009
NEXT
?ite0009 = 0
?PRINTSTR(IIF$(?opAND(((??c1n7=1000000)), ((??c2n8=1000000))), "*OK!* ", "ERROR ") & " " & FORMAT$(TIMER() - ??t1n5, "0.00") & " " & "STRING" & IIF$(0, " *" + STR$(0, null), "") & " vs " + "STRING" & IIF$(0, " *" + STR$(0, null), "") & " ", 1)
??sbna = ("concat")
??sunb = ("compare1")
?ASCZ_SET(??sanc, ("compare2"), 20)
??t1nd = (TIMER())
??in9 = 1
gosub .?FNini0012
goto .?FNind0012
..?FNini0012
int ?ite0012 = 0
LONG ?tov0012 = 1000000
RET
..?FNind0012
FOR ?ite0012 = 0 TO 2 STEP 1
..?FNst0012
if ?ite0012 then
??in9 = (??in9 + 1)
if ??in9 > ?tov0012 then exit for
end if
?ite0012 = 1
IF ??sbna + ??sunb=??sbna + ??sunb THEN
??c1nf = ((??c1nf) + 1)
END IF
IF ??sbna + ??sunb <> ??sbna + ??sanc THEN
??c2n10 = ((??c2n10) + 1)
END IF
..?FNite0012:
if ?ite0012=0 then gosub .?FNini0012
?ite0012 = 1
goto .?FNst0012
NEXT
?ite0012 = 0
?PRINTSTR(IIF$(?opAND(((??c1nf=1000000)), ((??c2n10=1000000))), "*OK!* ", "ERROR ") & " " & FORMAT$(TIMER() - ??t1nd, "0.00") & " " & "STRING" & IIF$(0, " *" + STR$(0, null), "") & " vs " + "ASCIIZ" & IIF$(20, " *" + STR$(20, null), "") & " ", 1)
RETURN ?RETVAL
END FUNCTION
PBMAIN() ' invoke entry point
