Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[e90b2f]: src / cmp / cmpcbk.lsp Maximize Restore History

Download this file

cmpcbk.lsp    136 lines (129 with data), 4.9 kB

  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
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
;;;; -*- 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")
#+:uint16-t #+:uint16-t
(:int16-t . "ECL_FFI_INT16_T")
(:uint16-t . "ECL_FFI_UINT16_T")
#+:uint32-t #+:uint32-t
(:int32-t . "ECL_FFI_INT32_T")
(:uint32-t . "ECL_FFI_UINT32_T")
#+:uint64-t #+:uint64-t
(:int64-t . "ECL_FFI_INT64_T")
(:uint64-t . "ECL_FFI_UINT64_T")
#+:long-long #+:long-long
(:long-long . "ECL_FFI_LONG_LONG")
(:unsigned-long-long . "ECL_FFI_UNSIGNED_LONG_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
(cmperr "~a is not a valid elementary FFI type" type))
(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 ((member return-type '(nil :void))
(setf return-p nil))
((ffi::foreign-elt-type-p return-type))
((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-nl-h "static " return-type-name " " fmod c-name "(")
(wt-nl1 "static " return-type-name " " fmod c-name "(")
(loop for n from 0
and type in arg-types
with comma = ""
do
(progn
(wt-h 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)
(setf comma ",")))
(wt ")")
(wt-h ");")
(wt-nl1 "{")
(when return-p
(wt-nl return-type-name " output;"))
(wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
(wt-nl "cl_object aux;")
(wt-nl "ECL_BUILD_STACK_FRAME(cl_env_copy, 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 "}")))