Homebrew variatric & named arguments

Share your advanced PureBasic knowledge/code with the community.
Post Reply
benubi
Enthusiast
Enthusiast
Posts: 215
Joined: Tue Mar 29, 2005 4:01 pm

Homebrew variatric & named arguments

Post by benubi »

Hello all!

I wrote a little "library" or include to create homebrew variatric arguments and lists. For a starter: what are variatric argument (lists) ? They are variable/variatric types and amount of parameters. Sometimes they can also be named, like in Python, Visual Basic and some other languages.

Code: Select all

function foo(a, b, ...) -- the three dots indicate a variatric arguments list (that may be empty, too)
  -- parameters:  a, b, args[1 .. n]
end
This can't be done yet natively in PureBasic, and C/C++ is very secretive about va_lists and their composition. Also: not all platforms that propose va_lists for C/C++ style API do allow named parameters (like in Python or Visual Basic etc.). So why bother fighting about secrets when in the end, you can only have half a solution, that won't be fully portable? I brew my own. It's not perfect, because C/C++ uses Macros and I use procedures (mostly) to emulate the functionality.

Cool exclusive feature: normally in C/C++ style apps the lists are used alone, or a copy is made, but with the homebrew solution you can do this:

Code: Select all

Procedure MyVarProc(*Input_VA_List, *Output_VA_List)
 ; If error = Write Error Message into output (return -1)
 ; Return 0,1 or many results in *Output_VA_List
 ProcedureReturn #Null ; no error
EndProcedure
So you can emulate multiple results, result-lists etc., just like in languages like Lua by using variatric lists. Also you can use them to throw error messages back to the callers, in case of errors. That's a use-case scenario I find interesting in connection with Behavior-Tree logic (success, failure, running + error). But that's only theoretical, yet :)

There's a 3-in-1 example showing different use-cases; notice you can also use the parameters like in sprintf() to return/store results, so you can also have multiple results without returning any list, but just by using the calling parameter list (see sprintf example). Or in other words, you can do - of course - with variatric arguments just the same as with regular ones, when you use parameters for return. This is of course nothing new, but just a reminder on how it could be done without va_lists:

Code: Select all

Procedure Simple_Multi_Results_Proc(A,b,c, *Result1.INTEGER, *Result2.INTEGER) 
    ; Store results in *Result1 and *Result2
EndProcedure

I haven't tested the code a lot yet, and perhaps you'd like something to be implemented? Like other's I am a bit experimenting with "object management" and structure/variable mapping, but I keep it on a low flame now to avoid too much spaghetti code. The VA lists allow FourCC types, meaning that in theory it could be extended to any/dynamic types but in practice you can simply use a pointer (e.g. #PB_Structure if #PB_Integer as type) to copy pointers. This is a huge subject in itself (when a object needs to be referenced, or fully copied, or cloned or instanciated...) so I'll save that for an other opportunity.

The reason the structures are a little "heavy" with destructors/freememory is that you could in theory access, add, free the va_lists from different DLL's and main programs, which means they would have different memory allocation and so on, so the va_lists have to be destroyed inside the context they were created in.

In c/c++ it is the called function that receives the va_lists that is obliged to destroy it; it has to be done manually in any case with the va_list macros, but it's not mandatory. VA_End() can be called outside or inside the called procedure to release the list.

Room for optimization: instead of allocating and freeing all list items with allocate/freememory, there could be a garbage collection and recycling of those va_list items (once everything else in the lib is stable and useful).

Code: Select all

; ============================================================================================================================================================================================================================================================
; VA_LIST variatric arguments (work around)
; ============================================================================================================================================================================================================================================================
; Author: benubi
; Date: February 14, 2025
; OS: All (and none)
; License: Free
; ============================================================================================================================================================================================================================================================
; va_list homebrew implementation
; allows  to use variatric arguments analogically to what's done in C/C++ and other languages
;
; features:
;    - create multiple VA lists and use them for input and output (or as error output!)
;    - named parameters
; cons:
;    - slower than C macros because it uses Procedures
;    - incompatible to native & secretive C/C++ va_lists
; ============================================================================================================================================================================================================================================================

#VA_BetaVersion = $8
#VA_Version     = $00000102 

#VA_List_FourCC           = ( 'V' << 24) | ( 'A' << 16) | ( 'L' << 8) | ( 'T')
#PB_VariatricArgumentList = #VA_List_FourCC

; Needed Declares
Declare.i VA_End(*VA_List)

; Prototypes for "destructors"
Prototype VA_FreeListStruct(*this)
Prototype VA_FreeListArg(*thisarg, boolFreeAll)


; Universal helper structure
Structure _VA_Any
  StructureUnion
    a.a
    b.b
    c.c
    d.d
    f.f
    i.i
    l.l
    *ptr._VA_Any
    q.q
    u.u
    w.w
  EndStructureUnion
EndStructure

; "Fake" (non-c compliant) variatric argument
Structure _VArg
  *nextArg._VArg
  flags.l
  Type.l ; FourCC
  Value._VA_Any
  OptName.s
  VA_FreeListArg.VA_FreeListArg
EndStructure
; List of arguments
Structure _VA_List
  VA_FreeListStruct.VA_FreeListStruct ; needed because the callee needs to free the list
  RefCount.i
  *First._Varg
  *Last._Varg
  *aNext._Varg ; next to be current
  Count.i
  CompareFlag.i
  
  *NullThisOnFree.INTEGER
  
EndStructure

; Helper function similar to Val()
Procedure.q _strVal(*this._VA_any) ; helper might be slower than PB's Val() implementation, but it supports "0x" and "#" prefixed hex values
  Protected check_hex, make_int, make_color
  Protected *next._VA_any = *this + SizeOf(Character)
  Protected result.q, tlen, lo, hi
  Protected *C.character
  ;Debug #PB_Compiler_Procedure
  If *This
    Select *this\c
      Case '$' ; check for hexa
        check_hex = 1
      Case '0'
        If *next\c = 'x'
          check_hex = 2
        Else
          make_int = 1
        EndIf
      Case '1' To '9'
        make_int = 1
      Case '#' ; CSS color
        make_color = 1
      Default
        ProcedureReturn 0
    EndSelect
    
    If make_int
      While *C\c
        Select *c\c
          Case '0' To '9'
            result * 10
            result + (*c\c - '0')
            *c + SizeOf(Character)
            Continue
          Default
            Break
        EndSelect
      Wend
    ElseIf check_hex
      
      *C = *this + (check_hex * SizeOf(Character))
      While *C\c
        Select *c\c
          Case '0' To '9'
            result << 4
            result | (*C\c - '0')
          Case 'a' To 'f'
            result << 4
            result | (10 + *C\c - 'a')
          Case 'A' To 'F'
            result << 4
            result | (10 + *C\c - 'A')
        EndSelect
        *C + SizeOf(character)
      Wend
      
    ElseIf make_color
      *C = *this + SizeOf(Character) ; two CSS formats: #rrggbb #rgb etc
      While *C\c And tlen < 9
        Select *C\c
          Case '0' To '9', 'a' To 'f', 'A' To 'F'
          Default
            ProcedureReturn 0
        EndSelect
        tlen + 1
      Wend
      
      If tlen = 3 Or tlen = 4 ; #RGB #RGBA
        *C   = *this + SizeOf(Character)
        tlen = 0
        While *c\c
          Select *C\c
            Case '0' To '9'
              hi = *c\c - '0'
            Case 'a' To 'f'
              hi = 10 + *c\c - 'a'
            Case 'A' To 'F'
              hi = 10 + *c\c - 'A'
          EndSelect
          *C + SizeOf(Character)
          Select *C\c
            Case '0' To '9'
              lo = *c\c - '0'
            Case 'a' To 'f'
              lo = 10 + *c\c - 'a'
            Case 'A' To 'F'
              lo = 10 + *c\c - 'A'
          EndSelect
          result = result | (lo << (tlen * 4)) | (hi << (tlen + 1) * 4)
          tlen + 2
          *C + SizeOf(Character)
        Wend
      ElseIf tlen = 6 Or tlen = 8 ; #RRGGBB #RRGGBBAA
        *C   = *this + SizeOf(Character)
        tlen = 0
        While *C\c
          Select *C\c
            Case '0' To '9'
              lo = *c\c - '0'
            Case 'a' To 'f'
              lo = 10 + *c\c - 'a'
            Case 'A' To 'F'
              lo = 10 + *c\c - 'A'
          EndSelect
          *C + SizeOf(Character)
          result = result | (lo << (tlen * 4))
          tlen + 1
        Wend
      EndIf
      
    EndIf
  EndIf
  ProcedureReturn result
EndProcedure

; Object management bindings (optional)
CompilerIf Not Defined(_OBJ_GET_TYPE_DESTRUCTOR, #PB_Procedure) ; external object management override/future implementation
  
  Procedure _OBJ_GET_TYPE_DESTRUCTOR(TYPE.l)
    ProcedureReturn #Null 
  EndProcedure
  
CompilerEndIf



; Helper function necessary for memory release, necessary for DLL/extern interactions
Procedure _va_free_mem(*this) ; helper needed because allocated/freed memory (heap) may be from a different environment e.g. if the va_list was called/used in/from a DLL
  If *this
    ProcedureReturn FreeMemory(*this)
  EndIf
EndProcedure


Procedure _va_free_arg(*this._Varg, boolFreeAll) ; helper to release embedded strings
  If *this
    *this\OptName = #Null$ ; release any name
    If (*this\Type = #PB_String Or *this\Type = #PB_UTF8) And *this\Value\ptr
      _va_free_mem(*this\Value\ptr)
      *this\Value\ptr = #Null   
    EndIf
    If boolFreeAll
      Debug "*This="+*this+"  type="+*this\Type
      _va_free_mem(*this) ; free this
    EndIf 
  EndIf
EndProcedure


Procedure _va_free_embedded_arglist(*this._Varg)
  If *This
    *this\OptName = #Null$
    If *This\Value\ptr
      Debug #PB_Compiler_Procedure +" VA_End()"
      VA_End(*this\Value\ptr)
    EndIf
    _va_free_mem(*this)
  EndIf
EndProcedure



; Basic and wrapped library procedures, inspired from the C/C++ va_list macros
Procedure VA_Start(*This._VA_List) ; Start (reset) va_list for traversal, select first element
  *this\aNext = *this\First
EndProcedure

Procedure VA_End(*this._VA_LIST) ; Finish traversal and free va_list
  If *this
    If *This\RefCount > 0
      *this\RefCount = *this\RefCount - 1
      If *this\RefCount = 0
        Protected *t._Varg = *This\First
        Protected *x._varg
        Protected VA_FreeListStruct.VA_FreeListStruct = *this\VA_FreeListStruct
        
        
        If *this\NullThisOnFree
          *This\NullThisOnFree\i = #Null
        EndIf
        
        While *T
          *x = *t\nextArg
          If *T\VA_FreeListArg
            *t\VA_FreeListArg(*t, #True)
          Else
            Debug "NO FREELIST SET FOR ARG " + *t
            If *T\OptName <> #Null$
              Debug "optname=" + *t\OptName
            EndIf
            _va_free_arg(*t, #True)
          EndIf
          *t = *x
        Wend
        *this\VA_FreeListStruct = #Null
        VA_FreeListStruct(*this)
      Else
        ProcedureReturn *this\RefCount
      EndIf
    EndIf
  EndIf
  ProcedureReturn 0
EndProcedure

Procedure VA_Add(*List._VA_List, Type.l, *pValue._VA_Any, VA_Name$ = #Empty$ , *destructor = #Null) ; Add "any" type (type = #PB_XYZ e.g. #PB_Float)
  Protected *P._Varg
  Protected *new._Varg
  Protected pptr 
  Protected *List2._VA_List
  If *list
    *P   = *list\Last
    *new = AllocateMemory(SizeOf(_Varg))
    
    If *new
      ; copy type:
      *new\Type           = Type
      If *destructor = #Null 
        *new\VA_FreeListArg = @_va_free_arg()
      Else 
        *new\VA_FreeListArg = *destructor
      EndIf 
      *new\OptName        = #Empty$
      ; copy value:
      Select Type
        Case #PB_String ; string needs to be allocated to prevent memory-leaks
          *new\Value\ptr = AllocateMemory(2 + (2*MemoryStringLength(*pValue)), #PB_Memory_NoClear)
          pptr           = *new\Value\ptr
          CopyMemoryString(*pValue, @pptr)
        Case #PB_Integer
          *new\Value\i = *pValue\i
        Case #PB_Double
          *new\Value\d = *pValue\d
        Case #PB_Float
          *new\Value\f = *pValue\f
        Case #PB_Quad
          *new\Value\q = *pValue\q
        Case #PB_Long
          *new\Value\l = *pValue\l
        Case #PB_Ascii
          *new\Value\a = *pValue\a
        Case #PB_Byte
          *new\Value\b = *pValue\b
        Case #PB_Character
          *new\Value\c = *pValue\c
        Case #PB_Unicode
          *new\Value\u = *pValue\u
        Case #PB_Word
          *new\value\w = *pValue\w
        Case #PB_VariatricArgumentList
          *List2 = *pValue
          *new\Value\ptr = *list2 
          *List2\RefCount = *List2\RefCount +1 
          If *destructor = #Null 
            *new\VA_FreeListArg = @_va_free_embedded_arglist()
          EndIf 
        Default
          *new\value\ptr = *pValue
      EndSelect
      
      *new\OptName = VA_Name$
      
      If *P
        *P\nextArg = *new
      Else
        *List\First = *new
      EndIf
      *List\Last  = *new
      *List\Count = *list\Count + 1
      ProcedureReturn *new
    EndIf
  EndIf
  ProcedureReturn #Null
EndProcedure

Procedure VA_AddString(*List._VA_List, String$, Name$ = #Empty$) ; Add string copy to va_list
  ProcedureReturn VA_Add(*list, #PB_String, @String$, Name$)
EndProcedure

Procedure VA_AddInt(*List._VA_List, value.q, Name$ = #Empty$) ; Add integer (quad) copy to va_list
  ProcedureReturn VA_Add(*List, #PB_Quad, @value, Name$)
EndProcedure

Procedure VA_AddReal(*List._VA_List, Real.d, Name$ = #Empty$) ; Add real (float/double) copy to va_list
  ProcedureReturn VA_Add(*List, #PB_Double, @Real, Name$)
EndProcedure

Procedure VA_AddPtr(*List._VA_List, *ptr, Name$ = #Empty$) ; Add a pointer to va_list
  ProcedureReturn VA_Add(*List, #PB_Integer, @*ptr, Name$)
EndProcedure

Procedure VA_Copy(*src._VA_LIST, *dst._VA_LIST) ; Copy all arguments from *src va_list to *dst va_list
  Protected *X._VARG
  Protected ppdest , *mem
  If *src And *dst
    *X = *SRC\First
    While *X
      If *X\Type <> #PB_String And *X\Type < 255 And *X\Type <> #PB_Structure And *X\Type <> #PB_Interface
        VA_Add(*dst, *X\Type, *X\Value, *X\OptName)
      Else
        VA_Add(*dst, *X\Type, *X\Value\ptr, *X\OptName)
      EndIf
      *X = *X\nextArg
    Wend
  EndIf
EndProcedure

Procedure$ VA_Name(*this._VA_List) ; return name of current selected argument
  If *this
    If *this\aNext
      ProcedureReturn *this\aNext\OptName
    EndIf
  EndIf
EndProcedure

Procedure.d VA_Real(*this._VA_List) ; cast current variadric argument to a real (double)
  Protected *a._VArg = *this\aNext
  Protected result.d
  If *a
    *this\aNext = *a\nextArg
    Select *a\Type
      Case #PB_Double
        result = *a\value\d
      Case #PB_Float
        result = *a\value\f
      Case #PB_Quad
        result = *a\value\q
      Case #PB_Long
        result = *a\value\l
      Case #PB_Integer
        result = *a\value\i
      Case #PB_Ascii
        result = *a\value\a
      Case #PB_Byte
        result = *a\value\b
      Case #PB_Character
        result = *a\value\c
      Case #PB_Unicode
        result = *a\value\u
      Case #PB_Word
        result = *a\value\w
      Case #PB_String, #PB_UTF16
        If *a\value\ptr
          result = ValD(PeekS(*a\value\ptr))
        EndIf
      Case #PB_UTF8
        If *a\Value\ptr
          result = ValD(PeekS(*a\value\ptr, -1, #PB_UTF8))
        EndIf
      Default
        result = (*a\value\ptr) * 1.0
    EndSelect
  EndIf
  ProcedureReturn result
EndProcedure

Procedure.q VA_Int(*this._VA_List) ; cast current variadric argument to a signed integer (quad)
  Protected *a._VArg = *this\aNext
  Protected result.q
  Protected temp$
  If *a
    *this\aNext = *a\nextArg
    Select *a\Type
      Case #PB_Double
        result = *a\value\d
      Case #PB_Float
        result = *a\value\f
      Case #PB_Quad
        result = *a\value\q
      Case #PB_Long
        result = *a\value\l
      Case #PB_Integer
        result = *a\value\i
      Case #PB_Ascii
        result = *a\value\a
      Case #PB_Byte
        result = *a\value\b
      Case #PB_Character
        result = *a\value\c
      Case #PB_Unicode
        result = *a\value\u
      Case #PB_Word
        result = *a\value\w
      Case #PB_String, #PB_UTF16
        If *a\value\ptr
          result = _strVal(*a\value\ptr)
        EndIf
      Case #PB_UTF8
        If *a\value\ptr
          temp$  = PeekS(*a\value\ptr, -1, #PB_UTF8)
          result = _strVal(@temp$)
          temp$  = #Null$
        EndIf
      Default
        result = *a\value\ptr  ;
    EndSelect
  EndIf
  ProcedureReturn result
EndProcedure

Procedure.s VA_String(*this._VA_List) ; cast current variadric argument to a string (#PB_String / must be utf16)
  Protected *a._VArg = *this\aNext
  Protected result.s
  If *a
    *this\aNext = *a\nextArg
    Select *a\Type
      Case #PB_Double
        result = StrD(*a\value\d)
      Case #PB_Float
        result = StrF(*a\value\f)
      Case #PB_Quad
        result = Str(*a\value\q)
      Case #PB_Long
        result = Str(*a\value\l)
      Case #PB_Integer
        result = Str(*a\value\i)
      Case #PB_Ascii
        result = Str(*a\value\a)
      Case #PB_Byte
        result = Str(*a\value\b)
      Case #PB_Character
        result = Str(*a\value\c)
      Case #PB_Unicode
        result = Str(*a\value\u)
      Case #PB_Word
        result = Str(*a\value\w)
      Case #PB_String
        If *a\value\ptr
          result = PeekS(*a\value\ptr)
        EndIf
      Default
        result = "0x" + RSet(LCase(Hex(*a\value\ptr)), 2*SizeOf(INTEGER), "0")
    EndSelect
  Else
    Debug "no current argument"
  EndIf
  ProcedureReturn result
EndProcedure

Procedure.i VA_Ptr(*this._VA_List) ; returns the raw pointer that was given when adding the variadric argument to the va_list
  Protected *a._VArg = *this\aNext
  If *a
    *this\aNext = *a\nextArg
    ProcedureReturn *a\Value\ptr
  EndIf
  ProcedureReturn #Null
EndProcedure

Procedure.d VA_GetReal(*this._VA_List, Name$) ; lookup Name$ argument and cast to "real" (double) value
  Protected *X._VArg
  If *this
    *X = *this\First
    While *X
      If CompareMemoryString(@*X\OptName, @Name$, *this\CompareFlag) = 0
        *this\aNext = *X
        ProcedureReturn VA_Real(*this)
      EndIf
      *X = *X\nextArg
    Wend
  EndIf
EndProcedure

Procedure.q VA_GetInt(*this._VA_List, Name$) ; lookup Name$ argument and cast to "int" (quad) value
  Protected *X._VArg
  If *this
    *X = *this\First
    While *X
      If CompareMemoryString(@*X\OptName, @Name$, *this\CompareFlag) = 0
        *this\aNext = *X
        ProcedureReturn VA_Int(*this)
      EndIf
      *X = *X\nextArg
    Wend
  EndIf
EndProcedure

Procedure.s VA_GetString(*this._VA_List, Name$) ; lookup Name$ and cast/return it's string value (as #PB_String)
  Protected *X._VArg
  If *this
    *X = *this\First
    While *X
      If CompareMemoryString(@*X\OptName, @Name$, *this\CompareFlag) = 0
        *this\aNext = *X
        ProcedureReturn VA_String(*this)
      EndIf
      *X = *X\nextArg
    Wend
  EndIf
EndProcedure

Procedure.i VA_GetPtr(*this._VA_List, Name$) ; loopup Name$ and return it's pointer value
  Protected *X._VArg
  If *this
    *X = *this\First
    While *X
      If CompareMemoryString(@*X\OptName, @Name$, *this\CompareFlag) = 0
        *this\aNext = *X
        ProcedureReturn VA_Ptr(*this)
      EndIf
      *X = *X\nextArg
    Wend
  EndIf
EndProcedure

Procedure VA_Count(*this._VA_LIST) ; returns the count of variatric arguments
  ProcedureReturn *this\Count
EndProcedure

Procedure$ VA_VersionString()
  Protected result$ = "va_list v." + Str((#VA_Version >> 24) & $FF) + "." + Str((#VA_Version >> 16) & $FF) + "." + Str((#VA_Version >> 8) & $FF)
  If #VA_Version & $FF
    result$ = result$ + " (beta " + Str(#VA_Version & $FF) + ")"
  EndIf
  ProcedureReturn result$
EndProcedure

; Be careful with auto-indentation (char 34 should remain without blanks around and no lines in the macro)
Macro _VA_DQ()
  "
EndMacro

Macro _VA_add(_VA_LIST_, _THIS_ , _NEW_NAME_ = #Null$) ; Macro doesn't work with String$ variables having $ in their name :/
  CompilerIf Not Defined(*__VA_prev, #PB_Variable)
    CompilerIf #PB_Compiler_Procedure <> #Empty$
      Protected *__VA_prev._vArg, *__VA_List._VA_list, *__NEW_VARG._VARG
    CompilerElse
      Define *__VA_prev._vArg, *__VA_List._VA_list, *__NEW_VARG._VARG
    CompilerEndIf
  CompilerEndIf
  *__VA_LIST       = _VA_LIST_
  *__VA_PREV       = *__VA_LIST\Last
  *__NEW_VARG      = AllocateMemory(SizeOf(_VARG))
  *__NEW_VARG\Type = TypeOf(_THIS_)
  
  CompilerIf _NEW_NAME_ = #Null$
    *__NEW_VARG\OptName = _VA_DQ()_THIS_"
  CompilerElse
    *__NEW_VARG\OptName = _NEW_NAME_
  CompilerEndIf
  If *__VA_PREV = #Null : *__VA_LIST\First = *__NEW_VARG : Else : *__VA_PREV\NextArg = *__NEW_VARG : EndIf
  *__VA_LIST\Count           = *__VA_LIST\Count + 1
  *__VA_LIST\Last            = *__NEW_VARG
  *__NEW_VARG\VA_FreeListArg = @_va_free_arg()
  CompilerSelect TypeOf(_THIS_)
    CompilerCase #PB_String
      *__NEW_VARG\value\ptr = AllocateMemory(StringByteLength(_THIS_))
      PokeS(*__NEW_VARG\value\ptr, _THIS_)
    CompilerCase #PB_Float
      *__NEW_VARG\value\f = _THIS_
    CompilerCase #PB_Double
      *__NEW_VARG\value\d = _THIS_
    CompilerDefault
      *__NEW_VARG\value\q = _THIS_
  CompilerEndSelect
EndMacro


; -----------------------------------------------------------------------------------
; Construction
; -----------------------------------------------------------------------------------
Procedure VA_Create(*NullOnFree.INTEGER = #Null, boolNocase = #True) ; Create a new va_list
  Protected *new._VA_LIST = AllocateMemory(SizeOf(_VA_LIST))
  If *new
    *new\RefCount          = 1
    *new\VA_FreeListStruct = @_va_free_mem()
    *new\NullThisOnFree    = *NullOnFree
    If boolNocase
      *new\CompareFlag = #PB_String_NoCase
    Else
      *new\CompareFlag = #PB_String_CaseSensitive
    EndIf
    If *NullOnFree
      *NullOnFree\i = *new
    EndIf
  EndIf
  ProcedureReturn *new
EndProcedure

; -----------------------------------------------------------------------------------
; End of va_list lib
; -----------------------------------------------------------------------------------

; -----------------------------------------------------------------------------------
; -----------------------------------------------------------------------------------
; -----------------------------------------------------------------------------------
; -----------------------------------------------------------------------------------
; -----------------------------------------------------------------------------------
; -----------------------------------------------------------------------------------
CompilerIf #PB_Compiler_IsMainFile
; -----------------------------------------------------------------------------------
; -----------------------------------------------------------------------------------
; Demo procedures using VA_List
; -----------------------------------------------------------------------------------
; -----------------------------------------------------------------------------------
; Msgbox using va_list without names
  Procedure VA_Msgbox(*VAList)
    Protected Title$
    Protected Msg$
    Protected flags
    Protected parent_id
  ; #5 Icon =}:o))
    
    If VA_Count(*VAList) < 2
      VA_End(*VAList)
      Debug "Line " + Str(#PB_Compiler_Line - 2) + ":" + #PB_Compiler_Procedure + "(): ERROR: NOT ENOUGH PARAMETERS (min 2)"
      ProcedureReturn
    ElseIf VA_Count(*VAList) > 4
      VA_End(*VAList)
      Debug "Line " + Str(#PB_Compiler_Line - 2) + ":" + #PB_Compiler_Procedure + "(): ERROR: TOO MANY PARAMETERS (max 4)"
      ProcedureReturn
    EndIf
    
    VA_Start(*VAList)
    Title$    = VA_String(*VAList)
    Msg$      = VA_String(*VAList)
    flags     = VA_Int(*VAList)
    parent_id = VA_Int(*VAList)
    VA_End(*VAList)
    
    ProcedureReturn MessageRequester(Title$, Msg$, flags, parent_id)
  EndProcedure
  
; Msgbox using names (going through argument list)
  Procedure VA_Msgbox_NamedParams(*VAList)
    Protected Title$
    Protected Msg$
    Protected flags
    Protected parent_id
  ; #5 Icon =}:o))
    If VA_Count(*VAList) < 2
      VA_End(*VAList)
      Debug "Line " + Str(#PB_Compiler_Line - 2) + ":" + #PB_Compiler_Procedure + "(): ERROR: NOT ENOUGH PARAMETERS (min 2)"
      ProcedureReturn
    ElseIf VA_Count(*VAList) > 4
      VA_End(*VAList)
      Debug "Line " + Str(#PB_Compiler_Line - 2) + ":" + #PB_Compiler_Procedure + "(): ERROR: TOO MANY PARAMETERS (max 4)"
      ProcedureReturn
    EndIf
    Protected i, c = VA_Count(*VAList)
    VA_Start(*VAList)
    While i < c
      Debug "var_arg(" + i + ")=" + VA_Name(*VAList)
      Select LCase(VA_Name(*VAList))
        Case "title$"
          Title$ = VA_String(*VAList)
        Case "text$"
          Msg$ = VA_String(*VAList)
        Case "flags"
          flags = VA_Int(*VAList)
        Case "parent"
          parent_id = VA_Int(*VAList)
      EndSelect
      i + 1
    Wend
    VA_End(*VAList)
    
    ProcedureReturn MessageRequester(Title$, Msg$, flags, parent_id)
  EndProcedure
  
; "fake" sprintf() implementation
; https://en.cppreference.com/w/c/io/fprintf
  Procedure$ VA_sprintf(Format$, *VAList)
  ;TODO:  ~90%
    
    Protected found
    Protected t$ = Format$
    Protected right
    Protected result$
    Protected *SIZE.INTEGER
    
    VA_Start(*VAList)
    
    Repeat
      found = FindString(t$, "%")
      If found
        result$ = result$ + Left(t$, found - 1)
        
        Select Mid(t$, found + 1, 1)
          Case "%"
            result$ = result$ + "%"
          Case "c"
            result$ = result$ + Chr(VA_Int(*VAList) & $FFFF)
          Case "s"
            result$ = result$ + VA_String(*VAList)
          Case "d", "i"
            result$ = result$ + Str(VA_Int(*VAList))
          Case "f", "F"
            result$ = result$ + StrD(VA_Real(*VAList) )
          Case "x"
            result$ = result$ + LCase(RSet(Hex(VA_Int(*VAList)), 4, "0"))
          Case "X"
            result$ = result$ + RSet(Hex(VA_Int(*VAList)), 4, "0")
          Case "u"
            result$ = result$ + RSet(Str(VA_Int(*VAList)), 4, "0")
          Case "p"
            result$ = result$ + "0x" + RSet(LCase(Hex(VA_Ptr(*VAList))), 2 * SizeOf(INTEGER), "0")
          Case "n"
            *SIZE = VA_Ptr(*VAList)
            If *SIZE
              *SIZE\i = Len(result$)
            EndIf
          ;
          Default
          ; ....
        EndSelect
        t$ = Mid(t$, found + 2)
        
      Else
        result$ = result$ + t$
      EndIf
    Until found = 0 Or t$ = #Empty$
    VA_End(*VAList)
    ProcedureReturn result$
  EndProcedure
  
; -----------------------------------------------------------------------------------
; #1 Demo
; -----------------------------------------------------------------------------------
; VA_Add()
; Call using VA_Add() and specifing a type (structures and types>=255 get their pointers copied)
; -----------------------------------------------------------------------------------
  Define t$  = "MsgBoxTitle: " + VA_VersionString()
  Define m$  = "This is the hello world message yes / no / cancel"
  Define fl  = #PB_MessageRequester_Info | #PB_MessageRequester_YesNoCancel
  Define fl$ = "$" + Hex(#PB_MessageRequester_Info | #PB_MessageRequester_YesNoCancel)
  Define p   = #Null
  Define *param
  
; -----------------------------------------------------------------------------------
; #2 Demo
; -----------------------------------------------------------------------------------
; Call a procedure that uses named parameters
; -----------------------------------------------------------------------------------
  *param = VA_Create(@*param)
; Add by type, the values will be copied 1:1 from the source
; Strings are copied to a new allocated memory space
  VA_Add(*param, #PB_String, @t$, "Title$") ;
  VA_Add(*param, #PB_String, @m$, "Text$")
  VA_Add(*param, #PB_String, @fl$, "Flags") ;
  VA_Add(*param, #PB_Integer, @p, "Parent")
  
; VA_Add(*param, #PB_Integer,@p) ; uncomment to test for 'too many' arguments
; *param will be destroyed by the called function
  Define result = VA_Msgbox_NamedParams(*param)
  Define so_far1
  Define so_far2
  Debug "result=" + result
  Debug "*param=" + *param
  If *param
    Debug "- the called function didn't call VA_End(), clean up..."
    VA_End(*param)
    Debug "*param=" + *param
  EndIf
  ;
  
; -----------------------------------------------------------------------------------
; #3 Demo
; -----------------------------------------------------------------------------------
; Use wrapper helper functions VA_AddString() VA_AddReal() VA_AddInt() and VA_AddPtr()
; -----------------------------------------------------------------------------------
  *param = VA_Create(@*param)
;
  VA_AddString(*param, "Hello")
  VA_AddString(*param, "World")
  VA_AddInt(*param, 123) ; Quad
  VA_AddPtr(*param, @so_far1)
  VA_AddInt(*param, 23456)
  VA_AddPtr(*param, @so_far2) ; quad/integer (will be used va_sprintf() as a return address)
  VA_AddReal(*param, #PI)     ; Double
  VA_Add(*param, #PB_VariatricArgumentList, *param, "self") ; <- MACRO test, adds itself, no good/forbidden
  
  Define re$ = VA_sprintf("Text=%s Text=%s Value1=%i checkpoint 1=%n value2=%i checkpoint2=%n PI=%F va_list=%p ", *param)
  Debug re$
  Debug "checkpoints:"
  Debug so_far1
  Debug so_far2
  Debug Left(re$, so_far1 + 1)
  Debug Mid(re$, so_far1 + 1, so_far2 - so_far1)
  Debug Mid(re$, so_far2 + 1)
  Debug "*param=" + *param
  If *param
    Debug "- the called function didn't call VA_End(), or the reference counter didn't allow it yet (perhaps the list added itself to itself) => clean up..."
    VA_End(*param)
    Debug "*param=" + *param
  EndIf
  
CompilerEndIf
Top
benubi
Enthusiast
Enthusiast
Posts: 215
Joined: Tue Mar 29, 2005 4:01 pm

Re: Homebrew variatric & named arguments

Post by benubi »

I forgot to mention:

+ implicitly you can add a VA_list to a VA_list as a parameter, meaning you can on-the-fly create data trees of va_lists.

+ va_lists can point to themselves, or contain a pointer copy to themselves ( a bit like in Lua and co with the tables )

That's why they have a "reference counter", because I thought it may happen anyways accidentally, better make it safe and a "feature" ;)
Top
moricode
Enthusiast
Enthusiast
Posts: 162
Joined: Thu May 25, 2023 3:55 am

Re: Homebrew variatric & named arguments

Post by moricode »

take a look at AutoCad ADS .dll or .arx programing , it has a impressive variable input output list between your program and AutoCad library .

[url
https://www.engr.uvic.ca/~mech410/ACAD_ ... otuial.pdf
[/url]

https://help.autodesk.com/view/OARX/20 ... x_Classes


it is most practical way to implement variable input/output argument in C/C++ / C# and event Purebasic
Top
benubi
Enthusiast
Enthusiast
Posts: 215
Joined: Tue Mar 29, 2005 4:01 pm

Re: Homebrew variatric & named arguments

Post by benubi »

Well, that seems to be an interface specifically designed for AutoCAD and co. The code/interface description you posted are specific and use their *own* types. In my version you use the predefined #PB_xyz type (e.g. #PB_Float) or simply AddStringArg() AddFloatArg() type of functions.

The va_lists I propose are not product-specific and since it's homebrew and portable it's also not dependent on the OS/Version.

I oriented towards the C/C++ standard macro names and syntax (va_start, va_end etc.) to make it easier memorizable and usable.

Here is someone who made also his own Variatric Argument lists, for very similar reasons we don't have them in PB ;) Starting at 11:32 you can see in the code that he uses the "same" method as me, which is call with a list-pointer argument; I found the video clip a few days ago and it somehow confirms that I am/was on the right track (even though I might clean up the source code and try to find ways to make it faster). I want it to be as lightweight, fast and readable/usable as possible once all necessary features/bugs have been dealt with.

https://youtu.be/S90a2_UyO5w?t=688

(I found the rest of the video is also interesting but I skip to the variatric functions list)
Top
Post Reply

Return to “Tricks 'n' Tips”