home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Usenet 1994 October
/
usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso
/
unix
/
volume7
/
basic
/
part01
next >
Wrap
Text File
|
1986-12-03
|
56KB
|
1,999 lines
Subject: v07i073: A BASIC Interpreter, Part01/06
Newsgroups: mod.sources
Approved: mirror!rs
Submitted by: phil@Cs.Ucl.AC.UK
Mod.sources: Volume 7, Issue 73
Archive-name: basic/Part01
[ This code ran fine on my Pyramid98x. --r$ ]
# Shar file shar01 (of 6)
#
# This is a shell archive containing the following files :-
# README
# assist.c
# bas.h
# bas1.c
# ------------------------------
# This is a shell archive, shar, format file.
# To unarchive, feed this text into /bin/sh in the directory
# you wish the files to be in.
echo Makeing subdirs 1>&2
mkdir pdp11 cursor vax pyramid docs m68000
echo x - README 1>&2
sed 's/^X//' > README << 'End of README'
XBASIC (an Interpreter)
X----------------------
X
XThis directory contains the source of my BASIC interpreter.
XIt was originally started when I was a student as a 2ndyr project, I
Xcontinued to work on it afterwards every once in a while, putting
Xvarious extra facilities into it as I went along.
XThe interpreter is based on a combination of Microsoft level 5 basic and
Xand RT11's MU-Basic with a smattering of Basic Plus in there for good
Xmeasure. The rational behind this was that these were the versions I
Xfirst learned to program in (many years ago). There are some parts of
Xthe system I would redo again (especially the file handling - which is
Xonly just workable) but I don't have the time. I'm sure the
Xdocumentation does not have all the latest facilities in but most of
Xthem can be worked out from the source code.
X
XThis code is being put in the Public Domain since I will soon loose
Xnetwork connectivity (I am leaving my job) and I don't particularly want
Xto sell it. This system does not contain any proprietary software. All
Xthe algorithms are original or come from publicly available sources.
X
XThere are no licensing restrictions on this code or documentation at
Xall. I only ask that you give appropriate credit to the author.
X
XBuilding the system
X-------------------
X
XThis system has been built and tested on a Vax running 4.2 (4.1) on a
Xpdp11 (with and without floating point hardware ) running V6 V7 BSD 2.8 and
XBSD 2.9, a pyramid 98X and on a unisoft 68000 (V7) system. With
Xappropriate convertion of the terminal handling routines (about 20 lines
Xof code) it should run on System V systems as well.
X
XThe system dependent code has been extracted and placed in relevent
Xsubdirectories. Follow one of the current systems for conversion guidance.
XThe only nasty is that it assumes (in print()) that ints and structure
Xpointers are the same size. This can be fixed but I don't want to do it.
X(It also assumes that all pointer types are the same size which I
Xwouldn't like to have to fix)
X
XTo compile the system use the "gen" shell script which will do all the
Xwork.
X
XYou may want to sort out the terminal handling/editing routines as
Xwell.
X
XHave fun.
X
XPhil Cockcroft Fall, 86
X------------------------
End of README
chmod u=rw-,g=r,o=r README
echo x - assist.c 1>&2
sed 's/^X//' > assist.c << 'End of assist.c'
X/*
X * BASIC by Phil Cockcroft
X */
X#include "bas.h"
X
X/* this file contains all the routines that were originally done in assembler
X * these routines only require a floating point emulator to work.
X * To speed things up some routines could be put into assembler and some
X * could be made into macros. the relevent routines are labeled as such
X */
X
X#ifndef VAX_ASSEM /* if done in assembler don't bring it in */
X/* AS */
X
X/* get a single character from the line pointed to by getch() */
X
Xgetch()
X{
X register char *p;
X
X p = point;
X while(*p++ == ' ');
X point = p;
X return(*--p & 0377);
X}
X
X/* AS #define ELSE 0351 */
X
Xcheck() /* check to see no garbage at end of command */
X{
X register char *p;
X register char c;
X
X p = point;
X while(*p++ == ' ');
X if(! (c = *--p) || c == ':' || (c == (char)ELSE && elsecount)){
X point = p;
X return;
X }
X error(SYNTAX); /* not a terminator - error */
X}
X#endif
X
X#ifndef SOFTFP
Xfpcrash()
X{
X error(34); /* arithmetic overflow */
X}
X#endif
X
Xint (*fpfunc)();
X
Xstartfp()
X{
X#ifndef SOFTFP
X fpfunc = fpcrash; /* will call error(34) on overflow */
X#else
X fpfunc = 0;
X#endif
X}
X
X/* AS */
X
X/* compare two values. return 0 if equal -1 if first less than second
X * or 1 for vice versa.
X */
X
Xcmp(p,q)
Xregister value *p,*q;
X{
X if(vartype){
X if(p->i == q->i)
X return(0);
X else if(p->i < q->i)
X return(-1);
X return(1);
X }
X if(p->f == q->f)
X return(0);
X else if(p->f< q->f )
X return(-1);
X return(1);
X}
X
X/* the arithmetic operation jump table */
X
X
X/* all the routines below should be put into AS */
X
Xint fandor(), andor(), comop(), fads(), ads(),
X fmdm(), mdm(), fexp(), ex();
X
Xint (*mbin[])() = {
X 0,0,
X fandor,
X andor,
X comop,
X comop,
X fads,
X ads,
X fmdm,
X mdm,
X fexp,
X ex,
X };
X
Xtypedef value *valp;
X
Xex(p,q,c) /* integer exponentiation */
Xvalp p,q;
X{
X cvt(p);
X cvt(q);
X vartype = 0;
X fexp(p,q,c);
X}
X
Xfmdm(p,q,c) /* floating * / mod */
Xvalp p,q;
X{
X double floor(),x;
X if(c == '*'){
X fmul(p,q);
X return;
X }
X if(q->f == 0)
X error(25);
X if(c=='/')
X fdiv(p,q);
X else { /* floating mod - yeuch */
X if( (x = p->f/q->f) < 0)
X q->f = p->f + floor(-x) * q->f;
X else
X q->f = p->f - floor(x) * q->f;
X }
X}
X
Xmdm(p,q,c) /* integer * / mod */
Xvalp p,q;
X{
X register long l;
X register short ll;
X
X l = p->i;
X if(c=='*'){
X l *= q->i;
X#ifdef VAX_ASSEM
X ll = l;
X { asm("bvc mdmov"); }
X q->f = l;
X vartype = 0;
X { asm("ret"); } /* could be 'return' */
X { asm("mdmov: "); }
X q->i = ll;
X#else
X if(l > 32767 || l < -32768){ /* overflow */
X q->f = l;
X vartype = 0;
X }
X else q->i = l;
X#endif
X return;
X }
X if(!q->i) /* zero divisor error */
X error(25);
X ll = p->i % q->i;
X if(c == '/'){
X if(ll){
X q->f = (double)l / q->i;
X vartype = 0;
X }
X else
X q->i = p->i / q->i;
X }
X else
X q->i = ll;
X}
X
Xfads(p,q,c) /* floating + - */
Xvalp p,q;
X{
X if(c=='+')
X fadd(p,q);
X else
X fsub(p,q);
X}
X
Xads(p,q,c) /* integer + - */
Xvalp p,q;
X{
X register long l;
X#ifdef VAX_ASSEM
X register short ll;
X#endif
X
X l = p->i;
X if(c == '+')
X l += q->i;
X else
X l -= q->i;
X#ifdef VAX_ASSEM
X ll = l;
X { asm("bvc adsov"); }
X q->f = l;
X vartype = 0;
X { asm("ret"); } /* could be 'return' */
X { asm("adsov: "); }
X q->i = ll;
X#else
X if(l > 32767 || l < -32768){ /* overflow */
X q->f = l;
X vartype = 0;
X }
X else
X q->i = l;
X#endif
X}
X
Xcomop(p,q,c) /* comparison operations */
Xvalp p,q;
X{
X compare(c,cmp(p,q));
X}
X
Xfandor(p,q,c) /* floating logical AND/OR/XOR */
Xregister valp p,q;
X{
X vartype = 01;
X#ifdef PORTABLE
X p->i = ((p->f != 0.0) ? -1 : 0);
X q->i = ((q->f != 0.0) ? -1 : 0);
X#else
X p->i = (p->i ? -1 : 0);
X q->i = (q->i ? -1 : 0);
X#endif
X andor(p,q,c);
X}
X
Xandor(p,q,c) /* integer logical */
Xvalp p,q;
X{
X register i,j;
X
X i = p->i;
X j = q->i;
X if(c == ANDD) /* and */
X i &= j;
X else if(c == ORR) /* or */
X i |= j;
X else
X i ^= j; /* xor */
X q->i = i;
X}
X
X/* down to about here */
X
X/* MACRO */
X
Xputin(p,var) /* convert + put the value in res into p */
Xmemp p;
Xchar var;
X{
X if(vartype != var){
X if(var){
X if(conv(&res))
X error(35);
X }
X else
X cvt(&res);
X }
X if(var)
X ((value *)p)->i = res.i;
X else
X ((value *)p)->f = res.f;
X}
X
X/* MACRO */
X
Xnegate() /* negate the value in res */
X{
X if(vartype){
X if(res.i == -32768){ /* special case */
X res.f = 32768;
X vartype = 0;
X }
X else
X res.i = -res.i;
X }
X else
X res.f = -res.f;
X}
X
X/* MACRO */
X
Xnotit() /* logical negation */
X{
X if(vartype){
X res.i = ~res.i;
X return;
X }
X vartype = 01;
X#ifdef PORTABLE
X if(res.f)
X res.i = 0;
X else
X res.i = -1;
X#else
X if(res.i)
X res.i = 0;
X else
X res.i = -1;
X#endif
X}
X
Xfexp(p,q,c) /* floating exponentiation */
Xvalp p,q;
X{
X double x,log(),exp();
X
X if(p->f < 0)
X error(41);
X else if(q->f == 0.0)
X q->f = 1.0;
X else if(p->f == 0.0) /* could use pow - but not on v6 */
X q->f = 0.0;
X else {
X if( (x = log(p->f) * q->f) > 88.02969) /* should be bigger */
X error(40);
X q->f = exp(x);
X }
X}
End of assist.c
chmod u=rw-,g=r,o=r assist.c
echo x - bas.h 1>&2
sed 's/^X//' > bas.h << 'End of bas.h'
X/*
X * BASIC by Phil Cockcroft
X */
X/*
X * This file contains all the variables and definitions needed by
X * all the C parts of the interpreter.
X */
X
X/*
X * include the correct include file for the current machine
X */
X
X#ifdef vax
X#include "vax/conf.h"
X#endif
X#ifdef pdp11
X#include "pdp11/conf.h"
X#endif
X#ifdef m68000
X#include "m68000/conf.h"
X#endif
X#ifdef pyramid
X#include "pyramid/conf.h"
X#endif
X
X#define MASK 0377
X#define SPECIAL 0200 /* top bit set */
X#define SYNTAX 1 /* error code */
X#define MAXLIN 255 /* maximum length of input line */
X#define BUSERR 10 /* bus error */
X#define SEGERR 11 /* segmentation violation */
X#define DEFAULTSTRING 512 /* default size of string space */
X#define VARREQD 2 /* error code */
X#define OUTOFSTRINGSPACE 3 /* ditto */
X#define NORMAL 0 /* normal return from a command */
X#define GTO 1 /* ignore rest of line return */
X#define normret return(NORMAL)
X#define MAXERR 51 /* maximum value of error code */
X#define BADDATA 26 /* error message values */
X#define OUTOFDATA 27
X#define FUNCT 33
X#define FLOATOVER 34
X#define INTOVER 35
X#define REDEFFN 45
X#define UNDEFFN 46
X#define CANTCONT 47
X
X#ifdef LNAMES /* if you want long names... */
X
X#define MAXNAME 16 /* maximum size of a name -1 */
X#define HSHTABSIZ 37 /* size of initial hash table */
X /* very rule of thumb. */
X#endif
X
X/*
X * values of constants from the symbol table
X */
X
X#define MAXFUNC 0350 /* maximum allowed function code */
X#define RND 0343 /* rnd function code */
X#define FN 0344
X#define MINFUNC 0311
X#define MAXSTRING 0307
X#define DATE 0310
X#define MAXCOMMAND 0272 /* maximum allowed command code */
X#define MINSTRING 0271 /* the rest are pretty obvious */
X#define DATA 0236
X#define QUOTE 0233
X#define ERROR 0231
X#define GOSUB 0226
X#define FOR 0224
X#define IF 0221
X#define INPUT 0212
X#define RUNN 0201
X#define REM 0203
X#define GOTO 0202
X#define WHILE 0257
X#define WEND 0260
X#define REPEAT 0255
X#define UNTIL 0256
X#define ELSE 0351
X#define THEN 0352
X#define ON 0230
X#define RESUME 0220
X#define RESTORE 0240
X#define TABB 0353 /* tab command */
X#define STEP 0354
X#define TO 0355
X#define AS 0365
X#define OUTPUT 0366
X#define APPEND 0367
X#define TERMINAL 0371
X
X/* logical operators */
X
X#define MODD 0361
X#define ANDD 0356
X#define ORR 0357
X#define XORR 0360
X#define NOTT 0370
X
X/* comparison operators */
X
X#define EQL '='
X#define LTEQ 0362
X#define NEQE 0363
X#define LTTH '<'
X#define GTEQ 0364
X#define GRTH '>'
X
X/* values used for file maintainance */
X
X#define _READ 01
X#define _WRITE 02
X#define _EOF 04
X#define _TERMINAL 010
X
X/*
X N.B. The value of this (_BLOCKED) controls wether the blockmode file stuff
X is included. ( comment this constant out if don't want it).
X*/
X#define _BLOCKED 020
X
X#define MAXFILES 9
X
X#define ESCAPE '\033'
X
X/* definitions of some simple functions */
X/* isletter() - true if character is a letter */
X/* isnumber() - true if character is a number */
X/* istermin() - true if character is a terminator */
X
X#define isletter(c) ((c)>='a' && (c)<='z')
X#define isnumber(c) ((c)>='0' && (c)<='9')
X#define istermin(c) (!(c)|| (c)==':' ||((char)(c)==(char)ELSE && elsecount))
X
X/* define the offset to the next line */
X
X#define lenv(p) ((p)->llen)
X
Xtypedef struct olin *lpoint; /* typedef for pointer to a line */
Xtypedef struct deffn *deffnp; /* pointer to a function definition */
Xtypedef struct filebuf *filebufp; /* pointer to a filebuffer */
Xtypedef struct forst *forstp; /* pointer to a for block */
Xtypedef struct strarr *strarrp; /* pointer to an array header */
Xtypedef struct vardata *vardp; /* pointer to a variable */
Xtypedef struct stdata *stdatap; /* pointer to a string header */
Xtypedef char *memp; /* a memory pointer */
X
X/* typedef fo the standard dual type of variable */
X
Xtypedef union {
X short i;
X double f;
X } value;
X
X/* declarations to stop the C compiler complaining */
X
Xfilebufp getf();
Xlpoint getline();
Xmemp xpand(),getname();
Xchar *printlin(),*strcpy(),*grow(),*getenv();
X
Xint rnd(),ffn(),pii(),erlin(),erval(),tim();
Xint sgn(),len(),abs(),val(),ascval(),instr(),eofl(),fposn(),sqrtf(),
X logf(),expf(),evalu(),intf(),peekf(),sinf(),cosf(),atanf(),
X mkint(),mkdouble(), ssystem();
Xint midst(),rightst(),leftst(),strng(),estrng(),chrstr(),nstrng(),
X space(),getstf(),mkistr(),mkdstr();
Xint endd(),runn(),gotos(),rem(),lets(),list(),
X print(),stop(),delete(),editl(),input(),clearl(),
X save(),old(),neww(),shell(),resume(),iff(),
X random(),dimensio(),forr(),next(),gosub(),retn(),
X onn(),doerror(),print(),rem(),dauto(),
X readd(),dodata(),cls(),restore(),base(),fopen(),
X fclosef(),merge(),quit(),chain(),deffunc(),cont(),lhmidst(),
X linput(),poke(),rept(),untilf(),whilef(),wendf(),fseek(),renumb(),
X dump(),loadd();
X
X/* all structures must have an exact multiple of the size of an int
X * to the start of the next structure
X */
X
Xstruct stdata { /* data for the string pointer */
X unsigned snam; /* getname() will return the address */
X char *stpt; /* of this structure for a string access */
X };
X
Xstruct vardata { /* storage of a standard non-indexed */
X unsigned nam; /* variable */
X value dt;
X };
X
Xtypedef unsigned xlinnumb; /* the type of linnumbers */
X
Xstruct olin{ /* structure for a line */
X unsigned linnumb;
X unsigned llen;
X char lin[1];
X };
X
Xstruct strarr { /* structure for an array */
X unsigned snm; /* name */
X int hash; /* index to the next array or the start */
X short dimens; /* of the special numbers */
X short dim[3]; /* the dimensions */
X };
X
X
Xstruct forst { /* for / gosub stack */
X char *fnnm; /* pointer to variable - relative to earray */
X char fr,elses; /* type of structure , elsecount on return */
X value final; /* the start and end values */
X value step;
X lpoint stolin; /* pointer to return start of line */
X char *pt; /* return value for point */
X };
X
X#ifdef LNAMES
X
Xstruct entry { /* the structure for a long name storage */
X struct entry *link;
X int ln_hash; /* hash value of entry */
X char _name[MAXNAME];
X };
X
X#endif
X
X#ifdef V7
X
X#include <setjmp.h>
X#include <signal.h>
X#include <sys/types.h>
X#include <sys/stat.h>
X
X#define setexit() setjmp(rcall)
X#define reset() longjmp(rcall,0)
X
X#else
X
Xstruct stat {
X short st_dev;
X short st_ino;
X short st_mode;
X int _stat[15];
X };
X
X#define _exit(x) exit(x)
X
Xint (*signal())();
X#define SIGINT 2
X#define SIGQUIT 3
X#define SIGFPE 8
X#define SIG_IGN ((int(*)())1)
X#define SIG_DFL ((int(*)())0)
X#define NSIG 16
X
X#endif
X
X#ifndef pdp11 /* don't need it on a VAX system */
X#define checksp() /* nothing */
X#endif
X
Xstruct filebuf { /* the file buffer structure */
X short filedes; /* system file descriptor */
X short userfiledes; /* user name */
X int posn; /* cursor / read positon */
X#ifdef _BLOCKED
X short blocksiz; /* if want block mode files */
X#endif
X short inodnumber; /* to stop people reading and writing */
X short device; /* to the same file at the same time */
X short use; /* flags */
X short nleft; /* number of characters in buffer */
X char buf[BLOCKSIZ]; /* the buffer itself */
X };
X
Xstruct tabl { /* structure for symbol table */
X char *string;
X int chval;
X };
X
Xstruct deffn { /* structure for a user definable function */
X int dnm;
X int offs;
X char narg;
X char vtys;
X short vargs[3];
X char exp[1];
X };
X
X#ifndef SOFTFP
X
X#define fadd(p,q) ((q)->f += (p)->f)
X#define fsub(p,q) ((q)->f = (p)->f - (q)->f)
X#define fmul(p,q) ((q)->f *= (p)->f)
X#define fdiv(p,q) ((q)->f = (p)->f / (q)->f)
X
X#define conv(p) \
X ( ((p)->f > MAXint || (p)->f < MINint) ? 1 : ( ((p)->i = (p)->f), 0) )
X
X#define cvt(p) (p)->f = (p)->i
X
X#endif
X
X/*
X * On pdp11's and VAXen the loader is clever about global bss symbols
X * On 68000's this is not true so we have to define the memory pointers
X * to be members of an array.
X */
X#ifdef MPORTABLE
X#define estring _space_[0]
X#ifdef LNAMES
X#define enames _space_[1]
X#define edefns _space_[2]
X#define estarr _space_[3]
X#define earray _space_[4]
X#define vend _space_[5]
X#define bstk _space_[6]
X#define vvend _space_[7]
X#else
X#define edefns _space_[1]
X#define estarr _space_[2]
X#define earray _space_[3]
X#define vend _space_[4]
X#define bstk _space_[5]
X#define vvend _space_[6]
X#endif
X
X#endif
X
X
X/*
X * PART1 is declared only once and so allocates storage for the
X * variables only once , otherwise the definiton for the variables
X * ( in all source files except bas1.c ). is declared as external.
X */
X
X#ifdef PART1
X
Xint baseval=1; /* value of the initial base for arrays */
Xchar nl[]="\n"; /* a new_line character */
Xchar line[MAXLIN+2]; /* the input line */
Xchar nline[MAXLIN]; /* the array used to store the compiled line */
Xunsigned linenumber; /* linenumber form compile */
X
X/* pointers to the various sections of the memory map */
X
Xmemp filestart; /* end of bss , start of file buffers */
Xmemp fendcore; /* end of buffers , start of text */
Xmemp ecore; /* end of text , start of string space */
Xmemp eostring; /* end of full strings */
Xmemp estdt; /* start of string header blocks */
X
X/* all these pointers below must be defined in this order so that xpand
X * will be able to increment them all */
X
X#ifndef MPORTABLE
Xmemp estring; /* end of strings , start of func defs */
X#ifdef LNAMES
Xmemp enames; /* end of symbol table. start of def fncs */
X#endif
Xmemp edefns; /* end of def fncs , start of arrays */
Xmemp estarr; /* end of string array structures */
Xmemp earray; /* end of arrays , start of simple variables */
Xmemp vend; /* end of simple variables , start of gosub stack */
Xmemp bstk;
Xmemp vvend; /* end of stack , top of memory */
X#else
Xmemp _space_[8]; /* for use in portable systems */
X#endif
X
X/* up to this point */
X
Xint cursor; /* position of cursor on line */
Xunsigned shash; /* starting value for string arrays */
Xint mcore(); /* trap functions- keep compiler happy */
Xint seger();
Xint trap();
Xlpoint stocurlin; /* start of current line */
Xunsigned curline; /* current line number */
Xint readfile; /* input file , file descriptor */
Xchar *point; /* pointer to current location */
Xchar *savepoint; /* value of point at start of current command */
Xchar elsecount; /* flag for enabling ELSEs as terminators */
Xchar vartype; /* current type of variable */
Xchar runmode; /* run or immeadiate mode */
Xchar ertrap; /* are about to call the error trapping routine */
Xchar intrap; /* we are in the error trapping routine */
Xchar trapped; /* cntrl-c trap has occured */
Xchar inserted; /* the line table has been changed, clear variables */
Xchar eelsecount; /* variables to save the current state after an */
Xlpoint estocurlin; /* error */
Xunsigned elinnumb; /* ditto */
Xchar *epoint; /* ditto */
Xint ecode; /* error code */
Xlpoint errortrap; /* error trap pointer */
Xlpoint saveertrap; /* error trap save location - during trap */
Xlpoint datastolin; /* pointer to start of current data line */
Xchar *datapoint; /* pointer into current data line */
Xint evallock; /* lock to stop recursive eval function */
Xunsigned autostart=10; /* values for auto command */
Xunsigned autoincr=10;
Xint ter_width; /* set from the terms system call */
X
Xlpoint constolin; /* values for 'cont' */
Xunsigned concurlin;
Xlpoint conerp;
Xchar *conpoint;
Xchar contelse;
Xchar contpos;
Xchar cancont;
Xchar noedit; /* set if noediting is to be done */
X
Xint pipes[2]; /* pipe structure for chain */
X
Xlong overfl; /* value of overflowed integers, converting to real */
X
Xvalue res; /* global variable for maths function */
X
Xdouble pivalue= 3.14159265358979323846; /* value of pi */
X#ifndef SOFTFP
Xdouble MAXint= 32767; /* for cvt */
Xdouble MINint= -32768;
X#endif
X
X#ifdef V7
Xjmp_buf rcall;
X#endif
X#ifdef BSD42
Xjmp_buf ecall; /* for use of cntrl-c in edit */
Xchar ecalling;
X#endif
X /* one edit mode , one for normal mode */
Xint nm; /* name of variable being accessed */
X
X#ifdef LNAMES
Xchar nam[MAXNAME]; /* local array for long names */
Xstruct entry *hshtab[HSHTABSIZ]; /* hash table pointers */
Xint varshash[HSHTABSIZ]; /* hashing for variables */
Xint chained; /* force full search only after a chain() */
X#endif
X
Xchar gblock[256]; /* global place for string functions */
Xint gcursiz; /* size of string in gblock[] */
X
X/*
X * definition of the command , function and string function 'jump'
X * tables.
X */
X
X/* maths functions that do not want an argument */
X
Xint (*functs[])()= {
X rnd,ffn, pii, erlin, erval, tim,
X };
X
X/* other maths functions */
X
Xint (*functb[])()={
X sgn, len, abs, val, ascval, instr, eofl, fposn, sqrtf, logf, expf,
X evalu,intf,peekf,sinf,cosf,atanf,mkint,mkdouble, ssystem,
X };
X
X/* string function , N.B. date$ is not here. */
X
Xint (*strngcommand[])()= {
X midst, rightst, leftst, strng, estrng, chrstr, nstrng, space, getstf,
X mkistr,mkdstr,
X };
X
X/* commands */
X
Xint (*commandf[])()= {
X endd,runn,gotos,rem,list,lets,print,stop,delete,editl,input,clearl,
X save,old,neww,shell,resume,iff,random,dimensio,forr,next,gosub,retn,
X onn,doerror,print,rem,dauto,readd,dodata,cls,restore,base,fopen,
X fclosef,merge,quit,quit,quit,chain,deffunc,cont,poke,linput,rept,
X untilf,whilef,wendf,fseek,renumb,loadd,dump,0,0,0,0,lhmidst,
X };
X
X/* table of error messages */
X
Xchar *ermesg[]= {
X "syntax error",
X "variable required",
X "out of string space",
X "assignment '=' required",
X "line number required",
X "undefined line number",
X "line number overflow",
X "illegal command",
X "string overflow",
X "illegal string size",
X "illegal function",
X "illegal core size",
X "illegal edit",
X "cannot creat file",
X "cannot open file",
X "dimension error",
X "subscript error",
X "next without for",
X "undefined array",
X "redimension error",
X "gosub / return error",
X "illegal error code",
X "bad load",
X "out of core",
X "zero divisor error",
X "bad data",
X "out of data",
X "bad base",
X "bad file descriptor",
X "unexpected eof",
X "out of files",
X "line length overflow",
X "argument error",
X "floating point overflow",
X "integer overflow",
X "bad number",
X "negative square root",
X "negative or zero log",
X "overflow in exp",
X "overflow in power",
X "negative power",
X "no space for chaining",
X "mutually recursive eval",
X "expression too complex",
X "illegal redefinition",
X "undefined user function",
X "can't continue",
X "until without repeat",
X "wend without while",
X "no wend statement found",
X "illegal loop nesting",
X };
X
X/* tokenising table */
X
Xstruct tabl table[]={
X "end",0200, /* commands 0200 - 0300 */
X "run",0201,
X "goto",0202,
X "rem",0203,
X "list",0204,
X "let",0205,
X "print",0206,
X "stop",0207,
X "delete",0210,
X "edit",0211,
X "input",0212,
X "clear",0213,
X "save",0214,
X "old",0215,
X "new",0216,
X "shell",0217,
X "resume",0220,
X "if",0221,
X "random",0222,
X "dim",0223,
X "for",0224,
X "next",0225,
X "gosub",0226,
X "return",0227,
X "on",0230,
X "error",0231,
X "?",0232,
X "'",0233,
X "auto",0234,
X "read",0235,
X "data",0236,
X "cls",0237,
X "restore",0240,
X "base",0241,
X "open",0242,
X "close",0243,
X "merge",0244,
X "quit",0245,
X "bye",0246,
X "exit",0247,
X "chain",0250,
X "def",0251,
X "cont",0252,
X "poke",0253,
X "linput",0254,
X "repeat",0255,
X "until",0256,
X "while",0257,
X "wend",0260,
X "seek",0261,
X#ifdef RENUMB
X "renumber",0262,
X#endif
X "load",0263,
X "dump",0264,
X "mid$",0271, /* string functions 0271 - 0310 */
X "right$",0272,
X "left$",0273,
X "string$",0274,
X "ermsg$",0275,
X "chr$",0276,
X "str$",0277,
X "space$",0300,
X "get$",0301,
X#ifdef _BLOCKED
X "mkis$",0302,
X "mkds$",0303,
X#endif
X "date$",0310, /* date must be last string funct */
X "sgn",0311, /* maths functions 0311 - 0350 */
X "len",0312,
X "abs",0313,
X "val",0314,
X "asc",0315,
X "instr",0316,
X "eof",0317,
X "posn",0320,
X "sqrt",0321,
X "log",0322,
X "exp",0323,
X "eval",0324,
X "int",0325,
X "peek",0326,
X "sin",0327,
X "cos",0330,
X "atan",0331,
X#ifdef _BLOCKED
X "mksi",0332,
X "mksd",0333,
X#endif
X "system", 0334,
X "rnd",0343,
X "fn",0344,
X "pi",0345,
X "erl",0346,
X "err",0347,
X "tim",0350,
X "else",0351, /* seperators and others 0351 - 0377 */
X "then",0352,
X "tab",0353,
X "step",0354,
X "to",0355,
X "and",0356,
X "or",0357,
X "xor",0360,
X "mod",0361,
X "<=",0362,
X "<>",0363,
X ">=",0364,
X "as",0365,
X "output",0366,
X "append",0367,
X "not",0370,
X "terminal",0371,
X 0,0
X };
X
X#else
X
X/* definition of variables for other source files */
X
Xextern int baseval;
Xextern char nl[];
Xextern char line[];
Xextern char nline[];
Xextern unsigned linenumber;
Xextern memp fendcore;
X#ifndef MPORTABLE
Xextern memp estring,edefns,estarr,earray,vend,bstk,vvend;
X#else
Xextern memp _space_[];
X#endif
Xextern memp filestart;
Xextern memp ecore,eostring,estdt;
Xextern int cursor;
Xextern unsigned shash;
Xextern int mcore(),seger(),trap();
Xextern lpoint stocurlin;
Xextern unsigned curline;
Xextern int readfile;
Xextern char *point;
Xextern char *savepoint;
Xextern char elsecount;
Xextern char vartype;
Xextern char runmode;
Xextern char ertrap;
Xextern char intrap;
Xextern char trapped;
Xextern char inserted;
Xextern char eelsecount;
Xextern lpoint estocurlin;
Xextern unsigned elinnumb;
Xextern char *epoint;
Xextern int ecode;
Xextern lpoint errortrap;
Xextern lpoint saveertrap;
Xextern lpoint datastolin;
Xextern char *datapoint;
Xextern int evallock;
Xextern unsigned autostart;
Xextern unsigned autoincr;
Xextern int ter_width;
Xextern lpoint constolin;
Xextern unsigned concurlin;
Xextern lpoint conerp;
Xextern char *conpoint;
Xextern char contelse;
Xextern char contpos;
Xextern char cancont;
Xextern char noedit;
X
Xextern int pipes[];
X
Xextern long overfl;
Xextern value res;
X
Xextern double pivalue;
Xextern double MAXint,MINint;
X#ifdef V7
Xextern jmp_buf rcall;
X#endif
X
X#ifdef BSD42
Xextern jmp_buf ecall;
Xextern char ecalling;
X#endif
X
Xextern int nm;
X
X#ifdef LNAMES
Xextern struct entry *hshtab[];
Xextern char nam[];
Xextern int varshash[];
Xextern int chained;
X#ifndef MPORTABLE
Xextern memp enames;
X#endif
X#endif
X
Xextern char gblock[];
Xextern int gcursiz;
X
Xextern (*functs[])();
Xextern (*functb[])();
Xextern (*strngcommand[])();
Xextern (*commandf[])();
Xextern char *ermesg[];
Xextern struct tabl table[];
X
X#endif
End of bas.h
chmod u=rw-,g=r,o=r bas.h
echo x - bas1.c 1>&2
sed 's/^X//' > bas1.c << 'End of bas1.c'
X/*
X * BASIC by Phil Cockcroft
X */
X/*
X * This file contains the main routines of the interpreter.
X */
X
X
X/*
X * the core is arranged as follows: -
X * ------------------------------------------------------------------- - - -
X * | file | text | string | user | array | simple | for/ | unused
X * | buffers | of | space | def | space | variables | gosub | memory
X * | | program | | fns | | | stack |
X * ------------------------------------------------------------------- - - -
X * ^ ^ ^ ^ ^ ^ ^ ^
X * filestart fendcore ecore estring edefns earray vend vvend
X * ^eostring ^estarr
X */
X
X#define PART1
X#include "bas.h"
X#undef PART1
X
X/*
X * The main program , it sets up all the files, signals,terminal
X * and pointers and prints the start up message.
X * It then calls setexit().
X * IMPORTANT NOTE:-
X * setexit() sets up a point of return for a function
X * It saves the local environment of the calling routine
X * and uses that environment for further use.
X * The function reset() uses the information saved in
X * setexit() to perform a non-local goto , e.g. poping the stack
X * until it looks as though it is a return from setexit()
X * The program then continues as if it has just executed setexit()
X * This facility is used all over the program as a way of getting
X * out of functions and returning to command mode.
X * The one exception to this is during error trapping , The error
X * routine must pop the stack so that there is not a recursive call
X * on execute() but if it does then it looks like we are back in
X * command mode. The flag ertrap is used to signal that we want to
X * go straight on to execute() the error trapping code. The pointers
X * must be set up before the execution of the reset() , (see error ).
X * N.B. reset() NEVER returns , so error() NEVER returns.
X */
X
Xmain(argc,argv)
Xchar **argv;
X{
X register i;
X catchsignal();
X startfp(); /* start up the floating point hardware */
X setupfiles(argc,argv);
X setupterm(); /* set up files after processing files */
X ecore = fendcore+sizeof(xlinnumb);
X ( (lpoint) fendcore )->linnumb=0;
X clear(DEFAULTSTRING);
X prints("Phil's Basic version v1.8\n");
X setexit();
X if(ertrap)
X goto execut;
X docont();
X runmode=0; /* say we are in immeadiate mode */
X if(cursor) /* put cursor on a blank line */
X prints(nl);
X prints("Ready\n");
X do{
X do{
X trapped=0;
X *line ='>';
X edit(1,1,1);
X }while( trapped || ( !(i=compile(1)) && !linenumber ));
X if(linenumber)
X insert(i);
X }while(linenumber);
X if(inserted){
X inserted=0;
X clear(DEFAULTSTRING);
X closeall();
X }
X vvend=bstk; /* reset the gosub stack */
X errortrap=0; /* disable error traps */
X intrap=0; /* say we are not in the error trap */
X trapped=0; /* say we haven't got a cntrl-c */
X cursor=0; /* cursor is at start of line */
X elsecount=0; /* disallow elses as terminators */
X curline=0; /* current line is zero */
X point=nline; /* start executing at start of input line */
X stocurlin=0; /* start of current line is null- see 'next' */
Xexecut: execute(); /* execute the line */
X return(-1); /* see note below */
X}
X
X/*
X * Execute will return by calling reset and so if execute returns then
X * there is a catastrophic error and we should exit with -1 or something
X */
X
X/*
X * compile converts the input line (in line[]) into tokenised
X * form for execution(in nline). If the line starts with a linenumber
X * then that is converted to binary and is stored in 'linenumber' N.B.
X * not curline (see evalu() ). A linenumber of zero is assumed to
X * be non existant and so the line is executed immeadiately.
X * The parameter to compile() is an index into line that is to be
X * ignored, e.g. the prompt.
X */
X
Xcompile(fl)
Xint fl;
X{
X register char *p,*q;
X register struct tabl *l;
X unsigned lin=0;
X char charac;
X char *eql(),*k;
X p= &line[fl];
X q=nline;
X while(*p++ ==' ');
X p--;
X while(isnumber(*p)){ /* get line number */
X if(lin >= 6553)
X error(7);
X lin = lin*10 + (*p++ -'0');
X }
X while(*p==' ')
X *q++ = *p++;
X if(!*p){
X linenumber =lin;
X return(0); /* no characters on the line */
X }
X while(*p){
X if(*p=='"' || *p=='`'){ /* quoted strings */
X charac= *p;
X *q++ = *p++;
X while(*p && *p != charac)
X *q++ = *p++;
X if(*p)
X *q++= *p++;
X continue;
X }
X if(*p < '<' && *p != '\''){ /* ignore all characters */
X *q++ = *p++; /* that couldn't be used */
X continue; /* in reserved words */
X }
X for(l=table ; l->string ; l++) /* search the table */
X if(*p != *(l->string) ) /* for the right entry */
X continue;
X else if(k = eql(p,l->string)){ /* if found then */
X#ifdef LKEYWORDS
X if( isletter(*p) ){
X if(p!= &line[fl] && isletter(*(p-1)) )
X continue;
X if( isletter(*k) && l->chval != FN)
X continue;
X }
X#endif
X *q++ = l->chval; /* replace by a token */
X p = k;
X if(l->chval== REM || l->chval== QUOTE ||
X l->chval == DATA)
X while(*p)
X *q++ = *p++;
X goto more; /* dont compile comments */
X } /* or data */
X *q++ = *p++;
X more: ;
X }
X *q='\0';
X linenumber=lin;
X return(q-nline); /* return length of line */
X}
X
X/*
X * eql() returns true if the strings are the same .
X * this routine is only called if the first letters are the same.
X * hence the increment of the pointers , we don't need to compare
X * the characters they point to.
X * To increase speed this routine could be put into machine code
X * the overheads on the function call and return are excessive
X * for what it accomplishes. (it fails most of the time , and
X * it can take a long time to load a large program ).
X */
X
Xchar *
Xeql(p,q)
Xregister char *p,*q;
X{
X p++,q++;
X while(*q)
X if(*p++ != *q++){
X#ifdef SCOMMS
X if(*(p-1) == '.')
X return(p);
X#endif
X return(0);
X }
X return(p);
X}
X
X/*
X * Puts a line in the table of lines then sets a flag (inserted) so that
X * the variables are cleared , since it is very likely to have moved
X * 'ecore' and so the variables will all be corrupted. The clearing
X * of the variables is not done in this routine since it is only needed
X * to clear the variables once and that is best accomplished in main
X * just before it executes the immeadiate mode line.
X * If the line existed before this routine is called then it is deleted
X * and then space is made available for the new line, which is then
X * inserted.
X * The structure of a line in memory has the following structure:-
X * struct olin{
X * unsigned linnumb;
X * unsigned llen;
X * char lin[1];
X * }
X * The linenumber of the line is stored in linnumb , If this is zero
X * then this is the end of the program (all searches of the line table
X * terminate if it finds the linenumber is zero.
X * The variable 'llen' is used to store the length of the line (in
X * characters including the above structure and any padding needed to
X * make the line an even length.
X * To search through the table of lines then:-
X * start at 'fendcore'
X * IF linnumb is zero THEN terminate search
X * ELSE IF linnumb is the required line THEN
X * found line , terminate
X * ELSE
X * goto next line ( add llen to the current pointer )
X * repeat loop.
X * The line is in fact stored in lin[] , To the C compiler this
X * is a one character array but since the lines are more than one
X * character long (usually) it is fooled into using it as a variable
X * length array ( impossible in 'pure' C ).
X * The pointers used by the program storage routines are:-
X * fendcore = start of text storage segment
X * ecore = end of text storage
X * = start of data segment (string space ).
X * strings are stored after the text but before the numeric variables
X * only 512 bytes are allocated at the start of the program for strings
X * but clear can be called to get more core for the strings.
X */
X
Xinsert(lsize)
Xregister int lsize;
X{
X register lpoint p;
X register unsigned l;
X inserted=1; /* say we want the variables cleared */
X l= linenumber;
X for(p= (lpoint) fendcore ; p->linnumb; p=(lpoint)((memp)p+lenv(p)))
X if(p->linnumb >= l ){
X if(p->linnumb != l )
X break;
X l=lenv(p); /* delete the old line */
X bmov( (short *)p, (int)l);
X ecore -= l;
X break;
X }
X if(!lsize) /* line has no length */
X return;
X lsize += sizeof(struct olin);
X#ifdef ALIGN4
X lsize = (lsize + 03) & ~03;
X#else
X if(lsize&01)
X lsize++; /* make length of line even */
X#endif
X mtest(ecore+lsize); /* get the core for it */
X ecore += lsize;
X bmovu( (short *)p,lsize); /* make space for the line */
X strcpy(nline,p->lin); /* move the line into the space */
X p->linnumb=linenumber; /* give it a linenumber */
X p->llen=lsize; /* give it its offset */
X}
X
X/* This routine will move the core image down so deleteing a line */
X
Xbmov(a,b)
Xregister short *a;
Xint b;
X{
X register short *c,*d;
X c= (short *)ecore;
X d= (short *)((char *)a + b );
X do{
X *a++ = *d++;
X }while(d<c);
X}
X
X/* This will move the text image up so that a new line can be inserted */
X
Xbmovu(a,b)
Xregister short *a;
Xint b;
X{
X register short *c,*d;
X c= (short *) ecore;
X d= (short *) (ecore-b);
X do{
X *--c = *--d;
X }while(a<d);
X}
X
X/*
X * The interpreter needs three variables to control the flow of the
X * the program. These are:-
X * stocurlin : This is the pointer to the start of the current
X * line it is used to index the next line.
X * If the program is in immeadiate mode then
X * this variable is NULL (very important for 'next')
X * point: This points to the current location that
X * we are executing.
X * curline: The current line number ( zero in immeadiate mode)
X * this is not needed for program exection ,
X * but is used in error etc. It could be made faster
X * if this variable is not used....
X */
X
X/*
X * The main loop of the execution of a program.
X * It does the following:-
X * FOR(ever){
X * save point so that resume will go to the right place
X * IF cntrl-c THEN stop
X * IF NOT a reserved word THEN do_assignment
X * ELSE IF legal command THEN execute_command
X * IF return is NORMAL THEN
X * BEGIN
X * IF terminator is ':' THEN continue
X * ELSE IF terminator is '\0' THEN
X * goto next line ; continue
X * ELSE IF terminator is 'ELSE' AND
X * 'ELSES' are enabled THEN
X * goto next line ; continue
X * END
X * ELSE IF return is < NORMAL THEN continue
X * ( used by goto etc. ).
X * ELSE IF return is > NORMAL THEN
X * ignore_rest_of_line ; goto next line ; continue
X * }
X * All commands return a value ( if they return ). This value is NORMAL
X * if the command is standard and does not change the flow of the program.
X * If the value is greater than zero then the command wants to miss the
X * rest of the line ( comments and data ).
X * If the value is less than zero then the program flow has changed
X * and so we should go back and try to execute the new command ( we are
X * now at the start of a command ).
X */
X
Xexecute()
X{
X register int i,c;
X register lpoint p;
X
X ertrap=0; /* stop recursive error trapping */
Xagain:
X savepoint=point;
X if(trapped)
X dobreak();
X if(!((c=getch())&0200)){
X point--;
X assign();
X goto retn;
X }
X if(c>=MAXCOMMAND)
X error(8);
X if((i=(*commandf[c&0177])())==NORMAL){ /* execute the command */
Xretn: if((c=getch())==':')
X goto again;
X else if(!c){
Xelseret: if(!runmode) /* end of immeadiate line */
X reset();
X p = stocurlin;
X p = (lpoint)((memp)p + lenv(p)); /* goto next line */
X stocurlin=p;
X point=p->lin;
X if(!(curline=p->linnumb)) /* end of program */
X reset();
X elsecount=0; /* disable `else`s */
X goto again;
X }
X else if(c==ELSE && elsecount) /* `else` is a terminator */
X goto elseret;
X error(SYNTAX);
X }
X if(i < NORMAL)
X goto again; /* changed execution position */
X else
X goto elseret; /* ignore rest of line */
X}
X
X/*
X * The error routine , this is called whenever there is any error
X * it does some tidying up of file descriptors and sets the error line
X * number and the error code. If there is error trapping ( errortrap is
X * non-zero and in runmode ), then save the old pointers and set up the
X * new pointers for the error trap routine.
X * Otherwise print out the error message and the current line if in
X * runmode.
X * Finally call reset() ( which DOES NOT return ) to pop
X * the stack and to return to the main routine.
X */
X
Xerror(i)
Xint i; /* error code */
X{
X register lpoint p;
X if(readfile){ /* close file descriptor */
X close(readfile); /* from loading a file */
X readfile=0;
X }
X if(pipes[0]){ /* close the pipe (from chain ) */
X close(pipes[0]); /* if an error while chaining */
X pipes[0]=0;
X }
X evallock=0; /* stop the recursive eval message */
X ecode=i; /* set up the error code */
X if(runmode)
X elinnumb=curline; /* set up the error line number */
X else
X elinnumb=0;
X if(runmode && errortrap && !inserted ){ /* we have error trapping */
X estocurlin=stocurlin; /* save the various pointers */
X epoint=savepoint;
X eelsecount=elsecount;
X p=errortrap;
X stocurlin=p; /* set up to execute code */
X point=p->lin;
X curline=p->linnumb;
X saveertrap=p; /* save errortrap pointer */
X errortrap=0; /* disable further error traps */
X intrap=1; /* say we are trapped */
X ertrap=1; /* we want to go to execute */
X }
X else { /* no error trapping */
X if(cursor){
X prints(nl);
X cursor=0;
X }
X prints(ermesg[i-1]); /* error message */
X if(runmode){
X prints(" on line ");
X prints(printlin(curline));
X }
X prints(nl);
X }
X reset(); /* no return - goes to main */
X}
X
X/*
X * This is executed by the ON ERROR construct it checks to see
X * that we are not executing an error trap then set up the error
X * trap pointer.
X */
X
Xerrtrap()
X{
X register lpoint p;
X p=getline();
X check();
X if(intrap)
X error(8);
X errortrap=p;
X}
X
X/*
X * The 'resume' command , checks to see that we are actually
X * executing an error trap. If there is an optional linenumber then
X * we resume from there else we resume from where the error was.
X */
X
Xresume()
X{
X register lpoint p;
X register unsigned i;
X if(!intrap)
X error(8);
X i= getlin();
X check();
X if(i!= (unsigned)(-1) ){
X for(p=(lpoint)fendcore;p->linnumb;p=(lpoint)((memp)p+lenv(p)))
X if(p->linnumb==i)
X goto got;
X error(6); /* undefined line */
Xgot: stocurlin= p; /* resume at that line */
X curline= p->linnumb;
X point= p->lin;
X elsecount=0;
X }
X else {
X stocurlin=estocurlin; /* resume where we left off */
X curline=elinnumb;
X point=epoint;
X elsecount=eelsecount;
X }
X errortrap=saveertrap; /* restore error trapping */
X intrap=0; /* get out of the trap */
X return(-1); /* return to re-execute */
X}
X
X/*
X * The 'error' command , this calls the error routine ( used in testing
X * an error trapping routine.
X */
X
Xdoerror()
X{
X register i;
X i=evalint();
X check();
X if(i<1 || i >MAXERR)
X error(22); /* illegal error code */
X error(i);
X}
X
X/*
X * This routine is used to clear space for strings and to reset all
X * other pointers so that it effectively clears the variables.
X */
X
Xclear(stringsize)
Xint stringsize; /* size of string space */
X{
X#ifdef LNAMES
X register struct entry **p;
X register int *ip;
X
X for(p = hshtab ; p < &hshtab[HSHTABSIZ];) /* clear the hash table*/
X *p++ = 0;
X for(ip = varshash ; ip < &varshash[HSHTABSIZ]; )
X *ip++ = -1;
X#endif
X#ifdef ALIGN4
X estring= &ecore[stringsize& ~03]; /* allocate string space */
X#else
X estring= &ecore[stringsize& ~01]; /* allocate string space */
X#endif
X mtest(estring); /* get the core */
X shash=1; /* string array "counter" */
X datapoint=0; /* reset the pointer to data */
X contpos=0;
X#ifdef LNAMES
X chained = 0; /* reset chained flag */
X estdt=enames=edefns=earray=vend=bstk=vvend=estarr=estring;
X#else
X estdt=edefns=earray=vend=bstk=vvend=estarr=estring;
X#endif
X /* reset variable pointers */
X eostring=ecore; /* string pointer */
X srand(0); /* reset the random number */
X} /* generator */
X
X/*
X * mtest() is used to set the amount of core for the current program
X * it uses brk() to ask the system for more core.
X * The core is allocated in 1K chunks, this is so that the program does
X * not spend most of is time asking the system for more core and at the
X * same time does not hog more core than is neccasary ( be friendly to
X * the system ).
X * Any test that is less than 'ecore' is though of as an error and
X * so is any test greater than the size that seven memory management
X * registers can handle.
X * If there is this error then a test is done to see if 'ecore' can
X * be accomodated. If so then that size is allocated and error() is called
X * otherwise print a message and exit the interpreter.
X * If the value of the call is less than 'ecore' we have a problem
X * with the interpreter and we should cry for help. (It doesn't ).
X */
X
Xmtest(l)
Xmemp l;
X{
X register memp m;
X static memp maxmem; /* pointer to top of memory */
X
X#ifdef ALIGN4
X if( (int)l & 03){
X prints("Illegal allignment\n");
X quit();
X }
X#endif
X m = (memp)(((int)l+MEMINC)&~MEMINC); /* round the size up */
X if(m==maxmem) /* if allocated then return */
X return;
X if(m < ecore || m > MAXMEM || brk(m) == -1){ /* problems*/
X m= (memp) (((int)ecore +DEFAULTSTRING+MEMINC )&~MEMINC);
X if(m <= MAXMEM && brk(m)!= -1){
X maxmem= m; /* oh, safe */
X clear(DEFAULTSTRING); /* zap all pointers */
X error(24); /* call error */
X }
X prints("out of core\n"); /* print message */
X quit(); /* exit flushing buffers */
X }
X maxmem=m; /* set new limit */
X}
X
X/*
X * This routine is called to test to see if there is enough space
X * for an array. The result is true if there is no space left.
X */
X
Xnospace(l)
Xlong l;
X{
X#ifndef pdp11
X if(l< 0 || vvend+l >= MAXMEM)
X#else
X if(l< 0 || l >65535L || (long)vvend+l >= 0160000L)
X#endif
X return(1);
X return(0); /* we have space */
X}
X
X/*
X * This routine is called by the routines that define variables
X * to increase the amount of space that is allocated between the
X * two end pointers of that 'type'. It uses the fact that all the
X * variable pointers are in a certain order (see bas.h ). It
X * increments the relevent pointers and then moves up the rest of
X * the data to a new position. It also clears the area that it
X * has just allocated and then returns a pointer to the space.
X */
X
Xmemp xpand(start,size)
Xregister memp *start;
Xint size;
X{
X register short *p,*q;
X short *bottom;
X bottom = (short *) (*start);
X p= (short *)vvend;
X do{
X *start++ += size;
X }while( start <= &vvend);
X mtest(vvend);
X start= (memp *)bottom;
X q= (short *)vvend;
X do{
X *--q = *--p;
X }while(p > (short *)start);
X do{
X *--q=0;
X }while(q > (short *)start);
X return( (memp) start);
X}
X
X/*
X * This routine tries to set up the system to catch all the signals that
X * can be produced. (except kill ). and do something sensible if it
X * gets one. ( There is no way of producing a core image through the
X * sending of signals).
X */
X
X#ifdef V6
X#define _exit exit
X#endif
X
Xcatchsignal()
X{
X extern _exit(),quit1(),catchfp();
X#ifdef SIGTSTP
X extern onstop();
X#endif
X register int i;
X static int (*traps[NSIG])()={
X quit, /* hang up */
X trap, /* cntrl-c */
X quit1, /* cntrl-\ */
X _exit,
X _exit,
X _exit,
X _exit,
X catchfp, /* fp exception */
X 0, /* kill */
X seger, /* seg err */
X mcore, /* bus err */
X 0,
X _exit,
X _exit,
X _exit,
X _exit,
X _exit,
X };
X
X for(i=1;i<NSIG;i++)
X signal(i,traps[i-1]);
X#ifdef SIGTSTP
X signal(SIGTSTP,onstop); /* the stop signal */
X#endif
X}
X
X/*
X * this routine deals with floating exceptions via fpfunc
X * this is a function pointer set up in fpstart so that trapping
X * can be done for floating point exceptions.
X */
X
Xcatchfp()
X{
X extern (*fpfunc)();
X
X signal(SIGFPE,catchfp); /* restart catching */
X if(fpfunc== 0) /* this is set up in fpstart() */
X _exit(1);
X (*fpfunc)();
X}
X
X/*
X * we have a segmentation violation and so should print the message and
X * exit. Either a kill() from another process or an interpreter bug.
X */
X
Xseger()
X{
X prints("segmentation violation\n");
X _exit(-1);
X}
X
X/*
X * This does the same for bus errors as seger() does for segmentation
X * violations. The interpreter is pretty nieve about the execution
X * of complex expressions and should really check the stack every time,
X * to see if there is space left. This is an easy error to fix, but
X * it was not though worthwhile at the moment. If it runs out of stack
X * space then there is a vain attempt to call mcore() that fails and
X * so which produces another bus error and a core image.
X */
X
Xmcore()
X{
X prints("bus error\n");
X _exit(-1);
X}
X
X/*
X * Called by the cntrl-c signal (number 2 ). It sets 'trapped' to
X * signify that there has been a cntrl-c and then re-enables the trap.
X * It also bleeps at you.
X */
X
Xtrap()
X{
X signal(SIGINT, SIG_IGN);/* ignore signal for the bleep */
X write(1, "\07", 1); /* bleep */
X signal(SIGINT, trap); /* re-enable the trap */
X trapped=1; /* say we have had a cntrl-c */
X#ifdef BSD42
X if(ecalling){
X ecalling = 0;
X longjmp(ecall, 1);
X }
X#endif
X}
X
X/*
X * called by cntrl-\ trap , It prints the message and then exits
X * via quit() so flushing the buffers, and getting the terminal back
X * in a sensible mode.
X */
X
Xquit1()
X{
X signal(SIGQUIT,SIG_IGN);/* ignore any more */
X if(cursor){ /* put cursor on a new line */
X prints(nl);
X cursor=0;
X }
X prints("quit\n\r"); /* print the message */
X quit(); /* exit */
X}
X
X/*
X * resets the terminal , flushes all files then exits
X * this is the standard route exit from the interpreter. The seger()
X * and mcore() traps should not go through these traps since it could
X * be the access to the files that is causing the error and so this
X * would produce a core image.
X * From this it may be gleened that I don't like core images.
X */
X
Xquit()
X{
X flushall(); /* flush the files */
X rset_term(1);
X if(cursor)
X prints(nl);
X exit(0); /* goodbye */
X}
X
Xdocont()
X{
X if(runmode){
X contpos=0;
X if(cancont){
X bstk= vvend;
X contpos=cancont;
X }
X else
X bstk= vend;
X }
X cancont=0;
X}
X
X#ifdef SIGTSTP
X/*
X * support added for job control
X */
Xonstop()
X{
X flushall(); /* flush the files */
X if(cursor){
X prints(nl);
X cursor = 0;
X }
X#ifdef BSD42
X sigsetmask(0); /* Urgh !!!!!! */
X#endif
X signal(SIGTSTP, SIG_DFL);
X kill(0,SIGTSTP);
X /* The PC stops here */
X signal(SIGTSTP,onstop);
X}
X#endif
End of bas1.c
chmod u=rw-,g=r,o=r bas1.c
