Module Analysis;

{$include"mathieeedoubtrans.lib" }
{$include "ana.h" }

VAR f:              ARRAY['f'..'h',0..99] OF p; EXPORT;
    x,y,hi,lo,step: atyp;
    v:              ARRAY['a'..'d',0..99] OF atyp; EXPORT;
    c1:             char;
    c:              char; EXPORT;
    i:              integer;
    fx:             p;
    everr:          boolean; EXPORT;
    Ein:            Buffer; IMPORT;

PROCEDURE InitAnalysis; EXPORT;
  BEGIN
    OpenLib(mathieeedoubtransbase,'mathieeedoubtrans.library',0);
  END;

Function Pri(b:p):integer;
  Begin
    Case b^.t Of
      operator: Case b^.name Of
                '+','-': Pri:=1;
                '*','/': Pri:=2;
                '^':     Pri:=3
                End;
      funktion: Pri:=4;
      variable,literal: Pri:=5
    End
  End;

Procedure WriteFunkName(n:char);
  Begin
    Case n Of
      '-': writeP('-');
      '+': writeP('abs');
      'c': writeP('cos');
      'e': writeP('exp');
      'g': writeP('lg');
      'l': writeP('ln');
      'o': writeP('cot');
      'q': writeP('sqr');
      'r': writeP('sqrt');
      's': writeP('sin');
      't': writeP('tan');
      'v': writeP('sgn');
      'C': writeP('arccos');
      'O': writeP('arccot');
      'S': writeP('arcsin');
      'T': writeP('arctan');
    End
  End;

Procedure InFix; { globale Funktion: (b:p; pr:integer); EXPORT }
  Var ap:integer;
  Begin
    If b<>Nil Then
    Case b^.t Of
      variable: Begin
                  writeP(b^.name); If b^.name='p' Then writeP('i')
                End;
      operator: Begin
                  ap:=pri(b);
                  If ap<pr Then writeP('(');
                  InFix(b^.op1,ap);
                  writeP(b^.name); InFix(b^.op2,ap+1);
                  If ap<pr Then writeP(')')
                End;
      literal: Begin writePR(b^.value,0); WriteP(' ') End;
      Funktion: Begin
                  WriteFunkName(b^.name);
                  If (pri(b^.op1)>=4) And (b^.name<>'-') Then writeP(' ');
                  InFix(b^.op1,4)
                End
    End
  End;

FUNCTION sgn; { globale Funktion: (x:atyp):integer; EXPORT }
  BEGIN
    sgn:=ord(x>0)-ord(x<0)
  END;

Function eval; { globale Funktion: (b:p; x:atyp):atyp; EXPORT }
  Var f,e1,e2:atyp;

  PROCEDURE Fehler;
    BEGIN
      everr:=true
    END;

  Begin
    case b^.t Of
      Variable:Case b^.name Of
                 'x': eval:=x;
                 'e': eval:=e;
                 'p': eval:=pi
               End;
      literal: eval:=b^.value;
      operator: BEGIN e1:=eval(b^.op1,x); e2:=eval(b^.op2,x);
                  Case b^.name Of
                  '+': eval:=e1+e2;
                  '-': eval:=e1-e2;
                  '*': eval:=e1*e2;
                  '/': IF e2=0 THEN Fehler ELSE
                       eval:=e1/e2;
                  '^': IF e2=0 THEN eval:=1
                       ELSE IF e2=1 THEN eval:=e1
                       ELSE IF e2=-1 THEN
                         IF e1=0 THEN Fehler ELSE eval:=1/e1
                       ELSE
                       IF e1>0 THEN eval:=IEEEDpexp(e2*IEEEDpLog(e1))
                       ELSE
                       IF e1=0 THEN eval:=0
                       ELSE
                       IF Abs(Frac(e2))<1e-5 THEN
                         BEGIN
                           e1:=IEEEDpexp(e2*IEEEDpLog(Abs(e1)));
                           IF Odd(Round(e2)) THEN Eval:=-e1
                                             ELSE Eval:=e1
                         END
                       ELSE Fehler;
                  END
                End;
      funktion: Begin f:=eval(b^.op1,x);
                  Case b^.name Of
                    '-': eval:=-f;
                    '+': eval:=abs(f);
                    'c': eval:=IEEEDpcos(f);
                    'e': eval:=IEEEDpexp(f);
                    'g': eval:=IEEEDpLog(f)/IEEEDpLog(10);
                    'l': IF f<=0 THEN Fehler ELSE
                         eval:=IEEEDpLog(f);
                    'o': BEGIN e1:=IEEEDpsin(f);
                           IF e1=0 THEN Fehler
                           ELSE eval:=IEEEDpcos(f)/e1
                         END;
                    'q': eval:=f*f;
                    'r': IF f<0 THEN Fehler ELSE
                         eval:=IEEEDpsqrt(f);
                    's': eval:=IEEEDpsin(f);
                    't': BEGIN e1:=IEEEDpcos(f);
                           IF e1=0 THEN Fehler
                           ELSE
                             eval:=IEEEDpsin(f)/e1
                         END;
                    'v': eval:=round(ord(f>0)-ord(f<0));
                    'T': eval:=IEEEDpatan(f);
                    'O': IF f=0 THEN Fehler ELSE
                         eval:=IEEEDpatan(1/f)
                  End
                End
    End
  End;


Procedure Forget; { globale Funktion: (Var z:p); EXPORT }
  Begin
    If z<>Nil Then
      Begin
        Forget(z^.op1);
        Forget(z^.op2);
        dispose(z);
        z:=Nil
      End
  End;


Function konstant; { globale Funktion: (b:p):boolean; EXPORT }
  Begin
    If b=Nil Then konstant:=true
    Else
      Case b^.t Of
        variable: konstant:=b^.name<>'x';
        operator: konstant:=konstant(b^.op1) And konstant(b^.op2);
        literal:  konstant:=true;
        funktion: konstant:=konstant(b^.op1)
      End
  End;

Procedure Optimize(Var b:p);
  Var h:p;
  Begin
    If b<>Nil Then
      Begin
        Optimize(b^.op1); Optimize(b^.op2);
        If konstant(b) Then
          Begin
            New(h);
            With h^ Do
              Begin
                t:=literal;
                name:=' ';
                op1:=Nil;
                op2:=Nil;
                value:=eval(b,0)
              End;
            Forget(b);
            b:=h
          End
      End
  End;

FUNCTION copy(c:p):p;
  VAR h:p;
  BEGIN
    IF c=Nil THEN copy:=Nil
    ELSE
      BEGIN
        New(h);
        h^:=c^;
        h^.op1:=copy(c^.op1);
        h^.op2:=copy(c^.op2);
        copy:=h
      END
  END;

PROCEDURE Subst(a:p; VAR b:p);
  { In Funktion b wird fuer x jeweils eine Kopie von a eingesetzt }
  BEGIN
    IF b<>NIL THEN
      IF (b^.t=variable) AND (b^.name='x') THEN
        BEGIN dispose(b); b:=copy(a) END
      ELSE
        BEGIN
          Subst(a,b^.op1); Subst(a,b^.op2)
        END
  END;

FUNCTION diff(b:p):p;
  VAR h,h1,h2: p;
        b1,b2: boolean;
        e1,e2: atyp;

  FUNCTION Neulit(r:atyp):p;
    VAR hl:p;
    BEGIN
      New(hl);
      hl^.t:=literal;
      hl^.value:=r;
      hl^.name:=' ';
      hl^.op1:=Nil;
      hl^.op2:=Nil;
      Neulit:=hl
    END;

  FUNCTION Neuop(n:char; o1,o2:p):p;
    VAR hl:p;
    BEGIN
      New(hl);
      hl^.t:=operator;
      hl^.name:=n;
      hl^.op1:=o1;
      hl^.op2:=o2;
      hl^.value:=0;
      Neuop:=hl
    END;

  FUNCTION Neufun(nam:char; o:p):p;
    VAR hl:p;
    BEGIN
      New(hl);
      hl^.t:=funktion;
      hl^.name:=nam;
      hl^.op1:=o;
      hl^.op2:=Nil;
      hl^.value:=0;
      Neufun:=hl
    END;

  FUNCTION Null(h:p):boolean;
    BEGIN
      IF konstant(h) THEN
        Null:=eval(h,1)=0
      ELSE Null:=false;
    END;

  BEGIN
    CASE b^.t OF
      literal: h:=Neulit(0);
      variable: IF b^.name='x' THEN h:=Neulit(1) ELSE h:=Neulit(0);
      operator: BEGIN
                  h1:=diff(b^.op1); b1:=konstant(h1);
                  h2:=diff(b^.op2); b2:=konstant(h2);
                  IF b1 THEN e1:=eval(h1,0) ELSE e1:=-1;
                  IF b2 THEN e2:=eval(h2,0) ELSE e2:=-1;
                  CASE b^.name OF
                    '+','-': IF e2=0 THEN
                               IF e1=0 THEN
                                 BEGIN h:=neulit(0);
                                   Forget(h1); Forget(h2)
                                 END
                               ELSE
                                 BEGIN h:=h1; Forget(h2) END
                             ELSE
                             IF e1=0 THEN
                               BEGIN
                                 IF b^.name='+' THEN h:=h2
                                 ELSE h:=Neufun('-',h2);
                                 Forget(h1)
                               END
                             ELSE
                               h:=Neuop(b^.name,h1,h2);
                    '*': IF e1=0 THEN
                           IF e2=0 THEN
                             BEGIN
                               h:=Neulit(0); Forget(h1); Forget(h2)
                             END
                           ELSE
                           IF e2=1 THEN
                             BEGIN h:=copy(b^.op1); Forget(h1); Forget(h2) END
                           ELSE
                             BEGIN
                               h:=Neuop('*',copy(b^.op1),h2); Forget(h1)
                             END
                         ELSE
                         IF e2=0 THEN
                           BEGIN
                             h:=Neuop('*',copy(b^.op2),h1); Forget(h2)
                           END
                         ELSE
                         IF e1=1 THEN
                           BEGIN
                             h:=Neuop('+',copy(b^.op2),Neuop('*',copy(b^.op1),h2));
                             Forget(h1)
                           END
                         ELSE
                         IF e2=1 THEN
                           BEGIN
                             h:=Neuop('+',Neuop('+',h1,copy(b^.op2)),copy(b^.op1));
                             Forget(h2)
                           END
                         ELSE
                           h:=Neuop('+',Neuop('*',h1,copy(b^.op2)),Neuop('*',copy(b^.op1),h2));
                    '/': BEGIN
                           IF e2=0 THEN      { Nenner konstant }
                             BEGIN
                               h:=Neuop('/',h1,copy(b^.op2));
                               Forget(h2)
                             END
                           ELSE
                           IF e1=0 THEN      { Zähler konstant }
                             BEGIN
                               IF e2=1 THEN   { und Nenner 1-linear }
                                 BEGIN
                                   h:=Neuop('*',Neulit(-eval(b^.op1,0)),
                                                Neuop('^',copy(b^.op2),
                                                          Neulit(-2)));
                                   Forget(h1); Forget(h2)
                                 END
                               ELSE
                                 BEGIN
                                   h:=Neuop('*',
                                        Neuop('*',Neulit(-eval(b^.op1,0)),
                                                  h2),
                                        Neuop('^',copy(b^.op2),
                                                  Neulit(-2)));
                                   Forget(h1)
                                 END
                             END
                           ELSE
                             BEGIN          { Quotientenregel }
                               h:=Neuop('/',Neuop('-',
                               Neuop('*',h1,copy(b^.op2)),Neuop('*',copy(b^.op1),h2)),
                               Neuop('^',copy(b^.op2),Neulit(2)))
                             END
                         END;
                    '^': IF e2=0 THEN
                           BEGIN
                             e2:=eval(b^.op2,0);
                             IF e2=0 THEN          { f(x)^0 }
                               BEGIN h:=Neulit(0);
                                 Forget(h1); Forget(h2) END
                             ELSE
                             IF e2=1 THEN
                               BEGIN h:=h1; Forget(h2) END
                             ELSE
                             BEGIN     { f(x)^n }
                               IF e2=2 THEN h:=copy(b^.op1)   { f(x)^2 }
                               ELSE h:=Neuop('^',copy(b^.op1),Neulit(e2-1));
                               IF e1=1 THEN
                                 h:=Neuop('*',Neulit(e2),h)
                               ELSE h:=Neuop('*',Neuop('*',Neulit(e2),h1),h);
                               Forget(h2)
                             END
                           END
                         ELSE
                         IF e1=0 THEN
                           BEGIN e1:=eval(b^.op1,0);
                             IF e2=1 THEN    { a^x }
                               IF e1=e THEN     { e^x }
                                 BEGIN
                                   h:=Neufun('e',copy(b^.op2));
                                   Forget(h1); Forget(h2)
                                 END
                               ELSE               { a<>e }
                                 BEGIN
                                   h:=NeuOp('*',Neufun('l',copy(b^.op1)),
                                                NeuOp('^',copy(b^.op1),
                                                          copy(b^.op2)));
                                   Forget(h1); Forget(h2)
                                 END
                             ELSE           { a^f(x) }
                               IF e1=e THEN  { e^f(x) }
                                 IF e2=1 THEN    { e^x }
                                   BEGIN
                                     h:=Neufun('e',copy(b^.op2));
                                     Forget(h1);Forget(h2)
                                   END
                                 ELSE
                                   BEGIN
                                     h:=Neuop('*',h2,Neufun('e',copy(b^.op2)));
                                     Forget(h1)
                                   END
                               ELSE           { a<>e}
                               IF e2=1 THEN    { a^x }
                                 BEGIN
                                   h:=Neuop('*',Neufun('l',copy(b^.op1))
                                               ,copy(b));
                                   Forget(h1); Forget(h2)
                                 END
                               ELSE
                                 BEGIN
                                   h:=Neuop('*',Neuop('*',
                                                      Neufun('l',copy(b^.op1)),h2)
                                               ,copy(b));
                                   Forget(h1)
                                 END
                           END
                         ELSE           { g(x)^h(x) }
                           BEGIN
                             Forget(h1); Forget(h2);
                             h1:=Neufun('e',Neuop('*',copy(b^.op2),
                                                      Neufun('l',copy(b^.op1))));
                             h:=diff(h1);
                             Forget(h1)
                           END
                  END
                END;
      funktion: BEGIN h1:=copy(b^.op1); h2:=diff(h1);
                  CASE b^.name OF
                    '-': BEGIN h:=Neulit(-1); Forget(h1) END;
                    '+': h:=Neufun('v',h1);
                    'c': h:=NeuOp('*',Neulit(-1),Neufun('s',h1));
                    'e': h:=Neufun('e',h1);
                    'g': h:=Neuop('*',Neulit(ln(10)),Neuop('^',h1,Neulit(-1)));
                    'l': h:=Neuop('^',h1,Neulit(-1));
                    'o': h:=Neuop('*',Neulit(-1)
                                     ,NeuOp('^',Neufun('s',h1),Neulit(-2)));
                    'q': h:=Neuop('*',Neulit(2),h1);
                    'r': h:=Neuop('*',Neulit(0.5),
                                      NeuOp('^',h1,Neulit(-0.5)));
                    's': h:=Neufun('c',h1);
                    't': h:=NeuOp('^',Neufun('c',h1),Neulit(-2));
                    'v': BEGIN h:=Neulit(0); Forget(h1) END;
                    'C': h:=Neuop('*',Neulit(-1),
                                      Neuop('^',Neuop('-',Neulit(1),
                                                          Neufun('q',h1)),
                                                Neulit(-0.5)));
                    'O': h:=Neuop('*',Neulit(-1),
                                      Neuop('^',Neuop('+',Neulit(1),
                                                          Neufun('q',h1)),
                                                Neulit(-1)));
                    'S': h:=Neuop('^',Neuop('-',Neulit(1),
                                                Neufun('q',h1)),
                                      Neulit(-0.5));
                    'T': h:=Neuop('^',Neuop('+',Neulit(1),
                                                Neufun('q',h1)),
                                      Neulit(-1))
                  END;
                  IF konstant(h2) THEN e2:=eval(h2,0) ELSE e2:=-1;
                  IF e2=1 THEN
                    Forget(h2)
                  ELSE
                    h:=Neuop('*',h2,h)
                END
    End;
    diff:=h
  End;

FUNCTION GetNum; { globale Funktion: (VAR tx:Buffer; VAR z:char):integer; EXPORT }
  VAR i:integer;
  BEGIN
    i:=0;
    WHILE (z>='0') AND (z<='9') DO
      BEGIN
        i:=10*i + ord(z)-ord('0');
        z := tx.s[tx.p];
        tx.p := tx.p+1
      END;
    GetNum:=i
  END;

PROCEDURE Inp; { globale Funktion: (VAR tx:Buffer; VAR i:p); EXPORT }

  VAR c:      char;
      err:    boolean;
      pos:    1..100;
      einstr: string[100];

  PROCEDURE gts;
    BEGIN
      IF err THEN c:=chr(0)
      ELSE
        BEGIN
          c := tx.s[tx.p];
          tx.p := tx.p+1;
          IF (c>='A') AND (c<='Z') THEN
            c:=chr(ord(c)-ord('A')+ord('a'));
          einstr[pos]:=c;
          pos:=pos+1
        END
    END;

  PROCEDURE get;
    BEGIN REPEAT gts UNTIL c<>' ' END;

  FUNCTION Neu(tp:typ):p;
    VAR h:p;
    BEGIN
      New(h);
      WITH h^ DO
        BEGIN t:=tp; name:=' '; op1:=NIL; op2:=NIL; value:=0 END;
      Neu:=h
    END;

  PROCEDURE Fehler;
    BEGIN
      IF NOT err THEN
        BEGIN einstr[pos]:=chr(0);
          WriteC('Error: ');
          WriteC(einstr);
          WriteC(LF)
         END;
      c:=chr(0); err:=true
    END;

  PROCEDURE Summe(Var s:p);
    VAR t:p;

    PROCEDURE Term(Var h: p);
      VAR z, hlp:atyp; g:p; c1:char; num:integer;

      PROCEDURE Parameter;
        BEGIN
          iF c='(' THEN
            BEGIN
              get;
              Summe(h^.op1);
              IF c<>')' THEN Fehler;
              get
            END
          ELSE
            term(h^.op1)
        END;

      PROCEDURE Fun(n:char);
        BEGIN
          h:=Neu(funktion);
          h^.name:=n;
          get;
          Parameter
        END;

      BEGIN   { Term }
        h:=NIL;
        IF c='x' THEN
          BEGIN h:=Neu(variable); h^.name:='x'; get END
        ELSE
        IF ((c>='0') AND (c<='9')) or (c='.') THEN
          BEGIN
            z:=0;
            WHILE (c>='0') And (c<='9') DO
              BEGIN
                z:=round(10*z+ord(c)-ord('0'));
                gts
              End;
            h:=Neu(literal);
            IF c='.' THEN
              BEGIN gts; hlp:=1;
                WHILE (c>='0') AND (c<='9') DO
                  BEGIN
                    hlp:=hlp/10;
                    z:=z+hlp*round(ord(c)-ord('0'));
                    gts
                  END
              END;
            IF c='e' THEN
              BEGIN gts;
                IF c='-' THEN
                  BEGIN gts; num:=getnum(tx,c); z:=z*pwr10(-num) END
                ELSE
                  BEGIN
                    IF c='+' THEN gts;
                    num:=getnum(tx,c); z:=z*dbpwr10(num)
                  END
              END;
            IF c=' ' THEN get;
            h^.value:=z
          END
        ELSE
        If c='(' Then
          Begin get;
            Summe(h);
            If c<>')' Then Fehler;
            get
          End
        ELSE
        IF c='|' THEN
          BEGIN
            get;
            Summe(g);
            IF c<>'|' THEN Fehler;
            get;
            h := Neu( Funktion );
            h^.name := '+';
            h^.op1 := g
          END
        Else
        If c='-' Then Fun('-')
        Else
        If c='a' Then
          Begin gts;
            If c='r' Then
              Begin gts;
                If c='c' Then
                  Begin gts;
                    If c='c' Then
                      Begin gts;
                        If c='o' Then
                          Begin gts;
                            If c='s' Then Fun('C')        { arccos }
                            Else
                            If c='t' Then Fun('O')        { arccot }
                            Else Fehler
                          End
                        Else Fehler
                      End
                    Else
                    If c='s' Then
                      Begin gts;
                        If c='i' Then
                          Begin gts;
                            If c='n' Then Fun('S') Else Fehler { arcsin }
                          End
                        Else Fehler
                      End
                    Else
                    If c='t' Then
                      Begin gts;
                        If c='a' Then
                          Begin gts;
                            If c='n' Then Fun('T') Else Fehler { arctan }
                          End
                        Else Fehler
                      End
                    Else Fehler
                  End
                Else Fehler
              End
            Else
            If c='b' Then
              Begin gts;
                If c='s' Then Fun('+') Else Fehler         { abs }
              End
            Else                                           { a }
              BEGIN
                num:=getnum(tx,c);
                h:=Neu(literal);
                h^.value:=v['a',num]
              END
          End
        Else
        IF c='b' THEN                                      { b }
          BEGIN
            get; num:=getnum(tx,c);
            h:=neu(literal);
            h^.value:=v['b',num]
          END
        ELSE
        If c='c' Then
          Begin gts;
            If c='o' Then
              Begin gts;
                If c='s' Then Fun('c')              { cos }
                ELSE
                  IF c='t' THEN Fun('o')            { cot }
                  Else Fehler
              End
            ELSE
              BEGIN                                  { c }
                num:=getnum(tx,c);
                h:=Neu(literal);
                h^.value:=v['c',num]
              END
          END
        ELSE
        IF c='d' THEN
          BEGIN
            get;
            num:=getnum(tx,c);
            h:=Neu(literal);
            h^.value:=v['d',num]
          END
        ELSE
        If c='e' Then
          Begin gts;
            If c='x' Then
              Begin gts;
                If c='p' Then Fun('e') Else Fehler   { exp }
              End
            Else
              Begin                                  {  e  }
                h:=Neu(variable);
                h^.name:='e';
                If c=' ' Then get
              End
          End
        ELSE
        IF (c>='f') AND (c<='h') THEN       { f, g, h }
          BEGIN
            c1:=c; gts; num:=Getnum(tx,c);
            IF f[c1,num]=NIL THEN Fehler
            ELSE
              BEGIN
                h:=copy(f[c1,num]);
                WHILE c='''' DO
                  BEGIN
                    get;
                    g:=h;
                    h:=diff(g);
                    Forget(g)
                  END;
                IF c=' ' THEN get;
                IF c='(' THEN
                  BEGIN get;
                    Summe(g);
                    Subst(g,h);
                    IF c<>')' THEN Fehler;
                    get;
                    Forget(g)
                  END
              END
          END
        ELSE
        IF c='l' THEN
          BEGIN gts;
            IF c='n' THEN Fun('l')
            ELSE
            IF c='g' THEN Fun('g')
            ELSE Fehler
          END
        ELSE
        IF c='p' THEN
          BEGIN gts;
            IF c='i' THEN
              BEGIN                                   { pi }
                h:=Neu(variable);
                h^.name:='p';
                get
              End
            Else Fehler
          End
        Else
        If c='s' Then
          Begin gts;
            If c='i' Then
              Begin gts;
                If c='n' Then Fun('s') Else Fehler   { sin }
              End
            Else
            If c='g' Then
              Begin gts;
                If c='n' Then Fun('v') Else Fehler    { sgn }
              End
            Else
            If c='q' Then
              Begin gts;
                If c='r' Then
                  Begin get;
                    If c='t' Then Fun('r')         { sqrt }
                     Else
                      Begin
                        h:=Neu(funktion);          { sqr }
                        h^.name:='q';
                        Parameter
                      End
                  End
                Else Fehler
              End
            Else Fehler
          End
        ELSE
        IF c='t' THEN
          BEGIN gts;
            IF c='a' THEN
              BEGIN gts;
                IF c='n' THEN Fun('t')
                ELSE Fehler
              END
            ELSE Fehler
          END

        ELSE Fehler;
        IF c='^' THEN
          BEGIN
            get;
            g:=neu(operator);
            g^.name:='^';
            g^.op1:=h;
            h:=g;
            Term(h^.op2)
          End;
        If (c>='a') and (c<='z') Or (c='(') Then
          Begin
            g:=Neu(operator);
            g^.op1:=h;
            h:=g;
            h^.name:='*';
            Term(h^.op2)
          End
      End;

    Procedure Produkt(Var h:p);
      Var hp:p;
      Begin
        Term(h);
        While (c='*') Or (c='/') Do
          Begin
            hp:=Neu(operator);
            hp^.name:=c;
            hp^.op1:=h;
            get;
            Term(hp^.op2);
            h:=hp
          End
      End;

    BEGIN { Summe }
      Produkt(s);
      WHILE (c='+') OR (c='-') DO
        BEGIN
          t:=Neu(operator);
          t^.name:=c;
          t^.op1:=s;
          get;
          Produkt(t^.op2);
          s:=t
        END
    END;

  BEGIN { Inp }
    i:=Nil; err:=false; pos:=1;
    get;
    Summe(i);
    IF err THEN Forget(i)
  END;

PROCEDURE ReadKonst; { globale Funktion: (VAR r:atyp; Var err:boolean); EXPORT }
  VAR f:p;
      t:Buffer;
  BEGIN
    ReadEin(t);
    Inp(t,f);
    IF not konstant(f) Then
      Begin
        writeC('not konstant.'\n);
        forget(f)
      End;
    err:=f=Nil;
    If not err then
      BEGIN
        everr:=false;
        r:=eval(f,0);
        err:=everr
      END
  END;

PROCEDURE GetC; { globale Funktion }
  BEGIN REPEAT c:=Ein.s[Ein.p]; Ein.p := Ein.p+1 UNTIL c<>' ' END;