Add a whole bunch of chicken runme scripts, and fix the bugs exposed by those scripts
git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk@7155 626c5289-ae23-0410-ae9c-e8d60b6d4f22
This commit is contained in:
John Lenz
parent
c4dc892c23
commit
420ba48099
72 changed files with 1085 additions and 412 deletions
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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());
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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>))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue