1991-02-19 08:39:46 -04:00
|
|
|
/***********************************************************
|
1994-08-30 05:27:36 -03:00
|
|
|
Copyright 1991, 1992, 1993, 1994 by Stichting Mathematisch Centrum,
|
1993-01-26 09:33:44 -04:00
|
|
|
Amsterdam, The Netherlands.
|
1991-02-19 08:39:46 -04:00
|
|
|
|
|
|
|
All Rights Reserved
|
|
|
|
|
|
|
|
Permission to use, copy, modify, and distribute this software and its
|
|
|
|
documentation for any purpose and without fee is hereby granted,
|
|
|
|
provided that the above copyright notice appear in all copies and that
|
|
|
|
both that copyright notice and this permission notice appear in
|
|
|
|
supporting documentation, and that the names of Stichting Mathematisch
|
|
|
|
Centrum or CWI not be used in advertising or publicity pertaining to
|
|
|
|
distribution of the software without specific, written prior permission.
|
|
|
|
|
|
|
|
STICHTING MATHEMATISCH CENTRUM DISCLAIMS ALL WARRANTIES WITH REGARD TO
|
|
|
|
THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
|
|
|
FITNESS, IN NO EVENT SHALL STICHTING MATHEMATISCH CENTRUM BE LIABLE
|
|
|
|
FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
|
|
|
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
|
|
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
|
|
|
|
OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
|
|
|
|
|
|
******************************************************************/
|
|
|
|
|
1990-10-14 09:07:46 -03:00
|
|
|
/* Module support implementation */
|
|
|
|
|
1990-12-20 11:06:42 -04:00
|
|
|
#include "allobjects.h"
|
1990-10-14 09:07:46 -03:00
|
|
|
#include "import.h"
|
|
|
|
|
1994-08-30 05:27:36 -03:00
|
|
|
#ifdef MPW /* MPW pushes 'extended' for float and double types with varargs */
|
|
|
|
typedef extended va_double;
|
|
|
|
#else
|
|
|
|
typedef double va_double;
|
|
|
|
#endif
|
|
|
|
|
|
|
|
|
|
|
|
/* initmodule2() has an additional parameter, 'passthrough', which is
|
|
|
|
passed as 'self' to functions defined in the module. This is used
|
|
|
|
e.g. by dynamically loaded modules on the Mac. */
|
|
|
|
|
1990-10-14 09:07:46 -03:00
|
|
|
object *
|
1994-08-30 05:27:36 -03:00
|
|
|
initmodule2(name, methods, passthrough)
|
1990-10-14 09:07:46 -03:00
|
|
|
char *name;
|
|
|
|
struct methodlist *methods;
|
1994-08-30 05:27:36 -03:00
|
|
|
object *passthrough;
|
1990-10-14 09:07:46 -03:00
|
|
|
{
|
|
|
|
object *m, *d, *v;
|
|
|
|
struct methodlist *ml;
|
1993-01-04 05:09:59 -04:00
|
|
|
char *namebuf;
|
1990-12-20 11:06:42 -04:00
|
|
|
if ((m = add_module(name)) == NULL) {
|
1990-10-14 09:07:46 -03:00
|
|
|
fprintf(stderr, "initializing module: %s\n", name);
|
|
|
|
fatal("can't create a module");
|
|
|
|
}
|
|
|
|
d = getmoduledict(m);
|
|
|
|
for (ml = methods; ml->ml_name != NULL; ml++) {
|
1993-01-04 05:09:59 -04:00
|
|
|
namebuf = NEW(char, strlen(name) + strlen(ml->ml_name) + 2);
|
|
|
|
if (namebuf == NULL)
|
|
|
|
fatal("out of mem for method name");
|
1990-12-20 11:06:42 -04:00
|
|
|
sprintf(namebuf, "%s.%s", name, ml->ml_name);
|
1993-01-04 05:09:59 -04:00
|
|
|
v = newmethodobject(namebuf, ml->ml_meth,
|
1994-08-30 05:27:36 -03:00
|
|
|
(object *)passthrough, ml->ml_varargs);
|
1993-01-04 05:09:59 -04:00
|
|
|
/* XXX The malloc'ed memory in namebuf is never freed */
|
1990-10-14 09:07:46 -03:00
|
|
|
if (v == NULL || dictinsert(d, ml->ml_name, v) != 0) {
|
|
|
|
fprintf(stderr, "initializing module: %s\n", name);
|
|
|
|
fatal("can't initialize module");
|
|
|
|
}
|
|
|
|
DECREF(v);
|
|
|
|
}
|
1990-12-20 11:06:42 -04:00
|
|
|
return m;
|
1990-10-14 09:07:46 -03:00
|
|
|
}
|
|
|
|
|
1994-08-30 05:27:36 -03:00
|
|
|
/* The standard initmodule() passes NULL for 'self' */
|
|
|
|
|
|
|
|
object *
|
|
|
|
initmodule(name, methods)
|
|
|
|
char *name;
|
|
|
|
struct methodlist *methods;
|
|
|
|
{
|
|
|
|
return initmodule2(name, methods, (object *)NULL);
|
|
|
|
}
|
|
|
|
|
1990-10-14 09:07:46 -03:00
|
|
|
|
1993-02-08 11:49:17 -04:00
|
|
|
/* Helper for mkvalue() to scan the length of a format */
|
1992-04-13 12:53:41 -03:00
|
|
|
|
|
|
|
static int countformat PROTO((char *format, int endchar));
|
|
|
|
static int countformat(format, endchar)
|
|
|
|
char *format;
|
|
|
|
int endchar;
|
|
|
|
{
|
|
|
|
int count = 0;
|
|
|
|
int level = 0;
|
|
|
|
while (level > 0 || *format != endchar) {
|
|
|
|
if (*format == '\0') {
|
|
|
|
/* Premature end */
|
|
|
|
err_setstr(SystemError, "unmatched paren in format");
|
|
|
|
return -1;
|
|
|
|
}
|
|
|
|
else if (*format == '(') {
|
|
|
|
if (level == 0)
|
|
|
|
count++;
|
|
|
|
level++;
|
|
|
|
}
|
|
|
|
else if (*format == ')')
|
|
|
|
level--;
|
|
|
|
else if (level == 0 && *format != '#')
|
|
|
|
count++;
|
|
|
|
format++;
|
|
|
|
}
|
|
|
|
return count;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Generic function to create a value -- the inverse of getargs() */
|
|
|
|
/* After an original idea and first implementation by Steven Miale */
|
|
|
|
|
|
|
|
static object *do_mktuple PROTO((char**, va_list *, int, int));
|
|
|
|
static object *do_mkvalue PROTO((char**, va_list *));
|
|
|
|
|
1992-04-13 07:48:55 -03:00
|
|
|
static object *
|
1992-04-13 12:53:41 -03:00
|
|
|
do_mktuple(p_format, p_va, endchar, n)
|
|
|
|
char **p_format;
|
|
|
|
va_list *p_va;
|
|
|
|
int endchar;
|
|
|
|
int n;
|
|
|
|
{
|
1992-04-13 07:48:55 -03:00
|
|
|
object *v;
|
1992-04-13 12:53:41 -03:00
|
|
|
int i;
|
|
|
|
if (n < 0)
|
|
|
|
return NULL;
|
|
|
|
if ((v = newtupleobject(n)) == NULL)
|
|
|
|
return NULL;
|
|
|
|
for (i = 0; i < n; i++) {
|
|
|
|
object *w = do_mkvalue(p_format, p_va);
|
|
|
|
if (w == NULL) {
|
|
|
|
DECREF(v);
|
|
|
|
return NULL;
|
|
|
|
}
|
|
|
|
settupleitem(v, i, w);
|
|
|
|
}
|
|
|
|
if (v != NULL && **p_format != endchar) {
|
|
|
|
DECREF(v);
|
|
|
|
v = NULL;
|
|
|
|
err_setstr(SystemError, "Unmatched paren in format");
|
|
|
|
}
|
|
|
|
else if (endchar)
|
|
|
|
++*p_format;
|
|
|
|
return v;
|
|
|
|
}
|
|
|
|
|
|
|
|
static object *
|
1992-05-15 08:04:59 -03:00
|
|
|
do_mkvalue(p_format, p_va)
|
|
|
|
char **p_format;
|
|
|
|
va_list *p_va;
|
|
|
|
{
|
1992-04-13 07:48:55 -03:00
|
|
|
|
|
|
|
switch (*(*p_format)++) {
|
|
|
|
|
|
|
|
case '(':
|
1992-04-13 12:53:41 -03:00
|
|
|
return do_mktuple(p_format, p_va, ')',
|
|
|
|
countformat(*p_format, ')'));
|
1993-03-16 08:15:04 -04:00
|
|
|
|
1992-04-13 12:53:41 -03:00
|
|
|
case 'b':
|
1992-04-13 07:48:55 -03:00
|
|
|
case 'h':
|
|
|
|
case 'i':
|
1992-04-13 12:53:41 -03:00
|
|
|
return newintobject((long)va_arg(*p_va, int));
|
1992-04-13 07:48:55 -03:00
|
|
|
|
|
|
|
case 'l':
|
1992-04-13 12:53:41 -03:00
|
|
|
return newintobject((long)va_arg(*p_va, long));
|
1992-04-13 07:48:55 -03:00
|
|
|
|
|
|
|
case 'f':
|
|
|
|
case 'd':
|
1994-08-30 05:27:36 -03:00
|
|
|
return newfloatobject((double)va_arg(*p_va, va_double));
|
1993-03-16 08:15:04 -04:00
|
|
|
|
1992-04-13 12:53:41 -03:00
|
|
|
case 'c':
|
|
|
|
{
|
|
|
|
char p[1];
|
|
|
|
p[0] = va_arg(*p_va, int);
|
|
|
|
return newsizedstringobject(p, 1);
|
|
|
|
}
|
1992-04-13 07:48:55 -03:00
|
|
|
|
|
|
|
case 's':
|
|
|
|
case 'z':
|
|
|
|
{
|
1992-04-13 12:53:41 -03:00
|
|
|
object *v;
|
1992-04-13 07:48:55 -03:00
|
|
|
char *str = va_arg(*p_va, char *);
|
|
|
|
int n;
|
|
|
|
if (**p_format == '#') {
|
|
|
|
++*p_format;
|
|
|
|
n = va_arg(*p_va, int);
|
|
|
|
}
|
|
|
|
else
|
|
|
|
n = -1;
|
|
|
|
if (str == NULL) {
|
|
|
|
v = None;
|
|
|
|
INCREF(v);
|
|
|
|
}
|
|
|
|
else {
|
|
|
|
if (n < 0)
|
|
|
|
n = strlen(str);
|
|
|
|
v = newsizedstringobject(str, n);
|
|
|
|
}
|
1992-04-13 12:53:41 -03:00
|
|
|
return v;
|
1992-04-13 07:48:55 -03:00
|
|
|
}
|
|
|
|
|
|
|
|
case 'S':
|
|
|
|
case 'O':
|
1992-04-13 12:53:41 -03:00
|
|
|
{
|
|
|
|
object *v;
|
|
|
|
v = va_arg(*p_va, object *);
|
|
|
|
if (v != NULL)
|
|
|
|
INCREF(v);
|
|
|
|
else if (!err_occurred())
|
|
|
|
/* If a NULL was passed because a call
|
|
|
|
that should have constructed a value
|
|
|
|
failed, that's OK, and we pass the error
|
|
|
|
on; but if no error occurred it's not
|
|
|
|
clear that the caller knew what she
|
|
|
|
was doing. */
|
|
|
|
err_setstr(SystemError,
|
|
|
|
"NULL object passed to mkvalue");
|
|
|
|
return v;
|
1992-04-13 07:48:55 -03:00
|
|
|
}
|
|
|
|
|
|
|
|
default:
|
|
|
|
err_setstr(SystemError, "bad format char passed to mkvalue");
|
1992-04-13 12:53:41 -03:00
|
|
|
return NULL;
|
1992-04-13 07:48:55 -03:00
|
|
|
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
1994-08-30 05:27:36 -03:00
|
|
|
#ifdef HAVE_STDARG_PROTOTYPES
|
1992-04-13 12:53:41 -03:00
|
|
|
/* VARARGS 2 */
|
|
|
|
object *mkvalue(char *format, ...)
|
|
|
|
#else
|
|
|
|
/* VARARGS */
|
|
|
|
object *mkvalue(va_alist) va_dcl
|
|
|
|
#endif
|
1992-04-13 07:48:55 -03:00
|
|
|
{
|
1992-04-13 12:53:41 -03:00
|
|
|
va_list va;
|
|
|
|
object* retval;
|
1994-08-30 05:27:36 -03:00
|
|
|
#ifdef HAVE_STDARG_PROTOTYPES
|
1992-04-13 12:53:41 -03:00
|
|
|
va_start(va, format);
|
|
|
|
#else
|
|
|
|
char *format;
|
|
|
|
va_start(va);
|
|
|
|
format = va_arg(va, char *);
|
|
|
|
#endif
|
1993-03-16 08:15:04 -04:00
|
|
|
retval = vmkvalue(format, va);
|
1992-04-13 12:53:41 -03:00
|
|
|
va_end(va);
|
|
|
|
return retval;
|
1992-04-13 07:48:55 -03:00
|
|
|
}
|
1993-03-16 08:15:04 -04:00
|
|
|
|
|
|
|
object *
|
|
|
|
vmkvalue(format, va)
|
|
|
|
char *format;
|
|
|
|
va_list va;
|
|
|
|
{
|
|
|
|
char *f = format;
|
|
|
|
int n = countformat(f, '\0');
|
|
|
|
if (n < 0)
|
|
|
|
return NULL;
|
|
|
|
if (n == 0) {
|
|
|
|
INCREF(None);
|
|
|
|
return None;
|
|
|
|
}
|
|
|
|
if (n == 1)
|
|
|
|
return do_mkvalue(&f, &va);
|
|
|
|
return do_mktuple(&f, &va, '\0', n);
|
|
|
|
}
|