/*************************************************************************
*  PDSS (PIMOS Development Support System)  Version 2.52		 *
*  (C) Copyright 1988,1989,1990,1992.					 *
*  Institute for New Generation Computer Technology (ICOT), Japan.	 *
*  Read "../COPYRIGHT" for detailed information.			 *
*************************************************************************/

#include  "pdss.h"
#include  "memory.h"
#include  "io.h"
#include  "ctype.h"


/*************************************************************************
*   Create New Window							 *
*************************************************************************/

int create_window(name, intr, ioid)
    CELL *name;	 /* + window name (STRING) */
    CELL *intr;	 /* - interrupt stream */
    int	 *ioid;	 /* - io device id */
{
    register IO_BACKET *it;
    register CELL *c;
    register int wn;
    CHAR buf[40];
    if(window_pool == NULL){
	return(IOSUB_IO_TABLE_FULL);
    }
    it = window_pool; window_pool = it->next;
    it->inp_flag = NO;
    it->int_code = 0;
    if(use_windows){
	it->buf_p1 = it->buf_p2 = it->buffer;
	it->buf_cc = it->buf_lc = 0;
	it->kb_req = 0;
    }else{
	it->buf_cc = EOF;
	it->buf_lc = YES;
    }
    wn = it-(&io_table[0]);
    convert_to_c_string(name, buf, 40);
    CreateWindow(wn, buf);
    AllocCell(it->inp_hook); AllocUndef(c);
    SetAll(it->inp_hook, REF, c, MRBOFF);
    AllocCell(it->int_hook); AllocUndef(c);
    SetAll(it->int_hook, REF, c, MRBOFF);
    SetAll(intr, REF, c, MRBOFF);
    *ioid = wn;
    it->status = IO_ACTIVE|IO_READ|IO_WRITE;
    it->ts_stt = TS_NORMAL;
    return(IOSUB_SUCCESS);
}


/*************************************************************************
*   Remove Window							 *
*************************************************************************/

int remove_window(ioid)
    int ioid;  /* + io device id */
{
    register IO_BACKET *it;
    RemoveWindow(ioid);
    it = &io_table[ioid];
    it->status = 0;
    it->next = window_pool; window_pool = it;
    return(IOSUB_SUCCESS);
}

int remove_all_windows()
{
    register IO_BACKET *it;
    register int wn;
    for(wn = 1; wn < MAX_OF_WINDOW; wn++){
	it = &io_table[wn];
	if(it->status & IO_ACTIVE){
	    RemoveWindow(wn);
	    it->status = 0;
	    it->next = window_pool; window_pool = it;
	}
    }
    return(IOSUB_SUCCESS);
}


/*************************************************************************
*   Show/Hide Window							 *
*************************************************************************/

int show_window(ioid)
    int ioid;  /* + io device id */
{
    ShowWindow(ioid);
    return(IOSUB_SUCCESS);
}

int hide_window(ioid)
    int ioid;  /* + io device id */
{
    HideWindow(ioid);
    return(IOSUB_SUCCESS);
}


/*************************************************************************
*   Create New File							 *
*************************************************************************/

int create_file(ioid)
    int	 *ioid;	 /* - io device id */
{
    register IO_BACKET *it;
    if(file_pool == NULL){
	return(IOSUB_IO_TABLE_FULL);
    }
    it = file_pool; file_pool = it->next;
    *ioid = it-(&io_table[0]);
    it->status = IO_ACTIVE;
    return(IOSUB_SUCCESS);
}


/*************************************************************************
*   Open File								 *
*************************************************************************/

int open_file(ioid, name, mode)
    int	 ioid;	 /* + io device id */
    CELL *name;	 /* + window name (STRING) */
    int	 mode;	 /* + open mode (0:read, 1:write, 2:append) */
{
    register IO_BACKET *it;
    CHAR buf1[256], buf2[512];
    it = &io_table[ioid];
    convert_to_c_string(name, buf1, 256);
    if(expand_path_name(buf1, buf2) != NULL){
	switch(mode){
	  case 0:
	    if(it->in = fopen(buf2, "r")) it->status |= IO_READ;
	    break;
	  case 1:
	    if(it->out = fopen(buf2, "w")) it->status |= IO_WRITE;
	    break;
	  case 2:
	    if(it->out = fopen(buf2, "a")) it->status |= IO_WRITE;
	    break;
	}
    }
    if((it->status&(IO_READ|IO_WRITE)) == 0){
	return(IOSUB_CANNOT_OPEN_FILE);
    }
    it->ts_stt = TS_NORMAL;
    return(IOSUB_SUCCESS);
}
 

/*************************************************************************
*   Close File								 *
*************************************************************************/

int close_file(ioid)
    int	 ioid;	 /* + io device id */
{
    register IO_BACKET *it;
    it = &io_table[ioid];
    if(it->status&IO_READ) fclose(it->in);
    if(it->status&IO_WRITE) fclose(it->out);
    it->status &= ~(IO_READ|IO_WRITE);
    return(IOSUB_SUCCESS);
}


/*************************************************************************
*   Remove File								 *
*************************************************************************/

int remove_file(ioid)
    int	 ioid;	 /* + io device id */
{
    register IO_BACKET *it;
    it = &io_table[ioid];
    it->status = 0;
    it->next = file_pool; file_pool = it;
    return(IOSUB_SUCCESS);
}


/*************************************************************************
*   Write Character							 *
*************************************************************************/

int write_char(ioid, chr)
    int	 ioid;	 /* + io device id */
    int	 chr;	 /* + character code */
{
    register IO_BACKET *it;
    it = &io_table[ioid];
    if(IsWindow(it)) SelectWindow(ioid);
    putc(chr&0xFF, it->out);
    if(IsWindow(it)) fflush(it->out);
    return(IOSUB_SUCCESS);
}


/*************************************************************************
*   Write Line								 *
*************************************************************************/

int write_line(ioid, line)
    int	 ioid;	 /* + io device id */
    CELL *line;	 /* + line (STRING) */
{
    register IO_BACKET *it;
    it = &io_table[ioid];
    if(IsWindow(it)) SelectWindow(ioid);
    fprint_string(it->out, line);
    putc('\n', it->out);
    if(IsWindow(it)) fflush(it->out);
    return(IOSUB_SUCCESS);
}


/*************************************************************************
*   Write Buffer							 *
*************************************************************************/

int write_buffer(ioid, buf)
    int	 ioid;	 /* + io device id */
    CELL *buf;	 /* + buffer (STRING) */
{
    register IO_BACKET *it;
    it = &io_table[ioid];
    if(IsWindow(it)) SelectWindow(ioid);
    fprint_string(it->out, buf);
    if(IsWindow(it)) fflush(it->out);
    return(IOSUB_SUCCESS);
}


/*************************************************************************
*   Write Term								 *
*************************************************************************/

int write_term(ioid, term, len, dep)
    int	 ioid;	 /* + io device id */
    CELL *term;	 /* + term */
    int	 len;	 /* + write length */
    int	 dep;	 /* + write depth */
{
    register IO_BACKET *it;
    it = &io_table[ioid];
    if(IsWindow(it)) SelectWindow(ioid);
    fprint_term(it->out, term, len, dep);
    if(IsWindow(it)) fflush(it->out);
    return(IOSUB_SUCCESS);
}


/*************************************************************************
*   Abort Read Command from Window					 *
*************************************************************************/

int abort_read_command(ioid)
    int	 ioid;	 /* + io device id */
{
    register IO_BACKET *it;
    register CELL *undef;
    it = &io_table[ioid];
    remove_suspended_goals(it->inp_hook);
    reset_var_table(it);
    it->kb_req = 0;
    it->ts_stt = TS_NORMAL;
    AllocUndef(undef);
    SetAll(it->inp_hook, REF, undef, MRBOFF);
    return(IOSUB_SUCCESS);
}

static remove_suspended_goals(cc) 
    CELL *cc;
{
    register SUSPENSION_RECORD *srec;
    register GOAL_RECORD *grec;
    CELL *c;
    CELL tmpc;

    Dereference2(cc, c);
    do{
	if(Typeof(c) == HOOK){	/* case of single waiting */
	    grec = Goalof(c);
	    tmpc = grec->pt; c = &tmpc;
	    FreeGoalRecord(grec, grec->argn);
	}else if(Typeof(c) == MHOOK){	/* case of multiple waiting */
	    SUSPENSION_RECORD  *other;
	    srec = Suspof(c);
	    other = srec->other;
	    if(other == srec){
		grec = srec->suspended;
		FreeGoalRecord(grec, grec->argn);
	    }else{
		while(other->other != srec){
		    other = other->other;
		}
		other->other = srec->other;
	    }
	    FreeSuspensionRecord(srec);
	    c = &(srec->forward);
	}
    }while(Typeof(c) != UNDEF);
}


/*************************************************************************
*   Read Character							 *
*************************************************************************/

int read_char(ioid, chr)
    int	 ioid;	 /* + io device id */
    int	 *chr;	 /* - character code */
{
    register IO_BACKET *it;
    register int ch;
    it = &io_table[ioid];
    if(IsWindow(it) && use_windows){
	if(!request_keyboard(it)) return(IOSUB_CONTINUE);
    }
    ch = GetC(it);
    *chr = ch;
    return(ch == EOF ? IOSUB_END_OF_FILE : IOSUB_SUCCESS);
}


/*************************************************************************
*   Read Line								 *
*************************************************************************/

int read_line(ioid, line)
    int	 ioid;	 /* + io device id */
    CELL *line;	 /* - line (STRING) */
{
    register IO_BACKET *it;
    register int ch;
    it = &io_table[ioid];
    if(it->ts_stt != TS_LINE){
	if(IsWindow(it) && use_windows){
	    if(!request_keyboard(it)) return(IOSUB_CONTINUE);
	}
	ClearTSB(it);
	while((ch = GetC(it)) != '\n' && ch != EOF) PutTSB(ch, it);
	if(HeapRest() <= (it->ts_ptr-it->ts_buf)/4){  /* Redo after GC */
	    it->ts_stt = TS_LINE;
	    SetHeapGcFlag();
	    return(IOSUB_REQUEST_GC);
	}
    }
    it->ts_stt = TS_NORMAL;
    SetAll(line, STRING,
	   convert_to_kl1_string2(it->ts_buf, it->ts_ptr-it->ts_buf), MRBOFF);
    return(ch == EOF ? IOSUB_END_OF_FILE : IOSUB_SUCCESS);
}


/*************************************************************************
*   Read Buffer								 *
*************************************************************************/

int read_buffer(ioid, max, buf)
    int	 ioid;	 /* + io device id */
    int	 max;	 /* + maximun size of buffer */
    CELL *buf;	 /* - line (STRING) */
{
    register IO_BACKET *it;
    register int ch;
    if(HeapRest() <= max/4){  /* Redo after GC */
	SetHeapGcFlag();
	return(IOSUB_REQUEST_GC);
    }
    it = &io_table[ioid];
    if(IsWindow(it)){
	if(use_windows){
	    if(!request_keyboard(it)) return(IOSUB_CONTINUE);
	}
	ClearTSB(it);
	while(max-- > 0 && (ch = GetC(it)) != EOF){
	    PutTSB(ch, it);
	    if(ch == '\n') break;
	}
    }else{
	ClearTSB(it);
	while(max-- > 0 && (ch = getc(it->in)) != EOF){
	    PutTSB(ch, it);
	}
    }
    SetAll(buf, STRING,
	   convert_to_kl1_string2(it->ts_buf, it->ts_ptr-it->ts_buf), MRBOFF);
    return(ch == EOF ? IOSUB_END_OF_FILE : IOSUB_SUCCESS);
}


/*************************************************************************
*   Token Scanner							 *
*************************************************************************/

#define	 SCAN_SUCCESS	0
#define	 SCAN_CONTINUE	1
#define	 SCAN_ERROR    -1


/*************************************************************************
*   Macros to Make Token List						 *
*************************************************************************/

#define MakeAtomToken(head, atom){\
    AllocCons(cons);\
    AllocVector2(vect, 2);\
    SetAll(head, LIST, cons, MRBOFF);\
    SetAll(&cons[0], VECTOR, vect, MRBOFF);\
    if((chr2 = GetC(it)) == '('){\
	vect[1] = const_atom_open;\
    }else{\
	UnGetC(chr2, it);\
	vect[1] = const_atom_atom;\
    }\
    SetAll(&vect[2], ATOM, atom, MRBOFF);\
    head = &cons[1];\
}

#define MakeSignToken(head, atom){\
    AllocCons(cons);\
    AllocVector2(vect, 2);\
    SetAll(head, LIST, cons, MRBOFF);\
    SetAll(&cons[0], VECTOR, vect, MRBOFF);\
    vect[1] = const_atom_sign;\
    SetAll(&vect[2], ATOM, atom, MRBOFF);\
    head = &cons[1];\
}

#define MakeIntegerToken(head, integer){\
    AllocCons(cons);\
    AllocVector2(vect, 2);\
    SetAll(head, LIST, cons, MRBOFF);\
    SetAll(&cons[0], VECTOR, vect, MRBOFF);\
    vect[1] = const_atom_integer;\
    SetAll(&vect[2], INT, integer, MRBOFF);\
    head = &cons[1];\
}

#define MakeFloatToken(head, flot){\
    AllocCons(cons);\
    AllocVector2(vect, 2);\
    SetAll(head, LIST, cons, MRBOFF);\
    SetAll(&cons[0], VECTOR, vect, MRBOFF);\
    vect[1] = const_atom_float;\
    SetAll(&vect[2], FLOAT, flot, MRBOFF);\
    head = &cons[1];\
}

#define MakeStringToken(head, string){\
    AllocCons(cons);\
    AllocVector2(vect, 2);\
    SetAll(head, LIST, cons, MRBOFF);\
    SetAll(&cons[0], VECTOR, vect, MRBOFF);\
    vect[1] = const_atom_string;\
    SetAll(&vect[2], STRING, string, MRBOFF);\
    head = &cons[1];\
}

#define MakeVarToken(head, number, string){\
    AllocCons(cons);\
    AllocVector2(vect, 3);\
    SetAll(head, LIST, cons, MRBOFF);\
    SetAll(&cons[0], VECTOR, vect, MRBOFF);\
    vect[1] = const_atom_d_var;\
    SetAll(&vect[2], INT, number, MRBOFF);\
    SetAll(&vect[3], STRING, string, MRBOFF);\
    head = &cons[1];\
}

#define MakeSpecialToken(head, atom){\
    AllocCons(cons);\
    SetAll(head, LIST, cons, MRBOFF);\
    SetAll(&cons[0], ATOM, atom, MRBOFF);\
    head = &cons[1];\
}

#define MakeIllegalToken(head, string){\
    AllocCons(cons);\
    AllocVector2(vect, 2);\
    SetAll(head, LIST, cons, MRBOFF);\
    SetAll(&cons[0], VECTOR, vect, MRBOFF);\
    vect[1] = const_atom_illegal;\
    SetAll(&vect[2], STRING, string, MRBOFF);\
    head = &cons[1];\
}

#define ContinueTokenList(head, tail){\
    AllocUndef(vect);\
    SetAll(head, REF, vect, MRBOFF);\
    SetAll(tail, REF, vect, MRBOFF);\
}

#define CloseTokenList(head){\
    AllocCons(cons);\
    SetAll(head, LIST, cons, MRBOFF);\
    cons[0] = const_atom_end;\
    cons[1] = const_nil;\
}


/*************************************************************************
*   Read Token								 *
*************************************************************************/

int read_token(ioid, head, tail, vars)
    int	 ioid;		  /* + io device id */
    register CELL *head;  /* - token list head (REF=>UNDEF or LIST or NIL) */
    CELL *tail;		  /* - token list tail (REF=>UNDEF or NIL) */
    int	 *vars;		  /* - number of variable */
{
    register IO_BACKET *it;
    register CELL *cons, *vect;
    register int chr, chr2, sign;
    int x;

    it = &io_table[ioid];
    if(IsWindow(it) && use_windows){
	if(!request_keyboard(it)){
	    ContinueTokenList(head, tail);
	    return(IOSUB_CONTINUE);  /** Date is Not Ready **/
	}
    }
    switch(it->ts_stt){
      case TS_QATOM:
	switch(scan_quote_atom(it)){
	  case SCAN_SUCCESS:
	    MakeAtomToken(head, intern_atom(it->ts_buf));
	    it->ts_stt = TS_NORMAL;
	    break;
	  case SCAN_CONTINUE:
	    ContinueTokenList(head, tail);
	    return(IOSUB_CONTINUE);
	  case SCAN_ERROR:
	    CloseTokenList(head);
	    *vars = reset_var_table(it);
	    it->ts_stt = TS_NORMAL;
	    return(IOSUB_EOF_IN_QUOTE);
	}
	break;
      case TS_STRING:
	switch(scan_string(it)){
	  case SCAN_SUCCESS:
	    MakeStringToken(head, convert_to_kl1_string(it->ts_buf));
	    it->ts_stt = TS_NORMAL;
	    break;
	  case SCAN_CONTINUE:
	    ContinueTokenList(head, tail);
	    return(IOSUB_CONTINUE);
	  case SCAN_ERROR:
	    CloseTokenList(head);
	    *vars = reset_var_table(it);
	    it->ts_stt = TS_NORMAL;
	    return(IOSUB_EOF_IN_QUOTE);
	}
	break;
      case TS_COMMENT:
	switch(scan_comment(it)){
	  case SCAN_SUCCESS:
	    it->ts_stt = TS_NORMAL;
	    break;
	  case SCAN_CONTINUE:
	    ContinueTokenList(head, tail);
	    return(IOSUB_CONTINUE);
	  case SCAN_ERROR:
	    CloseTokenList(head);
	    *vars = reset_var_table(it);
	    it->ts_stt = TS_NORMAL;
	    return(IOSUB_END_OF_FILE);
	}
	break;
    }

    for(;;){
	if(GcFlag_ON()){    /******** Check GC Request ********/
	    ContinueTokenList(head, tail);
	    return(IOSUB_REQUEST_GC);
	}
	chr = GetC(it);
	if(chr == EOF) goto eof_in_term;
	while(IsBlank(chr)){	   /******** Skip Blank ********/
	    if(chr == '\n'){
		if(IsWindow(it) && use_windows){
		    if(!request_keyboard(it)){
			ContinueTokenList(head, tail);
			return(IOSUB_CONTINUE);	 /** Date is Not Ready **/
		    }
		}
	    }
	    chr = GetC(it);
	    if(chr == EOF) goto eof_in_term;
	}
	if(chr == '%'){		 /******** Skip Comment ********/
	    while((chr = GetC(it)) != '\n'){
		if(chr == EOF) goto eof_in_term;
	    }
	    if(IsWindow(it) && use_windows){
		if(!request_keyboard(it)){
		    ContinueTokenList(head, tail);
		    return(IOSUB_CONTINUE);  /** Date is Not Ready **/
		}
	    }
	    continue;
	}
	if(chr == '/'){
	    chr2 = GetC(it);
	    if(chr2 == EOF) goto eof_in_term;
	    UnGetC(chr2, it);
	    if(chr2 == '*'){
		switch(scan_comment(it)){
		  case SCAN_SUCCESS:
		    continue;
		  case SCAN_CONTINUE:
		    ContinueTokenList(head, tail);
		    it->ts_stt = TS_COMMENT;
		    return(IOSUB_CONTINUE);
		  case SCAN_ERROR:
		    CloseTokenList(head);
		    *vars = reset_var_table(it);
		    return(IOSUB_END_OF_FILE);
		}
	    }
	}else if(chr == '.'){	      /******** Check Full Stop ********/
  period:
	    chr2 = GetC(it);
	    if(chr2 == EOF){
  eof_in_term:
		CloseTokenList(head);
		*vars = reset_var_table(it);
		return(IOSUB_END_OF_FILE);
	    }
	    if(IsBlank(chr2)){
		CloseTokenList(head);
		*vars = reset_var_table(it);
		return(IOSUB_SUCCESS);
	    }
	    UnGetC(chr2, it);
	}else if(chr == '+'){	      /******** Check Sign ********/
	    chr2 = GetC(it);
	    if(IsDigit(chr2)){
		sign = ATOM_PLUS;
		chr = chr2;
		goto number;
	    }
	    UnGetC(chr2, it);
	}else if(chr == '-'){
	    chr2 = GetC(it);
	    if(IsDigit(chr2)){
		sign = ATOM_MINUS;
		chr = chr2;
		goto number;
	    }
	    UnGetC(chr2, it);
	}else if(chr == '$'){	      /******** Special ********/
	    chr2 = GetC(it);
	    UnGetC(chr2, it);
	    if(IsAlNum(chr2)){
		scan_alpha_atom(chr, it);
		MakeIllegalToken(head, convert_to_kl1_string(it->ts_buf));
		continue;
	    }
	}

	switch(GetCharType(chr)){
	  case DIGIT:
	    sign = 0;
  number:
	    switch(scan_integer_or_float(sign, chr, it)){
	      case 0:
		if(!conv_to_integer(sign, it->ts_buf, &x)) goto illegal_number;
		if(sign) MakeSignToken(head, sign);
		MakeIntegerToken(head, x);
		continue;
	      case 1:
		if(conv_to_integer(sign, it->ts_buf, &x)){
		    if(sign) MakeSignToken(head, sign);
		    MakeIntegerToken(head, x);
		}else{
		    if(sign) MakeAtomToken(head, sign);
		    MakeIllegalToken(head, convert_to_kl1_string(it->ts_buf));
		}
		chr = '.';
		goto period;
	      case 2:
		if(!string_to_float(it->ts_buf, &x)) goto illegal_number;
		if(sign) MakeSignToken(head, sign);
		MakeFloatToken(head, x);
		continue;
	      case 3:
	      illegal_number:
		if(sign) MakeAtomToken(head, sign);
		MakeIllegalToken(head, convert_to_kl1_string(it->ts_buf));
		continue;
	    }
	  case UPPER_CASE:
	    scan_variable(chr, it);
	    MakeVarToken(head, conv_to_var(it->ts_buf, it),
			       convert_to_kl1_string(it->ts_buf));
	    continue;
	  case LOWER_CASE:
	    scan_alpha_atom(chr, it);
	    MakeAtomToken(head, intern_atom(it->ts_buf));
	    continue;
	  case SYMBOL:
	    scan_symbol_atom(chr, it);
	    MakeAtomToken(head, intern_atom(it->ts_buf));
	    continue;
	  default:
	    switch(chr){
	      case ',':
		MakeSpecialToken(head, ATOM_COMMA);
		continue;
	      case '|':
		MakeSpecialToken(head, ATOM_VLINE);
		continue;
	      case '!':
		MakeAtomToken(head, ATOM_EXCLAMATION);
		continue;
	      case '(':
		MakeSpecialToken(head, ATOM_PAREN_L);
		continue;
	      case ')':
		MakeSpecialToken(head, ATOM_PAREN_R);
		continue;
	      case '[':
		if((chr = GetC(it)) == ']'){
		    MakeAtomToken(head, NIL);
		    continue;
		}else{
		    UnGetC(chr, it);
		    MakeSpecialToken(head, ATOM_BRANKET_L);
		    continue;
		}
	      case ']':
		MakeSpecialToken(head, ATOM_BRANKET_R);
		continue;
	      case '{':
		MakeSpecialToken(head, ATOM_BRACE_L);
		continue;
	      case '}':
		MakeSpecialToken(head, ATOM_BRACE_R);
		continue;
	      case '\'':
		ClearTSB(it);
		switch(scan_quote_atom(it)){
		  case SCAN_SUCCESS:
		    MakeAtomToken(head, intern_atom(it->ts_buf));
		    continue;
		  case SCAN_CONTINUE:
		    ContinueTokenList(head, tail);
		    it->ts_stt = TS_QATOM;
		    return(IOSUB_CONTINUE);
		  case SCAN_ERROR:
		    CloseTokenList(head);
		    *vars = reset_var_table(it);
		    return(IOSUB_EOF_IN_QUOTE);
		}
	      case '"':
		ClearTSB(it);
		switch(scan_string(it)){
		  case SCAN_SUCCESS:
		    MakeStringToken(head, convert_to_kl1_string(it->ts_buf));
		    continue;
		  case SCAN_CONTINUE:
		    ContinueTokenList(head, tail);
		    it->ts_stt = TS_STRING;
		    return(IOSUB_CONTINUE);
		  case SCAN_ERROR:
		    CloseTokenList(head);
		    *vars = reset_var_table(it);
		    return(IOSUB_EOF_IN_QUOTE);
		}
	    }
	}
    }
}


/*************************************************************************
*   Scan Token Subroutine -- Integer/Float				 *
*************************************************************************/

static int scan_integer_or_float(sign, chr, it)
    int sign;
    register int chr;
    register IO_BACKET *it;
{
    register unsigned int base, f;
    ClearTSB(it);
    PutTSB(chr, it);
    base = (unsigned int)GetDigitValue(chr);
    chr = GetC(it);
    while(IsDigit(chr)){
	base = (base*10)+(unsigned int)GetDigitValue(chr);
	PutTSB(chr, it);
	chr = GetC(it);
    }
    if(chr == '\''){
	PutTSB(chr, it);
	chr = GetC(it);
	if(!IsAlNum(chr)){
	    UnGetC(chr, it);
	    PutTSB(0, it);
	    return(3);
	}
	PutTSB(chr, it);
	chr = GetC(it);
	while(IsAlNum(chr)){
	    PutTSB(chr, it);
	    chr = GetC(it);
	}
	UnGetC(chr, it);
	PutTSB(0, it);
	return(sign ? 3 : 0);
    }else if(chr == '.'){
	chr = GetC(it);
	if(!IsDigit(chr)){
	    UnGetC(chr, it);
	    PutTSB(0, it);
	    return(1);
	}
	PutTSB('.', it);
	while(IsDigit(chr)){
	    PutTSB(chr, it);
	    chr = GetC(it);
	}
	f = YES;
	if(chr == 'e' || chr == 'E'){
	    PutTSB(chr, it);
	    chr = GetC(it);
	    if(chr == '+' || chr == '-'){
		PutTSB(chr, it);
		chr = GetC(it);
	    }
	    if(IsDigit(chr)){
		while(IsDigit(chr)){
		    PutTSB(chr, it);
		    chr = GetC(it);
		}
	    }else if(!IsAlpha(chr)){
		UnGetC(chr, it);
		PutTSB(0, it);
		return(3);
	    }
	}
	if(IsAlNum(chr)){
	    f = NO;
	    while(IsAlNum(chr)){
		PutTSB(chr, it);
		chr = GetC(it);
	    }
	}
	UnGetC(chr, it);
	PutTSB(0, it);
	return(f ? 2 : 3);
    }else{
	f = YES;
	if(IsAlNum(chr)){
	    f = NO;
	    while(IsAlNum(chr)){
		PutTSB(chr, it);
		chr = GetC(it);
	    }
	}
	UnGetC(chr, it);
	PutTSB(0, it);
	return(f ? 0 : 3);
    }
}

static int conv_to_integer(sign, c, x)
    int sign;
    register CHAR *c;
    unsigned int *x;
{
    register int base;
    double value;
    value = 0.0;
    switch(sign){
      case 0:
	while(IsDigit(*c)){
	    value = value*10.0+(double)GetDigitValue(*c++);
	    if(IntOverflowP(value)) return(NO);
	}
	if(*c == '\''){
	    if(value < 2.0 || value > 36.0) return(NO);
	    base = (int)value;
	    value = 0.0;
	    c++;
	    while(IsAlNum(*c)){
		if(GetDigitValue(*c) == 0xFF || GetDigitValue(*c) >= base)
		    return(NO);
		value = value*(double)base+(double)GetDigitValue(*c++);
		if(IntOverflowU(value)) return(NO);
	    }
	}
	break;
      case ATOM_PLUS:
	while(IsDigit(*c)){
	    value = value*10.0+(double)GetDigitValue(*c++);
	    if(IntOverflowP(value)) return(NO);
	}
	break;
      case ATOM_MINUS:
	while(IsDigit(*c)){
	    value = value*10.0+(double)GetDigitValue(*c++);
	    if(IntOverflowM(value)) return(NO);
	}
	break;
    }
    *x = (unsigned int)value;
    return(YES);
}


/*************************************************************************
*   Scan Token Subroutine -- Variable/Atom				 *
*************************************************************************/

static scan_variable(chr, it)
    register int chr;
    register IO_BACKET *it;
{
    ClearTSB(it);
    PutTSB(chr, it);
    chr = GetC(it);
    while(IsAlNum(chr)){ PutTSB(chr, it); chr = GetC(it); }
    UnGetC(chr, it);
    PutTSB(0, it);
}

static scan_alpha_atom(chr, it)
    register int chr;
    register IO_BACKET *it;
{
    ClearTSB(it);
    PutTSB(chr, it);
    chr = GetC(it);
    while(IsAlNum(chr)){ PutTSB(chr, it); chr = GetC(it); }
    UnGetC(chr, it);
    PutTSB(0, it);
}

static scan_symbol_atom(chr, it)
    register int chr;
    register IO_BACKET *it;
{
    ClearTSB(it);
    PutTSB(chr, it);
    chr = GetC(it);
    while(IsSymbol(chr)){ PutTSB(chr, it); chr = GetC(it); }
    UnGetC(chr, it);
    PutTSB(0, it);
}


/*************************************************************************
*   Scan Token Subroutine -- Quoted Object				 *
*************************************************************************/

static int scan_quote_atom(it)
    register IO_BACKET *it;
{
    register int chr;
    for(;;){
	chr = GetC(it);
	if(chr == EOF){
	    return(SCAN_ERROR);
	}else if(chr == '\n' && IsWindow(it)){
	    if(!request_keyboard(it)){
		PutTSB(chr, it);
		return(SCAN_CONTINUE);	/** Date is Not Ready **/
	    }
	}else if(chr == '\''){
	    if((chr = GetC(it)) != '\''){
		UnGetC(chr, it);
		PutTSB(0, it);
		return(SCAN_SUCCESS);
	    }
	}
	PutTSB(chr, it);
    }
}

static int scan_string(it)
    register IO_BACKET *it;
{
    register int chr;
    for(;;){
	chr = GetC(it);
	if(chr == EOF){
	    return(SCAN_ERROR);
	}else if(chr == '\n' && IsWindow(it)){
	    if(!request_keyboard(it)){
		PutTSB(chr, it);
		return(SCAN_CONTINUE);	/** Date is Not Ready **/
	    }
	}else if(chr == '"'){
	    if((chr = GetC(it)) != '"'){
		UnGetC(chr, it);
		PutTSB(0, it);
		return(SCAN_SUCCESS);
	    }
	}
	PutTSB(chr, it);
    }
}

static int scan_comment(it)
    register IO_BACKET *it;
{
    register int chr;
    chr = GetC(it);
    for(;;){
	if(chr == EOF){
	    return(SCAN_ERROR);
	}else if(chr == '\n' && IsWindow(it)){
	    if(!request_keyboard(it)){
		return(SCAN_CONTINUE);	/** Date is Not Ready **/
	    }
	}else if(chr == '*'){
	    if((chr = GetC(it)) == '/'){
		return(SCAN_SUCCESS);
	    }
	}else{
	    chr = GetC(it);
	}
    }
}


/*************************************************************************
*   Token Scanner Buffer Support					 *
*************************************************************************/

static expand_ts_buffer(it)
    register IO_BACKET *it;
{
    register int siz, i;
    register CHAR *old, *new;
    CHAR *malloc();
    old = it->ts_buf;
    siz = it->ts_siz;
    new = malloc(siz*2);
    if(new == NULL){
	Error("Not Enough Memory (malloc failure) -- Aborted.");
	exit_pdss(1);
    }
    bcopy(old, new, siz);
    free(old);
    siz *= 2;
    if(IsWindow(it)){
	it->ts_buf = new;
	it->ts_siz = siz;
    }else{
	for(i = MAX_OF_WINDOW; i < MAX_OF_WINDOW+MAX_OF_FILE; i++){
	    io_table[i].ts_buf = new;
	    io_table[i].ts_siz = siz;
	}
    }
    it->ts_ptr = new+(it->ts_ptr-old);
}


/*************************************************************************
*   Variable Table							 *
*************************************************************************/

static int reset_var_table(it)
    register IO_BACKET *it;
{
    register int i;
    for(i=0; i<VT_HASH; i++) it->var[i] = NULL;
    i = it->var_num;
    it->var_num = 0;
    it->vt_ptr = it->vt_mem;
    return(i);
}

static VAR_ENTRY *alloc_var_table(size, it)
    int size;
    IO_BACKET *it;
{
    register CHAR *p, *q;
    CHAR *buf;
    VAR_ENTRY **v;
    int offset, i;
    size += sizeof(VAR_ENTRY);
    size = (size+3)&0xFFFFFFFC;
    while(it->vt_ptr+size > it->vt_mem+it->vt_siz){
	buf = malloc(it->vt_siz*2);
	if(buf == NULL){
	    Error("Not Enough Memory (malloc failure) -- Aborted.");
	    exit_pdss(1);
	}
	p = it->vt_mem; q = buf;
	offset = q-p;
	while(p < it->vt_ptr) *q++ = *p++;
	for(i=0; i<VT_HASH; i++){
	    v = &(it->var[i]);
	    while(*v){
		*v = (VAR_ENTRY *)((CHAR *)(*v)+offset);
		v = &((*v)->next);
	    }
	}
	free(it->vt_mem);
	it->vt_mem = buf;
	it->vt_ptr += offset;
	it->vt_siz *= 2;
    }
    p = it->vt_ptr;
    it->vt_ptr += size;
    return((VAR_ENTRY *)p);
}

static int conv_to_var(name, it)
    CHAR *name;
    IO_BACKET *it;
{
    register VAR_ENTRY *p;
    register int hash;
    register CHAR *s;
    if(name[0]=='_' && name[1]==0) return(it->var_num++);
    s = name;
    hash = 0;
    while(*s) hash = (hash*37 + *s++)&(VT_HASH-1);
    for(p = it->var[hash]; p != NULL; p = p->next){
	if(strcmp(name, p->name) == 0) return(p->number);
    }
    p = alloc_var_table(strlen(name), it);
    p->number = it->var_num++;
    strcpy(p->name, name);
    p->next = it->var[hash];
    it->var[hash] = p;
    return(p->number);
}
