|
Lhogho
0.0.027
|
| #define EXTERNAPI __attribute__((used,noinline,regparm(0),stdcall)) |
| #define C_TYPES 17 |
| #define GET_NEXT_TYPE prototype = CDR( prototype ) |
| #define GET_NEXT_DATA protodata = CDR( protodata ) |
| atom_t EXTERNAPI i1_to_atom | ( | signed char | data | ) |
{ RETURN(new_integer( data )); }
| atom_t EXTERNAPI i2_to_atom | ( | signed short | data | ) |
{ RETURN(new_integer( data )); }
| atom_t EXTERNAPI i4_to_atom | ( | signed int | data | ) |
{ RETURN(new_integer( data )); }
| atom_t EXTERNAPI i8_to_atom | ( | int64_t | data | ) |
{ RETURN(new_integer( data )); }
| atom_t EXTERNAPI u1_to_atom | ( | unsigned char | data | ) |
{ RETURN(new_integer( data )); }
| atom_t EXTERNAPI u2_to_atom | ( | unsigned short | data | ) |
{ RETURN(new_integer( data )); }
| atom_t EXTERNAPI u4_to_atom | ( | unsigned int | data | ) |
{ RETURN(new_integer( data )); }
| atom_t EXTERNAPI u8_to_atom | ( | int64_t | data | ) |
{ RETURN(new_integer( data )); }
| atom_t EXTERNAPI f4_to_atom | ( | float | data | ) |
| atom_t EXTERNAPI p4_to_atom | ( | void * | data | ) |
{ RETURN(new_integer( (int)data )); }
| atom_t EXTERNAPI s2_to_atom | ( | chars_t | data | ) |
| atom_t EXTERNAPI s1_to_atom | ( | char * | data | ) |
{
RETURN(new_word(ASCII_to_UTF16 (data), -1));
}
| signed char EXTERNAPI atom_to_i1 | ( | atom_t | data | ) |
{ int64_t i; atom_to_int( data, &i ); return i; }
| signed short EXTERNAPI atom_to_i2 | ( | atom_t | data | ) |
{ int64_t i; atom_to_int( data, &i ); return i; }
| signed int EXTERNAPI atom_to_i4 | ( | atom_t | data | ) |
{ int64_t i; atom_to_int( data, &i ); return i; }
| int64_t EXTERNAPI atom_to_i8 | ( | atom_t | data | ) |
{ int64_t i; atom_to_int( data, &i ); return i; }
| unsigned char EXTERNAPI atom_to_u1 | ( | atom_t | data | ) |
{ int64_t i; atom_to_int( data, &i ); return i; }
| unsigned short EXTERNAPI atom_to_u2 | ( | atom_t | data | ) |
{ int64_t i; atom_to_int( data, &i ); return i; }
| unsigned int EXTERNAPI atom_to_u4 | ( | atom_t | data | ) |
{ int64_t i; atom_to_int( data, &i ); return i; }
| int64_t EXTERNAPI atom_to_u8 | ( | atom_t | data | ) |
{ int64_t i; atom_to_int( data, &i ); return i; }
| float EXTERNAPI atom_to_f4 | ( | atom_t | data | ) |
{ float64_t i; atom_to_float( data, &i ); return i; }
| float64_t EXTERNAPI atom_to_f8 | ( | atom_t | data | ) |
{ float64_t i; atom_to_float( data, &i ); return i; }
| void EXTERNAPI atom_to_v0 | ( | atom_t | data | ) |
{ return; }
| void* EXTERNAPI atom_to_p4 | ( | atom_t | data | ) |
{
if( IS_MEM(data) )
{
return MEMORY(data);
};
int64_t i;
atom_to_int( data, &i );
return (void*)((int)i);
}
| atom_t unique_word | ( | atom_t | data | ) |
{
if( IS_SUBWORD(data) ) data = new_word( STRING(data), LENGTH(data) );
if( !IS_WORD(data) ) data = atom_to_word( data );
if( !IS_WORD(data) ) data = new_word( TEXT(""), -1 );
return USE(data);
}
| chars_t EXTERNAPI atom_to_s2 | ( | atom_t | data | ) |
{
data = unique_word( data );
delayed_free = new_list( data, delayed_free );
return STRING(data);
}
| char* EXTERNAPI atom_to_s1 | ( | atom_t | data | ) |
{
data = unique_word( data );
char* c = UTF16_to_ASCII( STRING(data) );
DEUSE( data );
data = new_mem( 0 );
DEALLOC( MEMORY(data) );
MEMORY(data) = c;
delayed_free = new_list( data, delayed_free );
return c;
}
| type | word containing type name |
Examines the value of type which must be a 2-character word. Returns an index of the type which can be used with array c c_types[] to get more details.
{
if( IS_LIST(type) ) return C_TYPE_STRUCT;
#ifdef SAFE_MODE
assert( IS_ANY_WORD(type) );
#endif
// check whether the word is: i1 i2 i4 i8 u1 u2 u4 u8 f4 f8 v0 p4 a4 s1 s2
if( LENGTH(type)==2 )
{
char_t ch1 = TOUPPER(*(STRING(type)));
char_t ch2 = *(STRING(type)+1);
int i;
for( i=2; i<C_TYPES; i++ ) // skip 0-th and 1-st elements
{
//printf("compare index=%d %C %C\n",i,*c_types[i].name,*(c_types[i].name+1));
if( ch1==*c_types[i].name && ch2==*(c_types[i].name+1) )
{
//printf("type_info("); dump(type); printf(")=%d\n",i);
return i;
}
}
}
//printf("type_info("); dump(type); printf(")=0\n");
return C_TYPE_UNKNOWN;
}
| atom_t type_value | ( | int | static_link, |
| atom_t | parent, | ||
| atom_t | type | ||
| ) |
| static_link | static link from the current frame |
| parent | current parent |
| type | word containing type name |
Assumes that type is a name of a type variable and returns its value. If it is not a variable or has no value then return unbound atom.
{
atom_t var = find_runtime_var( type, static_link );
// not found or not a var then exit
if( !var || !IS_VARIABLE( var ) ) return unbound;
// get the value and try again to calculate type size
if( IS_RUNTIME( var ) )
return VALUE( var );
else
return rt_var_value( static_link, parent, var );
}
| int get_c_type | ( | int | static_link, |
| atom_t | parent, | ||
| atom_t | type | ||
| ) |
| static_link | static link from the current frame |
| parent | current parent |
| type | word containing type name |
This function finds the C-type index of a type. This index can be used with c_types[] array to get additional information about the C-type.
This function does not recurse into struct types.
{
int c_type;
try_again:
c_type = type_info( type );
if( c_type==C_TYPE_UNKNOWN )
{
type = type_value( static_link, parent, type );
if( IS_UNBOUND(type) ) return C_TYPE_UNKNOWN;
goto try_again;
}
return c_type;
}
| atom_t traverse_pack | ( | int | static_link, |
| atom_t | parent, | ||
| atom_t | prototype, | ||
| atom_t | protodata, | ||
| char * | ptr, | ||
| int | mode | ||
| ) |
| static_link | static link from the current frame |
| parent | current parent |
| prototype | list describing the c-type in the pack |
| protodata | list containing the Logo data |
| ptr | pointer to memory with C data |
| mode | mode of traversal |
This function traverses a structure defined by c-type prototype and performs an action determined by mode.
If mode is MEM_STRUCT_SIZE then only the size of the packed data is calculated. Parameters protodata and ptr are not used. The returned value is an integer atom containing the size.
If mode is MEM_STRUCT_PACK then Logo data from protodata is packed into the memory pointed to by ptr using the structure described in prototype. The result is unbound atom.
If mode is MEM_STRUCT_UNPACK then packed data from ptr is unpacked into a list of Logo data using the structure described in prototype . The result of traverse_pack is the list of Logo data.
{
int ofs = 0;
atom_t new_type;
atom_t traverse( atom_t prototype, atom_t protodata )
{
atom_t result = unbound;
atom_t result_end;
// check prototype list
if (IS_ERROR( prototype )) return prototype;
if (!IS_LIST( prototype )) return new_error( ERROR_NOT_A_LIST, prototype );
// check data list
if (IS_ERROR( protodata )) return protodata;
if (!IS_LIST( protodata )) return new_error( ERROR_NOT_A_LIST, protodata );
if( mode==MEM_STRUCT_UNPACK )
{
result = empty_list;
result_end = empty_list;
}
int count = 1;
#define GET_NEXT_TYPE prototype = CDR( prototype )
#define GET_NEXT_DATA protodata = CDR( protodata )
// scan all elements of the prototype
for (; IS_NOT_EMPTY( prototype ); )
{
atom_t type = CAR( prototype );
atom_t data = CAR( protodata );
try_again:
// list prototypes are processed recursively
if( IS_LIST(type) )
{
atom_t res = traverse( type, data );
if( IS_ERROR(res) ) return res;
if( mode==MEM_STRUCT_UNPACK ) append( res, &result, &result_end );
goto to_continue;
}
// other non-word prototypes are not accepted
if( IS_INTEGER(type) || IS_FLOAT(type) ) goto its_a_number;
if( !IS_ANY_WORD(type) ) return new_error(ERROR_NOT_A_TYPE_NAME,type);
int type_id = type_info( type );
int type_size = c_types[type_id].size;
switch( c_types[type_id].class )
{
case C_TYPE_POINTER:
{
int64_t i = 0;
if( mode==MEM_STRUCT_PACK )
{
if( !IS_EMPTY( data ) )
{
if( IS_MEM(data) )
i = (int)MEMORY(data);
else
GET_INT( data, i );
}
*(int*)(ptr+ofs) = (int)i;
}
if( mode==MEM_STRUCT_UNPACK )
{
i = *(int*)(ptr+ofs);
append( new_integer(i), &result, &result_end );
}
ofs += type_size/8;
goto to_continue;
}
case C_TYPE_ATOM:
{
atom_t i = 0;
if( mode==MEM_STRUCT_PACK )
{
break;
}
if( mode==MEM_STRUCT_UNPACK )
{
i = *(atom_t*)(ptr+ofs);
append( USE(i), &result, &result_end );
}
ofs += type_size/8;
goto to_continue;
}
case C_TYPE_FLOAT:
{
float64_t i = 0;
if( mode==MEM_STRUCT_PACK )
{
if( !IS_EMPTY( data ) ) GET_FLOAT( data, i );
switch( type_size )
{
case 32: *(float32_t*)(ptr+ofs) = i; break;
case 64: *(float64_t*)(ptr+ofs) = i; break;
default: goto subtype_test;
}
}
if( mode==MEM_STRUCT_UNPACK )
{
switch( type_size )
{
case 32: i = *(float32_t*)(ptr+ofs); break;
case 64: i = *(float64_t*)(ptr+ofs); break;
default: goto subtype_test;
}
append( new_float(i), &result, &result_end );
}
ofs += type_size/8;
goto to_continue;
}
case C_TYPE_SIGNED:
{
int64_t i = 0;
if( mode==MEM_STRUCT_PACK )
{
if( !IS_EMPTY( data ) ) GET_INT( data, i );
switch( type_size )
{
case 8: *(int8_t*) (ptr+ofs) = i; break;
case 16: *(int16_t*)(ptr+ofs) = i; break;
case 32: *(int32_t*)(ptr+ofs) = i; break;
case 64: *(int64_t*)(ptr+ofs) = i; break;
default: goto subtype_test;
}
}
if( mode==MEM_STRUCT_UNPACK )
{
switch( type_size )
{
case 8: i = *(int8_t*) (ptr+ofs); break;
case 16: i = *(int16_t*)(ptr+ofs); break;
case 32: i = *(int32_t*)(ptr+ofs); break;
case 64: i = *(int64_t*)(ptr+ofs); break;
default: goto subtype_test;
}
append( new_integer(i), &result, &result_end );
}
ofs += type_size/8;
goto to_continue;
}
case C_TYPE_UNSIGNED:
{
int64_t i = 0;
if( mode==MEM_STRUCT_PACK )
{
if( !IS_EMPTY( data ) ) GET_INT( data, i );\
switch( type_size )
{
case 8: *(uint8_t*) (ptr+ofs) = i; break;
case 16: *(uint16_t*)(ptr+ofs) = i; break;
case 32: *(uint32_t*)(ptr+ofs) = i; break;
case 64: *(uint64_t*)(ptr+ofs) = i; break;
default: goto subtype_test;
}
}
if( mode==MEM_STRUCT_UNPACK )
{
switch( type_size )
{
case 8: i = *(uint8_t*) (ptr+ofs); break;
case 16: i = *(uint16_t*)(ptr+ofs); break;
case 32: i = *(uint32_t*)(ptr+ofs); break;
case 64: i = *(uint64_t*)(ptr+ofs); break;
default: goto subtype_test;
}
append( new_integer(i), &result, &result_end );
}
ofs += type_size/8;
goto to_continue;
}
}
subtype_test:
new_type = type_value( static_link, parent, type );
if( IS_UNBOUND(new_type) )
{
its_a_number:
if( atom_to_integer( type, &count ) )
{
GET_NEXT_TYPE;
continue;
}
return USE(new_error( ERROR_NOT_A_TYPE_NAME, type ));
}
type = new_type;
goto try_again;
to_continue:
count--;
if( !count )
{
count = 1;
GET_NEXT_TYPE;
}
GET_NEXT_DATA;
} //for
return result ;
}
atom_t res = traverse( prototype, protodata );
if( IS_ERROR(res) ) return res;
// if there is no target pointer, then just return the size
if( mode==MEM_STRUCT_SIZE ) return new_integer( ofs );
return res;
}
{
{ TEXT(""), 0, C_TYPE_UNKNOWN, 0, 0, TEXT(""), TEXT("") },
{ TEXT(""), 0, C_TYPE_STRUCT, 0, 0, TEXT(""), TEXT("") },
{ TEXT("I1"), 8, C_TYPE_SIGNED, (fn)i1_to_atom, (fn)atom_to_i1, TEXT("i1_to_atom"), TEXT("atom_to_i1") },
{ TEXT("I2"), 16, C_TYPE_SIGNED, (fn)i2_to_atom, (fn)atom_to_i2, TEXT("i2_to_atom"), TEXT("atom_to_i2") },
{ TEXT("I4"), 32, C_TYPE_SIGNED, (fn)i4_to_atom, (fn)atom_to_i4, TEXT("i4_to_atom"), TEXT("atom_to_i4") },
{ TEXT("I8"), 64, C_TYPE_SIGNED, (fn)i8_to_atom, (fn)atom_to_i8, TEXT("i8_to_atom"), TEXT("atom_to_i8") },
{ TEXT("U1"), 8, C_TYPE_UNSIGNED, (fn)u1_to_atom, (fn)atom_to_u1, TEXT("u1_to_atom"), TEXT("atom_to_u1") },
{ TEXT("U2"), 16, C_TYPE_UNSIGNED, (fn)u2_to_atom, (fn)atom_to_u2, TEXT("u2_to_atom"), TEXT("atom_to_u2") },
{ TEXT("U4"), 32, C_TYPE_UNSIGNED, (fn)u4_to_atom, (fn)atom_to_u4, TEXT("u4_to_atom"), TEXT("atom_to_u4") },
{ TEXT("U8"), 64, C_TYPE_UNSIGNED, (fn)u8_to_atom, (fn)atom_to_u8, TEXT("u8_to_atom"), TEXT("atom_to_u8") },
{ TEXT("F4"), 32, C_TYPE_FLOAT, (fn)f4_to_atom, (fn)atom_to_f4, TEXT("f4_to_atom"), TEXT("atom_to_f4") },
{ TEXT("F8"), 64, C_TYPE_FLOAT, (fn)f8_to_atom, (fn)atom_to_f8, TEXT("f8_to_atom"), TEXT("atom_to_f8") },
{ TEXT("V0"), 0, C_TYPE_VOID, (fn)v0_to_atom, (fn)atom_to_v0, TEXT("v0_to_atom"), TEXT("atom_to_v0") },
{ TEXT("P4"), 32, C_TYPE_POINTER, (fn)p4_to_atom, (fn)atom_to_p4, TEXT("p4_to_atom"), TEXT("atom_to_p4") },
{ TEXT("A4"), 32, C_TYPE_ATOM, (fn)NULL, (fn)NULL, TEXT(""), TEXT("") },
{ TEXT("S1"), 32, C_TYPE_STRING, (fn)s1_to_atom, (fn)atom_to_s1, TEXT("s1_to_atom"), TEXT("atom_to_s1") },
{ TEXT("S2"), 32, C_TYPE_STRING, (fn)s2_to_atom, (fn)atom_to_s2, TEXT("s2_to_atom"), TEXT("atom_to_s2") },
}