home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fresh Fish 5
/
FreshFish_July-August1994.bin
/
bbs
/
dev
/
alst-3.04.lha
/
ALSt-3.04
/
src
/
primitive.c
< prev
next >
Wrap
C/C++ Source or Header
|
1994-05-14
|
16KB
|
663 lines
/*
Little Smalltalk, version 3
Written by Tim Budd, Oregon State University, July 1988
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.
system specific I/O primitives are found in a different file.
*/
# include <stdio.h>
# include <math.h>
# include "env.h"
# include "memory.h"
# include "names.h"
# ifdef STRING
# include <string.h>
# endif
# ifdef STRINGS
# include <strings.h>
# endif
# ifdef SIGNAL
# include <signal.h>
# include <setjmp.h>
# endif
# ifdef CTRLBRK
# include <dos.h>
# include <signal.h>
# include <setjmp.h>
# endif
extern object processStack;
extern int linkPointer;
#ifdef AZTEC_C
extern double frexp(double, int *), ldexp(double, int);
#else
extern double frexp(), ldexp();
#endif
extern long time();
extern object ioPrimitive(INT X OBJP);
extern object sysPrimitive(INT X OBJP);
# ifdef SIGNAL
static jmp_buf jb;
brkfun() { longjmp(jb, 1); }
brkignore() {;}
# endif
# ifdef CTRLBRK
static jmp_buf jb;
brkfun() { longjmp(jb, 1); }
brkignore() {;}
# endif
static object zeroaryPrims(number)
int number;
{ short i;
object returnedObject;
int objectCount();
returnedObject = nilobj;
switch(number) {
case 1:
fprintf(stderr,"did primitive 1\n");
break;
case 2:
fprintf(stderr,"object count %d\n", objectCount());
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;
case 4: /* return time in seconds */
i = (short) time((long *) 0);
returnedObject = newInteger(i);
break;
case 5: /* flip watch - done in interp */
break;
case 9:
exit(0);
default: /* unknown primitive */
sysError("unknown primitive","zeroargPrims");
break;
}
return(returnedObject);
}
static int unaryPrims(number, firstarg)
int number;
object firstarg;
{ int i, j, saveLinkPointer;
object returnedObject, saveProcessStack;
returnedObject = firstarg;
switch(number) {
case 1: /* class of object */
returnedObject = getClass(firstarg);
break;
case 2: /* basic size of object */
if (isInteger(firstarg))
i = 0;
else {
i = sizeField(firstarg);
/* byte objects have negative size */
if (i < 0) i = (-i);
}
returnedObject = newInteger(i);
break;
case 3: /* hash value of object */
if (isInteger(firstarg))
returnedObject = firstarg;
else
returnedObject = newInteger(firstarg);
break;
case 4: /* debugging print */
fprintf(stderr,"primitive 14 %d\n", firstarg);
break;
case 8: /* change return point - block return */
/* first get previous link pointer */
i = intValue(basicAt(processStack, linkPointer));
/* then creating context pointer */
j = intValue(basicAt(firstarg, 1));
if (basicAt(processStack, j+1) != firstarg) {
returnedObject = falseobj;
break;
}
/* first change link pointer to that of creator */
fieldAtPut(processStack, i,
basicAt(processStack, j));
/* then change return point to that of creator */
fieldAtPut(processStack, i+2,
basicAt(processStack, j+2));
returnedObject = trueobj;
break;
case 9: /* process execute */
/* first save the values we are about to clobber */
saveProcessStack = processStack;
saveLinkPointer = linkPointer;
# ifdef SIGNAL
/* trap control-C */
signal(SIGINT, brkfun);
if (setjmp(jb)) {
returnedObject = falseobj;
}
else
# endif
# ifdef CRTLBRK
/* trap control-C using dos ctrlbrk routine */
ctrlbrk(brkfun);
if (setjmp(jb)) {
returnedObject = falseobj;
}
else
# endif
if (execute(firstarg, 5000))
returnedObject = trueobj;
else
returnedObject = falseobj;
/* then restore previous environment */
processStack = saveProcessStack;
linkPointer = saveLinkPointer;
# ifdef SIGNAL
signal(SIGINT, brkignore);
# endif
# ifdef CTRLBRK
ctrlbrk(brkignore);
# endif
break;
default: /* unknown primitive */
sysError("unknown primitive","unaryPrims");
break;
}
return(returnedObject);
}
static int binaryPrims(number, firstarg, secondarg)
int number;
object firstarg, secondarg;
{ char buffer[2000];
int i;
object returnedObject;
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 3: /* debugging stuff */
fprintf(stderr,"primitive 23 %d %d\n", firstarg, secondarg);
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","byteAt:");
i = byteAt(firstarg, intValue(secondarg));
if (i < 0) i += 256;
returnedObject = newInteger(i);
break;
case 7: /* symbol set */
nameTableInsert(symbols, strHash(charPtr(firstarg)),
firstarg, secondarg);
break;
case 8: /* block start */
/* first get previous link */
i = intValue(basicAt(processStack, linkPointer));
/* change context and byte pointer */
fieldAtPut(processStack, i+1, firstarg);
fieldAtPut(processStack, i+4, secondarg);
break;
case 9: /* duplicate a block, adding a new context to it */
returnedObject = newBlock();
basicAtPut(returnedObject, 1, secondarg);
basicAtPut(returnedObject, 2, basicAt(firstarg, 2));
basicAtPut(returnedObject, 3, basicAt(firstarg, 3));
basicAtPut(returnedObject, 4, basicAt(firstarg, 4));
break;
default: /* unknown primitive */
sysError("unknown primitive","binaryPrims");
break;
}
return(returnedObject);
}
static int trinaryPrims(number, firstarg, secondarg, thirdarg)
int number;
object firstarg, secondarg, thirdarg;
{ char *bp, *tp, buffer[256];
int i, j;
object returnedObject;
returnedObject = firstarg;
switch(number) {
case 1: /* basicAt:Put: */
if (! isInteger(secondarg))
sysError("non integer index","basicAtPut");
fprintf(stderr,"IN BASICATPUT %d %d %d\n", firstarg, intValue(secondarg), thirdarg);
fieldAtPut(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 9: /* compile method */
setInstanceVariables(firstarg);
if (parse(thirdarg, charPtr(secondarg), false)) {
flushCache(basicAt(thirdarg, messageInMethod), firstarg);
returnedObject = trueobj;
}
else
returnedObject = falseobj;
break;
default: /* unknown primitive */
sysError(