#include "df0:include/exec/types.h"
#include "df0:include/stdio.h"

#define anzahl 78 /*Diese Konstante muß stimmen, sonst ev. Guru !*/
#define garb_grenze 50 /*Erst nach soviel Müll findet GC statt. */

/*Befehle für dynamische Struturen*/

/* neue Ausgabebefehle */
extern void nprint();
char zp[15];  /*Für die Ausgabe von Zahlen*/
#define dprint(a) sprintf(zp,"%d",a);nprint(zp)

int dateiw=-1L;  /*Dateihandle für Schreiboperationen*/
int dateir=-1L;  /*Handle für Lesedatei*/

extern char* AllocMem();
extern void  FreeMem();
extern ULONG OpenLibrary();
extern ULONG Open();
extern ULONG Read();
extern void fehler(),beenden(),conreinit();
unsigned long int *truedynber=0L,*freizeiger=0L;
ULONG *segmente[257]; /*8 MByte adressierbar*/
int anzSeg; /*Anzahl der belegten 32K-Segmente*/
BYTE bildaus=1;  /*Ausgabe gestattet ?*/
BYTE muell=0;    /*GarbageCollection erforderlich ?*/
char *textpuffer; /* Zeigt auf eingelesenen Programmtext */
char *filepuffer;
WORD *leeres_atom=0L;
extern struct { int knotentyp;
                char zeichenkette[3]; } befzeig[];
/* Lisp-Strukturen */

struct {  int knotentyp;      /*kein Rückgabewert*/
          char zeichenkette;
       } leer;
struct {  int knotentyp;      /*t - Wert*/
          char zeichenkette[2];
       } tr;
WORD *wahr=0L;

struct paar {  int knotentyp;  /* 1 = Punktepaar */
                               /* 2 = Atom */
               WORD *CAR,*CDR; /* 3 = Variablenverkettung */
            };                 /* 4 = Komplexe Zahl, sonst wie 1 */
struct atom {  int knotentyp;         /*Dummy-Struktur*/
               char zeichenkette[2];  /*Länge wird dynamisch festgelegt*/
            };
struct bruch { int knotentyp;     /* spezielles Atom */
               char kennung[2];
               int zaehler,nenner;
             };
struct dezimal{int knotentyp;
               char kennung[2];
               float wert;
              };

/* Speicherverwaltung mit eigener Garbage-Collection */
/* ------------------------------------------------- */

#define wait { int i,j; for(i=0;i<600;i++) for(j=0;j<1000;j++) ; }
/* dyninit initialisiert die Routinen und reserviert durch das Betriebs-*/
/* System einen Speicherbereich, der später die Knoten aufnimmt.*/

/* Die Paare (u. kompl. Zahlen) sind alle linear doppelt*/
/* verkettet, damit sie bei einer*/
/* Garbage-Collection schnell geprüft werden können*/
/* Paare sind die mit Abstand häufigsten Daten*/

struct paarheap { struct paarheap *last,*next;
                  struct paar inhalt;
                };
struct paarheap *PaarListe[256],*FreiPaar,*BesetztPaar;
int PSecZahl=0; /*Anzahl der Paar-Segmente*/
int PZahl; /*Anzahl der Punktepaare*/
void dyninit()
{  int i,j;
   struct paarheap *lauf1;

   if((FreiPaar=PaarListe[0]=AllocMem(30000,1))<=0)
   { fehler(8,0L); wait; beenden(); conreinit(); exit(FALSE); }
   PSecZahl=1;
   BesetztPaar=PZahl=0L;
   lauf1=FreiPaar;                   /*Freispeicherliste für Paare*/
   for(i=1;i<1499;i++)               /*erstellen*/
   { lauf1->next=lauf1+1; lauf1++; }
   lauf1->next=0L;

   truedynber = AllocMem(32768L,1L);
   if(truedynber<=0L)
   {  fehler(8,0L); FreeMem(FreiPaar,30000);
      wait;
      beenden();
      conreinit();
      exit(FALSE);
   }
   anzSeg=0; /*nur das Basissegment angelegt*/
   leeres_atom=&leer; /*Zeiger auf leeres Atom setzen*/
   leer.knotentyp=2;leer.zeichenkette=(char)0;
   wahr=&tr;
   tr.knotentyp=2;tr.zeichenkette[0]='t';tr.zeichenkette[1]=0;
   *truedynber=32764L+(ULONG)(truedynber); /*Marken setzen*/
   *((ULONG*)(*truedynber))=0xfffffffeL;
   freizeiger=truedynber;
   /*Textpuffer reservieren*/
   textpuffer=AllocMem(40000,1L);
   if(textpuffer<=0L)
   {  FreeMem(truedynber,32768L);
      fehler(8,0L); FreeMem(FreiPaar,30000);
      wait;
      beenden();
      conreinit();
      exit(FALSE);
   }
   filepuffer=AllocMem(32768L,1L);
   if(filepuffer<=0L)
   {  FreeMem(truedynber,32768L);  /*Ausgabe auf Diskette puffern*/
      FreeMem(textpuffer,40000L);
      fehler(8,0L); FreeMem(FreiPaar,30000);
      wait;
      beenden();
      conreinit();
      exit(FALSE);
   }
}

/* angliedern - fügt benachbarte leere Bereiche zu einem neuen */
/* zusammen. */

void angliedern()
{  register ULONG *lauf;
   ULONG merke;
   BYTE flag=1;

   lauf=truedynber;
   while(*lauf!=0xfffffffeL)
   {  if((*lauf)&1L)
         lauf=((*lauf)&0x7ffffffeL); /*Feld besetzt*/
      else
      {  if(flag)  /*neue Startposition*/
         {  freizeiger=lauf;
            flag=0;
         }
         if((*((ULONG*)(*lauf)))&1L) /*nur ein Feld frei*/
            lauf=(*lauf);
         else
         {
            merke=*((ULONG*)(*lauf)); /*angliedern*/
            if(merke!=0xfffffffeL)
               *lauf=merke;
            else
               lauf=(*lauf);
         }
      }
   }
}

struct paar *PNeu() /* PNeu reserviert Speicher für Paare */
{  void dynreinit();
   if(FreiPaar)
   {  struct paarheap *merke;
      merke=FreiPaar;
      FreiPaar=FreiPaar->next;
      merke->next=BesetztPaar; /*besetzter Knoten anketten*/
      if(BesetztPaar)
        BesetztPaar->last=merke;
      merke->last=0L;
      BesetztPaar=merke;PZahl++;
      return(&(merke->inhalt));
   }
   else /*Segment voll*/
   {  struct paarheap *lauf;
      int i;
      if(PSecZahl>=255) /*alles voll*/
      { fehler(7,0L);wait;beenden();dynreinit();conreinit();exit(FALSE); }
      PaarListe[PSecZahl]=AllocMem(30000,1);
      if(PaarListe<=0)
      { fehler(7,0L);wait;beenden();dynreinit();conreinit();exit(FALSE); }
      lauf=PaarListe[PSecZahl]+1;
      for(i=1;i<1499;i++)
      { lauf->next=lauf+1; lauf++; }
      lauf->next=0L; /*Ende der Freispeicherliste*/
      FreiPaar=PaarListe[PSecZahl]+1;
      lauf=PaarListe[PSecZahl++];
      lauf->next=BesetztPaar; /*besetzter Knoten anketten*/
      if(BesetztPaar)
        BesetztPaar->last=lauf;
      lauf->last=0L;
      BesetztPaar=lauf;PZahl++;
      return(&(lauf->inhalt));
   }
}
/* new(zeiger) setzt den Zeiger auf einen genügend großen Bereich */
#define new(a) a=neu((ULONG)sizeof(int)+8L)
char *neu(laenge)
unsigned long int laenge;
{  register ULONG *lauf;
   ULONG hilf;
   void dynreinit();
   if(laenge%2L)   /* Länge muß gerade sein (gerade Adressen) */
      laenge++;
   lauf=freizeiger;
   while(((*lauf)&1L)||((*lauf - (ULONG)(lauf))<laenge+4L))
      lauf=(*lauf)&0x7ffffffeL;     /*genügend gr. Ber. suchen */
   if(*lauf==0xfffffffeL)
   {  angliedern(); /*Platz schaffen*/
      lauf=freizeiger;
      while(((*lauf)&1L)||((*lauf - (ULONG)(lauf))<laenge+4L))
         lauf=(*lauf)&0x7ffffffeL;     /*genügend gr. Ber. suchen */
      if(*lauf==0xfffffffeL)
      {  segmente[anzSeg]=AllocMem(32768L,1L);
         if((segmente[anzSeg]>0L)&&(anzSeg<=256))
         {  *lauf=((ULONG)segmente[anzSeg])|0x80000001;
            *(lauf=segmente[anzSeg])=32764L+(ULONG)segmente[anzSeg];
            *((ULONG*)(*segmente[anzSeg++]))=0xfffffffe;
         }             /*bei Bedarf Speicher hinzufügen...*/
         else
         { fehler(7,0L);wait;beenden();dynreinit();conreinit();exit(FALSE); }
      }
   }
   if((*lauf)-(ULONG)(lauf)<laenge+8L)
   {  freizeiger=*lauf;
      *lauf |= 1L;       /*Bereich kann nicht unterteilt werden*/
   }
   else
   {  hilf=*lauf; /*Bereich wird zweigeteilt*/
      freizeiger=(*lauf=(ULONG)(lauf)+laenge+5L)&0xfffffffeL;
      *((unsigned long int*)((*lauf)&0xfffffffeL))=hilf;
   }
   return((char*)(++lauf)); /*Zeiger auf Bereich zurück*/
}

/* dispose(zeiger) gibt den Bereich, auf den Zeiger zeigt, für neue */
/* Benutzung frei. Der Wert von Zeiger ändert sich nicht. Auf *zeiger */
/* darf aber keinesfalls mehr zugegriffen werden ! */

void PDis(zeiger) /*löscht ein Paar*/
struct paarheap *zeiger;
{  if(zeiger->inhalt.knotentyp<=0) return(); /*Fehlertoleranz*/
   if(zeiger->next)
     zeiger->next->last=zeiger->last; /*Verkettung der Besetzt-Liste */
   if(zeiger->last)                   /*reparieren*/
     zeiger->last->next=zeiger->next;
   else
     BesetztPaar=zeiger->next;
   zeiger->next=FreiPaar;  /*Verkettung der Frei-Liste retten*/
   FreiPaar=zeiger;
   FreiPaar->inhalt.knotentyp=0;PZahl--;
}
void dispose(zeiger)
unsigned long int *zeiger;
{  if((zeiger!=0L)&&(zeiger!=-1L)&&(zeiger!=leeres_atom)&&(zeiger!=wahr)&&
      (((ULONG)zeiger<(ULONG)(&befzeig[0]))||((ULONG)zeiger>=(ULONG)
        (&befzeig[anzahl]))))
   {  if((*zeiger==1)||(*zeiger==4))
        PDis(zeiger-2);
      else
      { muell++;
        (*(--zeiger))&=0xfffffffeL;  /*Bereich freigeben */
      }
   }
}

/* dynreinit gibt den vom System reservierten Speicherbereich frei */

void dynreinit()
{
   if(truedynber!=0L)           /*sicher ist sicher*/
   {  int i=0;
      FreeMem(truedynber,32768L);
      for(i=0;i<anzSeg;i++)
         FreeMem(segmente[i],32768L);
      for(i=0;i<PSecZahl;i++)
         FreeMem(PaarListe[i],30000L);
      FreeMem(textpuffer,40000L);
      FreeMem(filepuffer,32768L);
   }
}

/* GarbageCollection */

struct varlist { int knotentyp;
                 struct varlist *links,*rechts;
                 struct paar *eintrag;
                 struct atom *name;
               };
struct lastpos { int knotentyp;
                 struct lastpos *next;
                 float x,y,richtung;
               };

/* kontrolle korrigiert Referenzen nach dem Umkopieren*/
#define kontrolle(a) if(((ULONG)(a)>(ULONG)start)&&((ULONG)(a)<(ULONG)ende)){ a=(ULONG)(a)-differenz;i++;}

void garbage_collection()   /* V. 3.0 */
{  ULONG *lauf,*start,*ende,*merke;
   register ULONG *source,*target;
   register struct paar *pa;
   extern WORD *symbolliste;
   int anz,i;
   struct paarheap *h;
   ULONG differenz;

   if(muell<garb_grenze)
      return();
   muell=0;
   angliedern();
   lauf=freizeiger;
   while(*lauf!=0xfffffffe)
   { if(*lauf&1L) lauf=(*lauf)&0x7ffffffe; /*Bereich voll*/
     else if(*((ULONG*)(*lauf))==0xfffffffe)
             lauf=*lauf; /*der letzte freie Bereich bleibt.*/
     else /*leeren Bereich entfernen*/
     {  start=lauf;
        differenz=(*lauf)-(ULONG)lauf;
        lauf=*lauf;
        anz=0;
        while(((*lauf)&1L)&&(!((*lauf)&0x80000000))) /*solange belegt*/
           lauf=*lauf&0xfffffffe;  /*Vorabtest auf Segmentgrenze*/
        if(((*lauf)&0x80000000)||(*lauf==0xfffffffe))
        /*Segmentgrenze erreicht, Umkopieren zwecklos*/
        { if(*lauf!=0xfffffffe)
            lauf=(*lauf)&0x7ffffffe;
        }
        else
        { lauf=*start;
          while(((*lauf)&1L)&&(!((*lauf)&0x80000000))) /*solange belegt*/
          {  merke=*lauf&0xfffffffe;
             *lauf-=differenz;        /*Verweise ändern*/
             anz++;
             lauf=merke;
          }
          ende=lauf+1;    /*4 Bytes zusätzlich zum Anschluß*/
          target=start;   /*Das ist die Marke des freien Bereichs, der*/
          source=*start;  /*damit vergrößert wird.*/
          while((ULONG)source<(ULONG)ende) /*den Bereich kopieren*/
             *target++=*source++;
          lauf=truedynber;       /*nun die Referenzen korrigieren*/
          i=0;
          kontrolle(symbolliste)
          while((i<anz)&&(*lauf!=0xfffffffe))
          {  if((*lauf)&1L) /*belegt*/
             {  pa=lauf+1L;
                if(pa->knotentyp==3) /*Variablenliste*/
                {  kontrolle(((struct varlist*)pa)->rechts)
                   kontrolle(((struct varlist*)pa)->links)
                   kontrolle(((struct varlist*)pa)->eintrag)
                   kontrolle(((struct varlist*)pa)->name)
                }
             }
             lauf=(*lauf)&0xfffffffe;
          }
          /*Referenzen in der Paar-Liste anpassen*/
          h=BesetztPaar;
          while(h)
          { kontrolle(h->inhalt.CAR);
            kontrolle(h->inhalt.CDR);
            h=h->next;
          }
          lauf=(ULONG)(ende-1)-differenz;
          /*auf den Anfang des nächsten freien Bereichs setzen*/
        }
     }
   }
}

/* uebrig zählt die belegten Knoten und den freien Speicherplatz */

void uebrig()
{  register ULONG *lauf;
   long int frei=0L,knoten[4];
   struct paarheap *h;
   lauf=truedynber;
   knoten[0]=knoten[1]=knoten[2]=knoten[3]=0L;
   while(*lauf!=0xfffffffeL)
   {  if((*lauf)&1L) /*Knoten belegt*/
      { if(!((*lauf)&0x80000000L))
           knoten[(*(lauf+1))-1L]++;
      }
      else           /*Knoten frei*/
         frei+=((*lauf)-((ULONG)lauf)-4L);
      lauf=(*lauf)&0x7ffffffeL;
   }
   h=BesetztPaar;
   while(h)
   {  knoten[h->inhalt.knotentyp-1]++;
      h=h->next;
   }
   dprint((anzSeg+1)*32768+PSecZahl*30000);
   nprint(" Bytes reserviert, davon\n");
   dprint(frei+PSecZahl*30000-PZahl*20);
   nprint(" Bytes für Programme und Daten frei\n");
   dprint(knoten[0]+knoten[3]);nprint(" Punktepaar-Knoten aktiv\n");
   dprint(knoten[1]);nprint(" atomare Knoten aktiv\n");
   dprint(knoten[2]);nprint(" Variablenverkettungsknoten aktiv\n");
   /*Knotentyp 3 z.Z. nicht benutzt*/
}

char *textpointer=0L;

BYTE load(name,typ) /*falls typ=1 wird load vom Editor aufgerufen*/
char *name;
BYTE typ;
{  ULONG filehandle;
   ULONG dosbase;
   dosbase=OpenLibrary("dos.library",0L);
   if(dosbase==0L)
   {  if(typ!=1) {fehler(4,0L); return(0); }
      return(0);
   }
   else
   {  ULONG laenge;
      filehandle=Open(name,1005L);
      if(filehandle!=0L)
      {  laenge=Read(filehandle,textpuffer,39999L);
         Close(filehandle);
         CloseLibrary(dosbase);
         if(laenge<0L)
         {  if(typ!=1) {fehler(5,0L); return(0); }
            return(4);
         }
         else
           if(laenge>=39999L)
           {  if(typ!=1) { fehler(6,0L);return(0); }
              return(3);
           }
           else
           {  *((char*)(textpuffer+laenge))=0;
              if(typ!=1) textpointer=textpuffer;  /*Interpreter auf Anfang setzen*/
              return(1);
           }
      }
      else
      {  CloseLibrary(dosbase);
         if(typ!=1) {fehler(5,0L); return(0); }
         return(2);
      }
   }
}
BYTE esave(name) /*wird nur vom Editor aufgerufen*/
char *name;
{  ULONG filehandle;
   ULONG dosbase;
   ULONG i=0L;
   char *z;
   dosbase=OpenLibrary("dos.library",0L);
   if(dosbase==0L)
      return(0);
   else
   {  ULONG laenge;
      z=textpuffer;
      while(*z++) i++;
      filehandle=Open(name,1006L);
      if(filehandle!=0L)
      {  laenge=Write(filehandle,textpuffer,i);
         Close(filehandle);
         CloseLibrary(dosbase);
         if(laenge!=i)
            return(4);
         return(1);
      }
      else
      {  CloseLibrary(dosbase);
         return(2);
      }
   }
}

/* Allgemeines */

long int length(string)
char *string;
{  register long int i;
   i=0;
   while(*string++)
      i++;
   return(i);
}

/* Der Lisp - Interpreter */
/* ---------------------- */

extern struct atom* string_int();
extern char* int_string();

/* copy kopiert eine komplette Baumstruktur, die aber auch nur aus einem*/
/* Atom bestehen darf.*/

WORD *copy(wurzel)
WORD *wurzel;
{
   if((wurzel==0L)||(wurzel==wahr)||(((ULONG)wurzel>=(ULONG)(&befzeig[0]))&&
       ((ULONG)wurzel<(ULONG)(&befzeig[anzahl]))))
   /*Ende eines Astes erreicht*/
      return(wurzel);
   else
   {  if(*((int*)wurzel)==2) /*Atom gefunden*/
      {  register struct atom *hilf1;
         hilf1=wurzel;
         if(hilf1->zeichenkette[0]!='æ') /*keine Zahl*/
         {  struct atom *hilf2;
            hilf2=neu(length(hilf1->zeichenkette)+(ULONG)(sizeof(int))+1L);
            hilf2->knotentyp=2;
            strcpy(hilf2->zeichenkette,hilf1->zeichenkette);
            return(hilf2);
         }
         else  /* Zahl ! */
         {  struct bruch *hilf2;
            hilf2=neu(sizeof(struct bruch));
            hilf2->knotentyp=2;
            hilf2->kennung[0]='æ';
            if(hilf1->zeichenkette[1]=='B')
            {  hilf2->zaehler=((struct bruch*)hilf1)->zaehler;
               hilf2->nenner= ((struct bruch*)hilf1)->nenner;
               hilf2->kennung[1]='B';
            }
            else /*Fließkommazahl*/
            {  hilf2->kennung[1]='F';
               ((struct dezimal*)hilf2)->wert=((struct dezimal*)hilf1)->wert;
            }
            return(hilf2);
         }
      }
      else  /*Punktepaar gefunden,d.h. typ=1 oder 4*/
      {  register struct paar *hilf1,*hilf2;
         hilf1=wurzel;
         hilf2=PNeu();
         hilf2->knotentyp=hilf1->knotentyp; /*1 oder 4*/
         hilf2->CAR=copy(hilf1->CAR);
         hilf2->CDR=copy(hilf1->CDR);
         return(hilf2);
      }
   }
}

/* delete entfernt eine Baumstruktur aus dem Speicher, deren Wurzel*/
/* übergeben wird.*/

void delete(zeiger)
int *zeiger;
{  if((zeiger!=0L)&&(zeiger!=-1L))
     if(*zeiger==2) /*Atom soll gelöscht werden*/
        dispose(zeiger);
     else  /*Paar oder komp. Zahl*/
     {  register struct paar *hilf;
        hilf=zeiger;
        delete(hilf->CAR);
        delete(hilf->CDR);
        dispose(hilf);
     }
}

/* cons bildet eine Liste aus einem Atom und einer Restliste oder einem*/
/* weiteren Atom und gibt einen Zeiger auf diese zurück*/

struct paar *cons(element,restliste)
struct paar *restliste;
struct atom *element;
{  register struct paar *kopf;

   kopf=PNeu();
   kopf->CDR=restliste;
   kopf->CAR=element; /*Eingänge gehen verloren*/
   kopf->knotentyp=1;

   return(kopf);
}

struct atom *car(liste)       /*car gibt einen Zeiger auf das erste*/
struct paar *liste;           /*Element einer Liste an*/
{                             /*Vorsicht : Der Rückgabewert kann*/
   if(liste!=0L)              /*auch Zeiger auf ein Paar sein.*/
   { if((*((int*)liste)!=1)&&(*((int*)liste)!=4))
     {  fehler(9,liste);
        delete(liste);
        return(-1L);
     }
     else
     {  WORD *merke;
        merke=liste->CAR;     /*Restliste und Verbindungsknoten löschen*/
        delete(liste->CDR);
        dispose(liste);
        return(merke);
     }
   }
   else return(0L);
}

struct paar *cdr(liste)       /*cdr gibt ein Zeiger auf die restliche*/
struct paar *liste;           /*Liste zurück. Der Zeiger*/
{                             /*kann auch 0 sein*/
   if(liste!=0L)
   { if((*((int*)liste)!=1)&&(*((int*)liste)!=4))
     {  fehler(9,liste);
        delete(liste);
        return(-1L);
     }
     else
     {  WORD *merke;
        merke=liste->CDR;
        delete(liste->CAR);
        dispose(liste);
        return(merke);
     }
   }
   else
      return(0L);
}

/* datprint ruft nprint auf oder schickt den Text an eine Datei */
BYTE datflag=1; /*wählt den Ausgabeort, siehe princ*/
void datprint(text)
char *text;
{  extern BYTE EDACTIVE;
   if((datflag==1)||EDACTIVE)
      nprint(text);
   else if(datflag!=2)
   {  int i=0,j;
      register char *z;
      z=text;
      while(*z++!=0) i++; /*Länge des Textes ermitteln*/
      j=write(dateiw,text,i);
      if(j!=i)
         datflag=2; /*nicht mehr weiterschreiben*/
   }
}


/* listout gibt eine Liste oder ein Atom aus (ohne äußere Klammern)*/

void listout(kopf)
int *kopf;
{  void output();
   if(kopf!=0L)
   { if(*kopf == 2) /*Atom !*/
       if(((struct atom*)kopf)->zeichenkette[0]=='#')
       {  datprint(" #Primitive ");
          sprintf(zp,"%d",(int)(((struct atom*)kopf)->zeichenkette[1]));
          datprint(zp);
       }
       else
          if(((struct atom*)kopf)->zeichenkette[0]!='æ')
          {  if(((struct atom*)kopf)->zeichenkette[0]!=0)
             {  datprint(" ");
                datprint(((struct atom*)kopf)->zeichenkette);
                datprint(" ");
             }
          }
          else
          {  datprint(" ");
             datprint(int_string(kopf)); /*Zahl ausgeben*/
             datprint(" ");
          }
     else if(*kopf == 4) /*komp. Zahl*/
     { datprint("[");
       output(((struct paar*)kopf)->CAR);
       output(((struct paar*)kopf)->CDR);
       datprint("]");
     }
     else
     { register struct paar *hilf;
       hilf=kopf;
       /*Erster Teil des Punktepaares :*/
       if((hilf->CAR==0L)||(*((int*)(hilf->CAR))==1))/*CAR bezeichnet*/
       {  datprint("(");        /*ein Punktepaar oder NIL-Zeiger       */
          listout(hilf->CAR);
          datprint(")");
       }
       else
          listout(hilf->CAR);
       /*Zweiter Teil des Punktepaares :*/
       if((hilf->CDR != 0L)&&(*((int*)(hilf->CDR))==2))
          datprint("."); /*linksseitiger Baum*/
       listout(hilf->CDR);
     }
   }
}

/* output ruft listout auf und setzt gegebenenfalls umschließende ()*/

void output(kopf)
int *kopf;
{  if((kopf!=-1L)&&bildaus)
     if((kopf==0L)||(*kopf==1))
     {  datprint("(");
        listout(kopf);
        datprint(")");
     }
     else
        listout(kopf);
}

extern BYTE genug_parameter();
extern struct paar *evaluate();

/*readdat liest eine Datei aus*/

extern void initsymbol();
extern int befehl();
WORD *input();
struct atom *readdat(parameter)
struct paar *parameter;
{  if(genug_parameter(parameter,1,1))
   {  struct atom *merke;
      struct paar *hilf;
      char name[41],*l1,*l2;
      int j=0,i=0;
      merke=evaluate(parameter->CAR);
      dispose(parameter);
      if((merke==-1L)||(!merke)||(merke->knotentyp!=2)||
         (merke->zeichenkette[0]!='\"'))
      {  if(merke!=-1L)
         {  fehler(2,merke);
            delete(merke);
         }
         delete(parameter);
         return(-1L);
      }
      l1=&(merke->zeichenkette[1]);l2=name;       /*Dateiname kopieren*/
      while((i++<40)&&(*l1!='\"')) *l2++=*l1++;
      *l2=0; dispose(merke); /*Stringende*/
      dateir=open(name,0,i);
      if(dateir<=0L)
        return(0L);
      l1=filepuffer;
      do
         i=read(dateir,l1++,1);
      while((i==1)&&(++j<32768));
      close(dateir);
      dateir=-1L;
      if(j>=32768)   /*Puffer voll !*/
        return(0L);
      i=textpointer; /*aktuelle Position zwischenspeichern*/
      hilf=input(filepuffer);
      textpointer=i;
      return(hilf); /*gelesene Liste zurückgeben*/
   }
   else { delete(parameter); return(-1L); }
}

/*open öffnet eine Datei zum Schreiben */
struct atom *open_(parameter)
struct paar *parameter;
{  extern struct paar *evaluate();
   if(dateiw!=-1L)
   {  delete(parameter);
      return(0L);
   }
   if(genug_parameter(parameter,1,1))
   {  struct atom *hilf;
      hilf=evaluate(parameter->CAR);
      dispose(parameter);
      if((hilf!=-1L)&&(hilf!=0L)&&(hilf->knotentyp==2)&&(hilf->zeichenkette[0]=='\"'))
      {  int i=1,dummy;
         while(hilf->zeichenkette[i]!='\"') i++;
         hilf->zeichenkette[i]=0; /*Anführungszeichen entfernen*/
         dateiw=creat(&hilf->zeichenkette[1],i);
         dispose(hilf);
         if(dateiw==-1L)
            return(0L);
         else
         {  dummy=write(dateiw,"(",1);
            return(wahr);
         }
      }
      else
      {  if(hilf!=-1L)
         {  fehler(2,parameter);
            delete(parameter);
         }
         return(-1L);
      }
   }
   else
   {  delete(parameter);
      return(-1L);
   }
}

struct atom *close_(parameter)
struct paar *parameter;
{  if(genug_parameter(parameter,0,0))
   {  if(dateiw!=-1L)
      {  int dummy;
         dummy=write(dateiw,")",1); /*Liste abschließen*/
         close(dateiw);
      }
      return(leeres_atom);
   }
   else
   {  delete(parameter);
      return(-1L);
   }
}

struct atom *ddelete(parameter)
struct paar *parameter;
{  if(genug_parameter(parameter,1))
   {  struct atom *merke;
      merke=evaluate(parameter->CAR);dispose(parameter);
      if((merke==-1L)||(!merke)||(merke->knotentyp!=2)||
         (merke->zeichenkette[0]!='\"'))
      {  if(merke!=-1L)
         {  fehler(2,merke);
            delete(merke);
         }
         delete(parameter);
         return(-1L);
      }
      else
      { ULONG filehandle;
        ULONG dosbase;
        char *z;
        dosbase=OpenLibrary("dos.library",0L);
        if(dosbase==0L)
        {  fehler(4,0L);
           return(0);
        }
        z=&(merke->zeichenkette[1]);
        while(*z!='\"') z++;
        *z=0;
        if(DeleteFile(&(merke->zeichenkette[1])))
        {  dispose(merke);
           CloseLibrary(dosbase);
           return(wahr);
        }
        dispose(merke);
        CloseLibrary(dosbase);
        return(0L);
      }
   }
   else
   {  delete(parameter); return(-1L);
   }
}

char *leerweg(zeig) /*überliest Leerzeichen*/
char *zeig;
{ register char *zeiger;
  zeiger=zeig;
  while((*zeiger==10)||(*zeiger==13)||(*zeiger==' ')||(*zeiger==';'))
  {  if(*zeiger==';')                       /*Kommentare*/
       while((*zeiger!=10)&&(*zeiger!=13))
          zeiger++;
     zeiger++;
  }
  return(zeiger);
}

/* varzeichen evaluiert zu true, wenn das übergebene Zeichen in einem*/
/* Variablennamen erlaubt ist*/

BYTE varzeichen(zeichen)
char zeichen;
{ if((zeichen!=10)&&(zeichen!=13)&&(zeichen!=';')&&(zeichen!=' ')
     &&(zeichen!=')')&&(zeichen!='(')&&(zeichen!=0)&&
     (zeichen!=39)&&(zeichen!='[')&&(zeichen!=']'))
     return(1);
  else
     return(0);
}

/* atomin liest ein einzelnes Atom aus einem String ein. Der textpointer*/
/* muß auf das erste Zeichen des Atoms zeigen*/

WORD *atomin()
{
  register struct atom *knoten;
  register char *hilf;
  long int i=0L;
  WORD *input();
  extern BYTE compare();

  if((*textpointer!=0)&&(*textpointer!=')')&&(*textpointer!='.'))
  {
    hilf=textpointer;
    /* Eine ZAHL gelesen */
    if(((*hilf=='-')&&varzeichen(*(hilf+1)))||
       ((*hilf<58)&&(*hilf>47)))
    {  knoten=string_int(hilf);
       while(varzeichen(*textpointer)&&((*textpointer!='.')
             ||((*(textpointer+1)>=48)&&(*(textpointer+1)<58))))
          textpointer++;
       return(knoten);
    }
    /* Wahrheitswert TRUE gelesen */
    if((*hilf=='t')&&((!varzeichen(*(hilf+1)))||(*(hilf+1)=='.')))
    {  textpointer++;
       return(wahr);      /* true wird nur als Zeiger gesp.*/
    }
    /* Wahrheitswert NIL gelesen */
    if((*hilf=='n')&&(*(hilf+1)=='i')&&(*(hilf+2)=='l')&&
       ((!varzeichen(*(hilf+3)))||(*(hilf+3)=='.')))
    {  textpointer+=3;
       return(0L);    /* nil wird zu () */
    }
    if(*hilf=='[')  /*komplexe Zahl*/
    {  struct paar *knoten;
       textpointer++;
       knoten=PNeu();
       knoten->knotentyp=4;
       knoten->CAR=input(textpointer);
       if(*textpointer) knoten->CDR=input(textpointer);
       else knoten->CDR=0L;
       textpointer=leerweg(textpointer);
       if(*textpointer==']')
         textpointer++;
       else
          fehler(38,0L);
       return(knoten);
    }
    /* Knotengröße für Strings/Variablen ermitteln */
    if(*hilf=='"') /*Es liegt ein String vor*/
    {  hilf++;
       while((*hilf!='"')&&(*hilf!=0))
       {  hilf++;
          i++;          /*\n werden einfach mitgerechnet*/
       }
       i+=2L; /*Platz für die Anführungszeichen*/
    }
    else  /* Platz für Symbol ermitteln*/
       while(varzeichen(*hilf)&&(*hilf!='.'))
       {   hilf++;i++;
       }
    knoten=neu(i+(ULONG)(sizeof(int))+2L); /*gegen +1L ändern*/
    /*Knoten mit Inhalt füllen*/
    knoten->knotentyp=2;
    hilf=&(knoten->zeichenkette[0]);
    if(*textpointer=='"') /*String kopieren*/
    {  *(hilf++)='"';
       while((*(textpointer+1L)!=0)&&(*(textpointer+1L)!='"'))
       { if(*(++textpointer)!='\n')   /*Stringende!=Zeilenende*/
            *(hilf++)=*textpointer;
       }
       *(hilf++)='"';
       *hilf=0;
       if(*(++textpointer)==0)/*Quelltextende erreicht !*/
          fehler(10,knoten);
       else
          textpointer++;
    }
    else /*Symbol kopieren*/
    {  while(varzeichen(*textpointer)&&(*textpointer!='.'))
          *(hilf++)=*(textpointer++);
       *hilf=0;
    }
    return(knoten);
  }
  else
  {  if(*textpointer==')')
     {  fehler(11,0L);
        textpointer++;
     }
     else
        if(*textpointer=='.')
        {  fehler(12,0L);
           textpointer++;
        }
     return(0L);
  }
}

/* listin liest eine Liste aus einem String ein. Der textpointer muß auf*/
/* das erste Zeichen nach der geöffneten Anfangsklammer zeigen*/

WORD *listin(klammern)
BYTE klammern;
{ register struct paar *knoten;
  WORD *input();
  textpointer=leerweg(textpointer);
  if((*textpointer!=0)&&(*textpointer!=')'))
  {
    knoten=PNeu();
    knoten->knotentyp=1;
    knoten->CAR=input(textpointer);
    textpointer=leerweg(textpointer);
    if((*textpointer!=0)&&(*textpointer!='.'))   /*Es folgt liste*/
    {
       knoten->CDR=listin(1);
    }
    else
    {  if(*textpointer!=0)
          knoten->CDR=input(++textpointer);
       else
          knoten->CDR=0L;
    }
    textpointer=leerweg(textpointer);
  }
  else
     knoten=0L;
  if(*textpointer==')')
  { if(klammern == 0)
       textpointer++;
  }
  else
    if(klammern==0)
       fehler(13,0L);
  return(knoten);
}

WORD *input(was)
char *was;
{  textpointer=leerweg(was);
   if(*textpointer=='(')
   {  textpointer++;
      return(listin(0));  /*bisher 0 Klammern geöffnet*/
   }
   else
      if(*textpointer==39)                      /*(quote ...) er-*/
      {  register struct paar *hilfsk1,*hilfsk2;/*zeugen*/
         register struct atom *hilfsat;
         hilfsat=neu((ULONG)sizeof(int)+8L);
         hilfsat->knotentyp=2;
         strcpy(hilfsat->zeichenkette,"quote");
         hilfsk1=PNeu();
         hilfsk2=PNeu();
         hilfsk1->knotentyp=hilfsk2->knotentyp=1;
         hilfsk1->CAR=hilfsat;hilfsk1->CDR=hilfsk2;
         hilfsk2->CAR=input(++textpointer);
         hilfsk2->CDR=0L;
         return(hilfsk1);
      }
      else if(*textpointer==']')
      {  textpointer++;fehler(39,0L);
         return(0L);
      }
      else
         return(atomin());
}

extern char *newcon();  /*aus Modul8*/

char *edit()
{  static char puffer[255];
   char *merke,*z;
   if(textpointer) textpointer=leerweg(textpointer);
   if((textpointer==0L)||(*textpointer==0))
   {  do
        merke=newcon();
      while(*merke==0);
      if(merke!=textpuffer) /*Eingabe kommt nicht aus dem Editor*/
      { z=puffer;           /*Kopie der Eingabe anlegen, damit auch*/
        while(*merke!=0)    /*read auf newcon zugreifen kann.      */
          *z++=*merke++;
        *z=0;
        return(puffer);
      }
      return(textpuffer);
   }
   else
      return(textpointer);
}