This commit is contained in:
FluorescentCIAAfricanAmerican
2020-04-22 12:56:21 -04:00
commit 3bf9df6b27
15370 changed files with 5489726 additions and 0 deletions
@@ -0,0 +1,773 @@
/* -----------------------------------------------------------------------------
* See the LICENSE file for information on copyright, usage and redistribution
* of SWIG, and the README file for authors - http://www.swig.org/release.html.
*
* chicken.swg
*
* CHICKEN configuration module.
* ----------------------------------------------------------------------------- */
/* chicken.h has to appear first. */
%insert(runtime) %{
#include <chicken.h>
%}
%insert(runtime) "swigrun.swg"; // Common C API type-checking code
%insert(runtime) "chickenrun.swg"; // CHICKEN run-time code
/* -----------------------------------------------------------------------------
* standard typemaps
* ----------------------------------------------------------------------------- */
/*
CHICKEN: C
----------
fixnum: int, short, unsigned int, unsigned short, unsigned char,
signed char
char: char
bool: bool
flonum: float, double, long, long long, unsigned long, unsigned long
long
*/
/* --- Primitive types --- */
%define SIMPLE_TYPEMAP(type_, from_scheme, to_scheme, checker, convtype, storage_)
%typemap(in) type_
%{ if (!checker ($input)) {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, "Argument #$argnum is not of type 'type_'");
}
$1 = ($1_ltype) from_scheme ($input); %}
/* Const primitive references. Passed by value */
%typemap(in) const type_ & ($*1_ltype temp)
%{ if (!checker ($input)) {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, "Argument #$argnum is not of type 'type_'");
}
temp = ($*1_ltype) from_scheme ($input);
$1 = &temp; %}
/* --- Variable input --- */
%typemap(varin) type_
%{ if (!checker ($input)) {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, "Cannot use '$1_ltype' for variable '$name' of type 'type_'");
}
$1 = ($1_ltype) from_scheme ($input); %}
#if "storage_" == "0"
%typemap(out) type_
%{
$result = to_scheme (convtype ($1));
%}
/* References to primitive types. Return by value */
%typemap(out) const type_ &
%{
$result = to_scheme (convtype (*$1));
%}
/* --- Variable output --- */
%typemap(varout) type_
%{
$result = to_scheme (convtype ($varname));
%}
%typemap(throws) type_
%{
SWIG_Chicken_ThrowException(to_scheme ( convtype ($1)));
%}
#else
%typemap(out) type_
%{
{
C_word *space = C_alloc(storage_);
$result = to_scheme (&space, convtype ($1));
}
%}
/* References to primitive types. Return by value */
%typemap(out) const type_ &
%{
{
C_word *space = C_alloc(storage_);
$result = to_scheme (&space, convtype (*$1));
}
%}
/* --- Variable output --- */
%typemap(varout) type_
%{
{
C_word *space = C_alloc(storage_);
$result = to_scheme (&space, convtype ($varname));
}
%}
%typemap(throws) type_
%{
{
C_word *space = C_alloc(storage_);
SWIG_Chicken_ThrowException(to_scheme (&space, convtype ($1)));
}
%}
#endif
/* --- Constants --- */
%typemap(constcode) type_
"static const $1_type $result = $value;"
%enddef
SIMPLE_TYPEMAP(int, C_num_to_int, C_fix, C_swig_is_number, (int), 0);
//SIMPLE_TYPEMAP(enum SWIGTYPE, C_unfix, C_fix, C_swig_is_fixnum, (int), 0);
SIMPLE_TYPEMAP(short, C_num_to_int, C_fix, C_swig_is_number, (int), 0);
SIMPLE_TYPEMAP(long, C_num_to_long, C_long_to_num, C_swig_is_long, (long), C_SIZEOF_FLONUM);
SIMPLE_TYPEMAP(long long, C_num_to_long, C_long_to_num, C_swig_is_long, (long), C_SIZEOF_FLONUM);
SIMPLE_TYPEMAP(unsigned int, C_num_to_unsigned_int, C_unsigned_int_to_num, C_swig_is_number, (unsigned int), C_SIZEOF_FLONUM);
SIMPLE_TYPEMAP(unsigned short, C_num_to_unsigned_int, C_fix, C_swig_is_number, (unsigned int), 0);
SIMPLE_TYPEMAP(unsigned long, C_num_to_unsigned_long, C_unsigned_long_to_num, C_swig_is_long, (unsigned long), C_SIZEOF_FLONUM);
SIMPLE_TYPEMAP(unsigned long long, C_num_to_unsigned_long, C_unsigned_long_to_num, C_swig_is_long, (unsigned long), C_SIZEOF_FLONUM);
SIMPLE_TYPEMAP(unsigned char, C_character_code, C_make_character, C_swig_is_char, (unsigned int), 0);
SIMPLE_TYPEMAP(signed char, C_character_code, C_make_character, C_swig_is_char, (int), 0);
SIMPLE_TYPEMAP(char, C_character_code, C_make_character, C_swig_is_char, (char), 0);
SIMPLE_TYPEMAP(bool, C_truep, C_mk_bool, C_swig_is_bool, (bool), 0);
SIMPLE_TYPEMAP(float, C_c_double, C_flonum, C_swig_is_number, (double), C_SIZEOF_FLONUM);
SIMPLE_TYPEMAP(double, C_c_double, C_flonum, C_swig_is_number, (double), C_SIZEOF_FLONUM);
/* enum SWIGTYPE */
%apply int { enum SWIGTYPE };
%apply const int& { const enum SWIGTYPE& };
%typemap(varin) enum SWIGTYPE
{
if (!C_swig_is_fixnum($input) && sizeof(int) != sizeof($1)) {
swig_barf(SWIG_BARF1_BAD_ARGUMENT_TYPE, "enum variable '$name' can not be set");
}
*((int *)(void *)&$1) = C_unfix($input);
}
/* --- Input arguments --- */
/* Strings */
%typemap(in) char *
{ if ($input == C_SCHEME_FALSE) {
$1 = NULL;
}
else {
if (!C_swig_is_string ($input)) {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, "Argument #$argnum is not of type 'char *'");
}
$1 = ($ltype) SWIG_MakeString ($input);
}
}
%typemap(freearg) char * "if ($1 != NULL) { free ($1); }"
/* Pointers, references, and arrays */
%typemap(in,closcode="(slot-ref $input 'swig-this)") SWIGTYPE *, SWIGTYPE [], SWIGTYPE & {
$1 = ($1_ltype)SWIG_MustGetPtr($input, $descriptor, $argnum, $disown);
}
%typemap(in,closcode="(slot-ref $input 'swig-this)") SWIGTYPE *DISOWN {
$1 = ($1_ltype)SWIG_MustGetPtr($input, $descriptor, $argnum, SWIG_POINTER_DISOWN);
}
/* Void pointer. Accepts any kind of pointer */
%typemap(in) void * {
$1 = ($1_ltype)SWIG_MustGetPtr($input, NULL, $argnum, 0);
}
%typemap(varin,closcode="(slot-ref $input 'swig-this)") SWIGTYPE * {
$1 = ($1_ltype)SWIG_MustGetPtr($input, $descriptor, 1, SWIG_POINTER_DISOWN);
}
%typemap(varin,closcode="(slot-ref $input 'swig-this)") SWIGTYPE & {
$1 = *(($1_ltype)SWIG_MustGetPtr($input, $descriptor, 1, 0));
}
%typemap(varin) SWIGTYPE [] {
SWIG_Chicken_Barf(SWIG_BARF1_BAD_ARGUMENT_TYPE, "Type error");
}
%typemap(varin) SWIGTYPE [ANY] {
void *temp;
int ii;
$1_basetype *b = 0;
temp = SWIG_MustGetPtr($input, $1_descriptor, 1, 0);
b = ($1_basetype *) $1;
for (ii = 0; ii < $1_size; ii++) b[ii] = *(($1_basetype *) temp + ii);
}
%typemap(varin) void * {
$1 = SWIG_MustGetPtr($input, NULL, 1, 0);
}
%typemap(out) SWIGTYPE *, SWIGTYPE &, SWIGTYPE [] {
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
$result = SWIG_NewPointerObj($1, $descriptor, $owner);
}
%typemap(out) 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);
}
%typemap(varout) SWIGTYPE *, SWIGTYPE [] {
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
$result = SWIG_NewPointerObj($varname, $descriptor, 0);
}
%typemap(varout) SWIGTYPE & {
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
$result = SWIG_NewPointerObj((void *) &$varname, $1_descriptor, 0);
}
/* special typemaps for class pointers */
%typemap(in) SWIGTYPE (CLASS::*) {
char err_msg[256];
if (C_swig_is_pair($input)) {
/* try and convert pointer object */
void *result;
if (!SWIG_ConvertPtr(C_block_item($input,1), &result, $descriptor, 0)) {
C_word ptr = C_block_item($input,0);
if (C_swig_is_string(ptr)) {
SWIG_UnpackData(C_c_string(ptr), (void *) &$1, sizeof($type));
} else {
snprintf(err_msg, sizeof(err_msg), "Type error in argument #%i: expected %s", $argnum, ($descriptor->str ? $descriptor->str : $descriptor->name));
SWIG_Chicken_Barf(SWIG_BARF1_BAD_ARGUMENT_TYPE, err_msg);
}
} else {
snprintf(err_msg, sizeof(err_msg), "Type error in argument #%i: expected %s", $argnum, ($descriptor->str ? $descriptor->str : $descriptor->name));
SWIG_Chicken_Barf(SWIG_BARF1_BAD_ARGUMENT_TYPE, err_msg);
}
} else {
snprintf(err_msg, sizeof(err_msg), "Type error in argument #%i: expected %s", $argnum, ($descriptor->str ? $descriptor->str : $descriptor->name));
SWIG_Chicken_Barf(SWIG_BARF1_BAD_ARGUMENT_TYPE, err_msg);
}
}
%typemap(out) SWIGTYPE (CLASS::*) {
size_t ptr_size = sizeof($type);
C_word *known_space = C_alloc(C_SIZEOF_PAIR + C_SIZEOF_STRING(2*ptr_size) + C_SIZEOF_SWIG_POINTER);
char *temp = (char *)malloc(2*ptr_size);
C_word ptr = SWIG_NewPointerObj((void *) known_space, $descriptor, 0);
SWIG_PackData(temp, (void *) &$1, ptr_size);
$result = C_pair(&known_space, C_string(&known_space, 2*ptr_size, temp), ptr);
free(temp);
}
%typemap(varin) SWIGTYPE (CLASS::*) {
char err_msg[256];
if (C_swig_is_pair($input)) {
/* try and convert pointer object */
void *result;
if (!SWIG_ConvertPtr(C_block_item($input,1), &result, $descriptor, 0)) {
C_word ptr = C_block_item($input,0);
if (C_swig_is_string(ptr)) {
SWIG_UnpackData(C_c_string(ptr), (void *) &$1, sizeof($type));
} else {
snprintf(err_msg, sizeof(err_msg), "Type error in argument #%i: expected %s", 1, ($descriptor->str ? $descriptor->str : $descriptor->name));
SWIG_Chicken_Barf(SWIG_BARF1_BAD_ARGUMENT_TYPE, err_msg);
}
} else {
snprintf(err_msg, sizeof(err_msg), "Type error in argument #%i: expected %s", 1, ($descriptor->str ? $descriptor->str : $descriptor->name));
SWIG_Chicken_Barf(SWIG_BARF1_BAD_ARGUMENT_TYPE, err_msg);
}
} else {
snprintf(err_msg, sizeof(err_msg), "Type error in argument #%i: expected %s", 1, ($descriptor->str ? $descriptor->str : $descriptor->name));
SWIG_Chicken_Barf(SWIG_BARF1_BAD_ARGUMENT_TYPE, err_msg);
}
}
%typemap(varout) SWIGTYPE (CLASS::*) {
size_t ptr_size = sizeof($type);
C_word *known_space = C_alloc(C_SIZEOF_PAIR + C_SIZEOF_STRING(2*ptr_size) + C_SIZEOF_SWIG_POINTER);
char *temp = (char *)malloc(2*ptr_size);
C_word ptr = SWIG_NewPointerObj((void *) known_space, $descriptor, 0);
SWIG_PackData(temp, (void *) &$varname, ptr_size);
$result = C_pair(&known_space, C_string(&known_space, 2*ptr_size, temp), ptr);
free(temp);
}
/* Pass-by-value */
%typemap(in,closcode="(slot-ref $input 'swig-this)") SWIGTYPE($&1_ltype argp) {
argp = ($&1_ltype)SWIG_MustGetPtr($input, $&1_descriptor, $argnum, 0);
$1 = *argp;
}
%typemap(varin,closcode="(slot-ref $input 'swig-this)") SWIGTYPE {
$&1_ltype argp;
argp = ($&1_ltype)SWIG_MustGetPtr($input, $&1_descriptor, 1, 0);
$1 = *argp;
}
%typemap(out) 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);
}
#else
{
$&1_ltype resultptr;
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);
}
#endif
%typemap(varout) 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);
}
#else
{
$&1_ltype resultptr;
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);
}
#endif
/* --- Output values --- */
/* Strings */
%typemap(out)
char *
{ char *s = (char*) $1;
if ($1 == NULL) {
$result = C_SCHEME_FALSE;
}
else {
int string_len = strlen ((char *) ($1));
C_word *string_space = C_alloc (C_SIZEOF_STRING (string_len));
$result = C_string (&string_space, string_len, s);
}
}
%typemap(varout)
char *
{ char *s = (char*) $varname;
if ($varname == NULL) {
$result = C_SCHEME_FALSE;
}
else {
int string_len = strlen ($varname);
C_word *string_space = C_alloc (C_SIZEOF_STRING (string_len));
$result = C_string (&string_space, string_len, s);
}
}
%typemap(throws) char *
{
if ($1 == NULL) {
SWIG_Chicken_ThrowException(C_SCHEME_FALSE);
} else {
int string_len = strlen($1);
C_word *string_space = C_alloc(C_SIZEOF_STRING(string_len));
SWIG_Chicken_ThrowException(C_string(&string_space, string_len, (char *) $1));
}
}
/* Void */
%typemap(out) void
%{
$result = C_SCHEME_UNDEFINED;
%}
/* Special typemap for character array return values */
%typemap(out)
char [ANY], const char [ANY]
%{ if ($1 == NULL) {
$result = C_SCHEME_FALSE;
}
else {
const int string_len = strlen ($1);
C_word *string_space = C_alloc (C_SIZEOF_STRING (string_len));
$result = C_string (&string_space, string_len, $1);
} %}
/* Primitive types--return by value */
/* --- Variable input --- */
/* A string */
#ifdef __cplusplus
%typemap(varin) char * {
if ($input == C_SCHEME_FALSE) {
$1 = NULL;
}
else if (!C_swig_is_string ($input)) {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, "C variable '$name ($1_ltype)'");
}
else {
char *temp = C_c_string ($input);
int len = C_header_size ($input);
if ($1) delete [] $1;
$1 = ($type) new char[len+1];
strncpy((char*)$1, temp, len);
((char*)$1) [len] = 0;
}
}
%typemap(varin,warning="451:Setting const char * variable may leak memory") const char * {
if ($input == C_SCHEME_FALSE) {
$1 = NULL;
}
else if (!C_swig_is_string ($input)) {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, "C variable '$name ($1_ltype)'");
}
else {
char *temp = C_c_string ($input);
int len = C_header_size ($input);
$1 = ($type) new char[len+1];
strncpy((char*)$1,temp,len);
((char*)$1) [len] = 0;
}
}
#else
%typemap(varin) char * {
if ($input == C_SCHEME_FALSE) {
$1 = NULL;
}
else if (!C_swig_is_string ($input)) {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, "C variable '$name ($1_ltype)'");
}
else {
char *temp = C_c_string ($input);
int len = C_header_size ($input);
if ($1) free((char*) $1);
$1 = ($type) malloc(len+1);
strncpy((char*)$1,temp,len);
((char*)$1) [len] = 0;
}
}
%typemap(varin,warning="451:Setting const char * variable may leak memory") const char * {
if ($input == C_SCHEME_FALSE) {
$1 = NULL;
}
else if (!C_swig_is_string ($input)) {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, "C variable '$name ($1_ltype)'");
}
else {
char *temp = C_c_string ($input);
int len = C_header_size ($input);
$1 = ($type) malloc(len+1);
strncpy((char*)$1,temp,len);
((char*)$1) [len] = 0;
}
}
#endif
%typemap(varin) char [] {
swig_barf(SWIG_BARF1_BAD_ARGUMENT_TYPE, "C/C++ variable '$name' is read-only");
}
/* Special case for string array variables */
%typemap(varin) char [ANY] {
if ($input == C_SCHEME_FALSE) {
memset($1,0,$1_dim0*sizeof(char));
}
else if (!C_swig_is_string ($input)) {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, "C variable '$name ($1_ltype)'");
}
else {
char *temp = C_c_string ($input);
strncpy($1,temp,$1_dim0*sizeof(char));
}
}
/* --- Variable output --- */
/* Void */
%typemap(varout) void "$result = C_SCHEME_UNDEFINED;";
/* Special typemap for character array return values */
%typemap(varout) char [ANY], const char [ANY]
%{ if ($varname == NULL) {
$result = C_SCHEME_FALSE;
}
else {
const int string_len = strlen ($varname);
C_word *string_space = C_alloc (C_SIZEOF_STRING (string_len));
$result = C_string (&string_space, string_len, (char *) $varname);
}
%}
/* --- Constants --- */
%typemap(constcode) char *
"static const char *$result = $value;"
%typemap(constcode) SWIGTYPE *, SWIGTYPE &, SWIGTYPE []
"static const void *$result = (void*) $value;"
/* ------------------------------------------------------------
* String & length
* ------------------------------------------------------------ */
%typemap(in) (char *STRING, int LENGTH) {
if ($input == C_SCHEME_FALSE) {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, "Cannot use a null/#f string for a char*, int arguments");
}
else if (C_swig_is_string ($input)) {
$1 = ($1_ltype) C_c_string ($input);
$2 = ($2_ltype) C_header_size ($input);
}
else {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, "Argument #$argnum is not of type 'string'");
}
}
/* ------------------------------------------------------------
* CHICKEN types
* ------------------------------------------------------------ */
%typemap(in) C_word "$1 = $input;";
%typemap(out) C_word "$result = $1;";
/* ------------------------------------------------------------
* Typechecking rules
* ------------------------------------------------------------ */
%typecheck(SWIG_TYPECHECK_INTEGER)
bool, const bool &
{
$1 = C_swig_is_bool ($input);
}
%typecheck(SWIG_TYPECHECK_INTEGER)
int, short,
unsigned int, unsigned short,
signed char, unsigned char,
const int &, const short &,
const unsigned int &, const unsigned short &,
enum SWIGTYPE
{
$1 = C_swig_is_fixnum ($input);
}
%typecheck(SWIG_TYPECHECK_INTEGER)
long,
unsigned long,
long long, unsigned long long,
const long &,
const unsigned long &,
const long long &, const unsigned long long &
{
$1 = (C_swig_is_bool ($input) ||
C_swig_is_fixnum ($input) ||
C_swig_is_flonum ($input)) ? 1 : 0;
}
%typecheck(SWIG_TYPECHECK_DOUBLE)
float, double,
const float &, const double &
{
$1 = C_swig_is_flonum ($input);
}
%typecheck(SWIG_TYPECHECK_CHAR) char {
$1 = C_swig_is_string ($input);
}
%typecheck(SWIG_TYPECHECK_STRING) char * {
$1 = C_swig_is_string ($input);
}
%typecheck(SWIG_TYPECHECK_POINTER) SWIGTYPE *, SWIGTYPE &, SWIGTYPE [] {
void *ptr;
$1 = !SWIG_ConvertPtr($input, &ptr, $1_descriptor, 0);
}
%typecheck(SWIG_TYPECHECK_VOIDPTR) void * {
void *ptr;
$1 = !SWIG_ConvertPtr($input, &ptr, 0, 0);
}
%typecheck(SWIG_TYPECHECK_POINTER) SWIGTYPE &
{
void *ptr = 0;
if (SWIG_ConvertPtr($input, &ptr, $descriptor, 0)) {
/* error */
$1 = 0;
} else {
$1 = (ptr != 0);
}
}
%typecheck(SWIG_TYPECHECK_POINTER) SWIGTYPE
{
void *ptr = 0;
if (SWIG_ConvertPtr($input, &ptr, $&descriptor, 0)) {
/* error */
$1 = 0;
} else {
$1 = (ptr != 0);
}
}
/* ------------------------------------------------------------
* Exception handling
* ------------------------------------------------------------ */
/* ------------------------------------------------------------
* --- Exception handling ---
* ------------------------------------------------------------ */
%typemap(throws) SWIGTYPE {
$&ltype temp = new $ltype($1);
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
C_word ptr = SWIG_NewPointerObj(temp, $&descriptor,1);
SWIG_Chicken_ThrowException(ptr);
}
%typemap(throws) SWIGTYPE * {
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
C_word ptr = SWIG_NewPointerObj((void *) $1, $descriptor, 0);
SWIG_Chicken_ThrowException(ptr);
}
%typemap(throws) SWIGTYPE [ANY] {
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
C_word ptr = SWIG_NewPointerObj((void *) $1, $descriptor, 0);
SWIG_Chicken_ThrowException(ptr);
}
%typemap(throws) SWIGTYPE & {
C_word *known_space = C_alloc(C_SIZEOF_SWIG_POINTER);
C_word ptr = SWIG_NewPointerObj((void *)&($1),$descriptor,0);
SWIG_Chicken_ThrowException(ptr);
}
/* ------------------------------------------------------------
* ANSI C typemaps
* ------------------------------------------------------------ */
%apply unsigned long { size_t };
/* ------------------------------------------------------------
* Overloaded operator support
* ------------------------------------------------------------ */
#ifdef __cplusplus
%rename(__add__) *::operator+;
%rename(__pos__) *::operator+();
%rename(__pos__) *::operator+() const;
%rename(__sub__) *::operator-;
%rename(__neg__) *::operator-();
%rename(__neg__) *::operator-() const;
%rename(__mul__) *::operator*;
%rename(__div__) *::operator/;
%rename(__mod__) *::operator%;
%rename(__lshift__) *::operator<<;
%rename(__rshift__) *::operator>>;
%rename(__and__) *::operator&;
%rename(__or__) *::operator|;
%rename(__xor__) *::operator^;
%rename(__invert__) *::operator~;
%rename(__iadd__) *::operator+=;
%rename(__isub__) *::operator-=;
%rename(__imul__) *::operator*=;
%rename(__idiv__) *::operator/=;
%rename(__imod__) *::operator%=;
%rename(__ilshift__) *::operator<<=;
%rename(__irshift__) *::operator>>=;
%rename(__iand__) *::operator&=;
%rename(__ior__) *::operator|=;
%rename(__ixor__) *::operator^=;
%rename(__lt__) *::operator<;
%rename(__le__) *::operator<=;
%rename(__gt__) *::operator>;
%rename(__ge__) *::operator>=;
%rename(__eq__) *::operator==;
%rename(__ne__) *::operator!=;
/* Special cases */
%rename(__call__) *::operator();
#endif
/* Warnings for certain CHICKEN keywords */
%include <chickenkw.swg>
/* TinyCLOS <--> Low-level CHICKEN */
%typemap("clos_in") SIMPLE_CLOS_OBJECT * "(slot-ref $input (quote this))"
%typemap("clos_out") SIMPLE_CLOS_OBJECT * "(make $class (quote this) $1)"
%insert(header) %{
#ifdef __cplusplus
extern "C" {
#endif
/* Chicken initialization function */
SWIGEXPORT void SWIG_init(C_word, C_word, C_word) C_noret;
#ifdef __cplusplus
}
#endif
%}
%insert(closprefix) "swigclosprefix.scm"
%insert(init) "swiginit.swg"
%insert(init) %{
/* CHICKEN initialization function */
#ifdef __cplusplus
extern "C" {
#endif
SWIGEXPORT void SWIG_init(C_word argc, C_word closure, C_word continuation) {
int i;
C_word sym;
C_word tmp;
C_word *a;
C_word ret;
C_word *return_vec;
SWIG_InitializeModule(0);
SWIG_PropagateClientData();
ret = C_SCHEME_TRUE;
#if $veclength
return_vec = C_alloc(C_SIZEOF_VECTOR($veclength));
ret = (C_word) return_vec;
*(return_vec++) = C_VECTOR_TYPE | $veclength;
#endif
a = C_alloc(2*$nummethods$symsize);
%}
@@ -0,0 +1,31 @@
#ifndef CHICKEN_CHICKENKW_SWG_
#define CHICKEN_CHICKENKW_SWG_
/* Warnings for certain CHICKEN keywords. From Section 7.1.1 of
Revised^5 Report on the Algorithmic Language Scheme */
#define CHICKENKW(x) %namewarn("314:" #x " is a R^5RS syntatic keyword") #x
CHICKENKW(else);
CHICKENKW(=>);
CHICKENKW(define);
CHICKENKW(unquote);
CHICKENKW(unquote-splicing);
CHICKENKW(quote);
CHICKENKW(lambda);
CHICKENKW(if);
CHICKENKW(set!);
CHICKENKW(begin);
CHICKENKW(cond);
CHICKENKW(and);
CHICKENKW(or);
CHICKENKW(case);
CHICKENKW(let);
CHICKENKW(let*);
CHICKENKW(letrec);
CHICKENKW(do);
CHICKENKW(delay);
CHICKENKW(quasiquote);
#undef CHICKENKW
#endif //CHICKEN_CHICKENKW_SWG_
@@ -0,0 +1,377 @@
/* -----------------------------------------------------------------------------
* See the LICENSE file for information on copyright, usage and redistribution
* of SWIG, and the README file for authors - http://www.swig.org/release.html.
*
* chickenrun.swg
*
* ----------------------------------------------------------------------------- */
#include <chicken.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#if defined(_MSC_VER) || defined(__BORLANDC__) || defined(_WATCOM)
# ifndef snprintf
# define snprintf _snprintf
# endif
#endif
#ifdef __cplusplus
extern "C" {
#endif
#define SWIG_malloc(size) \
malloc(size)
#define SWIG_free(mem) \
free(mem)
#define SWIG_MakeString(c) \
SWIG_Chicken_MakeString(c)
#define SWIG_ConvertPtr(s, result, type, flags) \
SWIG_Chicken_ConvertPtr(s, result, type, flags)
#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)
#define swig_barf SWIG_Chicken_Barf
#define SWIG_ThrowException(val) SWIG_Chicken_ThrowException(val)
#define SWIG_contract_assert(expr, message) if (!(expr)) { \
SWIG_Chicken_Barf(SWIG_BARF1_CONTRACT_ASSERT, C_text(message)); } else
/* Runtime API */
#define SWIG_GetModule(clientdata) SWIG_Chicken_GetModule()
#define SWIG_SetModule(clientdata, pointer) SWIG_Chicken_SetModule(pointer)
#define C_swig_is_bool(x) C_truep (C_booleanp (x))
#define C_swig_is_char(x) C_truep (C_charp (x))
#define C_swig_is_fixnum(x) C_truep (C_fixnump (x))
#define C_swig_is_flonum(x) (C_truep (C_blockp (x)) && C_truep (C_flonump (x)))
#define C_swig_is_string(x) (C_truep (C_blockp (x)) && C_truep (C_stringp (x)))
#define C_swig_is_vector(x) (C_truep (C_blockp (x)) && C_truep (C_vectorp (x)))
#define C_swig_is_list(x) (C_truep (C_i_listp (x)))
#define C_swig_is_pair(x) (C_truep (C_blockp(x)) && C_truep (C_pairp(x)))
#define C_swig_is_ptr(x) (C_truep (C_blockp (x)) && C_truep (C_pointerp (x)))
#define C_swig_is_swigpointer(x) (C_truep (C_blockp(x)) && C_truep (C_swigpointerp(x)))
#define C_swig_is_closurep(x) (C_truep (C_blockp(x)) && C_truep(C_closurep(x)))
#define C_swig_is_number(x) (C_swig_is_fixnum(x) || C_swig_is_flonum(x))
#define C_swig_is_long(x) C_swig_is_number(x)
#define C_swig_sizeof_closure(num) (num+1)
#define SWIG_Chicken_SetupArgout { \
C_word *a = C_alloc(C_swig_sizeof_closure(2)); \
C_word *closure = a; \
*(a++)=C_CLOSURE_TYPE|2; \
*(a++)=(C_word)SWIG_Chicken_ApplyResults; \
*(a++)=continuation; \
continuation=(C_word)closure; \
}
#define SWIG_APPEND_VALUE(obj) { \
C_word val = (C_word)(obj); \
if (val != C_SCHEME_UNDEFINED) { \
C_word *a = C_alloc(C_swig_sizeof_closure(3)); \
C_word *closure = a; \
*(a++)=C_CLOSURE_TYPE|3; \
*(a++)=(C_word)SWIG_Chicken_MultiResultBuild; \
*(a++)=(C_word)continuation; \
*(a++)=val; \
continuation=(C_word)closure; \
} }
#define SWIG_Chicken_FindCreateProxy(func,obj) \
if (C_swig_is_swigpointer(obj)) { \
swig_type_info *t = (swig_type_info *) C_block_item(obj, 1); \
if (t && t->clientdata && ((swig_chicken_clientdata *)t->clientdata)->gc_proxy_create) { \
func = CHICKEN_gc_root_ref( ((swig_chicken_clientdata *)t->clientdata)->gc_proxy_create); \
} else { \
func = C_SCHEME_FALSE; \
} \
} else { \
func = C_SCHEME_FALSE; \
}
enum {
SWIG_BARF1_BAD_ARGUMENT_TYPE /* 1 arg */,
SWIG_BARF1_ARGUMENT_NULL /* 1 arg */,
SWIG_BARF1_CONTRACT_ASSERT /* 1 arg */,
};
typedef C_word (*swig_chicken_destructor)(C_word,C_word,C_word,C_word);
typedef struct swig_chicken_clientdata {
void *gc_proxy_create;
swig_chicken_destructor destroy;
} swig_chicken_clientdata;
static char *
SWIG_Chicken_MakeString(C_word str) {
char *ret;
size_t l;
l = C_header_size(str);
ret = (char *) SWIG_malloc( (l + 1) * sizeof(char));
if (!ret) return NULL;
memcpy(ret, C_c_string(str), l);
ret[l] = '\0';
return ret;
}
static C_word SWIG_Chicken_LookupSymbol(char *name, C_SYMBOL_TABLE *stable) {
C_word *a = C_alloc(C_SIZEOF_STRING (strlen (name)));
C_word n = C_string2(&a, name);
C_word sym = C_find_symbol(n, stable);
if (C_truep(sym)) {
return C_symbol_value(sym);
} else {
return C_SCHEME_FALSE;
}
}
/* Just a helper function. Do not export it */
static void SWIG_Chicken_Panic (C_char *) C_noret;
static void SWIG_Chicken_Panic (C_char *msg)
{
C_word *a = C_alloc (C_SIZEOF_STRING (strlen (msg)));
C_word scmmsg = C_string2 (&a, msg);
C_halt (scmmsg);
exit (5); /* should never get here */
}
static void
SWIG_Chicken_Barf(int code, C_char *msg, ...) C_noret;
static void
SWIG_Chicken_Barf(int code, C_char *msg, ...)
{
char *errorhook = C_text("\003syserror-hook");
C_word *a = C_alloc (C_SIZEOF_STRING (strlen (errorhook)));
C_word err = C_intern2 (&a, errorhook);
int c = -1;
int i, barfval;
va_list v;
C_temporary_stack = C_temporary_stack_bottom;
err = C_block_item(err, 0);
if(C_immediatep (err))
SWIG_Chicken_Panic (C_text ("`##sys#error-hook' is not defined"));
switch (code) {
case SWIG_BARF1_BAD_ARGUMENT_TYPE:
barfval = C_BAD_ARGUMENT_TYPE_ERROR;
c = 1;
break;
case SWIG_BARF1_ARGUMENT_NULL:
barfval = C_BAD_ARGUMENT_TYPE_ERROR;
c = 1;
break;
case SWIG_BARF1_CONTRACT_ASSERT:
barfval = C_BAD_ARGUMENT_TYPE_ERROR;
c = 1;
break;
default:
SWIG_Chicken_Panic (C_text (msg));
};
if(c > 0 && !C_immediatep (err)) {
C_save (C_fix (barfval));
i = c;
if (i) {
C_word *b = C_alloc (C_SIZEOF_STRING (strlen (msg)));
C_word scmmsg = C_string2 (&b, msg);
C_save (scmmsg);
i--;
}
va_start (v, msg);
while(i--)
C_save (va_arg (v, C_word));
va_end (v);
C_do_apply (c + 1, err,
C_SCHEME_UNDEFINED); /* <- no continuation is passed:
'##sys#error-hook' may not
return! */
}
else if (msg) {
SWIG_Chicken_Panic (msg);
}
else {
SWIG_Chicken_Panic (C_text ("unspecified panic"));
}
}
static void SWIG_Chicken_ThrowException(C_word value) C_noret;
static void SWIG_Chicken_ThrowException(C_word value)
{
char *aborthook = C_text("\003sysabort");
C_word *a = C_alloc(C_SIZEOF_STRING(strlen(aborthook)));
C_word abort = C_intern2(&a, aborthook);
abort = C_block_item(abort, 0);
if (C_immediatep(abort))
SWIG_Chicken_Panic(C_text("`##sys#abort' is not defined"));
C_save(value);
C_do_apply(1, abort, C_SCHEME_UNDEFINED);
}
static void
SWIG_Chicken_Finalizer(C_word argc, C_word closure, C_word continuation, C_word s)
{
swig_type_info *type;
swig_chicken_clientdata *cdata;
if (argc == 3 && s != C_SCHEME_FALSE && C_swig_is_swigpointer(s)) {
type = (swig_type_info *) C_block_item(s, 1);
if (type) {
cdata = (swig_chicken_clientdata *) type->clientdata;
if (cdata && cdata->destroy) {
/* this will not return, but will continue correctly */
cdata->destroy(3,closure,continuation,s);
}
}
}
C_kontinue(continuation, C_SCHEME_UNDEFINED);
}
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_clientdata *cdata = (swig_chicken_clientdata *) type->clientdata;
if (ptr == NULL)
return C_SCHEME_FALSE;
else {
C_word cptr = C_swigmpointer(data, ptr, type);
/* add finalizer to object */
#ifndef SWIG_CHICKEN_NO_COLLECTION
if (owner)
C_do_register_finalizer(cptr, (C_word) finalizer_obj);
#endif
return cptr;
}
}
/* Return 0 if successful. */
static int
SWIG_Chicken_ConvertPtr(C_word s, void **result, swig_type_info *type, int flags)
{
swig_cast_info *cast;
swig_type_info *from;
if (s == C_SCHEME_FALSE) {
*result = NULL;
} else if (C_swig_is_swigpointer(s)) {
/* try and convert type */
from = (swig_type_info *) C_block_item(s, 1);
if (!from) return 1;
if (type) {
cast = SWIG_TypeCheckStruct(from, type);
if (cast) {
int newmemory = 0;
*result = SWIG_TypeCast(cast, (void *) C_block_item(s, 0), &newmemory);
assert(!newmemory); /* newmemory handling not yet implemented */
} else {
return 1;
}
} else {
*result = (void *) C_block_item(s, 0);
}
/* check if we are disowning this object */
if (flags & SWIG_POINTER_DISOWN) {
C_do_unregister_finalizer(s);
}
} else {
return 1;
}
return 0;
}
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 */
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;
}
static char *chicken_runtimevar_name = "type_pointer" SWIG_TYPE_TABLE_NAME;
static swig_module_info *
SWIG_Chicken_GetModule() {
swig_module_info *ret = 0;
C_word sym;
/* lookup the type pointer... it is stored in it's own symbol table */
C_SYMBOL_TABLE *stable = C_find_symbol_table("swig_runtime_data" SWIG_RUNTIME_VERSION);
if (stable != NULL) {
sym = SWIG_Chicken_LookupSymbol(chicken_runtimevar_name, stable);
if (C_truep(sym) && C_swig_is_ptr(sym)) {
ret = (swig_module_info *) C_block_item(sym, 0);
}
}
return ret;
}
static void
SWIG_Chicken_SetModule(swig_module_info *module) {
C_word *a;
C_SYMBOL_TABLE *stable;
C_word sym;
C_word pointer;
static C_word *space = 0;
/* type pointer is stored in it's own symbol table */
stable = C_find_symbol_table("swig_runtime_data" SWIG_RUNTIME_VERSION);
if (stable == NULL) {
stable = C_new_symbol_table("swig_runtime_data" SWIG_RUNTIME_VERSION, 16);
}
if (!space) {
space = (C_word *) C_malloc((C_SIZEOF_POINTER + C_SIZEOF_INTERNED_SYMBOL(C_strlen(chicken_runtimevar_name))) * sizeof(C_word));
}
a = space;
pointer = C_mpointer(&a, (void *) module);
sym = C_intern_in(&a, C_strlen(chicken_runtimevar_name), chicken_runtimevar_name, stable);
C_set_block_item(sym, 0, pointer);
}
static C_word SWIG_Chicken_MultiResultBuild(C_word num, C_word closure, C_word lst) {
C_word cont = C_block_item(closure,1);
C_word obj = C_block_item(closure,2);
C_word func;
SWIG_Chicken_FindCreateProxy(func,obj);
if (C_swig_is_closurep(func)) {
((C_proc4)(void *)C_block_item(func, 0))(4,func,cont,obj,lst);
} else {
C_word *a = C_alloc(C_SIZEOF_PAIR);
C_kontinue(cont,C_pair(&a,obj,lst));
}
return C_SCHEME_UNDEFINED; /* never reached */
}
static C_word SWIG_Chicken_ApplyResults(C_word num, C_word closure, C_word result) {
C_apply_values(3,C_SCHEME_UNDEFINED,C_block_item(closure,1),result);
return C_SCHEME_UNDEFINED; /* never reached */
}
#ifdef __cplusplus
}
#endif
@@ -0,0 +1,3 @@
swigclosprefix.scm
multi-generic.scm
tinyclos-multi-generic.patch
@@ -0,0 +1,152 @@
;; This file is no longer necessary with Chicken versions above 1.92
;;
;; This file overrides two functions inside TinyCLOS to provide support
;; for multi-argument generics. There are many ways of linking this file
;; into your code... all that needs to happen is this file must be
;; executed after loading TinyCLOS but before any SWIG modules are loaded
;;
;; something like the following
;; (require 'tinyclos)
;; (load "multi-generic")
;; (declare (uses swigmod))
;;
;; An alternative to loading this scheme code directly is to add a
;; (declare (unit multi-generic)) to the top of this file, and then
;; compile this into the final executable or something. Or compile
;; this into an extension.
;; Lastly, to override TinyCLOS method creation, two functions are
;; overridden: see the end of this file for which two are overridden.
;; You might want to remove those two lines and then exert more control over
;; which functions are used when.
;; Comments, bugs, suggestions: send either to chicken-users@nongnu.org or to
;; Author: John Lenz <lenz@cs.wisc.edu>, most code copied from TinyCLOS
(define <multi-generic> (make <entity-class>
'name "multi-generic"
'direct-supers (list <generic>)
'direct-slots '()))
(letrec ([applicable?
(lambda (c arg)
(memq c (class-cpl (class-of arg))))]
[more-specific?
(lambda (c1 c2 arg)
(memq c2 (memq c1 (class-cpl (class-of arg)))))]
[filter-in
(lambda (f l)
(if (null? l)
'()
(let ([h (##sys#slot l 0)]
[r (##sys#slot l 1)] )
(if (f h)
(cons h (filter-in f r))
(filter-in f r) ) ) ) )])
(add-method compute-apply-generic
(make-method (list <multi-generic>)
(lambda (call-next-method generic)
(lambda args
(let ([cam (let ([x (compute-apply-methods generic)]
[y ((compute-methods generic) args)] )
(lambda (args) (x y args)) ) ] )
(cam args) ) ) ) ) )
(add-method compute-methods
(make-method (list <multi-generic>)
(lambda (call-next-method generic)
(lambda (args)
(let ([applicable
(filter-in (lambda (method)
(let check-applicable ([list1 (method-specializers method)]
[list2 args])
(cond ((null? list1) #t)
((null? list2) #f)
(else
(and (applicable? (##sys#slot list1 0) (##sys#slot list2 0))
(check-applicable (##sys#slot list1 1) (##sys#slot list2 1)))))))
(generic-methods generic) ) ] )
(if (or (null? applicable) (null? (##sys#slot applicable 1)))
applicable
(let ([cmms (compute-method-more-specific? generic)])
(sort applicable (lambda (m1 m2) (cmms m1 m2 args))) ) ) ) ) ) ) )
(add-method compute-method-more-specific?
(make-method (list <multi-generic>)
(lambda (call-next-method generic)
(lambda (m1 m2 args)
(let loop ((specls1 (method-specializers m1))
(specls2 (method-specializers m2))
(args args))
(cond-expand
[unsafe
(let ((c1 (##sys#slot specls1 0))
(c2 (##sys#slot specls2 0))
(arg (##sys#slot args 0)))
(if (eq? c1 c2)
(loop (##sys#slot specls1 1)
(##sys#slot specls2 1)
(##sys#slot args 1))
(more-specific? c1 c2 arg))) ]
[else
(cond ((and (null? specls1) (null? specls2))
(##sys#error "two methods are equally specific" generic))
;((or (null? specls1) (null? specls2))
; (##sys#error "two methods have different number of specializers" generic))
((null? specls1) #f)
((null? specls2) #t)
((null? args)
(##sys#error "fewer arguments than specializers" generic))
(else
(let ((c1 (##sys#slot specls1 0))
(c2 (##sys#slot specls2 0))
(arg (##sys#slot args 0)))
(if (eq? c1 c2)
(loop (##sys#slot specls1 1)
(##sys#slot specls2 1)
(##sys#slot args 1))
(more-specific? c1 c2 arg)))) ) ] ) ) ) ) ) )
) ;; end of letrec
(define multi-add-method
(lambda (generic method)
(slot-set!
generic
'methods
(let filter-in-method ([methods (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))))))))))))
(##sys#setslot (##sys#slot generic (- (##sys#size generic) 2)) 1 (compute-apply-generic generic)) ))
(define (multi-add-global-method val sym specializers proc)
(let ((generic (if (procedure? val) val (make <multi-generic> 'name (##sys#symbol->string sym)))))
(multi-add-method generic (make-method specializers proc))
generic))
;; Might want to remove these, or perhaps do something like
;; (define old-add-method ##tinyclos#add-method)
;; and then you can switch between creating multi-generics and TinyCLOS generics.
(set! ##tinyclos#add-method multi-add-method)
(set! ##tinyclos#add-global-method multi-add-global-method)
@@ -0,0 +1,100 @@
/* -----------------------------------------------------------------------------
* See the LICENSE file for information on copyright, usage and redistribution
* of SWIG, and the README file for authors - http://www.swig.org/release.html.
*
* std_string.i
*
* SWIG typemaps for std::string
* ----------------------------------------------------------------------------- */
%{
#include <string>
%}
namespace std {
%naturalvar 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 *;
%typemap(in) string (char* tempptr) {
if ($input == C_SCHEME_FALSE) {
$1.resize(0);
} else {
if (!C_swig_is_string ($input)) {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE,
"Argument #$argnum is not a string");
}
tempptr = SWIG_MakeString($input);
$1.assign(tempptr);
if (tempptr) SWIG_free(tempptr);
}
}
%typemap(in) const string& (std::string temp,
char* tempptr) {
if ($input == C_SCHEME_FALSE) {
temp.resize(0);
$1 = &temp;
} else {
if (!C_swig_is_string ($input)) {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE,
"Argument #$argnum is not a string");
}
tempptr = SWIG_MakeString($input);
temp.assign(tempptr);
if (tempptr) SWIG_free(tempptr);
$1 = &temp;
}
}
%typemap(out) string {
int size = $1.size();
C_word *space = C_alloc (C_SIZEOF_STRING (size));
$result = C_string (&space, size, (char *) $1.c_str());
}
%typemap(out) const string& {
int size = $1->size();
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.resize(0);
} 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.assign(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());
}
}
@@ -0,0 +1,31 @@
(declare (hide swig-initialize))
(define (swig-initialize obj initargs create)
(slot-set! obj 'swig-this
(if (memq 'swig-this initargs)
(cadr initargs)
(let ((ret (apply create initargs)))
(if (instance? ret)
(slot-ref ret 'swig-this)
ret)))))
(define-class <swig-metaclass-$module> (<class>) (void))
(define-method (compute-getter-and-setter (class <swig-metaclass-$module>) slot allocator)
(if (not (memq ':swig-virtual slot))
(call-next-method)
(let ((getter (let search-get ((lst slot))
(if (null? lst)
#f
(if (eq? (car lst) ':swig-get)
(cadr lst)
(search-get (cdr lst))))))
(setter (let search-set ((lst slot))
(if (null? lst)
#f
(if (eq? (car lst) ':swig-set)
(cadr lst)
(search-set (cdr lst)))))))
(values
(lambda (o) (getter (slot-ref o 'swig-this)))
(lambda (o new) (setter (slot-ref o 'swig-this) new) new)))))
@@ -0,0 +1,150 @@
# This patch is against chicken 1.92, but it should work just fine
# with older versions of chicken. It adds support for mulit-argument
# 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-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
- (cons method
- (filter-in
- (lambda (m)
- (let ([ms1 (method-specializers m)]
- [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* ([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) )
@@ -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)
- (every2 applicable?
- (method-specializers method)
- args))
+ (let check-applicable ([list1 (method-specializers method)]
+ [list2 args])
+ (cond ((null? list1) #t)
+ ((null? list2) #f)
+ (else
+ (and (applicable? (##sys#slot list1 0) (##sys#slot list2 0))
+ (check-applicable (##sys#slot list1 1) (##sys#slot list2 1)))))))
(generic-methods generic) ) ] )
(if (or (null? applicable) (null? (##sys#slot applicable 1)))
applicable
@@ -975,8 +1001,10 @@
[else
(cond ((and (null? specls1) (null? specls2))
(##sys#error "two methods are equally specific" generic))
- ((or (null? specls1) (null? specls2))
- (##sys#error "two methods have different number of specializers" generic))
+ ;((or (null? specls1) (null? specls2))
+ ; (##sys#error "two methods have different number of specializers" generic))
+ ((null? specls1) #f)
+ ((null? specls2) #t)
((null? args)
(##sys#error "fewer arguments than specializers" generic))
(else
@@ -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>))
@@ -0,0 +1,318 @@
/* -----------------------------------------------------------------------------
* See the LICENSE file for information on copyright, usage and redistribution
* of SWIG, and the README file for authors - http://www.swig.org/release.html.
*
* typemaps.i
*
* Pointer handling
*
* These mappings provide support for input/output arguments and
* common uses for C/C++ pointers. INOUT mappings allow for C/C++
* pointer variables in addition to input/output arguments.
* ----------------------------------------------------------------------------- */
// INPUT typemaps.
// These remap a C pointer to be an "INPUT" value which is passed by value
// instead of reference.
/*
The following methods can be applied to turn a pointer into a simple
"input" value. That is, instead of passing a pointer to an object,
you would use a real value instead.
int *INPUT
short *INPUT
long *INPUT
long long *INPUT
unsigned int *INPUT
unsigned short *INPUT
unsigned long *INPUT
unsigned long long *INPUT
unsigned char *INPUT
char *INPUT
bool *INPUT
float *INPUT
double *INPUT
To use these, suppose you had a C function like this :
double fadd(double *a, double *b) {
return *a+*b;
}
You could wrap it with SWIG as follows :
%include <typemaps.i>
double fadd(double *INPUT, double *INPUT);
or you can use the %apply directive :
%include <typemaps.i>
%apply double *INPUT { double *a, double *b };
double fadd(double *a, double *b);
*/
// OUTPUT typemaps. These typemaps are used for parameters that
// are output only. The output value is appended to the result as
// a list element.
/*
The following methods can be applied to turn a pointer into an "output"
value. When calling a function, no input value would be given for
a parameter, but an output value would be returned. In the case of
multiple output values, they are returned in the form of a Scheme list.
int *OUTPUT
short *OUTPUT
long *OUTPUT
long long *OUTPUT
unsigned int *OUTPUT
unsigned short *OUTPUT
unsigned long *OUTPUT
unsigned long long *OUTPUT
unsigned char *OUTPUT
char *OUTPUT
bool *OUTPUT
float *OUTPUT
double *OUTPUT
For example, suppose you were trying to wrap the modf() function in the
C math library which splits x into integral and fractional parts (and
returns the integer part in one of its parameters).K:
double modf(double x, double *ip);
You could wrap it with SWIG as follows :
%include <typemaps.i>
double modf(double x, double *OUTPUT);
or you can use the %apply directive :
%include <typemaps.i>
%apply double *OUTPUT { double *ip };
double modf(double x, double *ip);
*/
// These typemaps contributed by Robin Dunn
//----------------------------------------------------------------------
//
// T_OUTPUT typemap (and helper function) to return multiple argouts as
// a tuple instead of a list.
//
//----------------------------------------------------------------------
// Simple types
%define INOUT_TYPEMAP(type_, from_scheme, to_scheme, checker, convtype, storage_)
%typemap(in) type_ *INPUT($*1_ltype temp), type_ &INPUT($*1_ltype temp)
%{ if (!checker ($input)) {
swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, "Argument #$argnum is not of type 'type_'");
}
temp = ($*1_ltype) from_scheme ($input);
$1 = &temp; %}
%typemap(typecheck) type_ *INPUT = type_;
%typemap(typecheck) type_ &INPUT = type_;
%typemap(in, numinputs=0) type_ *OUTPUT($*1_ltype temp), type_ &OUTPUT($*1_ltype temp)
" $1 = &temp;"
#if "storage_" == "0"
%typemap(argout) type_ *OUTPUT, type_ &OUTPUT
%{
if ($1 == NULL) {
swig_barf (SWIG_BARF1_ARGUMENT_NULL, "Argument #$argnum must be non-null");
}
SWIG_APPEND_VALUE(to_scheme (convtype (*$1)));
%}
#else
%typemap(argout) type_ *OUTPUT, type_ &OUTPUT
%{
{
C_word *known_space = C_alloc(storage_);
if ($1 == NULL) {
swig_barf (SWIG_BARF1_ARGUMENT_NULL, "Variable '$1' must be non-null");
}
SWIG_APPEND_VALUE(to_scheme (&known_space, convtype (*$1)));
}
%}
#endif
%enddef
INOUT_TYPEMAP(int, C_num_to_int, C_fix, C_swig_is_number, (int), 0);
INOUT_TYPEMAP(enum SWIGTYPE, C_num_to_int, C_fix, C_swig_is_number, (int), 0);
INOUT_TYPEMAP(short, C_num_to_int, C_fix, C_swig_is_number, (int), 0);
INOUT_TYPEMAP(long, C_num_to_long, C_long_to_num, C_swig_is_long, (long), C_SIZEOF_FLONUM);
INOUT_TYPEMAP(long long, C_num_to_long, C_long_to_num, C_swig_is_long, (long), C_SIZEOF_FLONUM);
INOUT_TYPEMAP(unsigned int, C_num_to_unsigned_int, C_unsigned_int_to_num, C_swig_is_number, (int), C_SIZEOF_FLONUM);
INOUT_TYPEMAP(unsigned short, C_num_to_unsigned_int, C_fix, C_swig_is_number, (unsigned int), 0);
INOUT_TYPEMAP(unsigned long, C_num_to_unsigned_long, C_unsigned_long_to_num, C_swig_is_long, (unsigned long), C_SIZEOF_FLONUM);
INOUT_TYPEMAP(unsigned long long, C_num_to_unsigned_long, C_unsigned_long_to_num, C_swig_is_long, (unsigned long), C_SIZEOF_FLONUM);
INOUT_TYPEMAP(unsigned char, C_character_code, C_make_character, C_swig_is_char, (unsigned int), 0);
INOUT_TYPEMAP(signed char, C_character_code, C_make_character, C_swig_is_char, (int), 0);
INOUT_TYPEMAP(char, C_character_code, C_make_character, C_swig_is_char, (char), 0);
INOUT_TYPEMAP(bool, C_truep, C_mk_bool, C_swig_is_bool, (bool), 0);
INOUT_TYPEMAP(float, C_c_double, C_flonum, C_swig_is_number, (double), C_SIZEOF_FLONUM);
INOUT_TYPEMAP(double, C_c_double, C_flonum, C_swig_is_number, (double), C_SIZEOF_FLONUM);
// INOUT
// Mappings for an argument that is both an input and output
// parameter
/*
The following methods can be applied to make a function parameter both
an input and output value. This combines the behavior of both the
"INPUT" and "OUTPUT" methods described earlier. Output values are
returned in the form of a CHICKEN tuple.
int *INOUT
short *INOUT
long *INOUT
long long *INOUT
unsigned int *INOUT
unsigned short *INOUT
unsigned long *INOUT
unsigned long long *INOUT
unsigned char *INOUT
char *INOUT
bool *INOUT
float *INOUT
double *INOUT
For example, suppose you were trying to wrap the following function :
void neg(double *x) {
*x = -(*x);
}
You could wrap it with SWIG as follows :
%include <typemaps.i>
void neg(double *INOUT);
or you can use the %apply directive :
%include <typemaps.i>
%apply double *INOUT { double *x };
void neg(double *x);
As well, you can wrap variables with :
%include <typemaps.i>
%apply double *INOUT { double *y };
extern double *y;
Unlike C, this mapping does not directly modify the input value (since
this makes no sense in CHICKEN). Rather, the modified input value shows
up as the return value of the function. Thus, to apply this function
to a CHICKEN variable you might do this :
x = neg(x)
Note : previous versions of SWIG used the symbol 'BOTH' to mark
input/output arguments. This is still supported, but will be slowly
phased out in future releases.
*/
%typemap(in) int *INOUT = int *INPUT;
%typemap(in) enum SWIGTYPE *INOUT = enum SWIGTYPE *INPUT;
%typemap(in) short *INOUT = short *INPUT;
%typemap(in) long *INOUT = long *INPUT;
%typemap(in) long long *INOUT = long long *INPUT;
%typemap(in) unsigned *INOUT = unsigned *INPUT;
%typemap(in) unsigned short *INOUT = unsigned short *INPUT;
%typemap(in) unsigned long *INOUT = unsigned long *INPUT;
%typemap(in) unsigned long long *INOUT = unsigned long long *INPUT;
%typemap(in) unsigned char *INOUT = unsigned char *INPUT;
%typemap(in) char *INOUT = char *INPUT;
%typemap(in) bool *INOUT = bool *INPUT;
%typemap(in) float *INOUT = float *INPUT;
%typemap(in) double *INOUT = double *INPUT;
%typemap(in) int &INOUT = int &INPUT;
%typemap(in) enum SWIGTYPE &INOUT = enum SWIGTYPE &INPUT;
%typemap(in) short &INOUT = short &INPUT;
%typemap(in) long &INOUT = long &INPUT;
%typemap(in) long long &INOUT = long long &INPUT;
%typemap(in) unsigned &INOUT = unsigned &INPUT;
%typemap(in) unsigned short &INOUT = unsigned short &INPUT;
%typemap(in) unsigned long &INOUT = unsigned long &INPUT;
%typemap(in) unsigned long long &INOUT = unsigned long long &INPUT;
%typemap(in) unsigned char &INOUT = unsigned char &INPUT;
%typemap(in) char &INOUT = char &INPUT;
%typemap(in) bool &INOUT = bool &INPUT;
%typemap(in) float &INOUT = float &INPUT;
%typemap(in) double &INOUT = double &INPUT;
%typemap(argout) int *INOUT = int *OUTPUT;
%typemap(argout) enum SWIGTYPE *INOUT = enum SWIGTYPE *OUTPUT;
%typemap(argout) short *INOUT = short *OUTPUT;
%typemap(argout) long *INOUT = long *OUTPUT;
%typemap(argout) long long *INOUT = long long *OUTPUT;
%typemap(argout) unsigned *INOUT = unsigned *OUTPUT;
%typemap(argout) unsigned short *INOUT = unsigned short *OUTPUT;
%typemap(argout) unsigned long *INOUT = unsigned long *OUTPUT;
%typemap(argout) unsigned long long *INOUT = unsigned long long *OUTPUT;
%typemap(argout) unsigned char *INOUT = unsigned char *OUTPUT;
%typemap(argout) bool *INOUT = bool *OUTPUT;
%typemap(argout) float *INOUT = float *OUTPUT;
%typemap(argout) double *INOUT = double *OUTPUT;
%typemap(argout) int &INOUT = int &OUTPUT;
%typemap(argout) enum SWIGTYPE &INOUT = enum SWIGTYPE &OUTPUT;
%typemap(argout) short &INOUT = short &OUTPUT;
%typemap(argout) long &INOUT = long &OUTPUT;
%typemap(argout) long long &INOUT = long long &OUTPUT;
%typemap(argout) unsigned &INOUT = unsigned &OUTPUT;
%typemap(argout) unsigned short &INOUT = unsigned short &OUTPUT;
%typemap(argout) unsigned long &INOUT = unsigned long &OUTPUT;
%typemap(argout) unsigned long long &INOUT = unsigned long long &OUTPUT;
%typemap(argout) unsigned char &INOUT = unsigned char &OUTPUT;
%typemap(argout) char &INOUT = char &OUTPUT;
%typemap(argout) bool &INOUT = bool &OUTPUT;
%typemap(argout) float &INOUT = float &OUTPUT;
%typemap(argout) double &INOUT = double &OUTPUT;
/* Overloading information */
%typemap(typecheck) double *INOUT = double;
%typemap(typecheck) bool *INOUT = bool;
%typemap(typecheck) char *INOUT = char;
%typemap(typecheck) signed char *INOUT = signed char;
%typemap(typecheck) unsigned char *INOUT = unsigned char;
%typemap(typecheck) unsigned long *INOUT = unsigned long;
%typemap(typecheck) unsigned long long *INOUT = unsigned long long;
%typemap(typecheck) unsigned short *INOUT = unsigned short;
%typemap(typecheck) unsigned int *INOUT = unsigned int;
%typemap(typecheck) long *INOUT = long;
%typemap(typecheck) long long *INOUT = long long;
%typemap(typecheck) short *INOUT = short;
%typemap(typecheck) int *INOUT = int;
%typemap(typecheck) enum SWIGTYPE *INOUT = enum SWIGTYPE;
%typemap(typecheck) float *INOUT = float;
%typemap(typecheck) double &INOUT = double;
%typemap(typecheck) bool &INOUT = bool;
%typemap(typecheck) char &INOUT = char;
%typemap(typecheck) signed char &INOUT = signed char;
%typemap(typecheck) unsigned char &INOUT = unsigned char;
%typemap(typecheck) unsigned long &INOUT = unsigned long;
%typemap(typecheck) unsigned long long &INOUT = unsigned long long;
%typemap(typecheck) unsigned short &INOUT = unsigned short;
%typemap(typecheck) unsigned int &INOUT = unsigned int;
%typemap(typecheck) long &INOUT = long;
%typemap(typecheck) long long &INOUT = long long;
%typemap(typecheck) short &INOUT = short;
%typemap(typecheck) int &INOUT = int;
%typemap(typecheck) enum SWIGTYPE &INOUT = enum SWIGTYPE;
%typemap(typecheck) float &INOUT = float;