5 /* gets the address of an object representing a C pointer, with the
6 intention of storing the pointer across code which may potentially GC. */
7 char* factor_vm::pinned_alien_offset(cell obj) {
8 switch (tagged<object>(obj).type()) {
10 alien* ptr = untag<alien>(obj);
11 if (to_boolean(ptr->expired))
12 general_error(ERROR_EXPIRED, obj, false_object);
13 if (to_boolean(ptr->base))
14 type_error(ALIEN_TYPE, obj);
16 return (char*)ptr->address;
21 type_error(ALIEN_TYPE, obj);
22 return NULL; /* can't happen */
27 /* Allocates memory */
28 cell factor_vm::allot_alien(cell delegate_, cell displacement) {
29 if (displacement == 0)
32 data_root<object> delegate(delegate_, this);
33 data_root<alien> new_alien(allot<alien>(sizeof(alien)), this);
35 if (delegate.type_p(ALIEN_TYPE)) {
36 tagged<alien> delegate_alien = delegate.as<alien>();
37 displacement += delegate_alien->displacement;
38 new_alien->base = delegate_alien->base;
40 new_alien->base = delegate.value();
42 new_alien->displacement = displacement;
43 new_alien->expired = false_object;
44 new_alien->update_address();
46 return new_alien.value();
49 /* Allocates memory */
50 cell factor_vm::allot_alien(void* address) {
51 return allot_alien(false_object, (cell)address);
54 /* make an alien pointing at an offset of another alien */
55 /* Allocates memory */
56 void factor_vm::primitive_displaced_alien() {
57 cell alien = ctx->pop();
58 cell displacement = to_cell(ctx->pop());
60 switch (tagged<object>(alien).type()) {
64 ctx->push(allot_alien(alien, displacement));
67 type_error(ALIEN_TYPE, alien);
72 /* address of an object representing a C pointer. Explicitly throw an error
73 if the object is a byte array, as a sanity check. */
74 /* Allocates memory (from_unsigned_cell can allocate) */
75 void factor_vm::primitive_alien_address() {
76 ctx->replace(from_unsigned_cell((cell)pinned_alien_offset(ctx->peek())));
79 /* pop ( alien n ) from datastack, return alien's address plus n */
80 void* factor_vm::alien_pointer() {
81 fixnum offset = to_fixnum(ctx->pop());
82 return alien_offset(ctx->pop()) + offset;
85 /* define words to read/write values at an alien address */
86 #define DEFINE_ALIEN_ACCESSOR(name, type, from, to) \
87 VM_C_API void primitive_alien_##name(factor_vm * parent) { \
88 parent->ctx->push(parent->from(*(type*)(parent->alien_pointer()))); \
90 VM_C_API void primitive_set_alien_##name(factor_vm * parent) { \
91 type* ptr = (type*)parent->alien_pointer(); \
92 type value = (type)parent->to(parent->ctx->pop()); \
96 EACH_ALIEN_PRIMITIVE(DEFINE_ALIEN_ACCESSOR)
98 /* open a native library and push a handle */
99 void factor_vm::primitive_dlopen() {
100 data_root<byte_array> path(ctx->pop(), this);
101 path.untag_check(this);
102 data_root<dll> library(allot<dll>(sizeof(dll)), this);
103 library->path = path.value();
104 ffi_dlopen(library.untagged());
105 ctx->push(library.value());
108 /* look up a symbol in a native library */
109 /* Allocates memory */
110 void factor_vm::primitive_dlsym() {
111 data_root<object> library(ctx->pop(), this);
112 data_root<byte_array> name(ctx->peek(), this);
113 name.untag_check(this);
115 symbol_char* sym = name->data<symbol_char>();
117 if (to_boolean(library.value())) {
118 dll* d = untag_check<dll>(library.value());
120 if (d->handle == NULL)
121 ctx->replace(false_object);
123 ctx->replace(allot_alien(ffi_dlsym(d, sym)));
125 ctx->replace(allot_alien(ffi_dlsym(NULL, sym)));
128 /* look up a symbol in a native library */
129 /* Allocates memory */
130 void factor_vm::primitive_dlsym_raw() {
131 data_root<object> library(ctx->pop(), this);
132 data_root<byte_array> name(ctx->peek(), this);
133 name.untag_check(this);
135 symbol_char* sym = name->data<symbol_char>();
137 if (to_boolean(library.value())) {
138 dll* d = untag_check<dll>(library.value());
140 if (d->handle == NULL)
141 ctx->replace(false_object);
143 ctx->replace(allot_alien(ffi_dlsym_raw(d, sym)));
145 ctx->replace(allot_alien(ffi_dlsym_raw(NULL, sym)));
148 /* close a native library handle */
149 void factor_vm::primitive_dlclose() {
150 dll* d = untag_check<dll>(ctx->pop());
151 if (d->handle != NULL)
155 void factor_vm::primitive_dll_validp() {
156 cell library = ctx->peek();
157 if (to_boolean(library))
158 ctx->replace(tag_boolean(untag_check<dll>(library)->handle != NULL));
160 ctx->replace(true_object);
163 /* gets the address of an object representing a C pointer */
164 char* factor_vm::alien_offset(cell obj) {
165 switch (tagged<object>(obj).type()) {
166 case BYTE_ARRAY_TYPE:
167 return untag<byte_array>(obj)->data<char>();
169 return (char*)untag<alien>(obj)->address;
173 type_error(ALIEN_TYPE, obj);
174 return NULL; /* can't happen */