You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
544 lines
21 KiB
544 lines
21 KiB
5 years ago
|
/* Define a C preprocessor symbol that can be used in interface files
|
||
|
|
to distinguish between the SWIG language modules. */
|
||
|
|
|
||
|
|
#define SWIG_ALLEGRO_CL
|
||
|
|
|
||
|
|
#define %ffargs(...) %feature("ffargs", "1", ##__VA_ARGS__)
|
||
|
|
%ffargs(strings_convert="t");
|
||
|
|
|
||
|
|
/* typemaps for argument and result type conversions. */
|
||
|
|
%typemap(lin,numinputs=1) SWIGTYPE "(cl::let (($out $in))\n $body)";
|
||
|
|
|
||
|
|
%typemap(lout) bool, char, unsigned char, signed char,
|
||
|
|
short, signed short, unsigned short,
|
||
|
|
int, signed int, unsigned int,
|
||
|
|
long, signed long, unsigned long,
|
||
|
|
float, double, long double, char *, void *,
|
||
|
|
enum SWIGTYPE "(cl::setq ACL_ffresult $body)";
|
||
|
|
%typemap(lout) void "$body";
|
||
|
|
%typemap(lout) SWIGTYPE[ANY], SWIGTYPE *,
|
||
|
|
SWIGTYPE &
|
||
|
|
%{ (cl:let* ((address $body)
|
||
|
|
(new-inst (cl:make-instance '$lclass :foreign-address address)))
|
||
|
|
(cl:when (cl:and $owner (cl:not (cl:zerop address)))
|
||
|
|
(excl:schedule-finalization new-inst #'$ldestructor))
|
||
|
|
(cl:setq ACL_ffresult new-inst)) %}
|
||
|
|
|
||
|
|
%typemap(lout) SWIGTYPE "(cl::let* ((address $body)\n (new-inst (cl::make-instance '$lclass :foreign-address address)))\n (cl::unless (cl::zerop address)\n (excl:schedule-finalization new-inst #'$ldestructor))\n (cl::setq ACL_ffresult new-inst))";
|
||
|
|
|
||
|
|
%typemap(lisptype) bool "cl:boolean";
|
||
|
|
%typemap(lisptype) char "cl:character";
|
||
|
|
%typemap(lisptype) unsigned char "cl:integer";
|
||
|
|
%typemap(lisptype) signed char "cl:integer";
|
||
|
|
|
||
|
|
%typemap(ffitype) bool ":int";
|
||
|
|
%typemap(ffitype) char ":char";
|
||
|
|
%typemap(ffitype) unsigned char ":unsigned-char";
|
||
|
|
%typemap(ffitype) signed char ":char";
|
||
|
|
%typemap(ffitype) short, signed short ":short";
|
||
|
|
%typemap(ffitype) unsigned short ":unsigned-short";
|
||
|
|
%typemap(ffitype) int, signed int ":int";
|
||
|
|
%typemap(ffitype) unsigned int ":unsigned-int";
|
||
|
|
%typemap(ffitype) long, signed long ":long";
|
||
|
|
%typemap(ffitype) unsigned long ":unsigned-long";
|
||
|
|
%typemap(ffitype) float ":float";
|
||
|
|
%typemap(ffitype) double ":double";
|
||
|
|
%typemap(ffitype) char * "(* :char)";
|
||
|
|
%typemap(ffitype) void * "(* :void)";
|
||
|
|
%typemap(ffitype) void ":void";
|
||
|
|
%typemap(ffitype) enum SWIGTYPE ":int";
|
||
|
|
%typemap(ffitype) SWIGTYPE & "(* :void)";
|
||
|
|
|
||
|
|
%typemap(ctype) bool "int";
|
||
|
|
%typemap(ctype) char, unsigned char, signed char,
|
||
|
|
short, signed short, unsigned short,
|
||
|
|
int, signed int, unsigned int,
|
||
|
|
long, signed long, unsigned long,
|
||
|
|
float, double, long double, char *, void *, void,
|
||
|
|
enum SWIGTYPE, SWIGTYPE *,
|
||
|
|
SWIGTYPE[ANY], SWIGTYPE & "$1_ltype";
|
||
|
|
%typemap(ctype) SWIGTYPE "$&1_type";
|
||
|
|
|
||
|
|
%typemap(in) bool "$1 = (bool)$input;";
|
||
|
|
%typemap(in) char, unsigned char, signed char,
|
||
|
|
short, signed short, unsigned short,
|
||
|
|
int, signed int, unsigned int,
|
||
|
|
long, signed long, unsigned long,
|
||
|
|
float, double, long double, char *, void *, void,
|
||
|
|
enum SWIGTYPE, SWIGTYPE *,
|
||
|
|
SWIGTYPE[ANY], SWIGTYPE & "$1 = $input;";
|
||
|
|
%typemap(in) SWIGTYPE "$1 = *$input;";
|
||
|
|
|
||
|
|
/* We don't need to do any actual C-side typechecking, but need to
|
||
|
|
use the precedence values to choose which overloaded function
|
||
|
|
interfaces to generate when conflicts arise. */
|
||
|
|
|
||
|
|
/* predefined precedence values
|
||
|
|
|
||
|
|
Symbolic Name Precedence Value
|
||
|
|
------------------------------ ------------------
|
||
|
|
SWIG_TYPECHECK_POINTER 0
|
||
|
|
SWIG_TYPECHECK_VOIDPTR 10
|
||
|
|
SWIG_TYPECHECK_BOOL 15
|
||
|
|
SWIG_TYPECHECK_UINT8 20
|
||
|
|
SWIG_TYPECHECK_INT8 25
|
||
|
|
SWIG_TYPECHECK_UINT16 30
|
||
|
|
SWIG_TYPECHECK_INT16 35
|
||
|
|
SWIG_TYPECHECK_UINT32 40
|
||
|
|
SWIG_TYPECHECK_INT32 45
|
||
|
|
SWIG_TYPECHECK_UINT64 50
|
||
|
|
SWIG_TYPECHECK_INT64 55
|
||
|
|
SWIG_TYPECHECK_UINT128 60
|
||
|
|
SWIG_TYPECHECK_INT128 65
|
||
|
|
SWIG_TYPECHECK_INTEGER 70
|
||
|
|
SWIG_TYPECHECK_FLOAT 80
|
||
|
|
SWIG_TYPECHECK_DOUBLE 90
|
||
|
|
SWIG_TYPECHECK_COMPLEX 100
|
||
|
|
SWIG_TYPECHECK_UNICHAR 110
|
||
|
|
SWIG_TYPECHECK_UNISTRING 120
|
||
|
|
SWIG_TYPECHECK_CHAR 130
|
||
|
|
SWIG_TYPECHECK_STRING 140
|
||
|
|
SWIG_TYPECHECK_BOOL_ARRAY 1015
|
||
|
|
SWIG_TYPECHECK_INT8_ARRAY 1025
|
||
|
|
SWIG_TYPECHECK_INT16_ARRAY 1035
|
||
|
|
SWIG_TYPECHECK_INT32_ARRAY 1045
|
||
|
|
SWIG_TYPECHECK_INT64_ARRAY 1055
|
||
|
|
SWIG_TYPECHECK_INT128_ARRAY 1065
|
||
|
|
SWIG_TYPECHECK_FLOAT_ARRAY 1080
|
||
|
|
SWIG_TYPECHECK_DOUBLE_ARRAY 1090
|
||
|
|
SWIG_TYPECHECK_CHAR_ARRAY 1130
|
||
|
|
SWIG_TYPECHECK_STRING_ARRAY 1140
|
||
|
|
*/
|
||
|
|
|
||
|
|
%typecheck(SWIG_TYPECHECK_BOOL) bool { $1 = 1; };
|
||
|
|
%typecheck(SWIG_TYPECHECK_CHAR) char { $1 = 1; };
|
||
|
|
%typecheck(SWIG_TYPECHECK_FLOAT) float { $1 = 1; };
|
||
|
|
%typecheck(SWIG_TYPECHECK_DOUBLE) double { $1 = 1; };
|
||
|
|
%typecheck(SWIG_TYPECHECK_STRING) char * { $1 = 1; };
|
||
|
|
%typecheck(SWIG_TYPECHECK_INTEGER)
|
||
|
|
unsigned char, signed char,
|
||
|
|
short, signed short, unsigned short,
|
||
|
|
int, signed int, unsigned int,
|
||
|
|
long, signed long, unsigned long,
|
||
|
|
enum SWIGTYPE { $1 = 1; };
|
||
|
|
%typecheck(SWIG_TYPECHECK_POINTER) SWIGTYPE *, SWIGTYPE &,
|
||
|
|
SWIGTYPE[ANY], SWIGTYPE { $1 = 1; };
|
||
|
|
|
||
|
|
/* This maps C/C++ types to Lisp classes for overload dispatch */
|
||
|
|
|
||
|
|
%typemap(lispclass) bool "t";
|
||
|
|
%typemap(lispclass) char "cl:character";
|
||
|
|
%typemap(lispclass) unsigned char, signed char,
|
||
|
|
short, signed short, unsigned short,
|
||
|
|
int, signed int, unsigned int,
|
||
|
|
long, signed long, unsigned long,
|
||
|
|
enum SWIGTYPE "cl:integer";
|
||
|
|
%typemap(lispclass) float "cl:single-float";
|
||
|
|
%typemap(lispclass) double "cl:double-float";
|
||
|
|
%typemap(lispclass) char * "cl:string";
|
||
|
|
|
||
|
|
%typemap(out) bool "$result = (int)$1;";
|
||
|
|
%typemap(out) char, unsigned char, signed char,
|
||
|
|
short, signed short, unsigned short,
|
||
|
|
int, signed int, unsigned int,
|
||
|
|
long, signed long, unsigned long,
|
||
|
|
float, double, long double, char *, void *, void,
|
||
|
|
enum SWIGTYPE, SWIGTYPE *,
|
||
|
|
SWIGTYPE[ANY], SWIGTYPE & "$result = $1;";
|
||
|
|
#ifdef __cplusplus
|
||
|
|
%typemap(out) SWIGTYPE "$result = new $1_type($1);";
|
||
|
|
#else
|
||
|
|
%typemap(out) SWIGTYPE {
|
||
|
|
$result = ($&1_ltype) malloc(sizeof($1_type));
|
||
|
|
memmove($result, &$1, sizeof($1_type));
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
|
||
|
|
//////////////////////////////////////////////////////////////
|
||
|
|
// UCS-2 string conversion
|
||
|
|
|
||
|
|
// should this be SWIG_TYPECHECK_CHAR?
|
||
|
|
%typecheck(SWIG_TYPECHECK_UNICHAR) wchar_t { $1 = 1; };
|
||
|
|
|
||
|
|
%typemap(in) wchar_t "$1 = $input;";
|
||
|
|
%typemap(lin,numinputs=1) wchar_t "(cl::let (($out (cl:char-code $in)))\n $body)";
|
||
|
|
%typemap(lin,numinputs=1) wchar_t* "(excl:with-native-string ($out $in
|
||
|
|
:external-format #+little-endian :fat-le #-little-endian :fat)\n
|
||
|
|
$body)"
|
||
|
|
|
||
|
|
%typemap(out) wchar_t "$result = $1;";
|
||
|
|
%typemap(lout) wchar_t "(cl::setq ACL_ffresult (cl::code-char $body))";
|
||
|
|
%typemap(lout) wchar_t* "(cl::setq ACL_ffresult (excl:native-to-string $body
|
||
|
|
:external-format #+little-endian :fat-le #-little-endian :fat))";
|
||
|
|
|
||
|
|
%typemap(ffitype) wchar_t ":unsigned-short";
|
||
|
|
%typemap(lisptype) wchar_t "";
|
||
|
|
%typemap(ctype) wchar_t "wchar_t";
|
||
|
|
%typemap(lispclass) wchar_t "cl:character";
|
||
|
|
%typemap(lispclass) wchar_t* "cl:string";
|
||
|
|
//////////////////////////////////////////////////////////////
|
||
|
|
|
||
|
|
/* name conversion for overloaded operators. */
|
||
|
|
#ifdef __cplusplus
|
||
|
|
%rename(__add__) *::operator+;
|
||
|
|
%rename(__pos__) *::operator+();
|
||
|
|
%rename(__pos__) *::operator+() const;
|
||
|
|
|
||
|
|
%rename(__sub__) *::operator-;
|
||
|
|
%rename(__neg__) *::operator-() const;
|
||
|
|
%rename(__neg__) *::operator-();
|
||
|
|
|
||
|
|
%rename(__mul__) *::operator*;
|
||
|
|
%rename(__deref__) *::operator*();
|
||
|
|
%rename(__deref__) *::operator*() const;
|
||
|
|
|
||
|
|
%rename(__div__) *::operator/;
|
||
|
|
%rename(__mod__) *::operator%;
|
||
|
|
%rename(__logxor__) *::operator^;
|
||
|
|
%rename(__logand__) *::operator&;
|
||
|
|
%rename(__logior__) *::operator|;
|
||
|
|
%rename(__lognot__) *::operator~();
|
||
|
|
%rename(__lognot__) *::operator~() const;
|
||
|
|
|
||
|
|
%rename(__not__) *::operator!();
|
||
|
|
%rename(__not__) *::operator!() const;
|
||
|
|
|
||
|
|
%rename(__assign__) *::operator=;
|
||
|
|
|
||
|
|
%rename(__add_assign__) *::operator+=;
|
||
|
|
%rename(__sub_assign__) *::operator-=;
|
||
|
|
%rename(__mul_assign__) *::operator*=;
|
||
|
|
%rename(__div_assign__) *::operator/=;
|
||
|
|
%rename(__mod_assign__) *::operator%=;
|
||
|
|
%rename(__logxor_assign__) *::operator^=;
|
||
|
|
%rename(__logand_assign__) *::operator&=;
|
||
|
|
%rename(__logior_assign__) *::operator|=;
|
||
|
|
|
||
|
|
%rename(__lshift__) *::operator<<;
|
||
|
|
%rename(__lshift_assign__) *::operator<<=;
|
||
|
|
%rename(__rshift__) *::operator>>;
|
||
|
|
%rename(__rshift_assign__) *::operator>>=;
|
||
|
|
|
||
|
|
%rename(__eq__) *::operator==;
|
||
|
|
%rename(__ne__) *::operator!=;
|
||
|
|
%rename(__lt__) *::operator<;
|
||
|
|
%rename(__gt__) *::operator>;
|
||
|
|
%rename(__lte__) *::operator<=;
|
||
|
|
%rename(__gte__) *::operator>=;
|
||
|
|
|
||
|
|
%rename(__and__) *::operator&&;
|
||
|
|
%rename(__or__) *::operator||;
|
||
|
|
|
||
|
|
%rename(__preincr__) *::operator++();
|
||
|
|
%rename(__postincr__) *::operator++(int);
|
||
|
|
%rename(__predecr__) *::operator--();
|
||
|
|
%rename(__postdecr__) *::operator--(int);
|
||
|
|
|
||
|
|
%rename(__comma__) *::operator,();
|
||
|
|
%rename(__comma__) *::operator,() const;
|
||
|
|
|
||
|
|
%rename(__member_ref__) *::operator->;
|
||
|
|
%rename(__member_func_ref__) *::operator->*;
|
||
|
|
|
||
|
|
%rename(__funcall__) *::operator();
|
||
|
|
%rename(__aref__) *::operator[];
|
||
|
|
#endif
|
||
|
|
|
||
|
|
%insert("lisphead") %{
|
||
|
|
;; $Id: allegrocl.swg 9901 2007-08-16 18:39:50Z mutandiz $
|
||
|
|
|
||
|
|
(eval-when (compile load eval)
|
||
|
|
|
||
|
|
;; avoid compiling ef-templates at runtime
|
||
|
|
(excl:find-external-format :fat)
|
||
|
|
(excl:find-external-format :fat-le)
|
||
|
|
|
||
|
|
;;; You can define your own identifier converter if you want.
|
||
|
|
;;; Use the -identifier-converter command line argument to
|
||
|
|
;;; specify its name.
|
||
|
|
|
||
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||
|
|
(cl::defparameter *swig-export-list* nil))
|
||
|
|
|
||
|
|
(cl::defconstant *void* :..void..)
|
||
|
|
|
||
|
|
;; parsers to aid in finding SWIG definitions in files.
|
||
|
|
(cl::defun scm-p1 (form)
|
||
|
|
(let* ((info (cl::second form))
|
||
|
|
(id (car info))
|
||
|
|
(id-args (if (eq (cl::car form) 'swig-dispatcher)
|
||
|
|
(cl::cdr info)
|
||
|
|
(cl::cddr info))))
|
||
|
|
(cl::apply *swig-identifier-converter* id
|
||
|
|
(cl::progn (cl::when (cl::eq (cl::car form) 'swig-dispatcher)
|
||
|
|
(cl::remf id-args :arities))
|
||
|
|
id-args))))
|
||
|
|
|
||
|
|
(cl::defmacro defswig1 (name (&rest args) &body body)
|
||
|
|
`(cl::progn (cl::defmacro ,name ,args
|
||
|
|
,@body)
|
||
|
|
(excl::define-simple-parser ,name scm-p1)) )
|
||
|
|
|
||
|
|
(cl::defmacro defswig2 (name (&rest args) &body body)
|
||
|
|
`(cl::progn (cl::defmacro ,name ,args
|
||
|
|
,@body)
|
||
|
|
(excl::define-simple-parser ,name second)))
|
||
|
|
|
||
|
|
(defun read-symbol-from-string (string)
|
||
|
|
(cl::multiple-value-bind (result position)
|
||
|
|
(cl::read-from-string string nil "eof" :preserve-whitespace t)
|
||
|
|
(cl::if (cl::and (cl::symbolp result)
|
||
|
|
(cl::eql position (cl::length string)))
|
||
|
|
result
|
||
|
|
(cl::multiple-value-bind (sym)
|
||
|
|
(cl::intern string)
|
||
|
|
sym))))
|
||
|
|
|
||
|
|
(cl::defun full-name (id type arity class)
|
||
|
|
(cl::case type
|
||
|
|
(:getter (cl::format nil "~@[~A_~]~A" class id))
|
||
|
|
(:constructor (cl::format nil "new_~A~@[~A~]" id arity))
|
||
|
|
(:destructor (cl::format nil "delete_~A" id))
|
||
|
|
(:type (cl::format nil "ff_~A" id))
|
||
|
|
(:slot id)
|
||
|
|
(:ff-operator (cl::format nil "ffi_~A" id))
|
||
|
|
(otherwise (cl::format nil "~@[~A_~]~A~@[~A~]"
|
||
|
|
class id arity))))
|
||
|
|
|
||
|
|
(cl::defun identifier-convert-null (id &key type class arity)
|
||
|
|
(cl::if (cl::eq type :setter)
|
||
|
|
`(cl::setf ,(identifier-convert-null
|
||
|
|
id :type :getter :class class :arity arity))
|
||
|
|
(read-symbol-from-string (full-name id type arity class))))
|
||
|
|
|
||
|
|
(cl::defun identifier-convert-lispify (cname &key type class arity)
|
||
|
|
(cl::assert (cl::stringp cname))
|
||
|
|
(cl::when (cl::eq type :setter)
|
||
|
|
(cl::return-from identifier-convert-lispify
|
||
|
|
`(cl::setf ,(identifier-convert-lispify
|
||
|
|
cname :type :getter :class class :arity arity))))
|
||
|
|
(cl::setq cname (full-name cname type arity class))
|
||
|
|
(cl::if (cl::eq type :constant)
|
||
|
|
(cl::setf cname (cl::format nil "*~A*" cname)))
|
||
|
|
(cl::setf cname (excl::replace-regexp cname "_" "-"))
|
||
|
|
(cl::let ((lastcase :other)
|
||
|
|
newcase char res)
|
||
|
|
(cl::dotimes (n (cl::length cname))
|
||
|
|
(cl::setf char (cl::schar cname n))
|
||
|
|
(excl::if* (cl::alpha-char-p char)
|
||
|
|
then
|
||
|
|
(cl::setf newcase (cl::if (cl::upper-case-p char) :upper :lower))
|
||
|
|
|
||
|
|
(cl::when (cl::or (cl::and (cl::eq lastcase :upper)
|
||
|
|
(cl::eq newcase :lower))
|
||
|
|
(cl::and (cl::eq lastcase :lower)
|
||
|
|
(cl::eq newcase :upper)))
|
||
|
|
;; case change... add a dash
|
||
|
|
(cl::push #\- res)
|
||
|
|
(cl::setf newcase :other))
|
||
|
|
|
||
|
|
(cl::push (cl::char-downcase char) res)
|
||
|
|
|
||
|
|
(cl::setf lastcase newcase)
|
||
|
|
|
||
|
|
else
|
||
|
|
(cl::push char res)
|
||
|
|
(cl::setf lastcase :other)))
|
||
|
|
(read-symbol-from-string (cl::coerce (cl::nreverse res) 'string))))
|
||
|
|
|
||
|
|
(cl::defun id-convert-and-export (name &rest kwargs)
|
||
|
|
(cl::multiple-value-bind (symbol package)
|
||
|
|
(cl::apply *swig-identifier-converter* name kwargs)
|
||
|
|
(cl::let ((args (cl::list (cl::if (cl::consp symbol)
|
||
|
|
(cl::cadr symbol) symbol)
|
||
|
|
(cl::or package cl::*package*))))
|
||
|
|
(cl::apply #'cl::export args)
|
||
|
|
(cl::pushnew args *swig-export-list*))
|
||
|
|
symbol))
|
||
|
|
|
||
|
|
(cl::defmacro swig-insert-id (name namespace &key (type :type) class)
|
||
|
|
`(cl::let ((cl::*package* (cl::find-package ,(package-name-for-namespace namespace))))
|
||
|
|
(id-convert-and-export ,name :type ,type :class ,class)))
|
||
|
|
|
||
|
|
(defswig2 swig-defconstant (string value)
|
||
|
|
(cl::let ((symbol (id-convert-and-export string :type :constant)))
|
||
|
|
`(cl::eval-when (compile load eval)
|
||
|
|
(cl::defconstant ,symbol ,value))))
|
||
|
|
|
||
|
|
(cl::defun maybe-reorder-args (funcname arglist)
|
||
|
|
;; in the foreign setter function the new value will be the last argument
|
||
|
|
;; in Lisp it needs to be the first
|
||
|
|
(cl::if (cl::consp funcname)
|
||
|
|
(cl::append (cl::last arglist) (cl::butlast arglist))
|
||
|
|
arglist))
|
||
|
|
|
||
|
|
(cl::defun maybe-return-value (funcname arglist)
|
||
|
|
;; setf functions should return the new value
|
||
|
|
(cl::when (cl::consp funcname)
|
||
|
|
`(,(cl::if (cl::consp (cl::car arglist))
|
||
|
|
(cl::caar arglist)
|
||
|
|
(cl::car arglist)))))
|
||
|
|
|
||
|
|
(cl::defun swig-anyvarargs-p (arglist)
|
||
|
|
(cl::member :SWIG__varargs_ arglist))
|
||
|
|
|
||
|
|
(defswig1 swig-defun ((name &optional (mangled-name name)
|
||
|
|
&key (type :operator) class arity)
|
||
|
|
arglist kwargs
|
||
|
|
&body body)
|
||
|
|
(cl::let* ((symbol (id-convert-and-export name :type type
|
||
|
|
:arity arity :class class))
|
||
|
|
(mangle (excl::if* (cl::string-equal name mangled-name)
|
||
|
|
then (id-convert-and-export
|
||
|
|
(cl::cond
|
||
|
|
((cl::eq type :setter) (cl::format nil "~A-set" name))
|
||
|
|
((cl::eq type :getter) (cl::format nil "~A-get" name))
|
||
|
|
(t name))
|
||
|
|
:type :ff-operator :arity arity :class class)
|
||
|
|
else (cl::intern mangled-name)))
|
||
|
|
(defun-args (maybe-reorder-args
|
||
|
|
symbol
|
||
|
|
(cl::mapcar #'cl::car (cl::and (cl::not (cl::equal arglist '(:void)))
|
||
|
|
(cl::loop as i in arglist
|
||
|
|
when (cl::eq (cl::car i) :p+)
|
||
|
|
collect (cl::cdr i))))))
|
||
|
|
(ffargs (cl::if (cl::equal arglist '(:void))
|
||
|
|
arglist
|
||
|
|
(cl::mapcar #'cl::cdr arglist)))
|
||
|
|
)
|
||
|
|
(cl::when (swig-anyvarargs-p ffargs)
|
||
|
|
(cl::setq ffargs '()))
|
||
|
|
`(cl::eval-when (compile load eval)
|
||
|
|
(excl::compiler-let ((*record-xref-info* nil))
|
||
|
|
(ff:def-foreign-call (,mangle ,mangled-name) ,ffargs ,@kwargs))
|
||
|
|
(cl::macrolet ((swig-ff-call (&rest args)
|
||
|
|
(cl::cons ',mangle args)))
|
||
|
|
(cl::defun ,symbol ,defun-args
|
||
|
|
,@body
|
||
|
|
,@(maybe-return-value symbol defun-args))))))
|
||
|
|
|
||
|
|
(defswig1 swig-defmethod ((name &optional (mangled-name name)
|
||
|
|
&key (type :operator) class arity)
|
||
|
|
ffargs kwargs
|
||
|
|
&body body)
|
||
|
|
(cl::let* ((symbol (id-convert-and-export name :type type
|
||
|
|
:arity arity :class class))
|
||
|
|
(mangle (cl::intern mangled-name))
|
||
|
|
(defmethod-args (maybe-reorder-args
|
||
|
|
symbol
|
||
|
|
(cl::unless (cl::equal ffargs '(:void))
|
||
|
|
(cl::loop for (lisparg name dispatch) in ffargs
|
||
|
|
when (eq lisparg :p+)
|
||
|
|
collect `(,name ,dispatch)))))
|
||
|
|
(ffargs (cl::if (cl::equal ffargs '(:void))
|
||
|
|
ffargs
|
||
|
|
(cl::loop for (nil name nil . ffi) in ffargs
|
||
|
|
collect `(,name ,@ffi)))))
|
||
|
|
`(cl::eval-when (compile load eval)
|
||
|
|
(excl::compiler-let ((*record-xref-info* nil))
|
||
|
|
(ff:def-foreign-call (,mangle ,mangled-name) ,ffargs ,@kwargs))
|
||
|
|
(cl::macrolet ((swig-ff-call (&rest args)
|
||
|
|
(cl::cons ',mangle args)))
|
||
|
|
(cl::defmethod ,symbol ,defmethod-args
|
||
|
|
,@body
|
||
|
|
,@(maybe-return-value symbol defmethod-args))))))
|
||
|
|
|
||
|
|
(defswig1 swig-dispatcher ((name &key (type :operator) class arities))
|
||
|
|
(cl::let ((symbol (id-convert-and-export name
|
||
|
|
:type type :class class)))
|
||
|
|
`(cl::eval-when (compile load eval)
|
||
|
|
(cl::defun ,symbol (&rest args)
|
||
|
|
(cl::case (cl::length args)
|
||
|
|
,@(cl::loop for arity in arities
|
||
|
|
for symbol-n = (id-convert-and-export name
|
||
|
|
:type type :class class :arity arity)
|
||
|
|
collect `(,arity (cl::apply #',symbol-n args)))
|
||
|
|
(t (cl::error "No applicable wrapper-methods for foreign call ~a with args ~a of classes ~a" ',symbol args (cl::mapcar #'(cl::lambda (x) (cl::class-name (cl::class-of x))) args)))
|
||
|
|
)))))
|
||
|
|
|
||
|
|
(defswig2 swig-def-foreign-stub (name)
|
||
|
|
(cl::let ((lsymbol (id-convert-and-export name :type :class))
|
||
|
|
(symbol (id-convert-and-export name :type :type)))
|
||
|
|
`(cl::eval-when (compile load eval)
|
||
|
|
(ff:def-foreign-type ,symbol (:class ))
|
||
|
|
(cl::defclass ,lsymbol (ff:foreign-pointer) ()))))
|
||
|
|
|
||
|
|
(defswig2 swig-def-foreign-class (name supers &rest rest)
|
||
|
|
(cl::let ((lsymbol (id-convert-and-export name :type :class))
|
||
|
|
(symbol (id-convert-and-export name :type :type)))
|
||
|
|
`(cl::eval-when (compile load eval)
|
||
|
|
(ff:def-foreign-type ,symbol ,@rest)
|
||
|
|
(cl::defclass ,lsymbol ,supers
|
||
|
|
((foreign-type :initform ',symbol :initarg :foreign-type
|
||
|
|
:accessor foreign-pointer-type))))))
|
||
|
|
|
||
|
|
(defswig2 swig-def-foreign-type (name &rest rest)
|
||
|
|
(cl::let ((symbol (id-convert-and-export name :type :type)))
|
||
|
|
`(cl::eval-when (compile load eval)
|
||
|
|
(ff:def-foreign-type ,symbol ,@rest))))
|
||
|
|
|
||
|
|
(defswig2 swig-def-synonym-type (synonym of ff-synonym)
|
||
|
|
`(cl::eval-when (compile load eval)
|
||
|
|
(cl::setf (cl::find-class ',synonym) (cl::find-class ',of))
|
||
|
|
(ff:def-foreign-type ,ff-synonym (:struct ))))
|
||
|
|
|
||
|
|
(cl::defun package-name-for-namespace (namespace)
|
||
|
|
(excl::list-to-delimited-string
|
||
|
|
(cl::cons *swig-module-name*
|
||
|
|
(cl::mapcar #'(cl::lambda (name)
|
||
|
|
(cl::string
|
||
|
|
(cl::funcall *swig-identifier-converter*
|
||
|
|
name
|
||
|
|
:type :namespace)))
|
||
|
|
namespace))
|
||
|
|
"."))
|
||
|
|
|
||
|
|
(cl::defmacro swig-defpackage (namespace)
|
||
|
|
(cl::let* ((parent-namespaces (cl::maplist #'cl::reverse (cl::cdr (cl::reverse namespace))))
|
||
|
|
(parent-strings (cl::mapcar #'package-name-for-namespace
|
||
|
|
parent-namespaces))
|
||
|
|
(string (package-name-for-namespace namespace)))
|
||
|
|
`(cl::eval-when (compile load eval)
|
||
|
|
(cl::defpackage ,string
|
||
|
|
(:use :swig :ff #+ignore '(:common-lisp :ff :excl)
|
||
|
|
,@parent-strings ,*swig-module-name*)
|
||
|
|
(:import-from :cl :* :nil :t)))))
|
||
|
|
|
||
|
|
(cl::defmacro swig-in-package (namespace)
|
||
|
|
`(cl::eval-when (compile load eval)
|
||
|
|
(cl::in-package ,(package-name-for-namespace namespace))))
|
||
|
|
|
||
|
|
(defswig2 swig-defvar (name mangled-name &key type (ftype :unsigned-natural))
|
||
|
|
(cl::let ((symbol (id-convert-and-export name :type type)))
|
||
|
|
`(cl::eval-when (compile load eval)
|
||
|
|
(ff:def-foreign-variable (,symbol ,mangled-name) :type ,ftype))))
|
||
|
|
|
||
|
|
) ;; eval-when
|
||
|
|
|
||
|
|
(cl::eval-when (compile eval)
|
||
|
|
(cl::flet ((starts-with-p (str prefix)
|
||
|
|
(cl::and (cl::>= (cl::length str) (cl::length prefix))
|
||
|
|
(cl::string= str prefix :end1 (cl::length prefix)))))
|
||
|
|
(cl::export (cl::loop for sym being each present-symbol of cl::*package*
|
||
|
|
when (cl::or (starts-with-p (cl::symbol-name sym) (cl::symbol-name :swig-))
|
||
|
|
(starts-with-p (cl::symbol-name sym) (cl::symbol-name :identifier-convert-)))
|
||
|
|
collect sym))))
|
||
|
|
|
||
|
|
%}
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
%{
|
||
|
|
|
||
|
|
#ifdef __cplusplus
|
||
|
|
# define EXTERN extern "C"
|
||
|
|
#else
|
||
|
|
# define EXTERN extern
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#define EXPORT EXTERN SWIGEXPORT
|
||
|
|
|
||
|
|
#include <string.h>
|
||
|
|
#include <stdlib.h>
|
||
|
|
%}
|