allegrocl.swg 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613
  1. /* Define a C preprocessor symbol that can be used in interface files
  2. to distinguish between the SWIG language modules. */
  3. #define SWIG_ALLEGRO_CL
  4. #define %ffargs(...) %feature("ffargs", "1", ##__VA_ARGS__)
  5. %ffargs(strings_convert="t");
  6. /* typemaps for argument and result type conversions. */
  7. %typemap(lin,numinputs=1) SWIGTYPE "(cl::let (($out $in))\n $body)";
  8. %typemap(lout) bool, char, unsigned char, signed char,
  9. short, signed short, unsigned short,
  10. int, signed int, unsigned int,
  11. long, signed long, unsigned long,
  12. float, double, long double, char *, void *,
  13. enum SWIGTYPE "(cl::setq ACL_ffresult $body)";
  14. %typemap(lout) void "$body";
  15. #ifdef __cplusplus
  16. %typemap(lout) SWIGTYPE[ANY], SWIGTYPE *, SWIGTYPE &, SWIGTYPE &&
  17. %{ (cl:let* ((address $body)
  18. (new-inst (cl:make-instance '$lclass :foreign-address address)))
  19. (cl:when (cl:and $owner (cl:not (cl:zerop address)))
  20. (excl:schedule-finalization new-inst #'$ldestructor))
  21. (cl:setq ACL_ffresult new-inst)) %}
  22. %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))";
  23. #else
  24. %typemap(lout) SWIGTYPE[ANY], SWIGTYPE *, SWIGTYPE &, SWIGTYPE &&, SWIGTYPE
  25. %{ (cl:let* ((address $body)
  26. (new-inst (cl:make-instance '$lclass :foreign-address address)))
  27. (cl:setq ACL_ffresult new-inst)) %}
  28. #endif
  29. %typemap(lisptype) bool, const bool "cl:boolean";
  30. %typemap(lisptype) char, const char "cl:character";
  31. %typemap(lisptype) unsigned char, const unsigned char "cl:integer";
  32. %typemap(lisptype) signed char, const signed char "cl:integer";
  33. %typemap(ffitype) bool, const bool ":int";
  34. %typemap(ffitype) char, const char,
  35. signed char, const signed char ":char";
  36. %typemap(ffitype) unsigned char, const unsigned char ":unsigned-char";
  37. %typemap(ffitype) short, const short,
  38. signed short, const signed short ":short";
  39. %typemap(ffitype) unsigned short, const unsigned short ":unsigned-short";
  40. %typemap(ffitype) int, const int, signed int, const signed int ":int";
  41. %typemap(ffitype) unsigned int, const unsigned int ":unsigned-int";
  42. %typemap(ffitype) long, const long, signed long, const signed long ":long";
  43. %typemap(ffitype) unsigned long, const unsigned long ":unsigned-long";
  44. %typemap(ffitype) float, const float ":float";
  45. %typemap(ffitype) double, const double ":double";
  46. %typemap(ffitype) char *, const char *, signed char *,
  47. const signed char *, signed char &,
  48. const signed char & "(* :char)";
  49. %typemap(ffitype) unsigned char *, const unsigned char *,
  50. unsigned char &, const unsigned char & "(* :unsigned-char)";
  51. %typemap(ffitype) short *, const short *, short &,
  52. const short & "(* :short)";
  53. %typemap(ffitype) unsigned short *, const unsigned short *,
  54. unsigned short &, const unsigned short & "(* :unsigned-short)";
  55. %typemap(ffitype) int *, const int *, int &, const int & "(* :int)";
  56. %typemap(ffitype) unsigned int *, const unsigned int *,
  57. unsigned int &, const unsigned int & "(* :unsigned-int)";
  58. %typemap(ffitype) void * "(* :void)";
  59. %typemap(ffitype) void ":void";
  60. %typemap(ffitype) enum SWIGTYPE ":int";
  61. %typemap(ffitype) SWIGTYPE & "(* :void)";
  62. %typemap(ffitype) SWIGTYPE && "(* :void)";
  63. /* const typemaps
  64. idea: marshall all primitive c types to their respective lisp types
  65. to maintain const corretness. For pointers/references, all bets
  66. are off if you try to modify them.
  67. idea: add a constant-p slot to the base foreign-pointer class. For
  68. constant pointer/references check this value when setting (around method?)
  69. and error if a setf operation is performed on the address of this object.
  70. */
  71. /*
  72. %exception %{
  73. try {
  74. $action
  75. } catch (...) {
  76. return $null;
  77. }
  78. %}
  79. */
  80. // %typemap(throws) SWIGTYPE {
  81. // (void)$1;
  82. // SWIG_fail;
  83. // }
  84. %typemap(ctype) bool, const bool "int";
  85. %typemap(ctype) char, unsigned char, signed char,
  86. short, signed short, unsigned short,
  87. int, signed int, unsigned int,
  88. long, signed long, unsigned long,
  89. float, double, long double, char *, void *, void,
  90. enum SWIGTYPE, SWIGTYPE *, SWIGTYPE[],
  91. SWIGTYPE[ANY], SWIGTYPE &, SWIGTYPE &&, const SWIGTYPE "$1_ltype";
  92. %typemap(ctype) SWIGTYPE "$&1_type";
  93. %typemap(in) bool "$1 = (bool)$input;";
  94. %typemap(in) char, unsigned char, signed char,
  95. short, signed short, unsigned short,
  96. int, signed int, unsigned int,
  97. long, signed long, unsigned long,
  98. float, double, long double, char *, void *, void,
  99. enum SWIGTYPE, SWIGTYPE *, SWIGTYPE[],
  100. SWIGTYPE[ANY], SWIGTYPE &, SWIGTYPE && "$1 = $input;";
  101. %typemap(in) SWIGTYPE "$1 = *$input;";
  102. /* We don't need to do any actual C-side typechecking, but need to
  103. use the precedence values to choose which overloaded function
  104. interfaces to generate when conflicts arise. */
  105. /* predefined precedence values
  106. Symbolic Name Precedence Value
  107. ------------------------------ ------------------
  108. SWIG_TYPECHECK_POINTER 0
  109. SWIG_TYPECHECK_VOIDPTR 10
  110. SWIG_TYPECHECK_BOOL 15
  111. SWIG_TYPECHECK_UINT8 20
  112. SWIG_TYPECHECK_INT8 25
  113. SWIG_TYPECHECK_UINT16 30
  114. SWIG_TYPECHECK_INT16 35
  115. SWIG_TYPECHECK_UINT32 40
  116. SWIG_TYPECHECK_INT32 45
  117. SWIG_TYPECHECK_UINT64 50
  118. SWIG_TYPECHECK_INT64 55
  119. SWIG_TYPECHECK_UINT128 60
  120. SWIG_TYPECHECK_INT128 65
  121. SWIG_TYPECHECK_INTEGER 70
  122. SWIG_TYPECHECK_FLOAT 80
  123. SWIG_TYPECHECK_DOUBLE 90
  124. SWIG_TYPECHECK_COMPLEX 100
  125. SWIG_TYPECHECK_UNICHAR 110
  126. SWIG_TYPECHECK_UNISTRING 120
  127. SWIG_TYPECHECK_CHAR 130
  128. SWIG_TYPECHECK_STRING 140
  129. SWIG_TYPECHECK_BOOL_ARRAY 1015
  130. SWIG_TYPECHECK_INT8_ARRAY 1025
  131. SWIG_TYPECHECK_INT16_ARRAY 1035
  132. SWIG_TYPECHECK_INT32_ARRAY 1045
  133. SWIG_TYPECHECK_INT64_ARRAY 1055
  134. SWIG_TYPECHECK_INT128_ARRAY 1065
  135. SWIG_TYPECHECK_FLOAT_ARRAY 1080
  136. SWIG_TYPECHECK_DOUBLE_ARRAY 1090
  137. SWIG_TYPECHECK_CHAR_ARRAY 1130
  138. SWIG_TYPECHECK_STRING_ARRAY 1140
  139. */
  140. %typecheck(SWIG_TYPECHECK_BOOL) bool { $1 = 1; };
  141. %typecheck(SWIG_TYPECHECK_CHAR) char { $1 = 1; };
  142. %typecheck(SWIG_TYPECHECK_FLOAT) float { $1 = 1; };
  143. %typecheck(SWIG_TYPECHECK_DOUBLE) double { $1 = 1; };
  144. %typecheck(SWIG_TYPECHECK_STRING) char * { $1 = 1; };
  145. %typecheck(SWIG_TYPECHECK_INTEGER)
  146. unsigned char, signed char,
  147. short, signed short, unsigned short,
  148. int, signed int, unsigned int,
  149. long, signed long, unsigned long,
  150. enum SWIGTYPE { $1 = 1; };
  151. %typecheck(SWIG_TYPECHECK_POINTER) SWIGTYPE *, SWIGTYPE &, SWIGTYPE &&,
  152. SWIGTYPE[], SWIGTYPE[ANY],
  153. SWIGTYPE { $1 = 1; };
  154. /* This maps C/C++ types to Lisp classes for overload dispatch */
  155. %typemap(lispclass) bool "t";
  156. %typemap(lispclass) char "cl:character";
  157. %typemap(lispclass) unsigned char, signed char,
  158. short, signed short, unsigned short,
  159. int, signed int, unsigned int,
  160. long, signed long, unsigned long,
  161. enum SWIGTYPE "cl:integer";
  162. %typemap(lispclass) float "cl:single-float";
  163. %typemap(lispclass) double "cl:double-float";
  164. %typemap(lispclass) char * "cl:string";
  165. %typemap(out) void "";
  166. %typemap(out) bool "$result = (int)$1;";
  167. %typemap(out) char, unsigned char, signed char,
  168. short, signed short, unsigned short,
  169. int, signed int, unsigned int,
  170. long, signed long, unsigned long,
  171. float, double, long double, char *, void *,
  172. enum SWIGTYPE, SWIGTYPE *,
  173. SWIGTYPE[ANY], SWIGTYPE &, SWIGTYPE && "$result = $1;";
  174. #ifdef __cplusplus
  175. %typemap(out) SWIGTYPE "$result = new $1_ltype($1);";
  176. #else
  177. %typemap(out) SWIGTYPE {
  178. $result = ($&1_ltype) malloc(sizeof($1_type));
  179. memmove($result, &$1, sizeof($1_type));
  180. }
  181. #endif
  182. //////////////////////////////////////////////////////////////
  183. // UCS-2 string conversion
  184. // should this be SWIG_TYPECHECK_CHAR?
  185. %typecheck(SWIG_TYPECHECK_UNICHAR) wchar_t { $1 = 1; };
  186. %typemap(in) wchar_t "$1 = $input;";
  187. %typemap(lin,numinputs=1) wchar_t "(cl::let (($out (cl:char-code $in)))\n $body)";
  188. %typemap(lin,numinputs=1) wchar_t * "(excl:with-native-string ($out $in
  189. :external-format #+little-endian :fat-le #-little-endian :fat)\n
  190. $body)"
  191. %typemap(out) wchar_t "$result = $1;";
  192. %typemap(lout) wchar_t "(cl::setq ACL_ffresult (cl::code-char $body))";
  193. %typemap(lout) wchar_t * "(cl::setq ACL_ffresult (excl:native-to-string $body
  194. :external-format #+little-endian :fat-le #-little-endian :fat))";
  195. %typemap(ffitype) wchar_t ":unsigned-short";
  196. %typemap(lisptype) wchar_t "";
  197. %typemap(ctype) wchar_t "wchar_t";
  198. %typemap(lispclass) wchar_t "cl:character";
  199. %typemap(lispclass) wchar_t * "cl:string";
  200. //////////////////////////////////////////////////////////////
  201. /* Array reference typemaps */
  202. %apply SWIGTYPE & { SWIGTYPE ((&)[ANY]) }
  203. %apply SWIGTYPE && { SWIGTYPE ((&&)[ANY]) }
  204. /* const pointers */
  205. %apply SWIGTYPE * { SWIGTYPE *const }
  206. /* name conversion for overloaded operators. */
  207. #ifdef __cplusplus
  208. %rename(__add__) *::operator+;
  209. %rename(__pos__) *::operator+();
  210. %rename(__pos__) *::operator+() const;
  211. %rename(__sub__) *::operator-;
  212. %rename(__neg__) *::operator-() const;
  213. %rename(__neg__) *::operator-();
  214. %rename(__mul__) *::operator*;
  215. %rename(__deref__) *::operator*();
  216. %rename(__deref__) *::operator*() const;
  217. %rename(__div__) *::operator/;
  218. %rename(__mod__) *::operator%;
  219. %rename(__logxor__) *::operator^;
  220. %rename(__logand__) *::operator&;
  221. %rename(__logior__) *::operator|;
  222. %rename(__lognot__) *::operator~();
  223. %rename(__lognot__) *::operator~() const;
  224. %rename(__not__) *::operator!();
  225. %rename(__not__) *::operator!() const;
  226. %rename(__assign__) *::operator=;
  227. %rename(__add_assign__) *::operator+=;
  228. %rename(__sub_assign__) *::operator-=;
  229. %rename(__mul_assign__) *::operator*=;
  230. %rename(__div_assign__) *::operator/=;
  231. %rename(__mod_assign__) *::operator%=;
  232. %rename(__logxor_assign__) *::operator^=;
  233. %rename(__logand_assign__) *::operator&=;
  234. %rename(__logior_assign__) *::operator|=;
  235. %rename(__lshift__) *::operator<<;
  236. %rename(__lshift_assign__) *::operator<<=;
  237. %rename(__rshift__) *::operator>>;
  238. %rename(__rshift_assign__) *::operator>>=;
  239. %rename(__eq__) *::operator==;
  240. %rename(__ne__) *::operator!=;
  241. %rename(__lt__) *::operator<;
  242. %rename(__gt__) *::operator>;
  243. %rename(__lte__) *::operator<=;
  244. %rename(__gte__) *::operator>=;
  245. %rename(__and__) *::operator&&;
  246. %rename(__or__) *::operator||;
  247. %rename(__preincr__) *::operator++();
  248. %rename(__postincr__) *::operator++(int);
  249. %rename(__predecr__) *::operator--();
  250. %rename(__postdecr__) *::operator--(int);
  251. %rename(__comma__) *::operator,();
  252. %rename(__comma__) *::operator,() const;
  253. %rename(__member_ref__) *::operator->;
  254. %rename(__member_func_ref__) *::operator->*;
  255. %rename(__funcall__) *::operator();
  256. %rename(__aref__) *::operator[];
  257. %rename(__bool__) *::operator bool();
  258. %rename(__bool__) *::operator bool() const;
  259. #endif
  260. %insert("lisphead") %{
  261. (eval-when (:compile-toplevel :load-toplevel :execute)
  262. ;; avoid compiling ef-templates at runtime
  263. (excl:find-external-format :fat)
  264. (excl:find-external-format :fat-le)
  265. ;;; You can define your own identifier converter if you want.
  266. ;;; Use the -identifier-converter command line argument to
  267. ;;; specify its name.
  268. (eval-when (:compile-toplevel :load-toplevel :execute)
  269. (cl::defparameter *swig-export-list* nil))
  270. (cl::defconstant *void* :..void..)
  271. ;; parsers to aid in finding SWIG definitions in files.
  272. (cl::defun scm-p1 (form)
  273. (let* ((info (cl::second form))
  274. (id (car info))
  275. (id-args (if (eq (cl::car form) 'swig-dispatcher)
  276. (cl::cdr info)
  277. (cl::cddr info))))
  278. (cl::apply *swig-identifier-converter* id
  279. (cl::progn (cl::when (cl::eq (cl::car form) 'swig-dispatcher)
  280. (cl::remf id-args :arities))
  281. id-args))))
  282. (cl::defmacro defswig1 (name (&rest args) &body body)
  283. `(cl::progn (cl::defmacro ,name ,args
  284. ,@body)
  285. (excl::define-simple-parser ,name scm-p1)) )
  286. (cl::defmacro defswig2 (name (&rest args) &body body)
  287. `(cl::progn (cl::defmacro ,name ,args
  288. ,@body)
  289. (excl::define-simple-parser ,name second)))
  290. (defun read-symbol-from-string (string)
  291. (cl::multiple-value-bind (result position)
  292. (cl::read-from-string string nil "eof" :preserve-whitespace t)
  293. (cl::if (cl::and (cl::symbolp result)
  294. (cl::eql position (cl::length string)))
  295. result
  296. (cl::multiple-value-bind (sym)
  297. (cl::intern string)
  298. sym))))
  299. (cl::defun full-name (id type arity class)
  300. ; We need some kind of a hack here to handle template classes
  301. ; and other synonym types right. We need the original name.
  302. (let*( (sym (read-symbol-from-string
  303. (if (eq *swig-identifier-converter* 'identifier-convert-lispify)
  304. (string-lispify id)
  305. id)))
  306. (sym-class (find-class sym nil))
  307. (id (cond ( (not sym-class)
  308. id )
  309. ( (and sym-class
  310. (not (eq (class-name sym-class)
  311. sym)))
  312. (class-name sym-class) )
  313. ( t
  314. id ))) )
  315. (cl::case type
  316. (:getter (cl::format nil "~@[~A_~]~A" class id))
  317. (:constructor (cl::format nil "new_~A~@[~A~]" id arity))
  318. (:destructor (cl::format nil "delete_~A" id))
  319. (:type (cl::format nil "ff_~A" id))
  320. (:slot id)
  321. (:ff-operator (cl::format nil "ffi_~A" id))
  322. (otherwise (cl::format nil "~@[~A_~]~A~@[~A~]"
  323. class id arity)))))
  324. (cl::defun identifier-convert-null (id &key type class arity)
  325. (cl::if (cl::eq type :setter)
  326. `(cl::setf ,(identifier-convert-null
  327. id :type :getter :class class :arity arity))
  328. (read-symbol-from-string (full-name id type arity class))))
  329. (cl::defun string-lispify (str)
  330. (cl::let ( (cname (excl::replace-regexp str "_" "-"))
  331. (lastcase :other)
  332. newcase char res )
  333. (cl::dotimes (n (cl::length cname))
  334. (cl::setf char (cl::schar cname n))
  335. (excl::if* (cl::alpha-char-p char)
  336. then
  337. (cl::setf newcase (cl::if (cl::upper-case-p char) :upper :lower))
  338. (cl::when (cl::and (cl::eq lastcase :lower)
  339. (cl::eq newcase :upper))
  340. ;; case change... add a dash
  341. (cl::push #\- res)
  342. (cl::setf newcase :other))
  343. (cl::push (cl::char-downcase char) res)
  344. (cl::setf lastcase newcase)
  345. else
  346. (cl::push char res)
  347. (cl::setf lastcase :other)))
  348. (cl::coerce (cl::nreverse res) 'string)))
  349. (cl::defun identifier-convert-lispify (cname &key type class arity)
  350. (cl::assert (cl::stringp cname))
  351. (cl::when (cl::eq type :setter)
  352. (cl::return-from identifier-convert-lispify
  353. `(cl::setf ,(identifier-convert-lispify
  354. cname :type :getter :class class :arity arity))))
  355. (cl::setq cname (full-name cname type arity class))
  356. (cl::if (cl::eq type :constant)
  357. (cl::setf cname (cl::format nil "*~A*" cname)))
  358. (read-symbol-from-string (string-lispify cname)))
  359. (cl::defun id-convert-and-export (name &rest kwargs)
  360. (cl::multiple-value-bind (symbol package)
  361. (cl::apply *swig-identifier-converter* name kwargs)
  362. (cl::let ((args (cl::list (cl::if (cl::consp symbol)
  363. (cl::cadr symbol) symbol)
  364. (cl::or package cl::*package*))))
  365. (cl::apply #'cl::export args)
  366. (cl::pushnew args *swig-export-list*))
  367. symbol))
  368. (cl::defmacro swig-insert-id (name namespace &key (type :type) class)
  369. `(cl::let ((cl::*package* (cl::find-package ,(package-name-for-namespace namespace))))
  370. (id-convert-and-export ,name :type ,type :class ,class)))
  371. (defswig2 swig-defconstant (string value)
  372. (cl::let ((symbol (id-convert-and-export string :type :constant)))
  373. `(cl::eval-when (:compile-toplevel :load-toplevel :execute)
  374. (cl::defconstant ,symbol ,value))))
  375. (cl::defun maybe-reorder-args (funcname arglist)
  376. ;; in the foreign setter function the new value will be the last argument
  377. ;; in Lisp it needs to be the first
  378. (cl::if (cl::consp funcname)
  379. (cl::append (cl::last arglist) (cl::butlast arglist))
  380. arglist))
  381. (cl::defun maybe-return-value (funcname arglist)
  382. ;; setf functions should return the new value
  383. (cl::when (cl::consp funcname)
  384. `(,(cl::if (cl::consp (cl::car arglist))
  385. (cl::caar arglist)
  386. (cl::car arglist)))))
  387. (cl::defun swig-anyvarargs-p (arglist)
  388. (cl::member :SWIG__varargs_ arglist))
  389. (defswig1 swig-defun ((name &optional (mangled-name name)
  390. &key (type :operator) class arity)
  391. arglist kwargs
  392. &body body)
  393. (cl::let* ((symbol (id-convert-and-export name :type type
  394. :arity arity :class class))
  395. (mangle (excl::if* (cl::string-equal name mangled-name)
  396. then (id-convert-and-export
  397. (cl::cond
  398. ((cl::eq type :setter) (cl::format nil "~A-set" name))
  399. ((cl::eq type :getter) (cl::format nil "~A-get" name))
  400. (t name))
  401. :type :ff-operator :arity arity :class class)
  402. else (cl::intern mangled-name)))
  403. (defun-args (maybe-reorder-args
  404. symbol
  405. (cl::mapcar #'cl::car (cl::and (cl::not (cl::equal arglist '(:void)))
  406. (cl::loop as i in arglist
  407. when (cl::eq (cl::car i) :p+)
  408. collect (cl::cdr i))))))
  409. (ffargs (cl::if (cl::equal arglist '(:void))
  410. arglist
  411. (cl::mapcar #'cl::cdr arglist)))
  412. )
  413. (cl::when (swig-anyvarargs-p ffargs)
  414. (cl::setq ffargs '()))
  415. `(cl::eval-when (:compile-toplevel :load-toplevel :execute)
  416. (excl::compiler-let ((*record-xref-info* nil))
  417. (ff:def-foreign-call (,mangle ,mangled-name) ,ffargs ,@kwargs))
  418. (cl::macrolet ((swig-ff-call (&rest args)
  419. (cl::cons ',mangle args)))
  420. (cl::defun ,symbol ,defun-args
  421. ,@body
  422. ,@(maybe-return-value symbol defun-args))))))
  423. (defswig1 swig-defmethod ((name &optional (mangled-name name)
  424. &key (type :operator) class arity)
  425. ffargs kwargs
  426. &body body)
  427. (cl::let* ((symbol (id-convert-and-export name :type type
  428. :arity arity :class class))
  429. (mangle (cl::intern mangled-name))
  430. (defmethod-args (maybe-reorder-args
  431. symbol
  432. (cl::unless (cl::equal ffargs '(:void))
  433. (cl::loop for (lisparg name dispatch) in ffargs
  434. when (eq lisparg :p+)
  435. collect `(,name ,dispatch)))))
  436. (ffargs (cl::if (cl::equal ffargs '(:void))
  437. ffargs
  438. (cl::loop for (nil name nil . ffi) in ffargs
  439. collect `(,name ,@ffi)))))
  440. `(cl::eval-when (:compile-toplevel :load-toplevel :execute)
  441. (excl::compiler-let ((*record-xref-info* nil))
  442. (ff:def-foreign-call (,mangle ,mangled-name) ,ffargs ,@kwargs))
  443. (cl::macrolet ((swig-ff-call (&rest args)
  444. (cl::cons ',mangle args)))
  445. (cl::defmethod ,symbol ,defmethod-args
  446. ,@body
  447. ,@(maybe-return-value symbol defmethod-args))))))
  448. (defswig1 swig-dispatcher ((name &key (type :operator) class arities))
  449. (cl::let ((symbol (id-convert-and-export name
  450. :type type :class class)))
  451. `(cl::eval-when (:compile-toplevel :load-toplevel :execute)
  452. (cl::defun ,symbol (&rest args)
  453. (cl::case (cl::length args)
  454. ,@(cl::loop for arity in arities
  455. for symbol-n = (id-convert-and-export name
  456. :type type :class class :arity arity)
  457. collect `(,arity (cl::apply #',symbol-n args)))
  458. (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)))
  459. )))))
  460. (defswig2 swig-def-foreign-stub (name)
  461. (cl::let ((lsymbol (id-convert-and-export name :type :class))
  462. (symbol (id-convert-and-export name :type :type)))
  463. `(cl::eval-when (:compile-toplevel :load-toplevel :execute)
  464. (ff:def-foreign-type ,symbol (:class ))
  465. (cl::defclass ,lsymbol (ff:foreign-pointer) ()))))
  466. (defswig2 swig-def-foreign-class (name supers &rest rest)
  467. (cl::let ((lsymbol (id-convert-and-export name :type :class))
  468. (symbol (id-convert-and-export name :type :type)))
  469. `(cl::eval-when (:compile-toplevel :load-toplevel :execute)
  470. (ff:def-foreign-type ,symbol ,@rest)
  471. (cl::defclass ,lsymbol ,supers
  472. ((foreign-type :initform ',symbol :initarg :foreign-type
  473. :accessor foreign-pointer-type))))))
  474. (defswig2 swig-def-foreign-type (name &rest rest)
  475. (cl::let ((symbol (id-convert-and-export name :type :type)))
  476. `(cl::eval-when (:compile-toplevel :load-toplevel :execute)
  477. (ff:def-foreign-type ,symbol ,@rest))))
  478. (defswig2 swig-def-synonym-type (synonym of ff-synonym)
  479. `(cl::eval-when (:compile-toplevel :load-toplevel :execute)
  480. (cl::setf (cl::find-class ',synonym) (cl::find-class ',of))
  481. (ff:def-foreign-type ,ff-synonym (:struct ))))
  482. (cl::defun package-name-for-namespace (namespace)
  483. (excl::list-to-delimited-string
  484. (cl::cons *swig-module-name*
  485. (cl::mapcar #'(cl::lambda (name)
  486. (cl::string
  487. (cl::funcall *swig-identifier-converter*
  488. name
  489. :type :namespace)))
  490. namespace))
  491. "."))
  492. (cl::defmacro swig-defpackage (namespace)
  493. (cl::let* ((parent-namespaces (cl::maplist #'cl::reverse (cl::cdr (cl::reverse namespace))))
  494. (parent-strings (cl::mapcar #'package-name-for-namespace
  495. parent-namespaces))
  496. (string (package-name-for-namespace namespace)))
  497. `(cl::eval-when (:compile-toplevel :load-toplevel :execute)
  498. (cl::defpackage ,string
  499. (:use :swig :ff #+ignore '(:common-lisp :ff :excl)
  500. ,@parent-strings ,*swig-module-name*)
  501. (:import-from :cl :* :nil :t)))))
  502. (cl::defmacro swig-in-package (namespace)
  503. `(cl::eval-when (:compile-toplevel :load-toplevel :execute)
  504. (cl::in-package ,(package-name-for-namespace namespace))))
  505. (defswig2 swig-defvar (name mangled-name &key type (ftype :unsigned-natural))
  506. (cl::let ((symbol (id-convert-and-export name :type type)))
  507. `(cl::eval-when (:compile-toplevel :load-toplevel :execute)
  508. (ff:def-foreign-variable (,symbol ,mangled-name) :type ,ftype))))
  509. ) ;; eval-when
  510. (cl::eval-when (:compile-toplevel :execute)
  511. (cl::flet ((starts-with-p (str prefix)
  512. (cl::and (cl::>= (cl::length str) (cl::length prefix))
  513. (cl::string= str prefix :end1 (cl::length prefix)))))
  514. (cl::export (cl::loop for sym being each present-symbol of cl::*package*
  515. when (cl::or (starts-with-p (cl::symbol-name sym) (cl::symbol-name :swig-))
  516. (starts-with-p (cl::symbol-name sym) (cl::symbol-name :identifier-convert-)))
  517. collect sym))))
  518. %}
  519. typedef void *__SWIGACL_FwdReference;
  520. %{
  521. #ifdef __cplusplus
  522. # define EXTERN extern "C"
  523. #else
  524. # define EXTERN extern
  525. #endif
  526. #define EXPORT EXTERN SWIGEXPORT
  527. typedef void *__SWIGACL_FwdReference;
  528. #include <string.h>
  529. #include <stdlib.h>
  530. %}