/*******************************************************************************
* Simplified Wrapper and Interface Generator (SWIG)
*
* Dave Beazley
*
* Department of Computer Science Theoretical Division (T-11)
* University of Utah Los Alamos National Laboratory
* Salt Lake City, Utah 84112 Los Alamos, New Mexico 87545
* beazley@cs.utah.edu beazley@lanl.gov
*
* Copyright (c) 1995-1997
* The University of Utah and the Regents of the University of California
* All Rights Reserved
*
* Permission is hereby granted, without written agreement and without
* license or royalty fees, to use, copy, modify, and distribute this
* software and its documentation for any purpose, provided that
* (1) The above copyright notice and the following two paragraphs
* appear in all copies of the source code and (2) redistributions
* including binaries reproduces these notices in the supporting
* documentation. Substantial modifications to this software may be
* copyrighted by their authors and need not follow the licensing terms
* described here, provided that the new terms are clearly indicated in
* all files where they apply.
*
* IN NO EVENT SHALL THE AUTHOR, THE UNIVERSITY OF CALIFORNIA, THE
* UNIVERSITY OF UTAH OR DISTRIBUTORS OF THIS SOFTWARE BE LIABLE TO ANY
* PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL
* DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION,
* EVEN IF THE AUTHORS OR ANY OF THE ABOVE PARTIES HAVE BEEN ADVISED OF
* THE POSSIBILITY OF SUCH DAMAGE.
*
* THE AUTHOR, THE UNIVERSITY OF CALIFORNIA, AND THE UNIVERSITY OF UTAH
* SPECIFICALLY DISCLAIM ANY WARRANTIES,INCLUDING, BUT NOT LIMITED TO,
* THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND
* THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE,
* SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
*
*******************************************************************************/
/***********************************************************************
* $Header: /home/beazley/SWIG/SWIG1.2/Modules/RCS/perl5.cxx,v 1.66 1997/07/10 03:05:24 beazley Exp $
*
* perl5.c
*
* Definitions for adding functions to Perl 5
*
* How to extend perl5 (note : this is totally different in Perl 4) :
*
* 1. Variable linkage
*
* Must declare two functions :
*
* _var_set(SV *sv, MAGIC *mg);
* _var_get(SV *sv, MAGIC *mg);
*
* These functions must set/get the values of a variable using
* Perl5 internals.
*
* To add these to Perl5 (which isn't entirely clear), need to
* do the following :
*
* SV *sv;
* MAGIC *m;
* sv = perl_get_sv("varname",TRUE);
* sv_magic(sv,sv, 'U', "varname", strlen("varname));
* m = mg_find(sv, 'U');
* m->mg_virtual = (MGVTBL *) malloc(sizeof(MGVTBL));
* m->mg_virtual.svt_get = _var_set;
* m->mg_virtual.svt_set = _var_get;
* m->mg_virtual.svt_len = 0;
* m->mg_virtual.svt_free = 0;
* m->mg_virtual.svt_clear = 0;
*
*
* 2. Function extension
*
* Functions are declared as :
* XS(_wrap_func) {
* dXSARGS;
* if (items != parmcount) {
* croak("Usage :");
* }
* ... get arguments ...
*
* ... call function ...
* ... set return value in ST(0)
* XSRETURN(1);
* }
* To extract function arguments, use the following :
* _arg = (int) SvIV(ST(0))
* _arg = (double) SvNV(ST(0))
* _arg = (char *) SvPV(ST(0),na);
*
* For return values, use :
* ST(0) = sv_newmortal();
* sv_setiv(ST(0), (IV) RETVAL); // Integers
* sv_setnv(ST(0), (double) RETVAL); // Doubles
* sv_setpv((SV*) ST(0), RETVAL); // Strings
*
* New functions are added using
* newXS("name", _wrap_func, file)
*
*
* 3. Compilation.
*
* Code should be compiled into an object file for dynamic
* loading into Perl.
***********************************************************************/
#include "swig.h"
#include "perl5.h"
static String pragma_include;
static char *usage = "\
Perl5 Options (available with -perl5)\n\
-module name - Set module name\n\
-package name - Set package prefix\n\
-static - Omit code related to dynamic loading.\n\
-shadow - Create shadow classes.\n\
-alt-header file- Use an alternate header.\n\n";
static char *import_file = 0;
static char *smodule = 0;
// ---------------------------------------------------------------------
// PERL5::parse_args(int argc, char *argv[])
//
// Parse command line options.
// ---------------------------------------------------------------------
void
PERL5::parse_args(int argc, char *argv[]) {
int i = 1;
export_all = 0;
sprintf(LibDir,"%s",perl_path);
// Look for certain command line options
// Get options
for (i = 1; i < argc; i++) {
if (argv[i]) {
if(strcmp(argv[i],"-package") == 0) {
if (argv[i+1]) {
package = new char[strlen(argv[i+1])+1];
strcpy(package, argv[i+1]);
mark_arg(i);
mark_arg(i+1);
i++;
} else {
arg_error();
}
} else if (strcmp(argv[i],"-module") == 0) {
if (argv[i+1]) {
module = new char[strlen(argv[i+1])+1];
strcpy(module, argv[i+1]);
mark_arg(i);
mark_arg(i+1);
i++;
} else {
arg_error();
}
} else if (strcmp(argv[i],"-exportall") == 0) {
export_all = 1;
mark_arg(i);
} else if (strcmp(argv[i],"-static") == 0) {
is_static = 1;
mark_arg(i);
} else if (strcmp(argv[i],"-shadow") == 0) {
blessed = 1;
mark_arg(i);
} else if (strcmp(argv[i],"-alt-header") == 0) {
if (argv[i+1]) {
alt_header = copy_string(argv[i+1]);
mark_arg(i);
mark_arg(i+1);
i++;
} else {
arg_error();
}
} else if (strcmp(argv[i],"-help") == 0) {
fputs(usage,stderr);
}
}
}
// Add a symbol for this module
add_symbol("SWIGPERL",0,0);
add_symbol("SWIGPERL5",0,0);
// Set name of typemaps
typemap_lang = "perl5";
}
// ------------------------------------------------------------------
// PERL5::parse()
//
// Parse an interface file
// ------------------------------------------------------------------
void
PERL5::parse() {
printf("Generating wrappers for Perl 5\n");
// Print out PERL5 specific headers
headers();
// Run the parser
yyparse();
fputs(vinit.get(),f_wrappers);
}
// ---------------------------------------------------------------------
// PERL5::set_module(char *mod_name, char **mod_list)
//
// Sets the module name.
// Does nothing if it's already set (so it can be overridden as a command
// line option).
//
//----------------------------------------------------------------------
static String modinit, modextern;
void PERL5::set_module(char *mod_name, char **mod_list) {
int i;
if (import_file) {
if (!(strcmp(import_file,input_file+strlen(input_file)-strlen(import_file)))) {
if (blessed) {
fprintf(f_pm,"require %s;\n", mod_name);
}
delete [] import_file;
import_file = 0;
}
}
if (module) return;
module = new char[strlen(mod_name)+1];
strcpy(module,mod_name);
// if there was a mod_list specified, make this big hack
if (mod_list) {
modinit << "#define SWIGMODINIT ";
modextern << "#ifdef __cplusplus\n"
<< "extern \"C\" {\n"
<< "#endif\n";
i = 0;
while(mod_list[i]) {
modinit << "newXS(\"" << mod_list[i] << "::boot_" << mod_list[i] << "\", boot_" << mod_list[i] << ", file);\\\n";
modextern << "extern void boot_" << mod_list[i] << "(CV *);\n";
i++;
}
modextern << "#ifdef __cplusplus\n"
<< "}\n"
<< "#endif\n";
modinit << "/* End of extern module initialization */\n";
}
}
// ---------------------------------------------------------------------
// PERL5::set_init(char *iname)
//
// Sets the initialization function name.
// Does nothing if it's already set
//
//----------------------------------------------------------------------
void PERL5::set_init(char *iname) {
set_module(iname,0);
}
// ---------------------------------------------------------------------
// PERL5::headers(void)
//
// Generate the appropriate header files for PERL5 interface.
// ----------------------------------------------------------------------
void PERL5::headers(void)
{
emit_banner(f_header);
if (!alt_header) {
fprintf(f_header,"/* Implementation : PERL 5 */\n\n");
fprintf(f_header,"#define SWIGPERL\n");
fprintf(f_header,"#define SWIGPERL5\n");
fprintf(f_header,"#ifdef __cplusplus\n");
fprintf(f_header,"#include <math.h>\n");
fprintf(f_header,"#include <stdlib.h>\n");
fprintf(f_header,"extern \"C\" {\n");
fprintf(f_header,"#endif\n");
fprintf(f_header,"#include \"EXTERN.h\"\n");
fprintf(f_header,"#include \"perl.h\"\n");
fprintf(f_header,"#include \"XSUB.h\"\n");
// Get rid of free and malloc defined by perl
fprintf(f_header,"#undef free\n");
fprintf(f_header,"#undef malloc\n");
fprintf(f_header,"#include <string.h>\n");
// fprintf(f_header,"#include <stdlib.h>\n");
fprintf(f_header,"#ifdef __cplusplus\n");
fprintf(f_header,"}\n");
fprintf(f_header,"#endif\n");
} else {
if (insert_file(alt_header, f_header) == -1) {
fprintf(stderr,"SWIG : Fatal error. Unable to locate %s.\n",alt_header);
SWIG_exit(1);
}
}
// Get special SWIG related declarations
if (insert_file("perl5.swg", f_header) == -1) {
fprintf(stderr,"SWIG : Fatal error. Unable to locate 'perl5.swg' in SWIG library.\n");
SWIG_exit(1);
}
// Get code for pointer conversion
if (!NoInclude) {
if (insert_file("perl5ptr.swg", f_header) == -1) {
fprintf(stderr,"SWIG : Fatal error. Unable to locate 'perl5ptr.swg' in SWIG library.\n");
SWIG_exit(1);
}
} 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,"#ifndef PERL_OBJECT\n");
fprintf(f_header,"extern void SWIG_RegisterMapping(char *, char *, void *(*)(void *));\n");
fprintf(f_header,"#else\n");
fprintf(f_header,"#define SWIG_RegisterMapping(a,b,c) _SWIG_RegisterMapping(pPerl,a,b,c);\n");
fprintf(f_header,"extern void _SWIG_RegisterMapping(CPerl *,char *, char *, void *(*)(void *),int);\n");
fprintf(f_header,"#endif\n");
fprintf(f_header,"#ifndef PERL_OBJECT\n");
fprintf(f_header,"extern char *SWIG_GetPtr(SV *, void **, char *);\n");
fprintf(f_header,"#else\n");
fprintf(f_header,"extern char *_SWIG_GetPtr(CPerl *, SV *, void **, char *);\n");
fprintf(f_header,"#define SWIG_GetPtr(a,b,c) _SWIG_GetPtr(pPerl,a,b,c)\n");
fprintf(f_header,"#endif\n");
fprintf(f_header,"#ifdef __cplusplus\n");
fprintf(f_header,"}\n");
fprintf(f_header,"#endif\n");
}
// Create a subroutine for creating magic variables.
// Get special SWIG related declarations
if (insert_file("perl5mg.swg", f_header) == -1) {
fprintf(stderr,"SWIG : Fatal error. Unable to locate 'perl5mg.swg' in SWIG library.\n");
SWIG_exit(1);
}
}
// --------------------------------------------------------------------
// PERL5::initialize()
//
// Output initialization code that registers functions with the
// interface.
// ---------------------------------------------------------------------
void PERL5::initialize()
{
char filen[256];
if (!module){
module = "swig";
fprintf(stderr,"SWIG : *** Warning. No module name specified.\n");
}
if (!package) {
package = new char[strlen(module)+1];
strcpy(package,module);
}
// If we're in blessed mode, change the package name to "packagec"
if (blessed) {
char *newpackage = new char[strlen(package)+2];
sprintf(newpackage,"%sc",package);
realpackage = package;
package = newpackage;
} else {
realpackage = package;
}
/* Create a .pm file */
sprintf(filen,"%s%s.pm", output_dir,module);
if ((f_pm = fopen(filen,"w")) == 0) {
fprintf(stderr,"Unable to open %s\n", filen);
SWIG_exit(0);
}
if (!blessed) {
smodule = module;
} else if (is_static) {
smodule = new char[strlen(module)+2];
strcpy(smodule,module);
strcat(smodule,"c");
} else {
smodule = module;
}
fprintf(f_header,"#define SWIG_init boot_%s\n\n", smodule);
fprintf(f_header,"#define SWIG_name \"%s::boot_%s\"\n", package, smodule);
fprintf(f_header,"#define SWIG_varinit \"%s::var_%s_init();\"\n", package, smodule);
fprintf(f_header,"#ifdef __cplusplus\n");
fprintf(f_header,"extern \"C\"\n");
fprintf(f_header,"#endif\n");
fprintf(f_header,"#ifndef PERL_OBJECT\n");
fprintf(f_header,"SWIGEXPORT(void,boot_%s)(CV* cv);\n", smodule);
fprintf(f_header,"#else\n");
fprintf(f_header,"SWIGEXPORT(void,boot_%s)(CPerl *, CV *cv);\n",smodule);
fprintf(f_header,"#endif\n");
fprintf(f_init,"#ifdef __cplusplus\n");
fprintf(f_init,"extern \"C\"\n");
fprintf(f_init,"#endif\n");
fprintf(f_init,"XS(boot_%s) {\n", smodule);
fprintf(f_init,"\t dXSARGS;\n");
fprintf(f_init,"\t char *file = __FILE__;\n");
fprintf(f_init,"\t cv = cv; items = items;\n");
fprintf(f_init,"\t newXS(\"%s::var_%s_init\", _wrap_perl5_%s_var_init, file);\n",package,smodule, smodule);
vinit << "XS(_wrap_perl5_" << smodule << "_var_init) {\n"
<< tab4 << "dXSARGS;\n"
<< tab4 << "SV *sv;\n"
<< tab4 << "cv = cv; items = items;\n";
fprintf(f_pm,"# This file was automatically generated by SWIG\n");
fprintf(f_pm,"package %s;\n",module);
fprintf(f_pm,"require Exporter;\n");
if (!is_static) {
fprintf(f_pm,"require DynaLoader;\n");
fprintf(f_pm,"@ISA = qw(Exporter DynaLoader);\n");
} else {
fprintf(f_pm,"@ISA = qw(Exporter);\n");
}
// Start creating magic code
magic << "#ifdef PERL_OBJECT\n"
<< "#define MAGIC_CLASS _wrap_" << module << "_var::\n"
<< "class _wrap_" << module << "_var : public CPerl {\n"
<< "public:\n"
<< "#else\n"
<< "#define MAGIC_CLASS\n"
<< "#endif\n"
<< "SWIGCLASS_STATIC int swig_magic_readonly(SV *sv, MAGIC *mg) {\n"
<< tab4 << "MAGIC_PPERL\n"
<< tab4 << "sv = sv; mg = mg;\n"
<< tab4 << "croak(\"Value is read-only.\");\n"
<< tab4 << "return 0;\n"
<< "}\n"; // Dump out external module declarations
/* Process additional initialization files here */
if (strlen(modinit.get()) > 0) {
fprintf(f_header,"%s\n",modinit.get());
}
if (strlen(modextern.get()) > 0) {
fprintf(f_header,"%s\n",modextern.get());
}
}
// ---------------------------------------------------------------------
// PERL5::import(char *filename)
//
// Import directive
// ---------------------------------------------------------------------
void PERL5::import(char *filename) {
if (import_file) delete [] import_file;
import_file = copy_string(filename);
}
// ---------------------------------------------------------------------
// PERL5::close(void)
//
// Wrap things up. Close initialization function.
// ---------------------------------------------------------------------
void PERL5::close(void)
{
String base;
// Dump out variable wrappers
magic << "\n\n#ifdef PERL_OBJECT\n"
<< "};\n"
<< "#endif\n";
fprintf(f_header,"%s\n", magic.get());
emit_ptr_equivalence(f_init);
fprintf(f_init,"\t ST(0) = &sv_yes;\n");
fprintf(f_init,"\t XSRETURN(1);\n");
fprintf(f_init,"}\n");
vinit << tab4 << "XSRETURN(1);\n"
<< "}\n";
fprintf(f_pm,"package %s;\n", package);
if (!is_static) {
fprintf(f_pm,"bootstrap %s;\n", smodule);
} else {
fprintf(f_pm,"boot_%s();\n", smodule);
}
fprintf(f_pm,"var_%s_init();\n", smodule);
fprintf(f_pm,"@EXPORT = qw(%s );\n",exported.get());
fprintf(f_pm,"%s",pragma_include.get());
if (blessed) {
base << "\n# ---------- BASE METHODS -------------\n\n"
<< "package " << realpackage << ";\n\n";
// Write out the TIE method
base << "sub TIEHASH {\n"
<< tab4 << "my ($classname,$obj) = @_;\n"
<< tab4 << "return bless $obj, $classname;\n"
<< "}\n\n";
// Output a CLEAR method. This is just a place-holder, but by providing it we
// can make declarations such as
// %$u = ( x => 2, y=>3, z =>4 );
//
// Where x,y,z are the members of some C/C++ object.
base << "sub CLEAR { }\n\n";
// Output a 'this' method
base << "sub this {\n"
<< tab4 << "my $ptr = shift;\n"
<< tab4 << "return tied(%$ptr);\n"
<< "}\n\n";
fprintf(f_pm,"%s",base.get());
// Emit function stubs for stand-alone functions
fprintf(f_pm,"\n# ------- FUNCTION WRAPPERS --------\n\n");
fprintf(f_pm,"package %s;\n\n",realpackage);
fprintf(f_pm,"%s",func_stubs.get());
// Emit package code for different classes
fprintf(f_pm,"%s",pm.get());
// Emit variable stubs
fprintf(f_pm,"\n# ------- VARIABLE STUBS --------\n\n");
fprintf(f_pm,"package %s;\n\n",realpackage);
fprintf(f_pm,"%s",var_stubs.get());
}
fprintf(f_pm,"1;\n");
fclose(f_pm);
// Patch up documentation title
if ((doc_entry) && (module)) {
doc_entry->cinfo << "Module : " << module << ", "
<< "Package : " << realpackage;
}
}
// ----------------------------------------------------------------------
// char *PERL5::type_mangle(DataType *t)
//
// Mangles a datatype into a Perl5 name compatible with xsubpp type
// T_PTROBJ.
// ----------------------------------------------------------------------
char *
PERL5::type_mangle(DataType *t) {
static char result[128];
int i;
char *r, *c;
if (blessed) {
// Check to see if we've blessed this datatype
if ((classes.lookup(t->name)) && (t->is_pointer <= 1)) {
// This is a blessed class. Return just the type-name
strcpy(result,(char *) classes.lookup(t->name));
return result;
}
}
r = result;
c = t->name;
for ( c = t->name; *c; c++,r++) {
*r = *c;
}
for (i = 0; i < (t->is_pointer-t->implicit_ptr); i++, r++) {
strcpy(r,"Ptr");
r+=2;
}
*r = 0;
return result;
}
// ----------------------------------------------------------------------
// PERL5::get_pointer(char *iname, char *srcname, char *src, char *target,
// DataType *t, String &f, char *ret)
//
// Emits code to get a pointer from a parameter and do type checking.
// ----------------------------------------------------------------------
void PERL5::get_pointer(char *iname, char *srcname, char *src, char *dest,
DataType *t, String &f, char *ret) {
// Now get the pointer value from the string and save in dest
f << tab4 << "if (SWIG_GetPtr(" << src << ",(void **) &" << dest << ",";
// If we're passing a void pointer, we give the pointer conversion a NULL
// pointer, otherwise pass in the expected type.
if (t->type == T_VOID) f << "(char *) 0 )) {\n";
else
f << "\"" << t->print_mangle() << "\")) {\n";
// This part handles the type checking according to three different
// levels. 0 = no checking, 1 = warning message, 2 = strict.
switch(TypeStrict) {
case 0: // No type checking
f << tab4 << "}\n";
break;
case 1: // Warning message only
// Change this part to how you want to handle a type-mismatch warning.
// By default, it will just print to stderr.
f << tab8 << "fprintf(stderr,\"Warning : type mismatch in " << srcname
<< " of " << iname << ". Expected " << t->print_mangle()
<< ", received %s\\n\"," << src << ");\n"
<< tab4 << "}\n";
break;
case 2: // Super strict mode.
// Change this part to return an error.
f << tab8 << "croak(\"Type error in " << srcname
<< " of " << iname << ". Expected " << t->print_mangle() << ".\");\n"
<< tab8 << ret << ";\n"
<< tab4 << "}\n";
break;
default :
fprintf(stderr,"SWIG Error. Unknown strictness level\n");
break;
}
}
// ----------------------------------------------------------------------
// PERL5::create_command(char *cname, char *iname)
//
// Create a command and register it with the interpreter
// ----------------------------------------------------------------------
void PERL5::create_command(char *cname, char *iname) {
fprintf(f_init,"\t newXS(\"%s::%s\", %s, file);\n", package, iname, name_wrapper(cname,""));
if (export_all) {
exported << iname << " ";
}
}
// ----------------------------------------------------------------------
// PERL5::create_function(char *name, char *iname, DataType *d,
// ParmList *l)
//
// Create a function declaration and register it with the interpreter.
// ----------------------------------------------------------------------
void PERL5::create_function(char *name, char *iname, DataType *d, ParmList *l)
{
Parm *p;
int pcount,i,j;
char *wname;
char *usage = 0;
WrapperFunction f;
char source[256],target[256],temp[256], argnum[32];
char *tm;
String cleanup,outarg,build;
int numopt = 0;
int need_save, num_saved = 0; // Number of saved arguments.
int have_build = 0;
// Make a wrapper name for this
wname = name_wrapper(iname,"");
// Now write the wrapper function itself....this is pretty ugly
f.def << "XS(" << wname << ") {\n";
f.code << tab4 << "cv = cv;\n";
pcount = emit_args(d, l, f);
numopt = l->numopt();
f.add_local("int","argvi = 0");
// Check the number of arguments
usage = usage_func(iname,d,l);
f.code << tab4 << "if ((items < " << (pcount-numopt) << ") || (items > " << l->numarg() << ")) \n"
<< tab8 << "croak(\"Usage: " << usage << "\");\n";
// Write code to extract parameters.
// This section should be able to extract virtually any kind
// parameter, represented as a string
i = 0;
j = 0;
p = l->get_first();
while (p != 0) {
// Produce string representation of source and target arguments
sprintf(source,"ST(%d)",j);
sprintf(target,"_arg%d",i);
sprintf(argnum,"%d",j+1);
// Check to see if this argument is being ignored
if (!p->ignore) {
// If there are optional arguments, check for this
if (j>= (pcount-numopt))
f.code << tab4 << "if (items > " << j << ") {\n";
// See if there is a type-map
if ((tm = typemap_lookup("in","perl5",p->t,p->name,source,target,&f))) {
f.code << tm << "\n";
f.code.replace("$argnum",argnum);
f.code.replace("$arg",source);
} else {
if (!p->t->is_pointer) {
// Extract a parameter by "value"
switch(p->t->type) {
// Integers
case T_BOOL:
case T_INT :
case T_SHORT :
case T_LONG :
case T_SINT :
case T_SSHORT:
case T_SLONG:
case T_SCHAR:
case T_UINT:
case T_USHORT:
case T_ULONG:
case T_UCHAR:
f.code << tab4 << "_arg" << i << " = " << p->t->print_cast()
<< "SvIV(ST(" << j << "));\n";
break;
case T_CHAR :
f.code << tab4 << "_arg" << i << " = (char) *SvPV(ST(" << j << "),na);\n";
break;
// Doubles
case T_DOUBLE :
case T_FLOAT :
f.code << tab4 << "_arg" << i << " = " << p->t->print_cast()
<< " SvNV(ST(" << j << "));\n";
break;
// Void.. Do nothing.
case T_VOID :
break;
// User defined. This is invalid here. Note, user-defined types by
// value are handled in the parser.
case T_USER:
// Unsupported data type
default :
fprintf(stderr,"%s : Line %d. Unable to use type %s as a function argument.\n",input_file, line_number, p->t->print_type());
break;
}
} else {
// Argument is a pointer type. Special case is for char *
// since that is usually a string.
if ((p->t->type == T_CHAR) && (p->t->is_pointer == 1)) {
f.code << tab4 << "_arg" << i << " = (char *) SvPV(ST(" << j << "),na);\n";
} else {
// Have a generic pointer type here. Read it in as a swig
// typed pointer.
sprintf(temp,"argument %d", i+1);
get_pointer(iname,temp,source,target, p->t, f.code, "XSRETURN(1)");
}
}
}
// The source is going to be an array of saved values.
sprintf(temp,"_saved[%d]",num_saved);
if (j>= (pcount-numopt))
f.code << tab4 << "} \n";
j++;
} else {
temp[0] = 0;
}
// Check to see if there is any sort of "build" typemap (highly complicated)
if ((tm = typemap_lookup("build","perl5",p->t,p->name,source,target))) {
build << tm << "\n";
have_build = 1;
}
// Check if there is any constraint code
if ((tm = typemap_lookup("check","perl5",p->t,p->name,source,target))) {
f.code << tm << "\n";
f.code.replace("$argnum",argnum);
}
need_save = 0;
if ((tm = typemap_lookup("freearg","perl5",p->t,p->name,target,temp))) {
cleanup << tm << "\n";
cleanup.replace("$argnum",argnum);
cleanup.replace("$arg",temp);
need_save = 1;
}
if ((tm = typemap_lookup("argout","perl5",p->t,p->name,target,"ST(argvi)"))) {
String tempstr;
tempstr = tm;
tempstr.replace("$argnum",argnum);
tempstr.replace("$arg",temp);
outarg << tempstr << "\n";
need_save = 1;
}
// If we needed a saved variable, we need to emit to emit some code for that
// This only applies if the argument actually existed (not ignore)
if ((need_save) && (!p->ignore)) {
f.code << tab4 << temp << " = " << source << ";\n";
num_saved++;
}
p = l->get_next();
i++;
}
// If there were any saved arguments, emit a local variable for them
if (num_saved) {
sprintf(temp,"_saved[%d]",num_saved);
f.add_local("SV *",temp);
}
// If there was a "build" typemap, we need to go in and perform a serious hack
if (have_build) {
char temp1[32];
char temp2[256];
l->sub_parmnames(build); // Replace all parameter names
j = 1;
for (i = 0; i < l->nparms; i++) {
p = l->get(i);
if (strlen(p->name) > 0) {
sprintf(temp1,"_in_%s", p->name);
} else {
sprintf(temp1,"_in_arg%d", i);
}
sprintf(temp2,"argv[%d]",j);
build.replaceid(temp1,temp2);
if (!p->ignore)
j++;
}
f.code << build;
}
// Now write code to make the function call
emit_func_call(name,d,l,f);
// See if there was a typemap
if ((tm = typemap_lookup("out","perl5",d,iname,"_result","ST(0)"))) {
// Yep. Use it instead of the default
f.code << tm << "\n";
} else if ((d->type != T_VOID) || (d->is_pointer)) {
if (!d->is_pointer) {
// Function returns a "value"
f.code << tab4 << "ST(argvi) = sv_newmortal();\n";
switch(d->type) {
case T_INT: case T_BOOL: case T_SINT: case T_UINT:
case T_SHORT: case T_SSHORT: case T_USHORT:
case T_LONG : case T_SLONG : case T_ULONG:
case T_SCHAR: case T_UCHAR :
f.code << tab4 << "sv_setiv(ST(argvi++),(IV) _result);\n";
break;
case T_DOUBLE :
case T_FLOAT :
f.code << tab4 << "sv_setnv(ST(argvi++), (double) _result);\n";
break;
case T_CHAR :
f.add_local("char", "_ctemp[2]");
f.code << tab4 << "_ctemp[0] = _result;\n"
<< tab4 << "_ctemp[1] = 0;\n"
<< tab4 << "sv_setpv((SV*)ST(argvi++),_ctemp);\n";
break;
// Return a complex type by value
case T_USER:
d->is_pointer++;
f.code << tab4 << "sv_setref_pv(ST(argvi++),\"" << d->print_mangle()
<< "\", (void *) _result);\n";
d->is_pointer--;
break;
default :
fprintf(stderr,"%s: Line %d. Unable to use return type %s in function %s.\n", input_file, line_number, d->print_type(), name);
break;
}
} else {
// Is a pointer return type
f.code << tab4 << "ST(argvi) = sv_newmortal();\n";
if ((d->type == T_CHAR) && (d->is_pointer == 1)) {
// Return a character string
f.code << tab4 << "sv_setpv((SV*)ST(argvi++),(char *) _result);\n";
} else {
// Is an ordinary pointer type.
f.code << tab4 << "sv_setref_pv(ST(argvi++),\"" << d->print_mangle()
<< "\", (void *) _result);\n";
}
}
}
// If there were any output args, take care of them.
f.code << outarg;
// If there was any cleanup, do that.
f.code << cleanup;
if (NewObject) {
if ((tm = typemap_lookup("newfree","perl5",d,iname,"_result",""))) {
f.code << tm << "\n";
}
}
if ((tm = typemap_lookup("ret","perl5",d,iname,"_result",""))) {
// Yep. Use it instead of the default
f.code << tm << "\n";
}
// Wrap things up (in a manner of speaking)
f.code << tab4 << "XSRETURN(argvi);\n}\n";
// Add the dXSARGS last
f.add_local("dXSARGS","");
// Substitute the cleanup code
f.code.replace("$cleanup",cleanup);
f.code.replace("$name",iname);
// Dump this function out
f.print(f_wrappers);
// Create a first crack at a documentation entry
if (doc_entry) {
static DocEntry *last_doc_entry = 0;
doc_entry->usage << usage;
if (last_doc_entry != doc_entry) {
doc_entry->cinfo << "returns " << d->print_type();
last_doc_entry = doc_entry;
}
}
// Now register the function
fprintf(f_init,"\t newXS(\"%s::%s\", %s, file);\n", package, iname, wname);
if (export_all) {
exported << iname << " ";
}
// --------------------------------------------------------------------
// Create a stub for this function, provided it's not a member function
//
// Really we only need to create a stub if this function involves
// complex datatypes. If it does, we'll make a small wrapper to
// process the arguments. If it doesn't, we'll just make a symbol
// table entry.
// --------------------------------------------------------------------
if ((blessed) && (!member_func)) {
int need_stub = 0;
String func;
// We'll make a stub since we may need it anyways
func << "sub " << iname << " {\n"
<< tab4 << "my @args = @_;\n";
// Now we have to go through and patch up the argument list. If any
// arguments to our function correspond to other Perl objects, we
// need to extract them from a tied-hash table object.
Parm *p = l->get_first();
int i = 0;
while(p) {
if (!p->ignore) {
// Look up the datatype name here
if ((classes.lookup(p->t->name)) && (p->t->is_pointer <= 1)) {
if (i >= (pcount - numopt))
func << tab4 << "if (scalar(@args) >= " << i << ") {\n" << tab4;
func << tab4 << "$args[" << i << "] = tied(%{$args[" << i << "]});\n";
if (i >= (pcount - numopt))
func << tab4 << "}\n";
need_stub = 1;
}
i++;
}
p = l->get_next();
}
func << tab4 << "my $result = " << package << "::" << iname << "(@args);\n";
// Now check to see what kind of return result was found.
// If this function is returning a result by 'value', SWIG did an
// implicit malloc/new. We'll mark the object like it was created
// in Perl so we can garbage collect it.
if ((classes.lookup(d->name)) && (d->is_pointer <=1)) {
func << tab4 << "return undef if (!defined($result));\n";
// If we're returning an object by value, put it's reference
// into our local hash table
if ((d->is_pointer == 0) || ((d->is_pointer == 1) && NewObject)) {
func << tab4 << "$" << (char *) classes.lookup(d->name) << "::OWNER{$result} = 1;\n";
}
// We're returning a Perl "object" of some kind. Turn it into
// a tied hash
func << tab4 << "my %resulthash;\n"
<< tab4 << "tie %resulthash, \"" << (char *) classes.lookup(d->name) << "\", $result;\n"
<< tab4 << "return bless \\%resulthash, \"" << (char *) classes.lookup(d->name) << "\";\n"
<< "}\n";
need_stub = 1;
} else {
// Hmmm. This doesn't appear to be anything I know about so just
// return it unmolested.
func << tab4 <<"return $result;\n"
<< "}\n";
}
// Now check if we needed the stub. If so, emit it, otherwise
// Emit code to hack Perl's symbol table instead
if (need_stub) {
func_stubs << func;
} else {
func_stubs << "*" << iname << " = *" << package << "::" << iname << ";\n";
}
}
}
// -----------------------------------------------------------------------
// PERL5::link_variable(char *name, char *iname, DataType *d)
//
// Create a link to a C variable.
// -----------------------------------------------------------------------
void PERL5::link_variable(char *name, char *iname, DataType *t)
{
char set_name[256];
char val_name[256];
WrapperFunction getf, setf;
char *tm;
sprintf(set_name,"_wrap_set_%s",iname);
sprintf(val_name,"_wrap_val_%s",iname);
// Create a new scalar that we will attach magic to
vinit << tab4 << "sv = perl_get_sv(\"" << iname << "\",TRUE | 0x2);\n";
// Create a Perl function for setting the variable value
if (!(Status & STAT_READONLY)) {
setf.def << "SWIGCLASS_STATIC int " << set_name << "(SV* sv, MAGIC *mg) {\n";
setf.code << tab4 << "MAGIC_PPERL\n";
setf.code << tab4 << "mg = mg;\n";
/* Check for a few typemaps */
if ((tm = typemap_lookup("varin","perl5",t,"","sv",name))) {
setf.code << tm << "\n";
} else if ((tm = typemap_lookup("in","perl5",t,"","sv",name))) {
setf.code << tm << "\n";
} else {
if (!t->is_pointer) {
// Set the value to something
switch(t->type) {
case T_INT : case T_BOOL: case T_SINT : case T_UINT:
case T_SHORT : case T_SSHORT : case T_USHORT:
case T_LONG : case T_SLONG : case T_ULONG:
case T_UCHAR: case T_SCHAR:
setf.code << tab4 << name << " = " << t->print_cast() << " SvIV(sv);\n";
break;
case T_DOUBLE :
case T_FLOAT :
setf.code << tab4 << name << " = " << t->print_cast() << " SvNV(sv);\n";
break;
case T_CHAR :
setf.code << tab4 << name << " = (char) *SvPV(sv,na);\n";
break;
case T_USER:
// Add support for User defined type here
// Get as a pointer value
t->is_pointer++;
setf.add_local("void","*_temp");
get_pointer(iname,"value","sv","_temp", t, setf.code, "return(1)");
setf.code << tab4 << name << " = *(" << t->print_cast() << " _temp);\n";
t->is_pointer--;
break;
default :
fprintf(stderr,"%s : Line %d. Unable to link with datatype %s (ignored).\n", input_file, line_number, t->print_type());
return;
}
} else {
// Have some sort of pointer type here, Process it differently
if ((t->type == T_CHAR) && (t->is_pointer == 1)) {
setf.add_local("char","*_a");
setf.code << tab4 << "_a = (char *) SvPV(sv,na);\n";
if (CPlusPlus)
setf.code << tab4 << "if (" << name << ") delete [] " << name << ";\n"
<< tab4 << name << " = new char[strlen(_a)+1];\n";
else
setf.code << tab4 << "if (" << name << ") free(" << name << ");\n"
<< tab4 << name << " = (char *) malloc(strlen(_a)+1);\n";
setf.code << "strcpy(" << name << ",_a);\n";
} else {
// Set the value of a pointer
setf.add_local("void","*_temp");
get_pointer(iname,"value","sv","_temp", t, setf.code, "return(1)");
setf.code << tab4 << name << " = " << t->print_cast() << " _temp;\n";
}
}
}
setf.code << tab4 << "return 1;\n"
<< "}\n";
setf.code.replace("$name",iname);
setf.print(magic);
}
// Now write a function to evaluate the variable
getf.def << "SWIGCLASS_STATIC int " << val_name << "(SV *sv, MAGIC *mg) {\n";
getf.code << tab4 << "MAGIC_PPERL\n";
getf.code << tab4 << "mg = mg;\n";
// Check for a typemap
if ((tm = typemap_lookup("varout","perl5",t,"",name, "sv"))) {
getf.code << tm << "\n";
} else if ((tm = typemap_lookup("out","perl5",t,"",name,"sv"))) {
setf.code << tm << "\n";
} else {
if (!t->is_pointer) {
switch(t->type) {
case T_INT : case T_BOOL: case T_SINT: case T_UINT:
case T_SHORT : case T_SSHORT: case T_USHORT:
case T_LONG : case T_SLONG : case T_ULONG:
case T_UCHAR: case T_SCHAR:
getf.code << tab4 << "sv_setiv(sv, (IV) " << name << ");\n";
vinit << tab4 << "sv_setiv(sv,(IV)" << name << ");\n";
break;
case T_DOUBLE :
case T_FLOAT :
getf.code << tab4 << "sv_setnv(sv, (double) " << name << ");\n";
vinit << tab4 << "sv_setnv(sv,(double)" << name << ");\n";
break;
case T_CHAR :
getf.add_local("char","_ptemp[2]");
getf.code << tab4 << "_ptemp[0] = " << name << ";\n"
<< tab4 << "_ptemp[1] = 0;\n"
<< tab4 << "sv_setpv((SV*) sv, _ptemp);\n";
break;
case T_USER:
t->is_pointer++;
getf.code << tab4 << "rsv = SvRV(sv);\n"
<< tab4 << "sv_setiv(rsv,(IV) &" << name << ");\n";
// getf.code << tab4 << "sv_setref_pv((SV*) sv,\"" << t->print_mangle()
// << "\", (void *) &" << name << ");\n";
getf.add_local("SV","*rsv");
vinit << tab4 << "sv_setref_pv(sv,\"" << t->print_mangle() << "\",(void *) &" << name << ");\n";
t->is_pointer--;
break;
default :
break;
}
} else {
// Have some sort of arbitrary pointer type. Return it as a string
if ((t->type == T_CHAR) && (t->is_pointer == 1))
getf.code << tab4 << "sv_setpv((SV*) sv, " << name << ");\n";
else {
getf.code << tab4 << "rsv = SvRV(sv);\n"
<< tab4 << "sv_setiv(rsv,(IV) " << name << ");\n";
getf.add_local("SV","*rsv");
vinit << tab4 << "sv_setref_pv(sv,\"" << t->print_mangle() << "\",(void *) 1);\n";
//getf.code << tab4 << "sv_setref_pv((SV*) sv,\"" << t->print_mangle()
// << "\", (void *) " << name << ");\n";
}
}
}
getf.code << tab4 << "return 1;\n"
<< "}\n";
getf.code.replace("$name",iname);
getf.print(magic);
// Now add symbol to the PERL interpreter
if (Status & STAT_READONLY) {
vinit << tab4 << "swig_create_magic(sv,\"" << iname << "\",MAGIC_CAST MAGIC_CLASS swig_magic_readonly, MAGIC_CAST MAGIC_CLASS " << val_name << ");\n";
} else {
vinit << tab4 << "swig_create_magic(sv,\"" << iname << "\", MAGIC_CAST MAGIC_CLASS " << set_name << ", MAGIC_CAST MAGIC_CLASS " << val_name << ");\n";
}
// Add a documentation entry
if (doc_entry) {
doc_entry->usage << usage_var(iname,t);
doc_entry->cinfo << "Global : " << t->print_type() << " " << name;
}
// If we're blessed, try to figure out what to do with the variable
// 1. If it's a Perl object of some sort, create a tied-hash
// around it.
// 2. Otherwise, just hack Perl's symbol table
if (blessed) {
if ((classes.lookup(t->name)) && (t->is_pointer <= 1)) {
var_stubs << "\nmy %__" << iname << "_hash;\n"
<< "tie %__" << iname << "_hash,\"" << (char *) classes.lookup(t->name) << "\", $"
<< package << "::" << iname << ";\n"
<< "$" << iname << "= \\%__" << iname << "_hash;\n"
<< "bless $" << iname << ", " << (char *) classes.lookup(t->name) << ";\n";
} else {
var_stubs << "*" << iname << " = *" << package << "::" << iname << ";\n";
}
}
}
// -----------------------------------------------------------------------
// PERL5::declare_const(char *name, char *iname, DataType *type, char *value)
//
// Makes a constant. Really just creates a variable and creates a read-only
// link to it.
// ------------------------------------------------------------------------
// Functions used to create constants
static const char *setiv = "#ifndef PERL_OBJECT\
\n#define swig_setiv(a,b) _swig_setiv(a,b)\
\nstatic void _swig_setiv(char *name, long value) { \
\n#else\
\n#define swig_setiv(a,b) _swig_setiv(pPerl,a,b)\
\nstatic void _swig_setiv(CPerl *pPerl, char *name, long value) { \
\n#endif\
\n SV *sv; \
\n sv = perl_get_sv(name,TRUE | 0x2);\
\n sv_setiv(sv, (IV) value);\
\n SvREADONLY_on(sv);\
\n}\n";
static const char *setnv = "#ifndef PERL_OBJECT\
\n#define swig_setnv(a,b) _swig_setnv(a,b)\
\nstatic void _swig_setnv(char *name, double value) { \
\n#else\
\n#define swig_setnv(a,b) _swig_setnv(pPerl,a,b)\
\nstatic void _swig_setnv(CPerl *pPerl, char *name, double value) { \
\n#endif\
\n SV *sv; \
\n sv = perl_get_sv(name,TRUE | 0x2);\
\n sv_setnv(sv, value);\
\n SvREADONLY_on(sv);\
\n}\n";
static const char *setpv = "#ifndef PERL_OBJECT\
\n#define swig_setpv(a,b) _swig_setpv(a,b)\
\nstatic void _swig_setpv(char *name, char *value) { \
\n#else\
\n#define swig_setpv(a,b) _swig_setpv(pPerl,a,b)\
\nstatic void _swig_setpv(CPerl *pPerl, char *name, char *value) { \
\n#endif\
\n SV *sv; \
\n sv = perl_get_sv(name,TRUE | 0x2);\
\n sv_setpv(sv, value);\
\n SvREADONLY_on(sv);\
\n}\n";
static const char *setrv = "#ifndef PERL_OBJECT\
\n#define swig_setrv(a,b,c) _swig_setrv(a,b,c)\
\nstatic void _swig_setrv(char *name, void *value, char *type) { \
\n#else\
\n#define swig_setrv(a,b,c) _swig_setrv(pPerl,a,b,c)\
\nstatic void _swig_setrv(CPerl *pPerl, char *name, void *value, char *type) { \
\n#endif\
\n SV *sv; \
\n sv = perl_get_sv(name,TRUE | 0x2);\
\n sv_setref_pv(sv, type, value);\
\n SvREADONLY_on(sv);\
\n}\n";
void
PERL5::declare_const(char *name, char *, DataType *type, char *value)
{
char *tm;
static int have_int_func = 0;
static int have_double_func = 0;
static int have_char_func = 0;
static int have_ref_func = 0;
if ((tm = typemap_lookup("const","perl5",type,name,value,name))) {
fprintf(f_init,"%s\n",tm);
} else {
if ((type->type == T_USER) && (!type->is_pointer)) {
fprintf(stderr,"%s : Line %d. Unsupported constant value.\n", input_file, line_number);
return;
}
// Generate a constant
// vinit << tab4 << "sv = perl_get_sv(\"" << name << "\",TRUE);\n";
if (type->is_pointer == 0) {
switch(type->type) {
case T_INT:case T_SINT: case T_UINT: case T_BOOL:
case T_SHORT: case T_SSHORT: case T_USHORT:
case T_LONG: case T_SLONG: case T_ULONG:
case T_SCHAR: case T_UCHAR:
if (!have_int_func) {
fprintf(f_header,"%s\n",setiv);
have_int_func = 1;
}
vinit << tab4 << "swig_setiv(\"" << name << "\", (long) " << value << ");\n";
break;
case T_DOUBLE:
case T_FLOAT:
if (!have_double_func) {
fprintf(f_header,"%s\n",setnv);
have_double_func = 1;
}
vinit << tab4 << "swig_setnv(\"" << name << "\", (double) (" << value << "));\n";
break;
case T_CHAR :
if (!have_char_func) {
fprintf(f_header,"%s\n",setpv);
have_char_func = 1;
}
vinit << tab4 << "swig_setpv(\"" << name << "\", \"" << value << "\");\n";
break;
default:
fprintf(stderr,"%s : Line %d. Unsupported constant value.\n", input_file, line_number);
break;
}
} else {
if ((type->type == T_CHAR) && (type->is_pointer == 1)) {
if (!have_char_func) {
fprintf(f_header,"%s\n",setpv);
have_char_func = 1;
}
vinit << tab4 << "swig_setpv(\"" << name << "\", \"" << value << "\");\n";
} else {
// A user-defined type. We're going to munge it into a string pointer value
if (!have_ref_func) {
fprintf(f_header,"%s\n",setrv);
have_ref_func = 1;
}
vinit << tab4 << "swig_setrv(\"" << name << "\", (void *) " << value << ", \""
<< type->print_mangle() << "\");\n";
}
}
}
// Patch up the documentation entry
if (doc_entry) {
doc_entry->usage = "";
doc_entry->usage << usage_const(name,type,value);
doc_entry->cinfo = "";
doc_entry->cinfo << "Constant: " << type->print_type();
}
if (blessed) {
if ((classes.lookup(type->name)) && (type->is_pointer <= 1)) {
var_stubs << "\nmy %__" << name << "_hash;\n"
<< "tie %__" << name << "_hash,\"" << (char *) classes.lookup(type->name) << "\", $"
<< package << "::" << name << ";\n"
<< "$" << name << "= \\%__" << name << "_hash;\n"
<< "bless $" << name << ", " << (char *) classes.lookup(type->name) << ";\n";
} else {
var_stubs << "*" << name << " = *" << package << "::" << name << ";\n";
}
}
}
// ----------------------------------------------------------------------
// PERL5::usage_var(char *iname, DataType *t)
//
// Produces a usage string for a Perl 5 variable.
// ----------------------------------------------------------------------
char *PERL5::usage_var(char *iname, DataType *) {
static char temp[1024];
char *c;
sprintf(temp,"$%s", iname);
c = temp + strlen(temp);
return temp;
}
// ---------------------------------------------------------------------------
// char *PERL5::usage_func(pkg, char *iname, DataType *t, ParmList *l)
//
// Produces a usage string for a function in Perl
// ---------------------------------------------------------------------------
char *PERL5::usage_func(char *iname, DataType *, ParmList *l) {
static String temp;
Parm *p;
int i;
temp = "";
temp << iname << "(";
/* Now go through and print parameters */
p = l->get_first();
i = 0;
while (p != 0) {
if (!p->ignore) {
/* If parameter has been named, use that. Otherwise, just print a type */
if ((p->t->type != T_VOID) || (p->t->is_pointer)) {
if (strlen(p->name) > 0) {
temp << p->name;
} else {
temp << p->t->print_type();
}
}
i++;
p = l->get_next();
if (p)
if (!p->ignore)
temp << ",";
} else {
p = l->get_next();
if (p)
if ((i>0) && (!p->ignore))
temp << ",";
}
}
temp << ");";
return temp.get();
}
// ----------------------------------------------------------------------
// PERL5::usage_const(char *iname, DataType *type, char *value)
//
// Produces a usage string for a Perl 5 constant
// ----------------------------------------------------------------------
char *PERL5::usage_const(char *iname, DataType *, char *value) {
static char temp[1024];
if (value) {
sprintf(temp,"$%s = %s", iname, value);
} else {
sprintf(temp,"$%s", iname);
}
return temp;
}
// -----------------------------------------------------------------------
// PERL5::add_native(char *name, char *funcname)
//
// Add a native module name to Perl5.
// -----------------------------------------------------------------------
void PERL5::add_native(char *name, char *funcname) {
fprintf(f_init,"\t newXS(\"%s::%s\", %s, file);\n", package,name, funcname);
if (export_all)
exported << name << " ";
if (blessed) {
func_stubs << "*" << name << " = *" << package << "::" << name << ";\n";
}
}
/****************************************************************************
*** OBJECT-ORIENTED FEATURES
****************************************************************************
*** These extensions provide a more object-oriented interface to C++
*** classes and structures. The code here is based on extensions
*** provided by David Fletcher and Gary Holt.
***
*** I have generalized these extensions to make them more general purpose
*** and to resolve object-ownership problems.
***
*** The approach here is very similar to the Python module :
*** 1. All of the original methods are placed into a single
*** package like before except that a 'c' is appended to the
*** package name.
***
*** 2. All methods and function calls are wrapped with a new
*** perl function. While possibly inefficient this allows
*** us to catch complex function arguments (which are hard to
*** track otherwise).
***
*** 3. Classes are represented as tied-hashes in a manner similar
*** to Gary Holt's extension. This allows us to access
*** member data.
***
*** 4. Stand-alone (global) C functions are modified to take
*** tied hashes as arguments for complex datatypes (if
*** appropriate).
***
*** 5. Global variables involving a class/struct is encapsulated
*** in a tied hash.
***
*** 6. Object ownership is maintained by having a hash table
*** within in each package called "this". It is unlikely
*** that C++ program will use this so it's a somewhat
*** safe variable name.
***
****************************************************************************/
static int class_renamed = 0;
// --------------------------------------------------------------------------
// PERL5::cpp_open_class(char *classname, char *rname, int strip)
//
// Opens a new C++ class or structure. Basically, this just records
// the class name and clears a few variables.
// --------------------------------------------------------------------------
void PERL5::cpp_open_class(char *classname, char *rname, char *ctype, int strip) {
char temp[256];
extern void typeeq_addtypedef(char *, char *);
// Register this with the default class handler
this->Language::cpp_open_class(classname, rname, ctype, strip);
if (blessed) {
have_constructor = 0;
have_destructor = 0;
have_data_members = 0;
// If the class is being renamed to something else, use the renaming
if (rname) {
class_name = copy_string(rname);
class_renamed = 1;
// Now things get even more hideous. Need to register an equivalence
// between the renamed name and the new name. Yuck!
// printf("%s %s\n", classname, rname);
typeeq_addtypedef(classname,rname);
typeeq_addtypedef(rname,classname);
/*
fprintf(f_init,"\t SWIG_RegisterMapping(\"%s\",\"%s\",0);\n",classname,rname);
fprintf(f_init,"\t SWIG_RegisterMapping(\"%s\",\"%s\",0);\n",rname,classname);
*/
} else {
class_name = copy_string(classname);
class_renamed = 0;
}
real_classname = copy_string(classname);
if (base_class) delete base_class;
base_class = 0;
class_type = copy_string(ctype);
pcode = new String();
blessedmembers = new String();
member_keys = new String();
// Add some symbols to the hash tables
classes.add(real_classname,copy_string(class_name)); /* Map original classname to class */
// Add full name of datatype to the hash table just in case the user uses it
sprintf(temp,"%s %s", class_type, real_classname);
classes.add(temp,copy_string(class_name)); /* Map full classname to classs */
}
}
// -------------------------------------------------------------------------------
// PERL5::cpp_close_class()
//
// These functions close a class definition.
//
// This also sets up the hash table of classes we've seen go by.
// -------------------------------------------------------------------------------
void PERL5::cpp_close_class() {
// We need to check to make sure we got constructors, and other
// stuff here.
if (blessed) {
pm << "\n############# Class : " << class_name << " ##############\n";
pm << "\npackage " << class_name << ";\n";
// If we are inheriting from a base class, set that up
if (strcmp(class_name,realpackage))
pm << "@ISA = qw( " << realpackage;
else
pm << "@ISA = qw( ";
if (base_class) {
pm << " " << *base_class;
}
pm << " );\n";
// Dump out a hash table containing the pointers that we own
pm << "%OWNER = ();\n";
if (have_data_members) {
pm << "%BLESSEDMEMBERS = (\n"
<< blessedmembers->get()
<< ");\n\n";
}
if (have_data_members || have_destructor)
pm << "%ITERATORS = ();\n";
// Dump out the package methods
pm << *pcode;
delete pcode;
// Output methods for managing ownership
pm << "sub DISOWN {\n"
<< tab4 << "my $self = shift;\n"
<< tab4 << "my $ptr = tied(%$self);\n"
<< tab4 << "delete $OWNER{$ptr};\n"
<< tab4 << "};\n\n"
<< "sub ACQUIRE {\n"
<< tab4 << "my $self = shift;\n"
<< tab4 << "my $ptr = tied(%$self);\n"
<< tab4 << "$OWNER{$ptr} = 1;\n"
<< tab4 << "};\n\n";
// Only output the following methods if a class has member data
if (have_data_members) {
// Output a FETCH method. This is actually common to all classes
pm << "sub FETCH {\n"
<< tab4 << "my ($self,$field) = @_;\n"
<< tab4 << "my $member_func = \"" << package << "::" << name_get(name_member("${field}",class_name,AS_IS),AS_IS) << "\";\n"
<< tab4 << "my $val = &$member_func($self);\n"
<< tab4 << "if (exists $BLESSEDMEMBERS{$field}) {\n"
<< tab8 << "return undef if (!defined($val));\n"
<< tab8 << "my %retval;\n"
<< tab8 << "tie %retval,$BLESSEDMEMBERS{$field},$val;\n"
<< tab8 << "return bless \\%retval, $BLESSEDMEMBERS{$field};\n"
<< tab4 << "}\n"
<< tab4 << "return $val;\n"
<< "}\n\n";
// Output a STORE method. This is also common to all classes (might move to base class)
pm << "sub STORE {\n"
<< tab4 << "my ($self,$field,$newval) = @_;\n"
<< tab4 << "my $member_func = \"" << package << "::" << name_set(name_member("${field}",class_name,AS_IS),AS_IS) << "\";\n"
<< tab4 << "if (exists $BLESSEDMEMBERS{$field}) {\n"
<< tab8 << "&$member_func($self,tied(%{$newval}));\n"
<< tab4 << "} else {\n"
<< tab8 << "&$member_func($self,$newval);\n"
<< tab4 << "}\n"
<< "}\n\n";
// Output a FIRSTKEY method. This is to allow iteration over a structure's keys.
pm << "sub FIRSTKEY {\n"
<< tab4 << "my $self = shift;\n"
<< tab4 << "$ITERATORS{$self} = [" << member_keys->get() << "];\n"
<< tab4 << "my $first = shift @{$ITERATORS{$self}};\n"
<< tab4 << "return $first;\n"
<< "}\n\n";
// Output a NEXTKEY method. This is the iterator so that each and keys works
pm << "sub NEXTKEY {\n"
<< tab4 << "my $self = shift;\n"
<< tab4 << "$nelem = scalar @{$ITERATORS{$self}};\n"
<< tab4 << "if ($nelem > 0) {\n"
<< tab8 << "my $member = shift @{$ITERATORS{$self}};\n"
<< tab8 << "return $member;\n"
<< tab4 << "} else {\n"
<< tab8 << "$ITERATORS{$self} = [" << member_keys->get() << "];\n"
<< tab8 << "return ();\n"
<< tab4 << "}\n"
<< "}\n\n";
}
}
}
// --------------------------------------------------------------------------
// PERL5::cpp_member_func(char *name, char *iname, DataType *t, ParmList *l)
//
// Handles a C++ member function. This basically does the same thing as
// the non-C++ version, but we set up a few status variables that affect
// the function generation function.
//
// --------------------------------------------------------------------------
void PERL5::cpp_member_func(char *name, char *iname, DataType *t, ParmList *l) {
String func;
char *realname;
Parm *p;
int i;
String cname = "perl5:";
int pcount, numopt;
// First emit normal member function
member_func = 1;
this->Language::cpp_member_func(name,iname,t,l);
member_func = 0;
if (!blessed) return;
// Now emit a Perl wrapper function around our member function, we might need
// to patch up some arguments along the way
if (!iname)
realname = name;
else
realname = iname;
cname << class_name << "::" << realname;
if (add_symbol(cname.get(),0,0)) {
return; // Forget it, we saw this function already
}
func << "sub " << realname << " {\n"
<< tab4 << "my @args = @_;\n"
<< tab4 << "$args[0] = tied(%{$args[0]});\n";
// Now we have to go through and patch up the argument list. If any
// arguments to our function correspond to other Perl objects, we
// need to extract them from a tied-hash table object.
p = l->get_first();
pcount = l->nparms;
numopt = l->numopt();
i = 1;
while(p) {
if (!p->ignore) {
// Look up the datatype name here
if ((classes.lookup(p->t->name)) && (p->t->is_pointer <= 1)) {
// Yep. This smells alot like an object, patch up the arguments
if (i >= (pcount - numopt))
func << tab4 << "if (scalar(@args) >= " << i << ") {\n";
func << tab4 << "$args[" << i << "] = tied(%{$args[" << i << "]});\n";
if (i >= (pcount - numopt))
func << tab4 << "}\n";
}
i++;
}
p = l->get_next();
}
// Okay. We've made argument adjustments, now call into the package
func << tab4 << "my $result = " << package << "::" << name_member(realname,class_name)
<< "(@args);\n";
// Now check to see what kind of return result was found.
// If this function is returning a result by 'value', SWIG did an
// implicit malloc/new. We'll mark the object like it was created
// in Perl so we can garbage collect it.
if ((classes.lookup(t->name)) && (t->is_pointer <=1)) {
func << tab4 << "return undef if (!defined($result));\n";
// If we're returning an object by value, put it's reference
// into our local hash table
if ((t->is_pointer == 0) || ((t->is_pointer == 1) && NewObject)) {
func << tab4 << "$" << (char *) classes.lookup(t->name) << "::OWNER{$result} = 1;\n";
}
// We're returning a Perl "object" of some kind. Turn it into
// a tied hash
func << tab4 << "my %resulthash;\n"
<< tab4 << "tie %resulthash, \"" << (char *) classes.lookup(t->name) << "\", $result;\n"
<< tab4 << "return bless \\%resulthash, \"" << (char *) classes.lookup(t->name) << "\";\n"
<< "}\n";
} else {
// Hmmm. This doesn't appear to be anything I know about so just
// return it unmolested.
func << tab4 <<"return $result;\n"
<< "}\n";
}
// Append our function to the pcode segment
*pcode << func;
// Create a new kind of documentation entry for the shadow class
if (doc_entry) {
doc_entry->usage = ""; // Blow away whatever was there before
doc_entry->usage << usage_func(realname,t,l);
}
}
// --------------------------------------------------------------------------------
// PERL5::cpp_variable(char *name, char *iname, DataType *t)
//
// Adds an instance member. This is a little hairy because data members are
// really added with a tied-hash table that is attached to the object.
//
// On the low level, we will emit a pair of get/set functions to retrieve
// values just like before. These will then be encapsulated in a FETCH/STORE
// method associated with the tied-hash.
//
// In the event that a member is an object that we have already wrapped, then
// we need to retrieve the data a tied-hash as opposed to what SWIG normally
// returns. To determine this, we build an internal hash called 'BLESSEDMEMBERS'
// that contains the names and types of tied data members. If a member name
// is in the list, we tie it, otherwise, we just return the normal SWIG value.
// --------------------------------------------------------------------------------
void PERL5::cpp_variable(char *name, char *iname, DataType *t) {
char *realname;
String cname = "perl5:";
// Emit a pair of get/set functions for the variable
member_func = 1;
this->Language::cpp_variable(name, iname, t);
member_func = 0;
if (iname) realname = iname;
else realname = name;
if (blessed) {
cname << class_name << "::" << realname;
if (add_symbol(cname.get(),0,0)) {
return; // Forget it, we saw this already
}
// Store name of key for future reference
*member_keys << "'" << realname << "', ";
// Now we need to generate a little Perl code for this
if ((classes.lookup(t->name)) && (t->is_pointer <= 1)) {
// This is a Perl object that we have already seen. Add an
// entry to the members list
*blessedmembers << tab4 << realname << " => '" << (char *) classes.lookup(t->name) << "',\n";
}
// Patch up the documentation entry
if (doc_entry) {
doc_entry->usage = "";
doc_entry->usage << "$this->{" << realname << "}";
}
}
have_data_members++;
}
// -----------------------------------------------------------------------------
// void PERL5::cpp_constructor(char *name, char *iname, ParmList *l)
//
// Emits a blessed constructor for our class. In addition to our construct
// we manage a Perl hash table containing all of the pointers created by
// the constructor. This prevents us from accidentally trying to free
// something that wasn't necessarily allocated by malloc or new
// -----------------------------------------------------------------------------
void PERL5::cpp_constructor(char *name, char *iname, ParmList *l) {
Parm *p;
int i;
char *realname;
String cname="perl5:constructor:";
// Emit an old-style constructor for this class
member_func = 1;
this->Language::cpp_constructor(name, iname, l);
if (blessed) {
if (iname)
realname = iname;
else {
if (class_renamed) realname = class_name;
else realname = class_name;
}
cname << class_name << "::" << realname;
if (add_symbol(cname.get(),0,0)) {
return; // Forget it, we saw this already
}
if ((strcmp(realname,class_name) == 0) || ((!iname) && (ObjCClass)) ){
// Emit a blessed constructor
*pcode << "sub new {\n";
} else {
// Constructor doesn't match classname so we'll just use the normal name
*pcode << "sub " << name_construct(realname) << " () {\n";
}
*pcode << tab4 << "my $self = shift;\n"
<< tab4 << "my @args = @_;\n";
// We are going to need to patch up arguments here if necessary
// Now we have to go through and patch up the argument list. If any
// arguments to our function correspond to other Perl objects, we
// need to extract them from a tied-hash table object.
p = l->get_first();
i = 0;
while(p) {
// Look up the datatype name here
if ((classes.lookup(p->t->name)) && (p->t->is_pointer <= 1)) {
// Yep. This smells alot like an object, patch up the arguments
*pcode << tab4 << "$args[" << i << "] = tied(%{$args[" << i << "]});\n";
}
p = l->get_next();
i++;
}
*pcode << tab4 << "$self = " << package << "::" << name_construct(realname) << "(@args);\n"
<< tab4 << "return undef if (!defined($self));\n"
<< tab4 << "bless $self, \"" << class_name << "\";\n"
<< tab4 << "$OWNER{$self} = 1;\n"
<< tab4 << "my %retval;\n"
<< tab4 << "tie %retval, \"" << class_name << "\", $self;\n"
<< tab4 << "return bless \\%retval,\"" << class_name << "\";\n"
<< "}\n\n";
have_constructor = 1;
// Patch up the documentation entry
if (doc_entry) {
doc_entry->usage = "";
doc_entry->usage << usage_func("new",0,l);
}
}
member_func = 0;
}
// ------------------------------------------------------------------------------
// void PERL5::cpp_destructor(char *name, char *newname)
//
// Creates a destructor for a blessed object
// ------------------------------------------------------------------------------
void PERL5::cpp_destructor(char *name, char *newname) {
char *realname;
member_func = 1;
this->Language::cpp_destructor(name, newname);
if (blessed) {
if (newname) realname = newname;
else {
if (class_renamed) realname = class_name;
else realname = name;
}
// Emit a destructor for this object
*pcode << "sub DESTROY {\n"
<< tab4 << "my $self = tied(%{$_[0]});\n"
<< tab4 << "delete $ITERATORS{$self};\n"
<< tab4 << "if (exists $OWNER{$self}) {\n"
<< tab8 << package << "::" << name_destroy(realname) << "($self);\n"
<< tab8 << "delete $OWNER{$self};\n"
<< tab4 << "}\n}\n\n";
have_destructor = 1;
if (doc_entry) {
doc_entry->usage = "DESTROY";
doc_entry->cinfo = "Destructor";
}
}
member_func = 0;
}
// -----------------------------------------------------------------------------
// void PERL5::cpp_static_func(char *name, char *iname, DataType *t, ParmList *l)
//
// Emits a wrapper for a static class function. Basically, we just call the
// appropriate method in the module package.
// ------------------------------------------------------------------------------
void PERL5::cpp_static_func(char *name, char *iname, DataType *t, ParmList *l) {
this->Language::cpp_static_func(name,iname,t,l);
char *realname;
if (iname) realname = name;
else realname = iname;
if (blessed) {
*pcode << "*" << realname << " = *" << realpackage << "::" << name_member(realname,class_name) << ";\n";
}
}
// ------------------------------------------------------------------------------
// void PERL5::cpp_inherit(char **baseclass, int mode)
//
// This sets the Perl5 baseclass (if possible).
// ------------------------------------------------------------------------------
void PERL5::cpp_inherit(char **baseclass, int) {
char *bc;
int i = 0, have_first = 0;
if (!blessed) {
this->Language::cpp_inherit(baseclass);
return;
}
// Inherit variables and constants from base classes, but not
// functions (since Perl can handle that okay).
this->Language::cpp_inherit(baseclass, INHERIT_CONST | INHERIT_VAR);
// Now tell the Perl5 module that we're inheriting from base classes
base_class = new String;
while (baseclass[i]) {
// See if this is a class we know about
bc = (char *) classes.lookup(baseclass[i]);
if (bc) {
if (have_first) *base_class << " ";
*base_class << bc;
have_first = 1;
}
i++;
}
if (!have_first) {
delete base_class;
base_class = 0;
}
}
// --------------------------------------------------------------------------------
// PERL5::cpp_declare_const(char *name, char *iname, DataType *type, char *value)
//
// Add access to a C++ constant. We can really just do this by hacking
// the symbol table
// --------------------------------------------------------------------------------
void PERL5::cpp_declare_const(char *name, char *iname, DataType *type, char *value) {
char *realname;
int oldblessed = blessed;
String cname;
// Create a normal constant
blessed = 0;
this->Language::cpp_declare_const(name, iname, type, value);
blessed = oldblessed;
if (blessed) {
if (!iname)
realname = name;
else
realname = iname;
cname << class_name << "::" << realname;
if (add_symbol(cname.get(),0,0)) {
return; // Forget it, we saw this already
}
// Create a symbol table entry for it
*pcode << "*" << realname << " = *" << package << "::" << name_member(realname,class_name) << ";\n";
// Fix up the documentation entry
if (doc_entry) {
doc_entry->usage = "";
doc_entry->usage << realname;
if (value) {
doc_entry->usage << " = " << value;
}
}
}
}
// -----------------------------------------------------------------------
// PERL5::cpp_class_decl(char *name, char *rename, char *type)
//
// Treatment of an empty class definition. Used to handle
// shadow classes across modules.
// -----------------------------------------------------------------------
void PERL5::cpp_class_decl(char *name, char *rename, char *type) {
char temp[256];
if (blessed) {
classes.add(name,copy_string(rename));
// Add full name of datatype to the hash table
if (strlen(type) > 0) {
sprintf(temp,"%s %s", type, name);
classes.add(temp,copy_string(rename));
}
}
}
// --------------------------------------------------------------------------------
// PERL5::add_typedef(DataType *t, char *name)
//
// This is called whenever a typedef is encountered. When shadow classes are
// used, this function lets us discovered hidden uses of a class. For example :
//
// struct FooBar {
// ...
// }
//
// typedef FooBar *FooBarPtr;
//
// --------------------------------------------------------------------------------
void PERL5::add_typedef(DataType *t, char *name) {
if (!blessed) return;
// First check to see if there aren't too many pointers
if (t->is_pointer > 1) return;
if (classes.lookup(name)) return; // Already added
// Now look up the datatype in our shadow class hash table
if (classes.lookup(t->name)) {
// Yep. This datatype is in the hash
// Put this types 'new' name into the hash
classes.add(name,copy_string((char *) classes.lookup(t->name)));
}
}
// --------------------------------------------------------------------------------
// PERL5::pragma(char *, char *, char *)
//
// Pragma directive.
//
// %pragma(perl5) code="String" # Includes a string in the .pm file
// %pragma(perl5) include="file.pl" # Includes a file in the .pm file
//
// --------------------------------------------------------------------------------
void PERL5::pragma(char *lang, char *code, char *value) {
if (strcmp(lang,"perl5") == 0) {
if (strcmp(code,"code") == 0) {
// Dump the value string into the .pm file
if (value) {
pragma_include << value << "\n";
}
} else if (strcmp(code,"include") == 0) {
// Include a file into the .pm file
if (value) {
if (get_file(value,pragma_include) == -1) {
fprintf(stderr,"%s : Line %d. Unable to locate file %s\n", input_file, line_number,value);
}
}
} else {
fprintf(stderr,"%s : Line %d. Unrecognized pragma.\n", input_file,line_number);
}
}
}
/***********************************************************************
*
* -- Revision History
* $Log: perl5.cxx,v $
* Revision 1.66 1997/07/10 03:05:24 beazley
* Fixed some static linking bugs with shadow classes and
* multiple modules.
*
* Revision 1.65 1997/07/09 03:03:31 beazley
* First cut at eliminating compiler warnings.
*
* Revision 1.64 1997/06/29 16:02:18 beazley
* Fixed Objective-C constructor bug with shadow classes.
*
* Revision 1.63 1997/06/23 05:39:32 beazley
* Fixed some static linking issues.
*
* Revision 1.62 1997/06/22 19:35:59 beazley
* Fixed the import directive.
*
* Revision 1.61 1997/06/17 04:41:05 beazley
* Fixed some bugs with the %name() directive.
*
* Revision 1.60 1997/05/28 21:38:58 beazley
* Moved revision history to end.
*
* Revision 1.59 1997/05/24 05:15:16 beazley
* A few minor bug fixes. Added the "build" typemap.
*
* Revision 1.58 1997/05/19 19:10:22 beazley
* Fixed bug in native function with shadow classes.
*
* Revision 1.57 1997/05/19 15:48:37 beazley
* Fixed ownership bug with returned objects.
*
* Revision 1.56 1997/05/10 23:47:17 beazley
* Eliminated compiler warning.
*
* Revision 1.55 1997/05/08 05:41:39 beazley
* Added $cleanup symbol. Fixed segmentation fault on empty files.
*
* Revision 1.54 1997/05/05 15:43:23 beazley
* Fixed code generation bugs related to 'ignore' typemap. Also added
* support for parameterized typemaps.
*
* Revision 1.53 1997/04/25 22:40:23 beazley
* Minor bug fixes
*
* Revision 1.52 1997/04/23 05:00:43 beazley
* Support for %new directive
*
* Revision 1.51 1997/04/19 21:24:50 beazley
* Added support for %new directive
*
* Revision 1.50 1997/04/18 04:09:34 beazley
* Added a few pragma directives. Fixed pointer variable linking bug.
* A number of other minor tweaks.
*
* Revision 1.49 1997/04/09 03:34:59 beazley
* Fixed bugs related to class renaming.
*
* Revision 1.48 1997/03/29 17:44:04 beazley
* Minor changes
*
* Revision 1.47 1997/03/19 23:47:38 beazley
* Changed "constrain" typemap to "check"
*
* Revision 1.46 1997/03/18 22:27:10 beazley
* Added support for constrain typemap
*
* Revision 1.45 1997/03/08 22:13:02 beazley
* Fixed some bugs in the -exportall option.
*
* Revision 1.44 1997/03/02 22:40:57 beazley
* Removed warning messages. More modifications for Win95
*
* Revision 1.43 1997/02/19 23:03:58 beazley
* Added create_command() function for C++ optimization.
*
* Revision 1.42 1997/02/16 18:35:31 beazley
* Added support for ignored arguments.
* Fixed bugs in default argument handling.
*
* Revision 1.41 1997/01/09 21:16:07 beazley
* Minor bug fixes to shadow classes
*
* Revision 1.40 1997/01/09 01:21:42 beazley
* Changed inherit method slightly
*
* Revision 1.39 1997/01/08 05:43:06 beazley
* Pre 1.1b3 checkin
*
* Revision 1.38 1997/01/06 17:12:03 beazley
* Added support for typemaps. Multiple inheritance.
*
* Revision 1.37 1996/12/26 23:03:19 beazley
* Modified to use new pointer type-checker
*
* Revision 1.36 1996/12/26 04:48:00 beazley
* Made a few more bug fixes to the shadow class mechanism
*
* Revision 1.35 1996/12/03 08:41:26 beazley
* pre-1.1b2 checkin
*
* Revision 1.34 1996/11/12 20:01:57 beazley
* Changes to support new documentation and C++ handling
*
* Revision 1.33 1996/10/30 19:32:58 beazley
* Added option to use a different header file. Minor cleanup.
*
* Revision 1.32 1996/10/29 19:27:11 beazley
* Major improvements to shadow classes. Still not quite stable yet
*
* Revision 1.31 1996/10/22 17:15:34 beazley
* Added support for 'bool' type. (from David Fletcher)
*
* Revision 1.30 1996/09/04 21:08:27 dmb
* Fixed minor bug with packages
*
* Revision 1.29 1996/08/27 23:01:51 dmb
* Minor changes to error handling
*
* Revision 1.28 1996/08/21 16:51:14 dmb
* Minor cleanup to eliminate warnings
*
* Revision 1.27 1996/08/21 05:49:45 dmb
* Some fixes to the new pointer type-checker.
*
* Revision 1.26 1996/08/15 05:08:57 dmb
* Major overhaul. Changed generation of wrapper functions to
* eliminate problems with undeclared variables.
*
* Also switched over to Perl5 references which seems to work much
* better---well, at least with other Perl5 extensions.
*
* Revision 1.25 1996/08/12 01:49:33 dmb
* Changes to support new language class. Also changed implementation
* of the variable initialization code
*
* Revision 1.24 1996/08/02 02:58:01 dmb
* Changed to use better parameter list functions
*
* Revision 1.23 1996/07/17 14:55:15 dmb
* Fixed bug in -strict 1 pointer type checking mode.
*
* Revision 1.22 1996/06/02 00:14:17 beazley
* Changed something--but I can't remember what.
*
* Revision 1.21 1996/05/22 20:20:21 beazley
* Add banner and cleanup functions to headers() and close() functions
*
* Revision 1.20 1996/05/20 23:35:56 beazley
* Added a few more constant datatypes.
*
* Revision 1.19 1996/05/17 05:53:12 beazley
* Added return by value support.
*
* Revision 1.18 1996/05/13 23:45:28 beazley
* Reworked the module/init procedure
*
* Revision 1.17 1996/05/01 22:41:30 dmb
* Cleaned up command line option handling.
*
* Revision 1.16 1996/04/16 17:13:01 dmb
* Fixed bug when linking to pointer variables.
*
* Revision 1.15 1996/04/09 20:19:01 beazley
* Minor cleanup
*
* Revision 1.14 1996/04/08 22:09:28 beazley
* Minor cleanup
*
* Revision 1.13 1996/04/03 22:48:44 beazley
* Minor changes to module naming.
*
* Revision 1.12 1996/03/28 02:46:56 beazley
* Minor bug fix to documentation.
*
* Revision 1.11 1996/03/24 22:14:51 beazley
* Cleaned up wrapper file construction. Took out "system" calls.
*
* Revision 1.10 1996/03/22 23:41:31 beazley
* Fixed to work with new class structure. Fixed variable linkage
* problem. Added support for constants.
*
* Revision 1.9 1996/03/04 21:28:54 beazley
* Changed usage(), made changes to pointer handling.
*
* Revision 1.8 1996/02/20 04:16:25 beazley
* Took out streams.
*
* Revision 1.7 1996/02/19 08:34:28 beazley
* Fixed a bug with pointer return values.
*
* Revision 1.6 1996/02/19 05:30:58 beazley
* Changed treatment of pointers to hexadecimal convert functions.
* Fixed quite a few minor bugs in the handling of several datatypes.
*
* Revision 1.5 1996/02/17 22:55:19 beazley
* Fixed documentation and a few things with package names.
*
* Revision 1.4 1996/02/16 07:20:17 beazley
* Fixed problems with sprintf(). Added package name to documentation.
*
* Revision 1.3 1996/02/16 06:38:49 beazley
* Removed a few unused variables.
*
* Revision 1.2 1996/02/16 05:20:22 beazley
* Changed variable linkage procedure to add "var_init" function.
* Fixed bugs related to fixes in other modules.
*
* Revision 1.1 1996/02/15 22:39:31 beazley
* Initial revision
*
*
***********************************************************************/
syntax highlighted by Code2HTML, v. 0.9.1