home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Club Amiga de Montreal - CAM
/
CAM_CD_1.iso
/
files
/
116.lha
/
SmallTalk
/
Sources
/
PRIMITIVE.C
< prev
next >
Wrap
C/C++ Source or Header
|
1986-11-20
|
15KB
|
635 lines
/*
Little Smalltalk, version 2
Written by Tim Budd, Oregon State University, July 1987
Primitive processor
primitives are how actions are ultimately executed in the Smalltalk
system.
unlike ST-80, Little Smalltalk primitives cannot fail (although
they can return nil, and methods can take this as an indication
of failure). In this respect primitives in Little Smalltalk are
much more like traditional system calls.
Primitives are combined into groups of 10 according to
argument count and type, and in some cases type checking is performed.
IMPORTANT NOTE:
The technique used to tell if an arithmetic operation
has overflowed in intBinary() depends upon integers
being 16 bits. If this is not true, other techniques
may be required.
*/
# include <stdio.h>
# include <math.h>
# include "env.h"
# include "memory.h"
# include "names.h"
# include "process.h"
# ifdef STRING
# include <string.h>
# endif
# ifdef STRINGS
# include <strings.h>
# endif
# define normalresult 1
# define counterror 2
# define typeerror 3
# define quitinterp 4
extern object doInterp(OBJ);
extern noreturn flushMessageCache();
extern double modf();
extern char *getenv();
static int zeroaryPrims(number)
int number;
{ short i;
returnedObject = nilobj;
switch(number) {
case 2:
flushMessageCache();
break;
case 3: /* return a random number */
/* this is hacked because of the representation */
/* of integers as shorts */
i = rand() >> 8; /* strip off lower bits */
if (i < 0) i = - i;
returnedObject = newInteger(i>>1);
break;
default: /* unknown primitive */
sysError("unknown primitive","zeroargPrims");
break;
}
return(normalresult);
}
static int unaryPrims(number, firstarg)
int number;
object firstarg;
{
returnedObject = firstarg;
switch(number) {
case 1: /* class of object */
returnedObject = getClass(firstarg);
break;
case 2: /* basic size of object */
if (isInteger(firstarg))
returnedObject = newInteger(0);
else
returnedObject = newInteger(objectSize(firstarg));
break;
case 3: /* hash value of object */
if (isInteger(firstarg))
returnedObject = firstarg;
else
returnedObject = newInteger(firstarg);
break;
case 9: /* interpreter bytecodes */
returnedObject = doInterp(firstarg);
break;
default: /* unknown primitive */
sysError("unknown primitive","unaryPrims");
break;
}
return(normalresult);
}
static int binaryPrims(number, firstarg, secondarg)
int number;
object firstarg, secondarg;
{ char buffer[512];
int i;
returnedObject = firstarg;
switch(number) {
case 1: /* object identity test */
if (firstarg == secondarg)
returnedObject = trueobj;
else
returnedObject = falseobj;
break;
case 2: /* set class of object */
decr(classField(firstarg));
setClass(firstarg, secondarg);
returnedObject = firstarg;
break;
case 4: /* string cat */
ignore strcpy(buffer, charPtr(firstarg));
ignore strcat(buffer, charPtr(secondarg));
returnedObject = newStString(buffer);
break;
case 5: /* basicAt: */
if (! isInteger(secondarg))
sysError("non integer index","basicAt:");
returnedObject = basicAt(firstarg, intValue(secondarg));
break;
case 6: /* byteAt: */
if (! isInteger(secondarg))
sysError("non integer index","bytAte:");
i = byteAt(firstarg, intValue(secondarg));
if (i < 0) i += 256;
returnedObject = newInteger(i);
break;
default: /* unknown primitive */
sysError("unknown primitive","binaryPrims");
break;
}
return(normalresult);
}
static int trinaryPrims(number, firstarg, secondarg, thirdarg)
int number;
object firstarg, secondarg, thirdarg;
{ char *bp, *tp, buffer[256];
int i, j;
returnedObject = firstarg;
switch(number) {
case 1: /* basicAt:Put: */
if (! isInteger(secondarg))
sysError("non integer index","basicAtPut");
basicAtPut(firstarg, intValue(secondarg), thirdarg);
break;
case 2: /* basicAt:Put: for bytes */
if (! isInteger(secondarg))
sysError("non integer index","byteAtPut");
if (! isInteger(thirdarg))
sysError("assigning non int","to byte");
byteAtPut(firstarg, intValue(secondarg),
intValue(thirdarg));
break;
case 3: /* string copyFrom:to: */
bp = charPtr(firstarg);
if ((! isInteger(secondarg)) || (! isInteger(thirdarg)))
sysError("non integer index","copyFromTo");
i = intValue(secondarg);
j = intValue(thirdarg);
tp = buffer;
if (i <= strlen(bp))
for ( ; (i <= j) && bp[i-1]; i++)
*tp++ = bp[i-1];
*tp = '\0';
returnedObject = newStString(buffer);
break;
case 8: /* execute a context */
messageToSend = firstarg;
if (! isInteger(secondarg))
sysError("non integer index","executeAt:");
argumentsOnStack = intValue(secondarg);
creator = thirdarg;
finalTask = ContextExecuteTask;
return(quitinterp);
case 9: /* compile method */
setInstanceVariables(firstarg);
if (parse(thirdarg, charPtr(secondarg)))
returnedObject = trueobj;
else
returnedObject = falseobj;
break;
default: /* unknown primitive */
sysError("unknown primitive","trinaryPrims");
break;
}
return(normalresult);
}
static int intUnary(number, firstarg)
int number, firstarg;
{ char buffer[20];
switch(number) {
case 1: /* float equiv of integer */
returnedObject = newFloat((double) firstarg);
break;
case 5: /* set random number */
ignore srand((unsigned) firstarg);
returnedObject = nilobj;
break;
case 7: /* string equiv of number */
ignore sprintf(buffer,"%d",firstarg);
returnedObject = newStString(buffer);
break;
case 8:
returnedObject = allocObject(firstarg);
break;
case 9:
returnedObject = allocByte(firstarg);
break;
default:
sysError("intUnary primitive","not implemented yet");
}
return(normalresult);
}
int intBinary(number, firstarg, secondarg)
register int firstarg, secondarg;
int number;
{ boolean binresult;
long longresult;
switch(number) {
case 0: /* addition */
longresult = firstarg;
longresult += secondarg;
if (longCanBeInt(longresult))
firstarg = longresult;
else
goto overflow;
break;
case 1: /* subtraction */
longresult = firstarg;
longresult -= secondarg;
if (longCanBeInt(longresult))
firstarg = longresult;
else
goto overflow;
break;
case 2: /* relationals */
binresult = firstarg < secondarg; break;
case 3:
binresult = firstarg > secondarg; break;
case 4:
binresult = firstarg <= secondarg; break;
case 5:
binresult = firstarg >= secondarg; break;
case 6:
binresult = firstarg == secondarg; break;
case 7:
binresult = firstarg != secondarg; break;
case 8: /* multiplication */
longresult = firstarg;
longresult *= secondarg;
if (longCanBeInt(longresult))
firstarg = longresult;
else
goto overflow;
break;
case 9: /* quo: */
if (secondarg == 0) goto overflow;
firstarg /= secondarg; break;
case 10: /* rem: */
if (secondarg == 0) goto overflow;
firstarg %= secondarg; break;
case 11: /* bit operations */
firstarg &= secondarg; break;
case 12:
firstarg ^= secondarg; break;
case 19: /* shifts */
if (secondarg < 0)
firstarg >>= (- secondarg);
else
firstarg <<= secondarg;
break;
}
if ((number >= 2) && (number <= 7))
if (binresult)
returnedObject = trueobj;
else
returnedObject = falseobj;
else
returnedObject = newInteger(firstarg);
return(normalresult);
/* on overflow, return nil and let smalltalk code */
/* figure out what to do */
overflow:
returnedObject = nilobj;
return(normalresult);
}
static int strUnary(number, firstargument)
int number;
char *firstargument;
{
switch(number) {
case 1: /* length of string */
returnedObject = newInteger(strlen(firstargument));
break;
case 3: /* string as symbol */
returnedObject = newSymbol(firstargument);
break;
case 8: /* do a system call */
returnedObject = newInteger(system(firstargument));
break;
default:
sysError("unknown primitive", "strUnary");
break;
}
return(normalresult);
}
static int floatUnary(number, firstarg)
int number;
double firstarg;
{ char buffer[20];
double temp;
switch(number) {
case 1: /* asString */
ignore sprintf(buffer,"%g", firstarg);
returnedObject = newStString(buffer);
break;
case 2: /* log */
returnedObject = newFloat(log(firstarg));
break;
case 3: /* exp */
returnedObject = newFloat(exp(firstarg));
break;
case 4: /* sqrt */
returnedObject = newFloat(sqrt(firstarg));
break;
case 6: /* integer part */
ignore modf(firstarg, &temp);
returnedObject = newInteger((int) temp);
break;
default:
sysError("unknown primitive","floatUnary");
break;
}
return(normalresult);
}
int floatBinary(number, first, second)
int number;
double first, second;
{ boolean binResult;
switch(number) {
case 0: first += second; break;
case 1: first -= second; break;
case 2: binResult = (first < second); break;
case 3: binResult = (first > second); break;
case 4: binResult = (first <= second); break;
case 5: binResult = (first >= second); break;
case 6: binResult = (first == second); break;
case 7: binResult = (first != second); break;
case 8: first *= second; break;
case 9: first /= second; break;
default:
sysError("unknown primitive", "floatBinary");
break;
}
if ((number >= 2) && (number <= 7))
if (binResult)
returnedObject = trueobj;
else
returnedObject = falseobj;
else
returnedObject = newFloat(first);
return(normalresult);
}
/* file primitives - necessaryily rather UNIX dependent;
basically, files are all kept in a large array.
File operations then just give an index into this array
*/
# define MAXFILES 20
/* we assume this is initialized to NULL */
static FILE *filepointers[MAXFILES];
static int filePrimitive(number, arguments, size)
int number, size;
object *arguments;
{ int i;
char *p, buffer[512];
returnedObject = nilobj;
if (number) { /* not an open, we can get file number*/
if (! isInteger(arguments[0]))
return(typeerror);
i = intValue(arguments[0]);
}
switch(number) {
case 0: /* file open */
/* first find a free slot */
for (i = 0; i < MAXFILES; i++)
if (filepointers[i] == NULL)
break;
if (i >= MAXFILES)
sysError("too many open files","primitive");
p = charPtr(arguments[0]);
if (streq(p, "stdin"))
filepointers[i] = stdin;
else if (streq(p, "stdout"))
filepointers[i] = stdout;
else if (streq(p, "stderr"))
filepointers[i] = stderr;
else {
filepointers[i] = fopen(p, charPtr(arguments[1]));
}
if (filepointers[i] == NULL)
returnedObject = nilobj;
else
returnedObject = newInteger(i);
break;
case 1: /* file close - recover slot */
ignore fclose(filepointers[i]);
filepointers[i] = NULL;
break;
case 2: /* file size */
case 3: /* file seek */
case 4: /* get character */
sysError("file operation not implemented yet","");
case 5: /* get string */
if (fgets(buffer, 512, filepointers[i]) != NULL) {
if (filepointers[i] == stdin) {
/* delete the newline */
i = strlen(buffer);
if (buffer[i-1] == '\n')
buffer[i-1] = '\0';
}
returnedObject = newStString(buffer);
}
break;
case 7: /* write an object image */
imageWrite(filepointers[i]);
returnedObject = trueobj;
break;
case 8: /* print no return */
case 9: /* print string */
ignore fputs(charPtr(arguments[1]), filepointers[i]);
if (number == 8)
ignore fflush(filepointers[i]);
else
ignore fputc('\n', filepointers[i]);
break;
default:
sysError("unknown primitive","filePrimitive");
}
return(normalresult);
}
/* primitive -
the main driver for the primitive handler
*/
boolean primitive(primitiveNumber, arguments, size)
int primitiveNumber, size;
object *arguments;
{ int primitiveGroup;
boolean done = false;
int response;
primitiveGroup = primitiveNumber / 10;
response = normalresult;
switch(primitiveGroup) {
case 0: case 1: case 2: case 3:
if (size != primitiveGroup)
response = counterror;
else {
switch(primitiveGroup) {
case 0:
response = zeroaryPrims(primitiveNumber);
break;
case 1:
response = unaryPrims(primitiveNumber - 10, arguments[0]);
break;
case 2:
response = binaryPrims(primitiveNumber-20, arguments[0], arguments[1]);
break;
case 3:
response = trinaryPrims(primitiveNumber-30, arguments[0], arguments[1], arguments[2]);
break;
}
}
break;
case 5: /* integer unary operations */
if (size != 1)
response = counterror;
else if (! isInteger(arguments[0]))
response = typeerror;
else
response = intUnary(primitiveNumber-50,
intValue(arguments[0]));
break;
case 6: case 7: /* integer binary operations */
if (size != 2)
response = counterror;
else if ((! isInteger(arguments[0])) ||
! isInteger(arguments[1]))
response = typeerror;
else
response = intBinary(primitiveNumber-60,
intValue(arguments[0]),
intValue(arguments[1]));
break;
case 8: /* string unary */
if (size != 1)
response = counterror;
else if (! isString(arguments[0]))
response = typeerror;
else
response = strUnary(primitiveNumber-80,
charPtr(arguments[0]));
break;
case 10: /* float unary */
if (size != 1)
response = counterror;
else if (! isFloat(arguments[0]))
response = typeerror;
else
response = floatUnary(primitiveNumber-100,
floatValue(arguments[0]));
break;
case 11: /* float binary */
if (size != 2)
response = counterror;
else if ((! isFloat(arguments[0])) ||
(! isFloat(arguments[1])))
response = typeerror;
else
response = floatBinary(primitiveNumber-110,
floatValue(arguments[0]),
floatValue(arguments[1]));
break;
case 12: /* file operations */
response = filePrimitive(primitiveNumber-120,
arguments, size);
break;
}
/* now check return code */
switch(response) {
case normalresult:
break;
case quitinterp:
done = true;
break;
case counterror:
sysError("count error","in primitive");
break;
case typeerror:
sysError("type error","in primitive");
returnedObject = nilobj;
break;
default:
sysError("unknown return code","in primitive");
returnedObject = nilobj;
break;
}
return (done);
}