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
|
/* xlwrap - Lisp wrappers for C code. */
/* XLISP-STAT 2.1 Copyright (c) 1990-1997, by Luke Tierney */
/* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz */
/* You may give out copies of this software; for conditions see the */
/* file COPYING included with this distribution. */
#include "xlisp.h"
#ifdef SHAREDLIBS
#include "xlwrap.h"
static LVAL s_types_registry = NULL;
LVAL xlw_lookup_type(char *tname)
{
LVAL next, types;
if (s_types_registry == NULL) {
s_types_registry = xlenter("SYSTEM::*C-TYPES-REGISTRY*");
setvalue(s_types_registry, NIL);
}
types = getvalue(s_types_registry);
for (next = types; consp(next); next = cdr(next))
if (stringp(car(next)) && strcmp(getstring(car(next)), tname) == 0)
return car(next);
types = cons(cvstring(tname), types);
setvalue(s_types_registry, types);
return car(types);
}
DECLARE_CPTR_TYPE(void)
LVAL xlgacptr(LVAL type, int null_ok)
{
LVAL p = xlgetarg();
if ((null(p) && null_ok) ||
(cptr_type_p(p,type) && getcpaddr(p) != NULL))
return p;
else
return xlbadtype(p);
}
LVAL cvcptr(LVAL type, void *v, LVAL data)
{
if (v == NULL)
return NIL;
else {
LVAL ptr, val;
xlprot1(data);
xlsave1(ptr);
ptr = newnatptr(v, data);
val = newcptr(type,ptr);
xlpopn(2);
return val;
}
}
LVAL xlw_make_cptr(LVAL type, size_t elsize)
{
LVAL data, count;
FIXTYPE n = 1;
if (moreargs()) {
count = xlgafixnum();
n = getfixnum(count);
if (n <= 0)
xlbadtype(count);
}
xllastarg();
data = mktvec(n * elsize, s_c_char);
return cvcptr(type, gettvecdata(data), data);
}
LVAL xlw_cast_cptr(LVAL type)
{
LVAL p = xlgetarg();
xllastarg();
if (null(p))
return NIL;
else if (cptrp(p)) /* won't be a NULL pointer */
return newcptr(type, getcpptr(p));
else if (natptrp(p)) /* need to check for NULL */
return getnpaddr(p) == NULL ? NIL : newcptr(type, p);
else
return xlbadtype(p);
}
LVAL xlw_offset_cptr(LVAL type, size_t elsize)
{
LVAL p = xlgetarg();
size_t off = getfixnum(xlgafixnum()) * elsize;
xllastarg();
if (! cptr_type_p(p, type))
xlbadtype(p);
return cvcptr(type, (char *) getcpaddr(p) + off, getcpprot(p));
}
#endif /* SHAREDLIBS */
|
