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,39 +15,40 @@ ...@@ -15,39 +15,40 @@
(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))
(let ((arg-types '()) (call-type (if (consp name-spec) (second name-spec) :cdecl)))
(arg-type-constants '()) (multiple-value-bind (exported-name callback-exported-p) (exported-fname name)
(arg-variables '()) (let ((arg-types '())
(c-name (format nil "mkcl_callback_~d" (length *callbacks*))) (arg-type-constants '())
(name (if (consp name) (first name) name)) (arg-variables '())
(call-type (if (consp name) (second name) :cdecl))) (helper-name (intern (mkcl:str+ (symbol-name name) "-CALLBACK-HELPER") (symbol-package name)))
(dolist (i arg-list) (c-name (if callback-exported-p exported-name (next-cfun "LC~D~A" name))))
(unless (consp i) (dolist (i arg-list)
(cmperr "Syntax error in CALLBACK form: C type is missing in argument ~A "i)) (unless (consp i)
(push (first i) arg-variables) (cmperr "Syntax error in CALLBACK form: C type is missing in argument ~A "i))
(let ((type (second i))) (push (first i) arg-variables)
(push (second i) arg-types) (let ((type (second i)))
(push (if (ffi::foreign-elt-type-p type) (push (second i) arg-types)
(foreign-elt-type-code type) (push (if (ffi::foreign-elt-type-p type)
(add-object type)) (foreign-elt-type-code type)
arg-type-constants))) (add-object type))
(push (list name c-name (add-object name) arg-type-constants)))
return-type (reverse arg-types) (reverse arg-type-constants) call-type) (push (list name c-name (add-object helper-name)
*callbacks*) return-type (reverse arg-types) (reverse arg-type-constants)
(c1expr call-type callback-exported-p)
`(progn *callbacks*)
;; defun does not seem to work very well when not at toplevel! (c1expr
;;(defun ,name ,(reverse arg-variables) ,@body) `(progn
(setf (symbol-function ',name) ;; defun does not seem to work very well when not at toplevel!
#'(si::lambda-block ,name ,(reverse arg-variables) ,@body)) ;;(defun ,helper-name ,(reverse arg-variables) ,@body)
(si::put-sysprop ',name :callback (setf (symbol-function ',helper-name)
(list #'(si::lambda-block ,helper-name ,(reverse arg-variables) ,@body))
(ffi:c-inline () () :object (si::put-sysprop ',name :callback
,(format nil "mkcl_make_foreign(env,@':pointer-void,0,~a)" c-name) (list
:one-liner t))))) (ffi:c-inline () () :object
))) ,(format nil "mkcl_make_foreign(env,@':pointer-void,0,~a)" c-name)
: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