/* FILE: lsp.c
 *
 * Functions to read and write LISP syntax files from C.
 *
 */
#include <stdio.h>
#include <string.h>
#include <ctype.h>
#include "lsp.h"


/*
 * local function to decide wheter a character is within some set
 */
static isinset(int ch,char *string)
{
   while( ch != *string && *++string );
   return *string;
}



/*
 * Local defines used within this file.
 */
#define getnode() (LVAL)malloc(sizeof(struct NODE))
#define SRC_WIDTH 80  /* The width of the screen for pretty printing. */
#define WSPACE "\t \f\r\n"
#define CONST1 "!$%&*-+./0123456789:<=>?@[]^_{}~"
#define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
#define NUMSET "0123456789"
#define NUMSET1 "0123456789-+"
#define numeral1(x) (isinset((x),NUMSET1))
#define space_p(x) isinset((x),WSPACE)
#define const_p(x) (isinset((x),CONST1)||isinset((x),CONST2))
#define const_p1(x) ((const_p(x))&&(!numeral1(x)))
#define numeral(x) (isinset((x),NUMSET))
#define spaceat(x,f) while(space_p(((x)=getC((f)))))

/*
 * Local variables.
 */
static FILE *f;
static int tabpos,scrsize;
static char buffer[MAXSTRING];

/*
 * StrDup well known, however rarely implemented function
 * This is global, because it is used in opt.c as well.
 * If you use this source file somewhere else in another
 * package and have problems you can make it local.
 */
char * StrDup(char *s)
{
   char *p;
   char *malloc(int);

   p = (char *)malloc(sizeof(char)*(strlen(s)+1));
   if( p == NULL )return NULL;
   strcpy(p,s);
   return p;
}
/*-----------------------------------------------------*/
/* Calculate 10^[a]                                    */
static double pow10(double a)
{
   int j,i;
   double pro,k;

   for( (i= a<0.0) && (a = -a) , j=(int)a , pro=1.0 , k=10; j ;
       j%2 && (pro *=k) , j /= 2 , k *= k )
      continue;
   i && (pro=1.0/pro);
   return pro;
}
/*
 * Convert a string to double or long.
 * string should contain the string
 * whatis 0 string is invalid
 *        1 string is float
 *        2 string is integer
 * dres   contains the result if whatis 1
 * lres   contains the result if whatis 2
 *
 * First version if MINIMOS in FORTRAN
 * Second version in MINIMOS2LISP converter
 * This version in lsp.c
 *   (Could you tell the origin?)
 */
static void cnumeric(char *string, int *whatis, double *dres, long *lres)
{
   double intpart,fracpart,exppart,man;
   int i,sig,esig;

   i=1;
   sig= 1;
   esig=1;
   (( *string == '-' && (sig=(-1)) ) || *string == '+') && string++;
   for( intpart = 0 ; numeral(*string) ; string++ )
   {
      intpart *= 10;
      intpart += (*string)-'0';
   }
   if( *string == '.' )
      for( man = 1.0 , fracpart = 0.0 ,i = 0 , string ++ ; numeral(*string)
	  ; string ++ )
	 fracpart += (man *= 0.1) * ((*string)-'0');
   if( *string == 'E' )
   {  string++;
      (*string == '-' && (esig=(-1))) || *string == '+' && string++;
      for( exppart=0.0 , i = 0 ; numeral(*string) ; string++)
	 exppart = 10*exppart + (*string)-'0';
   }
   while( space_p(*string) )string++;
   if( *string )
   {
      *whatis = 0;
      return;
   }
   if( i )
   {
      *lres   = sig*(long)intpart;
      *whatis = 2;
      return;
   }
   *dres = sig*(intpart + fracpart)*pow10(esig*exppart);
   *whatis = 1;
   return;
}

/*
 * getC to read skipping the comments from the file.
 *
 * Each comment returns a newline or EOF
 *
 * Reading strings normal getc is used!
 */
int getC(FILE *f)
{
   int ch;

   if( (ch=getc(f)) == ';' )
      while( (ch=getc(f)) != '\n' && ch != EOF )
	    ;
   return ch;
}

/*
 * Create a new cons node.
 */
LVAL cons(void)
{
   LVAL p;
   char *malloc();

   if( null((p = getnode())) )
      return NIL;
   settype(p,NTYPE_CON);
   setcar(p,NIL);
   setcdr(p,NIL);
   return p;
}

/*
 * Create a new node with the given type.
 */
LVAL newnode(unsigned char type)
{
   LVAL p;
   char *malloc();

   if( null((p = getnode())) )
      return NIL;

   settype(p,type);
   switch( type )
   {
   case NTYPE_CON:
      ReportLog('I',"Invalid use of function ``newnode''!");
   case NTYPE_FLO:
      setfloat(p,0.0);
      break;
   case NTYPE_INT:
      setint(p,0);
      break;
   case NTYPE_STR:
      setstring(p,NULL);
      break;
   case NTYPE_SYM:
      setsymbol(p,NULL);
      break;
   case NTYPE_CHR:
      setchar(p,(char)0);
      break;
   default:
      ReportLog('I',"Very invalid use of ``newnode''!");
   }
   return p;
}
/*
 * Set comparision length and case sensitivity flag.
 * SymbolLength == -1 means exact match for any length.
 */
static int SymbolLength=0,CaseFlag=1;
LVAL setflags(int Sl, int Cf)
{
   SymbolLength = Sl;
   CaseFlag     = Cf;
   return NIL;
}

/*
 * Compare a symbol to a string.
 * If the symbol is the same as the string then it return the pointer to the
 * symbol! (Garanteed.) Otherwise it returns NIL.
 *
 * The symbol and the string matches if the first SymbolLength characters
 * are matching, and CaseFlag says the case sensitivity.
 *
 */
LVAL symcmp(LVAL p, char *s)
{
   int i;
   char *w,cw,cs;

   if( null(p) || !symbolp(p) )return NIL;
   /* NOTE: A string should not be so long that decrementing -1 gets to 0! */
   for( i = SymbolLength , w = getstring(p) ;
        i && *s && *w ; i-- , s++ , w++  )
   {
      cw = !CaseFlag && islower(*w) ? toupper(*w) : *w;
      cs = !CaseFlag && islower(*s) ? toupper(*s) : *s;
      if( cw != cs )
	 return NIL;
   }
   return  i && ( *w || *s ) ? NIL : p;
}

/*
 * Get the nth assoc from a list.
 * This works only for *symbols* !!!
 * The second argument should be a string for symbol comparision.
 */
LVAL nthsassoc(LVAL p, char *s, int n)
{
   LVAL fp;

   if( null(p) || !consp(p) )return NIL;
   for( fp = p ; fp ; fp = cdr(fp) )
      if( !car(fp) || !consp(car(fp)) || !symbolp(caar(fp)) )
	 continue;
      else
	 if( symcmp(caar(fp),s) && !--n )
	    return car(fp);
   return NIL;
}


/*
 * Free a list.
 */
LVAL freelist(LVAL p)
{

   if( null(p) || freep(p) )return NIL;
   if(consp(p) )
   {
      settype(p,NTYPE_FRE);
      freelist(car(p));
      freelist(cdr(p));
   }
   if( stringp(p) )
      free(getstring(p));
   else if( symbolp(p) )
      free(getsymbol(p));
   free(p);
   return NIL;
}


/*
 * flatc returns the length of printstring
 */
static int flatc(LVAL p)
{
   int j;
   LVAL fp;

   if( null(p) )return 3;
   switch(gettype(p))
   {
   case NTYPE_CON:
      for( fp = p , j = 1/*(*/ ; fp ; fp = cdr(fp) )
	 j+= flatc(car(fp))+1/*space*/;
      return p ? j : 1+j; /*) was calculated as a space. (Not always.) */
   case NTYPE_FLO:
      sprintf(buffer,"%lf",getfloat(p));
      break;
   case NTYPE_INT:
      sprintf(buffer,"%ld",getint(p));
      break;
   case NTYPE_STR:
      sprintf(buffer,"\"%s\"",getstring(p));
      break;
   case NTYPE_SYM:
      sprintf(buffer,"%s",getsymbol(p));
      break;
   case NTYPE_CHR:
      sprintf(buffer,"\#\\%c",getchr(p));
      break;
   default:
      ReportLog('I',"Invalid node type in pprinting loop.");
   }
   return strlen(buffer);
}
/*
 * local pprinting function
 *
 * Do not try to understand how it works. When I wrote it I and God knew how
 * it works. I have forgotten...
 * Ask God!
 *
 * p is the expression is to print.
 * k is magic argument to handle non-algorithmic behaviour of pprint.
 *   (k holds internal beautiness (!) factor of printout. (AI!) :-)
 *  Serious:
 *    k=1  we dunno anything about expression
 *    k=1  the tabulatig spaces were alrady printed!
 *    k=2  we are in flatc mode
 *          -dont print tabulating space
 *          -there is no need to check flatc size.
 */
static LVAL __pprint(LVAL p,int k)
#define _pprint(x) __pprint((x),1)
{
   LVAL fp;
   int j;
   char *s;

   if( null(p) )
   {
      fprintf(f,"NIL");
      return NIL;
   }
   switch(gettype(p))
   {
   case NTYPE_CON:
      if( k == 2 || flatc(p) < scrsize-tabpos )
      {
	 /* Print in flat mode. */
	 if( k == 1 )
	    fprintf(f,"%*s(",tabpos,"");
	 else
	    fprintf(f,"(");
	 for( fp = p ; fp ;  )
	 {
	    __pprint(car(fp),2);
	    fp = cdr(fp);
	    if( fp )
	       fprintf(f," ");
	 }
	 fprintf(f,")");
	 return NIL;
      }
      if( atom(fp=car(p)) || flatc(fp) < (scrsize-tabpos)/2 )
      {
	 fprintf(f,"(");
	 scrsize--; /* Schrink screen size thinking of the closing paren. */
	 j = flatc(fp)+2;/* ([flatc]SPACE */
	 tabpos += j;
	 __pprint(fp,0);
	 if( cdr(p) )
	 {
	    fprintf(f," ");
	    __pprint(cadr(p),0);
	    fprintf(f,"\n");
	    for( fp = cdr(cdr(p)) ; fp ; )
	    {
	       fprintf(f,"%*s",tabpos,"");
	       __pprint(car(fp),0);
	       fp = cdr(fp);
	       if( fp )
		  fprintf(f,"\n");
	    }
	 }
	 tabpos -= j;
	 fprintf(f,")");
	 scrsize++;
	 return NIL;
      }
      fprintf(f,"(");
       /* Schrink screen size thinking of the closing paren. */
      scrsize--;
      tabpos++;
      __pprint(car(p),0);
      if( fp = cdr(p) )
	 fprintf(f,"\n");
      while( fp )
      {
	 fprintf(f,"%*s",tabpos,"");
	 _pprint(car(fp));
	 fp = cdr(fp);
            if( fp )
               fprintf(f,"\n");
      }
      tabpos--;
      fprintf(f,")");
      scrsize++;
      return NIL;
   case NTYPE_FLO:
      fprintf(f,"%lf",getfloat(p));
      return NIL;
   case NTYPE_INT:
      fprintf(f,"%ld",getint(p));
      return NIL;
   case NTYPE_STR:
      fprintf(f,"\"");
      for( s=getstring(p) ; *s ; s++ )
	 switch( *s )
	 {                      /* Handle spacial characters. */
	 case '\n':
	    fprintf(f,"\\n");
	    break;
	 case '\t':
	    fprintf(f,"\\t");
	    break;
	 case '\r':
	    fprintf(f,"\\r");
	    break;
	 case '\b':
	    fprintf(f,"\\b");
	    break;
	 case '\f':
	    fprintf(f,"\\f");
	    break;
	 default:
	    fprintf(f,"%c",*s);
	    break;
	 }
      fprintf(f,"\"");
      return NIL;
   case NTYPE_SYM:
      fprintf(f,"%s",getsymbol(p));
      return NIL;
   case NTYPE_CHR:
      fprintf(f,"\#\\%c",getchr(p));
      return NIL;
   default:
      ReportLog('I',"Invalid node type in pprinting loop.");
   }
   fprintf(f,buffer);
   return NIL;
}

/*
 * Pretty print a list.
 * pp-list
 *  Pretty-print a list expression.
 *      IF <the flatsize length of *expr is less than pp-maxlen*>
 *          THEN print the expression on one line,
 *      ELSE
 *      IF <the car of the expression is an atom> or
 *         <the flatsize length of the car of the expression is less than
 *          the half of the rest of the space>
 *          THEN print the expression in the following form:
 *                  "(<item0> <item1>
 *                            <item2>
 *                              ...
 *                            <itemn> )"
 *      ELSE
 *      IF <the car of the expression is a list>
 *          THEN print the expression in the following form:
 *                  "(<list1>
 *                    <item2>
 *                      ...
 *                    <itemn> )"
 *
 *
 * If an expression can not fit into the area
 * | -------------------------------------------------------- | then it falls out and gets the end into the new line without printing \n :-(
 */
LVAL pprint(LVAL p, FILE *file)
{
   /* We start in the first column. */
   tabpos = 0;
   /* Screen is not schrinked. */
   scrsize = SCR_WIDTH;
   f = file;
   _pprint(p);
   fprintf(f,"\n");
   return NIL;
}
/*
 * local function to read an expression
 */
static LVAL _readexpr(FILE *f)
{
   int ch,i;
   LVAL p;
   char *s;
   double dval;
   long lval;


   spaceat(ch,f);
   if( ch == EOF )
   {
      ReportLog('F',"Unexpected EOF");
   }
   if( ch == ')' )
   {
      ReportLog('F',"Unexpected \')\'");
   }

   if( ch == '(' )/* Read a cons node. */
      return readcons(f);

   /**** Note: XLISP allows 1E++10 as a symbol. This is dangerous.
	 We do not change XLISP (so far), but here I exclude all symbol
	 names starting with numeral. */
   if( const_p1(ch) )/* Read a symbol. */
   {
      for( i = 0 ; i < MAXSTRING && const_p(ch) ; i++ )
	 buffer[i]=ch,
	 ch = getC(f);
      ungetc(ch,f);
      if( i == MAXSTRING )
      {
	 buffer[ERRSTRLEN] = (char)0;
         ReportLog('F',"Too long string >>%s...<<",buffer);
      }
      buffer[i]=(char)0;
      /* Recognize NIL and nil symbols. */
      if( !strcmp(buffer,"NIL") || !strcmp(buffer,"nil") )
	 return NIL;
      p = newsymbol();
      s = StrDup( buffer );
      if( null(p) || s == NULL )
      {
         ReportLog('F',"Memory allocation error within ``_readexpr''.");
      }
      setsymbol(p,s);
      return p;
   }
   if( ch == '\"' )/* Read a string. */
   {
      /* Simple version. No new line within strings. */
      /* NOTE: within string we read direct from the file, without comment
	 filtering! */
      ch = getc(f);/* Eat the " character. */
      for( i = 0 ; i < MAXSTRING && ch != '\"' ; i++ )
      {
	 if( ch == '\\' )
	 {
	    ch = getc(f);
	    if( ch == '\n' )
	    {
               ReportLog('F',"End of line quoted in string.");
	    }
	    if( ch == 'n' || ch == 'N' )
	    {
	       buffer[i] = '\n';
	       ch = getc(f);
	       continue;
	    }
	    if( ch == 'r' || ch == 'R' )
	    {
	       buffer[i] = '\r';
	       ch = getc(f);
	       continue;
	    }
	    buffer[i] = ch;
	    ch = getc(f);
	    continue;
	 }
	 buffer[i] = ch;
	 ch = getc(f);
      }
      if( i == MAXSTRING )
      {
	 buffer[ERRSTRLEN] = (char)0;
         ReportLog('F',"Too long string >>%s...<<",buffer);
      }
      buffer[i] = (char)0;
      p = newstring();
      s = StrDup( buffer );
      if( null(p) || s == NULL )
      {
         ReportLog('F',"Memory Allocation Error Within ``_Readexpr''.");
      }
      setstring(p,s);
      return p;
   }
   if( numeral1(ch) )
   {
      for( i = 0 ; i < MAXSTRING && isinset(ch,"0123456789+-eE.") ; i++ )
      {
	 buffer[i] = ch;
	 ch = getC(f);
      }
      ungetc(ch,f);
      if( i == MAXSTRING )
      {
	 buffer[ERRSTRLEN] = (char)0;
         ReportLog('F',"Too long string >>%s...<<",buffer);
      }
      buffer[i] = (char)0;
      cnumeric(buffer,&i,&dval,&lval);
      switch( i )
      {
      case 0:
         ReportLog('F',"Bad numeric format >>%s<<",buffer);
      case 1:
	 /* A float number is coming. */
	 p = newfloat();
	 if( null(p) )
	 {
            ReportLog('F',"Memory allocarion error in ``_readexpr''.");
	 }
	 setfloat(p,dval);
	 return p;
      case 2:
	 /* An integer is coming. */
	 p = newint();
	 if( null(p) )
	 {
            ReportLog('F',"Memory allocarion error in ``_readexpr''.");
	 }
	 setint(p,lval);
	 return p;
      default:
         ReportLog('F',"Internal error in ``_readexpr''.");
         ReportLog('F',"Bad ``whatis'' returned from ``cnumeric''.");
      }
   }
   ReportLog('F',"Invalid character >>%d<<.",ch);
}

/*
 * local function to read a cons node
 */
LVAL readcons(FILE *f)
{
   int ch;

   spaceat(ch,f);
   if( ch == ')' )return NIL;
   ungetc(ch,f);
   return readlist(f);
}

/*
 * Read a list from a file.
 * The opening '(' character should be away already!
 */
LVAL readlist(FILE *f)
{
   int ch;
   LVAL p,q;

   spaceat(ch,f);
   if( ch == ')' )return NIL;
   ungetc(ch,f);
   q = cons();
   if( null(q) )
   {
      ReportLog('F',"Memory allocation error in ``readlist''.");
   }
   p = _readexpr(f);
   setcar(q,p);
   setcdr(q,readlist(f));
   return q;
}


/*
 * Read an expression from a file.
 */
LVAL readexpr(FILE *f)
{
   int ch;

   spaceat(ch,f);
   if( ch == EOF )return NIL;
   ungetc(ch,f);
   return _readexpr(f);
}

/*
 *  Reads an expression and forgets
 */
LVAL skipexpr(FILE *f)
{
   LVAL p;

   p = readexpr(f);
   freelist(p);
   return NIL;
}

/*
 * Calculates the length of a list.
 */
int llength(LVAL p)
{
   int k;

   for( k = 0 ; p ; k++ )
      p = cdr(p);
   return k;
}


/*
 * Returns the nth element of a list.
 */
LVAL nth(int n, LVAL p)
{
   LVAL q;

   for( q = p ; n && q ; q = cdr(q) )n--;

   return q ? car(q) : NIL;
}

/*
 * Returns the nthcdr element of a list.
 */
LVAL nthcdr(int n, LVAL p)
{
   LVAL q;

   for( q = p ; n && q ; q = cdr(q) )n--;

   return q;
}

/*
 * Returns the character code of a character.
 */
LVAL char_code(LVAL p)
{
   LVAL q;

   if( null(p) || !characterp(p) )return NIL;
   q = newint();
   setint(q,(int)getchr(p));
   return q;
}
/*
 * Returns the character character of a code.
 */
LVAL code_char(LVAL p)
{
   LVAL q;

   if( null(p) || !integerp(p) )return NIL;
   q = newchar();
   setchar(q,(char)getint(p));
   return q;
}

/*
 * Returns the lower case equivalent of the character.
 */
LVAL char_downcase(LVAL p)
{
   LVAL q;

   if( null(p) || !characterp(p) )return NIL;
   q = newchar();
   setchar(q, (isalpha(getchr(p)) && isupper(getchr(p))) ?
	   tolower((int) getchr(p)) : getchr(p));
   return q;
}

/*
 * Returns the lower case equivalent of the character.
 */
LVAL char_upcase(LVAL p)
{
   LVAL q;

   if( null(p) || !characterp(p) )return NIL;
   q = newchar();
   setchar(q, (isalpha(getchr(p)) && islower(getchr(p))) ?
	   toupper((int) getchr(p)) : getchr(p));
   return q;
}

/*
 * Performs equal LISP function.
 * Returns 1 if p and q are equal and 0 if not.
 */
int equal(LVAL p, LVAL q)
{
   if( p == q ) return 1;
   if( gettype(p) != gettype(q) )return 0;
   switch( gettype(p) )
   {
   case NTYPE_CON:
      return equal(car(p),car(q)) && equal(cdr(p),cdr(q));
   case NTYPE_FLO:
      return getfloat(p)==getfloat(q);
   case NTYPE_INT:
      return getint(p)==getint(q);
   case NTYPE_STR:
      return  getstring(p) == getstring(q) ||
	 !strcmp(getstring(p),getstring(q));
   case NTYPE_SYM:
      return getsymbol(p) == getsymbol(q) ||
	 !strcmp(getsymbol(p),getsymbol(q));
   case NTYPE_CHR:
      return getchr(p) == getchr(q);
   default:
      ReportLog('I',"Invalid node type %d in ``equal''.",gettype(p));
      break;
   }
}


/*
 * -.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
 *
 *    Here we define car and cdr and other functions.
 *
 * They can be used undef-ing the macros. They are slower, but
 * safer, and car(NIL) does not cause memory fault core dumped
 * song.
 *
 * If one undefs car and cdr the macros like cadr are
 * already safe.
 *
 */
#undef car
LVAL car(LVAL x)
{
   if( null(x) )return NIL;
   return ((x)->n_value.n_cons._car);
}

#undef cdr
LVAL cdr(LVAL x)
{
   if( null(x) )return NIL;
   return ((x)->n_value.n_cons._cdr);
}

#undef consp
int consp(LVAL x)
{
   if( null(x) )return 0;
   return ((x)->ntype == NTYPE_CON);
}

#undef floatp
int floatp(LVAL x)
{
   if( null(x) )return 0;
   return ((x)->ntype == NTYPE_FLO);
}

#undef integerp
int integerp(LVAL x)
{
   if( null(x) )return 0;
   return ((x)->ntype == NTYPE_INT);
}

#undef stringp
int stringp(LVAL x)
{
   if( null(x) )return 0;
   return ((x)->ntype == NTYPE_STR);
}

#undef symbolp
int symbolp(LVAL x)
{
   if( null(x) )return 0;
   return ((x)->ntype == NTYPE_SYM);
}

#undef characterp
int characterp(LVAL x)
{
   if( null(x) )return 0;
   return ((x)->ntype == NTYPE_CHR);
}

#undef atom
int atom(LVAL x)
{
   if( null(x) )return 0;
   return ((x)->ntype != NTYPE_CON);
}