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 /* Allocates memory */
32 cell factor_vm::allot_alien(cell delegate_, cell displacement)
37 data_root<object> delegate(delegate_,this);
38 data_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
40 if(delegate.type_p(ALIEN_TYPE))
42 tagged<alien> delegate_alien = delegate.as<alien>();
43 displacement += delegate_alien->displacement;
44 new_alien->base = delegate_alien->base;
47 new_alien->base = delegate.value();
49 new_alien->displacement = displacement;
50 new_alien->expired = false_object;
51 new_alien->update_address();
53 return new_alien.value();
56 /* Allocates memory */
57 cell factor_vm::allot_alien(void *address)
59 return allot_alien(false_object,(cell)address);
62 /* Allocates memory */
63 /* make an alien pointing at an offset of another alien */
64 void factor_vm::primitive_displaced_alien()
66 cell alien = ctx->pop();
67 cell displacement = to_cell(ctx->pop());
69 switch(tagged<object>(alien).type())
74 ctx->push(allot_alien(alien,displacement));
77 type_error(ALIEN_TYPE,alien);
82 /* Allocates memory (from_unsigned_cell can allocate) */
83 /* address of an object representing a C pointer. Explicitly throw an error
84 if the object is a byte array, as a sanity check. */
85 void factor_vm::primitive_alien_address()
87 ctx->replace(from_unsigned_cell((cell)pinned_alien_offset(ctx->peek())));
90 /* pop ( alien n ) from datastack, return alien's address plus n */
91 void *factor_vm::alien_pointer()
93 fixnum offset = to_fixnum(ctx->pop());
94 return alien_offset(ctx->pop()) + offset;
97 /* define words to read/write values at an alien address */
98 #define DEFINE_ALIEN_ACCESSOR(name,type,from,to) \
99 VM_C_API void primitive_alien_##name(factor_vm *parent) \
101 parent->ctx->push(parent->from(*(type*)(parent->alien_pointer()))); \
103 VM_C_API void primitive_set_alien_##name(factor_vm *parent) \
105 type *ptr = (type *)parent->alien_pointer(); \
106 type value = (type)parent->to(parent->ctx->pop()); \
110 EACH_ALIEN_PRIMITIVE(DEFINE_ALIEN_ACCESSOR)
112 /* open a native library and push a handle */
113 void factor_vm::primitive_dlopen()
115 data_root<byte_array> path(ctx->pop(),this);
116 path.untag_check(this);
117 data_root<dll> library(allot<dll>(sizeof(dll)),this);
118 library->path = path.value();
119 ffi_dlopen(library.untagged());
120 ctx->push(library.value());
123 /* Allocates memory */
124 /* look up a symbol in a native library */
125 void factor_vm::primitive_dlsym()
127 data_root<object> library(ctx->pop(),this);
128 data_root<byte_array> name(ctx->peek(),this);
129 name.untag_check(this);
131 symbol_char *sym = name->data<symbol_char>();
133 if(to_boolean(library.value()))
135 dll *d = untag_check<dll>(library.value());
137 if(d->handle == NULL)
138 ctx->replace(false_object);
140 ctx->replace(allot_alien(ffi_dlsym(d,sym)));
143 ctx->replace(allot_alien(ffi_dlsym(NULL,sym)));
146 /* Allocates memory */
147 /* look up a symbol in a native library */
148 void factor_vm::primitive_dlsym_raw()
150 data_root<object> library(ctx->pop(),this);
151 data_root<byte_array> name(ctx->peek(),this);
152 name.untag_check(this);
154 symbol_char *sym = name->data<symbol_char>();
156 if(to_boolean(library.value()))
158 dll *d = untag_check<dll>(library.value());
160 if(d->handle == NULL)
161 ctx->replace(false_object);
163 ctx->replace(allot_alien(ffi_dlsym_raw(d,sym)));
166 ctx->replace(allot_alien(ffi_dlsym_raw(NULL,sym)));
169 /* close a native library handle */
170 void factor_vm::primitive_dlclose()
172 dll *d = untag_check<dll>(ctx->pop());
173 if(d->handle != NULL)
177 void factor_vm::primitive_dll_validp()
179 cell library = ctx->peek();
180 if(to_boolean(library))
181 ctx->replace(tag_boolean(untag_check<dll>(library)->handle != NULL));
183 ctx->replace(true_object);
186 /* gets the address of an object representing a C pointer */
187 char *factor_vm::alien_offset(cell obj)
189 switch(tagged<object>(obj).type())
191 case BYTE_ARRAY_TYPE:
192 return untag<byte_array>(obj)->data<char>();
194 return (char *)untag<alien>(obj)->address;
198 type_error(ALIEN_TYPE,obj);
199 return NULL; /* can't happen */