This is callin.c in view mode; [Download] [Up]
/***********************************************************************
*
* C Callin facility
*
* This module provides the routines necessary to allow C code to
* invoke Smalltalk messages on objects.
*
* $Revision: 1.5 $
* $Date: 1995/09/12 04:34:44 $
* $Author: sbb $
*
***********************************************************************/
/***********************************************************************
*
* Copyright (C) 1990, 1991, 1992, 1994, 1995 Free Software Foundation, Inc.
* Written by Steve Byrne.
*
* This file is part of GNU Smalltalk.
*
* GNU Smalltalk is free software; you can redistribute it and/or modify it
* under the terms of the GNU General Public License as published by the Free
* Software Foundation; either version 1, or (at your option) any later
* version.
*
* GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
* more details.
*
* You should have received a copy of the GNU General Public License along with
* GNU Smalltalk; see the file COPYING. If not, write to the Free Software
* Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
*
***********************************************************************/
/*
* Change Log
* ============================================================================
* Author Date Change
* sbb 9 Sep 95 Added incubator usage.
*
* sbb 9 Jul 95 Fixed to include correct header files.
*
* sbb 6 Jun 95 Switched to new file naming scheme.
*
* sbb 19 Mar 94 Added %t and %T for more direct control over types.
* Also, added typeNameToOOP for mapping string type
* names to actual CType subclass instances.
*
* sbb 1 Jan 92 Fixed to auto-initialize Smalltalk when the public
* routines are invoked.
*
* sbb 31 Dec 91 Created.
*
*/
#include "gst.h"
#include "lib.h"
#include "interp.h"
#include "callin.h"
#include "dict.h"
#include "sym.h"
#include "oop.h"
#include "comp.h"
#include "lex.h"
#include <stdio.h>
#if STDC_HEADERS
#include <stdlib.h>
#endif /* STDC_HEADERS */
#if defined(HAVE_STDARG_H)
# include <stdarg.h>
#else
# include <varargs.h>
#endif
/* Simple control over oop registry size */
#define INITIAL_REGISTRY_SIZE 100
extern int yyparse();
/*
* The registry of OOPs which have been passed to C code. A vector of
* of oops, running from 0 to registryIndex, some of which may be nilOOP.
* the current allocated size of the registry is registrySize, and the
* registry may be reallocated to a larger size as need. The registry
* is examined at GC time to ensure that OOPs that C code knows about don't
* go away. "C code" here means user level C code, not Smalltalk internal
* code.
*/
static OOP *oopRegistry;
static int registrySize, registryIndex;
#if defined(HAVE_STDARG_H)
OOP msgSend __P ((OOP receiver, OOP selector __DOTS))
#else
OOP msgSend(va_alist)
va_dcl
#endif
{
va_list args;
#if !defined(HAVE_STDARG_H)
OOP receiver, selector;
#endif
OOP anArg, result;
int numArgs;
#if defined(HAVE_STDARG_H)
va_start(args, selector);
#else
va_start(args);
#endif
if (!smalltalkInitialized) { initSmalltalk(); }
#if !defined(HAVE_STDARG_H)
receiver = va_arg(args, OOP);
selector = va_arg(args, OOP);
#endif
/* These objects don't need to be incubated because they are being
* pushed onto the Smalltalk stack which will make them visible to the GC
*/
prepareExecutionEnvironment();
pushOOP(receiver);
for (numArgs = 0; (anArg = va_arg(args, OOP)) != nil; numArgs++) {
pushOOP(anArg);
}
sendMessage(selector, numArgs, false);
interpret();
result = popOOP();
finishExecutionEnvironment();
return (result);
}
#if defined(HAVE_STDARG_H)
OOP strMsgSend __P((OOP receiver __DOTS))
#else
OOP strMsgSend(va_alist)
va_dcl
#endif
{
va_list args;
#if !defined(HAVE_STDARG_H)
OOP receiver;
#endif
OOP selector, anArg, result;
int numArgs;
IncPtr incPtr;
#if defined(HAVE_STDARG_H)
va_start(args, receiver);
#else
va_start(args);
#endif
if (!smalltalkInitialized) { initSmalltalk(); }
#if !defined(HAVE_STDARG_H)
receiver = va_arg(args, OOP);
#endif
selector = internString(va_arg(args, char *));
/* It's possible (there is an existing case) that in sendMessage a GC can
occur, and selector is not protected */
incPtr = incSavePointer();
incAddOOP(selector);
prepareExecutionEnvironment();
pushOOP(receiver);
for (numArgs = 0; (anArg = va_arg(args, OOP)) != nil; numArgs++) {
pushOOP(anArg);
}
sendMessage(selector, numArgs, false);
interpret();
result = popOOP();
finishExecutionEnvironment();
incRestorePointer(incPtr);
return (result);
}
#ifdef looks_goofy_to_me /* Tue Dec 31 20:41:01 1991 */
/**/voidPtr cMsgSend(va_alist)
/**/va_dcl
/**/{
/**/ va_list args;
/**/ OOP receiver, selector, anArg, result;
/**/ int numArgs, bool;
/**/ char *argStr, *s;
/**/ union {
/**/ voidPtr v;
/**/ float f;
/**/ } conv;
/**/
/**/ va_start(args);
/**/
/**/ argStr = va_arg(args, char *);
/**/ selector = internString(va_arg(args, char *));
/**/
/**/ prepareExecutionEnvironment();
/**/
/**/ s = argStr + 2; /* <type>= */
/**/ for (numArgs = -1; *s; numArgs++, s++) {
/**/ switch (*s) {
/**/ case 'i':
/**/ pushInt(va_arg(args, long));
/**/ break;
/**/
/**/ case 'f':
/**/ anArg = floatNew(va_arg(args, double));
/**/ pushOOP(anArg);
/**/ break;
/**/
/**/ case 'b':
/**/ if (va_arg(args, int)) {
/**/ pushOOP(trueOOP);
/**/ } else {
/**/ pushOOP(falseOOP);
/**/ }
/**/ break;
/**/
/**/ case 'c':
/**/ anArg = charOOPAt(va_arg(args, char));
/**/ pushOOP(anArg);
/**/ break;
/**/
/**/ case 'C':
/**/ anArg = cObjectNew(va_arg(args, voidPtr));
/**/ pushOOP(anArg);
/**/ break;
/**/
/**/ case 's':
/**/ anArg = stringNew(va_arg(args, char *));
/**/ pushOOP(anArg);
/**/ break;
/**/
/**/ case 'S':
/**/ anArg = internString(va_arg(args, char *));
/**/ pushOOP(anArg);
/**/ break;
/**/ }
/**/ }
/**/
/**/ sendMessage(selector, numArgs, false);
/**/ interpret();
/**/ result = popOOP();
/**/ finishExecutionEnvironment();
/**/
/**/ switch (*argStr) {
/**/ case 'i':
/**/ return ((voidPtr)toInt(result));
/**/
/**/ case 'c':
/**/ return ((voidPtr)charOOPValue(result));
/**/
/**/ case 'C':
/**/ return (cObjectValue(result));
/**/
/**/ case 's':
/**/ return (toCString(result));
/**/
/**/ case 'b':
/**/ return ((voidPtr)(result == trueOOP));
/**/
/**/ case 'f':
/**/ conv.f = floatOOPValue(result);
/**/ return (conv.v);
/**/
/**/ default:
/**/ return (result);
/**/ }
/**/}
#endif /* looks_goofy_to_me Tue Dec 31 20:41:01 1991 */
/* Use like printf */
#if defined(HAVE_STDARG_H)
void msgSendf __P((voidPtr resultPtr __DOTS))
#else
void msgSendf(va_alist)
va_dcl
#endif
{
va_list args;
OOP selector, anArg, result;
int numArgs;
#if !defined(HAVE_STDARG_H)
voidPtr *resultPtr;
#endif
char *fmt, *fp, *s, selectorBuf[256];
IncPtr incPtr;
#if defined(HAVE_STDARG_H)
va_start(args, resultPtr);
#else
va_start(args);
#endif
if (!smalltalkInitialized) { initSmalltalk(); }
#if !defined(HAVE_STDARG_H)
resultPtr = va_arg(args, voidPtr *);
#endif
fmt = va_arg(args, char *);
incPtr = incSavePointer();
prepareExecutionEnvironment();
numArgs = -1;
for (s = selectorBuf, fp = &fmt[2]; *fp; fp++) {
if (*fp == '%') {
fp++;
numArgs++;
switch (*fp) {
case 'i':
pushInt(va_arg(args, long));
break;
case 'f':
anArg = floatNew(va_arg(args, double));
pushOOP(anArg);
break;
case 'b':
if (va_arg(args, int)) {
pushOOP(trueOOP);
} else {
pushOOP(falseOOP);
}
break;
case 'c':
anArg = charOOPAt(va_arg(args, char));
pushOOP(anArg);
break;
case 'C':
anArg = cObjectNew(va_arg(args, voidPtr));
pushOOP(anArg);
break;
case 's':
anArg = stringNew(va_arg(args, char *));
pushOOP(anArg);
break;
case 'S':
anArg = internString(va_arg(args, char *));
pushOOP(anArg);
break;
case 'o':
anArg = va_arg(args, OOP);
pushOOP(anArg);
break;
case 't': /* type string, followed by a void * */
{
OOP ctype;
ctype = typeNameToOOP(va_arg(args, char *));
incAddOOP(ctype);
printf("before sp = %x\n", sp);
anArg = cObjectNewTyped(va_arg(args, voidPtr), ctype);
pushOOP(anArg);
printf("type object: "); printObject(anArg);
printf("sp = %x\n", sp);
}
break;
case 'T': /* existing type instance */
{
OOP ctype;
ctype = va_arg(args, OOP);
anArg = cObjectNewTyped(va_arg(args, voidPtr), ctype);
pushOOP(anArg);
}
break;
case '%':
*s++ = '%';
numArgs--;
break;
}
} else if (*fp != ' ' && *fp != '\t') {
*s++ = *fp;
}
}
*s = '\0';
selector = internString(selectorBuf);
incAddOOP(selector); /* not automatically protected! */
sendMessage(selector, numArgs, false);
interpret();
result = popOOP();
finishExecutionEnvironment();
if (resultPtr) {
switch (fmt[1]) {
case 'i':
*(int *)resultPtr = toInt(result);
break;
case 'c':
*(char *)resultPtr = charOOPValue(result);
break;
case 'C':
/* !!! Fix this -- it is ugly, but OS/2 compilers don't like it without */
*(voidPtr *)resultPtr = cObjectValue(result);
break;
case 's':
*(char **)resultPtr = (char *)toCString(result);
break;
case 'b':
*(int *)resultPtr = (result == trueOOP);
break;
case 'f':
*(double *)resultPtr = floatOOPValue(result);
break;
case 'v': /* don't care about the result */
break; /* "v" for "void" */
case 'o':
default:
*(OOP *)resultPtr = result;
break;
}
}
incRestorePointer(incPtr);
}
OOP
typeNameToOOP(name)
char *name;
{
OOP result;
char buf[300];
sprintf(buf, "^%s!", name);
result = evalExpr(buf);
return (result);
}
void evalCode(str)
char *str;
{
if (!smalltalkInitialized) { initSmalltalk(); }
prepareExecutionEnvironment();
initLexer(false);
pushCString(str);
yyparse();
popStream(false);
finishExecutionEnvironment();
}
/*
* OOP evalExpr(str)
*
* Description
*
* Evaluate a single Smalltalk expression and return the result.
*
* Inputs
*
* str : A Smalltalk method body. Can have local variables, but no
* parameters. This is much like the immediate expression
* evaluation that the command interpreter provides.
*
* Outputs
*
*
*/
OOP evalExpr(str)
char *str;
{
OOP result;
if (!smalltalkInitialized) { initSmalltalk(); }
/* !!! not done yet */
/* not clear that prepare/finish is needed, since the evaluation
* of the expression will already do this
*/
/* prepareExecutionEnvironment(); */
initLexer(false);
pushCString(str);
yyparse();
popStream(false);
/* result = finishExecutionEnvironment(); */
/* finishExecutionEnvironment(); see comment above*/
result = lastReturnedValue;
return (result);
}
/***********************************************************************
*
* Conversion *to* Smalltalk datatypes routines
*
***********************************************************************/
OOP intToOOP(i)
long i;
{
if (!smalltalkInitialized) { initSmalltalk(); }
return (fromInt(i));
}
OOP floatToOOP(f)
double f;
{
return (registerOOP(floatNew(f)));
}
OOP boolToOOP(b)
int b;
{
if (!smalltalkInitialized) { initSmalltalk(); }
if (b) {
return (trueOOP);
} else {
return (falseOOP);
}
}
OOP charToOOP(c)
char c;
{
if (!smalltalkInitialized) { initSmalltalk(); }
return (charOOPAt(c));
}
/* !!! Add in byteArray support sometime soon */
OOP stringToOOP(str)
char *str;
{
if (!smalltalkInitialized) { initSmalltalk(); }
if (str == nil) {
return (nilOOP);
} else {
return (registerOOP(stringNew(str)));
}
}
OOP symbolToOOP(str)
char *str;
{
if (!smalltalkInitialized) { initSmalltalk(); }
if (str == nil) {
return (nilOOP);
} else {
/* Symbols don't get freed, so the new OOP doesn't need to be registered */
return (internString(str));
}
}
OOP cObjectToOOP(co)
voidPtr co;
{
if (!smalltalkInitialized) { initSmalltalk(); }
if (co == nil) {
return (nilOOP);
} else {
return (registerOOP(cObjectNew(co)));
}
}
/***********************************************************************
*
* Conversion *from* Smalltalk datatypes routines
*
***********************************************************************/
/* ### need a type inquiry routine */
long OOPToInt(oop)
OOP oop;
{
if (!smalltalkInitialized) { initSmalltalk(); }
return (toInt(oop));
}
double OOPToFloat(oop)
OOP oop;
{
if (!smalltalkInitialized) { initSmalltalk(); }
return (floatOOPValue(oop));
}
int OOPToBool(oop)
OOP oop;
{
if (!smalltalkInitialized) { initSmalltalk(); }
return (oop == trueOOP);
}
char OOPToChar(oop)
OOP oop;
{
if (!smalltalkInitialized) { initSmalltalk(); }
return (charOOPValue(oop));
}
char *OOPToString(oop)
OOP oop;
{
if (!smalltalkInitialized) { initSmalltalk(); }
if (isNil(oop)) {
return (nil);
} else {
return ((char *)toCString(oop));
}
}
/* !!! add in byteArray support soon */
voidPtr OOPToCObject(oop)
OOP oop;
{
if (!smalltalkInitialized) { initSmalltalk(); }
if (isNil(oop)) {
return (nil);
} else {
return (cObjectValue(oop));
}
}
/***********************************************************************
*
* Bookkeeping routines
*
***********************************************************************/
void initOOPRegistry()
{
oopRegistry = (OOP *)malloc(INITIAL_REGISTRY_SIZE * sizeof(OOP));
registrySize = INITIAL_REGISTRY_SIZE;
registryIndex = 0;
}
OOP registerOOP(oop)
OOP oop;
{
if (!smalltalkInitialized) { initSmalltalk(); }
if (registryIndex >= registrySize) {
registrySize += INITIAL_REGISTRY_SIZE;
oopRegistry = (OOP *)realloc(oopRegistry, registrySize * sizeof(OOP));
}
oopRegistry[registryIndex++] = oop;
return (oop);
}
void unregisterOOP(oop)
OOP oop;
{
int i;
if (!smalltalkInitialized) { initSmalltalk(); }
for (i = 0; i < registryIndex; i++) {
if (oopRegistry[i] == oop) {
oopRegistry[i] = nilOOP;
}
}
}
/*
* void markRegisteredOOPs()
*
* Description
*
* Called at gcFlip time, marks registered objects
* and compresses out unregistered objects.
*
*/
void markRegisteredOOPs()
{
int maxIndex, i;
OOP oop;
maxIndex = 0;
for (i = 0; i < registryIndex; i++) {
oop = oopRegistry[i];
if (!isNil(oop)) {
oopRegistry[maxIndex++] = oop;
maybeMarkOOP(oop);
}
}
registryIndex = maxIndex;
}
#ifdef pre_sc_gc /* Sat Jun 17 16:57:33 1995 */
/**//*
/**/ * void copyRegisteredOOPs()
/**/ *
/**/ * Description
/**/ *
/**/ * Called at gcFlip time, copies registered objects to the new space,
/**/ * and compresses out unregistered objects and those which are duplicates.
/**/ *
/**/ */
/**/void copyRegisteredOOPs()
/**/{
/**/ int maxIndex, i;
/**/ OOP oop;
/**/
/**/ maxIndex = 0;
/**/ for (i = 0; i < registryIndex; i++) {
/**/ oop = oopRegistry[i];
/**/ if (!isNil(oop) && inFromSpace(oop)) {
/**/ oopRegistry[maxIndex++] = oop;
/**/ localMaybeMoveOOP(oop);
/**/ }
/**/ }
/**/
/**/ registryIndex = maxIndex;
/**/}
#endif /* pre_sc_gc Sat Jun 17 16:57:33 1995 */
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.