#include <exec/types.h>
#define new(a) a=neu((ULONG)sizeof(int)+8L)

extern void output(),fehler();
extern WORD *copy();
extern void delete(),dispose();
extern WORD *neu();
extern WORD *evaluate();
extern long int length();
extern BYTE verhaeltnis(),trace;
extern BYTE genug_parameter(),compare();

struct paar { int knotentyp;
              WORD *CAR,*CDR;
            };
struct atom { int knotentyp;
              char zeichenkette[2];
            };
struct bruch { int knotentyp;
               char kennung[2];
               int zaehler,nenner;
             };
extern struct atom *wahr;
extern int fehlerport;
extern float getfloat();
extern int getint();
extern struct paar *PNeu();

/* nth gibt das n-te Element einer Liste zurück*/


struct atom *nth(parameter)
struct paar *parameter;
{  if(genug_parameter(parameter,2,2))
   {  struct bruch *hilf;
      register struct paar *merke,*merke2;
      hilf=evaluate(parameter->CAR);
      merke=evaluate((merke2=parameter->CDR)->CAR);
      dispose(parameter);dispose(merke2);
      if((hilf!=-1L)&&(hilf!=0L)&&(hilf->knotentyp==2)&&
         (hilf->kennung[0]=='æ'))
      {  int i,j;
         i=getint(hilf);
         dispose(hilf);
         for(j=1;((j<i)&&(merke!=-1L)&&merke);j++)
         {  if(merke->knotentyp!=1)
            {  fehler(2,merke);
               delete(merke);
               merke=-1L;
            }
            else
            {  merke2=merke->CDR;
               delete(merke->CAR);
               dispose(merke);
               merke=merke2;
            }
         }
         if((merke!=0L)&&(merke!=-1L))
         {  delete(merke->CDR);
            merke2=merke->CAR;
            dispose(merke);
            return(merke2);
         }
         else
            return(0L);
      }
      else
      {  if(hilf!=-1L)
         {  fehler(2,hilf);delete(hilf);
         }
         delete(merke);
         return(-1L);
      }
   }
   else
   {  delete(parameter);
      return(-1L);
   }
}

/* relation stellt die Befehle >,>=,<=,< und eql dar*/

struct atom *relation(parameter,typ)
struct paar *parameter;
char typ;   /*1:>=,2:>,3:=,4:<,5:<=*/
{  if(genug_parameter(parameter,2,2))
   {  register struct atom *hilf1,*hilf2;

      hilf1=evaluate(parameter->CAR);
      hilf2=evaluate(((struct paar*)(parameter->CDR))->CAR);
      dispose(parameter->CDR);dispose(parameter);
      if((hilf1==-1L)||(hilf2==-1L))
      {  delete(hilf1);delete(hilf2); /*Auswertefehler*/
         return(-1L);
      }
      else
      {  register BYTE merke;

         merke=verhaeltnis(hilf1,hilf2);
         if(merke==3) return(-1L);
         else
         {  if(((merke==0)&&((typ==1)||(typ==5)||(typ==3)))||
               ((merke==1)&&((typ==5)||(typ==4)))||
               ((merke==2)&&((typ==1)||(typ==2))))
               return(wahr);
            else
               return(0L);
         }
      }
   }
   else
   {  delete(parameter);
      return(-1L);
   }
}

/* comprec vergleicht zwei Listen rekursiv */

BYTE comprec(liste1,liste2)
struct paar *liste1,*liste2;
{
   extern BYTE compare();

   if(liste1==liste2) /*Listen sind im Speicher nur eine*/
      return(1);
   else
      if((liste1==0L)||(liste2==0L)) /*unerwartetes Listenende*/
         return(0);
      else
         if(liste1->knotentyp!=liste2->knotentyp) /*Atom = Liste ?*/
            return(0);
         else
            if((liste1->knotentyp==1)||(liste1->knotentyp==4))/*Liste == Liste ?*/
            {  BYTE zurueck;
               if(zurueck=comprec(liste1->CAR,liste2->CAR))
                  zurueck=comprec(liste1->CDR,liste2->CDR);
               return(zurueck);
            }
            else
               if(compare(((struct atom*)liste1)->zeichenkette,
                          ((struct atom*)liste2)->zeichenkette))
                  return(1);
               else
                  return(0);
}

/* equal : typ==1 : eq-Fkt, sonst equal-Fkt mittels comprec */

struct atom *equal(parameter,typ)
struct paar *parameter;
BYTE typ;
{  if(genug_parameter(parameter,2,2))
   {  register struct paar *hilf1,*hilf2;
      struct atom *hilf;
      hilf1=evaluate(parameter->CAR);
      hilf2=evaluate(((struct paar*)(parameter->CDR))->CAR);
      dispose(parameter->CDR);
      dispose(parameter);
      if((hilf1==-1L)||(hilf2==-1L))
      {  delete(hilf1);delete(hilf2);return(-1L);
      }
      else
         if(((typ==1)&&((hilf1==0L)||(hilf1->knotentyp==2))
                     &&((hilf2==0L)||(hilf2->knotentyp==2))
                     &&comprec(hilf1,hilf2))||
            ((typ==2)&&comprec(hilf1,hilf2)))
         {  delete(hilf1);delete(hilf2);
            return(wahr);
         }
         else
         {  delete(hilf1);delete(hilf2);
            return(0L);
         }
   }
   else
   {  delete(parameter);return(-1L);
   }
}

/* Logische Operatoren :*/

/* bool ermittelt, ob eine Wahrheitswert vorliegt oder nicht */

BYTE bool(knoten)
struct atom *knoten;
{  if(knoten!=-1L)
      if((knoten==0L)||(knoten==wahr))
         return(1);  /* System - Werte*/
      else
         if((knoten->knotentyp==2)&&(knoten->zeichenkette[0]=='t')&&
            (knoten->zeichenkette[1]==0))
            return(1); /*true - Wert*/
         else
            return(0);
   else
      return(0);
}

/* Negation (not) :*/

struct atom *not(parameter)
struct paar *parameter;
{  if(genug_parameter(parameter,1,1))
   {  register struct atom *hilf;

      hilf=evaluate(parameter->CAR);
      dispose(parameter);
      if(hilf==-1L)
         return(-1L);
      else
         if(bool(hilf))
            if(hilf==0L)
               return(wahr);
            else
            {  dispose(hilf); return(0L);
            }
         else
         {  fehler(2,hilf);
            delete(hilf);return(-1L);
         }
   }
   else
   {  delete(parameter); return(-1L);
   }
}

/* logik : and und or - Befehl (Die Parameteruntersuchung wird */
/* abgebrochen, wenn das Ergebnis feststeht !*/

struct atom *logik(parameter,art)
struct paar *parameter;
char art;
{  if(genug_parameter(parameter,2,-1))
   {  register struct atom *hilf;
      BYTE ok=1;
      do
      {  if(bool(hilf=evaluate(parameter->CAR)))
         {  if((hilf==0L)&&(art=='&'))
               ok=0;
            else
               if((hilf!=0L)&&(art=='|'))
                  ok=0;
            dispose(hilf);
         }
         else
         {  if(hilf!=-1L)
            {  fehler(2,hilf);
               delete(hilf);
            }
            ok=3;
         }
         hilf=parameter->CDR;
         dispose(parameter);
         parameter=hilf;
      }while((parameter!=0L)&&(ok==1));
      delete(parameter);
      if(ok==3)
         return(-1L);
      else
         if(((ok==0)&&(art=='|'))||((ok==1)&&(art=='&')))
            return(wahr);
         else return(0L);
   }
   else
   {  delete(parameter);
      return(-1L);
   }
}

/* Kontrollstrukturen */


/* condition wertet das erste Listenelement aus. Ergibt sich hier der */
/* Wert true, dann werden alle weiteren Listenelemente ausgewertet. */

struct atom* condition(parameter)
struct paar* parameter;
{
   if(genug_parameter(parameter,2,-1))
   {  register struct atom *hilf;
      hilf=evaluate(parameter->CAR);
      if(bool(hilf)) /*erster Parameter ist Wahrheitswert !*/
         if(hilf!=0L) /*und true !*/
         {  register struct paar* merke;
            dispose(hilf); /*true-Knoten vernichten*/
            merke=parameter->CDR; /*auf ersten Befehl*/
            dispose(parameter);
            parameter=merke;
            do
            {  hilf=evaluate(parameter->CAR);
               if(hilf==-1L)  /*Auswertefehler*/
               {  delete(parameter->CDR);
                  dispose(parameter);
               }
               else
               {  if(parameter->CDR!=0L)  /*es folgen noch Befehle...*/
                     delete(hilf);
                  merke=parameter->CDR;
                  dispose(parameter);
                  parameter=merke;
               }
            }while((parameter!=0L)&&(hilf!=-1L));
            return(hilf);
         }
         else
         {  delete(parameter->CDR);
            dispose(parameter);
            return(1L); /*Mitteilen, daß Bedingung false*/
         }
      else
      {  if(hilf!=-1L)
         {  fehler(2,hilf);
            delete(hilf);
         }
         delete(parameter->CDR);
         dispose(parameter);
         return(-1L);
      }
   }
   else
   {  delete(parameter);
      return(-1L);
   }
}

/* cond geht solange alle Bedingungen einer cond-Anweisung statt, */
/* bis eine true ist oder Fehler auftreten...*/

struct atom* cond(parameter)
struct paar* parameter;
{  BYTE erfuellt=0;
   if(genug_parameter(parameter,1,-1))
   {
      register struct paar *hilf;
      struct paar *merke;
      do
      {  hilf=parameter->CAR;
         if((hilf!=0L)&&(hilf->knotentyp==1))
         {  hilf=condition(hilf);
            if(hilf==-1L)
               erfuellt=2;
            else
               if(hilf!=1L) /*Bedingung nicht erfüllt !*/
                  erfuellt=1;
         }
         else
         {  fehler(2,hilf);
            dispose(hilf);
            erfuellt=2;
         }
         merke=parameter->CDR;
         dispose(parameter);
         parameter=merke;
      }while((parameter!=0L)&&(erfuellt==0));
      delete(parameter);
      if(erfuellt==1)
         return(hilf);
      else
         if(erfuellt==2)
            return(-1L);
         else
            return(0L); /*keine Bedingung war erfüllt !!!*/
   }
   else
   {  delete(parameter);
      return(-1L);
   }
}

/* Funktionskonzept der Lambda-Terme : */

/* atomtest überprüft, ob alle Elemente einer Liste Atome sind... */

BYTE atomtest(parameter)
struct paar* parameter;
{  BYTE flag=1;
   extern int befehl();
   while((parameter!=0L)&&flag)
   {  if(parameter->knotentyp==2)
         flag=0;
      else
      {  register struct atom *merke;
         merke=parameter->CAR;
         if((merke==0L)||(merke->knotentyp==1)) /*Parameter ist Liste !!!*/
            flag=0;
         else
            if(befehl(merke->zeichenkette))/*Parameter ist Schlüsselw.*/
               flag=0;
            else /*Parameter ev. String ?*/
               if((merke->zeichenkette[0]=='"')||
                  (merke->zeichenkette[0]=='#'))
                  flag=0;
               else /*sollte eine Zahl oder t vorliegen ??*/
                  if((merke->zeichenkette[0]=='æ')||
                     (merke->zeichenkette[0]=='-')||
                     ((merke->zeichenkette[0]=='t')&&
                      (merke->zeichenkette[1]==0)))
                     flag=0;
                  else
                     parameter=parameter->CDR;
      }
   }
   if(flag)
      return(0);
   else
      return(1);
}

/* lambda legt die Parameter- und lokalen Variablen an und füllt sie*/
/* gemäß der Liste zuordnung. Dann wird auswertung u. entfernen aufg.*/

struct atom *lambda(parameter,zuordnung,typ)  /*parameter :Rest Lambda-Term*/
struct paar *parameter,*zuordnung;            /*zuordnung :Parameterwerte  */
BYTE typ; /*typ == 1 : lambda, typ ==0 : macro */
{  extern BYTE compare();
   void entfernen();
   struct atom *auswerten();BYTE argaus();
   if(genug_parameter(parameter,2,-1L))
   {  register struct paar *formale;
      register struct atom *merke1,*merke2;

      formale=parameter->CAR;
      if(atomtest(formale)) /*Parameterliste falsch*/
      {  fehler(18,formale);
         delete(parameter);
         delete(zuordnung);
         return(-1L);
      }                   /*zuordnung wird während des Lesens */
      else                /*vernichtet - formale nicht !*/
      {  BYTE flag=1;     /*flag=2 : &aux gefunden...*/
         if(typ)
            flag=argaus(zuordnung); /*Argumente auswerten*/
         if(flag)
         {  if(trace)
            {  output(zuordnung); nprint("\n"); }
            while(formale!=0L)
            {  merke1=formale->CAR;
               if(compare(merke1->zeichenkette,"&aux"))
               {  if((flag==2)||(flag==4))
                     fehler(17,0L);
                  flag=2;          /*lokale Variablen beginnen */
                  formale=formale->CDR;
                  delete(zuordnung); /*restliche Parameter egal*/
                  zuordnung=0L;
               }
               else
                  if(compare(merke1->zeichenkette,"&rest"))
                  {  if((flag==2)||(flag==4))
                       fehler(17,0L);
                     else
                        flag=4; /*an den nächsten Parameter wird alles*/
                     formale=formale->CDR;
                  }
               else /*formaler Parameter gefunden*/
               {  if(zuordnung==0L)
                  {  merke2=0L;
                     if(flag==1)
                        fehler(16,0L);
                  }
                  else
                     if(flag==4)
                     {  merke2=zuordnung;
                        zuordnung=0L;
                        flag=1;
                     }
                     else
                        merke2=zuordnung->CAR;
                  initsymbol(copy(merke1),merke2,0);
                  delete(merke2);
                  formale=formale->CDR;
                  if(zuordnung!=0L)
                  {  merke1=zuordnung->CDR;
                     dispose(zuordnung);
                     zuordnung=merke1;
                  }
               }
            }
            if(zuordnung!=0L)
            {  fehler(15,zuordnung);
               delete(zuordnung);
            }
            merke1=auswerten(parameter->CDR);
            entfernen(parameter->CAR);
            dispose(parameter);
            if(typ)
               return(merke1);           /*lambda*/
            else
            {  if(merke1!=-1L)
                 return(evaluate(merke1)); /*macro*/
               return(-1L);
            }
         }
         else
         {  delete(zuordnung);
            delete(parameter);
            return(-1L);
         }
      }
   }
   else
   {  delete(parameter);delete(zuordnung);
      return(-1L);
   }
}

/* entfernen entfernt die lokalen Variablen und Parameter vom >Stack< */

void entfernen(parameter)
struct paar *parameter;
{  struct paar *merke;
   while(parameter!=0L)
   {  if((compare(((struct atom*)(parameter->CAR))->zeichenkette,"&aux")==0)
      &&(compare(((struct atom*)(parameter->CAR))->zeichenkette,"&rest")==0))
         delsymbol(parameter->CAR);  /*&aux nicht gefunden*/
      else
         dispose(parameter->CAR);
      merke=parameter->CDR;
      dispose(parameter);
      parameter=merke;
   }
}

/* auswerten wertet alle Elemente nacheinander aus*/

struct atom *auswerten(parameter)
struct paar *parameter;
{  register struct atom *merke=0L;
   while((parameter!=0L)&&(merke!=-1L))
   {  delete(merke); /*letztes Ergebnis entfernen*/
      merke=evaluate(parameter->CAR);
      if(merke==-1L)
      {  delete(parameter->CDR);
         dispose(parameter);
      }
      else
      {  register struct atom *hilf;
         hilf=parameter->CDR;
         dispose(parameter);
         parameter=hilf;
      }
   }
   return(merke);
}

/* argaus wertet die Argumentliste aus und verkettet die Ergebnisse*/

BYTE argaus(parameter)
struct paar *parameter;
{  BYTE flag;
   register struct atom *merke=0L;
   while((parameter!=0L)&&(merke!=-1L))
   {  merke=evaluate(parameter->CAR);
      if(merke==-1L)
      {  delete(parameter->CDR);
         parameter->CAR=parameter->CDR=0L;
      }
      else
      {  parameter->CAR=merke;
         parameter=parameter->CDR;
      }
   }
   if(merke==-1L)
     return(0);
   return(1);
}

/* defun ist eine abgewandelte setq - Variante */

struct atom *defun(parameter,typ)
struct paar *parameter;
BYTE typ; /*0 == defmacro , 1 == defun */
{  extern WORD *set();
   if(genug_parameter(parameter,3,-1))
   {  register struct paar *hilf1;
      register struct atom *hilf3;

      hilf1=parameter->CDR;
      parameter->CDR=0L;
      if(!atomtest(parameter)) /*ist der erste Parameter ein Symbol ?*/
      {  parameter->CDR=hilf1; /*ja !*/
         hilf3=neu((ULONG)sizeof(int)+9L);
         hilf3->knotentyp=2;
         if(typ)
            strcpy(hilf3->zeichenkette,"lambda");
         else
            strcpy(hilf3->zeichenkette,"macro");
         hilf1=PNeu();
         hilf1->CAR=hilf3;
         hilf1->CDR=parameter->CDR;
         hilf1->knotentyp=1;
         hilf3=copy(parameter->CAR);
         initsymbol(parameter->CAR,hilf1,1);
         delete(hilf1);
         dispose(parameter);
         return(hilf3);
      }
      else
      {  fehler(2,parameter);
         parameter->CDR=hilf1;
         delete(parameter);
         return(-1L);
      }
   }
   else
   {  delete(parameter);
      return(-1L);
   }
}

struct atom *While(parameter)
struct paar *parameter;
{
   if(genug_parameter(parameter,2,-1))
   {  register struct paar *bedingung;
      bedingung=evaluate(copy(parameter->CAR));
      if(bool(bedingung))
      {  register struct paar *merke=0L;
         while(bedingung&&(merke!=-1L)) /*true*/
         {  delete(bedingung);
            delete(merke);
            merke=auswerten(copy(parameter->CDR));
            if(merke!=-1L)
            {  bedingung=evaluate(copy(parameter->CAR));
               if(bedingung==-1)
               {  delete(merke); merke=-1L; }
            }
         }
         /*Schleifenende*/
         delete(parameter);
         return(merke);
      }
      else
      {  if(bedingung!=-1L)
         { fehler(2,bedingung);
           delete(bedingung);
         }
         delete(parameter);
         return(-1L);
      }
   }
   else
   {  delete(parameter);
      return(-1L);
   }
}

struct atom *Do(parameter)
struct paar *parameter;
{
   if(genug_parameter(parameter,2,-1))
   {  register struct paar *bedingung=0L,*merke=0L;
      do
      {  delete(merke);
         dispose(bedingung);
         merke=auswerten(copy(parameter->CDR));
         if(merke!=-1L)
         {  bedingung=evaluate(copy(parameter->CAR));
            if(bedingung==-1L)
            { delete(merke); merke=-1L;}
            else
              if(!bool(bedingung))
              {  fehler(2,bedingung);
                 delete(bedingung);
                 merke=-1L;
              }
         }
      }while(bedingung&&(merke!=-1L));
      delete(parameter);
      return(merke);
   }
   else
   {  delete(parameter);
      return(-1L);
   }
}

struct atom *For(parameter)
struct paar *parameter;
{
   if(genug_parameter(parameter,2,-1))
   {  register struct paar *merke,*rueck=0L;
      struct bruch *hilf;
      register long int i;

      hilf=evaluate(parameter->CAR);
      merke=parameter->CDR;
      dispose(parameter);
      if((hilf!=-1L)&&(hilf!=0L)&&(hilf->knotentyp==2)&&
         (hilf->kennung[0]=='æ'))
      {  i=getint(hilf);
         dispose(hilf);
         while(((i--)>0)&&(rueck!=-1L)) /*Schleife*/
         {  delete(rueck);
            rueck=auswerten(copy(merke));
         }
         delete(merke);
         return(rueck);
      }
      else
      {  if(hilf!=-1L)
         {  fehler(2,hilf);delete(hilf);
         }
         delete(merke);
         return(-1L);
      }
   }
   else
   {  delete(parameter);
      return(-1L);
   }
}