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() */
|
|||
|
****************************************************/
|
|||
|
|
|||
|
|