1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
/* @(#) pl_dld.c 1.0.0 (UvA SWI) Thu Sep 13 13:56:45 1990
Copyright (c) 1990 Jan Wielemaker. All rights reserved.
jan@swi.psy.uva.nl
Purpose: linking dld to SWI-Prolog
*/
#include <stdio.h>
#include "../include/SWI-Prolog.h"
#include "../include/dld.h"
static char *
dld_string_error()
{ switch(dld_errno)
{ case DLD_ENOFILE: return "cannot open file";
case DLD_EBADMAGIC: return "bad magic number";
case DLD_EBADHEADER: return "failure reading header";
case DLD_ENOTEXT: return "premature eof in text section";
case DLD_ENOSYMBOLS: return "premature end of file in symbols";
case DLD_ENOSTRINGS: return "bad string table";
case DLD_ENOTXTRELOC: return "premature eof in text relocation";
case DLD_ENODATA: return "premature eof in data section";
case DLD_ENODATRELOC: return "premature eof in data relocation";
case DLD_EMULTDEFS: return "multiple definitions of symbol";
case DLD_EBADLIBRARY: return "malformed library archive";
case DLD_EBADCOMMON: return "common block not supported";
case DLD_EBADOBJECT: return "malformed input file (not rel or archive)";
case DLD_EBADRELOC: return "bad relocation info";
case DLD_ENOMEMORY: return "virtual memory exhausted";
case DLD_EUNDEFSYM: return "undefined symbol";
default: return "unknown dld error";
}
}
static foreign_t
dld_error(name, arity)
char *name;
int arity;
{ PL_warning("%s/%d: %s", name, arity, dld_string_error());
PL_fail;
}
static int
dld_initialise(debug)
int debug;
{ static dld_initialised = FALSE;
if ( dld_initialised == FALSE )
{ if ( dld_init(PL_query(PL_QUERY_SYMBOLFILE), debug) != 0 )
{ dld_error("dld_initialise", 0);
return FALSE;
}
dld_initialised = TRUE;
}
return TRUE;
}
static char *
get_char_p(name, arity, atom)
char *name;
int arity;
term atom;
{ if ( PL_type(atom) != PL_ATOM )
{ PL_warning("%s/%d: instantiation fault");
return NULL;
}
return PL_atom_value(PL_atomic(atom));
}
static foreign_t
pl_dld_link(name)
term name;
{ char *path;
if ( dld_initialise(FALSE) == FALSE )
PL_fail;
if ( (path = get_char_p("dld_link", 1, name)) == NULL )
PL_fail;
if ( dld_link(path) != 0 )
return dld_error("dld_link", 1);
PL_succeed;
}
static foreign_t
pl_dld_unlink(name)
term name;
{ char *path;
if ( dld_initialise(FALSE) == FALSE )
PL_fail;
if ( (path = get_char_p("dld_unlink", 1, name)) == NULL )
PL_fail;
if ( dld_unlink_by_file(path) != 0 )
return dld_error("dld_unlink", 1);
PL_succeed;
}
typedef void (*Func)();
static foreign_t
pl_dld_call(name)
term name;
{ char *func_name;
Func func;
if ( dld_initialise() == FALSE )
PL_fail;
if ( (func_name = get_char_p("dld_call", 1, name)) == NULL )
PL_fail;
if ( dld_function_executable_p(func_name) == 0 )
return PL_warning("dld_call/1: %s is not executable: %s",
func_name, dld_string_error());
if ( (func = (Func) dld_get_func(func_name)) == 0 )
return dld_error("dld_call", 1);
(*func)();
PL_succeed;
}
static foreign_t
pl_dld_list_undefined()
{ if ( dld_initialise(FALSE) == FALSE )
PL_fail;
if ( dld_list_undefined() == 0 )
PL_succeed;
PL_fail;
}
pl_dld_initialise(debug)
term debug;
{ if ( PL_type(debug) != PL_INTEGER )
return PL_warning("dld_initialise/2: intantiation fault");
if ( dld_initialise(PL_integer_value(PL_atomic(debug))) == FALSE )
PL_fail;
PL_succeed;
}
pl_dld_function(name, address)
term name, address;
{ if ( PL_type(name) == PL_ATOM )
{ char *fn = PL_atom_value(PL_atomic(name));
long addr;
if ( (addr = dld_get_func(fn)) == FALSE )
PL_fail;
return PL_unify_atomic(address, PL_new_integer(addr));
} else if ( PL_type(address) == PL_INTEGER )
{ long addr = PL_integer_value(PL_atomic(address));
char *fn;
int perc;
fn = dld_find_function(addr, &perc);
return PL_unify_atomic(name, PL_new_atom(fn));
} else
return PL_warning("dld_function/2: intantiation fault");
}
dld_start()
{ PL_register_foreign("dld_initialise", 1, pl_dld_initialise, 0);
PL_register_foreign("dld_link", 1, pl_dld_link, 0);
PL_register_foreign("dld_unlink", 1, pl_dld_unlink, 0);
PL_register_foreign("dld_call", 1, pl_dld_call, 0);
PL_register_foreign("dld_list_undefined", 0, pl_dld_list_undefined, 0);
PL_register_foreign("dld_function", 2, pl_dld_function, 0);
PL_succeed;
}
|
