From 8d704fbc0f640923bdad79d50fab4496e05bb25e Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 6 Apr 2000 08:26:59 +0000 Subject: [PATCH] Initial revision git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk@392 626c5289-ae23-0410-ae9c-e8d60b6d4f22 --- SWIG/Examples/mzscheme/simple/Makefile | 12 + SWIG/Examples/mzscheme/simple/README | 1 + SWIG/Examples/mzscheme/simple/example.c | 24 + SWIG/Examples/mzscheme/simple/example.i | 13 + SWIG/Examples/mzscheme/simple/example.scm | 24 + SWIG/Lib/mzscheme/Makefile | 4 + SWIG/Lib/mzscheme/mzscheme.swg | 289 ++++++++ SWIG/Lib/mzscheme/typemaps.i | 673 +++++++++++++++++ SWIG/Source/Modules1.1/mzscheme.cxx | 846 ++++++++++++++++++++++ SWIG/Source/Modules1.1/mzscheme.h | 55 ++ 10 files changed, 1941 insertions(+) create mode 100644 SWIG/Examples/mzscheme/simple/Makefile create mode 100644 SWIG/Examples/mzscheme/simple/README create mode 100644 SWIG/Examples/mzscheme/simple/example.c create mode 100644 SWIG/Examples/mzscheme/simple/example.i create mode 100644 SWIG/Examples/mzscheme/simple/example.scm create mode 100644 SWIG/Lib/mzscheme/Makefile create mode 100644 SWIG/Lib/mzscheme/mzscheme.swg create mode 100644 SWIG/Lib/mzscheme/typemaps.i create mode 100644 SWIG/Source/Modules1.1/mzscheme.cxx create mode 100644 SWIG/Source/Modules1.1/mzscheme.h diff --git a/SWIG/Examples/mzscheme/simple/Makefile b/SWIG/Examples/mzscheme/simple/Makefile new file mode 100644 index 000000000..b0cd5ae03 --- /dev/null +++ b/SWIG/Examples/mzscheme/simple/Makefile @@ -0,0 +1,12 @@ +TOP = ../.. +SWIG = $(TOP)/../swig +SRCS = example.c +TARGET = example +INTERFACE = example.i +SWIGOPT = +all:: + $(MAKE) -f $(TOP)/Makefile SRCS='$(SRCS)' SWIG='$(SWIG)' \ + SWIGOPT='$(SWIGOPT)' TARGET='$(TARGET)' INTERFACE='$(INTERFACE)' mzscheme +clean:: + rm -f *_wrap* *.o core *~ *.so + diff --git a/SWIG/Examples/mzscheme/simple/README b/SWIG/Examples/mzscheme/simple/README new file mode 100644 index 000000000..07e8da069 --- /dev/null +++ b/SWIG/Examples/mzscheme/simple/README @@ -0,0 +1 @@ +Simple example from users manual. diff --git a/SWIG/Examples/mzscheme/simple/example.c b/SWIG/Examples/mzscheme/simple/example.c new file mode 100644 index 000000000..f2b074781 --- /dev/null +++ b/SWIG/Examples/mzscheme/simple/example.c @@ -0,0 +1,24 @@ +/* Simple example from documentation */ +/* File : example.c */ + +#include + +double My_variable = 3.0; + +/* Compute factorial of n */ +int fact(int n) { + if (n <= 1) return 1; + else return n*fact(n-1); +} + +/* Compute n mod m */ +int my_mod(int n, int m) { + return (n % m); +} + + +char *get_time() { + long ltime; + time(<ime); + return ctime(<ime); +} diff --git a/SWIG/Examples/mzscheme/simple/example.i b/SWIG/Examples/mzscheme/simple/example.i new file mode 100644 index 000000000..405fbc9d4 --- /dev/null +++ b/SWIG/Examples/mzscheme/simple/example.i @@ -0,0 +1,13 @@ +/* File : example.i */ +%module example +%{ +/* Put headers and other declarations here */ +%} + +%include typemaps.i + +extern double My_variable; +extern int fact(int); +%name(mod) extern int my_mod(int n, int m); +extern int my_mod(int n, int m); +extern char *get_time(); diff --git a/SWIG/Examples/mzscheme/simple/example.scm b/SWIG/Examples/mzscheme/simple/example.scm new file mode 100644 index 000000000..8e20345b2 --- /dev/null +++ b/SWIG/Examples/mzscheme/simple/example.scm @@ -0,0 +1,24 @@ +;; run with mzscheme -r example.scm + +(load-extension "example.so") + +(display (get-time)) + +(printf "My-variable = ~a~n" (my-variable)) + +(let loop ((i 0)) + (when (< i 14) (begin (display i) + (display " factorial is ") + (display (fact i)) + (newline) + (loop (+ i 1))))) + +(let loop ((i 1)) + (when (< i 250) + (begin + (let loopi ((j 1)) + (when (< j 250) (begin (my-variable (+ (my-variable) (mod i j))) + (loopi (+ j 1))))) + (loop (+ i 1))))) + +(printf "My-variable = ~a~n" (my-variable)) diff --git a/SWIG/Lib/mzscheme/Makefile b/SWIG/Lib/mzscheme/Makefile new file mode 100644 index 000000000..ff66f9efa --- /dev/null +++ b/SWIG/Lib/mzscheme/Makefile @@ -0,0 +1,4 @@ + +co:: + co RCS/*.i* RCS/*.swg* + diff --git a/SWIG/Lib/mzscheme/mzscheme.swg b/SWIG/Lib/mzscheme/mzscheme.swg new file mode 100644 index 000000000..e0487030f --- /dev/null +++ b/SWIG/Lib/mzscheme/mzscheme.swg @@ -0,0 +1,289 @@ +#include "escheme.h" + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef SWIG_GLOBAL +#define SWIGSTATIC +#endif + +#ifndef SWIGSTATIC +#define SWIGSTATIC static +#endif + +/* SWIG pointer structure */ + +typedef struct SwigPtrType { + char *name; /* Datatype name */ + int len; /* Length (used for optimization) */ + void *(*cast)(void *); /* Pointer casting function */ + struct SwigPtrType *next; /* Linked list pointer */ +} SwigPtrType; + +/* Pointer cache structure */ + +typedef struct { + int stat; /* Status (valid) bit */ + SwigPtrType *tp; /* Pointer to type structure */ + char name[256]; /* Given datatype name */ + char mapped[256]; /* Equivalent name */ +} SwigCacheType; + +/* Some variables */ + +static int SwigPtrMax = 64; /* Max entries that can be currently held */ + /* This value may be adjusted dynamically */ +static int SwigPtrN = 0; /* Current number of entries */ +static int SwigPtrSort = 0; /* Status flag indicating sort */ +static int SwigStart[256]; /* Starting positions of types */ + +/* Pointer table */ +static SwigPtrType *SwigPtrTable = 0; /* Table containing pointer equivalences */ + +/* Cached values */ + +#define SWIG_CACHESIZE 8 +#define SWIG_CACHEMASK 0x7 +static SwigCacheType SwigCache[SWIG_CACHESIZE]; +static int SwigCacheIndex = 0; +static int SwigLastCache = 0; + +/* Sort comparison function */ +static int swigsort(const void *data1, const void *data2) { + SwigPtrType *d1 = (SwigPtrType *) data1; + SwigPtrType *d2 = (SwigPtrType *) data2; + return strcmp(d1->name,d2->name); +} + +/* Binary Search function */ +static int swigcmp(const void *key, const void *data) { + char *k = (char *) key; + SwigPtrType *d = (SwigPtrType *) data; + return strncmp(k,d->name,d->len); +} + +/* Register a new datatype with the type-checker */ + +SWIGSTATIC +void SWIG_RegisterMapping(char *origtype, char *newtype, void *(*cast)(void *)) { + + int i; + SwigPtrType *t = 0,*t1; + + /* Allocate the pointer table if necessary */ + + if (!SwigPtrTable) { + SwigPtrTable = (SwigPtrType *) malloc(SwigPtrMax*sizeof(SwigPtrType)); + SwigPtrN = 0; + } + /* Grow the table */ + if (SwigPtrN >= SwigPtrMax) { + SwigPtrMax = 2*SwigPtrMax; + SwigPtrTable = (SwigPtrType *) realloc((char *) SwigPtrTable,SwigPtrMax*sizeof(SwigPtrType)); + } + for (i = 0; i < SwigPtrN; i++) + if (strcmp(SwigPtrTable[i].name,origtype) == 0) { + t = &SwigPtrTable[i]; + break; + } + if (!t) { + t = &SwigPtrTable[SwigPtrN]; + t->name = origtype; + t->len = strlen(t->name); + t->cast = 0; + t->next = 0; + SwigPtrN++; + } + + /* Check for existing entry */ + + while (t->next) { + if ((strcmp(t->name,newtype) == 0)) { + if (cast) t->cast = cast; + return; + } + t = t->next; + } + + /* Now place entry (in sorted order) */ + + t1 = (SwigPtrType *) malloc(sizeof(SwigPtrType)); + t1->name = newtype; + t1->len = strlen(t1->name); + t1->cast = cast; + t1->next = 0; + t->next = t1; + SwigPtrSort = 0; +} + +/* Make a pointer value string */ + +SWIGSTATIC +void SWIG_MakePtr(char *_c, const void *_ptr, char *type) { + static char _hex[16] = + {'0', '1', '2', '3', '4', '5', '6', '7', '8', '9', + 'a', 'b', 'c', 'd', 'e', 'f'}; + unsigned long _p, _s; + char _result[20], *_r; /* Note : a 64-bit hex number = 16 digits */ + _r = _result; + _p = (unsigned long) _ptr; + if (_p > 0) { + while (_p > 0) { + _s = _p & 0xf; + *(_r++) = _hex[_s]; + _p = _p >> 4; + } + *_r = '_'; + while (_r >= _result) + *(_c++) = *(_r--); + } else { + strcpy (_c, "NULL"); + } + if (_ptr) + strcpy (_c, type); +} + +/* Define for backwards compatibility */ + +#define _swig_make_hex SWIG_MakePtr + +/* Function for getting a pointer value */ + +SWIGSTATIC +char *SWIG_GetPtr(char *_c, void **ptr, char *_t) +{ + unsigned long _p; + char temp_type[256]; + char *name; + int i, len; + SwigPtrType *sp,*tp; + SwigCacheType *cache; + int start, end; + _p = 0; + + /* Pointer values must start with leading underscore */ + if (*_c == '_') { + _c++; + /* Extract hex value from pointer */ + while (*_c) { + if ((*_c >= '0') && (*_c <= '9')) + _p = (_p << 4) + (*_c - '0'); + else if ((*_c >= 'a') && (*_c <= 'f')) + _p = (_p << 4) + ((*_c - 'a') + 10); + else + break; + _c++; + } + + if (_t) { + if (strcmp(_t,_c)) { + if (!SwigPtrSort) { + qsort((void *) SwigPtrTable, SwigPtrN, sizeof(SwigPtrType), swigsort); + for (i = 0; i < 256; i++) { + SwigStart[i] = SwigPtrN; + } + for (i = SwigPtrN-1; i >= 0; i--) { + SwigStart[(int) (SwigPtrTable[i].name[1])] = i; + } + for (i = 255; i >= 1; i--) { + if (SwigStart[i-1] > SwigStart[i]) + SwigStart[i-1] = SwigStart[i]; + } + SwigPtrSort = 1; + for (i = 0; i < SWIG_CACHESIZE; i++) + SwigCache[i].stat = 0; + } + + /* First check cache for matches. Uses last cache value as starting point */ + cache = &SwigCache[SwigLastCache]; + for (i = 0; i < SWIG_CACHESIZE; i++) { + if (cache->stat) { + if (strcmp(_t,cache->name) == 0) { + if (strcmp(_c,cache->mapped) == 0) { + cache->stat++; + *ptr = (void *) _p; + if (cache->tp->cast) *ptr = (*(cache->tp->cast))(*ptr); + return (char *) 0; + } + } + } + SwigLastCache = (SwigLastCache+1) & SWIG_CACHEMASK; + if (!SwigLastCache) cache = SwigCache; + else cache++; + } + /* We have a type mismatch. Will have to look through our type + mapping table to figure out whether or not we can accept this datatype */ + + start = SwigStart[(int) _t[1]]; + end = SwigStart[(int) _t[1]+1]; + sp = &SwigPtrTable[start]; + while (start < end) { + if (swigcmp(_t,sp) == 0) break; + sp++; + start++; + } + if (start > end) sp = 0; + /* Try to find a match for this */ + while (start <= end) { + if (swigcmp(_t,sp) == 0) { + name = sp->name; + len = sp->len; + tp = sp->next; + /* Try to find entry for our given datatype */ + while(tp) { + if (tp->len >= 255) { + return _c; + } + strcpy(temp_type,tp->name); + strncat(temp_type,_t+len,255-tp->len); + if (strcmp(_c,temp_type) == 0) { + + strcpy(SwigCache[SwigCacheIndex].mapped,_c); + strcpy(SwigCache[SwigCacheIndex].name,_t); + SwigCache[SwigCacheIndex].stat = 1; + SwigCache[SwigCacheIndex].tp = tp; + SwigCacheIndex = SwigCacheIndex & SWIG_CACHEMASK; + + /* Get pointer value */ + *ptr = (void *) _p; + if (tp->cast) *ptr = (*(tp->cast))(*ptr); + return (char *) 0; + } + tp = tp->next; + } + } + sp++; + start++; + } + /* Didn't find any sort of match for this data. + Get the pointer value and return the received type */ + *ptr = (void *) _p; + return _c; + } else { + /* Found a match on the first try. Return pointer value */ + *ptr = (void *) _p; + return (char *) 0; + } + } else { + /* No type specified. Good luck */ + *ptr = (void *) _p; + return (char *) 0; + } + } else { + if (strcmp (_c, "NULL") == 0) { + *ptr = (void *) 0; + return (char *) 0; + } + *ptr = (void *) 0; + return _c; + } +} + +/* Compatibility mode */ + +#define _swig_get_hex SWIG_GetPtr + +#ifdef __cplusplus +} +#endif diff --git a/SWIG/Lib/mzscheme/typemaps.i b/SWIG/Lib/mzscheme/typemaps.i new file mode 100644 index 000000000..c77a9d7ca --- /dev/null +++ b/SWIG/Lib/mzscheme/typemaps.i @@ -0,0 +1,673 @@ +/* + -------------------------------------------------- + argout typemaps + convert arguments from C to Scheme + -------------------------------------------------- + */ + +%{ +#define MAXVALUES 6 +%} + +%typemap(mzscheme, argout) + int *M_OUTPUT, + unsigned int *M_OUTPUT, + short *M_OUTPUT, + unsigned short *M_OUTPUT +{ + Scheme_Object *s; + s = scheme_make_integer(*$target); + m_output_helper(_values, s, &_lenv); +} + +%typemap(mzscheme, argout) + long *M_OUTPUT +{ + Scheme_Object *s; + s = scheme_make_integer_value(*$target); + m_output_helper(_values, s, &_lenv); +} + + +%typemap(mzscheme, argout) + unsigned long *M_OUTPUT +{ + Scheme_Object *s; + s = scheme_make_integer_value_from_unsigned(*$target); + m_output_helper(_values, s, &_lenv); +} + + +%typemap(mzscheme, argout) + char *M_OUTPUT, + unsigned char *M_OUTPUT +{ + Scheme_Object *s; + s = scheme_make_string(*$target); + m_output_helper(_values, s, &_lenv); +} + +%typemap(mzscheme, argout) +float *M_OUTPUT, +double *M_OUTPUT +{ + Scheme_Object *s; + s = scheme_make_double(*$target); + m_output_helper(_values, s, &_lenv); +} + +%{ +void m_output_helper(Scheme_Object **target, Scheme_Object *s, int *_lenv) { + target[*_lenv] = s; + (*_lenv)++; +} +%} + +/* + ------------------------------------------------- + Check the type of the MzScheme arguments and + convert function arguments from a MzScheme to a C + representation. + ------------------------------------------------- + */ + +%typemap(mzscheme, in) char { + if(!SCHEME_CHARP($source)) + scheme_wrong_type("$name", "character", $argnum, argc, argv); + $target = SCHEME_CHAR_VAL($source); +} + +%typemap(mzscheme, in) unsigned char { + if(!SCHEME_CHARP($source)) + scheme_wrong_type("$name", "character", $argnum, argc, argv); + $target = SCHEME_CHAR_VAL($source); +} + +%typemap(mzscheme, in) char * { + if(!SCHEME_STRINGP($source)) + scheme_wrong_type("$name", "string ", $argnum, argc, argv); + $target = SCHEME_STR_VAL($source); +} + +%typemap(mzscheme, in) char [ANY] { + if(!SCHEME_STRINGP($source)) + scheme_wrong_type("$name", "string ", $argnum, argc, argv); + $target = SCHEME_STR_VAL($source); +} + +%typemap(mzscheme, in) int { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + $target = SCHEME_INT_VAL($source); +} + +%typemap(mzscheme, in) long { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + scheme_get_int_val($source, &$target); +} + +%typemap(mzscheme, in) short { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + $target = SCHEME_INT_VAL($source); +} + +%typemap(mzscheme, in) unsigned int { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + $target = SCHEME_INT_VAL($source); +} + +%typemap(mzscheme, in) unsigned long { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + scheme_get_unsigned_int_val($source, &$target); +} + +%typemap(mzscheme, in) unsigned short { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + $target = SCHEME_INT_VAL($source); +} +/* +%typemap(mzscheme, in) long long { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + scheme_get_int_val($source, &$target); +} +*/ +%typemap(mzscheme, in) float { + if(!SCHEME_DBLP($source)) + scheme_wrong_type("$name", "double", $argnum, argc, argv); + $target = SCHEME_DBL_VAL($source); +} + +%typemap(mzscheme, in) double { + if(SCHEME_DBLP($source)) + $target = SCHEME_DBL_VAL($source); + else if(SCHEME_REALP($source)) + $target = scheme_real_to_double($source); + else scheme_wrong_type("$name", "real", $argnum, argc, argv); +} +/* +%typemap(mzscheme, in) long double { + if(SCHEME_DBLP($source)) + $target = SCHEME_DBL_VAL($source); + else if(SCHEME_REALP($source)) + $target = scheme_real_to_double($source); + else scheme_wrong_type("$name", "real", $argnum, argc, argv); +} +*/ + +/* + ------------------------------------ + in typemaps for pass-by-reference + ------------------------------------ + */ + +%typemap(mzscheme, in) unsigned char *(unsigned char temp) { + if(!SCHEME_CHARP($source)) + scheme_wrong_type("$name", "character", $argnum, argc, argv); + temp = SCHEME_STR_VAL($source); + $target = &temp; +} + +%typemap(mzscheme, in) int *(int temp) { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + temp = (int)SCHEME_INT_VAL($source); + $target = &temp; +} + +%typemap(mzscheme, in) long *(long temp) { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + scheme_get_int_val($source, &temp); + $target = &temp; + +} + +%typemap(mzscheme, in) short *(short temp) { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + temp = (short)SCHEME_INT_VAL($source); + $target = &temp; +} + +%typemap(mzscheme, in) unsigned int *(unsigned temp) { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + temp = (unsigned)SCHEME_INT_VAL($source); + $target = &temp; +} + +%typemap(mzscheme, in) unsigned long *(unsigned long temp) { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + scheme_get_unsigned_int_val($source, &temp); + $target = &temp; +} + +%typemap(mzscheme, in) unsigned short *(unsigned short temp) { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + temp = (unsigned short)SCHEME_INT_VAL($source); + $target = &temp; + +} +/* +%typemap(mzscheme, in) long long *(long long temp) { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + scheme_get_int_val($source, &temp); + $target = &temp; +} +*/ +%typemap(mzscheme, in) float *(float temp) { + if(!SCHEME_DBLP($source)) + scheme_wrong_type("$name", "double", $argnum, argc, argv); + temp = (float)SCHEME_DBL_VAL($source); + $target = &temp; + +} + +%typemap(mzscheme, in) double *(double temp) { + if(SCHEME_DBLP($source)) { + temp = (double)SCHEME_DBL_VAL($source); + $target = &temp; + } + else if(SCHEME_REALP($source)) { + temp = (double)scheme_real_to_double($source); + $target = &temp; + } + else scheme_wrong_type("$name", "real", $argnum, argc, argv); +} +/* +%typemap(mzscheme, in) long double *(long double temp) { + if(SCHEME_DBLP($source)) { + temp = (long double)SCHEME_DBL_VAL($source); + $target = &temp; + } + else if(SCHEME_REALP($source)) { + temp = (long double)scheme_real_to_double($source); + $target = &temp; + } + else scheme_wrong_type("$name", "real", $argnum, argc, argv); +} +*/ + +/* + ------------------------------------ + convert return type from C to Scheme + ------------------------------------ + */ + +%typemap(mzscheme, out) char { + $target = scheme_make_character($source); +} + +%typemap(mzscheme, out) unsigned char { + $target = scheme_make_character($source); +} + +%typemap(mzscheme, out) char * { + $target = scheme_make_string($source); +} + +%typemap(mzscheme, out) char [ANY] { + $target = scheme_make_string($source); +} + +%typemap(mzscheme, out) int { + $target = scheme_make_integer_value($source); +} + +%typemap(mzscheme, out) long { + $target = scheme_make_integer_value($source); +} + +%typemap(mzscheme, out) short { + $target = scheme_make_integer_value($source); +} +/* +%typemap(mzscheme, out) long long { + $target = scheme_make_integer_value($source); +} +*/ +%typemap(mzscheme, out) unsigned int { + $target = scheme_make_integer_value_from_unsigned($source); +} + +%typemap(mzscheme, out) unsigned long { + $target = scheme_make_integer_value_from_unsigned($source); +} + +%typemap(mzscheme, out) unsigned short { + $target = scheme_make_integer_value_from_unsigned($source); +} + +%typemap(mzscheme, out) float { + $target = scheme_make_double($source); +} + +%typemap(mzscheme, out) double { + $target = scheme_make_double($source); +} +/* +%typemap(mzscheme, out) long double { + $target = scheme_make_double($source); +} +*/ + +/* + ----------------------------------- + convert pointers from C to MzScheme + ----------------------------------- + */ + +%typemap(mzscheme, out) int * { + $target = scheme_make_integer_value(*$source); +} + +%typemap(mzscheme, out) long * { + $target = scheme_make_integer_value(*$source); +} + +%typemap(mzscheme, out) short * { + $target = scheme_make_integer_value(*$source); +} + +/* +%typemap(mzscheme, out) long long * { + $target = scheme_make_integer_value(*$source); +} +*/ +%typemap(mzscheme, out) unsigned int * { + $target = scheme_make_integer_value_from_unsigned(*$source); +} + +%typemap(mzscheme, out) unsigned long * { + $target = scheme_make_integer_value_from_unsigned(*$source); +} + +%typemap(mzscheme, out) unsigned short * { + $target = scheme_make_integer_value_from_unsigned(*$source); +} + +%typemap(mzscheme, out) float * { + $target = scheme_make_double(*$source); +} + +%typemap(mzscheme, out) double * { + $target = scheme_make_double(*$source); +} +/* +%typemap(mzscheme, out) long double * { + $target = scheme_make_double(*$source); +} +*/ + +/* + ------------------------------------------------------------ + Typemaps for accessing a global C variable from MzScheme + ------------------------------------------------------------ + */ + +%typemap(mzscheme, varin) char { + if(!SCHEME_CHARP($source)) + scheme_wrong_type("$name", "character", $argnum, argc, argv); + $target = SCHEME_CHAR_VAL($source); +} + +%typemap(mzscheme, varin) unsigned char { + if(!SCHEME_CHARP($source)) + scheme_wrong_type("$name", "character", $argnum, argc, argv); + $target = SCHEME_CHAR_VAL($source); +} + +%typemap(mzscheme, varin) char * { + if(!SCHEME_STRINGP($source)) + scheme_wrong_type("$name", "string ", $argnum, argc, argv); + $target = SCHEME_STR_VAL($source); +} + +%typemap(mzscheme, varin) char [ANY] { + if(!SCHEME_STRINGP($source)) + scheme_wrong_type("$name", "string ", $argnum, argc, argv); + $target = SCHEME_STR_VAL($source); +} + +%typemap(mzscheme, varin) int { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + $target = SCHEME_INT_VAL($source); +} + +%typemap(mzscheme, varin) long { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + scheme_get_int_val($source, &$target); +} + +%typemap(mzscheme, varin) short { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + $target = SCHEME_INT_VAL($source); +} + +%typemap(mzscheme, varin) unsigned int { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + $target = SCHEME_INT_VAL($source); +} + +%typemap(mzscheme, varin) unsigned long { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + scheme_get_unsigned_int_val($source, &$target); +} + +%typemap(mzscheme, varin) unsigned short { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + $target = SCHEME_INT_VAL($source); +} +/* +%typemap(mzscheme, varin) long long { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + scheme_get_int_val($source, &$target); +} +*/ +%typemap(mzscheme, varin) float { + if(!SCHEME_DBLP($source)) + scheme_wrong_type("$name", "double", $argnum, argc, argv); + $target = SCHEME_DBL_VAL($source); +} + +%typemap(mzscheme, varin) double { + if(SCHEME_DBLP($source)) + $target = SCHEME_DBL_VAL($source); + else if(SCHEME_REALP($source)) + $target = scheme_real_to_double($source); + else scheme_wrong_type("$name", "real", $argnum, argc, argv); +} +/* +%typemap(mzscheme, varin) long double { + if(SCHEME_DBLP($source)) + $target = SCHEME_DBL_VAL($source); + else if(SCHEME_REALP($source)) + $target = scheme_real_to_double($source); + else scheme_wrong_type("$name", "real", $argnum, argc, argv); +} +*/ + +/* + ------------------------------------ + global pointer variable + ------------------------------------ + */ + +%typemap(mzscheme, varin) unsigned char *(unsigned char temp) { + if(!SCHEME_CHARP($source)) + scheme_wrong_type("$name", "character", $argnum, argc, argv); + temp = SCHEME_STR_VAL($source); + $target = &temp; +} + +%typemap(mzscheme, varin) int *(int temp) { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + temp = (int)SCHEME_INT_VAL($source); + $target = &temp; +} + +%typemap(mzscheme, varin) long *(long temp) { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + scheme_get_int_val($source, &temp); + $target = &temp; + +} + +%typemap(mzscheme, varin) short *(short temp) { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + temp = (short)SCHEME_INT_VAL($source); + $target = &temp; +} + +%typemap(mzscheme, varin) unsigned int *(unsigned temp) { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + temp = (unsigned)SCHEME_INT_VAL($source); + $target = &temp; +} + +%typemap(mzscheme, varin) unsigned long *(unsigned long temp) { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + scheme_get_unsigned_int_val($source, &temp); + $target = &temp; +} + +%typemap(mzscheme, varin) unsigned short *(unsigned short temp) { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + temp = (unsigned short)SCHEME_INT_VAL($source); + $target = &temp; + +} +/* +%typemap(mzscheme, varin) long long *(long long temp) { + if(!SCHEME_INTP($source)) + scheme_wrong_type("$name", "integer", $argnum, argc, argv); + scheme_get_int_val($source, &temp); + $target = &temp; +} +*/ +%typemap(mzscheme, varin) float *(float temp) { + if(!SCHEME_DBLP($source)) + scheme_wrong_type("$name", "double", $argnum, argc, argv); + temp = (float)SCHEME_DBL_VAL($source); + $target = &temp; + +} + +%typemap(mzscheme, varin) double *(double temp) { + if(SCHEME_DBLP($source)) { + temp = (double)SCHEME_DBL_VAL($source); + $target = &temp; + } + else if(SCHEME_REALP($source)) { + temp = (double)scheme_real_to_double($source); + $target = &temp; + } + else scheme_wrong_type("$name", "real", $argnum, argc, argv); +} +/* +%typemap(mzscheme, varin) long double *(long double temp) { + if(SCHEME_DBLP($source)) { + temp = (long double)SCHEME_DBL_VAL($source); + $target = &temp; + } + else if(SCHEME_REALP($source)) { + temp = (long double)scheme_real_to_double($source); + $target = &temp; + } + else scheme_wrong_type("$name", "real", $argnum, argc, argv); +} +*/ + + +/* + ----------------------------------- + convert a variable from C to Scheme + ----------------------------------- + */ + +%typemap(mzscheme, varout) char { + $target = scheme_make_character($source); +} + +%typemap(mzscheme, varout) unsigned char { + $target = scheme_make_character($source); +} + +%typemap(mzscheme, varout) char * { + $target = scheme_make_string($source); +} + +%typemap(mzscheme, varout) char [ANY] { + $target = scheme_make_string($source); +} + +%typemap(mzscheme, varout) int { + $target = scheme_make_integer_value($source); +} + +%typemap(mzscheme, varout) long { + $target = scheme_make_integer_value($source); +} + +%typemap(mzscheme, varout) short { + $target = scheme_make_integer_value($source); +} +/* +%typemap(mzscheme, varout) long long { + $target = scheme_make_integer_value($source); +} +*/ +%typemap(mzscheme, varout) unsigned int { + $target = scheme_make_integer_value_from_unsigned($source); +} + +%typemap(mzscheme, varout) unsigned long { + $target = scheme_make_integer_value_from_unsigned($source); +} + +%typemap(mzscheme, varout) unsigned short { + $target = scheme_make_integer_value_from_unsigned($source); +} + +%typemap(mzscheme, varout) float { + $target = scheme_make_double($source); +} + +%typemap(mzscheme, varout) double { + $target = scheme_make_double($source); +} +/* +%typemap(mzscheme, varout) long double { + $target = scheme_make_double($source); +} +*/ + +/* + ----------------------------------- + convert a pointer variable from C to MzScheme + ----------------------------------- + */ + +%typemap(mzscheme, varout) int * { + $target = scheme_make_integer_value(*$source); +} + +%typemap(mzscheme, varout) long * { + $target = scheme_make_integer_value(*$source); +} + +%typemap(mzscheme, varout) short * { + $target = scheme_make_integer_value(*$source); +} + +/* +%typemap(mzscheme, varout) long long * { + $target = scheme_make_integer_value(*$source); +} +*/ +%typemap(mzscheme, varout) unsigned int * { + $target = scheme_make_integer_value_from_unsigned(*$source); +} + +%typemap(mzscheme, varout) unsigned long * { + $target = scheme_make_integer_value_from_unsigned(*$source); +} + +%typemap(mzscheme, varout) unsigned short * { + $target = scheme_make_integer_value_from_unsigned(*$source); +} + +%typemap(mzscheme, varout) float * { + $target = scheme_make_double(*$source); +} + +%typemap(mzscheme, varout) double * { + $target = scheme_make_double(*$source); +} +/* +%typemap(mzscheme, varout) long double * { + $target = scheme_make_double(*$source); +} +*/ diff --git a/SWIG/Source/Modules1.1/mzscheme.cxx b/SWIG/Source/Modules1.1/mzscheme.cxx new file mode 100644 index 000000000..018decddb --- /dev/null +++ b/SWIG/Source/Modules1.1/mzscheme.cxx @@ -0,0 +1,846 @@ +/****************************************************************************** + * Simplified Wrapper and Interface Generator (SWIG) + * + * Author : David Beazley + * + * Department of Computer Science + * University of Chicago + * 1100 E 58th Street + * Chicago, IL 60637 + * beazley@cs.uchicago.edu + * + * Please read the file LICENSE for the copyright and terms by which SWIG + * can be used and distributed. + *****************************************************************************/ + +static char cvsroot[] = "$Header$"; + +/*********************************************************************** + * $Header$ + * + * mzscheme.cxx + * + * Definitions for adding functions to Mzscheme 101 + ***********************************************************************/ + +#include "mod11.h" +#include "mzscheme.h" + +static char *mzscheme_usage = "\ +\n\ +Mzscheme Options (available with -mzscheme)\n\ + -help - Print this help\n\ + -module name - Set base name of module (not implemented) \n\ + -prefix name - Set a prefix to be appended to all name\n\ +\n" +; + + +// --------------------------------------------------------------------- +// MZSCHEME () +// --------------------------------------------------------------------- + +MZSCHEME::MZSCHEME () +{ + prefix = NULL; + module = NULL; + package = ""; + linkage = 0; + mzscheme_path = "mzscheme"; + init_func_def = ""; +} + +// --------------------------------------------------------------------- +// MZSCHEME::parse_args(int argc, char *argv[]) +// +// Parse arguments. +// --------------------------------------------------------------------- + +void +MZSCHEME::parse_args (int argc, char *argv[]) +{ + int i; + + sprintf (LibDir, "%s", mzscheme_path); + + // Look for certain command line options + for (i = 1; i < argc; i++) { + if (argv[i]) { + if (strcmp (argv[i], "-help") == 0) { + fputs (mzscheme_usage, stderr); + SWIG_exit (0); + } + else if (strcmp (argv[i], "-prefix") == 0) { + if (argv[i + 1]) { + prefix = new char[strlen(argv[i + 1]) + 2]; + strcpy(prefix, argv[i + 1]); + Swig_mark_arg (i); + Swig_mark_arg (i + 1); + i++; + } else { + Swig_arg_error(); + } + } + else if (strcmp (argv[i], "-module") == 0) { + if (argv[i + 1]) { + set_module (argv[i + 1], 0); + Swig_mark_arg (i); + Swig_mark_arg (i + 1); + ++i; + } else { + Swig_arg_error(); + } + } + } + } + + // If a prefix has been specified make sure it ends in a '_' + + if (prefix) { + if (prefix[strlen (prefix)] != '_') { + prefix[strlen (prefix) + 1] = 0; + prefix[strlen (prefix)] = '_'; + } + } else + prefix = "swig_"; + + // Add a symbol for this module + + Preprocessor_define ((void *) "SWIGMZSCHEME",0); + + // Set name of typemaps + + typemap_lang = "mzscheme"; +} + +// -------------------------------------------------------------------- +// MZSCHEME::parse() +// +// Parse the input file +// -------------------------------------------------------------------- + +void +MZSCHEME::parse () +{ + printf ("Generating wrappers for Mzscheme\n"); + + // Print out MZSCHEME specific headers + + headers(); + + // Run the parser + + yyparse(); + +} + +// --------------------------------------------------------------------- +// MZSCHEME::set_module(char *mod_name) +// +// Sets the module name. +// Does nothing if it's already set (so it can be overridden as a command +// line option). +// +//---------------------------------------------------------------------- + +void +MZSCHEME::set_module (char *mod_name, char **) +{ + if (module) { + printf ("module already set (%s), returning\n", module); + return; + } + + module = new char [strlen (mod_name) + 1]; + strcpy (module, mod_name); +} + +// --------------------------------------------------------------------- +// MZSCHEME::set_init(char *iname) +// +// Sets the initialization function name. +// Does nothing if it's already set +// +//---------------------------------------------------------------------- + +void +MZSCHEME::set_init (char *iname) +{ + abort (); // for now -ttn + set_module (iname, 0); +} + +// --------------------------------------------------------------------- +// MZSCHEME::headers(void) +// +// Generate the appropriate header files for MZSCHEME interface. +// ---------------------------------------------------------------------- + +void +MZSCHEME::headers (void) +{ + emit_banner (f_header); + + fprintf (f_header, "/* Implementation : MZSCHEME */\n\n"); + fprintf (f_header, "#include \n"); + fprintf (f_header, "#include \n"); + fprintf (f_header, "#include \n"); + + // Write out hex conversion functions + + if (!NoInclude) { + if (Swig_insert_file ("mzscheme.swg", f_header) == -1) { + fprintf (stderr, "SWIG : Fatal error. "); + fprintf (stderr, "Unable to locate 'mzscheme.swg' in SWIG library.\n"); + SWIG_exit (1); + } + // I Removed a call to emit_hex() here. The pointer + // type-checking code should be included into guile.swg instead + } else { + fprintf (f_header, "#ifdef __cplusplus\n"); + fprintf (f_header, "extern \"C\" {\n"); + fprintf (f_header, "#endif\n"); + fprintf (f_header, "extern void SWIG_MakePtr(char *, void *, char *);\n"); + fprintf (f_header, "extern void SWIG_RegisterMapping(char *, char *, void *(*)(void *));\n"); + fprintf (f_header, "extern char *SWIG_GetPtr(char *, void **, char *);\n"); + fprintf (f_header, "#ifdef __cplusplus\n"); + fprintf (f_header, "}\n"); + fprintf (f_header, "#endif\n"); + } +} + +// -------------------------------------------------------------------- +// MZSCHEME::initialize() +// +// Output initialization code that registers functions with the +// interface. +// --------------------------------------------------------------------- + +void +MZSCHEME::initialize (void) +{ + int i; + +#ifdef OLD_STYLE_WILL_GO_AWAY + if (InitNames) { + i = 0; + while (InitNames[i]) { + fprintf(f_init,"\t %s();\n",InitNames[i]); + i++; + } + } +#endif /* OLD_STYLE_WILL_GO_AWAY */ + + fprintf (f_init, "static void\nSWIG_init (void)\n{\n"); +} + +// --------------------------------------------------------------------- +// MZSCHEME::close(void) +// +// Wrap things up. Close initialization function. +// --------------------------------------------------------------------- + +void +MZSCHEME::close (void) +{ + // emit_ptr_equivalence (f_init); + fprintf (f_init, "}\n\n"); + + fprintf(f_init, "Scheme_Object *scheme_reload(Scheme_Env *env) {\n"); + fprintf(f_init, "%s\n", init_func_def.get()); + fprintf (f_init, "\treturn scheme_void;\n}\n"); + fprintf(f_init, "Scheme_Object *scheme_initialize(Scheme_Env *env) {\n"); + fprintf(f_init, "\treturn scheme_reload(env);\n"); + fprintf (f_init, "}\n"); +} + +// ---------------------------------------------------------------------- +// MZSCHEME::get_pointer(int parm, DataType *t) +// +// Emits code to get a pointer from a parameter and do type checking. +// parm is the parameter number. This function is only used +// in create_function(). +// ---------------------------------------------------------------------- + +void +MZSCHEME::get_pointer (char *iname, int parm, DataType *t, + WrapperFunction &f) +{ + // Pointers are read as hex-strings with encoded type information + f.code << tab4 << "_tempc = SCHEME_STR_VAL(argv[" << parm << "]);\n"; +// f.code << tab4 << "_len = SCHEME_STRLEN_VAL(argv[" << parm << "]);\n"; + f.code << tab4 << "if (SWIG_GetPtr (_tempc, (void **) &_arg" << parm; + if (t->type == T_VOID) + f.code << ", (char *) 0)) {\n"; + else + f.code << ", \"" << t->print_mangle() << "\")) {\n"; + + f.code << tab8 << "scheme_signal_error(\"couldn't get pointer\");\n"; + + f.code << tab4 << "}\n"; + // f.code << tab4 << "free(_tempc);\n"; +} + +// ---------------------------------------------------------------------- +// MZSCHEME::create_function(char *name, char *iname, DataType *d, +// ParmList *l) +// +// Create a function declaration and register it with the interpreter. +// ---------------------------------------------------------------------- + +static void +mreplace (String &s, String &argnum, String &arg, String &proc_name) +{ + s.replace ("$argnum", argnum); + s.replace ("$arg", arg); + s.replace ("$name", proc_name); +} + +static void +throw_unhandled_mzscheme_type_error (DataType *d) +{ + fflush (stdout); + fprintf (stderr, "ERROR: Unhandled MZSCHEME type error.\n"); + fprintf (stderr, " type %d\n", d->type); + fprintf (stderr, " name %s\n", d->name); + fprintf (stderr, " is_pointer %d\n", d->is_pointer); + fprintf (stderr, "implicit_ptr %d\n", d->implicit_ptr); + fprintf (stderr, "is_reference %d\n", d->is_reference); + fprintf (stderr, " status %d\n", d->status); + fprintf (stderr, " qualifier %s\n", (d->qualifier ? d->qualifier : "")); + fprintf (stderr, " arraystr %s\n", (d->arraystr ? d->arraystr : "")); + fprintf (stderr, " id %d\n", d->id); + + fprintf (stderr, "\n\nBAILING...\n"); // for now -ttn + abort(); // for now -ttn +} + +void +MZSCHEME::create_function (char *name, char *iname, DataType *d, ParmList *l) +{ + Parm *p; + String proc_name; + String source; + String target; + String argnum; + String arg; + char *tm; + WrapperFunction f; + String cleanup; + int need_len = 0; + int need_tempc = 0; + + String outarg; + int have_build = 0; + String build; + + int argout_set = 0; + + // Make a wrapper name for this + char * wname = name_wrapper (iname, prefix); + + // Build the name for Scheme. + proc_name = ""; + proc_name << iname; + proc_name.replace ("_", "-"); + + // writing the function wrapper function + f.def << "static Scheme_Object *" << wname << " ("; + f.def << "int argc, Scheme_Object **argv"; + f.def << ")\n{"; + + // Declare return variable and arguments + // number of parameters + // they are called _arg0, _arg1, ... + // the return value is called _result + + int pcount = emit_args (d, l, f); + int numargs = 0; + int numopt = 0; + + // adds local variables : type name + f.add_local ("int", "_len"); + f.add_local ("char *", "_tempc"); + f.add_local ("Scheme_Object *", "swig_result"); + + // Now write code to extract the parameters (this is super ugly) + + int i = 0; + for (i = 0; i < pcount; ++i) { + Parm &p = (*l)[i]; + + // Produce names of source and target + source = ""; + target = ""; + argnum = ""; + arg = ""; + + source << "argv[" << i << "]"; + target << "_arg" << i; + argnum << i; + arg << p.name; + + // Handle parameter types. + + if (p.ignore) + f.code << "/* " << p.name << " ignored... */\n"; + else { + ++numargs; + if ((tm = typemap_lookup ("in", typemap_lang, + p.t, p.name, source, target, &f))) { + f.code << tm << "\n"; + mreplace (f.code, argnum, arg, proc_name); + } + // no typemap found + // assume it's a pointer string and try to put it's pointer value + // in _tempc + else if (p.t->is_pointer) { + get_pointer (iname, i, p.t, f); + } + // no typemap found and not a pointer + else throw_unhandled_mzscheme_type_error (p.t); + } + + // Check if there are any constraints. + + if ((tm = typemap_lookup ("check", typemap_lang, + p.t, p.name, source, target, &f))) { + // Yep. Use it instead of the default + f.code << tm << "\n"; + mreplace (f.code, argnum, arg, proc_name); + } + + // Pass output arguments back to the caller. + + if ((tm = typemap_lookup ("argout", typemap_lang, + p.t, p.name, source, target, &f))) { + // Yep. Use it instead of the default + outarg << tm << "\n"; + mreplace (outarg, argnum, arg, proc_name); + argout_set = 1; + } + + // Free up any memory allocated for the arguments. + if ((tm = typemap_lookup ("freearg", typemap_lang, + p.t, p.name, source, target, &f))) { + // Yep. Use it instead of the default + cleanup << tm << "\n"; + mreplace (cleanup, argnum, arg, proc_name); + } + } + + // Now write code to make the function call + + emit_func_call (name, d, l, f); + + // Now have return value, figure out what to do with it. + + if (d->type == T_VOID) + f.code << tab4 << "swig_result = scheme_void;\n"; + else if ((tm = typemap_lookup ("out", typemap_lang, + d, name, "_result", "swig_result", &f))) { + f.code << tm << "\n"; + mreplace (f.code, argnum, arg, proc_name); + } + // no typemap found and not void then put a pointer string in _ptemp + // convert it to a Scheme string and return it. + else if (d->is_pointer) { + f.add_local ("char", "_ptemp[128]"); + f.code << tab4 + << "SWIG_MakePtr (_ptemp, _result,\"" + << d->print_mangle() + << "\");\n"; + f.code << tab4 + << "swig_result = scheme_make_string(_ptemp);\n"; + } + else { + throw_unhandled_mzscheme_type_error (d); + } + + // Dump the argument output code + f.code << outarg; + + // Dump the argument cleanup code + f.code << cleanup; + + // Look for any remaining cleanup + + if (NewObject) { + if ((tm = typemap_lookup ("newfree", typemap_lang, + d, iname, "_result", "", &f))) { + f.code << tm << "\n"; + mreplace (f.code, argnum, arg, proc_name); + } + } + + // Free any memory allocated by the function being wrapped.. + + if ((tm = typemap_lookup ("ret", typemap_lang, + d, name, "_result", "", &f))) { + // Yep. Use it instead of the default + f.code << tm << "\n"; + mreplace (f.code, argnum, arg, proc_name); + } + + // returning multiple values + if(argout_set) { + if(d->type == T_VOID) { + f.add_local("int", "_lenv", "0"); + f.add_local("Scheme_Object", "*_values[MAXVALUES]"); + f.code << tab4 << "swig_result = scheme_values(_lenv, _values);"; + } + else { + f.add_local("int", "_lenv", "1"); + f.add_local("Scheme_Object", "*_values[MAXVALUES]"); + f.code << tab4 << "_values[0] = swig_result;\n"; + f.code << tab4 << "swig_result = scheme_values(_lenv, _values);\n"; + } + } + + // Wrap things up (in a manner of speaking) + + f.code << tab4 << "return swig_result;\n"; + f.code << "}\n"; + + f.print (f_wrappers); + + // Now register the function + init_func_def << "scheme_add_global(\"" << proc_name.get() << \ + "\", scheme_make_prim_w_arity(" << wname << \ + ", \"" << proc_name.get() << "\", " << numargs << ", " << numargs << \ + "), env);\n"; +} + +// ----------------------------------------------------------------------- +// MZSCHEME::link_variable(char *name, char *iname, DataType *d) +// +// Create a link to a C variable. +// This creates a single function _wrap_swig_var_varname(). +// This function takes a single optional argument. If supplied, it means +// we are setting this variable to some value. If omitted, it means we are +// simply evaluating this variable. Either way, we return the variables +// value. +// ----------------------------------------------------------------------- + +void +MZSCHEME::link_variable (char *name, char *iname, DataType *t) +{ + String proc_name; + char var_name[256]; + char *tm; + String tm2; + String argnum = "0"; + String arg = "argv[0]"; + + // evaluation function names + + sprintf (var_name, "_wrap_%svar_%s", prefix, iname); + + // Build the name for scheme. + proc_name = ""; + proc_name << iname; + proc_name.replace ("_", "-"); + + if ((t->type != T_USER) || (t->is_pointer)) { + + fprintf (f_wrappers, "static Scheme_Object *%s(int argc, Scheme_Object** argv) {\n", var_name); + + if ((t->type == T_CHAR) || (t->is_pointer)){ + fprintf (f_wrappers, "\t char *_temp, _ptemp[128];\n"); + fprintf (f_wrappers, "\t int _len;\n"); + } + fprintf (f_wrappers, "\t Scheme_Object *swig_result;\n"); + + // Check for a setting of the variable value + + fprintf (f_wrappers, "\t if (argc) {\n"); + + // Yup. Extract the type from argv[0] and set variable value + +// if (Status & STAT_READONLY) { +// fprintf (f_wrappers, "\t\t GSWIG_ASSERT(0,\"Unable to set %s. " +// "Variable is read only.\", argv[0]);\n", iname); +// } + if (Status & STAT_READONLY) { + fprintf (f_wrappers, "\t\t scheme_signal_error(\"Unable to set %s. " + "Variable is read only.\");\n", iname); + } + else if ((tm = typemap_lookup ("varin", typemap_lang, + t, name, "argv[0]", name))) { + tm2 = tm; + mreplace(tm2, argnum, arg, proc_name); + fprintf (f_wrappers, "%s\n", tm2.get()); + } + else if (t->is_pointer) { + if ((t->type == T_CHAR) && (t->is_pointer == 1)) { + fprintf (f_wrappers, "\t\t _temp = SCHEME_STR_VAL(argv[0]);\n"); + fprintf (f_wrappers, "\t\t _len = SCHEME_STRLEN_VAL(argv[0]);\n"); + fprintf (f_wrappers, "\t\t if (%s) { free(%s);}\n", name, name); + fprintf (f_wrappers, "\t\t %s = (char *) " + "malloc((_len+1)*sizeof(char));\n", name); + fprintf (f_wrappers, "\t\t strncpy(%s,_temp,_len);\n", name); + fprintf (f_wrappers, "\t\t %s[_len] = 0;\n", name); + } else { + // Set the value of a pointer + fprintf (f_wrappers, "\t\t _temp = SCHEME_STR_VAL(argv[0]);\n"); +// fprintf (f_wrappers, "\t\t _len = SCHEME_STRLEN_VAL(argv[0]);\n"); + fprintf (f_wrappers, "\t\t if (SWIG_GetPtr(_temp, (void **) &%s,", + name); + if (t->type == T_VOID) + fprintf (f_wrappers, "(char *) 0)) {\n"); + else + fprintf (f_wrappers, "\"%s\")) {\n", t->print_mangle()); + + fprintf(f_wrappers, "\t\t\t scheme_signal_error(\"couldn't get pointer\");\n"); + fprintf (f_wrappers, "\t\t}\n"); + } + } + else { + throw_unhandled_mzscheme_type_error (t); + } + fprintf (f_wrappers, "\t}\n"); + + // Now return the value of the variable (regardless + // of evaluating or setting) + + if ((tm = typemap_lookup ("varout", typemap_lang, + t, name, name, "swig_result"))) { + fprintf (f_wrappers, "%s\n", tm); + } + else if (t->is_pointer) { + if ((t->type == T_CHAR) && (t->is_pointer == 1)) { + fprintf (f_wrappers, "\t swig_result = scheme_make_string(%s);\n", name); + } else { + // Is an ordinary pointer type. + fprintf (f_wrappers, "\t SWIG_MakePtr(_ptemp, %s,\"%s\");\n", + name, t->print_mangle()); + fprintf (f_wrappers, "\t swig_result = scheme_make_string(_ptemp);\n"); + } + } + else { + throw_unhandled_mzscheme_type_error (t); + } + fprintf (f_wrappers, "\t return swig_result;\n"); + fprintf (f_wrappers, "}\n"); + + // Now add symbol to the MzScheme interpreter + + init_func_def << "scheme_add_global(\"" << proc_name.get() << \ + "\", scheme_make_prim_w_arity(" << var_name << \ + ", \"" << proc_name.get() << "\", " << 0 << ", " << 1 << "), env);\n"; + + } else { + fprintf (stderr, "%s : Line %d. ** Warning. Unable to link with " + " type %s (ignored).\n", + input_file, line_number, t->print_type()); + } +} + +// ----------------------------------------------------------------------- +// MZSCHEME::declare_const(char *name, char *iname, DataType *type, char *value) +// +// Makes a constant. Not sure how this is really supposed to work. +// I'm going to fake out SWIG and create a variable instead. +// ------------------------------------------------------------------------ + +void +MZSCHEME::declare_const (char *name, char *, DataType *type, char *value) +{ + int OldStatus = Status; // Save old status flags + String proc_name; + char var_name[256]; + String rvalue; + char *tm; + + Status = STAT_READONLY; // Enable readonly mode. + + // Make a static variable; + + sprintf (var_name, "_wrap_const_%s", name); + + // Build the name for scheme. + proc_name = ""; + proc_name = name; + proc_name.replace ("_", "-"); + + if ((type->type == T_USER) && (!type->is_pointer)) { + fprintf (stderr, "%s : Line %d. Unsupported constant value.\n", + input_file, line_number); + return; + } + + // See if there's a typemap + + rvalue = value; + if ((type->type == T_CHAR) && (type->is_pointer == 1)) { + rvalue << "\""; + "\"" >> rvalue; + } + if ((type->type == T_CHAR) && (type->is_pointer == 0)) { + rvalue << "'"; + "'" >> rvalue; + } + if ((tm = typemap_lookup ("const", typemap_lang, type, name, + rvalue.get(), name))) { + // Yep. Use it instead of the default + fprintf (f_init, "%s\n", tm); + } else { + // Create variable and assign it a value + + fprintf (f_header, "static %s %s = ", type->print_type(), var_name); + if ((type->type == T_CHAR) && (type->is_pointer <= 1)) { + fprintf (f_header, "\"%s\";\n", value); + } else { + fprintf (f_header, "%s;\n", value); + } + + // Now create a variable declaration + + link_variable (var_name, name, type); + Status = OldStatus; + } +} + +// ---------------------------------------------------------------------- +// MZSCHEME::usage_var(char *iname, DataType *t, String &usage) +// +// Produces a usage string for a Guile variable. +// ---------------------------------------------------------------------- + +void +MZSCHEME::usage_var (char *iname, DataType *t, String &usage) +{ + char temp[1024], *c; + + usage << "(" << iname << " [value])"; + if (!((t->type != T_USER) || (t->is_pointer))) { + usage << " - unsupported"; + } +} + +// --------------------------------------------------------------------------- +// MZSCHEME::usage_func(char *iname, DataType *t, ParmList *l, String &usage) +// +// Produces a usage string for a function in Guile +// --------------------------------------------------------------------------- + +void +MZSCHEME::usage_func (char *iname, DataType *d, ParmList *l, String &usage) +{ + char temp[1024]; + char *c; + int i; + Parm *p; + + // Print the function name. + + usage << "(" << iname; + + // Now go through and print parameters + + for (p = l->get_first(); p != 0; p = l->get_next()) { + + if (p->ignore) + continue; + + // Print the type. If the parameter has been named, use that as well. + + if ((p->t->type != T_VOID) || (p->t->is_pointer)) { + + // Print the type. + usage << " <" << p->t->name; + if (p->t->is_pointer) { + for (int j = 0; j < (p->t->is_pointer - p->t->implicit_ptr); j++) { + usage << "*"; + } + } + usage << ">"; + + // Print the name if it exists. + if (strlen (p->name) > 0) { + usage << " " << p->name; + } + } + } + usage << ")"; +} + + +// --------------------------------------------------------------------------- +// MZSCHEME::usage_returns(char *iname, DataType *t, ParmList *l, String &usage) +// +// Produces a usage string for a function in Guile +// --------------------------------------------------------------------------- + +void +MZSCHEME::usage_returns (char *iname, DataType *d, ParmList *l, String &usage) +{ + Parm *p; + String param; + int have_param = 0, j; + + usage = "returns "; + param = ""; + + // go through and see if any are output. + + for (p = l->get_first(); p != 0; p = l->get_next()) { + + if (strcmp (p->name,"BOTH") && strcmp (p->name,"OUTPUT")) + continue; + + // Print the type. If the parameter has been named, use that as well. + + if ((p->t->type != T_VOID) || (p->t->is_pointer)) { + ++have_param; + + // Print the type. + param << " $" << p->t->name; + if (p->t->is_pointer) { + for (j = 0; j < (p->t->is_pointer - p->t->implicit_ptr - 1); j++) { + param << "*"; + } + } + param << "# "; + } + } + + // See if we stick on the function return type. + if (d->type != T_VOID || have_param == 0) { + ++have_param; + if (d->type == T_VOID) + " unspecified " >> param; + else { + "# " >> param; + d->print_type() >> param; + " $" >> param; + } + } + + // Kill extra white space. + param.strip(); + param.replace ("$", "<"); + param.replace ("#", ">"); + param.replace ("><", "> <"); + + // If there are multiple return values put them in a list. + if (have_param > 1) { + "(" >> param; + param << ")"; + } + + usage << param; +} + + +// ---------------------------------------------------------------------- +// MZSCHEME::usage_const(char *iname, DataType *type, char *value, String &usage) +// +// Produces a usage string for a Guile constant +// ---------------------------------------------------------------------- + +void +MZSCHEME::usage_const (char *iname, DataType *, char *value, String &usage) +{ + usage << "(" << iname << " " << value << ")"; +} diff --git a/SWIG/Source/Modules1.1/mzscheme.h b/SWIG/Source/Modules1.1/mzscheme.h new file mode 100644 index 000000000..186fac69b --- /dev/null +++ b/SWIG/Source/Modules1.1/mzscheme.h @@ -0,0 +1,55 @@ +/******************************************************************************* + * Simplified Wrapper and Interface Generator (SWIG) + * + * Author : David Beazley + * + * Department of Computer Science + * University of Chicago + * 1100 E 58th Street + * Chicago, IL 60637 + * beazley@cs.uchicago.edu + * + * Please read the file LICENSE for the copyright and terms by which SWIG + * can be used and distributed. + *******************************************************************************/ + +/************************************************************************** + * $Header$ + * + * class MZSCHEME + * + * Mzscheme implementation + * (Caution : This is *somewhat* experimental) + * + **************************************************************************/ + +class MZSCHEME : public Language +{ +private: + char *mzscheme_path; + char *prefix; + char *module; + char *package; + int linkage; + void get_pointer(char *iname, int parm, DataType *t, WrapperFunction &f); + void usage_var(char *, DataType *, String &usage); + void usage_func(char *, DataType *, ParmList *, String &usage); + void usage_returns(char *, DataType *, ParmList *, String &usage); + void usage_const(char *, DataType *, char *, String &usage); + + String init_func_def; + +public : + MZSCHEME (); + void parse_args (int, char *argv[]); + void parse (); + void create_function (char *, char *, DataType *, ParmList *); + void link_variable (char *, char *, DataType *); + void declare_const (char *, char *, DataType *, char *); + void initialize (); + void headers (void); + void close (void); + void set_module (char *, char **); + void set_init (char *); + void create_command (char *, char *) { }; +};