mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-10 11:12:58 -08:00
121 lines
4.2 KiB
Common Lisp
121 lines
4.2 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
|
|
;;;;
|
|
;;;; CMPCBK -- Callbacks: lisp functions that can be called from the C world
|
|
|
|
;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll.
|
|
;;;;
|
|
;;;; This program is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Library General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 2 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; See file '../Copyright' for full details.
|
|
|
|
(in-package "COMPILER")
|
|
|
|
(defun c1-defcallback (args)
|
|
(destructuring-bind (name return-type arg-list &rest body)
|
|
args
|
|
(let ((arg-types '())
|
|
(arg-type-constants '())
|
|
(arg-variables '())
|
|
(c-name (format nil "ecl_callback_~d" (length *callbacks*)))
|
|
(name (if (consp name) (first name) name))
|
|
(call-type (if (consp name) (second name) :cdecl)))
|
|
(dolist (i arg-list)
|
|
(unless (consp i)
|
|
(cmperr "Syntax error in CALLBACK form: C type is missing in argument ~A "i))
|
|
(push (first i) arg-variables)
|
|
(let ((type (second i)))
|
|
(push (second i) arg-types)
|
|
(push (if (ffi::foreign-elt-type-p type)
|
|
(foreign-elt-type-code type)
|
|
(add-object type))
|
|
arg-type-constants)))
|
|
(push (list name c-name (add-object name)
|
|
return-type (reverse arg-types) (reverse arg-type-constants) call-type)
|
|
*callbacks*)
|
|
(c1expr
|
|
`(progn
|
|
(defun ,name ,(reverse arg-variables) ,@body)
|
|
(si::put-sysprop ',name :callback
|
|
(list
|
|
(ffi:c-inline () () :object
|
|
,(format nil "ecl_make_foreign_data(@':pointer-void,0,~a)" c-name)
|
|
:one-liner t)))))
|
|
)))
|
|
|
|
(defconstant +foreign-elt-type-codes+
|
|
'((:char . "ECL_FFI_CHAR")
|
|
(:unsigned-char . "ECL_FFI_UNSIGNED_CHAR")
|
|
(:byte . "ECL_FFI_BYTE")
|
|
(:unsigned-byte . "ECL_FFI_UNSIGNED_BYTE")
|
|
(:short . "ECL_FFI_SHORT")
|
|
(:unsigned-short . "ECL_FFI_UNSIGNED_SHORT")
|
|
(:int . "ECL_FFI_INT")
|
|
(:unsigned-int . "ECL_FFI_UNSIGNED_INT")
|
|
(:long . "ECL_FFI_LONG")
|
|
(:unsigned-long . "ECL_FFI_UNSIGNED_LONG")
|
|
(:pointer-void . "ECL_FFI_POINTER_VOID")
|
|
(:cstring . "ECL_FFI_CSTRING")
|
|
(:object . "ECL_FFI_OBJECT")
|
|
(:float . "ECL_FFI_FLOAT")
|
|
(:double . "ECL_FFI_DOUBLE")
|
|
(:void . "ECL_FFI_VOID")))
|
|
|
|
(defun foreign-elt-type-code (type)
|
|
(let ((x (assoc type +foreign-elt-type-codes+)))
|
|
(unless x
|
|
(error "~a is not a valid elementary FFI type" x))
|
|
(cdr x)))
|
|
|
|
(defun t3-defcallback (lisp-name c-name c-name-constant return-type
|
|
arg-types arg-type-constants call-type &aux (return-p t))
|
|
(cond ((ffi::foreign-elt-type-p return-type))
|
|
((member return-type '(nil :void))
|
|
(setf return-p nil))
|
|
((and (consp return-type)
|
|
(member (first return-type) '(* array)))
|
|
(setf return-type :pointer-void))
|
|
(t
|
|
(cmperr "DEFCALLBACK does not support complex return types such as ~A"
|
|
return-type)))
|
|
(let ((return-type-name (rep-type-name (ffi::%convert-to-arg-type return-type)))
|
|
(fmod (case call-type
|
|
(:cdecl "")
|
|
(:stdcall "__stdcall ")
|
|
(t (cmperr "DEFCALLBACK does not support ~A as calling convention"
|
|
call-type)))))
|
|
(wt-nl1 "static " return-type-name " " fmod c-name "(")
|
|
(loop for n from 0
|
|
and type in arg-types
|
|
with comma = ""
|
|
do
|
|
(progn
|
|
(wt comma (rep-type-name (ffi::%convert-to-arg-type type)) " var" n)
|
|
(setf comma ",")))
|
|
(wt ")")
|
|
(wt-nl1 "{")
|
|
(when return-p
|
|
(wt-nl return-type-name " output;"))
|
|
(wt-nl "cl_object aux;")
|
|
(wt-nl "ECL_BUILD_STACK_FRAME(frame, helper)")
|
|
(loop for n from 0
|
|
and type in arg-types
|
|
and ct in arg-type-constants
|
|
do
|
|
(if (stringp ct)
|
|
(wt-nl "ecl_stack_frame_push(frame,ecl_foreign_data_ref_elt(&var"
|
|
n "," ct "));")
|
|
(wt-nl "ecl_stack_frame_push(frame,ecl_make_foreign_data(&var"
|
|
n "," ct "," (ffi:size-of-foreign-type type) "));")))
|
|
(wt-nl "aux = ecl_apply_from_stack_frame(frame,"
|
|
"ecl_fdefinition(" c-name-constant "));")
|
|
(wt-nl "ecl_stack_frame_close(frame);")
|
|
(when return-p
|
|
(wt-nl "ecl_foreign_data_set_elt(&output,"
|
|
(foreign-elt-type-code return-type) ",aux);")
|
|
(wt-nl "return output;"))
|
|
(wt-nl1 "}")))
|
|
|
|
(put-sysprop 'FFI:DEFCALLBACK 'C1 #'c1-defcallback)
|