--**** 
-- == Structure manipulation routines 
-- 
-- Example: 
-- 
-- ==== C code 
-- {{{ 
--   typedef struct tagRECT {  
--     LONG left; 
--     LONG top; 
--     LONG right; 
--     LONG bottom; 
--   } RECT; 
-- 
--   RECT rctA; 
--   rctA.left = 20;   
--   rctA.top = 30;  
--   rctA.right = 180;   
--   rctA.bottom = 230; 
-- 
--   long width = rctA.right - rctA.left; 
-- }}} 
-- 
-- ==== Euphoria code 
-- <eucode> 
--   public constant 
--     RECT_left    = allot( C_LONG ), 
--     RECT_top     = allot( C_LONG ), 
--     RECT_right   = allot( C_LONG ), 
--     RECT_bottom  = allot( C_LONG ), 
--     SIZEOF_RECT  = struct() 
-- 
--   atom rctA = allocate( SIZEOF_RECT ) 
--   store( rctA, RECT_left,    20 ) 
--   store( rctA, RECT_top,     30 ) 
--   store( rctA, RECT_right,  180 ) 
--   store( rctA, RECT_bottom, 230 ) 
-- 
--   atom width = fetch( rctA, RECT_right ) - fetch( rctA, RECT_left ) 
-- </eucode> 
-- 

include std/convert.e 
include std/dll.e 
include std/machine.e 
include std/math.e 
include std/memory.e 
include std/unicode.e 

--** 
-- C type for a string pointer 
-- 
-- This allows poking/peeking a string directly to/from a pointer. 
public constant 
    C_STRING    = #04000004, 
    C_UTF8      = C_STRING 

--** 
-- C type for a unicode string pointer 
-- 
-- This allows poking/peeking a **UNICODE** string directly to/from a pointer. 
public constant 
    C_UNICODE   = #04000008, 
    C_UTF16     = C_UNICODE 

atom current_size = 0 

--** 
-- Allots a C type to a structure definition. 
-- 
-- Parameters: 
--   # ##atom## **c_type** : Any C type defined in dll.e 
--   # ##integer## **count**=1 : Number of items to repeat (default 1) 
-- 
-- Returns: 
--   Structure definition sequence: {size, sign, offset, count} 
-- 
export function allot( atom c_type, integer count=1 ) 

    integer size = and_bits( c_type, #FF ) * count 
    integer sign = right_shift( c_type, #1000000 ) 
    integer offset = current_size 

    current_size += size 

    return {size, sign, offset, count} 
end function 

--** 
-- Closes the structure definition and resets the internal counter to zero. 
-- 
-- Returns: 
--   Structure size in bytes. Pass this to allocate() when reserving memory. 
-- 
export function struct() 

    integer size = current_size 
    current_size = 0 

    return size 
end function 

--** 
-- Stores a value into a structure in memory. 
-- 
-- Parameters: 
--   # ##atom## **pointer** : Memory address of the structure. 
--   # ##sequence## **spec** : Structure specification from [[allot]](). 
--   # ##object## **val** : Value to store in memory. 
-- 
export procedure store( atom ptr, sequence spec, object val ) 

    integer size   = spec[1] 
    integer sign   = spec[2] 
    integer offset = spec[3] 
    integer count  = spec[4] 

    ptr += offset 

    if atom( val ) and count > 1 then 
        val = repeat( val, count ) 
    end if 

    if sign != 4 and sequence( val ) and length( val ) > count then 
        val = val[1..count] 
    end if 

    switch sign do 

        -- signed or unsigned 
        case 1 then 
            fallthru 
        case 2 then 

            switch size do 
                case 1 then -- C_CHAR, C_UCHAR 
                    poke( ptr, val ) 
                case 2 then -- C_SHORT, C_USHORT 
                    poke2( ptr, val ) 
                case 4 then -- C_INT, C_LONG, C_UINT, C_ULONG, C_POINTER 
                    poke4( ptr, val ) 
            end switch 

        -- floating-point 
        case 3 then 

            switch size do 
                case 4 then -- C_FLOAT 
                    poke( ptr, atom_to_float32(val) ) 
                case 8 then -- C_DOUBLE 
                    poke( ptr, atom_to_float64(val) ) 
            end switch 

        -- string pointer 
        case 4 then 

            switch size do 
                case 4 then -- C_STRING, C_UTF8 
                    poke4( ptr, allocate_string(val) ) 
                case 8 then -- C_UNICODE, C_UTF16 
                    poke4( ptr, allocate_wstring(val) ) 
            end switch 

        -- unsupported 
        case else 
            -- do nothing 

    end switch 

end procedure 

--** 
-- Fetches a value from a structure in memory. 
-- 
-- Parameters: 
--   # ##atom## **pointer** : Memory address of the structure. 
--   # ##sequence## **spec** : Structure specification from [[allot]](). 
-- 
-- Returns: 
--   Value stored in memory. 
-- 
export function fetch( object ptr, sequence spec ) 

    integer size   = spec[1] 
    integer sign   = spec[2] 
    integer offset = spec[3] 
    integer count  = spec[4] 

    ptr += offset 
    if count > 1 then 
        ptr = {ptr, count} 
    end if 
     
    object val = NULL 

    switch sign do 

        -- signed 
        case 1 then 

            switch size do 
                case 1 then -- C_CHAR 
                    val = peek( ptr ) - 128 
                case 2 then -- C_SHORT 
                    val = peek2s( ptr ) 
                case 4 then -- C_INT, C_LONG 
                    val = peek4s( ptr ) 
            end switch 

        -- unsigned 
        case 2 then 

            switch size do 
                case 1 then -- C_UCHAR 
                    val = peek( ptr ) 
                case 2 then -- C_USHORT 
                    val = peek2u( ptr ) 
                case 3 then -- C_UINT, C_ULONG, C_POINTER 
                    val = peek4u( ptr ) 
            end switch 

        -- floating-point 
        case 3 then 
             
            switch size do 
                case 4 then -- C_FLOAT 
                    val = float32_to_atom( peek({ptr, 4}) ) 
                case 8 then -- C_DOUBLE 
                    val = float64_to_atom( peek({ptr, 8}) ) 
            end switch 
             
        -- string pointer 
        case 4 then 

            switch size do 
                case 4 then -- C_STRING, C_UTF8 
                    val = peek_string( peek4u(ptr) ) 
                case 8 then -- C_UNICODE, C_UTF16 
                    val = peek_wstring( peek4u(ptr) ) 
            end switch 

        -- unsupported 
        case else 
            -- do nothing 

    end switch 

    return val 
end function