123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613 |
- /* 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 &, 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 &&, 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)";
- %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 &, 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 &, 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[], 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 &, 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]) }
- %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>
- %}
|