| /* 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"; |
| #ifdef __cplusplus |
| %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))"; |
| #else |
| %typemap(lout) SWIGTYPE[ANY], SWIGTYPE *, SWIGTYPE &, SWIGTYPE |
| %{ (cl:let* ((address $body) |
| (new-inst (cl:make-instance '$lclass :foreign-address address))) |
| (cl:setq ACL_ffresult new-inst)) %} |
| #endif |
| |
| %typemap(lisptype) bool, const bool "cl:boolean"; |
| %typemap(lisptype) char, const char "cl:character"; |
| %typemap(lisptype) unsigned char, const unsigned char "cl:integer"; |
| %typemap(lisptype) signed char, const signed char "cl:integer"; |
| |
| %typemap(ffitype) bool, const bool ":int"; |
| %typemap(ffitype) char, const char, |
| signed char, const signed char ":char"; |
| %typemap(ffitype) unsigned char, const unsigned char ":unsigned-char"; |
| %typemap(ffitype) short, const short, |
| signed short, const signed short ":short"; |
| %typemap(ffitype) unsigned short, const unsigned short ":unsigned-short"; |
| %typemap(ffitype) int, const int, signed int, const signed int ":int"; |
| %typemap(ffitype) unsigned int, const unsigned int ":unsigned-int"; |
| %typemap(ffitype) long, const long, signed long, const signed long ":long"; |
| %typemap(ffitype) unsigned long, const unsigned long ":unsigned-long"; |
| %typemap(ffitype) float, const float ":float"; |
| %typemap(ffitype) double, const double ":double"; |
| %typemap(ffitype) char *, const char *, signed char *, |
| const signed char *, signed char &, |
| const signed char & "(* :char)"; |
| %typemap(ffitype) unsigned char *, const unsigned char *, |
| unsigned char &, const unsigned char & "(* :unsigned-char)"; |
| %typemap(ffitype) short *, const short *, short &, |
| const short & "(* :short)"; |
| %typemap(ffitype) unsigned short *, const unsigned short *, |
| unsigned short &, const unsigned short & "(* :unsigned-short)"; |
| %typemap(ffitype) int *, const int *, int &, const int & "(* :int)"; |
| %typemap(ffitype) unsigned int *, const unsigned int *, |
| unsigned int &, const unsigned int & "(* :unsigned-int)"; |
| %typemap(ffitype) void * "(* :void)"; |
| %typemap(ffitype) void ":void"; |
| %typemap(ffitype) enum SWIGTYPE ":int"; |
| %typemap(ffitype) SWIGTYPE & "(* :void)"; |
| |
| /* const typemaps |
| idea: marshall all primitive c types to their respective lisp types |
| to maintain const corretness. For pointers/references, all bets |
| are off if you try to modify them. |
| |
| idea: add a constant-p slot to the base foreign-pointer class. For |
| constant pointer/references check this value when setting (around method?) |
| and error if a setf operation is performed on the address of this object. |
| |
| */ |
| |
| /* |
| %exception %{ |
| try { |
| $action |
| } catch (...) { |
| return $null; |
| } |
| %} |
| |
| */ |
| |
| // %typemap(throws) SWIGTYPE { |
| // (void)$1; |
| // SWIG_fail; |
| // } |
| |
| %typemap(ctype) bool, const 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[], |
| SWIGTYPE[ANY], SWIGTYPE &, const 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[], |
| 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[], 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) void ""; |
| %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 *, |
| enum SWIGTYPE, SWIGTYPE *, |
| SWIGTYPE[ANY], SWIGTYPE & "$result = $1;"; |
| #ifdef __cplusplus |
| %typemap(out) SWIGTYPE "$result = new $1_ltype($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"; |
| ////////////////////////////////////////////////////////////// |
| |
| /* Array reference typemaps */ |
| %apply SWIGTYPE & { SWIGTYPE ((&)[ANY]) } |
| |
| /* const pointers */ |
| %apply SWIGTYPE * { SWIGTYPE *const } |
| |
| /* 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[]; |
| |
| %rename(__bool__) *::operator bool(); |
| %rename(__bool__) *::operator bool() const; |
| #endif |
| |
| %insert("lisphead") %{ |
| (eval-when (:compile-toplevel :load-toplevel :execute) |
| |
| ;; 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) |
| ; We need some kind of a hack here to handle template classes |
| ; and other synonym types right. We need the original name. |
| (let*( (sym (read-symbol-from-string |
| (if (eq *swig-identifier-converter* 'identifier-convert-lispify) |
| (string-lispify id) |
| id))) |
| (sym-class (find-class sym nil)) |
| (id (cond ( (not sym-class) |
| id ) |
| ( (and sym-class |
| (not (eq (class-name sym-class) |
| sym))) |
| (class-name sym-class) ) |
| ( t |
| id ))) ) |
| (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 string-lispify (str) |
| (cl::let ( (cname (excl::replace-regexp str "_" "-")) |
| (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::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))) |
| (cl::coerce (cl::nreverse res) 'string))) |
| |
| (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))) |
| (read-symbol-from-string (string-lispify cname))) |
| |
| (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-toplevel :load-toplevel :execute) |
| (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-toplevel :load-toplevel :execute) |
| (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-toplevel :load-toplevel :execute) |
| (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-toplevel :load-toplevel :execute) |
| (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-toplevel :load-toplevel :execute) |
| (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-toplevel :load-toplevel :execute) |
| (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-toplevel :load-toplevel :execute) |
| (ff:def-foreign-type ,symbol ,@rest)))) |
| |
| (defswig2 swig-def-synonym-type (synonym of ff-synonym) |
| `(cl::eval-when (:compile-toplevel :load-toplevel :execute) |
| (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-toplevel :load-toplevel :execute) |
| (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-toplevel :load-toplevel :execute) |
| (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-toplevel :load-toplevel :execute) |
| (ff:def-foreign-variable (,symbol ,mangled-name) :type ,ftype)))) |
| |
| ) ;; eval-when |
| |
| (cl::eval-when (:compile-toplevel :execute) |
| (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)))) |
| |
| %} |
| |
| typedef void *__SWIGACL_FwdReference; |
| |
| %{ |
| |
| #ifdef __cplusplus |
| # define EXTERN extern "C" |
| #else |
| # define EXTERN extern |
| #endif |
| |
| #define EXPORT EXTERN SWIGEXPORT |
| |
| typedef void *__SWIGACL_FwdReference; |
| |
| #include <string.h> |
| #include <stdlib.h> |
| %} |
