earlw@pesnta.UUCP (Earl Wallace) (06/13/85)
#! /bin/sh
#
# This is an another posting of the Little Smalltalk source, the last posting
# of this source went out in 5 parts and they were too big (>200k) for most
# sites so I redid the whole mess to keep the files around the 50k range.
#
# The complete set is now 20 parts.
#
# P.S. - If you don't receive all 20 parts within 5 days, drop me a line.
# Also, I have the Rand sources of May 1984, if someone has a more
# updated copy, I'll be happy to post them (or YOU can post them :-))
#
# -earlw@pesnta
#
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# sources/primitive.c
# sources/primitive.h
# sources/process.c
# sources/process.h
# sources/sstr.c
# sources/string.c
# sources/string.h
# sources/symbol.c
# This archive created: Thu Jun 13 11:33:05 1985
# By: Earl Wallace (Perkin-Elmer Data Systems Group / Customer Service)
export PATH; PATH=/bin:$PATH
if test -f 'sources/primitive.c'
then
echo shar: will not over-write existing file "'sources/primitive.c'"
else
cat << \SHAR_EOF > 'sources/primitive.c'
/*
Little Smalltalk
Primitive manager
timothy a. budd
10/84
hashcode code written by Robert McConeghy
(who also wrote classes Dictionary, et al).
*/
/*
The source code for the Little Smalltalk System may be freely
copied provided that the source of all files is acknowledged
and that this condition is copied with each file.
The Little Smalltalk System is distributed without responsibility
for the performance of the program and without any guarantee of
maintenance.
All questions concerning Little Smalltalk should be addressed to:
Professor Tim Budd
Department of Computer Science
The University of Arizona
Tucson, Arizona
85721
USA
*/
# include <stdio.h>
# include <ctype.h>
# include <math.h>
# include <errno.h>
# include "object.h"
# include "drive.h"
# include "interp.h"
# include "process.h"
# include "block.h"
# include "string.h"
# include "symbol.h"
# include "number.h"
# include "file.h"
# include "byte.h"
# include "primitive.h"
extern int errno;
extern int prntcmd;
extern double modf();
extern long time();
extern object *lookup_class();
extern process *runningProcess;
extern int responds_to(), generality();
extern class *mk_class();
extern object *o_object, *o_true, *o_false, *o_nil, *o_number, *o_magnitude;
object *primitive(primnumber, numargs, args)
int primnumber, numargs;
object **args;
{ object *resultobj;
object *leftarg, *rightarg, *fnd_class(), *fnd_super();
int leftint, rightint, i, j;
double leftfloat, rightfloat;
long clock;
char *leftp, *rightp, *errp;
class *aClass;
bytearray *byarray;
struct file_struct *phil;
int opnumber = primnumber % 10;
char strbuffer[300], tempname[100];
errno = 0;
/* first do argument type checking */
switch(i = (primnumber / 10)) {
case 0: /* misc operations */
if (opnumber <= 5 && numargs != 1) goto argcerror;
leftarg = args[0];
break;
case 1: /* integer operations */
case 2:
if (numargs != 2) goto argcerror;
rightarg = args[1];
if (! is_integer(rightarg)) goto argterror;
rightint = int_value(rightarg);
case 3:
if (i == 3 && opnumber && numargs != 1)
goto argcerror;
leftarg = args[0];
if (! is_integer(leftarg)) goto argterror;
leftint = int_value(leftarg);
break;
case 4: /* character operations */
if (numargs != 2) goto argcerror;
rightarg = args[1];
if (! is_character(rightarg)) goto argterror;
rightint = int_value(rightarg);
case 5:
if (i == 5 && numargs != 1) goto argcerror;
leftarg = args[0];
if (! is_character(leftarg)) goto argterror;
leftint = int_value(leftarg);
break;
case 6: /* floating point operations */
if (numargs != 2) goto argcerror;
rightarg = args[1];
if (! is_float(rightarg)) goto argterror;
rightfloat = float_value(rightarg);
case 7:
if (i == 7 && numargs != 1) goto argcerror;
case 8:
if (i == 8 && opnumber < 8 && numargs != 1)
goto argcerror;
leftarg = args[0];
if (! is_float(leftarg)) goto argterror;
leftfloat = float_value(leftarg);
break;
case 9: /* symbol operations */
leftarg = args[0];
if (! is_symbol(leftarg)) goto argterror;
leftp = symbol_value(leftarg);
break;
case 10: /* string operations */
if (numargs < 1) goto argcerror;
leftarg = args[0];
if (! is_string(leftarg)) goto argterror;
leftp = string_value(leftarg);
if (opnumber && opnumber <= 3) {
if (numargs != 2) goto argcerror;
rightarg = args[1];
if (! is_string(rightarg)) goto argterror;
rightp = string_value(rightarg);
}
else if ((opnumber >= 4) && (opnumber <= 6)) {
if (numargs < 2) goto argcerror;
if (! is_integer(args[1])) goto argterror;
i = int_value(args[1])-1;
if ((i < 0) || (i >= strlen(leftp)))
goto indexerror;
}
break;
case 11: /* misc operations */
if ((opnumber == 1) || (opnumber == 2)) {
if (is_bltin(args[0])) goto argterror;
if (numargs < 2) goto argcerror;
if (! is_integer(args[1])) goto argterror;
i = int_value(args[1]);
if (i < 1 || i > args[0]->size)
goto indexerror;
}
else if ((opnumber >= 4) && (opnumber <= 6)) {
if (numargs != 1) goto argcerror;
if (! is_integer(args[0])) goto argterror;
i = int_value(args[0]);
if (i < 0) goto indexerror;
}
else if (opnumber >= 7) {
if (numargs < 1) goto argcerror;
if (! is_bytearray(args[0])) goto argterror;
byarray = (bytearray *) args[0];
if (opnumber >= 8) {
if (numargs < 2) goto argcerror;
if (! is_integer(args[1]))
goto argterror;
i = int_value(args[1]) - 1;
if (i < 0 || i >= byarray->a_bsize)
goto indexerror;
}
}
break;
case 12: /* string i/o operations */
if (opnumber < 6) {
if (numargs < 1) goto argcerror;
leftarg = args[0];
if (! is_string(leftarg)) goto argterror;
leftp = string_value(leftarg);
}
break;
case 13: /* operations on file */
if (numargs < 1) goto argcerror;
if (! is_file(args[0])) goto argterror;
phil = (struct file_struct *) args[0];
if (opnumber && (phil->fp == (FILE *) NULL)) {
errp = "file must be open for operation";
goto return_error;
}
break;
case 15: /* operations on classes */
if (opnumber < 3 && numargs != 1) goto argcerror;
if (! is_class(args[0])) goto argterror;
aClass = (class *) args[0];
break;
}
/* now do operation */
switch(primnumber) {
case 1: /* class of object */
resultobj = fnd_class(args[0]);
if (resultobj) goto return_obj;
else goto return_nil;
case 2: /* get super_object */
resultobj = fnd_super(args[0]);
if (resultobj) goto return_obj;
else goto return_nil;
case 3: /* see if class responds to new */
leftint = 0;
if (! is_class(args[0])) goto return_boolean;
leftint = responds_to("new", (class *) args[0]);
goto return_boolean;
case 4: /* compute size of object */
leftint = args[0]->size;
goto return_integer;
case 5: /* return hashnum of object */
if (is_integer(leftarg))
leftint = int_value(leftarg);
else if (is_character(leftarg))
leftint = int_value(leftarg);
else if (is_symbol(leftarg))
leftint = (int) symbol_value(leftarg);
else if (is_string(leftarg)) {
leftp = string_value(leftarg);
leftint = 0;
for(i = 0; *leftp != 0; leftp++){
leftint += *leftp;
i++;
if(i > 5)
break;
}
}
else /* for all other objects return address */
leftint = (int) &leftarg;
if (leftint < 0)
leftint = -leftint;
goto return_integer;
case 6: /* built in object type testing */
if (numargs != 2) goto argcerror;
leftint = (args[0]->size == args[1]->size);
goto return_boolean;
case 7: /* object equality testing */
if (numargs != 2) goto argcerror;
leftint = (args[0] == args[1]);
goto return_boolean;
case 8: /* toggle debugging flag */
if (numargs == 0) {
debug = 1 - debug;
goto return_nil;
}
if (numargs != 2) goto argcerror;
if (! is_integer(args[0])) goto argterror;
if (! is_integer(args[1])) goto argterror;
leftint = int_value(args[0]);
rightint = int_value(args[1]);
switch(leftint) {
case 1: prntcmd = rightint; break;
case 2: debug = rightint; break;
}
goto return_nil;
case 9: /* numerical generality comparison */
if (numargs != 2) goto argcerror;
leftint =
(generality(args[0]) > generality(args[1]));
goto return_boolean;
case 10: /* integer addition */
leftint += rightint;
goto return_integer;
case 11: /* integer subtraction */
leftint -= rightint;
goto return_integer;
case 12: case 42:
leftint = (leftint < rightint);
goto return_boolean;
case 13: case 43:
leftint = (leftint > rightint);
goto return_boolean;
case 14: case 44:
leftint = (leftint <= rightint);
goto return_boolean;
case 15: case 45:
leftint = (leftint >= rightint);
goto return_boolean;
case 16: case 46:
leftint = (leftint == rightint);
goto return_boolean;
case 17: case 47:
leftint = (leftint != rightint);
goto return_boolean;
case 18:
leftint *= rightint;
goto return_integer;
case 19: /* // integer */
if (rightint == 0) goto numerror;
i = leftint / rightint;
if ((leftint < 0) && (leftint % rightint))
i -= 1;
leftint = i;
goto return_integer;
case 20: /* gcd of two integers */
if (leftint == 0 || rightint == 0) goto numerror;
if (leftint < 0) leftint = -leftint;
if (rightint < 0) rightint = -rightint;
if (leftint > rightint)
{i = leftint; leftint = rightint; rightint = i;}
while (i = rightint % leftint)
{rightint = leftint; leftint = i;}
goto return_integer;
case 21: /* bitAt: */
leftint = (leftint & (1 << rightint)) ? 1 : 0;
goto return_integer;
case 22: /* logical bit-or */
leftint |= rightint;
goto return_integer;
case 23: /* logical bit-and */
leftint &= rightint;
goto return_integer;
case 24: /* logical bit-exclusive or */
leftint ^= rightint;
goto return_integer;
case 25: /* bit shift */
if (rightint < 0)
leftint >>= - rightint;
else
leftint <<= rightint;
goto return_integer;
case 26: /* integer radix */
if (rightint < 2 || rightint > 36) goto numerror;
prnt_radix(leftint, rightint, strbuffer);
goto return_string;
case 28:
if (rightint == 0) goto numerror;
leftint /= rightint;
goto return_integer;
case 29:
if (rightint == 0) goto numerror;
leftint %= rightint;
goto return_integer;
case 30: /* doPrimitive:withArguments: */
if (numargs != 2) goto argcerror;
resultobj = primitive(leftint, args[1]->size,
&args[1]->inst_var[0]);
goto return_obj;
case 32: /* convert random int into random float */
leftfloat = ((double) ((leftint/10) % 1000)) / 1000.0;
goto return_float;
case 33: /* bit inverse */
leftint ^= -1;
goto return_integer;
case 34: /* highBit */
rightint = leftint;
for (leftint = 32; leftint >= 0; leftint--)
if (rightint & (1 << leftint))
goto return_integer;
goto return_nil;
case 35: /* random number */
srand(leftint);
leftint = rand();
goto return_integer;
case 36: /* convert integer to character */
goto return_character;
case 37: /* convert integer to string */
sprintf(strbuffer,"%d", leftint);
goto return_string;
case 38: /* factorial */
if (leftint < 0) goto numerror;
if (leftint < FACTMAX) {
for (i = 1; leftint; leftint--)
i *= leftint;
leftint = i;
goto return_integer;
}
# ifndef GAMMA
/* gamma not supported, use float multiply */
leftfloat = 1.0;
if (leftint < 30) {
for (i = 1; leftint; leftint--)
leftfloat *= leftint;
}
goto return_float;
# endif
# ifdef GAMMA
/* compute gamma */
leftfloat = (double) (leftint + 1);
sassign(leftarg, new_float(leftfloat));
resultobj = primitive(GAMMAFUN, 1, &leftarg);
obj_dec(leftarg);
goto return_obj;
# endif
case 39: /* convert integer to float */
leftfloat = (double) leftint;
goto return_float;
case 50: /* digitValue */
if (isdigit(leftint))
leftint -= '0';
else if (isupper(leftint)) {
leftint -= 'A';
leftint += 10;
}
else goto return_nil;
goto return_integer;
case 51:
if (isupper(leftint)) leftint += 'a' - 'A';
leftint = (leftint == 'a') || (leftint == 'e') ||
(leftint == 'i') || (leftint == 'o') ||
(leftint == 'u');
goto return_boolean;
case 52:
leftint = isalpha(leftint);
goto return_boolean;
case 53:
leftint = islower(leftint);
goto return_boolean;
case 54:
leftint = isupper(leftint);
goto return_boolean;
case 55:
leftint = isspace(leftint);
goto return_boolean;
case 56:
leftint = isalnum(leftint);
goto return_boolean;
case 57:
if (isupper(leftint)) leftint += 'a' - 'A';
else if (islower(leftint)) leftint += 'A' - 'a';
goto return_character;
case 58: /* convert character to string */
sprintf(strbuffer,"%c", leftint);
goto return_string;
case 59: /* convert character to integer */
goto return_integer;
case 60: /* floating point addition */
leftfloat += rightfloat;
goto return_float;
case 61: /* floating point subtraction */
leftfloat -= rightfloat;
goto return_float;
case 62:
leftint = (leftfloat < rightfloat);
goto return_boolean;
case 63:
leftint = (leftfloat > rightfloat);
goto return_boolean;
case 64:
leftint = (leftfloat <= rightfloat);
goto return_boolean;
case 65:
leftint = (leftfloat >= rightfloat);
goto return_boolean;
case 66:
leftint = (leftfloat == rightfloat);
goto return_boolean;
case 67:
leftint = (leftfloat != rightfloat);
goto return_boolean;
case 68:
leftfloat *= rightfloat;
goto return_float;
case 69:
if (rightfloat == 0) goto numerror;
leftfloat /= rightfloat;
goto return_float;
case 70:
leftfloat = log(leftfloat);
goto float_check;
case 71:
if (leftfloat < 0) goto numerror;
leftfloat = sqrt(leftfloat);
goto float_check;
case 72:
leftint = (int) floor(leftfloat);
goto return_integer;
case 73: /* ceiling */
leftint = (int) ceil(leftfloat);
goto return_integer;
case 75: /* integer part */
leftfloat = modf(leftfloat, &rightfloat);
leftint = (int) rightfloat;
goto return_integer;
case 76: /* fractional part */
leftfloat = modf(leftfloat, &rightfloat);
goto return_float;
case 77: /* gamma function */
# ifdef GAMMA
leftfloat = gamma(leftfloat);
if (leftfloat > 88.0) goto numerror;
leftfloat = exp(leftfloat);
goto float_check;
# endif
# ifndef GAMMA
errp = "gamma function";
goto not_implemented;
# endif
case 78:
sprintf(strbuffer,"%g", leftfloat);
goto return_string;
case 79:
leftfloat = exp(leftfloat);
goto return_float;
case 80: /* normalize radian value */
# define TWOPI (double) 6.2831853072
rightfloat =
floor(((leftfloat < 0) ? -leftfloat:leftfloat) / TWOPI);
if (leftfloat < 0)
leftfloat += (1 + rightfloat) * TWOPI;
else
leftfloat -= rightfloat * TWOPI;
goto return_float;
case 81:
leftfloat = sin(leftfloat);
goto float_check;
case 82:
leftfloat = cos(leftfloat);
goto float_check;
case 84:
leftfloat = asin(leftfloat);
goto float_check;
case 85:
leftfloat = acos(leftfloat);
goto float_check;
case 86:
leftfloat = atan(leftfloat);
goto float_check;
case 88:
if (numargs != 2) goto argcerror;
if (! is_float(args[1])) goto argterror;
leftfloat = pow(leftfloat, float_value(args[1]));
goto float_check;
case 89: /* floating point radix */
if (numargs != 2) goto argcerror;
if (! is_integer(args[1])) goto argterror;
i = int_value(args[1]); /* base */
if (i < 2 || i > 36) goto numerror;
fprnt_radix(leftfloat, i, strbuffer);
goto return_string;
case 91: /* symbol comparison */
if (numargs != 2) goto argcerror;
if (! is_symbol(args[1])) goto argterror;
leftint = (leftp == symbol_value(args[1]));
goto return_boolean;
case 92: /* symbol printString */
sprintf(strbuffer, "#%s", leftp);
goto return_string;
case 93: /* symbol asString */
sprintf(strbuffer, "%s", leftp);
goto return_string;
case 94: /* symbol print ( with tabs) */
if (numargs == 2) {
if (! is_integer(args[1])) goto argterror;
for (i = int_value(args[1]); i >= 0; i--)
putchar('\t');
}
printf("%s\n", leftp);
# ifdef FLUSHREQ
fflush(stdout);
# endif
goto return_nil;
case 96:
goto return_nil;
case 97: /* make a new class (generated by parser)*/
if (numargs != 8) goto argcerror;
if (! is_symbol(args[1])) goto argterror;
if (! is_symbol(args[2])) goto argterror;
if (! is_integer(args[6])) goto argterror;
if (! is_integer(args[7])) goto argterror;
resultobj = (object *) mk_class(leftp, args);
goto return_obj;
case 98: /* install class in dictionary */
if (numargs != 2) goto argcerror;
if (! is_class(args[1])) goto argterror;
enter_class(leftp, args[1]);
goto return_nil;
case 99: /* find a class in class dictionary */
if (numargs != 1) goto argcerror;
resultobj = lookup_class(leftp);
if (resultobj == (object *) 0) {
sprintf(strbuffer,"cannot find class %s",
leftp);
sassign(resultobj, new_str(strbuffer));
primitive(ERRPRINT, 1, &resultobj);
obj_dec(resultobj);
resultobj = lookup_class("Object");
if (! resultobj) cant_happen(7);
}
goto return_obj;
case 100: /* string length */
leftint = strlen(leftp);
goto return_integer;
case 101: /* string compare, case dependent */
leftint = strcmp(leftp, rightp);
goto return_integer;
case 102: /* string compare, case independent */
leftint = 1;
while (*leftp || *rightp) {
i = *leftp++;
j = *rightp++;
if (i >= 'A' && i <= 'Z')
i = i - 'A' + 'a';
if (j >= 'A' && j <= 'Z')
j = j - 'A' + 'a';
if (i != j) {leftint = 0; break;}
}
goto return_boolean;
case 103: /* string catenation */
for (i = leftint = 0; i < numargs; i++) {
if (! is_string(args[i])) goto argterror;
leftint += strlen(string_value(args[i]));
}
errp = (char *) o_alloc((unsigned) (1 + leftint));
*errp = '\0';
for (i = 0; i < numargs; i++)
strcat(errp, string_value(args[i]));
resultobj = (object *) new_istr(errp);
goto return_obj;
case 104: /* string at: */
if (numargs != 2) goto argcerror;
leftint = leftp[i];
goto return_character;
case 105: /* string at: put: */
if (numargs != 3) goto argcerror;
if (! is_character(args[2])) goto argterror;
leftp[i] = int_value(args[2]);
goto return_nil;
case 106: /* copyFrom: length: */
if (numargs != 3) goto argcerror;
if (! is_integer(args[2])) goto argterror;
j = int_value(args[2]);
if (j < 0) goto indexerror;
for (rightp = strbuffer; j; j--, i++)
*rightp++ = leftp[i];
*rightp = '\0';
goto return_string;
case 107: /* string copy */
if (numargs != 1) goto argcerror;
resultobj = new_str(leftp);
goto return_obj;
case 108: /* string asSymbol */
if (numargs != 1) goto argcerror;
resultobj = new_sym(leftp);
goto return_obj;
case 109: /* string printString */
if (numargs != 1) goto argcerror;
sprintf(strbuffer,"\'%s\'", leftp);
goto return_string;
case 110: /* new untyped object */
if (numargs != 1) goto argcerror;
if (! is_integer(args[0])) goto argterror;
leftint = int_value(args[0]);
if (leftint < 0) goto numerror;
resultobj = new_obj((class *) 0, leftint, 1);
goto return_obj;
case 111: /* object at: */
if (numargs != 2) goto argcerror;
resultobj = args[0]->inst_var[ i - 1 ];
goto return_obj;
case 112: /* object at:put: */
if (numargs != 3) goto argcerror;
assign(args[0]->inst_var[i - 1], args[2]);
goto return_nil;
case 113: /* object grow */
leftarg = args[0];
rightarg = args[1];
if (is_bltin(leftarg)) goto argterror;
resultobj = new_obj(leftarg->class,
leftarg->size+1, 0);
if (leftarg->super_obj)
sassign(resultobj->super_obj,
leftarg->super_obj);
for (i = 0; i < leftarg->size; i++)
sassign(resultobj->inst_var[i], leftarg->inst_var[i]);
sassign(resultobj->inst_var[i], rightarg);
goto return_obj;
case 114: /* new array */
resultobj = new_array(i, 1);
goto return_obj;
case 115: /* new string */
for (j = 0; j < i; j++)
strbuffer[j] = ' ';
strbuffer[j] = '\0';
goto return_string;
case 116: /* bytearray new */
/* initialize with random garbage */
resultobj = new_bytearray(strbuffer, i);
goto return_obj;
case 117: /* bytearray size */
if (numargs != 1) goto argcerror;
leftint = byarray->a_bsize;
goto return_integer;
case 118: /* bytearray at: */
if (numargs != 2) goto argcerror;
leftint = uctoi(byarray->a_bytes[i]);
goto return_integer;
case 119: /* bytearray at:put: */
if (numargs != 3) goto argcerror;
if (! int_value(args[2])) goto argterror;
byarray->a_bytes[i] = itouc(int_value(args[2]));
goto return_nil;
case 120: /* print, no return */
printf("%s", leftp);
# ifdef FLUSHREQ
fflush(stdout);
# endif
goto return_nil;
case 121: /* print, with return */
printf("%s\n", leftp);
# ifdef FLUSHREQ
fflush(stdout);
# endif
goto return_nil;
case 122: /* format for error printing */
aClass = (class *) fnd_class(args[1]);
sprintf(strbuffer,"%s: %s",
symbol_value(aClass->class_name), leftp);
leftp = strbuffer;
case 123: /* print on error output */
fprintf(stderr,"%s\n", leftp);
# ifdef FLUSHREQ
fflush(stderr);
# endif
goto return_nil;
case 125: /* unix system call */
# ifndef NOSYSTEM
leftint = system(leftp);
goto return_integer;
# endif
# ifdef NOSYSTEM
errp = "system()";
goto not_implemented;
# endif
case 127: /* block return */
errp = "block return without surrounding context";
goto return_error;
case 128: /* reference count error */
if (numargs != 1) goto argcerror;
sprintf(strbuffer,"object %d reference count %d",
args[0], args[0]->ref_count);
errp = strbuffer;
goto return_error;
case 129: /* does not respond error */
if (numargs != 2) goto argcerror;
if (! is_symbol(args[1])) goto argterror;
fprintf(stderr,"129 error %s\n",
symbol_value(args[1]));
aClass = (class *) fnd_class(args[0]);
if (! is_class(aClass)) goto argterror;
sprintf(strbuffer,"%s: does not respond to %s",
symbol_value(aClass->class_name),
symbol_value(args[1]));
errp = strbuffer;
goto return_error;
case 130: /* file open */
if (numargs != 3) goto argcerror;
if (! is_string(args[1])) goto argterror;
if (! is_string(args[2])) goto argterror;
file_open(phil,
string_value(args[1]), string_value(args[2]));
goto return_nil;
case 131: /* file read */
if (numargs != 1) goto argcerror;
resultobj = file_read(phil);
goto return_obj;
case 132: /* file write */
if (numargs != 2) goto argcerror;
file_write(phil, args[1]);
goto return_nil;
case 133: /* set file mode */
if (numargs != 2) goto argcerror;
if (! is_integer(args[1])) goto argterror;
phil->file_mode = int_value(args[1]);
goto return_nil;
case 134: /* compute file size */
fseek(phil->fp, (long) 0, 2);
leftint = (int) ftell(phil->fp);
goto return_integer;
case 135: /* set file position */
if (numargs != 2) goto argcerror;
if (! is_integer(args[1])) goto argterror;
leftint = fseek(phil->fp, (long) int_value(args[1]), 0);
goto return_integer;
case 136: /* find current position */
if (numargs != 1) goto argcerror;
leftint = (int) ftell(phil->fp);
goto return_integer;
case 140:
errp = "block execute should be trapped by interp";
goto return_error;
case 141: /* newProcess (withArguments:) */
if (numargs < 1) goto argcerror;
if (! is_block(args[0])) goto argterror;
if (numargs == 1)
resultobj = (object *) cr_process(
block_execute((interpreter *) 0,
(block *) args[0], 0, args));
else if (numargs == 2)
resultobj = (object *) cr_process(
block_execute((interpreter *) 0,
(block *) args[0], args[1]->size,
&(args[1]->inst_var[0])));
else goto argcerror;
goto return_obj;
case 142: /* terminate a process */
if (numargs != 1) goto argcerror;
if (! is_process(args[0])) goto argterror;
terminate_process( (process *) args[0]);
goto return_nil;
case 143: /* perform:withArguments: */
errp = "perform should be trapped by interpreter";
goto return_error;
case 145: /* set the state of a process */
if (numargs != 2) goto argcerror;
if (! is_process(args[0])) goto argterror;
if (! is_integer(args[1])) goto argterror;
leftint = int_value(args[1]);
switch (leftint) {
case 0: leftint = READY;
break;
case 1: leftint = SUSPENDED;
break;
case 2: leftint = BLOCKED;
break;
case 3: leftint = UNBLOCKED;
break;
default: errp = "invalid state for process";
goto return_error;
}
set_state((process *) args[0], leftint);
goto return_integer;
case 146: /* return the state of a process */
if (numargs != 1) goto argcerror;
if (! is_process(args[0])) goto argterror;
leftint = set_state((process *) args[0], CUR_STATE);
goto return_integer;
case 148: /* begin atomic action */
if (numargs != 0) goto argcerror;
atomcnt++;
goto return_nil;
case 149: /* end atomic action */
if (numargs != 0) goto argcerror;
if (atomcnt == 0) {
errp = "end atomic attempted while not in atomic action";
goto return_error;
}
atomcnt--;
goto return_nil;
case 150: /* class edit */
leftp = symbol_value(aClass->file_name);
if (! writeable(leftp)) {
gettemp(tempname);
sprintf(strbuffer,"cp %s %s", leftp, tempname);
# ifndef NOSYSTEM
system(strbuffer);
# endif
leftp = tempname;
}
if (! lexedit(leftp)) lexinclude(leftp);
goto return_nil;
case 151: /* superclass of a class */
if (! aClass->super_class)
goto return_nil;
resultobj = (object *) aClass->super_class;
if (! is_symbol(resultobj)) goto return_nil;
resultobj = lookup_class(symbol_value(resultobj));
if (! resultobj) goto return_nil;
goto return_obj;
case 152: /* class name */
resultobj = aClass->class_name;
leftp = symbol_value(resultobj);
resultobj = new_str(leftp);
goto return_obj;
case 153: /* new */
if (numargs != 2) goto argcerror;
if (args[1] == o_nil)
resultobj = new_inst(aClass);
else
resultobj = new_sinst(aClass, args[1]);
goto return_obj;
case 154: /* print message names list */
prnt_messages(aClass);
goto return_nil;
case 155: /* respondsTo: aMessage */
if (numargs != 2) goto argcerror;
if (! is_symbol(args[1])) goto argterror;
leftint = responds_to(symbol_value(args[1]), aClass);
goto return_boolean;
case 156: /* class view */
leftp = symbol_value(aClass->file_name);
gettemp(tempname);
# ifndef NOSYSTEM
sprintf(strbuffer,"cp %s %s", leftp, tempname);
# endif
system(strbuffer);
leftp = tempname;
lexedit(leftp);
goto return_nil;
case 157: /* class list */
class_list(aClass, 0);
goto return_nil;
case 158: /* variables */
resultobj = aClass->c_inst_vars;
goto return_obj;
case 160: /* current time */
time(&clock);
strcpy(strbuffer, ctime(&clock));
goto return_string;
case 161: /* time, measure in seconds */
leftint = (int) time((long *) 0);
goto return_integer;
default: fprintf(stderr,"Primitive number %d not implemented\n",
primnumber);
goto return_nil;
}
/* return different types of objects */
return_obj:
return(resultobj);
return_nil:
return(o_nil);
return_integer:
return(new_int(leftint));
return_character:
return(new_char(leftint));
return_boolean:
return(leftint ? o_true : o_false);
float_check:
if (errno == ERANGE || errno == EDOM) goto numerror;
return_float:
return(new_float(leftfloat));
return_string:
return(new_str(strbuffer));
/* error conditions */
not_implemented:
sprintf(strbuffer,"%s not implemented yet", errp);
errp = strbuffer;
goto return_error;
argcerror:
sprintf(strbuffer,"%d is wrong number of arguments for primitive %d",
numargs, primnumber);
errp = strbuffer;
goto return_error;
argterror:
sprintf(strbuffer,"argument type not correct for primitive %d",
primnumber);
errp = strbuffer;
goto return_error;
numerror:
errp = "numerical error in primitive";
goto return_error;
indexerror:
errp = "primitive index error";
goto return_error;
return_error:
sassign(resultobj, new_str(errp));
primitive(ERRPRINT, 1, &resultobj);
obj_dec(resultobj);
goto return_nil;
}
static prnt_radix(n, r, buffer)
int n, r;
char buffer[];
{ char *p, *q, buffer2[60];
int i, s;
if (n < 0) {n = - n; s = 1;}
else s = 0;
p = buffer2; *p++ = '\0';
if (n == 0) *p++ = '0';
while (n) {
i = n % r;
*p++ = i + ((i < 10) ? '0' : ('A' - 10));
n = n / r;
}
sprintf(buffer,"%dr", r);
for (q = buffer; *q; q++);
if (s) *q++ = '-';
for (*p = '0' ; *p ; ) *q++ = *--p;
*q = '\0';
}
static fprnt_radix(f, n, buffer)
double f;
int n;
char buffer[];
{ int sign, exp, i, j;
char *p, *q, tempbuffer[60];
double ip;
if (f < 0) {
sign = 1;
f = - f;
}
else sign = 0;
exp = 0;
if (f != 0) {
exp = (int) floor(log(f) / log((double) n));
if (exp < -4 || 4 < exp) {
f *= pow((double) n, (double) - exp);
}
else exp = 0;
}
f = modf(f, &ip);
if (sign) ip = - ip;
prnt_radix((int) ip, n, buffer);
for (p = buffer; *p; p++) ;
if (f != 0) {
*p++ = '.';
for (j = 0; (f != 0) && (j < 6); j++){
i = (int) (f *= n);
*p++ = (i < 10) ? '0' + i : 'A' + (i-10) ;
f -= i;
}
}
if (exp) {
*p++ = 'e';
sprintf(tempbuffer,"%d", exp);
for (q = tempbuffer; *q; )
*p++ = *q++;
}
*p = '\0';
return;
}
/* generalit - numerical generality */
static int generality(aNumber)
object *aNumber;
{ int i;
if (is_integer(aNumber)) i = 1;
else if (is_float(aNumber)) i = 2;
else i = 3;
return(i);
}
/* cant_happen - report that an impossible condition has occured */
cant_happen(n) int n;
{ char *s;
# ifdef SMALLDATA
s = "what a pain!";
# endif
# ifndef SMALLDATA
switch(n) {
case 1: s = "out of memory allocation space"; break;
case 2: s = "array size less than zero"; break;
case 3: s = "block return from call should not occur"; break;
case 4: s = "attempt to make instance of non class"; break;
case 5: s = "case error in new integer or string"; break;
case 6: s = "decrement on unknown built in object"; break;
case 7: s = "cannot find class Object"; break;
case 8: s = "primitive free of object of wrong type"; break;
case 9: s = "internal interpreter error"; break;
case 11: s = "block execute on non-block"; break;
case 12: s = "out of symbol space"; break;
case 14: s = "out of standard bytecode space"; break;
case 15: s = "system deadlocked - all processes blocked"; break;
case 16: s = "attempt to free symbol"; break;
case 17: s = "invalid process state passed to set_state"; break;
case 18: s = "internal buffer overflow"; break;
case 20: s = "can't open prelude file"; break;
case 22: s = "system file open error"; break;
case 23: s = "fastsave error"; break;
default: s = "unknown, but impossible nonetheless, condition"; break;
}
# endif
fprintf(stderr,"Can't happen number %d: %s\n", n, s);
n = n / 0; /* on vax, this will force a core dump */
exit(1);
}
/* writeable - see if a file can be written to */
int writeable(name)
char *name;
{ char buffer[150];
sprintf(buffer,"test -w %s", name);
# ifdef NOSYSTEM
return(0);
# endif
# ifndef NOSYSTEM
return(! system(buffer));
# endif
}
SHAR_EOF
if test 31094 -ne "`wc -c < 'sources/primitive.c'`"
then
echo shar: error transmitting "'sources/primitive.c'" '(should have been 31094 characters)'
fi
fi # end of overwriting check
if test -f 'sources/primitive.h'
then
echo shar: will not over-write existing file "'sources/primitive.h'"
else
cat << \SHAR_EOF > 'sources/primitive.h'
/*
Little Smalltalk primitive definitions
(only a subset of primitives are described here,
basically those used by the courier and other systems routines.
All other primitives are known only by number)
*/
# define EQTEST 7
# define GAMMAFUN 77
# define SYMEQTEST 91
# define SYMPRINT 94
# define FINDCLASS 99
# define GROW 113
# define BLKRETERROR 127
# define REFCOUNTERROR 128
# define NORESPONDERROR 129
# define RAWPRINT 120
# define PRINT 121
# define ERRPRINT 123
# define BLOCKEXECUTE 140
# define DOPERFORM 143
SHAR_EOF
if test 528 -ne "`wc -c < 'sources/primitive.h'`"
then
echo shar: error transmitting "'sources/primitive.h'" '(should have been 528 characters)'
fi
fi # end of overwriting check
if test -f 'sources/process.c'
then
echo shar: will not over-write existing file "'sources/process.c'"
else
cat << \SHAR_EOF > 'sources/process.c'
/*
Little Smalltalk
process manager
dennis a. vadner and michael t. benhase, 11/84
modified by timothy a. budd 4/85
*/
/*
The source code for the Little Smalltalk System may be freely
copied provided that the source of all files is acknowledged
and that this condition is copied with each file.
The Little Smalltalk System is distributed without responsibility
for the performance of the program and without any guarantee of
maintenance.
All questions concerning Little Smalltalk should be addressed to:
Professor Tim Budd
Department of Computer Science
The University of Arizona
Tucson, Arizona
85721
USA
*/
# include <stdio.h>
# include <signal.h>
# include <setjmp.h>
# include "drive.h"
# include "object.h"
# include "interp.h"
# include "process.h"
extern int test_driver(); /* routine to test for user keystrokes*/
static process *currentProcess; /* current process */
static process *fr_process = 0; /* process memory free list */
int atomcnt = 0; /* atomic action flag */
process *runningProcess; /* currently running process,
may be different from
currentProcess during process
termination */
# define PROCINITMAX 6
static process prcinit[PROCINITMAX]; /* initial process free list */
/* init_process - initialize the process module */
init_process ()
{ process *p;
int i;
/* first make the initial process free list */
for (p = prcinit, i = 0; i < PROCINITMAX; i++, p++) {
p->next = fr_process;
fr_process = p;
}
/* make the process associated with the driver */
currentProcess = cr_process(o_drive);
assign(currentProcess->next, currentProcess);
assign(currentProcess->prev, currentProcess);
currentProcess->p_state = ACTIVE;
}
/* cr_process - create a new process with the given interpreter */
process *cr_process (anInterpreter)
interpreter *anInterpreter;
{ process *new;
if (fr_process) {
new = (process *) fr_process;
fr_process = fr_process->next;
}
else
new = structalloc(process);
new->p_ref_count = 0;
new->p_size = PROCSIZE;
sassign(new->interp, anInterpreter);
new->p_state = SUSPENDED;
sassign(new->next, (process *) o_nil);
sassign(new->prev, (process *) o_nil);
return(new);
}
/* free_process - return an unused process to free list */
free_process (aProcess)
process *aProcess;
{
obj_dec((object *) aProcess->interp);
obj_dec((object *) aProcess->next);
obj_dec((object *) aProcess->prev);
aProcess->p_state = TERMINATED;
aProcess->next = fr_process;
fr_process = aProcess;
}
/* flush_processes - flush out any remaining process from queue */
flush_processes ()
{
while (currentProcess != currentProcess->next)
remove_process(currentProcess);
/* prev link and next link should point to the same place now.
In order to avoid having memory recovered while we are
manipulating pointers, we increment reference count, then change
pointers, then decrement reference counts */
obj_inc((object *) currentProcess);
safeassign(currentProcess->prev, (process *) o_nil);
safeassign(currentProcess->next, (process *) o_nil);
obj_dec((object *) currentProcess);
}
/* link_to_process - change the interpreter for the current process */
link_to_process (anInterpreter)
interpreter *anInterpreter;
{ object *temp;
safeassign(runningProcess->interp, anInterpreter);
}
/* remove_process - remove a process from process queue */
static remove_process (aProcess)
process *aProcess;
{
if (aProcess == aProcess->next)
cant_happen(15); /* removing last active process */
/* currentProcess must always point to a process that is on the
process queue, make sure this remains true */
if (aProcess == currentProcess)
currentProcess = currentProcess->prev;
/* In order to avoid having memory recovered while we are changing
pointers, we increment the reference counts on both processes,
change pointers, then decrement reference counts */
obj_inc((object *) currentProcess); obj_inc((object *) aProcess);
safeassign(aProcess->next->prev, aProcess->prev);
safeassign(aProcess->prev->next, aProcess->next);
obj_dec((object *) currentProcess); obj_dec((object *) aProcess);
}
/* schedule_process - add a new process to the process queue */
static schedule_process (aProcess)
process *aProcess;
{
safeassign(aProcess->next, currentProcess);
safeassign(aProcess->prev, currentProcess->prev);
safeassign(aProcess->prev->next, aProcess);
safeassign(currentProcess->prev, aProcess);
}
/* set_state - set the state on a process, which may involve inserting or
removing it from the process queue */
int set_state (aProcess, state)
process *aProcess;
int state;
{
switch (state) {
case BLOCKED:
case SUSPENDED:
case TERMINATED: if (aProcess->p_state == ACTIVE)
remove_process(aProcess);
aProcess->p_state |= state;
break;
case READY:
case UNBLOCKED: if ((aProcess->p_state ^ state) == ~ACTIVE)
schedule_process(aProcess);
aProcess->p_state &= state;
break;
case CUR_STATE: break;
default: cant_happen(17);
}
return(aProcess->p_state);
}
# ifdef SETJUMP
static jmp_buf intenv;
# endif
/* brkfun - what to do on a break key */
brkfun()
{ static int warn = 1;
# ifndef SETJUMP
exit(1);
# endif
if (warn) {
fprintf(stderr,"warning: recovery from interrupt may cause\n");
fprintf(stderr,"reference counts to be incorrect, and\n");
fprintf(stderr,"some memory to be inaccessible\n");
warn = 0;
}
# ifdef SETJUMP
longjmp(intenv, 1);
# endif
}
/* start_execution - main execution loop */
start_execution ()
{ interpreter *presentInterpreter;
atomcnt = 0;
# ifdef SIGS
/* trap user interrupt signals and recover */
signal(SIGINT, brkfun);
# endif
# ifdef SETJUMP
if (setjmp(intenv)) {
atomcnt = 0;
link_to_process(o_drive);
}
# endif
while (1) {
/* unless it is an atomic action get the next process */
if (! atomcnt)
runningProcess = currentProcess = currentProcess->next;
if (! is_driver(runningProcess->interp)) {
sassign(presentInterpreter, runningProcess->interp);
resume(presentInterpreter);
obj_dec((object *) presentInterpreter);
}
else if (! test_driver((currentProcess == currentProcess->next) ||
(atomcnt > 0)))
break;
}
}
SHAR_EOF
if test 6273 -ne "`wc -c < 'sources/process.c'`"
then
echo shar: error transmitting "'sources/process.c'" '(should have been 6273 characters)'
fi
fi # end of overwriting check
if test -f 'sources/process.h'
then
echo shar: will not over-write existing file "'sources/process.h'"
else
cat << \SHAR_EOF > 'sources/process.h'
/*
Little Smalltalk
process definitions
dennis a. vadner and michael t. benhase, 11/84
*/
/*
the process
interp = pointer to the head of the process'
interpreter chain
p_state = current state of the process
next = link to the next process in the active list
prev = link to the previous process in the active list
*/
struct process_struct {
int p_ref_count;
int p_size;
interpreter *interp;
int p_state;
struct process_struct *next;
struct process_struct *prev;
} ;
typedef struct process_struct process;
extern int atomcnt; /* atomic action flag */
extern process *runningProcess; /* currently running process */
extern process *cr_process(); /* create a new process */
extern int set_state(); /* set the state on a process */
/* process states */
# define ACTIVE 0
# define SUSPENDED 1
# define READY ~SUSPENDED
# define BLOCKED 2
# define UNBLOCKED ~BLOCKED
# define TERMINATED 4
# define CUR_STATE 10
# define terminate_process(aProcess) {set_state(aProcess, TERMINATED); \
if (aProcess == runningProcess) \
atomcnt = 0;}
SHAR_EOF
if test 1106 -ne "`wc -c < 'sources/process.h'`"
then
echo shar: error transmitting "'sources/process.h'" '(should have been 1106 characters)'
fi
fi # end of overwriting check
if test -f 'sources/sstr.c'
then
echo shar: will not over-write existing file "'sources/sstr.c'"
else
cat << \SHAR_EOF > 'sources/sstr.c'
/*
sstr - find and replace string occurrences
with common addresses,
can be used to share strings accross compiled boundaries
written by tim budd, 9/84
*/
/*
The source code for the Little Smalltalk System may be freely
copied provided that the source of all files is acknowledged
and that this condition is copied with each file.
The Little Smalltalk System is distributed without responsibility
for the performance of the program and without any guarantee of
maintenance.
All questions concerning Little Smalltalk should be addressed to:
Professor Tim Budd
Department of Computer Science
The University of Arizona
Tucson, Arizona
85721
USA
*/
# include <stdio.h>
# define WORDTABMAX 1000
# define STRTABMAX 10000
int x_cmax = 0;
int x_tmax = -1;
char x_str[STRTABMAX];
char *x_tab[WORDTABMAX];
main(argc, argv)
int argc;
char **argv;
{ int i;
FILE *fd;
if (strcmp(argv[1], "-f") == 0) {
for (i = 2; i < argc; i++) {
fd = fopen(argv[i], "r");
if (fd != NULL) {
findstrs(fd);
fclose(fd);
}
}
}
else if (strcmp(argv[1], "-t") == 0) {
for (i = 4; i < argc; i++)
puts(argv[i]);
fd = fopen(argv[2], "r");
if (fd == NULL) {
fprintf(stderr,"can't open string table\n");
exit(1);
}
maketab(fd, stdout, argv[3]);
}
else {
fd = fopen(argv[1], "r");
if (fd == NULL) {
fprintf(stderr,"can't open string table\n");
exit(1);
}
maketab(fd, 0, 0);
printf("extern char x_str[];\n");
replacestr(stdin);
}
exit(0);
}
/* findstrs - find all strings and output them to stdout */
findstrs(fd)
FILE *fd;
{
char *p, buffer[500];
int c;
for (; (c = getc(fd)) != EOF; )
if (c == '\"') {
for (p = buffer; (c = getc(fd)) != '\"'; p++)
if (c == EOF) {
fprintf(stderr,"unexpected eof\n");
exit(1);
}
else *p = c;
*p = '\0';
puts(buffer);
}
}
/* replacestr - replace strings with their address in x_str */
replacestr(fd)
FILE *fd;
{
char *p, buffer[500], *w_search();
int c;
for (; (c = getc(fd)) != EOF; )
if (c != '\"') putchar(c);
else {
for (p = buffer; (c = getc(fd)) != '\"'; p++)
if (c == EOF) {
fprintf(stderr,"unexpected eof\n");
exit(1);
}
else *p = c;
*p = '\0';
p = w_search(buffer, 0);
if (p) printf("&x_str[%d]", p - &x_str[0]);
else printf("\"%s\"", buffer);
}
}
maketab(ifd, ofd, itab)
FILE *ifd, *ofd;
char *itab;
{ char wbuf[100], *p;
int i;
x_cmax = 0;
if (ofd)
fprintf(ofd, "char x_str[] = {");
while (fgets(wbuf, 100, ifd) != NULL) {
x_tab[++x_tmax] = &x_str[x_cmax];
for (p = wbuf; *p; p++) {
if (*p == '\n') {*p = '\0'; break;}
if (ofd)
fprintf(ofd,"0%o, ", *p);
x_str[x_cmax++] = *p;
}
if (ofd)
fprintf(ofd, "0, /* %s */\n", wbuf);
x_str[x_cmax++] = '\0';
}
if (ofd) {
fprintf(ofd, "0 };\n");
fprintf(ofd, "int x_cmax = %d;\n", x_cmax);
}
if (itab) {
fprintf(ofd, "static symbol x_sytab[] = {\n");
for (i = 0; i <= x_tmax; i++) {
fprintf(ofd, "{1, SYMBOLSIZE, &x_str[%d]}, /* ",
x_tab[i]-x_tab[0]);
for (p = x_tab[i]; *p; p++)
putc(*p, ofd);
fprintf(ofd," */\n");
}
fprintf(ofd, "0};\n");
fprintf(ofd, "symbol *x_tab[%s] = {\n", itab);
for (i = 0; i <= x_tmax; i++) {
fprintf(ofd, "&x_sytab[%d], /* ",i);
for (p = x_tab[i]; *p; p++)
putc(*p, ofd);
fprintf(ofd," */\n");
}
fprintf(ofd, "0};\n");
fprintf(ofd,"int x_tmax = %d;\n", x_tmax);
}
}
/*
word search for table routines
*/
char *w_search(word, insert)
char *word;
int insert;
{ int i,j,k;
for (i=1; i <= x_tmax; i <<= 1);
for (i >>= 1, j = i >>1, i--; ; j >>= 1) {
if (! (k = strcmp(word, x_tab[i])))
return(x_tab[i]);
if (!j) break;
if (k < 0) i -= j;
else {
if ((i += j) > x_tmax) i = x_tmax;
}
}
if (insert) {
for (k = ++x_tmax; k > i; k--) {
x_tab[k] = x_tab[k-1];
}
if (!(x_tab[i] = (char *) malloc(1 + strlen(word))))
return((char *) 0);
strcpy(x_tab[i], word);
return(x_tab[i]);
}
else return((char *) 0);
}
SHAR_EOF
if test 4018 -ne "`wc -c < 'sources/sstr.c'`"
then
echo shar: error transmitting "'sources/sstr.c'" '(should have been 4018 characters)'
fi
fi # end of overwriting check
if test -f 'sources/string.c'
then
echo shar: will not over-write existing file "'sources/string.c'"
else
cat << \SHAR_EOF > 'sources/string.c'
/*
Little Smalltalk
string creation and deletion
timothy a. budd, 10/84
*/
/*
The source code for the Little Smalltalk System may be freely
copied provided that the source of all files is acknowledged
and that this condition is copied with each file.
The Little Smalltalk System is distributed without responsibility
for the performance of the program and without any guarantee of
maintenance.
All questions concerning Little Smalltalk should be addressed to:
Professor Tim Budd
Department of Computer Science
The University of Arizona
Tucson, Arizona
85721
USA
*/
# include <stdio.h>
# include "object.h"
# include "string.h"
int ca_str = 0;
int ca_wal = 0;
/* walloc allocates a string containing the same chars as the arg */
# define WALLOCINITSIZE 1000
static char wtable[WALLOCINITSIZE];
int wtop = 0;
char *walloc(val)
char *val;
{ char *p;
int size;
size = 1 + strlen(val);
if ((size < 40) && ((wtop + size) < WALLOCINITSIZE)) {
p = &wtable[wtop];
wtop += size;
}
else {
p = o_alloc((unsigned) size);
ca_wal++;
}
strcpy(p, val);
return(p);
}
/*---------------------------------------*/
extern class *ArrayedCollection;
extern object *o_acollection;
static mstruct *fr_string = 0;
# define STRINITSIZE 50
static string st_init_table[STRINITSIZE];
str_init() {
string *p;
mstruct *new;
int i;
for (p = st_init_table, i = 0; i < STRINITSIZE; i++, p++) {
new = (mstruct *) p;
new->mlink = fr_string;
fr_string = new;
}
}
extern int started;
static new_rstr(new)
string *new;
{
new->s_ref_count = 0;
new->s_size = STRINGSIZE;
if (! started)
sassign(new->s_super_obj, o_acollection);
else if (ArrayedCollection)
sassign(new->s_super_obj, new_inst(ArrayedCollection));
else
new->s_super_obj = (object *) 0;
}
string *new_istr(text)
char *text;
{ register string *new;
if (fr_string) {
new = (string *) fr_string;
fr_string = fr_string->mlink;
}
else {
ca_str++;
new = structalloc(string);
}
new->s_value = text;
new_rstr(new);
return(new);
}
# define STRLISTMAX 100
mstruct *frl_str[STRLISTMAX];
object *new_str(text)
char *text;
{ int size;
string *new;
size = 1 + strlen(text);
if ((size < STRLISTMAX) && frl_str[size]) {
new = (string *) frl_str[size];
frl_str[size] = frl_str[size]->mlink;
strcpy(new->s_value, text);
new_rstr(new);
}
else {
new = new_istr(walloc(text));
}
return((object *) new);
}
free_string(s)
string *s;
{ int size;
if (s->s_super_obj)
obj_dec(s->s_super_obj);
size = 1 + strlen(s->s_value);
if (size < STRLISTMAX) {
((mstruct *)s)->mlink = frl_str[size];
frl_str[size] = (mstruct *) s;
}
else {
((mstruct *)s)->mlink = fr_string;
fr_string = (mstruct *) s;
}
}
SHAR_EOF
if test 2734 -ne "`wc -c < 'sources/string.c'`"
then
echo shar: error transmitting "'sources/string.c'" '(should have been 2734 characters)'
fi
fi # end of overwriting check
if test -f 'sources/string.h'
then
echo shar: will not over-write existing file "'sources/string.h'"
else
cat << \SHAR_EOF > 'sources/string.h'
/*
Little Smalltalk string definitions
*/
/*
for strings s_size = STRINGSIZE
Unlike other special objects (integers, floats, etc), strings
must keep their own super_obj pointer, since the class
ArrayedCollection (a super class of String) contains instance
variables, and thus each instance of String must have a unique
super_obj.
*/
struct string_struct {
int s_ref_count;
int s_size;
object *s_super_obj;
char *s_value;
} ;
typedef struct string_struct string;
extern object *new_str(); /* make a new string object */
extern string *new_istr(); /* internal form of new string */
extern char *walloc(); /* allocate a copy a word */
# define string_value(x) (((string *) x)->s_value)
SHAR_EOF
if test 706 -ne "`wc -c < 'sources/string.h'`"
then
echo shar: error transmitting "'sources/string.h'" '(should have been 706 characters)'
fi
fi # end of overwriting check
if test -f 'sources/symbol.c'
then
echo shar: will not over-write existing file "'sources/symbol.c'"
else
cat << \SHAR_EOF > 'sources/symbol.c'
/*
Little Smalltalk
symbol creation - symbols are never deleted once created.
timothy a. budd, 10/84
*/
/*
The source code for the Little Smalltalk System may be freely
copied provided that the source of all files is acknowledged
and that this condition is copied with each file.
The Little Smalltalk System is distributed without responsibility
for the performance of the program and without any guarantee of
maintenance.
All questions concerning Little Smalltalk should be addressed to:
Professor Tim Budd
Department of Computer Science
The University of Arizona
Tucson, Arizona
85721
USA
*/
# include <stdio.h>
# include "object.h"
# include "symbol.h"
/*
only one copy of symbol values are kept.
multiple copies of the same symbol point to the same
location.
sy_search will find, and if necessary insert, a string into
this common table
*/
extern char x_str[]; /* initialized common string table */
extern symbol *x_tab[]; /* initialized common symbols table */
extern int x_tmax; /* top of symbols table */
extern char *walloc(); /* routine to allocate a new word */
int ca_sym = 0; /* symbol allocation counter */
/* sy_search performs a binary search of a symbol, is the main interface to
the symbols routines */
symbol *sy_search(word, insert)
char *word;
int insert;
{ register int i;
register int j;
register int k;
char *p;
symbol *new_y();
for (i=1; i <= x_tmax; i <<= 1);
for (i >>= 1, j = i >>1, i--; ; j >>= 1) {
p = symbol_value(x_tab[i]);
if (word == p) return(x_tab[i]);
k = *word - *p;
if (!k) k = *(word+1) - *(p+1);
if (!k) k = strcmp(word, p);
if (!k)
return(x_tab[i]);
if (!j) break;
if (k < 0) i -= j;
else {
if ((i += j) > x_tmax) i = x_tmax;
}
}
if (insert) {
if (k > 0) i++;
if ((k = ++x_tmax) >= SYMTABMAX)
cant_happen(12);
for (; k > i; k--) {
x_tab[k] = x_tab[k-1];
}
/*fprintf(stderr,"adding %s\n", word);*/
x_tab[i] = new_y(walloc(word));
x_tab[i]->y_ref_count++; /* make sure not freed */
return(x_tab[i]);
}
else return((symbol *) 0);
}
/* w_search performs a search for a word, not a symbol */
char *w_search(word, insert)
char *word;
int insert;
{ symbol *sym;
sym = sy_search(word, insert);
if (sym)
return(symbol_value(sym));
else
return((char *) 0);
}
/*---------------------------------------*/
static mstruct *fr_symbol = 0; /* symbols free list */
static symbol strspace[SYMINITSIZE]; /* initial symbols free list */
extern object *o_object; /* common instance of Object */
extern class *ArrayedCollection;
/* sym_init - initialize the symbols routine */
sym_init() {
int i;
symbol *p;
mstruct *new;
p = strspace;
for (i = 0; i < SYMINITSIZE; i++) {
new = (mstruct *) p;
new->mlink = fr_symbol;
fr_symbol = new;
p++;
}
}
/* new_y is the internal routine for making new symbols */
symbol *new_y(text)
char *text;
{ symbol *new;
if (fr_symbol) {
new = (symbol *) fr_symbol;
fr_symbol = fr_symbol->mlink;
}
else {
ca_sym++;
new = structalloc(symbol);
}
new->y_ref_count = 0;
new->y_size = SYMBOLSIZE;
new->y_value = text;
return(new);
}
SHAR_EOF
if test 3138 -ne "`wc -c < 'sources/symbol.c'`"
then
echo shar: error transmitting "'sources/symbol.c'" '(should have been 3138 characters)'
fi
fi # end of overwriting check
# End of shell archive
exit 0