3 /* gets the address of an object representing a C pointer */
4 char *alien_offset(CELL object)
7 F_BYTE_ARRAY *byte_array;
9 switch(type_of(object))
12 byte_array = untagged<F_BYTE_ARRAY>(object);
13 return (char *)(byte_array + 1);
15 alien = untagged<F_ALIEN>(object);
16 if(alien->expired != F)
17 general_error(ERROR_EXPIRED,object,F,NULL);
18 return alien_offset(alien->alien) + alien->displacement;
22 type_error(ALIEN_TYPE,object);
23 return NULL; /* can't happen */
27 /* gets the address of an object representing a C pointer, with the
28 intention of storing the pointer across code which may potentially GC. */
29 char *pinned_alien_offset(CELL object)
33 switch(type_of(object))
36 alien = untagged<F_ALIEN>(object);
37 if(alien->expired != F)
38 general_error(ERROR_EXPIRED,object,F,NULL);
39 return pinned_alien_offset(alien->alien) + alien->displacement;
43 type_error(ALIEN_TYPE,object);
44 return NULL; /* can't happen */
48 /* pop an object representing a C pointer */
49 char *unbox_alien(void)
51 return alien_offset(dpop());
55 CELL allot_alien(CELL delegate_, CELL displacement)
57 gc_root<F_OBJECT> delegate(delegate_);
58 gc_root<F_ALIEN> alien(allot<F_ALIEN>(sizeof(F_ALIEN)));
60 if(delegate.isa(ALIEN_TYPE))
62 tagged<F_ALIEN> delegate_alien = delegate.as<F_ALIEN>();
63 displacement += delegate_alien->displacement;
64 alien->alien = delegate_alien->alien;
67 alien->alien = delegate.value();
69 alien->displacement = displacement;
75 /* make an alien and push */
76 void box_alien(void *ptr)
81 dpush(allot_alien(F,(CELL)ptr));
84 /* make an alien pointing at an offset of another alien */
85 void primitive_displaced_alien(void)
88 CELL displacement = to_cell(dpop());
90 if(alien == F && displacement == 0)
94 switch(type_of(alien))
99 dpush(allot_alien(alien,displacement));
102 type_error(ALIEN_TYPE,alien);
108 /* address of an object representing a C pointer. Explicitly throw an error
109 if the object is a byte array, as a sanity check. */
110 void primitive_alien_address(void)
112 box_unsigned_cell((CELL)pinned_alien_offset(dpop()));
115 /* pop ( alien n ) from datastack, return alien's address plus n */
116 INLINE void *alien_pointer(void)
118 F_FIXNUM offset = to_fixnum(dpop());
119 return unbox_alien() + offset;
122 /* define words to read/write values at an alien address */
123 #define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
124 void primitive_alien_##name(void) \
126 boxer(*(type*)alien_pointer()); \
128 void primitive_set_alien_##name(void) \
130 type *ptr = (type *)alien_pointer(); \
131 type value = to(dpop()); \
135 DEFINE_ALIEN_ACCESSOR(signed_cell,F_FIXNUM,box_signed_cell,to_fixnum)
136 DEFINE_ALIEN_ACCESSOR(unsigned_cell,CELL,box_unsigned_cell,to_cell)
137 DEFINE_ALIEN_ACCESSOR(signed_8,s64,box_signed_8,to_signed_8)
138 DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,box_unsigned_8,to_unsigned_8)
139 DEFINE_ALIEN_ACCESSOR(signed_4,s32,box_signed_4,to_fixnum)
140 DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,box_unsigned_4,to_cell)
141 DEFINE_ALIEN_ACCESSOR(signed_2,s16,box_signed_2,to_fixnum)
142 DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,box_unsigned_2,to_cell)
143 DEFINE_ALIEN_ACCESSOR(signed_1,s8,box_signed_1,to_fixnum)
144 DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,box_unsigned_1,to_cell)
145 DEFINE_ALIEN_ACCESSOR(float,float,box_float,to_float)
146 DEFINE_ALIEN_ACCESSOR(double,double,box_double,to_double)
147 DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset)
149 /* for FFI calls passing structs by value */
150 void to_value_struct(CELL src, void *dest, CELL size)
152 memcpy(dest,alien_offset(src),size);
155 /* for FFI callbacks receiving structs by value */
156 void box_value_struct(void *src, CELL size)
158 F_BYTE_ARRAY *array = allot_byte_array(size);
159 memcpy(array + 1,src,size);
160 dpush(tag_object(array));
163 /* On some x86 OSes, structs <= 8 bytes are returned in registers. */
164 void box_small_struct(CELL x, CELL y, CELL size)
169 box_value_struct(data,size);
172 /* On OS X/PPC, complex numbers are returned in registers. */
173 void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size)
180 box_value_struct(data,size);
183 /* open a native library and push a handle */
184 void primitive_dlopen(void)
186 gc_root<F_BYTE_ARRAY> path(dpop());
188 gc_root<F_DLL> dll(allot<F_DLL>(sizeof(F_DLL)));
189 dll->path = path.value();
190 ffi_dlopen(dll.untagged());
194 /* look up a symbol in a native library */
195 void primitive_dlsym(void)
197 gc_root<F_OBJECT> dll(dpop());
198 gc_root<F_BYTE_ARRAY> name(dpop());
202 F_CHAR *sym = (F_CHAR *)(name.untagged() + 1);
205 box_alien(ffi_dlsym(NULL,sym));
208 tagged<F_DLL> d = dll.as<F_DLL>();
212 box_alien(ffi_dlsym(d.untagged(),sym));
216 /* close a native library handle */
217 void primitive_dlclose(void)
219 ffi_dlclose(untag_dll(dpop()));
222 void primitive_dll_validp(void)
228 dpush(tagged<F_DLL>(dll)->dll == NULL ? F : T);