PageRenderTime 46ms CodeModel.GetById 20ms app.highlight 22ms RepoModel.GetById 1ms app.codeStats 0ms

/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%}