A BASIC interpretor (Part 2 of 4)
sources-request at genrad.UUCP
sources-request at genrad.UUCP
Wed Jul 31 20:16:54 AEST 1985
Mod.sources: Volume 2, Issue 24
Submitted by: ukma!david (David Herron)
#! /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:
# newbs/bsdefs.c
# newbs/bsdefs.h
# newbs/bsgram.y
# newbs/bslash.c
# newbs/bslib.c
# newbs/getplace.c
# newbs/gvadr.c
# newbs/makefile
# newbs/makefile.old
# newbs/mkop.c
# newbs/mkop.sh
# newbs/mksop.c
# newbs/num_ins.c
# newbs/op2.c
# newbs/operat.c
# newbs/scon_in.c
# This archive created: Tue Jul 30 13:02:34 1985
export PATH; PATH=/bin:$PATH
if test ! -d 'newbs'
then
echo shar: creating directory "'newbs'"
mkdir 'newbs'
fi
echo shar: extracting "'newbs/bsdefs.c'" '(1128 characters)'
if test -f 'newbs/bsdefs.c'
then
echo shar: will not over-write existing file "'newbs/bsdefs.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/bsdefs.c'
/* bsdefs.c -- Actual definitions of all the variables.
*
* bsdefs.h only has the "extern's" of the things declared in here.
*/
#include "bsdefs.h"
/* Initial stuff for line number table.
*
* The line number table is a singly-linked list. The head is "firstline",
* and the tail is "lastline". The proper way to check for the end of the
* list is to compare it to LASTLINE. Lastline points to itself in case
* I forget and code something differently (it also neatly ties up the end
* of the list).
*/
#define LASTLINE (struct line *)(&lastline)
struct line lastline = { &lastline,0077777,"",_nulline };
struct line firstline = { &lastline,0,"",_nulline };
struct line *curline = LASTLINE;
/* Initial stuff for data statements.
*
* "dlist[]" holds pointers to lines that have data on them. It is initialized
* in M_FIXUP. "dlp" used to allocate entries from dlist[], it points to the
* first free entry. "dlindx" points within the current data line to the next
* data item.
* "dtype" indicates the data type for the last data item.
*/
struct line *dlist[DLSIZ];
int dlp = 0,dlindx = 0, dtype = 0;
SHAR_EOF
if test 1128 -ne "`wc -c < 'newbs/bsdefs.c'`"
then
echo shar: error transmitting "'newbs/bsdefs.c'" '(should have been 1128 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/bsdefs.h'" '(4648 characters)'
if test -f 'newbs/bsdefs.h'
then
echo shar: will not over-write existing file "'newbs/bsdefs.h'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/bsdefs.h'
/* bsdefs.h -- definition file for bs.
*/
#include <stdio.h>
#include <ctype.h>
/* 'Machine' status */
extern int status;
#define M_COMPILE (1<<0)
#define M_EXECUTE (1<<1)
#define M_INPUT (1<<2)
#define M_FIXUP (1<<3)
#define M_READ (1<<4)
#define XMODE (M_COMPILE|M_EXECUTE|M_INPUT|M_FIXUP|M_READ)
/* line table. */
#define LASTLINE (struct line *)(&lastline)
struct line {
struct line *nextline; /* next entry in list. */
int lnum; /* its' number */
int (*list)(); /* its' definition */
char *text; /* the original definition */
};
extern struct line firstline,lastline,*curline;
/* Variable types */
#define Q_NRM 0 /* nice, ordinary variable */
#define Q_ARY 1 /* array */
#define Q_BF 2 /* builtin-function */
#define Q_UFL 3 /* long user function */
#define Q_UFS 4 /* short user function */
/* in type part, a zero value is an undefined type. */
#define T_INT (1<<6)
#define T_CHR (2<<6)
#define T_DBL (3<<6)
#define T_LBL (4<<6)
#define T_QMASK 037 /* lower 5 bits for type qualifier */
#define T_TMASK (T_INT|T_CHR|T_DBL|T_LBL)
/* variable table */
#define VLSIZ 150
struct label {
char *name; /* what do we call it by. */
int (*where)(); /* and where does it live */
};
/* For arrays, storage of them is defined as follows:
*
* 1st item: number of dimensions in array <NDIMS>.
* next <NDIMS> items: size of each dimension.
* rest of items: the actual values.
*
* Until we can support varrying sized arrays this is the setup:
*
* 1,10,x0,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10
*
* for a total size of 13 items.
*/
union value {
long ival; /* T_INT */
double rval; /* T_DBL */
char *sval; /* T_CHR */
struct label lval; /* T_LBL */
struct line *locval; /* for pushing line# list entries */
union value *arval; /* any+Q_ARY */
struct dictnode *vpval; /* for use when pushing variable pointers */
union value *plval; /* for use when pushing pointers to a value */
};
struct dictnode { /* format of vlist entry */
struct dictnode *father,*daughter; /* doubly-linked list. */
char *name; /* name of entry. */
int type_of_value; /* its type. */
union value val; /* and its value */
};
extern struct dictnode *dicthead,*dictail,*curvp;
/* '_' Function table */
extern
_print(), _goto(), _if(), _else(),
_for(), _next(), _read(), _data(),
_dsep(), _spop(), _pop(), _stop(),
_end(), _dlabel(), _rlabel(), _contin(),
_leave(), _enter(), _exitlp(), _iadd(),
_isub(), _imult(), _idiv(), _imod(),
_comma(), _radd(), _rsub(), _rmult(),
_rdiv(), _scolon(), _gosub(), _return(),
_not(), _ieq(), _req(), _seq(),
_ineq(), _rneq(), _sneq(), _ileq(),
_rleq(), _sleq(), _ilt(), _rlt(),
_slt(), _igeq(), _rgeq(), _sgeq(),
_igt(), _rgt(), _sgt(), _or(),
_and(), _itoa(), _rtoa(), _itor(),
_rtoi(), _pushstate(), _popstate(), _scon(),
_rcon(), _icon(), _val(), _store(),
_var();
/*
* Data table.
* Array of pointers into llist.
* Each is a line which has data.
*/
#define DLSIZ 100
extern struct line *dlist[]; /* actual table, number of elems. is DLSIZ */
extern int dlp; /* index into dlist for current line of data */
extern int dlindx; /* index into current line for current data item. */
extern int dtype; /* in M_READ, operators set this to the type of
* their operation. When the expression is done
* executing, this variable will indicate its type.
*/
/* error routines */
extern int ULerror();
extern int STerror();
extern int FNerror();
extern int ODerror();
extern int BDerror();
extern int VTerror();
/*
* unions for storing data types in the code list
*
* Used to convert from a double (for instance) into "int" sized chunks
* for the purpose of manipulating instances of them in code lists.
*/
union doni {
double d_in_doni;
int i_in_doni[sizeof(double)/sizeof(int)];
};
union loni {
long l_in_loni;
int i_in_loni[sizeof(long)/sizeof(int)];
};
union voni {
union value v_in_voni;
int i_in_voni[sizeof(union value)/sizeof(int)];
};
/* miscellaneous definitions. */
#define STKSIZ 500
extern union value stack[];
extern int stackp;
extern int push();
extern union value pop();
#define CSTKSIZ 5
#define BFSIZ 200 /* input buffer */
extern char pbbuf[]; /* unput() buffer */
extern char ibuf[];
extern int iptr,pbptr;
extern char input();
extern rdlin(),unput();
extern blcpy();
extern char bslash();
extern char *scon_in();
extern int num_in();
extern char *myalloc();
extern union value *getplace();
extern struct line *gllentry();
extern FILE *bsin;
extern int dbg; /* debugging flag. */
extern long atol();
extern double atof();
SHAR_EOF
if test 4648 -ne "`wc -c < 'newbs/bsdefs.h'`"
then
echo shar: error transmitting "'newbs/bsdefs.h'" '(should have been 4648 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/bsgram.y'" '(8891 characters)'
if test -f 'newbs/bsgram.y'
then
echo shar: will not over-write existing file "'newbs/bsgram.y'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/bsgram.y'
/* bsgram.y -- grammer specification for bs.
*/
%{
#include "bsdefs.h"
char *p; /* the generic pointer */
int i; /* the generic counter */
int (*l[300])(); /* array to generate the code list into. */
int lp; /* pointer to current spot in l[] */
struct stk {
int stack[40];
int stkp;
};
struct stk ifstk,whstk,forstk,repstk,lpstk;
int gomax=0, ifmax=0, whmax=0, formax=0, repmax=0, lpmax=0;
extern char *yytext;
extern char *bsyysval;
extern int yyleng;
%}
%term EQUAL NEQ LE LT GE WHILE
%term GT OR AND NOT RET REPEAT
%term IF THEN ELSE GOTO GOSUB UNTIL
%term STOP END INTEGER REAL SCONST ELIHW
%term LET SWORD PRINT INPUT DATA CFOR
%term FOR TO STEP READ WRITE NEXT
%term DEFINE LFUN SFUN FDEF SYMBOL DIM
%term VALUE IWORD RWORD ROFC LOOP EXITIF
%term ITOR RTOI ITOA RTOA LEAVE CONTINUE
%term POOL
%left ',' ';'
%right '='
%nonassoc OR AND
%nonassoc LE LT GE GT EQUAL NEQ
%left '+' '-'
%left '*' '/' '%'
%left UNARY
%left '('
%start lines
%%
lines : /* empty */
| lines line
;
line : lnum stat '\n'
{ printf("\n"); }
| '\n'
;
lnum : INTEGER
{ bundle(2,_line,atoi($1); }
;
stat : LET let_xpr
| let_xpr
| PRINT pe
{ bundle(1,_print); }
| GOTO INTEGER
{
sprintf(s,"LN%s",$2);
bundle(4,_rlabel,gvadr(s,T_LBL),_goto,0);
}
| GOSUB INTEGER
{
sprintf(s,"LN%s",$2);
bundle(4,_rlabel,gvadr(s,T_LBL),_gosub,0);
}
| LEAVE
{ bundle(2,_leave,0); }
| CONTINUE
{ bundle(2,_contin,0); }
| RET
{ bundle(1,_return); }
| IF bexpr
{
lpush(&ifstk,ifmax);
sprintf(s,"IF%d",ifmax);
bundle(4,_rlabel,gvadr(s,T_LBL),_if,0);
ifmax += 2;
}
THEN stat
{
i = ltop(&ifstk);
sprintf(s,"IF%d",i+1);
bundle(4,_rlabel,gvadr(s,T_LBL),_goto,0);
}
if_else
| INPUT
{ bundle(2,_pushstate,M_INPUT); }
var_lst
{ bundle(1,_popstate); }
| STOP
{ bundle(1,_stop); }
| END
{ bundle(1,_end); }
| FOR nvar '=' rexpr TO rexpr for_step
{
lpush(&forstk,formax);
sprintf(s,"FOR%d",formax+2);
bundle(2,_rlabel,gvadr(s,T_LBL));
sprintf(s,"FOR%d",formax+1);
bundle(3,_rlabel,gvadr(s,T_LBL),_enter);
sprintf(s,"FOR%d",formax+1);
bundle(5,_icon,(long)0,_rlabel,gvadr(s,T_LBL));
sprintf(s,"FOR%d",formax);
bundle(4,_dlabel,gvadr(s,T_LBL),_for,0);
formax += 3;
}
| NEXT
{
i = ltop(&forstk);
sprintf(s,"FOR%d",i+2);
bundle(2,_dlabel,gvadr(s,T_LBL));
}
nvar
{
i = lpop(&forstk);
sprintf(s,"FOR%d",i);
bundle(5,_next,_rlabel,gvadr(s,T_LBL),_goto,0);
sprintf(s,"FOR%d",i+1);
bundle(3,_dlabel,gvadr(s,T_LBL),_exitlp);
}
| READ
{ bundle(2,_pushstate,M_READ); }
var_lst
{ bundle(1,_popstate); }
| DATA
{ bundle(2,_data,0); }
data_lst
| LOOP
{
lpush(&lpstk,lpmax);
sprintf(s,"LP%d",lpmax+2);
bundle(2,_rlabel,gvadr(s,T_LBL));
sprintf(s,"LP%d",lpmax+1);
bundle(3,_rlabel,gvadr(s,T_LBL),_enter);
sprintf(s,"LP%d",lpmax);
bundle(2,_dlabel,gvadr(s,T_LBL));
lpmax += 3;
}
| EXITIF bexpr
{
i = ltop(&lpstk);
sprintf(s,"LP%d",i+1);
bundle(5,_not,_rlabel,gvadr(s,T_LBL),_if,0);
}
| POOL
{
i = lpop(&lpstk);
sprintf(s,"LP%d",i+2);
bundle(2,_dlabel,gvadr(s,T_LBL));
sprintf(s,"LP%d",i);
bundle(4,_rlabel,gvadr(s,T_LBL),_goto,0);
sprintf(s,"LP%d",i+1);
bundle(3,_dlabel,gvadr(s,T_LBL),_exitlp);
}
| WHILE
{
lpush(&whstk,whmax);
sprintf(s,"WH%d",whmax+2);
bundle(2,_rlabel,gvadr(s,T_LBL));
sprintf(s,"WH%d",whmax+1);
bundle(3,_rlabel,gvadr(s,T_LBL),_enter);
sprintf(s,"WH%d",whmax);
bundle(2,_rlabel,gvadr(s,T_LBL));
whmax += 3;
}
bexpr
{
i = ltop(&whstk);
sprintf(s,"WH%d",i+1);
bundle(4,_rlabel,gvadr(s,T+LBL),_if,0);
}
| ELIHW
{
i = lpop(&whstk);
sprintf(s,"WH%d",i+2);
bundle(2,_dlabel,gvadr(s,T_LBL));
sprintf(s,"WH%d",i)
bundle(4,_rlabel,gvadr(s,T_LBL),_goto,0);
sprintf(s,"WH%d",i+1);
bundle(3,_dlabel,gvadr(s,T_LBL),_exitlp);
}
| REPEAT
{
lpush(&repstk,repmax);
sprintf(s,"REP%d",repmax+1);
bundle(2,_rlabel,gvadr(s,T_LBL));
sprintf(s,"REP%d",repmax+2);
bundle(3,_rlabel,gvadr(s,T_LBL),_enter);
sprintf(s,"REP%d",repmax);
bundle(2,_dlabel,gvadr(s,T_LBL));
repmax += 3;
}
| UNTIL
{
i = ltop(&repstk);
sprintf(s,"REP%d",i+1);
bundle(2,_dlabel,gvadr(s,T_LBL));
}
bexpr
{
i = lpop(&repstk);
sprintf(s,"REP%d",i);
bundle(5,_not,_rlabel,gvadr(s,T_LBL),_if,0);
sprintf(s,"REP%d",i+2);
bundle(3,_dlabel,gvadr(s,T_LBL),_exitlp);
}
;
nvar : ivar
| rvar
;
let_xpr : ivar '=' rexpr
{ bundle(4,_rtoi,_store,T_DBL,_pop); }
| rvar '=' rexpr
{ bundle(3,_store,T_DBL,_pop); }
| svar '=' sexpr
{ bundle(3,_store,T_CHR,spop); }
;
data_lst : rexpr
{ bundle(2,_dsep,0); }
| sexpr
{ bundle(1,_dsep); }
| data_lst ',' rexpr
{ bundle(1,_dsep); }
| data_lst ',' sexpr
{ bundle(1,_dsep); }
;
ind_lst : rexpr
| ind_lst ',' rexpr
;
for_step : /* empty */
{ bundle(3,_icon,(long)0); }
| STEP rexpr
;
if_else : /* empty */
{
i = lpop(&ifstk);
sprintf(s,"IF%d",i);
bundle(2,_dlabel,gvadr(s,T_LBL));
sprintf(s,"IF%d",i+1);
bundle(2,_dlabel,gvadr(s,T_LBL));
}
| ELSE
{
i = ltop(&ifstk);
sprintf(s,"IF%d",i);
bundle(2,_dlabel,gvadr(s,T_LBL));
}
stat
{
i = lpop(&ifstk);
sprintf(s,"IF%d",i+1);
bundle(2,_dlabel,gvadr(s,T_LBL));
}
;
pe : sexpr ','
{ bundle(3,_scon,"",_comma); }
| sexpr ';'
| sexpr
{ bundle(3,_scon,"\\n",_scolon); }
| /* empty */
{ bundle(2,_scon,"\\n"); }
;
var_lst : ivar
| rvar
| svar
| var_lst ',' var_lst
;
sexpr : SCONST
{ p=myalloc(yyleng); strcpy(p,$1); bundle(2,_scon,p); }
| svar
{ bundle(2,_val,T_CHR); }
| rexpr
{ bundle(1,_rtoa); }
| svar '=' sexpr
{ bundle(2,_store,T_CHR); }
| sexpr ';' sexpr
{ bundle(1,_scolon); }
| sexpr '+' sexpr
{ bundle(1,_scolon); }
| sexpr ',' sexpr
{ bundle(1,_comma); }
| '(' sexpr ')'
;
sbe : sexpr EQUAL sexpr
{ bundle(1,_seq); }
| sexpr NEQ sexpr
{ bundle(1,_sneq); }
| sexpr LE sexpr
{ bundle(1,_sleq); }
| sexpr LT sexpr
{ bundle(1,_slt); }
| sexpr GE sexpr
{ bundle(1,_sgeq); }
| sexpr GT sexpr
{ bundle(1,_sgt); }
;
ivar : IWORD
{ bundle(2,_var,gvadr($1,T_INT)); }
| IWORD '('
{ bundle(2,_pushstate,M_EXECUTE); }
ind_lst ')'
{ bundle(3,_popstate,_var,gvadr($1,T_INT+Q_ARY)); }
;
rvar : RWORD
{ bundle(2,_var,gvadr($1,T_DBL)); }
| RWORD '('
{ bundle(2,_pushstate,M_EXECUTE); }
ind_lst ')'
{ bundle(3,_popstate,_var,gvadr($1,T_DBL+Q_ARY)); }
;
svar : SWORD
{ bundle(2,_var,gvadr($1,T_CHR)); }
| SWORD '('
{ bundle(2,_pushstate,M_EXECUTE); }
ind_lst ')'
{ bundle(3,_popstate,_var,gvadr($1,T_CHR+Q_ARY)); }
;
rexpr : rvar
{ bundle(2,_val,T_DBL); }
| REAL
{ bundle(5,_rcon,(double)atof($1)); }
| INTEGER
{ bundle(5,_rcon,(double)atof($1)); }
| ivar
{ bundle(3,_val,T_INT,_itor); }
| rvar '=' rexpr
{ bundle(2,_store,T_DBL); }
| '(' rexpr ')'
| rexpr '+' rexpr
{ bundle(1,_radd); }
| rexpr '-' rexpr
{ bundle(1,_rsub); }
| rexpr '*' rexpr
{ bundle(1,_rmult); }
| rexpr '/' rexpr
{ bundle(1,_rdiv); }
| '+' rexpr %prec UNARY
| '-' rexpr %prec UNARY
{ bundle(6,_rcon,(double)(-1),_rmult); }
;
rbe : rexpr EQUAL rexpr
{ bundle(1,_req); }
| rexpr NEQ rexpr
{ bundle(1,_rneq); }
| rexpr LE rexpr
{ bundle(1,_rleq); }
| rexpr LT rexpr
{ bundle(1,_rlt); }
| rexpr GE rexpr
{ bundle(1,_rgeq); }
| rexpr GT rexpr
{ bundle(1,_rgt); }
;
bexpr : sbe
| rbe
| NOT bexpr %prec UNARY
{ bundle(1,_not); }
| bexpr OR bexpr
{ bundle(1,_or); }
| bexpr AND bexpr
{ bundle(1,_and); }
| '(' bexpr ')'
;
%%
main()
{
rdlin(bsin);
return(yyparse());
}
yyerror(s)
char *s;
{
fprintf(stderr,"%s\n",s);
}
lpush(stack,val) struct stk *stack; int val;
{
stack->stack[stack->stkp++] = val;
}
int ltop(stack) struct stk *stack;
{
return(stack->stack[stack->stkp-1]);
}
int lpop(stack) struct stk *stack;
{
return(stack->stack[--stack->stkp]);
}
/* bundle() -- append argument list to l[]. Idea tooken from bc.y.
*
* Usage: bundle(cnt,arg,arg,...,arg)
*
* The "arg"'s can be anything. "cnt" is a count of the number of integers
* it would take to hold all the args.
*
* e.g. bundle(4,(double)a); is the correct count for a.
*
* ******* NOTE *******
*
* This routine is machine dependant. It depends on the way arguments are
* passed on the stack on the PDP-11 machines. It may not work elsewhere.
*/
bundle(a)
int a;
{
register int *p;
register int sz;
p = &a;
sz = *p++;
while(sz-- > 0)
l[lp++] = *p++;
}
SHAR_EOF
if test 8891 -ne "`wc -c < 'newbs/bsgram.y'`"
then
echo shar: error transmitting "'newbs/bsgram.y'" '(should have been 8891 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/bslash.c'" '(567 characters)'
if test -f 'newbs/bslash.c'
then
echo shar: will not over-write existing file "'newbs/bslash.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/bslash.c'
/* bslash() -- have seen '\', use input() to say what is actually wanted.
*/
char bslash()
{
char text[8];
register char *s,c;
int v;
c=input();
if(c == 'n') c='\n';
else if(c == 't') c='\t';
else if(c == 'b') c='\b';
else if(c == 'r') c='\r';
else if(c == 'f') c='\f';
else if(c>='0' && c<='7') { /* octal digit string */
s = &text[0];
*s++ = c;
c=input();
while(c>='0' && c<='7') {
*s++ = c;
c=input();
}
*s++ = '\0';
sscanf(text,"%o",&v);
c = (char) v;
}
else if(c=='\n') rdlin(bsin);
return(c);
}
SHAR_EOF
if test 567 -ne "`wc -c < 'newbs/bslash.c'`"
then
echo shar: error transmitting "'newbs/bslash.c'" '(should have been 567 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/bslib.c'" '(1553 characters)'
if test -f 'newbs/bslib.c'
then
echo shar: will not over-write existing file "'newbs/bslib.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/bslib.c'
/* bslib.c -- subroutine library, routines useful anywhere.
*/
#include "bsdefs.h"
XFILE *bsin = stdin;
/* blcpy -- copies a block of memory (l bytes) from s to d.
*/
blcpy(d,s,l)
char *d,*s;
int l;
{
for(; l >= 0; (l--)) *(d++) = *(s++);
}
/* Input routines. These routines buffer input a line at a time into
* ibuf. Unputted input goes to pbbuf, and gets read before things in
* ibuf, if anything in pbbuf.
*/
char pbbuf[CSTKSIZ],ibuf[BFSIZ];
int iptr = -1;
int pbptr = -1;
char input()
{
if(pbptr > -1)
return(pbbuf[pbptr--]);
else {
if(ibuf[iptr] == '\0') rdlin(bsin);
if(ibuf[iptr]!='\0' && !feof(bsin))
return(ibuf[iptr++]);
else
return(0);
}
}
rdlin(f) FILE *f;
{
char c;
iptr = 0;
for(c=fgetc(f); c!='\n' && c!=EOF; c=fgetc(f)) ibuf[iptr++] = c;
ibuf[iptr++] = c;
ibuf[iptr++] = '\0';
iptr = 0;
}
unput(c) char c;
{ pbbuf[++pbptr] = c; }
/* myalloc() -- allocate, checking for out of memory.
*/
char *myalloc(nb)
int nb;
{
char *rval;
rval = malloc(nb);
/*
printf("myalloc:tos:%o,rv:%o,nb:%d,e:%o\n",&rval,rval,nb,sbrk(0));
*/
if(rval == 0) {
fprintf(stderr,"myalloc: out of memory\n");
exit(1);
}
return(rval);
}
/* Stack routines. Very simple. */
union value stack[STKSIZ];
int stackp = -1;
push(i) union value i;
{
stack[++stackp] = i;
}
union value pop()
{
return(stack[stackp--]);
}
/* Mark stack. Also very simple. */
int mstack[5];
int mstkp = -1;
mpush()
{ mstack[++mstkp] = stackp; }
mpop()
{ stackp = mstack[mstkp--]; }
SHAR_EOF
if test 1553 -ne "`wc -c < 'newbs/bslib.c'`"
then
echo shar: error transmitting "'newbs/bslib.c'" '(should have been 1553 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/getplace.c'" '(488 characters)'
if test -f 'newbs/getplace.c'
then
echo shar: will not over-write existing file "'newbs/getplace.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/getplace.c'
/* getplace() -- get a pointer to place of value for vlist entry on top of stack
* For arrays, getplace() expects the indexes to be on the stack as well.
* The parser should properly arrange for this to happen.
*/
union value *getplace(dp)
struct dictnode *dp;
{
int qual;
union value ind,*place;
qual = dp->type_of_value&T_QMASK;
if(qual == Q_ARY) {
ind = pop();
mpop();
place = & dp->val.arval[ind.ival+2];
}
else
place = & dp->val;
return(place);
}
SHAR_EOF
if test 488 -ne "`wc -c < 'newbs/getplace.c'`"
then
echo shar: error transmitting "'newbs/getplace.c'" '(should have been 488 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/gvadr.c'" '(911 characters)'
if test -f 'newbs/gvadr.c'
then
echo shar: will not over-write existing file "'newbs/gvadr.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/gvadr.c'
/* gvadr() -- Get variable address from vlist, with type checking.
* This routine allows numerous copies of same name as long as
* all copies have different types. Probably doesnt matter since
* the parser does the type checking.
*/
struct dictnode *gvadr(s,ty)
char *s;
int ty;
{
register int i;
register int qual; /* type qualifier */
/* Inefficient */
for(i=0; vlist[i].name!=0 && i<VLSIZ; i++)
if(vlist[i].type_of_value==ty && strcmp(s,vlist[i].name)==0)
/* match found */
break;
if(i >= VLSIZ) {
fprintf(stderr,"gvadr: out of room in variable list for %s\n",s);
exit(1);
}
/* not on list, enter it */
if(vlist[i].name == 0) {
vlist[i].name = myalloc(strlen(s)+1);
strcpy(vlist[i].name,s);
vlist[i].val.rval = 0;
vlist[i].type_of_value = ty;
if(ty&T_QMASK == Q_ARY)
vlist[i].val.arval = myalloc(13*sizeof(union value));
}
return(&vlist[i]);
}
SHAR_EOF
if test 911 -ne "`wc -c < 'newbs/gvadr.c'`"
then
echo shar: error transmitting "'newbs/gvadr.c'" '(should have been 911 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/makefile'" '(193 characters)'
if test -f 'newbs/makefile'
then
echo shar: will not over-write existing file "'newbs/makefile'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/makefile'
operat2.o: mkop.sh op rop sop
mkop.sh >operat2.c
cc -c operat2.c
rm operat2.c
: done operat2.o
op: mkop.c
cc mkop.c -o op
rop: mkrbop.c
cc mkrbop.c -o rop
sop: mksop.c
cc mksop.c -o sop
SHAR_EOF
if test 193 -ne "`wc -c < 'newbs/makefile'`"
then
echo shar: error transmitting "'newbs/makefile'" '(should have been 193 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/makefile.old'" '(661 characters)'
if test -f 'newbs/makefile.old'
then
echo shar: will not over-write existing file "'newbs/makefile.old'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/makefile.old'
OFILES = lex.o bsint.o action.o operat.o bslib.o errors.o
PRSO= bsgram.o lex.o bslib.o
INTO= bsint.o action.o operat2.o operat.o bslib.o errors.o
prs: ${PRSO}
cc -s ${PRSO} -o prs
bsgram.o: bsgram.c bsdefs.h
cc -c bsgram.c
bsgram.c: bsgram.y
yacc -d bsgram.y
mv y.tab.c bsgram.c
mv y.tab.h bstokens.h
int: ${INTO}
cc ${INTO} -o int
${OFILES}: bsdefs.h
operat2.o: mkop.sh op rop sop
mkop.sh >operat2.c
cc -c operat2.c
rm operat2.c
: done operat2.o
op: mkop.c
cc mkop.c -o op
rop: mkrbop.c
cc mkrbop.c -o rop
sop: mksop.c
cc mksop.c -o sop
pr:
pr bsgram.y lex.c bsdefs.h bslib.c bsint.c action.c operat.c mkop.c mkrbop.c mksop.c errors.c | lpr
SHAR_EOF
if test 661 -ne "`wc -c < 'newbs/makefile.old'`"
then
echo shar: error transmitting "'newbs/makefile.old'" '(should have been 661 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/mkop.c'" '(1030 characters)'
if test -f 'newbs/mkop.c'
then
echo shar: will not over-write existing file "'newbs/mkop.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/mkop.c'
/* mkop.c -- make operator function for bs.
*
* USAGE: op name type oper tag
*
* where: name: name of function generated.
* type: data type of operation.
* oper: operator for operation.
* tag: structure tag name.
*
* This will only work with T_INT and T_DBL operators, T_CHR operations
* do not boil down to a simple operation.
*/
#include <stdio.h>
main(argc,argv)
char **argv;
int argc;
{
char *name,*type,*oper,*tag;
if(argc != 5) {
fprintf(stderr,"arg count\n");
exit(1);
}
name = argv[1]; type = argv[2]; oper = argv[3]; tag = argv[4];
printf("_%s(l,p)\n",name);
printf("int (*l[])(),p;\n");
printf("{\n");
printf(" union value rg1,rg2,result;\n");
printf("\n");
printf(" if((status&XMODE)==M_READ){ dtype=T_%s; goto EXEC;}\n",type);
printf(" if((status&XMODE) == M_EXECUTE) {\n");
printf("EXEC:\n");
printf(" rg2 = pop();\n");
printf(" rg1 = pop();\n");
printf(" result.%s = rg1.%s %s rg2.%s;\n",tag,tag,oper,tag);
printf(" push(result);\n");
printf(" }\n");
printf(" return(p);\n");
printf("}\n");
}
SHAR_EOF
if test 1030 -ne "`wc -c < 'newbs/mkop.c'`"
then
echo shar: error transmitting "'newbs/mkop.c'" '(should have been 1030 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/mkop.sh'" '(482 characters)'
if test -f 'newbs/mkop.sh'
then
echo shar: will not over-write existing file "'newbs/mkop.sh'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/mkop.sh'
echo "/* operat2.c -- more operators for bs. the ones that are all alike."
echo " */"
echo ""
echo "#include \"bsdefs.h\""
echo ""
op "radd" "DBL" "+" "rval"
op "rsub" "DBL" "-" "rval"
op "rmult" "DBL" "*" "rval"
op "rdiv" "DBL" "/" "rval"
rop "req" "=="
sop "seq" "=="
rop "rneq" "!="
sop "sneq" "!="
rop "rleq" "<="
sop "sleq" "<="
rop "rlt" "<"
sop "slt" "<"
rop "rgeq" ">="
sop "sgeq" ">="
rop "rgt" ">"
sop "sgt" ">"
op "or" "INT" "||" "ival"
op "and" "INT" "&&" "ival"
SHAR_EOF
if test 482 -ne "`wc -c < 'newbs/mkop.sh'`"
then
echo shar: error transmitting "'newbs/mkop.sh'" '(should have been 482 characters)'
fi
chmod +x 'newbs/mkop.sh'
fi # end of overwriting check
echo shar: extracting "'newbs/mksop.c'" '(725 characters)'
if test -f 'newbs/mksop.c'
then
echo shar: will not over-write existing file "'newbs/mksop.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/mksop.c'
/* mksop.c -- make string comparator functions for bs.
*
* USAGE: op name oper
*
* where: name: name of function generated.
* oper: operator for operation.
*/
#include <stdio.h>
main(argc,argv)
char **argv;
int argc;
{
char *name,*oper;
if(argc != 3) {
fprintf(stderr,"arg count\n");
exit(1);
}
name = argv[1]; oper = argv[2];
printf("_%s(l,p)\n",name);
printf("int (*l[])(),p;\n");
printf("{\n");
printf(" union value rg1,rg2,result;\n");
printf("\n");
printf(" if((status&XMODE) == M_EXECUTE) {\n");
printf(" rg2 = pop();\n");
printf(" rg1 = pop();\n");
printf(" result.sval = strcmp(rg1.sval,rg2.sval) %s 0;\n",oper);
printf(" push(result);\n");
printf(" }\n");
printf(" return(p);\n");
printf("}\n");
}
SHAR_EOF
if test 725 -ne "`wc -c < 'newbs/mksop.c'`"
then
echo shar: error transmitting "'newbs/mksop.c'" '(should have been 725 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/num_ins.c'" '(3393 characters)'
if test -f 'newbs/num_ins.c'
then
echo shar: will not over-write existing file "'newbs/num_ins.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/num_ins.c'
/* int_in() -- tokenizer routine for inputting a number.
* int_in() returns a pointer to a static data area. This area gets
* overwritten with each call to int_in so use the data before calling
* int_in() again.
*/
char * int_in()
{
register char c,*s;
static char text[20];
s = &text[0];
/* beginning state, skip junk until either '-' or ['0'-'9'] comes along */
l1: c=input();
if(c>='0' && c<='9') goto l3;
else if(c == '-') goto l2;
else {
if(c=='\n' || c=='\0') rdlin(bsin);
goto l1;
}
/* skipped junk, seen '-', gather it and make sure next char is a digit */
l2: *s++ = c;
c=input();
if(c==' ' || c=='\t') goto l2; /* allow white between sign and digit */
else if(c>='0' && c<='9') goto l3;
else { /* seen something not allowed. */
s = &text[0];
printf("\n\007??");
goto l1; /* restart machine */
}
/* skipped junk, seen a digit, gather until a non-digit appears */
l3: *s++ = c;
c=input();
if(c>='0' && c<='9') goto l3;
else {
/* have reached successful conclusion to machine. */
unput(c);
*s++ = '\0';
return(text);
}
}
/* real_in() -- read in a floating point number using input().
*
* real_in() returns a pointer to a static data area. This data area
* gets overwritten with each call to real_in(), so use it quickly.
*/
char *real_in()
{
register char *s,c;
static char bf[30];
s = &bf[0];
/* starting state. loops back until something interesting seen */
state1: c=input();
if(c == '-') goto state3;
else if(c>='0' && c<='9') goto state2;
else if(c == '.') goto state4;
else {
if(c == '\0') return(0);
/* else */
if(c == '\n') rdlin(bsin);
goto state1;
}
/* seen ([sign] dig). loop back for digs, looking for (.|e|E) */
state2: *s++ = c;
c=input();
if(c>='0' && c<='9') goto state2;
else if(c=='e' || c=='E') goto state6;
else if(c == '.') goto state4;
else goto state9; /* done */
/* seen (sign). looking for (dig). ignore whitespace. */
state3: *s++ = c;
state3_a: c=input();
if(c==' ' || c=='\t') goto state3_a;
else if(c>='0' && c<='9') goto state2;
else if(c == '.') goto state4;
else goto state10; /* error, had a sign so we have to have digs. */
/* seen ([sign] digs '.'). looking for digs. done on anything else */
state4: *s++ = c;
c=input();
if(c>='0' && c<='9') goto state5;
else goto state9; /* done */
/* seen ([sign] digs '.' dig). looking for (dig|e|E). done on anything else */
state5: *s++ = c;
c=input();
if(c=='e' || c=='E') goto state6;
else if(c>='0' && c<='9') goto state5;
else goto state9;
/* seen ([sign] digs '.' digs (e|E)). looking for sign or digs, else error. */
state6: *s++ = c;
c=input();
if(c=='+' || c=='-') goto state7;
else if(c>='0' && c<='9') goto state8;
else goto state10; /* error */
/* seen ([sign] digs '.' digs (e|E) sign). looking for digs, else error. */
state7: *s++ = c;
c=input();
if(c>='0' && c<='9') goto state8;
else goto state10; /* error */
/* seen ([sign] digs '.' digs (e|E) [sign] dig). looking for digs. */
state8: *s++ = c;
c=input();
if(c>='0' && c<='9') goto state8;
else goto state9; /* done */
/* seen a complete number. machine successfully completed. whew! */
state9: unput(c); /* might want that later */
*s++ = '\0';
return(bf);
/* Uh oh. An error. Print an error and restart. */
state10: printf("\n\007??");
s = &bf[0];
goto state1;
}
SHAR_EOF
if test 3393 -ne "`wc -c < 'newbs/num_ins.c'`"
then
echo shar: error transmitting "'newbs/num_ins.c'" '(should have been 3393 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/op2.c'" '(4171 characters)'
if test -f 'newbs/op2.c'
then
echo shar: will not over-write existing file "'newbs/op2.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/op2.c'
/* operat2.c -- more operators for bs. the ones that are all alike.
*/
#include "bsdefs.h"
_radd(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE)==M_READ){ dtype=T_DBL; goto EXEC;}
if((status&XMODE) == M_EXECUTE) {
EXEC:
rg2 = pop();
rg1 = pop();
result.rval = rg1.rval + rg2.rval;
push(result);
}
return(p);
}
_rsub(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE)==M_READ){ dtype=T_DBL; goto EXEC;}
if((status&XMODE) == M_EXECUTE) {
EXEC:
rg2 = pop();
rg1 = pop();
result.rval = rg1.rval - rg2.rval;
push(result);
}
return(p);
}
_rmult(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE)==M_READ){ dtype=T_DBL; goto EXEC;}
if((status&XMODE) == M_EXECUTE) {
EXEC:
rg2 = pop();
rg1 = pop();
result.rval = rg1.rval * rg2.rval;
push(result);
}
return(p);
}
_rdiv(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE)==M_READ){ dtype=T_DBL; goto EXEC;}
if((status&XMODE) == M_EXECUTE) {
EXEC:
rg2 = pop();
rg1 = pop();
result.rval = rg1.rval / rg2.rval;
push(result);
}
return(p);
}
_req(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.ival = rg1.rval == rg2.rval;
push(result);
}
return(p);
}
_seq(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.sval = strcmp(rg1.sval,rg2.sval) == 0;
push(result);
}
return(p);
}
_rneq(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.ival = rg1.rval != rg2.rval;
push(result);
}
return(p);
}
_sneq(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.sval = strcmp(rg1.sval,rg2.sval) != 0;
push(result);
}
return(p);
}
_rleq(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.ival = rg1.rval <= rg2.rval;
push(result);
}
return(p);
}
_sleq(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.sval = strcmp(rg1.sval,rg2.sval) <= 0;
push(result);
}
return(p);
}
_rlt(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.ival = rg1.rval < rg2.rval;
push(result);
}
return(p);
}
_slt(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.sval = strcmp(rg1.sval,rg2.sval) < 0;
push(result);
}
return(p);
}
_rgeq(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.ival = rg1.rval >= rg2.rval;
push(result);
}
return(p);
}
_sgeq(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.sval = strcmp(rg1.sval,rg2.sval) >= 0;
push(result);
}
return(p);
}
_rgt(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.ival = rg1.rval > rg2.rval;
push(result);
}
return(p);
}
_sgt(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.sval = strcmp(rg1.sval,rg2.sval) > 0;
push(result);
}
return(p);
}
_or(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE)==M_READ){ dtype=T_INT; goto EXEC;}
if((status&XMODE) == M_EXECUTE) {
EXEC:
rg2 = pop();
rg1 = pop();
result.ival = rg1.ival || rg2.ival;
push(result);
}
return(p);
}
_and(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE)==M_READ){ dtype=T_INT; goto EXEC;}
if((status&XMODE) == M_EXECUTE) {
EXEC:
rg2 = pop();
rg1 = pop();
result.ival = rg1.ival && rg2.ival;
push(result);
}
return(p);
}
SHAR_EOF
if test 4171 -ne "`wc -c < 'newbs/op2.c'`"
then
echo shar: error transmitting "'newbs/op2.c'" '(should have been 4171 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/operat.c'" '(8663 characters)'
if test -f 'newbs/operat.c'
then
echo shar: will not over-write existing file "'newbs/operat.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/operat.c'
/* operat.c -- operations, as opposed to actions. FOR is an action,
* '+' is an operation.
*
* More operators can be found in the machine generated file "operat2.c".
*/
#include "bsdefs.h"
/* BINARY OPERATORS */
/* Common description for the binary ops.
* also applies to all ops in operat2.c
*
* M_COMPILE:
* x op x --to-- x,_op,x
* M_EXECUTE:
* stack: ar2,ar1,x --to-- (ar1 op ar2),x
*/
_comma(l,p) int (*l[])(),p;
{
union value s1,s2,s3;
if((status&XMODE) == M_FIXUP) return(p);
if((status&XMODE) == M_READ) { dtype = T_CHR; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
s1 = pop();
s2 = pop();
s3.sval = myalloc(strlen(s1.sval)+strlen(s2.sval)+3);
strcpy(s3.sval,s2.sval);
strcat(s3.sval,"\t");
strcat(s3.sval,s1.sval);
if(s1.sval != 0) free(s1.sval);
if(s2.sval != 0) free(s2.sval);
push(s3);
}
return(p);
}
_scolon(l,p) int(*l[])(),p;
{
union value s1,s2,s3;
if((status&XMODE) == M_READ) { dtype = T_CHR; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
s1 = pop();
s2 = pop();
s3.sval = myalloc(strlen(s1.sval)+strlen(s2.sval)+2);
strcpy(s3.sval,s2.sval);
strcat(s3.sval,s1.sval);
push(s3);
if(s1.sval != 0) free(s1.sval);
if(s2.sval != 0) free(s2.sval);
}
return(p);
}
/* last of binary operators */
/* ---And now for something completely different: a Unary Operator.
*
* M_COMPILE:
* x not x --to-- x,_not,x
* M_EXECUTE:
* stack: bool,x --to-- !(bool),x
*/
_not(l,p) int (*l[])(),p;
{
union value val;
if((status&XMODE) == M_EXECUTE) {
val = pop();
val.ival = ! val.ival;
push(val);
}
return(p);
}
/* M_COMPILE:
* x itoa x --to-- x,_itoa,x
* M_EXECUTE:
* stack: int,x --to-- string,x
*/
_itoa(l,p)
int (*l[])(),p;
{
union value val;
char s2[30];
if((status&XMODE) == M_READ) { dtype = T_CHR; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
val=pop();
sprintf(s2,"%D",val.ival); /* optimize later */
if(dbg) printf("_icon():M_EXECUTE:ival:%D to sval:%s\n",val.ival,s2);
val.sval=myalloc(strlen(s2)+1);
strcpy(val.sval,s2);
push(val);
}
return(p);
}
_rtoa(l,p)
int (*l[])(),p;
{
union value val;
char s2[30];
if((status&XMODE) == M_READ) { dtype = T_CHR; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
val = pop();
sprintf(s2,"%g",val.rval);
if(dbg) printf("_rtoa():M_EXECUTE:rval:%g to sval:%s\n",val.rval,s2);
val.sval = myalloc(strlen(s2)+1);
strcpy(val.sval,s2);
push(val);
}
return(p);
}
_itor(l,p)
int (*l[])(),p;
{
union value v1,v2;
if((status&XMODE) == M_READ) { dtype = T_DBL; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
v1 = pop();
v2.rval = (double)v1.ival;
push(v2);
}
return(p);
}
_rtoi(l,p)
int (*l[])(),p;
{
union value v1,v2;
if((status&XMODE) == M_READ) { dtype = T_INT; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
v1 = pop();
v2.ival = (int)v1.rval;
push(v2);
}
return(p);
}
/* M_COMPILE:
* x scon "quoted string" x --to-- x,_scon,&string,x
* M_EXECUTE:
* stack: x --to-- string,x
* other: pushes a COPY of the string, not the original.
*/
_scon(l,p)
int (*l[])(),p;
{
char *s,c;
union value val;
int i;
if((status&XMODE) == M_FIXUP) ++p;
if((status&XMODE) == M_READ) { dtype = T_CHR; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
s = l[p++];
val.sval = myalloc(strlen(s)+1);
strcpy(val.sval,s);
push(val);
if(dbg) printf("_scon():M_EXECUTE:sval:%s\n",val.sval);
}
return(p);
}
/* M_COMPILE:
* x icon int x --to-- x,_icon,int,x
* M_EXECUTE:
* stack: x --to-- int,x
*/
_icon(l,p)
int (*l[])(),p;
{
union value val;
union loni v;
int i;
if((status&XMODE) == M_FIXUP) return(p+(sizeof(long)/sizeof(int)));
if((status&XMODE) == M_READ) { dtype = T_INT; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
for(i=0; i<(sizeof(long)/sizeof(int)); i++)
v.i_in_loni[i] = l[p++];
val.ival = v.l_in_loni;
push(val);
if(dbg) printf("_icon():M_EXECUTE:ival:%D\n",val.ival);
}
return(p);
}
_rcon(l,p)
int (*l[])(),p;
{
union doni v;
int i;
union value val;
if((status&XMODE) == M_FIXUP) return(p+(sizeof(double)/sizeof(int)));
if((status&XMODE) == M_READ) { dtype = T_DBL; goto EXEC; }
if((status&XMODE) = M_EXECUTE) {
EXEC:
for(i=0; i<(sizeof(double)/sizeof(int)); i++)
v.i_in_doni[i] = l[p++];
val.rval = v.d_in_doni;
push(val);
}
return(p);
}
/* M_COMPILE:
* x val type x --to-- x,_val,type,x
* M_EXECUTE:
* stack: place,x --to-- value,x
* other: for strings, pushes a copy of the string.
*/
_val(l,p) int(*l[])(),p;
{
union value place,val;
int ty;
if((status&XMODE) == M_READ) { dtype = l[p]; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
ty = l[p];
place = pop();
if(dbg) printf("_val():M_EXECUTE:var:%s",place.vpval->name);
place.plval = getplace(place.vpval);
if(ty==T_CHR && place.plval->sval!=0) {
val.sval = myalloc(strlen(place.plval->sval)+1);
strcpy(val.sval,place.plval->sval);
push(val);
}
else push(*place.plval);
if(dbg) printf(":ival:%D:rval:%g:sval:%s\n",ty==T_INT?place.plval->ival:(long)0,
ty==T_DBL?place.plval->rval:(double)0,ty==T_CHR?place.plval->sval:0);
}
return(p+1);
}
/* M_COMPILE:
* x store typ x --to-- x,_store,type,x
* M_EXECUTE:
* stack: value,location,x --to-- value,x
* (stores value at location).
*/
_store(l,p) int(*l[])(),p;
{
union value place,val;
int ty;
if((status&XMODE) == M_READ) { dtype = l[p]; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
val = pop();
place = pop();
ty = l[p];
if(dbg) printf("_store():M_EXECUTE:var:%s:ival:%D:rval:%g:sval:%s\n",
place.vpval->name,ty==T_INT?val.ival:(long)0,ty==T_DBL?val.rval:(double)0,ty==T_CHR?val.sval:0);
place.plval = getplace(place.vpval);
if(ty==T_CHR && place.plval->sval!=0) free(place.plval->sval);
(*place.plval) = val;
push(val);
}
return(p+1);
}
/* M_COMPILE:
* x var typ name x --to-- x,_var,&vlist entry,x
* M_EXECUTE:
* stack: x --to-- &vlist entry,x
* M_INPUT:
* (&vlist entry)->val is set to input value.
* M_READ:
* Moves the data list pointers to the next data item. If no next
* data item, calls ODerror.
* Does a "gosub" to the data item, to get its value on the stack.
* Does T_INT to T_CHR conversion if necessary.
* Pops value into vp->val.
*/
_var(l,p) int(*l[])(),p; /* same proc for any variable type */
{
char *s;
struct dictnode *vp;
struct line *thislist;
union value place,val;
int ty,qual;
if((status&XMODE) == M_EXECUTE) {
val.vpval = l[p++];
if(dbg) printf("_var():M_EXECUTE:var:(%d)%s\n",val.vpval->type_of_value,
val.vpval->name);
push(val);
return(p);
}
if((status&XMODE) == M_INPUT) {
vp = l[p++];
place.plval = getplace(vp);
ty = (vp->type_of_value) & T_TMASK;
if(ty == T_INT)
place.plval->ival = atol(int_in());
else if(ty == T_DBL)
place.plval->rval = atof(real_in());
else /* ty == T_CHR */
place.plval->sval = scon_in();
if(dbg) printf("_var():M_INPUT:var:(%d)%s:ival:%D:rval:%g:sval:%s\n",
vp->type_of_value,vp->name,ty==T_INT?place.plval->ival:(long)0,
ty==T_DBL?place.plval->rval:(double)0,ty==T_CHR?place.plval->sval:0);
return(p);
}
if((status&XMODE) == M_READ) {
nxdl: if(dlist[dlp] == 0) ODerror(l,p); /* ran off end of dlist */
thislist = dlist[dlp];
if((thislist->code)[dlindx] == 0) {
dlp++;
dlindx = 2; /* skips <_data,0> */
goto nxdl;
}
status = M_EXECUTE;
dlindx = interp(thislist->code,dlindx);
status = M_READ;
val = pop();
vp = l[p];
place.plval = getplace(vp);
qual = vp->type_of_value&T_TMASK;
if(qual == T_INT) {
if(dtype == T_DBL) {
push(val); _rtoi(l,p); val = pop();
}
place.plval->ival = val.ival;
}
else if(qual == T_DBL) {
if(dtype == T_INT) {
push(val); _itor(l,p); val = pop();
}
place.plval->rval = val.rval;
}
else if(qual == T_CHR) {
if(dtype == T_INT) {
push(val); _itoa(l,p); val = pop();
}
else if(dtype == T_DBL) {
push(val); _rtoa(l,p); val = pop();
}
if(place.plval->sval != 0) free(place.plval->sval);
place.plval->sval = myalloc(strlen(val.sval)+1);
strcpy(place.plval->sval,val.sval);
}
else VTerror(l,p);
return(p+1);
}
return(p+1);
}
SHAR_EOF
if test 8663 -ne "`wc -c < 'newbs/operat.c'`"
then
echo shar: error transmitting "'newbs/operat.c'" '(should have been 8663 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/scon_in.c'" '(1454 characters)'
if test -f 'newbs/scon_in.c'
then
echo shar: will not over-write existing file "'newbs/scon_in.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/scon_in.c'
/* scon_in() -- read in a string constant using input.
* Format of an scon is either a quoted string, or a sequence
* of characters ended with a seperator (' ', '\t' or '\n' or ',').
*
* In either mode, you can get funny characters into the string by
* "quoting" them with a '\'.
*
* scon_in() uses myalloc() to create space to store the string in.
*/
char *scon_in()
{
register char c,*s;
static char text [80];
s = &text[0];
/* beginning state, skip seperators until something interesting comes along */
l1: c=input();
if(c == '"') goto l2;
else if(c=='\n' || c=='\0') {
rdlin(bsin);
goto l1;
}
else if(c==' ' || c=='\t' || c==',') goto l1;
else goto l3;
/* have skipped unwanted material, seen a '"', read in a quoted string */
l2: c=input();
if(c == '\n') {
fprintf(stderr,"scon_in: unterminated string\n");
exit(1);
}
else if(c == '\\') { *s++ = bslash(bsin); goto l2; }
else if(c == '"')
if((c=input()) == '"') {
*s++ = '"';
goto l2;
}
else goto done;
else { *s++ = c; goto l2; }
/* skipped unwanted, seen something interesting, not '"', gather until sep */
l3: *s++ = c;
c=input();
if(c == '\\') { c = bslash(bsin); goto l3; }
else if(c==' ' || c=='\t' || c==',' || c=='\n') goto done;
else goto l3;
/* final state (if machine finished ok.) */
done: unput(c);
*s++ = '\0';
s=myalloc(strlen(text)+1);
strcpy(s,text);
return(s);
}
SHAR_EOF
if test 1454 -ne "`wc -c < 'newbs/scon_in.c'`"
then
echo shar: error transmitting "'newbs/scon_in.c'" '(should have been 1454 characters)'
fi
fi # end of overwriting check
# End of shell archive
exit 0
More information about the Mod.sources
mailing list