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/drive.c
# sources/file.c
# sources/file.h
# sources/interp.c
# sources/interp.h
# sources/lex.c
# sources/lexcmd.c
# sources/line.c
# This archive created: Thu Jun 13 11:32:56 1985
# By: Earl Wallace (Perkin-Elmer Data Systems Group / Customer Service)
export PATH; PATH=/bin:$PATH
if test -f 'sources/drive.c'
then
echo shar: will not over-write existing file "'sources/drive.c'"
else
cat << \SHAR_EOF > 'sources/drive.c'
/*
Little Smalltalk
command parser
timothy a. budd, 12/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"
# define DRIVECODE
# include "drive.h"
# include "cmds.h"
# include "number.h"
# include "symbol.h"
# include "string.h"
# include "byte.h"
# include "interp.h"
# include "primitive.h"
extern enum lextokens token, nextlex();
extern int prntcmd;
extern int inisstd;
extern int started;
extern char toktext[];
extern char *lexptr;
extern int line_grabber();
extern tok_type t;
/* test_driver - see if the driver should be invoked */
int test_driver(block)
int block; /* indicates wheter to use block or non-blocking input */
{
switch(line_grabber( block )) {
default: cant_happen(17);
case -1:
/* return end of file indication */
return(0);
case 0:
/* enqueue driver process again */
return(1);
case 1:
if (*lexptr == ')') {
dolexcommand(lexptr);
return(1);
}
parse();
return(1);
}
}
/* ---- code generation routines -------------- */
# define CODEMAX 500
static uchar code[CODEMAX];
static int codetop = 0;
static gencode(value)
register int value;
{
if (value >= 256)
lexerr("code word too big: %d", value);
if (codetop > CODEMAX)
lexerr("too many code words: %d", codetop);
/*if (started)
fprintf(stderr,"code %d (%d %d)\n", value, value/16, value%16);*/
code[codetop++] = itouc(value);
}
static genhighlow(high, low)
register int high;
register int low;
{
if (high < 0 || high > 16)
lexerr("genhighlow error: %d", high);
if (low < 0)
lexerr("genhighlow low error: %d", low);
if (low < 16) gencode(high * 16 + low);
else {
gencode(TWOBIT * 16 + high);
gencode(low);
}
}
/*-------------------------------------------------------*/
static int errflag;
/* parse - main parser */
int parse()
{ register int i;
errflag = 0;
reset();
if (nextlex() == nothing) return(1);
if (token == NL) return(1);
i = aprimary();
if (i >= 0) {
asign(i);
if ((prntcmd > 1) && inisstd)
genhighlow(UNSEND, PRNTCMD);
}
else {
cexpression();
if (prntcmd && inisstd)
genhighlow(UNSEND, PRNTCMD);
}
genhighlow(POPINSTANCE, 0); /* assign to ``last'' */
if (errflag)
return(1);
if (token == nothing || token == NL) {
bld_interpreter();
return(0);
}
expect("end of expression");
return(1);
}
/* asign - code for an assignment statement - leaves result on stack */
static asign(pos)
int pos;
{ int i;
i = aprimary();
if (i >= 0) {
asign(i);
}
else {
cexpression();
}
genhighlow(SPECIAL, DUPSTACK);
genhighlow(POPINSTANCE, pos);
}
/* expression - read an expression, leaving result on stack */
static expression()
{ int i;
i = aprimary();
if (i >= 0) {
asign(i);
}
else {
cexpression();
}
}
/* cexpression - code for a (possibly cascaded) expression */
static cexpression()
{
kcontinuation();
while (token == SEMI) {
genhighlow(SPECIAL, DUPSTACK);
nextlex();
kcontinuation();
genhighlow(SPECIAL, POPSTACK);
}
}
/* kcontinuation - keyword continuation */
static kcontinuation()
{ char kbuf[150];
int kcount;
bcontinuation();
if (token == KEYWORD) {
kbuf[0] = '\0';
kcount = 0;
while (token == KEYWORD) {
strcat(kbuf, t.c);
strcat(kbuf, ":");
kcount++;
nextlex();
primary(1);
bcontinuation();
}
gensend(kbuf, kcount);
}
}
/* isbinary - see if the current token(s) is a binary */
static int isbinary(bbuf)
char *bbuf;
{
if (token == BINARY || token == MINUS ||
token == BAR || token == PE) {
strcpy(bbuf, t.c);
nextlex();
if (token == BINARY || token == MINUS ||
token == BAR || token == PE) {
strcat(bbuf, t.c);
nextlex();
}
return(1);
}
return(0);
}
/* bcontinuation - binary continuation */
static bcontinuation()
{ char bbuf[3];
ucontinuation();
while (isbinary(bbuf)) {
primary(1);
ucontinuation();
gensend(bbuf, 1);
}
}
/* ucontinuation - unary continuation */
static ucontinuation()
{
while (token == LOWERCASEVAR) {
gensend(t.c, 0);
nextlex();
}
}
/* aprimary - primary or beginning of assignment */
static int aprimary()
{ char *c;
if (token == LOWERCASEVAR) {
c = t.c;
if (nextlex() == ASSIGN) {
nextlex();
return(findvar(c, 1));
}
else {
genvar(c);
return( -1 );
}
}
primary(1);
return( - 1 );
}
/* primary - find a primary expression */
static int primary(must)
int must; /* must we find something ? */
{ int i, count;
switch(token) {
case UPPERCASEVAR:
genhighlow(PUSHCLASS, aliteral(1));
break;
case LOWERCASEVAR:
genvar(t.c);
nextlex();
break;
case LITNUM:
if (t.i >= 0 && t.i < 10) {
genhighlow(PUSHSPECIAL, t.i);
nextlex();
}
else {
genhighlow(PUSHLIT, aliteral(1));
}
break;
case MINUS:
case LITFNUM:
case LITCHAR:
case LITSTR:
case LITSYM:
case PS:
genhighlow(PUSHLIT, aliteral(1));
break;
case PSEUDO:
switch(t.p) {
case nilvar: i = 13; break;
case truevar: i = 11; break;
case falsevar: i = 12; break;
case smallvar: i = 14; break;
default: lexerr("unknown pseudo var %d", t.p);
}
genhighlow(PUSHSPECIAL, i);
nextlex();
break;
case PRIMITIVE:
if (nextlex() != LITNUM) expect("primitive number");
i = t.i;
nextlex();
count = 0;
while (primary(0)) count++;
if (token != PE) expect("primitive end");
nextlex();
genhighlow(SPECIAL, PRIMCMD);
gencode(count);
gencode(i);
break;
case LP:
nextlex();
expression();
if (token != RP) expect("right parenthesis");
nextlex();
break;
case LB:
nextlex();
block();
break;
default:
if (must) expect("primary expression");
return(0);
}
return(1);
}
static int maxtemps = 1;
static int temptop = 0;
static char *tempnames[20];
/* block - parse a block definition */
static block()
{ int count, i, position;
count = 0;
if (token == COLONVAR) {
while (token == COLONVAR) {
tempnames[temptop++] = t.c;
if (temptop > maxtemps) maxtemps = temptop;
count++;
nextlex();
}
if (token != BAR)
expect("bar following arguments in block");
nextlex();
}
genhighlow(BLOCKCREATE, count);
if (count) /* where arguments go in context */
gencode(1 + (temptop - count));
position = codetop;
gencode(0);
if (token == RB) {
genhighlow(PUSHSPECIAL, 13);
}
else
while (1) {
i = aprimary();
if (i >= 0) {
expression();
if (token != PERIOD)
genhighlow(SPECIAL, DUPSTACK);
genhighlow(POPINSTANCE, i);
}
else {
cexpression();
if (token == PERIOD)
genhighlow(SPECIAL, POPSTACK);
}
if (token != PERIOD)
break;
nextlex();
}
genhighlow(SPECIAL, RETURN);
if (token != RB) expect("end of block");
temptop -= count;
nextlex();
i = (codetop - position) - 1;
if (i > 255)
lexerr("block too big %d", i);
code[position] = itouc(i);
}
# define LITMAX 100
static object *lit_array[LITMAX];
static int littop = 0;
static int addliteral(lit)
object *lit;
{
if (littop >= LITMAX)
cant_happen(18);
sassign(lit_array[littop++], lit);
return(littop - 1);
}
/* aliteral - find a literal that is part of a literal array */
static int aliteral(must)
int must; /* must we find something ? */
{ char *c;
object *new;
int count;
int bytetop;
uchar bytes[200];
switch(token) {
case MINUS:
c = t.c;
nextlex();
if (token == LITNUM) {
new = new_int( - t.i );
nextlex();
}
else if (token == LITFNUM) {
new = new_float( - t.f );
nextlex();
}
else {
new = new_sym(c);
}
break;
case LITNUM:
new = new_int(t.i);
nextlex();
break;
case LITFNUM:
new = new_float(t.f);
nextlex();
break;
case LITCHAR:
new = new_char(t.i);
nextlex();
break;
case LITSTR:
new = new_str(t.c);
nextlex();
break;
case LITSYM:
new = new_sym(t.c);
nextlex();
break;
case PSEUDO:
switch(t.p) {
case nilvar: new = o_nil; break;
case truevar: new = o_true; break;
case falsevar: new = o_false; break;
case smallvar: new = o_smalltalk; break;
default: lexerr("unknown peudo %d", t.p);
}
nextlex();
break;
case PS:
nextlex();
if (token == LP) goto rdarray;
else if (token == LB) {
bytetop = 0;
while (nextlex() == LITNUM)
bytes[bytetop++] = itouc(t.i);
if (token != RB)
expect("right bracket");
nextlex();
new = new_bytearray(bytes, bytetop);
}
else expect("array or bytearray");
break;
case LP: rdarray:
count = 0;
nextlex();
while (aliteral(0) >= 0) {
count++;
}
if (token != RP) expect("right parenthesis");
nextlex();
new = new_array(count, 0);
while (count)
new->inst_var[--count] = lit_array[--littop];
break;
case UPPERCASEVAR:
case LOWERCASEVAR:
case KEYWORD:
case COLONVAR:
case BINARY:
case PE:
case BAR:
case SEMI:
new = new_sym(t.c);
nextlex();
break;
default:
if (must)
expect("literal");
else return( - 1 );
}
return(addliteral(new));
}
/* gensend - generate a message send */
static gensend(message, numargs)
char *message;
int numargs;
{ int i;
char **p, c;
tok_type e;
c = *message;
if (numargs == 0) {
for (p = unspecial, i = 0; *p; i++, p++)
if ((**p == c) && (strcmp(*p, message) == 0)) {
genhighlow(UNSEND, i);
return;
}
}
else if (numargs == 1) {
for (p = binspecial, i = 0; *p; i++, p++)
if ((**p == c) && (strcmp(*p, message) == 0)) {
genhighlow(BINSEND, i);
return;
}
for (p = arithspecial, i = 0; *p; i++, p++)
if ((**p == c) && (strcmp(*p, message) == 0)) {
genhighlow(ARITHSEND, i);
return;
}
}
else if (numargs == 2) {
for (p = keyspecial, i = 0; *p; i++, p++)
if ((**p == c) && (strcmp(*p, message) == 0)) {
genhighlow(KEYSEND, i);
return;
}
}
genhighlow(SEND, numargs);
gencode(addliteral(new_sym(message)));
}
static object *var_names;
static object *var_values;
extern object *o_nil, *o_true;
static int findvar(str, make)
char *str;
int make;
{ int i;
object *comp_obj;
sassign(comp_obj, new_obj((class *) 0, 2, 0));
sassign(comp_obj->inst_var[0], o_nil);
sassign(comp_obj->inst_var[1], new_sym(str));
for (i = 0; i < var_names->size; i++) {
assign(comp_obj->inst_var[0], var_names->inst_var[i]);
if (o_true == primitive(SYMEQTEST, 2, &(comp_obj->inst_var[0]))) {
obj_dec(comp_obj);
return(i);
}
}
/* not found, perhaps it's new */
if (make) {
assign(comp_obj->inst_var[0], var_names);
assign(var_names, primitive(GROW, 2, &(comp_obj->inst_var[0])));
assign(comp_obj->inst_var[0], var_values);
assign(comp_obj->inst_var[1], o_nil);
assign(var_values, primitive(GROW, 2, &(comp_obj->inst_var[0])));
}
else {
lexerr("unknown variable %s", str);
i = 0;
}
obj_dec(comp_obj);
return(i);
}
genvar(name)
char *name;
{ int i;
for (i = 0; i < temptop; i++)
if (strcmp(name, tempnames[i]) == 0) {
genhighlow(PUSHTEMP, i+1);
return;
}
genhighlow(PUSHINSTANCE, findvar(name, 0));
}
/* lexerr - error printing with limited reformatting */
lexerr(s, v)
char *s, *v;
{
char e1[500], e2[500];
object *new;
errflag = 1;
sprintf(e1, s, v); /* format error message */
sprintf(e2, "error: %s\n", e1);
sassign(new, new_str(e2));
primitive(ERRPRINT, 1, &new);
obj_dec(new);
}
expect(str)
char *str;
{ char ebuf[150];
/*fprintf(stderr,"expected %s\n", str);
fprintf(stderr,"current token type %d\n", token);
fprintf(stderr,"remainder of line %s\n", lexptr);
fprintf(stderr,"current text %s\n", toktext);*/
sprintf(ebuf,"expected %s found %s", str, toktext);
lexerr(ebuf,"");
}
extern object *o_drive; /* ``driver'' interpreter */
bld_interpreter()
{ interpreter *interp;
object *literals, *bytecodes, *context;
int i;
if (codetop == 0) {
return;
}
genhighlow(SPECIAL, SELFRETURN);
gencode(0); /* mark end of bytecodes */
sassign(literals, new_array(littop, 0));
for (i = 0; i < littop; i++)
literals->inst_var[ i ] = lit_array[i];
sassign(bytecodes, new_bytearray(code, codetop));
sassign(context, new_obj((class *) 0, 1 + maxtemps, 1));
interp = cr_interpreter((interpreter *) o_drive, var_values,
literals, bytecodes, context);
link_to_process(interp);
obj_dec(context);
obj_dec(bytecodes);
obj_dec(literals);
}
reset(){
codetop = littop = temptop = 0;
maxtemps = 1;
}
/* drv_init initializes the driver, should be called only once */
drv_init() {
sassign(var_names, new_obj((class *) 0, 0, 0));
sassign(var_values, new_obj((class *) 0, 0, 0));
reset();
findvar("last", 1); /* create variable "last" */
}
drv_free() {
int i;
for (i = 0; i < var_values->size; i++)
assign(var_values->inst_var[ i ], o_nil);
obj_dec(var_names);
obj_dec(var_values);
}
SHAR_EOF
if test 13242 -ne "`wc -c < 'sources/drive.c'`"
then
echo shar: error transmitting "'sources/drive.c'" '(should have been 13242 characters)'
fi
fi # end of overwriting check
if test -f 'sources/file.c'
then
echo shar: will not over-write existing file "'sources/file.c'"
else
cat << \SHAR_EOF > 'sources/file.c'
/*
Little Smalltalk
programs used by class File
timothy a. budd 11/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 "file.h"
# include "string.h"
# include "number.h"
# include "primitive.h"
static mstruct *fr_file = 0; /* free file list */
object *new_file()
{ struct file_struct *new;
if (fr_file) {
new = (struct file_struct *) fr_file;
fr_file = fr_file->mlink;
}
else {
new = structalloc(struct file_struct);
}
new->l_size = FILESIZE;
new->l_ref_count = 0;
new->file_mode = STRMODE;
new->fp = NULL;
return((object *) new);
}
free_file(phil)
struct file_struct *phil;
{
if (! is_file(phil))
cant_happen(8);
if (phil->fp != NULL)
fclose(phil->fp);
((mstruct *) phil)->mlink = fr_file;
fr_file = (mstruct *) phil;
}
file_err(message)
char *message;
{ object *errp;
char buffer[150];
sprintf(buffer,"File: %s", message);
sassign(errp, new_str(buffer));
primitive(ERRPRINT, 1, &errp);
obj_dec(errp);
}
file_open(phil, name, type)
struct file_struct *phil;
char *name, *type;
{ char buffer[100];
if (phil->fp != NULL)
fclose(phil->fp);
phil->fp = fopen(name, type);
if (phil->fp == NULL) {
sprintf(buffer,"can't open: %s\n", name);
file_err(buffer);
}
}
# define BUFLENGTH 250
object *file_read(phil)
struct file_struct *phil;
{ object *new;
int c;
char buffer[BUFLENGTH], *p;
if (phil->fp == NULL) {
file_err("attempt to read from unopened file");
return(o_nil);
}
switch(phil->file_mode) {
case CHARMODE:
if (EOF == (c = fgetc(phil->fp)))
new = o_nil;
else
new = new_char(c);
break;
case STRMODE:
if (NULL == fgets(buffer, BUFLENGTH, phil->fp))
new = o_nil;
else {
p = &buffer[strlen(buffer) - 1];
if (*p == '\n') *p = '\0';
new = new_str(buffer);
}
break;
case INTMODE:
if (EOF == (c = getw(phil->fp)))
new = o_nil;
else
new = new_int(c);
break;
default:
file_err("unknown mode");
new = o_nil;
}
return(new);
}
file_write(phil, obj)
struct file_struct *phil;
object *obj;
{
if (phil->fp == NULL) {
file_err("attempt to write to unopened file");
return;
}
switch(phil->file_mode) {
case CHARMODE:
if (! is_character(obj)) goto modeerr;
fputc(int_value(obj), phil->fp);
break;
case STRMODE:
if (! is_string(obj)) goto modeerr;
fputs(string_value(obj), phil->fp);
fputc('\n', phil->fp);
break;
case INTMODE:
if (! is_integer(obj)) goto modeerr;
putw(int_value(obj), phil->fp);
break;
}
return;
modeerr:
file_err("attempt to write object of wrong type for mode");
}
SHAR_EOF
if test 3082 -ne "`wc -c < 'sources/file.c'`"
then
echo shar: error transmitting "'sources/file.c'" '(should have been 3082 characters)'
fi
fi # end of overwriting check
if test -f 'sources/file.h'
then
echo shar: will not over-write existing file "'sources/file.h'"
else
cat << \SHAR_EOF > 'sources/file.h'
/*
Little Smalltalk
class File definitions
timothy a. budd, 11/84
*/
/*
files use standard i/o package
*/
struct file_struct {
int l_ref_count;
int l_size;
int file_mode;
FILE *fp;
};
typedef struct file_struct file;
extern object *new_file();
extern object *file_read();
/* files can be opened in one of three modes, modes are either
0 - char mode - each read gets one char
1 - string mode - each read gets a string
2 - integer mode - each read gets an integer
*/
# define CHARMODE 0
# define STRMODE 1
# define INTMODE 2
SHAR_EOF
if test 544 -ne "`wc -c < 'sources/file.h'`"
then
echo shar: error transmitting "'sources/file.h'" '(should have been 544 characters)'
fi
fi # end of overwriting check
if test -f 'sources/interp.c'
then
echo shar: will not over-write existing file "'sources/interp.c'"
else
cat << \SHAR_EOF > 'sources/interp.c'
/*
Little Smalltalk
bytecode interpreter
timothy a. budd
*/
/*
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 "drive.h"
# include "cmds.h"
# include "interp.h"
# include "process.h"
# include "number.h"
# include "string.h"
# include "symbol.h"
# include "byte.h"
# include "block.h"
# include "primitive.h"
extern object *o_smalltalk; /* value of pseudo variable smalltalk */
extern object *fnd_class(); /* used to find classes from names */
static mstruct *fr_interp = 0; /* interpreter memory free list */
int ca_terp = 0; /* counter for interpreter allocations */
/* cr_interpreter - create a new interpreter */
interpreter *cr_interpreter(sender, receiver, literals, bitearray, context)
interpreter *sender;
object *literals, *bitearray, *receiver, *context;
{ interpreter *new;
class *rclass;
int isize;
if (fr_interp) {
new = (interpreter *) fr_interp;
fr_interp = fr_interp->mlink;
}
else {
new = structalloc(interpreter);
ca_terp++;
}
new->t_ref_count = 0;
new->t_size = INTERPSIZE;
new->creator = (interpreter *) 0;
if (sender)
sassign(new->sender, sender);
else
sassign(new->sender, (interpreter *) o_nil);
sassign(new->literals, literals);
sassign(new->bytecodes, bitearray);
sassign(new->receiver, receiver);
rclass = (class *) fnd_class(receiver);
if ((! rclass) || ! is_class(rclass))
isize = 25;
else {
isize = rclass->stack_max;
}
sassign(new->context, context);
sassign(new->stack, new_obj((class *) 0, isize, 1));
new->stacktop = &(new->stack)->inst_var[0];
new->currentbyte = byte_value(new->bytecodes);
return(new);
}
/* free_terpreter - return an unused interpreter to free list */
free_terpreter(anInterpreter)
interpreter *anInterpreter;
{
if (! is_interpreter(anInterpreter))
cant_happen(8);
obj_dec((object *) anInterpreter->sender);
obj_dec(anInterpreter->receiver);
obj_dec(anInterpreter->bytecodes);
obj_dec(anInterpreter->literals);
obj_dec(anInterpreter->context);
obj_dec(anInterpreter->stack);
((mstruct *) anInterpreter)->mlink = fr_interp;
fr_interp = (mstruct *) anInterpreter;
}
/* copy_arguments - copy an array of arguments into the context */
copy_arguments(anInterpreter, argLocation, argCount, argArray)
interpreter *anInterpreter;
int argLocation, argCount;
object **argArray;
{ object *context = anInterpreter->context;
int i;
for (i = 0; i < argCount; argLocation++, i++) {
assign(context->inst_var[ argLocation ], argArray[i]);
}
}
# define push(x) {assign(*(anInterpreter->stacktop), x); \
anInterpreter->stacktop++;}
/* push_object - push a returned value on to an interpreter stack */
push_object(anInterpreter, anObject)
interpreter *anInterpreter;
object *anObject;
{
push(anObject); /* what? no bounds checking?!? */
}
# define nextbyte(x) {x = uctoi(*anInterpreter->currentbyte);\
anInterpreter->currentbyte++;}
# define instvar(x) (anInterpreter->receiver)->inst_var[ x ]
# define tempvar(x) (anInterpreter->context)->inst_var[ x ]
# define lit(x) (anInterpreter->literals)->inst_var[ x ]
# define popstack() (*(--anInterpreter->stacktop))
# define decstack(x) (anInterpreter->stacktop -= x)
# define skip(x) (anInterpreter->currentbyte += x )
/* resume - resume executing bytecodes associated with an interpreter */
resume(anInterpreter)
register interpreter *anInterpreter;
{
int highBits;
register int lowBits;
object *tempobj, *receiver, *fnd_super();
interpreter *sender;
int i, j, numargs, arglocation;
char *message;
while(1) {
nextbyte(highBits);
lowBits = highBits % 16;
highBits /= 16;
switchtop:
switch(highBits) {
default: cant_happen(9);
break;
case 0: /* two bit form */
highBits = lowBits;
nextbyte(lowBits);
goto switchtop;
case 1: /* push instance variable */
push(instvar(lowBits));
break;
case 2: /* push context value */
push(tempvar(lowBits));
break;
case 3: /* literals */
push(lit(lowBits));
break;
case 4: /* push class */
tempobj = lit(lowBits);
if (! is_symbol(tempobj)) cant_happen(9);
tempobj = primitive(FINDCLASS, 1, &tempobj);
push(tempobj);
break;
case 5: /* special literals */
if (lowBits < 10)
tempobj = new_int(lowBits);
else if (lowBits == 10)
tempobj = new_int(-1);
else if (lowBits == 11)
tempobj = o_true;
else if (lowBits == 12)
tempobj = o_false;
else if (lowBits == 13)
tempobj = o_nil;
else if (lowBits == 14)
tempobj = o_smalltalk;
else if (lowBits == 15)
tempobj = (object *) runningProcess;
else if ((lowBits >= 30) && (lowBits < 60)) {
/* get class */
tempobj =
new_sym(classpecial[lowBits-30]);
tempobj = primitive(FINDCLASS, 1,
&tempobj);
}
else tempobj = new_int(lowBits);
push(tempobj);
break;
case 6: /* pop and store instance variable */
assign(instvar(lowBits), popstack());
break;
case 7: /* pop and store in context */
assign(tempvar(lowBits), popstack());
break;
case 8: /* send a message */
numargs = lowBits;
nextbyte(i);
tempobj = lit(i);
if (! is_symbol(tempobj)) cant_happen(9);
message = symbol_value(tempobj);
goto do_send;
case 9: /* send a superclass message */
numargs = lowBits;
nextbyte(i);
tempobj = lit(i);
if (! is_symbol(tempobj)) cant_happen(9);
message = symbol_value(tempobj);
receiver =
fnd_super(anInterpreter->receiver);
goto do_send2;
case 10: /* send a special unary message */
numargs = 0;
message = unspecial[lowBits];
goto do_send;
case 11: /* send a special binary message */
numargs = 1;
message = binspecial[lowBits];
goto do_send;
case 12: /* send a special arithmetic message */
tempobj = *(anInterpreter->stacktop - 2);
if (! is_integer(tempobj)) goto ohwell;
i = int_value(tempobj);
tempobj = *(anInterpreter->stacktop - 1);
if (! is_integer(tempobj)) goto ohwell;
j = int_value(tempobj);
decstack(2);
switch(lowBits) {
case 0: i += j; break;
case 1: i -= j; break;
case 2: i *= j; break;
case 3: if (i < 0) i = -i;
i %= j; break;
case 4: if (j < 0) i >>= (-j);
else i <<= j; break;
case 5: i &= j; break;
case 6: i |= j; break;
case 7: i = (i < j); break;
case 8: i = (i <= j); break;
case 9: i = (i == j); break;
case 10: i = (i != j); break;
case 11: i = (i >= j); break;
case 12: i = (i > j); break;
case 13: i %= j; break;
case 14: i /= j; break;
case 15: i = (i < j) ? i : j;
break;
case 16: i = (i < j) ? j : i;
break;
default: cant_happen(9);
}
if ((lowBits < 7) || (lowBits > 12))
tempobj = new_int(i);
else tempobj = (i ? o_true : o_false);
push(tempobj);
break;
ohwell: /* oh well, send message */
numargs = 1;
message = arithspecial[lowBits];
goto do_send;
case 13: /* send a special ternary keyword messae */
numargs = 2;
message = keyspecial[lowBits];
goto do_send;
case 14: /* block creation */
numargs = lowBits;
if (numargs)
nextbyte(arglocation);
nextbyte(i); /* size of block */
push(new_block(anInterpreter, numargs,
arglocation));
skip(i);
break;
case 15: /* special bytecodes */
switch(lowBits) {
case 0: /* no - op */
break;
case 1: /* duplicate top of stack */
push(*(anInterpreter->stacktop - 1));
break;
case 2: /* pop top of stack */
anInterpreter->stacktop--;
break;
case 3: /* return top of stack */
tempobj = popstack();
goto do_return;
case 4: /* block return */
block_return(anInterpreter, popstack());
return;
case 5: /* self return */
tempobj = tempvar(0);
goto do_return;
case 6: /* skip on true */
nextbyte(i);
tempobj = popstack();
if (tempobj == o_true) {
skip(i);
push(o_nil);
}
break;
case 7: /* skip on false */
nextbyte(i);
tempobj = popstack();
if (tempobj == o_false) {
skip(i);
push(o_nil);
}
break;
case 8: /* just skip */
nextbyte(i);
skip(i);
break;
case 9: /* skip backward */
nextbyte(i);
skip( - i );
break;
case 10: /* execute a primitive */
nextbyte(numargs);
nextbyte(i); /* primitive number */
if (i == BLOCKEXECUTE)
goto blk_execute;
else if (i == DOPERFORM)
goto do_perform;
else {
decstack(numargs);
tempobj = primitive(i, numargs,
anInterpreter->stacktop);
push(tempobj);
}
break;
case 11: /* skip true, push true */
nextbyte(i);
tempobj = popstack();
if (tempobj == o_true) {
skip(i);
anInterpreter->stacktop++;
}
break;
case 12: /* skip on false, push false */
nextbyte(i);
tempobj = popstack();
if (tempobj == o_false) {
skip(i);
anInterpreter->stacktop++;
}
break;
default:
cant_happen(9);
}
break;
}
}
/* sorry for the unstructured gotos.
the sins of unstructuredness seemed less bothersome than
the problems of not doing the same thing in all places
-tab
*/
do_perform: /* process perform:withArguments: */
tempobj = popstack();
message = symbol_value(tempobj);
tempobj = popstack();
numargs = tempobj->size - 1;
for (i = 0; i <= numargs; i++)
push(tempobj->inst_var[i]);
/* fall through into do_send */
/* do_send - call courier to send a message */
do_send:
receiver = *(anInterpreter->stacktop - (numargs + 1));
do_send2:
decstack(numargs + 1);
send_mess(anInterpreter, receiver, message,
anInterpreter->stacktop , numargs);
return;
/* do_return - return from a message */
do_return:
sender = anInterpreter->sender;
if (is_interpreter(sender)) {
if (! is_driver(sender))
push_object(sender, tempobj);
link_to_process(sender);
}
else {
terminate_process(runningProcess);
}
return;
/* blk_execute - perform the block execute primitive */
blk_execute:
tempobj = popstack();
if (! is_integer(tempobj)) cant_happen(9);
numargs = int_value(tempobj);
sender = block_execute(anInterpreter->sender,
(block *) tempvar(0), numargs, &tempvar(1));
link_to_process(sender);
return;
}
SHAR_EOF
if test 10870 -ne "`wc -c < 'sources/interp.c'`"
then
echo shar: error transmitting "'sources/interp.c'" '(should have been 10870 characters)'
fi
fi # end of overwriting check
if test -f 'sources/interp.h'
then
echo shar: will not over-write existing file "'sources/interp.h'"
else
cat << \SHAR_EOF > 'sources/interp.h'
/*
Little Smalltalk interpeter definitions
*/
/*
for interpreters
t_size = INTERPSIZE
creator is a pointer to the interpreter which created
the current interpreter. it is zero except in the case
of blocks, in which case it points to the creating
interpreter for a block. it is NOT a reference, ie,
the ref_count field of the creator is not incremented when
this field is set - this avoids memory reference loops.
stacktop is a pointer to a pointer to an object, however it
is not considered a reference. ie, changing stacktop does
not alter reference counts.
*/
struct interp_struct {
int t_ref_count;
int t_size; /* should always be INTERPSIZE */
struct interp_struct *creator;
struct interp_struct *sender;
object *bytecodes;
object *receiver;
object *literals;
object *context;
object *stack;
object **stacktop;
uchar *currentbyte;
};
typedef struct interp_struct interpreter;
extern interpreter *cr_interpreter();
extern object *o_drive;
# define is_driver(x) (o_drive == (object *) x)
SHAR_EOF
if test 1065 -ne "`wc -c < 'sources/interp.h'`"
then
echo shar: error transmitting "'sources/interp.h'" '(should have been 1065 characters)'
fi
fi # end of overwriting check
if test -f 'sources/lex.c'
then
echo shar: will not over-write existing file "'sources/lex.c'"
else
cat << \SHAR_EOF > 'sources/lex.c'
/*
Little Smalltalk lexical analyzer for driver
timothy a. budd 12/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 <ctype.h>
# include <math.h>
# define DRIVECODE
# include "drive.h"
# define MAXTOKEN 100
char toktext[MAXTOKEN];
tok_type t;
enum lextokens token;
extern char *lexptr;
extern double atof();
static char ocbuf = 0;
static int pbbuf[20];
# define input() (ocbuf ? pbbuf[--ocbuf] : *lexptr++ )
# define putbak(c) (pbbuf[ocbuf++] = c)
static char *psuvars[] = {"nil", "true", "false", "smalltalk", 0};
static enum pseuvars psuval[] = {nilvar, truevar, falsevar, smallvar};
static char symbols[] = "\n-()[]!|.;>" ;
static enum lextokens symval[] = {NL, MINUS, LP, RP, LB, RB, BAR, BAR,
PERIOD, SEMI, PE};
static enum lextokens lexsave(type)
enum lextokens type;
{ char *w_search();
if (! (t.c = w_search(toktext, 1)))
lexerr("cannot create symbol %s", toktext);
/* assign token, and return value */
return(token = type);
}
enum lextokens nextlex() {
register char c;
register char *p;
char *q;
int i, n, base;
double d, denom;
do { /* read whitespace (including comments) */
c = input();
if (c == '\"') {
while ((c = input()) && c != '\"') ;
if (c == '\"') c = input();
else lexerr("unterminated comment", "");
}
} while (c == ' ' || c == '\t') ;
if (!c) return(token = nothing);
p = toktext;
*p = c;
toktext[1] = '\0';
/* identifiers and keywords */
if (( c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')) {
for (*p++ = c; (c = input()) && isalnum(c) ; *p++ = c) ;
*p = '\0';
lexsave(0);
if (c == ':') {
return(token = KEYWORD);
}
else {
putbak(c);
if (islower(toktext[0])) {
for (i = 0; psuvars[i]; i++)
if (strcmp(toktext, psuvars[i]) == 0) {
t.p = psuval[i];
return(token = PSEUDO);
}
return(token = LOWERCASEVAR);
}
else {
return(token = UPPERCASEVAR);
}
}
}
# define scandigits(x) for(*p++ = c; (c = input()) && isdigit(c) ; *p++ = c) x
if (c >= '0' && c <= '9') { /* numbers */
i = c - '0';
scandigits( i = 10 * i + (c - '0') );
if (c == '.' || c == 'e') {
if (c == '.')
scandigits();
if (c == 'e') {
*p++ = c;
c = input();
if (c == '+' || c == '-') {
*p++ = c; c = input(); }
scandigits();
}
putbak(c);
*p = '\0';
t.f = atof(toktext);
return(token = LITFNUM);
}
else if ((c == 'r') && ((i >= 2) && (i <= 36))) {
base = i;
i = 0;
for (*p++ = c; c = input(); *p++ = c) {
if (isdigit(c)) n = c - '0';
else if (isupper(c)) n = (c - 'A') + 10;
else break;
if (n >= base) break;
i = base * i + n;
}
if (c == '.' || c == 'e') {
d = (double) i;
if (c == '.') {
denom = 1.0 / (double) base;
for (*p++ = c; c = input(); *p++ = c) {
if (isdigit(c))
n = c - '0';
else if (isupper(c))
n = (c - 'A') + 10;
else break;
if (n >= base) break;
d += n * denom;
denom /= base;
}
}
if (c == 'e') {
*p++ = c;
c = input();
if (c == '+' || c == '-') {
n = c;
*p++ = c;
c = input();
}
else n = 0;
i = c - '0';
scandigits(i = 10 * i + (c - '0'));
if (n == '-') i = - i;
d *= pow((double) base, (double) i);
}
putbak(c);
*p = '\0';
t.f = d;
return(token = LITFNUM);
}
}
putbak(c);
*p = '\0';
t.i = i;
return(token = LITNUM);
}
if (c == '#') { /* symbol */
i = 1;
while (i)
switch(c = input()) {
case '\0': case ' ': case '\t': case '\n':
case '(': case '[': case ')':
putbak(c);
i = 0;
break;
default:
*p++ = c;
}
if (p == toktext)
return(token = PS);
else {
*p = '\0';
if ((p - toktext) >= MAXTOKEN) cant_happen(18);
return(lexsave(LITSYM));
}
}
if (c == '\'') { /* quoted string */
do {
for ( ; (c = input()) && c != '\'' ; *p++ = c) ;
c = input();
if (c == '\'') *p++ = '\'';
} while (c == '\'');
putbak(c);
*p = '\0';
if ((p - toktext) >= MAXTOKEN) cant_happen(18);
t.c = toktext;
return(token = LITSTR);
}
if (c == ':') { /* colon or argument name */
c = input();
if (c == '=')
return(token = ASSIGN);
else if (isalnum(c)) {
for (*p++ = c; isalnum(c = input()); *p++ = c );
putbak(c);
*p = '\0';
return(lexsave(COLONVAR));
}
putbak(c);
return(lexsave(BINARY));
}
if (c == '<') { /* assign, less than or primitive */
*p++ = c; *p = '\0';
c = input();
if (c == '-')
return(token = ASSIGN);
for (p = q = "primitive"; *p && *p == c; p++)
c = input();
putbak(c);
if (*p) {
for (p--; p >= q; p--) putbak(*p);
return(lexsave(BINARY));
}
else
return(token = PRIMITIVE);
}
if (c == '.') { /* number or period */
c = input();
if (c >= '0' && c <= '9') {
putbak(c); /* reparse with digit */
putbak('.'); /* inserted on front */
putbak('0'); /* so it looks like */
return(nextlex()); /* a number */
}
putbak(c);
return(token = PERIOD);
}
if (c == '\\') { /* binary or hidden newline */
c = input();
if (c == '\n')
return(nextlex());
putbak(c);
return(lexsave(BINARY));
}
if (c == '$') { /* literal character or binary */
c = input();
if (c) {
t.i = c;
return(token = LITCHAR);
}
return(lexsave(BINARY));
}
for (i = 0; symbols[i]; i++)
if (c == symbols[i])
return(lexsave(symval[i]));
return(lexsave(BINARY));
}
SHAR_EOF
if test 5964 -ne "`wc -c < 'sources/lex.c'`"
then
echo shar: error transmitting "'sources/lex.c'" '(should have been 5964 characters)'
fi
fi # end of overwriting check
if test -f 'sources/lexcmd.c'
then
echo shar: will not over-write existing file "'sources/lexcmd.c'"
else
cat << \SHAR_EOF > 'sources/lexcmd.c'
/*
Little Smalltalk
misc lexer related routines
timothy a. budd 12/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 "env.h"
# include <ctype.h>
# ifdef OPEN3ARG
# include <fcntl.h>
# endif OPEN3ARG
extern char toktext[];
/* dolexcommand - read a ) type directive, and process it */
dolexcommand(p)
char *p;
{ char *q;
/* replace trailing newline with end of string */
for (q = p; *q && *q != '\n'; q++);
if (*q == '\n') *q = '\0';
switch( *++p) {
case '!':
# ifndef NOSYSTEM
system(++p);
# endif
break;
case 'e': for (++p; isspace(*p); p++);
if (! lexedit(p)) lexinclude(p);
break;
case 'i': for (++p; isspace(*p); p++);
lexinclude(p);
break;
case 'r': for (++p; isspace(*p); p++);
lexread(p);
break;
case 's': for(++p; isspace(*p); p++);
dosave(p);
break;
case 'l': for(++p; isspace(*p); p++);
doload(p);
break;
default: lexerr("unknown command %s", toktext);
}
}
/* doload/dosave routines written by nick buchholz */
/*
doload and dosave routines make the following assumptions
1. version is the first global variable declared in main.
2. main is the first procedure seen by the loader
3. the loader allocates memory in the order it sees the procedures
4. memory is laid out as on the vax 780 under 4.2
on other machines any or all of these might be false and the
doload/dosave routines will not work
*/
extern int version;
dosave(p) char *p;{
int fd;
char *start, *end, *sbrk();
unsigned int length, len;
int dlen;
# ifdef OPEN3ARG
if ((fd = open(p, O_WRONLY|O_CREAT|O_TRUNC, 0666)) == -1)
# endif
# ifndef OPEN3ARG
if ((fd = creat(p, 0666)) == -1)
# endif
fprintf(stderr,"can't open: %s\n",p);
start = (char *) &version;
end = sbrk(0);
length = end - start;
write(fd, &version, sizeof(int));
write(fd, &start, sizeof(char *));
write(fd, &length, sizeof(unsigned int));
for (len = 0; len < length; len += dlen) {
dlen = ((length - len) > 512) ? 512 : (length - len);
if (dlen != write(fd, start + len, dlen)) {
cant_happen(23);
}
}
fprintf(stderr,"%u bytes written\n",len);
close(fd);
}
# ifdef ENVSAVE
extern char **environ;
# endif
doload(p) char *p;{
int fd;
char *start, *end, *brk();
unsigned int length, len;
int dlen;
int test;
# ifdef ENVSAVE
char **evsave;
# endif
# ifdef OPEN3ARG
if ((fd = open(p, O_RDONLY, 0)) == -1)
# endif
# ifndef OPEN3ARG
if ((fd = open(p, 0 )) == -1)
# endif
fprintf(stderr,"no such context as: %s\n", p);
else {
read(fd, &test, sizeof(int));
read(fd, &start, sizeof(char *));
read(fd, &length, sizeof(unsigned int));
if ((test != version) || (start != (char *) &version))
fprintf(stderr,"%s: not a valid context file for version %d\n",
p, version);
else {
start = (char *) &version;
end = brk(start + length + 1);
# ifdef ENVSAVE
evsave = environ;
# endif
for (len = 0; len < length; len += dlen) {
dlen = ((length - len) > 512) ? 512 : (length - len);
if (dlen != read(fd, start + len, dlen)) {
cant_happen(23);
}
}
# ifdef ENVSAVE
environ = evsave;
# endif
fprintf(stderr,"%u bytes read\n",len);
}
close(fd);
}
}
/* lexread - read commands from a file */
lexread(name)
char *name;
{ FILE *fd;
fd = fopen(name, "r");
if (fd == NULL) {
fprintf(stderr,"can't open %s\n", name);
}
else {
set_file(fd);
}
}
/* lexinclude - parse a class and include the class description */
lexinclude(name)
char *name;
{ char template[60], cmdbuf[120];
int i;
# ifndef NOSYSTEM
gettemp(template);
sprintf(cmdbuf,"%s %s >%s", PARSER, name, template);
i = system(cmdbuf);
if (i == 0)
lexread(template);
# endif
# ifdef NOSYSTEM
fprintf(stderr,")i does not work on this system\n");
# endif
}
/* lexedit - edit a class description */
int lexedit(name)
char *name;
{ char *e, buffer[100], *getenv();
# ifndef NOSYSTEM
e = getenv("EDITOR");
if (!e) e = "ed";
sprintf(buffer,"%s %s", e, name);
return(system(buffer));
# endif
# ifdef NOSYSTEM
fprintf(stderr,")e does not work on this system\n");
return(1);
# endif
}
SHAR_EOF
if test 4830 -ne "`wc -c < 'sources/lexcmd.c'`"
then
echo shar: error transmitting "'sources/lexcmd.c'" '(should have been 4830 characters)'
fi
fi # end of overwriting check
if test -f 'sources/line.c'
then
echo shar: will not over-write existing file "'sources/line.c'"
else
cat << \SHAR_EOF > 'sources/line.c'
/*
Little Smalltalk
line grabber - does lowest level input for command lines.
*/
/*
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 "primitive.h"
# define MAXINCLUDE 10
# define MAXBUFFER 1200 /* text buffer */
static FILE *fdstack[MAXINCLUDE];
static int fdtop = -1;
static char buffer[MAXBUFFER];
static char *buftop = buffer;
char *lexptr = buffer;
static enum {empty, half, filled} bufstate = empty;
int inisstd = 0;
extern object *o_tab;
/* set file - set a file on the file descriptor stack */
set_file(fd)
FILE *fd;
{
if ((++fdtop) > MAXINCLUDE)
cant_happen(18);
fdstack[fdtop] = fd;
if (fd == stdin) inisstd = 1;
else inisstd = 0;
}
/* line-grabber - read a line of text
do blocked i/o if blocked is nonzero,
otherwise do non-blocking i/o */
int line_grabber(block)
int block;
{
/* if it was filled last time, it is now empty */
if (bufstate == filled) {
bufstate = empty;
buftop = buffer;
lexptr = buffer;
}
if ( ! block)
return(0); /* for now, only respond to blocked requests*/
else while (bufstate != filled) {
if (fdtop < 0) {
fprintf(stderr,"no files to read\n");
return(-1);
}
if (inisstd && o_tab)
primitive(RAWPRINT, 1, &o_tab);
if (fgets(buftop, MAXBUFFER, fdstack[fdtop]) == NULL) {
bufstate = empty;
if (fdstack[fdtop] != stdin)
fclose(fdstack[fdtop]);
if (--fdtop < 0) return(-1);
inisstd = (fdstack[fdtop] == stdin);
}
else {
bufstate = half;
while (*buftop) buftop++;
if (*(buftop-1) == '\n') {
if (*(buftop-2) == '\\') {
buftop -= 2;
}
else {
if ((buftop - buffer) > MAXBUFFER)
cant_happen(18);
*buftop = '\0';
bufstate = filled;
}
}
}
}
return(bufstate == filled);
}
SHAR_EOF
if test 2244 -ne "`wc -c < 'sources/line.c'`"
then
echo shar: error transmitting "'sources/line.c'" '(should have been 2244 characters)'
fi
fi # end of overwriting check
# End of shell archive
exit 0