#include "lisp.h"

/* reader for SIMULISP */

extern int str_eql();
FILE *infile;		/* current input file */
extern FILE *logfile;	/* current log file, if any */
int getc_flag = 0;	/* <>0 if next character is from ungetc call */
int lineno = 1;		/* current line number */
object dot = NULL;	/* our own copy of the atom "." */
object quote = NULL;	/* our own copy of the atom "quote" */

double atof();
object r_obj(), m_num(), m_float(), r_cons();

/* just like getc, but copies of user typein are made to log file */
int lgetc(file)
  FILE *file;
  {	register int ch = getc(file);

	if (logfile!=NULL && file==stdin && (!getc_flag) && ch!=EOF)
	  putc(ch,logfile);
	getc_flag = 0;
	return(ch);
}

/* just like lgetc, but characters between ; and <newline> are ignored in the
 * input stream.
 */
int nlgetc(file)
  FILE *file;
  {	register int ch = lgetc(file);

	if (ch == ';') while ((ch = lgetc(file))!=EOF && ch!='\n');
	if (ch == '\n') lineno++;
	return(ch);
}

/* just like ungetc except newlines cause line counter to be decremented */
#define nlungetc(c,file) \
  { if (c == '\n') lineno--; ungetc(c,file); getc_flag = 1;}

/* read an object from a file */
object obj_read(ifile,cmdline)
  FILE *ifile;
  int cmdline;
  {	infile = ifile;
	if (dot == NULL) dot = intern(".");
	if (quote == NULL) quote = intern("quote");
	return(r_obj(0,cmdline));
}	

/* read an object, level == 0 if at top level of read, cmdline <> 0 if special
 * command line processing should be done.
 */
object r_obj(level,cmdline)
  {	register char *t;
	register int ch;
	register cons *p,*q;
	char token[500];
	object obj = NULL;
	object r;
	int num,again;

	t = token;
	while (1) switch (ch = nlgetc(infile)) {
	  case EOF:	if (t != token) goto endtoken;
			return(intern("end-of-file"));

	  case '.':	if (t == token) goto chtoken;
			*t = 0;
			if (m_num(token) != NULL) goto chtoken;
			if ((ch = nlgetc(infile))<=' ' || ch==')') {
			  nlungetc(ch,infile);
			  ch = '.';
			  goto chtoken;
			} else nlungetc(ch,infile);
			r = al_obj(CONS);
			push(r);
			p = (cons *)ADDR(r);
			p->car = intern("-struct-");
			p->cdr = al_obj(CONS);
			p = (cons *)ADDR(p->cdr);
			if ((p->car = m_num(token)) == NULL) p->car = intern(token);
			do {
			  again = 0;
			  p->cdr = al_obj(CONS);
			  p = (cons *)ADDR(p->cdr);
			  p->cdr = nil;
			  if ((ch = nlgetc(infile)) == '(') p->car = r_cons(0);
			  else {
			    t = token;
			    do *t++ = ch;
			    while ((ch = nlgetc(infile))!='.' && ch!=')' && ch>' ');
			    if (ch == '.') {
			      if ((ch = nlgetc(infile))<=' ' || ch==')') *t++ = '.';
			      else again = 1;
			    }
			    nlungetc(ch,infile);
			    *t = 0;
			    if ((p->car = m_num(token)) == NULL) p->car = intern(token);
			  }
			} while (again || (ch = nlgetc(infile)) == '.');
			nlungetc(ch,infile);
			pop(1);
			return(r);

			/* put terminating newlines back into input stream
			 * in case top level command reader will need it...
			 */
	  case '\n':	if (t != token) nlungetc(ch,infile);

	  case ' ':
	  case '\t':	if (t == token) continue;
	  endtoken:	*t = 0;
			if ((obj = m_num(token)) != NULL) return(obj);
			if (str_eql(token,"nil")) return(nil);
			if (token[0] == 0xff) {
			   return(intern("end-of-file"));
			}
			else return(intern(token));

	  case '"':	if (t != token) goto chtoken;
			num = 0;
			while ((ch = lgetc(infile))!='"' && ch!=EOF) {
		gotchar:  if (ch == 0134) switch(ch = lgetc(infile)) {
			      case 'n':	*t++ = '\n'; break;
			      case 'r': *t++ = '\r'; break;
			      case 't': *t++ = '\t'; break;
			      case 0134: *t++ = 0134; break;

			      default:  if (ch<'0' || ch>'9') {
					  *t++ = 0134;
					  *t++ = ch;
					  break;
					}
					while (ch>='0' && ch<='9') {
					  num = (num << 3) + ch - '0';
					  ch = lgetc(infile);
					}
					*t++ = num;
					goto gotchar;
			    }
			  else *t++ = ch;
			  if (ch == '\n') {
			    lineno++;
			    error("; warning: string extends past newline");
			  }
			}
			*t = 0;
			return(m_string(token));

	  case '\'':	if (t != token) goto chtoken;
			push(r_obj(1,0));
			push(al_obj(CONS));
			obj = al_obj(CONS);
			p = (cons *)ADDR(obj);
			p->car = quote;
			p->cdr = pop(1);
			p = (cons *)ADDR(p->cdr);
			p->car = pop(1);
			p->cdr = nil;
			return(obj);

	  case '(':	if (t == token) return(r_cons(0));
	  chsave:	nlungetc(ch,infile);
			goto endtoken;

	  case ')':	if (t!=token || level!=0) goto chsave;
			else continue;

	  chtoken:
	  default:	/* if user types in a line at top level that starts
			 * with an atom it gets special treatment:
			 *	a b c d e
			 * turns into
			 *	(a '(b c d e))
			*/
			if (cmdline && t==token && level==0) {
			  nlungetc(ch,infile);
			  obj = r_cons(1);
			  push(obj);
			  push(al_obj(CONS));
			  push(al_obj(CONS));
			  obj = al_obj(CONS);
			  p = (cons *)ADDR(obj);
			  p->car = pop(1);
			  p->cdr = nil;
			  p = (cons *)ADDR(p->car);
			  p->car = quote;
			  p->cdr = pop(1);
			  p = (cons *)ADDR(p->cdr);
			  p->cdr = nil;
			  r = pop(1);
			  q = (cons *)ADDR(r);
			  p->car = q->cdr;
			  q->cdr = obj;
			  return(r);
			}
			*t++ = ch;
			continue;
	 }
}

/* read what may well turn into a list */
object r_cons(cmd)
  int cmd;
  {	register int ch;
	register cons *last = NULL;
	cons *llast = NULL;
	cons *lllast = NULL;
	int startline = lineno;
	object obj,cell,o;

	/* see what next non-spacing character is */
	while ((ch = nlgetc(infile))<=' ' && ch != EOF && ch != 0xff);
	if (ch == EOF || ch == 0xff) goto eof;
	nlungetc(ch,infile);

	push(nil);		/* used to protect objects for gc'ing */
 
	while (1) {
	/* when we get to end of list, return what we've got */
	  if (ch==')' || (cmd==1 && ch=='\n')) {
	    lgetc(infile);
	    /* if at least 3 objects and one before last is dot, make dotted pair */
	    if ((llast != NULL) && ((last->car) == dot)) lllast->cdr = last->car;
	    return ((last==NULL) ? pop(1) : pop(2));
	  }

	/* get next object on list and see what char follows it */
	  obj = r_obj(1,0);
	  nth_exch((last==NULL)?0:1,obj);

	  while ((ch = nlgetc(infile))<=' ' && ch!=EOF)
	    if (ch=='\n' && cmd==1) break;
	  if (ch == EOF) {
   eof:	    error("; unexpected end of file, no match for open paren on line %d\n",startline);
	    ch = ')';
	  }
	  nlungetc(ch,infile);

	/* get a new cons, make object just read its car, and stick it at end of list */
	  lllast = llast;
	  llast = last;
	  if (last != NULL) { last->cdr = al_obj(CONS); last = (cons *)ADDR(last->cdr); }
	  else { cell = push(al_obj(CONS)); last = (cons *)ADDR(cell); }
	  last->car = obj;
	  last->cdr = nil;
	}
}

/* see if token can be made into a number, if so make a lisp object and return it */
object m_num(token)
  register char *token;
  {	register int ans = 0;
	int base = 10;
	int sign = 1;
	object obj;

	if ((obj = m_float(token)) != NULL) return(obj);

	if (*token == '-') { sign = -1; token++; }
	else if (*token == '+') token++;

	if (*token == 0) return(NULL);
	if (*token == '0') { token++; base = 8;	}

	while (*token>='0' && *token<=(base+'0')) ans = ans*base + *token++ - '0';
	if (*token == 0) { SETTYPE(obj,FIXNUM); SETVALUE(obj,ans*sign); return(obj); }
	return(NULL);
}

/* see if token looks like a floating point number */
object m_float(token)
  char *token;
  {	register char *p = token;
	int seendig = 0;
	object obj;

	/* skip over leading sign, if any */
	if (*p == '-' || *p == '+') p++;
	if (*p == 0) return(NULL);

	/* now skip over sequence of digits */
	while (*p >= '0' && *p <= '9') { p++; seendig = 1; }
	if (*p == 0) return(NULL);

	/* next character should be decimal point or 'e' */
	if (*p == '.') {
	  p++;
	  while (*p >= '0' && *p <= '9') { p++; seendig = 1; }
	  if (*p == 0) {
	    if (seendig) goto gotone;
	    else return(NULL);
	  }
	}

	/* here to skip over exponent */
	if (*p == 'e' || *p == 'E') {
	  p++;
	  if (*p == '-' || *p == '+') p++;
	  while (*p >= '0' && *p <= '9') p++;
	  if (*p==0 && seendig) goto gotone;
	}

	return(NULL);

gotone:	obj = al_obj(FLONUM);
	((flonum *)ADDR(obj))->flo_value = atof(token);
	return(obj);
}