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)
============================
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
Bugfix #1522858
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-defun ("fact")
((PARM0_statement string (* :char) ))
((PARM0_statement cl:string (* :char) ))
(:returning (:int )
:strings-convert t)
(let ((SWIG_arg0 PARM0_statement))
(swig-ff-call SWIG_arg0)))
(swig-defun ("fact")
((PARM0_n integer :int ))
((PARM0_n cl:integer :int ))
(:returning (:int )
:strings-convert t)
(let ((SWIG_arg0 PARM0_n))
@ -329,14 +329,14 @@ what is generated when parsing C code:
(swig-in-package ())
(swig-defmethod ("fact" "ACL___fact__SWIG_0" :type :function :arity 1)
((PARM0_statement string (* :char) ))
((PARM0_statement cl:string (* :char) ))
(:returning (:int )
:strings-convert t)
(let ((SWIG_arg0 PARM0_statement))
(swig-ff-call SWIG_arg0)))
(swig-defmethod ("fact" "ACL___fact__SWIG_1" :type :function :arity 1)
((PARM0_n integer :int ))
((PARM0_n cl:integer :int ))
(:returning (:int )
:strings-convert t)
(let ((SWIG_arg0 PARM0_n))
@ -545,8 +545,8 @@ char *xxx();
(swig-in-package ())
(swig-defmethod ("foo" "ACL___foo__SWIG_0" :type :function :arity 2)
((PARM0_f1 single-float :float )
(PARM1_f2 single-float :float ))
((PARM0_f1 cl:single-float :float )
(PARM1_f2 cl:single-float :float ))
(:returning (:int )
:call-direct t
:strings-convert nil)
@ -555,8 +555,8 @@ char *xxx();
(swig-ff-call SWIG_arg0 SWIG_arg1))))
(swig-defmethod ("foo" "ACL___foo__SWIG_1" :type :function :arity 2)
((PARM0_f1 single-float :float )
(PARM1_c2 character :char character))
((PARM0_f1 cl:single-float :float )
(PARM1_c2 cl:character :char character))
(:returning (:int )
:call-direct t
:strings-convert nil)
@ -672,8 +672,9 @@ char *xxx();
C++ namespaces are translated into Lisp packages by SWIG. The
Global namespace is mapped to a package named by the <tt>%module</tt>
directive or the <tt>-module</tt> command-line argument. Further
namespaces are created using Allegro CLs nested namespace convention.
For example:
namespaces are generated by the <tt>swig-defpackage</tt> utility
function and given names based on Allegro CLs nested namespace
convention. For example:
</p>
<div class="code">foo.i:
@ -731,6 +732,16 @@ namespace car {
case preferences, additional naming cues, etc.
</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>
@ -771,7 +782,7 @@ namespace car {
reduced to literal values, nodes are created, but with no simplification
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
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
expression will be included in the generated code, but commented out.
</p>
@ -788,7 +799,8 @@ namespace car {
</pre>
</div>
<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>
<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
<pre>
(swig-defmethod ("xxx" "ACL___xxx__SWIG_0" :type :function :arity 2)
((PARM0_i integer :int )
(PARM1_x integer :int ))
((PARM0_i cl:integer :int )
(PARM1_x cl:integer :int ))
(:returning (:float )
:strings-convert t)
(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-defmethod ("xxx" "ACL___xxx__SWIG_1" :type :function :arity 1)
((PARM0_i integer :int ))
((PARM0_i cl:integer :int ))
(:returning (:float )
:strings-convert t)
(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)
((PARM0_inst #.(swig-insert-id "A" () :type :class) (* #.(swig-insert-id "A" ())) )
(PARM1_x integer :int ))
(PARM1_x cl:integer :int ))
(:returning (:float )
:strings-convert t)
(let ((SWIG_arg0 PARM0_inst))
@ -1776,7 +1788,7 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
<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
are described below. The basic code generation structure is
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.
</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>
@ -1823,7 +1842,7 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
<div class="code">
<pre>
%typemap(lin) SWIGTYPE "(let (($out $in))\n $body)";
%typemap(lin) SWIGTYPE "(cl:let (($out $in))\n $body)";
</pre>
</div>
@ -1861,10 +1880,10 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
float, double, long double, char *, void *, void,
enum SWIGTYPE "$body";
%typemap(lout) SWIGTYPE[ANY], SWIGTYPE *,
SWIGTYPE &amp; "(make-instance '$lclass :foreign-address $body)";
%typemap(lout) SWIGTYPE "(let* ((address $body)\n
(ACL_result (make-instance '$lclass :foreign-address address)))\n
(unless (zerop address)\n
SWIGTYPE &amp; "(cl:make-instance '$lclass :foreign-address $body)";
%typemap(lout) SWIGTYPE "(cl:let* ((address $body)\n
(ACL_result (cl:make-instance '$lclass :foreign-address address)))\n
(cl:unless (cl::zerop address)\n
(excl:schedule-finalization ACL_result #'$ldestructor))\n
ACL_result)";
</pre>
@ -1933,10 +1952,10 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
<div class="code">
<pre>
%typemap(lisptype) bool "boolean";
%typemap(lisptype) char "character";
%typemap(lisptype) unsigned char "integer";
%typemap(lisptype) signed char "integer";
%typemap(lisptype) bool "cl:boolean";
%typemap(lisptype) char "cl:character";
%typemap(lisptype) unsigned char "cl:integer";
%typemap(lisptype) signed char "cl:integer";
</pre>
</div>
@ -1952,15 +1971,15 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
<div class="code">
<pre>
%typemap(lispclass) bool "t";
%typemap(lispclass) char "character";
%typemap(lispclass) char "cl:character";
%typemap(lispclass) unsigned char, signed char,
short, signed short, unsigned short,
int, signed int, unsigned int,
long, signed long, unsigned long,
enum SWIGTYPE "integer";
%typemap(lispclass) float "single-float";
%typemap(lispclass) double "double-float";
%typemap(lispclass) char * "string";
enum SWIGTYPE "cl:integer";
%typemap(lispclass) float "cl:single-float";
%typemap(lispclass) double "cl:double-float";
%typemap(lispclass) char * "cl:string";
</pre>
</div>
@ -1977,7 +1996,7 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
%typecheck(SWIG_TYPECHECK_UNICHAR) wchar_t { $1 = 1; };
%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
($out $in
:external-format #+little-endian :fat-le
@ -1985,7 +2004,7 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
$body)"
%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
:external-format #+little-endian :fat-le
#-little-endian :fat)";
@ -1993,8 +2012,8 @@ return-val wrapper-name(parm0, parm1, ..., parmN)
%typemap(ffitype) wchar_t ":unsigned-short";
%typemap(lisptype) wchar_t "";
%typemap(ctype) wchar_t "wchar_t";
%typemap(lispclass) wchar_t "character";
%typemap(lispclass) wchar_t* "string";
%typemap(lispclass) wchar_t "cl:character";
%typemap(lispclass) wchar_t* "cl:string";
</pre>
</div>

343
Lib/allegrocl/allegrocl.swg
View file

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

44
Lib/allegrocl/inout_typemaps.i
View file

@ -35,42 +35,42 @@
// $in_fftype, $*in_fftype
INOUT_TYPEMAP(int,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in));
(cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(short,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in));
(cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(long,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in));
(cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(unsigned int,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in));
(cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(unsigned short,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in));
(cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(unsigned long,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in));
(cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
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),
(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,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in));
(cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
INOUT_TYPEMAP(double,
(push (ff:fslot-value-typed (quote $*in_fftype) :c $out) ACL_result),
(setf (ff:fslot-value-typed (quote $*in_fftype) :c $out) $in));
(cl::push (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) ACL_result),
(cl::setf (ff:fslot-value-typed (cl::quote $*in_fftype) :c $out) $in));
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),
(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 *,
(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),
(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)))
%typemap(lisptype) bool *INPUT, bool &INPUT "boolean";

4
Lib/allegrocl/std_list.i
View file

@ -18,7 +18,6 @@
* %template (floatlist) std::list<float>;
* ----------------------------------------------------------------------------- */
%include "inout_typemaps.i"\
%module std_list
%warnfilter(468) std::list;
@ -72,6 +71,9 @@ namespace std{
%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)
{
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);
#endif
if(n) {
name=Getattr(n,"sym:name");
if(!name) name=Getattr(n,"sym:name");
if(!name) name = Getattr(n,"name");
if(templated) {
k = namespaced_name(n);
@ -381,8 +381,7 @@ void add_defined_foreign_type(Node *n,
if(!val || overwrite || is_fwd_ref) {
#ifdef ALLEGROCL_CLASS_DEBUG
Printf(stderr, "Adding defined type '%s' = '%s' '%s' (overwrite=%d)\n",
k, ns, name, overwrite);
Printf(stderr, "Adding defined type '%s' = '%s' '%s' (overwrite=%d, in-class=%d)\n", k, ns, name, overwrite, in_class);
#endif
String *mangled_name_gen =
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);
} else {
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);
@ -2350,7 +2349,7 @@ int ALLEGROCL :: emit_defun(Node *n, File *f_cl) {
SwigType *result_type = Swig_cparse_type(Getattr(n,"tmap:ctype"));
// 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;
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");
Replaceall(lout, "$owner", GetFlag(n, "feature:new") ? "t" : "nil");
Replaceall(wrap->code,"$body", lout);
// $lclass handling.
String *lclass = (String *)0;
SwigType *parsed = Swig_cparse_type(Getattr(n,"tmap:ctype"));
// SwigType *cl_t = SwigType_typedef_resolve_all(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);
int isPtrReturn = 0;
@ -2494,7 +2508,8 @@ int ALLEGROCL :: emit_defun(Node *n, File *f_cl) {
#endif
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) {
// 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",