Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
mkcl
mkcl
Commits
47942ff8
Commit
47942ff8
authored
Feb 15, 2021
by
Jean-Claude Beaudoin
Browse files
Get rid of some dead wood.
parent
f0016946
Changes
5
Hide whitespace changes
Inline
Side-by-side
src/c/ffi.d
View file @
47942ff8
...
...
@@ -679,7 +679,7 @@ mk_si_release_ffi_area(MKCL)
}
struct
mkcl_fficall
*
mkcl_fficall_prepare
(
MKCL
,
mkcl_object
return_type
,
mkcl_object
arg_type
,
mkcl_object
cc_type
)
mkcl_fficall_prepare
(
MKCL
,
mkcl_object
return_type
,
mkcl_object
arg_type
)
{
struct
mkcl_fficall
*
fficall
=
env
->
fficall
;
...
...
@@ -691,14 +691,9 @@ mkcl_fficall_prepare(MKCL, mkcl_object return_type, mkcl_object arg_type, mkcl_o
fficall
->
buffer_sp
=
fficall
->
buffer
;
fficall
->
registers
=
NULL
;
fficall
->
output
.
pc
=
NULL
;
/* fficall->cc = MKCL_FFI_CC_CDECL; */
/* fficall->cstring = mk_cl_Cnil; */
}
else
fficall
->
buffer_sp
=
fficall
->
buffer
;
/* fficall->buffer_size = 0; */
/* fficall->cstring = mk_cl_Cnil; */
/* fficall->cc = mkcl_foreign_cc_code(env, cc_type); */
fficall
->
registers
=
mkcl_fficall_prepare_extra
(
env
,
fficall
->
registers
);
return
fficall
;
}
...
...
@@ -739,11 +734,13 @@ void mkcl_fficall_align16(MKCL)
fficall
->
buffer_sp
=
(
char
*)
(((
intptr_t
)
(
fficall
->
buffer_sp
+
0xF
))
&
~((
uintptr_t
)
0xF
));
}
@
(
defun
si
::
call
-
cfun
(
fun
return_type
arg_types
args
&
optional
(
cc_type
@
'
:
cdecl
'
))
mkcl_object
mk_si_call_cfun
(
MKCL
,
mkcl_object
fun
,
mkcl_object
return_type
,
mkcl_object
arg_types
,
mkcl_object
args
)
{
void
*
cfun
=
mkcl_foreign_raw_pointer
(
env
,
fun
);
enum
mkcl_ffi_tag
return_type_tag
=
mkcl_foreign_type_code
(
env
,
return_type
);
@
struct
mkcl_fficall
*
fficall
=
mkcl_fficall_prepare
(
env
,
return_type
,
arg_types
,
cc_type
);
struct
mkcl_fficall
*
fficall
=
mkcl_fficall_prepare
(
env
,
return_type
,
arg_types
);
mkcl_call_stack_check
(
env
);
while
(
MKCL_CONSP
(
arg_types
))
{
mkcl_object
object
;
...
...
@@ -773,21 +770,19 @@ void mkcl_fficall_align16(MKCL)
fficall
->
buffer_sp
=
fficall
->
buffer
;
@
(
return
return_value
);
}
@
)
}
mkcl_object
mk_si_make_dynamic_callback
(
MKCL
,
mkcl_object
fun
,
mkcl_object
sym
,
mkcl_object
rtype
,
mkcl_object
argtypes
)
{
mkcl_call_stack_check
(
env
);
@
(
defun
si
::
make
-
dynamic
-
callback
(
fun
sym
rtype
argtypes
&
optional
(
cctype
@
'
:
cdecl
'
))
@
mkcl_object
data
=
mk_cl_list
(
env
,
3
,
fun
,
rtype
,
argtypes
);
#
if
0
void
*
ptr
=
mkcl_dynamic_callback_make
(
env
,
data
,
mkcl_foreign_cc_code
(
env
,
cctype
));
#
else
void
*
ptr
=
mkcl_dynamic_callback_make
(
env
,
data
);
#
endif
mkcl_object
C_type
=
mk_cl_list
(
env
,
2
,
@
'*'
,
@
'
:
void
'
);
mkcl_object
cbk
=
mkcl_make_foreign
(
env
,
C_type
,
sizeof
(
void
*));
*((
void
**)
cbk
->
foreign
.
data
)
=
ptr
;
mk_si_put_sysprop
(
env
,
sym
,
@
'
:
callback
'
,
MKCL_CONS
(
env
,
cbk
,
data
));
@
(
return
cbk
);
@
)
}
src/c/mkcl/external.h
View file @
47942ff8
...
...
@@ -838,8 +838,8 @@ extern "C" {
extern
MKCL_API
mkcl_object
mk_si_load_foreign_module
(
MKCL
,
mkcl_object
module
);
extern
MKCL_API
mkcl_object
mk_si_unload_foreign_module
(
MKCL
,
mkcl_object
module
);
extern
MKCL_API
mkcl_object
mk_si_find_foreign_symbol
(
MKCL
,
mkcl_object
var
,
mkcl_object
module
,
mkcl_object
type
,
mkcl_object
size
);
extern
MKCL_API
mkcl_object
mk_si_call_cfun
(
MKCL
,
mkcl_narg
,
mkcl_object
fun
,
mkcl_object
return_type
,
mkcl_object
arg_types
,
mkcl_object
args
,
...
);
extern
MKCL_API
mkcl_object
mk_si_make_dynamic_callback
(
MKCL
,
mkcl_narg
,
mkcl_object
fun
,
mkcl_object
sym
,
mkcl_object
return_type
,
mkcl_object
arg_types
,
...
);
extern
MKCL_API
mkcl_object
mk_si_call_cfun
(
MKCL
,
mkcl_object
fun
,
mkcl_object
return_type
,
mkcl_object
arg_types
,
mkcl_object
args
);
extern
MKCL_API
mkcl_object
mk_si_make_dynamic_callback
(
MKCL
,
mkcl_object
fun
,
mkcl_object
sym
,
mkcl_object
return_type
,
mkcl_object
arg_types
);
extern
MKCL_API
mkcl_object
mk_si_trim_ffi_arguments_staging_area
(
MKCL
);
extern
MKCL_API
mkcl_object
mk_si_release_ffi_area
(
MKCL
);
extern
MKCL_API
mkcl_object
mk_si_pointer
(
MKCL
,
mkcl_object
x
);
...
...
src/c/mkcl/internal.h
View file @
47942ff8
...
...
@@ -292,23 +292,10 @@ extern "C" {
long
double
ld
;
};
#if 0
enum mkcl_ffi_calling_convention {
MKCL_FFI_CC_CDECL = 0,
MKCL_FFI_CC_STDCALL
};
/* Note that the order of enums declared in enum mkcl_ffi_calling_convention must
carefully match the content of mkcl_foreign_cc_table[]. JCB
*/
#endif
struct
mkcl_fficall
{
char
*
buffer_sp
;
size_t
buffer_size
;
union
mkcl_ffi_values
output
;
#if 0
enum mkcl_ffi_calling_convention cc;
#endif
struct
mkcl_fficall_reg
*
registers
;
char
*
buffer
;
/* mkcl_object cstring; */
...
...
@@ -316,7 +303,7 @@ extern "C" {
extern
enum
mkcl_ffi_tag
mkcl_foreign_type_code
(
MKCL
,
mkcl_object
type
);
extern
enum
mkcl_ffi_calling_convention
mkcl_foreign_cc_code
(
MKCL
,
mkcl_object
cc_type
);
extern
struct
mkcl_fficall
*
mkcl_fficall_prepare
(
MKCL
,
mkcl_object
return_type
,
mkcl_object
arg_types
,
mkcl_object
cc_type
);
extern
struct
mkcl_fficall
*
mkcl_fficall_prepare
(
MKCL
,
mkcl_object
return_type
,
mkcl_object
arg_types
);
extern
void
mkcl_fficall_push_bytes
(
MKCL
,
void
*
data
,
size_t
bytes
);
extern
void
mkcl_fficall_push_int
(
MKCL
,
int
word
);
extern
void
mkcl_fficall_align4
(
MKCL
);
...
...
src/c/symbols_list.h
View file @
47942ff8
...
...
@@ -1539,7 +1539,7 @@ mkcl_symbol_initializer mkcl_root_symbols[] = {
{{
SYS_
"*CODE-WALKER*"
,
SI_SPECIAL
,
NULL
,
-
1
,
MKCL_OBJNULL
}},
{{
SYS_
"CALL-CFUN"
,
SI_ORDINARY
,
mk_si_call_cfun
,
-
1
,
MKCL_OBJNULL
}},
{{
SYS_
"CALL-CFUN"
,
SI_ORDINARY
,
mk_si_call_cfun
,
4
,
MKCL_OBJNULL
}},
{{
KEY_
"CALLBACK"
,
KEYWORD
,
NULL
,
-
1
,
MKCL_OBJNULL
}},
{{
SYS_
"MAKE-DYNAMIC-CALLBACK"
,
SI_ORDINARY
,
mk_si_make_dynamic_callback
,
-
1
,
MKCL_OBJNULL
}},
{{
KEY_
"CDECL"
,
KEYWORD
,
NULL
,
-
1
,
MKCL_OBJNULL
}},
...
...
src/lsp/ffi.lsp
View file @
47942ff8
...
...
@@ -697,19 +697,19 @@
0 (max 0 (1- (* nargs 3)))))) ;; There is 3 characters per argument specifier. JCB
;;; FIXME! We should turn this into a closure generator that produces no code.
(defmacro def-lib-function (name args &key returning module
(call :cdecl)
)
(defmacro def-lib-function (name args &key returning module)
(multiple-value-bind (c-name lisp-name) (map-name-from-c-to-lisp name)
(let* ((return-type (ffi::%convert-to-return-type returning))
(return-required (not (eq return-type :void)))
(argtypes (mapcar #'(lambda (a) (ffi::%convert-to-arg-type (second a))) args)))
`(let ((c-fun (si::find-foreign-symbol ',c-name ,module :pointer-void 0)))
(defun ,lisp-name ,(mapcar #'first args)
(si::call-cfun c-fun ',return-type ',argtypes (list ,@(mapcar #'first args))
,call
))))))
(si::call-cfun c-fun ',return-type ',argtypes (list ,@(mapcar #'first args))))))))
(defmacro def-function (name args &key module (returning :void)
(call :cdecl)
)
(defmacro def-function (name args &key module (returning :void))
(when module
(return-from def-function
`(def-lib-function ,name ,args :returning ,returning :module ,module
:call ,call
)))
`(def-lib-function ,name ,args :returning ,returning :module ,module)))
(multiple-value-bind (c-name lisp-name)
(map-name-from-c-to-lisp name)
(let* ((arguments (mapcar #'first args))
...
...
@@ -822,12 +822,12 @@
(multiple-value-bind (name call-type) (if (consp name)
(values-list name)
(values name :cdecl))
(declare (ignorable call-type))
;;(format t "~&Expanding macro defcallback on ~S.~%" name)
(let ((arg-types (mapcar #'second arg-desc))
(arg-names (mapcar #'first arg-desc)))
`(si::make-dynamic-callback
#'(si::lambda-block ,name ,arg-names ,@body)
',name ',ret-type ',arg-types ,call-type))))
#'(si::lambda-block ,name ,arg-names ,@body) ',name ',ret-type ',arg-types))))
(defun callback (name)
(let ((x (si::get-sysprop name :callback)))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment