873 lines
27 KiB
C
873 lines
27 KiB
C
/* TIPC Scheme '84 Runtime Support - S-Expression Reading
|
||
(C) Copyright 1984,1985 by Texas Instruments Incorporated.
|
||
All rights reserved.
|
||
|
||
Author: Mark E. Meyer
|
||
Installation: Texas Instruments Incorporated, Dallas, Texas
|
||
Division: Central Research Laboratories
|
||
Cost Center: Computer Science Laboratory
|
||
Project: Computer Architecture Branch
|
||
Date Written: 12 June 1984
|
||
Last Modification: 18 October 1985 by John Jensen
|
||
*/
|
||
|
||
#include "scheme.h"
|
||
#include "schars.h"
|
||
|
||
extern char decpoint; /* Current decimal point character */
|
||
|
||
#define ATOM 0 /* Codes returned by FINDTASK function */
|
||
#define NIL 1
|
||
#define LPAREN 2
|
||
#define RPAREN 3
|
||
#define QUOTE 4
|
||
#define DOT 5
|
||
|
||
#define DS 0 /* Register array subscripts */
|
||
#define PG 1
|
||
/************
|
||
static int scan = 0;
|
||
static char ch = ' '; /* Most recently received character */
|
||
static int *mainreg = NULL; /* Main register */
|
||
/** static int init_stk = 0; /* Initial Scheme top-of-stack */ **/
|
||
static int limit; /* Current size of atom buffer */
|
||
static char *atomb; /* Atom buffer */
|
||
static int flag_eof; /* Whether to flag end-of-file */
|
||
|
||
/**************************************************************/
|
||
/* REG2REG(sor,dest) */
|
||
/* Copy the contents from one regsiter to another. */
|
||
/**************************************************************/
|
||
#define reg2reg(sor,dest) (dest)[DS] = (sor)[DS]; (dest)[PG] = (sor)[PG];
|
||
|
||
|
||
/**************************************************************/
|
||
/* SKIPSPACE() */
|
||
/* Skip over spaces in the input stream, and get a new */
|
||
/* line of input if necessary */
|
||
/**************************************************************/
|
||
#define skipspace() do {rcvchar();} while (isspace(ch));
|
||
**************/
|
||
|
||
/**************************************************************/
|
||
/* SREAD(reg,pg,ds) */
|
||
/* Given a pointer to a register, SREAD constructs a */
|
||
/* list structure, based on input from the port at (PG,DS), */
|
||
/* leaving in the register a pointer to the structure. This */
|
||
/* memory-efficient algorithm has return pointers kept */
|
||
/* within the structure itself, both minimizing overhead and */
|
||
/* making the structure garbage-collector-compatible. */
|
||
/* Throughout this source, pointers in the registers use */
|
||
/* doubled pages, CORRected to single only when necessary. */
|
||
/* Aside from setting PORT once, a SUBSREAD routine is */
|
||
/* used so that two additional registers known to the garabge */
|
||
/* collector can be easily utilized. This means that READ */
|
||
/* may only be called with one of the R-registers. */
|
||
/**************************************************************/
|
||
/***** Code for 'read' turned off 16 July 1985 (JCJ) *****
|
||
sread(reg,pg,ds)
|
||
int *reg;
|
||
int pg,ds;
|
||
{
|
||
setabort();
|
||
if (setadr(pg,ds,1)) /* Set the read port */
|
||
abort(PORTERR);
|
||
flag_eof = TRUE; limit = 0;
|
||
mainreg = reg; /* Save pointer to main register */
|
||
if (reg < ®s[3])
|
||
subsread(reg, reg + 2, reg + 4);
|
||
else
|
||
{
|
||
subsread(reg, reg - 2, reg - 4);
|
||
}
|
||
return(0);
|
||
}
|
||
***** Code for 'read' turned off 16 July 1985 (JCJ) *****/
|
||
|
||
/***********
|
||
/**************************************************************/
|
||
/* SREAD_ATOM(reg,pg,ds) */
|
||
/* Setup for the operation of reading a single atom from */
|
||
/* the given port. Special characters such as ')' are parsed */
|
||
/* as lists(!) to tell them from ordianry atoms. */
|
||
/**************************************************************/
|
||
sread_atom(reg,pg,ds)
|
||
int *reg;
|
||
int pg,ds;
|
||
{
|
||
setabort();
|
||
if (setadr(pg,ds,1))
|
||
abort(PORTERR);
|
||
mainreg = reg; /* Save pointer to result register */
|
||
flag_eof = TRUE; limit = /* init_stk = */ 0;
|
||
do
|
||
{
|
||
skipspace(); skipcomments();
|
||
} while (!ch); /* if ch = '\0', flush it */
|
||
return(read_atom(reg));
|
||
}
|
||
***************/
|
||
|
||
/***** Code for 'read' turned off 16 July 1985 (JCJ) *****
|
||
/**************************************************************/
|
||
/* SUBSREAD(reg,pres,prev) */
|
||
/**************************************************************/
|
||
subsread(reg,pres,prev)
|
||
int reg[2];
|
||
int pres[2]; /* Pointer to the present cons cell */
|
||
int prev[2]; /* Ptr. to cell whose car is list containing [PRES] */
|
||
{
|
||
int task;
|
||
C_push(pres); /* Save old register values */
|
||
C_push(prev);
|
||
init_stk = TOS; /* Save initial top of stack pointer */
|
||
prev[PG] = prev[DS] = pres[PG] = pres[DS] = 0;
|
||
start:
|
||
task = findtask(); /* Determine next action to take, */
|
||
switch (task) /* depending on what's coming up */
|
||
{
|
||
case NIL: /* If atom coming, read it & leave */
|
||
case ATOM:
|
||
read_atom(reg);
|
||
goto fastexit;
|
||
case LPAREN: /* Grab cons cell */
|
||
descend(reg,pres,prev);
|
||
C_push(pres); /* Save start of list structure */
|
||
reg[PG] = fixpage; /* Bottom of stack for dot-lparens */
|
||
C_push(reg);
|
||
goto fillcar; /* Read in the car */
|
||
case QUOTE: /* Form quote structure */
|
||
buildq(pres,reg,&task);
|
||
C_push(reg); /* Save start */
|
||
reg[PG] = fixpage; /* Bottom of stack */
|
||
C_push(reg);
|
||
while (task == QUOTE) /* Handle nested quotes */
|
||
buildq(pres,reg,&task);
|
||
switch (task)
|
||
{
|
||
case NIL: /* Read atom and leave */
|
||
case ATOM:
|
||
read_atom(reg);
|
||
reg2ptr(reg,pres);
|
||
goto exit;
|
||
case LPAREN: /* Start reading list */
|
||
listquote:
|
||
grabcell(reg);
|
||
reg2ptr(reg,pres);
|
||
reg2reg(reg,pres);
|
||
goto fillcar;
|
||
default: /* Anything else is wrong! */
|
||
abortread(QUOTERR);
|
||
}
|
||
case RPAREN: /* Can't start with )! */
|
||
abortread(RPARERR);
|
||
case DOT: /* Nor with .! */
|
||
abortread(DOTERR);
|
||
}
|
||
fillcar:
|
||
task = findtask();
|
||
fillcar2:
|
||
switch (task)
|
||
{
|
||
case NIL: /* Deposit atom in car and read in cdr */
|
||
case ATOM:
|
||
read_atom(reg);
|
||
reg2ptr(reg,pres);
|
||
goto cross;
|
||
case LPAREN: /* Save PREV in cdr field and update PRES & PREV */
|
||
reg2cdr(prev,pres);
|
||
descend(reg,pres,prev);
|
||
goto fillcar;
|
||
case QUOTE:
|
||
C_push(prev); /* Save PREV & PRES */
|
||
reg2reg(pres,prev);
|
||
do /* Build quote structure */
|
||
buildq(pres,reg,&task);
|
||
while (task == QUOTE);
|
||
switch(task)
|
||
{
|
||
case NIL: /* If atom, read in, restore PRES & PREV, and cross */
|
||
case ATOM:
|
||
read_atom(reg);
|
||
reg2ptr(reg,pres);
|
||
reg2reg(prev,pres);
|
||
C_pop(prev);
|
||
goto cross;
|
||
case LPAREN: /* If list, save old PREV in cdr of old PRES */
|
||
C_pop(reg);
|
||
reg2cdr(reg,prev);
|
||
goto listquote;
|
||
default:
|
||
abortread(QUOTERR);
|
||
}
|
||
default: /* This is the case of (. */
|
||
abortread(DOTERR);
|
||
}
|
||
cross:
|
||
task = findtask();
|
||
switch (task)
|
||
{
|
||
case RPAREN: /* Try to ascend to higher list */
|
||
tryascend:
|
||
C_pop(reg);
|
||
while ((reg[PG] == prev[PG]) && (reg[DS] == prev[DS]))
|
||
/* Do while there are dot-lparens to be closed */
|
||
if (findtask() == RPAREN)
|
||
C_pop(reg);
|
||
else /* Some dot-lparen wasn't closed */
|
||
{
|
||
abortread(DOTERR);
|
||
}
|
||
C_push(reg); /* Restore stack */
|
||
if (prev[PG]) /* Not done if not at top level of list */
|
||
{
|
||
ascend(pres,prev);
|
||
goto cross;
|
||
}
|
||
else /* Else exit */
|
||
{
|
||
goto exit;
|
||
}
|
||
case DOT:
|
||
task = findtask();
|
||
switch (task)
|
||
{
|
||
case NIL: /* Fill cdr field */
|
||
case ATOM:
|
||
read_atom(reg);
|
||
reg2cdr(reg,pres);
|
||
dotatom:
|
||
if (findtask() == RPAREN) /* Ascend only if ) follows */
|
||
goto tryascend;
|
||
else /* more than one thing after dot */
|
||
{
|
||
abortread(DOTERR);
|
||
}
|
||
case LPAREN: /* Push PREV onto stack */
|
||
C_push(prev);
|
||
buildcdr(reg,pres); /* And treat as if dot-lparen */
|
||
goto fillcar; /* didn't happen */
|
||
case QUOTE:
|
||
task = -1; /* Fill cdr field first */
|
||
do
|
||
buildq(pres,reg,&task);
|
||
while (task == QUOTE);
|
||
switch (task)
|
||
{
|
||
case NIL: /* If atom, go fill space in quote structure */
|
||
case ATOM:
|
||
read_atom(reg);
|
||
reg2ptr(reg,pres);
|
||
goto dotatom;
|
||
case LPAREN:
|
||
C_push(prev); /* Save dot syntax indicator */
|
||
goto listquote;
|
||
default:
|
||
abortread(QUOTERR);
|
||
}
|
||
default:
|
||
abortread(DOTERR);
|
||
}
|
||
default: /* Otherwise, affix a cons cell to the cdr of PRES */
|
||
buildcdr(reg,pres);
|
||
goto fillcar2;
|
||
}
|
||
exit:
|
||
TOS -= PTRSIZE; /* Discard fixnum */
|
||
C_pop(reg); /* Get ptr to structure */
|
||
fastexit:
|
||
C_pop(prev); /* Restore old values */
|
||
C_pop(pres);
|
||
}
|
||
|
||
|
||
/**************************************************************/
|
||
/* FINDTASK() */
|
||
/* Scan the input stream and find out what's coming up */
|
||
/* (atom, ", (, etc.). */
|
||
/**************************************************************/
|
||
findtask()
|
||
{
|
||
char *stpchr();
|
||
|
||
skipspace();
|
||
skipcomments();
|
||
switch (ch)
|
||
{
|
||
case '(':
|
||
skipspace();
|
||
skipcomments();
|
||
if (ch == ')')
|
||
{
|
||
ch = ' '; return(NIL);
|
||
}
|
||
else
|
||
{
|
||
pushchar();
|
||
return(LPAREN);
|
||
}
|
||
case ')':
|
||
return(RPAREN);
|
||
case '\'':
|
||
return(QUOTE);
|
||
case '.':
|
||
rcvchar();
|
||
if (isspace(ch))
|
||
return(DOT);
|
||
else
|
||
{
|
||
pushchar();
|
||
if (stpchr( "()'|\";[]{}" , ch))
|
||
{
|
||
return(DOT); /* because dot is followed by non-atomic char */
|
||
}
|
||
else /* the dot is the first char of a symbol */
|
||
{
|
||
ch = '.'; /* Restore initial dot */
|
||
return(ATOM);
|
||
}
|
||
}
|
||
default:
|
||
return(ATOM);
|
||
}
|
||
}
|
||
|
||
|
||
/***************************************************************/
|
||
/* BUILDQ(pres,reg,task) */
|
||
/* BUILDQ's purpose is to build a list of the form (quote */
|
||
/* nil), and point the field pointed to by PRES to the list. */
|
||
/* On exit, PRES points to the cdr of the (quote nil), */
|
||
/* enabling easy handling of nested quotes; REG points to the */
|
||
/* (quote nil) itself, and TASK is set by FINDTASK(). */
|
||
/***************************************************************/
|
||
buildq(pres,reg,task)
|
||
int pres[2];
|
||
int reg[2];
|
||
int *task;
|
||
{
|
||
int temp[2]; /* Temporary register */
|
||
C_push(pres); /* Save destination pointer field */
|
||
grabcell(reg); /* Grab a cell and point its car to quote */
|
||
pres[PG] = ADJPAGE(QUOTE_PAGE);
|
||
pres[DS] = QUOTE_DISP;
|
||
reg2ptr(pres,reg);
|
||
grabcell(pres); /* Grab another cell, point cdr(reg) to it */
|
||
reg2cdr(pres,reg);
|
||
reg2reg(pres,temp); /* Save second cell address */
|
||
C_pop(pres); /* Point destination field to the quote list */
|
||
if (pres[PG]) /* if the field exists */
|
||
{
|
||
if (*task<0)
|
||
reg2cdr(reg,pres); /* Place in PRES's cdr field */
|
||
else
|
||
{
|
||
reg2ptr(reg,pres); /* Place in car field */
|
||
}
|
||
}
|
||
reg2reg(temp,pres); /* Recover second cell address */
|
||
*task = findtask();
|
||
}
|
||
***** Code for 'read' turned off 16 July 1985 (JCJ) *****/
|
||
|
||
/**************
|
||
/***************************************************************/
|
||
/* READ_ATOM(reg) */
|
||
/* Read in an atom (symbol, string, number), using REG as */
|
||
/* a scratch register, and store the pointer to the atom in */
|
||
/* REG. Special characters such as ')' or ',' are read as */
|
||
/* atoms themselves. Normal atoms will end in a whitespace or */
|
||
/* a terminating macro character; strings end with the closing */
|
||
/* '"'. Numbers in the requested base are interpreted as */
|
||
/* such. On exit, the next character in the buffer is the one */
|
||
/* following the last character of the atom. */
|
||
/***************************************************************/
|
||
read_atom(reg)
|
||
int reg[2];
|
||
{
|
||
register int i = 0; /* Index within buffer */
|
||
register char c;
|
||
char k;
|
||
char *bignum; /* Bignum workspace */
|
||
char *getmem();
|
||
char *stpchr();
|
||
int inputch = FALSE; /* Whether the #\ macro is in effect */
|
||
int escaped = FALSE; /* Whether an escape character has been used */
|
||
int j,pg,ds,siz,base,neg;
|
||
double inflo;
|
||
|
||
extern int CXFERR_status;
|
||
|
||
CXFERR_status = 0; /* set error code for normal return */
|
||
|
||
if (ch==' ') /* If ch is a space, form NIL */
|
||
{
|
||
reg[PG] = reg[DS] = 0;
|
||
goto end_of_function;
|
||
}
|
||
flag_eof = FALSE;
|
||
if (!(atomb = getmem(BUFSIZE))) /* Create buffer if possible */
|
||
abortread(HEAPERR);
|
||
limit = BUFSIZE; /* Initialize buffer size */
|
||
base = 10; /* Default base */
|
||
switch (ch) /* Read atom into buffer */
|
||
{
|
||
/* Special-character cases */
|
||
case '[':
|
||
case ']':
|
||
case '{':
|
||
case '}':
|
||
case '(':
|
||
case ')':
|
||
case '\'':
|
||
case '`': *atomb=ch; i++; goto speccase;
|
||
/* String case */
|
||
case '"': i = delimby('"',i);
|
||
alloc_block(reg, STRTYPE, i); /* Allocate string space */
|
||
toblock(reg, 3, atomb, i);
|
||
goto bye_now;
|
||
/* Comma case */
|
||
case ',': *atomb=','; i++;
|
||
rcvchar();
|
||
if ((ch=='@') || (ch=='.'))
|
||
{
|
||
atomb[1]=ch; i++; goto speccase;
|
||
}
|
||
goto norcvspec;
|
||
/* Macro case */
|
||
case '#': flag_eof = TRUE;
|
||
while ((ch=='#') && (!i))
|
||
{
|
||
rcvchar();
|
||
if (isspace(ch)) abortread(SHARPERR);
|
||
switch (tolower(ch))
|
||
{
|
||
case 'b': base=2; break;
|
||
case 'd': base=10; break;
|
||
case 'x':
|
||
case 'h': base=16; break;
|
||
case 'o': base=8; break;
|
||
case '\\': rcvchar();
|
||
addchar(i++,ch);
|
||
inputch=TRUE; escaped=TRUE;
|
||
/* Fall through to BREAK below */
|
||
case 'i': /* Ignore (currently) meaningless macros */
|
||
case 'e':
|
||
case 's':
|
||
case 'l': break;
|
||
case '<':
|
||
case ')': abortread(SHARPERR);
|
||
default: *atomb = '#';
|
||
atomb[1] = ch;
|
||
i = 2;
|
||
if (ch=='(') goto speccase;
|
||
break;
|
||
}
|
||
rcvchar();
|
||
}
|
||
flag_eof = FALSE;
|
||
/* Else a symbol */
|
||
default: while (!isspace(ch) &&
|
||
!stpchr( "()'`;,\"[]{}" , ch) &&
|
||
(ch!='\032'))
|
||
{
|
||
switch (ch=toupper(ch))
|
||
{
|
||
/* Multiple-escape: read chars until next | */
|
||
case '|': escaped = TRUE;
|
||
i = delimby('|',i);
|
||
break;
|
||
/* Single-escape: get next char and put it in */
|
||
case '\\': escaped = flag_eof = TRUE;
|
||
rcvchar();
|
||
flag_eof = FALSE;
|
||
default: addchar(i++,ch);
|
||
}
|
||
rcvchar();
|
||
}
|
||
} /* End of switch (ch) */
|
||
endatom:
|
||
addchar(i,'\0'); /* Put null at end of token */
|
||
/* Now check for single, unescaped dot (SPECIAL!) */
|
||
if ((i==1) && (*atomb=='.') && !escaped) goto norcvspec;
|
||
/* At this point a token has been accumulated. Check for number */
|
||
j = scannum(atomb,base);
|
||
if ((j) && !escaped) /* If a number */
|
||
{
|
||
if (j>0) /* integer of some size */
|
||
{
|
||
siz = (j + 9)/2; /* How many bytes needed for int? */
|
||
if (!(bignum = getmem(siz)))
|
||
{
|
||
abortread(HEAPERR);
|
||
}
|
||
bignum[3] = '\0';
|
||
bignum[4] = '\0';
|
||
buildint(bignum,atomb,base); /* Form integer */
|
||
alloc_int(reg,bignum);
|
||
rlsmem(bignum,siz);
|
||
}
|
||
else /* scan the flonum */
|
||
{
|
||
scanflo(atomb,&inflo,base);
|
||
alloc_flonum(reg,inflo);
|
||
}
|
||
}
|
||
else /* allocate character or interned symbol */
|
||
{
|
||
if (inputch)
|
||
{
|
||
reg[PG] = SPECCHAR*2;
|
||
if (i==1) reg[DS]=*atomb;
|
||
else /* check for a multichar character constant */
|
||
{
|
||
*atomb = toupper(*atomb); /* convert 1st symbol to uppercase */
|
||
for (j=0; j<test_num; j++)
|
||
{
|
||
if (!strcmp(atomb, test_string[j]))
|
||
{
|
||
reg[DS]=test_char[j]; break;
|
||
}
|
||
if (j == test_num-1)
|
||
{
|
||
alloc_string(tmp_reg, atomb);
|
||
set_error(0,"Invalid character constant",tmp_reg);
|
||
reg[DS] = '?';
|
||
CXFERR_status = -1;
|
||
}
|
||
} /* end of for(j=0; j<test_num; j++) */
|
||
}
|
||
}
|
||
else /* not a character, but a symbol */
|
||
{
|
||
intern(reg,atomb,i);
|
||
}
|
||
}
|
||
goto release;
|
||
|
||
speccase: /* Process the special cases */
|
||
intern(reg,atomb,i); /* Intern the symbol and encase in a list */
|
||
cons(reg,reg,nil_reg);
|
||
goto bye_now;
|
||
|
||
norcvspec:
|
||
intern(reg,atomb,i); /* Intern the symbol and encase in a list */
|
||
cons(reg,reg,nil_reg);
|
||
|
||
release:
|
||
if (ch!='\032') pushchar(); /* Put post-atom char back into buffer */
|
||
|
||
bye_now:
|
||
rlsmem(atomb,limit); /* Release the buffer space */
|
||
flag_eof = TRUE;
|
||
limit = 0;
|
||
|
||
end_of_function:
|
||
return(CXFERR_status);
|
||
}
|
||
******************************/
|
||
|
||
/**************************************************************/
|
||
/* SCANFLO(s,flo,base) */
|
||
/* The string S, which ends in a control char, holds a */
|
||
/* representation of a floating-point number. The value of */
|
||
/* this number is stored in *FLO. */
|
||
/**************************************************************/
|
||
scanflo(s,flo,base)
|
||
char *s;
|
||
double *flo;
|
||
int base;
|
||
{
|
||
int i=0;
|
||
int neg=0;
|
||
int x=0;
|
||
double place;
|
||
switch (*s)
|
||
{
|
||
case '-': neg=-1;
|
||
case '+': i++; break;
|
||
default: break;
|
||
}
|
||
while (s[i]=='#') i+=2;
|
||
*flo = 0.0;
|
||
while (isdig(s[i],base))
|
||
{
|
||
*flo = (*flo * base) + digval(s[i++]);
|
||
}
|
||
if (!(s[i]==decpoint)) goto EXPON;
|
||
POINT:
|
||
i++; place = 1.0;
|
||
while (isdig(s[i],base))
|
||
{
|
||
place /= base;
|
||
*flo += place*digval(s[i++]);
|
||
}
|
||
if (s[i]<' ') goto GOTFLO;
|
||
EXPON:
|
||
i++;
|
||
if (s[i]=='-')
|
||
{
|
||
i++; place = 1.0/base;
|
||
}
|
||
else place=base;
|
||
while (isdigit(s[i]))
|
||
x = (x*10) + digval(s[i++]);
|
||
while (x)
|
||
{
|
||
if (x!=(x>>1)<<1)
|
||
*flo *= place;
|
||
if (place<1.0e153) place*=place;
|
||
x >>= 1;
|
||
}
|
||
GOTFLO:
|
||
if (neg)
|
||
*flo = -*flo;
|
||
}
|
||
|
||
|
||
/**************************************************************/
|
||
/* ALLOC_INT(reg,buf) */
|
||
/* This allocates an integer, either a fixnum or a */
|
||
/* bignum, depending on the size of the integer, i.e., if */
|
||
/* the absolute value < 16384, then a fixnum is allocated. */
|
||
/* The value is read from BUF. */
|
||
/**************************************************************/
|
||
alloc_int(reg,buf)
|
||
int reg[2];
|
||
char *buf;
|
||
{
|
||
unsigned i,j;
|
||
int pg;
|
||
i = 256*buf[1] + buf[0];
|
||
j = 256*buf[4] + buf[3];
|
||
pg = buf[2] & 1;
|
||
if ((i == 1) && (j <= 16383+pg)) /* If fixnum */
|
||
alloc_fixnum(reg, (pg ? -j : j));
|
||
else
|
||
{
|
||
alloc_block(reg, BIGTYPE, 2*i + 1);
|
||
toblock(reg, 3, buf+2, 2*i +1);
|
||
}
|
||
}
|
||
|
||
/**************
|
||
/**************************************************************/
|
||
/* DELIMBY(c,i) */
|
||
/* DELIMBY takes characters from the input stream and */
|
||
/* places them in the buffer ATOMB, starting at offset I and */
|
||
/* ending when the delimiting character C is reached. This */
|
||
/* returns the number of characters stored in ATOMB, and CH */
|
||
/* is left equal to C. */
|
||
/**************************************************************/
|
||
delimby(c,i)
|
||
char c;
|
||
int i;
|
||
{
|
||
flag_eof = TRUE; /* Signal any end-of-file error */
|
||
rcvchar();
|
||
while (ch != c)
|
||
{
|
||
if (ch != '\r')
|
||
{
|
||
if (ch == '\\') rcvchar();
|
||
addchar(i++,ch);
|
||
}
|
||
rcvchar();
|
||
}
|
||
flag_eof = FALSE;
|
||
return(i);
|
||
}
|
||
|
||
|
||
/**************************************************************/
|
||
/* ADDCHAR(i,c) */
|
||
/* ADDCHAR takes the character C and places it in the */
|
||
/* dynamic atom buffer ATOMB, at offset I. If the buffer can */
|
||
/* not contain any more characters, additional space is */
|
||
/* allocated, and LIMIT is adjusted accordingly. */
|
||
/**************************************************************/
|
||
addchar(i,c)
|
||
int i;
|
||
char c;
|
||
{
|
||
int j; /* Scratch FOR variable */
|
||
char *atom2; /* New atom buffer, if necessary */
|
||
char *getmem(); /* Additional memory allocator */
|
||
if (i < limit) /* If room for character, put it in */
|
||
atomb[i] = c;
|
||
else /* Else create a new, larger buffer */
|
||
{
|
||
if (!(atom2 = getmem(limit + BUFSIZE)))
|
||
{
|
||
abortread(HEAPERR);
|
||
}
|
||
for (j = 0; j < limit; j++) atom2[j] = atomb[j];
|
||
rlsmem(atomb,limit); /* Discard the old buffer */
|
||
atomb = atom2;
|
||
atomb[i] = c;
|
||
limit += BUFSIZE;
|
||
}
|
||
}
|
||
********************************/
|
||
/***** Code for 'read' turned off 16 July 1985 (JCJ) *****
|
||
/**************************************************************/
|
||
/* DESCEND(reg,pres,prev) */
|
||
/* Get a new cons cell, point the car field of [PRES] to */
|
||
/* the cell, and update PREV and PRES. */
|
||
/**************************************************************/
|
||
descend(reg,pres,prev)
|
||
int reg[2];
|
||
int pres[2];
|
||
int prev[2];
|
||
{
|
||
grabcell(reg);
|
||
if (pres[PG]) /* Do only if PRES points to something */
|
||
reg2ptr(reg,pres);
|
||
reg2reg(pres,prev);
|
||
reg2reg(reg,pres);
|
||
}
|
||
|
||
|
||
/**************************************************************/
|
||
/* BUILDCDR(reg,pres) */
|
||
/* Grab a cons cell, point the cdr field of [PRES] to */
|
||
/* it, and update PRES. */
|
||
/**************************************************************/
|
||
buildcdr(reg,pres)
|
||
int reg[2];
|
||
int pres[2];
|
||
{
|
||
grabcell(reg);
|
||
pres[DS] += PTRSIZE;
|
||
reg2ptr(reg,pres);
|
||
reg2reg(reg,pres);
|
||
}
|
||
|
||
|
||
/**************************************************************/
|
||
/* ASCEND(pres,prev) */
|
||
/* Set PRES to PREV, and pluck the new value for PREV */
|
||
/* from the cdr field of [PREV], replacing it with NIL. */
|
||
/**************************************************************/
|
||
ascend(pres,prev)
|
||
int pres[2];
|
||
int prev[2];
|
||
{
|
||
int i,j; /* Scratch integers */
|
||
reg2reg(prev,pres);
|
||
j = pres[DS] + PTRSIZE;
|
||
i = CORRPAGE(pres[PG]);
|
||
/* note: put_byte/put_word return to contents of the byte/word replaced */
|
||
prev[PG] = put_byte(i, j++, 0);
|
||
prev[DS] = put_word(i, j, 0);
|
||
}
|
||
|
||
|
||
/**************************************************************/
|
||
/* GRABCELL(reg) */
|
||
/* Grab a cons cell, point REG to it, and set it to */
|
||
/* (nil . nil). */
|
||
/**************************************************************/
|
||
grabcell(reg)
|
||
int reg[2];
|
||
{
|
||
int i;
|
||
alloc_list_cell(reg);
|
||
i = CORRPAGE(reg[PG]);
|
||
put_word(i, reg[DS], 0);
|
||
put_word(i, reg[DS]+2, 0);
|
||
put_word(i, reg[DS]+4, 0);
|
||
}
|
||
|
||
/**************************************************************/
|
||
/* REG2PTR(reg,ptr) */
|
||
/* Transfer the contents of REG to the pointer field */
|
||
/* pointed to by PTR. */
|
||
/**************************************************************/
|
||
reg2ptr(reg,ptr)
|
||
int reg[2];
|
||
int ptr[2];
|
||
{
|
||
put_byte(CORRPAGE(ptr[PG]), (ptr[DS])++, reg[PG]);
|
||
put_word(CORRPAGE(ptr[PG]), (ptr[DS])--, reg[DS]);
|
||
}
|
||
|
||
/**************************************************************/
|
||
/* REG2CDR(reg,ptr) */
|
||
/* Transfer the contents of REG to the cdr field of the */
|
||
/* cell pointed to by PTR. */
|
||
/**************************************************************/
|
||
reg2cdr(reg,ptr)
|
||
int reg[2];
|
||
int ptr[2];
|
||
{
|
||
ptr[DS] += PTRSIZE;
|
||
reg2ptr(reg,ptr);
|
||
ptr[DS] -= PTRSIZE;
|
||
}
|
||
***** Code for 'read' turned off 16 July 1985 (JCJ) *****/
|
||
/*************
|
||
/**************************************************************/
|
||
/* RCVCHAR() */
|
||
/* This fetches a character from the input stream */
|
||
/**************************************************************/
|
||
rcvchar()
|
||
{
|
||
register int i;
|
||
i = take_ch();
|
||
if ((i<256) && (i!=26))
|
||
ch = i;
|
||
else
|
||
{
|
||
if (flag_eof) abortread(EOFERR);
|
||
else
|
||
{
|
||
ch = '\032'; /* EOF character */
|
||
}
|
||
}
|
||
}
|
||
|
||
|
||
/**************************************************************/
|
||
/* ABORTREAD(code) */
|
||
/* Cancels the entire read operation via ABORT, after */
|
||
/* resetting some vital registers. */
|
||
/**************************************************************/
|
||
abortread(code)
|
||
int code;
|
||
{
|
||
if (code == EOFERR)
|
||
{
|
||
mainreg[PG] = EOF_PAGE*2; /* return "eof" indicator */
|
||
mainreg[DS] = EOF_DISP;
|
||
}
|
||
else
|
||
{
|
||
mainreg[PG] = mainreg[DS] = 0; /* NILify main register */
|
||
}
|
||
if (limit) rlsmem(atomb,limit); /* Release buffer memory */
|
||
/*****
|
||
if (init_stk)
|
||
{
|
||
TOS = init_stk;
|
||
C_pop((mainreg < ®s[3]) ? (mainreg + 4) : (mainreg - 4));
|
||
C_pop((mainreg < ®s[3]) ? (mainreg + 2) : (mainreg - 2));
|
||
}
|
||
*****/
|
||
abort(code);
|
||
}
|
||
|
||
/****************************************************************/
|
||
/* Skip over Comments */
|
||
/****************************************************************/
|
||
skipcomments()
|
||
{
|
||
while (ch == ';')
|
||
{
|
||
while (ch != '\r') rcvchar();
|
||
skipspace();
|
||
}
|
||
} /* end of function: skipcomments() */
|
||
****************************************************/
|
||
|
||
|