Lhogho  0.0.028
 All Data Structures Files Functions Variables Typedefs Macros Pages
external.c
Go to the documentation of this file.
1 //
2 // Project: Lhogho
3 // File: external.c
4 //
5 // Copyright (C) 2008 P.Boytchev
6 //
7 // Revision history:
8 // 2008-09-14 - File created
9 // 2012-01-01 - Support for A4 type
10 // 2012-01-12 - Fixed bug #3470258 Crash with commandline but not with literal
11 // 2012-01-15 - Fixed bug #3473209 Assertion failure when unsupported type used in pack
12 // 2012-02-05 - Support for type repetitions
13 // 2012-02-26 - Fixed bug #3493842 Memory leak in glfwSetWindowTitle
14 //
15 //
16 // This program is free software; you can redistribute it and/or modify
17 // it under the terms of the GNU General Public License as published by
18 // the Free Software Foundation; either version 2 of the License, or
19 // (at your option) any later version.
20 //
21 // This program is distributed in the hope that it will be useful,
22 // but WITHOUT ANY WARRANTY; without even the implied warranty of
23 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 // GNU General Public License for more details.
25 //
26 // You should have received a copy of the GNU General Public License
27 // along with this program; if not, write to the Free Software
28 // Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
29 //
30 
31 
32 #ifdef WINDOWS
33 #include <windows.h>
34 #include <mmsystem.h>
35 #undef TEXT
36 #undef IS_ERROR
37 #define dlopen(a,b) LoadLibrary(a)
38 #define dlclose(a) FreeLibrary(a)
39 #define dlsym(h,a) GetProcAddress(h,a)
40 #else
41 #include <dlfcn.h>
42 #endif
43 
44 #include "globals.h"
45 #ifdef UNICODE_CHARS
46 #include <wctype.h>
47 #include <wchar.h> // STRCHR (i.e. wcsstr)
48 #endif
49 
50 #include "atoms.h"
51 #include "words.h"
52 #include "numbers.h"
53 #include "mems.h"
54 #include "vars.h"
55 #include "unicode.h"
56 #include "external.h"
57 #include "runtime.h"
58 #include "options.h"
59 
60 
61 #define EXTERNAPI __attribute__((used,noinline,regparm(0),stdcall))
62 
63 
64 
65 // converters C->Lhogho
66 atom_t EXTERNAPI i1_to_atom( signed char data ) { RETURN(new_integer( data )); }
67 atom_t EXTERNAPI i2_to_atom( signed short data ) { RETURN(new_integer( data )); }
68 atom_t EXTERNAPI i4_to_atom( signed int data ) { RETURN(new_integer( data )); }
69 atom_t EXTERNAPI i8_to_atom( int64_t data ) { RETURN(new_integer( data )); }
70 
71 atom_t EXTERNAPI u1_to_atom( unsigned char data ) { RETURN(new_integer( data )); }
72 atom_t EXTERNAPI u2_to_atom( unsigned short data ) { RETURN(new_integer( data )); }
73 atom_t EXTERNAPI u4_to_atom( unsigned int data ) { RETURN(new_integer( data )); }
74 atom_t EXTERNAPI u8_to_atom( int64_t data ) { RETURN(new_integer( data )); }
75 
76 atom_t EXTERNAPI f4_to_atom( float data ) { RETURN(new_float( data )); }
78 
80 atom_t EXTERNAPI p4_to_atom( void* data ) { RETURN(new_integer( (int)data )); }
81 atom_t EXTERNAPI a4_to_atom( atom_t data ) { /*printf("@<:%d::",(int)data); dump_atom(data,1); printf(":>@\n");*/ RETURN(data);}
82 
83 
84 #ifdef UNICODE_CHARS
86 {
87  int len = STRLEN( data );
88  chars_t w = ALLOC((len+1)*CHAR_SIZE);
89  memcpy( w, data, (len+1)*CHAR_SIZE);
90  RETURN(new_word( w, len ));
91 }
93 {
94  RETURN(new_word(ASCII_to_UTF16 (data), -1));
95 }
96 #else
98 {
99  int len = STRLEN( data );
100  chars_t w = MALLOC((len+1)*CHAR_SIZE);
101  memcpy( w, data, (len+1)*CHAR_SIZE);
102  RETURN(new_word( w, len ));
103 }
104 #endif
105 
106 
107 // converters Lhogho->C
108 signed char EXTERNAPI atom_to_i1( atom_t data ) { int64_t i; atom_to_int( data, &i ); return i; }
109 signed short EXTERNAPI atom_to_i2( atom_t data ) { int64_t i; atom_to_int( data, &i ); return i; }
110 signed int EXTERNAPI atom_to_i4( atom_t data ) { int64_t i; atom_to_int( data, &i ); return i; }
111 int64_t EXTERNAPI atom_to_i8( atom_t data ) { int64_t i; atom_to_int( data, &i ); return i; }
112 
113 unsigned char EXTERNAPI atom_to_u1( atom_t data ) { int64_t i; atom_to_int( data, &i ); return i; }
114 unsigned short EXTERNAPI atom_to_u2( atom_t data ) { int64_t i; atom_to_int( data, &i ); return i; }
115 unsigned int EXTERNAPI atom_to_u4( atom_t data ) { int64_t i; atom_to_int( data, &i ); return i; }
116 int64_t EXTERNAPI atom_to_u8( atom_t data ) { int64_t i; atom_to_int( data, &i ); return i; }
117 
118 float EXTERNAPI atom_to_f4( atom_t data ) { float64_t i; atom_to_float( data, &i ); return i; }
119 float64_t EXTERNAPI atom_to_f8( atom_t data ) { float64_t i; atom_to_float( data, &i ); return i; }
120 
121 void EXTERNAPI atom_to_v0( atom_t data ) { return; }
122 
123 atom_t EXTERNAPI atom_to_a4( atom_t data ) {/*printf("&[[;;%d;;]]\n",(int)data);*/ return data;}
124 
125 void* EXTERNAPI atom_to_p4( atom_t data ) {
126  if( IS_MEM(data) )
127  {
128  return MEMORY(data);
129  };
130  int64_t i;
131  atom_to_int( data, &i );
132  return (void*)((int)i);
133  }
134 
135 
137 {
138  if( IS_SUBWORD(data) ) return new_word( STRING(data), LENGTH(data) );
139  if( !IS_WORD(data) ) return atom_to_word( data );
140  if( !IS_WORD(data) ) return new_word( TEXT(""), -1 );
141  return USE(data);
142 }
143 
144 #ifdef UNICODE_CHARS
146 {
147  data = unique_word( data );
149  return STRING(data);
150 }
152 {
153  data = unique_word( data );
154 
155  char* c = UTF16_to_ASCII( STRING(data) );
156  DEUSE( data );
157 
158  data = new_mem( 0 );
159  DEALLOC( MEMORY(data) );
160  MEMORY(data) = c;
161 
163 
164  return c;
165 }
166 #else
167 chars_t* EXTERNAL atom_to_s1( atom_t data )
168 {
169  data = unique_word( data );
171  return STRING(data);
172 }
173 #endif
174 
175 #ifdef UNICODE_CHARS
176 #define C_TYPES 17
177 #else
178 #define C_TYPES 16
179 #endif
180 
182 {
183  { TEXT(""), 0, C_TYPE_UNKNOWN, 0, 0, TEXT(""), TEXT("") }, // must be at index 0 (==C_TYPE_UNKNOWN)
184  { TEXT(""), 0, C_TYPE_STRUCT, 0, 0, TEXT(""), TEXT("") }, // must be at index 1 (==C_TYPE_STRUCT)
185  { TEXT("I1"), 8, C_TYPE_SIGNED, (fn)i1_to_atom, (fn)atom_to_i1, TEXT("i1_to_atom"), TEXT("atom_to_i1") },
186  { TEXT("I2"), 16, C_TYPE_SIGNED, (fn)i2_to_atom, (fn)atom_to_i2, TEXT("i2_to_atom"), TEXT("atom_to_i2") },
187  { TEXT("I4"), 32, C_TYPE_SIGNED, (fn)i4_to_atom, (fn)atom_to_i4, TEXT("i4_to_atom"), TEXT("atom_to_i4") },
188  { TEXT("I8"), 64, C_TYPE_SIGNED, (fn)i8_to_atom, (fn)atom_to_i8, TEXT("i8_to_atom"), TEXT("atom_to_i8") },
189  { TEXT("U1"), 8, C_TYPE_UNSIGNED, (fn)u1_to_atom, (fn)atom_to_u1, TEXT("u1_to_atom"), TEXT("atom_to_u1") },
190  { TEXT("U2"), 16, C_TYPE_UNSIGNED, (fn)u2_to_atom, (fn)atom_to_u2, TEXT("u2_to_atom"), TEXT("atom_to_u2") },
191  { TEXT("U4"), 32, C_TYPE_UNSIGNED, (fn)u4_to_atom, (fn)atom_to_u4, TEXT("u4_to_atom"), TEXT("atom_to_u4") },
192  { TEXT("U8"), 64, C_TYPE_UNSIGNED, (fn)u8_to_atom, (fn)atom_to_u8, TEXT("u8_to_atom"), TEXT("atom_to_u8") },
193  { TEXT("F4"), 32, C_TYPE_FLOAT, (fn)f4_to_atom, (fn)atom_to_f4, TEXT("f4_to_atom"), TEXT("atom_to_f4") },
194  { TEXT("F8"), 64, C_TYPE_FLOAT, (fn)f8_to_atom, (fn)atom_to_f8, TEXT("f8_to_atom"), TEXT("atom_to_f8") },
195  { TEXT("V0"), 0, C_TYPE_VOID, (fn)v0_to_atom, (fn)atom_to_v0, TEXT("v0_to_atom"), TEXT("atom_to_v0") },
196  { TEXT("P4"), 32, C_TYPE_POINTER, (fn)p4_to_atom, (fn)atom_to_p4, TEXT("p4_to_atom"), TEXT("atom_to_p4") },
197  { TEXT("A4"), 32, C_TYPE_ATOM, (fn)a4_to_atom, (fn)atom_to_a4, TEXT("a4_to_atom"), TEXT("atom_to_a4") },
198  { TEXT("S1"), 32, C_TYPE_STRING, (fn)s1_to_atom, (fn)atom_to_s1, TEXT("s1_to_atom"), TEXT("atom_to_s1") },
199 #ifdef UNICODE_CHARS
200  { TEXT("S2"), 32, C_TYPE_STRING, (fn)s2_to_atom, (fn)atom_to_s2, TEXT("s2_to_atom"), TEXT("atom_to_s2") },
201 #endif
202 };
203 
204 
205 
206 
207 
208 
209 
210 //===================================================
220 //===================================================
221 int type_info( atom_t type )
222 {
223  if( IS_LIST(type) ) return C_TYPE_STRUCT;
224 
225 #ifdef SAFE_MODE
226  assert( IS_ANY_WORD(type) );
227 #endif
228 
229  // check whether the word is: i1 i2 i4 i8 u1 u2 u4 u8 f4 f8 v0 p4 a4 s1 s2
230  if( LENGTH(type)==2 )
231  {
232  char_t ch1 = TOUPPER(*(STRING(type)));
233  char_t ch2 = *(STRING(type)+1);
234  int i;
235  for( i=2; i<C_TYPES; i++ ) // skip 0-th and 1-st elements
236  {
237  //printf("compare index=%d %C %C\n",i,*c_types[i].name,*(c_types[i].name+1));
238  if( ch1==*c_types[i].name && ch2==*(c_types[i].name+1) )
239  {
240  //printf("type_info("); dump(type); printf(")=%d\n",i);
241  return i;
242  }
243  }
244  }
245 
246  //printf("type_info("); dump(type); printf(")=0\n");
247  return C_TYPE_UNKNOWN;
248 }
249 
250 
251 
252 //===================================================
263 //===================================================
264 atom_t type_value( int static_link, atom_t parent, atom_t type )
265 {
266  atom_t var = find_runtime_var( type, static_link );
267 
268  // not found or not a var then exit
269  if( !var || !IS_VARIABLE( var ) ) return unbound;
270 
271  // get the value and try again to calculate type size
272  if( IS_RUNTIME( var ) )
273  return VALUE( var );
274  else
275  return rt_var_value( static_link, parent, var );
276 }
277 
278 
279 
280 
281 
282 //===================================================
295 //===================================================
296 int get_c_type( int static_link, atom_t parent, atom_t type )
297 {
298  int c_type;
299 
300 try_again:
301  c_type = type_info( type );
302  if( c_type==C_TYPE_UNKNOWN )
303  {
304  type = type_value( static_link, parent, type );
305  if( IS_UNBOUND(type) ) return C_TYPE_UNKNOWN;
306  goto try_again;
307  }
308  return c_type;
309 }
310 
311 
312 
313 //===================================================
345 //===================================================
346 
347 atom_t traverse_pack( int static_link, atom_t parent, atom_t prototype, atom_t protodata, char* ptr, int mode )
348 {
349  int ofs = 0;
350  atom_t new_type;
351 
352  atom_t traverse( atom_t prototype, atom_t protodata )
353  {
354  atom_t result = unbound;
355  atom_t result_end;
356 
357  // check prototype list
358  if (IS_ERROR( prototype )) return prototype;
359  if (!IS_LIST( prototype )) return new_error( ERROR_NOT_A_LIST, prototype );
360 
361  // check data list
362  if (IS_ERROR( protodata )) return protodata;
363  if (!IS_LIST( protodata )) return new_error( ERROR_NOT_A_LIST, protodata );
364 
365  if( mode==MEM_STRUCT_UNPACK )
366  {
367  result = empty_list;
368  result_end = empty_list;
369  }
370 
371  int count = 1;
372 
373 #define GET_NEXT_TYPE prototype = CDR( prototype )
374 #define GET_NEXT_DATA protodata = CDR( protodata )
375 
376  // scan all elements of the prototype
377  for (; IS_NOT_EMPTY( prototype ); )
378  {
379  atom_t type = CAR( prototype );
380  atom_t data = CAR( protodata );
381 
382 try_again:
383 
384  // list prototypes are processed recursively
385  if( IS_LIST(type) )
386  {
387  atom_t res = traverse( type, data );
388  if( IS_ERROR(res) ) return res;
389  if( mode==MEM_STRUCT_UNPACK ) append( res, &result, &result_end );
390  goto to_continue;
391  }
392 
393  // other non-word prototypes are not accepted
394  if( IS_INTEGER(type) || IS_FLOAT(type) ) goto its_a_number;
395  if( !IS_ANY_WORD(type) ) return new_error(ERROR_NOT_A_TYPE_NAME,type);
396 
397  int type_id = type_info( type );
398  int type_size = c_types[type_id].size;
399 
400  switch( c_types[type_id].class )
401  {
402  case C_TYPE_POINTER:
403  {
404  int64_t i = 0;
405  if( mode==MEM_STRUCT_PACK )
406  {
407  if( !IS_EMPTY( data ) )
408  {
409  if( IS_MEM(data) )
410  i = (int)MEMORY(data);
411  else
412  GET_INT( data, i );
413  }
414  *(int*)(ptr+ofs) = (int)i;
415  }
416  if( mode==MEM_STRUCT_UNPACK )
417  {
418  i = *(int*)(ptr+ofs);
419  append( new_integer(i), &result, &result_end );
420  }
421  ofs += type_size/8;
422  goto to_continue;
423  }
424  case C_TYPE_ATOM:
425  {
426  atom_t i = 0;
427  if( mode==MEM_STRUCT_PACK )
428  {
429  //*(atom_t*)(ptr+ofs) = data;
430  break;
431  }
432  if( mode==MEM_STRUCT_UNPACK )
433  {
434  i = *(atom_t*)(ptr+ofs);
435  append( USE(i), &result, &result_end );
436  }
437  ofs += type_size/8;
438  goto to_continue;
439  }
440  case C_TYPE_FLOAT:
441  {
442  float64_t i = 0;
443  if( mode==MEM_STRUCT_PACK )
444  {
445  if( !IS_EMPTY( data ) ) GET_FLOAT( data, i );
446  switch( type_size )
447  {
448  case 32: *(float32_t*)(ptr+ofs) = i; break;
449  case 64: *(float64_t*)(ptr+ofs) = i; break;
450  default: goto subtype_test;
451  }
452  }
453  if( mode==MEM_STRUCT_UNPACK )
454  {
455  switch( type_size )
456  {
457  case 32: i = *(float32_t*)(ptr+ofs); break;
458  case 64: i = *(float64_t*)(ptr+ofs); break;
459  default: goto subtype_test;
460  }
461  append( new_float(i), &result, &result_end );
462  }
463  ofs += type_size/8;
464  goto to_continue;
465  }
466 
467  case C_TYPE_SIGNED:
468  {
469  int64_t i = 0;
470  if( mode==MEM_STRUCT_PACK )
471  {
472  if( !IS_EMPTY( data ) ) GET_INT( data, i );
473  switch( type_size )
474  {
475  case 8: *(int8_t*) (ptr+ofs) = i; break;
476  case 16: *(int16_t*)(ptr+ofs) = i; break;
477  case 32: *(int32_t*)(ptr+ofs) = i; break;
478  case 64: *(int64_t*)(ptr+ofs) = i; break;
479  default: goto subtype_test;
480  }
481  }
482  if( mode==MEM_STRUCT_UNPACK )
483  {
484  switch( type_size )
485  {
486  case 8: i = *(int8_t*) (ptr+ofs); break;
487  case 16: i = *(int16_t*)(ptr+ofs); break;
488  case 32: i = *(int32_t*)(ptr+ofs); break;
489  case 64: i = *(int64_t*)(ptr+ofs); break;
490  default: goto subtype_test;
491  }
492  append( new_integer(i), &result, &result_end );
493  }
494  ofs += type_size/8;
495  goto to_continue;
496  }
497  case C_TYPE_UNSIGNED:
498  {
499  int64_t i = 0;
500  if( mode==MEM_STRUCT_PACK )
501  {
502  if( !IS_EMPTY( data ) ) GET_INT( data, i );\
503  switch( type_size )
504  {
505  case 8: *(uint8_t*) (ptr+ofs) = i; break;
506  case 16: *(uint16_t*)(ptr+ofs) = i; break;
507  case 32: *(uint32_t*)(ptr+ofs) = i; break;
508  case 64: *(uint64_t*)(ptr+ofs) = i; break;
509  default: goto subtype_test;
510  }
511  }
512  if( mode==MEM_STRUCT_UNPACK )
513  {
514  switch( type_size )
515  {
516  case 8: i = *(uint8_t*) (ptr+ofs); break;
517  case 16: i = *(uint16_t*)(ptr+ofs); break;
518  case 32: i = *(uint32_t*)(ptr+ofs); break;
519  case 64: i = *(uint64_t*)(ptr+ofs); break;
520  default: goto subtype_test;
521  }
522  append( new_integer(i), &result, &result_end );
523  }
524  ofs += type_size/8;
525  goto to_continue;
526  }
527  }
528 
529  subtype_test:
530  new_type = type_value( static_link, parent, type );
531  if( IS_UNBOUND(new_type) )
532  {
533  its_a_number:
534  if( atom_to_integer( type, &count ) )
535  {
537  continue;
538  }
539  return USE(new_error( ERROR_NOT_A_TYPE_NAME, type ));
540  }
541  type = new_type;
542 
543  goto try_again;
544 
545  to_continue:
546  count--;
547  if( !count )
548  {
549  count = 1;
551  }
553  } //for
554 
555  return result ;
556  }
557 
558  atom_t res = traverse( prototype, protodata );
559  if( IS_ERROR(res) ) return res;
560 
561  // if there is no target pointer, then just return the size
562  if( mode==MEM_STRUCT_SIZE ) return new_integer( ofs );
563 
564  return res;
565 }
566 

[ HOME | INDEX | ATOMS | VARS | REFERENCE ]
Lhogho Developer's Documentation
Wed Jul 10 2013