v13i055: New release of little smalltalk, Part03/05
Rich Salz
rsalz at bbn.com
Tue Feb 23 10:08:41 AEST 1988
Submitted-by: Tim Budd <budd at MIST.CS.ORST.EDU>
Posting-number: Volume 13, Issue 55
Archive-name: little-st2/part03
#!/bin/sh
#
#
# This is version 2.02 of Little Smalltalk, distributed in five parts.
#
# This version is dated 12/25/87
#
# Several bugs and many features and improvements have been made since the
# first posting to comp.src.unix. See the file ``todo'' for a partial list.
#
# Comments, bug reports, and the like should be submitted to:
# Tim Budd
# Smalltalk Distribution
# Department of Computer Science
# Oregon State University
# Corvallis, Oregon
# 97330
#
# budd at cs.orst.edu
# {hp-pcd, tektronix}!orstcs!budd
#
#
echo 'Start of small.v2, part 03 of 05:'
echo 'x - READ_ME'
sed 's/^X//' > READ_ME << '/'
X
X
X
X
X
X
X_G_e_n_e_r_a_l _O_v_e_r_v_i_e_w
X
X First, the obvious facts. This is not Smalltalk-80,
Xnor even Smalltalk-V. This is the second version of the
XLittle Smalltalk system, the first version of which is
Xdescribed in the book recently published by Addison-Wesley*.
XVersion two is smaller and faster; does more in Smalltalk,
Xless in C; and is designed to be more portable to a wider
Xvariety of machines (we are working on versions now for
Xvarious PCs).
X
X My attitude towards the language has been rather
Xcavalier; what I liked I kept and what I didn't like I
Xtossed out. This is explained in more detail in my book and
Xin the end of this note. As a consequence, individuals fam-
Xiliar with ST-80 or Smalltalk-V will be struck by how much
Xthey are missing, and I make no apologies for this. On the
Xother hand, you don't find Smalltalk-V posted to
Xcomp.source.unix. Among the features you won't find here are
Xmetaclasses, class methods, windows, graphics support, and
Xmore.
X
X What you will find is a small language that does give
Xyou the flavor of object oriented programming at very little
Xcost. We are working to improve the system, and hope to
Xdistribute new versions as we develop them, as well as port-
Xing it to a wide range of machines. If you find (and
Xpreferably, fix!) bugs let us know. If you make nice addi-
Xtions let us know. If you want to make complements let us
Xknow. If you want to make complaints let us know. If you
Xwant support you just might be out of luck.
X
X This software is entirely public domain. You are
Xencouraged to give it to as many friends as you may have.
XAs a courtesy, I would appreciate it if you left my name on
Xthe code as the author, but I make no other claims to it (I
Xalso, of course, disavow any liability for any bizarre
Xthings you may choose to do with it). Enjoy.
X
X_B_u_i_l_d_i_n_g _t_h_e _S_y_s_t_e_m
X
X The first step in building the system is to unpack the
Xsources. The fact that you are reading this means you have
Xprobably already figured out how to do this.
X
X The next step is to tailor the system to the type of
Xenviornment it will be run in. For most users, this should
Xmean only changing at most three lines in the file env.h.
XThese three lines are near the front of the file and are
Xclearly marked. Two are hard paths; for the default initial
X_________________________
X* _A _L_i_t_t_l_e _S_m_a_l_l_t_a_l_k, by Timothy A. Budd. Published by
XAddison Wesley, 1987. In better bookshops everywhere.
X
X
X
X
X October 26, 1987
X
X
X
X
X
X - 2 -
X
X
Xobject image and for a temporary file to be used when edit-
Xing. The third line is a ``meta-define'' which indicates
Xthe type of machine and/or operating system to be used. You
Xshould examine the rest of the file to see the variety of
Xsystems supported. If you are unable to find anything
Xappropriate, you will have to look in the document
Xinstall.ms for further instructions. In this latter case,
Xif you are sucessful in porting the software to a new
Xmachine, I would be pleased if you could let me know the
Xnature of the changes required.
X
X Once you have tailored the system, there are then three
Xsteps involving in building the system; making the parser
X(the component used to generate the initial object image),
Xmaking the bytecode interpreter, and making the object
Ximage. Typing _m_a_k_e, with no arguments, will do all three.
XFor more detailed instructions on making the system consult
Xinstall.ms.
X
X Once you have sucessfully created the parser, the
Xbytecode compiler, and an object image, type
X
X st
X
X
Xto run the system. Now would be a very good time to go read
Xexplore.ms, which would tell you more how to find your way
Xaround.
X
X_C_h_a_n_g_e_s _f_r_o_m _L_i_t_t_l_e _S_m_a_l_l_t_a_l_k _v_e_r_s_i_o_n _o_n_e
X
X The following changes have been made from version one
Xto version two:
X
Xo+ The user interface is slightly different. This is most
X apparent in the way new classes are added (see
X explore.ms), and in the fact that expressions will not
X be printed unless you explicitly request printing, and
X in the fact that new global variables cannot be created
X at the command level merely by assignment.
X
Xo+ Much (very much) more of the system is now written in
X Smalltalk, rather than C. This allows the user to see,
X and modify it if they wish. This also means that the
X virtual machine is now much smaller.
X
Xo+ The pseudo variable selfProcess is no longer supported.
X The variables true, false and nil are now treated as
X global variables, not pseudo variables (see below).
X There are plans for adding processes to version two,
X but they have not been formalized yet.
X
Xo+ Global variables are now supported; in fact classes are
X now simply global variables, as are the variables true,
X
X
X
X October 26, 1987
X
X
X
X
X
X - 3 -
X
X
X false, smalltalk and nil. The global variable global-
X Names contains the dictionary of all currently known
X global variables and their values. (Pool variables are
X still not supported).
X
Xo+ The internal bytecodes are slightly different. In par-
X ticular, the bytecode representing ``send to super''
X has been eliminated, and a bytecode representing ``do a
X primitive'' has been added.
X
Xo+ The internal representation of objects is different.
X Instead of the ``super-object'' chain, objects are now
X created big enough to hold all the instance variables
X for all their superclasses. (This is the way it is
X done in Smalltalk-80, and, to the best of my knowledge,
X in Smalltalk-V).
X
Xo+ The Collection hierarchy has been rearranged. The
X rational for this change is explained in more detail in
X another essay. (possibly not written yet).
X
Xo+ Some methods, most notably the error message methods,
X have been moved out of class Object and into class
X Smalltalk.
X
Xo+ The syntax for primitives is different; the keyword
X primitive has been eliminated, and named primitives are
X now gone as well. Fewer actions are performed by prim-
X itives, having been replaced by Smalltalk methods.
X
Xo+ Command line options, such as the fast load feature,
X have been eliminated. However, since version two reads
X in a binary object image, not a textual file, loading
X should be considerably faster.
X
X_E_l_e_c_t_r_o_n_i_c _C_o_m_m_u_n_i_c_a_t_i_o_n
X
X Here is my address, various net addresses:
X
X Tim Budd
X Oregon State University
X Department of Computer Science
X Corvallis, Oregon 97331 USA
X (503) 754-3273
X
X budd@ cs.orst.edu
X
X {tektronix, hp-pcd} !orstcs!budd
X
X
X_C_h_a_n_g_e_s
X
X I want to emphasize that this is not even a beta-test
Xversion (does that make it an alpha or a gamma version?). I
X
X
X
X October 26, 1987
X
X
X
X
X
X - 4 -
X
X
Xwill be making a number of changes, hopefully just additions
Xto the initial image, in the next few months. In addition,
XI hope to prepare versions for other machines, notably the
XMacintosh and the IBM PC. I am also encouraging others to
Xport the system to new machines. If you have done so,
Xplease let me know.
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X October 26, 1987
X
X
/
echo 'x - env.h'
sed 's/^X//' > env.h << '/'
X/*
X Little Smalltalk, version two
X Written by Tim Budd, Oregon State University, July 1987
X
X environmental factors
X
X This include file gathers together environmental factors that
X are likely to change from one C compiler to another, or from
X one system to another. Please refer to the installation
X notes for more information.
X*/
X
X/* ### the following two define statements should be edit to conform
Xto your specific system, and should be the only changes most installations
Xneed to make ### */
X
X/*============= define the kind of system you are on ===========*/
X
X# define B42
X
X# define INITIALIMAGE "imageFile"
X
X/*=============== rules for various systems ====================*/
X
X# ifdef B42
X /* Berkeley 4.2, 4.3 and compatible, which include: */
X /* sequent balance */
X /* Harris HCX-7 */
X /* sun workstations */
X
Xtypedef unsigned char byte;
X
X# define byteToInt(b) (b)
X
X# define longCanBeInt(l) (l == (l & 037777))
X
X# define STRINGS
X# define SIGNALS
X
X# endif
X
X# ifdef SYSV
X /* system V systems including: */
X /* HP-UX for the HP-9000 series */
X /* TEK 4404 with some modifications (see install.ms) */
X
Xtypedef unsigned char byte;
X
X# define byteToInt(b) (b)
X
X# define longCanBeInt(l) (l == (l & 037777))
X
X# define STRING
X# define SIGNALS
X
X# endif
X
X# ifdef TURBOC
X /* IBM PC and compatiables using the TURBO C compiler */
X
X /* there are also changes that have to be made to the
X smalltalk source; see installation notes for
X details */
X
Xtypedef unsigned char byte;
X
X# define byteToInt(b) (b)
X
X# define longCanBeInt(l) (l == (l & 037777))
X
X# define STRING
X# define SSIGNALS
X# define ALLOC
X# define BINREADWRITE
X# define PROTO
X
X#endif
X
X/* ======== various defines that should work on all systems ==== */
X
X# define true 1
X# define false 0
X
X /* define the datatype boolean */
X# ifdef NOTYPEDEF
X# define boolean int
X# endif
X# ifndef NOTYPEDEF
Xtypedef int boolean;
X# endif
X
X /* define a bit of lint silencing */
X /* ignore means ``i know this function returns something,
X but I really, really do mean to ignore it */
X# ifdef NOVOID
X# define ignore
X# define noreturn
X# define void int
X# endif
X# ifndef NOVOID
X# define ignore (void)
X# define noreturn void
X# endif
X
X/* prototypes are another problem. If they are available, they should be
Xused; but if they are not available their use will cause compiler errors.
XTo get around this we define a lot of symbols which become nothing if
Xprototypes aren't available */
X# ifdef PROTO
X
X# define X ,
X# define OBJ object
X# define OBJP object *
X# define INT int
X# define BOOL boolean
X# define STR char *
X# define FLOAT double
X# define NOARGS void
X# define FILEP FILE *
X
X# endif
X
X# ifndef PROTO
X
X# define X
X# define OBJ
X# define OBJP
X# define INT
X# define BOOL
X# define STR
X# define FLOAT
X# define NOARGS
X# define FILEP
X
X# endif
/
echo 'x - interp.c'
sed 's/^X//' > interp.c << '/'
X/*
X Little Smalltalk version 2
X Written by Tim Budd, Oregon State University, July 1987
X
X bytecode interpreter module
X
X execute bytecodes for a given method until one of six events occur
X 1. A message must be sent to another object
X 2. A message must be sent to super
X 3. A return from a method occurs
X 4. An explicit return from a block occurs (backs up the process chain)
X 5. A block must be created
X 6. A block must begin execution
X
X the global variable finalTask indicates which of the six events is to
X be performed. Various other global variables (described in process.h)
X give other information to be used in performing the called for task.
X
X Note that the interpreter is called as part of the
X main instruction sequence (single process) and (via a primitive call)
X as part of the multi-process scheduler loop (class Scheduler, Process,
X et al)
X*/
X
X# include <stdio.h>
X# include "env.h"
X# include "memory.h"
X# include "names.h"
X# include "process.h"
X# include "interp.h"
X
Xextern object unSyms[], binSyms[], keySyms[];
Xextern boolean primitive(INT X OBJP X INT);
X
X# define nextByte() byteToInt(bytecodes[byteCounter++])
X# define ipush(x) incr(stack[stacktop++] = x)
X/* note that ipop leaves a ref count on the popped object */
X# define ipop(x) x=stack[--stacktop]; stack[stacktop]=nilobj
X
Xnoreturn execute(method, byteCounter, stack, stacktop, arguments, temporaries)
Xobject method, *stack, *arguments, *temporaries;
Xregister int byteCounter;
Xregister int stacktop;
X{
X int i, j, low, high;
X object receiver, *instance, *literals;
X object newobj;
X byte *bytecodes;
X boolean done;
X double f;
X
X /* do initialization */
X receiver = arguments[0];
X if (isInteger(receiver))
X instance = (object *) 0;
X else
X instance = memoryPtr(receiver);
X bytecodes = bytePtr(basicAt(method, bytecodesInMethod));
X literals = memoryPtr(basicAt(method, literalsInMethod));
X done = false;
X
X
X while( ! done ) {
X low = (high = nextByte()) & 0x0F;
X high >>= 4;
X if (high == 0) {
X high = low;
X low = nextByte();
X }
X/*if (debugging) ignore fprintf(stderr,"executing %s %d %d %d\n",
XcharPtr(basicAt(method, messageInMethod)), byteCounter, high, low);*/
X
X switch(high) {
X case PushInstance:
X ipush(instance[low]);
X break;
X
X case PushArgument:
X ipush(arguments[low]);
X break;
X
X case PushTemporary:
X ipush(temporaries[low]);
X break;
X
X case PushLiteral:
X ipush(literals[low]);
X break;
X
X case PushConstant:
X if (low == 3)
X low = -1;
X if (low < 3) {
X ipush(newInteger(low));
X }
X else
X switch(low) {
X case 4:
X ipush(nilobj);
X break;
X
X case 5:
X ipush(trueobj);
X break;
X
X case 6:
X ipush(falseobj);
X break;
X
X case 7:
X ipush(smallobj);
X break;
X
X case 8:
X ipush(globalNames);
X break;
X
X default:
X sysError("not done yet","pushConstant");
X }
X break;
X
X case PushGlobal:
X newobj = nameTableLookup(globalNames,
X literals[low]);
X if (newobj == nilobj) {
X /* send message instead */
X ipush(smallobj);
X ipush(literals[low]);
X argumentsOnStack = stacktop - 2;
X messageToSend =
X newSymbol("cantFindGlobal:");
X finalTask = sendMessageTask;
X done = true;
X }
X else
X ipush(newobj);
X break;
X
X case PopInstance:
X decr(instance[low]);
X /* we transfer reference count to instance */
X ipop(instance[low]);
X break;
X
X case PopTemporary:
X decr(temporaries[low]);
X /* we transfer reference count to temporaries */
X ipop(temporaries[low]);
X break;
X
X case SendMessage:
X argumentsOnStack = stacktop - (low + 1);
X messageToSend = literals[nextByte()];
X finalTask = sendMessageTask;
X done = true;
X break;
X
X case SendUnary:
X /* we optimize a couple common messages */
X if (low == 0) { /* isNil */
X ipop(newobj);
X if (newobj == nilobj) {
X ipush(trueobj);
X }
X else {
X decr(newobj);
X ipush(falseobj);
X }
X }
X else if (low == 1) { /* notNil */
X ipop(newobj);
X if (newobj == nilobj) {
X ipush(falseobj);
X }
X else {
X decr(newobj);
X ipush(trueobj);
X }
X }
X else {
X argumentsOnStack = stacktop - 1;
X messageToSend = unSyms[low];
X finalTask = sendMessageTask;
X done = true;
X }
X break;
X
X case SendBinary:
X /* optimize arithmetic as long as no */
X /* conversions are necessary */
X /* and overflow does not occur */
X if (low <= 12) {
X if (isInteger(stack[stacktop-1]) &&
X isInteger(stack[stacktop-2])) {
X ipop(newobj);
X i = intValue(newobj);
X ipop(newobj);
X j = intValue(newobj);
X ignore intBinary(low, j, i);
X if (returnedObject != nilobj) {
X ipush(returnedObject);
X break;
X }
X /* overflowed, go do it */
X /* the old fashioned way */
X ipush(newInteger(j));
X ipush(newInteger(i));
X }
X else if (isFloat(stack[stacktop-1]) &&
X isFloat(stack[stacktop-2])) {
X ipop(newobj);
X f = floatValue(newobj);
X decr(newobj);
X ipop(newobj);
X ignore floatBinary(low, floatValue(newobj), f);
X decr(newobj);
X ipush(returnedObject);
X break;
X }
X }
X argumentsOnStack = stacktop - 2;
X messageToSend = binSyms[low];
X finalTask = sendMessageTask;
X done = true;
X break;
X
X case SendKeyword:
X argumentsOnStack = stacktop - 3;
X messageToSend = keySyms[low];
X finalTask = sendMessageTask;
X done = true;
X break;
X
X case DoPrimitive:
X i = nextByte();
X done = primitive(i, &stack[stacktop - low], low);
X incr(returnedObject);
X /* pop off arguments */
X for (i = low; i > 0; i--) {
X ipop(newobj);
X decr(newobj);
X }
X if (! done) {
X ipush(returnedObject);
X decr(returnedObject);
X }
X break;
X
X case CreateBlock:
X /* we do most of the work in making the block */
X /* leaving it to the caller to fill in */
X /* the context information */
X newobj = allocObject(blockSize);
X setClass(newobj, blockclass);
X basicAtPut(newobj, argumentCountInBlock, newInteger(low));
X i = (low > 0) ? nextByte() : 0;
X basicAtPut(newobj, argumentLocationInBlock,
X newInteger(i));
X basicAtPut(newobj, bytecountPositionInBlock,
X newInteger(byteCounter + 1));
X incr(returnedObject = newobj);
X /* avoid a subtle side effect here */
X i = nextByte();
X byteCounter = i;
X finalTask = BlockCreateTask;
X done = true;
X break;
X
X case DoSpecial:
X switch(low) {
X case SelfReturn:
X incr(returnedObject = receiver);
X finalTask = ReturnTask;
X done = true;
X break;
X
X case StackReturn:
X ipop(returnedObject);
X finalTask = ReturnTask;
X done = true;
X break;
X
X case BlockReturn:
X ipop(returnedObject);
X finalTask = BlockReturnTask;
X done = true;
X break;
X
X case Duplicate:
X ipop(newobj);
X ipush(newobj);
X ipush(newobj);
X decr(newobj);
X break;
X
X case PopTop:
X ipop(newobj);
X decr(newobj);
X break;
X
X case Branch:
X /* avoid a subtle bug here */
X i = nextByte();
X byteCounter = i;
X break;
X
X case BranchIfTrue:
X ipop(newobj);
X i = nextByte();
X if (newobj == trueobj) {
X /* leave nil on stack */
X ++stacktop;
X byteCounter = i;
X }
X decr(newobj);
X break;
X
X case BranchIfFalse:
X ipop(newobj);
X i = nextByte();
X if (newobj == falseobj) {
X /* leave nil on stack */
X ++stacktop;
X byteCounter = i;
X }
X decr(newobj);
X break;
X
X case AndBranch:
X ipop(newobj);
X i = nextByte();
X if (newobj == falseobj) {
X ipush(newobj);
X byteCounter = i;
X }
X decr(newobj);
X break;
X
X case OrBranch:
X ipop(newobj);
X i = nextByte();
X if (newobj == trueobj) {
X ipush(newobj);
X byteCounter = i;
X }
X decr(newobj);
X break;
X
X case SendToSuper:
X argumentsOnStack = stacktop -
X (nextByte() + 1);
X messageToSend =
X literals[nextByte()];
X finalTask = sendSuperTask;
X done = true;
X break;
X
X default:
X sysError("invalid doSpecial","");
X break;
X }
X break;
X
X default:
X sysError("invalid bytecode","");
X break;
X }
X }
X
X /* when done, save stack top and bytecode counter */
X /* before we exit */
X
X finalStackTop = stacktop;
X finalByteCounter = byteCounter;
X}
/
echo 'x - memory.c'
sed 's/^X//' > memory.c << '/'
X/*
X Little Smalltalk, version 2
X Written by Tim Budd, Oregon State University, July 1987
X
X Improved incorporating suggestions by
X Steve Crawley, Cambridge University, October 1987
X Steven Pemberton, CWI, Amsterdam, Oct 1987
X
X memory management module
X
X This is a rather simple, straightforward, reference counting scheme.
X There are no provisions for detecting cycles, nor any attempt made
X at compaction. Free lists of various sizes are maintained.
X At present only objects up to 255 bytes can be allocated,
X which mostly only limits the size of method (in text) you can create.
X
X reference counts are not stored as part of an object image, but
X are instead recreated when the object is read back in.
X This is accomplished using a mark-sweep algorithm, similar
X to those used in garbage collection.
X
X There is a large amount of differences in the qualities of malloc
X procedures in the Unix world. Some perform very badly when asked
X to allocate thousands of very small memory blocks, while others
X take this without any difficulty. The routine mBlockAlloc is used
X to allocate a small bit of memory; the version given below
X allocates a large block and then chops it up as needed; if desired,
X for versions of malloc that can handle small blocks with ease
X this can be replaced using the following macro:
X
X# define mBlockAlloc(size) (object *) calloc((unsigned) size, sizeof(object))
X
X This can, and should, be replaced by a better memory management
X algorithm.
X*/
X# include <stdio.h>
X# include "env.h"
X# include "memory.h"
X# ifdef STRING
X# include <string.h>
X# endif
X# ifdef STRINGS
X# include <strings.h>
X# endif
X
X# define ObjectTableMax 5000
X# define MemoryBlockSize 2000
X
X# ifdef ALLOC
X# include <alloc.h>
X# endif
X# ifndef ALLOC
Xextern char *calloc();
X# endif
X
Xboolean debugging = false;
Xobject sysobj; /* temporary used to avoid rereference in macros */
Xobject intobj;
X
Xobject symbols; /* table of all symbols created */
Xobject globalNames; /* table of all accessible global names */
X
X/*
X in theory the objectTable should only be accessible to the memory
X manager. Indeed, given the right macro definitions, this can be
X made so. Never the less, for efficiency sake some of the macros
X can also be defined to access the object table directly
X*/
X
Xstruct objectStruct objectTable[ObjectTableMax];
X
X/*
X The following global variables are strictly local to the memory
X manager module
X*/
X
X# define FREELISTMAX 256
Xstatic object objectFreeList[FREELISTMAX];/* free list of objects */
X
X# ifndef mBlockAlloc
X /* the current memory block being hacked up */
Xstatic object *memoryBlock; /* malloc'ed chunck of memory */
Xstatic int currentMemoryPosition; /* last used position in above */
X# endif
X
X
X/* initialize the memory management module */
Xnoreturn initMemoryManager() {
X int i;
X
X /* set all the free list pointers to zero */
X for (i = 0; i < FREELISTMAX; i++)
X objectFreeList[i] = nilobj;
X
X /* set all the reference counts to zero */
X for (i = 0; i < ObjectTableMax; i++) {
X objectTable[i].referenceCount = 0;
X objectTable[i].size = 0;
X }
X
X /* make up the initial free lists */
X setFreeLists();
X
X# ifndef mBlockAlloc
X /* force an allocation on first object assignment */
X currentMemoryPosition = MemoryBlockSize + 1;
X# endif
X
X /* object at location 0 is the nil object, so give it nonzero ref */
X objectTable[0].referenceCount = 1;
X objectTable[0].size = 0;
X objectTable[0].type = objectMemory;
X
X}
X
X/* setFreeLists - initialise the free lists */
XsetFreeLists() {
X int z, i;
X struct objectStruct *p;
X
X for (z=ObjectTableMax-1; z>0; z--) {
X if (objectTable[z].referenceCount == 0){
X /* Unreferenced, so do a sort of sysDecr: */
X p= &objectTable[z];
X/*if (p->size > 0) printf("Unreferenced: %d\n", z);*/
X p->class = objectFreeList[p->size];
X objectFreeList[p->size]= z;
X for (i= p->size; i>0; )
X p->memory[--i] = nilobj;
X }
X }
X}
X
X/* report a (generally fatal) memory manager error */
Xnoreturn sysError(s1, s2)
Xchar *s1, *s2;
X{
X ignore fprintf(stderr,"%s\n%s\n", s1, s2);
X ignore abort();
X}
X
X/*
X mBlockAlloc - rip out a block (array) of object of the given size from
X the current malloc block
X*/
X# ifndef mBlockAlloc
Xstatic object *mBlockAlloc(memorySize)
Xint memorySize;
X{ object *objptr;
X
X if (currentMemoryPosition + memorySize >= MemoryBlockSize) {
X
X /* we toss away space here. Space-Frugal users may want to
X fix this by making a new object of size
X MemoryBlockSize - currentMemoryPositon - 1
X and putting it on the free list, but I think
X the savings is potentially small */
X
X memoryBlock = (object *) calloc((unsigned) MemoryBlockSize, sizeof(object));
X if (! memoryBlock)
X sysError("out of memory","malloc failed");
X currentMemoryPosition = 0;
X }
X objptr = (object *) &memoryBlock[currentMemoryPosition];
X currentMemoryPosition += memorySize;
X return(objptr);
X}
X# endif
X
X/* allocate a new memory object */
Xobject alcObject(memorySize, memoryType)
Xint memorySize;
Xint memoryType;
X{ int i;
X register int position;
X boolean done;
X
X if (memorySize >= FREELISTMAX) {
X sysError("allocation bigger than 255","");
X }
X
X /* first try the free lists, this is fastest */
X if ((position = objectFreeList[memorySize]) != 0) {
X objectFreeList[memorySize] = objectTable[position].class;
X }
X
X /* if not there, next try making a size zero object and
X making it bigger */
X else if ((position = objectFreeList[0]) != 0) {
X objectFreeList[0] = objectTable[position].class;
X objectTable[position].size = memorySize;
X objectTable[position].memory = mBlockAlloc(memorySize);
X }
X
X else { /* not found, must work a bit harder */
X done = false;
X
X /* first try making a bigger object smaller */
X for (i = memorySize + 1; i < FREELISTMAX; i++)
X if ((position = objectFreeList[i]) != 0) {
X objectFreeList[i] = objectTable[position].class;
X /* just trim it a bit */
X objectTable[position].size = memorySize;
X done = true;
X break;
X }
X
X /* next try making a smaller object bigger */
X if (! done)
X for (i = 1; i < memorySize; i++)
X if ((position = objectFreeList[i]) != 0) {
X objectFreeList[i] =
X objectTable[position].class;
X objectTable[position].size = memorySize;
X# ifdef mBlockAlloc
X free(objectTable[position].memory);
X# endif
X objectTable[position].memory =
X mBlockAlloc(memorySize);
X done = true;
X break;
X }
X
X /* if we STILL don't have it then there is nothing */
X /* more we can do */
X if (! done)
X sysError("out of objects","alloc");
X }
X
X /* set class and type */
X objectTable[position].referenceCount = 0;
X objectTable[position].class = nilobj;
X objectTable[position].type = memoryType;
X return(position << 1);
X}
X
Xobject allocSymbol(str)
Xchar *str;
X{ object newSym;
X
X newSym = alcObject((2 + strlen(str))/2, charMemory);
X ignore strcpy(charPtr(newSym), str);
X return(newSym);
X}
X
X# ifdef incr
Xobject incrobj; /* buffer for increment macro */
X# endif
X# ifndef incr
Xnoreturn incr(z)
Xobject z;
X{
X if (z && ! isInteger(z)) {
X objectTable[z>>1].referenceCount++;
X }
X}
X# endif
X
X# ifndef decr
Xnoreturn decr(z)
Xobject z;
X{
X if (z && ! isInteger(z)) {
X if (--objectTable[z>>1].referenceCount <= 0) {
X sysDecr(z);
X }
X }
X}
X# endif
X
X/* do the real work in the decr procedure */
Xnoreturn sysDecr(z)
Xobject z;
X{ register struct objectStruct *p;
X register int i;
X
X p = &objectTable[z>>1];
X if (p->referenceCount < 0) {
X sysError("negative reference count","");
X }
X decr(p->class);
X p->class = objectFreeList[p->size];
X objectFreeList[p->size] = z>>1;
X if (((int) p->size) > 0) {
X if (p->type == objectMemory)
X for (i = p->size; i > 0 ; )
X decr(p->memory[--i]);
X for (i = p->size; i > 0; )
X p->memory[--i] = nilobj;
X }
X
X}
X
X# ifndef basicAt
Xobject basicAt(z, i)
Xobject z;
Xregister int i;
X{
X if (isInteger(z))
X sysError("attempt to index","into integer");
X else if ((i <= 0) || (i > objectSize(z))) {
X ignore fprintf(stderr,"index %d size %d\n", i, (int) objectSize(z));
X sysError("index out of range","in basicAt");
X }
X else
X return(sysMemPtr(z)[i-1]);
X return(0);
X}
X# endif
X# ifndef basicAtPut
X
Xnoreturn basicAtPut(z, i, v)
Xobject z, v;
Xregister int i;
X{
X if (isInteger(z))
X sysError("assigning index to","integer value");
X else if ((i <= 0) || (i > objectSize(z))) {
X ignore fprintf(stderr,"index %d size %d\n", i, (int) objectSize(z));
X sysError("index out of range","in basicAtPut");
X }
X else {
X incr(v);
X decr(sysMemPtr(z)[i-1]);
X sysMemPtr(z)[i-1] = v;
X }
X}
X# endif
X
X# ifndef byteAt
Xint byteAt(z, i)
Xobject z;
Xregister int i;
X{ char *bp;
X
X if (isInteger(z))
X sysError("indexing integer","byteAt");
X else if ((i <= 0) || (i > 2 * objectSize(z))) {
X sysError("index out of range","byteAt");
X }
X else {
X bp = charPtr(z);
X i = bp[i-1];
X }
X return(i);
X}
X# endif
X
X# ifndef byteAtPut
Xnoreturn byteAtPut(z, i, x)
Xobject z;
Xint i, x;
X{ char *bp;
X
X if (isInteger(z))
X sysError("indexing integer","byteAtPut");
X else if ((i <= 0) || (i > 2 * objectSize(z))) {
X sysError("index out of range", "byteAtPut");
X }
X else {
X bp = charPtr(z);
X bp[i-1] = x;
X }
X}
X# endif
X/*
X imageWrite - write out an object image
X*/
Xstatic iwerr() { sysError("imageWrite count error",""); }
X
X/* ptr - used for conversions to keep lint happy */
X# define ptr(x) ((char *) x)
X
Xnoreturn imageWrite(fp)
XFILE *fp;
X{ short i;
X
X if (fwrite(ptr(&symbols), sizeof(object), 1, fp) != 1) iwerr();
X if (fwrite(ptr(&globalNames), sizeof(object), 1, fp) != 1) iwerr();
X
X for (i = 0; i < ObjectTableMax; i++) {
X if (objectTable[i].referenceCount > 0) {
X if (fwrite(ptr(&i), sizeof(short), 1, fp) != 1) iwerr();
X if (fwrite(ptr(&objectTable[i].class), sizeof(object), 1, fp)
X != 1) iwerr();
X if (fwrite(ptr(&objectTable[i].size), sizeof(byte), 1, fp)
X != 1) iwerr();
X if (fwrite(ptr(&objectTable[i].type), sizeof(byte), 1, fp)
X != 1) iwerr();
X if (objectTable[i].size != 0)
X if (fwrite(ptr(objectTable[i].memory), sizeof(object),
X (int) byteToInt(objectTable[i].size), fp) != byteToInt(objectTable[i].size))
X iwerr();
X }
X }
X}
X
X/*
XWritten by Steven Pemberton:
XThe following routine assures that objects read in are really referenced,
Xeliminating junk that may be in the object file but not referenced.
XIt is essentially a marking garbage collector algorithm using the
Xreference counts as the mark
X*/
X
Xstatic visit(x)
Xobject x;
X{
X int i, s;
X object *p;
X
X if (x && !isInteger(x)) {
X if (++(objectTable[x>>1].referenceCount) == 1) {
X /* then it's the first time we've visited it, so: */
X visit(objectTable[x>>1].class);
X s= (int) byteToInt(objectTable[x>>1].size);
X if (s>0 && objectTable[x>>1].type == objectMemory) {
X p= objectTable[x>>1].memory;
X for (i=0; i < s; i++) visit(p[i]);
X }
X }
X }
X}
X
X/*
X imageRead - read in an object image
X we toss out the free lists built initially,
X reconstruct the linkages, then rebuild the free
X lists around the new objects.
X The only objects with nonzero reference counts
X will be those reachable from either symbols or
X globalNames.
X*/
Xstatic irerr() { sysError("imageWrite count error",""); }
X
Xnoreturn imageRead(fp)
XFILE *fp;
X{ short i;
X object *p;
X
X if (fread(ptr(&symbols), sizeof(object), 1, fp) != 1) irerr();
X if (fread(ptr(&globalNames), sizeof(object), 1, fp) != 1) irerr();
X
X while(fread(ptr(&i), sizeof(short), 1, fp) == 1) {
X if ((i < 0) || (i > ObjectTableMax))
X sysError("index out of range","imageRead");
X if (fread(ptr(&objectTable[i].class), sizeof(object), 1, fp)
X != 1) irerr();
X if ((objectTable[i].class < 0) ||
X (objectTable[i].class > ObjectTableMax))
X sysError("class out of range","imageRead");
X if (fread(ptr(&objectTable[i].size), sizeof(byte), 1, fp)
X != 1) irerr();
X if (fread(ptr(&objectTable[i].type), sizeof(byte), 1, fp)
X != 1) irerr();
X if (objectTable[i].size != 0) {
X p = objectTable[i].memory = mBlockAlloc((int) objectTable[i].size);
X if (fread(ptr(p), sizeof(object),
X (int) byteToInt(objectTable[i].size), fp) != byteToInt(objectTable[i].size))
X irerr();
X }
X else
X objectTable[i].memory = (object *) 0;
X }
X
X /* now restore ref counts, getting rid of unneeded junk */
X visit(symbols);
X visit(globalNames);
X /* toss out the old free lists, build new ones */
X objectFreeList[0] = nilobj;
X setFreeLists();
X}
X
Xstatic ncopy(p, q, n)
Xchar *p, *q;
Xint n;
X{
X
X while (n>0) {
X *p++ = *q++;
X n--;
X }
X}
X
Xobject allocFloat(d)
Xdouble d;
X{ object newObj;
X
X newObj = alcObject((int) sizeof (double), floatMemory);
X ncopy(charPtr(newObj), (char *) &d, (int) sizeof (double));
X return(newObj);
X}
X
Xdouble floatValue(obj)
Xobject obj;
X{ double d;
X
X ncopy((char *) &d, charPtr(obj), (int) sizeof (double));
X return(d);
X}
X
Xint objcount()
X{ int i, count;
X
X
X for (count = i = 0; i < ObjectTableMax; i++)
X if (objectTable[i].referenceCount > 0)
X count++;
X return(count);
X}
/
echo 'x - process.c'
sed 's/^X//' > process.c << '/'
X/*
X Little Smalltalk, version 2
X Written by Tim Budd, Oregon State University, July 1987
X
X Process Manager
X
X This module manages the stack of pending processes.
X SendMessage is called when it is desired to send a message to an
X object. It looks up the method associated with the class of
X the receiver, then executes it.
X A block context is created only when it is necessary, and when it
X is required the routine executeFromContext is called instead of
X sendMessage.
X DoInterp is called by a primitive method to execute an interpreter,
X it returns the interpreter to which execution should continue
X following execution.
X*/
X# include <stdio.h>
X# include "env.h"
X# include "memory.h"
X# include "names.h"
X# include "process.h"
X
X# define ProcessStackMax 2000
X
Xextern noreturn execute(OBJ X INT X OBJP X INT X OBJP X OBJP);
X
X /* values set by interpreter when exiting */
Xint finalStackTop; /* stack top when finished with interpreter */
Xint finalByteCounter; /* bytecode counter when finished with interpreter */
Xint argumentsOnStack; /* position of arguments on stack for mess send */
Xobject messageToSend; /* message to send */
Xobject returnedObject; /* object returned from message */
XtaskType finalTask; /* next task to do (see below) */
Xobject creator; /* creating interpreter for blocks */
X
Xstatic object blockReturnContext;
X
Xobject processStack[ProcessStackMax];
Xint processStackTop = 0;
X
X/*
X we cache recently used methods, in case we want them again
X*/
X
X# define ProcessCacheSize 101 /* a suitable prime number */
X
Xstruct {
X object startClass, messageSymbol, methodClass, theMethod;
X } methodCache[ProcessCacheSize];
X
Xnoreturn prpush(newobj)
Xobject newobj;
X{
X incr(processStack[processStackTop++] = newobj);
X if (processStackTop >= ProcessStackMax)
X sysError("stack overflow","process stack");
X}
X
X/* flush out cache so new methods can be read in */
Xnoreturn flushMessageCache()
X{ int i;
X
X for (i = 0; i < ProcessCacheSize; i++)
X methodCache[i].messageSymbol = nilobj;
X}
X
Xstatic object findMethod(hash, message, startingClass)
Xint hash;
Xobject message, startingClass;
X{ object method, class, methodtable;
X
X /* first examine cache */
X if ((methodCache[hash].messageSymbol == message) &&
X (methodCache[hash].startClass == startingClass)) {
X /* found it in cache */
X method = methodCache[hash].theMethod;
X }
X else { /* must look in methods tables */
X method = nilobj;
X class = startingClass;
X while ( class != nilobj ) {
X methodtable = basicAt(class, methodsInClass);
X if (methodtable != nilobj)
X method = nameTableLookup(methodtable, message);
X if (method != nilobj) {
X /* fill in cache */
X methodCache[hash].messageSymbol = message;
X methodCache[hash].startClass = startingClass;
X methodCache[hash].methodClass = class;
X methodCache[hash].theMethod = method;
X class = nilobj;
X }
X else
X class = basicAt(class, superClassInClass);
X }
X }
X
X return(method);
X}
X
X/* newContext - create a new context. Note this returns three values,
Xvia side effects
X*/
Xstatic newContext(method, methodClass, contextobj, argobj, tempobj)
Xobject method, methodClass, *contextobj, argobj, *tempobj;
X{ int temporarysize;
X
X *contextobj = allocObject(contextSize);
X incr(*contextobj);
X setClass(*contextobj, contextclass);
X basicAtPut(*contextobj, methodInContext, method);
X basicAtPut(*contextobj, methodClassInContext, methodClass);
X basicAtPut(*contextobj, argumentsInContext, argobj);
X temporarysize = intValue(basicAt(method, temporarySizeInMethod));
X *tempobj = newArray(temporarysize);
X basicAtPut(*contextobj, temporariesInContext, *tempobj);
X}
X
Xnoreturn sendMessage(message, startingClass, argumentPosition)
Xobject message, startingClass;
Xint argumentPosition;
X{ object method, methodClass, size;
X object contextobj, tempobj, argobj, errMessage;
X int i, hash, bytecounter, temporaryPosition, errloc;
X int argumentsize, temporarySize;
X boolean done;
X
X /* compute size of arguments part of stack */
X argumentsize = processStackTop - argumentPosition;
X
X hash = (message + startingClass) % ProcessCacheSize;
X method = findMethod(hash, message, startingClass);
X/*fprintf(stderr,"sending message %s class %s\n", charPtr(message), charPtr(basicAt(startingClass, nameInClass)));*/
X
X if (method == nilobj) { /* didn't find it */
X errMessage = newSymbol("class:doesNotRespond:");
X if (message == errMessage)
X /* better give up */
X sysError("didn't find method", charPtr(message));
X else {
X errloc = processStackTop;
X prpush(smallobj);
X prpush(startingClass);
X prpush(message);
X sendMessage(errMessage, getClass(smallobj), errloc);
X }
X }
X else { /* found it, start execution */
X /* initialize things for execution */
X bytecounter = 0;
X done = false;
X
X /* allocate temporaries */
X temporaryPosition = processStackTop;
X size = basicAt(method, temporarySizeInMethod);
X if (! isInteger(size))
X sysError("temp size not integer","in method");
X else
X for (i = temporarySize = intValue(size); i > 0; i--)
X prpush(nilobj);
X methodClass = methodCache[hash].methodClass;
X
X while( ! done ) {
X execute(method, bytecounter,
X processStack, processStackTop,
X &processStack[argumentPosition],
X &processStack[temporaryPosition]);
X bytecounter = finalByteCounter;
X processStackTop = finalStackTop;
X
X switch(finalTask) {
X case sendMessageTask:
X sendMessage(messageToSend,
X getClass(processStack[argumentsOnStack]),
X argumentsOnStack);
X if (finalTask == BlockReturnTask)
X done = true;
X break;
X
X case sendSuperTask:
X sendMessage(messageToSend,
X basicAt(methodClass, superClassInClass),
X argumentsOnStack);
X if (finalTask == BlockReturnTask)
X done = true;
X break;
X
X
X case ContextExecuteTask:
X contextobj = messageToSend;
X executeFromContext(contextobj,
X argumentsOnStack);
X decr(contextobj);
X if (finalTask == ReturnTask)
X processStack[processStackTop++] = returnedObject;
X else
X done = true;
X break;
X
X case BlockCreateTask:
X /* block is in returnedObject, we just add */
X /* context info but first we must */
X /* create the context */
X argobj = newArray(argumentsize);
X newContext(method, methodClass, &contextobj, argobj, &tempobj);
X for (i = 1; i <= argumentsize; i++) {
X basicAtPut(argobj, i, processStack[argumentPosition + i - 1]);
X }
X for (i = 1; i <= temporarySize; i++) {
X basicAtPut(tempobj, i, processStack[temporaryPosition + i - 1]);
X }
X basicAtPut(returnedObject, contextInBlock, contextobj);
X processStack[processStackTop++] = returnedObject;
X /* we now execute using context - */
X /* so that changes to temp will be */
X /* recorded properly */
X executeFromContext(contextobj, bytecounter);
X while (processStackTop > argumentPosition) {
X decr(processStack[--processStackTop]);
X processStack[processStackTop] = nilobj;
X }
X
X /* if it is a block return, */
X /* see if it is our context */
X /* if so, make into a simple return */
X /* otherwise pass back to caller */
X /* we can decr, since only nums are */
X /* important */
X decr(contextobj);
X if (finalTask == BlockReturnTask) {
X if (blockReturnContext != contextobj)
X return;
X }
X finalTask = ReturnTask;
X /* fall into return code */
X
X case ReturnTask:
X while (processStackTop > argumentPosition) {
X decr(processStack[--processStackTop]);
X processStack[processStackTop] = nilobj;
X }
X /* note that ref count is picked up */
X /* from the interpreter */
X processStack[processStackTop++] = returnedObject;
X done = true;
X break;
X
X default:
X sysError("unknown task","in sendMessage");
X }
X }
X }
X/*fprintf(stderr,"returning from message %s\n", charPtr(message));*/
X}
X
X/*
X execute from a context rather than from the process stack
X*/
Xstatic executeFromContext(context, bytecounter)
Xobject context;
Xint bytecounter;
X{ object method, methodclass, arguments, temporaries;
X boolean done = false;
X
X method = basicAt(context, methodInContext);
X methodclass = basicAt(context, methodClassInContext);
X arguments = basicAt(context, argumentsInContext);
X temporaries = basicAt(context, temporariesInContext);
X
X while (! done) {
X execute(method, bytecounter, processStack, processStackTop,
X memoryPtr(arguments), memoryPtr(temporaries));
X bytecounter = finalByteCounter;
X processStackTop = finalStackTop;
X
X switch(finalTask) {
X case sendMessageTask:
X sendMessage(messageToSend,
X getClass(processStack[argumentsOnStack]),
X argumentsOnStack);
X if (finalTask == BlockReturnTask)
X done = true;
X break;
X
X case sendSuperTask:
X sendMessage(messageToSend,
X basicAt(methodclass, superClassInClass),
X argumentsOnStack);
X if (finalTask == BlockReturnTask)
X done = true;
X break;
X
X case BlockCreateTask:
X /* block is in returnedObject already */
X /* just add our context to it */
X basicAtPut(returnedObject, contextInBlock, context);
X processStack[processStackTop++] = returnedObject;
X break;
X
X case BlockReturnTask:
X blockReturnContext = context;
X /* fall into next case and return */
X
X case ReturnTask:
X /* exit and let caller handle it */
X done = true;
X break;
X
X default:
X sysError("unknown task","in context execute");
X }
X }
X}
X
Xflushstack()
X{
X while (processStackTop > 0) {
X decr(processStack[--processStackTop]);
X processStack[processStackTop] = nilobj;
X }
X}
X
Xstatic interpush(interp, value)
Xobject interp, value;
X{
X int stacktop;
X object stack;
X
X stacktop = 1 + intValue(basicAt(interp, stackTopInInterpreter));
X stack = basicAt(interp, stackInInterpreter);
X basicAtPut(stack, stacktop, value);
X basicAtPut(interp, stackTopInInterpreter, newInteger(stacktop));
X}
X
Xobject doInterp(interpreter)
Xobject interpreter;
X{ object context, method, arguments, temporaries, stack;
X object prev, contextobj, obj, argobj, class, newinterp, tempobj;
X int i, hash, argumentSize, bytecounter, stacktop;
X
X context = basicAt(interpreter, contextInInterpreter);
X method = basicAt(context, methodInContext);
X arguments = basicAt(context, argumentsInContext);
X temporaries = basicAt(context, temporariesInContext);
X stack = basicAt(interpreter, stackInInterpreter);
X stacktop = intValue(basicAt(interpreter, stackTopInInterpreter));
X bytecounter = intValue(basicAt(interpreter, byteCodePointerInInterpreter));
X
X execute(method, bytecounter, memoryPtr(stack), stacktop,
X memoryPtr(arguments), memoryPtr(temporaries));
X basicAtPut(interpreter, stackTopInInterpreter, newInteger(finalStackTop));
X basicAtPut(interpreter, byteCodePointerInInterpreter, newInteger(finalByteCounter));
X
X switch(finalTask) {
X case sendMessageTask:
X case sendSuperTask:
X /* first gather up arguments */
X argumentSize = finalStackTop - argumentsOnStack;
X argobj = newArray(argumentSize);
X for (i = argumentSize; i >= 1; i--) {
X obj = basicAt(stack, finalStackTop);
X basicAtPut(argobj, i, obj);
X basicAtPut(stack, finalStackTop, nilobj);
X finalStackTop--;
X }
X
X /* now go look up method */
X if (finalTask == sendMessageTask)
X class = getClass(basicAt(argobj, 1));
X else
X class = basicAt(basicAt(context,
X methodClassInContext), superClassInClass);
X hash = (messageToSend + class) % ProcessCacheSize;
X method = findMethod(hash, messageToSend, class);
X
X if (method == nilobj) {
X /* didn't find it, change message */
X incr(argobj); /* get rid of old args */
X decr(argobj);
X argobj = newArray(3);
X basicAtPut(argobj, 1, smallobj);
X basicAtPut(argobj, 2, class);
X basicAtPut(argobj, 3, messageToSend);
X class = getClass(smallobj);
X messageToSend = newSymbol("class:doesNotRespond:");
X hash = (messageToSend + class) % ProcessCacheSize;
X method = findMethod(hash, messageToSend, class);
X if (method == nilobj) /* oh well */
X sysError("cant find method",charPtr(messageToSend));
X }
X newContext(method, methodCache[hash].methodClass, &contextobj, argobj, &tempobj);
X basicAtPut(interpreter, stackTopInInterpreter, newInteger(finalStackTop));
X argumentsOnStack = 0;
X /* fall into context execute */
X
X case ContextExecuteTask:
X if (finalTask == ContextExecuteTask) {
X contextobj = messageToSend;
X }
X newinterp = allocObject(InterpreterSize);
X setClass(newinterp, intrclass);
X basicAtPut(newinterp, contextInInterpreter, contextobj);
X basicAtPut(newinterp, previousInterpreterInInterpreter, interpreter);
X basicAtPut(newinterp, creatingInterpreterInInterpreter, creator);
X /* this shouldn't be 15, but what should it be?*/
X basicAtPut(newinterp, stackInInterpreter, newArray(15));
X basicAtPut(newinterp, stackTopInInterpreter, newInteger(0));
X basicAtPut(newinterp, byteCodePointerInInterpreter, newInteger(argumentsOnStack));
X decr(contextobj);
X return(newinterp);
X
X case BlockCreateTask:
X basicAtPut(returnedObject, contextInBlock, context);
X prev = basicAt(interpreter, creatingInterpreterInInterpreter);
X if (prev == nilobj)
X prev = interpreter;
X basicAtPut(returnedObject, creatingInterpreterInBlock, prev);
X interpush(interpreter, returnedObject);
X decr(returnedObject);
X return(interpreter);
X
X case BlockReturnTask:
X interpreter = basicAt(interpreter, creatingInterpreterInInterpreter);
X /* fall into return task */
X
X case ReturnTask:
X prev = basicAt(interpreter, previousInterpreterInInterpreter);
X if (prev != nilobj) {
X interpush(prev, returnedObject);
X }
X /* get rid of excess ref count */
X decr(returnedObject);
X return(prev);
X
X default:
X sysError("unknown final task","doInterp");
X }
X return(nilobj);
X}
/
echo 'Part 03 of small.v2 complete.'
exit
--
For comp.sources.unix stuff, mail to sources at uunet.uu.net.
More information about the Comp.sources.unix
mailing list