6 /* gets the address of an object representing a C pointer, with the
7 intention of storing the pointer across code which may potentially GC. */
8 char *factor_vm::pinned_alien_offset(cell obj)
10 switch(tagged<object>(obj).type())
14 alien *ptr = untag<alien>(obj);
15 if(to_boolean(ptr->expired))
16 general_error(ERROR_EXPIRED,obj,false_object);
17 if(to_boolean(ptr->base))
18 type_error(ALIEN_TYPE,obj);
20 return (char *)ptr->address;
25 type_error(ALIEN_TYPE,obj);
26 return NULL; /* can't happen */
30 VM_C_API char *pinned_alien_offset(cell obj, factor_vm *parent)
32 return parent->pinned_alien_offset(obj);
36 cell factor_vm::allot_alien(cell delegate_, cell displacement)
38 if(delegate_ == false_object && displacement == 0)
41 data_root<object> delegate(delegate_,this);
42 data_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
44 if(delegate.type_p(ALIEN_TYPE))
46 tagged<alien> delegate_alien = delegate.as<alien>();
47 displacement += delegate_alien->displacement;
48 new_alien->base = delegate_alien->base;
51 new_alien->base = delegate.value();
53 new_alien->displacement = displacement;
54 new_alien->expired = false_object;
55 new_alien->update_address();
57 return new_alien.value();
60 cell factor_vm::allot_alien(void *address)
62 return allot_alien(false_object,(cell)address);
65 VM_C_API cell allot_alien(void *address, factor_vm *vm)
67 return vm->allot_alien(address);
70 /* make an alien pointing at an offset of another alien */
71 void factor_vm::primitive_displaced_alien()
73 cell alien = ctx->pop();
74 cell displacement = to_cell(ctx->pop());
76 switch(tagged<object>(alien).type())
81 ctx->push(allot_alien(alien,displacement));
84 type_error(ALIEN_TYPE,alien);
89 /* address of an object representing a C pointer. Explicitly throw an error
90 if the object is a byte array, as a sanity check. */
91 void factor_vm::primitive_alien_address()
93 ctx->push(allot_cell((cell)pinned_alien_offset(ctx->pop())));
96 /* pop ( alien n ) from datastack, return alien's address plus n */
97 void *factor_vm::alien_pointer()
99 fixnum offset = to_fixnum(ctx->pop());
100 return alien_offset(ctx->pop()) + offset;
103 /* define words to read/write values at an alien address */
104 #define DEFINE_ALIEN_ACCESSOR(name,type,from,to) \
105 VM_C_API void primitive_alien_##name(factor_vm *parent) \
107 parent->ctx->push(from(*(type*)(parent->alien_pointer()),parent)); \
109 VM_C_API void primitive_set_alien_##name(factor_vm *parent) \
111 type *ptr = (type *)parent->alien_pointer(); \
112 type value = (type)to(parent->ctx->pop(),parent); \
116 EACH_ALIEN_PRIMITIVE(DEFINE_ALIEN_ACCESSOR)
118 /* open a native library and push a handle */
119 void factor_vm::primitive_dlopen()
121 data_root<byte_array> path(ctx->pop(),this);
122 path.untag_check(this);
123 data_root<dll> library(allot<dll>(sizeof(dll)),this);
124 library->path = path.value();
125 ffi_dlopen(library.untagged());
126 ctx->push(library.value());
129 /* look up a symbol in a native library */
130 void factor_vm::primitive_dlsym()
132 data_root<object> library(ctx->pop(),this);
133 data_root<byte_array> name(ctx->pop(),this);
134 name.untag_check(this);
136 symbol_char *sym = name->data<symbol_char>();
138 if(to_boolean(library.value()))
140 dll *d = untag_check<dll>(library.value());
142 if(d->handle == NULL)
143 ctx->push(false_object);
145 ctx->push(allot_alien(ffi_dlsym(d,sym)));
148 ctx->push(allot_alien(ffi_dlsym(NULL,sym)));
151 /* close a native library handle */
152 void factor_vm::primitive_dlclose()
154 dll *d = untag_check<dll>(ctx->pop());
155 if(d->handle != NULL)
159 void factor_vm::primitive_dll_validp()
161 cell library = ctx->pop();
162 if(to_boolean(library))
163 ctx->push(tag_boolean(untag_check<dll>(library)->handle != NULL));
165 ctx->push(true_object);
168 /* gets the address of an object representing a C pointer */
169 char *factor_vm::alien_offset(cell obj)
171 switch(tagged<object>(obj).type())
173 case BYTE_ARRAY_TYPE:
174 return untag<byte_array>(obj)->data<char>();
176 return (char *)untag<alien>(obj)->address;
180 type_error(ALIEN_TYPE,obj);
181 return NULL; /* can't happen */
185 VM_C_API char *alien_offset(cell obj, factor_vm *parent)
187 return parent->alien_offset(obj);
190 /* For FFI calls passing structs by value. Cannot allocate */
191 void factor_vm::to_value_struct(cell src, void *dest, cell size)
193 memcpy(dest,alien_offset(src),size);
196 VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *parent)
198 return parent->to_value_struct(src,dest,size);
201 /* For FFI callbacks receiving structs by value */
202 cell factor_vm::from_value_struct(void *src, cell size)
204 byte_array *bytes = allot_byte_array(size);
205 memcpy(bytes->data<void>(),src,size);
206 return tag<byte_array>(bytes);
209 VM_C_API cell from_value_struct(void *src, cell size, factor_vm *parent)
211 return parent->from_value_struct(src,size);
214 /* On some x86 OSes, structs <= 8 bytes are returned in registers. */
215 cell factor_vm::from_small_struct(cell x, cell y, cell size)
220 return from_value_struct(data,size);
223 VM_C_API cell from_small_struct(cell x, cell y, cell size, factor_vm *parent)
225 return parent->from_small_struct(x,y,size);
228 /* On OS X/PPC, complex numbers are returned in registers. */
229 cell factor_vm::from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
236 return from_value_struct(data,size);
239 VM_C_API cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *parent)
241 return parent->from_medium_struct(x1, x2, x3, x4, size);