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

Add a whole bunch of chicken runme scripts, and fix the bugs exposed by those scripts

Browse source 
git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk@7155 626c5289-ae23-0410-ae9c-e8d60b6d4f22
This commit is contained in:
John Lenz 2005-04-15 05:23:14 +00:00
commit 420ba48099
72 changed files with 1085 additions and 412 deletions
Download patch file Download diff file Expand all files Collapse all files

10
SWIG/CHANGES.current
View file

@ -1,6 +1,16 @@
Version 1.3.25 (In progress)
============================
04/14/2005: wuzzeb (John Lenz)
[Chicken]
+ Added a whole bunch of new _runme scripts into the chicken test
suite. Also fix some bugs these new scripts turned up.
+ Added optimization when returning a wrapped proxy class. Before,
a minor garbage collection was invoked every time a function returned.
+ All the chicken Examples should now run correctly
04/14/2005: wsfulton
[C#] More fixes for typemap matching when wrapping variables, in particular
std::string, so that std::string variables can be easily marshalled with

21
SWIG/Doc/Manual/Chicken.html
View file

@ -26,11 +26,11 @@
<li><a href="#Chicken_nn10">Exceptions</a>
</ul>
<li><a href="#Chicken_nn11">TinyCLOS</a>
<li><a href="#Chicken_nn12">Compilation</a>
<li><a href="#Chicken_nn13">Linkage</a>
<li><a href="#Chicken_nn12">Linkage</a>
<ul>
<li><a href="#Chicken_nn14">Shared library</a>
<li><a href="#Chicken_nn15">Static binary</a>
<li><a href="#Chicken_nn13">Static binary or shared library linked at compile time</a>
<li><a href="#Chicken_nn14">Building chicken extension libraries</a>
<li><a href="#Chicken_nn15">Linking multiple SWIG modules with TinyCLOS</a>
</ul>
<li><a href="#Chicken_nn16">Typemaps</a>
<li><a href="#Chicken_nn17">Pointers</a>
@ -205,7 +205,7 @@
</ol>
<p>
In all cases, the constants may be accessed from with CHICKEN
In all cases, the constants may be accessed from within CHICKEN
using the form <tt>(MYCONSTANT1)</tt>; that is, the constants
may be accessed using the read-only parameter form.
</p>
@ -247,7 +247,7 @@
<p>Chicken supports both the <code>SWIG_exception(int code, const char *msg)</code> interface
as well as a <code>SWIG_ThrowException(C_word val)</code> function for throwing exceptions from
inside the %exception blocks. <code>SWIG_exception</code> will throw a list consiting of the code
inside the %exception blocks. <code>SWIG_exception</code> will throw a list consisting of the code
(as an integer) and the message. Both of these will throw an exception using <code>(abort)</code>,
which can be handled by <code>(handle-exceptions)</code>. See
<a href="http://www.call-with-current-continuation.org/manual/Exceptions.html#Exceptions">Chicken manual on Exceptions</a>
@ -378,7 +378,7 @@ $ csc -v test_script.scm -lexample
</pre>
</div>
<p>An alternative is the test_script.scm can have the code <code>(load-library 'example "example.so")</code>,
<p>An alternative is that the test_script.scm can have the code <code>(load-library 'example "example.so")</code>,
in which case the test script does not need to be linked with example.so. The test_script.scm file can then
be run with <tt>csi</tt>.
</p>
@ -388,8 +388,8 @@ be run with <tt>csi</tt>.
<p>Building a shared library like in the above section only works if the library
is linked at compile time with a script containing <code>(declare (uses ...))</code> or is
loaded explictetly with <code>(load-library 'example "example.so")</code>. It is
not the format that chicken expects for extension libraries and eggs. The problem is the
loaded explicitly with <code>(load-library 'example "example.so")</code>. It is
not the format that CHICKEN expects for extension libraries and eggs. The problem is the
<code>(declare (unit <i>modname</i>))</code> inside the <tt>modname.scm</tt> file. There are
two possible solutions to this.</p>
@ -405,7 +405,7 @@ $ csc -sv modname.scm modname_wrap.c modname_impl.c -o modname.so
<p>This library can then be loaded by scheme code with the <code>(require 'modname)</code> function.
See <a href="http://www.call-with-current-continuation.org/manual/Loading-extension-libraries.html">
Loading-extension-libraries</a> in the eval unit inside the Chicken manual for more information.</p>
Loading-extension-libraries</a> in the eval unit inside the CHICKEN manual for more information.</p>
<p>Another alternative is to run SWIG normally and create a scheme file that contains <code>(declare (uses <i>modname</i>))</code>
and then compile that file into the shared library as well. For example, inside the <tt>mod_load.scm</tt> file,</p>
@ -443,6 +443,7 @@ two eggs, one using the first method and one using the second method.</p>
<H3><a name="Chicken_nn15"></a>17.4.3 Linking multiple SWIG modules with TinyCLOS</H3>
<p>Linking together multiple modules that share type information using the <code>%import</code>
directive while also using <tt>-proxy</tt> is more complicated. For example, if <tt>mod2.i</tt> imports <tt>mod1.i</tt>, then the
<tt>mod2.scm</tt> file contains references to symbols declared in <tt>mod1.scm</tt>,

2
SWIG/Examples/chicken/README
View file

@ -10,5 +10,3 @@ zlib -- a wrapping of the zlib compression library
You should be able to run make in each of the examples. By default, a shared
library will be built. Run make check to execute the test.
You can uncomment a few lines in the Makefile to build a static test exe.

2
SWIG/Examples/chicken/class/Makefile
View file

@ -7,7 +7,7 @@ TARGET = class
INCLUDE =
SWIGOPT =
CFLAGS =
VARIANT = _csc
VARIANT =
# uncomment the following lines to build a static exe (only pick one of the CHICKEN_MAIN lines)
#CHICKEN_MAIN = test-lowlevel-class.scm

5
SWIG/Examples/chicken/class/test-lowlevel-class.scm
View file

@ -64,8 +64,9 @@
(display "\nGuess I'll clean up now\n")
;; Note: this invokes the virtual destructor
(delete-Shape c)
(delete-Shape s)
(set! c #f)
(set! s #f)
(gc #t)
(set! s 3)
(display (Shape-nshapes))

6
SWIG/Examples/chicken/class/test-tinyclos-class.scm
View file

@ -20,7 +20,7 @@
;; ----- Access a static member -----
(display "\nA total of ")
(display (nshapes))
(display (Shape-nshapes))
(display " shapes were created\n")
;; ----- Member data access -----
@ -67,9 +67,9 @@
;; Note: Invoke the virtual destructors by forcing garbage collection
(set! c 77)
(set! s 88)
;(gc #t)
(gc #t)
(display (nshapes))
(display (Shape-nshapes))
(display " shapes remain\n")
(display "Goodbye\n")

4
SWIG/Examples/chicken/constants/test-constants.scm
View file

@ -1,8 +1,6 @@
;; run with './constants test-constants.scm'
;; feel free to uncomment and comment sections
(load-library 'example "constants.so")
(declare (uses example))
(load-library 'example "./constants.so")
(display "starting test ... you will see 'finished' if successful.\n")
(or (= (ICONST) 42) (exit 1))

1
SWIG/Examples/chicken/multimap/test-multimap.scm
View file

@ -2,7 +2,6 @@
;; feel free to uncomment and comment sections
(load-library 'example "multimap.so")
(declare (uses example))
(display "(gcd 90 12): ")
(display (gcd 90 12))

4
SWIG/Examples/chicken/overload/test-overload.scm
View file

@ -1,8 +1,6 @@
;; This file demonstrates the overloading capabilities of SWIG
(load-library 'example "overload.so")
(declare (uses example))
(declare (uses tinyclos))
;; Low level
;; ---------
@ -40,7 +38,7 @@ Trying TinyCLOS code ...
(foo 1)
(foo "some string")
(define A-FOO (make <Foo>))
(define ANOTHER-FOO (make <Foo> (slot-ref A-FOO 'swig-this))) ;; copy constructor
(define ANOTHER-FOO (make <Foo> A-FOO)) ;; copy constructor
(bar A-FOO 2)
(bar ANOTHER-FOO "another string" 3)

2
SWIG/Examples/chicken/simple/example.i
View file

@ -8,6 +8,6 @@
extern double My_variable;
extern int fact(int);
%name(mod) extern int my_mod(int n, int m);
%rename(mod) my_mod;
extern int my_mod(int n, int m);
extern char *get_time();

18
SWIG/Examples/chicken/simple/test-simple.scm
View file

@ -1,6 +1,5 @@
;; feel free to uncomment and comment sections
(load-library 'example "simple.so")
(declare (uses example))
(display "(My-variable): ")
(display (My-variable))
@ -14,31 +13,14 @@
(display (My-variable))
(display "\n")
(display "(My-variable 'a): ")
;;(display (My-variable 'a))
(display "\n")
(display "(My-variable 1.5 'b): ")
(display (My-variable 1.5 'b))
(display "\n")
(display "(fact 5): ")
(display (fact 5))
(display "\n")
(display "(fact 'a): ")
;;(display (fact 'a))
(display "\n")
(display "(mod 75 7): ")
(display (mod 75 7))
(display "\n")
(display "(my-mod 75 7): ")
(display (my-mod 75 7))
(display "\n")
(display "(get-time): ")
(display (get-time))
(display "\n")

13
SWIG/Examples/chicken/zlib/Makefile
View file

@ -5,27 +5,24 @@ SRCS =
CXXSRCS =
TARGET = zlib
INCLUDE =
SWIGOPT = -I/usr/include -mixed -prefix zlib
SWIGOPT = -I/usr/include
CFLAGS =
VARIANT =
LIBS = -lz
# comment out the following two lines to build a dynamic exe
CHICKEN_MAIN = test-zlib.scm
VARIANT = _static
VARIANT = _direct
all:: $(TARGET)
$(TARGET): $(INTERFACE) $(SRCS)
$(MAKE) -f $(TOP)/Makefile \
SRCS='$(SRCS)' CXXSRCS='$(CXXSRCS)' CHICKEN_MAIN='$(CHICKEN_MAIN)' \
SRCS='$(SRCS)' CXXSRCS='$(CXXSRCS)' \
INCLUDE='$(INCLUDE)' SWIGOPT='$(SWIGOPT)' LIBS='$(LIBS)' TARGET='$(TARGET)' \
SWIG='$(SWIG)' INTERFACE='$(INTERFACE)' CHICKENOPTS='$(CHICKENOPTS)' chicken$(VARIANT)
clean::
$(MAKE) -f $(TOP)/Makefile chicken_clean
rm -f example.scm example-generic.scm example-clos.scm
rm -f example.scm
rm -f $(TARGET)
check::
csi -batch simple.so test-zlib.scm
csi test-zlib.scm

48
SWIG/Examples/chicken/zlib/test-zlib.scm
View file

@ -1,45 +1,43 @@
;; run with './zlib test-zlib.scm'
(declare (uses example))
(declare (uses format))
(load-library 'example "./zlib.so")
;; Init zstream
(define s (zlib:new-z-stream))
(zlib:z-stream-zalloc-set s #f)
(zlib:z-stream-zfree-set s #f)
(zlib:z-stream-opaque-set s #f)
(zlib:deflate-init s (zlib:z-default-compression))
(define s (new-z-stream))
(z-stream-zalloc-set s #f)
(z-stream-zfree-set s #f)
(z-stream-opaque-set s #f)
(deflate-init s (Z-DEFAULT-COMPRESSION))
;; Deflate something small so we don't need to loop/stream data
(define in "some pony et jumping et jack et flash et had a jack pony")
(define out (make-string 1000))
(format #t "to be compressed: ~A~%to be compressed bytes: ~D~%~%" in (string-length in))
(zlib:z-stream-next-in-set s in)
(zlib:z-stream-avail-in-set s (string-length in))
(zlib:z-stream-next-out-set s out)
(zlib:z-stream-avail-out-set s (string-length out))
(printf "to be compressed: ~A~%to be compressed bytes: ~A~%~%" in (string-length in))
(z-stream-next-in-set s in)
(z-stream-avail-in-set s (string-length in))
(z-stream-next-out-set s out)
(z-stream-avail-out-set s (string-length out))
(let*
((saved-out (zlib:z-stream-save-next-out s))
(ret (zlib:deflate s (zlib:z-finish))))
((saved-out (z-stream-save-next-out s))
(ret (deflate s (Z-FINISH))))
(cond
((= ret (zlib:z-stream-end))
(format #t "deflated properly!~%compressed bytes: ~D~%compressed stream: ~S~%"
(zlib:z-stream-total-out-get s) (zlib:z-stream-get-next-chunk s saved-out)))
((= ret (zlib:z-ok))
((= ret (Z-STREAM-END))
(printf "deflated properly!~%compressed bytes: ~A~%compressed stream: ~A~%"
(z-stream-total-out-get s) (z-stream-get-next-chunk s saved-out)))
((= ret (Z-OK))
(display "only partial deflation ... not enough output space\n"))
(else
(format #t "deflate error(~D): ~A ~%" ret (zlib:z-stream-msg-get s)))))
(printf "deflate error(~D): ~A ~%" ret (z-stream-msg-get s)))))
;; Use simple compress routine, and set max output size to 100
(define c (zlib:compress 100 in))
(define c (compress 100 in))
(newline)
(let
((ret (car c))
(compressed (cadr c)))
(cond
((= ret (zlib:z-ok))
(format #t "compressed properly!~%compressed bytes: ~D~%compressed stream: ~S~%"
((= ret (Z-OK))
(printf "compressed properly!~%compressed bytes: ~A~%compressed stream: ~A~%"
(string-length compressed) compressed))
(else
(format #t "compress error(~D): ~A ~%" ret (zlib:z-error ret)))))
(printf "compress error(~D): ~A ~%" ret (z-error ret)))))
(exit 0)

12
SWIG/Examples/test-suite/chicken/Makefile.in
View file

@ -18,7 +18,7 @@ SO = @SO@
include $(srcdir)/../common.mk
# Overridden variables here
SWIGOPT +=
SWIGOPT += -nounit
# Rules for the different types of tests
%.cpptest:
@ -41,6 +41,9 @@ SWIGOPT +=
$(setup) \
($(swig_and_compile_multi_cpp); ) && \
$(run_testcase)
if [ -f $(srcdir)/$(SCRIPTPREFIX)$*$(PROXYSUFFIX) ]; then ( \
$(MAKE) $*.multiproxy; ) \
fi;
# Runs the testcase. A testcase is only run if
# a file is found which has _runme.scm appended after the testcase name.
@ -65,6 +68,13 @@ run_testcase = \
($(swig_and_compile_c); ) && \
$(run_testcase)
%.multiproxy: SWIGOPT += -proxy -noclosuses
%.multiproxy: SCRIPTSUFFIX = $(PROXYSUFFIX)
%.multiproxy:
echo "Checking testcase $* (with run test) under chicken with -proxy"; \
($(swig_and_compile_multi_cpp); ) && \
$(run_testcase)
# Clean
%.clean:

2
SWIG/Examples/test-suite/chicken/casts_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'casts "casts.so")
(load "casts.so")
(include "../schemerunme/casts.scm")

2
SWIG/Examples/test-suite/chicken/char_constant_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'char_constant "char_constant.so")
(load "char_constant.so")
(include "../schemerunme/char_constant.scm")

2
SWIG/Examples/test-suite/chicken/class_ignore_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'class_ignore "class_ignore.so")
(load "class_ignore.so")
(include "../schemerunme/class_ignore.scm")

95
SWIG/Examples/test-suite/chicken/clientdata_prop_runme_proxy.ss Normal file
View file

@ -0,0 +1,95 @@
(require 'clientdata_prop_a)
(require 'clientdata_prop_b)
(define a (make <A>))
(test-A a)
(test-tA a)
(test-t2A a)
(test-t3A a)
(fA a)
(define b (make <B>))
(test-A b)
(test-tA b)
(test-t2A b)
(test-t3A b)
(test-B b)
(fA b)
(fB b)
(define c (make <C>))
(test-A c)
(test-tA c)
(test-t2A c)
(test-t3A c)
(test-C c)
(fA c)
(fC c)
(define d (make <D>))
(test-A d)
(test-tA d)
(test-t2A d)
(test-t3A d)
(test-D d)
(test-tD d)
(test-t2D d)
(fA d)
(fD d)
;; here are the real tests... if the clientdata is correctly
;; propegated, new-tA, new-t2A, should all return wrapped proxy's
;; of class <A>
(define a2 (new-tA))
(if (not (eq? (class-of a2) <A>))
(error "Error 1"))
(test-A a2)
(test-tA a2)
(test-t2A a2)
(test-t3A a2)
(fA a2)
(define a3 (new-t2A))
(if (not (eq? (class-of a3) <A>))
(error "Error 2"))
(test-A a3)
(test-tA a3)
(test-t2A a3)
(test-t3A a3)
(fA a3)
(define a4 (new-t3A))
(if (not (eq? (class-of a4) <A>))
(error "Error 3"))
(test-A a4)
(test-tA a4)
(test-t2A a4)
(test-t3A a4)
(fA a4)
(define d2 (new-tD))
(if (not (eq? (class-of d2) <D>))
(error "Error 4"))
(test-A d2)
(test-tA d2)
(test-t2A d2)
(test-t3A d2)
(test-D d2)
(test-tD d2)
(fA d2)
(fD d2)
(define d3 (new-t2D))
(if (not (eq? (class-of d3) <D>))
(error "Error 5"))
(test-A d3)
(test-tA d3)
(test-t2A d3)
(test-t3A d3)
(test-D d3)
(test-tD d3)
(fA d3)
(fD d3)
(exit 0)

2
SWIG/Examples/test-suite/chicken/constover_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'constover "constover.so")
(load "constover.so")
(include "../schemerunme/constover.scm")

2
SWIG/Examples/test-suite/chicken/contract_runme.ss
View file

@ -1,3 +1,3 @@
(load-library 'contract "contract.so")
(load "contract.so")
(include "testsuite.ss")
(include "../schemerunme/contract.scm")

51
SWIG/Examples/test-suite/chicken/cpp_basic_runme_proxy.ss Normal file
View file

@ -0,0 +1,51 @@
(require 'cpp_basic)
(define-macro (check test)
`(if (not ,test) (error "Error in test " ',test)))
(define f (make <Foo> 4))
(check (= (slot-ref f 'num) 4))
(slot-set! f 'num -17)
(check (= (slot-ref f 'num) -17))
(define b (make <Bar>))
(slot-set! b 'fptr f)
(check (= (slot-ref (slot-ref b 'fptr) 'num) -17))
(check (= (test b -3 (slot-ref b 'fptr)) -5))
(slot-set! f 'num 12)
(check (= (slot-ref (slot-ref b 'fptr) 'num) 12))
(check (= (slot-ref (slot-ref b 'fref) 'num) -4))
(check (= (test b 12 (slot-ref b 'fref)) 23))
;; references don't take ownership, so if we didn't define this here it might get garbage collected
(define f2 (make <Foo> 23))
(slot-set! b 'fref f2)
(check (= (slot-ref (slot-ref b 'fref) 'num) 23))
(check (= (test b -3 (slot-ref b 'fref)) 35))
(check (= (slot-ref (slot-ref b 'fval) 'num) 15))
(check (= (test b 3 (slot-ref b 'fval)) 33))
(slot-set! b 'fval (make <Foo> -15))
(check (= (slot-ref (slot-ref b 'fval) 'num) -15))
(check (= (test b 3 (slot-ref b 'fval)) -27))
(define f3 (testFoo b 12 (slot-ref b 'fref)))
(check (= (slot-ref f3 'num) 32))
;; now test global
(define f4 (make <Foo> 6))
(Bar-global-fptr f4)
(check (= (slot-ref (Bar-global-fptr) 'num) 6))
(slot-set! f4 'num 8)
(check (= (slot-ref (Bar-global-fptr) 'num) 8))
(check (= (slot-ref (Bar-global-fref) 'num) 23))
(Bar-global-fref (make <Foo> -7))
(check (= (slot-ref (Bar-global-fref) 'num) -7))
(check (= (slot-ref (Bar-global-fval) 'num) 3))
(Bar-global-fval (make <Foo> -34))
(check (= (slot-ref (Bar-global-fval) 'num) -34))
(exit 0)

2
SWIG/Examples/test-suite/chicken/cpp_enum_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'cpp-enum "cpp_enum.so")
(load "cpp_enum.so")
(include "../schemerunme/cpp_enum.scm")

2
SWIG/Examples/test-suite/chicken/cpp_namespace_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'cpp_namespace "cpp_namespace.so")
(load "cpp_namespace.so")
(include "../schemerunme/cpp_namespace.scm")

2
SWIG/Examples/test-suite/chicken/dynamic_cast_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'dynamic_cast "dynamic_cast.so")
(load "dynamic_cast.so")
(include "../schemerunme/dynamic_cast.scm")

2
SWIG/Examples/test-suite/chicken/global_vars_runme.ss Normal file
View file

@ -0,0 +1,2 @@
(require 'global_vars)
(load "../schemerunme/global_vars.scm")

2
SWIG/Examples/test-suite/chicken/global_vars_runme_proxy.ss Normal file
View file

@ -0,0 +1,2 @@
(require 'global_vars)
(load "../schemerunme/global_vars_proxy.scm")

2
SWIG/Examples/test-suite/chicken/import_nomodule_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'import_nomodule "import_nomodule.so")
(load "import_nomodule.so")
(include "../schemerunme/import_nomodule.scm")

4
SWIG/Examples/test-suite/chicken/imports_runme.ss
View file

@ -1,3 +1,3 @@
(load-library 'imports_a "imports_a.so")
(load-library 'imports_b "imports_b.so")
(load "imports_a.so")
(load "imports_b.so")
(include "../schemerunme/imports.scm")

2
SWIG/Examples/test-suite/chicken/inherit_missing_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'inherit_missing "inherit_missing.so")
(load "inherit_missing.so")
(include "../schemerunme/inherit_missing.scm")

2
SWIG/Examples/test-suite/chicken/li_std_string_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'li-std-string "li_std_string.so")
(load "li_std_string.so")
(include "../schemerunme/li_std_string.scm")

48
SWIG/Examples/test-suite/chicken/li_std_string_runme_proxy.ss Normal file
View file

@ -0,0 +1,48 @@
(load "li_std_string.so")
(define x "hello")
(if (not (string=? (test-value x) x))
(begin (error "Error 1") (exit 1)))
(if (not (string=? (test-const-reference x) x))
(begin (error "Error 2") (exit 1)))
(define y (test-pointer-out))
(test-pointer y)
(define z (test-const-pointer-out))
(test-const-pointer z)
(define a (test-reference-out))
(test-reference a)
;; test global variables
(GlobalString "whee")
(if (not (string=? (GlobalString) "whee"))
(error "Error 3"))
(if (not (string=? (GlobalString2) "global string 2"))
(error "Error 4"))
(define struct (make <Structure>))
;; MemberString should be a wrapped class
(define scl (slot-ref struct 'MemberString))
(if (not (string=? (slot-ref scl 'str) ""))
(error "Error 4.5"))
(slot-set! scl 'str "and how")
(if (not (string=? (slot-ref (slot-ref struct 'MemberString) 'str) "and how"))
(error "Error 5"))
(if (not (string=? (slot-ref struct 'MemberString2) "member string 2"))
(error "Error 6"))
(Structure-StaticMemberString "static str")
(if (not (string=? (Structure-StaticMemberString) "static str"))
(error "Error 7"))
(if (not (string=? (Structure-StaticMemberString2) "static member string 2"))
(error "Error 8"))
;(if (not (string=? (Structure-ConstMemberString-get struct) "const member string"))
; (error "Error 9"))
(if (not (string=? (Structure-ConstStaticMemberString) "const static member string"))
(error "Error 10"))
(exit 0)

2
SWIG/Examples/test-suite/chicken/li_typemaps_runme.ss Normal file
View file

@ -0,0 +1,2 @@
(require 'li_typemaps)
(load "../schemerunme/li_typemaps.scm")

2
SWIG/Examples/test-suite/chicken/li_typemaps_runme_proxy.ss Normal file
View file

@ -0,0 +1,2 @@
(require 'li_typemaps)
(load "../schemerunme/li_typemaps_proxy.scm")

2
SWIG/Examples/test-suite/chicken/list_vector_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'list_vector "list_vector.so")
(load "list_vector.so")
(include "../schemerunme/list_vector.scm")

2
SWIG/Examples/test-suite/chicken/multiple_inheritance_runme_proxy.ss Normal file
View file

@ -0,0 +1,2 @@
(require 'multiple_inheritance)
(load "../schemerunme/multiple_inheritance_proxy.scm")

2
SWIG/Examples/test-suite/chicken/multivalue_runme.ss
View file

@ -1,4 +1,4 @@
;; this doesn't work yet :(
(load-library 'multivalue "multivalue.so")
(load "multivalue.so")
(include "../schemerunme/multivalue.scm")
(exit 0)

2
SWIG/Examples/test-suite/chicken/name_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'name "name.so")
(load "name.so")
(include "../schemerunme/name.scm")

30
SWIG/Examples/test-suite/chicken/newobject1_runme_proxy.ss Normal file
View file

@ -0,0 +1,30 @@
(require 'newobject1)
(define-macro (check-count val)
`(if (not (= (Foo-fooCount) ,val)) (error "Error checking val " ,val " != " ,(Foo-fooCount))))
(define f (Foo-makeFoo))
(check-count 1)
(define f2 (makeMore f))
(check-count 2)
(set! f #f)
(gc #t)
(check-count 1)
(define f3 (makeMore f2))
(check-count 2)
(set! f3 #f)
(set! f2 #f)
(gc #t)
(check-count 0)
(exit 0)

2
SWIG/Examples/test-suite/chicken/newobject2_runme.ss
View file

@ -1,4 +1,4 @@
(load-library 'newobject2 "newobject2.so")
(load "newobject2.so")
(define f (new-Foo))

2
SWIG/Examples/test-suite/chicken/newobject2_runme_proxy.ss
View file

@ -1,4 +1,4 @@
(load-library 'newobject2 "newobject2.so")
(load "newobject2.so")
(define f (make <Foo>))

2
SWIG/Examples/test-suite/chicken/overload_complicated_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'overload_complicated "overload_complicated.so")
(load "overload_complicated.so")
(include "../schemerunme/overload_complicated.scm")

2
SWIG/Examples/test-suite/chicken/overload_copy_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'overload_copy "overload_copy.so")
(load "overload_copy.so")
(include "../schemerunme/overload_copy.scm")

4
SWIG/Examples/test-suite/chicken/overload_copy_runme_proxy.ss
View file

@ -1,6 +1,4 @@
(require 'tinyclos)
(load "../../../Lib/chicken/multi-generic.scm")
(load-library 'overload-copy "./overload_copy.so")
(load "./overload_copy.so")
(define f (make <Foo>))
(define g (make <Foo> f))

2
SWIG/Examples/test-suite/chicken/overload_extend_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'overload_extend "overload_extend.so")
(load "overload_extend.so")
(include "../schemerunme/overload_extend.scm")

4
SWIG/Examples/test-suite/chicken/overload_extend_runme_proxy.ss
View file

@ -1,6 +1,4 @@
(require 'tinyclos)
(load "../../../Lib/chicken/multi-generic.scm")
(load-library 'overload-extend "./overload_extend.so")
(load "./overload_extend.so")
(define f (make <Foo>))

2
SWIG/Examples/test-suite/chicken/overload_simple_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'overload_simple "overload_simple.so")
(load "overload_simple.so")
(include "../schemerunme/overload_simple.scm")

4
SWIG/Examples/test-suite/chicken/overload_simple_runme_proxy.ss
View file

@ -1,6 +1,4 @@
(require 'tinyclos)
(load "../../../Lib/chicken/multi-generic.scm")
(load-library 'overload_simple "overload_simple.so")
(load "overload_simple.so")
(define-macro (check test)
`(if (not ,test) (error ',test)))

2
SWIG/Examples/test-suite/chicken/overload_subtype_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'overload_subtype "overload_subtype.so")
(load "overload_subtype.so")
(include "../schemerunme/overload_subtype.scm")

2
SWIG/Examples/test-suite/chicken/overload_subtype_runme_proxy.ss
View file

@ -1,4 +1,4 @@
(load-library 'overload-subtype "./overload_subtype.so")
(load "./overload_subtype.so")
(define f (make <Foo>))
(define b (make <Bar>))

2
SWIG/Examples/test-suite/chicken/pointer_in_out_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'pointer_in_out "pointer_in_out.so")
(load "pointer_in_out.so")
(include "../schemerunme/pointer_in_out.scm")

2
SWIG/Examples/test-suite/chicken/reference_global_vars_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'reference_global_vars "reference_global_vars.so")
(load "reference_global_vars.so")
(include "../schemerunme/reference_global_vars.scm")

2
SWIG/Examples/test-suite/chicken/throw_exception_runme.ss
View file

@ -1,4 +1,4 @@
(load-library 'throw-exception "throw_exception.so")
(load "throw_exception.so")
(define-macro (check-throw expr check)
`(if (handle-exceptions exvar (if ,check #f (begin (print "Error executing: " ',expr " " exvar) (exit 1))) ,expr #t)

2
SWIG/Examples/test-suite/chicken/typedef_inherit_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'typedef_inherit "typedef_inherit.so")
(load "typedef_inherit.so")
(include "../schemerunme/typedef_inherit.scm")

2
SWIG/Examples/test-suite/chicken/typename_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'typename "typename.so")
(load "typename.so")
(include "../schemerunme/typename.scm")

2
SWIG/Examples/test-suite/chicken/unions_runme.ss
View file

@ -1,2 +1,2 @@
(load-library 'unions "unions.so")
(load "unions.so")
(include "../schemerunme/unions.scm")

2
SWIG/Examples/test-suite/chicken/unions_runme_proxy.ss Normal file
View file

@ -0,0 +1,2 @@
(load "unions.so")
(include "../schemerunme/unions_proxy.scm")

1
SWIG/Examples/test-suite/common.mk
View file

@ -96,6 +96,7 @@ CPP_TEST_CASES += \
conversion_namespace \
conversion_ns_template \
cplusplus_throw \
cpp_basic \
cpp_enum \
cpp_namespace \
cpp_nodefault \

52
SWIG/Examples/test-suite/cpp_basic.i Normal file
View file

@ -0,0 +1,52 @@
/* This is a basic test of proxy classes, used by chicken */
%module cpp_basic
%newobject Bar::testFoo;
%inline %{
class Foo {
public:
Foo(int a) : num(a) {}
int num;
};
%}
%{
static Foo init_ref = Foo(-4);
%}
%inline %{
class Bar {
public:
Bar() : fptr(0), fref(init_ref), fval(15) , cint(3) {}
Foo *fptr;
Foo &fref;
Foo fval;
const int cint;
static const int global_cint = -4;
static Foo *global_fptr;
static Foo &global_fref;
static Foo global_fval;
int test(int a, Foo *f) {
return a + (f ? f->num : 0) + fval.num;
}
Foo *testFoo(int a, Foo *f) {
return new Foo(2 * a + (f ? f->num : 0) + fval.num);
}
};
%}
%{
Foo *Bar::global_fptr = NULL;
Foo &Bar::global_fref = init_ref;
Foo Bar::global_fval = Foo(3);
%}

8
SWIG/Examples/test-suite/guile/li_typemaps_runme.scm Normal file
View file

@ -0,0 +1,8 @@
;;; This is the union runtime testcase. It ensures that values within a
;;; union embedded within a struct can be set and read correctly.
;; The SWIG modules have "passive" Linkage, i.e., they don't generate
;; Guile modules (namespaces) but simply put all the bindings into the
;; current module. That's enough for such a simple test.
(dynamic-call "scm_init_li_typemaps_module" (dynamic-link "./libli_typemaps.so"))
(load "../schemerunme/li_typemaps.scm")

11
SWIG/Examples/test-suite/li_typemaps.i
View file

@ -3,8 +3,11 @@
%include "typemaps.i"
%apply int &INOUT { int &INOUT2 };
%newobject out_foo;
%inline %{
struct Foo { int a; };
bool in_bool(bool *INPUT) { return *INPUT; }
int in_int(int *INPUT) { return *INPUT; }
long in_long(long *INPUT) { return *INPUT; }
@ -47,6 +50,14 @@ void out_double(double x, double *OUTPUT) { *OUTPUT = x; }
void out_longlong(long long x, long long *OUTPUT) { *OUTPUT = x; }
void out_ulonglong(unsigned long long x, unsigned long long *OUTPUT) { *OUTPUT = x; }
/* Tests a returning a wrapped pointer and an output argument */
struct Foo *out_foo(int a, int *OUTPUT) {
struct Foo *f = new struct Foo();
f->a = a;
*OUTPUT = a * 2;
return f;
}
void outr_bool(bool x, bool &OUTPUT) { OUTPUT = x; }
void outr_int(int x, int &OUTPUT) { OUTPUT = x; }
void outr_short(short x, short &OUTPUT) { OUTPUT = x; }

31
SWIG/Examples/test-suite/schemerunme/global_vars.scm Normal file
View file

@ -0,0 +1,31 @@
(define-macro (check test)
`(if (not ,test) (error "Error in test" ',test)))
(b "hello")
(check (string=? (b) "hello"))
(define sa (new-A))
(A-x-set sa 5)
(a sa)
(check (= (A-x-get (a)) 5))
(ap sa)
(check (= (A-x-get (ap)) 5))
(A-x-set sa 10)
(check (= (A-x-get (ap)) 10))
(define sa2 (new-A))
(A-x-set sa2 -4)
(cap sa2)
(check (= (A-x-get (cap)) -4))
(A-x-set sa2 -7)
(check (= (A-x-get (cap)) -7))
(check (= (A-x-get (ar)) 5))
(ar sa2)
(check (= (A-x-get (ar)) -7))
(x 4)
(check (= (x) 4))
(exit 0)

31
SWIG/Examples/test-suite/schemerunme/global_vars_proxy.scm Normal file
View file

@ -0,0 +1,31 @@
(define-macro (check test)
`(if (not ,test) (error "Error in test" ',test)))
(b "hello")
(check (string=? (b) "hello"))
(define sa (make <A>))
(slot-set! sa 'x 5)
(a sa)
(check (= (slot-ref (a) 'x) 5))
(ap sa)
(check (= (slot-ref (ap) 'x) 5))
(slot-set! sa 'x 10)
(check (= (slot-ref (ap) 'x) 10))
(define sa2 (make <A>))
(slot-set! sa2 'x -4)
(cap sa2)
(check (= (slot-ref (cap) 'x) -4))
(slot-set! sa2 'x -7)
(check (= (slot-ref (cap) 'x) -7))
(check (= (slot-ref (ar) 'x) 5))
(ar sa2)
(check (= (slot-ref (ar) 'x) -7))
(x 4)
(check (= (x) 4))
(exit 0)

29
SWIG/Examples/test-suite/schemerunme/li_std_string.scm
View file

@ -14,4 +14,33 @@
(define a (test-reference-out))
(test-reference a)
;; test global variables
(GlobalString "whee")
(if (not (string=? (GlobalString) "whee"))
(error "Error 3"))
(if (not (string=? (GlobalString2) "global string 2"))
(error "Error 4"))
(define struct (new-Structure))
;; MemberString should be a wrapped class
(define scl (Structure-MemberString-get struct))
(if (not (string=? (std-string-str-get scl) ""))
(error "Error 4.5"))
(std-string-str-set scl "and how")
(if (not (string=? (std-string-str-get (Structure-MemberString-get struct)) "and how"))
(error "Error 5"))
(if (not (string=? (Structure-MemberString2-get struct) "member string 2"))
(error "Error 6"))
(Structure-StaticMemberString "static str")
(if (not (string=? (Structure-StaticMemberString) "static str"))
(error "Error 7"))
(if (not (string=? (Structure-StaticMemberString2) "static member string 2"))
(error "Error 8"))
;(if (not (string=? (Structure-ConstMemberString-get struct) "const member string"))
; (error "Error 9"))
(if (not (string=? (Structure-ConstStaticMemberString) "const static member string"))
(error "Error 10"))
(exit 0)

34
SWIG/Examples/test-suite/schemerunme/li_typemaps.scm Normal file
View file

@ -0,0 +1,34 @@
(define-macro (check func val test)
(cons 'begin
(map
(lambda (x)
`(if (not (,test (,(string->symbol (string-append x func)) ,val) ,val))
(error ,(string-append "Error in test " x func))))
(list "in-" "inr-" "out-" "outr-" "inout-" "inoutr-"))))
(define (=~ a b)
(< (abs (- a b)) 1e-5))
(check "bool" #t and)
(check "int" -2 =)
(check "long" -32 =)
(check "short" -15 =)
(check "uint" 75 =)
(check "ushort" 123 =)
(check "ulong" 462 =)
;(check "uchar" 16 =)
;(check "schar" -53 =)
(check "float" 4.3 =~)
(check "double" -175.42 =~)
;(check "longlong" 1634 =)
;(check "ulonglong" 6432 =)
(let ((lst (inoutr-int2 3 -2)))
(if (not (and (= (car lst) 3) (= (cadr lst) -2)))
(error "Error in inoutr-int2")))
(let ((lst (out-foo 4)))
(if (not (and (= (Foo-a-get (car lst)) 4) (= (cadr lst) 8)))
(error "Error in out-foo")))
(exit 0)

34
SWIG/Examples/test-suite/schemerunme/li_typemaps_proxy.scm Normal file
View file

@ -0,0 +1,34 @@
(define-macro (check func val test)
(cons 'begin
(map
(lambda (x)
`(if (not (,test (,(string->symbol (string-append x func)) ,val) ,val))
(error ,(string-append "Error in test " x func))))
(list "in-" "inr-" "out-" "outr-" "inout-" "inoutr-"))))
(define (=~ a b)
(< (abs (- a b)) 1e-5))
(check "bool" #t and)
(check "int" -2 =)
(check "long" -32 =)
(check "short" -15 =)
(check "uint" 75 =)
(check "ushort" 123 =)
(check "ulong" 462 =)
;(check "uchar" 16 =)
;(check "schar" -53 =)
(check "float" 4.3 =~)
(check "double" -175.42 =~)
(check "longlong" 1634 =)
(check "ulonglong" 6432 =)
(let ((lst (inoutr-int2 3 -2)))
(if (not (and (= (car lst) 3) (= (cadr lst) -2)))
(error "Error in inoutr-int2")))
(let ((lst (out-foo 4)))
(if (not (and (= (slot-ref (car lst) 'a) 4) (= (cadr lst) 8)))
(error "Error in out-foo")))
(exit 0)

15
SWIG/Examples/test-suite/schemerunme/multiple_inheritance_proxy.scm Normal file
View file

@ -0,0 +1,15 @@
(define-macro (check test)
`(if (not ,test) (error "Error in test" ',test)))
(define b (make <Bar>))
(check (= (bar b) 1))
(define f (make <Foo>))
(check (= (foo f) 2))
(define fb (make <FooBar>))
(check (= (bar fb) 1))
(check (= (foo fb) 2))
(check (= (fooBar fb) 3))
(exit 0)

37
SWIG/Examples/test-suite/schemerunme/unions_proxy.scm Normal file
View file

@ -0,0 +1,37 @@
;;; This is the union runtime testcase. It ensures that values within a
;;; union embedded within a struct can be set and read correctly.
;; Create new instances of SmallStruct and BigStruct for later use
(define small (make <SmallStruct>))
(slot-set! small 'jill 200)
(define big (make <BigStruct>))
(slot-set! big 'smallstruct small)
(slot-set! big 'jack 300)
;; Use SmallStruct then BigStruct to setup EmbeddedUnionTest.
;; Ensure values in EmbeddedUnionTest are set correctly for each.
(define eut (make <EmbeddedUnionTest>))
;; First check the SmallStruct in EmbeddedUnionTest
(slot-set! eut 'number 1)
(slot-set! (slot-ref eut 'uni) 'small small)
(let ((Jill1 (slot-ref
(slot-ref
(slot-ref eut 'uni)
'small)
'jill)))
(if (not (= Jill1 200))
(begin
(display "Runtime test 1 failed.")
(exit 1))))
(let ((Num1 (slot-ref eut 'number)))
(if (not (= Num1 1))
(begin
(display "Runtime test 2 failed.")
(exit 1))))
;; that should do
(exit 0)

34
SWIG/Lib/chicken/chicken.swg
View file

@ -177,11 +177,11 @@ SIMPLE_TYPEMAP(double, C_flonum_magnitude, C_flonum, C_swig_is_flonum, (double),
%typemap(freearg) char * "if ($1 != NULL) { free ($1); }"
/* Pointers, references, and arrays */
%typemap(in) SWIGTYPE *, SWIGTYPE [], SWIGTYPE & {
%typemap(in,closcode="(slot-ref $input 'swig-this)") SWIGTYPE *, SWIGTYPE [], SWIGTYPE & {
$1 = ($1_ltype)SWIG_MustGetPtr($input, $descriptor, $argnum, $disown);
}
%typemap(in) SWIGTYPE *DISOWN {
%typemap(in,closcode="(slot-ref $input 'swig-this)") SWIGTYPE *DISOWN {
$1 = ($1_ltype)SWIG_MustGetPtr($input, $descriptor, $argnum, SWIG_POINTER_DISOWN);
}
@ -215,30 +215,30 @@ SIMPLE_TYPEMAP(double, C_flonum_magnitude, C_flonum, C_swig_is_flonum, (double),
$1 = SWIG_MustGetPtr($input, NULL, 1, 0);
}
%typemap(out) SWIGTYPE *, SWIGTYPE &, SWIGTYPE [] {
%typemap(out,chickenfastproxy="1") SWIGTYPE *, SWIGTYPE &, SWIGTYPE [] {
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
$result = SWIG_NewPointerObj ($1, $descriptor, $owner);
$result = SWIG_NewPointerObjProxy($1, $descriptor, $owner, $proxy);
}
%typemap(out) SWIGTYPE *DYNAMIC, SWIGTYPE &DYNAMIC {
%typemap(out,chickenfastproxy="1") SWIGTYPE *DYNAMIC, SWIGTYPE &DYNAMIC {
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
swig_type_info *ty = SWIG_TypeDynamicCast($1_descriptor,(void **) &$1);
$result = SWIG_NewPointerObj ($1, ty, $owner);
$result = SWIG_NewPointerObjProxy($1, ty, $owner, $proxy);
}
%typemap(varout) SWIGTYPE *, SWIGTYPE [] {
%typemap(varout,chickenfastproxy="1") SWIGTYPE *, SWIGTYPE [] {
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
$result = SWIG_NewPointerObj ($varname, $descriptor, 0);
$result = SWIG_NewPointerObjProxy($varname, $descriptor, 0, 0);
}
%typemap(varout) SWIGTYPE & {
%typemap(varout,chickenfastproxy="1") SWIGTYPE & {
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
$result = SWIG_NewPointerObj((void *) &$varname, $1_descriptor, 0);
$result = SWIG_NewPointerObjProxy((void *) &$varname, $1_descriptor, 0, 0);
}
/* Pass-by-value */
%typemap(in) SWIGTYPE($&1_ltype argp) {
%typemap(in,closcode="(slot-ref $input 'swig-this)") SWIGTYPE($&1_ltype argp) {
argp = ($&1_ltype)SWIG_MustGetPtr($input, $&1_descriptor, $argnum, 0);
$1 = *argp;
}
@ -249,13 +249,13 @@ SIMPLE_TYPEMAP(double, C_flonum_magnitude, C_flonum, C_swig_is_flonum, (double),
$1 = *argp;
}
%typemap(out) SWIGTYPE
%typemap(out,chickenfastproxy="1") SWIGTYPE
#ifdef __cplusplus
{
$&1_ltype resultptr;
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
resultptr = new $1_ltype(($1_ltype &) $1);
$result = SWIG_NewPointerObj (resultptr, $&1_descriptor, 1);
$result = SWIG_NewPointerObjProxy(resultptr, $&1_descriptor, 1, $proxy);
}
#else
{
@ -263,17 +263,17 @@ SIMPLE_TYPEMAP(double, C_flonum_magnitude, C_flonum, C_swig_is_flonum, (double),
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
resultptr = ($&1_ltype) malloc(sizeof($1_type));
memmove(resultptr, &$1, sizeof($1_type));
$result = SWIG_NewPointerObj(resultptr, $&1_descriptor, 1);
$result = SWIG_NewPointerObjProxy(resultptr, $&1_descriptor, 1,$proxy);
}
#endif
%typemap(varout) SWIGTYPE
%typemap(varout,chickenfastproxy="1") SWIGTYPE
#ifdef __cplusplus
{
$&1_ltype resultptr;
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
resultptr = new $1_ltype(($1_ltype&) $1);
$result = SWIG_NewPointerObj (resultptr, $&1_descriptor, 0);
$result = SWIG_NewPointerObjProxy(resultptr, $&1_descriptor, 0, 0);
}
#else
{
@ -281,7 +281,7 @@ SIMPLE_TYPEMAP(double, C_flonum_magnitude, C_flonum, C_swig_is_flonum, (double),
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
resultptr = ($&1_ltype) malloc(sizeof($1_type));
memmove(resultptr, &$1, sizeof($1_type));
$result = SWIG_NewPointerObj(resultptr, $&1_descriptor, 0);
$result = SWIG_NewPointerObjProxy(resultptr, $&1_descriptor, 0, 0);
}
#endif

26
SWIG/Lib/chicken/chickenrun.swg
View file

@ -25,7 +25,9 @@ extern "C" {
#define SWIG_MustGetPtr(s, type, argnum, flags) \
SWIG_Chicken_MustGetPtr(s, type, argnum, flags)
#define SWIG_NewPointerObj(ptr, type, owner) \
SWIG_Chicken_NewPointerObj((void*)ptr, type, owner, &known_space)
SWIG_Chicken_NewPointerObj((void*)ptr, type, owner, 1, &known_space)
#define SWIG_NewPointerObjProxy(ptr, type, owner, proxy) \
SWIG_Chicken_NewPointerObj((void*)ptr, type, owner, proxy, &known_space)
#define swig_barf SWIG_Chicken_Barf
#define SWIG_ThrowException(val) SWIG_Chicken_ThrowException(val)
@ -65,6 +67,19 @@ extern "C" {
resultobjlast = tmp; \
}
/* given a SWIG pointer wrapped in a C_word, return the proxy create function, if any */
#define SWIG_Chicken_FindCreateProxy(val, x) \
if (C_swig_is_swigpointer(x)) { \
swig_type_info *t = (swig_type_info *) C_block_item(x, 1); \
if (t && t->clientdata && ((swig_chicken_clientdata *)t->clientdata)->gc_proxy_create) { \
val = CHICKEN_gc_root_ref( ((swig_chicken_clientdata *)t->clientdata)->gc_proxy_create); \
} else { \
val = C_SCHEME_FALSE; \
} \
} else { \
val = C_SCHEME_FALSE; \
}
#define SWIG_POINTER_DISOWN 1
enum {
@ -216,7 +231,7 @@ SWIG_Chicken_Finalizer(C_word argc, C_word closure, C_word continuation, C_word
static C_word finalizer_obj[2] = {(C_word) (C_CLOSURE_TYPE|1), (C_word) SWIG_Chicken_Finalizer};
static C_word
SWIG_Chicken_NewPointerObj(void *ptr, swig_type_info *type, int owner, C_word **data)
SWIG_Chicken_NewPointerObj(void *ptr, swig_type_info *type, int owner, int create_proxy, C_word **data)
{
swig_chicken_clientdata *cdata = (swig_chicken_clientdata *) type->clientdata;
@ -231,7 +246,7 @@ SWIG_Chicken_NewPointerObj(void *ptr, swig_type_info *type, int owner, C_word **
#endif
/* wrap the result inside a proxy class if one is available */
if (cdata && cdata->gc_proxy_create) {
if (create_proxy && cdata && cdata->gc_proxy_create) {
C_word closure = CHICKEN_gc_root_ref(cdata->gc_proxy_create);
if (C_swig_is_closurep(closure)) {
C_save(cptr);
@ -281,10 +296,11 @@ static SWIGINLINE void *
SWIG_Chicken_MustGetPtr (C_word s, swig_type_info *type, int argnum, int flags)
{
void *result;
char err_msg[256];
if (SWIG_Chicken_ConvertPtr(s, &result, type, flags)) {
/* type mismatch */
SWIG_Chicken_Barf(SWIG_BARF1_BAD_ARGUMENT_TYPE,
"Type error in argument %i: expected a %s.", argnum, type->name);
snprintf(err_msg, sizeof(err_msg), "Type error in argument #%i: expected %s", argnum, (type->str ? type->str : type->name));
SWIG_Chicken_Barf(SWIG_BARF1_BAD_ARGUMENT_TYPE, err_msg);
}
return result;
}

36
SWIG/Lib/chicken/std_string.i
View file

@ -7,7 +7,20 @@
namespace std {
class string;
%insert(closprefix) %{ (declare (hide <std-string>)) %}
%nodefault string;
%rename("std-string") string;
class string {
public:
~string() {}
};
%extend string {
char *str;
}
%{
#define std_string_str_get(s) ((char *)((s)->c_str()))
#define std_string_str_set(s,v) (s->assign((char *)(v)))
%}
%typemap(typecheck) string = char *;
%typemap(typecheck) const string & = char *;
@ -55,4 +68,25 @@ namespace std {
C_word *space = C_alloc (C_SIZEOF_STRING (size));
$result = C_string (&space, size, (char *) $1->c_str());
}
%typemap(varin) string {
if ($input == C_SCHEME_FALSE) {
$1 = std::string();
} else {
char *tempptr;
if (!C_swig_is_string ($input)) {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE,
"Argument #$argnum is not a string");
}
tempptr = SWIG_MakeString($input);
$1 = std::string(tempptr);
if (tempptr) SWIG_free(tempptr);
}
}
%typemap(varout) string {
int size = $1.size();
C_word *space = C_alloc (C_SIZEOF_STRING (size));
$result = C_string (&space, size, (char *) $1.c_str());
}
}

130
SWIG/Lib/chicken/tinyclos-multi-generic.patch
View file

@ -3,13 +3,60 @@
# generics, that is, generics now correctly handle adding methods
# with different lengths of specializer lists
# This patch has been committed into the CHICKEN darcs repository,
# so chicken versions above 1.92 work fine.
# Comments, bugs, suggestions send to chicken-users@nongnu.org
# Patch written by John Lenz <lenz@cs.wisc.edu>
--- tinyclos.scm.old 2005-04-04 23:35:10.000000000 -0500
+++ tinyclos.scm 2005-04-05 14:03:26.740306763 -0500
@@ -868,13 +868,24 @@
--- tinyclos.scm.old 2005-04-05 01:13:56.000000000 -0500
+++ tinyclos.scm 2005-04-11 16:37:23.746181489 -0500
@@ -37,8 +37,10 @@
(include "parameters")
+(cond-expand [(not chicken-compile-shared) (declare (unit tinyclos))]
+ [else] )
+
(declare
- (unit tinyclos)
(uses extras)
(usual-integrations)
(fixnum)
@@ -234,7 +236,10 @@
y = C_block_item(y, 1);
}
}
- return(C_block_item(v, i + 1));
+ if (x == C_SCHEME_END_OF_LIST && y == C_SCHEME_END_OF_LIST)
+ return(C_block_item(v, i + 1));
+ else
+ goto mismatch;
}
else if(free_index == -1) free_index = i;
mismatch:
@@ -438,7 +443,7 @@
(define hash-arg-list
(foreign-lambda* unsigned-int ((scheme-object args) (scheme-object svector)) "
C_word tag, h, x;
- int n, i, j;
+ int n, i, j, len = 0;
for(i = 0; args != C_SCHEME_END_OF_LIST; args = C_block_item(args, 1)) {
x = C_block_item(args, 0);
if(C_immediatep(x)) {
@@ -481,8 +486,9 @@
default: i += 255;
}
}
+ ++len;
}
- return(i & (C_METHOD_CACHE_SIZE - 1));") )
+ return((i + len) & (C_METHOD_CACHE_SIZE - 1));") )
;
@@ -868,13 +874,27 @@
(##tinyclos#slot-set!
generic
'methods
@ -20,28 +67,49 @@
- [ms2 (method-specializers method)] )
- (not (every2 (lambda (x y) (eq? x y)) ms1 ms2) ) ) )
- (##tinyclos#slot-ref generic 'methods))))
+ (let* ([ms1 (method-specializers method)]
+ [l1 (length ms1)] )
+ (let filter-in-method ([methods (##tinyclos#slot-ref generic 'methods)])
+ (if (null? methods)
+ (list method)
+ (let ([l1 (length (method-specializers method))]
+ [l2 (length (method-specializers (##sys#slot methods 0)))])
+ (cond ((> l1 l2)
+ (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1))))
+ ((< l1 l2)
+ (cons method methods))
+ (else
+ (let check-method ([ms1 (method-specializers method)]
+ [ms2 (method-specializers (##sys#slot methods 0))])
+ (cond ((and (null? ms1) (null? ms2))
+ (cons method (##sys#slot methods 1))) ;; skip the method already in the generic
+ ((eq? (##sys#slot ms1 0) (##sys#slot ms2 0))
+ (check-method (##sys#slot ms1 1) (##sys#slot ms2 1)))
+ (else
+ (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1))))))))))))
+ (if (null? methods)
+ (list method)
+ (let* ([mm (##sys#slot methods 0)]
+ [ms2 (method-specializers mm)]
+ [l2 (length ms2)])
+ (cond ((> l1 l2)
+ (cons mm (filter-in-method (##sys#slot methods 1))))
+ ((< l1 l2)
+ (cons method methods))
+ (else
+ (let check-method ([ms1 ms1]
+ [ms2 ms2])
+ (cond ((and (null? ms1) (null? ms2))
+ (cons method (##sys#slot methods 1))) ;; skip the method already in the generic
+ ((eq? (##sys#slot ms1 0) (##sys#slot ms2 0))
+ (check-method (##sys#slot ms1 1) (##sys#slot ms2 1)))
+ (else
+ (cons mm (filter-in-method (##sys#slot methods 1)))))))))))))
(if (memq generic generic-invocation-generics)
(set! method-cache-tag (vector))
(%entity-cache-set! generic #f) )
@@ -946,9 +957,13 @@
@@ -925,11 +945,13 @@
(memq (car args) generic-invocation-generics))
(let ([proc
(method-procedure
+ ; select the first method of one argument
(let lp ([lis (generic-methods generic)])
- (let ([tail (##sys#slot lis 1)])
- (if (null? tail)
- (##sys#slot lis 0)
- (lp tail)) ) ) ) ] )
+ (if (null? lis)
+ (##sys#error "Unable to find original compute-apply-generic")
+ (if (= (length (method-specializers (##sys#slot lis 0))) 1)
+ (##sys#slot lis 0)
+ (lp (##sys#slot lis 1)))))) ] )
(lambda (args) (apply proc #f args)) )
(let ([x (compute-apply-methods generic)]
[y ((compute-methods generic) args)] )
@@ -946,9 +968,13 @@
(lambda (args)
(let ([applicable
(filter-in (lambda (method)
@ -58,7 +126,7 @@
(generic-methods generic) ) ] )
(if (or (null? applicable) (null? (##sys#slot applicable 1)))
applicable
@@ -975,8 +990,10 @@
@@ -975,8 +1001,10 @@
[else
(cond ((and (null? specls1) (null? specls2))
(##sys#error "two methods are equally specific" generic))
@ -71,12 +139,12 @@
((null? args)
(##sys#error "fewer arguments than specializers" generic))
(else
@@ -1235,7 +1252,7 @@
(define <tcp-listener> (make-primitive-class "tcp-listener" <structure>))
(define <c++-object> (make <class> 'name "c++-object" 'direct-supers (list <object>) 'direct-slots '(this)))
-(set! method-caching-enabled #t)
+;(set! method-caching-enabled #t)
;;; Utilities:
@@ -1210,7 +1238,7 @@
(define <structure> (make-primitive-class "structure"))
(define <procedure> (make-primitive-class "procedure" <procedure-class>))
(define <end-of-file> (make-primitive-class "end-of-file"))
-(define <environment> (make-primitive-class "environment" <structure>)) ; (Benedikt insisted on this)
+(define <environment> (make-primitive-class "environment" <structure>))
(define <hash-table> (make-primitive-class "hash-table" <structure>))
(define <promise> (make-primitive-class "promise" <structure>))
(define <queue> (make-primitive-class "queue" <structure>))

532
SWIG/Source/Modules/chicken.cxx
View file

@ -50,12 +50,11 @@ static File *f_header = 0;
static File *f_wrappers = 0;
static File *f_init = 0;
static String *chickentext = 0;
static String *closhelpers;
static String *closprefix = 0;
static String *swigtype_ptr = 0;
static String *f_sym_size = 0;
static String *closcode = 0;
/* some options */
static int declare_unit = 1;
@ -67,18 +66,19 @@ static int clos = 0;
static String *class_name = 0;
static String *short_class_name = 0;
/* sections of the clos code */
static String *clos_class_defines = 0;
static String *clos_methods = 0;
static int in_class = 0;
static int have_constructor = 0;
static bool exporting_destructor = false;
static String *constructor_name = 0;
static String *memberfunction_name = 0;
static String *member_name = 0;
/* sections of the clos code */
static String *clos_class_defines = 0;
static String *clos_methods = 0;
/* Some clos options */
static int useclassprefix = 0;
static String *closprefix = 0;
static String *clossymnameprefix = 0;
static int hide_primitive = 1;
static Hash *primitive_names = 0;
@ -122,7 +122,6 @@ protected:
};
/* -----------------------------------------------------------------------
static String *closhelpers;
* swig_chicken() - Instantiate module
* ----------------------------------------------------------------------- */
@ -134,17 +133,6 @@ extern "C" {
Language * swig_chicken(void) {
return new_swig_chicken();
}
static int checkNodeClass(Node *n) {
String *kind = Getattr(n, "kind");
if (kind && (
Strcmp(kind, "class") == 0 ||
Strcmp(kind, "struct") == 0 ||
Strcmp(kind, "union") == 0))
return 1;
else
return 0;
}
}
void
@ -158,15 +146,15 @@ CHICKEN::main(int argc, char *argv[])
for (i = 1; i < argc; i++) {
if (argv[i]) {
if (strcmp(argv[i], "-help") == 0) {
fputs(chicken_usage, stdout);
SWIG_exit(0);
fputs(chicken_usage, stdout);
SWIG_exit(0);
}
else if (strcmp(argv[i],"-proxy") == 0) {
clos = 1;
Swig_mark_arg(i);
clos = 1;
Swig_mark_arg(i);
} else if (strcmp(argv[i],"-closprefix") == 0) {
if (argv[i+1]) {
closprefix = NewString(argv[i+1]);
clossymnameprefix = NewString(argv[i+1]);
Swig_mark_arg(i);
Swig_mark_arg(i+1);
i++;
@ -180,11 +168,11 @@ CHICKEN::main(int argc, char *argv[])
hide_primitive = 0;
Swig_mark_arg(i);
} else if (strcmp(argv[i],"-nounit") == 0) {
declare_unit = 0;
Swig_mark_arg(i);
declare_unit = 0;
Swig_mark_arg(i);
} else if (strcmp(argv[i],"-noclosuses") == 0) {
clos_uses = 0;
Swig_mark_arg(i);
clos_uses = 0;
Swig_mark_arg(i);
} else if (strcmp(argv[i],"-nocollection") == 0) {
no_collection = 1;
Swig_mark_arg(i);
@ -225,7 +213,7 @@ CHICKEN::top(Node *n)
f_header = NewString("");
f_wrappers = NewString("");
chickentext = NewString("");
closhelpers = NewString("");
closprefix = NewString("");
f_sym_size = NewString("");
primitive_names = NewHash();
overload_parameter_lists = NewHash();
@ -237,9 +225,8 @@ CHICKEN::top(Node *n)
Swig_register_filebyname("init",f_init);
Swig_register_filebyname("chicken", chickentext);
Swig_register_filebyname("closprefix", closhelpers);
Swig_register_filebyname("closprefix", closprefix);
closcode = NewString("");
clos_class_defines = NewString("");
clos_methods = NewString("");
@ -285,24 +272,23 @@ CHICKEN::top(Node *n)
}
Printv(f_scm,
";; -*- buffer-read-only: t -*- vi: set ro:\n",
";; This file was created automatically by SWIG.\n",
";; Don't modify this file, modify the SWIG interface instead.\n",
NIL);
";; -*- buffer-read-only: t -*- vi: set ro:\n",
";; This file was created automatically by SWIG.\n",
";; Don't modify this file, modify the SWIG interface instead.\n",
NIL);
if (declare_unit)
Printv(f_scm,"(declare (unit ", scmmodule, "))\n\n", NIL);
Printv(f_scm,"(declare \n",
tab4, "(hide swig-init swig-init-return)\n",
tab4, "(foreign-declare \"C_extern void swig_", module, "_init(C_word,C_word,C_word) C_noret;\"))\n", NIL);
tab4, "(hide swig-init swig-init-return)\n",
tab4, "(foreign-declare \"C_extern void swig_", module, "_init(C_word,C_word,C_word) C_noret;\"))\n", NIL);
Printv(f_scm,"(define swig-init (##core#primitive \"swig_", module,
"_init\"))\n", NIL);
"_init\"))\n", NIL);
Printv(f_scm,"(define swig-init-return (swig-init))\n\n", NIL);
if (clos) {
Printf (f_scm, "(declare (uses tinyclos))\n");
Replaceall(closhelpers,"$module", scmmodule);
Printf (f_scm, "%s\n", closhelpers);
Printf (f_scm, "%s\n", closcode);
Replaceall(closprefix,"$module", scmmodule);
Printf (f_scm, "%s\n", closprefix);
Printf (f_scm, "%s\n", clos_class_defines);
Printf (f_scm, "%s\n", clos_methods);
}
@ -325,10 +311,9 @@ CHICKEN::top(Node *n)
Delete(chicken_filename);
Delete(chickentext);
Delete(closhelpers);
Delete(closprefix);
Delete(overload_parameter_lists);
Delete(closcode);
Delete(clos_class_defines);
Delete(clos_methods);
@ -364,13 +349,14 @@ CHICKEN::functionWrapper(Node *n)
String *mangle = NewString("");
String *get_pointers;
String *cleanup;
String *outarg;
String *argout;
String *tm;
String *overname = 0;
String *declfunc = 0;
String *scmname;
bool any_specialized_arg = false;
List *function_arg_types = NewList();
int return_proxy_fastcall = 0;
int num_required;
int num_arguments;
@ -387,15 +373,13 @@ CHICKEN::functionWrapper(Node *n)
wname = NewString("");
get_pointers = NewString("");
cleanup = NewString("");
outarg = NewString("");
argout = NewString("");
declfunc = NewString("");
scmname = NewString(iname);
Replaceall(scmname, "_", "-");
/* Local vars */
Wrapper_add_local(f,"resultobj", "C_word resultobj");
Wrapper_add_local(f,"resultobjlast", "C_word resultobjlast");
Wrapper_add_local(f,"gswig_list_p", "int gswig_list_p = 0");
/* Write code to extract function parameters. */
emit_args(d, l, f);
@ -417,14 +401,14 @@ CHICKEN::functionWrapper(Node *n)
Printv (f->code, "C_trace(\"",scmname,"\");\n", NIL);
Printv(f->def,
"static ",
"void ", wname,
" (C_word argc, C_word closure, C_word continuation",
NIL);
"static ",
"void ", wname,
" (C_word argc, C_word closure, C_word continuation",
NIL);
Printv(declfunc,
"void ", wname,
"(C_word,C_word,C_word",
NIL);
"void ", wname,
"(C_word,C_word,C_word",
NIL);
/* Generate code for argument marshalling */
for (i = 0, p=l; i < num_arguments; i++) {
@ -435,7 +419,6 @@ CHICKEN::functionWrapper(Node *n)
SwigType *pt = Getattr(p,"type");
String *ln = Getattr(p,"lname");
SwigType *pb = SwigType_typedef_resolve_all(SwigType_base(pt));
source = NewStringf("scm%d",i+1);
@ -446,35 +429,39 @@ CHICKEN::functionWrapper(Node *n)
if ((tm = Getattr(p,"tmap:in"))) {
String *parse = Getattr(p,"tmap:in:parse");
if (!parse) {
Replaceall(tm,"$source",source);
Replaceall(tm,"$target",ln);
Replaceall(tm,"$input", source);
Setattr(p,"emit:input", source); /* Save the location of
the object */
if (Getattr(p,"wrap:disown") || (Getattr(p,"tmap:in:disown"))) {
Replaceall(tm,"$disown","SWIG_POINTER_DISOWN");
} else {
Replaceall(tm,"$disown","0");
}
Replaceall(tm,"$source",source);
Replaceall(tm,"$target",ln);
Replaceall(tm,"$input", source);
Setattr(p,"emit:input", source); /* Save the location of
the object */
if (Getattr(p,"wrap:disown") || (Getattr(p,"tmap:in:disown"))) {
Replaceall(tm,"$disown","SWIG_POINTER_DISOWN");
} else {
Replaceall(tm,"$disown","0");
}
if (i >= num_required)
Printf(get_pointers, "if (argc-2>%i && (%s)) {\n", i, source);
Printv(get_pointers,tm,"\n", NIL);
if (i >= num_required)
Printv(get_pointers, "}\n", NIL);
if (i >= num_required)
Printf(get_pointers, "if (argc-2>%i && (%s)) {\n", i, source);
Printv(get_pointers,tm,"\n", NIL);
if (i >= num_required)
Printv(get_pointers, "}\n", NIL);
if (clos) {
if (i < num_required) {
if (strcmp("void", Char(pt)) != 0) {
Node *class_node = Swig_symbol_clookup_check(pb, Getattr(n, "sym:symtab"), checkNodeClass);
if (class_node) {
String *class_name = NewStringf("<%s>", Getattr(class_node, "sym:name"));
Node *class_node = 0;
String *clos_code = Getattr(p, "tmap:in:closcode");
class_node = classLookup(pt);
if (clos_code && class_node) {
String *class_name = NewStringf("<%s>", Getattr(class_node, "sym:name"));
Append(function_arg_types, class_name);
Append(function_arg_types, Copy(clos_code));
any_specialized_arg = true;
Delete(class_name);
} else {
Append(function_arg_types, "<top>");
Append(function_arg_types, "$input");
}
}
}
@ -488,8 +475,8 @@ CHICKEN::functionWrapper(Node *n)
continue;
} else {
Swig_warning(WARN_TYPEMAP_IN_UNDEF, input_file, line_number,
"Unable to use type %s as a function argument.\n",
SwigType_str(pt,0));
"Unable to use type %s as a function argument.\n",
SwigType_str(pt,0));
break;
}
@ -503,7 +490,7 @@ CHICKEN::functionWrapper(Node *n)
Printf(declfunc, ")");
if (num_required != num_arguments) {
Push(function_arg_types, "^^##optional$$");
Append(function_arg_types, "^^##optional$$");
}
/* First check the number of arguments is correct */
@ -540,6 +527,24 @@ CHICKEN::functionWrapper(Node *n)
/* Emit the function call */
emit_action(n,f);
/* Insert argument output code */
for (p = l; p;) {
if ((tm = Getattr(p,"tmap:argout"))) {
if (!Wrapper_check_local(f, "gswig_list_p")) {
Wrapper_add_local(f,"resultobjlast", "C_word resultobjlast");
Wrapper_add_local(f,"gswig_list_p", "int gswig_list_p = 0");
}
Replaceall(tm,"$source",Getattr(p,"lname"));
Replaceall(tm,"$target","resultobj");
Replaceall(tm,"$arg",Getattr(p,"emit:input"));
Replaceall(tm,"$input",Getattr(p,"emit:input"));
Printf(argout, "%s", tm);
p = Getattr(p,"tmap:argout:next");
} else {
p = nextSibling(p);
}
}
/* Return the function value */
if ((tm = Swig_typemap_lookup_new("out",n,"result",0))) {
Replaceall(tm,"$source", "result");
@ -550,26 +555,26 @@ CHICKEN::functionWrapper(Node *n)
} else {
Replaceall(tm,"$owner","0");
}
/* check for chickenfastproxy flag */
if (Getattr(n, "tmap:out:chickenfastproxy")) {
/* can only do fast proxy if there are no argout paramaters... */
if (Wrapper_check_local(f, "gswig_list_p")) {
Replaceall(tm, "$proxy", "1");
} else {
Replaceall(tm, "$proxy", "0");
return_proxy_fastcall = 1;
}
}
Printf(f->code, "%s", tm);
} else {
Swig_warning(WARN_TYPEMAP_OUT_UNDEF, input_file, line_number,
"Unable to use return type %s in function %s.\n",
SwigType_str(d,0), name);
"Unable to use return type %s in function %s.\n",
SwigType_str(d,0), name);
}
/* Insert argument output code */
for (p = l; p;) {
if ((tm = Getattr(p,"tmap:argout"))) {
Replaceall(tm,"$source",Getattr(p,"lname"));
Replaceall(tm,"$target","resultobj");
Replaceall(tm,"$arg",Getattr(p,"emit:input"));
Replaceall(tm,"$input",Getattr(p,"emit:input"));
Printf(f->code, "%s", tm);
p = Getattr(p,"tmap:argout:next");
} else {
p = nextSibling(p);
}
}
/* Insert the argumetn output code */
Printv(f->code, argout, NIL);
/* Output cleanup code */
Printv(f->code,cleanup,NIL);
@ -588,14 +593,25 @@ CHICKEN::functionWrapper(Node *n)
Printf(f->code,"%s\n",tm);
}
Printf(f->code," C_kontinue (continuation, resultobj);\n");
if (return_proxy_fastcall) {
Printv(f->code,"{\n",
"C_word func;\n",
"SWIG_Chicken_FindCreateProxy(func, resultobj);\n",
"if (C_swig_is_closurep(func))\n",
" ((C_proc3)(void *)C_block_item(func, 0))(3,func,continuation,resultobj);\n",
"else\n",
" C_kontinue(continuation, resultobj);\n",
"}\n", NIL);
} else {
Printf(f->code," C_kontinue (continuation, resultobj);\n");
}
/* Error handling code */
#ifdef USE_FAIL
Printf(f->code,"fail:\n");
Printv(f->code,cleanup,NIL);
Printf(f->code,"swig_panic (\"failure in "
"'$symname' SWIG function wrapper\");\n");
"'$symname' SWIG function wrapper\");\n");
#endif
Printf(f->code,"}\n");
@ -608,8 +624,8 @@ CHICKEN::functionWrapper(Node *n)
/* Dump the function out */
Printv(f_wrappers,
"static ",
declfunc, " C_noret;\n", NIL);
"static ",
declfunc, " C_noret;\n", NIL);
Wrapper_print(f,f_wrappers);
Setattr(n,"wrap:name", wname);
@ -624,13 +640,12 @@ CHICKEN::functionWrapper(Node *n)
addMethod(scmname, wname);
}
/* Only export if we are not in a class, or if in a class memberfunction (this protects against member variables
* and static functions and so forth, which are generated seperatly) */
if (!in_class || memberfunction_name) {
/* Only export if we are not in a class, or if in a class memberfunction */
if (!in_class || member_name) {
String *method_def;
String *clos_name;
if (in_class)
clos_name = NewString(memberfunction_name);
clos_name = NewString(member_name);
else
clos_name = chickenNameMapping(scmname, (char *)"");
@ -668,7 +683,6 @@ CHICKEN::functionWrapper(Node *n)
Delete(wname);
Delete(get_pointers);
Delete(cleanup);
Delete(outarg);
Delete(declfunc);
Delete(mangle);
Delete(function_arg_types);
@ -732,14 +746,14 @@ CHICKEN::variableWrapper(Node *n) {
if (1 || (SwigType_type(t) != T_USER) || (isPointer(t))) {
Printv(f->def,
"static ",
"void ",wname,"(C_word, C_word, C_word, C_word) C_noret;\n",
NIL);
"static ",
"void ",wname,"(C_word, C_word, C_word, C_word) C_noret;\n",
NIL);
Printv(f->def,
"static "
"void ",wname,"(C_word argc, C_word closure, "
"C_word continuation, C_word value) {\n",
NIL);
"static "
"void ",wname,"(C_word argc, C_word closure, "
"C_word continuation, C_word value) {\n",
NIL);
Wrapper_add_local(f, "resultobj", "C_word resultobj");
@ -749,15 +763,15 @@ CHICKEN::variableWrapper(Node *n) {
if (!Getattr(n,"feature:immutable")) {
Printf(f->code, "if (argc > 2) {\n");
if ((tm = Swig_typemap_lookup_new("varin",n,name,0))) {
Replaceall(tm,"$source","value");
Replaceall(tm,"$target",name);
Replaceall(tm,"$input","value");
Printv(f->code, tm, "\n",NIL);
Replaceall(tm,"$source","value");
Replaceall(tm,"$target",name);
Replaceall(tm,"$input","value");
Printv(f->code, tm, "\n",NIL);
}
else {
Swig_warning(WARN_TYPEMAP_VARIN_UNDEF, input_file, line_number,
"Unable to set variable of type %s.\n",
SwigType_str(t,0));
Swig_warning(WARN_TYPEMAP_VARIN_UNDEF, input_file, line_number,
"Unable to set variable of type %s.\n",
SwigType_str(t,0));
}
Printf(f->code, "}\n");
}
@ -780,15 +794,27 @@ CHICKEN::variableWrapper(Node *n) {
}
else {
Swig_warning(WARN_TYPEMAP_VAROUT_UNDEF, input_file, line_number,
"Unable to read variable of type %s\n", SwigType_str(t,0));
"Unable to read variable of type %s\n", SwigType_str(t,0));
}
Printf(f->code,"\nC_kontinue (continuation, resultobj);\n");
if (Getattr(n, "tmap:varout:chickenfastproxy")) {
Printv(f->code,"{\n",
"C_word func;\n",
"SWIG_Chicken_FindCreateProxy(func, resultobj);\n",
"if (C_swig_is_closurep(func))\n",
" ((C_proc3)(void *)C_block_item(func, 0))(3,func,continuation,resultobj);\n",
"else\n",
" C_kontinue(continuation, resultobj);\n",
"}\n", NIL);
} else {
Printf(f->code," C_kontinue (continuation, resultobj);\n");
}
/* Error handling code */
#ifdef USE_FAIL
Printf(f->code,"fail:\n");
Printf(f->code,"swig_panic (\"failure in "
"'%s' SWIG wrapper\");\n", proc_name);
"'%s' SWIG wrapper\");\n", proc_name);
#endif
Printf(f->code,"}\n");
@ -797,18 +823,27 @@ CHICKEN::variableWrapper(Node *n) {
/* Now register the variable with the interpreter. */
addMethod(scmname, wname);
if (!in_class) {
String *class_name = SwigType_typedef_resolve_all(SwigType_base(t));
String *clos_name = chickenNameMapping(scmname, (char *)"");
/* Simply re-export the procedure */
Printv(clos_methods, "(define ", clos_name, " ", chickenPrimitiveName(scmname), ")\n", NIL);
Delete(class_name);
if (!in_class || member_name) {
String *clos_name;
if (in_class)
clos_name = NewString(member_name);
else
clos_name = chickenNameMapping(scmname, (char *)"");
Node *class_node = classLookup(t);
if (class_node && Getattr(n, "tmap:varout:chickenfastproxy")) {
Printv(clos_methods, "(define (", clos_name, " . lst) (if (null? lst) (", chickenPrimitiveName(scmname), ") (",
chickenPrimitiveName(scmname), " (slot-ref (car lst) 'swig-this))))\n", NIL);
} else {
/* Simply re-export the procedure */
Printv(clos_methods, "(define ", clos_name, " ", chickenPrimitiveName(scmname), ")\n", NIL);
}
Delete(clos_name);
}
} else {
Swig_warning(WARN_TYPEMAP_VAR_UNDEF, input_file, line_number,
"Unsupported variable type %s (ignored).\n",
SwigType_str(t,0));
"Unsupported variable type %s (ignored).\n",
SwigType_str(t,0));
}
Delete(wname);
@ -898,7 +933,7 @@ CHICKEN::constantWrapper(Node *n)
}
else {
Swig_warning(WARN_TYPEMAP_CONST_UNDEF, input_file, line_number,
"Unsupported constant value.\n");
"Unsupported constant value.\n");
return SWIG_NOWRAP;
}
@ -922,15 +957,15 @@ CHICKEN::constantWrapper(Node *n)
if (1 || (SwigType_type(t) != T_USER) || (isPointer(t))) {
Printv(f->def,
"static ",
"void ",wname,"(C_word, C_word, C_word) C_noret;\n",
NIL);
"static ",
"void ",wname,"(C_word, C_word, C_word) C_noret;\n",
NIL);
Printv(f->def,
"static ",
"void ",wname,"(C_word argc, C_word closure, "
"C_word continuation) {\n",
NIL);
"static ",
"void ",wname,"(C_word argc, C_word closure, "
"C_word continuation) {\n",
NIL);
Wrapper_add_local(f, "resultobj", "C_word resultobj");
@ -947,15 +982,27 @@ CHICKEN::constantWrapper(Node *n)
}
else {
Swig_warning(WARN_TYPEMAP_VAROUT_UNDEF, input_file, line_number,
"Unable to read variable of type %s\n", SwigType_str(t,0));
"Unable to read variable of type %s\n", SwigType_str(t,0));
}
Printf(f->code,"\nC_kontinue (continuation, resultobj);\n");
if (Getattr(n, "tmap:varout:chickenfastproxy")) {
Printv(f->code,"{\n",
"C_word func;\n",
"SWIG_Chicken_FindCreateProxy(func, resultobj);\n",
"if (C_swig_is_closurep(func))\n",
" ((C_proc3)(void *)C_block_item(func, 0))(3,func,continuation,resultobj);\n",
"else\n",
" C_kontinue(continuation, resultobj);\n",
"}\n", NIL);
} else {
Printf(f->code," C_kontinue (continuation, resultobj);\n");
}
/* Error handling code */
#ifdef USE_FAIL
Printf(f->code,"fail:\n");
Printf(f->code,"swig_panic (\"failure in "
"'%s' SWIG wrapper\");\n", proc_name);
"'%s' SWIG wrapper\");\n", proc_name);
#endif
Printf(f->code,"}\n");
@ -964,16 +1011,20 @@ CHICKEN::constantWrapper(Node *n)
/* Now register the variable with the interpreter. */
addMethod(scmname, wname);
if (!in_class) {
String *clos_name = chickenNameMapping(scmname, (char *)"");
if (!in_class || member_name) {
String *clos_name;
if (in_class)
clos_name = NewString(member_name);
else
clos_name = chickenNameMapping(scmname, (char *)"");
Printv(clos_methods, "(define ", clos_name, " ", chickenPrimitiveName(scmname), ")\n", NIL);
Delete(clos_name);
}
} else {
Swig_warning(WARN_TYPEMAP_VAR_UNDEF, input_file, line_number,
"Unsupported variable type %s (ignored).\n",
SwigType_str(t,0));
"Unsupported variable type %s (ignored).\n",
SwigType_str(t,0));
}
Delete(wname);
@ -1014,9 +1065,9 @@ CHICKEN::classHandler(Node *n)
while (base.item) {
Printv(base_class, Getattr(base.item, "sym:name"),NIL);
base = Next(base);
if (base.item) {
Printf(base_class, "> <");
}
if (base.item) {
Printf(base_class, "> <");
}
}
}
Printf(base_class, ">");
@ -1026,7 +1077,7 @@ CHICKEN::classHandler(Node *n)
Replaceall(scmmod, "_", "-");
Printv(clos_class_defines,"(define ", class_name, "\n",
" (make <swig-metaclass-", scmmod, "> 'name '", class_name, "\n", NIL);
" (make <swig-metaclass-", scmmod, "> 'name \"", short_class_name, "\"\n", NIL);
Delete(scmmod);
if (Len(base_class) > 2) {
@ -1057,7 +1108,7 @@ CHICKEN::classHandler(Node *n)
if (have_constructor) {
Printv(clos_methods, "(define-method (initialize (obj ", class_name, ") initargs)\n",
" (swig-initialize obj initargs ", NIL);
" (swig-initialize obj initargs ", NIL);
if (constructor_arg_types) {
String *initfunc_name = NewStringf("%s@@SWIG@initmethod", class_name);
String *func_call = buildClosFunctionCall(constructor_arg_types, initfunc_name, chickenPrimitiveName(constructor_name));
@ -1079,8 +1130,8 @@ CHICKEN::classHandler(Node *n)
constructor_name = 0;
} else {
Printv(clos_methods, "(define-method (initialize (obj ", class_name, ") initargs)\n",
" (swig-initialize obj initargs (lambda x #f)))\n",
NIL);
" (swig-initialize obj initargs (lambda x #f)))\n",
NIL);
}
/* export class initialization function */
@ -1093,9 +1144,9 @@ CHICKEN::classHandler(Node *n)
Printv(f_wrappers, "static void ", funcname, "(C_word,C_word,C_word,C_word) C_noret;\n",
"static void ", funcname, "(C_word argc, C_word closure, C_word continuation, C_word cl) {\n",
" C_trace(\"", funcname, "\");\n",
" if (argc!=3) C_bad_argc(argc,3);\n",
" swig_chicken_clientdata *cdata = (swig_chicken_clientdata *) SWIGTYPE", swigtype_ptr,"->clientdata;\n",
" cdata->gc_proxy_create = CHICKEN_new_gc_root();\n",
" if (argc!=3) C_bad_argc(argc,3);\n",
" swig_chicken_clientdata *cdata = (swig_chicken_clientdata *) SWIGTYPE", swigtype_ptr,"->clientdata;\n",
" cdata->gc_proxy_create = CHICKEN_new_gc_root();\n",
" CHICKEN_gc_root_set(cdata->gc_proxy_create, cl);\n",
" C_kontinue(continuation, C_SCHEME_UNDEFINED);\n",
"}\n", NIL);
@ -1126,10 +1177,10 @@ CHICKEN::memberfunctionHandler(Node *n)
String *proc = NewString(iname);
Replaceall(proc, "_", "-");
memberfunction_name = chickenNameMapping(proc, short_class_name);
member_name = chickenNameMapping(proc, short_class_name);
Language::memberfunctionHandler(n);
Delete(memberfunction_name);
memberfunction_name = NULL;
Delete(member_name);
member_name = NULL;
Delete(proc);
return SWIG_OK;
@ -1142,10 +1193,10 @@ CHICKEN::staticmemberfunctionHandler(Node *n)
String *proc = NewString(iname);
Replaceall(proc, "_", "-");
memberfunction_name = NewStringf("%s-%s", short_class_name, proc);
member_name = NewStringf("%s-%s", short_class_name, proc);
Language::staticmemberfunctionHandler(n);
Delete(memberfunction_name);
memberfunction_name = NULL;
Delete(member_name);
member_name = NULL;
Delete(proc);
return SWIG_OK;
@ -1155,14 +1206,15 @@ int
CHICKEN::membervariableHandler(Node *n)
{
String *iname = Getattr(n,"sym:name");
String *pb = SwigType_typedef_resolve_all(SwigType_base(Getattr(n, "type")));
//String *pb = SwigType_typedef_resolve_all(SwigType_base(Getattr(n, "type")));
Language::membervariableHandler(n);
String *proc = NewString(iname);
Replaceall(proc,"_","-");
Node *class_node = Swig_symbol_clookup(pb, Getattr(n, "sym:symtab"));
//Node *class_node = Swig_symbol_clookup(pb, Getattr(n, "sym:symtab"));
Node *class_node = classLookup(Getattr(n, "type"));
String *getfunc = NewStringf("%s-%s-get", short_class_name, proc);
String *setfunc = NewStringf("%s-%s-set", short_class_name, proc);
@ -1186,30 +1238,17 @@ CHICKEN::membervariableHandler(Node *n)
int
CHICKEN::staticmembervariableHandler(Node *n)
{
String *iname = Getattr(n, "sym:name");
String *pb = SwigType_typedef_resolve_all(SwigType_base(Getattr(n, "type")));
String *iname = Getattr(n, "sym:name");
String *proc = NewString(iname);
Replaceall(proc, "_", "-");
Language::staticmembervariableHandler(n);
member_name = NewStringf("%s-%s", short_class_name, proc);
Language::staticmembervariableHandler(n);
Delete(member_name);
member_name = NULL;
Delete(proc);
String *proc = NewString(iname);
Replaceall(proc, "_", "-");
String *closprocname = chickenNameMapping(proc, short_class_name);
Node *class_node = Swig_symbol_clookup(pb, Getattr(n, "sym:symtab"));
String *primfunc = NewStringf("%s-%s", short_class_name, proc);
if (class_node) {
Printv(clos_methods, "(define (", closprocname, " . lst) (if (null? lst) (", chickenPrimitiveName(primfunc), ") (",
chickenPrimitiveName(primfunc), " (slot-ref (car lst) 'swig-this))))\n", NIL);
} else {
Printv(clos_methods, "(define ", closprocname, " ", chickenPrimitiveName(primfunc), ")\n", NIL);
}
Delete(closprocname);
return SWIG_OK;
return SWIG_OK;
}
int
@ -1249,7 +1288,7 @@ int CHICKEN::importDirective(Node *n) {
if (mod) {
String *name = Getattr(mod, "name");
if (name) {
Printf(closcode, "(declare (uses %s))\n", name);
Printf(closprefix, "(declare (uses %s))\n", name);
}
}
}
@ -1271,11 +1310,17 @@ String *CHICKEN::buildClosFunctionCall(List *types, String_or_char *closname, St
optional_arguments = 1;
} else {
Printf(method_signature, " (arg%i %s)", arg_count, arg_type.item);
if (Strcmp(arg_type.item, "<top>") == 0) {
Printf(func_args, " arg%i", arg_count);
} else {
Printf(func_args, " (slot-ref arg%i 'swig-this)", arg_count);
}
arg_type = Next(arg_type);
if (!arg_type.item) break;
String *arg = NewStringf("arg%i", arg_count);
String *access_arg = Copy(arg_type.item);
Replaceall(access_arg, "$input", arg);
Printf(func_args, " %s", access_arg);
Delete(arg);
Delete(access_arg);
}
arg_count++;
}
@ -1296,17 +1341,10 @@ String *CHICKEN::buildClosFunctionCall(List *types, String_or_char *closname, St
extern "C" {
/* This compares first based on the position of the last non-primitive argument,
* then if the positions are equal, comparing on non-primitive names */
static int compareTypeLists(const DOH *a, const DOH *b) {
/* compares based on non-primitive names */
static int compareTypeListsHelper(const DOH *a, const DOH *b, int opt_equal) {
List *la = (List *) a;
List *lb = (List *) b;
int la_len = Len(la);
int lb_len = Len(lb);
/* We want longer lists to come before shorter lists */
if (la_len < lb_len) return 1;
if (la_len > lb_len) return -1;
Iterator ia = First(la);
Iterator ib = First(lb);
@ -1314,13 +1352,25 @@ extern "C" {
while (ia.item && ib.item) {
int ret = Strcmp(ia.item, ib.item);
if (ret) return ret;
ia = Next(ia);
ib = Next(ib);
ia = Next(Next(ia));
ib = Next(Next(ib));
}
if (opt_equal && ia.item && Strcmp(ia.item, "^^##optional$$") == 0)
return 0;
if (ia.item)
return -1;
if (opt_equal && ib.item && Strcmp(ib.item, "^^##optional$$") == 0)
return 0;
if (ib.item)
return 1;
return 0;
}
static int compareTypeLists(const DOH *a, const DOH *b) {
return compareTypeListsHelper(a, b, 0);
}
}
void
@ -1331,9 +1381,9 @@ CHICKEN::dispatchFunction(Node *n)
int maxargs;
String *tmp = NewString("");
String *dispatch =
Swig_overload_dispatch(n,"%s (2+argc,closure,"
"continuation$commaargs);", &maxargs);
Swig_overload_dispatch(n,"%s (2+$numargs,closure,"
"continuation$commaargs);", &maxargs);
/* Generate a dispatch wrapper for all overloaded functions */
Wrapper *f = NewWrapper();
@ -1345,13 +1395,13 @@ CHICKEN::dispatchFunction(Node *n)
Append(wname, Swig_name_wrapper(iname));
Printv(f->def, "static void real_", wname,
"(C_word, C_word, C_word, C_word) C_noret;\n", NIL);
"(C_word, C_word, C_word, C_word) C_noret;\n", NIL);
Printv(f->def,
"static void real_",
wname,
"(C_word oldargc, C_word closure, C_word continuation, C_word args) {",
NIL);
"static void real_",
wname,
"(C_word oldargc, C_word closure, C_word continuation, C_word args) {",
NIL);
Wrapper_add_local(f,"argc","int argc");
Printf(tmp,"C_word argv[%d]", maxargs+1);
@ -1360,7 +1410,7 @@ CHICKEN::dispatchFunction(Node *n)
Wrapper_add_local(f,"t","C_word t = args");
Printf(f->code,"if (!C_swig_is_list (args)) {\n");
Printf(f->code," swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, "
"\"Argument #1 must be a list of overloaded arguments\");\n");
"\"Argument #1 must be a list of overloaded arguments\");\n");
Printf(f->code,"}\n");
Printf(f->code,"argc = C_unfix (C_i_length (args));\n");
Printf(f->code,"for (ii = 0; (ii < argc) && (ii < %d); ii++, t = C_block_item (t, 1)) {\n",maxargs);
@ -1369,7 +1419,7 @@ CHICKEN::dispatchFunction(Node *n)
Printv(f->code,dispatch,"\n",NIL);
Printf(f->code,"swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE,"
"\"No matching function for overloaded '%s'\");\n", iname);
"\"No matching function for overloaded '%s'\");\n", iname);
Printv(f->code,"}\n",NIL);
Wrapper_print(f,f_wrappers);
addMethod(scmname, wname);
@ -1379,18 +1429,18 @@ CHICKEN::dispatchFunction(Node *n)
/* varargs */
Printv(f->def, "void ", wname,
"(C_word, C_word, C_word, ...) C_noret;\n", NIL);
"(C_word, C_word, C_word, ...) C_noret;\n", NIL);
Printv(f->def, "void ", wname,
"(C_word c, C_word t0, C_word t1, ...) {",
NIL);
"(C_word c, C_word t0, C_word t1, ...) {",
NIL);
Printv(f->code,
"C_word t2;\n",
"va_list v;\n",
"C_word *a, c2 = c;\n",
"C_save_rest (t1, c2, 2);\n",
"a = C_alloc((c-2)*3);\n",
"t2 = C_restore_rest (a, C_rest_count (0));\n",
"real_", wname, " (3, t0, t1, t2);\n", NIL);
"C_word t2;\n",
"va_list v;\n",
"C_word *a, c2 = c;\n",
"C_save_rest (t1, c2, 2);\n",
"a = C_alloc((c-2)*3);\n",
"t2 = C_restore_rest (a, C_rest_count (0));\n",
"real_", wname, " (3, t0, t1, t2);\n", NIL);
Printv(f->code,"}\n",NIL);
Wrapper_print(f,f_wrappers);
@ -1411,7 +1461,7 @@ CHICKEN::dispatchFunction(Node *n)
construct = 1;
Printf(clos_methods, "(declare (hide %s))\n", clos_name);
} else if (in_class)
clos_name = NewString(memberfunction_name);
clos_name = NewString(member_name);
else
clos_name = chickenNameMapping(scmname, (char *)"");
@ -1423,7 +1473,7 @@ CHICKEN::dispatchFunction(Node *n)
String *newlist = NewList();
for (f = First(flist); f.item; f = Next(f)) {
/* check if cur is a duplicate of prev */
if (prev && compareTypeLists(f.item, prev) == 0) {
if (prev && compareTypeListsHelper(f.item, prev, 1) == 0) {
Delete(f.item);
} else {
Append(newlist, f.item);
@ -1482,15 +1532,15 @@ CHICKEN::addMethod(String *scheme_name, String *function)
" C_word *p0 = a;\n",
" *(a++)=C_CLOSURE_TYPE|1;\n",
" *(a++)=(C_word)", function, ";\n",
" C_mutate(return_vec++, (C_word)p0);\n",
"}\n", NIL);
" C_mutate(return_vec++, (C_word)p0);\n",
"}\n", NIL);
} else {
Printf(f_sym_size, "+C_SIZEOF_INTERNED_SYMBOL(%d)", Len(sym));
Printf(f_init, "sym = C_intern (&a, %d, \"%s\");\n",
Len(sym), sym);
Len(sym), sym);
Printv(f_init,
"C_mutate ((C_word*)sym+1, (*a=C_CLOSURE_TYPE|1, a[1]=(C_word)",
function, ", tmp=(C_word)a, a+=2, tmp));\n", NIL);
"C_mutate ((C_word*)sym+1, (*a=C_CLOSURE_TYPE|1, a[1]=(C_word)",
function, ", tmp=(C_word)a, a+=2, tmp));\n", NIL);
}
if (hide_primitive) {
@ -1523,22 +1573,22 @@ CHICKEN::validIdentifier(String *s)
/* <identifier> --> <initial> <subsequent>* | <peculiar identifier> */
/* <initial> --> <letter> | <special initial> */
if (!(isalpha(*c) || (*c == '!') || (*c == '$') || (*c == '%')
|| (*c == '&') || (*c == '*') || (*c == '/') || (*c == ':')
|| (*c == '<') || (*c == '=') || (*c == '>') || (*c == '?')
|| (*c == '^') || (*c == '_') || (*c == '~'))) {
|| (*c == '&') || (*c == '*') || (*c == '/') || (*c == ':')
|| (*c == '<') || (*c == '=') || (*c == '>') || (*c == '?')
|| (*c == '^') || (*c == '_') || (*c == '~'))) {
/* <peculiar identifier> --> + | - | ... */
if ((strcmp(c, "+") == 0)
|| strcmp(c, "-") == 0
|| strcmp(c, "...") == 0) return 1;
|| strcmp(c, "-") == 0
|| strcmp(c, "...") == 0) return 1;
else return 0;
}
/* <subsequent> --> <initial> | <digit> | <special subsequent> */
while (*c) {
if (!(isalnum(*c) || (*c == '!') || (*c == '$') || (*c == '%')
|| (*c == '&') || (*c == '*') || (*c == '/') || (*c == ':')
|| (*c == '<') || (*c == '=') || (*c == '>') || (*c == '?')
|| (*c == '^') || (*c == '_') || (*c == '~') || (*c == '+')
|| (*c == '-') || (*c == '.') || (*c == '@'))) return 0;
|| (*c == '&') || (*c == '*') || (*c == '/') || (*c == ':')
|| (*c == '<') || (*c == '=') || (*c == '>') || (*c == '?')
|| (*c == '^') || (*c == '_') || (*c == '~') || (*c == '+')
|| (*c == '-') || (*c == '.') || (*c == '@'))) return 0;
c++;
}
return 1;
@ -1556,8 +1606,8 @@ CHICKEN::validIdentifier(String *s)
if (Strcmp(class_name, "") == 0) {
// not part of a class, so no class name to prefix
if (closprefix) {
Printf(n, "%s%s", closprefix, name);
if (clossymnameprefix) {
Printf(n, "%s%s", clossymnameprefix, name);
} else {
Printf(n, "%s", name);
}
@ -1565,8 +1615,8 @@ CHICKEN::validIdentifier(String *s)
if (useclassprefix) {
Printf(n, "%s-%s", class_name, name);
} else {
if (closprefix) {
Printf(n, "%s%s", closprefix, name);
if (clossymnameprefix) {
Printf(n, "%s%s", clossymnameprefix, name);
} else {
Printf(n, "%s", name);
}