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