Relay-Version: version B 2.10.3 4.3bsd-beta 6/6/85; site seismo.UUCP Posting-Version: version B 2.10.2 9/3/84; site genrad.UUCP Path: seismo!harvard!think!mit-eddie!genrad!sources-request From: sources-request@genrad.UUCP Newsgroups: mod.sources Subject: A BASIC interpretor (Part 2 of 4) Message-ID: <990@genrad.UUCP> Date: 31 Jul 85 10:16:54 GMT Sender: john@genrad.UUCP Lines: 2017 Approved: john@genrad.UUCP 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 #include /* '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 . * next 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) { 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 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 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