jyapayne/swig
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

07/19/2006: mutandiz

Browse source 
[allegrocl]
	    - Add std_string.i support.
	    - Add newobject patch submitted by mkoeppe (thanks!)
	    - Fix type name mismatch issue for nested type definitions.
	      specifically typedefs in templated class defns.


git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk/SWIG@9220 626c5289-ae23-0410-ae9c-e8d60b6d4f22
This commit is contained in:
Mikel Bancroft 2006-07-19 21:53:07 +00:00
commit f2ff50e60e
7 changed files with 481 additions and 230 deletions
Download patch file Download diff file Expand all files Collapse all files

7
CHANGES.current
View file

@ -1,5 +1,12 @@
Version 1.3.30 (in progress) Version 1.3.30 (in progress)
============================ ============================
07/19/2006: mutandiz
[allegrocl]
- Add std_string.i support.
- Add newobject patch submitted by mkoeppe (thanks!)
- Fix type name mismatch issue for nested type definitions.
specifically typedefs in templated class defns.
07/18/2006: mgossage 07/18/2006: mgossage
Bugfix #1522858 Bugfix #1522858
updated lua.cxx to support -external-runtime command updated lua.cxx to support -external-runtime command

89
Doc/Manual/Allegrocl.html
View file

@ -204,14 +204,14 @@ int fact(char *statement); // pass it a fact, and it will rate it.
(swig-in-package ()) (swig-in-package ())
(swig-defun ("fact") (swig-defun ("fact")
((PARM0_statement string (* :char) )) ((PARM0_statement cl:string (* :char) ))
(:returning (:int ) (:returning (:int )
:strings-convert t) :strings-convert t)
(let ((SWIG_arg0 PARM0_statement)) (let ((SWIG_arg0 PARM0_statement))
(swig-ff-call SWIG_arg0))) (swig-ff-call SWIG_arg0)))
(swig-defun ("fact") (swig-defun ("fact")
((PARM0_n integer :int )) ((PARM0_n cl:integer :int ))
(:returning (:int ) (:returning (:int )
:strings-convert t) :strings-convert t)
(let ((SWIG_arg0 PARM0_n)) (let ((SWIG_arg0 PARM0_n))
@ -329,14 +329,14 @@ what is generated when parsing C code:
(swig-in-package ()) (swig-in-package ())
(swig-defmethod ("fact" "ACL___fact__SWIG_0" :type :function :arity 1) (swig-defmethod ("fact" "ACL___fact__SWIG_0" :type :function :arity 1)
((PARM0_statement string (* :char) )) ((PARM0_statement cl:string (* :char) ))
(:returning (:int ) (:returning (:int )
:strings-convert t) :strings-convert t)
(let ((SWIG_arg0 PARM0_statement)) (let ((SWIG_arg0 PARM0_statement))
(swig-ff-call SWIG_arg0))) (swig-ff-call SWIG_arg0)))
(swig-defmethod ("fact" "ACL___fact__SWIG_1" :type :function :arity 1) (swig-defmethod ("fact" "ACL___fact__SWIG_1" :type :function :arity 1)
((PARM0_n integer :int )) ((PARM0_n cl:integer :int ))
(:returning (:int ) (:returning (:int )
:strings-convert t) :strings-convert t)
(let ((SWIG_arg0 PARM0_n)) (let ((SWIG_arg0 PARM0_n))
@ -545,8 +545,8 @@ char *xxx();
(swig-in-package ()) (swig-in-package ())
(swig-defmethod ("foo" "ACL___foo__SWIG_0" :type :function :arity 2) (swig-defmethod ("foo" "ACL___foo__SWIG_0" :type :function :arity 2)
((PARM0_f1 single-float :float ) ((PARM0_f1 cl:single-float :float )
(PARM1_f2 single-float :float )) (PARM1_f2 cl:single-float :float ))
(:returning (:int ) (:returning (:int )
:call-direct t :call-direct t
:strings-convert nil) :strings-convert nil)
@ -555,8 +555,8 @@ char *xxx();
(swig-ff-call SWIG_arg0 SWIG_arg1)))) (swig-ff-call SWIG_arg0 SWIG_arg1))))
(swig-defmethod ("foo" "ACL___foo__SWIG_1" :type :function :arity 2) (swig-defmethod ("foo" "ACL___foo__SWIG_1" :type :function :arity 2)
((PARM0_f1 single-float :float ) ((PARM0_f1 cl:single-float :float )
(PARM1_c2 character :char character)) (PARM1_c2 cl:character :char character))
(:returning (:int ) (:returning (:int )
:call-direct t :call-direct t
:strings-convert nil) :strings-convert nil)
@ -672,8 +672,9 @@ char *xxx();
C++ namespaces are translated into Lisp packages by SWIG. The C++ namespaces are translated into Lisp packages by SWIG. The
Global namespace is mapped to a package named by the <tt>%module</tt> Global namespace is mapped to a package named by the <tt>%module</tt>
directive or the <tt>-module</tt> command-line argument. Further directive or the <tt>-module</tt> command-line argument. Further
namespaces are created using Allegro CLs nested namespace convention. namespaces are generated by the <tt>swig-defpackage</tt> utility
For example: function and given names based on Allegro CLs nested namespace
convention. For example:
</p> </p>
<div class="code">foo.i: <div class="code">foo.i:
@ -731,6 +732,16 @@ namespace car {
case preferences, additional naming cues, etc. case preferences, additional naming cues, etc.
</p> </p>
<p>
Note that packages created by <tt>swig-defpackage</tt> do not
use the COMMON-LISP or EXCL package. This reduces possible
conflicts when defining foreign types via the SWIG interface
in <b>all but the toplevel modules package</b>. This may
lead to confusion if, for example, the current package is
<tt>foo.car.tires</tt> and you attempt to use a common-lisp
function such as <tt>(car '(1 2 3)</tt>.
</p>
<H3><a name="Allegrocl_nn16"></a>16.3.2 Constants</H3> <H3><a name="Allegrocl_nn16"></a>16.3.2 Constants</H3>
@ -771,7 +782,7 @@ namespace car {
reduced to literal values, nodes are created, but with no simplification reduced to literal values, nodes are created, but with no simplification
of the constant value. A very very simple infix to prefix converter of the constant value. A very very simple infix to prefix converter
has been implemented that tries to do the right thing for simple cases, but has been implemented that tries to do the right thing for simple cases, but
does not for more complex expressoins. If the literal parser determines does not for more complex expressions. If the literal parser determines
that something is wrong, a warning will be generated and the literal that something is wrong, a warning will be generated and the literal
expression will be included in the generated code, but commented out. expression will be included in the generated code, but commented out.
</p> </p>
@ -788,7 +799,8 @@ namespace car {
</pre> </pre>
</div> </div>
<p> <p>
Users are cautioned to get to know their constants before use. Users are cautioned to get to know their constants before use, or
not use the <tt>-nocwrap</tt> command-line option.
</p> </p>
<H3><a name="Allegrocl_nn17"></a>16.3.3 Variables</H3> <H3><a name="Allegrocl_nn17"></a>16.3.3 Variables</H3>
@ -1399,8 +1411,8 @@ EXPORT float ACL___xxx__SWIG_2 (A *larg1, int larg2) {
<div class="targetlang">overload.cl <div class="targetlang">overload.cl
<pre> <pre>
(swig-defmethod ("xxx" "ACL___xxx__SWIG_0" :type :function :arity 2) (swig-defmethod ("xxx" "ACL___xxx__SWIG_0" :type :function :arity 2)
((PARM0_i integer :int ) ((PARM0_i cl:integer :int )
(PARM1_x integer :int )) (PARM1_x cl:integer :int ))
(:returning (:float ) (:returning (:float )
:strings-convert t) :strings-convert t)
(let ((SWIG_arg0 PARM0_i)) (let ((SWIG_arg0 PARM0_i))
@ -1408,7 +1420,7 @@ EXPORT float ACL___xxx__SWIG_2 (A *larg1, int larg2) {
(swig-ff-call SWIG_arg0 SWIG_arg1)))) (swig-ff-call SWIG_arg0 SWIG_arg1))))
(swig-defmethod ("xxx" "ACL___xxx__SWIG_1" :type :function :arity 1) (swig-defmethod ("xxx" "ACL___xxx__SWIG_1" :type :function :arity 1)
((PARM0_i integer :int )) ((PARM0_i cl:integer :int ))
(:returning (:float ) (:returning (:float )
:strings-convert t) :strings-convert t)
(let ((SWIG_arg0 PARM0_i)) (let ((SWIG_arg0 PARM0_i))
@ -1416,7 +1428,7 @@ EXPORT float ACL___xxx__SWIG_2 (A *larg1, int larg2) {
(swig-defmethod ("xxx" "ACL___xxx__SWIG_2" :type :function :arity 2) (swig-defmethod ("xxx" "ACL___xxx__SWIG_2" :type :function :arity 2)
((PARM0_inst #.(swig-insert-id "A" () :type :class) (* #.(swig-insert-id "A" ())) ) ((PARM0_inst #.(swig-insert-id "A" () :type :class) (* #.(swig-insert-id "A" ())) )
(PARM1_x integer :int )) (PARM1_x cl:integer :int ))
(:returning (:float ) (:returning (:float )
:strings-convert t) :strings-convert t)
(let ((SWIG_arg0 PARM0_inst)) (let ((SWIG_arg0 PARM0_inst))
@ -1776,7 +1788,7 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
<p> <p>
A number of custom typemaps have also been added, to facilitate A number of custom typemaps have also been added to facilitate
the generation of code in the lisp side of the interface. These the generation of code in the lisp side of the interface. These
are described below. The basic code generation structure is are described below. The basic code generation structure is
applied as a series of nested expressions, one for each applied as a series of nested expressions, one for each
@ -1784,6 +1796,13 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
the foreign function call itself. the foreign function call itself.
</p> </p>
<p>
Note that the typemaps below use fully qualified symbols where
necessary. Users writing their own typemaps should do likewise.
See the explanation in the last paragraph of
<a href="#Allegrocl_nn15">16.3.1 Namespaces</a> for details.
</p>
<H4><a name="Allegrocl_nn41"></a>16.4.2.1 LIN Typemap</H4> <H4><a name="Allegrocl_nn41"></a>16.4.2.1 LIN Typemap</H4>
@ -1823,7 +1842,7 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
<div class="code"> <div class="code">
<pre> <pre>
%typemap(lin) SWIGTYPE "(let (($out $in))\n $body)"; %typemap(lin) SWIGTYPE "(cl:let (($out $in))\n $body)";
</pre> </pre>
</div> </div>
@ -1861,10 +1880,10 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
float, double, long double, char *, void *, void, float, double, long double, char *, void *, void,
enum SWIGTYPE "$body"; enum SWIGTYPE "$body";
%typemap(lout) SWIGTYPE[ANY], SWIGTYPE *, %typemap(lout) SWIGTYPE[ANY], SWIGTYPE *,
SWIGTYPE &amp; "(make-instance '$lclass :foreign-address $body)"; SWIGTYPE &amp; "(cl:make-instance '$lclass :foreign-address $body)";
%typemap(lout) SWIGTYPE "(let* ((address $body)\n %typemap(lout) SWIGTYPE "(cl:let* ((address $body)\n
(ACL_result (make-instance '$lclass :foreign-address address)))\n (ACL_result (cl:make-instance '$lclass :foreign-address address)))\n
(unless (zerop address)\n (cl:unless (cl::zerop address)\n
(excl:schedule-finalization ACL_result #'$ldestructor))\n (excl:schedule-finalization ACL_result #'$ldestructor))\n
ACL_result)"; ACL_result)";
</pre> </pre>
@ -1933,10 +1952,10 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
<div class="code"> <div class="code">
<pre> <pre>
%typemap(lisptype) bool "boolean"; %typemap(lisptype) bool "cl:boolean";
%typemap(lisptype) char "character"; %typemap(lisptype) char "cl:character";
%typemap(lisptype) unsigned char "integer"; %typemap(lisptype) unsigned char "cl:integer";
%typemap(lisptype) signed char "integer"; %typemap(lisptype) signed char "cl:integer";
</pre> </pre>
</div> </div>
@ -1952,15 +1971,15 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
<div class="code"> <div class="code">
<pre> <pre>
%typemap(lispclass) bool "t"; %typemap(lispclass) bool "t";
%typemap(lispclass) char "character"; %typemap(lispclass) char "cl:character";
%typemap(lispclass) unsigned char, signed char, %typemap(lispclass) unsigned char, signed char,
short, signed short, unsigned short, short, signed short, unsigned short,
int, signed int, unsigned int, int, signed int, unsigned int,
long, signed long, unsigned long, long, signed long, unsigned long,
enum SWIGTYPE "integer"; enum SWIGTYPE "cl:integer";
%typemap(lispclass) float "single-float"; %typemap(lispclass) float "cl:single-float";
%typemap(lispclass) double "double-float"; %typemap(lispclass) double "cl:double-float";
%typemap(lispclass) char * "string"; %typemap(lispclass) char * "cl:string";
</pre> </pre>
</div> </div>
@ -1977,7 +1996,7 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
%typecheck(SWIG_TYPECHECK_UNICHAR) wchar_t { $1 = 1; }; %typecheck(SWIG_TYPECHECK_UNICHAR) wchar_t { $1 = 1; };
%typemap(in) wchar_t "$1 = $input;"; %typemap(in) wchar_t "$1 = $input;";
%typemap(lin) wchar_t "(let (($out (char-code $in)))\n $body)"; %typemap(lin) wchar_t "(cl:let (($out (cl:char-code $in)))\n $body)";
%typemap(lin) wchar_t* "(excl:with-native-string %typemap(lin) wchar_t* "(excl:with-native-string
($out $in ($out $in
:external-format #+little-endian :fat-le :external-format #+little-endian :fat-le
@ -1985,7 +2004,7 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
$body)" $body)"
%typemap(out) wchar_t "$result = $1;"; %typemap(out) wchar_t "$result = $1;";
%typemap(lout) wchar_t "(code-char $body)"; %typemap(lout) wchar_t "(cl:code-char $body)";
%typemap(lout) wchar_t* "(excl:native-to-string $body %typemap(lout) wchar_t* "(excl:native-to-string $body
:external-format #+little-endian :fat-le :external-format #+little-endian :fat-le
#-little-endian :fat)"; #-little-endian :fat)";
@ -1993,8 +2012,8 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
%typemap(ffitype) wchar_t ":unsigned-short"; %typemap(ffitype) wchar_t ":unsigned-short";
%typemap(lisptype) wchar_t ""; %typemap(lisptype) wchar_t "";
%typemap(ctype) wchar_t "wchar_t"; %typemap(ctype) wchar_t "wchar_t";
%typemap(lispclass) wchar_t "character"; %typemap(lispclass) wchar_t "cl:character";
%typemap(lispclass) wchar_t* "string"; %typemap(lispclass) wchar_t* "cl:string";
</pre> </pre>
</div> </div>

343
Lib/allegrocl/allegrocl.swg
View file

@ -7,24 +7,29 @@
%ffargs(strings_convert="t"); %ffargs(strings_convert="t");
/* typemaps for argument and result type conversions. */ /* typemaps for argument and result type conversions. */
%typemap(lin,numinputs=1) SWIGTYPE "(let (($out $in))\n $body)"; %typemap(lin,numinputs=1) SWIGTYPE "(cl::let (($out $in))\n $body)";
%typemap(lout) bool, char, unsigned char, signed char, %typemap(lout) bool, char, unsigned char, signed char,
short, signed short, unsigned short, short, signed short, unsigned short,
int, signed int, unsigned int, int, signed int, unsigned int,
long, signed long, unsigned long, long, signed long, unsigned long,
float, double, long double, char *, void *, float, double, long double, char *, void *,
enum SWIGTYPE "(setq ACL_ffresult $body)"; enum SWIGTYPE "(cl::setq ACL_ffresult $body)";
%typemap(lout) void "$body"; %typemap(lout) void "$body";
%typemap(lout) SWIGTYPE[ANY], SWIGTYPE *, %typemap(lout) SWIGTYPE[ANY], SWIGTYPE *,
SWIGTYPE & "(setq ACL_ffresult (make-instance '$lclass :foreign-address $body))"; SWIGTYPE &
%{ (let* ((address $body)
(new-inst (make-instance '$lclass :foreign-address address)))
(when (and $owner (not (zerop address)))
(excl:schedule-finalization new-inst #'$ldestructor))
(setq ACL_ffresult new-inst)) %}
%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))"; %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))";
%typemap(lisptype) bool "boolean"; %typemap(lisptype) bool "cl:boolean";
%typemap(lisptype) char "character"; %typemap(lisptype) char "cl:character";
%typemap(lisptype) unsigned char "integer"; %typemap(lisptype) unsigned char "cl:integer";
%typemap(lisptype) signed char "integer"; %typemap(lisptype) signed char "cl:integer";
%typemap(ffitype) bool ":int"; %typemap(ffitype) bool ":int";
%typemap(ffitype) char ":char"; %typemap(ffitype) char ":char";
@ -122,15 +127,15 @@ SWIG_TYPECHECK_STRING_ARRAY 1140
/* This maps C/C++ types to Lisp classes for overload dispatch */ /* This maps C/C++ types to Lisp classes for overload dispatch */
%typemap(lispclass) bool "t"; %typemap(lispclass) bool "t";
%typemap(lispclass) char "character"; %typemap(lispclass) char "cl:character";
%typemap(lispclass) unsigned char, signed char, %typemap(lispclass) unsigned char, signed char,
short, signed short, unsigned short, short, signed short, unsigned short,
int, signed int, unsigned int, int, signed int, unsigned int,
long, signed long, unsigned long, long, signed long, unsigned long,
enum SWIGTYPE "integer"; enum SWIGTYPE "cl:integer";
%typemap(lispclass) float "single-float"; %typemap(lispclass) float "cl:single-float";
%typemap(lispclass) double "double-float"; %typemap(lispclass) double "cl:double-float";
%typemap(lispclass) char * "string"; %typemap(lispclass) char * "cl:string";
%typemap(out) bool "$result = (int)$1;"; %typemap(out) bool "$result = (int)$1;";
%typemap(out) char, unsigned char, signed char, %typemap(out) char, unsigned char, signed char,
@ -156,21 +161,21 @@ SWIG_TYPECHECK_STRING_ARRAY 1140
%typecheck(SWIG_TYPECHECK_UNICHAR) wchar_t { $1 = 1; }; %typecheck(SWIG_TYPECHECK_UNICHAR) wchar_t { $1 = 1; };
%typemap(in) wchar_t "$1 = $input;"; %typemap(in) wchar_t "$1 = $input;";
%typemap(lin,numinputs=1) wchar_t "(let (($out (char-code $in)))\n $body)"; %typemap(lin,numinputs=1) wchar_t "(cl::let (($out (char-code $in)))\n $body)";
%typemap(lin,numinputs=1) wchar_t* "(excl:with-native-string ($out $in %typemap(lin,numinputs=1) wchar_t* "(excl:with-native-string ($out $in
:external-format #+little-endian :fat-le #-little-endian :fat)\n :external-format #+little-endian :fat-le #-little-endian :fat)\n
$body)" $body)"
%typemap(out) wchar_t "$result = $1;"; %typemap(out) wchar_t "$result = $1;";
%typemap(lout) wchar_t "(setq ACL_ffresult (code-char $body))"; %typemap(lout) wchar_t "(cl::setq ACL_ffresult (cl::code-char $body))";
%typemap(lout) wchar_t* "(setq ACL_ffresult (excl:native-to-string $body %typemap(lout) wchar_t* "(cl::setq ACL_ffresult (excl:native-to-string $body
:external-format #+little-endian :fat-le #-little-endian :fat))"; :external-format #+little-endian :fat-le #-little-endian :fat))";
%typemap(ffitype) wchar_t ":unsigned-short"; %typemap(ffitype) wchar_t ":unsigned-short";
%typemap(lisptype) wchar_t ""; %typemap(lisptype) wchar_t "";
%typemap(ctype) wchar_t "wchar_t"; %typemap(ctype) wchar_t "wchar_t";
%typemap(lispclass) wchar_t "character"; %typemap(lispclass) wchar_t "cl:character";
%typemap(lispclass) wchar_t* "string"; %typemap(lispclass) wchar_t* "cl:string";
////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////
/* name conversion for overloaded operators. */ /* name conversion for overloaded operators. */
@ -249,156 +254,161 @@ $body)"
;;; specify its name. ;;; specify its name.
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *swig-export-list* nil)) (cl::defparameter *swig-export-list* nil))
(defconstant *void* :..void..) (cl::defconstant *void* :..void..)
;; parsers to aid in finding SWIG definitions in files. ;; parsers to aid in finding SWIG definitions in files.
(defun scm-p1 (form) (cl::defun scm-p1 (form)
(let* ((info (second form)) (let* ((info (cl::second form))
(id (car info)) (id (car info))
(id-args (if (eq (car form) 'swig-dispatcher) (id-args (if (eq (cl::car form) 'swig-dispatcher)
(cdr info) (cl::cdr info)
(cddr info)))) (cl::cddr info))))
(apply *swig-identifier-converter* id (cl::apply *swig-identifier-converter* id
(progn (when (eq (car form) 'swig-dispatcher) (cl::progn (cl::when (cl::eq (cl::car form) 'swig-dispatcher)
(remf id-args :arities)) (cl::remf id-args :arities))
id-args)))) id-args))))
(defmacro defswig1 (name (&rest args) &body body) (cl::defmacro defswig1 (name (&rest args) &body body)
`(progn (defmacro ,name ,args `(cl::progn (cl::defmacro ,name ,args
,@body) ,@body)
(excl::define-simple-parser ,name scm-p1)) ) (excl::define-simple-parser ,name scm-p1)) )
(defmacro defswig2 (name (&rest args) &body body) (cl::defmacro defswig2 (name (&rest args) &body body)
`(progn (defmacro ,name ,args `(cl::progn (cl::defmacro ,name ,args
,@body) ,@body)
(excl::define-simple-parser ,name second))) (excl::define-simple-parser ,name second)))
(defun read-symbol-from-string (string) (defun read-symbol-from-string (string)
(multiple-value-bind (result position) (cl::multiple-value-bind (result position)
(read-from-string string nil "eof" :preserve-whitespace t) (cl::read-from-string string nil "eof" :preserve-whitespace t)
(if (and (symbolp result) (eql position (length string))) (cl::if (cl::and (cl::symbolp result)
(cl::eql position (cl::length string)))
result result
(multiple-value-bind (sym) (cl::multiple-value-bind (sym)
(intern string) (cl::intern string)
sym)))) sym))))
(defun full-name (id type arity class) (cl::defun full-name (id type arity class)
(case type (cl::case type
(:getter (format nil "~@[~A_~]~A" class id)) (:getter (cl::format nil "~@[~A_~]~A" class id))
(:constructor (format nil "new_~A~@[~A~]" id arity)) (:constructor (cl::format nil "new_~A~@[~A~]" id arity))
(:destructor (format nil "delete_~A" id)) (:destructor (cl::format nil "delete_~A" id))
(:type (format nil "ff_~A" id)) (:type (cl::format nil "ff_~A" id))
(:ff-operator (format nil "ffi_~A" id)) (:ff-operator (cl::format nil "ffi_~A" id))
(otherwise (format nil "~@[~A_~]~A~@[~A~]" (otherwise (cl::format nil "~@[~A_~]~A~@[~A~]"
class id arity)))) class id arity))))
(defun identifier-convert-null (id &key type class arity) (cl::defun identifier-convert-null (id &key type class arity)
(if (eq type :setter) (cl::if (cl::eq type :setter)
`(setf ,(identifier-convert-null `(cl::setf ,(identifier-convert-null
id :type :getter :class class :arity arity)) id :type :getter :class class :arity arity))
(read-symbol-from-string (full-name id type arity class)))) (read-symbol-from-string (full-name id type arity class))))
(defun identifier-convert-lispify (cname &key type class arity) (cl::defun identifier-convert-lispify (cname &key type class arity)
(assert (stringp cname)) (cl::assert (cl::stringp cname))
(when (eq type :setter) (cl::when (cl::eq type :setter)
(return-from identifier-convert-lispify (cl::return-from identifier-convert-lispify
`(setf ,(identifier-convert-lispify `(cl::setf ,(identifier-convert-lispify
cname :type :getter :class class :arity arity)))) cname :type :getter :class class :arity arity))))
(setq cname (full-name cname type arity class)) (cl::setq cname (full-name cname type arity class))
(if (eq type :constant) (cl::if (cl::eq type :constant)
(setf cname (format nil "*~A*" cname))) (cl::setf cname (cl::format nil "*~A*" cname)))
(setf cname (replace-regexp cname "_" "-")) (cl::setf cname (excl::replace-regexp cname "_" "-"))
(let ((lastcase :other) (cl::let ((lastcase :other)
newcase char res) newcase char res)
(dotimes (n (length cname)) (cl::dotimes (n (cl::length cname))
(setf char (schar cname n)) (cl::setf char (cl::schar cname n))
(if* (alpha-char-p char) (excl::if* (cl::alpha-char-p char)
then then
(setf newcase (if (upper-case-p char) :upper :lower)) (cl::setf newcase (cl::if (cl::upper-case-p char) :upper :lower))
(when (or (and (eq lastcase :upper) (eq newcase :lower)) (cl::when (cl::or (cl::and (cl::eq lastcase :upper)
(and (eq lastcase :lower) (eq newcase :upper))) (cl::eq newcase :lower))
(cl::and (cl::eq lastcase :lower)
(cl::eq newcase :upper)))
;; case change... add a dash ;; case change... add a dash
(push #\- res) (cl::push #\- res)
(setf newcase :other)) (cl::setf newcase :other))
(push (char-downcase char) res) (cl::push (cl::char-downcase char) res)
(setf lastcase newcase) (cl::setf lastcase newcase)
else else
(push char res) (cl::push char res)
(setf lastcase :other))) (cl::setf lastcase :other)))
(read-symbol-from-string (coerce (nreverse res) 'string)))) (read-symbol-from-string (cl::coerce (cl::nreverse res) 'string))))
(defun id-convert-and-export (name &rest kwargs) (cl::defun id-convert-and-export (name &rest kwargs)
(multiple-value-bind (symbol package) (cl::multiple-value-bind (symbol package)
(apply *swig-identifier-converter* name kwargs) (cl::apply *swig-identifier-converter* name kwargs)
(let ((args (list (if (consp symbol) (cadr symbol) symbol) (cl::let ((args (cl::list (cl::if (cl::consp symbol)
(or package *package*)))) (cl::cadr symbol) symbol)
(apply #'export args) (cl::or package cl::*package*))))
(pushnew args *swig-export-list*)) (cl::apply #'cl::export args)
(cl::pushnew args *swig-export-list*))
symbol)) symbol))
(defmacro swig-insert-id (name namespace &key (type :type) class) (cl::defmacro swig-insert-id (name namespace &key (type :type) class)
`(let ((*package* (find-package ,(package-name-for-namespace namespace)))) `(cl::let ((cl::*package* (cl::find-package ,(package-name-for-namespace namespace))))
(id-convert-and-export ,name :type ,type :class ,class))) (id-convert-and-export ,name :type ,type :class ,class)))
(defswig2 swig-defconstant (string value) (defswig2 swig-defconstant (string value)
(let ((symbol (id-convert-and-export string :type :constant))) (cl::let ((symbol (id-convert-and-export string :type :constant)))
`(eval-when (compile load eval) `(cl::eval-when (compile load eval)
(defconstant ,symbol ,value)))) (cl::defconstant ,symbol ,value))))
(defun maybe-reorder-args (funcname arglist) (cl::defun maybe-reorder-args (funcname arglist)
;; in the foreign setter function the new value will be the last argument ;; in the foreign setter function the new value will be the last argument
;; in Lisp it needs to be the first ;; in Lisp it needs to be the first
(if (consp funcname) (cl::if (cl::consp funcname)
(append (last arglist) (butlast arglist)) (cl::append (cl::last arglist) (cl::butlast arglist))
arglist)) arglist))
(defun maybe-return-value (funcname arglist) (cl::defun maybe-return-value (funcname arglist)
;; setf functions should return the new value ;; setf functions should return the new value
(when (consp funcname) (cl::when (cl::consp funcname)
`(,(if (consp (car arglist)) `(,(cl::if (cl::consp (cl::car arglist))
(caar arglist) (cl::caar arglist)
(car arglist))))) (cl::car arglist)))))
(defun swig-anyvarargs-p (arglist) (cl::defun swig-anyvarargs-p (arglist)
(member :SWIG__varargs_ arglist)) (cl::member :SWIG__varargs_ arglist))
(defswig1 swig-defun ((name &optional (mangled-name name) (defswig1 swig-defun ((name &optional (mangled-name name)
&key (type :operator) class arity) &key (type :operator) class arity)
arglist kwargs arglist kwargs
&body body) &body body)
(let* ((symbol (id-convert-and-export name :type type (cl::let* ((symbol (id-convert-and-export name :type type
:arity arity :class class)) :arity arity :class class))
(mangle (if* (eq name mangled-name) (mangle (excl::if* (cl::eq name mangled-name)
then (id-convert-and-export then (id-convert-and-export
(cond ((eq type :setter) (format nil "~A-set" name)) (cl::cond
((eq type :getter) (format nil "~A-get" name)) ((cl::eq type :setter) (cl::format nil "~A-set" name))
((cl::eq type :getter) (cl::format nil "~A-get" name))
(t name)) (t name))
:type :ff-operator :arity arity :class class) :type :ff-operator :arity arity :class class)
else (intern mangled-name))) else (cl::intern mangled-name)))
(defun-args (maybe-reorder-args (defun-args (maybe-reorder-args
symbol symbol
(mapcar #'car (and (not (equal arglist '(:void))) (cl::mapcar #'cl::car (cl::and (cl::not (cl::equal arglist '(:void)))
(loop as i in arglist (cl::loop as i in arglist
when (eq (car i) :p+) when (cl::eq (cl::car i) :p+)
collect (cdr i)))))) collect (cl::cdr i))))))
(ffargs (if (equal arglist '(:void)) (ffargs (cl::if (cl::equal arglist '(:void))
arglist arglist
(mapcar #'cdr arglist))) (cl::mapcar #'cl::cdr arglist)))
) )
(when (swig-anyvarargs-p ffargs) (cl::when (swig-anyvarargs-p ffargs)
(setq ffargs '())) (cl::setq ffargs '()))
`(eval-when (compile load eval) `(cl::eval-when (compile load eval)
(excl::compiler-let ((*record-xref-info* nil)) (excl::compiler-let ((*record-xref-info* nil))
(ff:def-foreign-call (,mangle ,mangled-name) ,ffargs ,@kwargs)) (ff:def-foreign-call (,mangle ,mangled-name) ,ffargs ,@kwargs))
(macrolet ((swig-ff-call (&rest args) (cl::macrolet ((swig-ff-call (&rest args)
(cons ',mangle args))) (cl::cons ',mangle args)))
(defun ,symbol ,defun-args (cl::defun ,symbol ,defun-args
,@body ,@body
,@(maybe-return-value symbol defun-args)))))) ,@(maybe-return-value symbol defun-args))))))
@ -406,106 +416,107 @@ $body)"
&key (type :operator) class arity) &key (type :operator) class arity)
ffargs kwargs ffargs kwargs
&body body) &body body)
(let* ((symbol (id-convert-and-export name :type type (cl::let* ((symbol (id-convert-and-export name :type type
:arity arity :class class)) :arity arity :class class))
(mangle (intern mangled-name)) (mangle (cl::intern mangled-name))
(defmethod-args (maybe-reorder-args (defmethod-args (maybe-reorder-args
symbol symbol
(unless (equal ffargs '(:void)) (cl::unless (cl::equal ffargs '(:void))
(loop for (lisparg name dispatch) in ffargs (cl::loop for (lisparg name dispatch) in ffargs
when (eq lisparg :p+) when (eq lisparg :p+)
collect `(,name ,dispatch))))) collect `(,name ,dispatch)))))
(ffargs (if (equal ffargs '(:void)) (ffargs (cl::if (cl::equal ffargs '(:void))
ffargs ffargs
(loop for (nil name nil . ffi) in ffargs (cl::loop for (nil name nil . ffi) in ffargs
collect `(,name ,@ffi))))) collect `(,name ,@ffi)))))
`(eval-when (compile load eval) `(cl::eval-when (compile load eval)
(excl::compiler-let ((*record-xref-info* nil)) (excl::compiler-let ((*record-xref-info* nil))
(ff:def-foreign-call (,mangle ,mangled-name) ,ffargs ,@kwargs)) (ff:def-foreign-call (,mangle ,mangled-name) ,ffargs ,@kwargs))
(macrolet ((swig-ff-call (&rest args) (cl::macrolet ((swig-ff-call (&rest args)
(cons ',mangle args))) (cl::cons ',mangle args)))
(defmethod ,symbol ,defmethod-args (cl::defmethod ,symbol ,defmethod-args
,@body ,@body
,@(maybe-return-value symbol defmethod-args)))))) ,@(maybe-return-value symbol defmethod-args))))))
(defswig1 swig-dispatcher ((name &key (type :operator) class arities)) (defswig1 swig-dispatcher ((name &key (type :operator) class arities))
(let ((symbol (id-convert-and-export name (cl::let ((symbol (id-convert-and-export name
:type type :class class))) :type type :class class)))
`(eval-when (compile load eval) `(cl::eval-when (compile load eval)
(defun ,symbol (&rest args) (cl::defun ,symbol (&rest args)
(case (length args) (cl::case (cl::length args)
,@(loop for arity in arities ,@(cl::loop for arity in arities
for symbol-n = (id-convert-and-export name for symbol-n = (id-convert-and-export name
:type type :class class :arity arity) :type type :class class :arity arity)
collect `(,arity (apply #',symbol-n args))) collect `(,arity (cl::apply #',symbol-n args)))
(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))) (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)))
))))) )))))
(defswig2 swig-def-foreign-stub (name) (defswig2 swig-def-foreign-stub (name)
(let ((lsymbol (id-convert-and-export name :type :class)) (cl::let ((lsymbol (id-convert-and-export name :type :class))
(symbol (id-convert-and-export name :type :type))) (symbol (id-convert-and-export name :type :type)))
`(eval-when (compile load eval) `(cl::eval-when (compile load eval)
(ff:def-foreign-type ,symbol (:class )) (ff:def-foreign-type ,symbol (:class ))
(defclass ,lsymbol (ff:foreign-pointer) ())))) (cl::defclass ,lsymbol (ff:foreign-pointer) ()))))
(defswig2 swig-def-foreign-class (name supers &rest rest) (defswig2 swig-def-foreign-class (name supers &rest rest)
(let ((lsymbol (id-convert-and-export name :type :class)) (cl::let ((lsymbol (id-convert-and-export name :type :class))
(symbol (id-convert-and-export name :type :type))) (symbol (id-convert-and-export name :type :type)))
`(eval-when (compile load eval) `(cl::eval-when (compile load eval)
(ff:def-foreign-type ,symbol ,@rest) (ff:def-foreign-type ,symbol ,@rest)
(defclass ,lsymbol ,supers (cl::defclass ,lsymbol ,supers
((foreign-type :initform ',symbol :initarg :foreign-type ((foreign-type :initform ',symbol :initarg :foreign-type
:accessor foreign-pointer-type)))))) :accessor foreign-pointer-type))))))
(defswig2 swig-def-foreign-type (name &rest rest) (defswig2 swig-def-foreign-type (name &rest rest)
(let ((symbol (id-convert-and-export name :type :type))) (cl::let ((symbol (id-convert-and-export name :type :type)))
`(eval-when (compile load eval) `(cl::eval-when (compile load eval)
(ff:def-foreign-type ,symbol ,@rest)))) (ff:def-foreign-type ,symbol ,@rest))))
(defswig2 swig-def-synonym-type (synonym of ff-synonym) (defswig2 swig-def-synonym-type (synonym of ff-synonym)
`(eval-when (compile load eval) `(cl::eval-when (compile load eval)
(setf (find-class ',synonym) (find-class ',of)) (cl::setf (cl::find-class ',synonym) (cl::find-class ',of))
(ff:def-foreign-type ,ff-synonym (:struct )))) (ff:def-foreign-type ,ff-synonym (:struct ))))
(defun package-name-for-namespace (namespace) (cl::defun package-name-for-namespace (namespace)
(list-to-delimited-string (excl::list-to-delimited-string
(cons *swig-module-name* (cl::cons *swig-module-name*
(mapcar #'(lambda (name) (cl::mapcar #'(cl::lambda (name)
(string (cl::string
(funcall *swig-identifier-converter* (cl::funcall *swig-identifier-converter*
name name
:type :namespace))) :type :namespace)))
namespace)) namespace))
".")) "."))
(defmacro swig-defpackage (namespace) (cl::defmacro swig-defpackage (namespace)
(let* ((parent-namespaces (maplist #'reverse (cdr (reverse namespace)))) (cl::let* ((parent-namespaces (cl::maplist #'cl::reverse (cl::cdr (cl::reverse namespace))))
(parent-strings (mapcar #'package-name-for-namespace (parent-strings (cl::mapcar #'package-name-for-namespace
parent-namespaces)) parent-namespaces))
(string (package-name-for-namespace namespace))) (string (package-name-for-namespace namespace)))
`(eval-when (compile load eval) `(cl::eval-when (compile load eval)
(defpackage ,string (cl::defpackage ,string
(:use :common-lisp :ff :swig :excl (:use :swig :ff #+ignore '(:common-lisp :ff :excl)
,@parent-strings ,*swig-module-name*))))) ,@parent-strings ,*swig-module-name*)
(:import-from :cl "*")))))
(defmacro swig-in-package (namespace) (cl::defmacro swig-in-package (namespace)
`(eval-when (compile load eval) `(cl::eval-when (compile load eval)
(in-package ,(package-name-for-namespace namespace)))) (cl::in-package ,(package-name-for-namespace namespace))))
(defswig2 swig-defvar (name mangled-name &key type) (defswig2 swig-defvar (name mangled-name &key type)
(let ((symbol (id-convert-and-export name :type type))) (cl::let ((symbol (id-convert-and-export name :type type)))
`(eval-when (compile load eval) `(cl::eval-when (compile load eval)
(ff:def-foreign-variable (,symbol ,mangled-name))))) (ff:def-foreign-variable (,symbol ,mangled-name)))))
) ;; eval-when ) ;; eval-when
(eval-when (compile eval) (cl::eval-when (compile eval)
(flet ((starts-with-p (str prefix) (cl::flet ((starts-with-p (str prefix)
(and (>= (length str) (length prefix)) (cl::and (cl::>= (cl::length str) (cl::length prefix))
(string= str prefix :end1 (length prefix))))) (cl::string= str prefix :end1 (cl::length prefix)))))
(export (loop for sym being each present-symbol of *package* (cl::export (cl::loop for sym being each present-symbol of cl::*package*
when (or (starts-with-p (symbol-name sym) (symbol-name :swig-)) when (cl::or (starts-with-p (cl::symbol-name sym) (cl::symbol-name :swig-))
(starts-with-p (symbol-name sym) (symbol-name :identifier-convert-))) (starts-with-p (cl::symbol-name sym) (cl::symbol-name :identifier-convert-)))
collect sym)))) collect sym))))
%} %}

44
Lib/allegrocl/inout_typemaps.i
View file

@ -35,42 +35,42 @@
// $in_fftype, $*in_fftype // $in_fftype, $*in_fftype
INOUT_TYPEMAP(int, INOUT_TYPEMAP(int,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result), (cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in)); (cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(short, INOUT_TYPEMAP(short,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result), (cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in)); (cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(long, INOUT_TYPEMAP(long,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result), (cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in)); (cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(unsigned int, INOUT_TYPEMAP(unsigned int,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result), (cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in)); (cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(unsigned short, INOUT_TYPEMAP(unsigned short,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result), (cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in)); (cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(unsigned long, INOUT_TYPEMAP(unsigned long,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result), (cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in)); (cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(char, INOUT_TYPEMAP(char,
(push (code-char (ff:fslot-value-typed (quote $*in_fftype) :c $out)) (cl::push (code-char (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out))
ACL_result), ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in)); (cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(float, INOUT_TYPEMAP(float,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result), (cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in)); (cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(double, INOUT_TYPEMAP(double,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result), (cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in)); (cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(bool, INOUT_TYPEMAP(bool,
(push (not (zerop (ff:fslot-value-typed (quote $*in_fftype) :c $out))) (cl::push (not (zerop (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out)))
ACL_result), ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) (if $in 1 0))); (cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) (if $in 1 0)));
INOUT_TYPEMAP(char *, INOUT_TYPEMAP(char *,
(push (ff:char*-to-string (ff:fslot-value-typed (quote $*in_fftype) :c $out)) (cl::push (ff:char*-to-string (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out))
ACL_result), ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) (cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out)
(ff:string-to-char* $in))) (ff:string-to-char* $in)))
%typemap(lisptype) bool *INPUT, bool &INPUT "boolean"; %typemap(lisptype) bool *INPUT, bool &INPUT "boolean";

4
Lib/allegrocl/std_list.i
View file

@ -18,7 +18,6 @@
* %template (floatlist) std::list<float>; * %template (floatlist) std::list<float>;
* ----------------------------------------------------------------------------- */ * ----------------------------------------------------------------------------- */
%include "inout_typemaps.i"\
%module std_list %module std_list
%warnfilter(468) std::list; %warnfilter(468) std::list;
@ -72,6 +71,9 @@ namespace std{
%extend %extend
{ {
%typemap(lout) T &__getitem__ "(cl::setq ACL_ffresult (ff:fslot-value-typed '$*out_fftype :c $body))";
%typemap(lout) T *__getitem__ "(cl::setq ACL_ffresult (make-instance '$lclass :foreign-address $body))";
const_reference __getitem__(int i) throw (std::out_of_range) const_reference __getitem__(int i) throw (std::out_of_range)
{ {
std::list<T>::iterator first = self->begin(); std::list<T>::iterator first = self->begin();

197
Lib/allegrocl/std_string.i Executable file
View file

@ -0,0 +1,197 @@
/* -----------------------------------------------------------------------------
* See the LICENSE file for information on copyright, usage and redistribution
* of SWIG, and the README file for authors - http://www.swig.org/release.html.
*
* std_string.i
*
* SWIG typemaps for std::string
* ----------------------------------------------------------------------------- */
// ------------------------------------------------------------------------
// std::string is typemapped by value
// This can prevent exporting methods which return a string
// in order for the user to modify it.
// However, I think I'll wait until someone asks for it...
// ------------------------------------------------------------------------
// %include <exception.i>
%warnfilter(404) std::string;
%warnfilter(404) std::wstring;
%{
#include <string>
// #include <vector>
// using std::vector;
using std::string;
%}
// %include <std_vector.i>
// %naturalvar std::string;
// %naturalvar std::wstring;
namespace std {
typedef unsigned long size_t;
typedef signed long ptrdiff_t;
template <class charT> class basic_string {
public:
typedef charT *pointer;
typedef charT &reference;
typedef const charT &const_reference;
typedef size_t size_type;
typedef ptrdiff_t difference_type;
basic_string();
basic_string( charT *str );
size_type size();
charT operator []( int pos ) const;
charT *c_str() const;
basic_string<charT> &operator = ( const basic_string &ws );
basic_string<charT> &operator = ( const charT *str );
basic_string<charT> &append( const basic_string<charT> &other );
basic_string<charT> &append( const charT *str );
void push_back( charT c );
void clear();
void reserve( size_type t );
void resize( size_type n, charT c = charT() );
int compare( const basic_string<charT> &other ) const;
int compare( const charT *str ) const;
basic_string<charT> &insert( size_type pos,
const basic_string<charT> &str );
size_type find( const basic_string<charT> &other, int pos = 0 ) const;
size_type find( charT c, int pos = 0 ) const;
%extend {
bool operator == ( const basic_string<charT> &other ) const {
return self->compare( other ) == 0;
}
bool operator != ( const basic_string<charT> &other ) const {
return self->compare( other ) != 0;
}
bool operator < ( const basic_string<charT> &other ) const {
return self->compare( other ) == -1;
}
bool operator > ( const basic_string<charT> &other ) const {
return self->compare( other ) == 1;
}
bool operator <= ( const basic_string<charT> &other ) const {
return self->compare( other ) != 1;
}
bool operator >= ( const basic_string<charT> &other ) const {
return self->compare( other ) != -1;
}
}
};
%template(string) basic_string<char>;
%template(wstring) basic_string<wchar_t>;
%apply char * { string };
%apply wchar_t * { wstring };
typedef basic_string<char> string;
typedef basic_string<wchar_t> wstring;
%typemap(ctype) string "char *";
%typemap(in) string "$1 = string($input);";
%typemap(out) string "$result = (char *)(&$1)->c_str();";
%typemap(lisptype) string "cl:string";
%typemap(lout) string "(cl::setq ACL_ffresult $body)";
/* Overloading check */
// %typemap(in) string {
// if (caml_ptr_check($input))
// $1 = std::string((char *)caml_ptr_val($input,0),
// caml_string_len($input));
// else
// SWIG_exception(SWIG_TypeError, "string expected");
// }
// %typemap(in) const string & (std::string temp) {
// if (caml_ptr_check($input)) {
// temp = std::string((char *)caml_ptr_val($input,0),
// caml_string_len($input));
// $1 = &temp;
// } else {
// SWIG_exception(SWIG_TypeError, "string expected");
// }
// }
// %typemap(in) string & (std::string temp) {
// if (caml_ptr_check($input)) {
// temp = std::string((char *)caml_ptr_val($input,0),
// caml_string_len($input));
// $1 = &temp;
// } else {
// SWIG_exception(SWIG_TypeError, "string expected");
// }
// }
// %typemap(in) string * (std::string *temp) {
// if (caml_ptr_check($input)) {
// temp = new std::string((char *)caml_ptr_val($input,0),
// caml_string_len($input));
// $1 = temp;
// } else {
// SWIG_exception(SWIG_TypeError, "string expected");
// }
// }
// %typemap(free) string * (std::string *temp) {
// delete temp;
// }
// %typemap(argout) string & {
// caml_list_append(swig_result,caml_val_string_len((*$1).c_str(),
// (*$1).size()));
// }
// %typemap(directorout) string {
// $result = std::string((char *)caml_ptr_val($input,0),
// caml_string_len($input));
// }
// %typemap(out) string {
// $result = caml_val_string_len($1.c_str(),$1.size());
// }
// %typemap(out) string * {
// $result = caml_val_string_len((*$1).c_str(),(*$1).size());
// }
}
// #ifdef ENABLE_CHARPTR_ARRAY
// char **c_charptr_array( const std::vector <string > &str_v );
// %{
// SWIGEXT char **c_charptr_array( const std::vector <string > &str_v ) {
// char **out = new char *[str_v.size() + 1];
// out[str_v.size()] = 0;
// for( int i = 0; i < str_v.size(); i++ ) {
// out[i] = (char *)str_v[i].c_str();
// }
// return out;
// }
// %}
// #endif
// #ifdef ENABLE_STRING_VECTOR
// %template (StringVector) std::vector<string >;
// %insert(ml) %{
// (* Some STL convenience items *)
// let string_array_to_vector sa =
// let nv = _new_StringVector C_void in
// array_to_vector nv (fun x -> C_string x) sa ; nv
// let c_string_array ar =
// _c_charptr_array (string_array_to_vector ar)
// %}
// %insert(mli) %{
// val c_string_array: string array -> c_obj
// %}
// #endif

27
Source/Modules/allegrocl.cxx
View file

@ -322,7 +322,7 @@ void add_defined_foreign_type(Node *n,
Printf(stderr," templated = '%x', classDecl = '%x'\n", templated, cDeclName); Printf(stderr," templated = '%x', classDecl = '%x'\n", templated, cDeclName);
#endif #endif
if(n) { if(n) {
name=Getattr(n,"sym:name"); if(!name) name=Getattr(n,"sym:name");
if(!name) name = Getattr(n,"name"); if(!name) name = Getattr(n,"name");
if(templated) { if(templated) {
k = namespaced_name(n); k = namespaced_name(n);
@ -381,8 +381,7 @@ void add_defined_foreign_type(Node *n,
if(!val || overwrite || is_fwd_ref) { if(!val || overwrite || is_fwd_ref) {
#ifdef ALLEGROCL_CLASS_DEBUG #ifdef ALLEGROCL_CLASS_DEBUG
Printf(stderr, "Adding defined type '%s' = '%s' '%s' (overwrite=%d)\n", Printf(stderr, "Adding defined type '%s' = '%s' '%s' (overwrite=%d, in-class=%d)\n", k, ns, name, overwrite, in_class);
k, ns, name, overwrite);
#endif #endif
String *mangled_name_gen = String *mangled_name_gen =
NewStringf("#.(swig-insert-id \"%s\" %s :type :type)", name, ns_list); NewStringf("#.(swig-insert-id \"%s\" %s :type :type)", name, ns_list);
@ -602,7 +601,7 @@ void add_defined_foreign_type(Node *n,
Delete(mangled_lname_gen); Delete(mangled_lname_gen);
} else { } else {
Swig_warning(WARN_TYPE_REDEFINED, Getfile(n), Getline(n), Swig_warning(WARN_TYPE_REDEFINED, Getfile(n), Getline(n),
"Attempting to store a foreign type that exists: %s\n", k); "Attempting to store a foreign type that exists: %s (%s)\n", k, val);
} }
Delete(ns_list); Delete(ns_list);
@ -2350,7 +2349,7 @@ int ALLEGROCL :: emit_defun(Node *n, File *f_cl) {
SwigType *result_type = Swig_cparse_type(Getattr(n,"tmap:ctype")); SwigType *result_type = Swig_cparse_type(Getattr(n,"tmap:ctype"));
// prime the pump, with support for OUTPUT, INOUT typemaps. // prime the pump, with support for OUTPUT, INOUT typemaps.
Printf(wrap->code,"(let ((ACL_ffresult %s:*void*)\n ACL_result)\n $body\n (if (eq ACL_ffresult %s:*void*)\n (values-list ACL_result)\n (values-list (cons ACL_ffresult ACL_result))))", swig_package, swig_package); Printf(wrap->code,"(cl::let ((ACL_ffresult %s:*void*)\n ACL_result)\n $body\n (cl::if (cl::eq ACL_ffresult %s:*void*)\n (cl::values-list ACL_result)\n (cl::values-list (cl::cons ACL_ffresult ACL_result))))", swig_package, swig_package);
Parm *p; Parm *p;
int largnum = 0, argnum=0, first=1; int largnum = 0, argnum=0, first=1;
@ -2461,12 +2460,27 @@ int ALLEGROCL :: emit_defun(Node *n, File *f_cl) {
} }
String *lout = Getattr(n,"tmap:lout"); String *lout = Getattr(n,"tmap:lout");
Replaceall(lout, "$owner", GetFlag(n, "feature:new") ? "t" : "nil");
Replaceall(wrap->code,"$body", lout); Replaceall(wrap->code,"$body", lout);
// $lclass handling. // $lclass handling.
String *lclass = (String *)0; String *lclass = (String *)0;
SwigType *parsed = Swig_cparse_type(Getattr(n,"tmap:ctype")); SwigType *parsed = Swig_cparse_type(Getattr(n,"tmap:ctype"));
// SwigType *cl_t = SwigType_typedef_resolve_all(parsed); // SwigType *cl_t = SwigType_typedef_resolve_all(parsed);
SwigType *cl_t = class_from_class_or_class_ref(parsed); SwigType *cl_t = class_from_class_or_class_ref(parsed);
String *out_ffitype = compose_foreign_type(parsed);
String *deref_out_ffitype;
String *out_temp = Copy(parsed);
if(SwigType_ispointer(out_temp)) {
SwigType_pop(out_temp);
deref_out_ffitype = compose_foreign_type(out_temp);
} else {
deref_out_ffitype = Copy(out_ffitype);
}
Delete(out_temp);
Delete(parsed); Delete(parsed);
int isPtrReturn = 0; int isPtrReturn = 0;
@ -2494,7 +2508,8 @@ int ALLEGROCL :: emit_defun(Node *n, File *f_cl) {
#endif #endif
if(lclass) Replaceall(wrap->code,"$lclass", lclass); if(lclass) Replaceall(wrap->code,"$lclass", lclass);
if(out_ffitype) Replaceall(wrap->code,"$out_fftype", out_ffitype);
if(deref_out_ffitype) Replaceall(wrap->code,"$*out_fftype", deref_out_ffitype);
// if(Replaceall(wrap->code,"$lclass", lclass) && !isPtrReturn) { // if(Replaceall(wrap->code,"$lclass", lclass) && !isPtrReturn) {
// Swig_warning(WARN_LANG_RETURN_TYPE,Getfile(n), Getline(n), // Swig_warning(WARN_LANG_RETURN_TYPE,Getfile(n), Getline(n),
// "While Wrapping %s, replaced a $lclass reference when return type is non-pointer %s!\n", // "While Wrapping %s, replaced a $lclass reference when return type is non-pointer %s!\n",