Commit 2c21e6e2 authored by Jean-Claude Beaudoin's avatar Jean-Claude Beaudoin
Browse files

Declaration C-EXPORT-FNAME can now be proclaimed on the name of a...

Declaration C-EXPORT-FNAME can now be proclaimed on the name of a ffi:defcallback to effectively expose, by C name, that callback entry point to C code.
parent 053263e5
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
;;;; CMPCBK -- Callbacks: lisp functions that can be called from the C world ;;;; CMPCBK -- Callbacks: lisp functions that can be called from the C world
;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll. ;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll.
;;;; Copyright (c) 2012, Jean-Claude Beaudoin. ;;;; Copyright (c) 2012,2021 Jean-Claude Beaudoin.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or ;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
...@@ -15,14 +15,15 @@ ...@@ -15,14 +15,15 @@
(in-package "COMPILER") (in-package "COMPILER")
(defun c1-defcallback (args) (defun c1-defcallback (args)
(destructuring-bind (name return-type arg-list &rest body) (destructuring-bind (name-spec return-type arg-list &rest body) args
args (let ((name (if (consp name-spec) (first name-spec) name-spec))
(call-type (if (consp name-spec) (second name-spec) :cdecl)))
(multiple-value-bind (exported-name callback-exported-p) (exported-fname name)
(let ((arg-types '()) (let ((arg-types '())
(arg-type-constants '()) (arg-type-constants '())
(arg-variables '()) (arg-variables '())
(c-name (format nil "mkcl_callback_~d" (length *callbacks*))) (helper-name (intern (mkcl:str+ (symbol-name name) "-CALLBACK-HELPER") (symbol-package name)))
(name (if (consp name) (first name) name)) (c-name (if callback-exported-p exported-name (next-cfun "LC~D~A" name))))
(call-type (if (consp name) (second name) :cdecl)))
(dolist (i arg-list) (dolist (i arg-list)
(unless (consp i) (unless (consp i)
(cmperr "Syntax error in CALLBACK form: C type is missing in argument ~A "i)) (cmperr "Syntax error in CALLBACK form: C type is missing in argument ~A "i))
...@@ -33,21 +34,21 @@ ...@@ -33,21 +34,21 @@
(foreign-elt-type-code type) (foreign-elt-type-code type)
(add-object type)) (add-object type))
arg-type-constants))) arg-type-constants)))
(push (list name c-name (add-object name) (push (list name c-name (add-object helper-name)
return-type (reverse arg-types) (reverse arg-type-constants) call-type) return-type (reverse arg-types) (reverse arg-type-constants)
call-type callback-exported-p)
*callbacks*) *callbacks*)
(c1expr (c1expr
`(progn `(progn
;; defun does not seem to work very well when not at toplevel! ;; defun does not seem to work very well when not at toplevel!
;;(defun ,name ,(reverse arg-variables) ,@body) ;;(defun ,helper-name ,(reverse arg-variables) ,@body)
(setf (symbol-function ',name) (setf (symbol-function ',helper-name)
#'(si::lambda-block ,name ,(reverse arg-variables) ,@body)) #'(si::lambda-block ,helper-name ,(reverse arg-variables) ,@body))
(si::put-sysprop ',name :callback (si::put-sysprop ',name :callback
(list (list
(ffi:c-inline () () :object (ffi:c-inline () () :object
,(format nil "mkcl_make_foreign(env,@':pointer-void,0,~a)" c-name) ,(format nil "mkcl_make_foreign(env,@':pointer-void,0,~a)" c-name)
:one-liner t))))) :one-liner t))))))))))
)))
(defconstant +foreign-elt-type-codes+ (defconstant +foreign-elt-type-codes+
'((:char . "MKCL_FFI_CHAR") '((:char . "MKCL_FFI_CHAR")
...@@ -76,8 +77,10 @@ ...@@ -76,8 +77,10 @@
(cmperr "~a is not a valid elementary FFI type" x)) (cmperr "~a is not a valid elementary FFI type" x))
(cdr x))) (cdr x)))
(defun t3-defcallback (lisp-name c-name c-name-constant return-type (defun t3-defcallback (lisp-name c-name helper-constant
arg-types arg-type-constants call-type &aux (return-p t)) return-type arg-types arg-type-constants
call-type exported-p
&aux (return-p t))
(cond ((ffi::foreign-elt-type-p return-type)) (cond ((ffi::foreign-elt-type-p return-type))
((member return-type '(nil :void)) ((member return-type '(nil :void))
(setf return-p nil)) (setf return-p nil))
...@@ -91,8 +94,8 @@ ...@@ -91,8 +94,8 @@
(:cdecl "") (:cdecl "")
(:stdcall "__stdcall ") (:stdcall "__stdcall ")
(t (cmperr "DEFCALLBACK does not support ~A as calling convention" call-type))))) (t (cmperr "DEFCALLBACK does not support ~A as calling convention" call-type)))))
(wt-nl1 "static " return-type-name " " fmod c-name "(") (wt-nl1 (if exported-p "extern " "static ") return-type-name " " fmod c-name "(")
(wt-nl-h "static " return-type-name " " fmod c-name "(") (wt-nl-h (if exported-p "extern MKCL_DLLEXPORT " "static ") return-type-name " " fmod c-name "(")
(if arg-types (if arg-types
(loop for n from 0 (loop for n from 0
and type in arg-types and type in arg-types
...@@ -102,8 +105,7 @@ ...@@ -102,8 +105,7 @@
(wt comma (rep-type-name (ffi::%convert-to-arg-type type)) " var" n) (wt comma (rep-type-name (ffi::%convert-to-arg-type type)) " var" n)
(wt-h comma (rep-type-name (ffi::%convert-to-arg-type type)) " var" n) (wt-h comma (rep-type-name (ffi::%convert-to-arg-type type)) " var" n)
(setf comma ","))) (setf comma ",")))
(progn (wt "void") (wt-h "void")) (progn (wt "void") (wt-h "void")))
)
(wt ")") (wt-h ");") (wt ")") (wt-h ");")
(wt-nl1 "{") (wt-nl1 "{")
(when return-p (when return-p
...@@ -132,7 +134,7 @@ ...@@ -132,7 +134,7 @@
n "," ct "," (ffi:size-of-foreign-type type) "));"))) n "," ct "," (ffi:size-of-foreign-type type) "));")))
;; here is the lisp callback function invocation. ;; here is the lisp callback function invocation.
(wt-nl "aux = mkcl_apply_from_temp_stack_frame(env, frame, mkcl_fdefinition(env, " c-name-constant "));") (wt-nl "aux = mkcl_apply_from_temp_stack_frame(env, frame, mkcl_fdefinition(env, " helper-constant "));")
(wt-nl "mkcl_temp_stack_frame_close(env, frame);") (wt-nl "mkcl_temp_stack_frame_close(env, frame);")
...@@ -158,8 +160,7 @@ ...@@ -158,8 +160,7 @@
(wt comma (rep-type-name (ffi::%convert-to-arg-type type)) " var" n) (wt comma (rep-type-name (ffi::%convert-to-arg-type type)) " var" n)
(wt-h comma (rep-type-name (ffi::%convert-to-arg-type type)) " var" n) (wt-h comma (rep-type-name (ffi::%convert-to-arg-type type)) " var" n)
(setf comma ","))) (setf comma ",")))
(progn (wt "void") (wt-h "void")) (progn (wt "void") (wt-h "void")))
)
(wt ")") (wt-h ");") (wt ")") (wt-h ");")
(wt-nl1 "{") (wt-nl1 "{")
(when return-p (when return-p
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment