New array features

General discussion for topics related to the FreeBASIC project or its community.
Post Reply
jj2007
Posts: 2326
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: New array features

Post by jj2007 »

Code: Select all

*** compiling TmpFb.bas with -w all -asm att -Wc -O3 -s console ***
C:\Juergen\FB64\inc\array.bi(715) error 1: Argument count mismatch, found ')' in 'function = fb_ArraySort( byval ap, byval sa, byval t, byval cp, byval ai.p, byval ai.li, byval n)'
C:\Juergen\FB64\inc\array.bi(1844) error 58: Type mismatch, at parameter 6 in 'function = fb_ArrayScan(byval p, byval cbp, ast.l, byval ast.p, ast.o, ai, flag, n)'
C:\Juergen\FB64\tmp\TmpFb.bas(72) warning 43(-1): Argument count mismatch, expanding: ARRAY
C:\Juergen\FB64\tmp\TmpFb.bas(72) error 42: Variable not declared, nocase
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: New array features

Post by dodicat »

Hi JK.
I hate doing this again, but sorry the errors are still there with your FB64 fbc.exe

for the dodicat-sortorig I get
error 42: Variable not declared, nocase in 'array(sort, (l, nocase)) '0.58'
if I switch to my own sort
sortup(L(),Lbound(L),Ubound(L))
I get .9 seconds for the sort and .7 seconds for the scan.
So that bit is OK.

I had a look and I can see no definition of nocase in array.bi, array - Koppie.bi or ustring.bi.
I found 14 locations of nocase in the folder FB64, but these locations include inside dll's, .a files e.t.c.

Search code:

Code: Select all

 
#include "file.bi"
#include "crt.bi"
Declare Function stats Cdecl Alias "_stat"(As zstring Ptr,As Any Ptr) As Integer

Function String_Split(s_in As String,chars As String,result() As String) As Long
    Dim As Long ctr,ctr2,k,n,LC=Len(chars)
    Dim As boolean tally(Len(s_in))
    #macro check_instring()
    n=0
    While n<Lc
        If chars[n]=s_in[k] Then 
            tally(k)=true
            If (ctr2-1) Then ctr+=1
            ctr2=0
            Exit While
        End If
        n+=1
    Wend
    #endmacro
    
    #macro split()
    If tally(k) Then
        If (ctr2-1) Then ctr+=1:result(ctr)=Mid(s_in,k+2-ctr2,ctr2-1)
        ctr2=0
    End If
    #endmacro
    '==================  LOOP TWICE =======================
    For k  =0 To Len(s_in)-1
        ctr2+=1:check_instring()
    Next k
     if ctr=0 then
         if len(s_in) andalso instr(chars,chr(s_in[0])) then ctr=1':beep
         end if
    If ctr Then Redim result(1 To ctr): ctr=0:ctr2=0 Else  Return 0
    For k  =0 To Len(s_in)-1
        ctr2+=1:split()
    Next k
    '===================== Last one ========================
    If ctr2>0 Then
        Redim Preserve result(1 To ctr+1)
        result(ctr+1)=Mid(s_in,k+1-ctr2,ctr2)
    End If
   
    Return Ubound(result)
End Function

Function _Remove(Byval Text As String,Char As String) As String
    Var index = 0,asci=Asc(char)
    For i As Integer = 0 To Len(Text) - 1
        If Text[i] <> ASCi Then Text[index] = Text[i] : index =index+ 1
    Next 
    Return Left(Text,index)
End Function

Function loadfile(file As String) As String
    file= _remove(file,Chr(34))
    If file="" Then Exit Function
    If Fileexists(file)=0 Then Print file;" CAN'T READ OR EMPTY FOLDER":Exit Function
    Var  f=Freefile
    Open file For Binary Access Read As #f
    Dim As String text
    If Lof(f) > 0 Then
        text = String(Lof(f), 0)
        Get #f, , text
    End If
    Close #f
    Return text
End Function

Function isfolder(path As zstring Ptr) As Long
    #define S_ISDIR(m)   (((m) And &hF000) = &h4000)
    Dim As stat statbuf
    If (stats(path, @statbuf) <> 0) Then Return 0
    Return S_ISDIR(statbuf.st_mode)
End Function

Function isfile(fname As String) As boolean
    Return Iif(isfolder(fname),0,1)
End Function

Function pipeout(Byval s As String="") Byref As String
    Var f=Freefile
    Dim As String tmp
    Open Pipe s For Input As #f 
    s=""
    Do Until Eof(f)
        Line Input #f,tmp
        s+=tmp+Chr(10)
    Loop
    Close #f
    Return s
End Function 

Function tally (somestring As String,partstring As String) As Integer
    Dim As Integer i,j,ln,lnp,count,num
    ln=Len(somestring)
    lnp=Len(partstring)
    count=0
    i=-1
    Do
        i+=1
        If somestring[i] <> partstring[0] Then Goto skip 
        If somestring[i] = partstring[0] Then
            For j=0 To lnp-1 
                If somestring[j+i]<>partstring[j] Then Goto skip
            Next j
        End If
        count+=1
        i=i+lnp-1
        skip:
    Loop Until i>=ln-1 
    Return count
End Function

function search(inputs As String,st As String) as long
    st=Lcase(st)
    dim as long dflag
    If isfile(inputs) Then 'for a single file or a drive:
        if len(inputs)=2 and inputs[1]=asc(":") then dflag=1:goto skip
        Var L=Lcase(loadfile(inputs))
        If Instr(L,st) Then Print inputs:Return 1 Else Return 0
    End If
    skip:
    Dim As String file
    If Instr(inputs," ") Then inputs=Chr(34)+inputs+Chr(34)
    Dim As String s=pipeout("dir /b " + inputs)
    Dim As String a()
    Static As Long counter
    string_split(s,Chr(13,10),a())
    inputs=_remove(inputs,Chr(34))
    if dflag=0 then 'not a drive
    redim as string tmp()
    string_split(inputs,"\/",tmp())
    if instr(tmp(ubound(tmp)),st) then print inputs;" >> (In folder name)":counter+=1
end if
    For n As Long=Lbound(a) To Ubound(a)
        Dim As String path=(inputs+"\"+a(n))
        If isfile(path) Then
            Redim As String tmp()
            string_split(path,"\",tmp())
            file= tmp(Ubound(tmp))
            If Instr(file,st) Then Print path;" >> (In file name)":counter+=1
            If Instr(file," ") Then file=Chr(34)+file+Chr(34)
            Var L=Lcase(loadfile(path))
            If Len(L) Andalso Instr(L,st) Then Print path + "  ("+ str(tally(L,st))+")":counter+=1
        Else
            search(path,st) 'for nested folders
        End If
    Next n
    return counter
End function 


Dim  As String location="C:\Users\User\Desktop\fbv1.06\64\jk\FB64" '<---- serarch path
print "You are using fb version ";__fb_version__

print "output format:"
print "path to file  (number of occurencies in the file)"
Print "Searching  . . .";
print
var c=search(location,"nocase")
Print "Done ",c; "  locations"
Sleep
  
coderJeff
Site Admin
Posts: 4313
Joined: Nov 04, 2005 14:23
Location: Ontario, Canada
Contact:

Re: New array features

Post by coderJeff »

Juergen Kuehlwein wrote:This will be no problem anymore as soon as Jeff changes the descriptor´s definition, because then this workaround will be obsolete.
By next weekend should be merge in. I ran out of time this weekend to get the array descriptor changes added.
Juergen Kuehlwein
Posts: 284
Joined: Mar 07, 2018 13:59
Location: Germany

Re: New array features

Post by Juergen Kuehlwein »

@dodicat,

well, something must still be wrong!

So the line:

Code: Select all

n = array(scan, l, for(@userscan))
compiles and runs

What happens, if you omit "nocase", like this?

Code: Select all

array(sort, l)
And what happens if you make "nocase" uppercase, like this?

Code: Select all

array(sort, (l, NOCASE))

JK
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: New array features

Post by dodicat »

OK
array(sort, (l, NOCASE)) works.
(Uppercase nocase)
I get about .88 seconds for the sort and about .7 for the scan.
My machine is obviously slower than yours.
For the syntax_test_sort.bas I had to change all to uppercase.
viz:

Code: Select all

  '#COMPILER FREEBASIC 
'#compile console 32 exe /o "-pp -maxerr 10"
'#compile console 32 exe /o "-gen gcc"
'#compile console 64 exe 

#include "ustring.bi"
#include "array.bi"


type testtype
  i as long
  n as byte
end type


private Function custom_sort_proc (byref a as testtype, byref b as testtype, byval flag as integer) as long
'***********************************************************************************************
' sample custom sort proc, byref parameters, flag > 0 -> sort up, flag <= 0 -> sort down
'***********************************************************************************************

  if flag > 0 then
    if a.n > b.n then                              
        return 1
    end if

  else          
    if a.n < b.n then                              
        return 1
    end if
  end if

  return 0

end function


'***********************************************************************************************

'const sort = 1                                        'this works
'#define sort 1                                        'this doesn´t


' i can have CONSTs, ENUMs, procedures and variables with the keywords name´s (sort, etc.)
' but obviously i cannot not have #DEFINEs for these words !


'dim a(1 to 5) as string '* 16
'dim a() as zstring * 16
dim a(1 to 5) as zstring * 16

'dim as integer a1 '= 0  
'dim as integer a2 '= 0  

'dim b(1 to 1000000) as byte
dim b(1 to 5) as byte
dim c(1 to 5) as testtype
dim limit as long = 1000000
'redim d(1 to limit) as byte'double
redim d(1 to limit) as double
redim d2(1 to limit) as double


dim i as long
'randomize timer
for i = 1 to limit
  d(i) = rnd '* 255
  d2(i) = d(i)
next i


'redim a(1 to 5) 'as zstring * 16


'print "a1: "; hex(@a1), hex(a1)
'print "a2: "; hex(@a2), hex(a2)
'print "desc a(): "; hex(fb_ArrayDesc(a(), 60))
'print "desc b(): "; hex(fb_ArrayDesc(b(), 60))
'
'
'a(1)="test"
'print hex(@a(1)), a(1)
'print hex(@a(2)), a(2)
'print hex(@a(5)), a(5)


sub setupa(a() as zstring)
dim i as long
'dim n as long

'print "setupa"
'print sizeof(a)
'print array(sizeof, a)
'print hex(array(data, a))                             'address correct!
'print sizeof(a(1))
'print sizeof(a(2))
'print sizeof(a(3))
'print sizeof(a(4))
'print sizeof(a(5))


'print hex(@a(1))                                      'address wrong in 64 bit, why ?
'print hex(@a(2))                                      'a(1) + 16, which is expected


  for i = 1 to 5
'    for n = 4 to 7
 '     b(i,n) = i*10 + n
      a(i) = "string" + str(i)

'      a(i) = "1"                                      'gpf in 64 bit

'    next n
  next i
  
end sub  

sub setupb(b() as byte)
dim i as long
'dim n as long

'  for i = 1 to 1000000
  for i = 1 to 5
'    for n = 4 to 7
 '     b(i,n) = i*10 + n
      b(i) = i
'    next n
  next i
  
end sub  

sub setupc(c() as testtype)
dim i as long
'dim n as long

  for i = 1 to 5
    c(i).i = 100 - i
    c(i).n = i
  next i
  
end sub  


'Sub show(d() As byte) 'double)
Sub show(d() as double)
    For n As Long=Lbound(d) To 10
'    For n As Long=Lbound(d) To ubound(d)
        Print d(n)
    Next
'    For n As Long=1 To 4
        Print "..."
'    Next
    For n As Long=Ubound(d)-10 To Ubound(d)
        Print d(n)
    Next
End Sub


sub showa(a() as zstring)
dim i as long

  print err, "Error #"
  for i = 1 to 5
    print "-" + a(i) + "-" '+ hex(varptr(a(i)))
  next i
  
end sub  

sub showb(b() as byte)
dim i as long
'dim n as long

  print err, "Error #"
  for i = 1 to 5
'    for n = 4 to 7
'      print i,n, b(i,n)
      print i, b(i)
'    next n
  next i
  
end sub  

sub showc(c() as testtype)
dim i as long
'dim n as long

  print err, "Error #"
  for i = 1 to 5
    print i, c(i).i, c(i).n
  next i
  
end sub  


'array(sort, (a, a), UP, at(1), 5)                     'error
'array(sort, (a, a, NOCASE), UP, (1), 5)             'error
'array(sort, (a, b, NOCASES), UP, (1), 5)            'error
'array(sort, (b, a)UP)                                 'error


setupa(a())

'***********************************************************************************************
dim as double t  'timer

show(d())

print "**********************************"
print "array(sort, d, DOWN)"
t=timer
'array(sort, d, DOWN)
'array(sort, d)
'array(sort, (d2, d))
array(sort, d)
print "Time taken  "; timer-t                         '0,26 (dedicated, without callback) /  0.33 (with 2 callbacks) / 0.35 sec (one callback [fb] with dflag)
show(d())
print
'***********************************************************************************************
' make dedicated functions, dflag before while loops
'***********************************************************************************************
dim n as long
for i as long = 1 to limit -1
  if d(i) > d(i+1) then
    n = n +1
    
    if n = 1 then
      print " error at", i
      print d(i)
      print d(i+1)
    end if
  end if
next i
print "# of errors:", n
sleep
'end
'***********************************************************************************************

setupb(b())
print "**********************************"
print "array(sort, b, DOWN)"
t=timer
array(sort, b, DOWN)
'array(sort, b)
print "Time taken  "; timer-t
showb(b())
print
sleep

setupa(a())
print "**********************************"
print "array(sort, a)"
array(sort, a)
showa(a())
print
sleep

setupa(a())
print "**********************************"
print "array(sort, a, DOWN)"
array(sort, a, DOWN)
showa(a())
print
sleep

setupa(a())
setupb(b())
showb(b())
print "**********************************"
print "array(sort, (a, b), DOWN)"
array(sort, (a, b), DOWN)
showa(a())
showb(b())
print
sleep

setupa(a())
print "**********************************"
print "array(sort, (a, NOCASE), DOWN, (2), 3)"
array(sort, (a, NOCASE), DOWN, (2), 3)
showa(a())
sleep
print

print "**********************************"
print "array(sort, a, DOWN, (1), 5)"
array(sort, a, DOWN, (1), 5)
sleep
print
print "**********************************"
print "array(sort, a, UP, (1))"
array(sort, a, UP, (1))
sleep
print
print "**********************************"
print "array(sort, a, UP)"
array(sort, a, UP)
sleep
print
print "**********************************"
print "array(sort, (a, b), DOWN, (1), 5)"
array(sort, (a, b), DOWN, (1), 5)
sleep
print
print "**********************************"
print "array(sort, (a, b, NOCASE), UP, (1), 5)"
array(sort, (a, b, NOCASE), UP, (1), 5)
sleep
print
setupc(c())
print "**********************************"
print "array(sort, c, @custom_sort_proc)"
array(sort, c, @custom_sort_proc)
showc(c())
sleep
print
setupc(c())
print "**********************************"
print "array(sort, c, @custom_sort_proc, (2), 3)"
array(sort, c, @custom_sort_proc, (2), 3)
showc(c())
sleep
print "**********************************"
print


end


'***********************************************************************************************
'***********************************************************************************************
'***********************************************************************************************


So generally I must write those instructions in uppercase.
Thanks JK.
Juergen Kuehlwein
Posts: 284
Joined: Mar 07, 2018 13:59
Location: Germany

Re: New array features

Post by Juergen Kuehlwein »

@ dodocat,

uppercase - yes, that´s it. What a silly bug! I wouldn´t have found it, if you hadn´t helped me - thanks.

I do some parameter parsing in "array.bi", and guess what, i do it in uppercase. At the very beginning of this project i installed a workaround making my "array(..." statements all uppercase. The idea was to let the compiler stringize these parameters later as uppercase. I totally forgot this :-(.

So for a start just make words like "up","down", nocase", etc. uppercase and then it should work. I don´t know when i will find time to fix that (make it case insensitive, as expected). Maybe by the end of the week, maybe earlier.

@jj2007,

thanks for testing! "-asm att" doesn´t work for me, throws a lot of strange errors. "-Wc -O3" runs here. Some of the warnings ("Argument count mismatch, expanding: ARRAY) are expected. In case of variadic array parameters, the compiler now skips an error, if there is an argument count mismatch, but still issues a warning. "From the error lines you posted, i can see that you don´t have the latest version of "array.bi".


JK
jj2007
Posts: 2326
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: New array features

Post by jj2007 »

Down to a few errors, using uppercase and no -asm att:

Code: Select all

*** compiling TmpFb.bas with -w all -Wc -O3 -s console ***
Juergen\FB64\inc\array.bi(715) error 1: Argument count mismatch, found ')' in 'function = fb_ArraySort( byval ap, byval sa, byval t, byval cp, byval ai.p, byval ai.li, byval n)'
Juergen\FB64\inc\array.bi(1844) error 58: Type mismatch, at parameter 6 in 'function = fb_ArrayScan(byval p, byval cbp, ast.l, byval ast.p, ast.o, ai, flag, n)'
Juergen\FB64\tmp\TmpFb.bas(72) warning 43(-1): Argument count mismatch, expanding: ARRAY
Juergen Kuehlwein
Posts: 284
Joined: Mar 07, 2018 13:59
Location: Germany

Re: New array features

Post by Juergen Kuehlwein »

A new version fixing (hopefully) the "uppercase bug" i had is available as usual here.

For testing you must exchange all binaries (as described above) + "array.bi" and "ustring.bi" with the new ones in the "new" folder. There is a file (documentation.txt) which explains a bit more how it works.

I recommend using the 32 (gen gas) version for testing, because 32 bit (gen gcc) and 64 bit still have a problem with memory alignment. As Jeff will change the array descriptor anyway (which will make my workaround and thus my problem obsolete), i don´t want to invest time for a fix!

@jj2007
From the error lines you posted, i can see that you don´t have the latest version of "array.bi"
Please update all files and re-try. In case it still doesn´t work, please post error message and code you are trying to compile - thanks.


JK
coderJeff
Site Admin
Posts: 4313
Joined: Nov 04, 2005 14:23
Location: Ontario, Canada
Contact:

Re: New array features

Post by coderJeff »

coderJeff wrote:
Juergen Kuehlwein wrote:This will be no problem anymore as soon as Jeff changes the descriptor´s definition, because then this workaround will be obsolete.
By next weekend should be merge in. I ran out of time this weekend to get the array descriptor changes added.
The first part needed, which is to document existing array descriptor is started at Re: Array Descriptor (split from Wiki Improvements) and can continue the discussion there for a bit as it relates to the array descriptor specifically.
Juergen Kuehlwein
Posts: 284
Joined: Mar 07, 2018 13:59
Location: Germany

Re: New array features

Post by Juergen Kuehlwein »

I will delete this fork of fbc, so the link provided in previous posts will no longer be valid.

Forked from the latest fbc version i will rebuild, what i have, separated in smaller commits for preparing a PR.


JK
Juergen Kuehlwein
Posts: 284
Joined: Mar 07, 2018 13:59
Location: Germany

Re: New array features

Post by Juergen Kuehlwein »

For all interested in testing the new fork is here. PR # 173 is ready for review.


JK
Post Reply