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