/branches/gsoc2009-ashishs99/Lib/allegrocl/allegrocl.swg

# · Unknown · 605 lines · 522 code · 83 blank · 0 comment · 0 complexity · f00f92dd2ea2b3297f59a174d5399985 MD5 · raw file

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