/*
* BASIC by Phil Cockcroft
*/
#include "bas.h"
/*
* Stringeval() will evaluate a string expression of any
* form. '+' is used as the concatenation operator
*
* gblock and gcursiz are used as global variables by the
* string routines. Gblock contains the resultant string while
* gcursiz holds the length of the resultant string ( even if not
* put in gblock ).
* For routines that need more than one result e.g. mid$ instr$
* then one result at least is put on the stack while the other
* ( possibly ) is put in gblock.
*/
/*
* The parameter to stringeval() is a pointer to where the
* result will be put.
*/
#ifdef __STDC__
static STR midst(void);
static STR hocvtstr(int);
#else
static STR midst();
static STR hocvtstr();
#endif
static STR str_free;
static int nstr_free;
/*
* maximum number of strings that should be left in the free
* list
*/
#define MAX_FREE_STRS 100
STR
stringeval()
{
register STR st;
register STR fstr;
register int c;
stringp l;
CHAR charac;
st = ALLOC_STR( (ival)0);
for(;;){
c=getch();
if(c & SPECIAL){ /* a string function */
if(c == SFUNCN)
fstr = (*strngncommand[*point++ & 0177])();
else if(c == SFUNCA){
c = (int)*point++ & 0177;
if(*point++!='(')
error(SYNTAX);
fstr = (*strngcommand[c])();
if(getch()!=')')
error(SYNTAX);
}
else if(c == MIDSTR){
if(*point++!='(')
error(SYNTAX);
fstr = midst();
if(getch()!=')')
error(SYNTAX);
}
else if(c == FN){
fstr = ALLOC_STR( (ival)0);
ffn( (struct entry *)0, fstr);
}
else
error(11);
}
else if(c=='"' || c=='`'){ /* a quoted string */
fstr = ALLOC_STR( (ival)0);
fstr->strval = point;
fstr->strlen = 0;
charac= (CHAR)c;
while(*point && *point!= charac){
fstr->strlen++;
point++;
}
if(*point)
point++;
}
else if(isletter(c)){ /* a string variable */
#if 0
CHAR *sp = --point;
l= (stringp)getname(ISFUNC);
if(l == 0){
fstr = ALLOC_STR( (ival)0);
point = sp;
ffn( (struct entry *)0, fstr);
}
else {
#else
--point;
l= (stringp)getname(0);
#endif
if(vartype!= SVAL)
error(SYNTAX);
fstr = ALLOC_STR( (ival)0);
fstr->strval = l->str;
fstr->strlen = l->len;
#if 0
}
#endif
}
else
error(SYNTAX);
/* all routines return to here with the string pointed to by p */
if((c = getch()) == '['){
ival l1, l2;
l1 = evalint();
if(l1 < 1 || l1 > MAX_STR)
error(9);
l1--;
if( (c = getch()) == ','){
l2 = evalint();
if(l2 < 0 || l2 > MAX_STR)
error(9);
c = getch();
}
else
l2 = MAX_STR;
if(c != ']')
error(SYNTAX);
if(l1 > fstr->strlen)
l1 = fstr->strlen;
if(l2 > fstr->strlen - l1)
l2 = fstr->strlen - l1;
fstr->strval += l1;
fstr->strlen = l2;
c = getch();
}
if(fstr->strlen + st->strlen > MAX_STR)
error(9);
if(st->strlen == 0)
COPY_OVER_STR(st, fstr);
else if(fstr->strlen != 0){
RESERVE_SPACE(st, (ival) (fstr->strlen + st->strlen));
VOID strmov(st->strval+st->strlen, fstr->strval, fstr->strlen);
st->strlen += fstr->strlen;
}
FREE_STR(fstr);
if(c != '+'){
point--;
if(c != '"' && c != '`' && !isletter(c))
break;
}
}
/*
* check to see if strval is in the allocated buffer
* If it is not, then put it in
*/
RESERVE_SPACE(st, (ival)st->strlen);
return(st);
}
/*
* stringassign() will put the sting in gblock into the string
* pointed to by p.
* It will call the garbage collection routine as neccasary.
*/
void
stringassign(p, ep, st, nodel)
register stringp p;
struct entry *ep;
STR st;
int nodel;
{
if(p->str){
if(ep->flags & IS_FSTRING)
error(3); /* illegal string function */
mfree( (MEMP)p->str);
p->str = 0;
}
if((p->len = st->strlen) != 0){
if(st->allocstr == st->locbuf){
p->str = (CHAR *)mmalloc(st->strlen);
VOID strmov(p->str, st->allocstr, st->strlen);
}
else
p->str = st->allocstr;
st->allocstr = 0;
}
if(!nodel)
FREE_STR(st);
}
/*
* The following routines implement string functions they are all quite
* straight forward in operation.
*/
STR
datef()
{
register STR st;
register int c, i, n;
register CHAR *p, *q;
struct tm *tmp;
int tf;
static int mplies[] = { 0, 1, 10, 100, 1000, 10000 };
#ifndef __STDC__
char *ctime();
long m;
struct tm *localtime();
#else
time_t m;
#endif
VOID time(&m);
c = getch();
if(c == '('){
st = stringeval();
if(getch() != ')')
error(SYNTAX);
tmp = localtime(&m);
for(p = st->strval, i = st->strlen ; i ;){
c = lcase(*p);
for(q = p, n = 0 ; lcase(*q) == c && n < i; q++)
n++;
i -= n;
switch(c){
case 's':
tf = tmp->tm_sec;
break;
case 'h':
tf = tmp->tm_hour;
break;
case 'd':
tf = tmp->tm_mday;
break;
case 'm':
if(c == UC(*p))
tf = tmp->tm_min;
else
tf = tmp->tm_mon + 1;
break;
case 'y':
tf = tmp->tm_year;
if(n >= 4)
tf += 1900;
break;
default:
p += n;
continue;
}
/*
* n is never 0
*/
if(n > 4){
set_mem(p, n - 4, '0');
p += n-4;
n = 4;
}
tf %= mplies[n + 1];
while(n){
*p++ = '0' + (tf / mplies[n]);
tf %= mplies[n];
n--;
}
}
}
else {
point--;
st = ALLOC_STR( (ival)24);
VOID strmov(st->strval, (CHAR *)ctime(&m), st->strlen);
}
return(st);
}
STR
strng()
{
register CHAR *p;
itype m;
register ival cursiz=0;
register int siz;
STR st;
st = stringeval();
if(getch()!=',')
error(SYNTAX);
m=evalint();
if(m> MAX_STR || m < 0)
error(10);
if(!st->strlen || m <= 1){
if(!m)
st->strlen = 0;
return(st);
}
siz=(int)m;
cursiz = siz * st->strlen;
if((unsigned)cursiz > MAX_STR)
error(9);
RESERVE_SPACE(st, cursiz);
for(p = st->strval + st->strlen, siz-- ; siz ; siz--)
p = strmov(p, st->strval, st->strlen);
st->strlen = cursiz;
return(st);
}
/* left$ string function */
STR
leftst()
{
register itype l1;
register STR st;
st = stringeval();
if(getch()!=',')
error(SYNTAX);
l1=evalint();
if(l1<0 || l1 > MAX_STR)
error(10);
if(l1 < st->strlen)
st->strlen = l1;
return(st);
}
/* right$ string function */
STR
rightst()
{
register itype l1;
register STR st;
st = stringeval();
if(getch()!=',')
error(SYNTAX);
l1=evalint();
if(l1<0 || l1 > MAX_STR)
error(10);
if(l1 < st->strlen){
st->strval += st->strlen - l1;
st->strlen = l1;
}
return(st);
}
/*
* midst$ string function:-
* can have two or three parameters , if third
* parameter is missing then a value of cursiz
* is used.
*/
static STR
midst()
{
register STR st;
register itype l1,l2;
st = stringeval();
if(getch() != ',')
error(SYNTAX);
l1 = evalint() - 1;
if(getch() != ','){
point--;
l2 = MAX_STR;
}
else
l2 = evalint();
if(l1 < 0 || l2 < 0 || l1 > MAX_STR || l2 > MAX_STR)
error(10);
l2 += l1;
if(l2 > st->strlen)
l2 = st->strlen;
if(l1 > st->strlen)
l1 = st->strlen;
st->strval += l1;
st->strlen = l2 - l1;
return(st);
}
/* ermsg$ string routine , returns the specified error message */
STR
estrng()
{
register STR st;
register CHAR *q;
register itype l;
ival mlen;
l = evalint();
if(l < 1 || l > MAXERR)
error(22);
q = (CHAR *)ermesg[l-1];
mlen = slen(q);
st = ALLOC_STR( (ival)mlen);
st->strval = q;
return(st);
}
/* chr$ string function , returns character from the ascii value */
STR
chrstr()
{
register STR st;
register itype i;
i = evalint();
if(i < 0 || i > 255)
error(FUNCT);
st = ALLOC_STR( (ival)1);
*st->strval = (CHAR)i;
return(st);
}
/* str$ string routine , returns a string representation
* of the number given. There is NO leading space on positive
* numbers.
*/
STR
nstrng()
{
register STR st;
eval();
st = mgcvt();
if(*st->strval == ' '){
st->strval++;
st->strlen--;
}
return(st);
}
/* val() maths function , returns the value of a string. If
* no numeric value is used then a value of zero is returned.
*/
void
val()
{
register CHAR *p;
register minus=0;
STR st;
int ret;
st = stringeval();
NULL_TERMINATE(st);
p = st->strval;
while(*p == ' ')
p++;
if(*p == '-'){
p++;
minus++;
}
if(!ispnumber(p) && *p != '.' && *p != '&'){
FREE_STR(st);
if(minus)
error(36);
res.i=0;
vartype= IVAL;
return;
}
ret = getnumb(p, (CHAR **)0);
FREE_STR(st);
if(!ret)
error(36);
if(minus)
negate();
}
void
binval()
{
register itype iv = 0;
int minus = 0;
int max_digits = sizeof(itype) * 8;
register CHAR *p;
STR st;
st = stringeval();
NULL_TERMINATE(st);
for(p = st->strval ; *p == ' ' ; p++);
if(*p == '-'){
minus++;
p++;
}
while(*p){
if(*p != '0' && *p != '1')
error(36);
iv <<= 1;
iv += *p++ - '0';
if(!max_digits--)
error(36);
}
FREE_STR(st);
if(minus)
iv = -iv;
res.i = iv;
vartype = IVAL;
}
/* instr() maths function , returns the index of the first string
* in the second. Starting either from the first character or from
* the optional third parameter position.
*/
void
brinstr(rflag)
int rflag;
{
register CHAR *p,*q,*r;
itype i=0;
STR st1, st2;
ival cursiz;
itype pos = -1;
st1 = stringeval();
if(getch()!=',')
error(SYNTAX);
st2 = stringeval();
if(getch()==','){
i=evalint()-1;
if(i<0 || i>= MAX_STR)
error(10);
}
else
point--;
cursiz = st1->strlen - st2->strlen;
vartype= IVAL;
for(r = st1->strval + st2->strlen + i; i <= cursiz ; i++, r++){
p = st2->strval;
q = st1->strval + i;
while(q < r && *p == *q)
p++,q++;
if( q == r ){
pos = i;
if(!rflag)
break;
}
}
/*
* should be '&& pos != -1' but pos is -1 when it fails so it works
*/
res.i = pos + 1;
FREE_STR(st2);
FREE_STR(st1);
}
void
instr()
{
brinstr(0);
}
void
rinstr()
{
brinstr(1);
}
/* space$ string function returns a string of spaces the number
* of which is the argument to the function
*/
STR
space()
{
register itype i;
STR st;
i = evalint();
if(i < 0 || i > MAX_STR)
error(10);
st = ALLOC_STR( (ival)i);
if(i != 0)
set_mem(st->strval, i, ' ');
return(st);
}
/* mid$() when on the left of an assignment */
/* can have optional third argument */
/* a$ = "this is me"
* mid$(a$,2) = "hello" -> a$ = "thello"
* mid$(a$,2,5) = "hello" -> a$ = "thellos me"
*/
int
lhmidst()
{
register CHAR *p;
itype i1,i2;
ival cursiz,rhside;
stringp pat;
struct entry *ep;
STR st, nst;
ival totlen;
if(*point++ !='(')
error(SYNTAX);
pat= (stringp)getname(0);
if(vartype!= SVAL)
error(VARREQD);
ep = curentry;
if(getch()!=',')
error(SYNTAX);
i1=evalint()-1;
if(getch()!=','){
i2= MAX_STR;
point--;
}
else
i2= evalint();
if(i2<0 || i2> MAX_STR || i1<0 || i1>= MAX_STR)
error(10);
if(getch()!=')' )
error(SYNTAX);
if(getch()!='=')
error(4);
cursiz = pat->len;
if(i1>cursiz)
i1=cursiz;
i2+=i1;
if(i2>cursiz)
i2=cursiz;
rhside= cursiz -i2;
st = stringeval();
check();
totlen = st->strlen + rhside + i1;
if(totlen > MAX_STR)
error(9);
if(i1){
nst = ALLOC_STR( (ival)totlen);
p = strmov(nst->strval, pat->str, i1);
p = strmov(p, st->strval, st->strlen);
if(rhside)
VOID strmov(p, pat->str + i2, rhside);
COPY_OVER_STR(st, nst);
FREE_STR(nst);
}
else {
RESERVE_SPACE(st, totlen);
if(rhside)
VOID strmov(st->strval, pat->str + i2, rhside);
}
st->strlen = totlen;
stringassign(pat, ep, st, 0); /* done it !! */
normret;
}
/*
* translitterate a character from a$ to result using b$
* y$ = xlate(a$, b$
*/
STR
xlate()
{
ival cursiz1;
ival cursiz2;
register CHAR *p, *q;
register ival c;
STR st1, st2;
st1 = stringeval();
if(getch()!=',')
error(SYNTAX);
st2 = stringeval();
cursiz1 = st1->strlen;
cursiz2 = st2->strlen;
for(p = st1->strval, q = st2->strval ; cursiz1 ; cursiz1--, p++){
if( (c = (ival)UC(*p)) >= cursiz2)
*p = 0;
else
*p = q[c];
}
FREE_STR(st2);
return(st1);
}
/* mkint(a$)
* routine to make the first 2 bytes of string into a integer
* for use with formatted files.
*/
void
mkint()
{
register STR st;
st = stringeval();
if(st->strlen < sizeof(itype) )
error(10);
/*LINTED pointer use*/
res.i = *(itype *)st->strval;
vartype = IVAL;
FREE_STR(st);
}
/* ditto for string to double */
void
mkdouble()
{
register STR st;
st = stringeval();
if(st->strlen < sizeof(res) )
error(10);
/*LINTED pointer use*/
res = *(value *)st->strval;
vartype = RVAL;
FREE_STR(st);
}
/*
* mkistr$(x%)
* convert an integer into a string for use with disk files
*/
STR
mkistr()
{
register itype iv;
register STR st;
iv = evalint();
st = ALLOC_STR( (ival)sizeof(itype));
/*LINTED pointer use*/
*(itype *)st->strval = iv;
return(st);
}
/* mkdstr$(x)
* ditto for doubles.
*/
STR
mkdstr()
{
register STR st;
evalreal();
st = ALLOC_STR( (ival)sizeof(res));
/*LINTED pointer use*/
*(value *)st->strval = res;
return(st);
}
static const CHAR hexchar[] = "0123456789ABCDEF";
static STR
hocvtstr(shift)
int shift;
{
register STR st;
register CHAR *p;
int nchars;
unsigned long lv;
ival nsig;
int mask;
nchars = (sizeof(itype) * 8 + shift - 1) / shift;
mask = (1 << shift) - 1;
lv = (unsigned long)evalint();
if(getch() == ','){
nsig = evalint();
if(nsig <= 0){
if(nsig == 0)
nsig = 1;
else
error(FUNCT);
}
}
else {
nsig = 1;
point--;
}
st = ALLOC_STR( (ival)nchars);
for(p = st->strval + nchars - 1; nchars ; nchars--, p--){
*p = hexchar[lv & mask];
lv >>= shift;
}
for(; st->strlen > nsig; st->strlen--, st->strval++)
if(*st->strval != '0')
break;
return(st);
}
STR
hexstr()
{
return(hocvtstr(4));
}
STR
octstr()
{
return(hocvtstr(3));
}
STR
binstr()
{
return(hocvtstr(1));
}
STR
decstr()
{
STR st, retst;
value x;
evalreal();
if(getch() != ',')
error(SYNTAX);
x = res;
st = stringeval();
res = x;
vartype = RVAL;
retst = mathpat(st);
COPY_OVER_STR(st, retst);
FREE_STR(retst);
return(st);
}
STR
bupper()
{
STR st;
itype i;
CHAR *p;
int c;
st = stringeval();
for(i = st->strlen , p = st->strval ; i ; i--, p++){
c = UC(*p);
if(islcase(c))
*p = c - 'a' + 'A';
}
return(st);
}
STR
blower()
{
STR st;
itype i;
CHAR *p;
int c;
st = stringeval();
for(i = st->strlen , p = st->strval ; i ; i--, p++){
c = UC(*p);
if(isucase(c))
*p = c - 'A' + 'a';
}
return(st);
}
void
COPY_OVER_STR(st, fstr)
register STR st, fstr;
{
if(st->allocstr && st->allocstr != st->locbuf)
mfree((MEMP)st->allocstr);
if(fstr->allocstr == fstr->locbuf){
st->allocstr = st->locbuf;
VOID strmov(st->allocstr, fstr->allocstr, fstr->alloclen);
}
else
st->allocstr = fstr->allocstr;
fstr->allocstr = 0;
st->alloclen = fstr->alloclen;
st->strval = fstr->strval;
st->strlen = fstr->strlen;
}
void
FREE_STR(st)
register STR st;
{
register STR nst;
if(st->allocstr != 0 && st->allocstr != st->locbuf)
mfree((MEMP)st->allocstr);
st->allocstr = 0;
/*
* now take off the used queue
*/
if(st->prev){
st->prev->next = 0;
str_uend = st->prev;
}
else
str_uend = str_used = 0;
nst = st->next;
/*
* and add to the free list
*/
st->next = str_free;
str_free = st;
nstr_free++;
while( (st = nst) != 0){
/* the cleanup case */
if(st->allocstr != 0 && st->allocstr != st->locbuf)
mfree((MEMP)st->allocstr);
st->allocstr = 0;
nst = st->next;
st->next = str_free;
str_free = st;
nstr_free++;
}
while(nstr_free > MAX_FREE_STRS){
st = str_free;
str_free = st->next;
mfree( (MEMP) st);
nstr_free--;
}
}
void
NULL_TERMINATE(st)
register STR st;
{
if(st->strlen >= st->alloclen)
RESERVE_SPACE(st, (ival)(st->strlen+1));
st->strval[st->strlen] = 0;
}
/*
* slop that might be needed, for adding a null byte etc.
* to the string... Stops sillies like reallocating a string to add a
* null byte on the end
*/
#define STR_SLOP 2
/*
* allways aallocate space in quantities of this
*/
#define STR_ALIGNED 64
#define STR_ALIGN(x) ((((x) + STR_SLOP) + STR_ALIGNED-1) & ~(STR_ALIGNED-1))
void
RESERVE_SPACE(st, len)
register STR st;
register ival len;
{
register CHAR *p;
register CHAR *tofree = 0;
if(len == 0){
st->strval = st->allocstr;
return;
}
if(st->allocstr != 0){
if(st->alloclen < len){
len = STR_ALIGN(len);
p = (CHAR *)mmalloc(len);
if(st->allocstr != st->locbuf)
tofree = st->allocstr;
st->allocstr = p;
st->alloclen = len;
}
}
else {
if(len <= LOC_BUF_SIZ){
st->allocstr = st->locbuf;
st->alloclen = LOC_BUF_SIZ;
}
else {
len = STR_ALIGN(len);
st->allocstr = (CHAR *)mmalloc(len);
st->alloclen = len;
}
}
if(st->strlen && st->strval != st->allocstr)
VOID strmov(st->allocstr, st->strval, st->strlen);
if(tofree)
mfree((MEMP)tofree);
st->strval = st->allocstr;
}
void
DROP_STRINGS()
{
register STR st;
while( (st = str_free) != 0){
str_free = st->next;
mfree( (MEMP)st);
}
nstr_free = 0;
}
STR
ALLOC_STR(len)
ival len;
{
/* Take a str element off the free list */
register STR st;
register int i;
if( (st = str_free) == 0){
for(i = 10 ; i ; i--){
st = (STR)mmalloc(sizeof(* st));
clr_mem( (memp)st, sizeof(* st) - LOC_BUF_SIZ);
st->next = str_free;
str_free = st;
nstr_free++;
}
st = str_free;
}
str_free = st->next;
nstr_free--;
/*
* now add to the used list
*/
st->next = 0;
if((st->prev = str_uend) == 0)
str_used = st;
else
st->prev->next = st;
str_uend = st;
/*
* now allocate any space needed for it
*/
st->strlen = len;
if(len == 0){
st->allocstr = 0;
st->alloclen = 0;
}
else if(len <= LOC_BUF_SIZ){
st->alloclen = LOC_BUF_SIZ;
st->allocstr = st->locbuf;
}
else {
st->alloclen = STR_ALIGN(len);
st->allocstr = (CHAR *)mmalloc(st->alloclen);
}
st->strval = st->allocstr;
return(st);
}
syntax highlighted by Code2HTML, v. 0.9.1